(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*
(defun !cold-init-secondary-attribute-table ()
(setq *secondary-attribute-table*
- (make-array char-code-limit :element-type '(unsigned-byte 8)
+ (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]
\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))
(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 (code-char return-char-code)))
(set-cat-entry #\\ +char-attr-escape+)
- (set-cmt-entry #\\ #'read-token)
+ (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-cat-entry char (get-secondary-attribute char))
+ (set-cmt-entry char nil)))))
\f
;;;; implementation of the read buffer
(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.
"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
(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))
(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))))
;;;; 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+
;;; 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+
;;; 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
+char-attr-delimiter+
(if (digit-char-p ,char (max *read-base* 10))
(if (digit-char-p ,char *read-base*)
- +char-attr-constituent-digit+
- +char-attr-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
(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)
- (escapes ()))
+ (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-package-delimiter+ (go COLON))
(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-package-delimiter+ (go COLON))
(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-escape+ (go 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-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"
(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)
+ (case (char-class char attribute-array attribute-hash-table)
(#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
(#.+char-attr-constituent-expt+ (go EXPONENT))
(#.+char-attr-delimiter+
(#.+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+
(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))
(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"))
(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))
(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))
(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)
(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))
(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)
(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)
(ouch-read-buffer char)
(setq char (fast-read-char nil nil))
(unless char (go RETURN-SYMBOL))
- (case (char-class char attribute-table)
+ (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)
(#.+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)
+ (case (char-class char attribute-array attribute-hash-table)
(#.+char-attr-escape+ (go ESCAPE))
- (#.+char-attr-delimiter+ (stream-unread-char stream char)
+ (#.+char-attr-delimiter+ (unread-char char stream)
(go RETURN-SYMBOL))
(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
(#.+char-attr-package-delimiter+ (go COLON))
(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-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)
+ (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))
;; 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)
+ (case (char-class char attribute-array attribute-hash-table)
(#.+char-attr-delimiter+
(unread-char char stream)
(%reader-error stream
(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
(#\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
(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
`(error 'simple-parse-error
:format-control ,format-control
:format-arguments (list string))))
- (with-array-data ((string 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)))
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))
+ (loop
+ (incf index)
+ (when (= index end) (return))
+ (unless (whitespacep (char string index))
(parse-error "junk in string ~S")))
(return nil))
(t
(if junk-allowed
nil
(parse-error "no digits in string ~S")))
- index)))))
+ (- index offset))))))
\f
;;;; reader initialization code
projects / sbcl.git / blobdiff