;;; ### 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.)
(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)))
;;;
;;; 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)
(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)
(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)
(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
;;; 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))
;; 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.
: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))
(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*)))
\f
;;;; built-in types
;;(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))
(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
(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)
(!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)))
(modified-numeric-type
not-type
:low (let ((h (numeric-type-high not-type)))
- (if (consp h) h (list h)))
+ (if (consp h) (car h) (list h)))
:high nil))
((null (numeric-type-high not-type))
(modified-numeric-type
not-type
:low nil
:high (let ((l (numeric-type-low not-type)))
- (if (consp l) l (list l)))))
+ (if (consp l) (car l) (list l)))))
(t (type-union
(modified-numeric-type
not-type
:low nil
:high (let ((l (numeric-type-low not-type)))
- (if (consp l) l (list l))))
+ (if (consp l) (car l) (list l))))
(modified-numeric-type
not-type
:low (let ((h (numeric-type-high not-type)))
- (if (consp h) h (list h)))
+ (if (consp h) (car h) (list h)))
:high nil))))))
((intersection-type-p not-type)
(apply #'type-union
(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*))
+ (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)))))
\f
;;;; numeric types
(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
(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.
(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))
;;; 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)
(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)
(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
(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
(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
;;; 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.
;;;
(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
((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)))
(!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)))
(!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)))
(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
(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 #<BUILT-IN-CLASS FUNCTION>;
;; that's what happens when we (DECLAIM (FTYPE FUNCTION FOO)).
(is-built-in-class-function-p declared-ftype)
projects / sbcl.git / blobdiff