src/code/reader.lisp

   1 ;;;; READ and friends
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   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.
  11
  12 (in-package "SB!IMPL")
  13 \f
  14 ;;;; miscellaneous global variables
  15
  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*))
  22
  23 (defvar *readtable*)
  24 (declaim (type readtable *readtable*))
  25 #!+sb-doc
  26 (setf (fdocumentation '*readtable* 'variable)
  27        "Variable bound to current readtable.")
  28
  29 ;;; a standard Lisp readtable. This is for recovery from broken
  30 ;;; read-tables (and for WITH-STANDARD-IO-SYNTAX), and should not
  31 ;;; normally be user-visible.
  32 (defvar *standard-readtable*)
  33
  34 (defvar *old-package* nil
  35   #!+sb-doc
  36   "the value of *PACKAGE* at the start of the last read, or NIL")
  37
  38 ;;; In case we get an error trying to parse a symbol, we want to rebind the
  39 ;;; above stuff so it's cool.
  40
  41 ;;; FIXME: These forward declarations should be moved somewhere earlier,
  42 ;;; or discarded.
  43 (declaim (special *package* *keyword-package* *read-base*))
  44 \f
  45 ;;;; reader errors
  46
  47 (defun reader-eof-error (stream context)
  48   (error 'reader-eof-error
  49          :stream stream
  50          :context context))
  51
  52 (defun %reader-error (stream control &rest args)
  53   (error 'reader-error
  54          :stream stream
  55          :format-control control
  56          :format-arguments args))
  57 \f
  58 ;;;; macros and functions for character tables
  59
  60 ;;; FIXME: could be SB!XC:DEFMACRO inside EVAL-WHEN (COMPILE EVAL)
  61 (defmacro get-cat-entry (char rt)
  62   ;; KLUDGE: Only give this side-effect-free args.
  63   ;; FIXME: should probably become inline function
  64   `(if (typep ,char 'base-char)
  65        (elt (character-attribute-array ,rt) (char-code ,char))
  66        (gethash ,char (character-attribute-hash-table ,rt)
  67         +char-attr-constituent+)))
  68
  69 (defun set-cat-entry (char newvalue &optional (rt *readtable*))
  70   (if (typep char 'base-char)
  71       (setf (elt (character-attribute-array rt) (char-code char)) newvalue)
  72       ;; FIXME: could REMHASH if we're setting to
  73       ;; +CHAR-ATTR-CONSTITUENT+
  74       (setf (gethash char (character-attribute-hash-table rt)) newvalue)))
  75
  76 ;;; the value actually stored in the character macro table. As per
  77 ;;; ANSI #'GET-MACRO-CHARACTER and #'SET-MACRO-CHARACTER, this can
  78 ;;; be either a function or NIL.
  79 (eval-when (:compile-toplevel :execute)
  80   (sb!xc:defmacro get-raw-cmt-entry (char readtable)
  81     `(if (typep ,char 'base-char)
  82          (svref (character-macro-array ,readtable) (char-code ,char))
  83          ;; Note: DEFAULT here is NIL, not #'UNDEFINED-MACRO-CHAR, so
  84          ;; that everything above the base-char range is a non-macro
  85          ;; constituent by default.
  86          (gethash ,char (character-macro-hash-table ,readtable) nil))))
  87
  88 ;;; the value represented by whatever is stored in the character macro
  89 ;;; table. As per ANSI #'GET-MACRO-CHARACTER and #'SET-MACRO-CHARACTER,
  90 ;;; a function value represents itself, and a NIL value represents the
  91 ;;; default behavior.
  92 (defun get-coerced-cmt-entry (char readtable)
  93   (the function
  94     (or (get-raw-cmt-entry char readtable)
  95         #'read-token)))
  96
  97 (defun set-cmt-entry (char new-value-designator &optional (rt *readtable*))
  98   (if (typep char 'base-char)
  99       (setf (svref (character-macro-array rt) (char-code char))
 100             (and new-value-designator
 101                  (%coerce-callable-to-fun new-value-designator)))
 102       (setf (gethash char (character-macro-hash-table rt))
 103         (and new-value-designator
 104                  (%coerce-callable-to-fun new-value-designator)))))
 105
 106 (defun undefined-macro-char (stream char)
 107   (unless *read-suppress*
 108     (%reader-error stream "undefined read-macro character ~S" char)))
 109
 110 ;;; The character attribute table is a CHAR-CODE-LIMIT vector of integers.
 111
 112 (defmacro test-attribute (char whichclass rt)
 113   `(= (the fixnum (get-cat-entry ,char ,rt)) ,whichclass))
 114
 115 ;;; predicates for testing character attributes
 116
 117 #!-sb-fluid (declaim (inline whitespacep))
 118 (defun whitespacep (char &optional (rt *readtable*))
 119   (test-attribute char +char-attr-whitespace+ rt))
 120
 121 (defmacro constituentp (char &optional (rt '*readtable*))
 122   `(test-attribute ,char +char-attr-constituent+ ,rt))
 123
 124 (defmacro terminating-macrop (char &optional (rt '*readtable*))
 125   `(test-attribute ,char +char-attr-terminating-macro+ ,rt))
 126
 127 (defmacro single-escape-p (char &optional (rt '*readtable*))
 128   `(test-attribute ,char +char-attr-single-escape+ ,rt))
 129
 130 (defmacro multiple-escape-p (char &optional (rt '*readtable*))
 131   `(test-attribute ,char +char-attr-multiple-escape+ ,rt))
 132
 133 (defmacro token-delimiterp (char &optional (rt '*readtable*))
 134   ;; depends on actual attribute numbering above.
 135   `(<= (get-cat-entry ,char ,rt) +char-attr-terminating-macro+))
 136 \f
 137 ;;;; constituent traits (see ANSI 2.1.4.2)
 138
 139 ;;; There are a number of "secondary" attributes which are constant
 140 ;;; properties of characters (as long as they are constituents).
 141
 142 (defvar *constituent-trait-table*)
 143 (declaim (type attribute-table *constituent-trait-table*))
 144
 145 (defun !set-constituent-trait (char trait)
 146   (aver (typep char 'base-char))
 147   (setf (elt *constituent-trait-table* (char-code char))
 148         trait))
 149
 150 (defun !cold-init-constituent-trait-table ()
 151   (setq *constituent-trait-table*
 152         (make-array base-char-code-limit :element-type '(unsigned-byte 8)
 153                     :initial-element +char-attr-constituent+))
 154   (!set-constituent-trait #\: +char-attr-package-delimiter+)
 155   (!set-constituent-trait #\. +char-attr-constituent-dot+)
 156   (!set-constituent-trait #\+ +char-attr-constituent-sign+)
 157   (!set-constituent-trait #\- +char-attr-constituent-sign+)
 158   (!set-constituent-trait #\/ +char-attr-constituent-slash+)
 159   (do ((i (char-code #\0) (1+ i)))
 160       ((> i (char-code #\9)))
 161     (!set-constituent-trait (code-char i) +char-attr-constituent-digit+))
 162   (!set-constituent-trait #\E +char-attr-constituent-expt+)
 163   (!set-constituent-trait #\F +char-attr-constituent-expt+)
 164   (!set-constituent-trait #\D +char-attr-constituent-expt+)
 165   (!set-constituent-trait #\S +char-attr-constituent-expt+)
 166   (!set-constituent-trait #\L +char-attr-constituent-expt+)
 167   (!set-constituent-trait #\e +char-attr-constituent-expt+)
 168   (!set-constituent-trait #\f +char-attr-constituent-expt+)
 169   (!set-constituent-trait #\d +char-attr-constituent-expt+)
 170   (!set-constituent-trait #\s +char-attr-constituent-expt+)
 171   (!set-constituent-trait #\l +char-attr-constituent-expt+)
 172   (!set-constituent-trait #\Space +char-attr-invalid+)
 173   (!set-constituent-trait #\Newline +char-attr-invalid+)
 174   (dolist (c (list backspace-char-code tab-char-code form-feed-char-code
 175                    return-char-code rubout-char-code))
 176     (!set-constituent-trait (code-char c) +char-attr-invalid+)))
 177
 178 (defmacro get-constituent-trait (char)
 179   `(if (typep ,char 'base-char)
 180        (elt *constituent-trait-table* (char-code ,char))
 181        +char-attr-constituent+))
 182 \f
 183 ;;;; readtable operations
 184
 185 (defun shallow-replace/eql-hash-table (to from)
 186   (maphash (lambda (k v) (setf (gethash k to) v)) from))
 187
 188 (defun copy-readtable (&optional (from-readtable *readtable*)
 189                                  to-readtable)
 190   (let ((really-from-readtable (or from-readtable *standard-readtable*))
 191         (really-to-readtable (or to-readtable (make-readtable))))
 192     (replace (character-attribute-array really-to-readtable)
 193              (character-attribute-array really-from-readtable))
 194     (shallow-replace/eql-hash-table
 195      (character-attribute-hash-table really-to-readtable)
 196      (character-attribute-hash-table really-from-readtable))
 197     (replace (character-macro-array really-to-readtable)
 198              (character-macro-array really-from-readtable))
 199     (shallow-replace/eql-hash-table
 200      (character-macro-hash-table really-to-readtable)
 201      (character-macro-hash-table really-from-readtable))
 202     (setf (dispatch-tables really-to-readtable)
 203           (mapcar (lambda (pair)
 204                     (cons (car pair)
 205                           (let ((table (make-hash-table)))
 206                             (shallow-replace/eql-hash-table table (cdr pair))
 207                             table)))
 208                   (dispatch-tables really-from-readtable)))
 209     (setf (readtable-case really-to-readtable)
 210           (readtable-case really-from-readtable))
 211     really-to-readtable))
 212
 213 (defun set-syntax-from-char (to-char from-char &optional
 214                                      (to-readtable *readtable*)
 215                                      (from-readtable ()))
 216   #!+sb-doc
 217   "Causes the syntax of TO-CHAR to be the same as FROM-CHAR in the
 218   optional readtable (defaults to the current readtable). The
 219   FROM-TABLE defaults to the standard Lisp readtable when NIL."
 220   (let ((really-from-readtable (or from-readtable *standard-readtable*)))
 221     (let ((att (get-cat-entry from-char really-from-readtable))
 222           (mac (get-raw-cmt-entry from-char really-from-readtable))
 223           (from-dpair (find from-char (dispatch-tables really-from-readtable)
 224                             :test #'char= :key #'car))
 225           (to-dpair (find to-char (dispatch-tables to-readtable)
 226                           :test #'char= :key #'car)))
 227       (set-cat-entry to-char att to-readtable)
 228       (set-cmt-entry to-char mac to-readtable)
 229       (when from-dpair
 230         (cond
 231           (to-dpair
 232            (let ((table (cdr to-dpair)))
 233              (clrhash table)
 234              (shallow-replace/eql-hash-table table (cdr from-dpair))))
 235           (t
 236            (let ((pair (cons to-char (make-hash-table))))
 237              (shallow-replace/eql-hash-table (cdr pair) (cdr from-dpair))
 238              (setf (dispatch-tables to-readtable)
 239                    (push pair (dispatch-tables to-readtable)))))))))
 240   t)
 241
 242 (defun set-macro-character (char function &optional
 243                                  (non-terminatingp nil)
 244                                  (readtable *readtable*))
 245   #!+sb-doc
 246   "Causes CHAR to be a macro character which invokes FUNCTION when seen
 247    by the reader. The NON-TERMINATINGP flag can be used to make the macro
 248    character non-terminating, i.e. embeddable in a symbol name."
 249   (let ((designated-readtable (or readtable *standard-readtable*)))
 250     (set-cat-entry char (if non-terminatingp
 251                             +char-attr-constituent+
 252                             +char-attr-terminating-macro+)
 253                    designated-readtable)
 254     (set-cmt-entry char function designated-readtable)
 255     t)) ; (ANSI-specified return value)
 256
 257 (defun get-macro-character (char &optional (readtable *readtable*))
 258   #!+sb-doc
 259   "Return the function associated with the specified CHAR which is a macro
 260   character, or NIL if there is no such function. As a second value, return
 261   T if CHAR is a macro character which is non-terminating, i.e. which can
 262   be embedded in a symbol name."
 263   (let* ((designated-readtable (or readtable *standard-readtable*))
 264          ;; the first return value: a FUNCTION if CHAR is a macro
 265          ;; character, or NIL otherwise
 266          (fun-value (get-raw-cmt-entry char designated-readtable)))
 267     (values fun-value
 268             ;; NON-TERMINATING-P return value:
 269             (if fun-value
 270                 (or (constituentp char)
 271                     (not (terminating-macrop char)))
 272                 ;; ANSI's definition of GET-MACRO-CHARACTER says this
 273                 ;; value is NIL when CHAR is not a macro character.
 274                 ;; I.e. this value means not just "non-terminating
 275                 ;; character?" but "non-terminating macro character?".
 276                 nil))))
 277 \f
 278 ;;;; definitions to support internal programming conventions
 279
 280 (defmacro eofp (char)
 281   `(eq ,char *eof-object*))
 282
 283 (defun flush-whitespace (stream)
 284   ;; This flushes whitespace chars, returning the last char it read (a
 285   ;; non-white one). It always gets an error on end-of-file.
 286   (let ((stream (in-synonym-of stream)))
 287     (if (ansi-stream-p stream)
 288         (prepare-for-fast-read-char stream
 289           (do ((attribute-array (character-attribute-array *readtable*))
 290                (attribute-hash-table
 291                 (character-attribute-hash-table *readtable*))
 292                (char (fast-read-char t) (fast-read-char t)))
 293               ((/= (the fixnum
 294                      (if (typep char 'base-char)
 295                          (aref attribute-array (char-code char))
 296                          (gethash char attribute-hash-table
 297                                   +char-attr-constituent+)))
 298                    +char-attr-whitespace+)
 299                (done-with-fast-read-char)
 300                char)))
 301         ;; CLOS stream
 302         (do ((attribute-array (character-attribute-array *readtable*))
 303              (attribute-hash-table
 304               (character-attribute-hash-table *readtable*))
 305              (char (read-char stream nil :eof) (read-char stream nil :eof)))
 306             ((or (eq char :eof)
 307                  (/= (the fixnum
 308                        (if (typep char 'base-char)
 309                            (aref attribute-array (char-code char))
 310                            (gethash char attribute-hash-table
 311                                     +char-attr-constituent+)))
 312                      +char-attr-whitespace+))
 313              (if (eq char :eof)
 314                  (error 'end-of-file :stream stream)
 315                  char))))))
 316 \f
 317 ;;;; temporary initialization hack
 318
 319 (defun !cold-init-standard-readtable ()
 320   (setq *standard-readtable* (make-readtable))
 321   ;; All characters get boring defaults in MAKE-READTABLE. Now we
 322   ;; override the boring defaults on characters which need more
 323   ;; interesting behavior.
 324   (let ((*readtable* *standard-readtable*))
 325
 326     (flet ((whitespaceify (char)
 327              (set-cmt-entry char nil)
 328              (set-cat-entry char +char-attr-whitespace+)))
 329       (whitespaceify (code-char tab-char-code))
 330       (whitespaceify #\Newline)
 331       (whitespaceify #\Space)
 332       (whitespaceify (code-char form-feed-char-code))
 333       (whitespaceify (code-char return-char-code)))
 334
 335     (set-cat-entry #\\ +char-attr-single-escape+)
 336     (set-cmt-entry #\\ nil)
 337
 338     (set-cat-entry #\| +char-attr-multiple-escape+)
 339     (set-cmt-entry #\| nil)
 340
 341     ;; Easy macro-character definitions are in this source file.
 342     (set-macro-character #\" #'read-string)
 343     (set-macro-character #\' #'read-quote)
 344     (set-macro-character #\( #'read-list)
 345     (set-macro-character #\) #'read-right-paren)
 346     (set-macro-character #\; #'read-comment)
 347     ;; (The hairier macro-character definitions, for #\# and #\`, are
 348     ;; defined elsewhere, in their own source files.)
 349
 350     ;; all constituents
 351     (do ((ichar 0 (1+ ichar))
 352          (char))
 353         ((= ichar base-char-code-limit))
 354       (setq char (code-char ichar))
 355       (when (constituentp char *standard-readtable*)
 356         (set-cmt-entry char nil)))))
 357 \f
 358 ;;;; implementation of the read buffer
 359
 360 (defvar *read-buffer*)
 361 (defvar *read-buffer-length*)
 362 ;;; FIXME: Is it really helpful to have *READ-BUFFER-LENGTH* be a
 363 ;;; separate variable instead of just calculating it on the fly as
 364 ;;; (LENGTH *READ-BUFFER*)?
 365
 366 (defvar *inch-ptr*)
 367 (defvar *ouch-ptr*)
 368
 369 (declaim (type index *read-buffer-length* *inch-ptr* *ouch-ptr*))
 370 (declaim (type (simple-array character (*)) *read-buffer*))
 371
 372 (defmacro reset-read-buffer ()
 373   ;; Turn *READ-BUFFER* into an empty read buffer.
 374   `(progn
 375      ;; *OUCH-PTR* always points to next char to write.
 376      (setq *ouch-ptr* 0)
 377      ;; *INCH-PTR* always points to next char to read.
 378      (setq *inch-ptr* 0)))
 379
 380 ;;; FIXME I removed "THE FIXNUM"'s from OUCH-READ-BUFFER and
 381 ;;; OUCH-UNREAD-BUFFER, check to make sure that Python really is smart
 382 ;;; enough to make good code without them. And while I'm at it,
 383 ;;; converting them from macros to inline functions might be good,
 384 ;;; too.
 385
 386 (defmacro ouch-read-buffer (char)
 387   `(progn
 388      ;; When buffer overflow
 389      (when (>= *ouch-ptr* *read-buffer-length*)
 390        ;; Size should be doubled.
 391        (grow-read-buffer))
 392      (setf (elt (the simple-string *read-buffer*) *ouch-ptr*) ,char)
 393      (setq *ouch-ptr* (1+ *ouch-ptr*))))
 394
 395 ;;; macro to move *ouch-ptr* back one.
 396 (defmacro ouch-unread-buffer ()
 397   '(when (> *ouch-ptr* *inch-ptr*)
 398      (setq *ouch-ptr* (1- (the fixnum *ouch-ptr*)))))
 399
 400 (defun grow-read-buffer ()
 401   (let ((rbl (length (the simple-string *read-buffer*))))
 402     (setq *read-buffer*
 403           (concatenate 'simple-string
 404                        *read-buffer*
 405                        (make-string rbl)))
 406     (setq *read-buffer-length* (* 2 rbl))))
 407
 408 (defun inchpeek-read-buffer ()
 409   (if (>= (the fixnum *inch-ptr*) (the fixnum *ouch-ptr*))
 410       *eof-object*
 411       (elt *read-buffer* *inch-ptr*)))
 412
 413 (defun inch-read-buffer ()
 414   (if (>= *inch-ptr* *ouch-ptr*)
 415       *eof-object*
 416       (prog1
 417           (elt *read-buffer* *inch-ptr*)
 418         (incf *inch-ptr*))))
 419
 420 (defmacro unread-buffer ()
 421   `(decf *inch-ptr*))
 422
 423 (defun read-unwind-read-buffer ()
 424   ;; Keep contents, but make next (INCH..) return first character.
 425   (setq *inch-ptr* 0))
 426
 427 (defun read-buffer-to-string ()
 428   (subseq *read-buffer* 0 *ouch-ptr*))
 429
 430 (defmacro with-reader ((&optional recursive-p) &body body)
 431   #!+sb-doc
 432   "If RECURSIVE-P is NIL, bind *READER-BUFFER* and its subservient
 433 variables to allow for nested and thread safe reading."
 434   `(if ,recursive-p
 435        (progn ,@body)
 436        (let* ((*read-buffer* (make-string 128))
 437               (*read-buffer-length* 128)
 438               (*ouch-ptr* 0)
 439               (*inch-ptr* 0))
 440          ,@body)))
 441 \f
 442 ;;;; READ-PRESERVING-WHITESPACE, READ-DELIMITED-LIST, and READ
 443
 444 ;;; an alist for #=, used to keep track of objects with labels assigned that
 445 ;;; have been completely read. Each entry is (integer-tag gensym-tag value).
 446 ;;;
 447 ;;; KLUDGE: Should this really be an alist? It seems as though users
 448 ;;; could reasonably expect N log N performance for large datasets.
 449 ;;; On the other hand, it's probably very very seldom a problem in practice.
 450 ;;; On the third hand, it might be just as easy to use a hash table
 451 ;;; as an alist, so maybe we should. -- WHN 19991202
 452 (defvar *sharp-equal-alist* ())
 453
 454 (declaim (special *standard-input*))
 455
 456 ;;; READ-PRESERVING-WHITESPACE behaves just like READ, only it makes
 457 ;;; sure to leave terminating whitespace in the stream. (This is a
 458 ;;; COMMON-LISP exported symbol.)
 459 (defun read-preserving-whitespace (&optional (stream *standard-input*)
 460                                              (eof-error-p t)
 461                                              (eof-value nil)
 462                                              (recursivep nil))
 463   #!+sb-doc
 464   "Read from STREAM and return the value read, preserving any whitespace
 465    that followed the object."
 466   (if recursivep
 467       ;; a loop for repeating when a macro returns nothing
 468       (loop
 469        (let ((char (read-char stream eof-error-p *eof-object*)))
 470          (cond ((eofp char) (return eof-value))
 471                ((whitespacep char))
 472                (t
 473                 (let* ((macrofun (get-coerced-cmt-entry char *readtable*))
 474                        (result (multiple-value-list
 475                                 (funcall macrofun stream char))))
 476                   ;; Repeat if macro returned nothing.
 477                   (when result
 478                     (return (unless *read-suppress* (car result)))))))))
 479       (with-reader ()
 480         (let ((*sharp-equal-alist* nil))
 481           (read-preserving-whitespace stream eof-error-p eof-value t)))))
 482
 483 ;;; Return NIL or a list with one thing, depending.
 484 ;;;
 485 ;;; for functions that want comments to return so that they can look
 486 ;;; past them. We assume CHAR is not whitespace.
 487 (defun read-maybe-nothing (stream char)
 488   (let ((retval (multiple-value-list
 489                  (funcall (get-coerced-cmt-entry char *readtable*)
 490                           stream
 491                           char))))
 492     (if retval (rplacd retval nil))))
 493
 494 (defun read (&optional (stream *standard-input*)
 495                        (eof-error-p t)
 496                        (eof-value ())
 497                        (recursivep ()))
 498   #!+sb-doc
 499   "Read the next Lisp value from STREAM, and return it."
 500   (let ((result (read-preserving-whitespace stream
 501                                             eof-error-p
 502                                             eof-value
 503                                             recursivep)))
 504     ;; This function generally discards trailing whitespace. If you
 505     ;; don't want to discard trailing whitespace, call
 506     ;; CL:READ-PRESERVING-WHITESPACE instead.
 507     (unless (or (eql result eof-value) recursivep)
 508       (let ((next-char (read-char stream nil nil)))
 509         (unless (or (null next-char)
 510                     (whitespacep next-char))
 511           (unread-char next-char stream))))
 512     result))
 513
 514 ;;; (This is a COMMON-LISP exported symbol.)
 515 (defun read-delimited-list (endchar &optional
 516                                     (input-stream *standard-input*)
 517                                     recursive-p)
 518   #!+sb-doc
 519   "Read Lisp values from INPUT-STREAM until the next character after a
 520    value's representation is ENDCHAR, and return the objects as a list."
 521   (with-reader (recursive-p)
 522     (do ((char (flush-whitespace input-stream)
 523                (flush-whitespace input-stream))
 524          (retlist ()))
 525         ((char= char endchar) (unless *read-suppress* (nreverse retlist)))
 526       (setq retlist (nconc (read-maybe-nothing input-stream char) retlist)))))
 527 \f
 528 ;;;; basic readmacro definitions
 529 ;;;;
 530 ;;;; Some large, hairy subsets of readmacro definitions (backquotes
 531 ;;;; and sharp macros) are not here, but in their own source files.
 532
 533 (defun read-quote (stream ignore)
 534   (declare (ignore ignore))
 535   (list 'quote (read stream t nil t)))
 536
 537 (defun read-comment (stream ignore)
 538   (declare (ignore ignore))
 539   (handler-bind
 540       ((character-decoding-error
 541         #'(lambda (decoding-error)
 542             (declare (ignorable decoding-error))
 543             (style-warn "Character decoding error in a ;-comment at position ~A reading source file ~A, resyncing." (file-position stream) stream)
 544             (invoke-restart 'attempt-resync))))
 545     (let ((stream (in-synonym-of stream)))
 546       (if (ansi-stream-p stream)
 547           (prepare-for-fast-read-char stream
 548            (do ((char (fast-read-char nil nil)
 549                       (fast-read-char nil nil)))
 550                ((or (not char) (char= char #\newline))
 551                 (done-with-fast-read-char))))
 552           ;; CLOS stream
 553           (do ((char (read-char stream nil :eof) (read-char stream nil :eof)))
 554               ((or (eq char :eof) (char= char #\newline)))))))
 555   ;; Don't return anything.
 556   (values))
 557
 558 (defun read-list (stream ignore)
 559   (declare (ignore ignore))
 560   (let* ((thelist (list nil))
 561          (listtail thelist))
 562     (do ((firstchar (flush-whitespace stream) (flush-whitespace stream)))
 563         ((char= firstchar #\) ) (cdr thelist))
 564       (when (char= firstchar #\.)
 565             (let ((nextchar (read-char stream t)))
 566               (cond ((token-delimiterp nextchar)
 567                      (cond ((eq listtail thelist)
 568                             (unless *read-suppress*
 569                               (%reader-error
 570                                stream
 571                                "Nothing appears before . in list.")))
 572                            ((whitespacep nextchar)
 573                             (setq nextchar (flush-whitespace stream))))
 574                      (rplacd listtail
 575                              ;; Return list containing last thing.
 576                              (car (read-after-dot stream nextchar)))
 577                      (return (cdr thelist)))
 578                     ;; Put back NEXTCHAR so that we can read it normally.
 579                     (t (unread-char nextchar stream)))))
 580       ;; Next thing is not an isolated dot.
 581       (let ((listobj (read-maybe-nothing stream firstchar)))
 582         ;; allows the possibility that a comment was read
 583         (when listobj
 584               (rplacd listtail listobj)
 585               (setq listtail listobj))))))
 586
 587 (defun read-after-dot (stream firstchar)
 588   ;; FIRSTCHAR is non-whitespace!
 589   (let ((lastobj ()))
 590     (do ((char firstchar (flush-whitespace stream)))
 591         ((char= char #\) )
 592          (if *read-suppress*
 593              (return-from read-after-dot nil)
 594              (%reader-error stream "Nothing appears after . in list.")))
 595       ;; See whether there's something there.
 596       (setq lastobj (read-maybe-nothing stream char))
 597       (when lastobj (return t)))
 598     ;; At least one thing appears after the dot.
 599     ;; Check for more than one thing following dot.
 600     (do ((lastchar (flush-whitespace stream)
 601                    (flush-whitespace stream)))
 602         ((char= lastchar #\) ) lastobj) ;success!
 603       ;; Try reading virtual whitespace.
 604       (if (and (read-maybe-nothing stream lastchar)
 605                (not *read-suppress*))
 606           (%reader-error stream "More than one object follows . in list.")))))
 607
 608 (defun read-string (stream closech)
 609   ;; This accumulates chars until it sees same char that invoked it.
 610   ;; For a very long string, this could end up bloating the read buffer.
 611   (reset-read-buffer)
 612   (let ((stream (in-synonym-of stream)))
 613     (if (ansi-stream-p stream)
 614         (prepare-for-fast-read-char stream
 615           (do ((char (fast-read-char t) (fast-read-char t)))
 616               ((char= char closech)
 617                (done-with-fast-read-char))
 618             (if (single-escape-p char) (setq char (fast-read-char t)))
 619             (ouch-read-buffer char)))
 620         ;; CLOS stream
 621         (do ((char (read-char stream nil :eof) (read-char stream nil :eof)))
 622             ((or (eq char :eof) (char= char closech))
 623              (if (eq char :eof)
 624                  (error 'end-of-file :stream stream)))
 625           (when (single-escape-p char)
 626             (setq char (read-char stream nil :eof))
 627             (if (eq char :eof)
 628                 (error 'end-of-file :stream stream)))
 629           (ouch-read-buffer char))))
 630   (read-buffer-to-string))
 631
 632 (defun read-right-paren (stream ignore)
 633   (declare (ignore ignore))
 634   (%reader-error stream "unmatched close parenthesis"))
 635
 636 ;;; Read from the stream up to the next delimiter. Leave the resulting
 637 ;;; token in *READ-BUFFER*, and return two values:
 638 ;;; -- a list of the escaped character positions, and
 639 ;;; -- The position of the first package delimiter (or NIL).
 640 (defun internal-read-extended-token (stream firstchar escape-firstchar)
 641   (reset-read-buffer)
 642   (let ((escapes '()))
 643     (when escape-firstchar
 644       (push *ouch-ptr* escapes)
 645       (ouch-read-buffer firstchar)
 646       (setq firstchar (read-char stream nil *eof-object*)))
 647   (do ((char firstchar (read-char stream nil *eof-object*))
 648        (colon nil))
 649       ((cond ((eofp char) t)
 650              ((token-delimiterp char)
 651               (unread-char char stream)
 652               t)
 653              (t nil))
 654        (values escapes colon))
 655     (cond ((single-escape-p char)
 656            ;; It can't be a number, even if it's 1\23.
 657            ;; Read next char here, so it won't be casified.
 658            (push *ouch-ptr* escapes)
 659            (let ((nextchar (read-char stream nil *eof-object*)))
 660              (if (eofp nextchar)
 661                  (reader-eof-error stream "after escape character")
 662                  (ouch-read-buffer nextchar))))
 663           ((multiple-escape-p char)
 664            ;; Read to next multiple-escape, escaping single chars
 665            ;; along the way.
 666            (loop
 667              (let ((ch (read-char stream nil *eof-object*)))
 668                (cond
 669                 ((eofp ch)
 670                  (reader-eof-error stream "inside extended token"))
 671                 ((multiple-escape-p ch) (return))
 672                 ((single-escape-p ch)
 673                  (let ((nextchar (read-char stream nil *eof-object*)))
 674                    (cond ((eofp nextchar)
 675                           (reader-eof-error stream "after escape character"))
 676                          (t
 677                           (push *ouch-ptr* escapes)
 678                           (ouch-read-buffer nextchar)))))
 679                 (t
 680                  (push *ouch-ptr* escapes)
 681                  (ouch-read-buffer ch))))))
 682           (t
 683            (when (and (constituentp char)
 684                       (eql (get-constituent-trait char)
 685                            +char-attr-package-delimiter+)
 686                       (not colon))
 687              (setq colon *ouch-ptr*))
 688            (ouch-read-buffer char))))))
 689 \f
 690 ;;;; character classes
 691
 692 ;;; Return the character class for CHAR.
 693 ;;;
 694 ;;; FIXME: why aren't these ATT-getting forms using GET-CAT-ENTRY?
 695 ;;; Because we've cached the readtable tables?
 696 (defmacro char-class (char attarray atthash)
 697   `(let ((att (if (typep ,char 'base-char)
 698                   (aref ,attarray (char-code ,char))
 699                   (gethash ,char ,atthash +char-attr-constituent+))))
 700      (declare (fixnum att))
 701      (cond
 702        ((<= att +char-attr-terminating-macro+) +char-attr-delimiter+)
 703        ((< att +char-attr-constituent+) att)
 704        (t (setf att (get-constituent-trait ,char))
 705           (if (= att +char-attr-invalid+)
 706               (%reader-error stream "invalid constituent")
 707               att)))))
 708
 709 ;;; Return the character class for CHAR, which might be part of a
 710 ;;; rational number.
 711 (defmacro char-class2 (char attarray atthash)
 712   `(let ((att (if (typep ,char 'base-char)
 713                   (aref ,attarray (char-code ,char))
 714                   (gethash ,char ,atthash +char-attr-constituent+))))
 715      (declare (fixnum att))
 716      (cond
 717        ((<= att +char-attr-terminating-macro+) +char-attr-delimiter+)
 718        ((< att +char-attr-constituent+) att)
 719        (t (setf att (get-constituent-trait ,char))
 720           (cond
 721             ((digit-char-p ,char *read-base*) +char-attr-constituent-digit+)
 722             ((= att +char-attr-constituent-digit+) +char-attr-constituent+)
 723             ((= att +char-attr-invalid+)
 724              (%reader-error stream "invalid constituent"))
 725             (t att))))))
 726
 727 ;;; Return the character class for a char which might be part of a
 728 ;;; rational or floating number. (Assume that it is a digit if it
 729 ;;; could be.)
 730 (defmacro char-class3 (char attarray atthash)
 731   `(let ((att (if (typep ,char 'base-char)
 732                   (aref ,attarray (char-code ,char))
 733                   (gethash ,char ,atthash +char-attr-constituent+))))
 734      (declare (fixnum att))
 735      (cond
 736        ((<= att +char-attr-terminating-macro+) +char-attr-delimiter+)
 737        ((< att +char-attr-constituent+) att)
 738        (t (setf att (get-constituent-trait ,char))
 739           (when possibly-rational
 740             (setq possibly-rational
 741                   (or (digit-char-p ,char *read-base*)
 742                       (= att +char-attr-constituent-slash+))))
 743           (when possibly-float
 744             (setq possibly-float
 745                   (or (digit-char-p ,char 10)
 746                       (= att +char-attr-constituent-dot+))))
 747           (cond
 748             ((digit-char-p ,char (max *read-base* 10))
 749              (if (digit-char-p ,char *read-base*)
 750                  (if (= att +char-attr-constituent-expt+)
 751                      +char-attr-constituent-digit-or-expt+
 752                      +char-attr-constituent-digit+)
 753                  +char-attr-constituent-decimal-digit+))
 754             ((= att +char-attr-invalid+)
 755              (%reader-error stream "invalid constituent"))
 756             (t att))))))
 757 \f
 758 ;;;; token fetching
 759
 760 (defvar *read-suppress* nil
 761   #!+sb-doc
 762   "Suppress most interpreting in the reader when T.")
 763
 764 (defvar *read-base* 10
 765   #!+sb-doc
 766   "the radix that Lisp reads numbers in")
 767 (declaim (type (integer 2 36) *read-base*))
 768
 769 ;;; Modify the read buffer according to READTABLE-CASE, ignoring
 770 ;;; ESCAPES. ESCAPES is a list of the escaped indices, in reverse
 771 ;;; order.
 772 (defun casify-read-buffer (escapes)
 773   (let ((case (readtable-case *readtable*)))
 774     (cond
 775      ((and (null escapes) (eq case :upcase))
 776       (dotimes (i *ouch-ptr*)
 777         (setf (schar *read-buffer* i)
 778               (char-upcase (schar *read-buffer* i)))))
 779      ((eq case :preserve))
 780      (t
 781       (macrolet ((skip-esc (&body body)
 782                    `(do ((i (1- *ouch-ptr*) (1- i))
 783                          (escapes escapes))
 784                         ((minusp i))
 785                       (declare (fixnum i))
 786                       (when (or (null escapes)
 787                                 (let ((esc (first escapes)))
 788                                   (declare (fixnum esc))
 789                                   (cond ((< esc i) t)
 790                                         (t
 791                                          (aver (= esc i))
 792                                          (pop escapes)
 793                                          nil))))
 794                         (let ((ch (schar *read-buffer* i)))
 795                           ,@body)))))
 796         (flet ((lower-em ()
 797                  (skip-esc (setf (schar *read-buffer* i) (char-downcase ch))))
 798                (raise-em ()
 799                  (skip-esc (setf (schar *read-buffer* i) (char-upcase ch)))))
 800           (ecase case
 801             (:upcase (raise-em))
 802             (:downcase (lower-em))
 803             (:invert
 804              (let ((all-upper t)
 805                    (all-lower t))
 806                (skip-esc
 807                  (when (both-case-p ch)
 808                    (if (upper-case-p ch)
 809                        (setq all-lower nil)
 810                        (setq all-upper nil))))
 811                (cond (all-lower (raise-em))
 812                      (all-upper (lower-em))))))))))))
 813
 814 (defun read-token (stream firstchar)
 815   #!+sb-doc
 816   "This function is just an fsm that recognizes numbers and symbols."
 817   ;; Check explicitly whether FIRSTCHAR has an entry for
 818   ;; NON-TERMINATING in CHARACTER-ATTRIBUTE-TABLE and
 819   ;; READ-DOT-NUMBER-SYMBOL in CMT. Report an error if these are
 820   ;; violated. (If we called this, we want something that is a
 821   ;; legitimate token!) Read in the longest possible string satisfying
 822   ;; the Backus-Naur form for "unqualified-token". Leave the result in
 823   ;; the *READ-BUFFER*. Return next char after token (last char read).
 824   (when *read-suppress*
 825     (internal-read-extended-token stream firstchar nil)
 826     (return-from read-token nil))
 827   (let ((attribute-array (character-attribute-array *readtable*))
 828         (attribute-hash-table (character-attribute-hash-table *readtable*))
 829         (package-designator nil)
 830         (colons 0)
 831         (possibly-rational t)
 832         (seen-digit-or-expt nil)
 833         (possibly-float t)
 834         (was-possibly-float nil)
 835         (escapes ())
 836         (seen-multiple-escapes nil))
 837     (reset-read-buffer)
 838     (prog ((char firstchar))
 839       (case (char-class3 char attribute-array attribute-hash-table)
 840         (#.+char-attr-constituent-sign+ (go SIGN))
 841         (#.+char-attr-constituent-digit+ (go LEFTDIGIT))
 842         (#.+char-attr-constituent-digit-or-expt+
 843          (setq seen-digit-or-expt t)
 844          (go LEFTDIGIT))
 845         (#.+char-attr-constituent-decimal-digit+ (go LEFTDECIMALDIGIT))
 846         (#.+char-attr-constituent-dot+ (go FRONTDOT))
 847         (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
 848         (#.+char-attr-package-delimiter+ (go COLON))
 849         (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
 850         (#.+char-attr-invalid+ (%reader-error stream "invalid constituent"))
 851         ;; can't have eof, whitespace, or terminating macro as first char!
 852         (t (go SYMBOL)))
 853      SIGN ; saw "sign"
 854       (ouch-read-buffer char)
 855       (setq char (read-char stream nil nil))
 856       (unless char (go RETURN-SYMBOL))
 857       (setq possibly-rational t
 858             possibly-float t)
 859       (case (char-class3 char attribute-array attribute-hash-table)
 860         (#.+char-attr-constituent-digit+ (go LEFTDIGIT))
 861         (#.+char-attr-constituent-digit-or-expt+
 862          (setq seen-digit-or-expt t)
 863          (go LEFTDIGIT))
 864         (#.+char-attr-constituent-decimal-digit+ (go LEFTDECIMALDIGIT))
 865         (#.+char-attr-constituent-dot+ (go SIGNDOT))
 866         (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
 867         (#.+char-attr-package-delimiter+ (go COLON))
 868         (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
 869         (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
 870         (t (go SYMBOL)))
 871      LEFTDIGIT ; saw "[sign] {digit}+"
 872       (ouch-read-buffer char)
 873       (setq char (read-char stream nil nil))
 874       (unless char (return (make-integer)))
 875       (setq was-possibly-float possibly-float)
 876       (case (char-class3 char attribute-array attribute-hash-table)
 877         (#.+char-attr-constituent-digit+ (go LEFTDIGIT))
 878         (#.+char-attr-constituent-decimal-digit+ (if possibly-float
 879                                                      (go LEFTDECIMALDIGIT)
 880                                                      (go SYMBOL)))
 881         (#.+char-attr-constituent-dot+ (if possibly-float
 882                                            (go MIDDLEDOT)
 883                                            (go SYMBOL)))
 884         (#.+char-attr-constituent-digit-or-expt+
 885          (if (or seen-digit-or-expt (not was-possibly-float))
 886              (progn (setq seen-digit-or-expt t) (go LEFTDIGIT))
 887              (progn (setq seen-digit-or-expt t) (go LEFTDIGIT-OR-EXPT))))
 888         (#.+char-attr-constituent-expt+
 889          (if was-possibly-float
 890              (go EXPONENT)
 891              (go SYMBOL)))
 892         (#.+char-attr-constituent-slash+ (if possibly-rational
 893                                              (go RATIO)
 894                                              (go SYMBOL)))
 895         (#.+char-attr-delimiter+ (unread-char char stream)
 896                                  (return (make-integer)))
 897         (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
 898         (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
 899         (#.+char-attr-package-delimiter+ (go COLON))
 900         (t (go SYMBOL)))
 901      LEFTDIGIT-OR-EXPT
 902       (ouch-read-buffer char)
 903       (setq char (read-char stream nil nil))
 904       (unless char (return (make-integer)))
 905       (case (char-class3 char attribute-array attribute-hash-table)
 906         (#.+char-attr-constituent-digit+ (go LEFTDIGIT))
 907         (#.+char-attr-constituent-decimal-digit+ (bug "impossible!"))
 908         (#.+char-attr-constituent-dot+ (go SYMBOL))
 909         (#.+char-attr-constituent-digit-or-expt+ (go LEFTDIGIT))
 910         (#.+char-attr-constituent-expt+ (go SYMBOL))
 911         (#.+char-attr-constituent-sign+ (go EXPTSIGN))
 912         (#.+char-attr-constituent-slash+ (if possibly-rational
 913                                              (go RATIO)
 914                                              (go SYMBOL)))
 915         (#.+char-attr-delimiter+ (unread-char char stream)
 916                                  (return (make-integer)))
 917         (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
 918         (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
 919         (#.+char-attr-package-delimiter+ (go COLON))
 920         (t (go SYMBOL)))
 921      LEFTDECIMALDIGIT ; saw "[sign] {decimal-digit}+"
 922       (aver possibly-float)
 923       (ouch-read-buffer char)
 924       (setq char (read-char stream nil nil))
 925       (unless char (go RETURN-SYMBOL))
 926       (case (char-class char attribute-array attribute-hash-table)
 927         (#.+char-attr-constituent-digit+ (go LEFTDECIMALDIGIT))
 928         (#.+char-attr-constituent-dot+ (go MIDDLEDOT))
 929         (#.+char-attr-constituent-expt+ (go EXPONENT))
 930         (#.+char-attr-constituent-slash+ (aver (not possibly-rational))
 931                                          (go SYMBOL))
 932         (#.+char-attr-delimiter+ (unread-char char stream)
 933                                  (go RETURN-SYMBOL))
 934         (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
 935         (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
 936         (#.+char-attr-package-delimiter+ (go COLON))
 937         (t (go SYMBOL)))
 938      MIDDLEDOT ; saw "[sign] {digit}+ dot"
 939       (ouch-read-buffer char)
 940       (setq char (read-char stream nil nil))
 941       (unless char (return (let ((*read-base* 10))
 942                              (make-integer))))
 943       (case (char-class char attribute-array attribute-hash-table)
 944         (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
 945         (#.+char-attr-constituent-expt+ (go EXPONENT))
 946         (#.+char-attr-delimiter+
 947          (unread-char char stream)
 948          (return (let ((*read-base* 10))
 949                    (make-integer))))
 950         (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
 951         (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
 952         (#.+char-attr-package-delimiter+ (go COLON))
 953         (t (go SYMBOL)))
 954      RIGHTDIGIT ; saw "[sign] {decimal-digit}* dot {digit}+"
 955       (ouch-read-buffer char)
 956       (setq char (read-char stream nil nil))
 957       (unless char (return (make-float stream)))
 958       (case (char-class char attribute-array attribute-hash-table)
 959         (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
 960         (#.+char-attr-constituent-expt+ (go EXPONENT))
 961         (#.+char-attr-delimiter+
 962          (unread-char char stream)
 963          (return (make-float stream)))
 964         (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
 965         (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
 966         (#.+char-attr-package-delimiter+ (go COLON))
 967         (t (go SYMBOL)))
 968      SIGNDOT ; saw "[sign] dot"
 969       (ouch-read-buffer char)
 970       (setq char (read-char stream nil nil))
 971       (unless char (go RETURN-SYMBOL))
 972       (case (char-class char attribute-array attribute-hash-table)
 973         (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
 974         (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
 975         (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
 976         (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
 977         (t (go SYMBOL)))
 978      FRONTDOT ; saw "dot"
 979       (ouch-read-buffer char)
 980       (setq char (read-char stream nil nil))
 981       (unless char (%reader-error stream "dot context error"))
 982       (case (char-class char attribute-array attribute-hash-table)
 983         (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
 984         (#.+char-attr-constituent-dot+ (go DOTS))
 985         (#.+char-attr-delimiter+  (%reader-error stream "dot context error"))
 986         (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
 987         (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
 988         (#.+char-attr-package-delimiter+ (go COLON))
 989         (t (go SYMBOL)))
 990      EXPONENT
 991       (ouch-read-buffer char)
 992       (setq char (read-char stream nil nil))
 993       (unless char (go RETURN-SYMBOL))
 994       (setq possibly-float t)
 995       (case (char-class char attribute-array attribute-hash-table)
 996         (#.+char-attr-constituent-sign+ (go EXPTSIGN))
 997         (#.+char-attr-constituent-digit+ (go EXPTDIGIT))
 998         (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
 999         (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1000         (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1001         (#.+char-attr-package-delimiter+ (go COLON))
1002         (t (go SYMBOL)))
1003      EXPTSIGN ; got to EXPONENT, and saw a sign character
1004       (ouch-read-buffer char)
1005       (setq char (read-char stream nil nil))
1006       (unless char (go RETURN-SYMBOL))
1007       (case (char-class char attribute-array attribute-hash-table)
1008         (#.+char-attr-constituent-digit+ (go EXPTDIGIT))
1009         (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
1010         (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1011         (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1012         (#.+char-attr-package-delimiter+ (go COLON))
1013         (t (go SYMBOL)))
1014      EXPTDIGIT ; got to EXPONENT, saw "[sign] {digit}+"
1015       (ouch-read-buffer char)
1016       (setq char (read-char stream nil nil))
1017       (unless char (return (make-float stream)))
1018       (case (char-class char attribute-array attribute-hash-table)
1019         (#.+char-attr-constituent-digit+ (go EXPTDIGIT))
1020         (#.+char-attr-delimiter+
1021          (unread-char char stream)
1022          (return (make-float stream)))
1023         (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1024         (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1025         (#.+char-attr-package-delimiter+ (go COLON))
1026         (t (go SYMBOL)))
1027      RATIO ; saw "[sign] {digit}+ slash"
1028       (ouch-read-buffer char)
1029       (setq char (read-char stream nil nil))
1030       (unless char (go RETURN-SYMBOL))
1031       (case (char-class2 char attribute-array attribute-hash-table)
1032         (#.+char-attr-constituent-digit+ (go RATIODIGIT))
1033         (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
1034         (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1035         (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1036         (#.+char-attr-package-delimiter+ (go COLON))
1037         (t (go SYMBOL)))
1038      RATIODIGIT ; saw "[sign] {digit}+ slash {digit}+"
1039       (ouch-read-buffer char)
1040       (setq char (read-char stream nil nil))
1041       (unless char (return (make-ratio stream)))
1042       (case (char-class2 char attribute-array attribute-hash-table)
1043         (#.+char-attr-constituent-digit+ (go RATIODIGIT))
1044         (#.+char-attr-delimiter+
1045          (unread-char char stream)
1046          (return (make-ratio stream)))
1047         (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1048         (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1049         (#.+char-attr-package-delimiter+ (go COLON))
1050         (t (go SYMBOL)))
1051      DOTS ; saw "dot {dot}+"
1052       (ouch-read-buffer char)
1053       (setq char (read-char stream nil nil))
1054       (unless char (%reader-error stream "too many dots"))
1055       (case (char-class char attribute-array attribute-hash-table)
1056         (#.+char-attr-constituent-dot+ (go DOTS))
1057         (#.+char-attr-delimiter+
1058          (unread-char char stream)
1059          (%reader-error stream "too many dots"))
1060         (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1061         (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1062         (#.+char-attr-package-delimiter+ (go COLON))
1063         (t (go SYMBOL)))
1064      SYMBOL ; not a dot, dots, or number
1065       (let ((stream (in-synonym-of stream)))
1066         (if (ansi-stream-p stream)
1067             (prepare-for-fast-read-char stream
1068               (prog ()
1069                SYMBOL-LOOP
1070                (ouch-read-buffer char)
1071                (setq char (fast-read-char nil nil))
1072                (unless char (go RETURN-SYMBOL))
1073                (case (char-class char attribute-array attribute-hash-table)
1074                  (#.+char-attr-single-escape+ (done-with-fast-read-char)
1075                                               (go SINGLE-ESCAPE))
1076                  (#.+char-attr-delimiter+ (done-with-fast-read-char)
1077                                           (unread-char char stream)
1078                                           (go RETURN-SYMBOL))
1079                  (#.+char-attr-multiple-escape+ (done-with-fast-read-char)
1080                                                 (go MULT-ESCAPE))
1081                  (#.+char-attr-package-delimiter+ (done-with-fast-read-char)
1082                                                   (go COLON))
1083                  (t (go SYMBOL-LOOP)))))
1084             ;; CLOS stream
1085             (prog ()
1086              SYMBOL-LOOP
1087              (ouch-read-buffer char)
1088              (setq char (read-char stream nil :eof))
1089              (when (eq char :eof) (go RETURN-SYMBOL))
1090              (case (char-class char attribute-array attribute-hash-table)
1091                (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1092                (#.+char-attr-delimiter+ (unread-char char stream)
1093                             (go RETURN-SYMBOL))
1094                (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1095                (#.+char-attr-package-delimiter+ (go COLON))
1096                (t (go SYMBOL-LOOP))))))
1097      SINGLE-ESCAPE ; saw a single-escape
1098       ;; Don't put the escape character in the read buffer.
1099       ;; READ-NEXT CHAR, put in buffer (no case conversion).
1100       (let ((nextchar (read-char stream nil nil)))
1101         (unless nextchar
1102           (reader-eof-error stream "after single-escape character"))
1103         (push *ouch-ptr* escapes)
1104         (ouch-read-buffer nextchar))
1105       (setq char (read-char stream nil nil))
1106       (unless char (go RETURN-SYMBOL))
1107       (case (char-class char attribute-array attribute-hash-table)
1108         (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
1109         (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1110         (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1111         (#.+char-attr-package-delimiter+ (go COLON))
1112         (t (go SYMBOL)))
1113       MULT-ESCAPE
1114       (setq seen-multiple-escapes t)
1115       (do ((char (read-char stream t) (read-char stream t)))
1116           ((multiple-escape-p char))
1117         (if (single-escape-p char) (setq char (read-char stream t)))
1118         (push *ouch-ptr* escapes)
1119         (ouch-read-buffer char))
1120       (setq char (read-char stream nil nil))
1121       (unless char (go RETURN-SYMBOL))
1122       (case (char-class char attribute-array attribute-hash-table)
1123         (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
1124         (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1125         (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1126         (#.+char-attr-package-delimiter+ (go COLON))
1127         (t (go SYMBOL)))
1128       COLON
1129       (casify-read-buffer escapes)
1130       (unless (zerop colons)
1131         (%reader-error stream "too many colons in ~S"
1132                       (read-buffer-to-string)))
1133       (setq colons 1)
1134       (setq package-designator
1135             (if (plusp *ouch-ptr*)
1136                 ;; FIXME: It seems inefficient to cons up a package
1137                 ;; designator string every time we read a symbol with an
1138                 ;; explicit package prefix. Perhaps we could implement
1139                 ;; a FIND-PACKAGE* function analogous to INTERN*
1140                 ;; and friends?
1141                 (read-buffer-to-string)
1142                 (if seen-multiple-escapes
1143                     (read-buffer-to-string)
1144                     *keyword-package*)))
1145       (reset-read-buffer)
1146       (setq escapes ())
1147       (setq char (read-char stream nil nil))
1148       (unless char (reader-eof-error stream "after reading a colon"))
1149       (case (char-class char attribute-array attribute-hash-table)
1150         (#.+char-attr-delimiter+
1151          (unread-char char stream)
1152          (%reader-error stream
1153                         "illegal terminating character after a colon: ~S"
1154                         char))
1155         (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1156         (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1157         (#.+char-attr-package-delimiter+ (go INTERN))
1158         (t (go SYMBOL)))
1159       INTERN
1160       (setq colons 2)
1161       (setq char (read-char stream nil nil))
1162       (unless char
1163         (reader-eof-error stream "after reading a colon"))
1164       (case (char-class char attribute-array attribute-hash-table)
1165         (#.+char-attr-delimiter+
1166          (unread-char char stream)
1167          (%reader-error stream
1168                         "illegal terminating character after a colon: ~S"
1169                         char))
1170         (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
1171         (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
1172         (#.+char-attr-package-delimiter+
1173          (%reader-error stream
1174                         "too many colons after ~S name"
1175                         package-designator))
1176         (t (go SYMBOL)))
1177       RETURN-SYMBOL
1178       (casify-read-buffer escapes)
1179       (let ((found (if package-designator
1180                        (find-package package-designator)
1181                        (sane-package))))
1182         (unless found
1183           (error 'reader-package-error :stream stream
1184                  :format-arguments (list package-designator)
1185                  :format-control "package ~S not found"))
1186
1187         (if (or (zerop colons) (= colons 2) (eq found *keyword-package*))
1188             (return (intern* *read-buffer* *ouch-ptr* found))
1189             (multiple-value-bind (symbol test)
1190                 (find-symbol* *read-buffer* *ouch-ptr* found)
1191               (when (eq test :external) (return symbol))
1192               (let ((name (read-buffer-to-string)))
1193                 (with-simple-restart (continue "Use symbol anyway.")
1194                   (error 'reader-package-error :stream stream
1195                          :format-arguments (list name (package-name found))
1196                          :format-control
1197                          (if test
1198                              "The symbol ~S is not external in the ~A package."
1199                              "Symbol ~S not found in the ~A package.")))
1200                 (return (intern name found)))))))))
1201
1202 ;;; for semi-external use:
1203 ;;;
1204 ;;; For semi-external use: Return 3 values: the string for the token,
1205 ;;; a flag for whether there was an escape char, and the position of
1206 ;;; any package delimiter.
1207 (defun read-extended-token (stream &optional (*readtable* *readtable*))
1208   (let ((first-char (read-char stream nil nil t)))
1209     (cond (first-char
1210            (multiple-value-bind (escapes colon)
1211                (internal-read-extended-token stream first-char nil)
1212              (casify-read-buffer escapes)
1213              (values (read-buffer-to-string) (not (null escapes)) colon)))
1214           (t
1215            (values "" nil nil)))))
1216
1217 ;;; for semi-external use:
1218 ;;;
1219 ;;; Read an extended token with the first character escaped. Return
1220 ;;; the string for the token.
1221 (defun read-extended-token-escaped (stream &optional (*readtable* *readtable*))
1222   (let ((first-char (read-char stream nil nil)))
1223     (cond (first-char
1224             (let ((escapes (internal-read-extended-token stream first-char t)))
1225               (casify-read-buffer escapes)
1226               (read-buffer-to-string)))
1227           (t
1228             (reader-eof-error stream "after escape")))))
1229 \f
1230 ;;;; number-reading functions
1231
1232 (defmacro digit* nil
1233   `(do ((ch char (inch-read-buffer)))
1234        ((or (eofp ch) (not (digit-char-p ch))) (setq char ch))
1235      ;; Report if at least one digit is seen.
1236      (setq one-digit t)))
1237
1238 (defmacro exponent-letterp (letter)
1239   `(memq ,letter '(#\E #\S #\F #\L #\D #\e #\s #\f #\l #\d)))
1240
1241 ;;; FIXME: It would be cleaner to have these generated automatically
1242 ;;; by compile-time code instead of having them hand-created like
1243 ;;; this. The !COLD-INIT-INTEGER-READER code below should be resurrected
1244 ;;; and tested.
1245 (defvar *integer-reader-safe-digits*
1246   #(nil nil
1247     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)
1248   #!+sb-doc
1249   "the mapping of base to 'safe' number of digits to read for a fixnum")
1250 (defvar *integer-reader-base-power*
1251   #(nil nil
1252     67108864 129140163 67108864 48828125 60466176 40353607
1253     16777216 43046721 100000000 19487171 35831808 62748517 105413504 11390625
1254     16777216 24137569 34012224 47045881 64000000 85766121 113379904 6436343
1255     7962624 9765625 11881376 14348907 17210368 20511149 24300000 28629151
1256     33554432 39135393 45435424 52521875 60466176)
1257   #!+sb-doc
1258   "the largest fixnum power of the base for MAKE-INTEGER")
1259 (declaim (simple-vector *integer-reader-safe-digits*
1260                         *integer-reader-base-power*))
1261 #|
1262 (defun !cold-init-integer-reader ()
1263   (do ((base 2 (1+ base)))
1264       ((> base 36))
1265     (let ((digits
1266           (do ((fix (truncate most-positive-fixnum base)
1267                     (truncate fix base))
1268                (digits 0 (1+ digits)))
1269               ((zerop fix) digits))))
1270       (setf (aref *integer-reader-safe-digits* base)
1271             digits
1272             (aref *integer-reader-base-power* base)
1273             (expt base digits)))))
1274 |#
1275
1276 (defun make-integer ()
1277   #!+sb-doc
1278   "Minimizes bignum-fixnum multiplies by reading a 'safe' number of digits,
1279   then multiplying by a power of the base and adding."
1280   (let* ((base *read-base*)
1281          (digits-per (aref *integer-reader-safe-digits* base))
1282          (base-power (aref *integer-reader-base-power* base))
1283          (negativep nil)
1284          (number 0))
1285     (declare (type index digits-per base-power))
1286     (read-unwind-read-buffer)
1287     (let ((char (inch-read-buffer)))
1288       (cond ((char= char #\-)
1289              (setq negativep t))
1290             ((char= char #\+))
1291             (t (unread-buffer))))
1292     (loop
1293      (let ((num 0))
1294        (declare (type index num))
1295        (dotimes (digit digits-per)
1296          (let* ((ch (inch-read-buffer)))
1297            (cond ((or (eofp ch) (char= ch #\.))
1298                   (return-from make-integer
1299                                (let ((res
1300                                       (if (zerop number) num
1301                                           (+ num (* number
1302                                                     (expt base digit))))))
1303                                  (if negativep (- res) res))))
1304                  (t (setq num (+ (digit-char-p ch base)
1305                                  (the index (* num base))))))))
1306        (setq number (+ num (* number base-power)))))))
1307
1308 (defun make-float (stream)
1309   ;; Assume that the contents of *read-buffer* are a legal float, with nothing
1310   ;; else after it.
1311   (read-unwind-read-buffer)
1312   (let ((negative-fraction nil)
1313         (number 0)
1314         (divisor 1)
1315         (negative-exponent nil)
1316         (exponent 0)
1317         (float-char ())
1318         (char (inch-read-buffer)))
1319     (if (cond ((char= char #\+) t)
1320               ((char= char #\-) (setq negative-fraction t)))
1321         ;; Flush it.
1322         (setq char (inch-read-buffer)))
1323     ;; Read digits before the dot.
1324     (do* ((ch char (inch-read-buffer))
1325           (dig (digit-char-p ch) (digit-char-p ch)))
1326          ((not dig) (setq char ch))
1327       (setq number (+ (* number 10) dig)))
1328     ;; Deal with the dot, if it's there.
1329     (when (char= char #\.)
1330       (setq char (inch-read-buffer))
1331       ;; Read digits after the dot.
1332       (do* ((ch char (inch-read-buffer))
1333             (dig (and (not (eofp ch)) (digit-char-p ch))
1334                  (and (not (eofp ch)) (digit-char-p ch))))
1335            ((not dig) (setq char ch))
1336         (setq divisor (* divisor 10))
1337         (setq number (+ (* number 10) dig))))
1338     ;; Is there an exponent letter?
1339     (cond ((eofp char)
1340            ;; If not, we've read the whole number.
1341            (let ((num (make-float-aux number divisor
1342                                       *read-default-float-format*
1343                                       stream)))
1344              (return-from make-float (if negative-fraction (- num) num))))
1345           ((exponent-letterp char)
1346            (setq float-char char)
1347            ;; Build exponent.
1348            (setq char (inch-read-buffer))
1349            ;; Check leading sign.
1350            (if (cond ((char= char #\+) t)
1351                      ((char= char #\-) (setq negative-exponent t)))
1352                ;; Flush sign.
1353                (setq char (inch-read-buffer)))
1354            ;; Read digits for exponent.
1355            (do* ((ch char (inch-read-buffer))
1356                  (dig (and (not (eofp ch)) (digit-char-p ch))
1357                       (and (not (eofp ch)) (digit-char-p ch))))
1358                 ((not dig)
1359                  (setq exponent (if negative-exponent (- exponent) exponent)))
1360              (setq exponent (+ (* exponent 10) dig)))
1361            ;; Generate and return the float, depending on FLOAT-CHAR:
1362            (let* ((float-format (case (char-upcase float-char)
1363                                   (#\E *read-default-float-format*)
1364                                   (#\S 'short-float)
1365                                   (#\F 'single-float)
1366                                   (#\D 'double-float)
1367                                   (#\L 'long-float)))
1368                   (result (make-float-aux (* (expt 10 exponent) number)
1369                                           divisor float-format stream)))
1370              (return-from make-float
1371                (if negative-fraction (- result) result))))
1372           (t (bug "bad fallthrough in floating point reader")))))
1373
1374 (defun make-float-aux (number divisor float-format stream)
1375   (handler-case
1376       (coerce (/ number divisor) float-format)
1377     (type-error (c)
1378       (error 'reader-impossible-number-error
1379              :error c :stream stream
1380              :format-control "failed to build float"))))
1381
1382 (defun make-ratio (stream)
1383   ;; Assume *READ-BUFFER* contains a legal ratio. Build the number from
1384   ;; the string.
1385   ;;
1386   ;; Look for optional "+" or "-".
1387   (let ((numerator 0) (denominator 0) (char ()) (negative-number nil))
1388     (read-unwind-read-buffer)
1389     (setq char (inch-read-buffer))
1390     (cond ((char= char #\+)
1391            (setq char (inch-read-buffer)))
1392           ((char= char #\-)
1393            (setq char (inch-read-buffer))
1394            (setq negative-number t)))
1395     ;; Get numerator.
1396     (do* ((ch char (inch-read-buffer))
1397           (dig (digit-char-p ch *read-base*)
1398                (digit-char-p ch *read-base*)))
1399          ((not dig))
1400          (setq numerator (+ (* numerator *read-base*) dig)))
1401     ;; Get denominator.
1402     (do* ((ch (inch-read-buffer) (inch-read-buffer))
1403           (dig ()))
1404          ((or (eofp ch) (not (setq dig (digit-char-p ch *read-base*)))))
1405          (setq denominator (+ (* denominator *read-base*) dig)))
1406     (let ((num (handler-case
1407                    (/ numerator denominator)
1408                  (arithmetic-error (c)
1409                    (error 'reader-impossible-number-error
1410                           :error c :stream stream
1411                           :format-control "failed to build ratio")))))
1412       (if negative-number (- num) num))))
1413 \f
1414 ;;;; cruft for dispatch macros
1415
1416 (defun make-char-dispatch-table ()
1417   (make-hash-table))
1418
1419 (defun dispatch-char-error (stream sub-char ignore)
1420   (declare (ignore ignore))
1421   (if *read-suppress*
1422       (values)
1423       (%reader-error stream "no dispatch function defined for ~S" sub-char)))
1424
1425 (defun make-dispatch-macro-character (char &optional
1426                                            (non-terminating-p nil)
1427                                            (rt *readtable*))
1428   #!+sb-doc
1429   "Cause CHAR to become a dispatching macro character in readtable (which
1430    defaults to the current readtable). If NON-TERMINATING-P, the char will
1431    be non-terminating."
1432   (set-macro-character char #'read-dispatch-char non-terminating-p rt)
1433   (let* ((dalist (dispatch-tables rt))
1434          (dtable (cdr (find char dalist :test #'char= :key #'car))))
1435     (cond (dtable
1436            (error "The dispatch character ~S already exists." char))
1437           (t
1438            (setf (dispatch-tables rt)
1439                  (push (cons char (make-char-dispatch-table)) dalist)))))
1440   t)
1441
1442 (defun set-dispatch-macro-character (disp-char sub-char function
1443                                                &optional (rt *readtable*))
1444   #!+sb-doc
1445   "Cause FUNCTION to be called whenever the reader reads DISP-CHAR
1446    followed by SUB-CHAR."
1447   ;; Get the dispatch char for macro (error if not there), diddle
1448   ;; entry for sub-char.
1449   (when (digit-char-p sub-char)
1450     (error "SUB-CHAR must not be a decimal digit: ~S" sub-char))
1451   (let* ((sub-char (char-upcase sub-char))
1452          (rt (or rt *standard-readtable*))
1453          (dpair (find disp-char (dispatch-tables rt)
1454                       :test #'char= :key #'car)))
1455     (if dpair
1456         (setf (gethash sub-char (cdr dpair)) (coerce function 'function))
1457         (error "~S is not a dispatch char." disp-char))))
1458
1459 (defun get-dispatch-macro-character (disp-char sub-char
1460                                      &optional (rt *readtable*))
1461   #!+sb-doc
1462   "Return the macro character function for SUB-CHAR under DISP-CHAR
1463    or NIL if there is no associated function."
1464   (let* ((sub-char (char-upcase sub-char))
1465          (rt (or rt *standard-readtable*))
1466          (dpair (find disp-char (dispatch-tables rt)
1467                       :test #'char= :key #'car)))
1468     (if dpair
1469         (values (gethash sub-char (cdr dpair)))
1470         (error "~S is not a dispatch char." disp-char))))
1471
1472 (defun read-dispatch-char (stream char)
1473   ;; Read some digits.
1474   (let ((numargp nil)
1475         (numarg 0)
1476         (sub-char ()))
1477     (do* ((ch (read-char stream nil *eof-object*)
1478               (read-char stream nil *eof-object*))
1479           (dig ()))
1480          ((or (eofp ch)
1481               (not (setq dig (digit-char-p ch))))
1482           ;; Take care of the extra char.
1483           (if (eofp ch)
1484               (reader-eof-error stream "inside dispatch character")
1485               (setq sub-char (char-upcase ch))))
1486       (setq numargp t)
1487       (setq numarg (+ (* numarg 10) dig)))
1488     ;; Look up the function and call it.
1489     (let ((dpair (find char (dispatch-tables *readtable*)
1490                        :test #'char= :key #'car)))
1491       (if dpair
1492           (funcall (the function
1493                      (gethash sub-char (cdr dpair) #'dispatch-char-error))
1494                    stream sub-char (if numargp numarg nil))
1495           (%reader-error stream "no dispatch table for dispatch char")))))
1496 \f
1497 ;;;; READ-FROM-STRING
1498
1499 (defun read-from-string (string &optional (eof-error-p t) eof-value
1500                                 &key (start 0) end
1501                                 preserve-whitespace)
1502   #!+sb-doc
1503   "The characters of string are successively given to the lisp reader
1504    and the lisp object built by the reader is returned. Macro chars
1505    will take effect."
1506   (declare (string string))
1507   (with-array-data ((string string :offset-var offset)
1508                     (start start)
1509                     (end (%check-vector-sequence-bounds string start end)))
1510     (let ((stream (make-string-input-stream string start end)))
1511       (values (if preserve-whitespace
1512                   (read-preserving-whitespace stream eof-error-p eof-value)
1513                   (read stream eof-error-p eof-value))
1514               (- (string-input-stream-current stream) offset)))))
1515 \f
1516 ;;;; PARSE-INTEGER
1517
1518 (defun parse-integer (string &key (start 0) end (radix 10) junk-allowed)
1519   #!+sb-doc
1520   "Examine the substring of string delimited by start and end
1521   (default to the beginning and end of the string)  It skips over
1522   whitespace characters and then tries to parse an integer. The
1523   radix parameter must be between 2 and 36."
1524   (macrolet ((parse-error (format-control)
1525                `(error 'simple-parse-error
1526                        :format-control ,format-control
1527                        :format-arguments (list string))))
1528     (with-array-data ((string string :offset-var offset)
1529                       (start start)
1530                       (end (%check-vector-sequence-bounds string start end)))
1531       (let ((index (do ((i start (1+ i)))
1532                        ((= i end)
1533                         (if junk-allowed
1534                             (return-from parse-integer (values nil end))
1535                             (parse-error "no non-whitespace characters in string ~S.")))
1536                      (declare (fixnum i))
1537                      (unless (whitespacep (char string i)) (return i))))
1538             (minusp nil)
1539             (found-digit nil)
1540             (result 0))
1541         (declare (fixnum index))
1542         (let ((char (char string index)))
1543           (cond ((char= char #\-)
1544                  (setq minusp t)
1545                  (incf index))
1546                 ((char= char #\+)
1547                  (incf index))))
1548         (loop
1549          (when (= index end) (return nil))
1550          (let* ((char (char string index))
1551                 (weight (digit-char-p char radix)))
1552            (cond (weight
1553                   (setq result (+ weight (* result radix))
1554                         found-digit t))
1555                  (junk-allowed (return nil))
1556                  ((whitespacep char)
1557                   (loop
1558                    (incf index)
1559                    (when (= index end) (return))
1560                    (unless (whitespacep (char string index))
1561                       (parse-error "junk in string ~S")))
1562                   (return nil))
1563                  (t
1564                   (parse-error "junk in string ~S"))))
1565          (incf index))
1566         (values
1567          (if found-digit
1568              (if minusp (- result) result)
1569              (if junk-allowed
1570                  nil
1571                  (parse-error "no digits in string ~S")))
1572          (- index offset))))))
1573 \f
1574 ;;;; reader initialization code
1575
1576 (defun !reader-cold-init ()
1577   (!cold-init-constituent-trait-table)
1578   (!cold-init-standard-readtable)
1579   ;; FIXME: This was commented out, but should probably be restored.
1580   #+nil (!cold-init-integer-reader))
1581 \f
1582 (def!method print-object ((readtable readtable) stream)
1583   (print-unreadable-object (readtable stream :identity t :type t)))