X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fsharpm.lisp;h=6615bb92b7e572284d495715a36f9bdeb6b70ec1;hb=2b596efa9a6b08a22bbdcdf88198c5d2af1d0335;hp=1a9112a2060b3de626bd2c770d7df4673b1f3ec8;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/code/sharpm.lisp b/src/code/sharpm.lisp index 1a9112a..6615bb9 100644 --- a/src/code/sharpm.lisp +++ b/src/code/sharpm.lisp @@ -8,16 +8,13 @@ ;;;; files for more information. (in-package "SB!IMPL") - -(file-comment - "$Header$") (declaim (special *read-suppress* *standard-readtable* *bq-vector-flag*)) ;;; FIXME: Is it standard to ignore numeric args instead of raising errors? (defun ignore-numarg (sub-char numarg) (when numarg - (warn "A numeric argument was ignored in #~D~A." numarg sub-char))) + (warn "A numeric argument was ignored in #~W~A." numarg sub-char))) ;;;; reading arrays and vectors: the #(, #*, and #A readmacros @@ -95,16 +92,17 @@ (make-array (dims) :initial-contents contents)) (unless (typep seq 'sequence) (%reader-error stream - "#~DA axis ~D is not a sequence:~% ~S" + "#~WA axis ~W is not a sequence:~% ~S" dimensions axis seq)) (let ((len (length seq))) (dims len) - (unless (= axis (1- dimensions)) - (when (zerop len) - (%reader-error stream - "#~DA axis ~D is empty, but is not ~ - the last dimension." - dimensions axis)) + (unless (or (= axis (1- dimensions)) + ;; ANSI: "If some dimension of the array whose + ;; representation is being parsed is found to be + ;; 0, all dimensions to the right (i.e., the + ;; higher numbered dimensions) are also + ;; considered to be 0." + (= len 0)) (setq seq (elt seq 0)))))))) ;;;; reading structure instances: the #S readmacro @@ -121,13 +119,13 @@ (%reader-error stream "non-list following #S: ~S" body)) (unless (symbolp (car body)) (%reader-error stream "Structure type is not a symbol: ~S" (car body))) - (let ((class (sb!xc:find-class (car body) nil))) - (unless (typep class 'sb!xc:structure-class) + (let ((classoid (find-classoid (car body) nil))) + (unless (typep classoid 'structure-classoid) (%reader-error stream "~S is not a defined structure type." (car body))) (let ((def-con (dd-default-constructor (layout-info - (class-layout class))))) + (classoid-layout classoid))))) (unless def-con (%reader-error stream "The ~S structure does not have a default constructor." @@ -160,13 +158,13 @@ ((not radix) (%reader-error stream "radix missing in #R")) ((not (<= 2 radix 36)) - (%reader-error stream "illegal radix for #R: ~D" radix)) + (%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." + "#~A (base ~D.) value is not a rational: ~S." sub-char radix res)) @@ -186,12 +184,12 @@ ;; 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 ((not (typep tree '(or cons (array t) structure-object))) + (cond ((not (typep tree '(or cons (array t) structure-object standard-object))) (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 ((typep tree 'structure-object) + (cond ((typep tree '(or structure-object standard-object)) (do ((i 1 (1+ i)) (end (%instance-length tree))) ((= i end)) @@ -218,19 +216,21 @@ tree) (t tree))) -;;; 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. +;;; Sharp-equal works as follows. When a label is assigned (i.e. 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. +;;; 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. +;;; *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) @@ -301,23 +301,20 @@ (defun sharp-backslash (stream backslash numarg) (ignore-numarg backslash numarg) - (unread-char backslash stream) - (let* ((*readtable* *standard-readtable*) - (charstring (read-extended-token stream))) + (let ((charstring (read-extended-token-escaped stream))) (declare (simple-string charstring)) (cond (*read-suppress* nil) ((= (the fixnum (length charstring)) 1) (char charstring 0)) ((name-char charstring)) (t - (%reader-error stream - "unrecognized character name: ~S" + (%reader-error stream "unrecognized character name: ~S" charstring))))) (defun sharp-vertical-bar (stream sub-char numarg) (ignore-numarg sub-char numarg) (let ((stream (in-synonym-of stream))) - (if (lisp-stream-p stream) + (if (ansi-stream-p stream) (prepare-for-fast-read-char stream (do ((level 1) (prev (fast-read-char) char) @@ -412,9 +409,9 @@ (set-dispatch-macro-character #\# #\| #'sharp-vertical-bar) (set-dispatch-macro-character #\# #\p #'sharp-p) (set-dispatch-macro-character #\# #\P #'sharp-p) - (set-dispatch-macro-character #\# #\ #'sharp-illegal) (set-dispatch-macro-character #\# #\) #'sharp-illegal) (set-dispatch-macro-character #\# #\< #'sharp-illegal) - ;; FIXME: Should linefeed/newline go in this list too? - (dolist (cc '#.(list tab-char-code form-feed-char-code return-char-code)) + (set-dispatch-macro-character #\# #\Space #'sharp-illegal) + (dolist (cc '#.(list tab-char-code form-feed-char-code return-char-code + line-feed-char-code backspace-char-code)) (set-dispatch-macro-character #\# (code-char cc) #'sharp-illegal)))