X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Freader.lisp;h=41145889555ba7e41b9518b99aca2817cdc79282;hb=2963d6858d147b23c33f38e051e61264b479c9fc;hp=51df957ec72d1b10e94086c5aec2052c31fe2038;hpb=667ec9d494530079bef28e8589dd0d3274b935ec;p=sbcl.git diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 51df957..4114588 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -154,19 +154,20 @@ ;;;; readtable operations (defun copy-readtable (&optional (from-readtable *readtable*) - (to-readtable (make-readtable))) - (let ((really-from-readtable (or from-readtable *standard-readtable*))) - (replace (character-attribute-table to-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 to-readtable) + (replace (character-macro-table really-to-readtable) (character-macro-table really-from-readtable)) - (setf (dispatch-tables to-readtable) - (mapcar #'(lambda (pair) (cons (car pair) - (copy-seq (cdr pair)))) + (setf (dispatch-tables really-to-readtable) + (mapcar (lambda (pair) (cons (car pair) + (copy-seq (cdr pair)))) (dispatch-tables really-from-readtable))) - (setf (readtable-case to-readtable) - (readtable-case from-readtable)) - to-readtable)) + (setf (readtable-case really-to-readtable) + (readtable-case really-from-readtable)) + really-to-readtable)) (defun set-syntax-from-char (to-char from-char &optional (to-readtable *readtable*) @@ -192,20 +193,21 @@ (defun set-macro-character (char function &optional (non-terminatingp nil) (rt *readtable*)) #!+sb-doc - "Causes char to be a macro character which invokes function when - seen by the reader. The non-terminatingp flag can be used to + "Causes CHAR to be a macro character which invokes FUNCTION when + seen by the reader. The NON-TERMINATINGP flag can be used to make the macro character non-terminating. The optional readtable - argument defaults to the current readtable. Set-macro-character + argument defaults to the current readtable. SET-MACRO-CHARACTER returns T." - (if non-terminatingp - (set-cat-entry char (get-secondary-attribute char) rt) - (set-cat-entry char +char-attr-terminating-macro+ rt)) - (set-cmt-entry char function rt) - T) + (let ((rt (or rt *standard-readtable*))) + (if non-terminatingp + (set-cat-entry char (get-secondary-attribute char) rt) + (set-cat-entry char +char-attr-terminating-macro+ rt)) + (set-cmt-entry char function rt) + T)) (defun get-macro-character (char &optional (rt *readtable*)) #!+sb-doc - "Return the function associated with the specified char which is a macro + "Return the function associated with the specified CHAR which is a macro character. The optional readtable argument defaults to the current readtable." (let ((rt (or rt *standard-readtable*))) @@ -225,7 +227,7 @@ ;; This flushes whitespace chars, returning the last char it read (a ;; non-white one). It always gets an error on end-of-file. (let ((stream (in-synonym-of stream))) - (if (lisp-stream-p stream) + (if (ansi-stream-p stream) (prepare-for-fast-read-char stream (do ((attribute-table (character-attribute-table *readtable*)) (char (fast-read-char t) (fast-read-char t))) @@ -448,7 +450,7 @@ (defun read-comment (stream ignore) (declare (ignore ignore)) (let ((stream (in-synonym-of stream))) - (if (lisp-stream-p stream) + (if (ansi-stream-p stream) (prepare-for-fast-read-char stream (do ((char (fast-read-char nil nil) (fast-read-char nil nil))) @@ -511,7 +513,7 @@ ;; For a very long string, this could end up bloating the read buffer. (reset-read-buffer) (let ((stream (in-synonym-of stream))) - (if (lisp-stream-p stream) + (if (ansi-stream-p stream) (prepare-for-fast-read-char stream (do ((char (fast-read-char t) (fast-read-char t))) ((char= char closech) @@ -879,7 +881,7 @@ (t (go SYMBOL))) SYMBOL ; not a dot, dots, or number (let ((stream (in-synonym-of stream))) - (if (lisp-stream-p stream) + (if (ansi-stream-p stream) (prepare-for-fast-read-char stream (prog () SYMBOL-LOOP @@ -1220,8 +1222,8 @@ (return-from make-float (if negative-fraction (- num) num)))))) - ;; should never happen: - (t (error "internal error in floating point reader"))))) + ;; should never happen + (t (bug "bad fallthrough in floating point reader"))))) (defun make-float-aux (number divisor float-format) (coerce (/ number divisor) float-format)) @@ -1291,6 +1293,7 @@ (when (digit-char-p sub-char) (error "SUB-CHAR must not be a decimal digit: ~S" sub-char)) (let* ((sub-char (char-upcase sub-char)) + (rt (or rt *standard-readtable*)) (dpair (find disp-char (dispatch-tables rt) :test #'char= :key #'car))) (if dpair @@ -1302,17 +1305,22 @@ (defun get-dispatch-macro-character (disp-char sub-char &optional (rt *readtable*)) #!+sb-doc - "Return the macro character function for sub-char under disp-char - or nil if there is no associated function." - (unless (digit-char-p sub-char) - (let* ((sub-char (char-upcase sub-char)) - (rt (or rt *standard-readtable*)) - (dpair (find disp-char (dispatch-tables rt) - :test #'char= :key #'car))) - (if dpair - (elt (the simple-vector (cdr dpair)) - (char-code sub-char)) - (error "~S is not a dispatch char." disp-char))))) + "Return the macro character function for SUB-CHAR under DISP-CHAR + or NIL if there is no associated function." + (let* ((sub-char (char-upcase sub-char)) + (rt (or rt *standard-readtable*)) + (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)) + (error "~S is not a dispatch char." disp-char)))) (defun read-dispatch-char (stream char) ;; Read some digits.