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 ;;; If the initial value is changed from NIL to something more interesting,
33 ;;; be sure to update the duplicated definition in "src/code/print.lisp"
34 (defglobal *standard-readtable
* nil
)
36 ;;; In case we get an error trying to parse a symbol, we want to rebind the
37 ;;; above stuff so it's cool.
42 (defun reader-eof-error (stream context
)
43 (error 'reader-eof-error
47 ;;; If The Gods didn't intend for us to use multiple namespaces, why
48 ;;; did They specify them?
49 (defun simple-reader-error (stream control
&rest args
)
50 (error 'simple-reader-error
52 :format-control control
53 :format-arguments args
))
55 ;;;; macros and functions for character tables
57 (declaim (ftype (sfunction (character readtable
) (unsigned-byte 8))
59 (defun get-cat-entry (char rt
)
60 (if (typep char
'base-char
)
61 (elt (character-attribute-array rt
) (char-code char
))
62 (values (gethash char
(character-attribute-hash-table rt
)
63 +char-attr-constituent
+))))
65 (defun set-cat-entry (char newvalue
&optional
(rt *readtable
*))
66 (declare (character char
) (type (unsigned-byte 8) newvalue
) (readtable rt
))
67 (if (typep char
'base-char
)
68 (setf (elt (character-attribute-array rt
) (char-code char
)) newvalue
)
69 (if (= newvalue
+char-attr-constituent
+)
70 ;; Default value for the C-A-HASH-TABLE is +CHAR-ATTR-CONSTITUENT+.
71 (%remhash char
(character-attribute-hash-table rt
))
72 (setf (gethash char
(character-attribute-hash-table rt
)) newvalue
)))
75 ;; Set the character-macro-table entry without coercing NEW-VALUE.
76 ;; As used by set-syntax-from-char it must always process "raw" values.
77 (defun set-cmt-entry (char new-value
&optional
(rt *readtable
*))
78 (declare (character char
)
79 (type (or null function fdefn
) new-value
)
81 (if (typep char
'base-char
)
82 (setf (svref (character-macro-array rt
) (char-code char
)) new-value
)
83 (if new-value
; never store NILs
84 (setf (gethash char
(character-macro-hash-table rt
)) new-value
)
85 (remhash char
(character-macro-hash-table rt
)))))
87 ;;; the value actually stored in the character macro table. As per
88 ;;; ANSI #'GET-MACRO-CHARACTER and #'SET-MACRO-CHARACTER, this can
89 ;;; be either a function-designator or NIL, except that we store
90 ;;; symbols not as themselves but as their #<fdefn>.
91 (defun get-raw-cmt-entry (char readtable
)
92 (declare (character char
) (readtable readtable
))
93 (if (typep char
'base-char
)
94 (svref (character-macro-array readtable
) (char-code char
))
95 (values (gethash char
(character-macro-hash-table readtable
) nil
))))
97 ;; As above but get the entry for SUB-CHAR in a dispatching macro table.
98 (defun get-raw-cmt-dispatch-entry (sub-char sub-table
)
99 (declare (character sub-char
))
100 (if (typep sub-char
'base-char
)
101 (svref (truly-the (simple-vector #.base-char-code-limit
)
102 (cdr (truly-the cons sub-table
)))
103 (char-code sub-char
))
104 (awhen (car sub-table
)
105 (gethash sub-char it
))))
107 ;; Coerce THING to a character-macro-table entry
108 (defmacro !coerce-to-cmt-entry
(thing)
110 (if (typep x
'(or null function
)) x
(find-or-create-fdefn x
))))
112 ;; Return a callable function given a character-macro-table entry.
113 (defmacro !cmt-entry-to-function
(val fallback
)
117 (cond ((functionp x
) x
)
119 (t (values (sb!sys
:%primitive sb
!c
:safe-fdefn-fun x
)))))))
121 ;; Return a function-designator given a character-macro-table entry.
122 (defmacro !cmt-entry-to-fun-designator
(val)
124 (if (fdefn-p x
) (fdefn-name x
) x
)))
126 ;;; The character attribute table is a BASE-CHAR-CODE-LIMIT vector
127 ;;; of (unsigned-byte 8) plus a hashtable to handle higher character codes.
129 (defmacro test-attribute
(char whichclass rt
)
130 `(= (get-cat-entry ,char
,rt
) ,whichclass
))
132 ;;; predicates for testing character attributes
136 (declaim (inline whitespace
[1]p whitespace[2]p))
137 (declaim (inline constituentp terminating-macrop))
138 (declaim (inline single-escape-p multiple-escape-p))
139 (declaim (inline token-delimiterp)))
141 ;;; the [1] and
[2] here refer to ANSI glossary entries for
143 ;; whitespace[2]p is the only predicate whose readtable is optional
144 ;; - other than whitespace[1]p which has a fixed readtable - due to
145 ;; callers not otherwise needing a readtable at all, and so not binding
146 ;; *READTABLE* into a local variable throughout their lifetime.
147 (defun whitespace[1]p (char)
148 (test-attribute char +char-attr-whitespace+ *standard-readtable*))
149 (defun whitespace[2]p (char &optional (rt *readtable*))
150 (test-attribute char +char-attr-whitespace+ rt))
152 (defun constituentp (char rt)
153 (test-attribute char +char-attr-constituent+ rt))
155 (defun terminating-macrop (char rt)
156 (test-attribute char +char-attr-terminating-macro+ rt))
158 (defun single-escape-p (char rt)
159 (test-attribute char +char-attr-single-escape+ rt))
161 (defun multiple-escape-p (char rt)
162 (test-attribute char +char-attr-multiple-escape+ rt))
164 (defun token-delimiterp (char &optional (rt *readtable*))
165 ;; depends on actual attribute numbering in readtable.lisp.
166 (<= (get-cat-entry char rt) +char-attr-terminating-macro+))
168 ;;;; constituent traits (see ANSI 2.1.4.2)
170 ;;; There are a number of "secondary" attributes which are constant
171 ;;; properties of characters (as long as they are constituents).
173 (declaim (type attribute-table *constituent-trait-table*))
174 (defglobal *constituent-trait-table*
175 (make-array base-char-code-limit
176 :element-type '(unsigned-byte 8)
177 :initial-element +char-attr-constituent+))
179 (defun !set-constituent-trait (char trait)
180 (aver (typep char 'base-char))
181 (setf (elt *constituent-trait-table* (char-code char))
184 (defun !cold-init-constituent-trait-table ()
185 (!set-constituent-trait #\: +char-attr-package-delimiter+)
186 (!set-constituent-trait #\. +char-attr-constituent-dot+)
187 (!set-constituent-trait #\+ +char-attr-constituent-sign+)
188 (!set-constituent-trait #\- +char-attr-constituent-sign+)
189 (!set-constituent-trait #\/ +char-attr-constituent-slash+)
190 (do ((i (char-code #\0) (1+ i)))
191 ((> i (char-code #\9)))
192 (!set-constituent-trait (code-char i) +char-attr-constituent-digit+))
193 (!set-constituent-trait #\E +char-attr-constituent-expt+)
194 (!set-constituent-trait #\F +char-attr-constituent-expt+)
195 (!set-constituent-trait #\D +char-attr-constituent-expt+)
196 (!set-constituent-trait #\S +char-attr-constituent-expt+)
197 (!set-constituent-trait #\L +char-attr-constituent-expt+)
198 (!set-constituent-trait #\e +char-attr-constituent-expt+)
199 (!set-constituent-trait #\f +char-attr-constituent-expt+)
200 (!set-constituent-trait #\d +char-attr-constituent-expt+)
201 (!set-constituent-trait #\s +char-attr-constituent-expt+)
202 (!set-constituent-trait #\l +char-attr-constituent-expt+)
203 (!set-constituent-trait #\Space +char-attr-invalid+)
204 (!set-constituent-trait #\Newline +char-attr-invalid+)
205 (dolist (c (list backspace-char-code tab-char-code form-feed-char-code
206 return-char-code rubout-char-code))
207 (!set-constituent-trait (code-char c) +char-attr-invalid+)))
209 (declaim (inline get-constituent-trait))
210 (defun get-constituent-trait (char)
211 (if (typep char 'base-char)
212 (elt *constituent-trait-table* (char-code char))
213 +char-attr-constituent+))
215 ;;;; Readtable Operations
217 (defun assert-not-standard-readtable (readtable operation)
218 (when (eq readtable *standard-readtable*)
219 (cerror "Frob it anyway!" 'standard-readtable-modified-error
220 :operation operation)))
222 (defun readtable-case (readtable)
223 (%readtable-case readtable))
225 (defun (setf readtable-case) (case readtable)
226 ;; This function does not accept a readtable designator, only a readtable.
227 (assert-not-standard-readtable readtable '(setf readtable-case))
228 (setf (%readtable-case readtable) case))
230 (defun readtable-normalization (readtable)
232 "Returns T if READTABLE normalizes strings to NFKC, and NIL otherwise.
233 The READTABLE-NORMALIZATION of the standard readtable is T."
234 (%readtable-normalization readtable))
236 (defun (setf readtable-normalization) (new-value readtable)
238 "Sets the READTABLE-NORMALIZATION of the given READTABLE to NEW-VALUE.
239 Pass T to make READTABLE normalize symbols to NFKC (the default behavior),
240 and NIL to suppress normalization."
241 ;; This function does not accept a readtable designator, only a readtable.
242 (assert-not-standard-readtable readtable '(setf readtable-normalization))
243 (setf (%readtable-normalization readtable) new-value))
245 (defun replace/eql-hash-table (to from &optional (transform #'identity))
246 (maphash (lambda (k v) (setf (gethash k to) (funcall transform v))) from)
249 (defun %make-dispatch-macro-char (dtable)
250 (lambda (stream char)
251 (declare (ignore char))
252 (read-dispatch-char stream dtable)))
254 (defun %dispatch-macro-char-table (fun)
256 (eq (%closure-fun fun)
257 (load-time-value (%closure-fun (%make-dispatch-macro-char nil))
259 (find-if-in-closure #'consp fun)))
261 ;; If ENTRY is a dispatching macro, copy its dispatch table.
262 ;; Otherwise return it without alteration.
263 (defun copy-cmt-entry (entry)
264 (let ((dtable (%dispatch-macro-char-table entry)))
266 (%make-dispatch-macro-char
267 (cons (awhen (car dtable)
268 (replace/eql-hash-table (make-hash-table) it))
269 (copy-seq (cdr dtable))))
272 (defun copy-readtable (&optional (from-readtable *readtable*) to-readtable)
273 (assert-not-standard-readtable to-readtable 'copy-readtable)
274 (let ((really-from-readtable (or from-readtable *standard-readtable*))
275 (really-to-readtable (or to-readtable (make-readtable))))
276 (replace (character-attribute-array really-to-readtable)
277 (character-attribute-array really-from-readtable))
278 (replace/eql-hash-table
279 (character-attribute-hash-table really-to-readtable)
280 (character-attribute-hash-table really-from-readtable))
281 ;; CLHS says that when TO-READTABLE is non-nil "... the readtable specified
282 ;; ... is modified and returned." Is that to imply making TO-READTABLE look
283 ;; exactly like FROM-READTABLE, or does it mean to augment it?
284 ;; We have conflicting behaviors - everything in the base-char range,
285 ;; is overwritten, but above that range it's additive.
286 (map-into (character-macro-array really-to-readtable)
288 (character-macro-array really-from-readtable))
289 (replace/eql-hash-table
290 (character-macro-hash-table really-to-readtable)
291 (character-macro-hash-table really-from-readtable)
293 (setf (readtable-case really-to-readtable)
294 (readtable-case really-from-readtable))
295 (setf (readtable-normalization really-to-readtable)
296 (readtable-normalization really-from-readtable))
297 really-to-readtable))
299 (defun set-syntax-from-char (to-char from-char &optional
300 (to-readtable *readtable*) (from-readtable nil))
302 "Causes the syntax of TO-CHAR to be the same as FROM-CHAR in the optional
303 readtable (defaults to the current readtable). The FROM-TABLE defaults to the
304 standard Lisp readtable when NIL."
305 ;; TO-READTABLE is a readtable, not a readtable-designator
306 (assert-not-standard-readtable to-readtable 'set-syntax-from-char)
307 (let* ((really-from-readtable (or from-readtable *standard-readtable*))
308 (att (get-cat-entry from-char really-from-readtable))
309 (mac (get-raw-cmt-entry from-char really-from-readtable)))
310 (set-cat-entry to-char att to-readtable)
311 (set-cmt-entry to-char (copy-cmt-entry mac) to-readtable))
314 (defun set-macro-character (char function &optional
315 (non-terminatingp nil)
316 (rt-designator *readtable*))
318 "Causes CHAR to be a macro character which invokes FUNCTION when seen
319 by the reader. The NON-TERMINATINGP flag can be used to make the macro
320 character non-terminating, i.e. embeddable in a symbol name."
321 (let ((designated-readtable (or rt-designator *standard-readtable*)))
322 (assert-not-standard-readtable designated-readtable 'set-macro-character)
323 (set-cat-entry char (if non-terminatingp
324 +char-attr-constituent+
325 +char-attr-terminating-macro+)
326 designated-readtable)
327 (set-cmt-entry char (!coerce-to-cmt-entry function) designated-readtable)
328 t)) ; (ANSI-specified return value)
330 (defun get-macro-character (char &optional (rt-designator *readtable*))
332 "Return the function associated with the specified CHAR which is a macro
333 character, or NIL if there is no such function. As a second value, return
334 T if CHAR is a macro character which is non-terminating, i.e. which can
335 be embedded in a symbol name."
336 (let* ((designated-readtable (or rt-designator *standard-readtable*))
337 ;; the first return value: (OR FUNCTION SYMBOL) if CHAR is a macro
338 ;; character, or NIL otherwise
339 (fun-value (!cmt-entry-to-fun-designator
340 (get-raw-cmt-entry char designated-readtable))))
342 ;; NON-TERMINATING-P return value:
344 (or (constituentp char designated-readtable)
345 (not (terminating-macrop char designated-readtable)))
346 ;; ANSI's definition of GET-MACRO-CHARACTER says this
347 ;; value is NIL when CHAR is not a macro character.
348 ;; I.e. this value means not just "non-terminating
349 ;; character?" but "non-terminating macro character?".
352 (defun get-dispatch-macro-char-table (disp-char readtable &optional (errorp t))
353 (cond ((%dispatch-macro-char-table (get-raw-cmt-entry disp-char readtable)))
354 (errorp (error "~S is not a dispatching macro character." disp-char))))
356 (defun make-dispatch-macro-character (char &optional
357 (non-terminating-p nil)
360 "Cause CHAR to become a dispatching macro character in readtable (which
361 defaults to the current readtable). If NON-TERMINATING-P, the char will
363 ;; This used to call ERROR if the character was already a dispatching
364 ;; macro but I saw no evidence of that in other implementations except cmucl.
365 ;; Without a portable way to inquire whether a character is dispatching,
366 ;; a file that frobs *READTABLE* can't be repeatedly loaded except
367 ;; by catching the error, so I removed it.
368 ;; RT is a readtable, not a readtable-designator, as per CLHS.
369 (unless (get-dispatch-macro-char-table char rt nil)
370 ;; The dtable is a cons whose whose CAR is initially NIL but upgraded
371 ;; to a hashtable if required, and whose CDR is a vector indexed by
372 ;; char-code up to the maximum base-char.
373 (let ((dtable (cons nil (make-array base-char-code-limit
374 :initial-element nil))))
375 (set-macro-character char (%make-dispatch-macro-char dtable)
376 non-terminating-p rt)))
379 (defun set-dispatch-macro-character (disp-char sub-char function
380 &optional (rt-designator *readtable*))
382 "Cause FUNCTION to be called whenever the reader reads DISP-CHAR
383 followed by SUB-CHAR."
384 ;; Get the dispatch char for macro (error if not there), diddle
385 ;; entry for sub-char.
386 (let* ((sub-char (char-upcase sub-char))
387 (readtable (or rt-designator *standard-readtable*)))
388 (assert-not-standard-readtable readtable 'set-dispatch-macro-character)
389 (when (digit-char-p sub-char)
390 (error "SUB-CHAR must not be a decimal digit: ~S" sub-char))
391 (let ((dtable (get-dispatch-macro-char-table disp-char readtable))
392 (function (!coerce-to-cmt-entry function)))
393 ;; (SET-MACRO-CHARACTER #\$ (GET-MACRO-CHARACTER #\#)) will share
394 ;; the dispatch table. Perhaps it should be copy-on-write?
395 (if (typep sub-char 'base-char)
396 (setf (svref (cdr dtable) (char-code sub-char)) function)
397 (let ((hashtable (car dtable)))
398 (cond (function ; allocate the hashtable if it wasn't made yet
399 (setf (gethash sub-char
400 (or hashtable (setf (car dtable)
403 (hashtable ; remove an existing entry
404 (remhash sub-char hashtable)))))))
407 (defun get-dispatch-macro-character (disp-char sub-char
408 &optional (rt-designator *readtable*))
410 "Return the macro character function for SUB-CHAR under DISP-CHAR
411 or NIL if there is no associated function."
412 (let ((dtable (get-dispatch-macro-char-table
413 disp-char (or rt-designator *standard-readtable*))))
414 (!cmt-entry-to-fun-designator
415 (get-raw-cmt-dispatch-entry (char-upcase sub-char) dtable))))
418 ;;;; definitions to support internal programming conventions
420 (defconstant +EOF+ 0)
422 (defun flush-whitespace (stream)
423 ;; This flushes whitespace chars, returning the last char it read (a
424 ;; non-white one). It always gets an error on end-of-file.
425 (let* ((stream (in-synonym-of stream))
427 (attribute-array (character-attribute-array rt))
428 (attribute-hash-table (character-attribute-hash-table rt)))
429 (macrolet ((done-p ()
430 '(not (eql (if (typep char 'base-char)
431 (aref attribute-array (char-code char))
432 (gethash char attribute-hash-table
433 +char-attr-constituent+))
434 +char-attr-whitespace+))))
435 (if (ansi-stream-p stream)
436 (prepare-for-fast-read-char stream
437 (loop (let ((char (fast-read-char t)))
439 (done-with-fast-read-char)
442 (loop (let ((char (read-char stream nil +EOF+)))
443 ;; (THE) should not be needed if DONE-P, but it was not
444 ;; being derived to return a character, causing an extra
445 ;; check in consumers of flush-whitespace despite the
446 ;; promise to return a character or else signal EOF.
447 (cond ((eq char +EOF+) (error 'end-of-file :stream stream))
448 ((done-p) (return (the character char))))))))))
450 ;;;; temporary initialization hack
452 ;; Install the (easy) standard macro-chars into *READTABLE*.
453 (defun !cold-init-standard-readtable ()
454 (/show0 "entering !cold-init-standard-readtable")
455 ;; All characters get boring defaults in MAKE-READTABLE. Now we
456 ;; override the boring defaults on characters which need more
457 ;; interesting behavior.
458 (flet ((whitespaceify (char)
459 (set-cmt-entry char nil)
460 (set-cat-entry char +char-attr-whitespace+)))
461 (whitespaceify (code-char tab-char-code))
462 (whitespaceify #\Newline)
463 (whitespaceify #\Space)
464 (whitespaceify (code-char form-feed-char-code))
465 (whitespaceify (code-char return-char-code)))
467 (set-cat-entry #\\ +char-attr-single-escape+)
468 (set-cmt-entry #\\ nil)
470 (set-cat-entry #\| +char-attr-multiple-escape+)
471 (set-cmt-entry #\| nil)
473 ;; Easy macro-character definitions are in this source file.
474 (set-macro-character #\" #'read-string)
475 (set-macro-character #\' #'read-quote)
476 ;; Using symbols makes these traceable and redefineable with ease,
477 ;; as well as avoids a forward-referenced function (from "backq")
478 (set-macro-character #\( 'read-list)
479 (set-macro-character #\) 'read-right-paren)
480 (set-macro-character #\; #'read-comment)
481 ;; (The hairier macro-character definitions, for #\# and #\`, are
482 ;; defined elsewhere, in their own source files.)
485 (do ((ichar 0 (1+ ichar))
487 ((= ichar base-char-code-limit))
488 (setq char (code-char ichar))
489 (when (constituentp char *readtable*)
490 (set-cmt-entry char nil)))
492 (/show0 "leaving !cold-init-standard-readtable"))
494 ;;;; implementation of the read buffer
496 (defstruct (token-buf (:predicate nil) (:copier nil)
500 (initial-string (make-string 128))
501 (string initial-string)
504 :element-type 'character
506 :displaced-to string)))))
507 ;; The string accumulated during reading of tokens.
508 ;; Always starts out EQ to 'initial-string'.
509 (string nil :type (simple-array character (*)))
510 ;; Counter advanced as characters are placed into 'string'
511 (fill-ptr 0 :type index)
512 ;; Counter advanced as characters are consumed from 'string' on re-scan
513 ;; by auxilliary functions MAKE-{INTEGER,FLOAT,RATIONAL} etc.
514 (cursor 0 :type index)
515 ;; A string used only for FIND-PACKAGE calls in package-qualified
516 ;; symbols so that we don't need to call SUBSEQ on the 'string'.
517 (adjustable-string nil :type (and (array character (*)) (not simple-array)))
518 ;; A small string that is permanently assigned into this token-buf.
519 (initial-string nil :type (simple-array character (128))
521 (escapes (make-array 10 :element-type 'fixnum :fill-pointer 0 :adjustable t)
522 :type (and (vector fixnum) (not simple-array)) :read-only t)
523 ;; Link to next TOKEN-BUF, to chain the *TOKEN-BUF-POOL* together.
524 (next nil :type (or null token-buf))
525 (only-base-chars t :type boolean))
526 (declaim (freeze-type token-buf))
528 (def!method print-object ((self token-buf) stream)
529 (print-unreadable-object (self stream :identity t :type t)
530 (format stream "~@[next=~S~]" (token-buf-next self))))
532 ;; The current TOKEN-BUF
533 (declaim (type token-buf *read-buffer*))
534 (defvar *read-buffer*)
536 ;; A list of available TOKEN-BUFs
537 ;; Should need no toplevel binding if multi-threaded,
538 ;; but doesn't really matter, as INITIAL-THREAD-FUNCTION-TRAMPOLINE
540 (declaim (type (or null token-buf) *token-buf-pool*))
541 (defvar *token-buf-pool* nil)
543 (defun reset-read-buffer (buffer)
544 ;; Turn BUFFER into an empty read buffer.
545 (setf (fill-pointer (token-buf-escapes buffer)) 0)
546 (setf (token-buf-fill-ptr buffer) 0)
547 (setf (token-buf-cursor buffer) 0)
548 (setf (token-buf-only-base-chars buffer) t)
551 ;; "Output" a character into the reader's buffer.
552 (declaim (inline ouch-read-buffer))
553 (defun ouch-read-buffer (char buffer)
554 ;; When buffer overflow
555 (let ((op (token-buf-fill-ptr buffer)))
556 (declare (optimize (sb!c::insert-array-bounds-checks 0)))
557 (when (>= op (length (token-buf-string buffer)))
558 ;; an out-of-line call for the uncommon case avoids bloat.
559 ;; Size should be doubled.
561 (unless (typep char 'base-char)
562 (setf (token-buf-only-base-chars buffer) nil))
563 (setf (elt (token-buf-string buffer) op) char)
564 (setf (token-buf-fill-ptr buffer) (1+ op))))
566 (defun ouch-read-buffer-escaped (char buf)
567 (vector-push-extend (token-buf-fill-ptr buf) (token-buf-escapes buf))
568 (ouch-read-buffer char buf))
570 (defun grow-read-buffer ()
571 (let* ((b *read-buffer*)
572 (string (token-buf-string b)))
573 (setf (token-buf-string b)
574 (replace (make-string (* 2 (length string))) string))))
576 ;; Retun the next character from the buffered token, or NIL.
577 (declaim (maybe-inline token-buf-getchar))
578 (defun token-buf-getchar (b)
579 (declare (optimize (sb!c::insert-array-bounds-checks 0)))
580 (let ((i (token-buf-cursor (truly-the token-buf b))))
581 (and (< i (token-buf-fill-ptr b))
582 (prog1 (elt (token-buf-string b) i)
583 (setf (token-buf-cursor b) (1+ i))))))
585 ;; Grab a buffer off the token-buf pool if there is one, or else make one.
586 ;; This does not need to be protected against other threads because the
587 ;; pool is thread-local, or against async interrupts. An async signal
588 ;; delivered anywhere in the midst of the code sequence below can not
589 ;; corrupt the buffer given to the caller of ACQUIRE-TOKEN-BUF.
590 ;; Additionally the cleanup is on a "best effort" basis. Async unwinds
591 ;; through WITH-READ-BUFFER fail to recycle token-bufs, but that's ok.
592 (defun acquire-token-buf ()
593 (let ((this-buffer *token-buf-pool*))
595 (shiftf *token-buf-pool* (token-buf-next this-buffer) nil)
600 (defun release-token-buf (chain)
601 (named-let free ((buffer chain))
602 ;; If 'adjustable-string' was displaced to 'string',
603 ;; adjust it back down to allow GC of the abnormally large string.
604 (unless (eq (%array-data-vector (token-buf-adjustable-string buffer))
605 (token-buf-initial-string buffer))
606 (adjust-array (token-buf-adjustable-string buffer) '(0)
607 :displaced-to (token-buf-initial-string buffer)))
608 ;; 'initial-string' is assigned into 'string'
609 ;; so not to preserve huge buffers in the pool indefinitely.
610 (setf (token-buf-string buffer) (token-buf-initial-string buffer))
611 (if (token-buf-next buffer)
612 (free (token-buf-next buffer))
613 (setf (token-buf-next buffer) *token-buf-pool*)))
614 (setf *token-buf-pool* chain))
616 ;; Return a fresh copy of BUFFER's string
617 (defun copy-token-buf-string (buffer)
618 (subseq (token-buf-string buffer) 0 (token-buf-fill-ptr buffer)))
620 ;; Return a string displaced to BUFFER's string.
621 ;; The string should not be held onto - either a copy must be made
622 ;; by the receiver, or it should be parsed into something else.
623 (defun sized-token-buf-string (buffer)
624 ;; It would in theory be faster to make the adjustable array have
625 ;; a fill-pointer, and just set that most of the time. Except we still
626 ;; need the ability to displace to a different string if a package name
627 ;; has >128 characters, so then there'd be two modes of sharing, one of
628 ;; which is rarely exercised and most likely to be subtly wrong.
629 ;; At any rate, SET-ARRAY-HEADER is faster than ADJUST-ARRAY.
630 ;; TODO: find evidence that it is/is-not worth having complicated
631 ;; mechanism involving a fill-pointer or not.
633 (token-buf-adjustable-string buffer) ; the array
634 (token-buf-string buffer) ; the underlying data
635 (token-buf-fill-ptr buffer) ; total size
638 (token-buf-fill-ptr buffer) ; dimension 0
639 t nil)) ; displacedp / newp
641 ;; Acquire a TOKEN-BUF from the pool and execute the body, returning only
642 ;; the primary value therefrom. Recycle the buffer when done.
643 ;; No UNWIND-PROTECT - recycling is designed to help with the common case
644 ;; of normal return and is not intended to be resilient against nonlocal exit.
645 (defmacro with-read-buffer (() &body body)
646 `(let* ((*read-buffer* (acquire-token-buf))
647 (result (progn ,@body)))
648 (release-token-buf *read-buffer*)
651 (defun check-for-recursive-read (stream recursive-p operator-name)
652 (when (and recursive-p (not (boundp '*read-buffer*)))
655 "~A was invoked with RECURSIVE-P being true outside ~
656 of a recursive read operation."
659 ;;;; READ-PRESERVING-WHITESPACE, READ-DELIMITED-LIST, and READ
661 ;;; an alist for #=, used to keep track of objects with labels assigned that
662 ;;; have been completely read. Each entry is (integer-tag gensym-tag value).
664 ;;; KLUDGE: Should this really be an alist? It seems as though users
665 ;;; could reasonably expect N log N performance for large datasets.
666 ;;; On the other hand, it's probably very very seldom a problem in practice.
667 ;;; On the third hand, it might be just as easy to use a hash table
668 ;;; as an alist, so maybe we should. -- WHN 19991202
669 (defvar *sharp-equal-alist* ())
671 (declaim (ftype (sfunction (t t) (values bit t)) read-maybe-nothing))
673 ;;; Like READ-PRESERVING-WHITESPACE, but doesn't check the read buffer
674 ;;; for being set up properly.
675 (defun %read-preserving-whitespace (stream eof-error-p eof-value recursive-p)
676 (declare (optimize (sb!c::check-tag-existence 0)))
678 ;; a loop for repeating when a macro returns nothing
680 (let ((char (read-char stream eof-error-p +EOF+)))
681 (cond ((eq char +EOF+) (return eof-value))
682 ((whitespace[2]p char))
684 (multiple-value-bind (result-p result)
685 (read-maybe-nothing stream char)
686 ;; Repeat if macro returned nothing.
687 (unless (zerop result-p)
688 (return (unless *read-suppress* result))))))))
689 (let ((*sharp-equal-alist* nil))
691 (%read-preserving-whitespace stream eof-error-p eof-value t)))))
693 ;;; READ-PRESERVING-WHITESPACE behaves just like READ, only it makes
694 ;;; sure to leave terminating whitespace in the stream. (This is a
695 ;;; COMMON-LISP exported symbol.)
696 (defun read-preserving-whitespace (&optional (stream *standard-input*)
701 "Read from STREAM and return the value read, preserving any whitespace
702 that followed the object."
703 (check-for-recursive-read stream recursive-p 'read-preserving-whitespace)
704 (%read-preserving-whitespace stream eof-error-p eof-value recursive-p))
706 ;;; Read from STREAM given starting CHAR, returning 1 and the resulting
707 ;;; object, unless CHAR is a macro yielding no value, then 0 and NIL,
708 ;;; for functions that want comments to return so that they can look
709 ;;; past them. CHAR must not be whitespace.
710 (defun read-maybe-nothing (stream char)
712 (lambda (&optional (result nil supplied-p) &rest junk)
713 (declare (ignore junk)) ; is this ANSI-specified?
714 (values (if supplied-p 1 0) result))
715 (funcall (!cmt-entry-to-function
716 (get-raw-cmt-entry char *readtable*) #'read-token)
719 (defun read (&optional (stream *standard-input*)
724 "Read the next Lisp value from STREAM, and return it."
725 (check-for-recursive-read stream recursive-p 'read)
726 (let* ((local-eof-val (load-time-value *eof-object* t))
727 (result (%read-preserving-whitespace
728 stream eof-error-p local-eof-val recursive-p)))
729 ;; This function generally discards trailing whitespace. If you
730 ;; don't want to discard trailing whitespace, call
731 ;; CL:READ-PRESERVING-WHITESPACE instead.
732 (unless (or (eql result local-eof-val) recursive-p)
733 (let ((next-char (read-char stream nil +EOF+)))
734 (unless (or (eq next-char +EOF+)
735 (whitespace[2]p next-char))
736 (unread-char next-char stream))))
737 (if (eq result local-eof-val) eof-value result)))
740 ;;;; basic readmacro definitions
742 ;;;; Some large, hairy subsets of readmacro definitions (backquotes
743 ;;;; and sharp macros) are not here, but in their own source files.
745 (defun read-quote (stream ignore)
746 (declare (ignore ignore))
747 (list 'quote (read stream t nil t)))
749 (defun read-comment (stream ignore)
750 (declare (ignore ignore))
752 ((character-decoding-error
753 #'(lambda (decoding-error)
754 (declare (ignorable decoding-error))
756 'sb!kernel::character-decoding-error-in-macro-char-comment
757 :position (file-position stream) :stream stream)
758 (invoke-restart 'attempt-resync))))
759 (let ((stream (in-synonym-of stream)))
760 (if (ansi-stream-p stream)
761 (prepare-for-fast-read-char stream
762 (loop (let ((char (fast-read-char nil +EOF+)))
763 (when (or (eq char +EOF+) (char= char #\newline))
764 (return (done-with-fast-read-char))))))
766 (loop (let ((char (read-char stream nil +EOF+)))
767 (when (or (eq char +EOF+) (char= char #\newline))
769 ;; Don't return anything.
773 ((with-list-reader ((streamvar delimiter) &body body)
774 `(let* ((thelist (list nil))
776 (collectp (if *read-suppress* 0 -1)))
777 (declare (dynamic-extent thelist))
778 (loop (let ((firstchar (flush-whitespace ,streamvar)))
779 (when (eq firstchar ,delimiter)
780 (return (cdr thelist)))
782 (read-list-item (streamvar)
783 `(multiple-value-bind (winp obj)
784 (read-maybe-nothing ,streamvar firstchar)
785 ;; allow for a character macro return to return nothing
786 (unless (zerop (logand winp collectp))
788 (cdr (rplacd (truly-the cons listtail) (list obj))))))))
790 ;;; The character macro handler for left paren
791 (defun read-list (stream ignore)
792 (declare (ignore ignore))
793 (with-list-reader (stream #\))
794 (when (eq firstchar #\.)
795 (let ((nextchar (read-char stream t)))
796 (cond ((token-delimiterp nextchar)
797 (cond ((eq listtail thelist)
798 (unless (zerop collectp)
800 stream "Nothing appears before . in list.")))
801 ((whitespace[2]p nextchar)
802 (setq nextchar (flush-whitespace stream))))
803 (rplacd (truly-the cons listtail)
804 (read-after-dot stream nextchar collectp))
805 ;; Check for improper ". ,@" or ". ,." now rather than
806 ;; in the #\` reader. The resulting QUASIQUOTE macro might
807 ;; never be exapanded, but nonetheless could be erroneous.
808 (unless (zerop (logand *backquote-depth* collectp))
809 (let ((lastcdr (cdr (last listtail))))
810 (when (and (comma-p lastcdr) (comma-splicing-p lastcdr))
812 stream "~S contains a splicing comma after a dot"
814 (return (cdr thelist)))
815 ;; Put back NEXTCHAR so that we can read it normally.
816 (t (unread-char nextchar stream)))))
817 ;; Next thing is not an isolated dot.
818 (read-list-item stream)))
820 ;;; (This is a COMMON-LISP exported symbol.)
821 (defun read-delimited-list (endchar &optional
822 (input-stream *standard-input*)
825 "Read Lisp values from INPUT-STREAM until the next character after a
826 value's representation is ENDCHAR, and return the objects as a list."
827 (check-for-recursive-read input-stream recursive-p 'read-delimited-list)
828 (flet ((%read-delimited-list ()
829 (with-list-reader (input-stream endchar)
830 (read-list-item input-stream))))
832 (%read-delimited-list)
833 (with-read-buffer () (%read-delimited-list)))))) ; end MACROLET
835 (defun read-after-dot (stream firstchar collectp)
836 ;; FIRSTCHAR is non-whitespace!
838 (do ((char firstchar (flush-whitespace stream)))
841 (return-from read-after-dot nil)
842 (simple-reader-error stream "Nothing appears after . in list.")))
843 ;; See whether there's something there.
844 (multiple-value-bind (winp obj) (read-maybe-nothing stream char)
845 (unless (zerop winp) (return (setq lastobj obj)))))
846 ;; At least one thing appears after the dot.
847 ;; Check for more than one thing following dot.
849 (let ((char (flush-whitespace stream)))
850 (cond ((eq char #\)) (return lastobj)) ;success!
851 ;; Try reading virtual whitespace.
852 ((not (zerop (logand (read-maybe-nothing stream char)
853 (truly-the fixnum collectp))))
855 stream "More than one object follows . in list.")))))))
857 (defun read-string (stream closech)
858 ;; This accumulates chars until it sees same char that invoked it.
859 ;; For a very long string, this could end up bloating the read buffer.
860 (declare (character closech))
861 (let ((stream (in-synonym-of stream))
864 (reset-read-buffer buf)
865 (macrolet ((scan (read-a-char eofp &optional finish)
866 `(loop (let ((char ,read-a-char))
867 (cond (,eofp (error 'end-of-file :stream stream))
870 ((single-escape-p char rt)
871 (setq char ,read-a-char)
873 (error 'end-of-file :stream stream))))
874 (ouch-read-buffer (truly-the character char) buf)))))
875 (if (ansi-stream-p stream)
876 (prepare-for-fast-read-char stream
877 (scan (fast-read-char t) nil (done-with-fast-read-char)))
879 (scan (read-char stream nil +EOF+) (eq char +EOF+))))
880 (copy-token-buf-string buf)))
882 (defun read-right-paren (stream ignore)
883 (declare (ignore ignore))
884 (simple-reader-error stream "unmatched close parenthesis"))
886 ;;; Read from the stream up to the next delimiter. Leave the resulting
887 ;;; token in *READ-BUFFER*, and return three values:
889 ;;; -- whether any escape character was seen (even if no character is escaped)
890 ;;; -- whether a package delimiter character was seen
891 ;;; Normalizes the input to NFKC before returning
892 (defun internal-read-extended-token (stream firstchar escape-firstchar
893 &aux (read-buffer *read-buffer*))
894 (reset-read-buffer read-buffer)
895 (when escape-firstchar
896 (ouch-read-buffer-escaped firstchar read-buffer)
897 (setq firstchar (read-char stream nil +EOF+)))
898 (do ((char firstchar (read-char stream nil +EOF+))
899 (seen-multiple-escapes nil)
902 ((cond ((eq char +EOF+) t)
903 ((token-delimiterp char rt)
904 (unread-char char stream)
908 (multiple-value-setq (read-buffer colon)
909 (normalize-read-buffer read-buffer colon))
911 (or (plusp (fill-pointer (token-buf-escapes read-buffer)))
912 seen-multiple-escapes)
914 (cond ((single-escape-p char rt)
915 ;; It can't be a number, even if it's 1\23.
916 ;; Read next char here, so it won't be casified.
917 (let ((nextchar (read-char stream nil +EOF+)))
918 (if (eq nextchar +EOF+)
919 (reader-eof-error stream "after escape character")
920 (ouch-read-buffer-escaped nextchar read-buffer))))
921 ((multiple-escape-p char rt)
922 (setq seen-multiple-escapes t)
923 ;; Read to next multiple-escape, escaping single chars
926 (let ((ch (read-char stream nil +EOF+)))
929 (reader-eof-error stream "inside extended token"))
930 ((multiple-escape-p ch rt) (return))
931 ((single-escape-p ch rt)
932 (let ((nextchar (read-char stream nil +EOF+)))
933 (if (eq nextchar +EOF+)
934 (reader-eof-error stream "after escape character")
935 (ouch-read-buffer-escaped nextchar read-buffer))))
937 (ouch-read-buffer-escaped ch read-buffer))))))
939 (when (and (not colon) ; easiest test first
940 (constituentp char rt)
941 (eql (get-constituent-trait char)
942 +char-attr-package-delimiter+))
944 (ouch-read-buffer char read-buffer)))))
946 ;;;; character classes
948 ;;; Return the character class for CHAR.
950 ;;; FIXME: why aren't these ATT-getting forms using GET-CAT-ENTRY?
951 ;;; Because we've cached the readtable tables?
952 (defmacro char-class (char attarray atthash)
953 `(let ((att (if (typep (truly-the character ,char) 'base-char)
954 (aref ,attarray (char-code ,char))
955 (gethash ,char ,atthash +char-attr-constituent+))))
956 (declare (fixnum att))
958 ((<= att +char-attr-terminating-macro+) +char-attr-delimiter+)
959 ((< att +char-attr-constituent+) att)
960 (t (setf att (get-constituent-trait ,char))
961 (if (= att +char-attr-invalid+)
962 (simple-reader-error stream "invalid constituent")
965 ;;; Return the character class for CHAR, which might be part of a
967 (defmacro char-class2 (char attarray atthash)
968 `(let ((att (if (typep (truly-the character ,char) 'base-char)
969 (aref ,attarray (char-code ,char))
970 (gethash ,char ,atthash +char-attr-constituent+))))
971 (declare (fixnum att))
973 ((<= att +char-attr-terminating-macro+) +char-attr-delimiter+)
974 ((< att +char-attr-constituent+) att)
975 (t (setf att (get-constituent-trait ,char))
977 ((digit-char-p ,char *read-base*) +char-attr-constituent-digit+)
978 ((= att +char-attr-constituent-digit+) +char-attr-constituent+)
979 ((= att +char-attr-invalid+)
980 (simple-reader-error stream "invalid constituent"))
983 ;;; Return the character class for a char which might be part of a
984 ;;; rational or floating number. (Assume that it is a digit if it
986 (defmacro char-class3 (char attarray atthash)
987 `(let ((att (if (typep (truly-the character ,char) 'base-char)
988 (aref ,attarray (char-code ,char))
989 (gethash ,char ,atthash +char-attr-constituent+))))
990 (declare (fixnum att))
992 ((<= att +char-attr-terminating-macro+) +char-attr-delimiter+)
993 ((< att +char-attr-constituent+) att)
994 (t (setf att (get-constituent-trait ,char))
995 (when possibly-rational
996 (setq possibly-rational
997 (or (digit-char-p ,char *read-base*)
998 (= att +char-attr-constituent-slash+))))
1000 (setq possibly-float
1001 (or (digit-char-p ,char 10)
1002 (= att +char-attr-constituent-dot+))))
1004 ((digit-char-p ,char (max *read-base* 10))
1005 (if (digit-char-p ,char *read-base*)
1006 (if (= att +char-attr-constituent-expt+)
1007 +char-attr-constituent-digit-or-expt+
1008 +char-attr-constituent-digit+)
1009 +char-attr-constituent-decimal-digit+))
1010 ((= att +char-attr-invalid+)
1011 (simple-reader-error stream "invalid constituent"))
1016 (defvar *read-suppress* nil
1018 "Suppress most interpreting in the reader when T.")
1020 (defvar *read-base* 10
1022 "the radix that Lisp reads numbers in")
1023 (declaim (type (integer 2 36) *read-base*))
1025 ;;; Normalize TOKEN-BUF to NFKC, returning a new TOKEN-BUF and the
1027 (defun normalize-read-buffer (token-buf &optional colon)
1028 (unless (readtable-normalization *readtable*)
1029 (return-from normalize-read-buffer (values token-buf colon)))
1030 (when (token-buf-only-base-chars token-buf)
1031 (return-from normalize-read-buffer (values token-buf colon)))
1032 (let ((current-buffer (copy-token-buf-string token-buf))
1033 (old-escapes (copy-seq (token-buf-escapes token-buf)))
1034 (str-to-normalize (make-string (token-buf-fill-ptr token-buf)))
1035 (normalize-ptr 0) (escapes-ptr 0))
1036 (reset-read-buffer token-buf)
1037 (macrolet ((clear-str-to-normalize ()
1039 (loop for char across (sb!unicode:normalize-string
1040 (subseq str-to-normalize 0 normalize-ptr)
1042 (ouch-read-buffer char token-buf))
1043 (setf normalize-ptr 0)))
1044 (push-to-normalize (ch)
1045 (let ((ch-gen (gensym)))
1046 `(let ((,ch-gen ,ch))
1047 (setf (char str-to-normalize normalize-ptr) ,ch-gen)
1048 (incf normalize-ptr)))))
1049 (loop for c across current-buffer
1052 (if (and (< escapes-ptr (length old-escapes))
1053 (eql i (aref old-escapes escapes-ptr)))
1055 (clear-str-to-normalize)
1056 (ouch-read-buffer-escaped c token-buf)
1058 (push-to-normalize c)))
1059 (clear-str-to-normalize)
1060 (values token-buf colon))))
1062 ;;; Modify the read buffer according to READTABLE-CASE, ignoring
1063 ;;; ESCAPES. ESCAPES is a vector of the escaped indices.
1064 (defun casify-read-buffer (token-buf)
1065 (let ((case (readtable-case *readtable*))
1066 (escapes (token-buf-escapes token-buf)))
1068 ((and (zerop (length escapes)) (eq case :upcase))
1069 (let ((buffer (token-buf-string token-buf)))
1070 (dotimes (i (token-buf-fill-ptr token-buf))
1071 (declare (optimize (sb!c::insert-array-bounds-checks 0)))
1072 (setf (schar buffer i) (char-upcase (schar buffer i))))))
1073 ((eq case :preserve))
1075 (macrolet ((skip-esc (&body body)
1076 `(do ((i (1- (token-buf-fill-ptr token-buf)) (1- i))
1077 (buffer (token-buf-string token-buf))
1078 (esc (if (zerop (fill-pointer escapes))
1079 -1 (vector-pop escapes))))
1082 (optimize (sb!c::insert-array-bounds-checks 0)))
1084 (let ((ch (schar buffer i)))
1088 (setq esc (if (zerop (fill-pointer escapes))
1089 -1 (vector-pop escapes))))))))
1091 (skip-esc (setf (schar buffer i) (char-downcase ch))))
1093 (skip-esc (setf (schar buffer i) (char-upcase ch)))))
1095 (:upcase (raise-em))
1096 (:downcase (lower-em))
1100 (fillptr (fill-pointer escapes)))
1102 (when (both-case-p ch)
1103 (if (upper-case-p ch)
1104 (setq all-lower nil)
1105 (setq all-upper nil))))
1106 (setf (fill-pointer escapes) fillptr)
1107 (cond (all-lower (raise-em))
1108 (all-upper (lower-em))))))))))))
1110 (eval-when (:compile-toplevel :load-toplevel :execute)
1111 (defvar *reader-package* nil))
1112 (declaim (type (or null package) *reader-package*)
1113 (always-bound *reader-package*))
1115 (defun reader-find-package (package-designator stream)
1116 (if (%instancep package-designator)
1118 (let ((package (find-package package-designator)))
1120 ;; Release the token-buf that was used for the designator
1121 (release-token-buf (shiftf (token-buf-next *read-buffer*) nil))
1124 (error 'simple-reader-package-error
1125 :package package-designator
1127 :format-control "Package ~A does not exist."
1128 :format-arguments (list package-designator)))))))
1130 (defun read-token (stream firstchar)
1132 "Default readmacro function. Handles numbers, symbols, and SBCL's
1133 extended <package-name>::<form-in-package> syntax."
1134 ;; Check explicitly whether FIRSTCHAR has an entry for
1135 ;; NON-TERMINATING in CHARACTER-ATTRIBUTE-TABLE and
1136 ;; READ-DOT-NUMBER-SYMBOL in CMT. Report an error if these are
1137 ;; violated. (If we called this, we want something that is a
1138 ;; legitimate token!) Read in the longest possible string satisfying
1139 ;; the Backus-Naur form for "unqualified-token". Leave the result in
1140 ;; the *READ-BUFFER*. Return next char after token (last char read).
1141 (when *read-suppress*
1142 (internal-read-extended-token stream firstchar nil)
1143 (return-from read-token nil))
1144 (let* ((rt *readtable*)
1145 (attribute-array (character-attribute-array rt))
1146 (attribute-hash-table (character-attribute-hash-table rt))
1148 (package-designator nil)
1150 (possibly-rational t)
1151 (seen-digit-or-expt nil)
1153 (was-possibly-float nil)
1154 (seen-multiple-escapes nil))
1155 (declare (token-buf buf))
1156 (reset-read-buffer buf)
1157 (macrolet ((getchar-or-else (what)
1158 `(when (eq (setq char (read-char stream nil +EOF+)) +EOF+)
1160 (prog ((char firstchar))
1161 (case (char-class3 char attribute-array attribute-hash-table)
1162 (#.+char-attr-constituent-sign+ (go SIGN))
1163 (#.+char-attr-constituent-digit+ (go LEFTDIGIT))
1164 (#.+char-attr-constituent-digit-or-expt+
1165 (setq seen-digit-or-expt t)
1167 (#.+char-attr-constituent-decimal-digit+ (go LEFTDECIMALDIGIT))
1168 (#.+char-attr-constituent-dot+ (go FRONTDOT))
1169 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1170 (#.+char-attr-package-delimiter+ (go COLON))
1171 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1172 (#.+char-attr-invalid+ (simple-reader-error stream
1173 "invalid constituent"))
1174 ;; can't have eof, whitespace, or terminating macro as first char!
1177 (ouch-read-buffer char buf)
1178 (getchar-or-else (go RETURN-SYMBOL))
1179 (setq possibly-rational t
1181 (case (char-class3 char attribute-array attribute-hash-table)
1182 (#.+char-attr-constituent-digit+ (go LEFTDIGIT))
1183 (#.+char-attr-constituent-digit-or-expt+
1184 (setq seen-digit-or-expt t)
1186 (#.+char-attr-constituent-decimal-digit+ (go LEFTDECIMALDIGIT))
1187 (#.+char-attr-constituent-dot+ (go SIGNDOT))
1188 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1189 (#.+char-attr-package-delimiter+ (go COLON))
1190 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1191 (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
1193 LEFTDIGIT ; saw "[sign] {digit}+"
1194 (ouch-read-buffer char buf)
1195 (getchar-or-else (return (make-integer)))
1196 (setq was-possibly-float possibly-float)
1197 (case (char-class3 char attribute-array attribute-hash-table)
1198 (#.+char-attr-constituent-digit+ (go LEFTDIGIT))
1199 (#.+char-attr-constituent-decimal-digit+ (if possibly-float
1200 (go LEFTDECIMALDIGIT)
1202 (#.+char-attr-constituent-dot+ (if possibly-float
1205 (#.+char-attr-constituent-digit-or-expt+
1206 (if (or seen-digit-or-expt (not was-possibly-float))
1207 (progn (setq seen-digit-or-expt t) (go LEFTDIGIT))
1208 (progn (setq seen-digit-or-expt t) (go LEFTDIGIT-OR-EXPT))))
1209 (#.+char-attr-constituent-expt+
1210 (if was-possibly-float
1213 (#.+char-attr-constituent-slash+ (if possibly-rational
1216 (#.+char-attr-delimiter+ (unread-char char stream)
1217 (return (make-integer)))
1218 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1219 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1220 (#.+char-attr-package-delimiter+ (go COLON))
1223 (ouch-read-buffer char buf)
1224 (getchar-or-else (return (make-integer)))
1225 (case (char-class3 char attribute-array attribute-hash-table)
1226 (#.+char-attr-constituent-digit+ (go LEFTDIGIT))
1227 (#.+char-attr-constituent-decimal-digit+ (bug "impossible!"))
1228 (#.+char-attr-constituent-dot+ (go SYMBOL))
1229 (#.+char-attr-constituent-digit-or-expt+ (go LEFTDIGIT))
1230 (#.+char-attr-constituent-expt+ (go SYMBOL))
1231 (#.+char-attr-constituent-sign+ (go EXPTSIGN))
1232 (#.+char-attr-constituent-slash+ (if possibly-rational
1235 (#.+char-attr-delimiter+ (unread-char char stream)
1236 (return (make-integer)))
1237 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1238 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1239 (#.+char-attr-package-delimiter+ (go COLON))
1241 LEFTDECIMALDIGIT ; saw "[sign] {decimal-digit}+"
1242 (aver possibly-float)
1243 (ouch-read-buffer char buf)
1244 (getchar-or-else (go RETURN-SYMBOL))
1245 (case (char-class char attribute-array attribute-hash-table)
1246 (#.+char-attr-constituent-digit+ (go LEFTDECIMALDIGIT))
1247 (#.+char-attr-constituent-dot+ (go MIDDLEDOT))
1248 (#.+char-attr-constituent-expt+ (go EXPONENT))
1249 (#.+char-attr-constituent-slash+ (aver (not possibly-rational))
1251 (#.+char-attr-delimiter+ (unread-char char stream)
1253 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1254 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1255 (#.+char-attr-package-delimiter+ (go COLON))
1257 MIDDLEDOT ; saw "[sign] {digit}+ dot"
1258 (ouch-read-buffer char buf)
1259 (getchar-or-else (return (make-integer 10)))
1260 (case (char-class char attribute-array attribute-hash-table)
1261 (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
1262 (#.+char-attr-constituent-expt+ (go EXPONENT))
1263 (#.+char-attr-delimiter+
1264 (unread-char char stream)
1265 (return (make-integer 10)))
1266 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1267 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1268 (#.+char-attr-package-delimiter+ (go COLON))
1270 RIGHTDIGIT ; saw "[sign] {decimal-digit}* dot {digit}+"
1271 (ouch-read-buffer char buf)
1272 (getchar-or-else (return (make-float stream)))
1273 (case (char-class char attribute-array attribute-hash-table)
1274 (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
1275 (#.+char-attr-constituent-expt+ (go EXPONENT))
1276 (#.+char-attr-delimiter+
1277 (unread-char char stream)
1278 (return (make-float stream)))
1279 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1280 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1281 (#.+char-attr-package-delimiter+ (go COLON))
1283 SIGNDOT ; saw "[sign] dot"
1284 (ouch-read-buffer char buf)
1285 (getchar-or-else (go RETURN-SYMBOL))
1286 (case (char-class char attribute-array attribute-hash-table)
1287 (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
1288 (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
1289 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1290 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1292 FRONTDOT ; saw "dot"
1293 (ouch-read-buffer char buf)
1294 (getchar-or-else (simple-reader-error stream "dot context error"))
1295 (case (char-class char attribute-array attribute-hash-table)
1296 (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
1297 (#.+char-attr-constituent-dot+ (go DOTS))
1298 (#.+char-attr-delimiter+ (simple-reader-error stream
1299 "dot context error"))
1300 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1301 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1302 (#.+char-attr-package-delimiter+ (go COLON))
1305 (ouch-read-buffer char buf)
1306 (getchar-or-else (go RETURN-SYMBOL))
1307 (setq possibly-float t)
1308 (case (char-class char attribute-array attribute-hash-table)
1309 (#.+char-attr-constituent-sign+ (go EXPTSIGN))
1310 (#.+char-attr-constituent-digit+ (go EXPTDIGIT))
1311 (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
1312 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1313 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1314 (#.+char-attr-package-delimiter+ (go COLON))
1316 EXPTSIGN ; got to EXPONENT, and saw a sign character
1317 (ouch-read-buffer char buf)
1318 (getchar-or-else (go RETURN-SYMBOL))
1319 (case (char-class char attribute-array attribute-hash-table)
1320 (#.+char-attr-constituent-digit+ (go EXPTDIGIT))
1321 (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
1322 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1323 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1324 (#.+char-attr-package-delimiter+ (go COLON))
1326 EXPTDIGIT ; got to EXPONENT, saw "[sign] {digit}+"
1327 (ouch-read-buffer char buf)
1328 (getchar-or-else (return (make-float stream)))
1329 (case (char-class char attribute-array attribute-hash-table)
1330 (#.+char-attr-constituent-digit+ (go EXPTDIGIT))
1331 (#.+char-attr-delimiter+
1332 (unread-char char stream)
1333 (return (make-float stream)))
1334 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1335 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1336 (#.+char-attr-package-delimiter+ (go COLON))
1338 RATIO ; saw "[sign] {digit}+ slash"
1339 (ouch-read-buffer char buf)
1340 (getchar-or-else (go RETURN-SYMBOL))
1341 (case (char-class2 char attribute-array attribute-hash-table)
1342 (#.+char-attr-constituent-digit+ (go RATIODIGIT))
1343 (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
1344 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1345 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1346 (#.+char-attr-package-delimiter+ (go COLON))
1348 RATIODIGIT ; saw "[sign] {digit}+ slash {digit}+"
1349 (ouch-read-buffer char buf)
1350 (getchar-or-else (return (make-ratio stream)))
1351 (case (char-class2 char attribute-array attribute-hash-table)
1352 (#.+char-attr-constituent-digit+ (go RATIODIGIT))
1353 (#.+char-attr-delimiter+
1354 (unread-char char stream)
1355 (return (make-ratio stream)))
1356 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1357 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1358 (#.+char-attr-package-delimiter+ (go COLON))
1360 DOTS ; saw "dot {dot}+"
1361 (ouch-read-buffer char buf)
1362 (getchar-or-else (simple-reader-error stream "too many dots"))
1363 (case (char-class char attribute-array attribute-hash-table)
1364 (#.+char-attr-constituent-dot+ (go DOTS))
1365 (#.+char-attr-delimiter+
1366 (unread-char char stream)
1367 (simple-reader-error stream "too many dots"))
1368 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1369 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1370 (#.+char-attr-package-delimiter+ (go COLON))
1372 SYMBOL ; not a dot, dots, or number
1373 (let ((stream (in-synonym-of stream)))
1375 ((scan (read-a-char &optional finish)
1378 (ouch-read-buffer char buf)
1379 (setq char ,read-a-char)
1380 (when (eq char +EOF+) (go RETURN-SYMBOL))
1381 (case (char-class char attribute-array attribute-hash-table)
1382 (#.+char-attr-single-escape+ ,finish (go SINGLE-ESCAPE))
1383 (#.+char-attr-delimiter+ ,finish
1384 (unread-char char stream)
1386 (#.+char-attr-multiple-escape+ ,finish (go MULT-ESCAPE))
1387 (#.+char-attr-package-delimiter+ ,finish (go COLON))
1388 (t (go SYMBOL-LOOP))))))
1389 (if (ansi-stream-p stream)
1390 (prepare-for-fast-read-char stream
1391 (scan (fast-read-char nil +EOF+) (done-with-fast-read-char)))
1393 (scan (read-char stream nil +EOF+)))))
1394 SINGLE-ESCAPE ; saw a single-escape
1395 ;; Don't put the escape character in the read buffer.
1396 ;; READ-NEXT CHAR, put in buffer (no case conversion).
1397 (let ((nextchar (read-char stream nil +EOF+)))
1398 (when (eq nextchar +EOF+)
1399 (reader-eof-error stream "after single-escape character"))
1400 (ouch-read-buffer-escaped nextchar buf))
1401 (getchar-or-else (go RETURN-SYMBOL))
1402 (case (char-class char attribute-array attribute-hash-table)
1403 (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
1404 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1405 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1406 (#.+char-attr-package-delimiter+ (go COLON))
1409 (setq seen-multiple-escapes t)
1410 ;; sometimes we pass eof-error=nil but check. here we just let it err.
1411 ;; should pick one style and stick with it.
1412 (do ((char (read-char stream t) (read-char stream t)))
1413 ((multiple-escape-p char rt))
1414 (if (single-escape-p char rt) (setq char (read-char stream t)))
1415 (ouch-read-buffer-escaped char buf))
1416 (getchar-or-else (go RETURN-SYMBOL))
1417 (case (char-class char attribute-array attribute-hash-table)
1418 (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
1419 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1420 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1421 (#.+char-attr-package-delimiter+ (go COLON))
1424 (unless (zerop colons)
1425 (simple-reader-error
1426 stream "too many colons in ~S" (copy-token-buf-string buf)))
1427 (setf buf (normalize-read-buffer buf))
1428 (casify-read-buffer buf)
1430 (setq package-designator
1431 (if (or (plusp (token-buf-fill-ptr *read-buffer*))
1432 seen-multiple-escapes)
1433 (prog1 (sized-token-buf-string buf)
1434 (let ((new (acquire-token-buf)))
1435 (setf (token-buf-next new) buf ; new points to old
1436 buf new *read-buffer* new)))
1438 (reset-read-buffer buf)
1439 (getchar-or-else (reader-eof-error stream "after reading a colon"))
1440 (case (char-class char attribute-array attribute-hash-table)
1441 (#.+char-attr-delimiter+
1442 (unread-char char stream)
1443 (simple-reader-error stream
1444 "illegal terminating character after a colon: ~S"
1446 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1447 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1448 (#.+char-attr-package-delimiter+ (go INTERN))
1452 (getchar-or-else (reader-eof-error stream "after reading a colon"))
1453 (case (char-class char attribute-array attribute-hash-table)
1454 (#.+char-attr-delimiter+
1455 (unread-char char stream)
1456 (if package-designator
1457 (let* ((*reader-package*
1458 (reader-find-package package-designator stream)))
1459 (return (read stream t nil t)))
1460 (simple-reader-error stream
1461 "illegal terminating character after a double-colon: ~S"
1463 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1464 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1465 (#.+char-attr-package-delimiter+
1466 (simple-reader-error stream
1467 "too many colons after ~S name"
1468 package-designator))
1471 (setf buf (normalize-read-buffer buf))
1472 (casify-read-buffer buf)
1473 (let ((pkg (if package-designator
1474 (reader-find-package package-designator stream)
1475 (or *reader-package* (sane-package)))))
1476 (if (or (zerop colons) (= colons 2) (eq pkg *keyword-package*))
1477 (return (intern* (token-buf-string buf) (token-buf-fill-ptr buf)
1479 (multiple-value-bind (symbol accessibility)
1480 (find-symbol* (token-buf-string buf) (token-buf-fill-ptr buf)
1482 (when (eq accessibility :external) (return symbol))
1483 (let ((name (copy-token-buf-string buf)))
1484 (with-simple-restart (continue "Use symbol anyway.")
1485 (error 'simple-reader-package-error
1488 :format-arguments (list name (package-name pkg))
1491 "The symbol ~S is not external in the ~A package."
1492 "Symbol ~S not found in the ~A package.")))
1493 (return (intern name pkg))))))))))
1495 ;;; For semi-external use: Return 3 values: the token-buf,
1496 ;;; a flag for whether there was an escape char, and the position of
1497 ;;; any package delimiter. The returned token-buf is not case-converted.
1498 (defun read-extended-token (stream)
1499 ;; recursive-p = T is basically irrelevant.
1500 (let ((first-char (read-char stream nil +EOF+ t)))
1501 (if (neq first-char +EOF+)
1502 (internal-read-extended-token stream first-char nil)
1503 (values (reset-read-buffer *read-buffer*) nil nil))))
1505 ;;; for semi-external use:
1507 ;;; Read an extended token with the first character escaped. Return
1508 ;;; the token-buf. The returned token-buf is not case-converted.
1509 (defun read-extended-token-escaped (stream)
1510 (let ((first-char (read-char stream nil +EOF+)))
1511 (if (neq first-char +EOF+)
1512 (values (internal-read-extended-token stream first-char t))
1513 (reader-eof-error stream "after escape"))))
1515 ;;;; number-reading functions
1517 ;; Mapping of read-base to the max input characters in a positive fixnum.
1518 (eval-when (:compile-toplevel :execute)
1519 (defun integer-reader-safe-digits ()
1520 (do ((a (make-array 35 :element-type '(unsigned-byte 8)))
1523 (do ((total (1- base) (+ (* total base) (1- base)))
1524 (n-digits 0 (1+ n-digits)))
1525 ((sb!xc:typep total 'bignum)
1526 (setf (aref a (- base 2)) n-digits))
1531 (do ((maxdigits (integer-reader-safe-digits))
1534 (let* ((n-digits (aref maxdigits (- base 2)))
1535 (d (char (write-to-string (1- base) :base base) 0))
1536 (string (make-string (1+ n-digits) :initial-element d))) ; 1 extra
1537 (assert (not (typep (parse-integer string :radix base)
1538 `(unsigned-byte ,sb!vm:n-positive-fixnum-bits))))
1539 (assert (typep (parse-integer string :end n-digits :radix base)
1540 `(unsigned-byte ,sb!vm:n-positive-fixnum-bits))))))
1542 (defmacro !setq-optional-leading-sign (sign-flag token-buf rewind)
1543 ;; guaranteed to have at least one character in buffer at the start
1544 ;; or immediately following [ESFDL] marker depending on 'rewind' flag.
1545 `(locally (declare (optimize (sb!c::insert-array-bounds-checks 0)))
1546 (,(if rewind 'setf 'incf)
1547 (token-buf-cursor ,token-buf)
1548 (case (elt (token-buf-string ,token-buf)
1549 ,(if rewind 0 `(token-buf-cursor ,token-buf)))
1550 (#\- (setq ,sign-flag t) 1)
1554 (defun make-integer (&optional (base *read-base*))
1556 "Minimizes bignum-fixnum multiplies by reading a 'safe' number of digits,
1557 then multiplying by a power of the base and adding."
1558 (declare ((integer 2 36) base)
1559 (inline token-buf-getchar)) ; makes for smaller code
1560 (let* ((fixnum-max-digits
1561 (macrolet ((maxdigits ()
1562 (!coerce-to-specialized (integer-reader-safe-digits)
1563 '(unsigned-byte 8))))
1564 (aref (maxdigits) (- base 2))))
1566 (macrolet ((base-powers ()
1567 (do ((maxdigits (integer-reader-safe-digits))
1571 (setf (aref a (- base 2))
1572 (expt base (aref maxdigits (- base 2)))))))
1573 (truly-the integer (aref (base-powers) (- base 2)))))
1576 (buf *read-buffer*))
1577 (!setq-optional-leading-sign negativep buf t)
1580 (declare (type (and fixnum unsigned-byte) acc))
1581 (dotimes (digit-count fixnum-max-digits)
1582 (let ((ch (token-buf-getchar buf)))
1583 (if (or (not ch) (eql ch #\.))
1584 (return-from make-integer
1586 (if (zerop result) acc
1587 (+ (* result (expt base digit-count)) acc))))
1588 (if negativep (- result) result)))
1589 (setq acc (truly-the fixnum
1590 (+ (digit-char-p ch base)
1591 (truly-the fixnum (* acc base))))))))
1592 (setq result (+ (* result base-power) acc))))))
1594 (defun truncate-exponent (exponent number divisor)
1596 "Truncate exponent if it's too large for a float"
1597 ;; Work with base-2 logarithms to avoid conversions to floats,
1598 ;; and convert to base-10 conservatively at the end.
1599 ;; Use the least positive float, because denormalized exponent
1600 ;; can be larger than normalized.
1601 (let* ((max-exponent
1603 (+ sb!vm:double-float-digits sb!vm:double-float-bias))
1604 (number-magnitude (integer-length number))
1605 (divisor-magnitude (1- (integer-length divisor)))
1606 (magnitude (- number-magnitude divisor-magnitude)))
1607 (if (minusp exponent)
1608 (max exponent (ceiling (- (+ max-exponent magnitude))
1609 #.(floor (log 10 2))))
1610 (min exponent (floor (- max-exponent magnitude)
1611 #.(floor (log 10 2)))))))
1613 (defun make-float (stream)
1614 ;; Assume that the contents of *read-buffer* are a legal float, with nothing
1616 (let ((buf *read-buffer*)
1617 (negative-fraction nil)
1620 (negative-exponent nil)
1624 (!setq-optional-leading-sign negative-fraction buf t)
1625 ;; Read digits before the dot.
1626 (macrolet ((accumulate (expr)
1628 (loop (if (and (setq char (token-buf-getchar buf))
1629 (setq digit (digit-char-p char)))
1632 (accumulate (setq number (+ (* number 10) digit)))
1633 ;; Deal with the dot, if it's there.
1634 (when (char= char #\.)
1635 ;; Read digits after the dot.
1636 (accumulate (setq divisor (* divisor 10)
1637 number (+ (* number 10) digit))))
1638 ;; Is there an exponent letter?
1641 ;; If not, we've read the whole number.
1642 (let ((num (make-float-aux number divisor
1643 *read-default-float-format*
1645 (return-from make-float (if negative-fraction (- num) num))))
1646 ((= (get-constituent-trait char) +char-attr-constituent-expt+)
1647 (setq float-char char)
1648 ;; Check leading sign.
1649 (!setq-optional-leading-sign negative-exponent buf nil)
1650 ;; Read digits for exponent.
1651 (accumulate (setq exponent (+ (* exponent 10) digit)))
1652 (setq exponent (if negative-exponent (- exponent) exponent))
1653 ;; Generate and return the float, depending on FLOAT-CHAR:
1654 (let* ((float-format (case (char-upcase float-char)
1655 (#\E *read-default-float-format*)
1660 (exponent (truncate-exponent exponent number divisor))
1661 (result (make-float-aux (* (expt 10 exponent) number)
1662 divisor float-format stream)))
1663 (return-from make-float
1664 (if negative-fraction (- result) result))))
1665 (t (bug "bad fallthrough in floating point reader"))))))
1667 (defun make-float-aux (number divisor float-format stream)
1669 (coerce (/ number divisor) float-format)
1671 (error 'reader-impossible-number-error
1672 :error c :stream stream
1673 :format-control "failed to build float from ~a"
1674 :format-arguments (list (copy-token-buf-string *read-buffer*))))))
1676 (defun make-ratio (stream)
1677 ;; Assume *READ-BUFFER* contains a legal ratio. Build the number from
1679 ;; This code is inferior to that of MAKE-INTEGER because it makes no
1680 ;; attempt to perform as few bignum multiplies as possible.
1682 (let ((numerator 0) (denominator 0) (negativep nil)
1683 (base *read-base*) (buf *read-buffer*))
1684 (!setq-optional-leading-sign negativep buf t)
1686 (loop (let ((dig (digit-char-p (token-buf-getchar buf) base)))
1688 (setq numerator (+ (* numerator base) dig))
1691 (do* ((ch (token-buf-getchar buf) (token-buf-getchar buf))
1693 ((or (null ch) (not (setq dig (digit-char-p ch base)))))
1694 (setq denominator (+ (* denominator base) dig)))
1695 (let ((num (handler-case
1696 (/ numerator denominator)
1697 (arithmetic-error (c)
1698 (error 'reader-impossible-number-error
1699 :error c :stream stream
1700 :format-control "failed to build ratio")))))
1701 (if negativep (- num) num))))
1703 ;;;; General reader for dispatch macros
1705 (defun dispatch-char-error (stream sub-char ignore)
1706 (declare (ignore ignore))
1709 (simple-reader-error stream
1710 "no dispatch function defined for ~S"
1713 (defun read-dispatch-char (stream dispatch-table)
1714 ;; Read some digits.
1719 (let ((ch (read-char stream nil +EOF+)))
1721 (reader-eof-error stream "inside dispatch character")
1722 ;; Take care of the extra char.
1723 (let ((dig (digit-char-p ch)))
1725 (setq numargp t numarg (+ (* numarg 10) dig))
1726 (return (setq sub-char (char-upcase ch))))))))
1727 ;; Look up the function and call it.
1728 (let ((fn (get-raw-cmt-dispatch-entry sub-char dispatch-table)))
1729 (funcall (!cmt-entry-to-function fn #'dispatch-char-error)
1730 stream sub-char (if numargp numarg nil)))))
1732 ;;;; READ-FROM-STRING
1734 (defun maybe-note-read-from-string-signature-issue (eof-error-p)
1735 ;; The interface is so unintuitive that we explicitly check for the common
1737 (when (member eof-error-p '(:start :end :preserve-whitespace))
1738 (style-warn "~@<~S as EOF-ERROR-P argument to ~S: probable error. ~
1739 Two optional arguments must be provided before the ~
1740 first keyword argument.~:@>"
1741 eof-error-p 'read-from-string)
1744 (declaim (ftype (sfunction (string t t index (or null index) t) (values t index))
1746 (defun %read-from-string (string eof-error-p eof-value start end preserve-whitespace)
1747 (with-array-data ((string string :offset-var offset)
1750 :check-fill-pointer t)
1751 (let ((stream (make-string-input-stream string start end)))
1752 (values (if preserve-whitespace
1753 (%read-preserving-whitespace stream eof-error-p eof-value nil)
1754 (read stream eof-error-p eof-value))
1755 (- (string-input-stream-current stream) offset)))))
1758 (declare (muffle-conditions style-warning))
1759 (defun read-from-string (string &optional (eof-error-p t) eof-value
1760 &key (start 0) end preserve-whitespace)
1762 "The characters of string are successively given to the lisp reader
1763 and the lisp object built by the reader is returned. Macro chars
1765 (declare (string string))
1766 (maybe-note-read-from-string-signature-issue eof-error-p)
1767 (%read-from-string string eof-error-p eof-value start end preserve-whitespace)))
1769 (define-compiler-macro read-from-string (&whole form string &rest args)
1770 ;; Check this at compile-time, and rewrite it so we're silent at runtime.
1771 (destructuring-bind (&optional (eof-error-p t) eof-value &rest keys)
1773 (cond ((maybe-note-read-from-string-signature-issue eof-error-p)
1774 `(read-from-string ,string t ,eof-value ,@keys))
1776 (let* ((start (gensym "START"))
1777 (end (gensym "END"))
1778 (preserve-whitespace (gensym "PRESERVE-WHITESPACE"))
1782 ;; Odd number of keys, punt.
1783 (when keys (return-from read-from-string form)))
1784 (let* ((key (pop keys))
1789 (:preserve-whitespace preserve-whitespace)
1791 (return-from read-from-string form)))))
1792 (when (member key seen)
1793 (setf var (gensym "IGNORE"))
1796 (push (list var value) bind)))
1797 (dolist (default (list (list start 0)
1799 (list preserve-whitespace nil)))
1800 (unless (assoc (car default) bind)
1801 (push default bind)))
1802 (once-only ((string string))
1803 `(let ,(nreverse bind)
1804 ,@(when ignore `((declare (ignore ,@ignore))))
1805 (%read-from-string ,string ,eof-error-p ,eof-value
1806 ,start ,end ,preserve-whitespace))))))))
1810 (defun parse-integer (string &key (start 0) end (radix 10) junk-allowed)
1812 "Examine the substring of string delimited by start and end
1813 (default to the beginning and end of the string) It skips over
1814 whitespace characters and then tries to parse an integer. The
1815 radix parameter must be between 2 and 36."
1816 (macrolet ((parse-error (format-control)
1817 `(error 'simple-parse-error
1818 :format-control ,format-control
1819 :format-arguments (list string))))
1820 (with-array-data ((string string :offset-var offset)
1823 :check-fill-pointer t)
1824 (let ((index (do ((i start (1+ i)))
1827 (return-from parse-integer (values nil end))
1828 (parse-error "no non-whitespace characters in string ~S.")))
1829 (declare (fixnum i))
1830 (unless (whitespace[1]p
(char string i
)) (return i
))))
1834 (declare (fixnum index
))
1835 (let ((char (char string index
)))
1836 (cond ((char= char
#\-
)
1842 (when (= index end
) (return nil
))
1843 (let* ((char (char string index
))
1844 (weight (digit-char-p char radix
)))
1846 (setq result
(+ weight
(* result radix
))
1848 (junk-allowed (return nil
))
1849 ((whitespace[1]p char)
1852 (when (= index end) (return))
1853 (unless (whitespace[1]p
(char string index
))
1854 (parse-error "junk in string ~S")))
1857 (parse-error "junk in string ~S"))))
1861 (if minusp
(- result
) result
)
1864 (parse-error "no digits in string ~S")))
1865 (- index offset
))))))
1867 ;;;; reader initialization code
1869 (defun !reader-cold-init
()
1870 (!cold-init-constituent-trait-table
)
1871 (!cold-init-standard-readtable
))
1873 (def!method print-object
((readtable readtable
) stream
)
1874 (print-unreadable-object (readtable stream
:identity t
:type t
)))
1876 ;; Backward-compatibility adapter. The "named-readtables" system in
1877 ;; Quicklisp expects this interface, and it's a reasonable thing to support.
1878 ;; What is silly however is that DISPATCH-TABLES was an alist each of whose
1879 ;; values was a hashtable which got immediately coerced to an alist.
1880 ;; In anticipation of perhaps not doing an extra re-shaping, if HASH-TABLE-P
1881 ;; is NIL then return nested alists: ((#\# (#\R . #<FUNCTION SHARP-R>) ...))
1882 (defun dispatch-tables (readtable &optional
(hash-table-p t
))
1884 (flet ((process (char fn
&aux
(dtable (%dispatch-macro-char-table fn
)))
1886 (let ((output (awhen (car dtable
) (%hash-table-alist it
))))
1887 (loop for fn across
(the simple-vector
(cdr dtable
))
1889 when fn do
(push (cons (code-char ch
) fn
) output
))
1890 (dolist (cell output
) ; coerce values to function-designator
1891 (rplacd cell
(!cmt-entry-to-fun-designator
(cdr cell
))))
1892 (when hash-table-p
; caller wants hash-tables
1893 (setq output
(%stuff-hash-table
(make-hash-table) output
)))
1894 (push (cons char output
) alist
)))))
1895 (loop for fn across
(character-macro-array readtable
) and ch from
0
1896 do
(process (code-char ch
) fn
))
1897 (maphash #'process
(character-macro-hash-table readtable
)))
1900 ;; Stub - should never get called with anything but NIL
1901 ;; and only after all macros have been changed to constituents already.
1902 (defun (setf dispatch-tables
) (new-alist readtable
)
1903 (declare (ignore readtable
))
1904 (unless (null new-alist
)
1905 (error "Assignment to virtual DISPATCH-TABLES slot not allowed"))