(declaim (type readtable *readtable*))
#!+sb-doc
(setf (fdocumentation '*readtable* 'variable)
- "Variable bound to current readtable.")
+ "Variable bound to current readtable.")
-;;; a standard Lisp readtable. This is for recovery from broken
-;;; read-tables (and for WITH-STANDARD-IO-SYNTAX), and should not
-;;; normally be user-visible.
-(defvar *standard-readtable*)
+;;; A standard Lisp readtable (once cold-init is through). This is for
+;;; recovery from broken read-tables (and for
+;;; WITH-STANDARD-IO-SYNTAX), and should not normally be user-visible.
+(defvar *standard-readtable* nil)
(defvar *old-package* nil
#!+sb-doc
:stream stream
:context context))
-(defun %reader-error (stream control &rest args)
- (error 'reader-error
+;;; If The Gods didn't intend for us to use multiple namespaces, why
+;;; did They specify them?
+(defun simple-reader-error (stream control &rest args)
+ (error 'simple-reader-error
:stream stream
:format-control control
:format-arguments args))
\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
- `(if (typep ,char 'base-char)
- (elt (character-attribute-array ,rt) (char-code ,char))
- (gethash ,char (character-attribute-hash-table ,rt)
- +char-attr-constituent+)))
+(defun get-cat-entry (char rt)
+ (declare (readtable rt))
+ (if (typep char 'base-char)
+ (elt (character-attribute-array rt) (char-code char))
+ (values (gethash char (character-attribute-hash-table rt)
+ +char-attr-constituent+))))
(defun set-cat-entry (char newvalue &optional (rt *readtable*))
+ (declare (readtable rt))
(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)))
+ (if (= newvalue +char-attr-constituent+)
+ ;; Default value for the C-A-HASH-TABLE is +CHAR-ATTR-CONSTITUENT+.
+ (%remhash char (character-attribute-hash-table rt))
+ (setf (gethash char (character-attribute-hash-table rt)) newvalue)))
+ (values))
;;; 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))))
+(defun get-raw-cmt-entry (char readtable)
+ (declare (readtable 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.
+ (values (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,
#'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)))))
+ (let ((new (when new-value-designator
+ (%coerce-callable-to-fun new-value-designator))))
+ (if (typep char 'base-char)
+ (setf (svref (character-macro-array rt) (char-code char)) new)
+ (setf (gethash char (character-macro-hash-table rt)) new))))
(defun undefined-macro-char (stream char)
(unless *read-suppress*
- (%reader-error stream "undefined read-macro character ~S" char)))
+ (simple-reader-error stream "undefined read-macro character ~S" char)))
;;; The character attribute table is a CHAR-CODE-LIMIT vector of integers.
;;; predicates for testing character attributes
+#!-sb-fluid
+(progn
+ (declaim (inline whitespace[1]p whitespace[2]p))
+ (declaim (inline constituentp terminating-macrop))
+ (declaim (inline single-escape-p multiple-escape-p))
+ (declaim (inline token-delimiterp)))
+
;;; the [1] and [2] here refer to ANSI glossary entries for
;;; "whitespace".
-#!-sb-fluid (declaim (inline whitespace[1]p whitespace[2]p))
(defun whitespace[1]p (char)
(test-attribute char +char-attr-whitespace+ *standard-readtable*))
(defun whitespace[2]p (char &optional (rt *readtable*))
(test-attribute char +char-attr-whitespace+ rt))
-(defmacro constituentp (char &optional (rt '*readtable*))
- `(test-attribute ,char +char-attr-constituent+ ,rt))
+(defun constituentp (char &optional (rt *readtable*))
+ (test-attribute char +char-attr-constituent+ rt))
-(defmacro terminating-macrop (char &optional (rt '*readtable*))
- `(test-attribute ,char +char-attr-terminating-macro+ ,rt))
+(defun terminating-macrop (char &optional (rt *readtable*))
+ (test-attribute char +char-attr-terminating-macro+ rt))
-(defmacro single-escape-p (char &optional (rt '*readtable*))
- `(test-attribute ,char +char-attr-single-escape+ ,rt))
+(defun 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 +char-attr-multiple-escape+ ,rt))
+(defun multiple-escape-p (char &optional (rt *readtable*))
+ (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) +char-attr-terminating-macro+))
+(defun token-delimiterp (char &optional (rt *readtable*))
+ ;; depends on actual attribute numbering in readtable.lisp.
+ (<= (get-cat-entry char rt) +char-attr-terminating-macro+))
\f
;;;; constituent traits (see ANSI 2.1.4.2)
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+))
+(declaim (inline get-constituent-trait))
+(defun get-constituent-trait (char)
+ (if (typep char 'base-char)
+ (elt *constituent-trait-table* (char-code char))
+ +char-attr-constituent+))
\f
-;;;; readtable operations
+;;;; Readtable Operations
+
+(defun assert-not-standard-readtable (readtable operation)
+ (when (eq readtable *standard-readtable*)
+ (cerror "Frob it anyway!" 'standard-readtable-modified-error
+ :operation operation)))
+
+(defun readtable-case (readtable)
+ (%readtable-case readtable))
+
+(defun (setf readtable-case) (case readtable)
+ (assert-not-standard-readtable readtable '(setf readtable-case))
+ (setf (%readtable-case readtable) case))
(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)
+(defun copy-readtable (&optional (from-readtable *readtable*) to-readtable)
+ (assert-not-standard-readtable to-readtable 'copy-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)
really-to-readtable))
(defun set-syntax-from-char (to-char from-char &optional
- (to-readtable *readtable*) (from-readtable ()))
+ (to-readtable *readtable*) (from-readtable nil))
#!+sb-doc
"Causes the syntax of TO-CHAR to be the same as FROM-CHAR in the optional
readtable (defaults to the current readtable). The FROM-TABLE defaults to the
standard Lisp readtable when NIL."
+ (assert-not-standard-readtable to-readtable 'set-syntax-from-char)
(let ((really-from-readtable (or from-readtable *standard-readtable*)))
(let ((att (get-cat-entry from-char really-from-readtable))
(mac (get-raw-cmt-entry from-char really-from-readtable))
:test #'char= :key #'car)))
(set-cat-entry to-char att 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))
+ (cond ((and (not from-dpair) (not to-dpair)))
+ ((and (not from-dpair) to-dpair)
(setf (dispatch-tables to-readtable)
- (push pair (dispatch-tables to-readtable)))))))))
+ (remove to-dpair (dispatch-tables to-readtable))))
+ (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)
- (readtable *readtable*))
+ (rt-designator *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, i.e. embeddable in a symbol name."
- (let ((designated-readtable (or readtable *standard-readtable*)))
+ (let ((designated-readtable (or rt-designator *standard-readtable*))
+ (function (%coerce-callable-to-fun function)))
+ (assert-not-standard-readtable designated-readtable 'set-macro-character)
(set-cat-entry char (if non-terminatingp
+char-attr-constituent+
+char-attr-terminating-macro+)
(set-cmt-entry char function designated-readtable)
t)) ; (ANSI-specified return value)
-(defun get-macro-character (char &optional (readtable *readtable*))
+(defun get-macro-character (char &optional (rt-designator *readtable*))
#!+sb-doc
"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*))
+ (let* ((designated-readtable (or rt-designator *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)))
+ (or (constituentp char designated-readtable)
+ (not (terminating-macrop char designated-readtable)))
;; 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))))
+
+
+(defun make-char-dispatch-table ()
+ (make-hash-table))
+
+(defun make-dispatch-macro-character (char &optional
+ (non-terminating-p nil)
+ (rt *readtable*))
+ #!+sb-doc
+ "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."
+ ;; Checks already for standard readtable modification.
+ (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 "The dispatch character ~S already exists." char))
+ (t
+ (setf (dispatch-tables rt)
+ (push (cons char (make-char-dispatch-table)) dalist)))))
+ t)
+
+(defun set-dispatch-macro-character (disp-char sub-char function
+ &optional (rt-designator *readtable*))
+ #!+sb-doc
+ "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.
+ (let* ((sub-char (char-upcase sub-char))
+ (readtable (or rt-designator *standard-readtable*)))
+ (assert-not-standard-readtable readtable 'set-dispatch-macro-character)
+ (when (digit-char-p sub-char)
+ (error "SUB-CHAR must not be a decimal digit: ~S" sub-char))
+ (let ((dpair (find disp-char (dispatch-tables readtable)
+ :test #'char= :key #'car)))
+ (if dpair
+ (setf (gethash sub-char (cdr dpair)) (coerce function 'function))
+ (error "~S is not a dispatch char." disp-char))))
+ t)
+
+(defun get-dispatch-macro-character (disp-char sub-char
+ &optional (rt-designator *readtable*))
+ #!+sb-doc
+ "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))
+ (readtable (or rt-designator *standard-readtable*))
+ (dpair (find disp-char (dispatch-tables readtable)
+ :test #'char= :key #'car)))
+ (if dpair
+ (values (gethash sub-char (cdr dpair)))
+ (error "~S is not a dispatch char." disp-char))))
+
\f
;;;; definitions to support internal programming conventions
-(defmacro eofp (char)
- `(eq ,char *eof-object*))
+(declaim (inline eofp))
+(defun eofp (char)
+ (eq char *eof-object*))
(defun flush-whitespace (stream)
;; This flushes whitespace chars, returning the last char it read (a
\f
;;;; temporary initialization hack
+;; Install the (easy) standard macro-chars into *READTABLE*.
(defun !cold-init-standard-readtable ()
- (setq *standard-readtable* (make-readtable))
+ (/show0 "entering !cold-init-standard-readtable")
;; 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*))
-
- (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)
- (set-macro-character #\' #'read-quote)
- (set-macro-character #\( #'read-list)
- (set-macro-character #\) #'read-right-paren)
- (set-macro-character #\; #'read-comment)
- ;; (The hairier macro-character definitions, for #\# and #\`, are
- ;; defined elsewhere, in their own source files.)
-
- ;; all constituents
- (do ((ichar 0 (1+ ichar))
- (char))
- ((= ichar base-char-code-limit))
- (setq char (code-char ichar))
- (when (constituentp char *standard-readtable*)
- (set-cmt-entry char nil)))))
+ (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)
+ (set-macro-character #\' #'read-quote)
+ (set-macro-character #\( #'read-list)
+ (set-macro-character #\) #'read-right-paren)
+ (set-macro-character #\; #'read-comment)
+ ;; (The hairier macro-character definitions, for #\# and #\`, are
+ ;; defined elsewhere, in their own source files.)
+
+ ;; all constituents
+ (do ((ichar 0 (1+ ichar))
+ (char))
+ ((= ichar base-char-code-limit))
+ (setq char (code-char ichar))
+ (when (constituentp char)
+ (set-cmt-entry char nil)))
+
+ (/show0 "leaving !cold-init-standard-readtable"))
\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*)?
-(defvar *inch-ptr*)
-(defvar *ouch-ptr*)
+(defvar *inch-ptr*) ; *OUCH-PTR* always points to next char to write.
+(defvar *ouch-ptr*) ; *INCH-PTR* always points to next char to read.
-(declaim (type index *read-buffer-length* *inch-ptr* *ouch-ptr*))
+(declaim (type index *inch-ptr* *ouch-ptr*))
(declaim (type (simple-array character (*)) *read-buffer*))
-(defmacro reset-read-buffer ()
+(declaim (inline reset-read-buffer))
+(defun reset-read-buffer ()
;; Turn *READ-BUFFER* into an empty read buffer.
- `(progn
- ;; *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.
-
-(defmacro ouch-read-buffer (char)
- `(progn
- ;; When buffer overflow
- (when (>= *ouch-ptr* *read-buffer-length*)
- ;; Size should be doubled.
- (grow-read-buffer))
- (setf (elt (the simple-string *read-buffer*) *ouch-ptr*) ,char)
- (setq *ouch-ptr* (1+ *ouch-ptr*))))
-
-;;; macro to move *ouch-ptr* back one.
-(defmacro ouch-unread-buffer ()
- '(when (> *ouch-ptr* *inch-ptr*)
- (setq *ouch-ptr* (1- (the fixnum *ouch-ptr*)))))
+ (setq *ouch-ptr* 0)
+ (setq *inch-ptr* 0))
+
+(declaim (inline ouch-read-buffer))
+(defun ouch-read-buffer (char)
+ ;; When buffer overflow
+ (let ((op *ouch-ptr*))
+ (declare (optimize (sb!c::insert-array-bounds-checks 0)))
+ (when (>= op (length *read-buffer*))
+ ;; Size should be doubled.
+ (grow-read-buffer))
+ (setf (elt *read-buffer* op) char)
+ (setq *ouch-ptr* (1+ op))))
(defun grow-read-buffer ()
- (let ((rbl (length (the simple-string *read-buffer*))))
- (setq *read-buffer*
- (concatenate 'simple-string
- *read-buffer*
- (make-string rbl)))
- (setq *read-buffer-length* (* 2 rbl))))
-
-(defun inchpeek-read-buffer ()
- (if (>= (the fixnum *inch-ptr*) (the fixnum *ouch-ptr*))
- *eof-object*
- (elt *read-buffer* *inch-ptr*)))
+ (let* ((rbl (length *read-buffer*))
+ (new-length (* 2 rbl))
+ (new-buffer (make-string new-length)))
+ (setq *read-buffer* (replace new-buffer *read-buffer*))))
(defun inch-read-buffer ()
(if (>= *inch-ptr* *ouch-ptr*)
(elt *read-buffer* *inch-ptr*)
(incf *inch-ptr*))))
-(defmacro unread-buffer ()
- `(decf *inch-ptr*))
+(declaim (inline unread-buffer))
+(defun unread-buffer ()
+ (decf *inch-ptr*))
+(declaim (inline read-unwind-read-buffer))
(defun read-unwind-read-buffer ()
;; Keep contents, but make next (INCH..) return first character.
(setq *inch-ptr* 0))
(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)))
+(defmacro with-read-buffer (() &body body)
+ `(let* ((*read-buffer* (make-string 128))
+ (*ouch-ptr* 0)
+ (*inch-ptr* 0))
+ ,@body))
+
+(declaim (inline read-buffer-boundp))
+(defun read-buffer-boundp ()
+ (and (boundp '*read-buffer*)
+ (boundp '*ouch-ptr*)
+ (boundp '*inch-ptr*)))
+
+(defun check-for-recursive-read (stream recursive-p operator-name)
+ (when (and recursive-p (not (read-buffer-boundp)))
+ (simple-reader-error
+ stream
+ "~A was invoked with RECURSIVE-P being true outside ~
+ of a recursive read operation."
+ `(,operator-name))))
\f
;;;; READ-PRESERVING-WHITESPACE, READ-DELIMITED-LIST, and READ
(declaim (special *standard-input*))
-;;; 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
- "Read from STREAM and return the value read, preserving any whitespace
- that followed the object."
- (if recursivep
+;;; Like READ-PRESERVING-WHITESPACE, but doesn't check the read buffer
+;;; for being set up properly.
+(defun %read-preserving-whitespace (stream eof-error-p eof-value recursive-p)
+ (if recursive-p
;; a loop for repeating when a macro returns nothing
(loop
(let ((char (read-char stream eof-error-p *eof-object*)))
;; 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)))))
+ (let ((*sharp-equal-alist* nil))
+ (with-read-buffer ()
+ (%read-preserving-whitespace stream eof-error-p eof-value t)))))
+
+;;; 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)
+ (recursive-p nil))
+ #!+sb-doc
+ "Read from STREAM and return the value read, preserving any whitespace
+ that followed the object."
+ (check-for-recursive-read stream recursive-p 'read-preserving-whitespace)
+ (%read-preserving-whitespace stream eof-error-p eof-value recursive-p))
;;; Return NIL or a list with one thing, depending.
;;;
(defun read (&optional (stream *standard-input*)
(eof-error-p t)
- (eof-value ())
- (recursivep ()))
+ (eof-value nil)
+ (recursive-p nil))
#!+sb-doc
"Read the next Lisp value from STREAM, and return it."
- (let ((result (read-preserving-whitespace stream
- eof-error-p
- eof-value
- recursivep)))
+ (check-for-recursive-read stream recursive-p 'read)
+ (let ((result (%read-preserving-whitespace stream eof-error-p eof-value
+ recursive-p)))
;; 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)
+ (unless (or (eql result eof-value) recursive-p)
(let ((next-char (read-char stream nil nil)))
(unless (or (null next-char)
(whitespace[2]p next-char))
#!+sb-doc
"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)))))
+ (check-for-recursive-read input-stream recursive-p 'read-delimited-list)
+ (flet ((%read-delimited-list (endchar input-stream)
+ (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)))))
+ (declare (inline %read-delimited-list))
+ (if recursive-p
+ (%read-delimited-list endchar input-stream)
+ (with-read-buffer ()
+ (%read-delimited-list endchar input-stream)))))
\f
;;;; basic readmacro definitions
;;;;
((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)
+ (style-warn
+ 'sb!kernel::character-decoding-error-in-macro-char-comment
+ :position (file-position stream) :stream stream)
(invoke-restart 'attempt-resync))))
(let ((stream (in-synonym-of stream)))
(if (ansi-stream-p stream)
(cond ((token-delimiterp nextchar)
(cond ((eq listtail thelist)
(unless *read-suppress*
- (%reader-error
+ (simple-reader-error
stream
"Nothing appears before . in list.")))
((whitespace[2]p nextchar)
((char= char #\) )
(if *read-suppress*
(return-from read-after-dot nil)
- (%reader-error stream "Nothing appears after . in list.")))
+ (simple-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)))
;; Try reading virtual whitespace.
(if (and (read-maybe-nothing stream lastchar)
(not *read-suppress*))
- (%reader-error stream "More than one object follows . in list.")))))
+ (simple-reader-error stream
+ "More than one object follows . in list.")))))
(defun read-string (stream closech)
;; This accumulates chars until it sees same char that invoked it.
(defun read-right-paren (stream ignore)
(declare (ignore ignore))
- (%reader-error stream "unmatched close parenthesis"))
+ (simple-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:
((< att +char-attr-constituent+) att)
(t (setf att (get-constituent-trait ,char))
(if (= att +char-attr-invalid+)
- (%reader-error stream "invalid constituent")
+ (simple-reader-error stream "invalid constituent")
att)))))
;;; Return the character class for CHAR, which might be part of a
((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"))
+ (simple-reader-error stream "invalid constituent"))
(t att))))))
;;; Return the character class for a char which might be part of a
+char-attr-constituent-digit+)
+char-attr-constituent-decimal-digit+))
((= att +char-attr-invalid+)
- (%reader-error stream "invalid constituent"))
+ (simple-reader-error stream "invalid constituent"))
(t att))))))
\f
;;;; token fetching
(let ((case (readtable-case *readtable*)))
(cond
((and (null escapes) (eq case :upcase))
- (dotimes (i *ouch-ptr*)
- (setf (schar *read-buffer* i)
- (char-upcase (schar *read-buffer* i)))))
+ ;; Pull the special variable access out of the loop.
+ (let ((buffer *read-buffer*))
+ (dotimes (i *ouch-ptr*)
+ (declare (optimize (sb!c::insert-array-bounds-checks 0)))
+ (setf (schar buffer i) (char-upcase (schar buffer i))))))
((eq case :preserve))
(t
(macrolet ((skip-esc (&body body)
`(do ((i (1- *ouch-ptr*) (1- i))
+ (buffer *read-buffer*)
(escapes escapes))
((minusp i))
- (declare (fixnum i))
+ (declare (fixnum i)
+ (optimize (sb!c::insert-array-bounds-checks 0)))
(when (or (null escapes)
(let ((esc (first escapes)))
(declare (fixnum esc))
(aver (= esc i))
(pop escapes)
nil))))
- (let ((ch (schar *read-buffer* i)))
+ (let ((ch (schar buffer i)))
,@body)))))
(flet ((lower-em ()
- (skip-esc (setf (schar *read-buffer* i) (char-downcase ch))))
+ (skip-esc (setf (schar buffer i) (char-downcase ch))))
(raise-em ()
- (skip-esc (setf (schar *read-buffer* i) (char-upcase ch)))))
+ (skip-esc (setf (schar buffer i) (char-upcase ch)))))
(ecase case
(:upcase (raise-em))
(:downcase (lower-em))
(cond (all-lower (raise-em))
(all-upper (lower-em))))))))))))
+(defvar *reader-package* nil)
+
(defun read-token (stream firstchar)
#!+sb-doc
- "This function is just an fsm that recognizes numbers and symbols."
+ "Default readmacro function. Handles numbers, symbols, and SBCL's
+extended <package-name>::<form-in-package> syntax."
;; 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
(#.+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"))
+ (#.+char-attr-invalid+ (simple-reader-error stream
+ "invalid constituent"))
;; can't have eof, whitespace, or terminating macro as first char!
(t (go SYMBOL)))
SIGN ; saw "sign"
FRONTDOT ; saw "dot"
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
- (unless char (%reader-error stream "dot context error"))
+ (unless char (simple-reader-error stream "dot context error"))
(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-delimiter+ (simple-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))
DOTS ; saw "dot {dot}+"
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
- (unless char (%reader-error stream "too many dots"))
+ (unless char (simple-reader-error stream "too many dots"))
(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"))
+ (simple-reader-error stream "too many dots"))
(#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
(#.+char-attr-package-delimiter+ (go COLON))
COLON
(casify-read-buffer escapes)
(unless (zerop colons)
- (%reader-error stream "too many colons in ~S"
- (read-buffer-to-string)))
+ (simple-reader-error stream
+ "too many colons in ~S"
+ (read-buffer-to-string)))
(setq colons 1)
(setq package-designator
(if (plusp *ouch-ptr*)
(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))
+ (simple-reader-error stream
+ "illegal terminating character after a colon: ~S"
+ char))
(#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
(#.+char-attr-package-delimiter+ (go INTERN))
(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))
+ (if package-designator
+ (let* ((*reader-package* (%find-package-or-lose package-designator)))
+ (return (read stream t nil t)))
+ (simple-reader-error stream
+ "illegal terminating character after a double-colon: ~S"
+ char)))
(#.+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))
+ (simple-reader-error stream
+ "too many colons after ~S name"
+ package-designator))
(t (go SYMBOL)))
RETURN-SYMBOL
(casify-read-buffer escapes)
(let ((found (if package-designator
- (find-package package-designator)
- (sane-package))))
- (unless found
- (error 'reader-package-error :stream stream
- :format-arguments (list package-designator)
- :format-control "package ~S not found"))
-
+ (or (find-package package-designator)
+ (error 'simple-reader-package-error
+ :package package-designator
+ :stream stream
+ :format-control "Package ~A does not exist."
+ :format-arguments (list package-designator)))
+ (or *reader-package* (sane-package)))))
(if (or (zerop colons) (= colons 2) (eq found *keyword-package*))
(return (intern* *read-buffer* *ouch-ptr* found))
(multiple-value-bind (symbol test)
(when (eq test :external) (return symbol))
(let ((name (read-buffer-to-string)))
(with-simple-restart (continue "Use symbol anyway.")
- (error 'reader-package-error :stream stream
+ (error 'simple-reader-package-error
+ :package found
+ :stream stream
:format-arguments (list name (package-name found))
:format-control
(if test
(the index (* num base))))))))
(setq number (+ num (* number base-power)))))))
+(defun truncate-exponent (exponent number divisor)
+ "Truncate exponent if it's too large for a float"
+ ;; Work with base-2 logarithms to avoid conversions to floats,
+ ;; and convert to base-10 conservatively at the end.
+ ;; Use the least positive float, because denormalized exponent
+ ;; can be larger than normalized.
+ (let* ((max-exponent
+ #!-long-float
+ (+ sb!vm:double-float-digits sb!vm:double-float-bias))
+ (number-magnitude (integer-length number))
+ (divisor-magnitude (1- (integer-length divisor)))
+ (magnitude (- number-magnitude divisor-magnitude)))
+ (if (minusp exponent)
+ (max exponent (ceiling (- (+ max-exponent magnitude))
+ #.(floor (log 10 2))))
+ (min exponent (floor (- max-exponent magnitude)
+ #.(floor (log 10 2)))))))
+
(defun make-float (stream)
;; Assume that the contents of *read-buffer* are a legal float, with nothing
;; else after it.
(#\F 'single-float)
(#\D 'double-float)
(#\L 'long-float)))
+ (exponent (truncate-exponent exponent number divisor))
(result (make-float-aux (* (expt 10 exponent) number)
divisor float-format stream)))
(return-from make-float
(type-error (c)
(error 'reader-impossible-number-error
:error c :stream stream
- :format-control "failed to build float"))))
+ :format-control "failed to build float from ~a"
+ :format-arguments (list (read-buffer-to-string))))))
(defun make-ratio (stream)
;; Assume *READ-BUFFER* contains a legal ratio. Build the number from
:format-control "failed to build ratio")))))
(if negative-number (- num) num))))
\f
-;;;; cruft for dispatch macros
-
-(defun make-char-dispatch-table ()
- (make-hash-table))
+;;;; General reader for dispatch macros
(defun dispatch-char-error (stream sub-char ignore)
(declare (ignore ignore))
(if *read-suppress*
(values)
- (%reader-error stream "no dispatch function defined for ~S" sub-char)))
-
-(defun make-dispatch-macro-character (char &optional
- (non-terminating-p nil)
- (rt *readtable*))
- #!+sb-doc
- "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 "The dispatch character ~S already exists." char))
- (t
- (setf (dispatch-tables rt)
- (push (cons char (make-char-dispatch-table)) dalist)))))
- t)
-
-(defun set-dispatch-macro-character (disp-char sub-char function
- &optional (rt *readtable*))
- #!+sb-doc
- "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 (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 *readtable*))
- #!+sb-doc
- "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))))
+ (simple-reader-error stream
+ "no dispatch function defined for ~S"
+ sub-char)))
(defun read-dispatch-char (stream char)
;; Read some digits.
(funcall (the function
(gethash sub-char (cdr dpair) #'dispatch-char-error))
stream sub-char (if numargp numarg nil))
- (%reader-error stream "no dispatch table for dispatch char")))))
+ (simple-reader-error stream
+ "no dispatch table for dispatch char")))))
\f
;;;; READ-FROM-STRING
-(defun read-from-string (string &optional (eof-error-p t) eof-value
- &key (start 0) end
- preserve-whitespace)
- #!+sb-doc
- "The characters of string are successively given to the lisp reader
- and the lisp object built by the reader is returned. Macro chars
- will take effect."
- (declare (string string))
+(defun maybe-note-read-from-string-signature-issue (eof-error-p)
+ ;; The interface is so unintuitive that we explicitly check for the common
+ ;; error.
+ (when (member eof-error-p '(:start :end :preserve-whitespace))
+ (style-warn "~@<~S as EOF-ERROR-P argument to ~S: probable error. ~
+ Two optional arguments must be provided before the ~
+ first keyword argument.~:@>"
+ eof-error-p 'read-from-string)
+ t))
+
+(declaim (ftype (sfunction (string t t index (or null index) t) (values t index))
+ %read-from-string))
+(defun %read-from-string (string eof-error-p eof-value start end preserve-whitespace)
(with-array-data ((string string :offset-var offset)
(start start)
- (end (%check-vector-sequence-bounds string start end)))
+ (end end)
+ :check-fill-pointer t)
(let ((stream (make-string-input-stream string start end)))
(values (if preserve-whitespace
- (read-preserving-whitespace stream eof-error-p eof-value)
+ (%read-preserving-whitespace stream eof-error-p eof-value nil)
(read stream eof-error-p eof-value))
(- (string-input-stream-current stream) offset)))))
+
+(defun read-from-string (string &optional (eof-error-p t) eof-value
+ &key (start 0) end preserve-whitespace)
+ #!+sb-doc
+ "The characters of string are successively given to the lisp reader
+ and the lisp object built by the reader is returned. Macro chars
+ will take effect."
+ (declare (string string))
+ (maybe-note-read-from-string-signature-issue eof-error-p)
+ (%read-from-string string eof-error-p eof-value start end preserve-whitespace))
+
+(define-compiler-macro read-from-string (&whole form string &rest args)
+ ;; Check this at compile-time, and rewrite it so we're silent at runtime.
+ (destructuring-bind (&optional (eof-error-p t) eof-value &rest keys)
+ args
+ (cond ((maybe-note-read-from-string-signature-issue eof-error-p)
+ `(read-from-string ,string t ,eof-value ,@keys))
+ (t
+ (let* ((start (gensym "START"))
+ (end (gensym "END"))
+ (preserve-whitespace (gensym "PRESERVE-WHITESPACE"))
+ bind seen ignore)
+ (do ()
+ ((not (cdr keys))
+ ;; Odd number of keys, punt.
+ (when keys (return-from read-from-string form)))
+ (let* ((key (pop keys))
+ (value (pop keys))
+ (var (case key
+ (:start start)
+ (:end end)
+ (:preserve-whitespace preserve-whitespace)
+ (otherwise
+ (return-from read-from-string form)))))
+ (when (member key seen)
+ (setf var (gensym "IGNORE"))
+ (push var ignore))
+ (push key seen)
+ (push (list var value) bind)))
+ (dolist (default (list (list start 0)
+ (list end nil)
+ (list preserve-whitespace nil)))
+ (unless (assoc (car default) bind)
+ (push default bind)))
+ (once-only ((string string))
+ `(let ,(nreverse bind)
+ ,@(when ignore `((declare (ignore ,@ignore))))
+ (%read-from-string ,string ,eof-error-p ,eof-value
+ ,start ,end ,preserve-whitespace))))))))
\f
;;;; PARSE-INTEGER
:format-arguments (list string))))
(with-array-data ((string string :offset-var offset)
(start start)
- (end (%check-vector-sequence-bounds string start end)))
+ (end end)
+ :check-fill-pointer t)
(let ((index (do ((i start (1+ i)))
((= i end)
(if junk-allowed
projects / sbcl.git / blobdiff