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
679 (let* ((tracking-p (form-tracking-stream-p stream))
682 (null (form-tracking-stream-form-start-char-pos stream)))))
684 (let ((char (read-char stream eof-error-p +EOF+)))
685 (cond ((eq char +EOF+) (return eof-value))
686 ((whitespace[2]p char))
689 ;; Calling FILE-POSITION at each token seems to slow down
690 ;; the reader by somewhere between 8x to 10x.
691 ;; Once per outermost form is acceptably fast though.
692 (setf (form-tracking-stream-form-start-byte-pos stream)
693 ;; pretend we queried the position before reading CHAR
694 (- (file-position stream)
695 (or (file-string-length stream (string char)) 0))
696 (form-tracking-stream-form-start-char-pos stream)
698 (1- (form-tracking-stream-input-char-pos stream))))
699 (multiple-value-bind (result-p result)
700 (read-maybe-nothing stream char)
701 (unless (zerop result-p)
702 (return (unless *read-suppress* result)))
703 ;; Repeat if macro returned nothing.
705 (funcall (form-tracking-stream-observer stream)
706 :reset nil nil))))))))
707 (let ((*sharp-equal-alist* nil))
709 (%read-preserving-whitespace stream eof-error-p eof-value t)))))
711 ;;; READ-PRESERVING-WHITESPACE behaves just like READ, only it makes
712 ;;; sure to leave terminating whitespace in the stream. (This is a
713 ;;; COMMON-LISP exported symbol.)
714 (defun read-preserving-whitespace (&optional (stream *standard-input*)
719 "Read from STREAM and return the value read, preserving any whitespace
720 that followed the object."
721 (check-for-recursive-read stream recursive-p 'read-preserving-whitespace)
722 (%read-preserving-whitespace stream eof-error-p eof-value recursive-p))
724 ;;; Read from STREAM given starting CHAR, returning 1 and the resulting
725 ;;; object, unless CHAR is a macro yielding no value, then 0 and NIL,
726 ;;; for functions that want comments to return so that they can look
727 ;;; past them. CHAR must not be whitespace.
728 (defun read-maybe-nothing (stream char)
730 (values bit t) ; avoid a type-check. M-V-CALL is lame
732 (lambda (stream start-pos &optional (result nil supplied-p) &rest junk)
733 (declare (ignore junk)) ; is this ANSI-specified?
734 (when (and supplied-p start-pos)
735 (funcall (form-tracking-stream-observer stream)
737 (form-tracking-stream-input-char-pos stream) result))
738 (values (if supplied-p 1 0) result))
739 ;; KLUDGE: not capturing anything in the lambda avoids closure consing
741 (and (form-tracking-stream-p stream)
742 ;; Subtract 1 because the position points _after_ CHAR.
743 (1- (form-tracking-stream-input-char-pos stream)))
744 (funcall (!cmt-entry-to-function
745 (get-raw-cmt-entry char *readtable*) #'read-token)
748 (defun read (&optional (stream *standard-input*)
753 "Read the next Lisp value from STREAM, and return it."
754 (check-for-recursive-read stream recursive-p 'read)
755 (let* ((local-eof-val (load-time-value (cons nil nil) t))
756 (result (%read-preserving-whitespace
757 stream eof-error-p local-eof-val recursive-p)))
758 ;; This function generally discards trailing whitespace. If you
759 ;; don't want to discard trailing whitespace, call
760 ;; CL:READ-PRESERVING-WHITESPACE instead.
761 (unless (or (eql result local-eof-val) recursive-p)
762 (let ((next-char (read-char stream nil +EOF+)))
763 (unless (or (eq next-char +EOF+)
764 (whitespace[2]p next-char))
765 (unread-char next-char stream))))
766 (if (eq result local-eof-val) eof-value result)))
769 ;;;; basic readmacro definitions
771 ;;;; Some large, hairy subsets of readmacro definitions (backquotes
772 ;;;; and sharp macros) are not here, but in their own source files.
774 (defun read-quote (stream ignore)
775 (declare (ignore ignore))
776 (list 'quote (read stream t nil t)))
778 (defun read-comment (stream ignore)
779 (declare (ignore ignore))
781 ((character-decoding-error
782 #'(lambda (decoding-error)
783 (declare (ignorable decoding-error))
785 'sb!kernel::character-decoding-error-in-macro-char-comment
786 :position (file-position stream) :stream stream)
787 (invoke-restart 'attempt-resync))))
788 (let ((stream (in-synonym-of stream)))
789 (if (ansi-stream-p stream)
790 (prepare-for-fast-read-char stream
791 (loop (let ((char (fast-read-char nil +EOF+)))
792 (when (or (eq char +EOF+) (char= char #\newline))
793 (return (done-with-fast-read-char))))))
795 (loop (let ((char (read-char stream nil +EOF+)))
796 (when (or (eq char +EOF+) (char= char #\newline))
798 ;; Don't return anything.
801 ;;; FIXME: for these two macro chars, if STREAM is a FORM-TRACKING-STREAM,
802 ;;; every cons cell should generate a notification so that the readtable
803 ;;; manipulation in SB-COVER can be eliminated in favor of a stream observer.
804 ;;; It is cheap to add events- it won't increase consing in the compiler
805 ;;; because it the extra events can simply be ignored.
807 ((with-list-reader ((streamvar delimiter) &body body)
808 `(let* ((thelist (list nil))
810 (collectp (if *read-suppress* 0 -1)))
811 (declare (dynamic-extent thelist))
812 (loop (let ((firstchar (flush-whitespace ,streamvar)))
813 (when (eq firstchar ,delimiter)
814 (return (cdr thelist)))
816 (read-list-item (streamvar)
817 `(multiple-value-bind (winp obj)
818 (read-maybe-nothing ,streamvar firstchar)
819 ;; allow for a character macro return to return nothing
820 (unless (zerop (logand winp collectp))
822 (cdr (rplacd (truly-the cons listtail) (list obj))))))))
824 ;;; The character macro handler for left paren
825 (defun read-list (stream ignore)
826 (declare (ignore ignore))
827 (with-list-reader (stream #\))
828 (when (eq firstchar #\.)
829 (let ((nextchar (read-char stream t)))
830 (cond ((token-delimiterp nextchar)
831 (cond ((eq listtail thelist)
832 (unless (zerop collectp)
834 stream "Nothing appears before . in list.")))
835 ((whitespace[2]p nextchar)
836 (setq nextchar (flush-whitespace stream))))
837 (rplacd (truly-the cons listtail)
838 (read-after-dot stream nextchar collectp))
839 ;; Check for improper ". ,@" or ". ,." now rather than
840 ;; in the #\` reader. The resulting QUASIQUOTE macro might
841 ;; never be exapanded, but nonetheless could be erroneous.
842 (unless (zerop (logand *backquote-depth* collectp))
843 (let ((lastcdr (cdr (last listtail))))
844 (when (and (comma-p lastcdr) (comma-splicing-p lastcdr))
846 stream "~S contains a splicing comma after a dot"
848 (return (cdr thelist)))
849 ;; Put back NEXTCHAR so that we can read it normally.
850 (t (unread-char nextchar stream)))))
851 ;; Next thing is not an isolated dot.
852 (read-list-item stream)))
854 ;;; (This is a COMMON-LISP exported symbol.)
855 (defun read-delimited-list (endchar &optional
856 (input-stream *standard-input*)
859 "Read Lisp values from INPUT-STREAM until the next character after a
860 value's representation is ENDCHAR, and return the objects as a list."
861 (check-for-recursive-read input-stream recursive-p 'read-delimited-list)
862 (flet ((%read-delimited-list ()
863 (with-list-reader (input-stream endchar)
864 (read-list-item input-stream))))
866 (%read-delimited-list)
867 (with-read-buffer () (%read-delimited-list)))))) ; end MACROLET
869 (defun read-after-dot (stream firstchar collectp)
870 ;; FIRSTCHAR is non-whitespace!
872 (do ((char firstchar (flush-whitespace stream)))
875 (return-from read-after-dot nil)
876 (simple-reader-error stream "Nothing appears after . in list.")))
877 ;; See whether there's something there.
878 (multiple-value-bind (winp obj) (read-maybe-nothing stream char)
879 (unless (zerop winp) (return (setq lastobj obj)))))
880 ;; At least one thing appears after the dot.
881 ;; Check for more than one thing following dot.
883 (let ((char (flush-whitespace stream)))
884 (cond ((eq char #\)) (return lastobj)) ;success!
885 ;; Try reading virtual whitespace.
886 ((not (zerop (logand (read-maybe-nothing stream char)
887 (truly-the fixnum collectp))))
889 stream "More than one object follows . in list.")))))))
891 (defun read-string (stream closech)
892 ;; This accumulates chars until it sees same char that invoked it.
893 ;; For a very long string, this could end up bloating the read buffer.
894 (declare (character closech))
895 (let ((stream (in-synonym-of stream))
898 ;; *read-suppress* => "... macros will not construct any new objects"
899 (suppress *read-suppress*))
900 (reset-read-buffer buf)
901 (macrolet ((scan (read-a-char eofp &optional finish)
902 `(loop (let ((char ,read-a-char))
903 (cond (,eofp (error 'end-of-file :stream stream))
906 ((single-escape-p char rt)
907 (setq char ,read-a-char)
909 (error 'end-of-file :stream stream))))
911 (ouch-read-buffer (truly-the character char)
913 (if (ansi-stream-p stream)
914 (prepare-for-fast-read-char stream
915 (scan (fast-read-char t) nil (done-with-fast-read-char)))
917 (scan (read-char stream nil +EOF+) (eq char +EOF+))))
918 (if suppress "" (copy-token-buf-string buf))))
920 (defun read-right-paren (stream ignore)
921 (declare (ignore ignore))
922 (simple-reader-error stream "unmatched close parenthesis"))
924 ;;; Read from the stream up to the next delimiter. Leave the resulting
925 ;;; token in *READ-BUFFER*, and return three values:
927 ;;; -- whether any escape character was seen (even if no character is escaped)
928 ;;; -- whether a package delimiter character was seen
929 ;;; Normalizes the input to NFKC before returning
930 (defun internal-read-extended-token (stream firstchar escape-firstchar
931 &aux (read-buffer *read-buffer*))
932 (reset-read-buffer read-buffer)
933 (when escape-firstchar
934 (ouch-read-buffer-escaped firstchar read-buffer)
935 (setq firstchar (read-char stream nil +EOF+)))
936 (do ((char firstchar (read-char stream nil +EOF+))
937 (seen-multiple-escapes nil)
940 ((cond ((eq char +EOF+) t)
941 ((token-delimiterp char rt)
942 (unread-char char stream)
946 (multiple-value-setq (read-buffer colon)
947 (normalize-read-buffer read-buffer colon))
949 (or (plusp (fill-pointer (token-buf-escapes read-buffer)))
950 seen-multiple-escapes)
952 (cond ((single-escape-p char rt)
953 ;; It can't be a number, even if it's 1\23.
954 ;; Read next char here, so it won't be casified.
955 (let ((nextchar (read-char stream nil +EOF+)))
956 (if (eq nextchar +EOF+)
957 (reader-eof-error stream "after escape character")
958 (ouch-read-buffer-escaped nextchar read-buffer))))
959 ((multiple-escape-p char rt)
960 (setq seen-multiple-escapes t)
961 ;; Read to next multiple-escape, escaping single chars
964 (let ((ch (read-char stream nil +EOF+)))
967 (reader-eof-error stream "inside extended token"))
968 ((multiple-escape-p ch rt) (return))
969 ((single-escape-p ch rt)
970 (let ((nextchar (read-char stream nil +EOF+)))
971 (if (eq nextchar +EOF+)
972 (reader-eof-error stream "after escape character")
973 (ouch-read-buffer-escaped nextchar read-buffer))))
975 (ouch-read-buffer-escaped ch read-buffer))))))
977 (when (and (not colon) ; easiest test first
978 (constituentp char rt)
979 (eql (get-constituent-trait char)
980 +char-attr-package-delimiter+))
982 (ouch-read-buffer char read-buffer)))))
984 ;;;; character classes
986 ;;; Return the character class for CHAR.
988 ;;; FIXME: why aren't these ATT-getting forms using GET-CAT-ENTRY?
989 ;;; Because we've cached the readtable tables?
990 (defmacro char-class (char attarray atthash)
991 `(let ((att (if (typep (truly-the character ,char) 'base-char)
992 (aref ,attarray (char-code ,char))
993 (gethash ,char ,atthash +char-attr-constituent+))))
994 (declare (fixnum att))
996 ((<= att +char-attr-terminating-macro+) +char-attr-delimiter+)
997 ((< att +char-attr-constituent+) att)
998 (t (setf att (get-constituent-trait ,char))
999 (if (= att +char-attr-invalid+)
1000 (simple-reader-error stream "invalid constituent")
1003 ;;; Return the character class for CHAR, which might be part of a
1004 ;;; rational number.
1005 (defmacro char-class2 (char attarray atthash)
1006 `(let ((att (if (typep (truly-the character ,char) 'base-char)
1007 (aref ,attarray (char-code ,char))
1008 (gethash ,char ,atthash +char-attr-constituent+))))
1009 (declare (fixnum att))
1011 ((<= att +char-attr-terminating-macro+) +char-attr-delimiter+)
1012 ((< att +char-attr-constituent+) att)
1013 (t (setf att (get-constituent-trait ,char))
1015 ((digit-char-p ,char *read-base*) +char-attr-constituent-digit+)
1016 ((= att +char-attr-constituent-digit+) +char-attr-constituent+)
1017 ((= att +char-attr-invalid+)
1018 (simple-reader-error stream "invalid constituent"))
1021 ;;; Return the character class for a char which might be part of a
1022 ;;; rational or floating number. (Assume that it is a digit if it
1024 (defmacro char-class3 (char attarray atthash)
1025 `(let ((att (if (typep (truly-the character ,char) 'base-char)
1026 (aref ,attarray (char-code ,char))
1027 (gethash ,char ,atthash +char-attr-constituent+))))
1028 (declare (fixnum att))
1030 ((<= att +char-attr-terminating-macro+) +char-attr-delimiter+)
1031 ((< att +char-attr-constituent+) att)
1032 (t (setf att (get-constituent-trait ,char))
1033 (when possibly-rational
1034 (setq possibly-rational
1035 (or (digit-char-p ,char *read-base*)
1036 (= att +char-attr-constituent-slash+))))
1037 (when possibly-float
1038 (setq possibly-float
1039 (or (digit-char-p ,char 10)
1040 (= att +char-attr-constituent-dot+))))
1042 ((digit-char-p ,char (max *read-base* 10))
1043 (if (digit-char-p ,char *read-base*)
1044 (if (= att +char-attr-constituent-expt+)
1045 +char-attr-constituent-digit-or-expt+
1046 +char-attr-constituent-digit+)
1047 +char-attr-constituent-decimal-digit+))
1048 ((= att +char-attr-invalid+)
1049 (simple-reader-error stream "invalid constituent"))
1054 (defvar *read-suppress* nil
1056 "Suppress most interpreting in the reader when T.")
1058 (defvar *read-base* 10
1060 "the radix that Lisp reads numbers in")
1061 (declaim (type (integer 2 36) *read-base*))
1063 ;;; Normalize TOKEN-BUF to NFKC, returning a new TOKEN-BUF and the
1065 (defun normalize-read-buffer (token-buf &optional colon)
1066 (unless (readtable-normalization *readtable*)
1067 (return-from normalize-read-buffer (values token-buf colon)))
1068 (when (token-buf-only-base-chars token-buf)
1069 (return-from normalize-read-buffer (values token-buf colon)))
1070 (let ((current-buffer (copy-token-buf-string token-buf))
1071 (old-escapes (copy-seq (token-buf-escapes token-buf)))
1072 (str-to-normalize (make-string (token-buf-fill-ptr token-buf)))
1073 (normalize-ptr 0) (escapes-ptr 0))
1074 (reset-read-buffer token-buf)
1075 (macrolet ((clear-str-to-normalize ()
1077 (loop for char across (sb!unicode:normalize-string
1078 (subseq str-to-normalize 0 normalize-ptr)
1080 (ouch-read-buffer char token-buf))
1081 (setf normalize-ptr 0)))
1082 (push-to-normalize (ch)
1083 (let ((ch-gen (gensym)))
1084 `(let ((,ch-gen ,ch))
1085 (setf (char str-to-normalize normalize-ptr) ,ch-gen)
1086 (incf normalize-ptr)))))
1087 (loop for c across current-buffer
1090 (if (and (< escapes-ptr (length old-escapes))
1091 (eql i (aref old-escapes escapes-ptr)))
1093 (clear-str-to-normalize)
1094 (ouch-read-buffer-escaped c token-buf)
1096 (push-to-normalize c)))
1097 (clear-str-to-normalize)
1098 (values token-buf colon))))
1100 ;;; Modify the read buffer according to READTABLE-CASE, ignoring
1101 ;;; ESCAPES. ESCAPES is a vector of the escaped indices.
1102 (defun casify-read-buffer (token-buf)
1103 (let ((case (readtable-case *readtable*))
1104 (escapes (token-buf-escapes token-buf)))
1106 ((and (zerop (length escapes)) (eq case :upcase))
1107 (let ((buffer (token-buf-string token-buf)))
1108 (dotimes (i (token-buf-fill-ptr token-buf))
1109 (declare (optimize (sb!c::insert-array-bounds-checks 0)))
1110 (setf (schar buffer i) (char-upcase (schar buffer i))))))
1111 ((eq case :preserve))
1113 (macrolet ((skip-esc (&body body)
1114 `(do ((i (1- (token-buf-fill-ptr token-buf)) (1- i))
1115 (buffer (token-buf-string token-buf))
1116 (esc (if (zerop (fill-pointer escapes))
1117 -1 (vector-pop escapes))))
1120 (optimize (sb!c::insert-array-bounds-checks 0)))
1122 (let ((ch (schar buffer i)))
1126 (setq esc (if (zerop (fill-pointer escapes))
1127 -1 (vector-pop escapes))))))))
1129 (skip-esc (setf (schar buffer i) (char-downcase ch))))
1131 (skip-esc (setf (schar buffer i) (char-upcase ch)))))
1133 (:upcase (raise-em))
1134 (:downcase (lower-em))
1138 (fillptr (fill-pointer escapes)))
1140 (when (both-case-p ch)
1141 (if (upper-case-p ch)
1142 (setq all-lower nil)
1143 (setq all-upper nil))))
1144 (setf (fill-pointer escapes) fillptr)
1145 (cond (all-lower (raise-em))
1146 (all-upper (lower-em))))))))))))
1148 (eval-when (:compile-toplevel :load-toplevel :execute)
1149 (defvar *reader-package* nil))
1150 (declaim (type (or null package) *reader-package*)
1151 (always-bound *reader-package*))
1153 (defun reader-find-package (package-designator stream)
1154 (if (%instancep package-designator)
1156 (let ((package (find-package package-designator)))
1158 ;; Release the token-buf that was used for the designator
1159 (release-token-buf (shiftf (token-buf-next *read-buffer*) nil))
1162 (error 'simple-reader-package-error
1163 :package package-designator
1165 :format-control "Package ~A does not exist."
1166 :format-arguments (list package-designator)))))))
1168 (defun read-token (stream firstchar)
1170 "Default readmacro function. Handles numbers, symbols, and SBCL's
1171 extended <package-name>::<form-in-package> syntax."
1172 ;; Check explicitly whether FIRSTCHAR has an entry for
1173 ;; NON-TERMINATING in CHARACTER-ATTRIBUTE-TABLE and
1174 ;; READ-DOT-NUMBER-SYMBOL in CMT. Report an error if these are
1175 ;; violated. (If we called this, we want something that is a
1176 ;; legitimate token!) Read in the longest possible string satisfying
1177 ;; the Backus-Naur form for "unqualified-token". Leave the result in
1178 ;; the *READ-BUFFER*. Return next char after token (last char read).
1179 (when *read-suppress*
1180 (internal-read-extended-token stream firstchar nil)
1181 (return-from read-token nil))
1182 (let* ((rt *readtable*)
1183 (attribute-array (character-attribute-array rt))
1184 (attribute-hash-table (character-attribute-hash-table rt))
1186 (package-designator nil)
1188 (possibly-rational t)
1189 (seen-digit-or-expt nil)
1191 (was-possibly-float nil)
1192 (seen-multiple-escapes nil))
1193 (declare (token-buf buf))
1194 (reset-read-buffer buf)
1195 (macrolet ((getchar-or-else (what)
1196 `(when (eq (setq char (read-char stream nil +EOF+)) +EOF+)
1198 (prog ((char firstchar))
1199 (case (char-class3 char attribute-array attribute-hash-table)
1200 (#.+char-attr-constituent-sign+ (go SIGN))
1201 (#.+char-attr-constituent-digit+ (go LEFTDIGIT))
1202 (#.+char-attr-constituent-digit-or-expt+
1203 (setq seen-digit-or-expt t)
1205 (#.+char-attr-constituent-decimal-digit+ (go LEFTDECIMALDIGIT))
1206 (#.+char-attr-constituent-dot+ (go FRONTDOT))
1207 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1208 (#.+char-attr-package-delimiter+ (go COLON))
1209 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1210 (#.+char-attr-invalid+ (simple-reader-error stream
1211 "invalid constituent"))
1212 ;; can't have eof, whitespace, or terminating macro as first char!
1215 (ouch-read-buffer char buf)
1216 (getchar-or-else (go RETURN-SYMBOL))
1217 (setq possibly-rational t
1219 (case (char-class3 char attribute-array attribute-hash-table)
1220 (#.+char-attr-constituent-digit+ (go LEFTDIGIT))
1221 (#.+char-attr-constituent-digit-or-expt+
1222 (setq seen-digit-or-expt t)
1224 (#.+char-attr-constituent-decimal-digit+ (go LEFTDECIMALDIGIT))
1225 (#.+char-attr-constituent-dot+ (go SIGNDOT))
1226 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1227 (#.+char-attr-package-delimiter+ (go COLON))
1228 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1229 (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
1231 LEFTDIGIT ; saw "[sign] {digit}+"
1232 (ouch-read-buffer char buf)
1233 (getchar-or-else (return (make-integer)))
1234 (setq was-possibly-float possibly-float)
1235 (case (char-class3 char attribute-array attribute-hash-table)
1236 (#.+char-attr-constituent-digit+ (go LEFTDIGIT))
1237 (#.+char-attr-constituent-decimal-digit+ (if possibly-float
1238 (go LEFTDECIMALDIGIT)
1240 (#.+char-attr-constituent-dot+ (if possibly-float
1243 (#.+char-attr-constituent-digit-or-expt+
1244 (if (or seen-digit-or-expt (not was-possibly-float))
1245 (progn (setq seen-digit-or-expt t) (go LEFTDIGIT))
1246 (progn (setq seen-digit-or-expt t) (go LEFTDIGIT-OR-EXPT))))
1247 (#.+char-attr-constituent-expt+
1248 (if was-possibly-float
1251 (#.+char-attr-constituent-slash+ (if possibly-rational
1254 (#.+char-attr-delimiter+ (unread-char char stream)
1255 (return (make-integer)))
1256 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1257 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1258 (#.+char-attr-package-delimiter+ (go COLON))
1261 (ouch-read-buffer char buf)
1262 (getchar-or-else (return (make-integer)))
1263 (case (char-class3 char attribute-array attribute-hash-table)
1264 (#.+char-attr-constituent-digit+ (go LEFTDIGIT))
1265 (#.+char-attr-constituent-decimal-digit+ (bug "impossible!"))
1266 (#.+char-attr-constituent-dot+ (go SYMBOL))
1267 (#.+char-attr-constituent-digit-or-expt+ (go LEFTDIGIT))
1268 (#.+char-attr-constituent-expt+ (go SYMBOL))
1269 (#.+char-attr-constituent-sign+ (go EXPTSIGN))
1270 (#.+char-attr-constituent-slash+ (if possibly-rational
1273 (#.+char-attr-delimiter+ (unread-char char stream)
1274 (return (make-integer)))
1275 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1276 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1277 (#.+char-attr-package-delimiter+ (go COLON))
1279 LEFTDECIMALDIGIT ; saw "[sign] {decimal-digit}+"
1280 (aver possibly-float)
1281 (ouch-read-buffer char buf)
1282 (getchar-or-else (go RETURN-SYMBOL))
1283 (case (char-class char attribute-array attribute-hash-table)
1284 (#.+char-attr-constituent-digit+ (go LEFTDECIMALDIGIT))
1285 (#.+char-attr-constituent-dot+ (go MIDDLEDOT))
1286 (#.+char-attr-constituent-expt+ (go EXPONENT))
1287 (#.+char-attr-constituent-slash+ (aver (not possibly-rational))
1289 (#.+char-attr-delimiter+ (unread-char char stream)
1291 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1292 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1293 (#.+char-attr-package-delimiter+ (go COLON))
1295 MIDDLEDOT ; saw "[sign] {digit}+ dot"
1296 (ouch-read-buffer char buf)
1297 (getchar-or-else (return (make-integer 10)))
1298 (case (char-class char attribute-array attribute-hash-table)
1299 (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
1300 (#.+char-attr-constituent-expt+ (go EXPONENT))
1301 (#.+char-attr-delimiter+
1302 (unread-char char stream)
1303 (return (make-integer 10)))
1304 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1305 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1306 (#.+char-attr-package-delimiter+ (go COLON))
1308 RIGHTDIGIT ; saw "[sign] {decimal-digit}* dot {digit}+"
1309 (ouch-read-buffer char buf)
1310 (getchar-or-else (return (make-float stream)))
1311 (case (char-class char attribute-array attribute-hash-table)
1312 (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
1313 (#.+char-attr-constituent-expt+ (go EXPONENT))
1314 (#.+char-attr-delimiter+
1315 (unread-char char stream)
1316 (return (make-float stream)))
1317 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1318 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1319 (#.+char-attr-package-delimiter+ (go COLON))
1321 SIGNDOT ; saw "[sign] dot"
1322 (ouch-read-buffer char buf)
1323 (getchar-or-else (go RETURN-SYMBOL))
1324 (case (char-class char attribute-array attribute-hash-table)
1325 (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
1326 (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
1327 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1328 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1330 FRONTDOT ; saw "dot"
1331 (ouch-read-buffer char buf)
1332 (getchar-or-else (simple-reader-error stream "dot context error"))
1333 (case (char-class char attribute-array attribute-hash-table)
1334 (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
1335 (#.+char-attr-constituent-dot+ (go DOTS))
1336 (#.+char-attr-delimiter+ (simple-reader-error stream
1337 "dot context error"))
1338 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1339 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1340 (#.+char-attr-package-delimiter+ (go COLON))
1343 (ouch-read-buffer char buf)
1344 (getchar-or-else (go RETURN-SYMBOL))
1345 (setq possibly-float t)
1346 (case (char-class char attribute-array attribute-hash-table)
1347 (#.+char-attr-constituent-sign+ (go EXPTSIGN))
1348 (#.+char-attr-constituent-digit+ (go EXPTDIGIT))
1349 (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
1350 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1351 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1352 (#.+char-attr-package-delimiter+ (go COLON))
1354 EXPTSIGN ; got to EXPONENT, and saw a sign character
1355 (ouch-read-buffer char buf)
1356 (getchar-or-else (go RETURN-SYMBOL))
1357 (case (char-class char attribute-array attribute-hash-table)
1358 (#.+char-attr-constituent-digit+ (go EXPTDIGIT))
1359 (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
1360 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1361 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1362 (#.+char-attr-package-delimiter+ (go COLON))
1364 EXPTDIGIT ; got to EXPONENT, saw "[sign] {digit}+"
1365 (ouch-read-buffer char buf)
1366 (getchar-or-else (return (make-float stream)))
1367 (case (char-class char attribute-array attribute-hash-table)
1368 (#.+char-attr-constituent-digit+ (go EXPTDIGIT))
1369 (#.+char-attr-delimiter+
1370 (unread-char char stream)
1371 (return (make-float stream)))
1372 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1373 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1374 (#.+char-attr-package-delimiter+ (go COLON))
1376 RATIO ; saw "[sign] {digit}+ slash"
1377 (ouch-read-buffer char buf)
1378 (getchar-or-else (go RETURN-SYMBOL))
1379 (case (char-class2 char attribute-array attribute-hash-table)
1380 (#.+char-attr-constituent-digit+ (go RATIODIGIT))
1381 (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
1382 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1383 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1384 (#.+char-attr-package-delimiter+ (go COLON))
1386 RATIODIGIT ; saw "[sign] {digit}+ slash {digit}+"
1387 (ouch-read-buffer char buf)
1388 (getchar-or-else (return (make-ratio stream)))
1389 (case (char-class2 char attribute-array attribute-hash-table)
1390 (#.+char-attr-constituent-digit+ (go RATIODIGIT))
1391 (#.+char-attr-delimiter+
1392 (unread-char char stream)
1393 (return (make-ratio stream)))
1394 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1395 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1396 (#.+char-attr-package-delimiter+ (go COLON))
1398 DOTS ; saw "dot {dot}+"
1399 (ouch-read-buffer char buf)
1400 (getchar-or-else (simple-reader-error stream "too many dots"))
1401 (case (char-class char attribute-array attribute-hash-table)
1402 (#.+char-attr-constituent-dot+ (go DOTS))
1403 (#.+char-attr-delimiter+
1404 (unread-char char stream)
1405 (simple-reader-error stream "too many dots"))
1406 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1407 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1408 (#.+char-attr-package-delimiter+ (go COLON))
1410 SYMBOL ; not a dot, dots, or number
1411 (let ((stream (in-synonym-of stream)))
1413 ((scan (read-a-char &optional finish)
1416 (ouch-read-buffer char buf)
1417 (setq char ,read-a-char)
1418 (when (eq char +EOF+) (go RETURN-SYMBOL))
1419 (case (char-class char attribute-array attribute-hash-table)
1420 (#.+char-attr-single-escape+ ,finish (go SINGLE-ESCAPE))
1421 (#.+char-attr-delimiter+ ,finish
1422 (unread-char char stream)
1424 (#.+char-attr-multiple-escape+ ,finish (go MULT-ESCAPE))
1425 (#.+char-attr-package-delimiter+ ,finish (go COLON))
1426 (t (go SYMBOL-LOOP))))))
1427 (if (ansi-stream-p stream)
1428 (prepare-for-fast-read-char stream
1429 (scan (fast-read-char nil +EOF+) (done-with-fast-read-char)))
1431 (scan (read-char stream nil +EOF+)))))
1432 SINGLE-ESCAPE ; saw a single-escape
1433 ;; Don't put the escape character in the read buffer.
1434 ;; READ-NEXT CHAR, put in buffer (no case conversion).
1435 (let ((nextchar (read-char stream nil +EOF+)))
1436 (when (eq nextchar +EOF+)
1437 (reader-eof-error stream "after single-escape character"))
1438 (ouch-read-buffer-escaped nextchar buf))
1439 (getchar-or-else (go RETURN-SYMBOL))
1440 (case (char-class char attribute-array attribute-hash-table)
1441 (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
1442 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1443 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1444 (#.+char-attr-package-delimiter+ (go COLON))
1447 (setq seen-multiple-escapes t)
1448 ;; sometimes we pass eof-error=nil but check. here we just let it err.
1449 ;; should pick one style and stick with it.
1450 (do ((char (read-char stream t) (read-char stream t)))
1451 ((multiple-escape-p char rt))
1452 (if (single-escape-p char rt) (setq char (read-char stream t)))
1453 (ouch-read-buffer-escaped char buf))
1454 (getchar-or-else (go RETURN-SYMBOL))
1455 (case (char-class char attribute-array attribute-hash-table)
1456 (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
1457 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1458 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1459 (#.+char-attr-package-delimiter+ (go COLON))
1462 (unless (zerop colons)
1463 (simple-reader-error
1464 stream "too many colons in ~S" (copy-token-buf-string buf)))
1465 (setf buf (normalize-read-buffer buf))
1466 (casify-read-buffer buf)
1468 (setq package-designator
1469 (if (or (plusp (token-buf-fill-ptr *read-buffer*))
1470 seen-multiple-escapes)
1471 (prog1 (sized-token-buf-string buf)
1472 (let ((new (acquire-token-buf)))
1473 (setf (token-buf-next new) buf ; new points to old
1474 buf new *read-buffer* new)))
1476 (reset-read-buffer buf)
1477 (getchar-or-else (reader-eof-error stream "after reading a colon"))
1478 (case (char-class char attribute-array attribute-hash-table)
1479 (#.+char-attr-delimiter+
1480 (unread-char char stream)
1481 (simple-reader-error stream
1482 "illegal terminating character after a colon: ~S"
1484 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1485 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1486 (#.+char-attr-package-delimiter+ (go INTERN))
1490 (getchar-or-else (reader-eof-error stream "after reading a colon"))
1491 (case (char-class char attribute-array attribute-hash-table)
1492 (#.+char-attr-delimiter+
1493 (unread-char char stream)
1494 (if package-designator
1495 (let* ((*reader-package*
1496 (reader-find-package package-designator stream)))
1497 (return (read stream t nil t)))
1498 (simple-reader-error stream
1499 "illegal terminating character after a double-colon: ~S"
1501 (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1502 (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1503 (#.+char-attr-package-delimiter+
1504 (simple-reader-error stream
1505 "too many colons after ~S name"
1506 package-designator))
1509 (setf buf (normalize-read-buffer buf))
1510 (casify-read-buffer buf)
1511 (let ((pkg (if package-designator
1512 (reader-find-package package-designator stream)
1513 (or *reader-package* (sane-package)))))
1514 (if (or (zerop colons) (= colons 2) (eq pkg *keyword-package*))
1515 (return (intern* (token-buf-string buf) (token-buf-fill-ptr buf)
1517 (multiple-value-bind (symbol accessibility)
1518 (find-symbol* (token-buf-string buf) (token-buf-fill-ptr buf)
1520 (when (eq accessibility :external) (return symbol))
1521 (let ((name (copy-token-buf-string buf)))
1522 (with-simple-restart (continue "Use symbol anyway.")
1523 (error 'simple-reader-package-error
1526 :format-arguments (list name (package-name pkg))
1529 "The symbol ~S is not external in the ~A package."
1530 "Symbol ~S not found in the ~A package.")))
1531 (return (intern name pkg))))))))))
1533 ;;; For semi-external use: Return 3 values: the token-buf,
1534 ;;; a flag for whether there was an escape char, and the position of
1535 ;;; any package delimiter. The returned token-buf is not case-converted.
1536 (defun read-extended-token (stream)
1537 ;; recursive-p = T is basically irrelevant.
1538 (let ((first-char (read-char stream nil +EOF+ t)))
1539 (if (neq first-char +EOF+)
1540 (internal-read-extended-token stream first-char nil)
1541 (values (reset-read-buffer *read-buffer*) nil nil))))
1543 ;;; for semi-external use:
1545 ;;; Read an extended token with the first character escaped. Return
1546 ;;; the token-buf. The returned token-buf is not case-converted.
1547 (defun read-extended-token-escaped (stream)
1548 (let ((first-char (read-char stream nil +EOF+)))
1549 (if (neq first-char +EOF+)
1550 (values (internal-read-extended-token stream first-char t))
1551 (reader-eof-error stream "after escape"))))
1553 ;;;; number-reading functions
1555 ;; Mapping of read-base to the max input characters in a positive fixnum.
1556 (eval-when (:compile-toplevel :execute)
1557 (defun integer-reader-safe-digits ()
1558 (do ((a (make-array 35 :element-type '(unsigned-byte 8)))
1561 (do ((total (1- base) (+ (* total base) (1- base)))
1562 (n-digits 0 (1+ n-digits)))
1563 ((sb!xc:typep total 'bignum)
1564 (setf (aref a (- base 2)) n-digits))
1569 (do ((maxdigits (integer-reader-safe-digits))
1572 (let* ((n-digits (aref maxdigits (- base 2)))
1573 (d (char (write-to-string (1- base) :base base) 0))
1574 (string (make-string (1+ n-digits) :initial-element d))) ; 1 extra
1575 (assert (not (typep (parse-integer string :radix base)
1576 `(unsigned-byte ,sb!vm:n-positive-fixnum-bits))))
1577 (assert (typep (parse-integer string :end n-digits :radix base)
1578 `(unsigned-byte ,sb!vm:n-positive-fixnum-bits))))))
1580 (defmacro !setq-optional-leading-sign (sign-flag token-buf rewind)
1581 ;; guaranteed to have at least one character in buffer at the start
1582 ;; or immediately following [ESFDL] marker depending on 'rewind' flag.
1583 `(locally (declare (optimize (sb!c::insert-array-bounds-checks 0)))
1584 (,(if rewind 'setf 'incf)
1585 (token-buf-cursor ,token-buf)
1586 (case (elt (token-buf-string ,token-buf)
1587 ,(if rewind 0 `(token-buf-cursor ,token-buf)))
1588 (#\- (setq ,sign-flag t) 1)
1592 (defun make-integer (&optional (base *read-base*))
1594 "Minimizes bignum-fixnum multiplies by reading a 'safe' number of digits,
1595 then multiplying by a power of the base and adding."
1596 (declare ((integer 2 36) base)
1597 (inline token-buf-getchar)) ; makes for smaller code
1598 (let* ((fixnum-max-digits
1599 (macrolet ((maxdigits ()
1600 (!coerce-to-specialized (integer-reader-safe-digits)
1601 '(unsigned-byte 8))))
1602 (aref (maxdigits) (- base 2))))
1604 (macrolet ((base-powers ()
1605 (do ((maxdigits (integer-reader-safe-digits))
1609 (setf (aref a (- base 2))
1610 (expt base (aref maxdigits (- base 2)))))))
1611 (truly-the integer (aref (base-powers) (- base 2)))))
1614 (buf *read-buffer*))
1615 (!setq-optional-leading-sign negativep buf t)
1618 (declare (type (and fixnum unsigned-byte) acc))
1619 (dotimes (digit-count fixnum-max-digits)
1620 (let ((ch (token-buf-getchar buf)))
1621 (if (or (not ch) (eql ch #\.))
1622 (return-from make-integer
1624 (if (zerop result) acc
1625 (+ (* result (expt base digit-count)) acc))))
1626 (if negativep (- result) result)))
1627 (setq acc (truly-the fixnum
1628 (+ (digit-char-p ch base)
1629 (truly-the fixnum (* acc base))))))))
1630 (setq result (+ (* result base-power) acc))))))
1632 (defun truncate-exponent (exponent number divisor)
1634 "Truncate exponent if it's too large for a float"
1635 ;; Work with base-2 logarithms to avoid conversions to floats,
1636 ;; and convert to base-10 conservatively at the end.
1637 ;; Use the least positive float, because denormalized exponent
1638 ;; can be larger than normalized.
1639 (let* ((max-exponent
1641 (+ sb!vm:double-float-digits sb!vm:double-float-bias))
1642 (number-magnitude (integer-length number))
1643 (divisor-magnitude (1- (integer-length divisor)))
1644 (magnitude (- number-magnitude divisor-magnitude)))
1645 (if (minusp exponent)
1646 (max exponent (ceiling (- (+ max-exponent magnitude))
1647 #.(floor (log 10 2))))
1648 (min exponent (floor (- max-exponent magnitude)
1649 #.(floor (log 10 2)))))))
1651 (defun make-float (stream)
1652 ;; Assume that the contents of *read-buffer* are a legal float, with nothing
1654 (let ((buf *read-buffer*)
1655 (negative-fraction nil)
1658 (negative-exponent nil)
1662 (!setq-optional-leading-sign negative-fraction buf t)
1663 ;; Read digits before the dot.
1664 (macrolet ((accumulate (expr)
1666 (loop (if (and (setq char (token-buf-getchar buf))
1667 (setq digit (digit-char-p char)))
1670 (accumulate (setq number (+ (* number 10) digit)))
1671 ;; Deal with the dot, if it's there.
1672 (when (char= char #\.)
1673 ;; Read digits after the dot.
1674 (accumulate (setq divisor (* divisor 10)
1675 number (+ (* number 10) digit))))
1676 ;; Is there an exponent letter?
1679 ;; If not, we've read the whole number.
1680 (let ((num (make-float-aux number divisor
1681 *read-default-float-format*
1683 (return-from make-float (if negative-fraction (- num) num))))
1684 ((= (get-constituent-trait char) +char-attr-constituent-expt+)
1685 (setq float-char char)
1686 ;; Check leading sign.
1687 (!setq-optional-leading-sign negative-exponent buf nil)
1688 ;; Read digits for exponent.
1689 (accumulate (setq exponent (+ (* exponent 10) digit)))
1690 (setq exponent (if negative-exponent (- exponent) exponent))
1691 ;; Generate and return the float, depending on FLOAT-CHAR:
1692 (let* ((float-format (case (char-upcase float-char)
1693 (#\E *read-default-float-format*)
1698 (exponent (truncate-exponent exponent number divisor))
1699 (result (make-float-aux (* (expt 10 exponent) number)
1700 divisor float-format stream)))
1701 (return-from make-float
1702 (if negative-fraction (- result) result))))
1703 (t (bug "bad fallthrough in floating point reader"))))))
1705 (defun make-float-aux (number divisor float-format stream)
1707 (coerce (/ number divisor) float-format)
1709 (error 'reader-impossible-number-error
1710 :error c :stream stream
1711 :format-control "failed to build float from ~a"
1712 :format-arguments (list (copy-token-buf-string *read-buffer*))))))
1714 (defun make-ratio (stream)
1715 ;; Assume *READ-BUFFER* contains a legal ratio. Build the number from
1717 ;; This code is inferior to that of MAKE-INTEGER because it makes no
1718 ;; attempt to perform as few bignum multiplies as possible.
1720 (let ((numerator 0) (denominator 0) (negativep nil)
1721 (base *read-base*) (buf *read-buffer*))
1722 (!setq-optional-leading-sign negativep buf t)
1724 (loop (let ((dig (digit-char-p (token-buf-getchar buf) base)))
1726 (setq numerator (+ (* numerator base) dig))
1729 (do* ((ch (token-buf-getchar buf) (token-buf-getchar buf))
1731 ((or (null ch) (not (setq dig (digit-char-p ch base)))))
1732 (setq denominator (+ (* denominator base) dig)))
1733 (let ((num (handler-case
1734 (/ numerator denominator)
1735 (arithmetic-error (c)
1736 (error 'reader-impossible-number-error
1737 :error c :stream stream
1738 :format-control "failed to build ratio")))))
1739 (if negativep (- num) num))))
1741 ;;;; General reader for dispatch macros
1743 (defun dispatch-char-error (stream sub-char ignore)
1744 (declare (ignore ignore))
1747 (simple-reader-error stream
1748 "no dispatch function defined for ~S"
1751 (defun read-dispatch-char (stream dispatch-table)
1752 ;; Read some digits.
1757 (let ((ch (read-char stream nil +EOF+)))
1759 (reader-eof-error stream "inside dispatch character")
1760 ;; Take care of the extra char.
1761 (let ((dig (digit-char-p ch)))
1763 (setq numargp t numarg (+ (* numarg 10) dig))
1764 (return (setq sub-char (char-upcase ch))))))))
1765 ;; Look up the function and call it.
1766 (let ((fn (get-raw-cmt-dispatch-entry sub-char dispatch-table)))
1767 (funcall (!cmt-entry-to-function fn #'dispatch-char-error)
1768 stream sub-char (if numargp numarg nil)))))
1770 ;;;; READ-FROM-STRING
1772 (defun maybe-note-read-from-string-signature-issue (eof-error-p)
1773 ;; The interface is so unintuitive that we explicitly check for the common
1775 (when (member eof-error-p '(:start :end :preserve-whitespace))
1776 (style-warn "~@<~S as EOF-ERROR-P argument to ~S: probable error. ~
1777 Two optional arguments must be provided before the ~
1778 first keyword argument.~:@>"
1779 eof-error-p 'read-from-string)
1782 (declaim (ftype (sfunction (string t t index (or null index) t) (values t index))
1784 (defun %read-from-string (string eof-error-p eof-value start end preserve-whitespace)
1785 (with-array-data ((string string :offset-var offset)
1788 :check-fill-pointer t)
1789 (let ((stream (make-string-input-stream string start end)))
1790 (values (if preserve-whitespace
1791 (%read-preserving-whitespace stream eof-error-p eof-value nil)
1792 (read stream eof-error-p eof-value))
1793 (- (string-input-stream-current stream) offset)))))
1796 (declare (muffle-conditions style-warning))
1797 (defun read-from-string (string &optional (eof-error-p t) eof-value
1798 &key (start 0) end preserve-whitespace)
1800 "The characters of string are successively given to the lisp reader
1801 and the lisp object built by the reader is returned. Macro chars
1803 (declare (string string))
1804 (maybe-note-read-from-string-signature-issue eof-error-p)
1805 (%read-from-string string eof-error-p eof-value start end preserve-whitespace)))
1807 (define-compiler-macro read-from-string (&whole form string &rest args)
1808 ;; Check this at compile-time, and rewrite it so we're silent at runtime.
1809 (destructuring-bind (&optional (eof-error-p t) eof-value &rest keys)
1811 (cond ((maybe-note-read-from-string-signature-issue eof-error-p)
1812 `(read-from-string ,string t ,eof-value ,@keys))
1814 (let* ((start (gensym "START"))
1815 (end (gensym "END"))
1816 (preserve-whitespace (gensym "PRESERVE-WHITESPACE"))
1820 ;; Odd number of keys, punt.
1821 (when keys (return-from read-from-string form)))
1822 (let* ((key (pop keys))
1827 (:preserve-whitespace preserve-whitespace)
1829 (return-from read-from-string form)))))
1830 (when (member key seen)
1831 (setf var (gensym "IGNORE"))
1834 (push (list var value) bind)))
1835 (dolist (default (list (list start 0)
1837 (list preserve-whitespace nil)))
1838 (unless (assoc (car default) bind)
1839 (push default bind)))
1840 (once-only ((string string))
1841 `(let ,(nreverse bind)
1842 ,@(when ignore `((declare (ignore ,@ignore))))
1843 (%read-from-string ,string ,eof-error-p ,eof-value
1844 ,start ,end ,preserve-whitespace))))))))
1848 (defun parse-integer (string &key (start 0) end (radix 10) junk-allowed)
1850 "Examine the substring of string delimited by start and end
1851 (default to the beginning and end of the string) It skips over
1852 whitespace characters and then tries to parse an integer. The
1853 radix parameter must be between 2 and 36."
1854 (macrolet ((parse-error (format-control)
1855 `(error 'simple-parse-error
1856 :format-control ,format-control
1857 :format-arguments (list string))))
1858 (with-array-data ((string string :offset-var offset)
1861 :check-fill-pointer t)
1862 (let ((index (do ((i start (1+ i)))
1865 (return-from parse-integer (values nil end))
1866 (parse-error "no non-whitespace characters in string ~S.")))
1867 (declare (fixnum i))
1868 (unless (whitespace[1]p
(char string i
)) (return i
))))
1872 (declare (fixnum index
))
1873 (let ((char (char string index
)))
1874 (cond ((char= char
#\-
)
1880 (when (= index end
) (return nil
))
1881 (let* ((char (char string index
))
1882 (weight (digit-char-p char radix
)))
1884 (setq result
(+ weight
(* result radix
))
1886 (junk-allowed (return nil
))
1887 ((whitespace[1]p char)
1890 (when (= index end) (return))
1891 (unless (whitespace[1]p
(char string index
))
1892 (parse-error "junk in string ~S")))
1895 (parse-error "junk in string ~S"))))
1899 (if minusp
(- result
) result
)
1902 (parse-error "no digits in string ~S")))
1903 (- index offset
))))))
1905 ;;;; reader initialization code
1907 (defun !reader-cold-init
()
1908 (!cold-init-constituent-trait-table
)
1909 (!cold-init-standard-readtable
))
1911 (def!method print-object
((readtable readtable
) stream
)
1912 (print-unreadable-object (readtable stream
:identity t
:type t
)))
1914 ;; Backward-compatibility adapter. The "named-readtables" system in
1915 ;; Quicklisp expects this interface, and it's a reasonable thing to support.
1916 ;; What is silly however is that DISPATCH-TABLES was an alist each of whose
1917 ;; values was a hashtable which got immediately coerced to an alist.
1918 ;; In anticipation of perhaps not doing an extra re-shaping, if HASH-TABLE-P
1919 ;; is NIL then return nested alists: ((#\# (#\R . #<FUNCTION SHARP-R>) ...))
1920 (defun dispatch-tables (readtable &optional
(hash-table-p t
))
1922 (flet ((process (char fn
&aux
(dtable (%dispatch-macro-char-table fn
)))
1924 (let ((output (awhen (car dtable
) (%hash-table-alist it
))))
1925 (loop for fn across
(the simple-vector
(cdr dtable
))
1927 when fn do
(push (cons (code-char ch
) fn
) output
))
1928 (dolist (cell output
) ; coerce values to function-designator
1929 (rplacd cell
(!cmt-entry-to-fun-designator
(cdr cell
))))
1930 (when hash-table-p
; caller wants hash-tables
1931 (setq output
(%stuff-hash-table
(make-hash-table) output
)))
1932 (push (cons char output
) alist
)))))
1933 (loop for fn across
(character-macro-array readtable
) and ch from
0
1934 do
(process (code-char ch
) fn
))
1935 (maphash #'process
(character-macro-hash-table readtable
)))
1938 ;; Stub - should never get called with anything but NIL
1939 ;; and only after all macros have been changed to constituents already.
1940 (defun (setf dispatch-tables
) (new-alist readtable
)
1941 (declare (ignore readtable
))
1942 (unless (null new-alist
)
1943 (error "Assignment to virtual DISPATCH-TABLES slot not allowed"))