0.9.10.24:

	Fix (I think) the %INSTANCE-REF build problems on PPC and
	probably SPARC.
	... the CTYPE-OF failure came about because the system didn't
		know that (AND INSTANCE FUNCTION) was NIL.  Make it
		so...
	... and then delete a stale KLUDGE workaround in primtype.lisp
	... this then built as far as stream.lisp, where the problem
		was that (AND INSTANCE STREAM) was being "simplified"
		to just STREAM, and then primtype didn't know that
		STREAMs are subtypes of INSTANCE...
	... which in fact they're not; CLOS allows us to construct
		funcallable streams.  So...
	... instead teach the system that (AND INSTANCE STREAM)
		shouldn't be simplified...
	... but (AND INSTANCE FD-STREAM) should.
	... (also delete some crufty classoids: BASIC-STRUCTURE-CLASS
		and FUNCALLABLE-STRUCTURE-CLASS were never used)
	... tests for all the failing things in type.{before,after}-xc

diff --git a/src/code/class.lisp b/src/code/class.lisp
index c19e3fb..8682721 100644 (file)
--- a/src/code/class.lisp
+++ b/src/code/class.lisp
@@ -677,29 +677,13 @@
   ;; during cold-load.
   (translation nil :type (or ctype (member nil :initializing))))
 
-;;; FIXME: In CMU CL, this was a class with a print function, but not
-;;; necessarily a structure class (e.g. CONDITIONs). In SBCL,
-;;; we let CLOS handle our print functions, so that is no longer needed.
-;;; Is there any need for this class any more?
-(def!struct (slot-classoid (:include classoid)
-                           (:constructor nil)))
-
 ;;; STRUCTURE-CLASS represents what we need to know about structure
 ;;; classes. Non-structure "typed" defstructs are a special case, and
 ;;; don't have a corresponding class.
-(def!struct (basic-structure-classoid (:include slot-classoid)
-                                      (:constructor nil)))
-
-(def!struct (structure-classoid (:include basic-structure-classoid)
+(def!struct (structure-classoid (:include classoid)
                                 (:constructor make-structure-classoid))
   ;; If true, a default keyword constructor for this structure.
   (constructor nil :type (or function null)))
-
-;;; FUNCALLABLE-STRUCTURE-CLASS is used to represent funcallable
-;;; structures, which are used to implement generic functions.
-(def!struct (funcallable-structure-classoid
-             (:include basic-structure-classoid)
-             (:constructor make-funcallable-structure-classoid)))
 \f
 ;;;; classoid namespace
 
@@ -870,8 +854,8 @@ NIL is returned when no such class exists."
         ;; Otherwise, we can't in general be sure that the
         ;; intersection is empty, since a subclass of both might be
         ;; defined. But we can eliminate it for some special cases.
-        ((or (basic-structure-classoid-p class1)
-             (basic-structure-classoid-p class2))
+        ((or (structure-classoid-p class1)
+             (structure-classoid-p class2))
          ;; No subclass of both can be defined.
          *empty-type*)
         ((eq (classoid-state class1) :sealed)

diff --git a/src/code/condition.lisp b/src/code/condition.lisp
index 8c19059..253b76f 100644 (file)
--- a/src/code/condition.lisp
+++ b/src/code/condition.lisp
@@ -41,7 +41,7 @@
 
 (/show0 "condition.lisp 24")
 
-(def!struct (condition-classoid (:include slot-classoid)
+(def!struct (condition-classoid (:include classoid)
                                 (:constructor make-condition-classoid))
   ;; list of CONDITION-SLOT structures for the direct slots of this
   ;; class

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 80916e3..102c8b5 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -1167,7 +1167,7 @@
                   (values nil t))
                  ((eq type1 (find-classoid 'function))
                   (values nil t))
-                 ((or (basic-structure-classoid-p type1)
+                 ((or (structure-classoid-p type1)
                       #+nil
                       (condition-classoid-p type1))
                   (values t t))
@@ -1196,9 +1196,15 @@
      (if (classoid-p type1)
          (if (and (not (member type1 *non-instance-classoid-types*
                                :key #'find-classoid))
+                  (not (eq type1 (find-classoid 'function)))
                   (not (find (classoid-layout (find-classoid 'function))
                              (layout-inherits (classoid-layout type1)))))
-             type1
+             (if (or (structure-classoid-p type1)
+                     (and (not (eq type1 (find-classoid 'stream)))
+                          (not (find (classoid-layout (find-classoid 'stream))
+                                     (layout-inherits (classoid-layout type1))))))
+                 type1
+                 nil)
              *empty-type*)
          (if (type-might-contain-other-types-p type1)
              nil
@@ -1211,7 +1217,7 @@
                         (layout-inherits (classoid-layout type1))))
              type1
              (if (type= type1 (find-classoid 'function))
-                 type1
+                 type2
                  nil))
          (if (fun-type-p type1)
              nil

diff --git a/src/compiler/generic/primtype.lisp b/src/compiler/generic/primtype.lisp
index 4a4489a..1232ca1 100644 (file)
--- a/src/compiler/generic/primtype.lisp
+++ b/src/compiler/generic/primtype.lisp
@@ -316,17 +316,9 @@
                (res (any))
                (exact nil))
            (dolist (type types (values res exact))
-             (when (eq type (specifier-type 'function))
-               ;; KLUDGE: Deal with (and function instance), both of which
-               ;; have an exact primitive type.
-               (return (part-of function)))
              (multiple-value-bind (ptype ptype-exact)
                  (primitive-type type)
                (when ptype-exact
-                 ;; Apart from the previous kludge exact primitive
-                 ;; types should match, if indeed there are any. It
-                 ;; may be that this assumption isn't really safe,
-                 ;; but at least we'll see what breaks. -- NS 20041104
                  (aver (or (not exact) (eq ptype res)))
                  (setq exact t))
                (when (or ptype-exact (and (not exact) (eq res (any))))

diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index b601e7a..584e86f 100644 (file)
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -433,7 +433,7 @@
                               `((when (layout-invalid ,n-layout)
                                   (%layout-invalid-error object ',layout))))
                       (eq ,n-layout ',layout)))))
-           ((and (typep class 'basic-structure-classoid) layout)
+           ((and (typep class 'structure-classoid) layout)
             ;; structure type tests; hierarchical layout depths
             (let ((depthoid (layout-depthoid layout))
                   (n-layout (gensym)))

diff --git a/tests/type.after-xc.lisp b/tests/type.after-xc.lisp
index b63d944..facbda3 100644 (file)
--- a/tests/type.after-xc.lisp
+++ b/tests/type.after-xc.lisp
@@ -25,4 +25,8 @@
                                 *empty-type*)))
 (assert (member-type-p (specifier-type '(or float-format null))))
 
+(let ((fd-stream (specifier-type 'fd-stream)))
+  (assert (type= fd-stream (type-intersection (specifier-type 'instance)
+                                              fd-stream))))
+
 (/show "done with tests/type.after-xc.lisp")

diff --git a/tests/type.before-xc.lisp b/tests/type.before-xc.lisp
index 3f8639e..380f930 100644 (file)
--- a/tests/type.before-xc.lisp
+++ b/tests/type.before-xc.lisp
@@ -284,4 +284,45 @@
   (assert (not yes))
   (assert win))
 
+(multiple-value-bind (yes win)
+    (sb-xc:subtypep '(and function instance) nil)
+  (assert yes)
+  (assert win))
+(multiple-value-bind (yes win)
+    (sb-xc:subtypep nil '(and function instance))
+  (assert yes)
+  (assert win))
+(multiple-value-bind (yes win)
+    (sb-xc:subtypep '(and function funcallable-instance) 'funcallable-instance)
+  (assert yes)
+  (assert win))
+(multiple-value-bind (yes win)
+    (sb-xc:subtypep 'funcallable-instance '(and function funcallable-instance))
+  (assert yes)
+  (assert win))
+(multiple-value-bind (yes win)
+    (sb-xc:subtypep 'stream 'instance)
+  (assert (not yes)))
+(multiple-value-bind (yes win)
+    (sb-xc:subtypep 'stream 'funcallable-instance)
+  (assert (not yes))
+  (assert win))
+(multiple-value-bind (yes win)
+    (sb-xc:subtypep '(and stream instance) 'instance)
+  (assert yes)
+  (assert win))
+(multiple-value-bind (yes win)
+    (sb-xc:subtypep '(and stream funcallable-instance) 'funcallable-instance)
+  (assert yes)
+  (assert win))
+(multiple-value-bind (yes win)
+    (sb-xc:subtypep '(and stream instance) 'stream)
+  (assert yes)
+  (assert win))
+(multiple-value-bind (yes win)
+    (sb-xc:subtypep '(and stream funcallable-instance) 'stream)
+  (assert yes)
+  (assert win))
+
+
 (/show "done with tests/type.before-xc.lisp")

diff --git a/version.lisp-expr b/version.lisp-expr
index 12519c3..1b8cfd9 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.10.23"
+"0.9.10.24"