From: William Harold Newman <william.newman@airmail.net>
Date: Sat, 11 Nov 2000 13:17:36 +0000 (+0000)
Subject: 0.6.8.15:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=e240e076bc5bfa07a408a89d2e354e7ec9ff9341;p=sbcl.git

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
--- 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
-  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
@@ -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. 
-    (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.
diff --git a/NEWS b/NEWS
index 741ced8..9731cfa 100644
--- 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.
+* 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
--- 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"
-             "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"
@@ -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"
-             "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"
diff --git a/src/code/class.lisp b/src/code/class.lisp
index bd6d361..4c67377 100644
--- a/src/code/class.lisp
+++ b/src/code/class.lisp
@@ -1053,6 +1053,7 @@
 		generic-sequence collection))
     (cons
      :codes (#.sb!vm:list-pointer-type)
+     :translation cons
      :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
--- 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)))
-    (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
diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp
index db84f2d..8aee3f6 100644
--- 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:
-;;;   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))
 
-;;; 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))
diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 863f248..4184077 100644
--- 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))))))
 
+;;;; 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)))))
+
 ;;; 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
--- a/src/code/target-type.lisp
+++ b/src/code/target-type.lisp
@@ -44,7 +44,8 @@
 	 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))
@@ -146,8 +147,8 @@
 
 ;;;; 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
@@ -160,9 +161,10 @@
       (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))
@@ -201,6 +203,8 @@
 			: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))))
 
diff --git a/src/code/typep.lisp b/src/code/typep.lisp
index b82f92c..8c58fac 100644
--- 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))))
+    (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")
diff --git a/version.lisp-expr b/version.lisp-expr
index a1dbea8..5d50b8f 100644
--- 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.
 
-"0.6.8.14"
+"0.6.8.15"