0.8.8.27:

	Fix for float reading with *READ-BASE* < 10 (part of the
	failures in PRINT.SINGLE-FLOAT.RANDOM et al. from PFD)
	... appropriate mysteriously-missing 9 entry for
		DECIMAL-DIGIT
	... some extra states in the tokenizer FSM
	... tests!

diff --git a/NEWS b/NEWS
index 0b1ee32..95c3d37 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -2354,6 +2354,8 @@ changes in sbcl-0.8.9 relative to sbcl-0.8.8:
        constitute a word.
     ** Printing the "Space" character with escaping on now yields "#\\ ", 
        rather than "#\\Space", as mandated by ANSI 22.1.3.2.
+    ** Reading floating-point numbers with *READ-BASE* set to a number
+       less than 10 works correctly.
 
 planned incompatible changes in 0.8.x:
   * (not done yet, but planned:) When the profiling interface settles

diff --git a/src/code/reader.lisp b/src/code/reader.lisp
index 92d8ee4..4980544 100644 (file)
--- a/src/code/reader.lisp
+++ b/src/code/reader.lisp
@@ -659,7 +659,7 @@
         (if (digit-char-p ,char (max *read-base* 10))
             (if (digit-char-p ,char *read-base*)
                 +char-attr-constituent-digit+
-                +char-attr-constituent+)
+                +char-attr-constituent-decimal-digit+)
             att))))
 \f
 ;;;; token fetching
@@ -743,6 +743,7 @@
       (case (char-class3 char attribute-table)
        (#.+char-attr-constituent-sign+ (go SIGN))
        (#.+char-attr-constituent-digit+ (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 +758,7 @@
            possibly-float t)
       (case (char-class3 char attribute-table)
        (#.+char-attr-constituent-digit+ (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))
@@ -769,6 +771,9 @@
       (unless char (return (make-integer)))
       (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)))
@@ -782,13 +787,36 @@
        (#.+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-class3 char attribute-table)
+       (#.+char-attr-constituent-digit+ (if possibly-float
+                                            (go LEFTDECIMALDIGIT)
+                                            (go SYMBOL)))
+       (#.+char-attr-constituent-decimal-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))
       (unless char (return (let ((*read-base* 10))
                             (make-integer))))
       (case (char-class char attribute-table)
-       (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
+       (#.+char-attr-constituent-digit+ (if possibly-float
+                                            (go RIGHTDIGIT)
+                                            (go SYMBOL)))
+       (#.+char-attr-constituent-decimal-digit+ (go RIGHTDIGIT))
        (#.+char-attr-constituent-expt+ (go EXPONENT))
        (#.+char-attr-delimiter+
         (unread-char char stream)
@@ -798,12 +826,15 @@
        (#.+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)))
       (case (char-class char attribute-table)
-       (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
+       (#.+char-attr-constituent-digit+ (if possibly-float
+                                            (go RIGHTDIGIT)
+                                            (go SYMBOL)))
+       (#.+char-attr-constituent-decimal-digit+ (go RIGHTDIGIT))
        (#.+char-attr-constituent-expt+ (go EXPONENT))
        (#.+char-attr-delimiter+
         (unread-char char stream)
@@ -817,7 +848,10 @@
       (setq char (read-char stream nil nil))
       (unless char (go RETURN-SYMBOL))
       (case (char-class char attribute-table)
-       (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
+       (#.+char-attr-constituent-digit+ (if possibly-float
+                                            (go RIGHTDIGIT)
+                                            (go SYMBOL)))
+       (#.+char-attr-constituent-decimal-digit+ (go RIGHTDIGIT))
        (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
        (#.+char-attr-escape+ (go ESCAPE))
        (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
@@ -827,7 +861,10 @@
       (setq char (read-char stream nil nil))
       (unless char (%reader-error stream "dot context error"))
       (case (char-class char attribute-table)
-       (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
+       (#.+char-attr-constituent-digit+ (if possibly-float
+                                            (go RIGHTDIGIT)
+                                            (go SYMBOL)))
+       (#.+char-attr-constituent-decimal-digit+ (go RIGHTDIGIT))
        (#.+char-attr-constituent-dot+ (go DOTS))
        (#.+char-attr-delimiter+  (%reader-error stream "dot context error"))
        (#.+char-attr-escape+ (go ESCAPE))
@@ -838,9 +875,13 @@
       (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))
+       (#.+char-attr-constituent-digit+ (if possibly-float
+                                            (go EXPTDIGIT)
+                                            (go SYMBOL)))
+       (#.+char-attr-constituent-decimal-digit+ (go EXPTDIGIT))
        (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
        (#.+char-attr-escape+ (go ESCAPE))
        (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
@@ -851,7 +892,10 @@
       (setq char (read-char stream nil nil))
       (unless char (go RETURN-SYMBOL))
       (case (char-class char attribute-table)
-       (#.+char-attr-constituent-digit+ (go EXPTDIGIT))
+       (#.+char-attr-constituent-digit+ (if possibly-float
+                                            (go EXPTDIGIT)
+                                            (go SYMBOL)))
+       (#.+char-attr-constituent-decimal-digit+ (go EXPTDIGIT))
        (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
        (#.+char-attr-escape+ (go ESCAPE))
        (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
@@ -862,7 +906,10 @@
       (setq char (read-char stream nil nil))
       (unless char (return (make-float stream)))
       (case (char-class char attribute-table)
-       (#.+char-attr-constituent-digit+ (go EXPTDIGIT))
+       (#.+char-attr-constituent-digit+ (if possibly-float
+                                            (go EXPTDIGIT)
+                                            (go SYMBOL)))
+       (#.+char-attr-constituent-decimal-digit+ (go EXPTDIGIT))
        (#.+char-attr-delimiter+
         (unread-char char stream)
         (return (make-float stream)))

diff --git a/src/code/readtable.lisp b/src/code/readtable.lisp
index 3764b16..ee4dd7a 100644 (file)
--- a/src/code/readtable.lisp
+++ b/src/code/readtable.lisp
@@ -26,6 +26,9 @@
 (def!constant +char-attr-constituent-digit+ 7)
 (def!constant +char-attr-constituent-sign+ 8)
 ;; the "9" entry intentionally left blank for some reason -- WHN 19990806
+;;
+;; appropriated by CSR 2004-03-16
+(def!constant +char-attr-constituent-decimal-digit+ 9)
 (def!constant +char-attr-multiple-escape+ 10)
 (def!constant +char-attr-package-delimiter+ 11)
 (def!constant +char-attr-delimiter+ 12) ; (a fake for READ-UNQUALIFIED-TOKEN)

diff --git a/tests/reader.pure.lisp b/tests/reader.pure.lisp
index 33af266..268d77e 100644 (file)
--- a/tests/reader.pure.lisp
+++ b/tests/reader.pure.lisp
@@ -107,3 +107,64 @@
   (assert (equal (multiple-value-list
                   (parse-integer string))
                  '(123 6))))
+
+(let ((*read-base* *read-base*))
+  (dolist (float-string '(".9" ".9e9" ".9e+9" ".9e-9"
+                         "-.9" "-.9e9" "-.9e+9" "-.9e-9"
+                         "+.9" "+.9e9" "+.9e+9" "+.9e-9"
+                         "0.9" "0.9e9" "0.9e+9" "0.9e-9"
+                         "9.09" "9.09e9" "9.09e+9" "9.09e-9"
+                         "9e9" "9e+9" "9e-9"))
+    (loop for i from 2 to 36
+         do (setq *read-base* i)
+         do (assert (typep (read-from-string float-string)
+                           *read-default-float-format*))
+         do (assert (typep
+                     (read-from-string (substitute #\E #\e float-string))
+                     *read-default-float-format*))
+         if (position #\e float-string)
+         do (assert (typep
+                     (read-from-string (substitute #\s #\e float-string))
+                     'short-float))
+         and do (assert (typep
+                         (read-from-string (substitute #\S #\e float-string))
+                         'short-float))
+         and do (assert (typep
+                         (read-from-string (substitute #\f #\e float-string))
+                         'single-float))
+         and do (assert (typep
+                         (read-from-string (substitute #\F #\e float-string))
+                         'single-float))
+         and do (assert (typep
+                         (read-from-string (substitute #\d #\e float-string))
+                         'double-float))
+         and do (assert (typep
+                         (read-from-string (substitute #\D #\e float-string))
+                         'double-float))
+         and do (assert (typep
+                         (read-from-string (substitute #\d #\e float-string))
+                         'long-float))
+         and do (assert (typep
+                         (read-from-string (substitute #\D #\e float-string))
+                         'long-float)))))
+
+(let ((*read-base* *read-base*))
+  (dolist (integer-string '("1." "2." "3." "4." "5." "6." "7." "8." "9." "0."))
+    (loop for i from 2 to 36
+         do (setq *read-base* i)
+         do (assert (typep (read-from-string integer-string) 'integer)))))
+
+(let ((*read-base* *read-base*))
+  (dolist (symbol-string '("A." "a." "Z." "z."
+                          
+                          "+.9eA" "+.9ea"
+                          
+                          "0.A" "0.a" "0.Z" "0.z"
+
+                          "9eA" "9ea" "9e+A" "9e+a" "9e-A" "9e-a"
+                          "Ae9" "ae9" "Ae+9" "ae+9" "Ae-9" "ae-9"
+                          
+                          "A.0" "A.0e10" "a.0" "a.0e10"))
+    (loop for i from 2 to 36
+         do (setq *read-base* i)
+         do (assert (typep (read-from-string symbol-string) 'symbol)))))

diff --git a/version.lisp-expr b/version.lisp-expr
index 1efb96d..500acb2 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.8.26"
+"0.8.8.27"