(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))
+ (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)
- `(svref (character-macro-table ,readtable)
- (char-code ,char))))
+ `(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,
#'read-token)))
(defun set-cmt-entry (char new-value-designator &optional (rt *readtable*))
- (setf (svref (character-macro-table rt)
- (char-code char))
+ (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))))
+ (%coerce-callable-to-fun new-value-designator)))))
(defun undefined-macro-char (stream char)
(unless *read-suppress*
(test-attribute char +char-attr-whitespace+ rt))
(defmacro constituentp (char &optional (rt '*readtable*))
- `(>= (get-cat-entry ,char ,rt) +char-attr-constituent+))
+ `(test-attribute ,char +char-attr-constituent+ ,rt))
(defmacro terminating-macrop (char &optional (rt '*readtable*))
`(test-attribute ,char +char-attr-terminating-macro+ ,rt))
-(defmacro escapep (char &optional (rt '*readtable*))
- `(test-attribute ,char +char-attr-escape+ ,rt))
+(defmacro single-escape-p (char &optional (rt '*readtable*))
+ `(test-attribute ,char +char-attr-single-escape+ ,rt))
(defmacro multiple-escape-p (char &optional (rt '*readtable*))
`(test-attribute ,char +char-attr-multiple-escape+ ,rt))
;; depends on actual attribute numbering above.
`(<= (get-cat-entry ,char ,rt) +char-attr-terminating-macro+))
\f
-;;;; secondary attribute table
+;;;; constituent traits (see ANSI 2.1.4.2)
;;; There are a number of "secondary" attributes which are constant
;;; properties of characters (as long as they are constituents).
-(defvar *secondary-attribute-table*)
-(declaim (type attribute-table *secondary-attribute-table*))
+(defvar *constituent-trait-table*)
+(declaim (type attribute-table *constituent-trait-table*))
-(defun !set-secondary-attribute (char attribute)
- (setf (elt *secondary-attribute-table* (char-code char))
- attribute))
+(defun !set-constituent-trait (char trait)
+ (aver (typep char 'base-char))
+ (setf (elt *constituent-trait-table* (char-code char))
+ trait))
-(defun !cold-init-secondary-attribute-table ()
- (setq *secondary-attribute-table*
- (make-array char-code-limit :element-type '(unsigned-byte 8)
+(defun !cold-init-constituent-trait-table ()
+ (setq *constituent-trait-table*
+ (make-array base-char-code-limit :element-type '(unsigned-byte 8)
:initial-element +char-attr-constituent+))
- (!set-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+)
+ (!set-constituent-trait #\: +char-attr-package-delimiter+)
+ (!set-constituent-trait #\. +char-attr-constituent-dot+)
+ (!set-constituent-trait #\+ +char-attr-constituent-sign+)
+ (!set-constituent-trait #\- +char-attr-constituent-sign+)
+ (!set-constituent-trait #\/ +char-attr-constituent-slash+)
(do ((i (char-code #\0) (1+ i)))
((> i (char-code #\9)))
- (!set-secondary-attribute (code-char i) +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*
- (char-code ,char)))
+ (!set-constituent-trait (code-char i) +char-attr-constituent-digit+))
+ (!set-constituent-trait #\E +char-attr-constituent-expt+)
+ (!set-constituent-trait #\F +char-attr-constituent-expt+)
+ (!set-constituent-trait #\D +char-attr-constituent-expt+)
+ (!set-constituent-trait #\S +char-attr-constituent-expt+)
+ (!set-constituent-trait #\L +char-attr-constituent-expt+)
+ (!set-constituent-trait #\e +char-attr-constituent-expt+)
+ (!set-constituent-trait #\f +char-attr-constituent-expt+)
+ (!set-constituent-trait #\d +char-attr-constituent-expt+)
+ (!set-constituent-trait #\s +char-attr-constituent-expt+)
+ (!set-constituent-trait #\l +char-attr-constituent-expt+)
+ (!set-constituent-trait #\Space +char-attr-invalid+)
+ (!set-constituent-trait #\Newline +char-attr-invalid+)
+ (dolist (c (list backspace-char-code tab-char-code form-feed-char-code
+ return-char-code rubout-char-code))
+ (!set-constituent-trait (code-char c) +char-attr-invalid+)))
+
+(defmacro get-constituent-trait (char)
+ `(if (typep ,char 'base-char)
+ (elt *constituent-trait-table* (char-code ,char))
+ +char-attr-constituent+))
\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)
(let ((really-from-readtable (or from-readtable *standard-readtable*))
(really-to-readtable (or to-readtable (make-readtable))))
- (replace (character-attribute-table really-to-readtable)
- (character-attribute-table really-from-readtable))
- (replace (character-macro-table really-to-readtable)
- (character-macro-table really-from-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)
- (copy-seq (cdr pair))))
+ (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)))
(setf (readtable-case really-to-readtable)
(readtable-case really-from-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
- ;; attributes (constituent types), and that said attributes magically
- ;; appear if you transform a non-constituent to a constituent.
- (let ((att (get-cat-entry from-char really-from-readtable)))
- (if (constituentp from-char really-from-readtable)
- (setq att (get-secondary-attribute to-char)))
+ (let ((att (get-cat-entry from-char really-from-readtable))
+ (mac (get-raw-cmt-entry from-char really-from-readtable))
+ (from-dpair (find from-char (dispatch-tables really-from-readtable)
+ :test #'char= :key #'car))
+ (to-dpair (find to-char (dispatch-tables to-readtable)
+ :test #'char= :key #'car)))
(set-cat-entry to-char att to-readtable)
- (set-cmt-entry to-char
- (get-raw-cmt-entry from-char really-from-readtable)
- to-readtable)))
+ (set-cmt-entry to-char mac to-readtable)
+ (when from-dpair
+ (cond
+ (to-dpair
+ (let ((table (cdr to-dpair)))
+ (clrhash table)
+ (shallow-replace/eql-hash-table table (cdr from-dpair))))
+ (t
+ (let ((pair (cons to-char (make-hash-table))))
+ (shallow-replace/eql-hash-table (cdr pair) (cdr from-dpair))
+ (setf (dispatch-tables to-readtable)
+ (push pair (dispatch-tables to-readtable)))))))))
t)
(defun set-macro-character (char function &optional
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+)
+ (set-cat-entry char (if non-terminatingp
+ +char-attr-constituent+
+ +char-attr-terminating-macro+)
designated-readtable)
(set-cmt-entry char function designated-readtable)
t)) ; (ANSI-specified return value)
(let ((stream (in-synonym-of 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)))
+ ((/= (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)))
+ (/= (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)
(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 #\linefeed)
- (whitespaceify #\space)
+ (whitespaceify #\Newline)
+ (whitespaceify #\Space)
(whitespaceify (code-char form-feed-char-code))
(whitespaceify (code-char return-char-code)))
- (set-cat-entry #\\ +char-attr-escape+)
- (set-cmt-entry #\\ #'read-token)
+ (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)
;; 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 nil)))))
+ (set-cmt-entry char nil)))))
\f
;;;; implementation of the read buffer
"Read from STREAM and return the value read, preserving any whitespace
that followed the object."
(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.
- (if result (return (car result))))))))
- (let ((*sharp-equal-alist* nil))
+ ;; 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.
eof-error-p
eof-value
recursivep)))
- ;; (This function generally discards trailing whitespace. If you
+ ;; This function generally discards trailing whitespace. If you
;; don't want to discard trailing whitespace, call
- ;; CL:READ-PRESERVING-WHITESPACE instead.)
+ ;; 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)
(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
(defun read-comment (stream ignore)
(declare (ignore ignore))
- (let ((stream (in-synonym-of stream)))
- (if (ansi-stream-p stream)
- (prepare-for-fast-read-char stream
- (do ((char (fast-read-char nil nil)
- (fast-read-char nil nil)))
- ((or (not char) (char= char #\newline))
- (done-with-fast-read-char))))
- ;; FUNDAMENTAL-STREAM
- (do ((char (stream-read-char stream) (stream-read-char stream)))
- ((or (eq char :eof) (char= char #\newline))))))
+ (handler-bind
+ ((character-decoding-error
+ #'(lambda (decoding-error)
+ (declare (ignorable decoding-error))
+ (style-warn "Character decoding error in a ;-comment at position ~A reading source file ~A, resyncing." (file-position stream) stream)
+ (invoke-restart 'attempt-resync))))
+ (let ((stream (in-synonym-of stream)))
+ (if (ansi-stream-p stream)
+ (prepare-for-fast-read-char stream
+ (do ((char (fast-read-char nil nil)
+ (fast-read-char nil nil)))
+ ((or (not char) (char= char #\newline))
+ (done-with-fast-read-char))))
+ ;; CLOS stream
+ (do ((char (read-char stream nil :eof) (read-char stream nil :eof)))
+ ((or (eq char :eof) (char= char #\newline)))))))
;; Don't return anything.
(values))
(do ((char (fast-read-char t) (fast-read-char t)))
((char= char closech)
(done-with-fast-read-char))
- (if (escapep char) (setq char (fast-read-char t)))
+ (if (single-escape-p char) (setq char (fast-read-char t)))
(ouch-read-buffer char)))
- ;; FUNDAMENTAL-STREAM
- (do ((char (stream-read-char stream) (stream-read-char stream)))
+ ;; CLOS stream
+ (do ((char (read-char stream nil :eof) (read-char stream nil :eof)))
((or (eq char :eof) (char= char closech))
(if (eq char :eof)
(error 'end-of-file :stream stream)))
- (when (escapep char)
- (setq char (stream-read-char stream))
+ (when (single-escape-p char)
+ (setq char (read-char stream nil :eof))
(if (eq char :eof)
(error 'end-of-file :stream stream)))
(ouch-read-buffer char))))
t)
(t nil))
(values escapes colon))
- (cond ((escapep char)
+ (cond ((single-escape-p char)
;; It can't be a number, even if it's 1\23.
;; Read next char here, so it won't be casified.
(push *ouch-ptr* escapes)
((eofp ch)
(reader-eof-error stream "inside extended token"))
((multiple-escape-p ch) (return))
- ((escapep ch)
+ ((single-escape-p ch)
(let ((nextchar (read-char stream nil *eof-object*)))
(cond ((eofp nextchar)
(reader-eof-error stream "after escape character"))
(ouch-read-buffer ch))))))
(t
(when (and (constituentp char)
- (eql (get-secondary-attribute char)
- +char-attr-package-delimiter+)
+ (eql (get-constituent-trait char)
+ +char-attr-package-delimiter+)
(not colon))
(setq colon *ouch-ptr*))
(ouch-read-buffer char))))))
;;;; character classes
;;; Return the character class for CHAR.
-(defmacro char-class (char attable)
- `(let ((att (aref ,attable (char-code ,char))))
+;;;
+;;; FIXME: why aren't these ATT-getting forms using GET-CAT-ENTRY?
+;;; Because we've cached the readtable tables?
+(defmacro char-class (char attarray atthash)
+ `(let ((att (if (typep ,char 'base-char)
+ (aref ,attarray (char-code ,char))
+ (gethash ,char ,atthash +char-attr-constituent+))))
(declare (fixnum att))
- (if (<= att +char-attr-terminating-macro+)
- +char-attr-delimiter+
- att)))
+ (cond
+ ((<= att +char-attr-terminating-macro+) +char-attr-delimiter+)
+ ((< att +char-attr-constituent+) att)
+ (t (setf att (get-constituent-trait ,char))
+ (if (= att +char-attr-invalid+)
+ (%reader-error stream "invalid constituent")
+ att)))))
;;; Return the character class for CHAR, which might be part of a
;;; rational number.
-(defmacro char-class2 (char attable)
- `(let ((att (aref ,attable (char-code ,char))))
+(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 +char-attr-terminating-macro+)
- +char-attr-delimiter+
- (if (digit-char-p ,char *read-base*)
- +char-attr-constituent-digit+
- (if (= att +char-attr-constituent-digit+)
- +char-attr-constituent+
- att)))))
+ (cond
+ ((<= att +char-attr-terminating-macro+) +char-attr-delimiter+)
+ ((< att +char-attr-constituent+) att)
+ (t (setf att (get-constituent-trait ,char))
+ (cond
+ ((digit-char-p ,char *read-base*) +char-attr-constituent-digit+)
+ ((= att +char-attr-constituent-digit+) +char-attr-constituent+)
+ ((= att +char-attr-invalid+)
+ (%reader-error stream "invalid constituent"))
+ (t att))))))
;;; Return the character class for a char which might be part of a
;;; rational or floating number. (Assume that it is a digit if it
;;; could be.)
-(defmacro char-class3 (char attable)
- `(let ((att (aref ,attable (char-code ,char))))
+(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 +char-attr-constituent-slash+))))
- (if possibly-float
- (setq possibly-float
- (or (digit-char-p ,char 10)
- (= att +char-attr-constituent-dot+))))
- (if (<= att +char-attr-terminating-macro+)
- +char-attr-delimiter+
- (if (digit-char-p ,char (max *read-base* 10))
+ (cond
+ ((<= att +char-attr-terminating-macro+) +char-attr-delimiter+)
+ ((< att +char-attr-constituent+) att)
+ (t (setf att (get-constituent-trait ,char))
+ (when possibly-rational
+ (setq possibly-rational
+ (or (digit-char-p ,char *read-base*)
+ (= att +char-attr-constituent-slash+))))
+ (when possibly-float
+ (setq possibly-float
+ (or (digit-char-p ,char 10)
+ (= att +char-attr-constituent-dot+))))
+ (cond
+ ((digit-char-p ,char (max *read-base* 10))
(if (digit-char-p ,char *read-base*)
- +char-attr-constituent-digit+
- +char-attr-constituent+)
- att))))
+ (if (= att +char-attr-constituent-expt+)
+ +char-attr-constituent-digit-or-expt+
+ +char-attr-constituent-digit+)
+ +char-attr-constituent-decimal-digit+))
+ ((= att +char-attr-invalid+)
+ (%reader-error stream "invalid constituent"))
+ (t att))))))
\f
;;;; token fetching
(when *read-suppress*
(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)
+ (was-possibly-float nil)
(escapes ())
(seen-multiple-escapes nil))
(reset-read-buffer)
(prog ((char firstchar))
- (case (char-class3 char attribute-table)
+ (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-single-escape+ (go SINGLE-ESCAPE))
(#.+char-attr-package-delimiter+ (go COLON))
(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+ (#.+char-attr-invalid+ (%reader-error stream "invalid constituent"))
;; can't have eof, whitespace, or terminating macro as first char!
(t (go SYMBOL)))
SIGN ; saw "sign"
(unless char (go RETURN-SYMBOL))
(setq possibly-rational t
possibly-float t)
- (case (char-class3 char attribute-table)
+ (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-single-escape+ (go SINGLE-ESCAPE))
(#.+char-attr-package-delimiter+ (go COLON))
(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
(#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (return (make-integer)))
- (case (char-class3 char attribute-table)
+ (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-expt+ (go EXPONENT))
+ (#.+char-attr-constituent-digit-or-expt+
+ (if (or seen-digit-or-expt (not was-possibly-float))
+ (progn (setq seen-digit-or-expt t) (go LEFTDIGIT))
+ (progn (setq seen-digit-or-expt t) (go LEFTDIGIT-OR-EXPT))))
+ (#.+char-attr-constituent-expt+
+ (if was-possibly-float
+ (go EXPONENT)
+ (go SYMBOL)))
+ (#.+char-attr-constituent-slash+ (if possibly-rational
+ (go RATIO)
+ (go SYMBOL)))
+ (#.+char-attr-delimiter+ (unread-char char stream)
+ (return (make-integer)))
+ (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
+ (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+ (#.+char-attr-package-delimiter+ (go COLON))
+ (t (go SYMBOL)))
+ LEFTDIGIT-OR-EXPT
+ (ouch-read-buffer char)
+ (setq char (read-char stream nil nil))
+ (unless char (return (make-integer)))
+ (case (char-class3 char attribute-array attribute-hash-table)
+ (#.+char-attr-constituent-digit+ (go LEFTDIGIT))
+ (#.+char-attr-constituent-decimal-digit+ (bug "impossible!"))
+ (#.+char-attr-constituent-dot+ (go SYMBOL))
+ (#.+char-attr-constituent-digit-or-expt+ (go LEFTDIGIT))
+ (#.+char-attr-constituent-expt+ (go SYMBOL))
+ (#.+char-attr-constituent-sign+ (go EXPTSIGN))
(#.+char-attr-constituent-slash+ (if possibly-rational
(go RATIO)
(go SYMBOL)))
(#.+char-attr-delimiter+ (unread-char char stream)
(return (make-integer)))
- (#.+char-attr-escape+ (go ESCAPE))
+ (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
+ (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+ (#.+char-attr-package-delimiter+ (go COLON))
+ (t (go SYMBOL)))
+ LEFTDECIMALDIGIT ; saw "[sign] {decimal-digit}+"
+ (aver possibly-float)
+ (ouch-read-buffer char)
+ (setq char (read-char stream nil nil))
+ (unless char (go RETURN-SYMBOL))
+ (case (char-class char attribute-array attribute-hash-table)
+ (#.+char-attr-constituent-digit+ (go LEFTDECIMALDIGIT))
+ (#.+char-attr-constituent-dot+ (go MIDDLEDOT))
+ (#.+char-attr-constituent-expt+ (go EXPONENT))
+ (#.+char-attr-constituent-slash+ (aver (not possibly-rational))
+ (go SYMBOL))
+ (#.+char-attr-delimiter+ (unread-char char stream)
+ (go RETURN-SYMBOL))
+ (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
(#.+char-attr-package-delimiter+ (go COLON))
(t (go SYMBOL)))
(setq char (read-char stream nil nil))
(unless char (return (let ((*read-base* 10))
(make-integer))))
- (case (char-class char attribute-table)
+ (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))))
- (#.+char-attr-escape+ (go ESCAPE))
+ (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
(#.+char-attr-package-delimiter+ (go COLON))
(t (go SYMBOL)))
- RIGHTDIGIT ; saw "[sign] {digit}* dot {digit}+"
+ RIGHTDIGIT ; saw "[sign] {decimal-digit}* dot {digit}+"
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (return (make-float stream)))
- (case (char-class char attribute-table)
+ (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-single-escape+ (go SINGLE-ESCAPE))
(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
(#.+char-attr-package-delimiter+ (go COLON))
(t (go SYMBOL)))
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (go RETURN-SYMBOL))
- (case (char-class char attribute-table)
+ (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-single-escape+ (go SINGLE-ESCAPE))
(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
(t (go SYMBOL)))
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)
+ (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-single-escape+ (go SINGLE-ESCAPE))
(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
(#.+char-attr-package-delimiter+ (go COLON))
(t (go SYMBOL)))
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (go RETURN-SYMBOL))
- (case (char-class char attribute-table)
+ (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-single-escape+ (go SINGLE-ESCAPE))
(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
(#.+char-attr-package-delimiter+ (go COLON))
(t (go SYMBOL)))
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (go RETURN-SYMBOL))
- (case (char-class char attribute-table)
+ (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-single-escape+ (go SINGLE-ESCAPE))
(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
(#.+char-attr-package-delimiter+ (go COLON))
(t (go SYMBOL)))
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (return (make-float stream)))
- (case (char-class char attribute-table)
+ (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-single-escape+ (go SINGLE-ESCAPE))
(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
(#.+char-attr-package-delimiter+ (go COLON))
(t (go SYMBOL)))
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (go RETURN-SYMBOL))
- (case (char-class2 char attribute-table)
+ (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-single-escape+ (go SINGLE-ESCAPE))
(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
(#.+char-attr-package-delimiter+ (go COLON))
(t (go SYMBOL)))
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (return (make-ratio stream)))
- (case (char-class2 char attribute-table)
+ (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-single-escape+ (go SINGLE-ESCAPE))
(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
(#.+char-attr-package-delimiter+ (go COLON))
(t (go SYMBOL)))
(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)
+ (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"))
- (#.+char-attr-escape+ (go ESCAPE))
+ (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
(#.+char-attr-package-delimiter+ (go COLON))
(t (go SYMBOL)))
(ouch-read-buffer char)
(setq char (fast-read-char nil nil))
(unless char (go RETURN-SYMBOL))
- (case (char-class char attribute-table)
- (#.+char-attr-escape+ (done-with-fast-read-char)
- (go ESCAPE))
+ (case (char-class char attribute-array attribute-hash-table)
+ (#.+char-attr-single-escape+ (done-with-fast-read-char)
+ (go SINGLE-ESCAPE))
(#.+char-attr-delimiter+ (done-with-fast-read-char)
(unread-char char stream)
(go RETURN-SYMBOL))
(#.+char-attr-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)
- (#.+char-attr-escape+ (go ESCAPE))
- (#.+char-attr-delimiter+ (stream-unread-char stream char)
+ (case (char-class char attribute-array attribute-hash-table)
+ (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
+ (#.+char-attr-delimiter+ (unread-char char stream)
(go RETURN-SYMBOL))
(#.+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.
+ SINGLE-ESCAPE ; saw a single-escape
+ ;; Don't put the escape character in the read buffer.
;; READ-NEXT CHAR, put in buffer (no case conversion).
(let ((nextchar (read-char stream nil nil)))
(unless nextchar
- (reader-eof-error stream "after escape character"))
+ (reader-eof-error stream "after single-escape character"))
(push *ouch-ptr* escapes)
(ouch-read-buffer nextchar))
(setq char (read-char stream nil nil))
(unless char (go RETURN-SYMBOL))
- (case (char-class char attribute-table)
+ (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-single-escape+ (go SINGLE-ESCAPE))
(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
(#.+char-attr-package-delimiter+ (go COLON))
(t (go SYMBOL)))
(setq seen-multiple-escapes t)
(do ((char (read-char stream t) (read-char stream t)))
((multiple-escape-p char))
- (if (escapep char) (setq char (read-char stream t)))
+ (if (single-escape-p char) (setq char (read-char stream t)))
(push *ouch-ptr* escapes)
(ouch-read-buffer char))
(setq char (read-char stream nil nil))
(unless char (go RETURN-SYMBOL))
- (case (char-class char attribute-table)
+ (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-single-escape+ (go SINGLE-ESCAPE))
(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
(#.+char-attr-package-delimiter+ (go COLON))
(t (go SYMBOL)))
(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)
+ (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))
- (#.+char-attr-escape+ (go ESCAPE))
+ (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
(#.+char-attr-package-delimiter+ (go INTERN))
(t (go SYMBOL)))
(setq char (read-char stream nil nil))
(unless char
(reader-eof-error stream "after reading a colon"))
- (case (char-class char attribute-table)
+ (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))
- (#.+char-attr-escape+ (go ESCAPE))
+ (#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
(#.+char-attr-package-delimiter+
(%reader-error stream
(#\F 'single-float)
(#\D 'double-float)
(#\L 'long-float)))
- num)
- ;; Raymond Toy writes: 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)
- ;; FIXME: These forms are broken w.r.t.
- ;; cross-compilation portability, as the
- ;; cross-compiler will call the host's LOG function
- ;; while attempting to constant-fold. Maybe some sort
- ;; of load-time-form magic could be used instead?
- (case float-format
- ((short-float single-float)
- (values
- (log sb!xc:least-positive-normalized-single-float 10f0)
- (log sb!xc:most-positive-single-float 10f0)))
- ((double-float #!-long-float long-float)
- (values
- (log sb!xc:least-positive-normalized-double-float 10d0)
- (log sb!xc:most-positive-double-float 10d0)))
- #!+long-float
- (long-float
- (values
- (log sb!xc:least-positive-normalized-long-float 10l0)
- (log sb!xc: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 stream))
- (setq num (* num (expt 10 exponent)))
- (return-from make-float (if negative-fraction
- (- num)
- num))))))
- ;; should never happen
+ (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)
;;;; 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))
(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
(dpair (find disp-char (dispatch-tables rt)
:test #'char= :key #'car)))
(if dpair
- (let ((dispatch-fun (elt (the simple-vector (cdr dpair))
- (char-code sub-char))))
- ;; Digits are also initialized in a dispatch table to
- ;; #'dispatch-char-error; READ-DISPATCH-CHAR handles them
- ;; separately. - CSR, 2002-04-12
- (if (eq dispatch-fun #'dispatch-char-error)
- nil
- dispatch-fun))
+ (values (gethash sub-char (cdr dpair)))
(error "~S is not a dispatch char." disp-char))))
(defun read-dispatch-char (stream char)
: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
will take effect."
(declare (string string))
- (with-array-data ((string string)
+ (with-array-data ((string string :offset-var offset)
(start start)
(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
(values (if preserve-whitespace
(read-preserving-whitespace stream eof-error-p eof-value)
(read stream eof-error-p eof-value))
- (string-input-stream-current stream))
+ (- (string-input-stream-current stream) offset))
(push stream *read-from-string-spares*)))))
\f
;;;; PARSE-INTEGER
(defun !reader-cold-init ()
(!cold-init-read-buffer)
- (!cold-init-secondary-attribute-table)
+ (!cold-init-constituent-trait-table)
(!cold-init-standard-readtable)
;; FIXME: This was commented out, but should probably be restored.
#+nil (!cold-init-integer-reader))
projects / sbcl.git / blobdiff