X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Flate-type.lisp;h=15b8cb518a8faa4318a55d9a0ece0d54e2347646;hb=b3a419f10ad442a1c59d51edabdc70518f193648;hp=a5e69ac11c09308ed93a98a1175566f18ef0c776;hpb=9e82d9fee6f2f029098a5463556dc5ae2ed47c4e;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index a5e69ac..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) @@ -1233,9 +1254,9 @@ (!define-type-method (negation :complex-=) (type1 type2) ;; (NOT FOO) isn't equivalent to anything that's not a negation - ;; type, except possibly a hairy type. + ;; type, except possibly a type that might contain it in disguise. (declare (ignore type2)) - (if (hairy-type-p type1) + (if (type-might-contain-other-types-p type1) (values nil nil) (values nil t))) @@ -1336,6 +1357,36 @@ (mapcar #'(lambda (x) (specifier-type `(not ,(type-specifier x)))) (union-type-types not-type)))) + ((and (cons-type-p not-type) + (eq (cons-type-car-type not-type) *universal-type*) + (eq (cons-type-cdr-type not-type) *universal-type*)) + (make-negation-type :type not-type)) + ((cons-type-p not-type) + (type-union + (make-negation-type :type (specifier-type 'cons)) + (cond + ((and (not (eq (cons-type-car-type not-type) *universal-type*)) + (not (eq (cons-type-cdr-type not-type) *universal-type*))) + (type-union + (make-cons-type + (specifier-type `(not ,(type-specifier + (cons-type-car-type not-type)))) + *universal-type*) + (make-cons-type + *universal-type* + (specifier-type `(not ,(type-specifier + (cons-type-cdr-type not-type))))))) + ((not (eq (cons-type-car-type not-type) *universal-type*)) + (make-cons-type + (specifier-type `(not ,(type-specifier + (cons-type-car-type not-type)))) + *universal-type*)) + ((not (eq (cons-type-cdr-type not-type) *universal-type*)) + (make-cons-type + *universal-type* + (specifier-type `(not ,(type-specifier + (cons-type-cdr-type not-type)))))) + (t (bug "Weird CONS type ~S" not-type))))) (t (make-negation-type :type not-type))))) ;;;; numeric types @@ -1505,11 +1556,13 @@ (null complexp2))) (values nil t)) ;; If the classes are specified and different, the types are - ;; disjoint unless type2 is rational and type1 is integer. + ;; disjoint unless type2 is RATIONAL and type1 is INTEGER. + ;; [ or type1 is INTEGER and type2 is of the form (RATIONAL + ;; X X) for integral X, but this is dealt with in the + ;; canonicalization inside MAKE-NUMERIC-TYPE ] ((not (or (eq class1 class2) (null class2) - (and (eq class1 'integer) - (eq class2 'rational)))) + (and (eq class1 'integer) (eq class2 'rational)))) (values nil t)) ;; If the float formats are specified and different, the types ;; are disjoint. @@ -1563,8 +1616,10 @@ ;;; Return a numeric type that is a supertype for both TYPE1 and TYPE2. ;;; -;;; ### Note: we give up early to keep from dropping lots of information on -;;; the floor by returning overly general types. +;;; Old comment, probably no longer applicable: +;;; +;;; ### Note: we give up early to keep from dropping lots of +;;; information on the floor by returning overly general types. (!define-type-method (number :simple-union2) (type1 type2) (declare (type numeric-type type1 type2)) (cond ((csubtypep type1 type2) type2) @@ -1576,22 +1631,65 @@ (class2 (numeric-type-class type2)) (format2 (numeric-type-format type2)) (complexp2 (numeric-type-complexp type2))) - (when (and (eq class1 class2) - (eq format1 format2) - (eq complexp1 complexp2) - (or (numeric-types-intersect type1 type2) - (numeric-types-adjacent type1 type2) - (numeric-types-adjacent type2 type1))) - (make-numeric-type - :class class1 - :format format1 - :complexp complexp1 - :low (numeric-bound-max (numeric-type-low type1) - (numeric-type-low type2) - <= < t) - :high (numeric-bound-max (numeric-type-high type1) - (numeric-type-high type2) - >= > t))))))) + (cond + ((and (eq class1 class2) + (eq format1 format2) + (eq complexp1 complexp2) + (or (numeric-types-intersect type1 type2) + (numeric-types-adjacent type1 type2) + (numeric-types-adjacent type2 type1))) + (make-numeric-type + :class class1 + :format format1 + :complexp complexp1 + :low (numeric-bound-max (numeric-type-low type1) + (numeric-type-low type2) + <= < t) + :high (numeric-bound-max (numeric-type-high type1) + (numeric-type-high type2) + >= > t))) + ;; FIXME: These two clauses are almost identical, and the + ;; consequents are in fact identical in every respect. + ((and (eq class1 'rational) + (eq class2 'integer) + (eq format1 format2) + (eq complexp1 complexp2) + (integerp (numeric-type-low type2)) + (integerp (numeric-type-high type2)) + (= (numeric-type-low type2) (numeric-type-high type2)) + (or (numeric-types-adjacent type1 type2) + (numeric-types-adjacent type2 type1))) + (make-numeric-type + :class 'rational + :format format1 + :complexp complexp1 + :low (numeric-bound-max (numeric-type-low type1) + (numeric-type-low type2) + <= < t) + :high (numeric-bound-max (numeric-type-high type1) + (numeric-type-high type2) + >= > t))) + ((and (eq class1 'integer) + (eq class2 'rational) + (eq format1 format2) + (eq complexp1 complexp2) + (integerp (numeric-type-low type1)) + (integerp (numeric-type-high type1)) + (= (numeric-type-low type1) (numeric-type-high type1)) + (or (numeric-types-adjacent type1 type2) + (numeric-types-adjacent type2 type1))) + (make-numeric-type + :class 'rational + :format format1 + :complexp complexp1 + :low (numeric-bound-max (numeric-type-low type1) + (numeric-type-low type2) + <= < t) + :high (numeric-bound-max (numeric-type-high type1) + (numeric-type-high type2) + >= > t))) + (t nil)))))) + (!cold-init-forms (setf (info :type :kind 'number) @@ -1701,9 +1799,6 @@ (h (canonicalized-bound high 'integer)) (hb (if (consp h) (1- (car h)) h))) (if (and hb lb (< hb lb)) - ;; previously we threw an error here: - ;; (error "Lower bound ~S is greater than upper bound ~S." l h)) - ;; but ANSI doesn't say anything about that, so: *empty-type* (make-numeric-type :class 'integer :complexp :real @@ -1716,9 +1811,6 @@ (let ((lb (canonicalized-bound low ',type)) (hb (canonicalized-bound high ',type))) (if (not (numeric-bound-test* lb hb <= <)) - ;; as above, previously we did - ;; (error "Lower bound ~S is not less than upper bound ~S." low high)) - ;; but it is correct to do *empty-type* (make-numeric-type :class ',class :format ',format @@ -2334,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 @@ -2378,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))) @@ -2448,7 +2560,8 @@ (!define-type-method (union :complex-=) (type1 type2) (declare (ignore type1)) - (if (some #'hairy-type-p (union-type-types type2)) + (if (some #'type-might-contain-other-types-p + (union-type-types type2)) (values nil nil) (values nil t))) @@ -2575,10 +2688,7 @@ (!def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*)) (let ((car-type (specifier-type car-type-spec)) (cdr-type (specifier-type cdr-type-spec))) - (if (or (eq car-type *empty-type*) - (eq cdr-type *empty-type*)) - *empty-type* - (make-cons-type car-type cdr-type)))) + (make-cons-type car-type cdr-type))) (!define-type-method (cons :unparse) (type) (let ((car-eltype (type-specifier (cons-type-car-type type))) @@ -2611,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 @@ -2697,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)