(defun sharp-left-paren (stream ignore length)
(declare (ignore ignore) (special *backquote-count*))
(let* ((list (read-list stream nil))
- (listlength (length 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)
- ((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)))
- (coerce list 'vector)))
- (t (cons *bq-vector-flag* list)))))
+ ((and length (> list-length length))
+ (simple-reader-error
+ stream
+ "Vector longer than the specified length: #~S~S."
+ length list))
+ ((zerop *backquote-count*)
+ (if length
+ (fill (replace (make-array length) list)
+ (car (last list))
+ :start list-length)
+ (coerce list 'vector)))
+ (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))
(multiple-value-bind (bstring escape-appearedp) (read-extended-token stream)
(declare (simple-string bstring))
(cond (*read-suppress* nil)
- (escape-appearedp
- (%reader-error stream "An escape character appeared after #*"))
- ((and numarg (zerop (length bstring)) (not (zerop numarg)))
- (%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))
- (len2 (or numarg len1))
- (bvec (make-array len2 :element-type 'bit
- :initial-element 0)))
- (declare (fixnum len1 last1 len2))
- (do ((i 0 (1+ i))
- (char ()))
- ((= i len2))
- (declare (fixnum i))
- (setq char (elt bstring (if (< i len1) i last1)))
- (setf (elt bvec i)
- (cond ((char= char #\0) 0)
- ((char= char #\1) 1)
- (t
- (%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)))))
+ (escape-appearedp
+ (simple-reader-error stream
+ "An escape character appeared after #*."))
+ ((and numarg (zerop (length bstring)) (not (zerop numarg)))
+ (simple-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))
+ (len2 (or numarg len1))
+ (bvec (make-array len2 :element-type 'bit
+ :initial-element 0)))
+ (declare (fixnum len1 last1 len2))
+ (do ((i 0 (1+ i))
+ (char ()))
+ ((= i len2))
+ (declare (fixnum i))
+ (setq char (elt bstring (if (< i len1) i last1)))
+ (setf (elt bvec i)
+ (cond ((char= char #\0) 0)
+ ((char= char #\1) 1)
+ (t
+ (simple-reader-error
+ stream
+ "illegal element given for bit-vector: ~S"
+ char)))))
+ bvec))
+ (t
+ (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))
- (seq contents))
+ (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))
- (let ((len (length seq)))
- (dims len)
- (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))))))))
+ (make-array (dims) :initial-contents contents))
+ (unless (typep seq 'sequence)
+ (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))
+ ;; 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))))))))
\f
;;;; reading structure instances: the #S readmacro
(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."
- (car body)))
- (apply (fdefinition def-con) (rest body))))))
+ (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))))
+ (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))
+ (simple-reader-error
+ stream
+ "the arglist for the ~S constructor in #S ~
+ has an odd length: ~S."
+ (car body) (rest body)))
+ (when (or (atom (cdr tail))
+ (and (atom (cddr tail))
+ (not (null (cddr tail)))))
+ (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))
+ (simple-reader-error
+ stream
+ "a slot name in #S is not a string ~
+ designator: ~S."
+ slot-name))
+ (when (not (keywordp slot-name))
+ (warn 'structure-initarg-not-keyword
+ :format-control
+ "in #S ~S, the use of non-keywords ~
+ as slot specifiers is deprecated: ~S."
+ :format-arguments
+ (list (car body) slot-name))))
+ collect (intern (string (car tail)) *keyword-package*)
+ collect (cadr tail)))))))
\f
;;;; reading numbers: the #B, #C, #O, #R, and #X readmacros
(defun sharp-B (stream sub-char numarg)
(ignore-numarg sub-char numarg)
- (sharp-r stream sub-char 2))
+ (sharp-R stream sub-char 2))
(defun sharp-C (stream sub-char numarg)
(ignore-numarg sub-char numarg)
;; The next thing had better be a list of two numbers.
(let ((cnum (read stream t nil t)))
- (when *read-suppress* (return-from sharp-c nil))
+ (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))))
+ (complex (car cnum) (cadr cnum))
+ (simple-reader-error stream
+ "illegal complex number format: #C~S"
+ cnum))))
(defun sharp-O (stream sub-char numarg)
(ignore-numarg sub-char numarg)
- (sharp-r stream sub-char 8))
+ (sharp-R stream sub-char 8))
(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))))
+ (read-extended-token stream)
+ nil)
+ ((not radix)
+ (simple-reader-error stream "radix missing in #R"))
+ ((not (<= 2 radix 36))
+ (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)
+ (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)
(ignore-numarg sub-char numarg)
- (sharp-r stream sub-char 16))
+ (sharp-R stream sub-char 16))
\f
;;;; reading circular data: the #= and ## readmacros
;; 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)))
- (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)))))
- ((arrayp tree)
- (with-array-data ((data tree) (start) (end))
- (declare (fixnum start end))
- (do ((i start (1+ i)))
- ((>= i end))
- (let* ((old (aref data i))
- (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)))))
- tree)
- (t tree)))
+ (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 ((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))
+ (do ((i start (1+ i)))
+ ((>= i end))
+ (let* ((old (aref data i))
+ (new (circle-subst old-new-alist old)))
+ (unless (eq old new)
+ (setf (aref data i) new))))))
+ ((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)))
;;; 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
(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))
+ (assoc label *sharp-equal-alist*))
+ (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)))
+ (*sharp-sharp-alist* (acons label tag *sharp-sharp-alist*))
+ (obj (read stream t nil t)))
(when (eq obj tag)
- (%reader-error stream
- "must tag something more than just #~D#"
- label))
+ (simple-reader-error stream
+ "must 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))))
(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*)))
- (unless pair
- (%reader-error stream "object is not labelled #~S#" label))
- (cdr pair)))))
+ (third entry)
+ (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
+ (simple-reader-error stream
+ "reference to undefined label #~D#"
+ label))
+ (cdr pair)))))
\f
;;;; conditional compilation: the #+ and #- readmacros
(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)))
+ (unless (if (let ((*package* *keyword-package*)
+ (*read-suppress* nil))
+ (featurep (read stream t nil t)))
+ (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)
(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"
- charstring)))))
+ ((= (the fixnum (length charstring)) 1)
+ (char charstring 0))
+ ((name-char charstring))
+ (t
+ (simple-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 (ansi-stream-p stream)
- (prepare-for-fast-read-char stream
- (do ((level 1)
- (prev (fast-read-char) char)
- (char (fast-read-char) (fast-read-char)))
- (())
- (cond ((and (char= prev #\|) (char= char #\#))
- (setq level (1- level))
- (when (zerop level)
- (done-with-fast-read-char)
- (return (values)))
- (setq char (fast-read-char)))
- ((and (char= prev #\#) (char= char #\|))
- (setq char (fast-read-char))
- (setq level (1+ level))))))
- ;; fundamental-stream
- (do ((level 1)
- (prev (read-char stream t) char)
- (char (read-char stream t) (read-char stream t)))
- (())
- (cond ((and (char= prev #\|) (char= char #\#))
- (setq level (1- level))
- (when (zerop level)
- (return (values)))
- (setq char (read-char stream t)))
- ((and (char= prev #\#) (char= char #\|))
- (setq char (read-char stream t))
- (setq level (1+ level))))))))
+ (handler-bind
+ ((character-decoding-error
+ #'(lambda (decoding-error)
+ (declare (ignorable decoding-error))
+ (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)
+ (prepare-for-fast-read-char stream
+ (do ((level 1)
+ (prev (fast-read-char) char)
+ (char (fast-read-char) (fast-read-char)))
+ (())
+ (cond ((and (char= prev #\|) (char= char #\#))
+ (setq level (1- level))
+ (when (zerop level)
+ (done-with-fast-read-char)
+ (return (values)))
+ (setq char (fast-read-char)))
+ ((and (char= prev #\#) (char= char #\|))
+ (setq char (fast-read-char))
+ (setq level (1+ level))))))
+ ;; fundamental-stream
+ (do ((level 1)
+ (prev (read-char stream t) char)
+ (char (read-char stream t) (read-char stream t)))
+ (())
+ (cond ((and (char= prev #\|) (char= char #\#))
+ (setq level (1- level))
+ (when (zerop level)
+ (return (values)))
+ (setq char (read-char stream t)))
+ ((and (char= prev #\#) (char= char #\|))
+ (setq char (read-char stream t))
+ (setq level (1+ level)))))))))
\f
;;;; a grab bag of other sharp readmacros: #', #:, and #.
(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 ()
(set-dispatch-macro-character #\# #\C #'sharp-C)
(set-dispatch-macro-character #\# #\c #'sharp-C)
(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 #\# #\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 #\# #\Space #'sharp-illegal)