0.9.15.35: fix CONS :SIMPLE-= method

 * The failure is uncertain if both types may be the empty type
   in disguise.
 * Tests.

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 8a6e01f..aaf4213 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -2970,11 +2970,23 @@ used for a COMPLEX component.~:@>"
 
 (!define-type-method (cons :simple-=) (type1 type2)
   (declare (type cons-type type1 type2))
-  (multiple-value-bind (match win)
+  (multiple-value-bind (car-match car-win)
       (type= (cons-type-car-type type1) (cons-type-car-type type2))
-    (if (and match win)
+    (multiple-value-bind (cdr-match cdr-win)
         (type= (cons-type-cdr-type type1) (cons-type-cdr-type type2))
-        (values nil win))))
+      (cond ((and car-match cdr-match)
+             (aver (and car-win cdr-win))
+             (values t t))
+            (t
+             (values nil
+                     ;; FIXME: Ideally we would like to detect and handle
+                     ;;  (CONS UNKNOWN INTEGER) (CONS UNKNOWN SYMBOL) => NIL, T
+                     ;; but just returning a secondary true on (and car-win cdr-win)
+                     ;; unfortunately breaks other things. --NS 2006-08-16
+                     (and (or (and (not car-match) car-win)
+                              (and (not cdr-match) cdr-win))
+                          (not (and (cons-type-might-be-empty-type type1)
+                                    (cons-type-might-be-empty-type type2))))))))))
 
 (!define-type-method (cons :simple-subtypep) (type1 type2)
   (declare (type cons-type type1 type2))

diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp
index 198fc61..bdd3ef7 100644 (file)
--- a/src/code/run-program.lisp
+++ b/src/code/run-program.lisp
@@ -845,28 +845,28 @@ Common Lisp Users Manual for details about the PROCESS structure.
                             (when (< handle 0)\r
                               (error "Couldn't spawn program: ~A" (strerror)))\r
                             (setf proc\r
-                                 (if wait \r
-                                     (make-process :pid handle\r
-                                                   :%status :exited\r
-                                                   :input input-stream\r
-                                                   :output output-stream\r
-                                                   :error error-stream\r
-                                                   :status-hook status-hook\r
-                                                   :cookie cookie\r
-                                                   :exit-code handle)\r
-                                     (make-process :pid handle\r
-                                                   :%status :running\r
-                                                   :input input-stream\r
-                                                   :output output-stream\r
-                                                   :error error-stream\r
-                                                   :status-hook status-hook\r
-                                                   :cookie cookie)))\r
-                           (push proc *active-processes*)))))))\r
+                                  (if wait \r
+                                      (make-process :pid handle\r
+                                                    :%status :exited\r
+                                                    :input input-stream\r
+                                                    :output output-stream\r
+                                                    :error error-stream\r
+                                                    :status-hook status-hook\r
+                                                    :cookie cookie\r
+                                                    :exit-code handle)\r
+                                      (make-process :pid handle\r
+                                                    :%status :running\r
+                                                    :input input-stream\r
+                                                    :output output-stream\r
+                                                    :error error-stream\r
+                                                    :status-hook status-hook\r
+                                                    :cookie cookie)))\r
+                            (push proc *active-processes*)))))))\r
       (dolist (fd *close-in-parent*)\r
-       (sb-unix:unix-close fd)))\r
+        (sb-unix:unix-close fd)))\r
     (unless proc\r
       (dolist (fd *close-on-error*)\r
-       (sb-unix:unix-close fd)))\r
+        (sb-unix:unix-close fd)))\r
 \r
     proc))\r
 \r
@@ -966,7 +966,7 @@ Common Lisp Users Manual for details about the PROCESS structure.
                                 #o666)\r
            (unless fd\r
              (error #-win32 "~@<couldn't open \"/dev/null\": ~2I~_~A~:>"\r
-                   #+win32 "~@<couldn't open \"nul\" device: ~2I~_~A~:>"\r
+                    #+win32 "~@<couldn't open \"nul\" device: ~2I~_~A~:>"\r
                     (strerror errno)))\r
            (push fd *close-in-parent*)\r
            (values fd nil)))\r

diff --git a/tests/mop-23.impure.lisp b/tests/mop-23.impure.lisp
index 04d9cf5..8080afe 100644 (file)
--- a/tests/mop-23.impure.lisp
+++ b/tests/mop-23.impure.lisp
@@ -54,8 +54,8 @@
                                   '(4 nil))))
                  "Called a method!Called a method!"))
 
-(defclass super () 
-  ((b :initform 3) 
+(defclass super ()
+  ((b :initform 3)
    (a :initarg :a)))
 
 (assert (string= (with-output-to-string (*trace-output*)

diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp
index 1ab5a2c..bf0bd45 100644 (file)
--- a/tests/type.impure.lisp
+++ b/tests/type.impure.lisp
@@ -500,4 +500,27 @@
   (setf (find-class 'to-be-type-ofed) nil)
   (assert (eq (type-of (make-instance class)) class)))
 \f
+;;; accuracy of CONS :SIMPLE-TYPE-=
+(deftype goldbach-1 () '(satisfies even-and-greater-then-two-p))
+(deftype goldbach-2 () ' (satisfies sum-of-two-primes-p))
+
+(multiple-value-bind (ok win)
+    (sb-kernel:type= (sb-kernel:specifier-type '(cons goldbach1 integer))
+                     (sb-kernel:specifier-type '(cons goldbach1 integer)))
+  (assert ok)
+  (assert win))
+
+;; See FIXME in type method for CONS :SIMPLE-TYPE-=
+#+nil 
+(multiple-value-bind (ok win)
+    (sb-kernel:type= (sb-kernel:specifier-type '(cons goldbach1 integer))
+                     (sb-kernel:specifier-type '(cons goldbach1 single-float)))
+  (assert (not ok))
+  (assert win))
+
+(multiple-value-bind (ok win)
+    (sb-kernel:type= (sb-kernel:specifier-type '(cons goldbach1 integer))
+                     (sb-kernel:specifier-type '(cons goldbach2 single-float)))
+  (assert (not ok))
+  (assert (not win)))
 ;;; success

diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp
index f92c3b7..af467d7 100644 (file)
--- a/tests/type.pure.lisp
+++ b/tests/type.pure.lisp
@@ -332,11 +332,11 @@ ACTUAL ~D DERIVED ~D~%"
    (sb-kernel:specifier-type '(simple-array an-unkown-type (8))))))
 
 (assert
- (sb-kernel:type/= (sb-kernel:specifier-type 'cons) 
+ (sb-kernel:type/= (sb-kernel:specifier-type 'cons)
                    (sb-kernel:specifier-type '(cons single-float single-float))))
 
 (multiple-value-bind (match win)
-    (sb-kernel:type= (sb-kernel:specifier-type '(cons integer)) 
+    (sb-kernel:type= (sb-kernel:specifier-type '(cons integer))
                      (sb-kernel:specifier-type '(cons)))
   (assert (and (not match) win)))
 

diff --git a/version.lisp-expr b/version.lisp-expr
index ff5a94d..2090cab 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.9.15.34"
+"0.9.15.35"