diff --git a/code/sharpm.lisp b/code/sharpm.lisp index 9278af236bbedb9cf753e0b4deebe8d0a4488341..9cde7658e4f6f1896957d0ad1a665bab76438f1b 100644 --- a/code/sharpm.lisp +++ b/code/sharpm.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sharpm.lisp,v 1.8 1991/11/30 03:16:49 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sharpm.lisp,v 1.9 1992/02/12 01:44:58 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -17,14 +17,19 @@ ;;; This uses the special std-lisp-readtable, which is internal to READER.LISP ;;; (in-package "LISP") +(export '(*read-eval*)) ;;; declared in READ.LISP (proclaim '(special *read-suppress* std-lisp-readtable *bq-vector-flag*)) -(defun sharp-backslash (stream backslash ignore) - (declare (ignore ignore)) +(defun ignore-numarg (sub-char numarg) + (when numarg + (warn "Numeric argument ignored in #~D~A." numarg sub-char))) + +(defun sharp-backslash (stream backslash numarg) + (ignore-numarg backslash numarg) (unread-char backslash stream) (let* ((*readtable* std-lisp-readtable) (charstring (read-extended-token stream))) @@ -34,32 +39,33 @@ (char charstring 0)) ((name-char charstring)) (t - (error "Meaningless character name: ~S" charstring))))) - + (%reader-error stream "Unrecognized character name: ~S" + charstring))))) -(defun sharp-quote (stream ignore1 ignore2) - (declare (ignore ignore1 ignore2)) +(defun sharp-quote (stream sub-char numarg) + (ignore-numarg sub-char numarg) ;; 4th arg tells read that this is a recrusive call. `(function ,(read stream t nil t))) (defun sharp-left-paren (stream ignore length) - (declare (ignore ignore)) - (declare (special *backquote-count*)) + (declare (ignore ignore) (special *backquote-count*)) (let* ((list (read-list stream nil)) (listlength (length list))) (declare (list list) (fixnum listlength)) - (cond (*read-suppress*) + (cond (*read-suppress* nil) ((zerop *backquote-count*) (if length (cond ((> listlength (the fixnum length)) - (error + (%reader-error + stream "Vector longer than specified length: #~S~S" length list)) (t (fill (the simple-vector - (replace (the simple-vector (make-array length)) + (replace (the simple-vector + (make-array length)) list)) (car (last list)) :start listlength))) @@ -71,11 +77,13 @@ (multiple-value-bind (bstring escape-appearedp) (read-extended-token stream) (declare (simple-string bstring)) - (cond (*read-suppress*) + (cond (*read-suppress* nil) (escape-appearedp - (error "Escape character appeared after #*")) + (%reader-error stream "Escape character appeared after #*")) ((and numarg (zerop (length bstring)) (not (zerop numarg))) - (error "You have to give a little bit for non-zero #* bit-vectors.")) + (%reader-error + stream + "You have to give a little bit for non-zero #* bit-vectors.")) ((or (null numarg) (>= (the fixnum numarg) (length bstring))) (let* ((len1 (length bstring)) (last1 (1- len1)) @@ -92,197 +100,163 @@ (cond ((char= char #\0) 0) ((char= char #\1) 1) (t - (error "Illegal element given for ~ - bitvector #~A*~A" - numarg bstring))))) + (%reader-error + stream + "Illegal element given for bit-vector: ~S" + char))))) bvec)) (t - (error "Bit vector is longer than specified length #~A*~A" - numarg bstring))))) + (%reader-error stream + "Bit vector is longer than specified length #~A*~A" + numarg bstring))))) -(defun sharp-colon (stream ignore1 ignore2) - (declare (ignore ignore1 ignore2)) - (when *read-suppress* - (read stream t nil t) - (return-from sharp-colon nil)) - (let ((token (read-extended-token stream))) - (declare (simple-string token)) - (cond (*read-suppress*) - ((find #\: token) - (error "Symbol following #: contains a #\: ~S" token)) - ((eql (length token) 0) - (let ((ch (read-char stream nil nil t))) - (if ch - (error "Illegal terminating character after a colon, ~S." ch) - (error "Illegal terminating character after a colon.")))) - (T (make-symbol token))))) +(defun sharp-colon (stream sub-char numarg) + (ignore-numarg sub-char numarg) + (multiple-value-bind (token escapep colon) + (read-extended-token stream) + (declare (simple-string token) (ignore escapep)) + (cond + (*read-suppress* nil) + (colon + (%reader-error stream "Symbol following #: contains a package marker: ~S" + token)) + ((eql (length token) 0) + (let ((ch (read-char stream nil nil t))) + (when ch + (%reader-error stream + "Illegal terminating character after a colon: ~S." + ch)) + (reader-eof-error stream "after a colon"))) + (t + (make-symbol token))))) ;;;; #. handling. -(export '(*read-eval*)) - (defvar *read-eval* t "If false, then the #. read macro is disabled.") -(defun sharp-dot (stream ignore1 ignore2) - (declare (ignore ignore1 ignore2)) - (if *read-eval* - (let ((token (read stream t nil t))) - (unless *read-suppress* - (eval token))) - (error "Attemt to read #. while *READ-EVAL* is bound to NIL."))) +(defun sharp-dot (stream sub-char numarg) + (ignore-numarg sub-char numarg) + (let ((token (read stream t nil t))) + (unless *read-suppress* + (unless *read-eval* + (%reader-error stream + "Attempt to read #. while *READ-EVAL* is bound to NIL.")) + (eval token)))) + + +;;;; Numeric radix stuff: + +(defun sharp-R (stream sub-char radix) + (cond (*read-suppress* + (read-extended-token stream) + nil) + ((not radix) + (%reader-error stream "Radix missing in #R.")) + ((not (<= 2 radix 36)) + (%reader-error stream "Illegal radix for #R: ~D." radix)) + (t + (let ((res (let ((*read-base* radix)) + (read stream t nil t)))) + (unless (typep res 'rational) + (%reader-error stream "#~A (base ~D) value is not a rational: ~S." + sub-char radix res)) + res)))) + +(defun sharp-B (stream sub-char numarg) + (ignore-numarg sub-char numarg) + (sharp-r stream sub-char 2)) + +(defun sharp-O (stream sub-char numarg) + (ignore-numarg sub-char numarg) + (sharp-r stream sub-char 8)) + +(defun sharp-X (stream sub-char numarg) + (ignore-numarg sub-char numarg) + (sharp-r stream sub-char 16)) -(defun sharp-R (stream ignore radix) - (declare (ignore ignore)) - (multiple-value-bind (token escape-appearedp) - (read-extended-token stream) - (declare (simple-string token)) - (when *read-suppress* (return-from sharp-R nil)) - (let ((numval 0) (denval 0) (resttok 0) (toklength (length token)) - (sign 1)) - (declare (fixnum toklength)) - (if escape-appearedp - (error "Escape character appears in number.")) - ;;look for leading sign - (let ((firstchar (elt token 0))) - (cond ((char= firstchar #\-) - (setq sign -1) - (setq resttok 1)) - ((char= firstchar #\+) - (setq resttok 1)))) - ;;read numerator - (do ((position resttok (1+ position)) - (dig ())) - ((or (>= position toklength) - (not (setq dig (digit-char-p (elt token position) radix)))) - (setq resttok position)) - (setq numval (+ (* numval radix) dig))) - ;;see if we're at the end. - (cond ((>= resttok toklength) - ;;just return numerator -- that's all there is. - (* numval sign)) - ((char= (elt token resttok) #\/) - ;;it's a ratio. - (do ((position (1+ resttok) (1+ position)) - (dig ()) - (retval ())) - ((cond ((>= position toklength) - (setq retval (/ (* numval sign) denval))) - ((not (setq dig (digit-char-p (elt token position) - radix))) - ;;there's bogus stuff at the end - (error - "Illegal digits ~S for radix ~S" token radix) - (setq retval (/ (* numval sign) denval))) - ;;continue looping - (t nil)) - retval) - (setq denval (+ (* denval radix) dig)))) - ;;it's bogus - (t (error "Illegal digits ~S for radix ~S" token radix)))))) - -(defun sharp-B (stream ignore1 ignore2) - (declare (ignore ignore1 ignore2)) - (sharp-r stream nil 2)) - -(defun sharp-O (stream ignore1 ignore2) - (declare (ignore ignore1 ignore2)) - (sharp-r stream nil 8)) - -(defun sharp-X (stream ignore1 ignore2) - (declare (ignore ignore1 ignore2)) - (sharp-r stream nil 16)) (defun sharp-A (stream ignore dimensions) (declare (ignore ignore)) (when *read-suppress* (read stream t nil t) (return-from sharp-A nil)) - (unless dimensions (error "No dimensions argument to #A.")) - (unless (and (integerp dimensions) (>= dimensions 0)) - (error "Dimensions argument to #A not a non-negative integer: ~S" - dimensions)) + (unless dimensions (%reader-error stream "No dimensions argument to #A.")) (if (> dimensions 0) (let ((dlist (make-list dimensions)) - (init-list (if (char= (read-char stream t) #\() - (read-list stream nil) - (error "Array values must be a list.")))) + (init-list + (if (char= (read-char stream t) #\() + (read-list stream nil) + (%reader-error stream "Array values must be a list.")))) (do ((dl dlist (cdr dl)) (il init-list (car il))) ;; I think the nreverse is causing the problem. ((null dl)) - (if (listp il) - (rplaca dl (length il)) - (error - "Initial contents for #A is inconsistent with ~ - dimensions: #~SA~S" dimensions init-list))) + (if (listp il) + (rplaca dl (length il)) + (%reader-error + stream + "Initial contents for #A is inconsistent with ~ + dimensions: #~SA~S" dimensions init-list))) (make-array dlist :initial-contents init-list)) (make-array nil :initial-element (read stream t nil t)))) -(defun sharp-S (stream ignore1 ignore2) - (declare (ignore ignore1 ignore2)) +(defun sharp-S (stream sub-char numarg) + (ignore-numarg sub-char numarg) ;;this needs to know about defstruct implementation (when *read-suppress* - (read stream t nil t) - (return-from sharp-S nil)) + (read stream t nil t) + (return-from sharp-S nil)) (let ((body (if (char= (read-char stream t) #\( ) (read-list stream nil) - (error "Non-list following #S")))) + (%reader-error stream "Non-list following #S")))) (cond ((listp body) (unless (symbolp (car body)) - (error "Structure type is not a symbol: ~S" (car body))) + (%reader-error stream + "Structure type is not a symbol: ~S" (car body))) (let ((defstruct (info type defined-structure-info (car body)))) (unless defstruct - (error "~S is not a defined structure type." (car body))) + (%reader-error stream + "~S is not a defined structure type." + (car body))) (unless (c::dd-constructors defstruct) - (error "The ~S structure does not have a default constructor." - (car body))) + (%reader-error + stream "The ~S structure does not have a default constructor." + (car body))) (do ((arg (cdr body) (cddr arg)) (res ())) ((endp arg) (apply (car (c::dd-constructors defstruct)) res)) (push (cadr arg) res) (push (intern (string (car arg)) *keyword-package*) res)))) - (t (error "Non-list following #S: ~S" body))))) - -(defmacro int-subst-array (new old array rank var-list) - (if (> rank (array-rank array)) - (let ((new-list (nreverse var-list))) - `(if (eq ,old (aref ,array ,@new-list)) - (setf (aref ,array ,@new-list) ,new))) - (let ((newvar (gensym))) - `(dotimes (,newvar (array-dimension ,array ,rank)) - (int-subst-array ,new ,old ,array (1+ ,rank) - (push ,newvar ,var-list)))))) - -(defmacro subst-array (new old array) - `(int-subst-array ,new ,old ,array 0 nil)) - -(defvar sharp-cons-table () - "Holds the cons cells seen already by circle-subst") - -;; This function is the same as nsubst, except that it checks for circular -;; lists. the first arg is an alist of the things to be replaced assoc'd with -;; the things to replace them. + (t (%reader-error stream "Non-list following #S: ~S" body))))) + + + +;;;; #=/## + +;;; Holds objects already seen by CIRCLE-SUBST. +;;; +(defvar *sharp-equal-circle-table*) + +;; This function is kind of like to NSUBLIS, but checks for circularities and +;; substitutes in arrays and structures as well as lists. The first arg is an +;; alist of the things to be replaced assoc'd with the things to replace them. +;; (defun circle-subst (old-new-alist tree) - (cond ((and (atom tree) - (not (and (arrayp tree) - (eq (array-element-type tree) t)))) - (let ((pair (assq tree old-new-alist))) - (if pair (cdr pair) tree))) - ((null (gethash tree sharp-cons-table)) - (setf (gethash tree sharp-cons-table) t) - (cond ((simple-vector-p tree) - (do ((i 0 (1+ i)) - (len (length tree))) - ((>= i len)) - (declare (fixnum i len)) - (setf (svref tree i) - (circle-subst old-new-alist (svref tree i)))) - tree) + (cond ((not (typep tree '(or cons (array t) structure))) + (let ((entry (find tree old-new-alist :key #'second))) + (if entry (third entry) tree))) + ((null (gethash tree *sharp-equal-circle-table*)) + (setf (gethash tree *sharp-equal-circle-table*) t) + (cond ((structurep tree) + (dotimes (i (structure-length tree) tree) + (structure-set tree i + (circle-subst old-new-alist + (structure-ref tree i))))) ((arrayp tree) (with-array-data ((data tree) (start) (end)) (declare (fixnum start end)) @@ -291,87 +265,103 @@ (setf (aref data i) (circle-subst old-new-alist (aref data i))))) tree) - (T (let ((a (circle-subst old-new-alist (car tree))) - (d (circle-subst old-new-alist (cdr tree)))) - (if (eq a (car tree)) - tree - (rplaca tree a)) - (if (eq d (cdr tree)) - tree - (rplacd tree d))) + (t + (let ((a (circle-subst old-new-alist (car tree))) + (d (circle-subst old-new-alist (cdr tree)))) + (if (eq a (car tree)) + tree + (rplaca tree a)) + (if (eq d (cdr tree)) + tree + (rplacd tree d))) tree))) (t tree))) -;; Sharp-equal works as follows. When a label is assigned -;; (ie when #= is called) a symbol (ref) is gensym'd and -;; a cons cell whose car is the label, and cdr is the symbol -;; is put on the sharp-sharp alist. When sharp-sharp encounters -;; a reference to a label it returns the symbol assoc'd with the label. -;; When an object has been read then a cons cell whose car is the symbol -;; and cdr is the object is pushed onto the sharp-sharp-alist. Then -;; for each cons cell on the sharp-sharp-alist, the current object is searched -;; and where a symbol eq to the car of the current cons cell is found, -;; the object is substituted in. -(defun sharp-equal (stream ignore label &aux (ref (gensym))) +;;; Sharp-equal works as follows. When a label is assigned (ie when #= is +;;; called) we GENSYM a symbol is which is used as an unforgeable tag. +;;; *SHARP-SHARP-ALIST* maps the integer tag to this gensym. +;;; +;;; When SHARP-SHARP encounters a reference to a label, it returns the symbol +;;; assoc'd with the label. Resolution of the reference is deferred until the +;;; read done by #= finishes. Any already resolved tags (in +;;; *SHARP-EQUAL-ALIST*) are simply returned. +;;; +;;; After reading of the #= form is completed, we add an entry to +;;; *SHARP-EQUAL-ALIST* that maps the gensym tag to the resolved object. Then +;;; for each entry in the *SHARP-SHARP-ALIST, the current object is searched +;;; and any uses of the gensysm token are replaced with the actual value. +;;; +(defvar *sharp-sharp-alist* ()) +;;; +(defun sharp-equal (stream ignore label) (declare (ignore ignore)) - (declare (special sharp-equal-alist sharp-sharp-alist)) (when *read-suppress* (return-from sharp-equal (values))) - (unless (integerp label) - (error "non-integer label #~S=" label)) - (push (cons label ref) sharp-sharp-alist) - (let ((obj (read stream t nil t))) - (push (cons ref obj) sharp-equal-alist) - (clrhash sharp-cons-table) - (circle-subst sharp-equal-alist obj))) - -(defun sharp-sharp (ignore1 ignore2 label) - (declare (ignore ignore1 ignore2)) - (declare (special sharp-equal-alist sharp-sharp-alist)) + (unless label + (%reader-error stream "Missing label for #=." label)) + (when (or (assoc label *sharp-sharp-alist*) + (assoc label *sharp-equal-alist*)) + (%reader-error stream "Multiply defined label: #~D=" label)) + (let* ((tag (gensym)) + (*sharp-sharp-alist* (acons label tag *sharp-sharp-alist*)) + (obj (read stream t nil t))) + (when (eq obj tag) + (%reader-error stream "Have to tag something more than just #~D#." + label)) + (push (list label tag obj) *sharp-equal-alist*) + (let ((*sharp-equal-circle-table* (make-hash-table :test #'eq :size 20))) + (circle-subst *sharp-equal-alist* obj)))) +;;; +(defun sharp-sharp (stream ignore label) + (declare (ignore ignore)) (when *read-suppress* (return-from sharp-sharp nil)) - (if (integerp label) - (let ((pair (assoc label sharp-sharp-alist))) - (if pair - (let ((ret-obj (cdr (assoc (cdr pair) sharp-equal-alist)))) - (if ret-obj ret-obj - (cdr pair))) - (error "Object is not labelled #~S#" label))) - (error "Non-integer label #~S#" label))) - -(defun sharp-plus (stream ignore1 ignore2) - (declare (ignore ignore1 ignore2)) - (cond (*read-suppress* - (read stream t nil t) - (values)) - ((featurep (let ((*package* *keyword-package*)) - (read stream t nil t))) - (read stream t nil t)) - (t (let ((*read-suppress* t)) - (read stream t nil t) - (values))))) - -(defun sharp-minus (stream ignore1 ignore2) - (declare (ignore ignore1 ignore2)) - (cond (*read-suppress* - (read stream t nil t) - (values)) - ((not (featurep (let ((*package* *keyword-package*)) - (read stream t nil t)))) - (read stream t nil t)) - (t (let ((*read-suppress* t)) - (read stream t nil t) - (values))))) - -(defun sharp-C (stream ignore1 ignore2) - (declare (ignore ignore1 ignore2)) + (unless label + (%reader-error stream "Missing label for ##." label)) + + (let ((entry (assoc label *sharp-equal-alist*))) + (if entry + (third entry) + (let ((pair (assoc label *sharp-sharp-alist*))) + (unless pair + (%reader-error stream "Object is not labelled #~S#" label)) + (cdr pair))))) + + +;;;; #+/- + +(flet ((guts (stream not-p) + (unless (if (handler-case + (let ((*package* *keyword-package*) + (*read-suppress* nil)) + (featurep (read stream t nil t))) + (reader-package-error + (condition) + (declare (ignore condition)) + nil)) + (not not-p) + not-p) + (let ((*read-suppress* t)) + (read stream t nil t))) + (values))) + + (defun sharp-plus (stream sub-char numarg) + (ignore-numarg sub-char numarg) + (guts stream nil)) + + (defun sharp-minus (stream sub-char numarg) + (ignore-numarg sub-char numarg) + (guts stream t))) + +(defun sharp-C (stream sub-char numarg) + (ignore-numarg sub-char numarg) ;;next thing better be a list of two numbers. (let ((cnum (read stream t nil t))) (when *read-suppress* (return-from sharp-c nil)) - (if (= (length cnum) 2) + (if (and (listp cnum) (= (length cnum) 2)) (complex (car cnum) (cadr cnum)) - (error "Illegal complex number format" cnum)))) + (%reader-error stream "Illegal complex number format: #C~S" cnum)))) -(defun sharp-vertical-bar (stream ignore1 ignore2) - (declare (ignore ignore1 ignore2)) +(defun sharp-vertical-bar (stream sub-char numarg) + (ignore-numarg sub-char numarg) (prepare-for-fast-read-char stream (do ((level 1) (prev (fast-read-char) char) @@ -387,19 +377,18 @@ (setq char (fast-read-char)) (setq level (1+ level))))))) -(defun sharp-illegal (ignore1 sub-char ignore2) - (declare (ignore ignore1 ignore2)) - (error "Illegal sharp character ~S" sub-char)) +(defun sharp-illegal (stream sub-char ignore) + (declare (ignore ignore)) + (%reader-error stream "Illegal sharp character ~S" sub-char)) -(defun sharp-P (stream sub-char argument) - (declare (ignore sub-char argument)) +(defun sharp-P (stream sub-char numarg) + (ignore-numarg sub-char numarg) (parse-namestring (read stream t nil t))) (defun sharp-init () (declare (special std-lisp-readtable)) - (setq sharp-cons-table (make-hash-table :size 50)) (let ((*readtable* std-lisp-readtable)) - (make-dispatch-macro-character #\#) + (make-dispatch-macro-character #\# t) (set-dispatch-macro-character #\# #\\ #'sharp-backslash) (set-dispatch-macro-character #\# #\' #'sharp-quote) (set-dispatch-macro-character #\# #\( #'sharp-left-paren)