(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))
(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)
(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)
;;; mechanically unparsed.
(!define-type-method (intersection :unparse) (type)
(declare (type ctype type))
- (or (find type '(ratio keyword) :key #'specifier-type :test #'type=)
+ (or (find type '(ratio keyword compiled-function) :key #'specifier-type :test #'type=)
`(and ,@(mapcar #'type-specifier (intersection-type-types type)))))
;;; shared machinery for type equality: true if every type in the set
(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