home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / readtable.lisp < prev    next >
Encoding:
Text File  |  1991-11-22  |  3.2 KB  |  99 lines
  1. ; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SCHEME-HACKS; -*-
  2. ; File readtable.lisp / Copyright (c) 1991 Jonathan Rees / See file COPYING
  3.  
  4. ;;;; Scheme readtable
  5.  
  6. (lisp:in-package "SCHEME-HACKS" :use '("LISP"))
  7.  
  8. (export '*sharp-sharp*)
  9.  
  10. (defvar *non-scheme-readtable* (copy-readtable nil))
  11.  
  12. (defparameter scheme-readtable (copy-readtable nil))
  13.  
  14. #+Symbolics
  15. (pushnew scheme-readtable si:*valid-readtables*)
  16.  
  17. (defun quote-read-macro (stream c)
  18.   (if (eq *package* scheme-package)
  19.       (list (intern "QUOTE" scheme-package) (read stream t nil t))
  20.       (funcall (get-macro-character #\' *non-scheme-readtable*) stream c)))
  21.  
  22. (defun quasiquote-read-macro (stream c)
  23.   (if (eq *package* scheme-package)
  24.       (list (intern "QUASIQUOTE" scheme-package) 
  25.         (read stream t nil t))
  26.       (funcall (get-macro-character #\` *non-scheme-readtable*) stream c)))
  27.  
  28. (defun unquote-read-macro (stream c)
  29.   (if (eq *package* scheme-package)
  30.       (let* ((following-char (peek-char nil stream t nil t))
  31.          (marker (cond ((char= following-char #\@)
  32.                 (read-char stream)
  33.                 (intern "UNQUOTE-SPLICING" scheme-package))
  34.                (t
  35.                 (intern "UNQUOTE" scheme-package)))))
  36.     (list marker (read stream t nil t)))
  37.       (funcall (get-macro-character #\, *non-scheme-readtable*) stream c)))
  38.  
  39. (defun sharp-F-read-macro (stream subchar arg)
  40.   (declare (ignore stream subchar arg)
  41.        (special schi:false))
  42.   schi:false)
  43.  
  44. (defun sharp-T-read-macro (stream subchar arg)
  45.   (declare (ignore stream subchar arg)
  46.        (special schi:true))
  47.   schi:true)
  48.  
  49. (defun sharp-D-read-macro (stream subchar arg)
  50.   (declare (ignore subchar arg))
  51.   (let ((*read-base* 10.))
  52.     (read stream t nil t)))
  53.  
  54. (defun sharp-E-read-macro (stream subchar arg)
  55.   (declare (ignore subchar arg))
  56.   (let ((n (read stream t nil t)))
  57.     (if (rationalp n)
  58.     n
  59.     (rationalize n))))
  60.  
  61. (defun sharp-I-read-macro (stream subchar arg)
  62.   (declare (ignore subchar arg))
  63.   (let ((n (read stream t nil t)))
  64.     (if (floatp n)
  65.     n
  66.     (float n))))
  67.  
  68. (defvar *sharp-sharp* '(values-list /))
  69.  
  70. (defun sharp-sharp-read-macro (stream subchar arg)
  71.   (cond (arg (funcall (get-dispatch-macro-character #\# #\#
  72.                             *non-scheme-readtable*)
  73.               stream subchar arg))
  74.     (t *sharp-sharp*)))
  75.  
  76. (defun illegal-read-macro (stream c)
  77.   (unread-char c stream)        ;won't work in general
  78.   (when (eq *package* scheme-package)
  79.     (cerror "Try to treat it as Common Lisp would."
  80.         "The character `~A' was encountered."
  81.         c))
  82.   (let ((*readtable* *non-scheme-readtable*))
  83.     (read stream nil 0 t)))
  84.  
  85. (let ((*readtable* scheme-readtable))
  86.   (set-macro-character #\' #'quote-read-macro)
  87.   (set-macro-character #\` #'quasiquote-read-macro)
  88.   (set-macro-character #\, #'unquote-read-macro)
  89.   (set-dispatch-macro-character #\# #\F #'sharp-F-read-macro)
  90.   (set-dispatch-macro-character #\# #\T #'sharp-T-read-macro)
  91.   (set-dispatch-macro-character #\# #\D #'sharp-D-read-macro)
  92.   (set-dispatch-macro-character #\# #\E #'sharp-E-read-macro)
  93.   (set-dispatch-macro-character #\# #\I #'sharp-I-read-macro)
  94.   (set-dispatch-macro-character #\# #\# #'sharp-sharp-read-macro)
  95.   ;; Don't mess with backslash, or strings will bite you.
  96.   (mapc #'(lambda (c)
  97.         (set-macro-character c #'illegal-read-macro t))
  98.     '(#\[ #\] #\{ #\} #\|)))
  99.