/[cmucl]/src/code/reader.lisp
ViewVC logotype

Contents of /src/code/reader.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.68 - (show annotations)
Thu Jan 27 00:49:32 2011 UTC (3 years, 2 months ago) by rtoy
Branch: MAIN
CVS Tags: GIT-CONVERSION, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, HEAD
Changes since 1.67: +9 -3 lines
Micro optimization:  In SET-CMT-ENTRY, if the char-code is above
attribute-table-limit and if the newvalue is #'read-token, we don't
actually add the entry to the character-macro-hash-table, because that
is the default value for the hash-table.  This helps to keep the
hash-table size small.
1 ;;; -*- Log: code.log; Package: Lisp -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/reader.lisp,v 1.68 2011/01/27 00:49:32 rtoy Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Spice Lisp Reader
13 ;;; Written by David Dill
14 ;;; Package system interface by Lee Schumacher.
15 ;;; Runs in the standard Spice Lisp environment.
16 ;;;
17
18 (in-package "EXTENSIONS")
19 (intl:textdomain "cmucl")
20
21 (export '*ignore-extra-close-parentheses*)
22
23 (in-package "LISP")
24 (export '(readtable readtable-case readtablep *read-base* *readtable*
25 copy-readtable set-syntax-from-char set-macro-character
26 get-macro-character make-dispatch-macro-character
27 set-dispatch-macro-character get-dispatch-macro-character read
28 *read-default-float-format* read-preserving-whitespace
29 read-delimited-list parse-integer read-from-string *read-suppress*
30 reader-error))
31
32
33 ;;;Random global variables
34
35 (defvar *read-default-float-format* 'single-float "Float format for 1.0E1")
36 (declaim (type (member short-float single-float double-float long-float)
37 *read-default-float-format*))
38
39 (defvar *readtable*)
40 (declaim (type readtable *readtable*))
41 (setf (documentation '*readtable* 'variable)
42 _N"Variable bound to current readtable.")
43
44
45 ;;;; Reader errors:
46
47 (define-condition reader-error (parse-error stream-error)
48 ((format-control
49 :reader reader-error-format-control
50 :initarg :format-control)
51 (format-arguments
52 :reader reader-error-format-arguments
53 :initarg :format-arguments
54 :initform '()))
55 (:report
56 (lambda (condition stream)
57 (let ((error-stream (stream-error-stream condition)))
58 (when c:*compiler-notification-function*
59 (funcall c:*compiler-notification-function* :error
60 (apply #'format nil
61 (reader-error-format-control condition)
62 (reader-error-format-arguments condition))
63 nil error-stream
64 (file-position error-stream)))
65 (format stream (intl:gettext "Reader error ~@[at ~D ~]on ~S:~%~?")
66 (file-position error-stream) error-stream
67 (reader-error-format-control condition)
68 (reader-error-format-arguments condition))))))
69
70 (define-condition reader-package-error (reader-error) ())
71
72 ;;; %READ-ERROR -- Interface
73 ;;;
74 ;;; Like, signal a READ-ERROR, man...
75 ;;;
76 (defun %reader-error (stream control &rest args)
77 (error 'reader-error :stream stream :format-control control
78 :format-arguments args))
79
80 (define-condition reader-eof-error (end-of-file)
81 ((context :reader reader-eof-error-context :initarg :context))
82 (:report
83 (lambda (condition stream)
84 (format stream (intl:gettext "Unexpected EOF on ~S ~A.")
85 (stream-error-stream condition)
86 (reader-eof-error-context condition)))))
87
88 (defun reader-eof-error (stream context)
89 (error 'reader-eof-error :stream stream :context context))
90
91
92 ;;;; Readtable implementation.
93
94
95 (defvar std-lisp-readtable ()
96 "Standard lisp readtable. This is for recovery from broken
97 read-tables, and should not normally be user-visible.")
98
99 ;; Max size of the attribute table before we switch from an array to a
100 ;; hash-table.
101 (defconstant attribute-table-limit
102 #-unicode char-code-limit
103 #+unicode 256)
104
105 (deftype attribute-table ()
106 '(simple-array (unsigned-byte 8) (#.attribute-table-limit)))
107
108 (defstruct (readtable
109 (:conc-name nil)
110 (:predicate readtablep)
111 (:copier nil)
112 (:print-function
113 (lambda (s stream d)
114 (declare (ignore d))
115 (print-unreadable-object (s stream :identity t)
116 (prin1 'readtable stream)))))
117 "Readtable is a data structure that maps characters into syntax
118 types for the Common Lisp expression reader."
119 ;; The CHARACTER-ATTRIBUTE-TABLE is a vector of ATTRIBUTE-TABLE-LIMIT integers for
120 ;; describing the character type. Conceptually, there are 4 distinct
121 ;; "primary" character attributes: WHITESPACE, TERMINATING-MACRO, ESCAPE, and
122 ;; CONSTITUENT. Non-terminating macros (such as the symbol reader) have the
123 ;; attribute CONSTITUENT.
124 ;;
125 ;; In order to make the READ-TOKEN fast, all this information is
126 ;; stored in the character attribute table by having different varieties of
127 ;; constituents.
128 (character-attribute-table
129 (make-array attribute-table-limit
130 :element-type '(unsigned-byte 8)
131 :initial-element constituent)
132 :type attribute-table)
133 ;;
134 ;; The CHARACTER-MACRO-TABLE is a vector of ATTRIBUTE-TABLE-LIMIT functions. One
135 ;; of these functions called with appropriate arguments whenever any
136 ;; non-WHITESPACE character is encountered inside READ-PRESERVING-WHITESPACE.
137 ;; These functions are used to implement user-defined read-macros, system
138 ;; read-macros, and the number-symbol reader.
139 (character-macro-table
140 (make-array attribute-table-limit :initial-element #'undefined-macro-char)
141 :type (simple-vector #.attribute-table-limit))
142 ;;
143 ;; DISPATCH-TABLES entry, which is an alist from dispatch characters to
144 ;; vectors of CHAR-CODE-LIMIT functions, for use in defining dispatching
145 ;; macros (like #-macro).
146 (dispatch-tables () :type list)
147 (readtable-case :upcase :type (member :upcase :downcase :preserve :invert))
148 ;;
149 ;; The CHARACTER-ATTRIBUTE-HASH-TABLE handles the case of char codes
150 ;; above ATTRIBUTE-TABLE-LIMIT, since we expect these to be
151 ;; relatively rare.
152 #+unicode
153 (character-attribute-hash-table (make-hash-table)
154 :type (or null hash-table))
155 ;;
156 ;; The CHARACTER-MACRO-HASH-TABLE handles the case of char codes
157 ;; above ATTRIBUTE-TABLE-LIMIT, since we expect these to be
158 ;; relatively rare.
159 #+unicode
160 (character-macro-hash-table (make-hash-table)
161 :type (or null hash-table)))
162
163
164 ;;;; Constants for character attributes. These are all as in the manual.
165
166 (eval-when (compile load eval)
167 (defconstant whitespace 0)
168 (defconstant terminating-macro 1)
169 (defconstant escape 2)
170 (defconstant constituent 3)
171 (defconstant constituent-dot 4)
172 (defconstant constituent-expt 5)
173 (defconstant constituent-slash 6)
174 (defconstant constituent-digit 7)
175 (defconstant constituent-sign 8)
176 ; 9
177 (defconstant multiple-escape 10)
178 (defconstant package-delimiter 11)
179 ;;fake attribute for use in read-unqualified-token
180 (defconstant delimiter 12)
181 ;; More fake attributes for used for reading numbers.
182 ;;
183 ;; The following two are not static but depend on *READ-BASE*.
184 ;; DECIMAL-DIGIT is for characters being digits in base 10 but not in
185 ;; base *READ-BASE* (which is therefore perforce smaller than 10);
186 ;; DIGIT-OR-EXPT is for characters being both exponent markers and
187 ;; digits in base *READ-BASE* (which is therefore perforce larger
188 ;; than 10).
189
190 (defconstant constituent-decimal-digit 13)
191 (defconstant constituent-digit-or-expt 14)
192 ;; Invalid constituent character
193 (defconstant constituent-invalid 15))
194
195
196 ;;;; Package specials.
197
198 (defvar *old-package* ()
199 "Value of *package* at the start of the last read or Nil.")
200
201 ;;; In case we get an error trying to parse a symbol, we want to rebind the
202 ;;; above stuff so it's cool.
203
204 (declaim (special *package* *keyword-package* *read-base*))
205
206
207
208 ;;;; Macros and functions for character tables.
209
210 #-unicode
211 (defmacro get-cat-entry (char rt)
212 ;;only give this side-effect-free args.
213 `(elt (character-attribute-table ,rt)
214 (char-code ,char)))
215
216 #+unicode
217 (defmacro get-cat-entry (char rt)
218 ;;only give this side-effect-free args.
219 `(if (< (char-code ,char) attribute-table-limit)
220 (elt (character-attribute-table ,rt)
221 (char-code ,char))
222 (gethash (char-code ,char)
223 (character-attribute-hash-table ,rt)
224 ;; Default is constituent, because the attribute table
225 ;; is initialized to constituent
226 constituent)))
227
228 #-unicode
229 (defun set-cat-entry (char newvalue &optional (rt *readtable*))
230 (setf (elt (character-attribute-table rt)
231 (char-code char))
232 newvalue))
233
234 #+unicode
235 (defun set-cat-entry (char newvalue &optional (rt *readtable*))
236 (let ((code (char-code char)))
237 (if (< code attribute-table-limit)
238 (setf (elt (character-attribute-table rt)
239 code)
240 newvalue)
241 (unless (= newvalue constituent)
242 ;; The default value (in get-cat-entry) is constituent, so
243 ;; don't enter it into the hash table.
244 (setf (gethash code (character-attribute-hash-table rt))
245 newvalue)))))
246
247 #-unicode
248 (defmacro get-cmt-entry (char rt)
249 `(the function
250 (elt (the simple-vector (character-macro-table ,rt))
251 (char-code ,char))))
252
253 #+unicode
254 (defmacro get-cmt-entry (char rt)
255 `(if (< (char-code ,char) attribute-table-limit)
256 (the function
257 (elt (the simple-vector (character-macro-table ,rt))
258 (char-code ,char)))
259 (gethash (char-code ,char)
260 (character-macro-hash-table ,rt)
261 ;; This default value needs to be coordinated with
262 ;; init-std-lisp-readtable.
263 #'read-token)))
264
265 #-unicode
266 (defun set-cmt-entry (char newvalue &optional (rt *readtable*))
267 (setf (elt (the simple-vector (character-macro-table rt))
268 (char-code char))
269 (coerce newvalue 'function)))
270
271 #+unicode
272 (defun set-cmt-entry (char newvalue &optional (rt *readtable*))
273 (let ((code (char-code char)))
274 (if (< code attribute-table-limit)
275 (setf (elt (the simple-vector (character-macro-table rt))
276 code)
277 (coerce newvalue 'function))
278 (let ((f (coerce newvalue 'function)))
279 ;; Don't add an entry if the function would be the same as
280 ;; the default. This needs to be coordinated with
281 ;; GET-CMT-ENTRY above.
282 (if (eq f #'read-token)
283 f
284 (setf (gethash code (character-macro-hash-table rt))
285 f))))))
286
287 (defun undefined-macro-char (stream char)
288 (unless *read-suppress*
289 (%reader-error stream (intl:gettext "Undefined read-macro character ~S") char)))
290
291 ;;; The character attribute table is a CHAR-CODE-LIMIT vector of integers.
292
293 (defmacro test-attribute (char whichclass rt)
294 `(= (the fixnum (get-cat-entry ,char ,rt)) ,whichclass))
295
296 ;;; Predicates for testing character attributes
297
298 ;;; Make this a function, since other people want to use it.
299 ;;;
300 (declaim (inline whitespacep))
301 (defun whitespacep (char &optional (rt *readtable*))
302 (test-attribute char whitespace rt))
303
304 (defmacro constituentp (char &optional (rt '*readtable*))
305 `(test-attribute ,char #.constituent ,rt))
306
307 (defmacro terminating-macrop (char &optional (rt '*readtable*))
308 `(test-attribute ,char #.terminating-macro ,rt))
309
310 (defmacro escapep (char &optional (rt '*readtable*))
311 `(test-attribute ,char #.escape ,rt))
312
313 (defmacro multiple-escape-p (char &optional (rt '*readtable*))
314 `(test-attribute ,char #.multiple-escape ,rt))
315
316 (defmacro token-delimiterp (char &optional (rt '*readtable*))
317 ;;depends on actual attribute numbering above.
318 `(<= (get-cat-entry ,char ,rt) #.terminating-macro))
319
320
321
322 ;;;; Secondary attribute table.
323
324 ;;; There are a number of "secondary" attributes which are constant properties
325 ;;; of characters characters (as long as they are constituents).
326
327 (defvar secondary-attribute-table)
328 (declaim (type attribute-table secondary-attribute-table))
329
330 (defun set-secondary-attribute (char attribute)
331 (setf (elt secondary-attribute-table (char-code char))
332 attribute))
333
334
335 (defun init-secondary-attribute-table ()
336 (setq secondary-attribute-table
337 (make-array attribute-table-limit
338 :element-type '(unsigned-byte 8)
339 :initial-element #.constituent))
340 (set-secondary-attribute #\: #.package-delimiter)
341 ;;(set-secondary-attribute #\| #.multiple-escape) ; |) [For EMACS]
342 (set-secondary-attribute #\. #.constituent-dot)
343 (set-secondary-attribute #\+ #.constituent-sign)
344 (set-secondary-attribute #\- #.constituent-sign)
345 (set-secondary-attribute #\/ #.constituent-slash)
346 (do ((i (char-code #\0) (1+ i)))
347 ((> i (char-code #\9)))
348 (set-secondary-attribute (code-char i) #.constituent-digit))
349 (set-secondary-attribute #\E #.constituent-expt)
350 (set-secondary-attribute #\F #.constituent-expt)
351 (set-secondary-attribute #\D #.constituent-expt)
352 (set-secondary-attribute #\S #.constituent-expt)
353 (set-secondary-attribute #\L #.constituent-expt)
354 (set-secondary-attribute #\e #.constituent-expt)
355 (set-secondary-attribute #\f #.constituent-expt)
356 (set-secondary-attribute #\d #.constituent-expt)
357 (set-secondary-attribute #\s #.constituent-expt)
358 (set-secondary-attribute #\l #.constituent-expt)
359 #+double-double
360 (progn
361 (set-secondary-attribute #\W #.constituent-expt)
362 (set-secondary-attribute #\w #.constituent-expt))
363 ;; See CLHS 2.1.4.2 for the list of constituent characters that are
364 ;; invalid constituent characters.
365 (set-secondary-attribute #\Space #.constituent-invalid)
366 (set-secondary-attribute #\Newline #.constituent-invalid)
367 (dolist (c '(#\backspace #\tab #\page #\return #\rubout))
368 (set-secondary-attribute c #.constituent-invalid)))
369
370 #-unicode
371 (defmacro get-secondary-attribute (char)
372 `(elt secondary-attribute-table
373 (char-code ,char)))
374
375 #+unicode
376 (defmacro get-secondary-attribute (char)
377 `(if (< (char-code ,char) attribute-table-limit)
378 (elt secondary-attribute-table
379 (char-code ,char))
380 constituent))
381
382
383
384 ;;; Character dispatch stuff
385
386 ;; For non-unicode stuff, a simple vector of 256 elements works fine.
387 #-unicode
388 (defun make-char-dispatch-table ()
389 (make-array attribute-table-limit :initial-element #'dispatch-char-error))
390
391 #-unicode
392 (declaim (inline copy-char-dispatch-table))
393 #-unicode
394 (defun copy-char-dispatch-table (dispatch)
395 (copy-seq dispatch))
396
397 ;; For unicode, we define a structure to hold a vector and a
398 ;; hash-table to conserve space instead of using a huge vector. The
399 ;; vector handles the common case for 8-bit characters, and the hash
400 ;; table handles the rest.
401 #+unicode
402 (defstruct (char-dispatch-table
403 (:copier nil)
404 (:print-function
405 (lambda (s stream d)
406 (declare (ignore d))
407 (print-unreadable-object (s stream :identity t :type t)
408 ))))
409 ;; TABLE is a vector for quick access for 8-bit characters
410 (table (make-array attribute-table-limit :initial-element #'dispatch-char-error)
411 :type (simple-vector #.attribute-table-limit))
412 ;; HASH-TABLE is for handling the (presumably) rare case of dispatch
413 ;; characters above attribute-table-limit.
414 (hash-table (make-hash-table)
415 :type hash-table))
416
417 #+unicode
418 (defun copy-char-dispatch-table (dispatch)
419 ;; Make a new dispatch table and copy the contents to it
420 (let* ((new (make-char-dispatch-table))
421 (h (char-dispatch-table-hash-table new)))
422 (replace (char-dispatch-table-table new)
423 (char-dispatch-table-table dispatch))
424 (maphash #'(lambda (key val)
425 (setf (gethash key h) val))
426 (char-dispatch-table-hash-table dispatch))
427 new))
428
429 (declaim (inline get-dispatch-char set-dispatch-char))
430
431 #-unicode
432 (defun get-dispatch-char (char dispatch)
433 (elt (the simple-vector dispatch)
434 (char-code char)))
435
436 #+unicode
437 (defun get-dispatch-char (char dispatch)
438 (let ((code (char-code char)))
439 (if (< code attribute-table-limit)
440 (elt (the simple-vector (char-dispatch-table-table dispatch))
441 code)
442 (gethash char (char-dispatch-table-hash-table dispatch)
443 #'dispatch-char-error))))
444
445 #-unicode
446 (defun set-dispatch-char (char new-value dispatch)
447 (setf (elt (the simple-vector dispatch)
448 (char-code char))
449 (coerce new-value 'function)))
450
451 #+unicode
452 (defun set-dispatch-char (char new-value dispatch)
453 (let ((code (char-code char)))
454 (if (< code attribute-table-limit)
455 (setf (elt (the simple-vector (char-dispatch-table-table dispatch))
456 (char-code char))
457 (coerce new-value 'function))
458 (setf (gethash char (char-dispatch-table-hash-table dispatch))
459 (coerce new-value 'function)))))
460
461
462 ;;;; Readtable operations.
463
464 (defun copy-readtable (&optional (from-readtable *readtable*) to-readtable)
465 "A copy is made of from-readtable and place into to-readtable."
466 (let ((from-readtable (or from-readtable std-lisp-readtable))
467 (to-readtable (or to-readtable (make-readtable))))
468 (flet ((copy-hash-table (to from)
469 (clrhash to)
470 (maphash #'(lambda (key val)
471 (setf (gethash key to) val))
472 from)))
473 ;;physically clobber contents of internal tables.
474 (replace (character-attribute-table to-readtable)
475 (character-attribute-table from-readtable))
476 (replace (character-macro-table to-readtable)
477 (character-macro-table from-readtable))
478 #+unicode
479 (progn
480 (copy-hash-table (character-attribute-hash-table to-readtable)
481 (character-attribute-hash-table from-readtable))
482 (copy-hash-table (character-macro-hash-table to-readtable)
483 (character-macro-hash-table from-readtable)))
484 (setf (dispatch-tables to-readtable)
485 (mapcar #'(lambda (pair) (cons (car pair)
486 (copy-char-dispatch-table (cdr pair))))
487 (dispatch-tables from-readtable)))
488 (setf (readtable-case to-readtable)
489 (readtable-case from-readtable))
490 to-readtable)))
491
492 (defun set-syntax-from-char (to-char from-char &optional
493 (to-readtable *readtable*)
494 (from-readtable ()))
495 "Causes the syntax of to-char to be the same as from-char in the
496 optional readtable (defaults to the current readtable). The
497 from-table defaults the standard lisp readtable by being nil."
498 (let ((from-readtable (or from-readtable std-lisp-readtable)))
499 ;;copy from-char entries to to-char entries, but make sure that if
500 ;;from char is a constituent you don't copy non-movable secondary
501 ;;attributes (constituent types), and that said attributes magically
502 ;;appear if you transform a non-constituent to a constituent.
503 (let ((att (get-cat-entry from-char from-readtable))
504 (mac (get-cmt-entry from-char from-readtable))
505 (from-dpair (find from-char (dispatch-tables from-readtable)
506 :test #'char= :key #'car))
507 (to-dpair (find to-char (dispatch-tables to-readtable)
508 :test #'char= :key #'car)))
509 #+nil
510 (if (constituentp from-char from-readtable)
511 (setq att (get-secondary-attribute to-char)))
512 (set-cat-entry to-char att to-readtable)
513 (set-cmt-entry to-char
514 mac
515 to-readtable)
516 ;; Copy the reader macro functions too if from-char is a
517 ;; dispatching macro character.
518 ;;(format t "from-dpair = ~A~%" from-dpair)
519 (when from-dpair
520 (cond (to-dpair
521 ;; The to-readtable already has a dispatching table for
522 ;; this character. Replace it with a copy of the
523 ;; dispatching table from from-readtable.
524 (setf (cdr to-dpair) (copy-char-dispatch-table (cdr from-dpair))))
525 (t
526 ;; The to-readtable doesn't have such an entry. Add a
527 ;; copy of dispatch table from from-readtable to the
528 ;; dispatch table of the to-readtable.
529 (let ((pair (cons to-char (copy-char-dispatch-table (cdr from-dpair)))))
530 (setf (dispatch-tables to-readtable)
531 (push pair (dispatch-tables to-readtable)))))))))
532 t)
533
534 (defun set-macro-character (char function &optional
535 (non-terminatingp nil) (rt *readtable*))
536 "Causes char to be a macro character which invokes function when
537 seen by the reader. The non-terminatingp flag can be used to
538 make the macro character non-terminating. The optional readtable
539 argument defaults to the current readtable. Set-macro-character
540 returns T."
541 (if non-terminatingp
542 (set-cat-entry char (get-secondary-attribute char) rt)
543 (set-cat-entry char #.terminating-macro rt))
544 (set-cmt-entry char function rt)
545 T)
546
547 (defun get-macro-character (char &optional (rt *readtable*))
548 "Returns the function associated with the specified char which is a macro
549 character. The optional readtable argument defaults to the current
550 readtable."
551 (let ((rt (or rt std-lisp-readtable)))
552 ;; Check macro syntax, return associated function if it's there.
553 ;; Returns a value for all constituents.
554 (cond ((constituentp char rt)
555 (values (get-cmt-entry char rt) t))
556 ((terminating-macrop char rt)
557 (values (get-cmt-entry char rt) nil))
558 (t nil))))
559
560
561 ;;;; These definitions support internal programming conventions.
562
563 (defconstant eof-object '(*eof*))
564
565 (defmacro eofp (char) `(eq ,char eof-object))
566
567 (defun flush-whitespace (stream)
568 ;; This flushes whitespace chars, returning the last char it read (a
569 ;; non-white one). It always gets an error on end-of-file.
570 (let ((stream (in-synonym-of stream)))
571 (stream-dispatch stream
572 ;; simple-stream
573 (do ((char (stream::%read-char stream t nil t t)
574 (stream::%read-char stream t nil t t)))
575 ((not (test-attribute char #.whitespace *readtable*))
576 char))
577 ;; lisp-stream
578 (prepare-for-fast-read-char stream
579 (do ((char (fast-read-char t) (fast-read-char t)))
580 ((not (test-attribute char #.whitespace *readtable*))
581 (done-with-fast-read-char)
582 char)))
583 ;; fundamental-stream
584 (do ((char (stream-read-char stream) (stream-read-char stream)))
585 ((or (eq char :eof)
586 (not (test-attribute char #.whitespace *readtable*)))
587 (if (eq char :eof)
588 (error 'end-of-file :stream stream)
589 char))))))
590
591
592 ;;;; Temporary initialization hack.
593
594 (defun init-std-lisp-readtable ()
595 (setq std-lisp-readtable (make-readtable))
596 ;;all characters default to "constituent" in make-readtable
597 ;;*** un-constituent-ize some of these ***
598 (let ((*readtable* std-lisp-readtable))
599 (set-cat-entry #\tab #.whitespace)
600 (set-cat-entry #\linefeed #.whitespace)
601 (set-cat-entry #\space #.whitespace)
602 (set-cat-entry #\page #.whitespace)
603 (set-cat-entry #\return #.whitespace)
604 (set-cat-entry #\\ #.escape)
605 (set-cat-entry #\| #.multiple-escape)
606 (set-cmt-entry #\\ #'read-token)
607 (set-cmt-entry #\: #'read-token)
608 (set-cmt-entry #\| #'read-token)
609 ;;macro definitions
610 (set-macro-character #\" #'read-string)
611 ;;* # macro
612 (set-macro-character #\' #'read-quote)
613 (set-macro-character #\( #'read-list)
614 (set-macro-character #\) #'read-right-paren)
615 (set-macro-character #\; #'read-comment)
616 ;;* backquote
617 ;;all constituents
618 (do ((ichar 0 (1+ ichar))
619 (len #+unicode-bootstrap #o200
620 #-unicode-bootstrap char-code-limit))
621 ((= ichar len))
622 (let ((char (code-char ichar)))
623 #-unicode
624 (when (constituentp char std-lisp-readtable)
625 (set-cat-entry char (get-secondary-attribute char))
626 (set-cmt-entry char #'read-token))
627 #+unicode
628 (cond ((constituentp char std-lisp-readtable)
629 (set-cat-entry char (get-secondary-attribute char))
630 (when (< ichar attribute-table-limit)
631 ;; The hashtable default in get-cmt-entry returns
632 ;; #'read-token, so don't need to set it here.
633 (set-cmt-entry char #'read-token)))
634 ((>= ichar attribute-table-limit)
635 ;; A non-constituent character that would be stored in
636 ;; the hash table gets #'undefined-macro-char.
637 (set-cmt-entry char #'undefined-macro-char)))))))
638
639
640
641 ;;;; read-buffer implementation.
642
643 (defvar *read-buffer*)
644 (defvar *read-buffer-length*)
645
646 (defvar *inch-ptr*)
647 (defvar *ouch-ptr*)
648
649 (declaim (type index *read-buffer-length* *inch-ptr* *ouch-ptr*))
650 (declaim (simple-string *read-buffer*))
651
652 (defconstant +read-buffer-pool-size+ 16)
653 (defconstant +read-buffer-initial-size+ 16)
654
655 (defun make-read-buffer-stack (size count)
656 (let ((stack (make-array count :fill-pointer 0)))
657 (dotimes (i count)
658 (vector-push (make-string size) stack))
659 stack))
660
661 (defvar *read-buffer-stack*)
662
663 (defun init-read-buffer-stack ()
664 (setq *read-buffer-stack*
665 (make-read-buffer-stack +read-buffer-initial-size+ +read-buffer-pool-size+)))
666
667 (defun allocate-read-buffer ()
668 (cond ((zerop (fill-pointer *read-buffer-stack*))
669 (make-string 32))
670 (t (vector-pop *read-buffer-stack*))))
671
672 (defun free-read-buffer (buffer)
673 (vector-push buffer *read-buffer-stack*))
674
675 ;;; Recursive reader functions use with-read-buffer to allocate a
676 ;;; fresh buffer. We currently allocate a fresh buffer only for the
677 ;;; exported functions READ, READ-PRESERVING-WHITESPACE,
678 ;;; READ-FROM-STRING, and READ-DELIMITED-LIST. Some internal
679 ;;; functions like READ-TOKEN, INTERNAL-READ-EXTENDED-TOKEN and
680 ;;; READ-STRING avoid the overhead for the allocation and clobber the
681 ;;; current read-buffer.
682
683 (defmacro with-read-buffer (() &body body)
684 "Bind *read-buffer* to a fresh buffer and execute Body."
685 `(let* ((*read-buffer* (allocate-read-buffer))
686 (*read-buffer-length* (length *read-buffer*))
687 (*ouch-ptr* 0)
688 (*inch-ptr* 0))
689 (unwind-protect (progn ,@body)
690 (free-read-buffer *read-buffer*))))
691
692 (defmacro reset-read-buffer ()
693 ;;turn *read-buffer* into an empty read-buffer.
694 ;;*ouch-ptr* always points to next char to write
695 `(progn
696 (setq *ouch-ptr* 0)
697 ;;*inch-ptr* always points to next char to read
698 (setq *inch-ptr* 0)))
699
700 (defmacro ouch-read-buffer (char)
701 `(progn
702 (if (>= (the fixnum *ouch-ptr*)
703 (the fixnum *read-buffer-length*))
704 ;;buffer overflow -- double the size
705 (grow-read-buffer))
706 (setf (elt (the simple-string *read-buffer*) *ouch-ptr*) ,char)
707 (setq *ouch-ptr* (1+ *ouch-ptr*))))
708
709 ;; macro to move *ouch-ptr* back one.
710 (defmacro ouch-unread-buffer ()
711 '(if (> (the fixnum *ouch-ptr*) (the fixnum *inch-ptr*))
712 (setq *ouch-ptr* (1- (the fixnum *ouch-ptr*)))))
713
714 (defun grow-read-buffer ()
715 (let ((rbl (length (the simple-string *read-buffer*))))
716 (declare (fixnum rbl))
717 (setq *read-buffer*
718 (concatenate 'simple-string
719 (the simple-string *read-buffer*)
720 (the simple-string (make-string rbl))))
721 (setq *read-buffer-length* (* 2 rbl))))
722
723 (defun inchpeek-read-buffer ()
724 (if (>= (the fixnum *inch-ptr*) (the fixnum *ouch-ptr*))
725 eof-object
726 (elt (the simple-string *read-buffer*) *inch-ptr*)))
727
728 (defun inch-read-buffer ()
729 (cond ((>= (the fixnum *inch-ptr*) (the fixnum *ouch-ptr*))
730 eof-object)
731 (t (prog1 (elt (the simple-string *read-buffer*) *inch-ptr*)
732 (setq *inch-ptr* (1+ (the fixnum *inch-ptr*)))))))
733
734 (defmacro unread-buffer ()
735 `(decf (the fixnum *inch-ptr*)))
736
737 (defun read-unwind-read-buffer ()
738 ;;keep contents, but make next (inch..) return first char.
739 (setq *inch-ptr* 0))
740
741 (defun read-buffer-to-string ()
742 (subseq (the simple-string *read-buffer*) 0 *ouch-ptr*))
743
744
745
746 ;;;; READ-PRESERVING-WHITESPACE, READ-DELIMITED-LIST, and READ.
747
748 (defvar *ignore-extra-close-parentheses* t
749 "If true, only warn when there is an extra close paren, otherwise error.")
750
751 (declaim (special *standard-input*))
752
753 ;;; The SHARP-EQUAL function introduces a label for an object, and the
754 ;;; SHARP-SHARP function allows us to refer to this label. This is slightly
755 ;;; tricky because the object we are labelling can contain labels to itself in
756 ;;; order to create circular structures, e.g., #1=(cons 'hello #1#).
757 ;;;
758 ;;; The SHARP-EQUAL function is called when we are reading a stream and
759 ;;; encounter text of the form #<LABEL>=<OBJ>, where <LABEL> should be a number
760 ;;; and <OBJ> ought to be readable as an object. Our first step is to use
761 ;;; gensym to create a new <TAG> for this label; we temporarily bind <LABEL> to
762 ;;; <TAG> and then read in <OBJ> using our <TAG> as a temporary binding for
763 ;;; <LABEL>. Finally, we fix the <OBJ> by replacing any occurrences of <TAG>
764 ;;; with a pointer to <OBJ> itself, creating the circular structures.
765 ;;;
766 ;;; We now do this with a couple of data structures.
767 ;;;
768 ;;; 1. *SHARP-EQUAL-FINAL-TABLE* is a hash table where "finished" associations
769 ;;; are stored. That is, it is a hash table from labels to objects, where
770 ;;; the objects have already been patched and are tag-free.
771 ;;;
772 ;;; 2. *SHARP-EQUAL-TEMP-TABLE* is a hash table where "unfinished"
773 ;;; associations are stored. That is, it is a hash table from labels to
774 ;;; tags.
775 ;;;
776 ;;; 3. *SHARP-EQUAL-REPL-TABLE* is a hash table that associates tags with
777 ;;; their corrective pointers. That is, this is the table we use to
778 ;;; "patch" the objects.
779
780 (defvar *sharp-equal-final-table*)
781 (defvar *sharp-equal-temp-table*)
782 (defvar *sharp-equal-repl-table*)
783
784
785
786 ;;; READ-PRESERVING-WHITESPACE behaves just like read only it makes sure
787 ;;; to leave terminating whitespace in the stream.
788 ;;;
789 (defun read-preserving-whitespace (&optional (stream *standard-input*)
790 (eof-errorp t) (eof-value nil)
791 (recursivep nil))
792 "Reads from stream and returns the object read, preserving the whitespace
793 that followed the object."
794 (with-read-buffer ()
795 (read-preserving-whitespace-internal stream eof-errorp eof-value recursivep)))
796
797 (defun read-preserving-whitespace-internal (&optional (stream *standard-input*)
798 (eof-errorp t) (eof-value nil)
799 (recursivep nil))
800
801 (cond
802 (recursivep
803 ;; Loop for repeating when a macro returns nothing.
804 (loop
805 (let ((char (read-char stream eof-errorp eof-object)))
806 (cond ((eofp char) (return eof-value))
807 ((whitespacep char))
808 (t
809 (let* ((macrofun (get-cmt-entry char *readtable*))
810 (result (multiple-value-list
811 (funcall macrofun stream char))))
812 ;; Repeat if macro returned nothing.
813 (if result (return (if *read-suppress*
814 nil
815 (car result))))))))))
816 (t
817 (let ((*sharp-equal-final-table* nil)
818 (*sharp-equal-temp-table* nil)
819 (*sharp-equal-repl-table* nil))
820 (read-preserving-whitespace-internal stream eof-errorp eof-value t)))))
821
822
823 (defun read-maybe-nothing (stream char)
824 ;;returns nil or a list with one thing, depending.
825 ;;for functions that want comments to return so they can look
826 ;;past them. Assumes char is not whitespace.
827 (let ((retval (multiple-value-list
828 (funcall (get-cmt-entry char *readtable*) stream char))))
829 (if retval (rplacd retval nil))))
830
831 (defun read (&optional (stream *standard-input*) (eof-errorp t)
832 (eof-value ()) (recursivep ()))
833 "Reads in the next object in the stream, which defaults to
834 *standard-input*. For details see the I/O chapter of
835 the manual."
836 (with-read-buffer ()
837 (read-internal stream eof-errorp eof-value recursivep)))
838
839 (defun read-internal (&optional (stream *standard-input*) (eof-errorp t)
840 (eof-value ()) (recursivep ()))
841 (prog1
842 (read-preserving-whitespace-internal stream eof-errorp eof-value recursivep)
843 (let ((whitechar (read-char stream nil eof-object)))
844 (if (and (not (eofp whitechar))
845 (or (not (whitespacep whitechar))
846 recursivep))
847 (unread-char whitechar stream)))))
848
849 (defun read-delimited-list (endchar &optional
850 (input-stream *standard-input*)
851 recursive-p)
852 "Reads objects from input-stream until the next character after an
853 object's representation is endchar. A list of those objects read
854 is returned."
855 (declare (ignore recursive-p))
856 (with-read-buffer ()
857 (do ((char (flush-whitespace input-stream)
858 (flush-whitespace input-stream))
859 (retlist ()))
860 ((char= char endchar) (nreverse retlist))
861 (setq retlist (nconc (read-maybe-nothing input-stream char) retlist)))))
862
863
864 ;;;; Standard ReadMacro definitions to implement the reader.
865
866 (defun read-quote (stream ignore)
867 (declare (ignore ignore))
868 (list 'quote (read-internal stream t nil t)))
869
870 (defun read-comment (stream ignore)
871 (declare (ignore ignore))
872 (let ((stream (in-synonym-of stream)))
873 (stream-dispatch stream
874 ;; simple-stream
875 (do ((char (stream::%read-char stream nil nil t t)
876 (stream::%read-char stream nil nil t t)))
877 ((or (not char) (char= char #\newline))))
878 ;; lisp-stream
879 (prepare-for-fast-read-char stream
880 (do ((char (fast-read-char nil nil)
881 (fast-read-char nil nil)))
882 ((or (not char) (char= char #\newline))
883 (done-with-fast-read-char))))
884 ;; fundamental-stream
885 (do ((char (stream-read-char stream) (stream-read-char stream)))
886 ((or (eq char :eof) (char= char #\newline))))))
887 ;; don't return anything
888 (values))
889
890 (defun read-list (stream ignore)
891 (declare (ignore ignore))
892 (let* ((thelist (list nil))
893 (listtail thelist))
894 (do ((firstchar (flush-whitespace stream) (flush-whitespace stream)))
895 ((char= firstchar #\) ) (cdr thelist))
896 (when (char= firstchar #\.)
897 (let ((nextchar (read-char stream t)))
898 (cond ((token-delimiterp nextchar)
899 (cond ((eq listtail thelist)
900 (if *read-suppress*
901 (return-from read-list nil)
902 (%reader-error stream _"Nothing appears before . in list.")))
903 ((whitespacep nextchar)
904 (setq nextchar (flush-whitespace stream))))
905 (rplacd listtail
906 ;;return list containing last thing.
907 (car (read-after-dot stream nextchar)))
908 (return (cdr thelist)))
909 ;;put back nextchar so we can read it normally.
910 (t (unread-char nextchar stream)))))
911 ;;next thing is not an isolated dot.
912 (let ((listobj (read-maybe-nothing stream firstchar)))
913 ;;allows the possibility that a comment was read.
914 (when listobj
915 (rplacd listtail listobj)
916 (setq listtail listobj))))))
917
918 (defun read-after-dot (stream firstchar)
919 ;;firstchar is non-whitespace!
920 (let ((lastobj ()))
921 (do ((char firstchar (flush-whitespace stream)))
922 ((char= char #\) )
923 (%reader-error stream _"Nothing appears after . in list."))
924 ;;see if there's something there.
925 (setq lastobj (read-maybe-nothing stream char))
926 (when lastobj (return t)))
927 ;;at least one thing appears after the dot.
928 ;;check for more than one thing following dot.
929 (do ((lastchar (flush-whitespace stream)
930 (flush-whitespace stream)))
931 ((char= lastchar #\) ) lastobj) ;success!
932 ;;try reading virtual whitespace
933 (if (read-maybe-nothing stream lastchar)
934 (%reader-error stream _"More than one object follows . in list.")))))
935
936 (defun read-string (stream closech)
937 ;;this accumulates chars until it sees same char that invoked it.
938 ;;for a very long string, this could end up bloating the read buffer.
939 (reset-read-buffer)
940 (let ((stream (in-synonym-of stream)))
941 (stream-dispatch stream
942 ;; simple-stream
943 (do ((char (stream::%read-char stream t nil t t)
944 (stream::%read-char stream t nil t t)))
945 ((char= char closech))
946 (if (escapep char) (setq char (stream::%read-char stream t nil t t)))
947 (ouch-read-buffer char))
948 ;; lisp-stream
949 (prepare-for-fast-read-char stream
950 (do ((char (fast-read-char t) (fast-read-char t)))
951 ((char= char closech)
952 (done-with-fast-read-char))
953 (if (escapep char) (setq char (fast-read-char t)))
954 (ouch-read-buffer char)))
955 ;; fundamental-stream
956 (do ((char (stream-read-char stream) (stream-read-char stream)))
957 ((or (eq char :eof) (char= char closech))
958 (if (eq char :eof)
959 (error 'end-of-file :stream stream)))
960 (when (escapep char)
961 (setq char (stream-read-char stream))
962 (if (eq char :eof)
963 (error 'end-of-file :stream stream)))
964 (ouch-read-buffer char))))
965 (read-buffer-to-string))
966
967 (defun read-right-paren (stream ignore)
968 (declare (ignore ignore))
969 (cond (*ignore-extra-close-parentheses*
970 (warn _"Ignoring unmatched close parenthesis~
971 ~@[ at file position ~D~]."
972 (file-position stream))
973 (values))
974 (t
975 (%reader-error stream _"Unmatched close parenthesis."))))
976
977 ;;; INTERNAL-READ-EXTENDED-TOKEN -- Internal
978 ;;;
979 ;;; Read from the stream up to the next delimiter. If escape-firstchar is
980 ;;; true then the firstchar is assumed to be escaped. Leaves resulting token
981 ;;; in *read-buffer*, returns two values:
982 ;;; -- a list of the escaped character positions, and
983 ;;; -- The position of the first package delimiter (or NIL).
984 ;;;
985 (defun internal-read-extended-token (stream firstchar escape-firstchar)
986 (reset-read-buffer)
987 (let ((escapes ()))
988 (when escape-firstchar
989 (push *ouch-ptr* escapes)
990 (ouch-read-buffer firstchar)
991 (setq firstchar (read-char stream nil eof-object)))
992 (do ((char firstchar (read-char stream nil eof-object))
993 (colon nil))
994 ((cond ((eofp char) t)
995 ((token-delimiterp char)
996 (unread-char char stream)
997 t)
998 (t nil))
999 (values escapes colon))
1000 (cond ((escapep char)
1001 ;; It can't be a number, even if it's 1\23.
1002 ;; Read next char here, so it won't be casified.
1003 (push *ouch-ptr* escapes)
1004 (let ((nextchar (read-char stream nil eof-object)))
1005 (if (eofp nextchar)
1006 (reader-eof-error stream _"after escape character")
1007 (ouch-read-buffer nextchar))))
1008 ((multiple-escape-p char)
1009 ;; Read to next multiple-escape, escaping single chars along the
1010 ;; way.
1011 (loop
1012 (let ((ch (read-char stream nil eof-object)))
1013 (cond
1014 ((eofp ch)
1015 (reader-eof-error stream _"inside extended token"))
1016 ((multiple-escape-p ch) (return))
1017 ((escapep ch)
1018 (let ((nextchar (read-char stream nil eof-object)))
1019 (cond ((eofp nextchar)
1020 (reader-eof-error stream _"after escape character"))
1021 (t
1022 (push *ouch-ptr* escapes)
1023 (ouch-read-buffer nextchar)))))
1024 (t
1025 (push *ouch-ptr* escapes)
1026 (ouch-read-buffer ch))))))
1027 (t
1028 (when (and (constituentp char)
1029 (eql (get-secondary-attribute char)
1030 #.package-delimiter)
1031 (not colon))
1032 (setq colon *ouch-ptr*))
1033 (ouch-read-buffer char))))))
1034
1035
1036 ;;;; Character classes.
1037
1038 ;;; return the character class for a char
1039 ;;;
1040 (defmacro char-class (char readtable)
1041 `(let ((att (get-cat-entry ,char ,readtable)))
1042 (declare (fixnum att))
1043 (cond ((<= att #.terminating-macro)
1044 #.delimiter)
1045 ((or (< att constituent)
1046 (= att multiple-escape))
1047 att)
1048 (t
1049 (setf att (get-secondary-attribute ,char))
1050 (cond ((= att #.constituent-invalid)
1051 (%reader-error stream _"invalid constituent"))
1052 (t
1053 att))))))
1054
1055 ;;; return the character class for a char which might be part of a rational
1056 ;;; number
1057 ;;;
1058 (defmacro char-class2 (char readtable)
1059 `(let ((att (get-cat-entry ,char ,readtable)))
1060 (declare (fixnum att))
1061 (cond ((<= att #.terminating-macro)
1062 #.delimiter)
1063 ((or (< att constituent)
1064 (= att multiple-escape))
1065 att)
1066 (t
1067 (setf att (get-secondary-attribute ,char))
1068 (cond ((digit-char-p ,char *read-base*)
1069 constituent-digit)
1070 ((= att constituent-digit)
1071 constituent)
1072 ((= att constituent-invalid)
1073 (%reader-error stream _"invalid constituent"))
1074 (t
1075 att))))))
1076
1077 ;;; return the character class for a char which might be part of a rational or
1078 ;;; floating number (assume that it is a digit if it could be)
1079 ;;;
1080 (defmacro char-class3 (char readtable)
1081 `(let ((att (get-cat-entry ,char ,readtable)))
1082 (declare (fixnum att))
1083 (cond ((<= att #.terminating-macro)
1084 #.delimiter)
1085 ((or (< att constituent)
1086 (= att multiple-escape))
1087 att)
1088 (t
1089 (setf att (get-secondary-attribute ,char))
1090 (when possibly-rational
1091 (setq possibly-rational
1092 (or (digit-char-p ,char *read-base*)
1093 (= att constituent-slash))))
1094 (when possibly-float
1095 (setq possibly-float
1096 (or (digit-char-p ,char 10)
1097 (= att constituent-dot))))
1098 (cond ((digit-char-p ,char (max *read-base* 10))
1099 (if (digit-char-p ,char *read-base*)
1100 (if (= att #.constituent-expt)
1101 constituent-digit-or-expt
1102 constituent-digit)
1103 constituent-decimal-digit))
1104 ((= att constituent-invalid)
1105 (%reader-error stream _"invalid constituent"))
1106 (t
1107 att))))))
1108
1109
1110
1111 ;;;; Token fetching.
1112
1113 (defvar *read-suppress* nil
1114 "Suppresses most interpreting of the reader when T")
1115
1116 (defvar *read-base* 10
1117 "The radix that Lisp reads numbers in.")
1118 (declaim (type (integer 2 36) *read-base*))
1119
1120 ;;; CASIFY-READ-BUFFER -- Internal
1121 ;;;
1122 ;;; Modify the *read-buffer* according to READTABLE-CASE, ignoring escapes.
1123 ;;; ESCAPES is a list of the escaped indices, in reverse order.
1124 ;;;
1125 (defun casify-read-buffer (escapes)
1126 (let ((case (readtable-case *readtable*)))
1127 (cond
1128 ((and (null escapes) (eq case :upcase))
1129 (dotimes (i *ouch-ptr*)
1130 (setf (schar *read-buffer* i) (char-upcase (schar *read-buffer* i)))))
1131 ((eq case :preserve))
1132 (t
1133 (macrolet ((skip-esc (&body body)
1134 `(do ((i (1- *ouch-ptr*) (1- i))
1135 (escapes escapes))
1136 ((minusp i))
1137 (declare (fixnum i))
1138 (when (or (null escapes)
1139 (let ((esc (first escapes)))
1140 (declare (fixnum esc))
1141 (cond ((< esc i) t)
1142 (t
1143 (assert (= esc i))
1144 (pop escapes)
1145 nil))))
1146 (let ((ch (schar *read-buffer* i)))
1147 ,@body)))))
1148 (flet ((lower-em ()
1149 (skip-esc (setf (schar *read-buffer* i) (char-downcase ch))))
1150 (raise-em ()
1151 (skip-esc (setf (schar *read-buffer* i) (char-upcase ch)))))
1152 (ecase case
1153 (:upcase (raise-em))
1154 (:downcase (lower-em))
1155 (:invert
1156 (let ((all-upper t)
1157 (all-lower t))
1158 (skip-esc
1159 (when (both-case-p ch)
1160 (if (upper-case-p ch)
1161 (setq all-lower nil)
1162 (setq all-upper nil))))
1163 (cond (all-lower (raise-em))
1164 (all-upper (lower-em))))))))))))
1165
1166 (defun read-token (stream firstchar)
1167 "This function is just an fsm that recognizes numbers and symbols."
1168 ;; Check explicitly whether FIRSTCHAR has an entry for
1169 ;; NON-TERMINATING in CHARACTER-ATTRIBUTE-TABLE and
1170 ;; READ-DOT-NUMBER-SYMBOL in CMT. Report an error if these are
1171 ;; violated. (If we called this, we want something that is a
1172 ;; legitimate token!) Read in the longest possible string satisfying
1173 ;; the Backus-Naur form for "unqualified-token". Leave the result in
1174 ;; the *READ-BUFFER*. Return next char after token (last char read).
1175 (when *read-suppress*
1176 (internal-read-extended-token stream firstchar nil)
1177 (return-from read-token nil))
1178 (let ((package-designator nil)
1179 (colons 0)
1180 (possibly-rational t)
1181 (seen-digit-or-expt nil)
1182 (possibly-float t)
1183 (was-possibly-float nil)
1184 (escapes ())
1185 (seen-multiple-escapes nil))
1186 (reset-read-buffer)
1187 (prog ((char firstchar))
1188 (case (char-class3 char *readtable*)
1189 (#.constituent-sign (go SIGN))
1190 (#.constituent-digit (go LEFTDIGIT))
1191 (#.constituent-digit-or-expt
1192 (setq seen-digit-or-expt t)
1193 (go LEFTDIGIT))
1194 (#.constituent-decimal-digit (go LEFTDECIMALDIGIT))
1195 (#.constituent-dot (go FRONTDOT))
1196 (#.escape (go ESCAPE))
1197 (#.package-delimiter (go COLON))
1198 (#.multiple-escape (go MULT-ESCAPE))
1199 (#.constituent-invalid (%reader-error stream _"invalid constituent"))
1200 ;; can't have eof, whitespace, or terminating macro as first char!
1201 (t (go SYMBOL)))
1202 SIGN ; saw "sign"
1203 (ouch-read-buffer char)
1204 (setq char (read-char stream nil nil))
1205 (unless char (go RETURN-SYMBOL))
1206 (setq possibly-rational t
1207 possibly-float t)
1208 (case (char-class3 char *readtable*)
1209 (#.constituent-digit (go LEFTDIGIT))
1210 (#.constituent-digit-or-expt
1211 (setq seen-digit-or-expt t)
1212 (go LEFTDIGIT))
1213 (#.constituent-decimal-digit (go LEFTDECIMALDIGIT))
1214 (#.constituent-dot (go SIGNDOT))
1215 (#.escape (go ESCAPE))
1216 (#.package-delimiter (go COLON))
1217 (#.multiple-escape (go MULT-ESCAPE))
1218 (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
1219 (t (go SYMBOL)))
1220 LEFTDIGIT ; saw "[sign] {digit}+"
1221 (ouch-read-buffer char)
1222 (setq char (read-char stream nil nil))
1223 (unless char (return (make-integer)))
1224 (setq was-possibly-float possibly-float)
1225 (case (char-class3 char *readtable*)
1226 (#.constituent-digit (go LEFTDIGIT))
1227 (#.constituent-decimal-digit (if possibly-float
1228 (go LEFTDECIMALDIGIT)
1229 (go SYMBOL)))
1230 (#.constituent-dot (if possibly-float
1231 (go MIDDLEDOT)
1232 (go SYMBOL)))
1233 (#.constituent-digit-or-expt
1234 (if (or seen-digit-or-expt (not was-possibly-float))
1235 (progn (setq seen-digit-or-expt t) (go LEFTDIGIT))
1236 (progn (setq seen-digit-or-expt t) (go LEFTDIGIT-OR-EXPT))))
1237 (#.constituent-expt
1238 (if was-possibly-float
1239 (go EXPONENT)
1240 (go SYMBOL)))
1241 (#.constituent-slash (if possibly-rational
1242 (go RATIO)
1243 (go SYMBOL)))
1244 (#.delimiter (unread-char char stream)
1245 (return (make-integer)))
1246 (#.escape (go ESCAPE))
1247 (#.multiple-escape (go MULT-ESCAPE))
1248 (#.package-delimiter (go COLON))
1249 (t (go SYMBOL)))
1250 LEFTDIGIT-OR-EXPT
1251 (ouch-read-buffer char)
1252 (setq char (read-char stream nil nil))
1253 (unless char (return (make-integer)))
1254 (case (char-class3 char *readtable*)
1255 (#.constituent-digit (go LEFTDIGIT))
1256 (#.constituent-decimal-digit (error _"impossible!"))
1257 (#.constituent-dot (go SYMBOL))
1258 (#.constituent-digit-or-expt (go LEFTDIGIT))
1259 (#.constituent-expt (go SYMBOL))
1260 (#.constituent-sign (go EXPTSIGN))
1261 (#.constituent-slash (if possibly-rational
1262 (go RATIO)
1263 (go SYMBOL)))
1264 (#.delimiter (unread-char char stream)
1265 (return (make-integer)))
1266 (#.escape (go ESCAPE))
1267 (#.multiple-escape (go MULT-ESCAPE))
1268 (#.package-delimiter (go COLON))
1269 (t (go SYMBOL)))
1270 LEFTDECIMALDIGIT ; saw "[sign] {decimal-digit}+"
1271 (assert possibly-float)
1272 (ouch-read-buffer char)
1273 (setq char (read-char stream nil nil))
1274 (unless char (go RETURN-SYMBOL))
1275 (case (char-class char *readtable*)
1276 (#.constituent-digit (go LEFTDECIMALDIGIT))
1277 (#.constituent-dot (go MIDDLEDOT))
1278 (#.constituent-expt (go EXPONENT))
1279 (#.constituent-slash (assert (not possibly-rational))
1280 (go SYMBOL))
1281 (#.delimiter (unread-char char stream)
1282 (go RETURN-SYMBOL))
1283 (#.escape (go ESCAPE))
1284 (#.multiple-escape (go MULT-ESCAPE))
1285 (#.package-delimiter (go COLON))
1286 (t (go SYMBOL)))
1287 MIDDLEDOT ; saw "[sign] {digit}+ dot"
1288 (ouch-read-buffer char)
1289 (setq char (read-char stream nil nil))
1290 (unless char (return (let ((*read-base* 10))
1291 (make-integer))))
1292 (case (char-class char *readtable*)
1293 (#.constituent-digit (go RIGHTDIGIT))
1294 (#.constituent-expt (go EXPONENT))
1295 (#.delimiter
1296 (unread-char char stream)
1297 (return (let ((*read-base* 10))
1298 (make-integer))))
1299 (#.escape (go ESCAPE))
1300 (#.multiple-escape (go MULT-ESCAPE))
1301 (#.package-delimiter (go COLON))
1302 (t (go SYMBOL)))
1303 RIGHTDIGIT ; saw "[sign] {decimal-digit}* dot {digit}+"
1304 (ouch-read-buffer char)
1305 (setq char (read-char stream nil nil))
1306 (unless char (return (make-float stream)))
1307 (case (char-class char *readtable*)
1308 (#.constituent-digit (go RIGHTDIGIT))
1309 (#.constituent-expt (go EXPONENT))
1310 (#.delimiter
1311 (unread-char char stream)
1312 (return (make-float stream)))
1313 (#.escape (go ESCAPE))
1314 (#.multiple-escape (go MULT-ESCAPE))
1315 (#.package-delimiter (go COLON))
1316 (t (go SYMBOL)))
1317 SIGNDOT ; saw "[sign] dot"
1318 (ouch-read-buffer char)
1319 (setq char (read-char stream nil nil))
1320 (unless char (go RETURN-SYMBOL))
1321 (case (char-class char *readtable*)
1322 (#.constituent-digit (go RIGHTDIGIT))
1323 (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
1324 (#.escape (go ESCAPE))
1325 (#.multiple-escape (go MULT-ESCAPE))
1326 (t (go SYMBOL)))
1327 FRONTDOT ; saw "dot"
1328 (ouch-read-buffer char)
1329 (setq char (read-char stream nil nil))
1330 (unless char (%reader-error stream _"dot context error"))
1331 (case (char-class char *readtable*)
1332 (#.constituent-digit (go RIGHTDIGIT))
1333 (#.constituent-dot (go DOTS))
1334 (#.delimiter (%reader-error stream _"dot context error"))
1335 (#.escape (go ESCAPE))
1336 (#.multiple-escape (go MULT-ESCAPE))
1337 (#.package-delimiter (go COLON))
1338 (t (go SYMBOL)))
1339 EXPONENT
1340 (ouch-read-buffer char)
1341 (setq char (read-char stream nil nil))
1342 (unless char (go RETURN-SYMBOL))
1343 (setq possibly-float t)
1344 (case (char-class char *readtable*)
1345 (#.constituent-sign (go EXPTSIGN))
1346 (#.constituent-digit (go EXPTDIGIT))
1347 (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
1348 (#.escape (go ESCAPE))
1349 (#.multiple-escape (go MULT-ESCAPE))
1350 (#.package-delimiter (go COLON))
1351 (t (go SYMBOL)))
1352 EXPTSIGN ; got to EXPONENT, and saw a sign character
1353 (ouch-read-buffer char)
1354 (setq char (read-char stream nil nil))
1355 (unless char (go RETURN-SYMBOL))
1356 (case (char-class char *readtable*)
1357 (#.constituent-digit (go EXPTDIGIT))
1358 (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
1359 (#.escape (go ESCAPE))
1360 (#.multiple-escape (go MULT-ESCAPE))
1361 (#.package-delimiter (go COLON))
1362 (t (go SYMBOL)))
1363 EXPTDIGIT ; got to EXPONENT, saw "[sign] {digit}+"
1364 (ouch-read-buffer char)
1365 (setq char (read-char stream nil nil))
1366 (unless char (return (make-float stream)))
1367 (case (char-class char *readtable*)
1368 (#.constituent-digit (go EXPTDIGIT))
1369 (#.delimiter
1370 (unread-char char stream)
1371 (return (make-float stream)))
1372 (#.escape (go ESCAPE))
1373 (#.multiple-escape (go MULT-ESCAPE))
1374 (#.package-delimiter (go COLON))
1375 (t (go SYMBOL)))
1376 RATIO ; saw "[sign] {digit}+ slash"
1377 (ouch-read-buffer char)
1378 (setq char (read-char stream nil nil))
1379 (unless char (go RETURN-SYMBOL))
1380 (case (char-class2 char *readtable*)
1381 (#.constituent-digit (go RATIODIGIT))
1382 (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
1383 (#.escape (go ESCAPE))
1384 (#.multiple-escape (go MULT-ESCAPE))
1385 (#.package-delimiter (go COLON))
1386 (t (go SYMBOL)))
1387 RATIODIGIT ; saw "[sign] {digit}+ slash {digit}+"
1388 (ouch-read-buffer char)
1389 (setq char (read-char stream nil nil))
1390 (unless char (return (make-ratio stream)))
1391 (case (char-class2 char *readtable*)
1392 (#.constituent-digit (go RATIODIGIT))
1393 (#.delimiter
1394 (unread-char char stream)
1395 (return (make-ratio stream)))
1396 (#.escape (go ESCAPE))
1397 (#.multiple-escape (go MULT-ESCAPE))
1398 (#.package-delimiter (go COLON))
1399 (t (go SYMBOL)))
1400 DOTS ; saw "dot {dot}+"
1401 (ouch-read-buffer char)
1402 (setq char (read-char stream nil nil))
1403 (unless char (%reader-error stream _"too many dots"))
1404 (case (char-class char *readtable*)
1405 (#.constituent-dot (go DOTS))
1406 (#.delimiter
1407 (unread-char char stream)
1408 (%reader-error stream _"too many dots"))
1409 (#.escape (go ESCAPE))
1410 (#.multiple-escape (go MULT-ESCAPE))
1411 (#.package-delimiter (go COLON))
1412 (t (go SYMBOL)))
1413 SYMBOL ; not a dot, dots, or number
1414 (let ((stream (in-synonym-of stream)))
1415 (stream-dispatch stream
1416 ;; simple-stream
1417 (prog ()
1418 SYMBOL-LOOP
1419 (ouch-read-buffer char)
1420 (setq char (stream::%read-char stream nil nil t t))
1421 (unless char (go RETURN-SYMBOL))
1422 (case (char-class char *readtable*)
1423 (#.escape (go ESCAPE))
1424 (#.delimiter (stream::%unread-char stream char)
1425 (go RETURN-SYMBOL))
1426 (#.multiple-escape (go MULT-ESCAPE))
1427 (#.package-delimiter (go COLON))
1428 (t (go SYMBOL-LOOP))))
1429 ;; lisp stream
1430 (prepare-for-fast-read-char stream
1431 (prog ()
1432 SYMBOL-LOOP
1433 (ouch-read-buffer char)
1434 (setq char (fast-read-char nil nil))
1435 (unless char (go RETURN-SYMBOL))
1436 (case (char-class char *readtable*)
1437 (#.escape (done-with-fast-read-char)
1438 (go ESCAPE))
1439 (#.delimiter (done-with-fast-read-char)
1440 (unread-char char stream)
1441 (go RETURN-SYMBOL))
1442 (#.multiple-escape (done-with-fast-read-char)
1443 (go MULT-ESCAPE))
1444 (#.package-delimiter (done-with-fast-read-char)
1445 (go COLON))
1446 (t (go SYMBOL-LOOP)))))
1447 ;; fundamental-stream
1448 (prog ()
1449 SYMBOL-LOOP
1450 (ouch-read-buffer char)
1451 (setq char (read-char stream nil :eof))
1452 (when (eq char :eof) (go RETURN-SYMBOL))
1453 (case (char-class char *readtable*)
1454 (#.escape (go ESCAPE))
1455 (#.delimiter (unread-char char stream)
1456 (go RETURN-SYMBOL))
1457 (#.multiple-escape (go MULT-ESCAPE))
1458 (#.package-delimiter (go COLON))
1459 (t (go SYMBOL-LOOP))))))
1460 ESCAPE ; saw an escape
1461 ;; Don't put the escape in the read buffer.
1462 ;; READ-NEXT CHAR, put in buffer (no case conversion).
1463 (let ((nextchar (read-char stream nil nil)))
1464 (unless nextchar
1465 (reader-eof-error stream _"after escape character"))
1466 (push *ouch-ptr* escapes)
1467 (ouch-read-buffer nextchar))
1468 (setq char (read-char stream nil nil))
1469 (unless char (go RETURN-SYMBOL))
1470 (case (char-class char *readtable*)
1471 (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
1472 (#.escape (go ESCAPE))
1473 (#.multiple-escape (go MULT-ESCAPE))
1474 (#.package-delimiter (go COLON))
1475 (t (go SYMBOL)))
1476 MULT-ESCAPE
1477 (setq seen-multiple-escapes t)
1478 (do ((char (read-char stream t) (read-char stream t)))
1479 ((multiple-escape-p char))
1480 (if (escapep char) (setq char (read-char stream t)))
1481 (push *ouch-ptr* escapes)
1482 (ouch-read-buffer char))
1483 (setq char (read-char stream nil nil))
1484 (unless char (go RETURN-SYMBOL))
1485 (case (char-class char *readtable*)
1486 (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
1487 (#.escape (go ESCAPE))
1488 (#.multiple-escape (go MULT-ESCAPE))
1489 (#.package-delimiter (go COLON))
1490 (t (go SYMBOL)))
1491 COLON
1492 (casify-read-buffer escapes)
1493 (unless (zerop colons)
1494 (%reader-error stream _"too many colons in ~S"
1495 (read-buffer-to-string)))
1496 (setq colons 1)
1497 (setq package-designator
1498 (if (plusp *ouch-ptr*)
1499 ;; FIXME: It seems inefficient to cons up a package
1500 ;; designator string every time we read a symbol with an
1501 ;; explicit package prefix. Perhaps we could implement
1502 ;; a FIND-PACKAGE* function analogous to INTERN*
1503 ;; and friends?
1504 (read-buffer-to-string)
1505 (if seen-multiple-escapes
1506 (read-buffer-to-string)
1507 *keyword-package*)))
1508 (reset-read-buffer)
1509 (setq escapes ())
1510 (setq char (read-char stream nil nil))
1511 (unless char (reader-eof-error stream _"after reading a colon"))
1512 (case (char-class char *readtable*)
1513 (#.delimiter
1514 (unread-char char stream)
1515 (%reader-error stream
1516 "illegal terminating character after a colon: ~S"
1517 char))
1518 (#.escape (go ESCAPE))
1519 (#.multiple-escape (go MULT-ESCAPE))
1520 (#.package-delimiter (go INTERN))
1521 (t (go SYMBOL)))
1522 INTERN
1523 (setq colons 2)
1524 (setq char (read-char stream nil nil))
1525 (unless char
1526 (reader-eof-error stream _"after reading a colon"))
1527 (case (char-class char *readtable*)
1528 (#.delimiter
1529 (unread-char char stream)
1530 (%reader-error stream
1531 "illegal terminating character after a colon: ~S"
1532 char))
1533 (#.escape (go ESCAPE))
1534 (#.multiple-escape (go MULT-ESCAPE))
1535 (#.package-delimiter
1536 (%reader-error stream
1537 "too many colons after ~S name"
1538 package-designator))
1539 (t (go SYMBOL)))
1540 RETURN-SYMBOL
1541 (casify-read-buffer escapes)
1542 (let ((found (if package-designator
1543 (find-package package-designator)
1544 *package*)))
1545 (unless found
1546 (error 'reader-package-error :stream stream
1547 :format-arguments (list package-designator)
1548 :format-control _"package ~S not found"))
1549
1550 (if (or (zerop colons) (= colons 2) (eq found *keyword-package*))
1551 (return (intern* *read-buffer* *ouch-ptr* found))
1552 (multiple-value-bind (symbol test)
1553 (find-symbol* *read-buffer* *ouch-ptr* found)
1554 (when (eq test :external) (return symbol))
1555 (let ((name (read-buffer-to-string)))
1556 (with-simple-restart (continue _"Use symbol anyway.")
1557 (error 'reader-package-error :stream stream
1558 :format-arguments (list name (package-name found))
1559 :format-control
1560 (if test
1561 _"The symbol ~S is not external in the ~A package."
1562 _"Symbol ~S not found in the ~A package.")))
1563 (return (intern name found)))))))))
1564
1565
1566 (defun read-extended-token (stream &optional (*readtable* *readtable*))
1567 "For semi-external use: returns 3 values: the string for the token,
1568 a flag for whether there was an escape char, and the position of any
1569 package delimiter."
1570 (let ((firstch (read-char stream nil nil t)))
1571 (cond (firstch
1572 (multiple-value-bind (escapes colon)
1573 (internal-read-extended-token stream firstch nil)
1574 (casify-read-buffer escapes)
1575 (values (read-buffer-to-string) (not (null escapes)) colon)))
1576 (t
1577 (values "" nil nil)))))
1578
1579 (defun read-extended-token-escaped (stream &optional (*readtable* *readtable*))
1580 "For semi-external use: read an extended token with the first character
1581 escaped. Returns the string for the token."
1582 (let ((firstch (read-char stream nil nil)))
1583 (cond (firstch
1584 (let ((escapes (internal-read-extended-token stream firstch t)))
1585 (casify-read-buffer escapes)
1586 (read-buffer-to-string)))
1587 (t
1588 (reader-eof-error stream _"after escape")))))
1589
1590
1591
1592 ;;;; Number reading functions.
1593
1594 (defmacro exponent-letterp (letter)
1595 `(memq ,letter '(#\E #\S #\F #\L #\D #\e #\s #\f #\l #\d
1596 #+double-double #\w
1597 #+double-double #\W)))
1598
1599
1600 (defvar *integer-reader-safe-digits*
1601 '#(NIL NIL
1602 26 17 13 11 10 9 8 8 8 7 7 7 7 6 6 6 6 6 6 6 6 5 5 5 5 5 5 5 5 5 5 5 5 5 5)
1603 "Holds the mapping of base to 'safe' number of digits to read for a fixnum.")
1604
1605 (defvar *integer-reader-base-power*
1606 '#(NIL NIL
1607 67108864 129140163 67108864 48828125 60466176 40353607
1608 16777216 43046721 100000000 19487171 35831808 62748517 105413504 11390625
1609 16777216 24137569 34012224 47045881 64000000 85766121 113379904 6436343
1610 7962624 9765625 11881376 14348907 17210368 20511149 24300000 28629151
1611 33554432 39135393 45435424 52521875 60466176)
1612 "Holds the largest fixnum power of the base for make-integer.")
1613
1614 (declaim (simple-vector *integer-reader-safe-digits*
1615 *integer-reader-base-power*))
1616 #||
1617 ;; This function was used to initialize the variables above.
1618 (defun init-integer-reader ()
1619 (do ((base 2 (1+ base)))
1620 ((> base 36))
1621 (let ((digits
1622 (do ((fix (truncate most-positive-fixnum base)
1623 (truncate fix base))
1624 (digits 0 (1+ digits)))
1625 ((zerop fix) digits))))
1626 (setf (aref *integer-reader-safe-digits* base)
1627 digits
1628 (aref *integer-reader-base-power* base)
1629 (expt base digits)))))
1630 |#
1631
1632 (defun make-integer ()
1633 "Minimizes bignum-fixnum multiplies by reading a 'safe' number of digits,
1634 then multiplying by a power of the base and adding."
1635 (read-unwind-read-buffer)
1636 ;; Use the fast reader if the number has enough digits. It seems
1637 ;; that the fast reader is slower for small numbers but much faster
1638 ;; for large numbers. The value of 500 is an approximate break-even
1639 ;; point.
1640 (if (>= (the fixnum *ouch-ptr*) 500)
1641 (fast-read-integer *read-base*)
1642 (let* ((base *read-base*)
1643 (digits-per (aref *integer-reader-safe-digits* base))
1644 (base-power (aref *integer-reader-base-power* base))
1645 (negativep nil)
1646 (number 0))
1647 (declare (type index digits-per base-power))
1648 (let ((char (inch-read-buffer)))
1649 (cond ((char= char #\-)
1650 (setq negativep t))
1651 ((char= char #\+))
1652 (t (unread-buffer))))
1653 (loop
1654 (let ((num 0))
1655 (declare (type index num))
1656 (dotimes (digit digits-per)
1657 (let* ((ch (inch-read-buffer)))
1658 (cond ((or (eofp ch) (char= ch #\.))
1659 (return-from make-integer
1660 (let ((res
1661 (if (zerop number) num
1662 (+ num (* number
1663 (expt base digit))))))
1664 (if negativep (- res) res))))
1665 (t (setq num (+ (digit-char-p ch base)
1666 (the index (* num base))))))))
1667 (setq number (+ num (* number base-power))))))))
1668
1669 (defun fast-read-integer (r)
1670 "Fast bignum-reading interface. Reads from stream S an integer in radix
1671 R. If we find some kind of error (bad characters, EOF), then NIL is
1672 returned; otherwise the number. Reads at least one digit, but may not get to
1673 the end of the stream."
1674 (let ((v (make-array 32 :element-type 'integer
1675 :adjustable t :fill-pointer 0)))
1676 ;; V maps integers i to r^(2^i).
1677 (vector-push-extend r v)
1678 (labels ((scan (ch l)
1679 ;; Character CH has been read. L contains a list of entries
1680 ;; of the form (n . i), where i is the base-2 log of the
1681 ;; length of n in digits. We read digits and push entries
1682 ;; onto the front of the list as (d . 1), and then fix the
1683 ;; list to maintain the invariant that entries on the list
1684 ;; have strictly increasing length.
1685 (declare (type (or character list) ch) (list l))
1686 (if (or (eofp ch) (char= ch #\.))
1687 (finish l)
1688 (let ((d (digit-char-p ch r)))
1689 (declare (type (or null fixnum) d))
1690 (labels ((fix (x i l)
1691 (declare (integer x) (fixnum i) (list l))
1692 (if (>= i (fill-pointer v))
1693 (vector-push-extend
1694 (let ((x (aref v (1- i))))
1695 (* x x))
1696 v))
1697 (if (null l)
1698 (scan (inch-read-buffer) (cons (cons x i) nil))
1699 (let ((y (caar l)) (j (cdar l)) (rest (cdr l)))
1700 (declare (integer y) (fixnum j) (list l))
1701 (if (= i j)
1702 (fix (+ (* y (aref v i)) x) (1+ i) rest)
1703 (scan (inch-read-buffer) (cons (cons x i) l)))))))
1704 (fix d 0 l)))))
1705 (finish (l)
1706 ;; Convert the list into a final answer. The main loop below
1707 ;; counts Z as the length of what we've built so far in
1708 ;; digits. Remember that, since this is a stack, we're
1709 ;; effectively working right-to-left here.
1710 (declare (list l))
1711 (labels ((create-integer (a z l)
1712 (declare (integer a z) (list l))
1713 (if (null l)
1714 a
1715 (create-integer (+ (* z (the integer (caar l))) a)
1716 (* z (aref v (cdar l)))
1717 (cdr l)))))
1718 (create-integer 0 1 l))))
1719 (let ((ch (inch-read-buffer)))
1720 (cond ((char= ch #\-)
1721 (let ((n (scan (inch-read-buffer) nil)))
1722 (- n)))
1723 ((char= ch #\+)
1724 (scan (inch-read-buffer) nil))
1725 (t
1726 (scan ch nil)))))))
1727
1728
1729 (defun make-float (stream)
1730 ;; Assume that the contents of *read-buffer* are a legal float, with nothing
1731 ;; else after it.
1732 (read-unwind-read-buffer)
1733 (let ((negative-fraction nil)
1734 (number 0)
1735 (divisor 1)
1736 (negative-exponent nil)
1737 (exponent 0)
1738 (float-char ())
1739 (char (inch-read-buffer)))
1740 (if (cond ((char= char #\+) t)
1741 ((char= char #\-) (setq negative-fraction t)))
1742 ;; Flush it.
1743 (setq char (inch-read-buffer)))
1744 ;; Read digits before the dot.
1745 (do* ((ch char (inch-read-buffer))
1746 (dig (digit-char-p ch) (digit-char-p ch)))
1747 ((not dig) (setq char ch))
1748 (setq number (+ (* number 10) dig)))
1749 ;; Deal with the dot, if it's there.
1750 (when (char= char #\.)
1751 (setq char (inch-read-buffer))
1752 ;; Read digits after the dot.
1753 (do* ((ch char (inch-read-buffer))
1754 (dig (and (not (eofp ch)) (digit-char-p ch))
1755 (and (not (eofp ch)) (digit-char-p ch))))
1756 ((not dig) (setq char ch))
1757 (setq divisor (* divisor 10))
1758 (setq number (+ (* number 10) dig))))
1759 ;; Is there an exponent letter?
1760 (cond ((eofp char)
1761 ;; If not, we've read the whole number.
1762 (let ((num (make-float-aux number divisor
1763 *read-default-float-format*
1764 stream)))
1765 (return-from make-float (if negative-fraction (- num) num))))
1766 ((exponent-letterp char)
1767 (setq float-char char)
1768 ;; Build exponent.
1769 (setq char (inch-read-buffer))
1770 ;; Check leading sign.
1771 (if (cond ((char= char #\+) t)
1772 ((char= char #\-) (setq negative-exponent t)))
1773 ;; Flush sign.
1774 (setq char (inch-read-buffer)))
1775 ;; Read digits for exponent.
1776 (do* ((ch char (inch-read-buffer))
1777 (dig (and (not (eofp ch)) (digit-char-p ch))
1778 (and (not (eofp ch)) (digit-char-p ch))))
1779 ((not dig)
1780 (setq exponent (if negative-exponent (- exponent) exponent)))
1781 (setq exponent (+ (* exponent 10) dig)))
1782 ;; Generate and return the float, depending on FLOAT-CHAR:
1783 (let* ((float-format (case (char-upcase float-char)
1784 (#\E *read-default-float-format*)
1785 (#\S 'short-float)
1786 (#\F 'single-float)
1787 (#\D 'double-float)
1788 (#\L 'long-float)
1789 #+double-double
1790 (#\W 'kernel:double-double-float)))
1791 num)
1792 (setq num (make-float-aux (* (expt 10 exponent) number) divisor
1793 float-format stream))
1794
1795 (return-from make-float (if negative-fraction
1796 (- num)
1797 num))))
1798 (t (error _"Internal error in floating point reader.")))))
1799
1800 (defun make-float-aux (number divisor float-format stream)
1801 (handler-case
1802 (with-float-traps-masked (:underflow)
1803 (let ((result (coerce (/ number divisor) float-format)))
1804 (when (and (zerop result) (not (zerop number)))
1805 ;; With underflow traps disabled, reading any number
1806 ;; smaller than least-positive-foo-float will return zero.
1807 ;; But we really want to indicate that we can't read it.
1808 ;; So if we converted the number to zero, but the number
1809 ;; wasn't actually zero, throw an error.
1810 (error _"Underflow"))
1811 result))
1812 (error ()
1813 (%reader-error stream _"Floating-point number not representable"))))
1814
1815
1816 (defun make-ratio (stream)
1817 ;;assume *read-buffer* contains a legal ratio. Build the number from
1818 ;;the string.
1819 ;;look for optional "+" or "-".
1820 (let ((numerator 0) (denominator 0) (char ()) (negative-number nil))
1821 (read-unwind-read-buffer)
1822 (setq char (inch-read-buffer))
1823 (cond ((char= char #\+)
1824 (setq char (inch-read-buffer)))
1825 ((char= char #\-)
1826 (setq char (inch-read-buffer))
1827 (setq negative-number t)))
1828 ;;get numerator
1829 (do* ((ch char (inch-read-buffer))
1830 (dig (digit-char-p ch *read-base*)
1831 (digit-char-p ch *read-base*)))
1832 ((not dig))
1833 (setq numerator (+ (* numerator *read-base*) dig)))
1834 ;;get denominator
1835 (do* ((ch (inch-read-buffer) (inch-read-buffer))
1836 (dig ()))
1837 ((or (eofp ch) (not (setq dig (digit-char-p ch *read-base*)))))
1838 (setq denominator (+ (* denominator *read-base*) dig)))
1839 (when (zerop denominator)
1840 (%reader-error stream _"Invalid ratio: ~S/~S"
1841 (if negative-number (- numerator) numerator)
1842 denominator))
1843 (let ((num (/ numerator denominator)))
1844 (if negative-number (- num) num))))
1845
1846
1847
1848 ;;;; dispatching macro cruft
1849
1850 (defun dispatch-char-error (stream sub-char ignore)
1851 (declare (ignore ignore))
1852 (if *read-suppress*
1853 (values)
1854 (%reader-error stream _"No dispatch function defined for ~S." sub-char)))
1855
1856 (defun make-dispatch-macro-character (char &optional
1857 (non-terminating-p nil)
1858 (rt *readtable*))
1859 "Causes char to become a dispatching macro character in readtable
1860 (which defaults to the current readtable). If the non-terminating-p
1861 flag is set to T, the char will be non-terminating. Make-dispatch-
1862 macro-character returns T."
1863 (set-macro-character char #'read-dispatch-char non-terminating-p rt)
1864 (let ((dalist (dispatch-tables rt)))
1865 (setf (dispatch-tables rt)
1866 (push (cons char (make-char-dispatch-table)) dalist)))
1867 t)
1868
1869 (defun set-dispatch-macro-character
1870 (disp-char sub-char function &optional (rt *readtable*))
1871 "Causes function to be called whenever the reader reads
1872 disp-char followed by sub-char. Set-dispatch-macro-character
1873 returns T."
1874 ;;get the dispatch char for macro (error if not there), diddle
1875 ;;entry for sub-char.
1876 (when (digit-char-p sub-char)
1877 (simple-program-error _"Dispatch Sub-Char must not be a decimal digit: ~S" sub-char))
1878 (let* ((sub-char (char-upcase sub-char))
1879 (dpair (find disp-char (dispatch-tables rt)
1880 :test #'char= :key #'car)))
1881 (if dpair
1882 (set-dispatch-char sub-char function (cdr dpair))
1883 (simple-program-error _"~S is not a dispatch character." disp-char))))
1884
1885 (defun get-dispatch-macro-character
1886 (disp-char sub-char &optional (rt *readtable*))
1887 "Returns the macro character function for sub-char under disp-char
1888 or nil if there is no associated function."
1889 (unless (digit-char-p sub-char)
1890 (let* ((sub-char (char-upcase sub-char))
1891 (rt (or rt std-lisp-readtable))
1892 (dpair (find disp-char (dispatch-tables rt)
1893 :test #'char= :key #'car)))
1894 (if dpair
1895 (get-dispatch-char sub-char (cdr dpair))
1896 (simple-program-error _"~S is not a dispatch character." disp-char)))))
1897
1898 (defun read-dispatch-char (stream char)
1899 ;;read some digits
1900 (let ((numargp nil)
1901 (numarg 0)
1902 (sub-char ()))
1903 (do* ((ch (read-char stream nil eof-object)
1904 (read-char stream nil eof-object))
1905 (dig ()))
1906 ((or (eofp ch)
1907 (not (setq dig (digit-char-p ch))))
1908 ;;take care of the extra char.
1909 (if (eofp ch)
1910 (reader-eof-error stream _"inside dispatch character")
1911 (setq sub-char (char-upcase ch))))
1912 (setq numargp t)
1913 (setq numarg (+ (* numarg 10) dig)))
1914 ;;look up the function and call it.
1915 (let ((dpair (find char (dispatch-tables *readtable*)
1916 :test #'char= :key #'car)))
1917 (if dpair
1918 (funcall (the function (get-dispatch-char sub-char (cdr dpair)))
1919 stream sub-char (if numargp numarg nil))
1920 (%reader-error stream _"No dispatch table for dispatch char.")))))
1921
1922
1923
1924 ;;;; READ-FROM-STRING.
1925
1926 (defvar read-from-string-spares ()
1927 "A resource of string streams for Read-From-String.")
1928
1929 (defun read-from-string (string &optional (eof-error-p t) eof-value
1930 &key (start 0) end
1931 preserve-whitespace)
1932 "The characters of string are successively given to the lisp reader
1933 and the lisp object built by the reader is returned. Macro chars
1934 will take effect."
1935 (declare (string string))
1936 (with-array-data ((string string :offset-var offset)
1937 (start start)
1938 (end (or end (length string))))
1939 (unless read-from-string-spares
1940 (push (internal-make-string-input-stream "" 0 0)
1941 read-from-string-spares))
1942 (let ((stream (pop read-from-string-spares)))
1943 (setf (string-input-stream-string stream) string)
1944 (setf (string-input-stream-current stream) start)
1945 (setf (string-input-stream-end stream) end)
1946 (unwind-protect
1947 (values (if preserve-whitespace
1948 (read-preserving-whitespace stream eof-error-p eof-value)
1949 (read stream eof-error-p eof-value))
1950 (- (string-input-stream-current stream) offset))
1951 (push stream read-from-string-spares)))))
1952
1953
1954 ;;;; PARSE-INTEGER.
1955
1956 (defun parse-integer (string &key (start 0) end (radix 10) junk-allowed)
1957 "Examine the substring of string delimited by start and end
1958 (default to the beginning and end of the string) It skips over
1959 whitespace characters and then tries to parse an integer. The
1960 radix parameter must be between 2 and 36."
1961 (let ((orig-start start))
1962 (with-array-data ((string string)
1963 (start start)
1964 (end (or end (length string))))
1965 (let ((index start)
1966 (sign 1)
1967 (any-digits nil)
1968 (result 0))
1969 (declare (type index index)
1970 (type (member 1 -1) sign)
1971 (type boolean any-digits)
1972 (integer result))
1973 (flet ((skip-whitespace ()
1974 (loop while (< index end)
1975 while (whitespacep (char string index)) do
1976 (incf index))))
1977 (declare (inline skip-whitespace))
1978 (skip-whitespace)
1979 (when (< index end)
1980 (case (char string index)
1981 (#\+ (incf index))
1982 (#\- (incf index) (setq sign -1))))
1983 (loop while (< index end)
1984 for weight = (digit-char-p (char string index) radix)
1985 while weight do
1986 (incf index)
1987 (setq any-digits t)
1988 (setq result (+ (* radix result) weight)))
1989 (unless junk-allowed (skip-whitespace))
1990 ;;
1991 ;; May be /= index if string is displaced.
1992 (let ((real-index (+ (- index start) orig-start)))
1993 (cond ((not any-digits)
1994 (if junk-allowed
1995 (values nil real-index)
1996 (error 'simple-parse-error
1997 :format-control _"There are no digits in this string: ~S"
1998 :format-arguments (list string))))
1999 ((and (< index end) (not junk-allowed))
2000 (error 'simple-parse-error
2001 :format-control _"There's junk in this string: ~S."
2002 :format-arguments (list string)))
2003 (t
2004 (values (* sign result) real-index)))))))))
2005
2006
2007 ;;;; Reader initialization code.
2008
2009 (defun reader-init ()
2010 (init-read-buffer-stack)
2011 (init-secondary-attribute-table)
2012 (init-std-lisp-readtable)
2013 ; (init-integer-reader)
2014 )

  ViewVC Help
Powered by ViewVC 1.1.5