0.8.1.32:

        * Condition slot accessor installer: call
          ENSURE-GENERIC-FUNCTION;
        * fixed type method (VALUES :SIMPLE-=);
        * SB-C::DOMAIN-SUBTYPEP: merged patch by DTC 1999/01/23.

diff --git a/src/code/late-condition.lisp b/src/code/late-condition.lisp
index 2aa8921..7070f60 100644 (file)
--- a/src/code/late-condition.lisp
+++ b/src/code/late-condition.lisp
@@ -14,8 +14,12 @@
 (fmakunbound 'install-condition-slot-reader)
 (fmakunbound 'install-condition-slot-writer)
 (defun install-condition-slot-reader (name condition slot-name)
+  (unless (fboundp name)
+    (ensure-generic-function name :lambda-list '(condition)))
   (eval `(defmethod ,name ((.condition. ,condition))
            (condition-reader-function .condition. ',slot-name))))
 (defun install-condition-slot-writer (name condition slot-name)
+  (unless (fboundp name)
+    (ensure-generic-function name :lambda-list '(new-value condition)))
   (eval `(defmethod ,name (new-value (.condition. ,condition))
            (condition-writer-function .condition. new-value ',slot-name))))

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index d0a2938..cd1a796 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -182,20 +182,7 @@
        (return (values nil t))))))
 
 (!define-type-method (values :simple-=) (type1 type2)
-  (let ((rest1 (args-type-rest type1))
-       (rest2 (args-type-rest type2)))
-    (cond ((and rest1 rest2 (type/= rest1 rest2))
-          (type= rest1 rest2))
-         ((or rest1 rest2)
-          (values nil t))
-         (t
-          (multiple-value-bind (req-val req-win)
-              (type=-list (values-type-required type1)
-                          (values-type-required type2))
-            (multiple-value-bind (opt-val opt-win)
-                (type=-list (values-type-optional type1)
-                            (values-type-optional type2))
-              (values (and req-val opt-val) (and req-win opt-win))))))))
+  (type=-args type1 type2))
 
 (!define-type-class function)
 
@@ -327,32 +314,7 @@
                      (values nil t))
                     ((eq (fun-type-wild-args type1) t)
                      (values t t))
-                    (t (and/type
-                        (cond ((null (fun-type-rest type1))
-                               (values (null (fun-type-rest type2)) t))
-                              ((null (fun-type-rest type2))
-                               (values nil t))
-                              (t
-                               (compare type= rest)))
-                        (labels ((type-list-= (l1 l2)
-                                   (cond ((null l1)
-                                          (values (null l2) t))
-                                         ((null l2)
-                                          (values nil t))
-                                         (t (multiple-value-bind (res winp)
-                                                (type= (first l1) (first l2))
-                                              (cond ((not winp)
-                                                     (values nil nil))
-                                                    ((not res)
-                                                     (values nil t))
-                                                    (t
-                                                     (type-list-= (rest l1)
-                                                                  (rest l2)))))))))
-                          (and/type (and/type (compare type-list-= required)
-                                              (compare type-list-= optional))
-                              (if (or (fun-type-keyp type1) (fun-type-keyp type2))
-                                  (values nil nil)
-                                  (values t t))))))))))
+                    (t (type=-args type1 type2))))))
 
 (!define-type-class constant :inherits values)
 
@@ -627,6 +589,23 @@
                               :rest rest)
             exactp)))
 
+(defun type=-args (type1 type2)
+  (macrolet ((compare (comparator field)
+               (let ((reader (symbolicate '#:args-type- field)))
+                 `(,comparator (,reader type1) (,reader type2)))))
+    (and/type
+     (cond ((null (args-type-rest type1))
+            (values (null (args-type-rest type2)) t))
+           ((null (args-type-rest type2))
+            (values nil t))
+           (t
+            (compare type= rest)))
+     (and/type (and/type (compare type=-list required)
+                         (compare type=-list optional))
+               (if (or (args-type-keyp type1) (args-type-keyp type2))
+                   (values nil nil)
+                   (values t t))))))
+
 ;;; Do a union or intersection operation on types that might be values
 ;;; types. The result is optimized for utility rather than exactness,
 ;;; but it is guaranteed that it will be no smaller (more restrictive)

diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp
index 4a1f65f..ddf35ed 100644 (file)
--- a/src/code/target-type.lisp
+++ b/src/code/target-type.lisp
@@ -159,7 +159,8 @@
                   values-subtypep-cache-clear
                   csubtypep-cache-clear
                   type-intersection2-cache-clear
-                  values-type-intersection-cache-clear))
+                  values-type-intersection-cache-clear
+                   type=-cache-clear))
       (funcall (the function (symbol-function sym)))))
   (values))
 

diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
index 9ddb5aa..972a954 100644 (file)
--- a/src/compiler/float-tran.lisp
+++ b/src/compiler/float-tran.lisp
@@ -561,34 +561,27 @@
     (when (and arg-lo (floatp arg-lo-val) (zerop arg-lo-val) (consp arg-lo)
               (minusp (float-sign arg-lo-val)))
       (compiler-notify "float zero bound ~S not correctly canonicalized?" arg-lo)
-      (setq arg-lo '(0e0) arg-lo-val 0e0))
+      (setq arg-lo 0e0 arg-lo-val arg-lo))
     (when (and arg-hi (zerop arg-hi-val) (floatp arg-hi-val) (consp arg-hi)
               (plusp (float-sign arg-hi-val)))
       (compiler-notify "float zero bound ~S not correctly canonicalized?" arg-hi)
-      (setq arg-hi `(,(ecase *read-default-float-format*
-                       (double-float (load-time-value (make-unportable-float :double-float-negative-zero)))
-                       #!+long-float
-                       (long-float (load-time-value (make-unportable-float :long-float-negative-zero)))))
-           arg-hi-val (ecase *read-default-float-format*
-                        (double-float (load-time-value (make-unportable-float :double-float-negative-zero)))
-                        #!+long-float
-                        (long-float (load-time-value (make-unportable-float :long-float-negative-zero))))))
-    (and (or (null domain-low)
-            (and arg-lo (>= arg-lo-val domain-low)
-                 (not (and (zerop domain-low) (floatp domain-low)
-                           (plusp (float-sign domain-low))
-                           (zerop arg-lo-val) (floatp arg-lo-val)
-                           (if (consp arg-lo)
-                               (plusp (float-sign arg-lo-val))
-                               (minusp (float-sign arg-lo-val)))))))
-        (or (null domain-high)
-            (and arg-hi (<= arg-hi-val domain-high)
-                 (not (and (zerop domain-high) (floatp domain-high)
-                           (minusp (float-sign domain-high))
-                           (zerop arg-hi-val) (floatp arg-hi-val)
-                           (if (consp arg-hi)
-                               (minusp (float-sign arg-hi-val))
-                               (plusp (float-sign arg-hi-val))))))))))
+      (setq arg-hi (ecase *read-default-float-format*
+                     (double-float (load-time-value (make-unportable-float :double-float-negative-zero)))
+                     #!+long-float
+                     (long-float (load-time-value (make-unportable-float :long-float-negative-zero))))
+           arg-hi-val arg-hi))
+    (flet ((fp-neg-zero-p (f)           ; Is F -0.0?
+            (and (floatp f) (zerop f) (minusp (float-sign f))))
+          (fp-pos-zero-p (f)           ; Is F +0.0?
+            (and (floatp f) (zerop f) (plusp (float-sign f)))))
+      (and (or (null domain-low)
+               (and arg-lo (>= arg-lo-val domain-low)
+                    (not (and (fp-pos-zero-p domain-low)
+                             (fp-neg-zero-p arg-lo)))))
+           (or (null domain-high)
+               (and arg-hi (<= arg-hi-val domain-high)
+                    (not (and (fp-neg-zero-p domain-high)
+                             (fp-pos-zero-p arg-hi)))))))))
 (eval-when (:compile-toplevel :execute)
   (setf *read-default-float-format* 'single-float))
 

diff --git a/version.lisp-expr b/version.lisp-expr
index ac4f6d1..38c70fc 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.1.31"
+"0.8.1.32"