(in-package "SB!IMPL")
\f
-;;; 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*))
:format-control control
:format-arguments args))
\f
-;;;; constants for character attributes. These are all as in the manual.
-
-(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)
-\f
;;;; 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*
#!-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))
+ `(>= (get-cat-entry ,char ,rt) +char-attr-constituent+))
(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))
+ `(test-attribute ,char +char-attr-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+))
\f
;;;; secondary attribute table
-;;; There are a number of "secondary" attributes which are constant properties
-;;; of characters (as long as they are constituents).
+;;; 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 !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)
+ (make-array base-char-code-limit :element-type '(unsigned-byte 8)
+ :initial-element +char-attr-constituent+))
+ (!set-secondary-attribute #\: +char-attr-package-delimiter+)
+ (!set-secondary-attribute #\| +char-attr-multiple-escape+) ; |) [for EMACS]
+ (!set-secondary-attribute #\. +char-attr-constituent-dot+)
+ (!set-secondary-attribute #\+ +char-attr-constituent-sign+)
+ (!set-secondary-attribute #\- +char-attr-constituent-sign+)
+ (!set-secondary-attribute #\/ +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))
+ (!set-secondary-attribute (code-char i) +char-attr-constituent-digit+))
+ (!set-secondary-attribute #\E +char-attr-constituent-expt+)
+ (!set-secondary-attribute #\F +char-attr-constituent-expt+)
+ (!set-secondary-attribute #\D +char-attr-constituent-expt+)
+ (!set-secondary-attribute #\S +char-attr-constituent-expt+)
+ (!set-secondary-attribute #\L +char-attr-constituent-expt+)
+ (!set-secondary-attribute #\e +char-attr-constituent-expt+)
+ (!set-secondary-attribute #\f +char-attr-constituent-expt+)
+ (!set-secondary-attribute #\d +char-attr-constituent-expt+)
+ (!set-secondary-attribute #\s +char-attr-constituent-expt+)
+ (!set-secondary-attribute #\l +char-attr-constituent-expt+))
(defmacro get-secondary-attribute (char)
`(elt *secondary-attribute-table*
\f
;;;; 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*)
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
+ ;; 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)))
(setq att (get-secondary-attribute to-char)))
(set-cat-entry to-char att to-readtable)
(set-cmt-entry to-char
- (get-cmt-entry from-char really-from-readtable)
+ (get-raw-cmt-entry from-char really-from-readtable)
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
+ (get-secondary-attribute char)
+ +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))))
\f
;;;; definitions to support internal programming conventions
-(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))))))
(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 #\linefeed)
+ (whitespaceify #\space)
+ (whitespaceify (code-char form-feed-char-code))
+ (whitespaceify (code-char return-char-code)))
+
+ (set-cat-entry #\\ +char-attr-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-cat-entry char (get-secondary-attribute char))
+ (set-cmt-entry char nil)))))
\f
;;;; 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)))
+ ;; *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)))
(defun !cold-init-read-buffer ()
(setq *read-buffer* (make-string 512)) ; initial bufsize
(reset-read-buffer))
;;; 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
(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
- ;; 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-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)))))))))
+ (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."
+ "Read Lisp values from INPUT-STREAM until the next character after a
+ value's representation is ENDCHAR, and return the objects as a list."
(declare (ignore recursive-p))
(do ((char (flush-whitespace input-stream)
(flush-whitespace input-stream))
(retlist ()))
- ((char= char endchar) (nreverse retlist))
+ ((char= char endchar) (unless *read-suppress* (nreverse retlist)))
(setq retlist (nconc (read-maybe-nothing input-stream char) retlist))))
\f
;;;; 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))
(defun read-comment (stream ignore)
(declare (ignore ignore))
(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 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)))
+ ;; 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))
;; 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)))
(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))
+ (setq char (read-char stream nil :eof))
(if (eq char :eof)
(error 'end-of-file :stream stream)))
(ouch-read-buffer char))))
(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)
+ (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*))
- (escapes ())
(colon nil))
((cond ((eofp char) t)
((token-delimiterp char)
(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*)))
(cond
((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))))
+ (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-secondary-attribute char)
+ +char-attr-package-delimiter+)
(not colon))
(setq colon *ouch-ptr*))
- (ouch-read-buffer char)))))
+ (ouch-read-buffer char))))))
\f
;;;; 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
+ (if (<= att +char-attr-terminating-macro+)
+ +char-attr-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))))
+;;; 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 (<= att +char-attr-terminating-macro+)
+ +char-attr-delimiter+
(if (digit-char-p ,char *read-base*)
- constituent-digit
- (if (= att constituent-digit)
- constituent
+ +char-attr-constituent-digit+
+ (if (= att +char-attr-constituent-digit+)
+ +char-attr-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))))
+;;; 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))))
+ (= att +char-attr-constituent-slash+))))
(if possibly-float
(setq possibly-float
(or (digit-char-p ,char 10)
- (= att constituent-dot))))
- (if (<= att #.terminating-macro)
- #.delimiter
+ (= att +char-attr-constituent-dot+))))
+ (if (<= att +char-attr-terminating-macro+)
+ +char-attr-delimiter+
(if (digit-char-p ,char (max *read-base* 10))
(if (digit-char-p ,char *read-base*)
- constituent-digit
- constituent)
+ (if (= att +char-attr-constituent-expt+)
+ +char-attr-constituent-digit-or-expt+
+ +char-attr-constituent-digit+)
+ +char-attr-constituent-decimal-digit+)
att))))
\f
;;;; 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
(declare (fixnum esc))
(cond ((< esc i) t)
(t
- (assert (= esc i))
+ (aver (= esc i))
(pop escapes)
nil))))
(let ((ch (schar *read-buffer* i)))
(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-escape+ (go ESCAPE))
+ (#.+char-attr-package-delimiter+ (go COLON))
+ (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+ ;; 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-escape+ (go 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}+"
+ (ouch-read-buffer char)
+ (setq char (read-char stream nil nil))
+ (unless char (return (make-integer)))
+ (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-escape+ (go ESCAPE))
+ (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+ (#.+char-attr-package-delimiter+ (go COLON))
(t (go SYMBOL)))
- LEFTDIGIT
- ;;saw "[sign] {digit}+"
+ LEFTDIGIT-OR-EXPT
(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))
+ (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-escape+ (go 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-escape+ (go ESCAPE))
+ (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+ (#.+char-attr-package-delimiter+ (go COLON))
(t (go SYMBOL)))
- MIDDLEDOT
- ;;saw "[sign] {digit}+ dot"
+ 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-escape+ (go 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-escape+ (go 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-escape+ (go 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-escape+ (go 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-escape+ (go 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-escape+ (go 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-escape+ (go 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-escape+ (go 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-escape+ (go 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-escape+ (go 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-escape+ (done-with-fast-read-char)
+ (go 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-escape+ (go 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).
+ ESCAPE ; saw an escape
+ ;; Don't put the escape 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"))
(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-escape+ (go 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)))
(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-escape+ (go ESCAPE))
+ (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+ (#.+char-attr-package-delimiter+ (go COLON))
(t (go SYMBOL)))
COLON
(casify-read-buffer escapes)
;; 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-escape+ (go 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-escape+ (go ESCAPE))
+ (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+ (#.+char-attr-package-delimiter+
(%reader-error stream
"too many colons after ~S name"
package-designator))
(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)
"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")))))
\f
;;;; 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)
(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)
(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)
((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 "-".
(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))))
\f
;;;; 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))
(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.
: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")))))
\f
#!+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
and the lisp object built by the reader is returned. Macro chars
will take effect."
(declare (string string))
+
(with-array-data ((string string)
(start start)
- (end (or end (length string))))
+ (end (%check-vector-sequence-bounds string start end)))
(unless *read-from-string-spares*
- (push (internal-make-string-input-stream "" 0 0)
- *read-from-string-spares*))
+ (push (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-string stream)
+ (coerce string '(simple-array character (*))))
(setf (string-input-stream-current stream) start)
(setf (string-input-stream-end stream) end)
(unwind-protect
(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))))))
\f
;;;; reader initialization code