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")
15 (declaim (special *read-suppress* *standard-readtable* *bq-vector-flag*))
17 ;;; FIXME: Is it standard to ignore numeric args instead of raising errors?
18 (defun ignore-numarg (sub-char numarg)
20 (warn "A numeric argument was ignored in #~D~A." numarg sub-char)))
22 ;;;; reading arrays and vectors: the #(, #*, and #A readmacros
24 (defun sharp-left-paren (stream ignore length)
25 (declare (ignore ignore) (special *backquote-count*))
26 (let* ((list (read-list stream nil))
27 (listlength (length list)))
30 (cond (*read-suppress* nil)
31 ((zerop *backquote-count*)
33 (cond ((> listlength (the fixnum length))
36 "vector longer than specified length: #~S~S"
39 (fill (the simple-vector
40 (replace (the simple-vector
45 (coerce list 'vector)))
46 (t (cons *bq-vector-flag* list)))))
48 (defun sharp-star (stream ignore numarg)
49 (declare (ignore ignore))
50 (multiple-value-bind (bstring escape-appearedp) (read-extended-token stream)
51 (declare (simple-string bstring))
52 (cond (*read-suppress* nil)
54 (%reader-error stream "An escape character appeared after #*"))
55 ((and numarg (zerop (length bstring)) (not (zerop numarg)))
58 "You have to give a little bit for non-zero #* bit-vectors."))
59 ((or (null numarg) (>= (the fixnum numarg) (length bstring)))
60 (let* ((len1 (length bstring))
62 (len2 (or numarg len1))
63 (bvec (make-array len2 :element-type 'bit
65 (declare (fixnum len1 last1 len2))
70 (setq char (elt bstring (if (< i len1) i last1)))
72 (cond ((char= char #\0) 0)
77 "illegal element given for bit-vector: ~S"
82 "Bit vector is longer than specified length #~A*~A"
85 (defun sharp-A (stream ignore dimensions)
86 (declare (ignore ignore))
89 (return-from sharp-A nil))
90 (unless dimensions (%reader-error stream "no dimensions argument to #A"))
92 (let* ((contents (read stream t nil t))
94 (dotimes (axis dimensions
95 (make-array (dims) :initial-contents contents))
96 (unless (typep seq 'sequence)
98 "#~DA axis ~D is not a sequence:~% ~S"
100 (let ((len (length seq)))
102 (unless (= axis (1- dimensions))
104 (%reader-error stream
105 "#~DA axis ~D is empty, but is not ~
108 (setq seq (elt seq 0))))))))
110 ;;;; reading structure instances: the #S readmacro
112 (defun sharp-S (stream sub-char numarg)
113 (ignore-numarg sub-char numarg)
114 (when *read-suppress*
115 (read stream t nil t)
116 (return-from sharp-S nil))
117 (let ((body (if (char= (read-char stream t) #\( )
118 (read-list stream nil)
119 (%reader-error stream "non-list following #S"))))
121 (%reader-error stream "non-list following #S: ~S" body))
122 (unless (symbolp (car body))
123 (%reader-error stream "Structure type is not a symbol: ~S" (car body)))
124 (let ((class (sb!xc:find-class (car body) nil)))
125 (unless (typep class 'sb!xc:structure-class)
126 (%reader-error stream "~S is not a defined structure type."
128 (let ((def-con (dd-default-constructor
130 (class-layout class)))))
133 stream "The ~S structure does not have a default constructor."
135 (apply (fdefinition def-con) (rest body))))))
137 ;;;; reading numbers: the #B, #C, #O, #R, and #X readmacros
139 (defun sharp-B (stream sub-char numarg)
140 (ignore-numarg sub-char numarg)
141 (sharp-r stream sub-char 2))
143 (defun sharp-C (stream sub-char numarg)
144 (ignore-numarg sub-char numarg)
145 ;; The next thing had better be a list of two numbers.
146 (let ((cnum (read stream t nil t)))
147 (when *read-suppress* (return-from sharp-c nil))
148 (if (and (listp cnum) (= (length cnum) 2))
149 (complex (car cnum) (cadr cnum))
150 (%reader-error stream "illegal complex number format: #C~S" cnum))))
152 (defun sharp-O (stream sub-char numarg)
153 (ignore-numarg sub-char numarg)
154 (sharp-r stream sub-char 8))
156 (defun sharp-R (stream sub-char radix)
157 (cond (*read-suppress*
158 (read-extended-token stream)
161 (%reader-error stream "radix missing in #R"))
162 ((not (<= 2 radix 36))
163 (%reader-error stream "illegal radix for #R: ~D" radix))
165 (let ((res (let ((*read-base* radix))
166 (read stream t nil t))))
167 (unless (typep res 'rational)
168 (%reader-error stream
169 "#~A (base ~D) value is not a rational: ~S."
175 (defun sharp-X (stream sub-char numarg)
176 (ignore-numarg sub-char numarg)
177 (sharp-r stream sub-char 16))
179 ;;;; reading circular data: the #= and ## readmacros
181 ;;; objects already seen by CIRCLE-SUBST
182 (defvar *sharp-equal-circle-table*)
183 (declaim (type hash-table *sharp-equal-circle-table*))
185 ;; This function is kind of like NSUBLIS, but checks for circularities and
186 ;; substitutes in arrays and structures as well as lists. The first arg is an
187 ;; alist of the things to be replaced assoc'd with the things to replace them.
188 (defun circle-subst (old-new-alist tree)
189 (cond ((not (typep tree '(or cons (array t) structure-object)))
190 (let ((entry (find tree old-new-alist :key #'second)))
191 (if entry (third entry) tree)))
192 ((null (gethash tree *sharp-equal-circle-table*))
193 (setf (gethash tree *sharp-equal-circle-table*) t)
194 (cond ((typep tree 'structure-object)
196 (end (%instance-length tree)))
198 (let* ((old (%instance-ref tree i))
199 (new (circle-subst old-new-alist old)))
201 (setf (%instance-ref tree i) new)))))
203 (with-array-data ((data tree) (start) (end))
204 (declare (fixnum start end))
205 (do ((i start (1+ i)))
207 (let* ((old (aref data i))
208 (new (circle-subst old-new-alist old)))
210 (setf (aref data i) new))))))
212 (let ((a (circle-subst old-new-alist (car tree)))
213 (d (circle-subst old-new-alist (cdr tree))))
214 (unless (eq a (car tree))
216 (unless (eq d (cdr tree))
221 ;;; Sharp-equal works as follows. When a label is assigned (i.e. when
222 ;;; #= is called) we GENSYM a symbol is which is used as an
223 ;;; unforgeable tag. *SHARP-SHARP-ALIST* maps the integer tag to this
226 ;;; When SHARP-SHARP encounters a reference to a label, it returns the
227 ;;; symbol assoc'd with the label. Resolution of the reference is
228 ;;; deferred until the read done by #= finishes. Any already resolved
229 ;;; tags (in *SHARP-EQUAL-ALIST*) are simply returned.
231 ;;; After reading of the #= form is completed, we add an entry to
232 ;;; *SHARP-EQUAL-ALIST* that maps the gensym tag to the resolved
233 ;;; object. Then for each entry in the *SHARP-SHARP-ALIST, the current
234 ;;; object is searched and any uses of the gensysm token are replaced
235 ;;; with the actual value.
236 (defvar *sharp-sharp-alist* ())
238 (defun sharp-equal (stream ignore label)
239 (declare (ignore ignore))
240 (when *read-suppress* (return-from sharp-equal (values)))
242 (%reader-error stream "missing label for #=" label))
243 (when (or (assoc label *sharp-sharp-alist*)
244 (assoc label *sharp-equal-alist*))
245 (%reader-error stream "multiply defined label: #~D=" label))
246 (let* ((tag (gensym))
247 (*sharp-sharp-alist* (acons label tag *sharp-sharp-alist*))
248 (obj (read stream t nil t)))
250 (%reader-error stream
251 "must tag something more than just #~D#"
253 (push (list label tag obj) *sharp-equal-alist*)
254 (let ((*sharp-equal-circle-table* (make-hash-table :test 'eq :size 20)))
255 (circle-subst *sharp-equal-alist* obj))))
257 (defun sharp-sharp (stream ignore label)
258 (declare (ignore ignore))
259 (when *read-suppress* (return-from sharp-sharp nil))
261 (%reader-error stream "missing label for ##" label))
263 (let ((entry (assoc label *sharp-equal-alist*)))
266 (let ((pair (assoc label *sharp-sharp-alist*)))
268 (%reader-error stream "object is not labelled #~S#" label))
271 ;;;; conditional compilation: the #+ and #- readmacros
273 (flet ((guts (stream not-p)
274 (unless (if (handler-case
275 (let ((*package* *keyword-package*)
276 (*read-suppress* nil))
277 (featurep (read stream t nil t)))
278 (reader-package-error
280 (declare (ignore condition))
284 (let ((*read-suppress* t))
285 (read stream t nil t)))
288 (defun sharp-plus (stream sub-char numarg)
289 (ignore-numarg sub-char numarg)
292 (defun sharp-minus (stream sub-char numarg)
293 (ignore-numarg sub-char numarg)
296 ;;;; reading miscellaneous objects: the #P, #\, and #| readmacros
298 (defun sharp-P (stream sub-char numarg)
299 (ignore-numarg sub-char numarg)
300 (let ((namestring (read stream t nil t)))
301 (unless *read-suppress*
302 (parse-namestring namestring))))
304 (defun sharp-backslash (stream backslash numarg)
305 (ignore-numarg backslash numarg)
306 (unread-char backslash stream)
307 (let* ((*readtable* *standard-readtable*)
308 (charstring (read-extended-token stream)))
309 (declare (simple-string charstring))
310 (cond (*read-suppress* nil)
311 ((= (the fixnum (length charstring)) 1)
313 ((name-char charstring))
315 (%reader-error stream
316 "unrecognized character name: ~S"
319 (defun sharp-vertical-bar (stream sub-char numarg)
320 (ignore-numarg sub-char numarg)
321 (let ((stream (in-synonym-of stream)))
322 (if (lisp-stream-p stream)
323 (prepare-for-fast-read-char stream
325 (prev (fast-read-char) char)
326 (char (fast-read-char) (fast-read-char)))
328 (cond ((and (char= prev #\|) (char= char #\#))
329 (setq level (1- level))
331 (done-with-fast-read-char)
333 (setq char (fast-read-char)))
334 ((and (char= prev #\#) (char= char #\|))
335 (setq char (fast-read-char))
336 (setq level (1+ level))))))
337 ;; fundamental-stream
339 (prev (read-char stream t) char)
340 (char (read-char stream t) (read-char stream t)))
342 (cond ((and (char= prev #\|) (char= char #\#))
343 (setq level (1- level))
346 (setq char (read-char stream t)))
347 ((and (char= prev #\#) (char= char #\|))
348 (setq char (read-char stream t))
349 (setq level (1+ level))))))))
351 ;;;; a grab bag of other sharp readmacros: #', #:, and #.
353 (defun sharp-quote (stream sub-char numarg)
354 (ignore-numarg sub-char numarg)
355 ;; The fourth arg tells READ that this is a recursive call.
356 `(function ,(read stream t nil t)))
358 (defun sharp-colon (stream sub-char numarg)
359 (ignore-numarg sub-char numarg)
360 (multiple-value-bind (token escapep colon) (read-extended-token stream)
361 (declare (simple-string token) (ignore escapep))
363 (*read-suppress* nil)
365 (%reader-error stream
366 "The symbol following #: contains a package marker: ~S"
369 (make-symbol token)))))
371 (defvar *read-eval* t
373 "If false, then the #. read macro is disabled.")
375 (defun sharp-dot (stream sub-char numarg)
376 (ignore-numarg sub-char numarg)
377 (let ((token (read stream t nil t)))
378 (unless *read-suppress*
380 (%reader-error stream "can't read #. while *READ-EVAL* is NIL"))
383 (defun sharp-illegal (stream sub-char ignore)
384 (declare (ignore ignore))
385 (%reader-error stream "illegal sharp macro character: ~S" sub-char))
387 ;;; for cold init: Install SHARPM stuff in the current *READTABLE*.
388 (defun !sharpm-cold-init ()
389 (make-dispatch-macro-character #\# t)
390 (set-dispatch-macro-character #\# #\\ #'sharp-backslash)
391 (set-dispatch-macro-character #\# #\' #'sharp-quote)
392 (set-dispatch-macro-character #\# #\( #'sharp-left-paren)
393 (set-dispatch-macro-character #\# #\* #'sharp-star)
394 (set-dispatch-macro-character #\# #\: #'sharp-colon)
395 (set-dispatch-macro-character #\# #\. #'sharp-dot)
396 (set-dispatch-macro-character #\# #\R #'sharp-R)
397 (set-dispatch-macro-character #\# #\r #'sharp-R)
398 (set-dispatch-macro-character #\# #\B #'sharp-B)
399 (set-dispatch-macro-character #\# #\b #'sharp-B)
400 (set-dispatch-macro-character #\# #\O #'sharp-O)
401 (set-dispatch-macro-character #\# #\o #'sharp-O)
402 (set-dispatch-macro-character #\# #\X #'sharp-X)
403 (set-dispatch-macro-character #\# #\x #'sharp-X)
404 (set-dispatch-macro-character #\# #\A #'sharp-A)
405 (set-dispatch-macro-character #\# #\a #'sharp-A)
406 (set-dispatch-macro-character #\# #\S #'sharp-S)
407 (set-dispatch-macro-character #\# #\s #'sharp-S)
408 (set-dispatch-macro-character #\# #\= #'sharp-equal)
409 (set-dispatch-macro-character #\# #\# #'sharp-sharp)
410 (set-dispatch-macro-character #\# #\+ #'sharp-plus)
411 (set-dispatch-macro-character #\# #\- #'sharp-minus)
412 (set-dispatch-macro-character #\# #\C #'sharp-C)
413 (set-dispatch-macro-character #\# #\c #'sharp-C)
414 (set-dispatch-macro-character #\# #\| #'sharp-vertical-bar)
415 (set-dispatch-macro-character #\# #\p #'sharp-p)
416 (set-dispatch-macro-character #\# #\P #'sharp-p)
417 (set-dispatch-macro-character #\# #\ #'sharp-illegal)
418 (set-dispatch-macro-character #\# #\) #'sharp-illegal)
419 (set-dispatch-macro-character #\# #\< #'sharp-illegal)
420 ;; FIXME: Should linefeed/newline go in this list too?
421 (dolist (cc '#.(list tab-char-code form-feed-char-code return-char-code))
422 (set-dispatch-macro-character #\# (code-char cc) #'sharp-illegal)))