1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from the CMU CL system, which was
5 ;;;; written at Carnegie Mellon University and released into the
6 ;;;; public domain. The software is in the public domain and is
7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
8 ;;;; files for more information.
10 (in-package "SB!IMPL")
12 (declaim (special *read-suppress
*))
14 ;;; FIXME: Is it standard to ignore numeric args instead of raising errors?
15 (defun ignore-numarg (sub-char numarg
)
17 (warn "A numeric argument was ignored in #~W~A." numarg sub-char
)))
19 ;;;; reading arrays and vectors: the #(, #*, and #A readmacros
21 (defun sharp-left-paren (stream ignore length
)
22 (declare (ignore ignore
))
23 (let* ((list (read-list stream nil
))
25 (handler-case (length list
)
27 (simple-reader-error stream
"Improper list in #(): ~S." list
)))))
30 (cond (*read-suppress
* nil
)
31 ((and length
(> list-length length
))
34 "Vector longer than the specified length: #~S~S."
37 ;; the syntax `#n(foo ,@bar) is not well-defined. [See lp#1096043.]
38 ;; We take it to mean that the vector as read should be padded to
39 ;; length 'n'. It could be argued that 'n' is the length after
40 ;; expansion, but that's not easy, not to mention unportable.
41 (fill (replace (make-array length
) list
)
42 (car (last list
)) :start list-length
))
44 (coerce list
'vector
)))))
46 (defun sharp-star (stream ignore numarg
)
47 (declare (ignore ignore
))
48 (declare (type (or null fixnum
) numarg
))
49 (binding* (((buffer escape-appearedp
) (read-extended-token stream
))
50 (input-len (token-buf-fill-ptr buffer
))
51 (bstring (token-buf-string buffer
)))
52 (cond (*read-suppress
* nil
)
54 (simple-reader-error stream
55 "An escape character appeared after #*."))
56 ((and numarg
(zerop input-len
) (not (zerop numarg
)))
59 "You have to give a little bit for non-zero #* bit-vectors."))
60 ((or (null numarg
) (>= numarg input-len
))
62 (make-array (or numarg input-len
)
65 (if (and (plusp input-len
)
66 (char= (char bstring
(1- input-len
)) #\
1))
69 ((= i input-len
) bvec
)
70 (declare (index i
) (optimize (sb!c
::insert-array-bounds-checks
0)))
71 (let ((char (char bstring i
)))
76 (t (simple-reader-error
77 stream
"illegal element given for bit-vector: ~S"
82 "Bit vector is longer than specified length #~A*~A"
84 (copy-token-buf-string buffer
))))))
86 (defun sharp-A (stream ignore dimensions
)
87 (declare (ignore ignore
))
90 (return-from sharp-A nil
))
92 (simple-reader-error stream
"No dimensions argument to #A."))
95 (if (zerop *backquote-depth
*)
97 "Comma inside a backquoted array (not a list or general vector.)"))
99 (contents (read stream t nil t
))
101 (dotimes (axis dimensions
102 (make-array (dims) :initial-contents contents
))
103 (unless (typep seq
'sequence
)
104 (simple-reader-error stream
105 "#~WA axis ~W is not a sequence:~% ~S"
106 dimensions axis seq
))
107 (let ((len (length seq
)))
109 (unless (or (= axis
(1- dimensions
))
110 ;; ANSI: "If some dimension of the array whose
111 ;; representation is being parsed is found to be
112 ;; 0, all dimensions to the right (i.e., the
113 ;; higher numbered dimensions) are also
114 ;; considered to be 0."
116 (setq seq
(elt seq
0))))))))
118 ;;;; reading structure instances: the #S readmacro
120 (defun sharp-S (stream sub-char numarg
)
121 (ignore-numarg sub-char numarg
)
122 (when *read-suppress
*
123 (read stream t nil t
)
124 (return-from sharp-S nil
))
126 (if (zerop *backquote-depth
*)
128 "Comma inside backquoted structure (not a list or general vector.)"))
129 (body (if (char= (read-char stream t
) #\
( )
130 (let ((*backquote-depth
* 0))
131 (read-list stream nil
))
132 (simple-reader-error stream
"non-list following #S"))))
134 (simple-reader-error stream
"non-list following #S: ~S" body
))
135 (unless (symbolp (car body
))
136 (simple-reader-error stream
137 "Structure type is not a symbol: ~S"
139 (let ((classoid (find-classoid (car body
) nil
)))
140 (unless (typep classoid
'structure-classoid
)
141 (simple-reader-error stream
142 "~S is not a defined structure type."
144 (let ((default-constructor (dd-default-constructor
145 (layout-info (classoid-layout classoid
)))))
146 (unless default-constructor
149 "The ~S structure does not have a default constructor."
151 (when (and (atom (rest body
))
152 (not (null (rest body
))))
153 (simple-reader-error stream
"improper list for #S: ~S." body
))
154 (apply (fdefinition default-constructor
)
155 (loop for tail on
(rest body
) by
#'cddr
156 with slot-name
= (and (consp tail
) (car tail
))
158 (when (null (cdr tail
))
161 "the arglist for the ~S constructor in #S ~
162 has an odd length: ~S."
163 (car body
) (rest body
)))
164 (when (or (atom (cdr tail
))
165 (and (atom (cddr tail
))
166 (not (null (cddr tail
)))))
169 "the arglist for the ~S constructor in #S ~
171 (car body
) (rest body
)))
172 (when (not (typep (car tail
) 'string-designator
))
175 "a slot name in #S is not a string ~
178 (when (not (keywordp slot-name
))
179 (warn 'structure-initarg-not-keyword
181 "in #S ~S, the use of non-keywords ~
182 as slot specifiers is deprecated: ~S."
184 (list (car body
) slot-name
))))
185 collect
(intern (string (car tail
)) *keyword-package
*)
186 collect
(cadr tail
)))))))
188 ;;;; reading numbers: the #B, #C, #O, #R, and #X readmacros
190 (defun sharp-B (stream sub-char numarg
)
191 (ignore-numarg sub-char numarg
)
192 (sharp-R stream sub-char
2))
194 (defun sharp-C (stream sub-char numarg
)
195 (ignore-numarg sub-char numarg
)
196 ;; The next thing had better be a list of two numbers.
197 (let ((cnum (read stream t nil t
)))
198 (when *read-suppress
* (return-from sharp-C nil
))
199 (if (and (listp cnum
) (= (length cnum
) 2))
200 (complex (car cnum
) (cadr cnum
))
201 (simple-reader-error stream
202 "illegal complex number format: #C~S"
205 (defun sharp-O (stream sub-char numarg
)
206 (ignore-numarg sub-char numarg
)
207 (sharp-R stream sub-char
8))
209 (defun sharp-R (stream sub-char radix
)
210 (cond (*read-suppress
*
211 (read-extended-token stream
)
214 (simple-reader-error stream
"radix missing in #R"))
215 ((not (<= 2 radix
36))
216 (simple-reader-error stream
"illegal radix for #R: ~D." radix
))
218 ;; FIXME: (read-from-string "#o#x1f") should not work!
219 ;; The token should be comprised strictly of digits in the radix,
220 ;; though the docs say this is undefined behavior, so it's ok,
221 ;; other than it being something we should complain about
222 ;; for portability reasons.
223 (let ((res (let ((*read-base
* radix
))
224 (read stream t nil t
))))
225 (unless (typep res
'rational
)
226 (simple-reader-error stream
227 "#~A (base ~D.) value is not a rational: ~S."
233 (defun sharp-X (stream sub-char numarg
)
234 (ignore-numarg sub-char numarg
)
235 (sharp-R stream sub-char
16))
237 ;;;; reading circular data: the #= and ## readmacros
239 ;;; objects already seen by CIRCLE-SUBST
240 (defvar *sharp-equal-circle-table
*)
241 (declaim (type hash-table
*sharp-equal-circle-table
*))
243 ;; This function is kind of like NSUBLIS, but checks for circularities and
244 ;; substitutes in arrays and structures as well as lists. The first arg is an
245 ;; alist of the things to be replaced assoc'd with the things to replace them.
246 (defun circle-subst (old-new-alist tree
)
247 (cond ((not (typep tree
'(or cons
(array t
) instance funcallable-instance
)))
248 (let ((entry (find tree old-new-alist
:key
#'second
)))
249 (if entry
(third entry
) tree
)))
250 ((null (gethash tree
*sharp-equal-circle-table
*))
251 (setf (gethash tree
*sharp-equal-circle-table
*) t
)
253 (let ((a (circle-subst old-new-alist
(car tree
)))
254 (d (circle-subst old-new-alist
(cdr tree
))))
255 (unless (eq a
(car tree
))
257 (unless (eq d
(cdr tree
))
260 (with-array-data ((data tree
) (start) (end))
261 (declare (fixnum start end
))
262 (do ((i start
(1+ i
)))
264 (let* ((old (aref data i
))
265 (new (circle-subst old-new-alist old
)))
267 (setf (aref data i
) new
))))))
268 ((typep tree
'instance
)
269 (let* ((n-untagged (layout-n-untagged-slots (%instance-layout tree
)))
270 (n-tagged (- (%instance-length tree
) n-untagged
)))
271 ;; N-TAGGED includes the layout as well (at index 0), which
275 (let* ((old (%instance-ref tree i
))
276 (new (circle-subst old-new-alist old
)))
278 (setf (%instance-ref tree i
) new
))))
281 (let* ((old (%raw-instance-ref
/word tree i
))
282 (new (circle-subst old-new-alist old
)))
284 (setf (%raw-instance-ref
/word tree i
) new
))))))
285 ((typep tree
'funcallable-instance
)
287 (end (- (1+ (get-closure-length tree
)) sb
!vm
:funcallable-instance-info-offset
)))
289 (let* ((old (%funcallable-instance-info tree i
))
290 (new (circle-subst old-new-alist old
)))
292 (setf (%funcallable-instance-info tree i
) new
))))))
296 ;;; Sharp-equal works as follows. When a label is assigned (i.e. when
297 ;;; #= is called) we GENSYM a symbol is which is used as an
298 ;;; unforgeable tag. *SHARP-SHARP-ALIST* maps the integer tag to this
301 ;;; When SHARP-SHARP encounters a reference to a label, it returns the
302 ;;; symbol assoc'd with the label. Resolution of the reference is
303 ;;; deferred until the read done by #= finishes. Any already resolved
304 ;;; tags (in *SHARP-EQUAL-ALIST*) are simply returned.
306 ;;; After reading of the #= form is completed, we add an entry to
307 ;;; *SHARP-EQUAL-ALIST* that maps the gensym tag to the resolved
308 ;;; object. Then for each entry in the *SHARP-SHARP-ALIST, the current
309 ;;; object is searched and any uses of the gensysm token are replaced
310 ;;; with the actual value.
311 (defvar *sharp-sharp-alist
* ())
313 (defun sharp-equal (stream ignore label
)
314 (declare (ignore ignore
))
315 (when *read-suppress
* (return-from sharp-equal
(values)))
317 (simple-reader-error stream
"missing label for #=" label
))
318 (when (or (assoc label
*sharp-sharp-alist
*)
319 (assoc label
*sharp-equal-alist
*))
320 (simple-reader-error stream
"multiply defined label: #~D=" label
))
321 (let* ((tag (gensym))
322 (*sharp-sharp-alist
* (acons label tag
*sharp-sharp-alist
*))
323 (obj (read stream t nil t
)))
325 (simple-reader-error stream
326 "must tag something more than just #~D#"
328 (push (list label tag obj
) *sharp-equal-alist
*)
329 (let ((*sharp-equal-circle-table
* (make-hash-table :test
'eq
:size
20)))
330 (circle-subst *sharp-equal-alist
* obj
))))
332 (defun sharp-sharp (stream ignore label
)
333 (declare (ignore ignore
))
334 (when *read-suppress
* (return-from sharp-sharp nil
))
336 (simple-reader-error stream
"missing label for ##" label
))
338 (let ((entry (assoc label
*sharp-equal-alist
*)))
341 (let (;; Has this label been defined previously? (Don't read
342 ;; ANSI "2.4.8.15 Sharpsign Equal-Sign" and worry that
343 ;; it requires you to implement forward references,
344 ;; because forward references are disallowed in
345 ;; "2.4.8.16 Sharpsign Sharpsign".)
346 (pair (assoc label
*sharp-sharp-alist
*)))
348 (simple-reader-error stream
349 "reference to undefined label #~D#"
353 ;;;; conditional compilation: the #+ and #- readmacros
355 (flet ((guts (stream not-p
)
356 (unless (if (let ((*package
* *keyword-package
*)
357 (*reader-package
* nil
)
358 (*read-suppress
* nil
))
359 (featurep (read stream t nil t
)))
362 (let ((*read-suppress
* t
))
363 (read stream t nil t
)))
366 (defun sharp-plus (stream sub-char numarg
)
367 (ignore-numarg sub-char numarg
)
370 (defun sharp-minus (stream sub-char numarg
)
371 (ignore-numarg sub-char numarg
)
374 ;;;; reading miscellaneous objects: the #P, #\, and #| readmacros
376 (defun sharp-P (stream sub-char numarg
)
377 (ignore-numarg sub-char numarg
)
378 (let ((namestring (read stream t nil t
)))
379 (unless *read-suppress
*
380 (parse-namestring namestring
))))
382 (defun sharp-backslash (stream backslash numarg
)
383 (ignore-numarg backslash numarg
)
384 (let ((buf (read-extended-token-escaped stream
)))
385 (cond (*read-suppress
* nil
)
386 ((= (token-buf-fill-ptr buf
) 1)
387 (char (token-buf-string buf
) 0))
388 ;; NAME-CHAR is specified as case-insensitive
389 ((name-char (sized-token-buf-string buf
)))
391 (simple-reader-error stream
392 "unrecognized character name: ~S"
393 (copy-token-buf-string buf
))))))
395 (defun sharp-vertical-bar (stream sub-char numarg
)
396 (ignore-numarg sub-char numarg
)
398 ((character-decoding-error
399 #'(lambda (decoding-error)
400 (declare (ignorable decoding-error
))
402 'sb
!kernel
::character-decoding-error-in-dispatch-macro-char-comment
403 :sub-char sub-char
:position
(file-position stream
) :stream stream
)
404 (invoke-restart 'attempt-resync
))))
405 (let ((stream (in-synonym-of stream
)))
406 (if (ansi-stream-p stream
)
407 (prepare-for-fast-read-char stream
409 (prev (fast-read-char) char
)
410 (char (fast-read-char) (fast-read-char)))
412 (cond ((and (char= prev
#\|
) (char= char
#\
#))
413 (setq level
(1- level
))
415 (done-with-fast-read-char)
417 (setq char
(fast-read-char)))
418 ((and (char= prev
#\
#) (char= char
#\|
))
419 (setq char
(fast-read-char))
420 (setq level
(1+ level
))))))
421 ;; fundamental-stream
423 (prev (read-char stream t
) char
)
424 (char (read-char stream t
) (read-char stream t
)))
426 (cond ((and (char= prev
#\|
) (char= char
#\
#))
427 (setq level
(1- level
))
430 (setq char
(read-char stream t
)))
431 ((and (char= prev
#\
#) (char= char
#\|
))
432 (setq char
(read-char stream t
))
433 (setq level
(1+ level
)))))))))
435 ;;;; a grab bag of other sharp readmacros: #', #:, and #.
437 (defun sharp-quote (stream sub-char numarg
)
438 (ignore-numarg sub-char numarg
)
439 ;; The fourth arg tells READ that this is a recursive call.
440 `(function ,(read stream t nil t
)))
442 ;;; Read an uninterned symbol.
443 ;;; Unescaped whitespace terminates the token, however a token comprised
444 ;;; of zero characters is an edge-case that is not extremely portable other
445 ;;; than for a few well-known uses, such as the incontrovertible fact that
446 ;;; "#* foo" is two tokens: an empty bit-vector followed by a symbol.
447 ;;; But different behaviors can be observed for #: in other implementations:
448 ;;; (read-from-string "#: foo") => #:FOO
449 ;;; (read-from-string "#: foo") => ERROR "token expected"
450 (defun sharp-colon (stream sub-char numarg
)
451 (ignore-numarg sub-char numarg
)
452 (multiple-value-bind (buffer escapep colon
) (read-extended-token stream
)
453 (unless *read-suppress
*
454 (casify-read-buffer buffer
)
455 (let ((token (copy-token-buf-string buffer
)))
458 stream
"The symbol following #: contains a package marker: ~S"
460 ;; We'd like to signal errors on tokens that look like numbers,
461 ;; but doing that is actually nontrivial. None of the possible
462 ;; ways to test for numeric syntax are great:
463 ;; - using SYMBOL-QUOTEP to see if it says that the symbol would
464 ;; print using escapes could produce false positives
465 ;; because it's seldom wrong to use vertical bars.
466 ;; - calling READ-FROM-STRING to see if it returns a number
467 ;; would demand a new string stream.
468 ;; - a potential number with _ and/or ^ should not be allowed.
469 ;; An acceptable rough cut is to use PARSE-INTEGER even though it
470 ;; won't help to reject ratios or floating point syntax.
472 (multiple-value-bind (num end
)
473 (parse-integer token
:radix
*read-base
* :junk-allowed t
)
474 (and num
(= end
(length token
)))))
476 stream
"The symbol following #: has numeric syntax: ~S"
479 (make-symbol token
)))))))
481 (defvar *read-eval
* t
483 "If false, then the #. read macro is disabled.")
485 (defun sharp-dot (stream sub-char numarg
)
486 (ignore-numarg sub-char numarg
)
487 (let ((*backquote-depth
* 0))
488 (let ((expr (read stream t nil t
)))
489 (unless *read-suppress
*
491 (simple-reader-error stream
"can't read #. while *READ-EVAL* is NIL"))
494 (defun sharp-illegal (stream sub-char ignore
)
495 (declare (ignore ignore
))
496 (simple-reader-error stream
"illegal sharp macro character: ~S" sub-char
))
498 ;;; for cold init: Install SHARPM stuff in the current *READTABLE*.
499 (defun !sharpm-cold-init
()
500 (make-dispatch-macro-character #\
# t
)
501 (set-dispatch-macro-character #\
# #\\ #'sharp-backslash
)
502 (set-dispatch-macro-character #\
# #\' #'sharp-quote
)
503 (set-dispatch-macro-character #\
# #\
( #'sharp-left-paren
)
504 (set-dispatch-macro-character #\
# #\
* #'sharp-star
)
505 (set-dispatch-macro-character #\
# #\
: #'sharp-colon
)
506 (set-dispatch-macro-character #\
# #\.
#'sharp-dot
)
507 ;; This used to set the dispatch-function for pairs of alphabetics, but
508 ;; {SET,GET}-DISPATCH-MACRO-CHARACTER and READ-DISPATCH-CHAR
509 ;; all use CHAR-UPCASE on the sub-char, so it makes no difference.
510 (set-dispatch-macro-character #\
# #\r #'sharp-R
)
511 (set-dispatch-macro-character #\
# #\b #'sharp-B
)
512 (set-dispatch-macro-character #\
# #\o
#'sharp-O
)
513 (set-dispatch-macro-character #\
# #\x
#'sharp-X
)
514 (set-dispatch-macro-character #\
# #\a #'sharp-A
)
515 (set-dispatch-macro-character #\
# #\s
#'sharp-S
)
516 (set-dispatch-macro-character #\
# #\
= #'sharp-equal
)
517 (set-dispatch-macro-character #\
# #\
# #'sharp-sharp
)
518 (set-dispatch-macro-character #\
# #\
+ #'sharp-plus
)
519 (set-dispatch-macro-character #\
# #\-
#'sharp-minus
)
520 (set-dispatch-macro-character #\
# #\c
#'sharp-C
)
521 (set-dispatch-macro-character #\
# #\|
#'sharp-vertical-bar
)
522 (set-dispatch-macro-character #\
# #\p
#'sharp-P
)
523 (set-dispatch-macro-character #\
# #\
) #'sharp-illegal
)
524 (set-dispatch-macro-character #\
# #\
< #'sharp-illegal
)
525 (set-dispatch-macro-character #\
# #\Space
#'sharp-illegal
)
526 (dolist (cc '#.
(list tab-char-code form-feed-char-code return-char-code
527 line-feed-char-code backspace-char-code
))
528 (set-dispatch-macro-character #\
# (code-char cc
) #'sharp-illegal
)))