X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=6f6e61081a9a79084a162c0374012bc5e55ce55f;hb=98a76d4426660876dec6649b1e228d2e5b47f579;hp=61f6982bef789ffa926f1809be72964845ab0405;hpb=fbbf545a493def7c3732949c4f7e217996aaf018;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 61f6982..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.) @@ -271,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) @@ -287,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)) @@ -348,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 ;;;; @@ -387,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) @@ -722,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 @@ -1349,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*)) @@ -1390,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) @@ -1451,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) @@ -1464,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) @@ -1502,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 @@ -1578,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)) @@ -2356,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