3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!IMPL")
14 ;;;; miscellaneous global variables
16 ;;; ANSI: "the floating-point format that is to be used when reading a
17 ;;; floating-point number that has no exponent marker or that has e or
18 ;;; E for an exponent marker"
19 (defvar *read-default-float-format
* 'single-float
)
20 (declaim (type (member short-float single-float double-float long-float
)
21 *read-default-float-format
*))
24 (declaim (type readtable
*readtable
*))
26 (setf (fdocumentation '*readtable
* 'variable
)
27 "Variable bound to current readtable.")
29 ;;; A standard Lisp readtable (once cold-init is through). This is for
30 ;;; recovery from broken read-tables (and for
31 ;;; WITH-STANDARD-IO-SYNTAX), and should not normally be user-visible.
32 (defvar *standard-readtable
* nil
)
34 (defvar *old-package
* nil
36 "the value of *PACKAGE* at the start of the last read, or NIL")
38 ;;; In case we get an error trying to parse a symbol, we want to rebind the
39 ;;; above stuff so it's cool.
41 ;;; FIXME: These forward declarations should be moved somewhere earlier,
43 (declaim (special *package
* *keyword-package
* *read-base
*))
47 (defun reader-eof-error (stream context
)
48 (error 'reader-eof-error
52 ;;; If The Gods didn't intend for us to use multiple namespaces, why
53 ;;; did They specify them?
54 (defun simple-reader-error (stream control
&rest args
)
55 (error 'simple-reader-error
57 :format-control control
58 :format-arguments args
))
60 ;;;; macros and functions for character tables
62 (defun get-cat-entry (char rt
)
63 (declare (readtable rt
))
64 (if (typep char
'base-char
)
65 (elt (character-attribute-array rt
) (char-code char
))
66 (values (gethash char
(character-attribute-hash-table rt
)
67 +char-attr-constituent
+))))
69 (defun set-cat-entry (char newvalue
&optional
(rt *readtable
*))
70 (declare (readtable rt
))
71 (if (typep char
'base-char
)
72 (setf (elt (character-attribute-array rt
) (char-code char
)) newvalue
)
73 (if (= newvalue
+char-attr-constituent
+)
74 ;; Default value for the C-A-HASH-TABLE is +CHAR-ATTR-CONSTITUENT+.
75 (%remhash char
(character-attribute-hash-table rt
))
76 (setf (gethash char
(character-attribute-hash-table rt
)) newvalue
)))
79 ;;; the value actually stored in the character macro table. As per
80 ;;; ANSI #'GET-MACRO-CHARACTER and #'SET-MACRO-CHARACTER, this can
81 ;;; be either a function or NIL.
82 (defun get-raw-cmt-entry (char readtable
)
83 (declare (readtable readtable
))
84 (if (typep char
'base-char
)
85 (svref (character-macro-array readtable
) (char-code char
))
86 ;; Note: DEFAULT here is NIL, not #'UNDEFINED-MACRO-CHAR, so
87 ;; that everything above the base-char range is a non-macro
88 ;; constituent by default.
89 (values (gethash char
(character-macro-hash-table readtable
) nil
))))
91 ;;; the value represented by whatever is stored in the character macro
92 ;;; table. As per ANSI #'GET-MACRO-CHARACTER and #'SET-MACRO-CHARACTER,
93 ;;; a function value represents itself, and a NIL value represents the
95 (defun get-coerced-cmt-entry (char readtable
)
97 (or (get-raw-cmt-entry char readtable
)
100 (defun set-cmt-entry (char new-value-designator
&optional
(rt *readtable
*))
101 (let ((new (when new-value-designator
102 (%coerce-callable-to-fun new-value-designator
))))
103 (if (typep char
'base-char
)
104 (setf (svref (character-macro-array rt
) (char-code char
)) new
)
105 (setf (gethash char
(character-macro-hash-table rt
)) new
))))
107 (defun undefined-macro-char (stream char
)
108 (unless *read-suppress
*
109 (simple-reader-error stream
"undefined read-macro character ~S" char
)))
111 ;;; The character attribute table is a CHAR-CODE-LIMIT vector of integers.
113 (defmacro test-attribute
(char whichclass rt
)
114 `(= (the fixnum
(get-cat-entry ,char
,rt
)) ,whichclass
))
116 ;;; predicates for testing character attributes
120 (declaim (inline whitespace
[1]p whitespace[2]p))
121 (declaim (inline constituentp terminating-macrop))
122 (declaim (inline single-escape-p multiple-escape-p))
123 (declaim (inline token-delimiterp)))
125 ;;; the [1] and
[2] here refer to ANSI glossary entries for
127 (defun whitespace[1]p (char)
128 (test-attribute char +char-attr-whitespace+ *standard-readtable*))
129 (defun whitespace[2]p
(char &optional
(rt *readtable
*))
130 (test-attribute char
+char-attr-whitespace
+ rt
))
132 (defun constituentp (char &optional
(rt *readtable
*))
133 (test-attribute char
+char-attr-constituent
+ rt
))
135 (defun terminating-macrop (char &optional
(rt *readtable
*))
136 (test-attribute char
+char-attr-terminating-macro
+ rt
))
138 (defun single-escape-p (char &optional
(rt *readtable
*))
139 (test-attribute char
+char-attr-single-escape
+ rt
))
141 (defun multiple-escape-p (char &optional
(rt *readtable
*))
142 (test-attribute char
+char-attr-multiple-escape
+ rt
))
144 (defun token-delimiterp (char &optional
(rt *readtable
*))
145 ;; depends on actual attribute numbering in readtable.lisp.
146 (<= (get-cat-entry char rt
) +char-attr-terminating-macro
+))
148 ;;;; constituent traits (see ANSI 2.1.4.2)
150 ;;; There are a number of "secondary" attributes which are constant
151 ;;; properties of characters (as long as they are constituents).
153 (defvar *constituent-trait-table
*)
154 (declaim (type attribute-table
*constituent-trait-table
*))
156 (defun !set-constituent-trait
(char trait
)
157 (aver (typep char
'base-char
))
158 (setf (elt *constituent-trait-table
* (char-code char
))
161 (defun !cold-init-constituent-trait-table
()
162 (setq *constituent-trait-table
*
163 (make-array base-char-code-limit
:element-type
'(unsigned-byte 8)
164 :initial-element
+char-attr-constituent
+))
165 (!set-constituent-trait
#\
: +char-attr-package-delimiter
+)
166 (!set-constituent-trait
#\.
+char-attr-constituent-dot
+)
167 (!set-constituent-trait
#\
+ +char-attr-constituent-sign
+)
168 (!set-constituent-trait
#\-
+char-attr-constituent-sign
+)
169 (!set-constituent-trait
#\
/ +char-attr-constituent-slash
+)
170 (do ((i (char-code #\
0) (1+ i
)))
171 ((> i
(char-code #\
9)))
172 (!set-constituent-trait
(code-char i
) +char-attr-constituent-digit
+))
173 (!set-constituent-trait
#\E
+char-attr-constituent-expt
+)
174 (!set-constituent-trait
#\F
+char-attr-constituent-expt
+)
175 (!set-constituent-trait
#\D
+char-attr-constituent-expt
+)
176 (!set-constituent-trait
#\S
+char-attr-constituent-expt
+)
177 (!set-constituent-trait
#\L
+char-attr-constituent-expt
+)
178 (!set-constituent-trait
#\e
+char-attr-constituent-expt
+)
179 (!set-constituent-trait
#\f +char-attr-constituent-expt
+)
180 (!set-constituent-trait
#\d
+char-attr-constituent-expt
+)
181 (!set-constituent-trait
#\s
+char-attr-constituent-expt
+)
182 (!set-constituent-trait
#\l
+char-attr-constituent-expt
+)
183 (!set-constituent-trait
#\Space
+char-attr-invalid
+)
184 (!set-constituent-trait
#\Newline
+char-attr-invalid
+)
185 (dolist (c (list backspace-char-code tab-char-code form-feed-char-code
186 return-char-code rubout-char-code
))
187 (!set-constituent-trait
(code-char c
) +char-attr-invalid
+)))
189 (declaim (inline get-constituent-trait
))
190 (defun get-constituent-trait (char)
191 (if (typep char
'base-char
)
192 (elt *constituent-trait-table
* (char-code char
))
193 +char-attr-constituent
+))
195 ;;;; Readtable Operations
197 (defun assert-not-standard-readtable (readtable operation
)
198 (when (eq readtable
*standard-readtable
*)
199 (cerror "Frob it anyway!" 'standard-readtable-modified-error
200 :operation operation
)))
202 (defun readtable-case (readtable)
203 (%readtable-case readtable
))
205 (defun (setf readtable-case
) (case readtable
)
206 (assert-not-standard-readtable readtable
'(setf readtable-case
))
207 (setf (%readtable-case readtable
) case
))
209 (defun shallow-replace/eql-hash-table
(to from
)
210 (maphash (lambda (k v
) (setf (gethash k to
) v
)) from
))
212 (defun copy-readtable (&optional
(from-readtable *readtable
*) to-readtable
)
213 (assert-not-standard-readtable to-readtable
'copy-readtable
)
214 (let ((really-from-readtable (or from-readtable
*standard-readtable
*))
215 (really-to-readtable (or to-readtable
(make-readtable))))
216 (replace (character-attribute-array really-to-readtable
)
217 (character-attribute-array really-from-readtable
))
218 (shallow-replace/eql-hash-table
219 (character-attribute-hash-table really-to-readtable
)
220 (character-attribute-hash-table really-from-readtable
))
221 (replace (character-macro-array really-to-readtable
)
222 (character-macro-array really-from-readtable
))
223 (shallow-replace/eql-hash-table
224 (character-macro-hash-table really-to-readtable
)
225 (character-macro-hash-table really-from-readtable
))
226 (setf (dispatch-tables really-to-readtable
)
227 (mapcar (lambda (pair)
229 (let ((table (make-hash-table)))
230 (shallow-replace/eql-hash-table table
(cdr pair
))
232 (dispatch-tables really-from-readtable
)))
233 (setf (readtable-case really-to-readtable
)
234 (readtable-case really-from-readtable
))
235 really-to-readtable
))
237 (defun set-syntax-from-char (to-char from-char
&optional
238 (to-readtable *readtable
*) (from-readtable nil
))
240 "Causes the syntax of TO-CHAR to be the same as FROM-CHAR in the optional
241 readtable (defaults to the current readtable). The FROM-TABLE defaults to the
242 standard Lisp readtable when NIL."
243 (assert-not-standard-readtable to-readtable
'set-syntax-from-char
)
244 (let ((really-from-readtable (or from-readtable
*standard-readtable
*)))
245 (let ((att (get-cat-entry from-char really-from-readtable
))
246 (mac (get-raw-cmt-entry from-char really-from-readtable
))
247 (from-dpair (find from-char
(dispatch-tables really-from-readtable
)
248 :test
#'char
= :key
#'car
))
249 (to-dpair (find to-char
(dispatch-tables to-readtable
)
250 :test
#'char
= :key
#'car
)))
251 (set-cat-entry to-char att to-readtable
)
252 (set-cmt-entry to-char mac to-readtable
)
256 (let ((table (cdr to-dpair
)))
258 (shallow-replace/eql-hash-table table
(cdr from-dpair
))))
260 (let ((pair (cons to-char
(make-hash-table))))
261 (shallow-replace/eql-hash-table
(cdr pair
) (cdr from-dpair
))
262 (setf (dispatch-tables to-readtable
)
263 (push pair
(dispatch-tables to-readtable
)))))))))
266 (defun set-macro-character (char function
&optional
267 (non-terminatingp nil
)
268 (rt-designator *readtable
*))
270 "Causes CHAR to be a macro character which invokes FUNCTION when seen
271 by the reader. The NON-TERMINATINGP flag can be used to make the macro
272 character non-terminating, i.e. embeddable in a symbol name."
273 (let ((designated-readtable (or rt-designator
*standard-readtable
*)))
274 (assert-not-standard-readtable designated-readtable
'set-macro-character
)
275 (set-cat-entry char
(if non-terminatingp
276 +char-attr-constituent
+
277 +char-attr-terminating-macro
+)
278 designated-readtable
)
279 (set-cmt-entry char function designated-readtable
)
280 t
)) ; (ANSI-specified return value)
282 (defun get-macro-character (char &optional
(rt-designator *readtable
*))
284 "Return the function associated with the specified CHAR which is a macro
285 character, or NIL if there is no such function. As a second value, return
286 T if CHAR is a macro character which is non-terminating, i.e. which can
287 be embedded in a symbol name."
288 (let* ((designated-readtable (or rt-designator
*standard-readtable
*))
289 ;; the first return value: a FUNCTION if CHAR is a macro
290 ;; character, or NIL otherwise
291 (fun-value (get-raw-cmt-entry char designated-readtable
)))
293 ;; NON-TERMINATING-P return value:
295 (or (constituentp char designated-readtable
)
296 (not (terminating-macrop char designated-readtable
)))
297 ;; ANSI's definition of GET-MACRO-CHARACTER says this
298 ;; value is NIL when CHAR is not a macro character.
299 ;; I.e. this value means not just "non-terminating
300 ;; character?" but "non-terminating macro character?".
304 (defun make-char-dispatch-table ()
307 (defun make-dispatch-macro-character (char &optional
308 (non-terminating-p nil
)
311 "Cause CHAR to become a dispatching macro character in readtable (which
312 defaults to the current readtable). If NON-TERMINATING-P, the char will
314 ;; Checks already for standard readtable modification.
315 (set-macro-character char
#'read-dispatch-char non-terminating-p rt
)
316 (let* ((dalist (dispatch-tables rt
))
317 (dtable (cdr (find char dalist
:test
#'char
= :key
#'car
))))
319 (error "The dispatch character ~S already exists." char
))
321 (setf (dispatch-tables rt
)
322 (push (cons char
(make-char-dispatch-table)) dalist
)))))
325 (defun set-dispatch-macro-character (disp-char sub-char function
326 &optional
(rt-designator *readtable
*))
328 "Cause FUNCTION to be called whenever the reader reads DISP-CHAR
329 followed by SUB-CHAR."
330 ;; Get the dispatch char for macro (error if not there), diddle
331 ;; entry for sub-char.
332 (let* ((sub-char (char-upcase sub-char
))
333 (readtable (or rt-designator
*standard-readtable
*)))
334 (assert-not-standard-readtable readtable
'set-dispatch-macro-character
)
335 (when (digit-char-p sub-char
)
336 (error "SUB-CHAR must not be a decimal digit: ~S" sub-char
))
337 (let ((dpair (find disp-char
(dispatch-tables readtable
)
338 :test
#'char
= :key
#'car
)))
340 (setf (gethash sub-char
(cdr dpair
)) (coerce function
'function
))
341 (error "~S is not a dispatch char." disp-char
))))
344 (defun get-dispatch-macro-character (disp-char sub-char
345 &optional
(rt-designator *readtable
*))
347 "Return the macro character function for SUB-CHAR under DISP-CHAR
348 or NIL if there is no associated function."
349 (let* ((sub-char (char-upcase sub-char
))
350 (readtable (or rt-designator
*standard-readtable
*))
351 (dpair (find disp-char
(dispatch-tables readtable
)
352 :test
#'char
= :key
#'car
)))
354 (values (gethash sub-char
(cdr dpair
)))
355 (error "~S is not a dispatch char." disp-char
))))
358 ;;;; definitions to support internal programming conventions
360 (declaim (inline eofp
))
362 (eq char
*eof-object
*))
364 (defun flush-whitespace (stream)
365 ;; This flushes whitespace chars, returning the last char it read (a
366 ;; non-white one). It always gets an error on end-of-file.
367 (let ((stream (in-synonym-of stream
)))
368 (if (ansi-stream-p stream
)
369 (prepare-for-fast-read-char stream
370 (do ((attribute-array (character-attribute-array *readtable
*))
371 (attribute-hash-table
372 (character-attribute-hash-table *readtable
*))
373 (char (fast-read-char t
) (fast-read-char t
)))
375 (if (typep char
'base-char
)
376 (aref attribute-array
(char-code char
))
377 (gethash char attribute-hash-table
378 +char-attr-constituent
+)))
379 +char-attr-whitespace
+)
380 (done-with-fast-read-char)
383 (do ((attribute-array (character-attribute-array *readtable
*))
384 (attribute-hash-table
385 (character-attribute-hash-table *readtable
*))
386 (char (read-char stream nil
:eof
) (read-char stream nil
:eof
)))
389 (if (typep char
'base-char
)
390 (aref attribute-array
(char-code char
))
391 (gethash char attribute-hash-table
392 +char-attr-constituent
+)))
393 +char-attr-whitespace
+))
395 (error 'end-of-file
:stream stream
)
398 ;;;; temporary initialization hack
400 ;; Install the (easy) standard macro-chars into *READTABLE*.
401 (defun !cold-init-standard-readtable
()
402 (/show0
"entering !cold-init-standard-readtable")
403 ;; All characters get boring defaults in MAKE-READTABLE. Now we
404 ;; override the boring defaults on characters which need more
405 ;; interesting behavior.
406 (flet ((whitespaceify (char)
407 (set-cmt-entry char nil
)
408 (set-cat-entry char
+char-attr-whitespace
+)))
409 (whitespaceify (code-char tab-char-code
))
410 (whitespaceify #\Newline
)
411 (whitespaceify #\Space
)
412 (whitespaceify (code-char form-feed-char-code
))
413 (whitespaceify (code-char return-char-code
)))
415 (set-cat-entry #\\ +char-attr-single-escape
+)
416 (set-cmt-entry #\\ nil
)
418 (set-cat-entry #\|
+char-attr-multiple-escape
+)
419 (set-cmt-entry #\| nil
)
421 ;; Easy macro-character definitions are in this source file.
422 (set-macro-character #\" #'read-string
)
423 (set-macro-character #\' #'read-quote
)
424 (set-macro-character #\
( #'read-list
)
425 (set-macro-character #\
) #'read-right-paren
)
426 (set-macro-character #\
; #'read-comment)
427 ;; (The hairier macro-character definitions, for #\# and #\`, are
428 ;; defined elsewhere, in their own source files.)
431 (do ((ichar 0 (1+ ichar
))
433 ((= ichar base-char-code-limit
))
434 (setq char
(code-char ichar
))
435 (when (constituentp char
)
436 (set-cmt-entry char nil
)))
438 (/show0
"leaving !cold-init-standard-readtable"))
440 ;;;; implementation of the read buffer
442 (defvar *read-buffer
*)
444 (defvar *inch-ptr
*) ; *OUCH-PTR* always points to next char to write.
445 (defvar *ouch-ptr
*) ; *INCH-PTR* always points to next char to read.
447 (declaim (type index
*inch-ptr
* *ouch-ptr
*))
448 (declaim (type (simple-array character
(*)) *read-buffer
*))
450 (declaim (inline reset-read-buffer
))
451 (defun reset-read-buffer ()
452 ;; Turn *READ-BUFFER* into an empty read buffer.
456 (declaim (inline ouch-read-buffer
))
457 (defun ouch-read-buffer (char)
458 ;; When buffer overflow
459 (let ((op *ouch-ptr
*))
460 (declare (optimize (sb!c
::insert-array-bounds-checks
0)))
461 (when (>= op
(length *read-buffer
*))
462 ;; Size should be doubled.
464 (setf (elt *read-buffer
* op
) char
)
465 (setq *ouch-ptr
* (1+ op
))))
467 (defun grow-read-buffer ()
468 (let* ((rbl (length *read-buffer
*))
469 (new-length (* 2 rbl
))
470 (new-buffer (make-string new-length
)))
471 (setq *read-buffer
* (replace new-buffer
*read-buffer
*))))
473 (defun inch-read-buffer ()
474 (if (>= *inch-ptr
* *ouch-ptr
*)
477 (elt *read-buffer
* *inch-ptr
*)
480 (declaim (inline unread-buffer
))
481 (defun unread-buffer ()
484 (declaim (inline read-unwind-read-buffer
))
485 (defun read-unwind-read-buffer ()
486 ;; Keep contents, but make next (INCH..) return first character.
489 (defun read-buffer-to-string ()
490 (subseq *read-buffer
* 0 *ouch-ptr
*))
492 (defmacro with-read-buffer
(() &body body
)
493 `(let* ((*read-buffer
* (make-string 128))
498 (declaim (inline read-buffer-boundp
))
499 (defun read-buffer-boundp ()
500 (and (boundp '*read-buffer
*)
502 (boundp '*inch-ptr
*)))
504 (defun check-for-recursive-read (stream recursive-p operator-name
)
505 (when (and recursive-p
(not (read-buffer-boundp)))
508 "~A was invoked with RECURSIVE-P being true outside ~
509 of a recursive read operation."
512 ;;;; READ-PRESERVING-WHITESPACE, READ-DELIMITED-LIST, and READ
514 ;;; an alist for #=, used to keep track of objects with labels assigned that
515 ;;; have been completely read. Each entry is (integer-tag gensym-tag value).
517 ;;; KLUDGE: Should this really be an alist? It seems as though users
518 ;;; could reasonably expect N log N performance for large datasets.
519 ;;; On the other hand, it's probably very very seldom a problem in practice.
520 ;;; On the third hand, it might be just as easy to use a hash table
521 ;;; as an alist, so maybe we should. -- WHN 19991202
522 (defvar *sharp-equal-alist
* ())
524 (declaim (special *standard-input
*))
526 ;;; Like READ-PRESERVING-WHITESPACE, but doesn't check the read buffer
527 ;;; for being set up properly.
528 (defun %read-preserving-whitespace
(stream eof-error-p eof-value recursive-p
)
530 ;; a loop for repeating when a macro returns nothing
532 (let ((char (read-char stream eof-error-p
*eof-object
*)))
533 (cond ((eofp char
) (return eof-value
))
534 ((whitespace[2]p char))
536 (let* ((macrofun (get-coerced-cmt-entry char *readtable*))
537 (result (multiple-value-list
538 (funcall macrofun stream char))))
539 ;; Repeat if macro returned nothing.
541 (return (unless *read-suppress* (car result)))))))))
542 (let ((*sharp-equal-alist* nil))
544 (%read-preserving-whitespace stream eof-error-p eof-value t)))))
546 ;;; READ-PRESERVING-WHITESPACE behaves just like READ, only it makes
547 ;;; sure to leave terminating whitespace in the stream. (This is a
548 ;;; COMMON-LISP exported symbol.)
549 (defun read-preserving-whitespace (&optional (stream *standard-input*)
554 "Read from STREAM and return the value read, preserving any whitespace
555 that followed the object."
556 (check-for-recursive-read stream recursive-p 'read-preserving-whitespace)
557 (%read-preserving-whitespace stream eof-error-p eof-value recursive-p))
559 ;;; Return NIL or a list with one thing, depending.
561 ;;; for functions that want comments to return so that they can look
562 ;;; past them. We assume CHAR is not whitespace.
563 (defun read-maybe-nothing (stream char)
564 (let ((retval (multiple-value-list
565 (funcall (get-coerced-cmt-entry char *readtable*)
568 (if retval (rplacd retval nil))))
570 (defun read (&optional (stream *standard-input*)
575 "Read the next Lisp value from STREAM, and return it."
576 (check-for-recursive-read stream recursive-p 'read)
577 (let ((result (%read-preserving-whitespace stream eof-error-p eof-value
579 ;; This function generally discards trailing whitespace. If you
580 ;; don't want to discard trailing whitespace, call
581 ;; CL:READ-PRESERVING-WHITESPACE instead.
582 (unless (or (eql result eof-value) recursive-p)
583 (let ((next-char (read-char stream nil nil)))
584 (unless (or (null next-char)
585 (whitespace[2]p next-char
))
586 (unread-char next-char stream
))))
589 ;;; (This is a COMMON-LISP exported symbol.)
590 (defun read-delimited-list (endchar &optional
591 (input-stream *standard-input
*)
594 "Read Lisp values from INPUT-STREAM until the next character after a
595 value's representation is ENDCHAR, and return the objects as a list."
596 (check-for-recursive-read input-stream recursive-p
'read-delimited-list
)
597 (flet ((%read-delimited-list
(endchar input-stream
)
598 (do ((char (flush-whitespace input-stream
)
599 (flush-whitespace input-stream
))
601 ((char= char endchar
)
602 (unless *read-suppress
* (nreverse retlist
)))
603 (setq retlist
(nconc (read-maybe-nothing input-stream char
)
605 (declare (inline %read-delimited-list
))
607 (%read-delimited-list endchar input-stream
)
609 (%read-delimited-list endchar input-stream
)))))
611 ;;;; basic readmacro definitions
613 ;;;; Some large, hairy subsets of readmacro definitions (backquotes
614 ;;;; and sharp macros) are not here, but in their own source files.
616 (defun read-quote (stream ignore
)
617 (declare (ignore ignore
))
618 (list 'quote
(read stream t nil t
)))
620 (defun read-comment (stream ignore
)
621 (declare (ignore ignore
))
623 ((character-decoding-error
624 #'(lambda (decoding-error)
625 (declare (ignorable decoding-error
))
627 'sb
!kernel
::character-decoding-error-in-macro-char-comment
628 :position
(file-position stream
) :stream stream
)
629 (invoke-restart 'attempt-resync
))))
630 (let ((stream (in-synonym-of stream
)))
631 (if (ansi-stream-p stream
)
632 (prepare-for-fast-read-char stream
633 (do ((char (fast-read-char nil nil
)
634 (fast-read-char nil nil
)))
635 ((or (not char
) (char= char
#\newline
))
636 (done-with-fast-read-char))))
638 (do ((char (read-char stream nil
:eof
) (read-char stream nil
:eof
)))
639 ((or (eq char
:eof
) (char= char
#\newline
)))))))
640 ;; Don't return anything.
643 (defun read-list (stream ignore
)
644 (declare (ignore ignore
))
645 (let* ((thelist (list nil
))
647 (do ((firstchar (flush-whitespace stream
) (flush-whitespace stream
)))
648 ((char= firstchar
#\
) ) (cdr thelist
))
649 (when (char= firstchar
#\.
)
650 (let ((nextchar (read-char stream t
)))
651 (cond ((token-delimiterp nextchar
)
652 (cond ((eq listtail thelist
)
653 (unless *read-suppress
*
656 "Nothing appears before . in list.")))
657 ((whitespace[2]p nextchar)
658 (setq nextchar (flush-whitespace stream))))
660 ;; Return list containing last thing.
661 (car (read-after-dot stream nextchar)))
662 (return (cdr thelist)))
663 ;; Put back NEXTCHAR so that we can read it normally.
664 (t (unread-char nextchar stream)))))
665 ;; Next thing is not an isolated dot.
666 (let ((listobj (read-maybe-nothing stream firstchar)))
667 ;; allows the possibility that a comment was read
669 (rplacd listtail listobj)
670 (setq listtail listobj))))))
672 (defun read-after-dot (stream firstchar)
673 ;; FIRSTCHAR is non-whitespace!
675 (do ((char firstchar (flush-whitespace stream)))
678 (return-from read-after-dot nil)
679 (simple-reader-error stream "Nothing appears after . in list.")))
680 ;; See whether there's something there.
681 (setq lastobj (read-maybe-nothing stream char))
682 (when lastobj (return t)))
683 ;; At least one thing appears after the dot.
684 ;; Check for more than one thing following dot.
685 (do ((lastchar (flush-whitespace stream)
686 (flush-whitespace stream)))
687 ((char= lastchar #\) ) lastobj) ;success!
688 ;; Try reading virtual whitespace.
689 (if (and (read-maybe-nothing stream lastchar)
690 (not *read-suppress*))
691 (simple-reader-error stream
692 "More than one object follows . in list.")))))
694 (defun read-string (stream closech)
695 ;; This accumulates chars until it sees same char that invoked it.
696 ;; For a very long string, this could end up bloating the read buffer.
698 (let ((stream (in-synonym-of stream)))
699 (if (ansi-stream-p stream)
700 (prepare-for-fast-read-char stream
701 (do ((char (fast-read-char t) (fast-read-char t)))
702 ((char= char closech)
703 (done-with-fast-read-char))
704 (if (single-escape-p char) (setq char (fast-read-char t)))
705 (ouch-read-buffer char)))
707 (do ((char (read-char stream nil :eof) (read-char stream nil :eof)))
708 ((or (eq char :eof) (char= char closech))
710 (error 'end-of-file :stream stream)))
711 (when (single-escape-p char)
712 (setq char (read-char stream nil :eof))
714 (error 'end-of-file :stream stream)))
715 (ouch-read-buffer char))))
716 (read-buffer-to-string))
718 (defun read-right-paren (stream ignore)
719 (declare (ignore ignore))
720 (simple-reader-error stream "unmatched close parenthesis"))
722 ;;; Read from the stream up to the next delimiter. Leave the resulting
723 ;;; token in *READ-BUFFER*, and return two values:
724 ;;; -- a list of the escaped character positions, and
725 ;;; -- The position of the first package delimiter (or NIL).
726 (defun internal-read-extended-token (stream firstchar escape-firstchar)
729 (when escape-firstchar
730 (push *ouch-ptr* escapes)
731 (ouch-read-buffer firstchar)
732 (setq firstchar (read-char stream nil *eof-object*)))
733 (do ((char firstchar (read-char stream nil *eof-object*))
735 ((cond ((eofp char) t)
736 ((token-delimiterp char)
737 (unread-char char stream)
740 (values escapes colon))
741 (cond ((single-escape-p char)
742 ;; It can't be a number, even if it's 1\23.
743 ;; Read next char here, so it won't be casified.
744 (push *ouch-ptr* escapes)
745 (let ((nextchar (read-char stream nil *eof-object*)))
747 (reader-eof-error stream "after escape character")
748 (ouch-read-buffer nextchar))))
749 ((multiple-escape-p char)
750 ;; Read to next multiple-escape, escaping single chars
753 (let ((ch (read-char stream nil *eof-object*)))
756 (reader-eof-error stream "inside extended token"))
757 ((multiple-escape-p ch) (return))
758 ((single-escape-p ch)
759 (let ((nextchar (read-char stream nil *eof-object*)))
760 (cond ((eofp nextchar)
761 (reader-eof-error stream "after escape character"))
763 (push *ouch-ptr* escapes)
764 (ouch-read-buffer nextchar)))))
766 (push *ouch-ptr* escapes)
767 (ouch-read-buffer ch))))))
769 (when (and (constituentp char)
770 (eql (get-constituent-trait char)
771 +char-attr-package-delimiter+)
773 (setq colon *ouch-ptr*))
774 (ouch-read-buffer char))))))
776 ;;;; character classes
778 ;;; Return the character class for CHAR.
780 ;;; FIXME: why aren't these ATT-getting forms using GET-CAT-ENTRY?
781 ;;; Because we've cached the readtable tables?
782 (defmacro char-class (char attarray atthash)
783 `(let ((att (if (typep ,char 'base-char)
784 (aref ,attarray (char-code ,char))
785 (gethash ,char ,atthash +char-attr-constituent+))))
786 (declare (fixnum att))
788 ((<= att +char-attr-terminating-macro+) +char-attr-delimiter+)
789 ((< att +char-attr-constituent+) att)
790 (t (setf att (get-constituent-trait ,char))
791 (if (= att +char-attr-invalid+)
792 (simple-reader-error stream "invalid constituent")
795 ;;; Return the character class for CHAR, which might be part of a
797 (defmacro char-class2 (char attarray atthash)
798 `(let ((att (if (typep ,char 'base-char)
799 (aref ,attarray (char-code ,char))
800 (gethash ,char ,atthash +char-attr-constituent+))))
801 (declare (fixnum att))
803 ((<= att +char-attr-terminating-macro+) +char-attr-delimiter+)
804 ((< att +char-attr-constituent+) att)
805 (t (setf att (get-constituent-trait ,char))
807 ((digit-char-p ,char *read-base*) +char-attr-constituent-digit+)
808 ((= att +char-attr-constituent-digit+) +char-attr-constituent+)
809 ((= att +char-attr-invalid+)
810 (simple-reader-error stream "invalid constituent"))
813 ;;; Return the character class for a char which might be part of a
814 ;;; rational or floating number. (Assume that it is a digit if it
816 (defmacro char-class3 (char attarray atthash)
817 `(let ((att (if (typep ,char 'base-char)
818 (aref ,attarray (char-code ,char))
819 (gethash ,char ,atthash +char-attr-constituent+))))
820 (declare (fixnum att))
822 ((<= att +char-attr-terminating-macro+) +char-attr-delimiter+)
823 ((< att +char-attr-constituent+) att)
824 (t (setf att (get-constituent-trait ,char))
825 (when possibly-rational
826 (setq possibly-rational
827 (or (digit-char-p ,char *read-base*)
828 (= att +char-attr-constituent-slash+))))
831 (or (digit-char-p ,char 10)
832 (= att +char-attr-constituent-dot+))))
834 ((digit-char-p ,char (max *read-base* 10))
835 (if (digit-char-p ,char *read-base*)
836 (if (= att +char-attr-constituent-expt+)
837 +char-attr-constituent-digit-or-expt+
838 +char-attr-constituent-digit+)
839 +char-attr-constituent-decimal-digit+))
840 ((= att +char-attr-invalid+)
841 (simple-reader-error stream "invalid constituent"))
846 (defvar *read-suppress* nil
848 "Suppress most interpreting in the reader when T.")
850 (defvar *read-base* 10
852 "the radix that Lisp reads numbers in")
853 (declaim (type (integer 2 36) *read-base*))
855 ;;; Modify the read buffer according to READTABLE-CASE, ignoring
856 ;;; ESCAPES. ESCAPES is a list of the escaped indices, in reverse
858 (defun casify-read-buffer (escapes)
859 (let ((case (readtable-case *readtable*)))
861 ((and (null escapes) (eq case :upcase))
862 ;; Pull the special variable access out of the loop.
863 (let ((buffer *read-buffer*))
864 (dotimes (i *ouch-ptr*)
865 (declare (optimize (sb!c::insert-array-bounds-checks 0)))
866 (setf (schar buffer i) (char-upcase (schar buffer i))))))
867 ((eq case :preserve))
869 (macrolet ((skip-esc (&body body)
870 `(do ((i (1- *ouch-ptr*) (1- i))
871 (buffer *read-buffer*)
875 (optimize (sb!c::insert-array-bounds-checks 0)))
876 (when (or (null escapes)
877 (let ((esc (first escapes)))
878 (declare (fixnum esc))
884 (let ((ch (schar buffer i)))
887 (skip-esc (setf (schar buffer i) (char-downcase ch))))
889 (skip-esc (setf (schar buffer i) (char-upcase ch)))))
892 (:downcase (lower-em))
897 (when (both-case-p ch)
898 (if (upper-case-p ch)
900 (setq all-upper nil))))
901 (cond (all-lower (raise-em))
902 (all-upper (lower-em))))))))))))
904 (defun read-token (stream firstchar)
906 "This function is just an fsm that recognizes numbers and symbols."
907 ;; Check explicitly whether FIRSTCHAR has an entry for
908 ;; NON-TERMINATING in CHARACTER-ATTRIBUTE-TABLE and
909 ;; READ-DOT-NUMBER-SYMBOL in CMT. Report an error if these are
910 ;; violated. (If we called this, we want something that is a
911 ;; legitimate token!) Read in the longest possible string satisfying
912 ;; the Backus-Naur form for "unqualified-token". Leave the result in
913 ;; the *READ-BUFFER*. Return next char after token (last char read).
914 (when *read-suppress*
915 (internal-read-extended-token stream firstchar nil)
916 (return-from read-token nil))
917 (let ((attribute-array (character-attribute-array *readtable*))
918 (attribute-hash-table (character-attribute-hash-table *readtable*))
919 (package-designator nil)
921 (possibly-rational t)
922 (seen-digit-or-expt nil)
924 (was-possibly-float nil)
926 (seen-multiple-escapes nil))
928 (prog ((char firstchar))
929 (case (char-class3 char attribute-array attribute-hash-table)
930 (#.+char-attr-constituent-sign+ (go SIGN))
931 (#.+char-attr-constituent-digit+ (go LEFTDIGIT))
932 (#.+char-attr-constituent-digit-or-expt+
933 (setq seen-digit-or-expt t)
935 (#.+char-attr-constituent-decimal-digit+ (go LEFTDECIMALDIGIT))
936 (#.+char-attr-constituent-dot+ (go FRONTDOT))
937 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
938 (#.+char-attr-package-delimiter+ (go COLON))
939 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
940 (#.+char-attr-invalid+ (simple-reader-error stream
941 "invalid constituent"))
942 ;; can't have eof, whitespace, or terminating macro as first char!
945 (ouch-read-buffer char)
946 (setq char (read-char stream nil nil))
947 (unless char (go RETURN-SYMBOL))
948 (setq possibly-rational t
950 (case (char-class3 char attribute-array attribute-hash-table)
951 (#.+char-attr-constituent-digit+ (go LEFTDIGIT))
952 (#.+char-attr-constituent-digit-or-expt+
953 (setq seen-digit-or-expt t)
955 (#.+char-attr-constituent-decimal-digit+ (go LEFTDECIMALDIGIT))
956 (#.+char-attr-constituent-dot+ (go SIGNDOT))
957 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
958 (#.+char-attr-package-delimiter+ (go COLON))
959 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
960 (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
962 LEFTDIGIT ; saw "[sign] {digit}+"
963 (ouch-read-buffer char)
964 (setq char (read-char stream nil nil))
965 (unless char (return (make-integer)))
966 (setq was-possibly-float possibly-float)
967 (case (char-class3 char attribute-array attribute-hash-table)
968 (#.+char-attr-constituent-digit+ (go LEFTDIGIT))
969 (#.+char-attr-constituent-decimal-digit+ (if possibly-float
970 (go LEFTDECIMALDIGIT)
972 (#.+char-attr-constituent-dot+ (if possibly-float
975 (#.+char-attr-constituent-digit-or-expt+
976 (if (or seen-digit-or-expt (not was-possibly-float))
977 (progn (setq seen-digit-or-expt t) (go LEFTDIGIT))
978 (progn (setq seen-digit-or-expt t) (go LEFTDIGIT-OR-EXPT))))
979 (#.+char-attr-constituent-expt+
980 (if was-possibly-float
983 (#.+char-attr-constituent-slash+ (if possibly-rational
986 (#.+char-attr-delimiter+ (unread-char char stream)
987 (return (make-integer)))
988 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
989 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
990 (#.+char-attr-package-delimiter+ (go COLON))
993 (ouch-read-buffer char)
994 (setq char (read-char stream nil nil))
995 (unless char (return (make-integer)))
996 (case (char-class3 char attribute-array attribute-hash-table)
997 (#.+char-attr-constituent-digit+ (go LEFTDIGIT))
998 (#.+char-attr-constituent-decimal-digit+ (bug "impossible!"))
999 (#.+char-attr-constituent-dot+ (go SYMBOL))
1000 (#.+char-attr-constituent-digit-or-expt+ (go LEFTDIGIT))
1001 (#.+char-attr-constituent-expt+ (go SYMBOL))
1002 (#.+char-attr-constituent-sign+ (go EXPTSIGN))
1003 (#.+char-attr-constituent-slash+ (if possibly-rational
1006 (#.+char-attr-delimiter+ (unread-char char stream)
1007 (return (make-integer)))
1008 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1009 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1010 (#.+char-attr-package-delimiter+ (go COLON))
1012 LEFTDECIMALDIGIT ; saw "[sign] {decimal-digit}+"
1013 (aver possibly-float)
1014 (ouch-read-buffer char)
1015 (setq char (read-char stream nil nil))
1016 (unless char (go RETURN-SYMBOL))
1017 (case (char-class char attribute-array attribute-hash-table)
1018 (#.+char-attr-constituent-digit+ (go LEFTDECIMALDIGIT))
1019 (#.+char-attr-constituent-dot+ (go MIDDLEDOT))
1020 (#.+char-attr-constituent-expt+ (go EXPONENT))
1021 (#.+char-attr-constituent-slash+ (aver (not possibly-rational))
1023 (#.+char-attr-delimiter+ (unread-char char stream)
1025 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1026 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1027 (#.+char-attr-package-delimiter+ (go COLON))
1029 MIDDLEDOT ; saw "[sign] {digit}+ dot"
1030 (ouch-read-buffer char)
1031 (setq char (read-char stream nil nil))
1032 (unless char (return (let ((*read-base* 10))
1034 (case (char-class char attribute-array attribute-hash-table)
1035 (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
1036 (#.+char-attr-constituent-expt+ (go EXPONENT))
1037 (#.+char-attr-delimiter+
1038 (unread-char char stream)
1039 (return (let ((*read-base* 10))
1041 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1042 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1043 (#.+char-attr-package-delimiter+ (go COLON))
1045 RIGHTDIGIT ; saw "[sign] {decimal-digit}* dot {digit}+"
1046 (ouch-read-buffer char)
1047 (setq char (read-char stream nil nil))
1048 (unless char (return (make-float stream)))
1049 (case (char-class char attribute-array attribute-hash-table)
1050 (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
1051 (#.+char-attr-constituent-expt+ (go EXPONENT))
1052 (#.+char-attr-delimiter+
1053 (unread-char char stream)
1054 (return (make-float stream)))
1055 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1056 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1057 (#.+char-attr-package-delimiter+ (go COLON))
1059 SIGNDOT ; saw "[sign] dot"
1060 (ouch-read-buffer char)
1061 (setq char (read-char stream nil nil))
1062 (unless char (go RETURN-SYMBOL))
1063 (case (char-class char attribute-array attribute-hash-table)
1064 (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
1065 (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
1066 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1067 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1069 FRONTDOT ; saw "dot"
1070 (ouch-read-buffer char)
1071 (setq char (read-char stream nil nil))
1072 (unless char (simple-reader-error stream "dot context error"))
1073 (case (char-class char attribute-array attribute-hash-table)
1074 (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
1075 (#.+char-attr-constituent-dot+ (go DOTS))
1076 (#.+char-attr-delimiter+ (simple-reader-error stream
1077 "dot context error"))
1078 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1079 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1080 (#.+char-attr-package-delimiter+ (go COLON))
1083 (ouch-read-buffer char)
1084 (setq char (read-char stream nil nil))
1085 (unless char (go RETURN-SYMBOL))
1086 (setq possibly-float t)
1087 (case (char-class char attribute-array attribute-hash-table)
1088 (#.+char-attr-constituent-sign+ (go EXPTSIGN))
1089 (#.+char-attr-constituent-digit+ (go EXPTDIGIT))
1090 (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
1091 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1092 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1093 (#.+char-attr-package-delimiter+ (go COLON))
1095 EXPTSIGN ; got to EXPONENT, and saw a sign character
1096 (ouch-read-buffer char)
1097 (setq char (read-char stream nil nil))
1098 (unless char (go RETURN-SYMBOL))
1099 (case (char-class char attribute-array attribute-hash-table)
1100 (#.+char-attr-constituent-digit+ (go EXPTDIGIT))
1101 (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
1102 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1103 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1104 (#.+char-attr-package-delimiter+ (go COLON))
1106 EXPTDIGIT ; got to EXPONENT, saw "[sign] {digit}+"
1107 (ouch-read-buffer char)
1108 (setq char (read-char stream nil nil))
1109 (unless char (return (make-float stream)))
1110 (case (char-class char attribute-array attribute-hash-table)
1111 (#.+char-attr-constituent-digit+ (go EXPTDIGIT))
1112 (#.+char-attr-delimiter+
1113 (unread-char char stream)
1114 (return (make-float stream)))
1115 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1116 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1117 (#.+char-attr-package-delimiter+ (go COLON))
1119 RATIO ; saw "[sign] {digit}+ slash"
1120 (ouch-read-buffer char)
1121 (setq char (read-char stream nil nil))
1122 (unless char (go RETURN-SYMBOL))
1123 (case (char-class2 char attribute-array attribute-hash-table)
1124 (#.+char-attr-constituent-digit+ (go RATIODIGIT))
1125 (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
1126 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1127 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1128 (#.+char-attr-package-delimiter+ (go COLON))
1130 RATIODIGIT ; saw "[sign] {digit}+ slash {digit}+"
1131 (ouch-read-buffer char)
1132 (setq char (read-char stream nil nil))
1133 (unless char (return (make-ratio stream)))
1134 (case (char-class2 char attribute-array attribute-hash-table)
1135 (#.+char-attr-constituent-digit+ (go RATIODIGIT))
1136 (#.+char-attr-delimiter+
1137 (unread-char char stream)
1138 (return (make-ratio stream)))
1139 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1140 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1141 (#.+char-attr-package-delimiter+ (go COLON))
1143 DOTS ; saw "dot {dot}+"
1144 (ouch-read-buffer char)
1145 (setq char (read-char stream nil nil))
1146 (unless char (simple-reader-error stream "too many dots"))
1147 (case (char-class char attribute-array attribute-hash-table)
1148 (#.+char-attr-constituent-dot+ (go DOTS))
1149 (#.+char-attr-delimiter+
1150 (unread-char char stream)
1151 (simple-reader-error stream "too many dots"))
1152 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1153 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1154 (#.+char-attr-package-delimiter+ (go COLON))
1156 SYMBOL ; not a dot, dots, or number
1157 (let ((stream (in-synonym-of stream)))
1158 (if (ansi-stream-p stream)
1159 (prepare-for-fast-read-char stream
1162 (ouch-read-buffer char)
1163 (setq char (fast-read-char nil nil))
1164 (unless char (go RETURN-SYMBOL))
1165 (case (char-class char attribute-array attribute-hash-table)
1166 (#.+char-attr-single-escape+ (done-with-fast-read-char)
1168 (#.+char-attr-delimiter+ (done-with-fast-read-char)
1169 (unread-char char stream)
1171 (#.+char-attr-multiple-escape+ (done-with-fast-read-char)
1173 (#.+char-attr-package-delimiter+ (done-with-fast-read-char)
1175 (t (go SYMBOL-LOOP)))))
1179 (ouch-read-buffer char)
1180 (setq char (read-char stream nil :eof))
1181 (when (eq char :eof) (go RETURN-SYMBOL))
1182 (case (char-class char attribute-array attribute-hash-table)
1183 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1184 (#.+char-attr-delimiter+ (unread-char char stream)
1186 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1187 (#.+char-attr-package-delimiter+ (go COLON))
1188 (t (go SYMBOL-LOOP))))))
1189 SINGLE-ESCAPE ; saw a single-escape
1190 ;; Don't put the escape character in the read buffer.
1191 ;; READ-NEXT CHAR, put in buffer (no case conversion).
1192 (let ((nextchar (read-char stream nil nil)))
1194 (reader-eof-error stream "after single-escape character"))
1195 (push *ouch-ptr* escapes)
1196 (ouch-read-buffer nextchar))
1197 (setq char (read-char stream nil nil))
1198 (unless char (go RETURN-SYMBOL))
1199 (case (char-class char attribute-array attribute-hash-table)
1200 (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
1201 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1202 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1203 (#.+char-attr-package-delimiter+ (go COLON))
1206 (setq seen-multiple-escapes t)
1207 (do ((char (read-char stream t) (read-char stream t)))
1208 ((multiple-escape-p char))
1209 (if (single-escape-p char) (setq char (read-char stream t)))
1210 (push *ouch-ptr* escapes)
1211 (ouch-read-buffer char))
1212 (setq char (read-char stream nil nil))
1213 (unless char (go RETURN-SYMBOL))
1214 (case (char-class char attribute-array attribute-hash-table)
1215 (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
1216 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1217 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1218 (#.+char-attr-package-delimiter+ (go COLON))
1221 (casify-read-buffer escapes)
1222 (unless (zerop colons)
1223 (simple-reader-error stream
1224 "too many colons in ~S"
1225 (read-buffer-to-string)))
1227 (setq package-designator
1228 (if (plusp *ouch-ptr*)
1229 ;; FIXME: It seems inefficient to cons up a package
1230 ;; designator string every time we read a symbol with an
1231 ;; explicit package prefix. Perhaps we could implement
1232 ;; a FIND-PACKAGE* function analogous to INTERN*
1234 (read-buffer-to-string)
1235 (if seen-multiple-escapes
1236 (read-buffer-to-string)
1237 *keyword-package*)))
1240 (setq char (read-char stream nil nil))
1241 (unless char (reader-eof-error stream "after reading a colon"))
1242 (case (char-class char attribute-array attribute-hash-table)
1243 (#.+char-attr-delimiter+
1244 (unread-char char stream)
1245 (simple-reader-error stream
1246 "illegal terminating character after a colon: ~S"
1248 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1249 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1250 (#.+char-attr-package-delimiter+ (go INTERN))
1254 (setq char (read-char stream nil nil))
1256 (reader-eof-error stream "after reading a colon"))
1257 (case (char-class char attribute-array attribute-hash-table)
1258 (#.+char-attr-delimiter+
1259 (unread-char char stream)
1260 (simple-reader-error stream
1261 "illegal terminating character after a colon: ~S"
1263 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1264 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1265 (#.+char-attr-package-delimiter+
1266 (simple-reader-error stream
1267 "too many colons after ~S name"
1268 package-designator))
1271 (casify-read-buffer escapes)
1272 (let ((found (if package-designator
1273 (find-package package-designator)
1276 (error 'simple-reader-package-error :stream stream
1277 :format-arguments (list package-designator)
1278 :format-control "package ~S not found"))
1280 (if (or (zerop colons) (= colons 2) (eq found *keyword-package*))
1281 (return (intern* *read-buffer* *ouch-ptr* found))
1282 (multiple-value-bind (symbol test)
1283 (find-symbol* *read-buffer* *ouch-ptr* found)
1284 (when (eq test :external) (return symbol))
1285 (let ((name (read-buffer-to-string)))
1286 (with-simple-restart (continue "Use symbol anyway.")
1287 (error 'simple-reader-package-error :stream stream
1288 :format-arguments (list name (package-name found))
1291 "The symbol ~S is not external in the ~A package."
1292 "Symbol ~S not found in the ~A package.")))
1293 (return (intern name found)))))))))
1295 ;;; for semi-external use:
1297 ;;; For semi-external use: Return 3 values: the string for the token,
1298 ;;; a flag for whether there was an escape char, and the position of
1299 ;;; any package delimiter.
1300 (defun read-extended-token (stream &optional (*readtable* *readtable*))
1301 (let ((first-char (read-char stream nil nil t)))
1303 (multiple-value-bind (escapes colon)
1304 (internal-read-extended-token stream first-char nil)
1305 (casify-read-buffer escapes)
1306 (values (read-buffer-to-string) (not (null escapes)) colon)))
1308 (values "" nil nil)))))
1310 ;;; for semi-external use:
1312 ;;; Read an extended token with the first character escaped. Return
1313 ;;; the string for the token.
1314 (defun read-extended-token-escaped (stream &optional (*readtable* *readtable*))
1315 (let ((first-char (read-char stream nil nil)))
1317 (let ((escapes (internal-read-extended-token stream first-char t)))
1318 (casify-read-buffer escapes)
1319 (read-buffer-to-string)))
1321 (reader-eof-error stream "after escape")))))
1323 ;;;; number-reading functions
1325 (defmacro digit* nil
1326 `(do ((ch char (inch-read-buffer)))
1327 ((or (eofp ch) (not (digit-char-p ch))) (setq char ch))
1328 ;; Report if at least one digit is seen.
1329 (setq one-digit t)))
1331 (defmacro exponent-letterp (letter)
1332 `(memq ,letter '(#\E #\S #\F #\L #\D #\e #\s #\f #\l #\d)))
1334 ;;; FIXME: It would be cleaner to have these generated automatically
1335 ;;; by compile-time code instead of having them hand-created like
1336 ;;; this. The !COLD-INIT-INTEGER-READER code below should be resurrected
1338 (defvar *integer-reader-safe-digits*
1340 26 17 13 11 10 9 8 8 8 7 7 7 7 6 6 6 6 6 6 6 6 5 5 5 5 5 5 5 5 5 5 5 5 5 5)
1342 "the mapping of base to 'safe' number of digits to read for a fixnum")
1343 (defvar *integer-reader-base-power*
1345 67108864 129140163 67108864 48828125 60466176 40353607
1346 16777216 43046721 100000000 19487171 35831808 62748517 105413504 11390625
1347 16777216 24137569 34012224 47045881 64000000 85766121 113379904 6436343
1348 7962624 9765625 11881376 14348907 17210368 20511149 24300000 28629151
1349 33554432 39135393 45435424 52521875 60466176)
1351 "the largest fixnum power of the base for MAKE-INTEGER")
1352 (declaim (simple-vector *integer-reader-safe-digits*
1353 *integer-reader-base-power*))
1355 (defun !cold-init-integer-reader ()
1356 (do ((base 2 (1+ base)))
1359 (do ((fix (truncate most-positive-fixnum base)
1360 (truncate fix base))
1361 (digits 0 (1+ digits)))
1362 ((zerop fix) digits))))
1363 (setf (aref *integer-reader-safe-digits* base)
1365 (aref *integer-reader-base-power* base)
1366 (expt base digits)))))
1369 (defun make-integer ()
1371 "Minimizes bignum-fixnum multiplies by reading a 'safe' number of digits,
1372 then multiplying by a power of the base and adding."
1373 (let* ((base *read-base*)
1374 (digits-per (aref *integer-reader-safe-digits* base))
1375 (base-power (aref *integer-reader-base-power* base))
1378 (declare (type index digits-per base-power))
1379 (read-unwind-read-buffer)
1380 (let ((char (inch-read-buffer)))
1381 (cond ((char= char #\-)
1384 (t (unread-buffer))))
1387 (declare (type index num))
1388 (dotimes (digit digits-per)
1389 (let* ((ch (inch-read-buffer)))
1390 (cond ((or (eofp ch) (char= ch #\.))
1391 (return-from make-integer
1393 (if (zerop number) num
1395 (expt base digit))))))
1396 (if negativep (- res) res))))
1397 (t (setq num (+ (digit-char-p ch base)
1398 (the index (* num base))))))))
1399 (setq number (+ num (* number base-power)))))))
1401 (defun make-float (stream)
1402 ;; Assume that the contents of *read-buffer* are a legal float, with nothing
1404 (read-unwind-read-buffer)
1405 (let ((negative-fraction nil)
1408 (negative-exponent nil)
1411 (char (inch-read-buffer)))
1412 (if (cond ((char= char #\+) t)
1413 ((char= char #\-) (setq negative-fraction t)))
1415 (setq char (inch-read-buffer)))
1416 ;; Read digits before the dot.
1417 (do* ((ch char (inch-read-buffer))
1418 (dig (digit-char-p ch) (digit-char-p ch)))
1419 ((not dig) (setq char ch))
1420 (setq number (+ (* number 10) dig)))
1421 ;; Deal with the dot, if it's there.
1422 (when (char= char #\.)
1423 (setq char (inch-read-buffer))
1424 ;; Read digits after the dot.
1425 (do* ((ch char (inch-read-buffer))
1426 (dig (and (not (eofp ch)) (digit-char-p ch))
1427 (and (not (eofp ch)) (digit-char-p ch))))
1428 ((not dig) (setq char ch))
1429 (setq divisor (* divisor 10))
1430 (setq number (+ (* number 10) dig))))
1431 ;; Is there an exponent letter?
1433 ;; If not, we've read the whole number.
1434 (let ((num (make-float-aux number divisor
1435 *read-default-float-format*
1437 (return-from make-float (if negative-fraction (- num) num))))
1438 ((exponent-letterp char)
1439 (setq float-char char)
1441 (setq char (inch-read-buffer))
1442 ;; Check leading sign.
1443 (if (cond ((char= char #\+) t)
1444 ((char= char #\-) (setq negative-exponent t)))
1446 (setq char (inch-read-buffer)))
1447 ;; Read digits for exponent.
1448 (do* ((ch char (inch-read-buffer))
1449 (dig (and (not (eofp ch)) (digit-char-p ch))
1450 (and (not (eofp ch)) (digit-char-p ch))))
1452 (setq exponent (if negative-exponent (- exponent) exponent)))
1453 (setq exponent (+ (* exponent 10) dig)))
1454 ;; Generate and return the float, depending on FLOAT-CHAR:
1455 (let* ((float-format (case (char-upcase float-char)
1456 (#\E *read-default-float-format*)
1461 (result (make-float-aux (* (expt 10 exponent) number)
1462 divisor float-format stream)))
1463 (return-from make-float
1464 (if negative-fraction (- result) result))))
1465 (t (bug "bad fallthrough in floating point reader")))))
1467 (defun make-float-aux (number divisor float-format stream)
1469 (coerce (/ number divisor) float-format)
1471 (error 'reader-impossible-number-error
1472 :error c :stream stream
1473 :format-control "failed to build float"))))
1475 (defun make-ratio (stream)
1476 ;; Assume *READ-BUFFER* contains a legal ratio. Build the number from
1479 ;; Look for optional "+" or "-".
1480 (let ((numerator 0) (denominator 0) (char ()) (negative-number nil))
1481 (read-unwind-read-buffer)
1482 (setq char (inch-read-buffer))
1483 (cond ((char= char #\+)
1484 (setq char (inch-read-buffer)))
1486 (setq char (inch-read-buffer))
1487 (setq negative-number t)))
1489 (do* ((ch char (inch-read-buffer))
1490 (dig (digit-char-p ch *read-base*)
1491 (digit-char-p ch *read-base*)))
1493 (setq numerator (+ (* numerator *read-base*) dig)))
1495 (do* ((ch (inch-read-buffer) (inch-read-buffer))
1497 ((or (eofp ch) (not (setq dig (digit-char-p ch *read-base*)))))
1498 (setq denominator (+ (* denominator *read-base*) dig)))
1499 (let ((num (handler-case
1500 (/ numerator denominator)
1501 (arithmetic-error (c)
1502 (error 'reader-impossible-number-error
1503 :error c :stream stream
1504 :format-control "failed to build ratio")))))
1505 (if negative-number (- num) num))))
1507 ;;;; General reader for dispatch macros
1509 (defun dispatch-char-error (stream sub-char ignore)
1510 (declare (ignore ignore))
1513 (simple-reader-error stream
1514 "no dispatch function defined for ~S"
1517 (defun read-dispatch-char (stream char)
1518 ;; Read some digits.
1522 (do* ((ch (read-char stream nil *eof-object*)
1523 (read-char stream nil *eof-object*))
1526 (not (setq dig (digit-char-p ch))))
1527 ;; Take care of the extra char.
1529 (reader-eof-error stream "inside dispatch character")
1530 (setq sub-char (char-upcase ch))))
1532 (setq numarg (+ (* numarg 10) dig)))
1533 ;; Look up the function and call it.
1534 (let ((dpair (find char (dispatch-tables *readtable*)
1535 :test #'char= :key #'car)))
1537 (funcall (the function
1538 (gethash sub-char (cdr dpair) #'dispatch-char-error))
1539 stream sub-char (if numargp numarg nil))
1540 (simple-reader-error stream
1541 "no dispatch table for dispatch char")))))
1543 ;;;; READ-FROM-STRING
1545 (defun read-from-string (string &optional (eof-error-p t) eof-value
1547 preserve-whitespace)
1549 "The characters of string are successively given to the lisp reader
1550 and the lisp object built by the reader is returned. Macro chars
1552 (declare (string string))
1553 (with-array-data ((string string :offset-var offset)
1556 :check-fill-pointer t)
1557 (let ((stream (make-string-input-stream string start end)))
1558 (values (if preserve-whitespace
1559 (%read-preserving-whitespace stream eof-error-p eof-value nil)
1560 (read stream eof-error-p eof-value))
1561 (- (string-input-stream-current stream) offset)))))
1565 (defun parse-integer (string &key (start 0) end (radix 10) junk-allowed)
1567 "Examine the substring of string delimited by start and end
1568 (default to the beginning and end of the string) It skips over
1569 whitespace characters and then tries to parse an integer. The
1570 radix parameter must be between 2 and 36."
1571 (macrolet ((parse-error (format-control)
1572 `(error 'simple-parse-error
1573 :format-control ,format-control
1574 :format-arguments (list string))))
1575 (with-array-data ((string string :offset-var offset)
1578 :check-fill-pointer t)
1579 (let ((index (do ((i start (1+ i)))
1582 (return-from parse-integer (values nil end))
1583 (parse-error "no non-whitespace characters in string ~S.")))
1584 (declare (fixnum i))
1585 (unless (whitespace[1]p (char string i)) (return i))))
1589 (declare (fixnum index))
1590 (let ((char (char string index)))
1591 (cond ((char= char #\-)
1597 (when (= index end) (return nil))
1598 (let* ((char (char string index))
1599 (weight (digit-char-p char radix)))
1601 (setq result (+ weight (* result radix))
1603 (junk-allowed (return nil))
1604 ((whitespace[1]p char)
1607 (when (= index end) (return))
1608 (unless (whitespace[1]p (char string index))
1609 (parse-error "junk in string ~S")))
1612 (parse-error "junk in string ~S"))))
1616 (if minusp (- result) result)
1619 (parse-error "no digits in string ~S")))
1620 (- index offset))))))
1622 ;;;; reader initialization code
1624 (defun !reader-cold-init ()
1625 (!cold-init-constituent-trait-table)
1626 (!cold-init-standard-readtable)
1627 ;; FIXME: This was commented out, but should probably be restored.
1628 #+nil (!cold-init-integer-reader))
1630 (def!method print-object ((readtable readtable) stream)
1631 (print-unreadable-object (readtable stream :identity t :type t)))