X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=15b8cb518a8faa4318a55d9a0ece0d54e2347646;hb=b3a419f10ad442a1c59d51edabdc70518f193648;hp=623ff1cb3e237901ca7572c65d5bee8007c4b7c7;hpb=05449b9101cdf156f48e7cf935d3874dc7cbadeb;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 623ff1c..15b8cb5 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -77,15 +77,16 @@ (values ;; FIXME: This old CMU CL code probably deserves a comment ;; explaining to us mere mortals how it works... - (and (sb!xc:typep type2 'sb!xc:class) + (and (sb!xc:typep type2 'classoid) (dolist (x info nil) (when (or (not (cdr x)) (csubtypep type1 (specifier-type (cdr x)))) (return (or (eq type2 (car x)) - (let ((inherits (layout-inherits (class-layout (car x))))) + (let ((inherits (layout-inherits + (classoid-layout (car x))))) (dotimes (i (length inherits) nil) - (when (eq type2 (layout-class (svref inherits i))) + (when (eq type2 (layout-classoid (svref inherits i))) (return t))))))))) t))) @@ -110,7 +111,7 @@ (destructuring-bind (super &optional guard) spec - (cons (sb!xc:find-class super) guard))) + (cons (find-classoid super) guard))) ',specs))) (setf (type-class-complex-subtypep-arg1 ,type-class) (lambda (type1 type2) @@ -1011,6 +1012,23 @@ ;;(aver (not (eq type1 *wild-type*))) ; * isn't really a type. (values (eq type1 type2) t)) +(!define-type-method (named :complex-=) (type1 type2) + (cond + ((and (eq type2 *empty-type*) + (intersection-type-p type1) + ;; not allowed to be unsure on these... FIXME: keep the list + ;; of CL types that are intersection types once and only + ;; once. + (not (or (type= type1 (specifier-type 'ratio)) + (type= type1 (specifier-type 'keyword))))) + ;; things like (AND (EQL 0) (SATISFIES ODDP)) or (AND FUNCTION + ;; STREAM) can get here. In general, we can't really tell + ;; whether these are equal to NIL or not, so + (values nil nil)) + ((type-might-contain-other-types-p type1) + (invoke-complex-=-other-method type1 type2)) + (t (values nil t)))) + (!define-type-method (named :simple-subtypep) (type1 type2) (aver (not (eq type1 *wild-type*))) ; * isn't really a type. (values (or (eq type1 *empty-type*) (eq type2 *wild-type*)) t)) @@ -1053,7 +1071,9 @@ (aver (not (eq type2 *wild-type*))) ; * isn't really a type. (cond ((eq type2 *universal-type*) (values t t)) - ((hairy-type-p type1) + ((type-might-contain-other-types-p type1) + ;; those types can be *EMPTY-TYPE* or *UNIVERSAL-TYPE* in + ;; disguise. So we'd better delegate. (invoke-complex-subtypep-arg1-method type1 type2)) (t ;; FIXME: This seems to rely on there only being 2 or 3 @@ -1145,7 +1165,8 @@ (intersection2 (type-intersection2 type1 complement-type2))) (if intersection2 - (values (eq intersection2 *empty-type*) t) + ;; FIXME: if uncertain, maybe try arg1? + (type= intersection2 *empty-type*) (invoke-complex-subtypep-arg1-method type1 type2)))) (!define-type-method (negation :complex-subtypep-arg1) (type1 type2) @@ -2405,9 +2426,7 @@ (intersection-type-types type2))) (defun %intersection-complex-subtypep-arg1 (type1 type2) - (any/type (swapped-args-fun #'csubtypep) - type2 - (intersection-type-types type1))) + (type= type1 (type-intersection type1 type2))) (defun %intersection-simple-subtypep (type1 type2) (every/type #'%intersection-complex-subtypep-arg1 @@ -2449,6 +2468,28 @@ ((and (not (intersection-type-p type1)) (%intersection-complex-subtypep-arg1 type2 type1)) type1) + ;; KLUDGE: This special (and somewhat hairy) magic is required + ;; to deal with the RATIONAL/INTEGER special case. The UNION + ;; of (INTEGER * -1) and (AND (RATIONAL * -1/2) (NOT INTEGER)) + ;; should be (RATIONAL * -1/2) -- CSR, 2003-02-28 + ((and (csubtypep type2 (specifier-type 'ratio)) + (numeric-type-p type1) + (csubtypep type1 (specifier-type 'integer)) + (csubtypep type2 + (make-numeric-type + :class 'rational + :complexp nil + :low (if (null (numeric-type-low type1)) + nil + (list (1- (numeric-type-low type1)))) + :high (if (null (numeric-type-high type1)) + nil + (list (1+ (numeric-type-high type1))))))) + (type-union type1 + (apply #'type-intersection + (remove (specifier-type '(not integer)) + (intersection-type-types type2) + :test #'type=)))) (t (let ((accumulator *universal-type*)) (do ((t2s (intersection-type-types type2) (cdr t2s))) @@ -2519,8 +2560,7 @@ (!define-type-method (union :complex-=) (type1 type2) (declare (ignore type1)) - (if (some #'(lambda (x) (or (hairy-type-p x) - (negation-type-p x))) + (if (some #'type-might-contain-other-types-p (union-type-types type2)) (values nil nil) (values nil t))) @@ -2681,13 +2721,35 @@ (car-type2 (cons-type-car-type type2)) (cdr-type1 (cons-type-cdr-type type1)) (cdr-type2 (cons-type-cdr-type type2))) - (cond ((type= car-type1 car-type2) - (make-cons-type car-type1 - (type-union cdr-type1 cdr-type2))) - ((type= cdr-type1 cdr-type2) - (make-cons-type (type-union cdr-type1 cdr-type2) - cdr-type1))))) - + ;; UGH. -- CSR, 2003-02-24 + (macrolet ((frob-car (car1 car2 cdr1 cdr2) + `(type-union + (make-cons-type ,car1 (type-union ,cdr1 ,cdr2)) + (make-cons-type + (type-intersection ,car2 + (specifier-type + `(not ,(type-specifier ,car1)))) + ,cdr2)))) + (cond ((type= car-type1 car-type2) + (make-cons-type car-type1 + (type-union cdr-type1 cdr-type2))) + ((type= cdr-type1 cdr-type2) + (make-cons-type (type-union car-type1 car-type2) + cdr-type1)) + ((csubtypep car-type1 car-type2) + (frob-car car-type1 car-type2 cdr-type1 cdr-type2)) + ((csubtypep car-type2 car-type1) + (frob-car car-type2 car-type1 cdr-type2 cdr-type1)) + ;; Don't put these in -- consider the effect of taking the + ;; union of (CONS (INTEGER 0 2) (INTEGER 5 7)) and + ;; (CONS (INTEGER 0 3) (INTEGER 5 6)). + #+nil + ((csubtypep cdr-type1 cdr-type2) + (frob-cdr car-type1 car-type2 cdr-type1 cdr-type2)) + #+nil + ((csubtypep cdr-type2 cdr-type1) + (frob-cdr car-type2 car-type1 cdr-type2 cdr-type1)))))) + (!define-type-method (cons :simple-intersection2) (type1 type2) (declare (type cons-type type1 type2)) (let (car-int2 @@ -2767,8 +2829,8 @@ (defun defined-ftype-matches-declared-ftype-p (defined-ftype declared-ftype) (declare (type ctype defined-ftype declared-ftype)) (flet ((is-built-in-class-function-p (ctype) - (and (built-in-class-p ctype) - (eq (built-in-class-%name ctype) 'function)))) + (and (built-in-classoid-p ctype) + (eq (built-in-classoid-name ctype) 'function)))) (cond (;; DECLARED-FTYPE could certainly be #; ;; that's what happens when we (DECLAIM (FTYPE FUNCTION FOO)). (is-built-in-class-function-p declared-ftype)