;; 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*)))
(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
(cond ((eq type2 *universal-type*)
(values t t))
- ((or (type-might-contain-other-types-p type1)
- ;; some CONS types can conceal danger
- (and (cons-type-p type1)
- (cons-type-might-be-empty-type type1)))
+ ;; some CONS types can conceal danger
+ ((and (cons-type-p type1) (cons-type-might-be-empty-type type1))
+ (values nil nil))
+ ((type-might-contain-other-types-p type1)
;; those types can be other types in disguise. So we'd
;; better delegate.
(invoke-complex-subtypep-arg1-method type1 type2))
;; 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)
;; 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)
(typecase type1
(structure-classoid *empty-type*)
(classoid
- (if (and (not (member type1 *non-instance-classoid-types*
- :key #'find-classoid))
- (find (classoid-layout (find-classoid 'function))
- (layout-inherits (classoid-layout type1))))
- type1
- (if (type= type1 (find-classoid 'function))
- type2
- nil)))
+ (if (member type1 *non-instance-classoid-types* :key #'find-classoid)
+ *empty-type*
+ (if (find (classoid-layout (find-classoid 'function))
+ (layout-inherits (classoid-layout type1)))
+ type1
+ (if (type= type1 (find-classoid 'function))
+ type2
+ nil))))
(fun-type nil)
(t
(if (or (type-might-contain-other-types-p type1)
;; 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*
((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))))
(array-type-specialized-element-type type2))
t)))))
-;;; FIXME: is this dead?
(!define-superclasses array
- ((base-string base-string)
- (vector vector)
- (array))
+ ((vector vector) (array))
!cold-init-forms)
(defun array-types-intersect (type1 type2)
(type-intersection (cons-type-car-type type1)
(cons-type-car-type type2))
cdr-int2)))))
+
+(!define-superclasses cons ((cons)) !cold-init-forms)
\f
;;;; CHARACTER-SET types
(!define-type-method (character-set :negate) (type)
(let ((pairs (character-set-type-pairs type)))
(if (and (= (length pairs) 1)
- (= (caar pairs) 0)
- (= (cdar pairs) (1- sb!xc:char-code-limit)))
- (make-negation-type :type type)
- (let ((not-character
- (make-negation-type
- :type (make-character-set-type
- :pairs '((0 . #.(1- sb!xc:char-code-limit)))))))
- (type-union
- not-character
- (make-character-set-type
- :pairs (let (not-pairs)
- (when (> (caar pairs) 0)
- (push (cons 0 (1- (caar pairs))) not-pairs))
- (do* ((tail pairs (cdr tail))
- (high1 (cdar tail))
- (low2 (caadr tail)))
- ((null (cdr tail))
- (when (< (cdar tail) (1- sb!xc:char-code-limit))
- (push (cons (1+ (cdar tail))
- (1- sb!xc:char-code-limit))
- not-pairs))
- (nreverse not-pairs))
- (push (cons (1+ high1) (1- low2)) not-pairs)))))))))
+ (= (caar pairs) 0)
+ (= (cdar pairs) (1- sb!xc:char-code-limit)))
+ (make-negation-type :type type)
+ (let ((not-character
+ (make-negation-type
+ :type (make-character-set-type
+ :pairs '((0 . #.(1- sb!xc:char-code-limit)))))))
+ (type-union
+ not-character
+ (make-character-set-type
+ :pairs (let (not-pairs)
+ (when (> (caar pairs) 0)
+ (push (cons 0 (1- (caar pairs))) not-pairs))
+ (do* ((tail pairs (cdr tail))
+ (high1 (cdar tail) (cdar tail))
+ (low2 (caadr tail) (caadr tail)))
+ ((null (cdr tail))
+ (when (< (cdar tail) (1- sb!xc:char-code-limit))
+ (push (cons (1+ (cdar tail))
+ (1- sb!xc:char-code-limit))
+ not-pairs))
+ (nreverse not-pairs))
+ (push (cons (1+ high1) (1- low2)) not-pairs)))))))))
(!define-type-method (character-set :unparse) (type)
(cond
projects / sbcl.git / blobdiff