(return (values nil t))))))
(!define-type-method (values :simple-=) (type1 type2)
- (let ((rest1 (args-type-rest type1))
- (rest2 (args-type-rest type2)))
- (cond ((and rest1 rest2 (type/= rest1 rest2))
- (type= rest1 rest2))
- ((or rest1 rest2)
- (values nil t))
- (t
- (multiple-value-bind (req-val req-win)
- (type=-list (values-type-required type1)
- (values-type-required type2))
- (multiple-value-bind (opt-val opt-win)
- (type=-list (values-type-optional type1)
- (values-type-optional type2))
- (values (and req-val opt-val) (and req-win opt-win))))))))
+ (type=-args type1 type2))
(!define-type-class function)
(values nil t))
((eq (fun-type-wild-args type1) t)
(values t t))
- (t (and/type
- (cond ((null (fun-type-rest type1))
- (values (null (fun-type-rest type2)) t))
- ((null (fun-type-rest type2))
- (values nil t))
- (t
- (compare type= rest)))
- (labels ((type-list-= (l1 l2)
- (cond ((null l1)
- (values (null l2) t))
- ((null l2)
- (values nil t))
- (t (multiple-value-bind (res winp)
- (type= (first l1) (first l2))
- (cond ((not winp)
- (values nil nil))
- ((not res)
- (values nil t))
- (t
- (type-list-= (rest l1)
- (rest l2)))))))))
- (and/type (and/type (compare type-list-= required)
- (compare type-list-= optional))
- (if (or (fun-type-keyp type1) (fun-type-keyp type2))
- (values nil nil)
- (values t t))))))))))
+ (t (type=-args type1 type2))))))
(!define-type-class constant :inherits values)
:rest rest)
exactp)))
+(defun type=-args (type1 type2)
+ (macrolet ((compare (comparator field)
+ (let ((reader (symbolicate '#:args-type- field)))
+ `(,comparator (,reader type1) (,reader type2)))))
+ (and/type
+ (cond ((null (args-type-rest type1))
+ (values (null (args-type-rest type2)) t))
+ ((null (args-type-rest type2))
+ (values nil t))
+ (t
+ (compare type= rest)))
+ (and/type (and/type (compare type=-list required)
+ (compare type=-list optional))
+ (if (or (args-type-keyp type1) (args-type-keyp type2))
+ (values nil nil)
+ (values t t))))))
+
;;; Do a union or intersection operation on types that might be values
;;; types. The result is optimized for utility rather than exactness,
;;; but it is guaranteed that it will be no smaller (more restrictive)
(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)
(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