(type-specifier
(fun-type-returns type)))))
-;;; Since all function types are equivalent to FUNCTION, they are all
-;;; subtypes of each other.
-(!define-type-method
- (function :simple-subtypep) (type1 type2)
+;;; The meaning of this is a little confused. On the one hand, all
+;;; function objects are represented the same way regardless of the
+;;; arglists and return values, and apps don't get to ask things like
+;;; (TYPEP #'FOO (FUNCTION (FIXNUM) *)) in any meaningful way. On the
+;;; other hand, Python wants to reason about function types. So...
+(!define-type-method (function :simple-subtypep) (type1 type2)
(flet ((fun-type-simple-p (type)
(not (or (fun-type-rest type)
(fun-type-keyp type))))
(multiple-value-bind (val2 win2) ,y
(if (and val1 val2)
(values t t)
- (values nil (or win1 win2))))))))
+ (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) (values nil t))
- ((not (or (fun-type-simple-p type1)
- (fun-type-simple-p type2)))
+ ((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)
(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 #'specifier-type required))
- (setf (args-type-optional result) (mapcar #'specifier-type optional))
- (setf (args-type-rest result) (if restp (specifier-type rest) nil))
+ (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)
(error "~@<repeated keyword ~S in lambda list: ~2I~_~S~:>"
kwd lambda-list))
(key-info (make-key-info :name kwd
- :type (specifier-type (second key))))))
+ :type (single-value-specifier-type (second key))))))
(setf (args-type-keywords result) (key-info)))
(setf (args-type-allowp result) allowp)
(values)))
res))
(!def-type-translator values (&rest values)
- (let ((res (make-values-type)))
+ (let ((res (%make-values-type)))
(parse-args-types values res)
res))
\f
:initial-element rest2)))
exact)))
-;;; If Type isn't a values type, then make it into one:
+;;; If TYPE isn't a values type, then make it into one:
;;; <type> ==> (values type &rest t)
(defun coerce-to-values (type)
(declare (type ctype type))
(defun args-type-op (type1 type2 operation nreq default-type)
(declare (type ctype type1 type2 default-type)
(type function operation nreq))
+ (when (eq type1 type2)
+ (values type1 t))
(if (or (values-type-p type1) (values-type-p type2))
(let ((type1 (coerce-to-values type1))
(type2 (coerce-to-values type2)))
:complex-arg1 :complex-subtypep-arg1))))
;;; Just parse the type specifiers and call CSUBTYPE.
-(defun sb!xc:subtypep (type1 type2)
+(defun sb!xc:subtypep (type1 type2 &optional environment)
#!+sb-doc
"Return two values indicating the relationship between type1 and type2.
If values are T and T, type1 definitely is a subtype of type2.
If values are NIL and T, type1 definitely is not a subtype of type2.
If values are NIL and NIL, it couldn't be determined."
+ (declare (ignore environment))
(csubtypep (specifier-type type1) (specifier-type type2)))
;;; If two types are definitely equivalent, return true. The second
(defun accumulate1-compound-type (type types %compound-type-p simplify2)
(declare (type ctype type))
(declare (type (vector ctype) types))
- (declare (type function simplify2))
+ (declare (type function %compound-type-p simplify2))
;; Any input object satisfying %COMPOUND-TYPE-P should've been
;; broken into components before it reached us.
(aver (not (funcall %compound-type-p type)))
nil)))
(defun type-intersection (&rest input-types)
+ (%type-intersection input-types))
+(defun-cached (%type-intersection :hash-bits 8
+ :hash-function (lambda (x)
+ (logand (sxhash x) #xff)))
+ ((input-types equal))
(let ((simplified-types (simplified-compound-types input-types
#'intersection-type-p
#'type-intersection2)))
(if (and (> (length simplified-types) 1)
(some #'union-type-p simplified-types))
(let* ((first-union (find-if #'union-type-p simplified-types))
- (other-types (coerce (remove first-union simplified-types) 'list))
- (distributed (maybe-distribute-one-union first-union other-types)))
+ (other-types (coerce (remove first-union simplified-types)
+ 'list))
+ (distributed (maybe-distribute-one-union first-union
+ other-types)))
(if distributed
(apply #'type-union distributed)
(make-hairy-type
- :specifier `(and ,@(map 'list #'type-specifier simplified-types)))))
+ :specifier `(and ,@(map 'list
+ #'type-specifier
+ simplified-types)))))
(make-compound-type-or-something #'%make-intersection-type
simplified-types
(some #'type-enumerable
*universal-type*))))
(defun type-union (&rest input-types)
+ (%type-union input-types))
+(defun-cached (%type-union :hash-bits 8
+ :hash-function (lambda (x)
+ (logand (sxhash x) #xff)))
+ ((input-types equal))
(let ((simplified-types (simplified-compound-types input-types
#'union-type-p
#'type-union2)))
- (make-compound-type-or-something #'%make-union-type
+ (make-compound-type-or-something #'make-union-type
simplified-types
(every #'type-enumerable simplified-types)
*empty-type*)))
(macrolet ((frob (name var)
`(progn
(setq ,var (make-named-type :name ',name))
- (setf (info :type :kind ',name) #+sb-xc-host :defined #-sb-xc-host :primitive)
+ (setf (info :type :kind ',name)
+ #+sb-xc-host :defined #-sb-xc-host :primitive)
(setf (info :type :builtin ',name) ,var))))
;; KLUDGE: In ANSI, * isn't really the name of a type, it's just a
;; special symbol which can be stuck in some places where an
(invoke-complex-subtypep-arg1-method type1 type2))
(t
;; FIXME: This seems to rely on there only being 2 or 3
- ;; HAIRY-TYPE values, and the exclusion of various
+ ;; 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))))
(!define-type-method (hairy :simple-subtypep) (type1 type2)
(let ((hairy-spec1 (hairy-type-specifier type1))
(hairy-spec2 (hairy-type-specifier type2)))
- (cond ((and (consp hairy-spec1) (eq (car hairy-spec1) 'not)
- (consp hairy-spec2) (eq (car hairy-spec2) 'not))
- (csubtypep (specifier-type (cadr hairy-spec2))
- (specifier-type (cadr hairy-spec1))))
- ((equal hairy-spec1 hairy-spec2)
+ (cond ((equal-but-no-car-recursion hairy-spec1 hairy-spec2)
(values t t))
(t
(values nil nil)))))
(!define-type-method (hairy :complex-subtypep-arg2) (type1 type2)
- (let ((hairy-spec (hairy-type-specifier type2)))
- (cond ((and (consp hairy-spec) (eq (car hairy-spec) 'not))
- (let* ((complement-type2 (specifier-type (cadr hairy-spec)))
- (intersection2 (type-intersection2 type1
- complement-type2)))
- (if intersection2
- (values (eq intersection2 *empty-type*) t)
- (invoke-complex-subtypep-arg1-method type1 type2))))
- (t
- (invoke-complex-subtypep-arg1-method type1 type2)))))
+ (invoke-complex-subtypep-arg1-method type1 type2))
(!define-type-method (hairy :complex-subtypep-arg1) (type1 type2)
- ;; "Incrementally extended heuristic algorithms tend inexorably toward the
- ;; incomprehensible." -- http://www.unlambda.com/~james/lambda/lambda.txt
- (let ((hairy-spec (hairy-type-specifier type1)))
- (cond ((and (consp hairy-spec) (eq (car hairy-spec) 'not))
- ;; You may not believe this. I couldn't either. But then I
- ;; sat down and drew lots of Venn diagrams. Comments
- ;; involving a and b refer to the call (subtypep '(not a)
- ;; 'b) -- CSR, 2002-02-27.
- (block nil
- ;; (Several logical truths in this block are true as
- ;; long as b/=T. As of sbcl-0.7.1.28, it seems
- ;; impossible to construct a case with b=T where we
- ;; actually reach this type method, but we'll test for
- ;; and exclude this case anyway, since future
- ;; maintenance might make it possible for it to end up
- ;; in this code.)
- (multiple-value-bind (equal certain)
- (type= type2 (specifier-type t))
- (unless certain
- (return (values nil nil)))
- (when equal
- (return (values t t))))
- (let ((complement-type1 (specifier-type (cadr hairy-spec))))
- ;; Do the special cases first, in order to give us a
- ;; chance if subtype/supertype relationships are hairy.
- (multiple-value-bind (equal certain)
- (type= complement-type1 type2)
- ;; If a = b, ~a is not a subtype of b (unless b=T,
- ;; which was excluded above).
- (unless certain
- (return (values nil nil)))
- (when equal
- (return (values nil t))))
- ;; KLUDGE: ANSI requires that the SUBTYPEP result
- ;; between any two built-in atomic type specifiers
- ;; never be uncertain. This is hard to do cleanly for
- ;; the built-in types whose definitions include
- ;; (NOT FOO), i.e. CONS and RATIO. However, we can do
- ;; it with this hack, which uses our global knowledge
- ;; that our implementation of the type system uses
- ;; disjoint implementation types to represent disjoint
- ;; sets (except when types are contained in other types).
- ;; (This is a KLUDGE because it's fragile. Various
- ;; changes in internal representation in the type
- ;; system could make it start confidently returning
- ;; incorrect results.) -- WHN 2002-03-08
- (unless (or (type-might-contain-other-types-p complement-type1)
- (type-might-contain-other-types-p type2))
- ;; Because of the way our types which don't contain
- ;; other types are disjoint subsets of the space of
- ;; possible values, (SUBTYPEP '(NOT AA) 'B)=NIL when
- ;; AA and B are simple (and B is not T, as checked above).
- (return (values nil t)))
- ;; The old (TYPE= TYPE1 TYPE2) branch would never be
- ;; taken, as TYPE1 and TYPE2 will only be equal if
- ;; they're both NOT types, and then the
- ;; :SIMPLE-SUBTYPEP method would be used instead.
- ;; But a CSUBTYPEP relationship might still hold:
- (multiple-value-bind (equal certain)
- (csubtypep complement-type1 type2)
- ;; If a is a subtype of b, ~a is not a subtype of b
- ;; (unless b=T, which was excluded above).
- (unless certain
- (return (values nil nil)))
- (when equal
- (return (values nil t))))
- (multiple-value-bind (equal certain)
- (csubtypep type2 complement-type1)
- ;; If b is a subtype of a, ~a is not a subtype of b.
- ;; (FIXME: That's not true if a=T. Do we know at
- ;; this point that a is not T?)
- (unless certain
- (return (values nil nil)))
- (when equal
- (return (values nil t))))
- ;; old CSR comment ca. 0.7.2, now obsoleted by the
- ;; SIMPLE-CTYPE? KLUDGE case above:
- ;; Other cases here would rely on being able to catch
- ;; all possible cases, which the fragility of this
- ;; type system doesn't inspire me; for instance, if a
- ;; is type= to ~b, then we want T, T; if this is not
- ;; the case and the types are disjoint (have an
- ;; intersection of *empty-type*) then we want NIL, T;
- ;; else if the union of a and b is the
- ;; *universal-type* then we want T, T. So currently we
- ;; still claim to be unsure about e.g. (subtypep '(not
- ;; fixnum) 'single-float).
- )))
- (t
- (values nil nil)))))
+ (declare (ignore type1 type2))
+ (values nil nil))
(!define-type-method (hairy :complex-=) (type1 type2)
(declare (ignore type1 type2))
(values nil nil))
-(!define-type-method (hairy :simple-intersection2 :complex-intersection2)
+(!define-type-method (hairy :simple-intersection2 :complex-intersection2)
+ (type1 type2)
+ (if (type= type1 type2)
+ type1
+ nil))
+
+(!define-type-method (hairy :simple-union2)
(type1 type2)
(if (type= type1 type2)
type1
nil))
(!define-type-method (hairy :simple-=) (type1 type2)
- (if (equal (hairy-type-specifier type1)
- (hairy-type-specifier type2))
+ (if (equal-but-no-car-recursion (hairy-type-specifier type1)
+ (hairy-type-specifier type2))
(values t t)
(values nil nil)))
-(!def-type-translator not (&whole whole type)
- (declare (ignore type))
- ;; Check legality of arguments.
- (destructuring-bind (not typespec) whole
- (declare (ignore not))
- (let ((spec (type-specifier (specifier-type typespec)))) ; must be legal typespec
- (if (and (listp spec) (eq (car spec) 'not))
- ;; canonicalize (not (not foo))
- (specifier-type (cadr spec))
- (make-hairy-type :specifier whole)))))
-
(!def-type-translator satisfies (&whole whole fun)
(declare (ignore fun))
;; Check legality of arguments.
(error 'simple-type-error
:datum predicate-name
:expected-type 'symbol
- :format-control "~S is not a symbol."
+ :format-control "The SATISFIES predicate name is not a symbol: ~S"
:format-arguments (list predicate-name))))
;; Create object.
(make-hairy-type :specifier whole))
\f
+;;;; negation types
+
+(!define-type-method (negation :unparse) (x)
+ `(not ,(type-specifier (negation-type-type x))))
+
+(!define-type-method (negation :simple-subtypep) (type1 type2)
+ (csubtypep (negation-type-type type2) (negation-type-type type1)))
+
+(!define-type-method (negation :complex-subtypep-arg2) (type1 type2)
+ (let* ((complement-type2 (negation-type-type type2))
+ (intersection2 (type-intersection2 type1
+ complement-type2)))
+ (if intersection2
+ (values (eq intersection2 *empty-type*) t)
+ (invoke-complex-subtypep-arg1-method type1 type2))))
+
+(!define-type-method (negation :complex-subtypep-arg1) (type1 type2)
+ ;; "Incrementally extended heuristic algorithms tend inexorably toward the
+ ;; incomprehensible." -- http://www.unlambda.com/~james/lambda/lambda.txt
+ ;;
+ ;; You may not believe this. I couldn't either. But then I sat down
+ ;; and drew lots of Venn diagrams. Comments involving a and b refer
+ ;; to the call (subtypep '(not a) 'b) -- CSR, 2002-02-27.
+ (block nil
+ ;; (Several logical truths in this block are true as long as
+ ;; b/=T. As of sbcl-0.7.1.28, it seems impossible to construct a
+ ;; case with b=T where we actually reach this type method, but
+ ;; we'll test for and exclude this case anyway, since future
+ ;; maintenance might make it possible for it to end up in this
+ ;; code.)
+ (multiple-value-bind (equal certain)
+ (type= type2 *universal-type*)
+ (unless certain
+ (return (values nil nil)))
+ (when equal
+ (return (values t t))))
+ (let ((complement-type1 (negation-type-type type1)))
+ ;; Do the special cases first, in order to give us a chance if
+ ;; subtype/supertype relationships are hairy.
+ (multiple-value-bind (equal certain)
+ (type= complement-type1 type2)
+ ;; If a = b, ~a is not a subtype of b (unless b=T, which was
+ ;; excluded above).
+ (unless certain
+ (return (values nil nil)))
+ (when equal
+ (return (values nil t))))
+ ;; KLUDGE: ANSI requires that the SUBTYPEP result between any
+ ;; two built-in atomic type specifiers never be uncertain. This
+ ;; is hard to do cleanly for the built-in types whose
+ ;; definitions include (NOT FOO), i.e. CONS and RATIO. However,
+ ;; we can do it with this hack, which uses our global knowledge
+ ;; that our implementation of the type system uses disjoint
+ ;; implementation types to represent disjoint sets (except when
+ ;; types are contained in other types). (This is a KLUDGE
+ ;; because it's fragile. Various changes in internal
+ ;; representation in the type system could make it start
+ ;; confidently returning incorrect results.) -- WHN 2002-03-08
+ (unless (or (type-might-contain-other-types-p complement-type1)
+ (type-might-contain-other-types-p type2))
+ ;; Because of the way our types which don't contain other
+ ;; types are disjoint subsets of the space of possible values,
+ ;; (SUBTYPEP '(NOT AA) 'B)=NIL when AA and B are simple (and B
+ ;; is not T, as checked above).
+ (return (values nil t)))
+ ;; The old (TYPE= TYPE1 TYPE2) branch would never be taken, as
+ ;; TYPE1 and TYPE2 will only be equal if they're both NOT types,
+ ;; and then the :SIMPLE-SUBTYPEP method would be used instead.
+ ;; But a CSUBTYPEP relationship might still hold:
+ (multiple-value-bind (equal certain)
+ (csubtypep complement-type1 type2)
+ ;; If a is a subtype of b, ~a is not a subtype of b (unless
+ ;; b=T, which was excluded above).
+ (unless certain
+ (return (values nil nil)))
+ (when equal
+ (return (values nil t))))
+ (multiple-value-bind (equal certain)
+ (csubtypep type2 complement-type1)
+ ;; If b is a subtype of a, ~a is not a subtype of b. (FIXME:
+ ;; That's not true if a=T. Do we know at this point that a is
+ ;; not T?)
+ (unless certain
+ (return (values nil nil)))
+ (when equal
+ (return (values nil t))))
+ ;; old CSR comment ca. 0.7.2, now obsoleted by the SIMPLE-CTYPE?
+ ;; KLUDGE case above: Other cases here would rely on being able
+ ;; to catch all possible cases, which the fragility of this type
+ ;; system doesn't inspire me; for instance, if a is type= to ~b,
+ ;; then we want T, T; if this is not the case and the types are
+ ;; disjoint (have an intersection of *empty-type*) then we want
+ ;; NIL, T; else if the union of a and b is the *universal-type*
+ ;; then we want T, T. So currently we still claim to be unsure
+ ;; about e.g. (subtypep '(not fixnum) 'single-float).
+ ;;
+ ;; OTOH we might still get here:
+ (values nil nil))))
+
+(!define-type-method (negation :complex-=) (type1 type2)
+ ;; (NOT FOO) isn't equivalent to anything that's not a negation
+ ;; type, except possibly a type that might contain it in disguise.
+ (declare (ignore type2))
+ (if (type-might-contain-other-types-p type1)
+ (values nil nil)
+ (values nil t)))
+
+(!define-type-method (negation :simple-intersection2) (type1 type2)
+ (let ((not1 (negation-type-type type1))
+ (not2 (negation-type-type type2)))
+ (cond
+ ((csubtypep not1 not2) type2)
+ ((csubtypep not2 not1) type1)
+ ;; Why no analagous clause to the disjoint in the SIMPLE-UNION2
+ ;; method, below? The clause would read
+ ;;
+ ;; ((EQ (TYPE-UNION NOT1 NOT2) *UNIVERSAL-TYPE*) *EMPTY-TYPE*)
+ ;;
+ ;; but with proper canonicalization of negation types, there's
+ ;; no way of constructing two negation types with union of their
+ ;; negations being the universal type.
+ (t
+ (aver (not (eq (type-union not1 not2) *universal-type*)))
+ nil))))
+
+(!define-type-method (negation :complex-intersection2) (type1 type2)
+ (cond
+ ((csubtypep type1 (negation-type-type type2)) *empty-type*)
+ ((eq (type-intersection type1 (negation-type-type type2)) *empty-type*)
+ type1)
+ (t nil)))
+
+(!define-type-method (negation :simple-union2) (type1 type2)
+ (let ((not1 (negation-type-type type1))
+ (not2 (negation-type-type type2)))
+ (cond
+ ((csubtypep not1 not2) type1)
+ ((csubtypep not2 not1) type2)
+ ((eq (type-intersection not1 not2) *empty-type*)
+ *universal-type*)
+ (t nil))))
+
+(!define-type-method (negation :complex-union2) (type1 type2)
+ (cond
+ ((csubtypep (negation-type-type type2) type1) *universal-type*)
+ ((eq (type-intersection type1 (negation-type-type type2)) *empty-type*)
+ type2)
+ (t nil)))
+
+(!define-type-method (negation :simple-=) (type1 type2)
+ (type= (negation-type-type type1) (negation-type-type type2)))
+
+(!def-type-translator not (typespec)
+ (let* ((not-type (specifier-type typespec))
+ (spec (type-specifier not-type)))
+ (cond
+ ;; canonicalize (NOT (NOT FOO))
+ ((and (listp spec) (eq (car spec) 'not))
+ (specifier-type (cadr spec)))
+ ;; canonicalize (NOT NIL) and (NOT T)
+ ((eq not-type *empty-type*) *universal-type*)
+ ((eq not-type *universal-type*) *empty-type*)
+ ((and (numeric-type-p not-type)
+ (null (numeric-type-low not-type))
+ (null (numeric-type-high not-type)))
+ (make-negation-type :type not-type))
+ ((numeric-type-p not-type)
+ (type-union
+ (make-negation-type
+ :type (modified-numeric-type not-type :low nil :high nil))
+ (cond
+ ((null (numeric-type-low not-type))
+ (modified-numeric-type
+ not-type
+ :low (let ((h (numeric-type-high not-type)))
+ (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) (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) (car l) (list l))))
+ (modified-numeric-type
+ not-type
+ :low (let ((h (numeric-type-high not-type)))
+ (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))))
+ (intersection-type-types not-type))))
+ ((union-type-p not-type)
+ (apply #'type-intersection
+ (mapcar #'(lambda (x)
+ (specifier-type `(not ,(type-specifier x))))
+ (union-type-types 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
(!define-type-class number)
(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.
;;; 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) #+sb-xc-host :defined #-sb-xc-host :primitive)
+ (setf (info :type :kind 'number)
+ #+sb-xc-host :defined #-sb-xc-host :primitive)
(setf (info :type :builtin 'number)
(make-numeric-type :complexp nil)))
(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 :low lb :high hb)))))
+ (make-numeric-type :class ',class
+ :format ',format
+ :low lb
+ :high hb)))))
(!def-bounded-type rational rational nil)
*empty-type*))))))
(!define-type-method (member :complex-intersection2) (type1 type2)
- (block punt
+ (block punt
(collect ((members))
(let ((mem2 (member-type-members type2)))
(dolist (member mem2)
(!def-type-translator member (&rest members)
(if members
- (make-member-type :members (remove-duplicates members))
- *empty-type*))
+ (let (ms numbers)
+ (dolist (m (remove-duplicates members))
+ (typecase m
+ (number (push (ctype-of m) numbers))
+ (t (push m ms))))
+ (apply #'type-union
+ (if ms
+ (make-member-type :members ms)
+ *empty-type*)
+ (nreverse numbers)))
+ *empty-type*))
\f
;;;; intersection types
;;;;
;;; mechanically unparsed.
(!define-type-method (intersection :unparse) (type)
(declare (type ctype type))
- (or (find type '(ratio bignum keyword) :key #'specifier-type :test #'type=)
+ (or (find type '(ratio keyword) :key #'specifier-type :test #'type=)
`(and ,@(mapcar #'type-specifier (intersection-type-types type)))))
;;; shared machinery for type equality: true if every type in the set
type2
(intersection-type-types type1)))
-(!define-type-method (intersection :simple-subtypep) (type1 type2)
+(defun %intersection-simple-subtypep (type1 type2)
(every/type #'%intersection-complex-subtypep-arg1
type1
(intersection-type-types type2)))
+(!define-type-method (intersection :simple-subtypep) (type1 type2)
+ (%intersection-simple-subtypep type1 type2))
+
(!define-type-method (intersection :complex-subtypep-arg1) (type1 type2)
(%intersection-complex-subtypep-arg1 type1 type2))
-(!define-type-method (intersection :complex-subtypep-arg2) (type1 type2)
+(defun %intersection-complex-subtypep-arg2 (type1 type2)
(every/type #'csubtypep type1 (intersection-type-types type2)))
+(!define-type-method (intersection :complex-subtypep-arg2) (type1 type2)
+ (%intersection-complex-subtypep-arg2 type1 type2))
+
+;;; FIXME: This will look eeriely familiar to readers of the UNION
+;;; :SIMPLE-INTERSECTION2 :COMPLEX-INTERSECTION2 method. That's
+;;; because it was generated by cut'n'paste methods. Given that
+;;; intersections and unions have all sorts of symmetries known to
+;;; mathematics, it shouldn't be beyond the ken of some programmers to
+;;; reflect those symmetries in code in a way that ties them together
+;;; more strongly than having two independent near-copies :-/
+(!define-type-method (intersection :simple-union2 :complex-union2)
+ (type1 type2)
+ ;; Within this method, type2 is guaranteed to be an intersection
+ ;; type:
+ (aver (intersection-type-p type2))
+ ;; Make sure to call only the applicable methods...
+ (cond ((and (intersection-type-p type1)
+ (%intersection-simple-subtypep type1 type2)) type2)
+ ((and (intersection-type-p type1)
+ (%intersection-simple-subtypep type2 type1)) type1)
+ ((and (not (intersection-type-p type1))
+ (%intersection-complex-subtypep-arg2 type1 type2))
+ type2)
+ ((and (not (intersection-type-p type1))
+ (%intersection-complex-subtypep-arg1 type2 type1))
+ type1)
+ (t
+ (let ((accumulator *universal-type*))
+ (do ((t2s (intersection-type-types type2) (cdr t2s)))
+ ((null t2s) accumulator)
+ (let ((union (type-union type1 (car t2s))))
+ (when (union-type-p union)
+ ;; we have to give up here -- there are all sorts of
+ ;; ordering worries, but it's better than before.
+ ;; Doing exactly the same as in the UNION
+ ;; :SIMPLE/:COMPLEX-INTERSECTION2 method causes stack
+ ;; overflow with the mutual recursion never bottoming
+ ;; out.
+ (if (and (eq accumulator *universal-type*)
+ (null (cdr t2s)))
+ ;; KLUDGE: if we get here, we have a partially
+ ;; simplified result. While this isn't by any
+ ;; means a universal simplification, including
+ ;; this logic here means that we can get (OR
+ ;; KEYWORD (NOT KEYWORD)) canonicalized to T.
+ (return union)
+ (return nil)))
+ (setf accumulator
+ (type-intersection accumulator union))))))))
+
(!def-type-translator and (&whole whole &rest type-specifiers)
(apply #'type-intersection
(mapcar #'specifier-type
((type= type (specifier-type 'float)) 'float)
((type= type (specifier-type 'real)) 'real)
((type= type (specifier-type 'sequence)) 'sequence)
- ((type= type (specifier-type 'string-stream)) 'string-stream)
+ ((type= type (specifier-type 'bignum)) 'bignum)
(t `(or ,@(mapcar #'type-specifier (union-type-types type))))))
;;; Two union types are equal if they are each subtypes of each
(!define-type-method (union :complex-=) (type1 type2)
(declare (ignore type1))
- (if (some #'hairy-type-p (union-type-types type2))
+ (if (some #'(lambda (x) (or (hairy-type-p x)
+ (negation-type-p x)))
+ (union-type-types type2))
(values nil nil)
(values nil t)))
(let ((accumulator *empty-type*))
(dolist (t2 (union-type-types type2) accumulator)
(setf accumulator
- (type-union2 accumulator
- (type-intersection type1 t2)))
- ;; When our result isn't simple any more (because
- ;; TYPE-UNION2 was unable to give us a simple result)
- (unless accumulator
- (return nil)))))))
+ (type-union accumulator
+ (type-intersection type1 t2))))))))
(!def-type-translator or (&rest type-specifiers)
(apply #'type-union
(!define-type-class cons)
(!def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*))
- (make-cons-type (specifier-type car-type-spec)
- (specifier-type cdr-type-spec)))
+ (let ((car-type (specifier-type car-type-spec))
+ (cdr-type (specifier-type cdr-type-spec)))
+ (make-cons-type car-type cdr-type)))
(!define-type-method (cons :unparse) (type)
(let ((car-eltype (type-specifier (cons-type-car-type type)))
(dimensions '*))
(specialize-array-type
(make-array-type :dimensions (canonical-array-dimensions dimensions)
+ :complexp :maybe
:element-type (specifier-type element-type))))
(!def-type-translator simple-array (&optional (element-type '*)
(dimensions '*))
(specialize-array-type
(make-array-type :dimensions (canonical-array-dimensions dimensions)
- :element-type (specifier-type element-type)
- :complexp nil)))
+ :complexp nil
+ :element-type (specifier-type element-type))))
\f
;;;; utilities shared between cross-compiler and target system