0.8.9.45:

[sbcl.git] / src / code / reader.lisp

diff --git a/src/code/reader.lisp b/src/code/reader.lisp
index 3ec1059..7fc9cd1 100644 (file)
--- 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+))
@@ -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))))
 \f
 ;;;; token fetching
@@ -735,7 +737,9 @@
        (package-designator nil)
        (colons 0)
        (possibly-rational t)
+       (seen-digit-or-expt nil)
        (possibly-float t)
+       (was-possibly-float nil)
        (escapes ())
        (seen-multiple-escapes nil))
     (reset-read-buffer)
@@ -743,6 +747,10 @@
       (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))
@@ -757,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))
@@ -767,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)))
@@ -782,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))
@@ -798,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)))
@@ -838,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))
@@ -927,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))