X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=abe32f2b7aae43efe9a669a9b0df18bf7b95a9fb;hb=559d0ded238d8ec852fcd485656ef14578fc405f;hp=1c49b8916d7f7d2263f44a6d91760ad8a79a550f;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 1c49b89..abe32f2 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -196,7 +196,7 @@ (!cold-init-forms (setq *unparse-fun-type-simplify* nil)) (!define-type-method (function :negate) (type) - (error "NOT FUNCTION too confusing on ~S" (type-specifier type))) + (make-negation-type :type type)) (!define-type-method (function :unparse) (type) (if *unparse-fun-type-simplify* @@ -849,7 +849,6 @@ (eql yx :call-other-method)) *empty-type*) (t - (aver (and (not xy) (not yx))) ; else handled above nil)))))))) (defun-cached (type-intersection2 :hash-function type-cache-hash @@ -1048,7 +1047,17 @@ ;; In SBCL it also used to denote universal VALUES type. (frob * *wild-type*) (frob nil *empty-type*) - (frob t *universal-type*)) + (frob t *universal-type*) + ;; new in sbcl-0.9.5: these used to be CLASSOID types, but that + ;; view of them was incompatible with requirements on the MOP + ;; metaobject class hierarchy: the INSTANCE and + ;; FUNCALLABLE-INSTANCE types are disjoint (instances have + ;; instance-pointer-lowtag; funcallable-instances have + ;; fun-pointer-lowtag), while FUNCALLABLE-STANDARD-OBJECT is + ;; required to be a subclass of STANDARD-OBJECT. -- CSR, + ;; 2005-09-09 + (frob instance *instance-type*) + (frob funcallable-instance *funcallable-instance-type*)) (setf *universal-fun-type* (make-fun-type :wild-args t :returns *wild-type*))) @@ -1057,15 +1066,35 @@ ;;(aver (not (eq type1 *wild-type*))) ; * isn't really a type. (values (eq type1 type2) t)) +(defun cons-type-might-be-empty-type (type) + (declare (type cons-type type)) + (let ((car-type (cons-type-car-type type)) + (cdr-type (cons-type-cdr-type type))) + (or + (if (cons-type-p car-type) + (cons-type-might-be-empty-type car-type) + (multiple-value-bind (yes surep) + (type= car-type *empty-type*) + (aver (not yes)) + (not surep))) + (if (cons-type-p cdr-type) + (cons-type-might-be-empty-type cdr-type) + (multiple-value-bind (yes surep) + (type= cdr-type *empty-type*) + (aver (not yes)) + (not surep)))))) + (!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))))) + (or (and (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))))) + (and (cons-type-p type1) + (cons-type-might-be-empty-type type1)))) ;; 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 @@ -1076,7 +1105,10 @@ (!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)) + (aver (not (eq type1 type2))) + (values (or (eq type1 *empty-type*) + (eq type2 *wild-type*) + (eq type2 *universal-type*)) t)) (!define-type-method (named :complex-subtypep-arg1) (type1 type2) ;; This AVER causes problems if we write accurate methods for the @@ -1102,48 +1134,127 @@ ;; is a compound type which might contain a hairy type) by ;; returning uncertainty. (values nil nil)) + ((eq type1 *funcallable-instance-type*) + (values (eq type2 (specifier-type 'function)) t)) (t - ;; By elimination, TYPE1 is the universal type. - (aver (eq type1 *universal-type*)) ;; This case would have been picked off by the SIMPLE-SUBTYPEP ;; method, and so shouldn't appear here. - (aver (not (eq type2 *universal-type*))) - ;; Since TYPE2 is not EQ *UNIVERSAL-TYPE* and is not the - ;; universal type in disguise, TYPE2 is not a superset of TYPE1. + (aver (not (named-type-p type2))) + ;; Since TYPE2 is not EQ *UNIVERSAL-TYPE* and is not another + ;; named type in disguise, TYPE2 is not a superset of TYPE1. (values nil t)))) (!define-type-method (named :complex-subtypep-arg2) (type1 type2) (aver (not (eq type2 *wild-type*))) ; * isn't really a type. (cond ((eq type2 *universal-type*) (values t t)) - ((type-might-contain-other-types-p type1) - ;; those types can be *EMPTY-TYPE* or *UNIVERSAL-TYPE* in - ;; disguise. So we'd better delegate. + ((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))) + ;; those types can be other types in disguise. So we'd + ;; better delegate. (invoke-complex-subtypep-arg1-method type1 type2)) + ((and (eq type2 *instance-type*) (classoid-p type1)) + (if (member type1 *non-instance-classoid-types* :key #'find-classoid) + (values nil t) + (let* ((layout (classoid-layout type1)) + (inherits (layout-inherits layout)) + (functionp (find (classoid-layout (find-classoid 'function)) + inherits))) + (cond + (functionp + (values nil t)) + ((eq type1 (find-classoid 'function)) + (values nil t)) + ((or (basic-structure-classoid-p type1) + #+nil + (condition-classoid-p type1)) + (values t t)) + (t (values nil nil)))))) + ((and (eq type2 *funcallable-instance-type*) (classoid-p type1)) + (if (member type1 *non-instance-classoid-types* :key #'find-classoid) + (values nil t) + (let* ((layout (classoid-layout type1)) + (inherits (layout-inherits layout)) + (functionp (find (classoid-layout (find-classoid 'function)) + inherits))) + (values (if functionp t nil) t)))) (t - ;; FIXME: This seems to rely on there only being 2 or 3 + ;; FIXME: This seems to rely on there only being 4 or 5 ;; NAMED-TYPE values, and the exclusion of various ;; possibilities above. It would be good to explain it and/or ;; rewrite it so that it's clearer. - (values (not (eq type2 *empty-type*)) t)))) + (values nil t)))) (!define-type-method (named :complex-intersection2) (type1 type2) ;; FIXME: This assertion failed when I added it in sbcl-0.6.11.13. ;; Perhaps when bug 85 is fixed it can be reenabled. ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type. - (hierarchical-intersection2 type1 type2)) + (cond + ((eq type2 *instance-type*) + (if (classoid-p type1) + (if (and (not (member type1 *non-instance-classoid-types* + :key #'find-classoid)) + (not (find (classoid-layout (find-classoid 'function)) + (layout-inherits (classoid-layout type1))))) + type1 + *empty-type*) + (if (type-might-contain-other-types-p type1) + nil + *empty-type*))) + ((eq type2 *funcallable-instance-type*) + (if (classoid-p type1) + (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)) + type1 + nil)) + (if (fun-type-p type1) + nil + (if (type-might-contain-other-types-p type1) + nil + *empty-type*)))) + (t (hierarchical-intersection2 type1 type2)))) (!define-type-method (named :complex-union2) (type1 type2) ;; Perhaps when bug 85 is fixed this can be reenabled. ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type. - (hierarchical-union2 type1 type2)) + (cond + ((eq type2 *instance-type*) + (if (classoid-p type1) + (if (or (member type1 *non-instance-classoid-types* + :key #'find-classoid) + (find (classoid-layout (find-classoid 'function)) + (layout-inherits (classoid-layout type1)))) + nil + type2) + nil)) + ((eq type2 *funcallable-instance-type*) + (if (classoid-p type1) + (if (or (member type1 *non-instance-classoid-types* + :key #'find-classoid) + (not (find (classoid-layout (find-classoid 'function)) + (layout-inherits (classoid-layout type1))))) + nil + (if (eq type1 (specifier-type 'function)) + type1 + type2)) + nil)) + (t (hierarchical-union2 type1 type2)))) (!define-type-method (named :negate) (x) (aver (not (eq x *wild-type*))) (cond ((eq x *universal-type*) *empty-type*) ((eq x *empty-type*) *universal-type*) - (t (bug "NAMED type not universal, wild or empty: ~S" x)))) + ((or (eq x *instance-type*) + (eq x *funcallable-instance-type*)) + (make-negation-type :type x)) + (t (bug "NAMED type unexpected: ~S" x)))) (!define-type-method (named :unparse) (x) (named-type-name x)) @@ -1717,55 +1828,51 @@ (if (csubtypep component-type (specifier-type '(eql 0))) *empty-type* (modified-numeric-type component-type - :complexp :complex)))) + :complexp :complex))) + (do-complex (ctype) + (cond + ((eq ctype *empty-type*) *empty-type*) + ((eq ctype *universal-type*) (not-real)) + ((typep ctype 'numeric-type) (complex1 ctype)) + ((typep ctype 'union-type) + (apply #'type-union + (mapcar #'do-complex (union-type-types ctype)))) + ((typep ctype 'member-type) + (apply #'type-union + (mapcar (lambda (x) (do-complex (ctype-of x))) + (member-type-members ctype)))) + ((and (typep ctype 'intersection-type) + ;; FIXME: This is very much a + ;; not-quite-worst-effort, but we are required to do + ;; something here because of our representation of + ;; RATIO as (AND RATIONAL (NOT INTEGER)): we must + ;; allow users to ask about (COMPLEX RATIO). This + ;; will of course fail to work right on such types + ;; as (AND INTEGER (SATISFIES ZEROP))... + (let ((numbers (remove-if-not + #'numeric-type-p + (intersection-type-types ctype)))) + (and (car numbers) + (null (cdr numbers)) + (eq (numeric-type-complexp (car numbers)) :real) + (complex1 (car numbers)))))) + (t + (multiple-value-bind (subtypep certainly) + (csubtypep ctype (specifier-type 'real)) + (if (and (not subtypep) certainly) + (not-real) + ;; ANSI just says that TYPESPEC is any subtype of + ;; type REAL, not necessarily a NUMERIC-TYPE. In + ;; particular, at this point TYPESPEC could legally + ;; be a hairy type like (AND NUMBER (SATISFIES + ;; REALP) (SATISFIES ZEROP)), in which case we fall + ;; through the logic above and end up here, + ;; stumped. + (bug "~@<(known bug #145): The type ~S is too hairy to be ~ +used for a COMPLEX component.~:@>" + typespec))))))) (let ((ctype (specifier-type typespec))) - (cond - ((eq ctype *empty-type*) *empty-type*) - ((eq ctype *universal-type*) (not-real)) - ((typep ctype 'numeric-type) (complex1 ctype)) - ((typep ctype 'union-type) - (apply #'type-union - ;; FIXME: This code could suffer from (admittedly - ;; very obscure) cases of bug 145 e.g. when TYPE - ;; is - ;; (OR (AND INTEGER (SATISFIES ODDP)) - ;; (AND FLOAT (SATISFIES FOO)) - ;; and not even report the problem very well. - (mapcar #'complex1 (union-type-types ctype)))) - ((typep ctype 'member-type) - (apply #'type-union - (mapcar (lambda (x) (complex1 (ctype-of x))) - (member-type-members ctype)))) - ((and (typep ctype 'intersection-type) - ;; FIXME: This is very much a - ;; not-quite-worst-effort, but we are required to do - ;; something here because of our representation of - ;; RATIO as (AND RATIONAL (NOT INTEGER)): we must - ;; allow users to ask about (COMPLEX RATIO). This - ;; will of course fail to work right on such types - ;; as (AND INTEGER (SATISFIES ZEROP))... - (let ((numbers (remove-if-not - #'numeric-type-p - (intersection-type-types ctype)))) - (and (car numbers) - (null (cdr numbers)) - (eq (numeric-type-complexp (car numbers)) :real) - (complex1 (car numbers)))))) - (t - (multiple-value-bind (subtypep certainly) - (csubtypep ctype (specifier-type 'real)) - (if (and (not subtypep) certainly) - (not-real) - ;; ANSI just says that TYPESPEC is any subtype of - ;; type REAL, not necessarily a NUMERIC-TYPE. In - ;; particular, at this point TYPESPEC could legally - ;; be a hairy type like (AND NUMBER (SATISFIES - ;; REALP) (SATISFIES ZEROP)), in which case we fall - ;; through the logic above and end up here, - ;; stumped. - (bug "~@<(known bug #145): The type ~S is too hairy to be ~ - used for a COMPLEX component.~:@>" - typespec))))))))) + (do-complex ctype))))) ;;; If X is *, return NIL, otherwise return the bound, which must be a ;;; member of TYPE or a one-element list of a member of TYPE. @@ -2003,7 +2110,17 @@ (if up-p (1+ cx) (1- cx)) (if up-p (ceiling cx) (floor cx)))) (float - (let ((res (if format (coerce cx format) (float cx)))) + (let ((res + (cond + ((and format (subtypep format 'double-float)) + (if (<= most-negative-double-float cx most-positive-double-float) + (coerce cx format) + nil)) + (t + (if (<= most-negative-single-float cx most-positive-single-float) + ;; FIXME: bug #389 + (coerce cx (or format 'single-float)) + nil))))) (if (consp x) (list res) res))))) nil)) @@ -2845,7 +2962,8 @@ (csubtypep (cons-type-cdr-type type1) (cons-type-cdr-type type2)) (if (and val-car val-cdr) (values t (and win-car win-cdr)) - (values nil (or win-car win-cdr)))))) + (values nil (or (and (not val-car) win-car) + (and (not val-cdr) win-cdr))))))) ;;; Give up if a precise type is not possible, to avoid returning ;;; overly general types. @@ -2881,11 +2999,15 @@ ;; more general case of the above, but harder to compute ((progn (setf car-not1 (type-negation car-type1)) - (not (csubtypep car-type2 car-not1))) + (multiple-value-bind (yes win) + (csubtypep car-type2 car-not1) + (and (not yes) win))) (frob-car car-type1 car-type2 cdr-type1 cdr-type2 car-not1)) ((progn (setf car-not2 (type-negation car-type2)) - (not (csubtypep car-type1 car-not2))) + (multiple-value-bind (yes win) + (csubtypep car-type1 car-not2) + (and (not yes) win))) (frob-car car-type2 car-type1 cdr-type2 cdr-type1 car-not2)) ;; Don't put these in -- consider the effect of taking the ;; union of (CONS (INTEGER 0 2) (INTEGER 5 7)) and @@ -2957,8 +3079,8 @@ ((type= type (specifier-type 'standard-char)) 'standard-char) (t (let ((pairs (character-set-type-pairs type))) `(member ,@(loop for (low . high) in pairs - append (loop for code from low upto high - collect (sb!xc:code-char code)))))))) + nconc (loop for code from low upto high + collect (sb!xc:code-char code)))))))) (!define-type-method (character-set :simple-=) (type1 type2) (let ((pairs1 (character-set-type-pairs type1)) @@ -2986,6 +3108,7 @@ (!define-type-method (character-set :simple-intersection2) (type1 type2) ;; KLUDGE: brute force. +#| (let (pairs) (dolist (pair1 (character-set-type-pairs type1) (make-character-set-type @@ -2995,7 +3118,54 @@ ((<= (car pair1) (car pair2) (cdr pair1)) (push (cons (car pair2) (min (cdr pair1) (cdr pair2))) pairs)) ((<= (car pair2) (car pair1) (cdr pair2)) - (push (cons (car pair1) (min (cdr pair1) (cdr pair2))) pairs))))))) + (push (cons (car pair1) (min (cdr pair1) (cdr pair2))) pairs)))))) +|# + (make-character-set-type + :pairs (intersect-type-pairs + (character-set-type-pairs type1) + (character-set-type-pairs type2)))) + +;;; +;;; Intersect two ordered lists of pairs +;;; Each list is of the form ((start1 . end1) ... (startn . endn)), +;;; where start1 <= end1 < start2 <= end2 < ... < startn <= endn. +;;; Each pair represents the integer interval start..end. +;;; +(defun intersect-type-pairs (alist1 alist2) + (if (and alist1 alist2) + (let ((res nil) + (pair1 (pop alist1)) + (pair2 (pop alist2))) + (loop + (when (> (car pair1) (car pair2)) + (rotatef pair1 pair2) + (rotatef alist1 alist2)) + (let ((pair1-cdr (cdr pair1))) + (cond + ((> (car pair2) pair1-cdr) + ;; No over lap -- discard pair1 + (unless alist1 (return)) + (setq pair1 (pop alist1))) + ((<= (cdr pair2) pair1-cdr) + (push (cons (car pair2) (cdr pair2)) res) + (cond + ((= (cdr pair2) pair1-cdr) + (unless alist1 (return)) + (unless alist2 (return)) + (setq pair1 (pop alist1) + pair2 (pop alist2))) + (t ;; (< (cdr pair2) pair1-cdr) + (unless alist2 (return)) + (setq pair1 (cons (1+ (cdr pair2)) pair1-cdr)) + (setq pair2 (pop alist2))))) + (t ;; (> (cdr pair2) (cdr pair1)) + (push (cons (car pair2) pair1-cdr) res) + (unless alist1 (return)) + (setq pair2 (cons (1+ pair1-cdr) (cdr pair2))) + (setq pair1 (pop alist1)))))) + (nreverse res)) + nil)) + ;;; Return the type that describes all objects that are in X but not ;;; in Y. If we can't determine this type, then return NIL.