: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))
(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 (declaim (inline whitespacep))
-(defun whitespacep (char &optional (rt *readtable*))
+;;; 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*))
really-to-readtable))
(defun set-syntax-from-char (to-char from-char &optional
- (to-readtable *readtable*)
- (from-readtable ()))
+ (to-readtable *readtable*) (from-readtable ()))
#!+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."
+ "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."
(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))
(setq *ouch-ptr* (1- (the fixnum *ouch-ptr*)))))
(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))))
+ (let* ((rbl (length *read-buffer*))
+ (new-length (* 2 rbl))
+ (new-buffer (make-string new-length)))
+ (setq *read-buffer* (replace new-buffer *read-buffer*))
+ (setq *read-buffer-length* new-length)))
(defun inchpeek-read-buffer ()
(if (>= (the fixnum *inch-ptr*) (the fixnum *ouch-ptr*))
(loop
(let ((char (read-char stream eof-error-p *eof-object*)))
(cond ((eofp char) (return eof-value))
- ((whitespacep char))
+ ((whitespace[2]p char))
(t
(let* ((macrofun (get-coerced-cmt-entry char *readtable*))
(result (multiple-value-list
(unless (or (eql result eof-value) recursivep)
(let ((next-char (read-char stream nil nil)))
(unless (or (null next-char)
- (whitespacep next-char))
+ (whitespace[2]p next-char))
(unread-char next-char stream))))
result))
(cond ((token-delimiterp nextchar)
(cond ((eq listtail thelist)
(unless *read-suppress*
- (%reader-error
+ (simple-reader-error
stream
"Nothing appears before . in list.")))
- ((whitespacep nextchar)
+ ((whitespace[2]p nextchar)
(setq nextchar (flush-whitespace stream))))
(rplacd listtail
;; Return list containing last thing.
((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))
(#.+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))
+ (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+
- (%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)
(find-package package-designator)
(sane-package))))
(unless found
- (error 'reader-package-error :stream stream
+ (error 'simple-reader-package-error :stream stream
:format-arguments (list package-designator)
:format-control "package ~S not found"))
(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 :stream stream
:format-arguments (list name (package-name found))
:format-control
(if test
(declare (ignore ignore))
(if *read-suppress*
(values)
- (%reader-error stream "no dispatch function defined for ~S" sub-char)))
+ (simple-reader-error stream
+ "no dispatch function defined for ~S"
+ sub-char)))
(defun make-dispatch-macro-character (char &optional
(non-terminating-p nil)
(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
(declare (string 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 ((stream (make-string-input-stream string start end)))
(values (if preserve-whitespace
(read-preserving-whitespace stream eof-error-p eof-value)
: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
(return-from parse-integer (values nil end))
(parse-error "no non-whitespace characters in string ~S.")))
(declare (fixnum i))
- (unless (whitespacep (char string i)) (return i))))
+ (unless (whitespace[1]p (char string i)) (return i))))
(minusp nil)
(found-digit nil)
(result 0))
(setq result (+ weight (* result radix))
found-digit t))
(junk-allowed (return nil))
- ((whitespacep char)
+ ((whitespace[1]p char)
(loop
(incf index)
(when (= index end) (return))
- (unless (whitespacep (char string index))
+ (unless (whitespace[1]p (char string index))
(parse-error "junk in string ~S")))
(return nil))
(t