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 (ie when #= is
222 ;;; called) we GENSYM a symbol is which is used as an unforgeable tag.
223 ;;; *SHARP-SHARP-ALIST* maps the integer tag to this gensym.
225 ;;; When SHARP-SHARP encounters a reference to a label, it returns the symbol
226 ;;; assoc'd with the label. Resolution of the reference is deferred until the
227 ;;; read done by #= finishes. Any already resolved tags (in
228 ;;; *SHARP-EQUAL-ALIST*) are simply returned.
230 ;;; After reading of the #= form is completed, we add an entry to
231 ;;; *SHARP-EQUAL-ALIST* that maps the gensym tag to the resolved object. Then
232 ;;; for each entry in the *SHARP-SHARP-ALIST, the current object is searched
233 ;;; and any uses of the gensysm token are replaced with the actual value.
234 (defvar *sharp-sharp-alist* ())
236 (defun sharp-equal (stream ignore label)
237 (declare (ignore ignore))
238 (when *read-suppress* (return-from sharp-equal (values)))
240 (%reader-error stream "missing label for #=" label))
241 (when (or (assoc label *sharp-sharp-alist*)
242 (assoc label *sharp-equal-alist*))
243 (%reader-error stream "multiply defined label: #~D=" label))
244 (let* ((tag (gensym))
245 (*sharp-sharp-alist* (acons label tag *sharp-sharp-alist*))
246 (obj (read stream t nil t)))
248 (%reader-error stream
249 "must tag something more than just #~D#"
251 (push (list label tag obj) *sharp-equal-alist*)
252 (let ((*sharp-equal-circle-table* (make-hash-table :test 'eq :size 20)))
253 (circle-subst *sharp-equal-alist* obj))))
255 (defun sharp-sharp (stream ignore label)
256 (declare (ignore ignore))
257 (when *read-suppress* (return-from sharp-sharp nil))
259 (%reader-error stream "missing label for ##" label))
261 (let ((entry (assoc label *sharp-equal-alist*)))
264 (let ((pair (assoc label *sharp-sharp-alist*)))
266 (%reader-error stream "object is not labelled #~S#" label))
269 ;;;; conditional compilation: the #+ and #- readmacros
271 (flet ((guts (stream not-p)
272 (unless (if (handler-case
273 (let ((*package* *keyword-package*)
274 (*read-suppress* nil))
275 (featurep (read stream t nil t)))
276 (reader-package-error
278 (declare (ignore condition))
282 (let ((*read-suppress* t))
283 (read stream t nil t)))
286 (defun sharp-plus (stream sub-char numarg)
287 (ignore-numarg sub-char numarg)
290 (defun sharp-minus (stream sub-char numarg)
291 (ignore-numarg sub-char numarg)
294 ;;;; reading miscellaneous objects: the #P, #\, and #| readmacros
296 (defun sharp-P (stream sub-char numarg)
297 (ignore-numarg sub-char numarg)
298 (let ((namestring (read stream t nil t)))
299 (unless *read-suppress*
300 (parse-namestring namestring))))
302 (defun sharp-backslash (stream backslash numarg)
303 (ignore-numarg backslash numarg)
304 (unread-char backslash stream)
305 (let* ((*readtable* *standard-readtable*)
306 (charstring (read-extended-token stream)))
307 (declare (simple-string charstring))
308 (cond (*read-suppress* nil)
309 ((= (the fixnum (length charstring)) 1)
311 ((name-char charstring))
313 (%reader-error stream
314 "unrecognized character name: ~S"
317 (defun sharp-vertical-bar (stream sub-char numarg)
318 (ignore-numarg sub-char numarg)
319 (let ((stream (in-synonym-of stream)))
320 (if (lisp-stream-p stream)
321 (prepare-for-fast-read-char stream
323 (prev (fast-read-char) char)
324 (char (fast-read-char) (fast-read-char)))
326 (cond ((and (char= prev #\|) (char= char #\#))
327 (setq level (1- level))
329 (done-with-fast-read-char)
331 (setq char (fast-read-char)))
332 ((and (char= prev #\#) (char= char #\|))
333 (setq char (fast-read-char))
334 (setq level (1+ level))))))
335 ;; fundamental-stream
337 (prev (read-char stream t) char)
338 (char (read-char stream t) (read-char stream t)))
340 (cond ((and (char= prev #\|) (char= char #\#))
341 (setq level (1- level))
344 (setq char (read-char stream t)))
345 ((and (char= prev #\#) (char= char #\|))
346 (setq char (read-char stream t))
347 (setq level (1+ level))))))))
349 ;;;; a grab bag of other sharp readmacros: #', #:, and #.
351 (defun sharp-quote (stream sub-char numarg)
352 (ignore-numarg sub-char numarg)
353 ;; The fourth arg tells READ that this is a recursive call.
354 `(function ,(read stream t nil t)))
356 (defun sharp-colon (stream sub-char numarg)
357 (ignore-numarg sub-char numarg)
358 (multiple-value-bind (token escapep colon) (read-extended-token stream)
359 (declare (simple-string token) (ignore escapep))
361 (*read-suppress* nil)
363 (%reader-error stream
364 "The symbol following #: contains a package marker: ~S"
367 (make-symbol token)))))
369 (defvar *read-eval* t
371 "If false, then the #. read macro is disabled.")
373 (defun sharp-dot (stream sub-char numarg)
374 (ignore-numarg sub-char numarg)
375 (let ((token (read stream t nil t)))
376 (unless *read-suppress*
378 (%reader-error stream "can't read #. while *READ-EVAL* is NIL"))
381 (defun sharp-illegal (stream sub-char ignore)
382 (declare (ignore ignore))
383 (%reader-error stream "illegal sharp macro character: ~S" sub-char))
385 ;;; for cold init: Install SHARPM stuff in the current *READTABLE*.
386 (defun !sharpm-cold-init ()
387 (make-dispatch-macro-character #\# t)
388 (set-dispatch-macro-character #\# #\\ #'sharp-backslash)
389 (set-dispatch-macro-character #\# #\' #'sharp-quote)
390 (set-dispatch-macro-character #\# #\( #'sharp-left-paren)
391 (set-dispatch-macro-character #\# #\* #'sharp-star)
392 (set-dispatch-macro-character #\# #\: #'sharp-colon)
393 (set-dispatch-macro-character #\# #\. #'sharp-dot)
394 (set-dispatch-macro-character #\# #\R #'sharp-R)
395 (set-dispatch-macro-character #\# #\r #'sharp-R)
396 (set-dispatch-macro-character #\# #\B #'sharp-B)
397 (set-dispatch-macro-character #\# #\b #'sharp-B)
398 (set-dispatch-macro-character #\# #\O #'sharp-O)
399 (set-dispatch-macro-character #\# #\o #'sharp-O)
400 (set-dispatch-macro-character #\# #\X #'sharp-X)
401 (set-dispatch-macro-character #\# #\x #'sharp-X)
402 (set-dispatch-macro-character #\# #\A #'sharp-A)
403 (set-dispatch-macro-character #\# #\a #'sharp-A)
404 (set-dispatch-macro-character #\# #\S #'sharp-S)
405 (set-dispatch-macro-character #\# #\s #'sharp-S)
406 (set-dispatch-macro-character #\# #\= #'sharp-equal)
407 (set-dispatch-macro-character #\# #\# #'sharp-sharp)
408 (set-dispatch-macro-character #\# #\+ #'sharp-plus)
409 (set-dispatch-macro-character #\# #\- #'sharp-minus)
410 (set-dispatch-macro-character #\# #\C #'sharp-C)
411 (set-dispatch-macro-character #\# #\c #'sharp-C)
412 (set-dispatch-macro-character #\# #\| #'sharp-vertical-bar)
413 (set-dispatch-macro-character #\# #\p #'sharp-p)
414 (set-dispatch-macro-character #\# #\P #'sharp-p)
415 (set-dispatch-macro-character #\# #\ #'sharp-illegal)
416 (set-dispatch-macro-character #\# #\) #'sharp-illegal)
417 (set-dispatch-macro-character #\# #\< #'sharp-illegal)
418 ;; FIXME: Should linefeed/newline go in this list too?
419 (dolist (cc '#.(list tab-char-code form-feed-char-code return-char-code))
420 (set-dispatch-macro-character #\# (code-char cc) #'sharp-illegal)))