X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Freader.lisp;h=94d5ca74c177244325d05e1bec7d7aeac3ea8028;hb=02d7495253b9075e4d86275590c3e827c814b596;hp=243fd0cadb2ef7aec3daae6224a6b007da6e9ba3;hpb=c364434c07423e4b033f286397667b3fe0310e97;p=sbcl.git diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 243fd0c..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. @@ -215,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)) @@ -402,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*)) @@ -570,7 +570,7 @@ 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."))) ((whitespace[2]p nextchar) @@ -595,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))) @@ -607,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. @@ -635,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: @@ -707,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 @@ -725,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 @@ -756,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 @@ -777,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)) @@ -795,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)) @@ -851,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" @@ -982,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)) @@ -1055,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)) @@ -1132,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*) @@ -1153,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)) @@ -1168,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) @@ -1184,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")) @@ -1195,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 @@ -1424,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) @@ -1496,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 @@ -1510,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) @@ -1531,7 +1543,8 @@ 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