X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Freader.lisp;h=94d5ca74c177244325d05e1bec7d7aeac3ea8028;hb=a572ab7de4266dec958d50612a8376df6bb45226;hp=bf17289593ca0b524e58f95eab1806c472b3ae77;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/reader.lisp b/src/code/reader.lisp index bf17289..94d5ca7 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -49,8 +49,10 @@ :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)) @@ -105,7 +107,7 @@ (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. @@ -114,8 +116,12 @@ ;;; 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*)) @@ -211,12 +217,11 @@ 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)) @@ -398,12 +403,11 @@ (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*)) @@ -468,7 +472,7 @@ variables to allow for nested and thread safe reading." (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 @@ -507,7 +511,7 @@ variables to allow for nested and thread safe reading." (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)) @@ -566,10 +570,10 @@ variables to allow for nested and thread safe reading." (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. @@ -591,7 +595,7 @@ variables to allow for nested and thread safe reading." ((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))) @@ -603,7 +607,8 @@ variables to allow for nested and thread safe reading." ;; 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. @@ -631,7 +636,7 @@ variables to allow for nested and thread safe reading." (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: @@ -703,7 +708,7 @@ variables to allow for nested and thread safe reading." ((< 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 @@ -721,7 +726,7 @@ variables to allow for nested and thread safe reading." ((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 @@ -752,7 +757,7 @@ variables to allow for nested and thread safe reading." +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)))))) ;;;; token fetching @@ -773,16 +778,20 @@ variables to allow for nested and thread safe reading." (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)) @@ -791,12 +800,12 @@ variables to allow for nested and thread safe reading." (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)) @@ -847,7 +856,8 @@ variables to allow for nested and thread safe reading." (#.+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" @@ -978,11 +988,12 @@ variables to allow for nested and thread safe reading." 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)) @@ -1051,12 +1062,12 @@ variables to allow for nested and thread safe reading." 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)) @@ -1128,8 +1139,9 @@ variables to allow for nested and thread safe reading." 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*) @@ -1149,9 +1161,9 @@ variables to allow for nested and thread safe reading." (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)) @@ -1164,15 +1176,15 @@ variables to allow for nested and thread safe reading." (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) @@ -1180,7 +1192,7 @@ variables to allow for nested and thread safe reading." (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")) @@ -1191,7 +1203,7 @@ variables to allow for nested and thread safe reading." (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 @@ -1420,7 +1432,9 @@ variables to allow for nested and thread safe reading." (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) @@ -1492,7 +1506,8 @@ variables to allow for nested and thread safe reading." (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"))))) ;;;; READ-FROM-STRING @@ -1506,7 +1521,8 @@ variables to allow for nested and thread safe reading." (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) @@ -1527,14 +1543,15 @@ variables to allow for nested and thread safe reading." :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)) @@ -1553,11 +1570,11 @@ variables to allow for nested and thread safe reading." (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