X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=6f6e61081a9a79084a162c0374012bc5e55ce55f;hb=98a76d4426660876dec6649b1e228d2e5b47f579;hp=88eb018d725702ae6379aa965af6098c6b4b6263;hpb=800a2438e26a475325343134a39c7a3c09ba588f;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 88eb018..6f6e610 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -22,14 +22,8 @@ ;;; ### Remaining incorrectnesses: ;;; -;;; TYPE-UNION (and the OR type) doesn't properly canonicalize an -;;; exhaustive partition or coalesce contiguous ranges of numeric -;;; types. -;;; ;;; There are all sorts of nasty problems with open bounds on FLOAT ;;; types (and probably FLOAT types in general.) -;;; -;;; RATIO and BIGNUM are not recognized as numeric types. ;;; FIXME: This really should go away. Alas, it doesn't seem to be so ;;; simple to make it go away.. (See bug 123 in BUGS file.) @@ -77,15 +71,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 +105,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) @@ -230,43 +225,35 @@ (csubtypep a1 a2) (unless res (return (values res sure-p)))) finally (return (values t t))))) - (macrolet ((3and (x y) - `(multiple-value-bind (val1 win1) ,x - (if (and (not val1) win1) - (values nil t) - (multiple-value-bind (val2 win2) ,y - (if (and val1 val2) - (values t t) - (values nil (and win2 (not val2))))))))) - (3and (values-subtypep (fun-type-returns type1) - (fun-type-returns type2)) - (cond ((fun-type-wild-args type2) (values t t)) - ((fun-type-wild-args type1) - (cond ((fun-type-keyp type2) (values nil nil)) - ((not (fun-type-rest type2)) (values nil t)) - ((not (null (fun-type-required type2))) (values nil t)) - (t (3and (type= *universal-type* (fun-type-rest type2)) - (every/type #'type= *universal-type* - (fun-type-optional type2)))))) - ((not (and (fun-type-simple-p type1) - (fun-type-simple-p type2))) - (values nil nil)) - (t (multiple-value-bind (min1 max1) (fun-type-nargs type1) - (multiple-value-bind (min2 max2) (fun-type-nargs type2) - (cond ((or (> max1 max2) (< min1 min2)) - (values nil t)) - ((and (= min1 min2) (= max1 max2)) - (3and (every-csubtypep (fun-type-required type1) - (fun-type-required type2)) - (every-csubtypep (fun-type-optional type1) - (fun-type-optional type2)))) - (t (every-csubtypep - (concatenate 'list - (fun-type-required type1) - (fun-type-optional type1)) - (concatenate 'list - (fun-type-required type2) - (fun-type-optional type2))))))))))))) + (and/type (values-subtypep (fun-type-returns type1) + (fun-type-returns type2)) + (cond ((fun-type-wild-args type2) (values t t)) + ((fun-type-wild-args type1) + (cond ((fun-type-keyp type2) (values nil nil)) + ((not (fun-type-rest type2)) (values nil t)) + ((not (null (fun-type-required type2))) (values nil t)) + (t (and/type (type= *universal-type* (fun-type-rest type2)) + (every/type #'type= *universal-type* + (fun-type-optional type2)))))) + ((not (and (fun-type-simple-p type1) + (fun-type-simple-p type2))) + (values nil nil)) + (t (multiple-value-bind (min1 max1) (fun-type-nargs type1) + (multiple-value-bind (min2 max2) (fun-type-nargs type2) + (cond ((or (> max1 max2) (< min1 min2)) + (values nil t)) + ((and (= min1 min2) (= max1 max2)) + (and/type (every-csubtypep (fun-type-required type1) + (fun-type-required type2)) + (every-csubtypep (fun-type-optional type1) + (fun-type-optional type2)))) + (t (every-csubtypep + (concatenate 'list + (fun-type-required type1) + (fun-type-optional type1)) + (concatenate 'list + (fun-type-required type2) + (fun-type-optional type2)))))))))))) (!define-superclasses function ((function)) !cold-init-forms) @@ -278,6 +265,18 @@ (declare (ignore type1 type2)) (specifier-type 'function)) +;;; The union or intersection of a subclass of FUNCTION with a +;;; FUNCTION type is somewhat complicated. +(!define-type-method (function :complex-intersection2) (type1 type2) + (cond + ((type= type1 (specifier-type 'function)) type2) + ((csubtypep type1 (specifier-type 'function)) nil) + (t :call-other-method))) +(!define-type-method (function :complex-union2) (type1 type2) + (cond + ((type= type1 (specifier-type 'function)) type1) + (t nil))) + ;;; ### Not very real, but good enough for redefining transforms ;;; according to type: (!define-type-method (function :simple-=) (type1 type2) @@ -294,37 +293,6 @@ (!def-type-translator constant-arg (type) (make-constant-type :type (specifier-type type))) -;;; Given a LAMBDA-LIST-like values type specification and an ARGS-TYPE -;;; structure, fill in the slots in the structure accordingly. This is -;;; used for both FUNCTION and VALUES types. -(declaim (ftype (function (list args-type) (values)) parse-args-types)) -(defun parse-args-types (lambda-list result) - (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux) - (parse-lambda-list-like-thing lambda-list) - (declare (ignore aux)) ; since we require AUXP=NIL - (when auxp - (error "&AUX in a FUNCTION or VALUES type: ~S." lambda-list)) - (setf (args-type-required result) - (mapcar #'single-value-specifier-type required)) - (setf (args-type-optional result) - (mapcar #'single-value-specifier-type optional)) - (setf (args-type-rest result) - (if restp (single-value-specifier-type rest) nil)) - (setf (args-type-keyp result) keyp) - (collect ((key-info)) - (dolist (key keys) - (unless (proper-list-of-length-p key 2) - (error "Keyword type description is not a two-list: ~S." key)) - (let ((kwd (first key))) - (when (find kwd (key-info) :key #'key-info-name) - (error "~@" - kwd lambda-list)) - (key-info (make-key-info :name kwd - :type (single-value-specifier-type (second key)))))) - (setf (args-type-keywords result) (key-info))) - (setf (args-type-allowp result) allowp) - (values))) - ;;; Return the lambda-list-like type specification corresponding ;;; to an ARGS-TYPE. (declaim (ftype (function (args-type) list) unparse-args-types)) @@ -355,16 +323,10 @@ (result))) (!def-type-translator function (&optional (args '*) (result '*)) - (let ((res (make-fun-type :returns (values-specifier-type result)))) - (if (eq args '*) - (setf (fun-type-wild-args res) t) - (parse-args-types args res)) - res)) + (make-fun-type :args args :returns (values-specifier-type result))) (!def-type-translator values (&rest values) - (let ((res (%make-values-type))) - (parse-args-types values res) - res)) + (make-values-type :args values)) ;;;; VALUES types interfaces ;;;; @@ -394,7 +356,7 @@ ;;; type, return NIL, NIL. (defun fun-type-nargs (type) (declare (type ctype type)) - (if (fun-type-p type) + (if (and (fun-type-p type) (not (fun-type-wild-args type))) (let ((fixed (length (args-type-required type)))) (if (or (args-type-rest type) (args-type-keyp type) @@ -729,14 +691,14 @@ (flet ((1way (x y) (!invoke-type-method :simple-intersection2 :complex-intersection2 x y - :default :no-type-method-found))) + :default :call-other-method))) (declare (inline 1way)) (let ((xy (1way type1 type2))) - (or (and (not (eql xy :no-type-method-found)) xy) + (or (and (not (eql xy :call-other-method)) xy) (let ((yx (1way type2 type1))) - (or (and (not (eql yx :no-type-method-found)) yx) - (cond ((and (eql xy :no-type-method-found) - (eql yx :no-type-method-found)) + (or (and (not (eql yx :call-other-method)) yx) + (cond ((and (eql xy :call-other-method) + (eql yx :call-other-method)) *empty-type*) (t (aver (and (not xy) (not yx))) ; else handled above @@ -894,7 +856,7 @@ ;;; shared logic for unions and intersections: Make a COMPOUND-TYPE ;;; object whose components are the types in TYPES, or skip to special ;;; cases when TYPES is short. -(defun make-compound-type-or-something (constructor types enumerable identity) +(defun make-probably-compound-type (constructor types enumerable identity) (declare (type function constructor)) (declare (type (vector ctype) types)) (declare (type ctype identity)) @@ -908,7 +870,7 @@ ;; brain-dead, so that would generate a full call to ;; SPECIFIER-TYPE at runtime, so we get into bootstrap ;; problems in cold init because 'LIST is a compound - ;; type, so we need to MAKE-COMPOUND-TYPE-OR-SOMETHING + ;; type, so we need to MAKE-PROBABLY-COMPOUND-TYPE ;; before we know what 'LIST is. Once the COERCE ;; optimizer is less brain-dead, we can make this ;; (COERCE TYPES 'LIST) again. @@ -956,11 +918,11 @@ :specifier `(and ,@(map 'list #'type-specifier simplified-types))))) - (make-compound-type-or-something #'%make-intersection-type - simplified-types - (some #'type-enumerable - simplified-types) - *universal-type*)))) + (make-probably-compound-type #'%make-intersection-type + simplified-types + (some #'type-enumerable + simplified-types) + *universal-type*)))) (defun type-union (&rest input-types) (%type-union input-types)) @@ -971,10 +933,10 @@ (let ((simplified-types (simplified-compound-types input-types #'union-type-p #'type-union2))) - (make-compound-type-or-something #'make-union-type - simplified-types - (every #'type-enumerable simplified-types) - *empty-type*))) + (make-probably-compound-type #'make-union-type + simplified-types + (every #'type-enumerable simplified-types) + *empty-type*))) ;;;; built-in types @@ -1011,6 +973,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 +1032,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 @@ -1337,6 +1318,39 @@ (mapcar #'(lambda (x) (specifier-type `(not ,(type-specifier x)))) (union-type-types not-type)))) + ((member-type-p not-type) + (let ((members (member-type-members not-type))) + (if (some #'floatp members) + (let (floats) + (dolist (pair '((0.0f0 . -0.0f0) (0.0d0 . -0.0d0) + #!+long-float (0.0l0 . -0.0l0))) + (when (member (car pair) members) + (aver (not (member (cdr pair) members))) + (push (cdr pair) floats) + (setf members (remove (car pair) members))) + (when (member (cdr pair) members) + (aver (not (member (car pair) members))) + (push (car pair) floats) + (setf members (remove (cdr pair) members)))) + (apply #'type-intersection + (if (null members) + *universal-type* + (make-negation-type + :type (make-member-type :members members))) + (mapcar + (lambda (x) + (let ((type (ctype-of x))) + (type-union + (make-negation-type + :type (modified-numeric-type type + :low nil :high nil)) + (modified-numeric-type type + :low nil :high (list x)) + (make-member-type :members (list x)) + (modified-numeric-type type + :low (list x) :high nil)))) + floats))) + (make-negation-type :type 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*)) @@ -1378,8 +1392,8 @@ (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)) - (equal (numeric-type-low type1) (numeric-type-low type2)) - (equal (numeric-type-high type1) (numeric-type-high type2))) + (equalp (numeric-type-low type1) (numeric-type-low type2)) + (equalp (numeric-type-high type1) (numeric-type-high type2))) t)) (!define-type-method (number :unparse) (type) @@ -1439,7 +1453,6 @@ ;;; ;;; This is for comparing bounds of the same kind, e.g. upper and ;;; upper. Use NUMERIC-BOUND-TEST* for different kinds of bounds. -#!-negative-zero-is-not-zero (defmacro numeric-bound-test (x y closed open) `(cond ((not ,y) t) ((not ,x) nil) @@ -1452,32 +1465,12 @@ (,open ,x (car ,y)) (,closed ,x ,y))))) -#!+negative-zero-is-not-zero -(defmacro numeric-bound-test-zero (op x y) - `(if (and (zerop ,x) (zerop ,y) (floatp ,x) (floatp ,y)) - (,op (float-sign ,x) (float-sign ,y)) - (,op ,x ,y))) - -#!+negative-zero-is-not-zero -(defmacro numeric-bound-test (x y closed open) - `(cond ((not ,y) t) - ((not ,x) nil) - ((consp ,x) - (if (consp ,y) - (numeric-bound-test-zero ,closed (car ,x) (car ,y)) - (numeric-bound-test-zero ,closed (car ,x) ,y))) - (t - (if (consp ,y) - (numeric-bound-test-zero ,open ,x (car ,y)) - (numeric-bound-test-zero ,closed ,x ,y))))) - ;;; This is used to compare upper and lower bounds. This is different ;;; from the same-bound case: ;;; -- Since X = NIL is -infinity, whereas y = NIL is +infinity, we ;;; return true if *either* arg is NIL. ;;; -- an open inner bound is "greater" and also squeezes the interval, ;;; causing us to use the OPEN test for those cases as well. -#!-negative-zero-is-not-zero (defmacro numeric-bound-test* (x y closed open) `(cond ((not ,y) t) ((not ,x) t) @@ -1490,19 +1483,6 @@ (,open ,x (car ,y)) (,closed ,x ,y))))) -#!+negative-zero-is-not-zero -(defmacro numeric-bound-test* (x y closed open) - `(cond ((not ,y) t) - ((not ,x) t) - ((consp ,x) - (if (consp ,y) - (numeric-bound-test-zero ,open (car ,x) (car ,y)) - (numeric-bound-test-zero ,open (car ,x) ,y))) - (t - (if (consp ,y) - (numeric-bound-test-zero ,open ,x (car ,y)) - (numeric-bound-test-zero ,closed ,x ,y))))) - ;;; Return whichever of the numeric bounds X and Y is "maximal" ;;; according to the predicates CLOSED (e.g. >=) and OPEN (e.g. >). ;;; This is only meaningful for maximizing like bounds, i.e. upper and @@ -1566,28 +1546,19 @@ (cond ((not (and low-bound high-bound)) nil) ((and (consp low-bound) (consp high-bound)) nil) ((consp low-bound) - #!-negative-zero-is-not-zero (let ((low-value (car low-bound))) (or (eql low-value high-bound) (and (eql low-value -0f0) (eql high-bound 0f0)) (and (eql low-value 0f0) (eql high-bound -0f0)) (and (eql low-value -0d0) (eql high-bound 0d0)) - (and (eql low-value 0d0) (eql high-bound -0d0)))) - #!+negative-zero-is-not-zero - (eql (car low-bound) high-bound)) + (and (eql low-value 0d0) (eql high-bound -0d0))))) ((consp high-bound) - #!-negative-zero-is-not-zero (let ((high-value (car high-bound))) (or (eql high-value low-bound) (and (eql high-value -0f0) (eql low-bound 0f0)) (and (eql high-value 0f0) (eql low-bound -0f0)) (and (eql high-value -0d0) (eql low-bound 0d0)) - (and (eql high-value 0d0) (eql low-bound -0d0)))) - #!+negative-zero-is-not-zero - (eql (car high-bound) low-bound)) - #!+negative-zero-is-not-zero - ((or (and (eql low-bound -0f0) (eql high-bound 0f0)) - (and (eql low-bound -0d0) (eql high-bound 0d0)))) + (and (eql high-value 0d0) (eql low-bound -0d0))))) ((and (eq (numeric-type-class low) 'integer) (eq (numeric-type-class high) 'integer)) (eql (1+ low-bound) high-bound)) @@ -2344,6 +2315,9 @@ (let (ms numbers) (dolist (m (remove-duplicates members)) (typecase m + (float (if (zerop m) + (push m ms) + (push (ctype-of m) numbers))) (number (push (ctype-of m) numbers)) (t (push m ms)))) (apply #'type-union @@ -2384,15 +2358,13 @@ ;;; shared machinery for type equality: true if every type in the set ;;; TYPES1 matches a type in the set TYPES2 and vice versa (defun type=-set (types1 types2) - (flet (;; true if every type in the set X matches a type in the set Y - (type<=-set (x y) + (flet ((type<=-set (x y) (declare (type list x y)) - (every (lambda (xelement) - (position xelement y :test #'type=)) - x))) - (values (and (type<=-set types1 types2) - (type<=-set types2 types1)) - t))) + (every/type (lambda (x y-element) + (any/type #'type= y-element x)) + x y))) + (and/type (type<=-set types1 types2) + (type<=-set types2 types1)))) ;;; Two intersection types are equal if their subtypes are equal sets. ;;; @@ -2406,9 +2378,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 @@ -2542,8 +2512,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))) @@ -2812,8 +2781,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)