;;; ### 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.)
;;;
;;; WHEN controls when the forms are executed.
(defmacro !define-superclasses (type-class-name specs when)
- (let ((type-class (gensym "TYPE-CLASS-"))
- (info (gensym "INFO")))
+ (with-unique-names (type-class info)
`(,when
(let ((,type-class (type-class-or-lose ',type-class-name))
(,info (mapcar (lambda (spec)
(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)
(!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 "~@<repeated keyword ~S in lambda list: ~2I~_~S~:>"
- 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))
(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))
\f
;;;; VALUES types interfaces
;;;;
;;; 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)
(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
(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*))
(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)
;;;
;;; 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)
(,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)
(,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
(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))
(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
projects / sbcl.git / blobdiff