X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fsharpm.lisp;h=39c8e66ce1be9b66a5500bca95a19bbe0f60214a;hb=HEAD;hp=0d4508ca22cbc19b7d0bea1c05bea2c5d593c53c;hpb=fced4ded7356f1ce4afacd0dc6b2990506e28c47;p=sbcl.git diff --git a/src/code/sharpm.lisp b/src/code/sharpm.lisp index 0d4508c..39c8e66 100644 --- a/src/code/sharpm.lisp +++ b/src/code/sharpm.lisp @@ -21,31 +21,32 @@ (defun sharp-left-paren (stream ignore length) (declare (ignore ignore) (special *backquote-count*)) (let* ((list (read-list stream nil)) - (listlength (handler-case (length list) - (type-error - (error) - (declare (ignore error)) - (%reader-error stream "improper list in #(): ~S" - list))))) + (list-length (handler-case (length list) + (type-error () + (simple-reader-error stream + "Improper list in #(): ~S." + list))))) (declare (list list) - (fixnum listlength)) + (fixnum list-length)) (cond (*read-suppress* nil) + ((and length (> list-length length)) + (simple-reader-error + stream + "Vector longer than the specified length: #~S~S." + length list)) ((zerop *backquote-count*) (if length - (cond ((> listlength (the fixnum length)) - (%reader-error - stream - "vector longer than specified length: #~S~S" - length list)) - (t - (fill (the simple-vector - (replace (the simple-vector - (make-array length)) - list)) - (car (last list)) - :start listlength))) + (fill (replace (make-array length) list) + (car (last list)) + :start list-length) (coerce list 'vector))) - (t (cons *bq-vector-flag* list))))) + (t + (cons *bq-vector-flag* + (if length + (append list + (make-list (- length list-length) + :initial-element (car (last list)))) + list)))))) (defun sharp-star (stream ignore numarg) (declare (ignore ignore)) @@ -53,9 +54,10 @@ (declare (simple-string bstring)) (cond (*read-suppress* nil) (escape-appearedp - (%reader-error stream "An escape character appeared after #*")) + (simple-reader-error stream + "An escape character appeared after #*.")) ((and numarg (zerop (length bstring)) (not (zerop numarg))) - (%reader-error + (simple-reader-error stream "You have to give a little bit for non-zero #* bit-vectors.")) ((or (null numarg) (>= (the fixnum numarg) (length bstring))) @@ -74,31 +76,39 @@ (cond ((char= char #\0) 0) ((char= char #\1) 1) (t - (%reader-error + (simple-reader-error stream "illegal element given for bit-vector: ~S" char))))) bvec)) (t - (%reader-error stream - "Bit vector is longer than specified length #~A*~A" - numarg bstring))))) + (simple-reader-error + stream + "Bit vector is longer than specified length #~A*~A" + numarg + bstring))))) (defun sharp-A (stream ignore dimensions) (declare (ignore ignore)) (when *read-suppress* (read stream t nil t) (return-from sharp-A nil)) - (unless dimensions (%reader-error stream "no dimensions argument to #A")) + (unless dimensions + (simple-reader-error stream "No dimensions argument to #A.")) (collect ((dims)) - (let* ((contents (read stream t nil t)) + (let* ((*bq-error* + (if (zerop *backquote-count*) + *bq-error* + "Comma inside a backquoted array (not a list or general vector.)")) + (*backquote-count* 0) + (contents (read stream t nil t)) (seq contents)) (dotimes (axis dimensions (make-array (dims) :initial-contents contents)) (unless (typep seq 'sequence) - (%reader-error stream - "#~WA axis ~W is not a sequence:~% ~S" - dimensions axis seq)) + (simple-reader-error stream + "#~WA axis ~W is not a sequence:~% ~S" + dimensions axis seq)) (let ((len (length seq))) (dims len) (unless (or (= axis (1- dimensions)) @@ -117,34 +127,42 @@ (when *read-suppress* (read stream t nil t) (return-from sharp-S nil)) - (let ((body (if (char= (read-char stream t) #\( ) - (read-list stream nil) - (%reader-error stream "non-list following #S")))) + (let* ((*bq-error* + (if (zerop *backquote-count*) + *bq-error* + "Comma inside backquoted structure (not a list or general vector.)")) + (*backquote-count* 0) + (body (if (char= (read-char stream t) #\( ) + (let ((*backquote-count* 0)) + (read-list stream nil)) + (simple-reader-error stream "non-list following #S")))) (unless (listp body) - (%reader-error stream "non-list following #S: ~S" body)) + (simple-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))) + (simple-reader-error stream + "Structure type is not a symbol: ~S" + (car body))) (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 - (classoid-layout classoid))))) - (unless def-con - (%reader-error - stream "The ~S structure does not have a default constructor." + (simple-reader-error stream + "~S is not a defined structure type." + (car body))) + (let ((default-constructor (dd-default-constructor + (layout-info (classoid-layout classoid))))) + (unless default-constructor + (simple-reader-error + stream + "The ~S structure does not have a default constructor." (car body))) (when (and (atom (rest body)) (not (null (rest body)))) - (%reader-error - stream "improper list for #S: ~S." body)) - (apply (fdefinition def-con) + (simple-reader-error stream "improper list for #S: ~S." body)) + (apply (fdefinition default-constructor) (loop for tail on (rest body) by #'cddr with slot-name = (and (consp tail) (car tail)) do (progn (when (null (cdr tail)) - (%reader-error + (simple-reader-error stream "the arglist for the ~S constructor in #S ~ has an odd length: ~S." @@ -152,13 +170,13 @@ (when (or (atom (cdr tail)) (and (atom (cddr tail)) (not (null (cddr tail))))) - (%reader-error + (simple-reader-error stream "the arglist for the ~S constructor in #S ~ is improper: ~S." (car body) (rest body))) (when (not (typep (car tail) 'string-designator)) - (%reader-error + (simple-reader-error stream "a slot name in #S is not a string ~ designator: ~S." @@ -186,7 +204,9 @@ (when *read-suppress* (return-from sharp-C nil)) (if (and (listp cnum) (= (length cnum) 2)) (complex (car cnum) (cadr cnum)) - (%reader-error stream "illegal complex number format: #C~S" cnum)))) + (simple-reader-error stream + "illegal complex number format: #C~S" + cnum)))) (defun sharp-O (stream sub-char numarg) (ignore-numarg sub-char numarg) @@ -197,18 +217,18 @@ (read-extended-token stream) nil) ((not radix) - (%reader-error stream "radix missing in #R")) + (simple-reader-error stream "radix missing in #R")) ((not (<= 2 radix 36)) - (%reader-error stream "illegal radix for #R: ~D." radix)) + (simple-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)) + (simple-reader-error stream + "#~A (base ~D.) value is not a rational: ~S." + sub-char + radix + res)) res)))) (defun sharp-X (stream sub-char numarg) @@ -225,20 +245,18 @@ ;; 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 standard-object))) + (cond ((not (typep tree '(or cons (array t) instance funcallable-instance))) (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 '(or structure-object standard-object)) - (do ((i 1 (1+ i)) - (end (%instance-length tree))) - ((= i end)) - (let* ((old (%instance-ref tree i)) - (new (circle-subst old-new-alist old))) - (unless (eq old new) - (setf (%instance-ref tree i) new))))) + (cond ((consp tree) + (let ((a (circle-subst old-new-alist (car tree))) + (d (circle-subst old-new-alist (cdr tree)))) + (unless (eq a (car tree)) + (rplaca tree a)) + (unless (eq d (cdr tree)) + (rplacd tree d)))) ((arrayp tree) (with-array-data ((data tree) (start) (end)) (declare (fixnum start end)) @@ -248,13 +266,31 @@ (new (circle-subst old-new-alist old))) (unless (eq old new) (setf (aref data i) new)))))) - (t - (let ((a (circle-subst old-new-alist (car tree))) - (d (circle-subst old-new-alist (cdr tree)))) - (unless (eq a (car tree)) - (rplaca tree a)) - (unless (eq d (cdr tree)) - (rplacd tree d))))) + ((typep tree 'instance) + (let* ((n-untagged (layout-n-untagged-slots (%instance-layout tree))) + (n-tagged (- (%instance-length tree) n-untagged))) + ;; N-TAGGED includes the layout as well (at index 0), which + ;; we don't grovel. + (do ((i 1 (1+ i))) + ((= i n-tagged)) + (let* ((old (%instance-ref tree i)) + (new (circle-subst old-new-alist old))) + (unless (eq old new) + (setf (%instance-ref tree i) new)))) + (do ((i 0 (1+ i))) + ((= i n-untagged)) + (let* ((old (%raw-instance-ref/word tree i)) + (new (circle-subst old-new-alist old))) + (unless (= old new) + (setf (%raw-instance-ref/word tree i) new)))))) + ((typep tree 'funcallable-instance) + (do ((i 1 (1+ i)) + (end (- (1+ (get-closure-length tree)) sb!vm:funcallable-instance-info-offset))) + ((= i end)) + (let* ((old (%funcallable-instance-info tree i)) + (new (circle-subst old-new-alist old))) + (unless (eq old new) + (setf (%funcallable-instance-info tree i) new)))))) tree) (t tree))) @@ -279,15 +315,15 @@ (declare (ignore ignore)) (when *read-suppress* (return-from sharp-equal (values))) (unless label - (%reader-error stream "missing label for #=" label)) + (simple-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)) + (simple-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 + (simple-reader-error stream "must tag something more than just #~D#" label)) (push (list label tag obj) *sharp-equal-alist*) @@ -298,14 +334,21 @@ (declare (ignore ignore)) (when *read-suppress* (return-from sharp-sharp nil)) (unless label - (%reader-error stream "missing label for ##" label)) + (simple-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*))) + (let (;; Has this label been defined previously? (Don't read + ;; ANSI "2.4.8.15 Sharpsign Equal-Sign" and worry that + ;; it requires you to implement forward references, + ;; because forward references are disallowed in + ;; "2.4.8.16 Sharpsign Sharpsign".) + (pair (assoc label *sharp-sharp-alist*))) (unless pair - (%reader-error stream "object is not labelled #~S#" label)) + (simple-reader-error stream + "reference to undefined label #~D#" + label)) (cdr pair))))) ;;;; conditional compilation: the #+ and #- readmacros @@ -345,8 +388,9 @@ (char charstring 0)) ((name-char charstring)) (t - (%reader-error stream "unrecognized character name: ~S" - charstring))))) + (simple-reader-error stream + "unrecognized character name: ~S" + charstring))))) (defun sharp-vertical-bar (stream sub-char numarg) (ignore-numarg sub-char numarg) @@ -354,7 +398,9 @@ ((character-decoding-error #'(lambda (decoding-error) (declare (ignorable decoding-error)) - (style-warn "Character decoding error in a #|-comment at position ~A reading source file ~A, resyncing." (file-position stream) stream) + (style-warn + 'sb!kernel::character-decoding-error-in-dispatch-macro-char-comment + :sub-char sub-char :position (file-position stream) :stream stream) (invoke-restart 'attempt-resync)))) (let ((stream (in-synonym-of stream))) (if (ansi-stream-p stream) @@ -400,9 +446,8 @@ (cond (*read-suppress* nil) (colon - (%reader-error stream - "The symbol following #: contains a package marker: ~S" - token)) + (simple-reader-error + stream "The symbol following #: contains a package marker: ~S" token)) (t (make-symbol token))))) @@ -415,12 +460,12 @@ (let ((token (read stream t nil t))) (unless *read-suppress* (unless *read-eval* - (%reader-error stream "can't read #. while *READ-EVAL* is NIL")) + (simple-reader-error stream "can't read #. while *READ-EVAL* is NIL")) (eval token)))) (defun sharp-illegal (stream sub-char ignore) (declare (ignore ignore)) - (%reader-error stream "illegal sharp macro character: ~S" sub-char)) + (simple-reader-error stream "illegal sharp macro character: ~S" sub-char)) ;;; for cold init: Install SHARPM stuff in the current *READTABLE*. (defun !sharpm-cold-init ()