0.6.8.15:

	merged DTC's compound CONS type patches
	enabled (and fixed) tests in tests/compound-cons.impure.lisp
	canonicalized types (CONS *) etc. to (CONS T) etc.

diff --git a/BUGS b/BUGS
index 4898018..395fbab 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -36,7 +36,10 @@ KNOWN BUGS OF NO SPECIAL CLASS:
 2:
   DEFSTRUCT should almost certainly overwrite the old LAYOUT information
   instead of just punting when a contradictory structure definition
 2:
   DEFSTRUCT should almost certainly overwrite the old LAYOUT information
   instead of just punting when a contradictory structure definition

-  is loaded.
+  is loaded. As it is, if you redefine DEFSTRUCTs in a way which 
+  changes their layout, you probably have to rebuild your entire
+  program, even if you know or guess enough about the internals of
+  SBCL to wager that this (undefined in ANSI) operation would be safe.

 
 3:
   It should cause a STYLE-WARNING, not a full WARNING, when a structure
 
 3:
   It should cause a STYLE-WARNING, not a full WARNING, when a structure

@@ -54,7 +57,7 @@ KNOWN BUGS OF NO SPECIAL CLASS:
   very good when the stream argument has the wrong type, because
   the operation tries to fall through to Gray stream code, and then
   dies because it's undefined. E.g. 
   very good when the stream argument has the wrong type, because
   the operation tries to fall through to Gray stream code, and then
   dies because it's undefined. E.g. 

-    (PRINT-UNREADABLE-OBJECT (*STANDARD-OUTPUT* 1))
+    (PRINT-UNREADABLE-OBJECT (*STANDARD-OUTPUT* 1)) ..)

   gives the error message
     error in SB-KERNEL::UNDEFINED-SYMBOL-ERROR-HANDLER:
       The function SB-IMPL::STREAM-WRITE-STRING is undefined.
   gives the error message
     error in SB-KERNEL::UNDEFINED-SYMBOL-ERROR-HANDLER:
       The function SB-IMPL::STREAM-WRITE-STRING is undefined.

diff --git a/NEWS b/NEWS
index 741ced8..9731cfa 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -571,3 +571,6 @@ changes in sbcl-0.6.9 relative to sbcl-0.6.8:
   it doesn't seem to affect SBCL after all
 * The system now recovers better from non-PACKAGE values of the *PACKAGE*
   variable.
   it doesn't seem to affect SBCL after all
 * The system now recovers better from non-PACKAGE values of the *PACKAGE*
   variable.

+* The system now understands compound CONS types (e.g. (CONS FIXNUM T))
+  as required by ANSI. (thanks to Douglas Crosher's CMU CL patches, with
+  some porting work by Martin Atzmueller)

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index af3defe..5bd9630 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -918,8 +918,10 @@ is a good idea, but see SB-SYS for blurring of boundaries."
              "*COLD-INIT-COMPLETE-P*"
              "!COLD-INIT-FORMS" "COMPLEX-DOUBLE-FLOAT-P"
              "COMPLEX-FLOAT-P" "COMPLEX-LONG-FLOAT-P"
              "*COLD-INIT-COMPLETE-P*"
              "!COLD-INIT-FORMS" "COMPLEX-DOUBLE-FLOAT-P"
              "COMPLEX-FLOAT-P" "COMPLEX-LONG-FLOAT-P"

-             "COMPLEX-RATIONAL-P" "COMPLEX-SINGLE-FLOAT-P"
-             "COMPLEX-VECTOR-P" "CONSED-SEQUENCE" "CONSTANT" "CONSTANT-TYPE"
+             "COMPLEX-RATIONAL-P" "COMPLEX-SINGLE-FLOAT-P" "COMPLEX-VECTOR-P"
+             "CONS-TYPE" "CONS-TYPE-CAR-TYPE" "CONS-TYPE-CDR-TYPE"
+             "CONS-TYPE-P"
+             "CONSED-SEQUENCE" "CONSTANT" "CONSTANT-TYPE"

              "CONSTANT-TYPE-P" "CONSTANT-TYPE-TYPE"
              "CONTAINING-INTEGER-TYPE"
              "CONTROL-STACK-POINTER-SAP" "COPY-FROM-SYSTEM-AREA"
              "CONSTANT-TYPE-P" "CONSTANT-TYPE-TYPE"
              "CONTAINING-INTEGER-TYPE"
              "CONTROL-STACK-POINTER-SAP" "COPY-FROM-SYSTEM-AREA"

@@ -972,8 +974,8 @@ is a good idea, but see SB-SYS for blurring of boundaries."
              "LONG-FLOAT-LOW-BITS" "LONG-FLOAT-MID-BITS" "LONG-FLOAT-P"
              "LRA" "LRA-CODE-HEADER" "LRA-P"
              "MAKE-ALIEN-TYPE-TYPE" "MAKE-ARGS-TYPE"
              "LONG-FLOAT-LOW-BITS" "LONG-FLOAT-MID-BITS" "LONG-FLOAT-P"
              "LRA" "LRA-CODE-HEADER" "LRA-P"
              "MAKE-ALIEN-TYPE-TYPE" "MAKE-ARGS-TYPE"

-             "MAKE-ARRAY-HEADER" "MAKE-ARRAY-TYPE" "MAKE-DOUBLE-FLOAT"
-             "MAKE-FUNCTION-TYPE"
+             "MAKE-ARRAY-HEADER" "MAKE-ARRAY-TYPE" "MAKE-CONS-TYPE"
+             "MAKE-DOUBLE-FLOAT" "MAKE-FUNCTION-TYPE"

              "MAKE-KEY-INFO" "MAKE-LISP-OBJ" "MAKE-LONG-FLOAT"
              "MAKE-MEMBER-TYPE" "MAKE-NAMED-TYPE"
              "MAKE-NULL-LEXENV" "MAKE-NUMERIC-TYPE"
              "MAKE-KEY-INFO" "MAKE-LISP-OBJ" "MAKE-LONG-FLOAT"
              "MAKE-MEMBER-TYPE" "MAKE-NAMED-TYPE"
              "MAKE-NULL-LEXENV" "MAKE-NUMERIC-TYPE"

diff --git a/src/code/class.lisp b/src/code/class.lisp
index bd6d361..4c67377 100644 (file)
--- a/src/code/class.lisp
+++ b/src/code/class.lisp
@@ -1053,6 +1053,7 @@
                generic-sequence collection))
     (cons
      :codes (#.sb!vm:list-pointer-type)
                generic-sequence collection))
     (cons
      :codes (#.sb!vm:list-pointer-type)

+     :translation cons

      :inherits (list sequence
                mutable-sequence mutable-collection
                generic-sequence collection))
      :inherits (list sequence
                mutable-sequence mutable-collection
                generic-sequence collection))

diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp
index 53447f3..ab24bdb 100644 (file)
--- a/src/code/cross-type.lisp
+++ b/src/code/cross-type.lisp
@@ -314,7 +314,7 @@
                        :complexp (not (typep x 'simple-array))
                        :element-type etype
                        :specialized-element-type etype)))
                        :complexp (not (typep x 'simple-array))
                        :element-type etype
                        :specialized-element-type etype)))

-    (cons (sb!xc:find-class 'cons))
+    (cons (specifier-type 'cons))

     (character
      (cond ((typep x 'standard-char)
            ;; (Note that SBCL doesn't distinguish between BASE-CHAR and
     (character
      (cond ((typep x 'standard-char)
            ;; (Note that SBCL doesn't distinguish between BASE-CHAR and

diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp
index db84f2d..8aee3f6 100644 (file)
--- a/src/code/early-type.lisp
+++ b/src/code/early-type.lisp
@@ -207,15 +207,43 @@
 
 ;;; A UNION-TYPE represents a use of the OR type specifier which can't
 ;;; be canonicalized to something simpler. Canonical form:
 
 ;;; A UNION-TYPE represents a use of the OR type specifier which can't
 ;;; be canonicalized to something simpler. Canonical form:

-;;;   1. There is never more than one Member-Type component.
-;;;   2. There are never any Union-Type components.
+;;;   1. There is never more than one MEMBER-TYPE component.
+;;;   2. There are never any UNION-TYPE components.

 (defstruct (union-type (:include ctype
                                 (class-info (type-class-or-lose 'union)))
                       (:constructor %make-union-type (enumerable types)))
   ;; The types in the union.
   (types nil :type list))
 
 (defstruct (union-type (:include ctype
                                 (class-info (type-class-or-lose 'union)))
                       (:constructor %make-union-type (enumerable types)))
   ;; The types in the union.
   (types nil :type list))
 

-;;; Note that the type Name has been (re)defined, updating the
+;;; Return TYPE converted to canonical form for a situation where the
+;;; type '* is equivalent to type T.
+(defun type-*-to-t (type)
+  (if (type= type *wild-type*)
+      *universal-type*
+      type))
+
+;;; A CONS-TYPE is used to represent a CONS type.
+(defstruct (cons-type (:include ctype
+                               (:class-info (type-class-or-lose 'cons)))
+                     (:constructor
+                      ;; ANSI says that for CAR and CDR subtype
+                      ;; specifiers '* is equivalent to T. In order
+                      ;; to avoid special cases in SUBTYPEP and
+                      ;; possibly elsewhere, we slam all CONS-TYPE
+                      ;; objects into canonical form w.r.t. this
+                      ;; equivalence at creation time.
+                      make-cons-type (car-raw-type
+                                      cdr-raw-type
+                                      &aux
+                                      (car-type (type-*-to-t car-raw-type))
+                                      (cdr-type (type-*-to-t cdr-raw-type)))))
+  ;; the CAR and CDR element types (to support ANSI (CONS FOO BAR) types)
+  ;;
+  ;; FIXME: Most or all other type structure slots could also be :READ-ONLY.
+  (car-type (required-argument) :type ctype :read-only t)
+  (cdr-type (required-argument) :type ctype :read-only t))
+
+;;; Note that the type NAME has been (re)defined, updating the

 ;;; undefined warnings and VALUES-SPECIFIER-TYPE cache.
 (defun %note-type-defined (name)
   (declare (symbol name))
 ;;; undefined warnings and VALUES-SPECIFIER-TYPE cache.
 (defun %note-type-defined (name)
   (declare (symbol name))

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 863f248..4184077 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -1688,6 +1688,63 @@
            (return (make-hairy-type :specifier spec)))
          (setq res int))))))
 \f
            (return (make-hairy-type :specifier spec)))
          (setq res int))))))
 \f

+;;;; CONS types
+
+(define-type-class cons)
+
+(def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*))
+  (make-cons-type (specifier-type car-type-spec)
+                 (specifier-type cdr-type-spec)))
+ 
+(define-type-method (cons :unparse) (type)
+  (let ((car-eltype (type-specifier (cons-type-car-type type)))
+       (cdr-eltype (type-specifier (cons-type-cdr-type type))))
+    (if (and (member car-eltype '(t *))
+            (member cdr-eltype '(t *)))
+       'cons
+       `(cons ,car-eltype ,cdr-eltype))))
+ 
+(define-type-method (cons :simple-=) (type1 type2)
+  (declare (type cons-type type1 type2))
+  (and (type= (cons-type-car-type type1) (cons-type-car-type type2))
+       (type= (cons-type-cdr-type type1) (cons-type-cdr-type type2))))
+ 
+(define-type-method (cons :simple-subtypep) (type1 type2)
+  (declare (type cons-type type1 type2))
+  (multiple-value-bind (val-car win-car)
+      (csubtypep (cons-type-car-type type1) (cons-type-car-type type2))
+    (multiple-value-bind (val-cdr win-cdr)
+       (csubtypep (cons-type-cdr-type type1) (cons-type-cdr-type type2))
+      (if (and val-car val-cdr)
+         (values t (and win-car win-cdr))
+         (values nil (or win-car win-cdr))))))
+ 
+;;; Give up if a precise type is not possible, to avoid returning
+;;; overly general types.
+(define-type-method (cons :simple-union) (type1 type2)
+  (declare (type cons-type type1 type2))
+  (let ((car-type1 (cons-type-car-type type1))
+       (car-type2 (cons-type-car-type type2))
+       (cdr-type1 (cons-type-cdr-type type1))
+       (cdr-type2 (cons-type-cdr-type type2)))
+    (cond ((type= car-type1 car-type2)
+          (make-cons-type car-type1
+                          (type-union cdr-type1 cdr-type2)))
+         ((type= cdr-type1 cdr-type2)
+          (make-cons-type (type-union cdr-type1 cdr-type2)
+                          cdr-type1)))))
+
+(define-type-method (cons :simple-intersection) (type1 type2)
+  (declare (type cons-type type1 type2))
+  (multiple-value-bind (int-car win-car)
+      (type-intersection (cons-type-car-type type1)
+                        (cons-type-car-type type2))
+    (multiple-value-bind (int-cdr win-cdr)
+       (type-intersection (cons-type-cdr-type type1)
+                          (cons-type-cdr-type type2))
+      (values (make-cons-type int-car int-cdr)
+             (and win-car win-cdr)))))
+\f

 ;;; Return the type that describes all objects that are in X but not
 ;;; in Y. If we can't determine this type, then return NIL.
 ;;;
 ;;; Return the type that describes all objects that are in X but not
 ;;; in Y. If we can't determine this type, then return NIL.
 ;;;

diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp
index 1e24030..166e38a 100644 (file)
--- a/src/code/target-type.lisp
+++ b/src/code/target-type.lisp
@@ -44,7 +44,8 @@
         named-type
         member-type
         array-type
         named-type
         member-type
         array-type

-        sb!xc:built-in-class)
+        sb!xc:built-in-class
+        cons-type)

      (values (%typep obj type) t))
     (sb!xc:class
      (if (if (csubtypep type (specifier-type 'funcallable-instance))
      (values (%typep obj type) t))
     (sb!xc:class
      (if (if (csubtypep type (specifier-type 'funcallable-instance))

@@ -146,8 +147,8 @@
 \f
 ;;;; miscellaneous interfaces
 
 \f
 ;;;; miscellaneous interfaces
 

-;;; Clear memoization of all type system operations that can be altered by
-;;; type definition/redefinition.
+;;; Clear memoization of all type system operations that can be
+;;; altered by type definition/redefinition.

 (defun clear-type-caches ()
   (when *type-system-initialized*
     (dolist (sym '(values-specifier-type-cache-clear
 (defun clear-type-caches ()
   (when *type-system-initialized*
     (dolist (sym '(values-specifier-type-cache-clear

@@ -160,9 +161,10 @@
       (funcall (symbol-function sym))))
   (values))
 
       (funcall (symbol-function sym))))
   (values))
 

-;;; Like TYPE-OF, only we return a CTYPE structure instead of a type specifier,
-;;; and we try to return the type most useful for type checking, rather than
-;;; trying to come up with the one that the user might find most informative.
+;;; Like TYPE-OF, only we return a CTYPE structure instead of a type
+;;; specifier, and we try to return the type most useful for type
+;;; checking, rather than trying to come up with the one that the user
+;;; might find most informative.

 (declaim (ftype (function (t) ctype) ctype-of))
 (defun-cached (ctype-of
               :hash-function (lambda (x) (logand (sxhash x) #x1FF))
 (declaim (ftype (function (t) ctype) ctype-of))
 (defun-cached (ctype-of
               :hash-function (lambda (x) (logand (sxhash x) #x1FF))

@@ -201,6 +203,8 @@
                        :complexp (not (typep x 'simple-array))
                        :element-type etype
                        :specialized-element-type etype)))
                        :complexp (not (typep x 'simple-array))
                        :element-type etype
                        :specialized-element-type etype)))

+    (cons
+     (make-cons-type *universal-type* *universal-type*))

     (t
      (sb!xc:class-of x))))
 
     (t
      (sb!xc:class-of x))))
 

diff --git a/src/code/typep.lisp b/src/code/typep.lisp
index b82f92c..8c58fac 100644 (file)
--- a/src/code/typep.lisp
+++ b/src/code/typep.lisp
@@ -114,6 +114,10 @@
      (dolist (type (union-type-types type))
        (when (%%typep object type)
         (return t))))
      (dolist (type (union-type-types type))
        (when (%%typep object type)
         (return t))))

+    (cons-type
+     (and (consp object)
+         (%%typep (car object) (cons-type-car-type type))
+         (%%typep (cdr object) (cons-type-cdr-type type))))

     (unknown-type
      ;; dunno how to do this ANSIly -- WHN 19990413
      #+sb-xc-host (error "stub: %%TYPEP UNKNOWN-TYPE in xcompilation host")
     (unknown-type
      ;; dunno how to do this ANSIly -- WHN 19990413
      #+sb-xc-host (error "stub: %%TYPEP UNKNOWN-TYPE in xcompilation host")

diff --git a/version.lisp-expr b/version.lisp-expr
index a1dbea8..5d50b8f 100644 (file)
--- a/version.lisp-expr
+++ b/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.
 
 ;;; 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.8.14"
+"0.6.8.15"