;;;; files for more information.
(in-package "SB!IMPL")
-
-(file-comment
- "$Header$")
\f
(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)))
\f
;;;; reading arrays and vectors: the #(, #*, and #A readmacros
(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))))))))
\f
;;;; reading structure instances: the #S readmacro
(%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."
(car body)))
- (apply (fdefinition def-con) (rest body))))))
+ (when (and (atom (rest body))
+ (not (null (rest body))))
+ (%reader-error
+ stream "improper list for #S: ~S." body))
+ (apply (fdefinition def-con)
+ (loop for tail on (rest body) by #'cddr
+ with slot-name = (and (consp tail) (car tail))
+ do (progn
+ (when (null (cdr tail))
+ (%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)))))
+ (%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
+ 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))))
(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*
((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))
(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)))
+ (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))
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)
(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)
- (prepare-for-fast-read-char stream
+ (handler-bind
+ ((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)
+ (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 (fast-read-char) char)
- (char (fast-read-char) (fast-read-char)))
+ (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)
- (done-with-fast-read-char)
(return (values)))
- (setq char (fast-read-char)))
+ (setq char (read-char stream t)))
((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))))))))
+ (setq char (read-char stream t))
+ (setq level (1+ level)))))))))
\f
;;;; a grab bag of other sharp readmacros: #', #:, and #.
(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 #\# #\ #'sharp-illegal)
+ (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)
- ;; 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)))
projects / sbcl.git / blobdiff