(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))
(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)))
(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))
(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."
(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."
(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)
(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)
;; 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))
(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)))
(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*)
(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
;; "2.4.8.16 Sharpsign Sharpsign".)
(pair (assoc label *sharp-sharp-alist*)))
(unless pair
- (%reader-error stream "reference to undefined label #~D#" label))
+ (simple-reader-error stream
+ "reference to undefined label #~D#"
+ label))
(cdr pair)))))
\f
;;;; conditional compilation: the #+ and #- readmacros
(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)
((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)
(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)))))
(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))))
\f
(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 ()
projects / sbcl.git / blobdiff