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* *standard-readtable* *bq-vector-flag*))
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) (special *backquote-count*))
23 (let* ((list (read-list stream nil))
24 (listlength (length list)))
27 (cond (*read-suppress* nil)
28 ((zerop *backquote-count*)
30 (cond ((> listlength (the fixnum length))
33 "vector longer than specified length: #~S~S"
36 (fill (the simple-vector
37 (replace (the simple-vector
42 (coerce list 'vector)))
43 (t (cons *bq-vector-flag* list)))))
45 (defun sharp-star (stream ignore numarg)
46 (declare (ignore ignore))
47 (multiple-value-bind (bstring escape-appearedp) (read-extended-token stream)
48 (declare (simple-string bstring))
49 (cond (*read-suppress* nil)
51 (%reader-error stream "An escape character appeared after #*"))
52 ((and numarg (zerop (length bstring)) (not (zerop numarg)))
55 "You have to give a little bit for non-zero #* bit-vectors."))
56 ((or (null numarg) (>= (the fixnum numarg) (length bstring)))
57 (let* ((len1 (length bstring))
59 (len2 (or numarg len1))
60 (bvec (make-array len2 :element-type 'bit
62 (declare (fixnum len1 last1 len2))
67 (setq char (elt bstring (if (< i len1) i last1)))
69 (cond ((char= char #\0) 0)
74 "illegal element given for bit-vector: ~S"
79 "Bit vector is longer than specified length #~A*~A"
82 (defun sharp-A (stream ignore dimensions)
83 (declare (ignore ignore))
86 (return-from sharp-A nil))
87 (unless dimensions (%reader-error stream "no dimensions argument to #A"))
89 (let* ((contents (read stream t nil t))
91 (dotimes (axis dimensions
92 (make-array (dims) :initial-contents contents))
93 (unless (typep seq 'sequence)
95 "#~WA axis ~W is not a sequence:~% ~S"
97 (let ((len (length seq)))
99 (unless (or (= axis (1- dimensions))
100 ;; ANSI: "If some dimension of the array whose
101 ;; representation is being parsed is found to be
102 ;; 0, all dimensions to the right (i.e., the
103 ;; higher numbered dimensions) are also
104 ;; considered to be 0."
106 (setq seq (elt seq 0))))))))
108 ;;;; reading structure instances: the #S readmacro
110 (defun sharp-S (stream sub-char numarg)
111 (ignore-numarg sub-char numarg)
112 (when *read-suppress*
113 (read stream t nil t)
114 (return-from sharp-S nil))
115 (let ((body (if (char= (read-char stream t) #\( )
116 (read-list stream nil)
117 (%reader-error stream "non-list following #S"))))
119 (%reader-error stream "non-list following #S: ~S" body))
120 (unless (symbolp (car body))
121 (%reader-error stream "Structure type is not a symbol: ~S" (car body)))
122 (let ((classoid (find-classoid (car body) nil)))
123 (unless (typep classoid 'structure-classoid)
124 (%reader-error stream "~S is not a defined structure type."
126 (let ((def-con (dd-default-constructor
128 (classoid-layout classoid)))))
131 stream "The ~S structure does not have a default constructor."
133 (when (and (atom (rest body))
134 (not (null (rest body))))
136 stream "improper list for #S: ~S." body))
137 (apply (fdefinition def-con)
138 (loop for tail on (rest body) by #'cddr
139 with slot-name = (and (consp tail) (car tail))
141 (when (null (cdr tail))
144 "the arglist for the ~S constructor in #S ~
145 has an odd length: ~S."
146 (car body) (rest body)))
147 (when (or (atom (cdr tail))
148 (and (atom (cddr tail))
149 (not (null (cddr tail)))))
152 "the arglist for the ~S constructor in #S ~
154 (car body) (rest body)))
155 (when (not (typep (car tail) 'string-designator))
158 "a slot name in #S is not a string ~
161 (when (not (keywordp slot-name))
162 (warn 'structure-initarg-not-keyword
164 "in #S ~S, the use of non-keywords ~
165 as slot specifiers is deprecated: ~S."
167 (list (car body) slot-name))))
168 collect (intern (string (car tail)) *keyword-package*)
169 collect (cadr tail)))))))
171 ;;;; reading numbers: the #B, #C, #O, #R, and #X readmacros
173 (defun sharp-B (stream sub-char numarg)
174 (ignore-numarg sub-char numarg)
175 (sharp-r stream sub-char 2))
177 (defun sharp-C (stream sub-char numarg)
178 (ignore-numarg sub-char numarg)
179 ;; The next thing had better be a list of two numbers.
180 (let ((cnum (read stream t nil t)))
181 (when *read-suppress* (return-from sharp-c nil))
182 (if (and (listp cnum) (= (length cnum) 2))
183 (complex (car cnum) (cadr cnum))
184 (%reader-error stream "illegal complex number format: #C~S" cnum))))
186 (defun sharp-O (stream sub-char numarg)
187 (ignore-numarg sub-char numarg)
188 (sharp-r stream sub-char 8))
190 (defun sharp-R (stream sub-char radix)
191 (cond (*read-suppress*
192 (read-extended-token stream)
195 (%reader-error stream "radix missing in #R"))
196 ((not (<= 2 radix 36))
197 (%reader-error stream "illegal radix for #R: ~D." radix))
199 (let ((res (let ((*read-base* radix))
200 (read stream t nil t))))
201 (unless (typep res 'rational)
202 (%reader-error stream
203 "#~A (base ~D.) value is not a rational: ~S."
209 (defun sharp-X (stream sub-char numarg)
210 (ignore-numarg sub-char numarg)
211 (sharp-r stream sub-char 16))
213 ;;;; reading circular data: the #= and ## readmacros
215 ;;; objects already seen by CIRCLE-SUBST
216 (defvar *sharp-equal-circle-table*)
217 (declaim (type hash-table *sharp-equal-circle-table*))
219 ;; This function is kind of like NSUBLIS, but checks for circularities and
220 ;; substitutes in arrays and structures as well as lists. The first arg is an
221 ;; alist of the things to be replaced assoc'd with the things to replace them.
222 (defun circle-subst (old-new-alist tree)
223 (cond ((not (typep tree
224 '(or cons (array t) structure-object standard-object)))
225 (let ((entry (find tree old-new-alist :key #'second)))
226 (if entry (third entry) tree)))
227 ((null (gethash tree *sharp-equal-circle-table*))
228 (setf (gethash tree *sharp-equal-circle-table*) t)
229 (cond ((typep tree '(or structure-object standard-object))
231 (end (%instance-length tree)))
233 (let* ((old (%instance-ref tree i))
234 (new (circle-subst old-new-alist old)))
236 (setf (%instance-ref tree i) new)))))
238 (with-array-data ((data tree) (start) (end))
239 (declare (fixnum start end))
240 (do ((i start (1+ i)))
242 (let* ((old (aref data i))
243 (new (circle-subst old-new-alist old)))
245 (setf (aref data i) new))))))
247 (let ((a (circle-subst old-new-alist (car tree)))
248 (d (circle-subst old-new-alist (cdr tree))))
249 (unless (eq a (car tree))
251 (unless (eq d (cdr tree))
256 ;;; Sharp-equal works as follows. When a label is assigned (i.e. when
257 ;;; #= is called) we GENSYM a symbol is which is used as an
258 ;;; unforgeable tag. *SHARP-SHARP-ALIST* maps the integer tag to this
261 ;;; When SHARP-SHARP encounters a reference to a label, it returns the
262 ;;; symbol assoc'd with the label. Resolution of the reference is
263 ;;; deferred until the read done by #= finishes. Any already resolved
264 ;;; tags (in *SHARP-EQUAL-ALIST*) are simply returned.
266 ;;; After reading of the #= form is completed, we add an entry to
267 ;;; *SHARP-EQUAL-ALIST* that maps the gensym tag to the resolved
268 ;;; object. Then for each entry in the *SHARP-SHARP-ALIST, the current
269 ;;; object is searched and any uses of the gensysm token are replaced
270 ;;; with the actual value.
271 (defvar *sharp-sharp-alist* ())
273 (defun sharp-equal (stream ignore label)
274 (declare (ignore ignore))
275 (when *read-suppress* (return-from sharp-equal (values)))
277 (%reader-error stream "missing label for #=" label))
278 (when (or (assoc label *sharp-sharp-alist*)
279 (assoc label *sharp-equal-alist*))
280 (%reader-error stream "multiply defined label: #~D=" label))
281 (let* ((tag (gensym))
282 (*sharp-sharp-alist* (acons label tag *sharp-sharp-alist*))
283 (obj (read stream t nil t)))
285 (%reader-error stream
286 "must tag something more than just #~D#"
288 (push (list label tag obj) *sharp-equal-alist*)
289 (let ((*sharp-equal-circle-table* (make-hash-table :test 'eq :size 20)))
290 (circle-subst *sharp-equal-alist* obj))))
292 (defun sharp-sharp (stream ignore label)
293 (declare (ignore ignore))
294 (when *read-suppress* (return-from sharp-sharp nil))
296 (%reader-error stream "missing label for ##" label))
298 (let ((entry (assoc label *sharp-equal-alist*)))
301 (let ((pair (assoc label *sharp-sharp-alist*)))
303 (%reader-error stream "object is not labelled #~S#" label))
306 ;;;; conditional compilation: the #+ and #- readmacros
308 (flet ((guts (stream not-p)
309 (unless (if (handler-case
310 (let ((*package* *keyword-package*)
311 (*read-suppress* nil))
312 (featurep (read stream t nil t)))
313 (reader-package-error
315 (declare (ignore condition))
319 (let ((*read-suppress* t))
320 (read stream t nil t)))
323 (defun sharp-plus (stream sub-char numarg)
324 (ignore-numarg sub-char numarg)
327 (defun sharp-minus (stream sub-char numarg)
328 (ignore-numarg sub-char numarg)
331 ;;;; reading miscellaneous objects: the #P, #\, and #| readmacros
333 (defun sharp-P (stream sub-char numarg)
334 (ignore-numarg sub-char numarg)
335 (let ((namestring (read stream t nil t)))
336 (unless *read-suppress*
337 (parse-namestring namestring))))
339 (defun sharp-backslash (stream backslash numarg)
340 (ignore-numarg backslash numarg)
341 (let ((charstring (read-extended-token-escaped stream)))
342 (declare (simple-string charstring))
343 (cond (*read-suppress* nil)
344 ((= (the fixnum (length charstring)) 1)
346 ((name-char charstring))
348 (%reader-error stream "unrecognized character name: ~S"
351 (defun sharp-vertical-bar (stream sub-char numarg)
352 (ignore-numarg sub-char numarg)
354 ((character-decoding-error
355 #'(lambda (decoding-error)
356 (declare (ignorable decoding-error))
357 (style-warn "Character decoding error in a #|-comment at position ~A reading source file ~A, resyncing." (file-position stream) stream)
358 (invoke-restart 'attempt-resync))))
359 (let ((stream (in-synonym-of stream)))
360 (if (ansi-stream-p stream)
361 (prepare-for-fast-read-char stream
363 (prev (fast-read-char) char)
364 (char (fast-read-char) (fast-read-char)))
366 (cond ((and (char= prev #\|) (char= char #\#))
367 (setq level (1- level))
369 (done-with-fast-read-char)
371 (setq char (fast-read-char)))
372 ((and (char= prev #\#) (char= char #\|))
373 (setq char (fast-read-char))
374 (setq level (1+ level))))))
375 ;; fundamental-stream
377 (prev (read-char stream t) char)
378 (char (read-char stream t) (read-char stream t)))
380 (cond ((and (char= prev #\|) (char= char #\#))
381 (setq level (1- level))
384 (setq char (read-char stream t)))
385 ((and (char= prev #\#) (char= char #\|))
386 (setq char (read-char stream t))
387 (setq level (1+ level)))))))))
389 ;;;; a grab bag of other sharp readmacros: #', #:, and #.
391 (defun sharp-quote (stream sub-char numarg)
392 (ignore-numarg sub-char numarg)
393 ;; The fourth arg tells READ that this is a recursive call.
394 `(function ,(read stream t nil t)))
396 (defun sharp-colon (stream sub-char numarg)
397 (ignore-numarg sub-char numarg)
398 (multiple-value-bind (token escapep colon) (read-extended-token stream)
399 (declare (simple-string token) (ignore escapep))
401 (*read-suppress* nil)
403 (%reader-error stream
404 "The symbol following #: contains a package marker: ~S"
407 (make-symbol token)))))
409 (defvar *read-eval* t
411 "If false, then the #. read macro is disabled.")
413 (defun sharp-dot (stream sub-char numarg)
414 (ignore-numarg sub-char numarg)
415 (let ((token (read stream t nil t)))
416 (unless *read-suppress*
418 (%reader-error stream "can't read #. while *READ-EVAL* is NIL"))
421 (defun sharp-illegal (stream sub-char ignore)
422 (declare (ignore ignore))
423 (%reader-error stream "illegal sharp macro character: ~S" sub-char))
425 ;;; for cold init: Install SHARPM stuff in the current *READTABLE*.
426 (defun !sharpm-cold-init ()
427 (make-dispatch-macro-character #\# t)
428 (set-dispatch-macro-character #\# #\\ #'sharp-backslash)
429 (set-dispatch-macro-character #\# #\' #'sharp-quote)
430 (set-dispatch-macro-character #\# #\( #'sharp-left-paren)
431 (set-dispatch-macro-character #\# #\* #'sharp-star)
432 (set-dispatch-macro-character #\# #\: #'sharp-colon)
433 (set-dispatch-macro-character #\# #\. #'sharp-dot)
434 (set-dispatch-macro-character #\# #\R #'sharp-R)
435 (set-dispatch-macro-character #\# #\r #'sharp-R)
436 (set-dispatch-macro-character #\# #\B #'sharp-B)
437 (set-dispatch-macro-character #\# #\b #'sharp-B)
438 (set-dispatch-macro-character #\# #\O #'sharp-O)
439 (set-dispatch-macro-character #\# #\o #'sharp-O)
440 (set-dispatch-macro-character #\# #\X #'sharp-X)
441 (set-dispatch-macro-character #\# #\x #'sharp-X)
442 (set-dispatch-macro-character #\# #\A #'sharp-A)
443 (set-dispatch-macro-character #\# #\a #'sharp-A)
444 (set-dispatch-macro-character #\# #\S #'sharp-S)
445 (set-dispatch-macro-character #\# #\s #'sharp-S)
446 (set-dispatch-macro-character #\# #\= #'sharp-equal)
447 (set-dispatch-macro-character #\# #\# #'sharp-sharp)
448 (set-dispatch-macro-character #\# #\+ #'sharp-plus)
449 (set-dispatch-macro-character #\# #\- #'sharp-minus)
450 (set-dispatch-macro-character #\# #\C #'sharp-C)
451 (set-dispatch-macro-character #\# #\c #'sharp-C)
452 (set-dispatch-macro-character #\# #\| #'sharp-vertical-bar)
453 (set-dispatch-macro-character #\# #\p #'sharp-p)
454 (set-dispatch-macro-character #\# #\P #'sharp-p)
455 (set-dispatch-macro-character #\# #\) #'sharp-illegal)
456 (set-dispatch-macro-character #\# #\< #'sharp-illegal)
457 (set-dispatch-macro-character #\# #\Space #'sharp-illegal)
458 (dolist (cc '#.(list tab-char-code form-feed-char-code return-char-code
459 line-feed-char-code backspace-char-code))
460 (set-dispatch-macro-character #\# (code-char cc) #'sharp-illegal)))