(defun-cached (values-type-intersection :hash-function type-cache-hash
:hash-bits 8
- :values 2
- :default (values nil :empty)
+ :default (values nil)
:init-wrapper !cold-init-forms)
((type1 eq) (type2 eq))
(declare (type ctype type1 type2))
- (cond ((eq type1 *wild-type*) (values (coerce-to-values type2) t))
+ (cond ((eq type1 *wild-type*)
+ (coerce-to-values type2))
((or (eq type2 *wild-type*) (eq type2 *universal-type*))
- (values type1 t))
+ type1)
((or (eq type1 *empty-type*) (eq type2 *empty-type*))
*empty-type*)
((and (not (values-type-p type2))
(values-type-required type1))
(let ((req1 (values-type-required type1)))
- (make-values-type :required (cons (type-intersection (first req1) type2)
- (rest req1))
- :optional (values-type-optional type1)
- :rest (values-type-rest type1)
- :allowp (values-type-allowp type1))))
+ (make-values-type :required (cons (type-intersection (first req1) type2)
+ (rest req1))
+ :optional (values-type-optional type1)
+ :rest (values-type-rest type1)
+ :allowp (values-type-allowp type1))))
(t
- (values-type-op type1 (coerce-to-values type2)
- #'type-intersection
- #'max))))
+ (values (values-type-op type1 (coerce-to-values type2)
+ #'type-intersection
+ #'max)))))
;;; This is like TYPES-EQUAL-OR-INTERSECT, except that it sort of
;;; works on VALUES types. Note that due to the semantics of
((or (eq type1 *wild-type*) (eq type2 *wild-type*))
(values t t))
(t
- (multiple-value-bind (res win) (values-type-intersection type1 type2)
+ (let ((res (values-type-intersection type1 type2)))
(values (not (eq res *empty-type*))
- win)))))
+ t)))))
;;; a SUBTYPEP-like operation that can be used on any types, including
;;; VALUES types
(values nil nil))
(!define-type-method (hairy :complex-=) (type1 type2)
- (if (unknown-type-p type2)
+ (if (and (unknown-type-p type2)
+ (let* ((specifier2 (unknown-type-specifier type2))
+ (name2 (if (consp specifier2)
+ (car specifier2)
+ specifier2)))
+ (info :type :kind name2)))
(let ((type2 (specifier-type (unknown-type-specifier type2))))
(if (unknown-type-p type2)
(values nil nil)
(!define-type-class number)
+(declaim (inline numeric-type-equal))
+(defun numeric-type-equal (type1 type2)
+ (and (eq (numeric-type-class type1) (numeric-type-class type2))
+ (eq (numeric-type-format type1) (numeric-type-format type2))
+ (eq (numeric-type-complexp type1) (numeric-type-complexp type2))))
+
(!define-type-method (number :simple-=) (type1 type2)
(values
- (and (eq (numeric-type-class type1) (numeric-type-class type2))
- (eq (numeric-type-format type1) (numeric-type-format type2))
- (eq (numeric-type-complexp type1) (numeric-type-complexp type2))
+ (and (numeric-type-equal type1 type2)
(equalp (numeric-type-low type1) (numeric-type-low type2))
(equalp (numeric-type-high type1) (numeric-type-high type2)))
t))
(case eltype
(bit 'bit-vector)
(base-char 'base-string)
- (character 'string)
(* 'vector)
(t `(vector ,eltype)))
(case eltype
(bit `(bit-vector ,(car dims)))
(base-char `(base-string ,(car dims)))
- (character `(string ,(car dims)))
(t `(vector ,eltype ,(car dims)))))
(if (eq (car dims) '*)
(case eltype
(bit 'simple-bit-vector)
(base-char 'simple-base-string)
- (character 'simple-string)
((t) 'simple-vector)
(t `(simple-array ,eltype (*))))
(case eltype
(bit `(simple-bit-vector ,(car dims)))
(base-char `(simple-base-string ,(car dims)))
- (character `(simple-string ,(car dims)))
((t) `(simple-vector ,(car dims)))
(t `(simple-array ,eltype ,dims))))))
(t
(specialized-element-type-maybe type2))
t)))))
+;;; FIXME: is this dead?
(!define-superclasses array
- ((string string)
+ ((base-string base-string)
(vector vector)
(array))
!cold-init-forms)
((type= type (specifier-type 'real)) 'real)
((type= type (specifier-type 'sequence)) 'sequence)
((type= type (specifier-type 'bignum)) 'bignum)
+ ((type= type (specifier-type 'simple-string)) 'simple-string)
+ ((type= type (specifier-type 'string)) 'string)
(t `(or ,@(mapcar #'type-specifier (union-type-types type))))))
;;; Two union types are equal if they are each subtypes of each