Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv30261/src/code
Modified Files:
class.lisp deftypes-for-target.lisp early-type.lisp
late-type.lisp pred.lisp primordial-type.lisp typep.lisp
Log Message:
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...)
Index: class.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/class.lisp,v
retrieving revision 1.74
retrieving revision 1.75
diff -u -d -r1.74 -r1.75
--- class.lisp 5 Dec 2006 17:50:20 -0000 1.74
+++ class.lisp 28 Feb 2007 16:05:59 -0000 1.75
@@ -913,22 +913,6 @@
;; 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 @@
:inherits (array)
:prototype-form (make-array nil))
(sequence
+ :translation (or cons (member nil) vector extended-sequence)
:state :read-only
:depth 2)
(vector
Index: deftypes-for-target.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/deftypes-for-target.lisp,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -d -r1.27 -r1.28
--- deftypes-for-target.lisp 5 Dec 2006 17:50:20 -0000 1.27
+++ deftypes-for-target.lisp 28 Feb 2007 16:05:59 -0000 1.28
@@ -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))
Index: early-type.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-type.lisp,v
retrieving revision 1.49
retrieving revision 1.50
diff -u -d -r1.49 -r1.50
--- early-type.lisp 5 Dec 2006 17:50:21 -0000 1.49
+++ early-type.lisp 28 Feb 2007 16:06:00 -0000 1.50
@@ -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))
Index: late-type.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/late-type.lisp,v
retrieving revision 1.136
retrieving revision 1.137
diff -u -d -r1.136 -r1.137
--- late-type.lisp 5 Dec 2006 17:50:21 -0000 1.136
+++ late-type.lisp 28 Feb 2007 16:06:00 -0000 1.137
@@ -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))))
Index: pred.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/pred.lisp,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -d -r1.26 -r1.27
--- pred.lisp 5 Dec 2006 17:50:21 -0000 1.26
+++ pred.lisp 28 Feb 2007 16:06:00 -0000 1.27
@@ -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)
Index: primordial-type.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/primordial-type.lisp,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -d -r1.3 -r1.4
--- primordial-type.lisp 16 Jul 2006 06:48:19 -0000 1.3
+++ primordial-type.lisp 28 Feb 2007 16:06:01 -0000 1.4
@@ -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
Index: typep.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/typep.lisp,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -d -r1.21 -r1.22
--- typep.lisp 8 Aug 2006 20:14:22 -0000 1.21
+++ typep.lisp 28 Feb 2007 16:06:01 -0000 1.22
@@ -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)
|