X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Freader.lisp;h=3bcf87814d7693f38881e72ef1d5b157bac67d50;hb=42702bd5e2af3e0042c9f27372c6f5d92335df12;hp=69a853fa5bd29096c9fc8d84bf0ec6d3c75c594d;hpb=20c0ab0df7e895d55ef79cfe815e3d58870703a3;p=sbcl.git diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 69a853f..3bcf878 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. @@ -401,12 +403,11 @@ standard Lisp readtable when NIL." (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*)) @@ -569,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) @@ -594,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))) @@ -606,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. @@ -634,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: @@ -706,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 @@ -724,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 @@ -755,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 @@ -776,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)) @@ -794,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)) @@ -850,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" @@ -981,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)) @@ -1054,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)) @@ -1131,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*) @@ -1152,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)) @@ -1167,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) @@ -1183,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")) @@ -1194,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 @@ -1423,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) @@ -1495,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