1.0.3.5: slightly different SEQUENCE type handling.

	The UNION TYPE= issue affects type derivation as in
	(defun foo (x)
          (declare (type (simple-array character) x))
          (subseq x 1 2))
        where the system fails to derive that the intersection of
	consed-sequence and (simple-array character) is distinct from
	consed-sequence.  Change SEQUENCE to be an explicit union of
	LIST, VECTOR and an EXTENDED-SEQUENCE named type, defining
	appropriate type methods, and the symptom (but not the cause)
	goes away.

	(Note: it may well be that the EXTENDED-SEQUENCE named type
	disappears again, to be replaced by an actual protocol class
	similar to FUNDAMENTAL-STREAM for Gray streams, for reasons of
	future extensibility and ease of compatibility with other Lisps.
        Waiting for ILC feedback...)

diff --git a/BUGS b/BUGS
index f7c265b..93c7c37 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -1789,3 +1789,22 @@ WORKAROUND:
        TYPE/= do, and writing an explanation which is so clear that one
        can see immediately what it's supposed to mean in odd cases like
        (TYPE= '(SATISFIES X) 'INTEGER) when X isn't defined yet.
+
+409: MORE TYPE SYSTEM PROBLEMS
+  Found while investigating an optimization failure for extended
+  sequences. The extended sequence type implementation was altered to
+  work around the problem, but the fundamental problem remains, to wit:
+    (sb-kernel:type= (sb-kernel:specifier-type '(or float ratio))
+                     (sb-kernel:specifier-type 'single-float))
+  returns NIL, NIL on sbcl-1.0.3.
+  (probably related to bug #408)
+
+410: read circularities and type declarations
+  Consider the definition
+    (defstruct foo (a 0 :type (not symbol)))
+  followed by
+    (setf *print-circle* t) ; just in case
+    (read-from-string "#1=#s(foo :a #1#)")
+  This gives a type error (#:G1 is not a (NOT SYMBOL)) because of the
+  implementation of read circularity, using a symbol as a marker for
+  the previously-referenced object.

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 66adb49..bd09585 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1557,6 +1557,9 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "%MAKE-SYMBOL"
                "%FUNCALLABLE-INSTANCE-FUNCTION" "SYMBOL-HASH"
 
+               "EXTENDED-SEQUENCE" "*EXTENDED-SEQUENCE-TYPE*"
+               "EXTENDED-SEQUENCE-P"
+
                "BUILT-IN-CLASSOID" "CONDITION-CLASSOID-P"
                "CONDITION-CLASSOID-SLOTS" "MAKE-UNDEFINED-CLASSOID"
                "FIND-CLASSOID" "CLASSOID" "CLASSOID-DIRECT-SUPERCLASSES"

diff --git a/src/code/class.lisp b/src/code/class.lisp
index 4e06f52..4629a86 100644 (file)
--- a/src/code/class.lisp
+++ b/src/code/class.lisp
@@ -913,22 +913,6 @@ NIL is returned when no such class exists."
          ;; uncertain, since a subclass of both might be defined
          nil)))
 
-;;; KLUDGE: we need this for the special-case SEQUENCE type, which
-;;; (because of multiple inheritance with ARRAY for the VECTOR types)
-;;; doesn't have the nice hierarchical properties we want.  This is
-;;; basically DELEGATE-COMPLEX-INTERSECTION2 with a special-case for
-;;; SEQUENCE/ARRAY interactions.
-(!define-type-method (classoid :complex-intersection2) (type1 class2)
-  (cond
-    ((and (eq class2 (find-classoid 'sequence))
-          (array-type-p type1))
-     (type-intersection2 (specifier-type 'vector) type1))
-    (t
-     (let ((method (type-class-complex-intersection2 (type-class-info type1))))
-       (if (and method (not (eq method #'delegate-complex-intersection2)))
-           :call-other-method
-           (hierarchical-intersection2 type1 class2))))))
-
 ;;; KLUDGE: we need this to deal with the special-case INSTANCE and
 ;;; FUNCALLABLE-INSTANCE types (which used to be CLASSOIDs until CSR
 ;;; discovered that this was incompatible with the MOP class
@@ -1112,6 +1096,7 @@ NIL is returned when no such class exists."
       :inherits (array)
       :prototype-form (make-array nil))
      (sequence
+      :translation (or cons (member nil) vector extended-sequence)
       :state :read-only
       :depth 2)
      (vector

diff --git a/src/code/deftypes-for-target.lisp b/src/code/deftypes-for-target.lisp
index 103047c..d26547f 100644 (file)
--- a/src/code/deftypes-for-target.lisp
+++ b/src/code/deftypes-for-target.lisp
@@ -155,7 +155,7 @@
 
 ;;; a consed sequence result. If a vector, is a simple array.
 (sb!xc:deftype consed-sequence ()
-  '(or (simple-array * (*)) (and sequence (not vector))))
+  '(or (simple-array * (*)) list extended-sequence))
 
 ;;; the :END arg to a sequence
 (sb!xc:deftype sequence-end () '(or null index))

diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp
index 5b88476..6bc004e 100644 (file)
--- a/src/code/early-type.lisp
+++ b/src/code/early-type.lisp
@@ -221,10 +221,15 @@
   ;; specifier to win.
   (type (missing-arg) :type ctype))
 
-;;; The NAMED-TYPE is used to represent *, T and NIL. These types must
-;;; be super- or sub-types of all types, not just classes and * and
-;;; NIL aren't classes anyway, so it wouldn't make much sense to make
-;;; them built-in classes.
+;;; The NAMED-TYPE is used to represent *, T and NIL, the standard
+;;; special cases, as well as other special cases needed to
+;;; interpolate between regions of the type hierarchy, such as
+;;; INSTANCE (which corresponds to all those classes with slots which
+;;; are not funcallable), FUNCALLABLE-INSTANCE (those classes with
+;;; slots which are funcallable) and EXTENDED-SEQUUENCE (non-LIST
+;;; non-VECTOR classes which are also sequences).  These special cases
+;;; are the ones that aren't really discussed by Baker in his
+;;; "Decision Procedure for SUBTYPEP" paper.
 (defstruct (named-type (:include ctype
                                  (class-info (type-class-or-lose 'named)))
                        (:copier nil))

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 0e284b0..007950a 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -1051,7 +1051,11 @@
    ;; required to be a subclass of STANDARD-OBJECT.  -- CSR,
    ;; 2005-09-09
    (frob instance *instance-type*)
-   (frob funcallable-instance *funcallable-instance-type*))
+   (frob funcallable-instance *funcallable-instance-type*)
+   ;; new in sbcl-1.0.3.3: necessary to act as a join point for the
+   ;; extended sequence hierarchy.  (Might be removed later if we use
+   ;; a dedicated FUNDAMENTAL-SEQUENCE class for this.)
+   (frob extended-sequence *extended-sequence-type*))
  (setf *universal-fun-type*
        (make-fun-type :wild-args t
                       :returns *wild-type*)))
@@ -1155,6 +1159,12 @@
          ;; member types can be subtypep INSTANCE and
          ;; FUNCALLABLE-INSTANCE in surprising ways.
          (invoke-complex-subtypep-arg1-method type1 type2))
+        ((and (eq type2 *extended-sequence-type*) (classoid-p type1))
+         (let* ((layout (classoid-layout type1))
+                (inherits (layout-inherits layout))
+                (sequencep (find (classoid-layout (find-classoid 'sequence))
+                                 inherits)))
+           (values (if sequencep t nil) t)))
         ((and (eq type2 *instance-type*) (classoid-p type1))
          (if (member type1 *non-instance-classoid-types* :key #'find-classoid)
              (values nil t)
@@ -1192,6 +1202,21 @@
   ;; Perhaps when bug 85 is fixed it can be reenabled.
   ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
   (cond
+    ((eq type2 *extended-sequence-type*)
+     (typecase type1
+       (structure-classoid *empty-type*)
+       (classoid
+        (if (member type1 *non-instance-classoid-types* :key #'find-classoid)
+            *empty-type*
+            (if (find (classoid-layout (find-classoid 'sequence))
+                      (layout-inherits (classoid-layout type1)))
+                type1
+                nil)))
+       (t
+        (if (or (type-might-contain-other-types-p type1)
+                (member-type-p type1))
+            nil
+            *empty-type*))))
     ((eq type2 *instance-type*)
      (typecase type1
        (structure-classoid type1)
@@ -1232,6 +1257,15 @@
   ;; Perhaps when bug 85 is fixed this can be reenabled.
   ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
   (cond
+    ((eq type2 *extended-sequence-type*)
+     (if (classoid-p type1)
+         (if (or (member type1 *non-instance-classoid-types*
+                         :key #'find-classoid)
+                 (not (find (classoid-layout (find-classoid 'sequence))
+                            (layout-inherits (classoid-layout type1)))))
+             nil
+             type2)
+         nil))
     ((eq type2 *instance-type*)
      (if (classoid-p type1)
          (if (or (member type1 *non-instance-classoid-types*
@@ -1260,7 +1294,8 @@
     ((eq x *universal-type*) *empty-type*)
     ((eq x *empty-type*) *universal-type*)
     ((or (eq x *instance-type*)
-         (eq x *funcallable-instance-type*))
+         (eq x *funcallable-instance-type*)
+         (eq x *extended-sequence-type*))
      (make-negation-type :type x))
     (t (bug "NAMED type unexpected: ~S" x))))
 

diff --git a/src/code/pred.lisp b/src/code/pred.lisp
index 6de30db..7d006cc 100644 (file)
--- a/src/code/pred.lisp
+++ b/src/code/pred.lisp
@@ -24,6 +24,22 @@
            (do ((data (%array-data-vector x) (%array-data-vector data)))
                ((not (array-header-p data)) (simple-vector-p data))))))
 
+;;; Is X an extended sequence?
+(defun extended-sequence-p (x)
+  (and (not (listp x))
+       (not (vectorp x))
+       (let* ((slayout #.(info :type :compiler-layout 'sequence))
+             (depthoid #.(layout-depthoid (info :type :compiler-layout 'sequence)))
+             (layout (layout-of x)))
+        (when (layout-invalid layout)
+          (setq layout (update-object-layout-or-invalid x slayout)))
+        (if (eq layout slayout)
+            t
+            (let ((inherits (layout-inherits layout)))
+              (declare (optimize (safety 0)))
+              (and (> (length inherits) depthoid)
+                   (eq (svref inherits depthoid) slayout)))))))
+
 ;;; Is X a SEQUENCE?  Harder than just (OR VECTOR LIST)
 (defun sequencep (x)
   (or (listp x)

diff --git a/src/code/primordial-type.lisp b/src/code/primordial-type.lisp
index e131dcd..a89b208 100644 (file)
--- a/src/code/primordial-type.lisp
+++ b/src/code/primordial-type.lisp
@@ -19,6 +19,7 @@
 (defvar *universal-fun-type*)
 (defvar *instance-type*)
 (defvar *funcallable-instance-type*)
+(defvar *extended-sequence-type*)
 
 ;;; a vector that maps type codes to layouts, used for quickly finding
 ;;; the layouts of built-in classes

diff --git a/src/code/typep.lisp b/src/code/typep.lisp
index ca3c349..f52c5e7 100644 (file)
--- a/src/code/typep.lisp
+++ b/src/code/typep.lisp
@@ -39,6 +39,7 @@
        ((* t) t)
        ((instance) (%instancep object))
        ((funcallable-instance) (funcallable-instance-p object))
+       ((extended-sequence) (extended-sequence-p object))
        ((nil) nil)))
     (numeric-type
      (and (numberp object)

diff --git a/src/compiler/generic/primtype.lisp b/src/compiler/generic/primtype.lisp
index e3e59b2..5bf2533 100644 (file)
--- a/src/compiler/generic/primtype.lisp
+++ b/src/compiler/generic/primtype.lisp
@@ -356,6 +356,7 @@
            ((t *) (values *backend-t-primitive-type* t))
            ((instance) (exactly instance))
            ((funcallable-instance) (part-of function))
+           ((extended-sequence) (any))
            ((nil) (any))))
         (character-set-type
          (let ((pairs (character-set-type-pairs type)))

diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp
index 8db4fe6..355cf7b 100644 (file)
--- a/src/compiler/generic/vm-fndb.lisp
+++ b/src/compiler/generic/vm-fndb.lisp
@@ -25,7 +25,7 @@
            #!+sb-unicode character-string-p
            #!+sb-unicode simple-character-string-p
            array-header-p
-           sequencep
+           sequencep extended-sequence-p
            simple-array-p simple-array-nil-p vector-nil-p
            simple-array-unsigned-byte-2-p
            simple-array-unsigned-byte-4-p simple-array-unsigned-byte-7-p

diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index 62d2dcd..0eba7aa 100644 (file)
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -137,6 +137,7 @@
   (define-type-predicate rationalp rational)
   (define-type-predicate realp real)
   (define-type-predicate sequencep sequence)
+  (define-type-predicate extended-sequence-p extended-sequence)
   (define-type-predicate simple-bit-vector-p simple-bit-vector)
   (define-type-predicate simple-string-p simple-string)
   (define-type-predicate simple-vector-p simple-vector)

diff --git a/version.lisp-expr b/version.lisp-expr
index a300f9c..83360b1 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".)
-"1.0.3.4"
+"1.0.3.5"