X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Freader.lisp;h=b5c5e73b148557faf99754169f4d384ad5b7df95;hb=add57c72c932fbf70c8ba8297154936c908b410e;hp=2372ef8750fd2165af1f6dee3cd7f5fe36d6b739;hpb=93ba859423ec6e035a7b22a76a2ac70038691d65;p=sbcl.git diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 2372ef8..b5c5e73 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -256,9 +256,9 @@ +char-attr-whitespace+) (done-with-fast-read-char) char))) - ;; fundamental-stream + ;; CLOS stream (do ((attribute-table (character-attribute-table *readtable*)) - (char (stream-read-char stream) (stream-read-char stream))) + (char (read-char stream nil :eof) (read-char stream nil :eof))) ((or (eq char :eof) (/= (the fixnum (aref attribute-table (char-code char))) +char-attr-whitespace+)) @@ -316,7 +316,7 @@ (defvar *ouch-ptr*) (declaim (type index *read-buffer-length* *inch-ptr* *ouch-ptr*)) -(declaim (simple-string *read-buffer*)) +(declaim (type (simple-array character (*)) *read-buffer*)) (defmacro reset-read-buffer () ;; Turn *READ-BUFFER* into an empty read buffer. @@ -483,8 +483,8 @@ (fast-read-char nil nil))) ((or (not char) (char= char #\newline)) (done-with-fast-read-char)))) - ;; FUNDAMENTAL-STREAM - (do ((char (stream-read-char stream) (stream-read-char stream))) + ;; CLOS stream + (do ((char (read-char stream nil :eof) (read-char stream nil :eof))) ((or (eq char :eof) (char= char #\newline)))))) ;; Don't return anything. (values)) @@ -547,13 +547,13 @@ (done-with-fast-read-char)) (if (escapep char) (setq char (fast-read-char t))) (ouch-read-buffer char))) - ;; FUNDAMENTAL-STREAM - (do ((char (stream-read-char stream) (stream-read-char stream))) + ;; CLOS stream + (do ((char (read-char stream nil :eof) (read-char stream nil :eof))) ((or (eq char :eof) (char= char closech)) (if (eq char :eof) (error 'end-of-file :stream stream))) (when (escapep char) - (setq char (stream-read-char stream)) + (setq char (read-char stream nil :eof)) (if (eq char :eof) (error 'end-of-file :stream stream))) (ouch-read-buffer char)))) @@ -658,8 +658,10 @@ +char-attr-delimiter+ (if (digit-char-p ,char (max *read-base* 10)) (if (digit-char-p ,char *read-base*) - +char-attr-constituent-digit+ - +char-attr-constituent+) + (if (= att +char-attr-constituent-expt+) + +char-attr-constituent-digit-or-expt+ + +char-attr-constituent-digit+) + +char-attr-constituent-decimal-digit+) att)))) ;;;; token fetching @@ -735,13 +737,20 @@ (package-designator nil) (colons 0) (possibly-rational t) + (seen-digit-or-expt nil) (possibly-float t) - (escapes ())) + (was-possibly-float nil) + (escapes ()) + (seen-multiple-escapes nil)) (reset-read-buffer) (prog ((char firstchar)) (case (char-class3 char attribute-table) (#.+char-attr-constituent-sign+ (go SIGN)) (#.+char-attr-constituent-digit+ (go LEFTDIGIT)) + (#.+char-attr-constituent-digit-or-expt+ + (setq seen-digit-or-expt t) + (go LEFTDIGIT)) + (#.+char-attr-constituent-decimal-digit+ (go LEFTDECIMALDIGIT)) (#.+char-attr-constituent-dot+ (go FRONTDOT)) (#.+char-attr-escape+ (go ESCAPE)) (#.+char-attr-package-delimiter+ (go COLON)) @@ -756,6 +765,10 @@ possibly-float t) (case (char-class3 char attribute-table) (#.+char-attr-constituent-digit+ (go LEFTDIGIT)) + (#.+char-attr-constituent-digit-or-expt+ + (setq seen-digit-or-expt t) + (go LEFTDIGIT)) + (#.+char-attr-constituent-decimal-digit+ (go LEFTDECIMALDIGIT)) (#.+char-attr-constituent-dot+ (go SIGNDOT)) (#.+char-attr-escape+ (go ESCAPE)) (#.+char-attr-package-delimiter+ (go COLON)) @@ -766,12 +779,43 @@ (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (make-integer))) + (setq was-possibly-float possibly-float) (case (char-class3 char attribute-table) (#.+char-attr-constituent-digit+ (go LEFTDIGIT)) + (#.+char-attr-constituent-decimal-digit+ (if possibly-float + (go LEFTDECIMALDIGIT) + (go SYMBOL))) (#.+char-attr-constituent-dot+ (if possibly-float (go MIDDLEDOT) (go SYMBOL))) - (#.+char-attr-constituent-expt+ (go EXPONENT)) + (#.+char-attr-constituent-digit-or-expt+ + (if (or seen-digit-or-expt (not was-possibly-float)) + (progn (setq seen-digit-or-expt t) (go LEFTDIGIT)) + (progn (setq seen-digit-or-expt t) (go LEFTDIGIT-OR-EXPT)))) + (#.+char-attr-constituent-expt+ + (if was-possibly-float + (go EXPONENT) + (go SYMBOL))) + (#.+char-attr-constituent-slash+ (if possibly-rational + (go RATIO) + (go SYMBOL))) + (#.+char-attr-delimiter+ (unread-char char stream) + (return (make-integer))) + (#.+char-attr-escape+ (go ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL))) + LEFTDIGIT-OR-EXPT + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (return (make-integer))) + (case (char-class3 char attribute-table) + (#.+char-attr-constituent-digit+ (go LEFTDIGIT)) + (#.+char-attr-constituent-decimal-digit+ (bug "impossible!")) + (#.+char-attr-constituent-dot+ (go SYMBOL)) + (#.+char-attr-constituent-digit-or-expt+ (go LEFTDIGIT)) + (#.+char-attr-constituent-expt+ (go SYMBOL)) + (#.+char-attr-constituent-sign+ (go EXPTSIGN)) (#.+char-attr-constituent-slash+ (if possibly-rational (go RATIO) (go SYMBOL))) @@ -781,6 +825,23 @@ (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) (#.+char-attr-package-delimiter+ (go COLON)) (t (go SYMBOL))) + LEFTDECIMALDIGIT ; saw "[sign] {decimal-digit}+" + (aver possibly-float) + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (go RETURN-SYMBOL)) + (case (char-class char attribute-table) + (#.+char-attr-constituent-digit+ (go LEFTDECIMALDIGIT)) + (#.+char-attr-constituent-dot+ (go MIDDLEDOT)) + (#.+char-attr-constituent-expt+ (go EXPONENT)) + (#.+char-attr-constituent-slash+ (aver (not possibly-rational)) + (go SYMBOL)) + (#.+char-attr-delimiter+ (unread-char char stream) + (go RETURN-SYMBOL)) + (#.+char-attr-escape+ (go ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL))) MIDDLEDOT ; saw "[sign] {digit}+ dot" (ouch-read-buffer char) (setq char (read-char stream nil nil)) @@ -797,7 +858,7 @@ (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) (#.+char-attr-package-delimiter+ (go COLON)) (t (go SYMBOL))) - RIGHTDIGIT ; saw "[sign] {digit}* dot {digit}+" + RIGHTDIGIT ; saw "[sign] {decimal-digit}* dot {digit}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (make-float stream))) @@ -837,6 +898,7 @@ (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) + (setq possibly-float t) (case (char-class char attribute-table) (#.+char-attr-constituent-sign+ (go EXPTSIGN)) (#.+char-attr-constituent-digit+ (go EXPTDIGIT)) @@ -926,15 +988,15 @@ (#.+char-attr-package-delimiter+ (done-with-fast-read-char) (go COLON)) (t (go SYMBOL-LOOP))))) - ;; fundamental-stream + ;; CLOS stream (prog () SYMBOL-LOOP (ouch-read-buffer char) - (setq char (stream-read-char stream)) + (setq char (read-char stream nil :eof)) (when (eq char :eof) (go RETURN-SYMBOL)) (case (char-class char attribute-table) (#.+char-attr-escape+ (go ESCAPE)) - (#.+char-attr-delimiter+ (stream-unread-char stream char) + (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) (#.+char-attr-package-delimiter+ (go COLON)) @@ -956,6 +1018,7 @@ (#.+char-attr-package-delimiter+ (go COLON)) (t (go SYMBOL))) MULT-ESCAPE + (setq seen-multiple-escapes t) (do ((char (read-char stream t) (read-char stream t))) ((multiple-escape-p char)) (if (escapep char) (setq char (read-char stream t))) @@ -983,7 +1046,9 @@ ;; a FIND-PACKAGE* function analogous to INTERN* ;; and friends? (read-buffer-to-string) - *keyword-package*)) + (if seen-multiple-escapes + (read-buffer-to-string) + *keyword-package*))) (reset-read-buffer) (setq escapes ()) (setq char (read-char stream nil nil)) @@ -1207,49 +1272,10 @@ (#\F 'single-float) (#\D 'double-float) (#\L 'long-float))) - num) - ;; Raymond Toy writes: We need to watch out if the - ;; exponent is too small or too large. We add enough to - ;; EXPONENT to make it within range and scale NUMBER - ;; appropriately. This should avoid any unnecessary - ;; underflow or overflow problems. - (multiple-value-bind (min-expo max-expo) - ;; FIXME: These forms are broken w.r.t. - ;; cross-compilation portability, as the - ;; cross-compiler will call the host's LOG function - ;; while attempting to constant-fold. Maybe some sort - ;; of load-time-form magic could be used instead? - (case float-format - (short-float - (values - (log sb!xc:least-positive-normalized-short-float 10s0) - (log sb!xc:most-positive-short-float 10s0))) - (single-float - (values - (log sb!xc:least-positive-normalized-single-float 10f0) - (log sb!xc:most-positive-single-float 10f0))) - (double-float - (values - (log sb!xc:least-positive-normalized-double-float 10d0) - (log sb!xc:most-positive-double-float 10d0))) - (long-float - (values - (log sb!xc:least-positive-normalized-long-float 10L0) - (log sb!xc:most-positive-long-float 10L0)))) - (let ((correction (cond ((<= exponent min-expo) - (ceiling (- min-expo exponent))) - ((>= exponent max-expo) - (floor (- max-expo exponent))) - (t - 0)))) - (incf exponent correction) - (setf number (/ number (expt 10 correction))) - (setq num (make-float-aux number divisor float-format stream)) - (setq num (* num (expt 10 exponent))) - (return-from make-float (if negative-fraction - (- num) - num)))))) - ;; should never happen + (result (make-float-aux (* (expt 10 exponent) number) + divisor float-format stream))) + (return-from make-float + (if negative-fraction (- result) result)))) (t (bug "bad fallthrough in floating point reader"))))) (defun make-float-aux (number divisor float-format stream) @@ -1400,9 +1426,10 @@ and the lisp object built by the reader is returned. Macro chars will take effect." (declare (string string)) + (with-array-data ((string string) (start start) - (end (or end (length string)))) + (end (%check-vector-sequence-bounds string start end))) (unless *read-from-string-spares* (push (internal-make-string-input-stream "" 0 0) *read-from-string-spares*)) @@ -1429,9 +1456,9 @@ `(error 'simple-parse-error :format-control ,format-control :format-arguments (list string)))) - (with-array-data ((string string) + (with-array-data ((string string :offset-var offset) (start start) - (end (or end (length string)))) + (end (%check-vector-sequence-bounds string start end))) (let ((index (do ((i start (1+ i))) ((= i end) (if junk-allowed @@ -1458,10 +1485,10 @@ found-digit t)) (junk-allowed (return nil)) ((whitespacep char) - (do ((jndex (1+ index) (1+ jndex))) - ((= jndex end)) - (declare (fixnum jndex)) - (unless (whitespacep (char string jndex)) + (loop + (incf index) + (when (= index end) (return)) + (unless (whitespacep (char string index)) (parse-error "junk in string ~S"))) (return nil)) (t @@ -1473,7 +1500,7 @@ (if junk-allowed nil (parse-error "no digits in string ~S"))) - index))))) + (- index offset)))))) ;;;; reader initialization code