0.8.16.30:

	Fix PFD ansi-tests REAL.1 and REAL.2.
	... Ow my eyes!  Assorted horribleness.

diff --git a/NEWS b/NEWS
index 8ea62bf..6c17834 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -49,6 +49,8 @@ changes in sbcl-0.8.17 relative to sbcl-0.8.16:
        complaint.
     ** Case-altering FORMAT directives work correctly on non-ASCII
        characters.
+    ** The REAL type specifier handles bounds outside the floating
+       point ranges without signalling FLOATING-POINT-OVERFLOW.
 
 changes in sbcl-0.8.16 relative to sbcl-0.8.15:
   * enhancement: saving cores with foreign code loaded is now

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index e6f9931..341ff51 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -1820,38 +1820,92 @@
 ;;; FIXME: It's probably necessary to do something to fix the
 ;;; analogous problem with INTEGER and RATIONAL types. Perhaps
 ;;; bounded RATIONAL types should be represented as (OR RATIO INTEGER).
-(defun coerce-bound (bound type inner-coerce-bound-fun)
+(defun coerce-bound (bound type upperp inner-coerce-bound-fun)
   (declare (type function inner-coerce-bound-fun))
-  (cond ((eql bound '*)
-        bound)
-       ((consp bound)
-        (destructuring-bind (inner-bound) bound
-          (list (funcall inner-coerce-bound-fun inner-bound type))))
-       (t
-        (funcall inner-coerce-bound-fun bound type))))
-(defun inner-coerce-real-bound (bound type)
-  (ecase type
-    (rational (rationalize bound))
-    (float (if (floatp bound)
-              bound
-              ;; Coerce to the widest float format available, to
-              ;; avoid unnecessary loss of precision:
-              (coerce bound 'long-float)))))
-(defun coerced-real-bound (bound type)
-  (coerce-bound bound type #'inner-coerce-real-bound))
-(defun coerced-float-bound (bound type)
-  (coerce-bound bound type #'coerce))
+  (if (eql bound '*)
+      bound
+      (funcall inner-coerce-bound-fun bound type upperp)))
+(defun inner-coerce-real-bound (bound type upperp)
+  #+sb-xc-host (declare (ignore upperp))
+  (let #+sb-xc-host ()
+       #-sb-xc-host
+       ((nl (load-time-value (symbol-value 'sb!xc:most-negative-long-float)))
+        (pl (load-time-value (symbol-value 'sb!xc:most-positive-long-float))))
+    (let ((nbound (if (consp bound) (car bound) bound))
+          (consp (consp bound)))
+      (ecase type
+        (rational
+         (if consp
+             (list (rational nbound))
+             (rational nbound)))
+        (float
+         (cond
+           ((floatp nbound) bound)
+           (t
+            ;; Coerce to the widest float format available, to avoid
+            ;; unnecessary loss of precision, but don't coerce
+            ;; unrepresentable numbers, except on the host where we
+            ;; shouldn't be making these types (but KLUDGE: can't even
+            ;; assert portably that we're not).
+            #-sb-xc-host
+            (ecase upperp
+              ((nil)
+               (when (< nbound nl) (return-from inner-coerce-real-bound nl)))
+              ((t)
+               (when (> nbound pl) (return-from inner-coerce-real-bound pl))))
+            (let ((result (coerce nbound 'long-float)))
+              (if consp (list result) result)))))))))
+(defun inner-coerce-float-bound (bound type upperp)
+  #+sb-xc-host (declare (ignore upperp))
+  (let #+sb-xc-host ()
+       #-sb-xc-host
+       ((nd (load-time-value (symbol-value 'sb!xc:most-negative-double-float)))
+        (pd (load-time-value (symbol-value 'sb!xc:most-positive-double-float)))
+        (ns (load-time-value (symbol-value 'sb!xc:most-negative-single-float)))
+        (ps (load-time-value
+             (symbol-value 'sb!xc:most-positive-single-float))))
+    (let ((nbound (if (consp bound) (car bound) bound))
+          (consp (consp bound)))
+      (ecase type
+        (single-float
+         (cond
+           ((typep nbound 'single-float) bound)
+           (t
+            #-sb-xc-host
+            (ecase upperp
+              ((nil)
+               (when (< nbound ns) (return-from inner-coerce-float-bound ns)))
+              ((t)
+               (when (> nbound ps) (return-from inner-coerce-float-bound ps))))
+            (let ((result (coerce nbound 'single-float)))
+              (if consp (list result) result)))))
+        (double-float
+         (cond
+           ((typep nbound 'double-float) bound)
+           (t
+            #-sb-xc-host
+            (ecase upperp
+              ((nil)
+               (when (< nbound nd) (return-from inner-coerce-float-bound nd)))
+              ((t)
+               (when (> nbound pd) (return-from inner-coerce-float-bound pd))))
+            (let ((result (coerce nbound 'double-float)))
+              (if consp (list result) result)))))))))
+(defun coerced-real-bound (bound type upperp)
+  (coerce-bound bound type upperp #'inner-coerce-real-bound))
+(defun coerced-float-bound (bound type upperp)
+  (coerce-bound bound type upperp #'inner-coerce-float-bound))
 (!def-type-translator real (&optional (low '*) (high '*))
-  (specifier-type `(or (float ,(coerced-real-bound  low 'float)
-                             ,(coerced-real-bound high 'float))
-                      (rational ,(coerced-real-bound  low 'rational)
-                                ,(coerced-real-bound high 'rational)))))
+  (specifier-type `(or (float ,(coerced-real-bound  low 'float nil)
+                             ,(coerced-real-bound high 'float t))
+                      (rational ,(coerced-real-bound  low 'rational nil)
+                                ,(coerced-real-bound high 'rational t)))))
 (!def-type-translator float (&optional (low '*) (high '*))
   (specifier-type 
-   `(or (single-float ,(coerced-float-bound  low 'single-float)
-                     ,(coerced-float-bound high 'single-float))
-       (double-float ,(coerced-float-bound  low 'double-float)
-                     ,(coerced-float-bound high 'double-float))
+   `(or (single-float ,(coerced-float-bound  low 'single-float nil)
+                     ,(coerced-float-bound high 'single-float t))
+       (double-float ,(coerced-float-bound  low 'double-float nil)
+                     ,(coerced-float-bound high 'double-float t))
        #!+long-float ,(error "stub: no long float support yet"))))
 
 (defmacro !define-float-format (f)

diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp
index 1bd07f4..23e5850 100644 (file)
--- a/tests/type.pure.lisp
+++ b/tests/type.pure.lisp
@@ -219,3 +219,9 @@
                (subtypep '(complex (integer 1 2))
                          '(member #c(1 1) #c(1 2) #c(2 1) #c(2 2))))
               '(nil t)))
+
+(assert (typep 0 '(real #.(ash -1 10000) #.(ash 1 10000))))
+(assert (subtypep '(real #.(ash -1 1000) #.(ash 1 1000))
+                  '(real #.(ash -1 10000) #.(ash 1 10000))))
+(assert (subtypep '(real (#.(ash -1 1000)) (#.(ash 1 1000)))
+                  '(real #.(ash -1 1000) #.(ash 1 1000))))

diff --git a/version.lisp-expr b/version.lisp-expr
index e3357b7..3261ba3 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.16.29"
+"0.8.16.30"