0.7.9.1:

        * Added #+cmu(ext:quit) to build scripts
        * Fixed SIMPLE-SUBTYPEP type method for FUNCTIONs

diff --git a/BUGS b/BUGS
index 0df09bc..36986f9 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -1354,7 +1354,7 @@ WORKAROUND:
   the bad VECTOR-PUSH-EXTEND frame causes GC problems, though that may
   not be the actual problem. (CMU CL 18c doesn't have problems with this.)
 
-217:
+217: "Bad type operations with FUNCTION types"
   In sbcl.0.7.7:
 
     * (values-type-union (specifier-type '(function (base-char)))
@@ -1362,6 +1362,24 @@ WORKAROUND:
 
     #<FUN-TYPE (FUNCTION (BASE-CHAR) *)>
 
+  It causes insertion of wrong type assertions into generated
+  code. E.g.
+
+    (defun foo (x s)
+      (let ((f (etypecase x
+                 (character #'write-char)
+                 (integer #'write-byte))))
+        (funcall f x s)
+        (etypecase x
+          (character (write-char x s))
+          (integer (write-byte x s)))))
+
+   Then (FOO #\1 *STANDARD-OUTPUT*) signals type error.
+
+  (In 0.7.9.1 the result type is (FUNCTION * *), so Python does not
+  produce invalid code, but type checking is not accurate. Similar
+  problems exist with VALUES-TYPE-INTERSECTION.)
+
 
 DEFUNCT CATEGORIES OF BUGS
   IR1-#:

diff --git a/make-genesis-2.sh b/make-genesis-2.sh
index 620e680..551a34f 100644 (file)
--- a/make-genesis-2.sh
+++ b/make-genesis-2.sh
@@ -50,6 +50,7 @@ $SBCL_XC_HOST <<-'EOF' || exit 1
                       ;; The map file is not needed by the system, but can
                       ;; be very handy when debugging cold init problems.
                       :map-file-name "output/cold-sbcl.map")
+        #+cmu (ext:quit)
        EOF
 
 echo //testing for consistency of first and second GENESIS passes

diff --git a/make-host-1.sh b/make-host-1.sh
index 82ca185..6bbe840 100644 (file)
--- a/make-host-1.sh
+++ b/make-host-1.sh
@@ -44,4 +44,5 @@ $SBCL_XC_HOST <<-'EOF' || exit 1
          (load "tests/info.before-xc.lisp"))
         (host-cload-stem "src/compiler/generic/genesis")
        (sb!vm:genesis :c-header-file-name "src/runtime/sbcl.h")
+        #+cmu (ext:quit)
        EOF

diff --git a/make-host-2.sh b/make-host-2.sh
index 5d0fdf1..e3c4f3f 100644 (file)
--- a/make-host-2.sh
+++ b/make-host-2.sh
@@ -123,6 +123,7 @@ $SBCL_XC_HOST <<-'EOF' || exit 1
           #+cmu (ext:save-lisp "output/after-xc.core" :load-init-file nil)
           #+sbcl (sb-ext:save-lisp-and-die "output/after-xc.core")
          )
+        #+cmu (ext:quit)
        EOF
 
 # Run GENESIS (again) in order to create cold-sbcl.core. (The first

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 171ad65..70ccba2 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -69,7 +69,7 @@
   ;; If TYPE2 might be concealing something related to our class
   ;; hierarchy
   (if (type-might-contain-other-types-p type2)
-      ;; too confusing, gotta punt 
+      ;; too confusing, gotta punt
       (values nil nil)
       ;; ordinary case expected by old CMU CL code, where the taxonomy
       ;; of TYPE2's representation accurately reflects the taxonomy of
@@ -216,8 +216,45 @@
 ;;; Since all function types are equivalent to FUNCTION, they are all
 ;;; subtypes of each other.
 (!define-type-method (function :simple-subtypep) (type1 type2)
-  (declare (ignore type1 type2))
-  (values t t))
+   (flet ((fun-type-simple-p (type)
+            (not (or (fun-type-rest type)
+                     (fun-type-keyp type))))
+          (every-csubtypep (types1 types2)
+            (loop
+               for a1 in types1
+               for a2 in types2
+               do (multiple-value-bind (res sure-p)
+                      (csubtypep a1 a2)
+                    (unless res (return (values res sure-p))))
+               finally (return (values t t)))))
+     (macrolet ((3and (x y)
+                  `(multiple-value-bind (val1 win1)
+                       ,x
+                     (if (and (not val1) win1)
+                         (values nil t)
+                         (multiple-value-bind (val2 win2)
+                             ,y
+                           (if (and val1 val2)
+                               (values t t)
+                               (values nil (or win1 win2))))))))
+       (3and (csubtypep (fun-type-returns type1)
+                        (fun-type-returns type2))
+             (cond ((fun-type-wild-args type2)
+                    (values t t))
+                   ((fun-type-wild-args type1)
+                    (values nil t))
+                   ((not (or (fun-type-simple-p type1)
+                             (fun-type-simple-p type2)))
+                    (values nil nil))
+                   ((not (and (= (length (fun-type-required type1))
+                                 (length (fun-type-required type2)))
+                              (= (length (fun-type-optional type1))
+                                 (length (fun-type-optional type2)))))
+                    (values nil t))
+                   (t (3and (every-csubtypep (fun-type-required type1)
+                                             (fun-type-required type2))
+                            (every-csubtypep (fun-type-optional type1)
+                                             (fun-type-optional type2)))))))))
 
 (!define-superclasses function ((function)) !cold-init-forms)
 

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index ea565bf..f128f15 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -555,6 +555,18 @@ BUG 48c, not yet fixed:
     (assert failure-p)
     (assert (raises-error? (funcall result) program-error))))
 
+;;; bug 217: wrong type inference
+(defun bug217-1 (x s)
+  (let ((f (etypecase x
+             (character #'write-char)
+             (integer #'write-byte))))
+    (funcall f x s)
+    (etypecase x
+      (character (write-char x s))
+      (integer (write-byte x s)))))
+
+(bug217-1 #\1 *standard-output*)
+
 \f
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself

diff --git a/version.lisp-expr b/version.lisp-expr
index 69c1d34..a5363bb 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.9"
+"0.7.9.1"