X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Freader.lisp;h=cbdb50dbea24d48451311d89200dc8a4a175201d;hb=dc33d6a6b84f8338e603759cec8e25da29055d50;hp=fbd1e0ef3e39f63b2d621ad85a158038d922a520;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git

diff --git a/src/code/reader.lisp b/src/code/reader.lisp
index fbd1e0e..cbdb50d 100644
--- a/src/code/reader.lisp
+++ b/src/code/reader.lisp
@@ -10,14 +10,13 @@
 ;;;; files for more information.
 
 (in-package "SB!IMPL")
-
-(file-comment
-  "$Header$")
 
-;;; miscellaneous global variables
+;;;; miscellaneous global variables
 
-(defvar *read-default-float-format* 'single-float
-  #!+sb-doc "Float format for 1.0E1")
+;;; ANSI: "the floating-point format that is to be used when reading a
+;;; floating-point number that has no exponent marker or that has e or
+;;; E for an exponent marker"
+(defvar *read-default-float-format* 'single-float)
 (declaim (type (member short-float single-float double-float long-float)
 	       *read-default-float-format*))
 
@@ -56,48 +55,53 @@
 	 :format-control control
 	 :format-arguments args))
 
-;;;; constants for character attributes. These are all as in the manual.
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defconstant whitespace 0)
-  (defconstant terminating-macro 1)
-  (defconstant escape 2)
-  (defconstant constituent 3)
-  (defconstant constituent-dot 4)
-  (defconstant constituent-expt 5)
-  (defconstant constituent-slash 6)
-  (defconstant constituent-digit 7)
-  (defconstant constituent-sign 8)
-  ;; the "9" entry intentionally left blank for some reason -- WHN 19990806
-  (defconstant multiple-escape 10)
-  (defconstant package-delimiter 11)
-  ;; a fake attribute for use in read-unqualified-token
-  (defconstant delimiter 12))
-
 ;;;; macros and functions for character tables
 
 ;;; FIXME: could be SB!XC:DEFMACRO inside EVAL-WHEN (COMPILE EVAL)
 (defmacro get-cat-entry (char rt)
   ;; KLUDGE: Only give this side-effect-free args.
   ;; FIXME: should probably become inline function
-  `(elt (character-attribute-table ,rt)
-	(char-code ,char)))
+  `(if (typep ,char 'base-char)
+       (elt (character-attribute-array ,rt) (char-code ,char))
+       (gethash ,char (character-attribute-hash-table ,rt)
+        +char-attr-constituent+)))
 
 (defun set-cat-entry (char newvalue &optional (rt *readtable*))
-  (setf (elt (character-attribute-table rt)
-	     (char-code char))
-	newvalue))
-
-;;; FIXME: could be SB!XC:DEFMACRO inside EVAL-WHEN (COMPILE EVAL)
-(defmacro get-cmt-entry (char rt)
-  `(the function
-	(elt (the simple-vector (character-macro-table ,rt))
-	     (char-code ,char))))
-
-(defun set-cmt-entry (char newvalue &optional (rt *readtable*))
-  (setf (elt (the simple-vector (character-macro-table rt))
-	     (char-code char))
-	(coerce newvalue 'function)))
+  (if (typep char 'base-char)
+      (setf (elt (character-attribute-array rt) (char-code char)) newvalue)
+      ;; FIXME: could REMHASH if we're setting to
+      ;; +CHAR-ATTR-CONSTITUENT+
+      (setf (gethash char (character-attribute-hash-table rt)) newvalue)))
+
+;;; the value actually stored in the character macro table. As per
+;;; ANSI #'GET-MACRO-CHARACTER and #'SET-MACRO-CHARACTER, this can
+;;; be either a function or NIL.
+(eval-when (:compile-toplevel :execute)
+  (sb!xc:defmacro get-raw-cmt-entry (char readtable)
+    `(if (typep ,char 'base-char)
+         (svref (character-macro-array ,readtable) (char-code ,char))
+         ;; Note: DEFAULT here is NIL, not #'UNDEFINED-MACRO-CHAR, so
+         ;; that everything above the base-char range is a non-macro
+         ;; constituent by default.
+         (gethash ,char (character-macro-hash-table ,readtable) nil))))
+
+;;; the value represented by whatever is stored in the character macro
+;;; table. As per ANSI #'GET-MACRO-CHARACTER and #'SET-MACRO-CHARACTER,
+;;; a function value represents itself, and a NIL value represents the
+;;; default behavior.
+(defun get-coerced-cmt-entry (char readtable)
+  (the function 
+    (or (get-raw-cmt-entry char readtable)
+	#'read-token)))
+
+(defun set-cmt-entry (char new-value-designator &optional (rt *readtable*))
+  (if (typep char 'base-char)
+      (setf (svref (character-macro-array rt) (char-code char))
+            (and new-value-designator
+                 (%coerce-callable-to-fun new-value-designator)))
+      (setf (gethash char (character-macro-hash-table rt))
+	(and new-value-designator
+                 (%coerce-callable-to-fun new-value-designator)))))
 
 (defun undefined-macro-char (stream char)
   (unless *read-suppress*
@@ -112,78 +116,99 @@
 
 #!-sb-fluid (declaim (inline whitespacep))
 (defun whitespacep (char &optional (rt *readtable*))
-  (test-attribute char whitespace rt))
+  (test-attribute char +char-attr-whitespace+ rt))
 
 (defmacro constituentp (char &optional (rt '*readtable*))
-  `(>= (get-cat-entry ,char ,rt) #.constituent))
+  `(test-attribute ,char +char-attr-constituent+ ,rt))
 
 (defmacro terminating-macrop (char &optional (rt '*readtable*))
-  `(test-attribute ,char #.terminating-macro ,rt))
+  `(test-attribute ,char +char-attr-terminating-macro+ ,rt))
 
-(defmacro escapep (char &optional (rt '*readtable*))
-  `(test-attribute ,char #.escape ,rt))
+(defmacro single-escape-p (char &optional (rt '*readtable*))
+  `(test-attribute ,char +char-attr-single-escape+ ,rt))
 
 (defmacro multiple-escape-p (char &optional (rt '*readtable*))
-  `(test-attribute ,char #.multiple-escape ,rt))
+  `(test-attribute ,char +char-attr-multiple-escape+ ,rt))
 
 (defmacro token-delimiterp (char &optional (rt '*readtable*))
   ;; depends on actual attribute numbering above.
-  `(<= (get-cat-entry ,char ,rt) #.terminating-macro))
+  `(<= (get-cat-entry ,char ,rt) +char-attr-terminating-macro+))
 
-;;;; secondary attribute table
-
-;;; There are a number of "secondary" attributes which are constant properties
-;;; of characters (as long as they are constituents).
-
-(defvar *secondary-attribute-table*)
-(declaim (type attribute-table *secondary-attribute-table*))
-
-(defun !set-secondary-attribute (char attribute)
-  (setf (elt *secondary-attribute-table* (char-code char))
-	attribute))
-
-(defun !cold-init-secondary-attribute-table ()
-  (setq *secondary-attribute-table*
-	(make-array char-code-limit :element-type '(unsigned-byte 8)
-		    :initial-element #.constituent))
-  (!set-secondary-attribute #\: #.package-delimiter)
-  (!set-secondary-attribute #\| #.multiple-escape)	; |) [for EMACS]
-  (!set-secondary-attribute #\. #.constituent-dot)
-  (!set-secondary-attribute #\+ #.constituent-sign)
-  (!set-secondary-attribute #\- #.constituent-sign)
-  (!set-secondary-attribute #\/ #.constituent-slash)
+;;;; constituent traits (see ANSI 2.1.4.2)
+
+;;; There are a number of "secondary" attributes which are constant
+;;; properties of characters (as long as they are constituents).
+
+(defvar *constituent-trait-table*)
+(declaim (type attribute-table *constituent-trait-table*))
+
+(defun !set-constituent-trait (char trait)
+  (aver (typep char 'base-char))
+  (setf (elt *constituent-trait-table* (char-code char))
+	trait))
+
+(defun !cold-init-constituent-trait-table ()
+  (setq *constituent-trait-table*
+	(make-array base-char-code-limit :element-type '(unsigned-byte 8)
+		    :initial-element +char-attr-constituent+))
+  (!set-constituent-trait #\: +char-attr-package-delimiter+)
+  (!set-constituent-trait #\. +char-attr-constituent-dot+)
+  (!set-constituent-trait #\+ +char-attr-constituent-sign+)
+  (!set-constituent-trait #\- +char-attr-constituent-sign+)
+  (!set-constituent-trait #\/ +char-attr-constituent-slash+)
   (do ((i (char-code #\0) (1+ i)))
       ((> i (char-code #\9)))
-    (!set-secondary-attribute (code-char i) #.constituent-digit))
-  (!set-secondary-attribute #\E #.constituent-expt)
-  (!set-secondary-attribute #\F #.constituent-expt)
-  (!set-secondary-attribute #\D #.constituent-expt)
-  (!set-secondary-attribute #\S #.constituent-expt)
-  (!set-secondary-attribute #\L #.constituent-expt)
-  (!set-secondary-attribute #\e #.constituent-expt)
-  (!set-secondary-attribute #\f #.constituent-expt)
-  (!set-secondary-attribute #\d #.constituent-expt)
-  (!set-secondary-attribute #\s #.constituent-expt)
-  (!set-secondary-attribute #\l #.constituent-expt))
-
-(defmacro get-secondary-attribute (char)
-  `(elt *secondary-attribute-table*
-	(char-code ,char)))
+    (!set-constituent-trait (code-char i) +char-attr-constituent-digit+))
+  (!set-constituent-trait #\E +char-attr-constituent-expt+)
+  (!set-constituent-trait #\F +char-attr-constituent-expt+)
+  (!set-constituent-trait #\D +char-attr-constituent-expt+)
+  (!set-constituent-trait #\S +char-attr-constituent-expt+)
+  (!set-constituent-trait #\L +char-attr-constituent-expt+)
+  (!set-constituent-trait #\e +char-attr-constituent-expt+)
+  (!set-constituent-trait #\f +char-attr-constituent-expt+)
+  (!set-constituent-trait #\d +char-attr-constituent-expt+)
+  (!set-constituent-trait #\s +char-attr-constituent-expt+)
+  (!set-constituent-trait #\l +char-attr-constituent-expt+)
+  (!set-constituent-trait #\Space +char-attr-invalid+)
+  (!set-constituent-trait #\Newline +char-attr-invalid+)
+  (dolist (c (list backspace-char-code tab-char-code form-feed-char-code
+		   return-char-code rubout-char-code))
+    (!set-constituent-trait (code-char c) +char-attr-invalid+)))
+		   
+(defmacro get-constituent-trait (char)
+  `(if (typep ,char 'base-char)
+       (elt *constituent-trait-table* (char-code ,char))
+       +char-attr-constituent+))
 
 ;;;; readtable operations
 
+(defun shallow-replace/eql-hash-table (to from)
+  (maphash (lambda (k v) (setf (gethash k to) v)) from))
+
 (defun copy-readtable (&optional (from-readtable *readtable*)
-				 (to-readtable (make-readtable)))
-  (let ((really-from-readtable (or from-readtable *standard-readtable*)))
-    (replace (character-attribute-table to-readtable)
-	     (character-attribute-table really-from-readtable))
-    (replace (character-macro-table to-readtable)
-	     (character-macro-table really-from-readtable))
-    (setf (dispatch-tables to-readtable)
-	  (mapcar #'(lambda (pair) (cons (car pair)
-					 (copy-seq (cdr pair))))
+				 to-readtable)
+  (let ((really-from-readtable (or from-readtable *standard-readtable*))
+        (really-to-readtable (or to-readtable (make-readtable))))
+    (replace (character-attribute-array really-to-readtable)
+	     (character-attribute-array really-from-readtable))
+    (shallow-replace/eql-hash-table
+     (character-attribute-hash-table really-to-readtable)
+     (character-attribute-hash-table really-from-readtable))
+    (replace (character-macro-array really-to-readtable)
+	     (character-macro-array really-from-readtable))
+    (shallow-replace/eql-hash-table
+     (character-macro-hash-table really-to-readtable)
+     (character-macro-hash-table really-from-readtable))
+    (setf (dispatch-tables really-to-readtable)
+	  (mapcar (lambda (pair)
+                    (cons (car pair)
+                          (let ((table (make-hash-table)))
+                            (shallow-replace/eql-hash-table table (cdr pair))
+                            table)))
 		  (dispatch-tables really-from-readtable)))
-    to-readtable))
+    (setf (readtable-case really-to-readtable)
+	  (readtable-case really-from-readtable))
+    really-to-readtable))
 
 (defun set-syntax-from-char (to-char from-char &optional
 				     (to-readtable *readtable*)
@@ -193,72 +218,98 @@
   optional readtable (defaults to the current readtable). The
   FROM-TABLE defaults to the standard Lisp readtable when NIL."
   (let ((really-from-readtable (or from-readtable *standard-readtable*)))
-    ;; Copy from-char entries to to-char entries, but make sure that if
-    ;; from char is a constituent you don't copy non-movable secondary
-    ;; attributes (constituent types), and that said attributes magically
-    ;; appear if you transform a non-constituent to a constituent.
-    (let ((att (get-cat-entry from-char really-from-readtable)))
-      (if (constituentp from-char really-from-readtable)
-	  (setq att (get-secondary-attribute to-char)))
+    (let ((att (get-cat-entry from-char really-from-readtable))
+	  (mac (get-raw-cmt-entry from-char really-from-readtable))
+	  (from-dpair (find from-char (dispatch-tables really-from-readtable)
+			    :test #'char= :key #'car))
+	  (to-dpair (find to-char (dispatch-tables to-readtable)
+			  :test #'char= :key #'car)))
       (set-cat-entry to-char att to-readtable)
-      (set-cmt-entry to-char
-		     (get-cmt-entry from-char really-from-readtable)
-		     to-readtable)))
+      (set-cmt-entry to-char mac to-readtable)
+      (when from-dpair
+	(cond
+	  (to-dpair
+	   (let ((table (cdr to-dpair)))
+	     (clrhash table)
+	     (shallow-replace/eql-hash-table table (cdr from-dpair))))
+	  (t
+	   (let ((pair (cons to-char (make-hash-table))))
+	     (shallow-replace/eql-hash-table (cdr pair) (cdr from-dpair))
+	     (setf (dispatch-tables to-readtable)
+		   (push pair (dispatch-tables to-readtable)))))))))
   t)
 
 (defun set-macro-character (char function &optional
-				 (non-terminatingp nil) (rt *readtable*))
+				 (non-terminatingp nil)
+				 (readtable *readtable*))
   #!+sb-doc
-  "Causes char to be a macro character which invokes function when
-   seen by the reader. The non-terminatingp flag can be used to
-   make the macro character non-terminating. The optional readtable
-   argument defaults to the current readtable. Set-macro-character
-   returns T."
-  (if non-terminatingp
-      (set-cat-entry char (get-secondary-attribute char) rt)
-      (set-cat-entry char #.terminating-macro rt))
-  (set-cmt-entry char function rt)
-  T)
-
-(defun get-macro-character (char &optional rt)
+  "Causes CHAR to be a macro character which invokes FUNCTION when seen
+   by the reader. The NON-TERMINATINGP flag can be used to make the macro
+   character non-terminating, i.e. embeddable in a symbol name."
+  (let ((designated-readtable (or readtable *standard-readtable*)))
+    (set-cat-entry char (if non-terminatingp
+			    +char-attr-constituent+
+			    +char-attr-terminating-macro+)
+		   designated-readtable)
+    (set-cmt-entry char function designated-readtable)
+    t)) ; (ANSI-specified return value)
+
+(defun get-macro-character (char &optional (readtable *readtable*))
   #!+sb-doc
-  "Returns the function associated with the specified char which is a macro
-  character. The optional readtable argument defaults to the current
-  readtable."
-  (let ((rt (or rt *readtable*)))
-    ;; Check macro syntax, return associated function if it's there.
-    ;; Returns a value for all constituents.
-    (cond ((constituentp char)
-	   (values (get-cmt-entry char rt) t))
-	  ((terminating-macrop char)
-	   (values (get-cmt-entry char rt) nil))
-	  (t nil))))
+  "Return the function associated with the specified CHAR which is a macro
+  character, or NIL if there is no such function. As a second value, return
+  T if CHAR is a macro character which is non-terminating, i.e. which can
+  be embedded in a symbol name."
+  (let* ((designated-readtable (or readtable *standard-readtable*))
+	 ;; the first return value: a FUNCTION if CHAR is a macro
+	 ;; character, or NIL otherwise
+	 (fun-value (get-raw-cmt-entry char designated-readtable)))
+    (values fun-value
+	    ;; NON-TERMINATING-P return value:
+	    (if fun-value
+		(or (constituentp char)
+		    (not (terminating-macrop char)))
+		;; ANSI's definition of GET-MACRO-CHARACTER says this
+		;; value is NIL when CHAR is not a macro character.
+		;; I.e. this value means not just "non-terminating
+		;; character?" but "non-terminating macro character?".
+		nil))))
 
 ;;;; definitions to support internal programming conventions
 
-;;; FIXME: DEFCONSTANT doesn't actually work this way..
-(defconstant eof-object '(*eof*))
-
-(defmacro eofp (char) `(eq ,char eof-object))
+(defmacro eofp (char)
+  `(eq ,char *eof-object*))
 
 (defun flush-whitespace (stream)
   ;; This flushes whitespace chars, returning the last char it read (a
   ;; non-white one). It always gets an error on end-of-file.
   (let ((stream (in-synonym-of stream)))
-    (if (lisp-stream-p stream)
+    (if (ansi-stream-p stream)
 	(prepare-for-fast-read-char stream
-	  (do ((attribute-table (character-attribute-table *readtable*))
+	  (do ((attribute-array (character-attribute-array *readtable*))
+               (attribute-hash-table
+                (character-attribute-hash-table *readtable*))
 	       (char (fast-read-char t) (fast-read-char t)))
-	      ((/= (the fixnum (aref attribute-table (char-code char)))
-		   #.whitespace)
+	      ((/= (the fixnum
+                     (if (typep char 'base-char)
+                         (aref attribute-array (char-code char))
+                         (gethash char attribute-hash-table
+                                  +char-attr-constituent+)))
+		   +char-attr-whitespace+)
 	       (done-with-fast-read-char)
 	       char)))
-	;; fundamental-stream
-	(do ((attribute-table (character-attribute-table *readtable*))
-	     (char (stream-read-char stream) (stream-read-char stream)))
+	;; CLOS stream
+	(do ((attribute-array (character-attribute-array *readtable*))
+             (attribute-hash-table
+              (character-attribute-hash-table *readtable*))
+	     (char (read-char stream nil :eof) (read-char stream nil :eof)))
 	    ((or (eq char :eof)
-		 (/= (the fixnum (aref attribute-table (char-code char)))
-		     #.whitespace))
+		 (/= (the fixnum
+                       (if (typep char 'base-char)
+                           (aref attribute-array (char-code char))
+                           (gethash char attribute-hash-table
+                                    +char-attr-constituent+)))
+		     +char-attr-whitespace+))
 	     (if (eq char :eof)
 		 (error 'end-of-file :stream stream)
 		 char))))))
@@ -267,66 +318,70 @@
 
 (defun !cold-init-standard-readtable ()
   (setq *standard-readtable* (make-readtable))
-  ;; All characters default to "constituent" in MAKE-READTABLE.
-  ;; *** un-constituent-ize some of these ***
+  ;; All characters get boring defaults in MAKE-READTABLE. Now we
+  ;; override the boring defaults on characters which need more
+  ;; interesting behavior.
   (let ((*readtable* *standard-readtable*))
-    (set-cat-entry (code-char tab-char-code) #.whitespace)
-    (set-cat-entry #\linefeed #.whitespace)
-    (set-cat-entry #\space #.whitespace)
-    (set-cat-entry (code-char form-feed-char-code) #.whitespace)
-    (set-cat-entry (code-char return-char-code) #.whitespace)
-    (set-cat-entry #\\ #.escape)
-    (set-cmt-entry #\\ #'read-token)
-    (set-cat-entry (code-char rubout-char-code) #.whitespace)
-    (set-cmt-entry #\: #'read-token)
-    (set-cmt-entry #\| #'read-token)
-    ;; macro definitions
+
+    (flet ((whitespaceify (char)
+	     (set-cmt-entry char nil)
+	     (set-cat-entry char +char-attr-whitespace+)))
+      (whitespaceify (code-char tab-char-code))
+      (whitespaceify #\Newline)
+      (whitespaceify #\Space)
+      (whitespaceify (code-char form-feed-char-code))
+      (whitespaceify (code-char return-char-code)))
+
+    (set-cat-entry #\\ +char-attr-single-escape+)
+    (set-cmt-entry #\\ nil)
+
+    (set-cat-entry #\| +char-attr-multiple-escape+)
+    (set-cmt-entry #\| nil)
+
+    ;; Easy macro-character definitions are in this source file.
     (set-macro-character #\" #'read-string)
-    ;; * # macro
     (set-macro-character #\' #'read-quote)
     (set-macro-character #\( #'read-list)
     (set-macro-character #\) #'read-right-paren)
     (set-macro-character #\; #'read-comment)
-    ;; * backquote
+    ;; (The hairier macro-character definitions, for #\# and #\`, are
+    ;; defined elsewhere, in their own source files.)
+
     ;; all constituents
     (do ((ichar 0 (1+ ichar))
 	 (char))
-	((= ichar #O200))
+	((= ichar base-char-code-limit))
       (setq char (code-char ichar))
       (when (constituentp char *standard-readtable*)
-	    (set-cat-entry char (get-secondary-attribute char))
-	    (set-cmt-entry char #'read-token)))))
+	(set-cmt-entry char nil)))))
 
 ;;;; implementation of the read buffer
 
 (defvar *read-buffer*)
 (defvar *read-buffer-length*)
-;;; FIXME: Is it really helpful to have *READ-BUFFER-LENGTH* be a separate
-;;; variable instead of just calculating it on the fly as (LENGTH *READ-BUFFER*)?
+;;; FIXME: Is it really helpful to have *READ-BUFFER-LENGTH* be a
+;;; separate variable instead of just calculating it on the fly as
+;;; (LENGTH *READ-BUFFER*)?
 
 (defvar *inch-ptr*)
 (defvar *ouch-ptr*)
 
 (declaim (type index *read-buffer-length* *inch-ptr* *ouch-ptr*))
-(declaim (simple-string *read-buffer*))
+(declaim (type (simple-array character (*)) *read-buffer*))
 
 (defmacro reset-read-buffer ()
-  ;; Turn *read-buffer* into an empty read buffer.
-  ;; *Ouch-ptr* always points to next char to write.
+  ;; Turn *READ-BUFFER* into an empty read buffer.
   `(progn
-    (setq *ouch-ptr* 0)
-    ;; *inch-ptr* always points to next char to read.
-    (setq *inch-ptr* 0)))
-
-(defun !cold-init-read-buffer ()
-  (setq *read-buffer* (make-string 512)) ; initial bufsize
-  (setq *read-buffer-length* 512)
-  (reset-read-buffer))
+     ;; *OUCH-PTR* always points to next char to write.
+     (setq *ouch-ptr* 0)
+     ;; *INCH-PTR* always points to next char to read.
+     (setq *inch-ptr* 0)))
 
 ;;; FIXME I removed "THE FIXNUM"'s from OUCH-READ-BUFFER and
-;;; OUCH-UNREAD-BUFFER, check to make sure that Python really is smart enough
-;;; to make good code without them. And while I'm at it, converting them
-;;; from macros to inline functions might be good, too.
+;;; OUCH-UNREAD-BUFFER, check to make sure that Python really is smart
+;;; enough to make good code without them. And while I'm at it,
+;;; converting them from macros to inline functions might be good,
+;;; too.
 
 (defmacro ouch-read-buffer (char)
   `(progn
@@ -352,15 +407,15 @@
 
 (defun inchpeek-read-buffer ()
   (if (>= (the fixnum *inch-ptr*) (the fixnum *ouch-ptr*))
-      eof-object
+      *eof-object*
       (elt *read-buffer* *inch-ptr*)))
 
 (defun inch-read-buffer ()
   (if (>= *inch-ptr* *ouch-ptr*)
-    eof-object
-    (prog1
-	(elt *read-buffer* *inch-ptr*)
-      (incf *inch-ptr*))))
+      *eof-object*
+      (prog1
+	  (elt *read-buffer* *inch-ptr*)
+	(incf *inch-ptr*))))
 
 (defmacro unread-buffer ()
   `(decf *inch-ptr*))
@@ -371,6 +426,18 @@
 
 (defun read-buffer-to-string ()
   (subseq *read-buffer* 0 *ouch-ptr*))
+
+(defmacro with-reader ((&optional recursive-p) &body body)
+  #!+sb-doc
+  "If RECURSIVE-P is NIL, bind *READER-BUFFER* and its subservient
+variables to allow for nested and thread safe reading."
+  `(if ,recursive-p
+       (progn ,@body)
+       (let* ((*read-buffer* (make-string 128))
+              (*read-buffer-length* 128)
+              (*ouch-ptr* 0)
+              (*inch-ptr* 0))
+         ,@body)))
 
 ;;;; READ-PRESERVING-WHITESPACE, READ-DELIMITED-LIST, and READ
 
@@ -386,72 +453,82 @@
 
 (declaim (special *standard-input*))
 
-;;; READ-PRESERVING-WHITESPACE behaves just like READ, only it makes sure
-;;; to leave terminating whitespace in the stream.
+;;; READ-PRESERVING-WHITESPACE behaves just like READ, only it makes
+;;; sure to leave terminating whitespace in the stream. (This is a
+;;; COMMON-LISP exported symbol.)
 (defun read-preserving-whitespace (&optional (stream *standard-input*)
 					     (eof-error-p t)
 					     (eof-value nil)
 					     (recursivep nil))
   #!+sb-doc
-  "Reads from stream and returns the object read, preserving the whitespace
+  "Read from STREAM and return the value read, preserving any whitespace
    that followed the object."
-  (cond
-   (recursivep
-    ;; Loop for repeating when a macro returns nothing.
-    (loop
-      (let ((char (read-char stream eof-error-p eof-object)))
-	(cond ((eofp char) (return eof-value))
-	      ((whitespacep char))
-	      (t
-	       (let* ((macrofun (get-cmt-entry char *readtable*))
-		      (result (multiple-value-list
-			       (funcall macrofun stream char))))
-		 ;; Repeat if macro returned nothing.
-		 (if result (return (car result)))))))))
-   (t
-    (let ((*sharp-equal-alist* nil))
-      (read-preserving-whitespace stream eof-error-p eof-value t)))))
-
+  (if recursivep
+      ;; a loop for repeating when a macro returns nothing
+      (loop
+       (let ((char (read-char stream eof-error-p *eof-object*)))
+         (cond ((eofp char) (return eof-value))
+               ((whitespacep char))
+               (t
+                (let* ((macrofun (get-coerced-cmt-entry char *readtable*))
+                       (result (multiple-value-list
+                                (funcall macrofun stream char))))
+                  ;; Repeat if macro returned nothing.
+		  (when result
+                    (return (unless *read-suppress* (car result)))))))))
+      (with-reader ()
+        (let ((*sharp-equal-alist* nil))
+          (read-preserving-whitespace stream eof-error-p eof-value t)))))
+
+;;; Return NIL or a list with one thing, depending.
+;;;
+;;; for functions that want comments to return so that they can look
+;;; past them. We assume CHAR is not whitespace.
 (defun read-maybe-nothing (stream char)
-  ;;returns nil or a list with one thing, depending.
-  ;;for functions that want comments to return so they can look
-  ;;past them. Assumes char is not whitespace.
   (let ((retval (multiple-value-list
-		 (funcall (get-cmt-entry char *readtable*) stream char))))
+		 (funcall (get-coerced-cmt-entry char *readtable*)
+			  stream
+			  char))))
     (if retval (rplacd retval nil))))
 
-(defun read (&optional (stream *standard-input*) (eof-error-p t)
-		       (eof-value ()) (recursivep ()))
+(defun read (&optional (stream *standard-input*)
+		       (eof-error-p t)
+		       (eof-value ())
+		       (recursivep ()))
   #!+sb-doc
-  "Reads in the next object in the stream, which defaults to
-   *standard-input*. For details see the I/O chapter of
-   the manual."
-  (prog1
-      (read-preserving-whitespace stream eof-error-p eof-value recursivep)
-    (let ((whitechar (read-char stream nil eof-object)))
-      (if (and (not (eofp whitechar))
-	       (or (not (whitespacep whitechar))
-		   recursivep))
-	  (unread-char whitechar stream)))))
-
+  "Read the next Lisp value from STREAM, and return it."
+  (let ((result (read-preserving-whitespace stream
+					    eof-error-p
+					    eof-value
+					    recursivep)))
+    ;; This function generally discards trailing whitespace. If you
+    ;; don't want to discard trailing whitespace, call
+    ;; CL:READ-PRESERVING-WHITESPACE instead.
+    (unless (or (eql result eof-value) recursivep)
+      (let ((next-char (read-char stream nil nil)))
+	(unless (or (null next-char)
+		    (whitespacep next-char))
+	  (unread-char next-char stream))))
+    result))
+
+;;; (This is a COMMON-LISP exported symbol.)
 (defun read-delimited-list (endchar &optional
 				    (input-stream *standard-input*)
 				    recursive-p)
   #!+sb-doc
-  "Reads objects from input-stream until the next character after an
-   object's representation is endchar. A list of those objects read
-   is returned."
-  (declare (ignore recursive-p))
-  (do ((char (flush-whitespace input-stream)
-	     (flush-whitespace input-stream))
-       (retlist ()))
-      ((char= char endchar) (nreverse retlist))
-    (setq retlist (nconc (read-maybe-nothing input-stream char) retlist))))
+  "Read Lisp values from INPUT-STREAM until the next character after a
+   value's representation is ENDCHAR, and return the objects as a list."
+  (with-reader (recursive-p)
+    (do ((char (flush-whitespace input-stream)
+               (flush-whitespace input-stream))
+         (retlist ()))
+        ((char= char endchar) (unless *read-suppress* (nreverse retlist)))
+      (setq retlist (nconc (read-maybe-nothing input-stream char) retlist)))))
 
 ;;;; basic readmacro definitions
 ;;;;
-;;;; Large, hairy subsets of readmacro definitions (backquotes and sharp
-;;;; macros) are not here, but in their own source files.
+;;;; Some large, hairy subsets of readmacro definitions (backquotes
+;;;; and sharp macros) are not here, but in their own source files.
 
 (defun read-quote (stream ignore)
   (declare (ignore ignore))
@@ -459,16 +536,22 @@
 
 (defun read-comment (stream ignore)
   (declare (ignore ignore))
-  (let ((stream (in-synonym-of stream)))
-    (if (lisp-stream-p stream)
-	(prepare-for-fast-read-char stream
-	  (do ((char (fast-read-char nil nil)
-		     (fast-read-char nil nil)))
-	      ((or (not char) (char= char #\newline))
-	       (done-with-fast-read-char))))
-	;; FUNDAMENTAL-STREAM
-	(do ((char (stream-read-char stream) (stream-read-char stream)))
-	    ((or (eq char :eof) (char= char #\newline))))))
+  (handler-bind
+      ((character-decoding-error
+	#'(lambda (decoding-error)
+	    (declare (ignorable decoding-error))
+	    (style-warn "Character decoding error in a ;-comment at position ~A reading source file ~A, resyncing." (file-position stream) stream)
+	    (invoke-restart 'attempt-resync))))
+    (let ((stream (in-synonym-of stream)))
+      (if (ansi-stream-p stream)
+	  (prepare-for-fast-read-char stream
+	   (do ((char (fast-read-char nil nil)
+		      (fast-read-char nil nil)))
+	       ((or (not char) (char= char #\newline))
+		(done-with-fast-read-char))))
+	  ;; CLOS stream
+	  (do ((char (read-char stream nil :eof) (read-char stream nil :eof)))
+	      ((or (eq char :eof) (char= char #\newline)))))))
   ;; Don't return anything.
   (values))
 
@@ -482,9 +565,10 @@
 	    (let ((nextchar (read-char stream t)))
 	      (cond ((token-delimiterp nextchar)
 		     (cond ((eq listtail thelist)
-			    (%reader-error
-			     stream
-			     "Nothing appears before . in list."))
+			    (unless *read-suppress*
+			      (%reader-error
+			       stream
+			       "Nothing appears before . in list.")))
 			   ((whitespacep nextchar)
 			    (setq nextchar (flush-whitespace stream))))
 		     (rplacd listtail
@@ -505,7 +589,9 @@
   (let ((lastobj ()))
     (do ((char firstchar (flush-whitespace stream)))
 	((char= char #\) )
-	 (%reader-error stream "Nothing appears after . in list."))
+	 (if *read-suppress*
+	     (return-from read-after-dot nil)
+	     (%reader-error stream "Nothing appears after . in list.")))
       ;; See whether there's something there.
       (setq lastobj (read-maybe-nothing stream char))
       (when lastobj (return t)))
@@ -515,7 +601,8 @@
 		   (flush-whitespace stream)))
 	((char= lastchar #\) ) lastobj)	;success!
       ;; Try reading virtual whitespace.
-      (if (read-maybe-nothing stream lastchar)
+      (if (and (read-maybe-nothing stream lastchar)
+	       (not *read-suppress*))
 	  (%reader-error stream "More than one object follows . in list.")))))
 
 (defun read-string (stream closech)
@@ -523,20 +610,20 @@
   ;; For a very long string, this could end up bloating the read buffer.
   (reset-read-buffer)
   (let ((stream (in-synonym-of stream)))
-    (if (lisp-stream-p stream)
+    (if (ansi-stream-p stream)
 	(prepare-for-fast-read-char stream
 	  (do ((char (fast-read-char t) (fast-read-char t)))
 	      ((char= char closech)
 	       (done-with-fast-read-char))
-	    (if (escapep char) (setq char (fast-read-char t)))
+	    (if (single-escape-p char) (setq char (fast-read-char t)))
 	    (ouch-read-buffer char)))
-	;; FUNDAMENTAL-STREAM
-	(do ((char (stream-read-char stream) (stream-read-char stream)))
+	;; CLOS stream
+	(do ((char (read-char stream nil :eof) (read-char stream nil :eof)))
 	    ((or (eq char :eof) (char= char closech))
 	     (if (eq char :eof)
 		 (error 'end-of-file :stream stream)))
-	  (when (escapep char)
-	    (setq char (stream-read-char stream))
+	  (when (single-escape-p char)
+	    (setq char (read-char stream nil :eof))
 	    (if (eq char :eof)
 		(error 'end-of-file :stream stream)))
 	  (ouch-read-buffer char))))
@@ -546,14 +633,18 @@
   (declare (ignore ignore))
   (%reader-error stream "unmatched close parenthesis"))
 
-;;; Read from the stream up to the next delimiter. Leave the resulting token in
-;;; *read-buffer*, and return two values:
+;;; Read from the stream up to the next delimiter. Leave the resulting
+;;; token in *READ-BUFFER*, and return two values:
 ;;; -- a list of the escaped character positions, and
 ;;; -- The position of the first package delimiter (or NIL).
-(defun internal-read-extended-token (stream firstchar)
+(defun internal-read-extended-token (stream firstchar escape-firstchar)
   (reset-read-buffer)
-  (do ((char firstchar (read-char stream nil eof-object))
-       (escapes ())
+  (let ((escapes '()))
+    (when escape-firstchar
+      (push *ouch-ptr* escapes)
+      (ouch-read-buffer firstchar)
+      (setq firstchar (read-char stream nil *eof-object*)))
+  (do ((char firstchar (read-char stream nil *eof-object*))
        (colon nil))
       ((cond ((eofp char) t)
 	     ((token-delimiterp char)
@@ -561,95 +652,123 @@
 	      t)
 	     (t nil))
        (values escapes colon))
-    (cond ((escapep char)
+    (cond ((single-escape-p char)
 	   ;; It can't be a number, even if it's 1\23.
 	   ;; Read next char here, so it won't be casified.
 	   (push *ouch-ptr* escapes)
-	   (let ((nextchar (read-char stream nil eof-object)))
+	   (let ((nextchar (read-char stream nil *eof-object*)))
 	     (if (eofp nextchar)
 		 (reader-eof-error stream "after escape character")
 		 (ouch-read-buffer nextchar))))
 	  ((multiple-escape-p char)
-	   ;; Read to next multiple-escape, escaping single chars along the
-	   ;; way.
+	   ;; Read to next multiple-escape, escaping single chars
+	   ;; along the way.
 	   (loop
-	     (let ((ch (read-char stream nil eof-object)))
+	     (let ((ch (read-char stream nil *eof-object*)))
 	       (cond
 		((eofp ch)
 		 (reader-eof-error stream "inside extended token"))
 		((multiple-escape-p ch) (return))
-		((escapep ch)
-		 (let ((nextchar (read-char stream nil eof-object)))
-		   (if (eofp nextchar)
-		       (reader-eof-error stream "after escape character")
-		       (ouch-read-buffer nextchar))))
+		((single-escape-p ch)
+		 (let ((nextchar (read-char stream nil *eof-object*)))
+		   (cond ((eofp nextchar)
+			  (reader-eof-error stream "after escape character"))
+			 (t
+			  (push *ouch-ptr* escapes)
+			  (ouch-read-buffer nextchar)))))
 		(t
 		 (push *ouch-ptr* escapes)
 		 (ouch-read-buffer ch))))))
 	  (t
 	   (when (and (constituentp char)
-		      (eql (get-secondary-attribute char) #.package-delimiter)
+		      (eql (get-constituent-trait char)
+			   +char-attr-package-delimiter+)
 		      (not colon))
 	     (setq colon *ouch-ptr*))
-	   (ouch-read-buffer char)))))
+	   (ouch-read-buffer char))))))
 
 ;;;; character classes
 
 ;;; Return the character class for CHAR.
-(defmacro char-class (char attable)
-  `(let ((att (aref ,attable (char-code ,char))))
+;;;
+;;; FIXME: why aren't these ATT-getting forms using GET-CAT-ENTRY?
+;;; Because we've cached the readtable tables?
+(defmacro char-class (char attarray atthash)
+  `(let ((att (if (typep ,char 'base-char)
+                  (aref ,attarray (char-code ,char))
+                  (gethash ,char ,atthash +char-attr-constituent+))))
      (declare (fixnum att))
-     (if (<= att #.terminating-macro)
-	 #.delimiter
-	 att)))
-
-;;; Return the character class for CHAR, which might be part of a rational
-;;; number.
-(defmacro char-class2 (char attable)
-  `(let ((att (aref ,attable (char-code ,char))))
+     (cond
+       ((<= att +char-attr-terminating-macro+) +char-attr-delimiter+)
+       ((< att +char-attr-constituent+) att)
+       (t (setf att (get-constituent-trait ,char))
+	  (if (= att +char-attr-invalid+) 
+	      (%reader-error stream "invalid constituent")
+	      att)))))
+
+;;; Return the character class for CHAR, which might be part of a
+;;; rational number.
+(defmacro char-class2 (char attarray atthash)
+  `(let ((att (if (typep ,char 'base-char)
+                  (aref ,attarray (char-code ,char))
+                  (gethash ,char ,atthash +char-attr-constituent+))))
      (declare (fixnum att))
-     (if (<= att #.terminating-macro)
-	 #.delimiter
-	 (if (digit-char-p ,char *read-base*)
-	     constituent-digit
-	     (if (= att constituent-digit)
-		 constituent
-		 att)))))
-
-;;; Return the character class for a char which might be part of a rational or
-;;; floating number. (Assume that it is a digit if it could be.)
-(defmacro char-class3 (char attable)
-  `(let ((att (aref ,attable (char-code ,char))))
+     (cond
+       ((<= att +char-attr-terminating-macro+) +char-attr-delimiter+)
+       ((< att +char-attr-constituent+) att)
+       (t (setf att (get-constituent-trait ,char))
+	  (cond
+	    ((digit-char-p ,char *read-base*) +char-attr-constituent-digit+)
+	    ((= att +char-attr-constituent-digit+) +char-attr-constituent+)
+	    ((= att +char-attr-invalid+) 
+	     (%reader-error stream "invalid constituent"))
+	    (t att))))))
+
+;;; Return the character class for a char which might be part of a
+;;; rational or floating number. (Assume that it is a digit if it
+;;; could be.)
+(defmacro char-class3 (char attarray atthash)
+  `(let ((att (if (typep ,char 'base-char)
+                  (aref ,attarray (char-code ,char))
+                  (gethash ,char ,atthash +char-attr-constituent+))))
      (declare (fixnum att))
-     (if possibly-rational
-	 (setq possibly-rational
-	       (or (digit-char-p ,char *read-base*)
-		   (= att constituent-slash))))
-     (if possibly-float
-	 (setq possibly-float
-	       (or (digit-char-p ,char 10)
-		   (= att constituent-dot))))
-     (if (<= att #.terminating-macro)
-	 #.delimiter
-	 (if (digit-char-p ,char (max *read-base* 10))
+     (cond
+       ((<= att +char-attr-terminating-macro+) +char-attr-delimiter+)
+       ((< att +char-attr-constituent+) att)
+       (t (setf att (get-constituent-trait ,char))
+	  (when possibly-rational
+	    (setq possibly-rational
+		  (or (digit-char-p ,char *read-base*)
+		      (= att +char-attr-constituent-slash+))))
+	  (when possibly-float
+	    (setq possibly-float
+		  (or (digit-char-p ,char 10)
+		      (= att +char-attr-constituent-dot+))))
+	  (cond
+	    ((digit-char-p ,char (max *read-base* 10))
 	     (if (digit-char-p ,char *read-base*)
-		 constituent-digit
-		 constituent)
-	     att))))
+		 (if (= att +char-attr-constituent-expt+)
+		     +char-attr-constituent-digit-or-expt+
+		     +char-attr-constituent-digit+)
+		 +char-attr-constituent-decimal-digit+))
+	    ((= att +char-attr-invalid+)
+	     (%reader-error stream "invalid constituent"))
+	    (t att))))))
 
 ;;;; token fetching
 
 (defvar *read-suppress* nil
   #!+sb-doc
-  "Suppresses most interpreting of the reader when T")
+  "Suppress most interpreting in the reader when T.")
 
 (defvar *read-base* 10
   #!+sb-doc
-  "The radix that Lisp reads numbers in.")
+  "the radix that Lisp reads numbers in")
 (declaim (type (integer 2 36) *read-base*))
 
-;;; Modify the read buffer according to READTABLE-CASE, ignoring escapes.
-;;; ESCAPES is a list of the escaped indices, in reverse order.
+;;; Modify the read buffer according to READTABLE-CASE, ignoring
+;;; ESCAPES. ESCAPES is a list of the escaped indices, in reverse
+;;; order.
 (defun casify-read-buffer (escapes)
   (let ((case (readtable-case *readtable*)))
     (cond
@@ -669,7 +788,7 @@
 				  (declare (fixnum esc))
 				  (cond ((< esc i) t)
 					(t
-					 (assert (= esc i))
+					 (aver (= esc i))
 					 (pop escapes)
 					 nil))))
 			(let ((ch (schar *read-buffer* i)))
@@ -695,259 +814,316 @@
 (defun read-token (stream firstchar)
   #!+sb-doc
   "This function is just an fsm that recognizes numbers and symbols."
-  ;; Check explicitly whether firstchar has entry for non-terminating
-  ;; in character-attribute-table and read-dot-number-symbol in CMT.
-  ;; Report an error if these are violated (if we called this, we want
-  ;; something that is a legitimate token!).
-  ;; Read in the longest possible string satisfying the bnf for
-  ;; "unqualified-token". Leave the result in the *READ-BUFFER*.
-  ;; Return next char after token (last char read).
+  ;; Check explicitly whether FIRSTCHAR has an entry for
+  ;; NON-TERMINATING in CHARACTER-ATTRIBUTE-TABLE and
+  ;; READ-DOT-NUMBER-SYMBOL in CMT. Report an error if these are
+  ;; violated. (If we called this, we want something that is a
+  ;; legitimate token!) Read in the longest possible string satisfying
+  ;; the Backus-Naur form for "unqualified-token". Leave the result in
+  ;; the *READ-BUFFER*. Return next char after token (last char read).
   (when *read-suppress*
-    (internal-read-extended-token stream firstchar)
+    (internal-read-extended-token stream firstchar nil)
     (return-from read-token nil))
-  (let ((attribute-table (character-attribute-table *readtable*))
+  (let ((attribute-array (character-attribute-array *readtable*))
+        (attribute-hash-table (character-attribute-hash-table *readtable*))
 	(package-designator nil)
 	(colons 0)
 	(possibly-rational t)
+	(seen-digit-or-expt nil)
 	(possibly-float t)
-	(escapes ()))
+	(was-possibly-float nil)
+	(escapes ())
+	(seen-multiple-escapes nil))
     (reset-read-buffer)
     (prog ((char firstchar))
-      (case (char-class3 char attribute-table)
-	(#.constituent-sign (go SIGN))
-	(#.constituent-digit (go LEFTDIGIT))
-	(#.constituent-dot (go FRONTDOT))
-	(#.escape (go ESCAPE))
-	(#.package-delimiter (go COLON))
-	(#.multiple-escape (go MULT-ESCAPE))
-	;;can't have eof, whitespace, or terminating macro as first char!
+      (case (char-class3 char attribute-array attribute-hash-table)
+	(#.+char-attr-constituent-sign+ (go SIGN))
+	(#.+char-attr-constituent-digit+ (go LEFTDIGIT))
+	(#.+char-attr-constituent-digit-or-expt+
+	 (setq seen-digit-or-expt t)
+	 (go LEFTDIGIT))
+	(#.+char-attr-constituent-decimal-digit+ (go LEFTDECIMALDIGIT))
+	(#.+char-attr-constituent-dot+ (go FRONTDOT))
+	(#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
+	(#.+char-attr-package-delimiter+ (go COLON))
+	(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+	(#.+char-attr-invalid+ (%reader-error stream "invalid constituent"))
+	;; can't have eof, whitespace, or terminating macro as first char!
 	(t (go SYMBOL)))
-     SIGN
-      ;;saw "sign"
+     SIGN ; saw "sign"
       (ouch-read-buffer char)
       (setq char (read-char stream nil nil))
       (unless char (go RETURN-SYMBOL))
       (setq possibly-rational t
 	    possibly-float t)
-      (case (char-class3 char attribute-table)
-	(#.constituent-digit (go LEFTDIGIT))
-	(#.constituent-dot (go SIGNDOT))
-	(#.escape (go ESCAPE))
-	(#.package-delimiter (go COLON))
-	(#.multiple-escape (go MULT-ESCAPE))	
-	(#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
+      (case (char-class3 char attribute-array attribute-hash-table)
+	(#.+char-attr-constituent-digit+ (go LEFTDIGIT))
+	(#.+char-attr-constituent-digit-or-expt+
+	 (setq seen-digit-or-expt t)
+	 (go LEFTDIGIT))
+	(#.+char-attr-constituent-decimal-digit+ (go LEFTDECIMALDIGIT))
+	(#.+char-attr-constituent-dot+ (go SIGNDOT))
+	(#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
+	(#.+char-attr-package-delimiter+ (go COLON))
+	(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))	
+	(#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
 	(t (go SYMBOL)))
-     LEFTDIGIT
-      ;;saw "[sign] {digit}+"
+     LEFTDIGIT ; saw "[sign] {digit}+"
       (ouch-read-buffer char)
       (setq char (read-char stream nil nil))
       (unless char (return (make-integer)))
-      (case (char-class3 char attribute-table)
-	(#.constituent-digit (go LEFTDIGIT))
-	(#.constituent-dot (if possibly-float
-			       (go MIDDLEDOT)
-			       (go SYMBOL)))
-	(#.constituent-expt (go EXPONENT))
-	(#.constituent-slash (if possibly-rational
-				 (go RATIO)
-				 (go SYMBOL)))
-	(#.delimiter (unread-char char stream) (return (make-integer)))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter (go COLON))
+      (setq was-possibly-float possibly-float)
+      (case (char-class3 char attribute-array attribute-hash-table)
+	(#.+char-attr-constituent-digit+ (go LEFTDIGIT))
+	(#.+char-attr-constituent-decimal-digit+ (if possibly-float
+						     (go LEFTDECIMALDIGIT)
+						     (go SYMBOL)))
+	(#.+char-attr-constituent-dot+ (if possibly-float
+					   (go MIDDLEDOT)
+					   (go SYMBOL)))
+	(#.+char-attr-constituent-digit-or-expt+
+	 (if (or seen-digit-or-expt (not was-possibly-float))
+	     (progn (setq seen-digit-or-expt t) (go LEFTDIGIT))
+	     (progn (setq seen-digit-or-expt t) (go LEFTDIGIT-OR-EXPT))))
+	(#.+char-attr-constituent-expt+
+	 (if was-possibly-float
+	     (go EXPONENT)
+	     (go SYMBOL)))
+	(#.+char-attr-constituent-slash+ (if possibly-rational
+					     (go RATIO)
+					     (go SYMBOL)))
+	(#.+char-attr-delimiter+ (unread-char char stream)
+				 (return (make-integer)))
+	(#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
+	(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+	(#.+char-attr-package-delimiter+ (go COLON))
 	(t (go SYMBOL)))
-     MIDDLEDOT
-      ;;saw "[sign] {digit}+ dot"
+     LEFTDIGIT-OR-EXPT
+      (ouch-read-buffer char)
+      (setq char (read-char stream nil nil))
+      (unless char (return (make-integer)))
+      (case (char-class3 char attribute-array attribute-hash-table)
+	(#.+char-attr-constituent-digit+ (go LEFTDIGIT))
+	(#.+char-attr-constituent-decimal-digit+ (bug "impossible!"))
+	(#.+char-attr-constituent-dot+ (go SYMBOL))
+	(#.+char-attr-constituent-digit-or-expt+ (go LEFTDIGIT))
+	(#.+char-attr-constituent-expt+ (go SYMBOL))
+	(#.+char-attr-constituent-sign+ (go EXPTSIGN))
+	(#.+char-attr-constituent-slash+ (if possibly-rational
+					     (go RATIO)
+					     (go SYMBOL)))
+	(#.+char-attr-delimiter+ (unread-char char stream)
+				 (return (make-integer)))
+	(#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
+	(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+	(#.+char-attr-package-delimiter+ (go COLON))
+	(t (go SYMBOL)))
+     LEFTDECIMALDIGIT ; saw "[sign] {decimal-digit}+"
+      (aver possibly-float)
+      (ouch-read-buffer char)
+      (setq char (read-char stream nil nil))
+      (unless char (go RETURN-SYMBOL))
+      (case (char-class char attribute-array attribute-hash-table)
+	(#.+char-attr-constituent-digit+ (go LEFTDECIMALDIGIT))
+	(#.+char-attr-constituent-dot+ (go MIDDLEDOT))
+	(#.+char-attr-constituent-expt+ (go EXPONENT))
+	(#.+char-attr-constituent-slash+ (aver (not possibly-rational))
+					 (go SYMBOL))
+	(#.+char-attr-delimiter+ (unread-char char stream)
+				 (go RETURN-SYMBOL))
+	(#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
+	(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+	(#.+char-attr-package-delimiter+ (go COLON))
+	(t (go SYMBOL)))
+     MIDDLEDOT ; saw "[sign] {digit}+ dot"
       (ouch-read-buffer char)
       (setq char (read-char stream nil nil))
       (unless char (return (let ((*read-base* 10))
 			     (make-integer))))
-      (case (char-class char attribute-table)
-	(#.constituent-digit (go RIGHTDIGIT))
-	(#.constituent-expt (go EXPONENT))
-	(#.delimiter
+      (case (char-class char attribute-array attribute-hash-table)
+	(#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
+	(#.+char-attr-constituent-expt+ (go EXPONENT))
+	(#.+char-attr-delimiter+
 	 (unread-char char stream)
 	 (return (let ((*read-base* 10))
 		   (make-integer))))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter (go COLON))
+	(#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
+	(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+	(#.+char-attr-package-delimiter+ (go COLON))
 	(t (go SYMBOL)))
-     RIGHTDIGIT
-      ;;saw "[sign] {digit}* dot {digit}+"
+     RIGHTDIGIT ; saw "[sign] {decimal-digit}* dot {digit}+"
       (ouch-read-buffer char)
       (setq char (read-char stream nil nil))
-      (unless char (return (make-float)))
-      (case (char-class char attribute-table)
-	(#.constituent-digit (go RIGHTDIGIT))
-	(#.constituent-expt (go EXPONENT))
-	(#.delimiter (unread-char char stream) (return (make-float)))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter (go COLON))
+      (unless char (return (make-float stream)))
+      (case (char-class char attribute-array attribute-hash-table)
+	(#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
+	(#.+char-attr-constituent-expt+ (go EXPONENT))
+	(#.+char-attr-delimiter+
+	 (unread-char char stream)
+	 (return (make-float stream)))
+	(#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
+	(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+	(#.+char-attr-package-delimiter+ (go COLON))
 	(t (go SYMBOL)))
-     SIGNDOT
-      ;;saw "[sign] dot"
+     SIGNDOT ; saw "[sign] dot"
       (ouch-read-buffer char)
       (setq char (read-char stream nil nil))
       (unless char (go RETURN-SYMBOL))
-      (case (char-class char attribute-table)
-	(#.constituent-digit (go RIGHTDIGIT))
-	(#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
+      (case (char-class char attribute-array attribute-hash-table)
+	(#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
+	(#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
+	(#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
+	(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
 	(t (go SYMBOL)))
-     FRONTDOT
-      ;;saw "dot"
+     FRONTDOT ; saw "dot"
       (ouch-read-buffer char)
       (setq char (read-char stream nil nil))
       (unless char (%reader-error stream "dot context error"))
-      (case (char-class char attribute-table)
-	(#.constituent-digit (go RIGHTDIGIT))
-	(#.constituent-dot (go DOTS))
-	(#.delimiter  (%reader-error stream "dot context error"))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter (go COLON))
+      (case (char-class char attribute-array attribute-hash-table)
+	(#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
+	(#.+char-attr-constituent-dot+ (go DOTS))
+	(#.+char-attr-delimiter+  (%reader-error stream "dot context error"))
+	(#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
+	(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+	(#.+char-attr-package-delimiter+ (go COLON))
 	(t (go SYMBOL)))
      EXPONENT
       (ouch-read-buffer char)
       (setq char (read-char stream nil nil))
       (unless char (go RETURN-SYMBOL))
-      (case (char-class char attribute-table)
-	(#.constituent-sign (go EXPTSIGN))
-	(#.constituent-digit (go EXPTDIGIT))
-	(#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter (go COLON))
+      (setq possibly-float t)
+      (case (char-class char attribute-array attribute-hash-table)
+	(#.+char-attr-constituent-sign+ (go EXPTSIGN))
+	(#.+char-attr-constituent-digit+ (go EXPTDIGIT))
+	(#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
+	(#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
+	(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+	(#.+char-attr-package-delimiter+ (go COLON))
 	(t (go SYMBOL)))
-     EXPTSIGN
-      ;;we got to EXPONENT, and saw a sign character.
+     EXPTSIGN ; got to EXPONENT, and saw a sign character
       (ouch-read-buffer char)
       (setq char (read-char stream nil nil))
       (unless char (go RETURN-SYMBOL))
-      (case (char-class char attribute-table)
-	(#.constituent-digit (go EXPTDIGIT))
-	(#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter (go COLON))
+      (case (char-class char attribute-array attribute-hash-table)
+	(#.+char-attr-constituent-digit+ (go EXPTDIGIT))
+	(#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
+	(#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
+	(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+	(#.+char-attr-package-delimiter+ (go COLON))
 	(t (go SYMBOL)))
-     EXPTDIGIT
-      ;;got to EXPONENT, saw "[sign] {digit}+"
+     EXPTDIGIT ; got to EXPONENT, saw "[sign] {digit}+"
       (ouch-read-buffer char)
       (setq char (read-char stream nil nil))
-      (unless char (return (make-float)))
-      (case (char-class char attribute-table)
-	(#.constituent-digit (go EXPTDIGIT))
-	(#.delimiter (unread-char char stream) (return (make-float)))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter (go COLON))
+      (unless char (return (make-float stream)))
+      (case (char-class char attribute-array attribute-hash-table)
+	(#.+char-attr-constituent-digit+ (go EXPTDIGIT))
+	(#.+char-attr-delimiter+
+	 (unread-char char stream)
+	 (return (make-float stream)))
+	(#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
+	(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+	(#.+char-attr-package-delimiter+ (go COLON))
 	(t (go SYMBOL)))
-     RATIO
-      ;;saw "[sign] {digit}+ slash"
+     RATIO ; saw "[sign] {digit}+ slash"
       (ouch-read-buffer char)
       (setq char (read-char stream nil nil))
       (unless char (go RETURN-SYMBOL))
-      (case (char-class2 char attribute-table)
-	(#.constituent-digit (go RATIODIGIT))
-	(#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter (go COLON))
+      (case (char-class2 char attribute-array attribute-hash-table)
+	(#.+char-attr-constituent-digit+ (go RATIODIGIT))
+	(#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
+	(#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
+	(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+	(#.+char-attr-package-delimiter+ (go COLON))
 	(t (go SYMBOL)))
-     RATIODIGIT
-      ;;saw "[sign] {digit}+ slash {digit}+"
+     RATIODIGIT ; saw "[sign] {digit}+ slash {digit}+"
       (ouch-read-buffer char)
       (setq char (read-char stream nil nil))
-      (unless char (return (make-ratio)))
-      (case (char-class2 char attribute-table)
-	(#.constituent-digit (go RATIODIGIT))
-	(#.delimiter (unread-char char stream) (return (make-ratio)))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter (go COLON))
+      (unless char (return (make-ratio stream)))
+      (case (char-class2 char attribute-array attribute-hash-table)
+	(#.+char-attr-constituent-digit+ (go RATIODIGIT))
+	(#.+char-attr-delimiter+
+	 (unread-char char stream)
+	 (return (make-ratio stream)))
+	(#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
+	(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+	(#.+char-attr-package-delimiter+ (go COLON))
 	(t (go SYMBOL)))
-     DOTS
-      ;; saw "dot {dot}+"
+     DOTS ; saw "dot {dot}+"
       (ouch-read-buffer char)
       (setq char (read-char stream nil nil))
       (unless char (%reader-error stream "too many dots"))
-      (case (char-class char attribute-table)
-	(#.constituent-dot (go DOTS))
-	(#.delimiter
+      (case (char-class char attribute-array attribute-hash-table)
+	(#.+char-attr-constituent-dot+ (go DOTS))
+	(#.+char-attr-delimiter+
 	 (unread-char char stream)
 	 (%reader-error stream "too many dots"))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter (go COLON))
+	(#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
+	(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+	(#.+char-attr-package-delimiter+ (go COLON))
 	(t (go SYMBOL)))
-     SYMBOL
-      ;; not a dot, dots, or number
+     SYMBOL ; not a dot, dots, or number
       (let ((stream (in-synonym-of stream)))
-	(if (lisp-stream-p stream)
+	(if (ansi-stream-p stream)
 	    (prepare-for-fast-read-char stream
 	      (prog ()
 	       SYMBOL-LOOP
 	       (ouch-read-buffer char)
 	       (setq char (fast-read-char nil nil))
 	       (unless char (go RETURN-SYMBOL))
-	       (case (char-class char attribute-table)
-		 (#.escape (done-with-fast-read-char)
-			   (go ESCAPE))
-		 (#.delimiter (done-with-fast-read-char)
-			      (unread-char char stream)
-			      (go RETURN-SYMBOL))
-		 (#.multiple-escape (done-with-fast-read-char)
-				    (go MULT-ESCAPE))
-		 (#.package-delimiter (done-with-fast-read-char)
-				      (go COLON))
+	       (case (char-class char attribute-array attribute-hash-table)
+		 (#.+char-attr-single-escape+ (done-with-fast-read-char)
+					      (go SINGLE-ESCAPE))
+		 (#.+char-attr-delimiter+ (done-with-fast-read-char)
+					  (unread-char char stream)
+					  (go RETURN-SYMBOL))
+		 (#.+char-attr-multiple-escape+ (done-with-fast-read-char)
+						(go MULT-ESCAPE))
+		 (#.+char-attr-package-delimiter+ (done-with-fast-read-char)
+						  (go COLON))
 		 (t (go SYMBOL-LOOP)))))
-	    ;; fundamental-stream
+	    ;; CLOS stream
 	    (prog ()
 	     SYMBOL-LOOP
 	     (ouch-read-buffer char)
-	     (setq char (stream-read-char stream))
+	     (setq char (read-char stream nil :eof))
 	     (when (eq char :eof) (go RETURN-SYMBOL))
-	     (case (char-class char attribute-table)
-	       (#.escape (go ESCAPE))
-	       (#.delimiter (stream-unread-char stream char)
+	     (case (char-class char attribute-array attribute-hash-table)
+	       (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
+	       (#.+char-attr-delimiter+ (unread-char char stream)
 			    (go RETURN-SYMBOL))
-	       (#.multiple-escape (go MULT-ESCAPE))
-	       (#.package-delimiter (go COLON))
+	       (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+	       (#.+char-attr-package-delimiter+ (go COLON))
 	       (t (go SYMBOL-LOOP))))))
-     ESCAPE
-      ;;saw an escape.
-      ;;don't put the escape in the read buffer.
-      ;;read-next char, put in buffer (no case conversion).
+     SINGLE-ESCAPE ; saw a single-escape
+      ;; Don't put the escape character in the read buffer.
+      ;; READ-NEXT CHAR, put in buffer (no case conversion).
       (let ((nextchar (read-char stream nil nil)))
 	(unless nextchar
-	  (reader-eof-error stream "after escape character"))
+	  (reader-eof-error stream "after single-escape character"))
 	(push *ouch-ptr* escapes)
 	(ouch-read-buffer nextchar))
       (setq char (read-char stream nil nil))
       (unless char (go RETURN-SYMBOL))
-      (case (char-class char attribute-table)
-	(#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter (go COLON))
+      (case (char-class char attribute-array attribute-hash-table)
+	(#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
+	(#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
+	(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+	(#.+char-attr-package-delimiter+ (go COLON))
 	(t (go SYMBOL)))
       MULT-ESCAPE
+      (setq seen-multiple-escapes t)
       (do ((char (read-char stream t) (read-char stream t)))
 	  ((multiple-escape-p char))
-	(if (escapep char) (setq char (read-char stream t)))
+	(if (single-escape-p char) (setq char (read-char stream t)))
 	(push *ouch-ptr* escapes)
 	(ouch-read-buffer char))
       (setq char (read-char stream nil nil))
       (unless char (go RETURN-SYMBOL))
-      (case (char-class char attribute-table)
-	(#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter (go COLON))
+      (case (char-class char attribute-array attribute-hash-table)
+	(#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
+	(#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
+	(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+	(#.+char-attr-package-delimiter+ (go COLON))
 	(t (go SYMBOL)))
       COLON
       (casify-read-buffer escapes)
@@ -963,35 +1139,37 @@
 		;; a FIND-PACKAGE* function analogous to INTERN*
 		;; and friends?
 		(read-buffer-to-string)
-		*keyword-package*))
+		(if seen-multiple-escapes
+		    (read-buffer-to-string)
+		    *keyword-package*)))
       (reset-read-buffer)
       (setq escapes ())
       (setq char (read-char stream nil nil))
       (unless char (reader-eof-error stream "after reading a colon"))
-      (case (char-class char attribute-table)
-	(#.delimiter
+      (case (char-class char attribute-array attribute-hash-table)
+	(#.+char-attr-delimiter+
 	 (unread-char char stream)
 	 (%reader-error stream
 			"illegal terminating character after a colon: ~S"
 			char))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter (go INTERN))
+	(#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
+	(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+	(#.+char-attr-package-delimiter+ (go INTERN))
 	(t (go SYMBOL)))
       INTERN
       (setq colons 2)
       (setq char (read-char stream nil nil))
       (unless char
 	(reader-eof-error stream "after reading a colon"))
-      (case (char-class char attribute-table)
-	(#.delimiter
+      (case (char-class char attribute-array attribute-hash-table)
+	(#.+char-attr-delimiter+
 	 (unread-char char stream)
 	 (%reader-error stream
 			"illegal terminating character after a colon: ~S"
 			char))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter
+	(#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
+	(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+	(#.+char-attr-package-delimiter+
 	 (%reader-error stream
 			"too many colons after ~S name"
 			package-designator))
@@ -1000,7 +1178,7 @@
       (casify-read-buffer escapes)
       (let ((found (if package-designator
 		       (find-package package-designator)
-		       *package*)))
+		       (sane-package))))
 	(unless found
 	  (error 'reader-package-error :stream stream
 		 :format-arguments (list package-designator)
@@ -1021,26 +1199,40 @@
 			     "Symbol ~S not found in the ~A package.")))
 		(return (intern name found)))))))))
 
+;;; for semi-external use:
+;;;
+;;; For semi-external use: Return 3 values: the string for the token,
+;;; a flag for whether there was an escape char, and the position of
+;;; any package delimiter.
 (defun read-extended-token (stream &optional (*readtable* *readtable*))
-  #!+sb-doc
-  "For semi-external use: returns 3 values: the string for the token,
-   a flag for whether there was an escape char, and the position of any
-   package delimiter."
-  (let ((firstch (read-char stream nil nil t)))
-    (cond (firstch
+  (let ((first-char (read-char stream nil nil t)))
+    (cond (first-char
 	   (multiple-value-bind (escapes colon)
-	       (internal-read-extended-token stream firstch)
+               (internal-read-extended-token stream first-char nil)
 	     (casify-read-buffer escapes)
 	     (values (read-buffer-to-string) (not (null escapes)) colon)))
 	  (t
 	   (values "" nil nil)))))
+
+;;; for semi-external use:
+;;;
+;;; Read an extended token with the first character escaped. Return
+;;; the string for the token.
+(defun read-extended-token-escaped (stream &optional (*readtable* *readtable*))
+  (let ((first-char (read-char stream nil nil)))
+    (cond (first-char
+            (let ((escapes (internal-read-extended-token stream first-char t)))
+              (casify-read-buffer escapes)
+              (read-buffer-to-string)))
+          (t
+            (reader-eof-error stream "after escape")))))
 
 ;;;; number-reading functions
 
 (defmacro digit* nil
   `(do ((ch char (inch-read-buffer)))
        ((or (eofp ch) (not (digit-char-p ch))) (setq char ch))
-     ;;report if at least one digit is seen:
+     ;; Report if at least one digit is seen.
      (setq one-digit t)))
 
 (defmacro exponent-letterp (letter)
@@ -1113,7 +1305,7 @@
 				 (the index (* num base))))))))
        (setq number (+ num (* number base-power)))))))
 
-(defun make-float ()
+(defun make-float (stream)
   ;; Assume that the contents of *read-buffer* are a legal float, with nothing
   ;; else after it.
   (read-unwind-read-buffer)
@@ -1147,7 +1339,8 @@
     (cond ((eofp char)
 	   ;; If not, we've read the whole number.
 	   (let ((num (make-float-aux number divisor
-				      *read-default-float-format*)))
+				      *read-default-float-format*
+				      stream)))
 	     (return-from make-float (if negative-fraction (- num) num))))
 	  ((exponent-letterp char)
 	   (setq float-char char)
@@ -1165,56 +1358,29 @@
 		((not dig)
 		 (setq exponent (if negative-exponent (- exponent) exponent)))
 	     (setq exponent (+ (* exponent 10) dig)))
-	   ;; Generate and return the float, depending on float-char:
+	   ;; Generate and return the float, depending on FLOAT-CHAR:
 	   (let* ((float-format (case (char-upcase float-char)
 				  (#\E *read-default-float-format*)
 				  (#\S 'short-float)
 				  (#\F 'single-float)
 				  (#\D 'double-float)
 				  (#\L 'long-float)))
-		  num)
-	     ;; toy@rtp.ericsson.se: We need to watch out if the
-	     ;; exponent is too small or too large. We add enough to
-	     ;; EXPONENT to make it within range and scale NUMBER
-	     ;; appropriately. This should avoid any unnecessary
-	     ;; underflow or overflow problems.
-	     (multiple-value-bind (min-expo max-expo)
-		 (case float-format
-		   (short-float
-		    (values
-		     #.(log least-positive-normalized-short-float 10s0)
-		     #.(log most-positive-short-float 10s0)))
-		   (single-float
-		    (values
-		     #.(log least-positive-normalized-single-float 10f0)
-		     #.(log most-positive-single-float 10f0)))
-		   (double-float
-		    (values
-		     #.(log least-positive-normalized-double-float 10d0)
-		     #.(log most-positive-double-float 10d0)))
-		   (long-float
-		    (values
-		     #.(log least-positive-normalized-long-float 10L0)
-		     #.(log most-positive-long-float 10L0))))
-	       (let ((correction (cond ((<= exponent min-expo)
-					(ceiling (- min-expo exponent)))
-				       ((>= exponent max-expo)
-					(floor (- max-expo exponent)))
-				       (t
-					0))))
-		 (incf exponent correction)
-		 (setf number (/ number (expt 10 correction)))
-		 (setq num (make-float-aux number divisor float-format))
-		 (setq num (* num (expt 10 exponent)))
-		 (return-from make-float (if negative-fraction (- num) num))))))
-	  ;; should never happen:	
-	  (t (error "internal error in floating point reader")))))
-
-(defun make-float-aux (number divisor float-format)
-  (coerce (/ number divisor) float-format))
-
-(defun make-ratio ()
-  ;; Assume *read-buffer* contains a legal ratio. Build the number from
+		  (result (make-float-aux (* (expt 10 exponent) number)
+					  divisor float-format stream)))
+	     (return-from make-float
+	       (if negative-fraction (- result) result))))
+	  (t (bug "bad fallthrough in floating point reader")))))
+
+(defun make-float-aux (number divisor float-format stream)
+  (handler-case
+      (coerce (/ number divisor) float-format)
+    (type-error (c)
+      (error 'reader-impossible-number-error
+	     :error c :stream stream
+	     :format-control "failed to build float"))))
+
+(defun make-ratio (stream)
+  ;; Assume *READ-BUFFER* contains a legal ratio. Build the number from
   ;; the string.
   ;;
   ;; Look for optional "+" or "-".
@@ -1237,13 +1403,18 @@
 	  (dig ()))
 	 ((or (eofp ch) (not (setq dig (digit-char-p ch *read-base*)))))
 	 (setq denominator (+ (* denominator *read-base*) dig)))
-    (let ((num (/ numerator denominator)))
+    (let ((num (handler-case
+		   (/ numerator denominator)
+		 (arithmetic-error (c)
+		   (error 'reader-impossible-number-error
+			  :error c :stream stream
+			  :format-control "failed to build ratio")))))
       (if negative-number (- num) num))))
 
 ;;;; cruft for dispatch macros
 
 (defun make-char-dispatch-table ()
-  (make-array char-code-limit :initial-element #'dispatch-char-error))
+  (make-hash-table))
 
 (defun dispatch-char-error (stream sub-char ignore)
   (declare (ignore ignore))
@@ -1255,59 +1426,56 @@
 					   (non-terminating-p nil)
 					   (rt *readtable*))
   #!+sb-doc
-  "Causes char to become a dispatching macro character in readtable
-   (which defaults to the current readtable). If the non-terminating-p
-   flag is set to T, the char will be non-terminating. Make-dispatch-
-   macro-character returns T."
+  "Cause CHAR to become a dispatching macro character in readtable (which
+   defaults to the current readtable). If NON-TERMINATING-P, the char will
+   be non-terminating."
   (set-macro-character char #'read-dispatch-char non-terminating-p rt)
   (let* ((dalist (dispatch-tables rt))
 	 (dtable (cdr (find char dalist :test #'char= :key #'car))))
     (cond (dtable
-	   (error "Dispatch character already exists."))
+	   (error "The dispatch character ~S already exists." char))
 	  (t
 	   (setf (dispatch-tables rt)
-		 (push (cons char (make-char-dispatch-table)) dalist))))))
+		 (push (cons char (make-char-dispatch-table)) dalist)))))
+  t)
 
-(defun set-dispatch-macro-character
-       (disp-char sub-char function &optional (rt *readtable*))
+(defun set-dispatch-macro-character (disp-char sub-char function
+                                               &optional (rt *readtable*))
   #!+sb-doc
-  "Causes function to be called whenever the reader reads
-   disp-char followed by sub-char. Set-dispatch-macro-character
-   returns T."
+  "Cause FUNCTION to be called whenever the reader reads DISP-CHAR
+   followed by SUB-CHAR."
   ;; Get the dispatch char for macro (error if not there), diddle
   ;; entry for sub-char.
   (when (digit-char-p sub-char)
     (error "SUB-CHAR must not be a decimal digit: ~S" sub-char))
   (let* ((sub-char (char-upcase sub-char))
+         (rt (or rt *standard-readtable*))
 	 (dpair (find disp-char (dispatch-tables rt)
 		      :test #'char= :key #'car)))
     (if dpair
-	(setf (elt (the simple-vector (cdr dpair))
-		   (char-code sub-char))
-	      (coerce function 'function))
+	(setf (gethash sub-char (cdr dpair)) (coerce function 'function))
 	(error "~S is not a dispatch char." disp-char))))
 
-(defun get-dispatch-macro-character (disp-char sub-char &optional rt)
+(defun get-dispatch-macro-character (disp-char sub-char
+                                     &optional (rt *readtable*))
   #!+sb-doc
-  "Returns the macro character function for sub-char under disp-char
-   or nil if there is no associated function."
-  (unless (digit-char-p sub-char)
-    (let* ((sub-char (char-upcase sub-char))
-	   (rt (or rt *readtable*))
-	   (dpair (find disp-char (dispatch-tables rt)
-			:test #'char= :key #'car)))
-      (if dpair
-	  (elt (the simple-vector (cdr dpair))
-	       (char-code sub-char))
-	  (error "~S is not a dispatch char." disp-char)))))
+  "Return the macro character function for SUB-CHAR under DISP-CHAR
+   or NIL if there is no associated function."
+  (let* ((sub-char (char-upcase sub-char))
+         (rt (or rt *standard-readtable*))
+         (dpair (find disp-char (dispatch-tables rt)
+                      :test #'char= :key #'car)))
+    (if dpair
+        (values (gethash sub-char (cdr dpair)))
+        (error "~S is not a dispatch char." disp-char))))
 
 (defun read-dispatch-char (stream char)
   ;; Read some digits.
   (let ((numargp nil)
 	(numarg 0)
 	(sub-char ()))
-    (do* ((ch (read-char stream nil eof-object)
-	      (read-char stream nil eof-object))
+    (do* ((ch (read-char stream nil *eof-object*)
+	      (read-char stream nil *eof-object*))
 	  (dig ()))
 	 ((or (eofp ch)
 	      (not (setq dig (digit-char-p ch))))
@@ -1322,19 +1490,13 @@
 		       :test #'char= :key #'car)))
       (if dpair
 	  (funcall (the function
-			(elt (the simple-vector (cdr dpair))
-			     (char-code sub-char)))
+                     (gethash sub-char (cdr dpair) #'dispatch-char-error))
 		   stream sub-char (if numargp numarg nil))
 	  (%reader-error stream "no dispatch table for dispatch char")))))
 
 ;;;; READ-FROM-STRING
 
-;;; FIXME: Is it really worth keeping this pool?
-(defvar *read-from-string-spares* ()
-  #!+sb-doc
-  "A resource of string streams for Read-From-String.")
-
-(defun read-from-string (string &optional eof-error-p eof-value
+(defun read-from-string (string &optional (eof-error-p t) eof-value
 				&key (start 0) end
 				preserve-whitespace)
   #!+sb-doc
@@ -1342,22 +1504,14 @@
    and the lisp object built by the reader is returned. Macro chars
    will take effect."
   (declare (string string))
-  (with-array-data ((string string)
+  (with-array-data ((string string :offset-var offset)
 		    (start start)
-		    (end (or end (length string))))
-    (unless *read-from-string-spares*
-      (push (internal-make-string-input-stream "" 0 0)
-	    *read-from-string-spares*))
-    (let ((stream (pop *read-from-string-spares*)))
-      (setf (string-input-stream-string stream) string)
-      (setf (string-input-stream-current stream) start)
-      (setf (string-input-stream-end stream) end)
-      (unwind-protect
-	  (values (if preserve-whitespace
-		      (read-preserving-whitespace stream eof-error-p eof-value)
-		      (read stream eof-error-p eof-value))
-		  (string-input-stream-current stream))
-	(push stream *read-from-string-spares*)))))
+		    (end (%check-vector-sequence-bounds string start end)))
+    (let ((stream (make-string-input-stream string start end)))
+      (values (if preserve-whitespace
+                  (read-preserving-whitespace stream eof-error-p eof-value)
+                  (read stream eof-error-p eof-value))
+              (- (string-input-stream-current stream) offset)))))
 
 ;;;; PARSE-INTEGER
 
@@ -1367,57 +1521,60 @@
   (default to the beginning and end of the string)  It skips over
   whitespace characters and then tries to parse an integer. The
   radix parameter must be between 2 and 36."
-  (with-array-data ((string string)
-		    (start start)
-		    (end (or end (length string))))
-    (let ((index (do ((i start (1+ i)))
-		     ((= i end)
-		      (if junk-allowed
-			  (return-from parse-integer (values nil end))
-			  (error "no non-whitespace characters in number")))
-		   (declare (fixnum i))
-		   (unless (whitespacep (char string i)) (return i))))
-	  (minusp nil)
-	  (found-digit nil)
-	  (result 0))
-      (declare (fixnum index))
-      (let ((char (char string index)))
-	(cond ((char= char #\-)
-	       (setq minusp t)
-	       (incf index))
-	      ((char= char #\+)
-	       (incf index))))
-      (loop
-	(when (= index end) (return nil))
-	(let* ((char (char string index))
-	       (weight (digit-char-p char radix)))
-	  (cond (weight
-		 (setq result (+ weight (* result radix))
-		       found-digit t))
-		(junk-allowed (return nil))
-		((whitespacep char)
-		 (do ((jndex (1+ index) (1+ jndex)))
-		     ((= jndex end))
-		   (declare (fixnum jndex))
-		   (unless (whitespacep (char string jndex))
-		     (error "junk in string ~S" string)))
-		 (return nil))
-		(t
-		 (error "junk in string ~S" string))))
-	(incf index))
-      (values
-       (if found-digit
-	   (if minusp (- result) result)
-	   (if junk-allowed
-	       nil
-	       (error "no digits in string ~S" string)))
-       index))))
+  (macrolet ((parse-error (format-control)
+	       `(error 'simple-parse-error
+		       :format-control ,format-control
+		       :format-arguments (list string))))
+    (with-array-data ((string string :offset-var offset)
+		      (start start)
+		      (end (%check-vector-sequence-bounds string start end)))
+      (let ((index (do ((i start (1+ i)))
+		       ((= i end)
+			(if junk-allowed
+			    (return-from parse-integer (values nil end))
+			    (parse-error "no non-whitespace characters in string ~S.")))
+		     (declare (fixnum i))
+		     (unless (whitespacep (char string i)) (return i))))
+	    (minusp nil)
+	    (found-digit nil)
+	    (result 0))
+	(declare (fixnum index))
+	(let ((char (char string index)))
+	  (cond ((char= char #\-)
+		 (setq minusp t)
+		 (incf index))
+		((char= char #\+)
+		 (incf index))))
+	(loop
+	 (when (= index end) (return nil))
+	 (let* ((char (char string index))
+		(weight (digit-char-p char radix)))
+	   (cond (weight
+		  (setq result (+ weight (* result radix))
+			found-digit t))
+		 (junk-allowed (return nil))
+		 ((whitespacep char)
+                  (loop
+                   (incf index)
+                   (when (= index end) (return))
+                   (unless (whitespacep (char string index))
+		      (parse-error "junk in string ~S")))
+		  (return nil))
+		 (t
+		  (parse-error "junk in string ~S"))))
+	 (incf index))
+	(values
+	 (if found-digit
+	     (if minusp (- result) result)
+	     (if junk-allowed
+		 nil
+		 (parse-error "no digits in string ~S")))
+	 (- index offset))))))
 
 ;;;; reader initialization code
 
 (defun !reader-cold-init ()
-  (!cold-init-read-buffer)
-  (!cold-init-secondary-attribute-table)
+  (!cold-init-constituent-trait-table)
   (!cold-init-standard-readtable)
   ;; FIXME: This was commented out, but should probably be restored.
   #+nil (!cold-init-integer-reader))