0.6.11.15:

	some cleanups related to the type hackathon in 0.6.11.13..
	..restored :TYPE declaration for FORMAT slot in NUMERIC-TYPE
	..restored :TYPE declaration for TYPES slot in COMPOUND-TYPE
	..moved LIST, CONS, and NULL to a more logical point in
		*BUILT-IN-CLASSES*
	..rearranged CTYPE, ANY/TYPE, and EVERY/TYPE to share code
	..added tests related to CTYPE of COMPOUND-TYPE
	..redid INTERSECTION :SIMPLE-SUBTYPEP to share EVERY/TYPE too
	added tests for ANY/TYPE and EVERY/TYPE, fixed EVERY/TYPE
	moved SWAPPED-ARGS-FUN earlier to facilitate inlining, putting
		it in SB!INT so it can go in early-extensions.lisp
	deleted unused LETF and LETF*

BUGS

@@ -525,8 +525,18 @@ Error in function C::GET-LAMBDA-TO-COMPILE:
    #<Closure Over Function "DEFUN (SETF MACRO-FUNCTION)" {480E21B1}> was defined in a non-null environment.
 
 58:
-  (SUBTYPEP '(AND ZILCH INTEGER) 'ZILCH)
-  => NIL, NIL
+  (SUBTYPEP '(AND ZILCH INTEGER) 'ZILCH) => NIL, NIL
+  Note: I looked into fixing this in 0.6.11.15, but gave up. The
+  problem seems to be that there are two relevant type methods for
+  the subtypep operation, HAIRY :COMPLEX-SUBTYPEP-ARG2 and
+  INTERSECTION :COMPLEX-SUBTYPEP-ARG1, and only the first is
+  called. This could be fixed, but type dispatch is messy and
+  confusing enough already, I don't want to complicate it further.
+  Perhaps someday we can make CLOS cross-compiled (instead of compiled
+  after bootstrapping) so that we don't need to have the type system
+  available before CLOS, and then we can rewrite the type methods to
+  CLOS methods, and then expressing the solutions to stuff like this
+  should become much more straightforward. -- WHN 2001-03-14
 
 59:
   CL:*DEFAULT-PATHNAME-DEFAULTS* doesn't behave as ANSI suggests (reflecting
@@ -815,6 +825,19 @@ Error in function C::GET-LAMBDA-TO-COMPILE:
   (I haven't tried to investigate this bug enough to guess whether
   there might be any user-level symptoms.)
 
+86:
+  The system doesn't know how to reduce
+    (specifier-type '(intersection (or number vector) real)),
+  it just ends up as a HAIRY-TYPE. Smarter INTERSECTION2 methods for
+  UNION-TYPE might help.
+
+87:
+  Despite what the manual says, (DECLAIM (SPEED 0)) doesn't cause
+  things to be byte compiled. This seems to be true in cmucl-2.4.19,
+  too: (COMPILE-FILE .. :BYTE-COMPILE T) causes byte-compilation,
+  but ordinary COMPILE-FILE of a file containing (DECLAIM (SPEED 0))
+  does not.
+
 
 KNOWN BUGS RELATED TO THE IR1 INTERPRETER
 

package-data-list.lisp-expr

@@ -678,22 +678,25 @@ retained, possibly temporariliy, because it might be used internally."
              "SIMPLE-PROGRAM-ERROR" "SIMPLE-STYLE-WARNING"
              "STYLE-WARN"
 
-             ;; miscellaneous non-standard but widely useful user-level
-             ;; functions..
+             ;; bootstrapping magic, to make things happen both in
+             ;; the cross-compilation host compiler's environment and
+             ;; in the cross-compiler's environment
+             "DEF!MACRO" "DEF!METHOD" "DEF!STRUCT" "DEF!TYPE"
+
+             ;; miscellaneous non-standard but handy user-level functions..
              "ASSQ" "DELQ" "MEMQ" "POSQ" "NEQ"
 	     "%FIND-PACKAGE-OR-LOSE" "FIND-UNDELETED-PACKAGE-OR-LOSE"
              "SANE-PACKAGE"
              "CIRCULAR-LIST-P"
+             "SWAPPED-ARGS-FUN"
 
 	     ;; ..and macros..
              "COLLECT"
              "DO-ANONYMOUS" "DOHASH" "DOVECTOR"
              "NAMED-LET"
-             "LETF" "LETF*"
              "ONCE-ONLY"
              "DEFENUM"
              "DEFPRINTER"
-             "DEF!MACRO" "DEF!METHOD" "DEF!STRUCT" "DEF!TYPE"
 
              ;; ..and DEFTYPEs..
              "INDEX" 

src/code/class.lisp

@@ -995,6 +995,22 @@
 		array sequence
 		generic-string generic-vector generic-array mutable-sequence
 		mutable-collection generic-sequence collection))
+    (list
+     :translation (or cons (member nil))
+     :inherits (sequence mutable-sequence mutable-collection
+		generic-sequence collection))
+    (cons
+     :codes (#.sb!vm:list-pointer-type)
+     :translation cons
+     :inherits (list sequence
+		mutable-sequence mutable-collection
+		generic-sequence collection))
+    (null
+     :translation (member nil)
+     :inherits (list sequence
+		mutable-sequence mutable-collection
+		generic-sequence collection symbol)
+     :direct-superclasses (list symbol))
     (generic-number :state :read-only)
     (number :translation number :inherits (generic-number))
     (complex
@@ -1034,28 +1050,6 @@
     (rational
      :translation rational
      :inherits (real number generic-number))
-
-    ;; FIXME: moved LIST, CONS, and NULL here to help with translation
-    ;; of RATIO now that sbcl-0.6.11.13 has real INTERSECTION-TYPE;
-    ;; but it would be tidier to move them further back, if possible,
-    ;; so that all the numeric types are in an uninterrupted sequence
-    (list
-     :translation (or cons (member nil))
-     :inherits (sequence mutable-sequence mutable-collection
-		generic-sequence collection))
-    (cons
-     :codes (#.sb!vm:list-pointer-type)
-     :translation cons
-     :inherits (list sequence
-		mutable-sequence mutable-collection
-		generic-sequence collection))
-    (null
-     :translation (member nil)
-     :inherits (list sequence
-		mutable-sequence mutable-collection
-		generic-sequence collection symbol)
-     :direct-superclasses (list symbol))
-
     (ratio
      :translation (and rational (not integer))
      :inherits (rational real number generic-number)

src/code/early-extensions.lisp

@@ -380,6 +380,14 @@
 	;; a constant as long as the new value is EQL to the old
 	;; value.)
 	))
+
+;;; Return a function like FUN, but expecting its (two) arguments in
+;;; the opposite order that FUN does.
+(declaim (inline swapped-args-fun))
+(defun swapped-args-fun (fun)
+  (declare (type function fun))
+  (lambda (x y)
+    (funcall fun y x)))
 
 ;;;; DEFPRINTER
 

src/code/early-type.lisp

@@ -202,10 +202,7 @@
   ;; to do with #'FORMAT), or NIL if not specified or not a float.
   ;; Formats which don't exist in a given implementation don't appear
   ;; here.
-  (format nil
-	  ;; FIXME: suppressed because of cold init problems under
-	  ;; hacked type system in sbcl-0.6.11.13, should be restored
-	  #+nil :type #+nil (or float-format null))
+  (format nil :type (or float-format null))
   ;; Is this a complex numeric type?  Null if unknown (only in NUMBER).
   ;;
   ;; FIXME: I'm bewildered by FOO-P names for things not intended to
@@ -248,12 +245,7 @@
 (defstruct (compound-type (:include ctype)
 			  (:constructor nil)
 			  (:copier nil))
-  (types nil
-	 ;; FIXME: This type declaration was suppresed as a temporary
-	 ;; hack to work around sbcl-0.6.11.13 cold init problems.
-	 ;; Restore it.
-	 #+nil :type #+nil list 
-	 :read-only t))
+  (types nil :type list :read-only t))
 
 ;;; A UNION-TYPE represents a use of the OR type specifier which we
 ;;; couldn't canonicalize to something simpler. Canonical form:

src/code/late-type.lisp

@@ -1781,25 +1781,19 @@
   (type=-set (intersection-type-types type1)
 	     (intersection-type-types type2)))
 
-(!define-type-method (intersection :simple-subtypep) (type1 type2)
-  (let ((certain? t))
-    (dolist (t1 (intersection-type-types type1) (values nil certain?))
-      (multiple-value-bind (subtypep validp)
-	  (intersection-complex-subtypep-arg2 t1 type2)
-	(cond ((not validp)
-	       (setf certain? nil))
-	      (subtypep
-	       (return (values t t))))))))
-
-(!define-type-method (intersection :complex-subtypep-arg1) (type1 type2)
-  (any/type (swapped-args-fun #'csubtypep)
-	    type2
-	    (intersection-type-types type1)))
-
-(defun intersection-complex-subtypep-arg2 (type1 type2)
-  (every/type #'csubtypep type1 (intersection-type-types type2)))
+(flet ((intersection-complex-subtypep-arg1 (type1 type2)
+         (any/type (swapped-args-fun #'csubtypep)
+		   type2
+		   (intersection-type-types type1))))
+  (!define-type-method (intersection :simple-subtypep) (type1 type2)
+    (every/type #'intersection-complex-subtypep-arg1
+		type1
+		(intersection-type-types type2)))
+  (!define-type-method (intersection :complex-subtypep-arg1) (type1 type2)
+    (intersection-complex-subtypep-arg1 type1 type2)))
+
 (!define-type-method (intersection :complex-subtypep-arg2) (type1 type2)
-  (intersection-complex-subtypep-arg2 type1 type2))
+  (every/type #'csubtypep type1 (intersection-type-types type2)))
 
 (!def-type-translator and (&whole whole &rest type-specifiers)
   (apply #'type-intersection

src/code/target-type.lisp

@@ -32,6 +32,11 @@
 ;;; types. For STRUCTURE- types, we require that the type be defined
 ;;; in both the current and compiler environments, and that the
 ;;; INCLUDES be the same.
+;;;
+;;; KLUDGE: This should probably be a type method instead of a big
+;;; ETYPECASE. But then the type method system should probably be CLOS
+;;; too, and until that happens wedging more stuff into it might be
+;;; messy. So I've left it a big ETYPECASE. -- 2001-03-16
 (defun ctypep (obj type)
   (declare (type ctype type))
   (etypecase type
@@ -52,16 +57,10 @@
 	     (values nil nil))
 	 (values nil t)))
     (compound-type
+     ;; REMOVEME: old version
+     #|
      (let ((certain? t))
        (etypecase type
-	 ;; FIXME: The cases here are very similar to #'EVERY/TYPE and
-	 ;; #'ANY/TYPE. It would be good to fix them so that they
-	 ;; share the same code. (That will require making sure that
-	 ;; the two-value return convention for CTYPEP really is
-	 ;; exactly compatible with the two-value convention the
-	 ;; quantifier/TYPE functions operate on, and probably also
-	 ;; making sure that things are inlined and defined early
-	 ;; enough that consing can be avoided.)
 	 (union-type
 	  (dolist (mem (union-type-types type) (values nil certain?))
 	    (multiple-value-bind (val win) (ctypep obj mem)
@@ -74,7 +73,12 @@
 	    (multiple-value-bind (val win) (ctypep obj mem)
 	      (if win
 		  (unless val (return (values nil t)))
-		  (setf certain? nil))))))))
+		  (setf certain? nil)))))))
+     |#
+     (let ((types (compound-type-types type)))
+       (etypecase type
+	 (intersection-type (every/type #'ctypep obj types))
+	 (union-type        (any/type   #'ctypep obj types)))))
     (function-type
      (values (functionp obj) t))
     (unknown-type

src/code/typedefs.lisp

@@ -92,36 +92,26 @@
 
 ;;; sort of like ANY and EVERY, except:
 ;;;   * We handle two-VALUES predicate functions like SUBTYPEP. (And
-;;;     if the result is uncertain, then we return (VALUES NIL NIL).)
+;;;     if the result is uncertain, then we return (VALUES NIL NIL),
+;;;     just like SUBTYPEP.)
 ;;;   * THING is just an atom, and we apply OP (an arity-2 function)
 ;;;     successively to THING and each element of LIST.
 (defun any/type (op thing list)
   (declare (type function op))
   (let ((certain? t))
     (dolist (i list (values nil certain?))
-      (multiple-value-bind (sub-value sub-certain?)
-	  (funcall op thing i)
-	(unless sub-certain? (setf certain? nil))
-	(when sub-value (return (values t t)))))))
+      (multiple-value-bind (sub-value sub-certain?) (funcall op thing i)
+	(if sub-certain?
+	    (when sub-value (return (values t t)))
+	    (setf certain? nil))))))
 (defun every/type (op thing list)
   (declare (type function op))
-  (dolist (i list (values t t))
-    (multiple-value-bind (sub-value sub-certain?)
-	(funcall op thing i)
-      (unless sub-certain? (return (values nil nil)))
-      (unless sub-value (return (values nil t))))))
-
-;;; Return a function like FUN, but expecting its (two) arguments in
-;;; the opposite order that FUN does.
-;;;
-;;; (This looks like a sort of general utility, but currently it's
-;;; used only in the implementation of the type system, so it's
-;;; internal to SB-KERNEL. -- WHN 2001-02-13)
-(declaim (inline swapped-args-fun))
-(defun swapped-args-fun (fun)
-  (declare (type function fun))
-  (lambda (x y)
-    (funcall fun y x)))
+  (let ((certain? t))
+    (dolist (i list (if certain? (values t t) (values nil nil)))
+      (multiple-value-bind (sub-value sub-certain?) (funcall op thing i)
+	(if sub-certain?
+	    (unless sub-value (return (values nil t)))
+	    (setf certain? nil))))))
 
 ;;; Look for a nice intersection for types that intersect only when
 ;;; one is a hierarchical subtype of the other.

tests/type.before-xc.lisp

@@ -106,7 +106,7 @@
 
     (assert (csubtypep *empty-type* ctype))
     (assert (csubtypep ctype *universal-type*))))
-(/show "done with identities-should-be-identities block")
+(/show "finished with identities-should-be-identities block")
 
 (assert (sb-xc:subtypep 'simple-vector 'vector))
 (assert (sb-xc:subtypep 'simple-vector 'simple-array))
@@ -127,6 +127,34 @@
 				    nil))
   |#)
 
+;;; tests of 2-value quantifieroids FOO/TYPE
+(macrolet ((2= (v1 v2 expr2)
+             (let ((x1 (gensym))
+		   (x2 (gensym)))
+	       `(multiple-value-bind (,x1 ,x2) ,expr2
+		  (unless (and (eql ,x1 ,v1) (eql ,x2 ,v2))
+		    (error "mismatch for EXPR2=~S" ',expr2))))))
+  (flet (;; SUBTYPEP running in the cross-compiler
+	 (xsubtypep (x y)
+	   (csubtypep (specifier-type x)
+		      (specifier-type y))))
+    (2=   t   t (any/type   #'xsubtypep 'fixnum '(real integer)))
+    (2=   t   t (any/type   #'xsubtypep 'fixnum '(real cons)))
+    (2= nil   t (any/type   #'xsubtypep 'fixnum '(cons vector)))
+    (2= nil nil (any/type   #'xsubtypep 'fixnum '(cons some-unknown-type-foo)))
+    (2= nil nil (any/type   #'xsubtypep 'fixnum '(some-unknown-type-foo cons)))
+    (2=   t   t (any/type   #'xsubtypep 'fixnum '(some-unknown-type-foo real)))
+    (2=   t   t (any/type   #'xsubtypep 'fixnum '(real some-unknown-type-foo)))
+    (2= nil   t (any/type   #'xsubtypep 'fixnum '()))
+    (2=   t   t (every/type #'xsubtypep 'fixnum '()))
+    (2= nil nil (every/type #'xsubtypep 'fixnum '(real some-unknown-type-foo)))
+    (2= nil nil (every/type #'xsubtypep 'fixnum '(some-unknown-type-foo real)))
+    (2= nil   t (every/type #'xsubtypep 'fixnum '(some-unknown-type-foo cons)))
+    (2= nil   t (every/type #'xsubtypep 'fixnum '(cons some-unknown-type-foo)))
+    (2=   t   t (every/type #'xsubtypep 'fixnum '(real integer)))
+    (2= nil   t (every/type #'xsubtypep 'fixnum '(real cons)))
+    (2= nil   t (every/type #'xsubtypep 'fixnum '(cons vector)))))
+
 ;;; various dead bugs
 (assert (union-type-p (type-intersection (specifier-type 'list)
 					 (specifier-type '(or list vector)))))

tests/type.pure.lisp

@@ -0,0 +1,30 @@
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;; 
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(in-package "CL-USER")
+
+(locally
+  (declare (notinline mapcar))
+  (mapcar (lambda (args)
+	    (destructuring-bind (obj type-spec result) args
+	      (flet ((matches-result? (x)
+		       (eq (if x t nil) result)))
+		(assert (matches-result? (typep obj type-spec)))
+		(assert (matches-result? (sb-kernel:ctypep
+					  obj
+					  (sb-kernel:specifier-type
+					   type-spec)))))))
+	  '((nil (or null vector)              t)
+	    (nil (or number vector)            nil)
+	    (12  (or null vector)              nil)
+	    (12  (and (or number vector) real) t))))
+
+

version.lisp-expr

@@ -15,4 +15,4 @@
 ;;; versions, and a string like "0.6.5.12" is used for versions which
 ;;; aren't released but correspond only to CVS tags or snapshots.
 
-"0.6.11.14"
+"0.6.11.15"