;;; This is used by !DEFINE-SUPERCLASSES to define the SUBTYPE-ARG1
;;; method. INFO is a list of conses
;;; (SUPERCLASS-CLASS . {GUARD-TYPE-SPECIFIER | NIL}).
-;;; This will never be called with a hairy type as TYPE2, since the
-;;; hairy type TYPE2 method gets first crack.
(defun !has-superclasses-complex-subtypep-arg1 (type1 type2 info)
- (values
- (and (sb!xc:typep type2 'sb!xc:class)
- (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)))))
- (dotimes (i (length inherits) nil)
- (when (eq type2 (layout-class (svref inherits i)))
- (return t)))))))))
- t))
+ ;; If TYPE2 might be concealing something related to our class
+ ;; hierarchy
+ (if (type-might-contain-other-types-p type2)
+ ;; too confusing, gotta punt
+ (values nil nil)
+ ;; ordinary case expected by old CMU CL code, where the taxonomy
+ ;; of TYPE2's representation accurately reflects the taxonomy of
+ ;; the underlying set
+ (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)
+ (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)))))
+ (dotimes (i (length inherits) nil)
+ (when (eq type2 (layout-class (svref inherits i)))
+ (return t)))))))))
+ t)))
;;; This function takes a list of specs, each of the form
;;; (SUPERCLASS-NAME &OPTIONAL GUARD).
(eq type1 *empty-type*)
(eq type2 *wild-type*))
(values t t))
- ((or (eq type1 *wild-type*)
- (eq type2 *empty-type*))
+ ((eq type1 *wild-type*)
(values nil t))
(t
(!invoke-type-method :simple-subtypep :complex-subtypep-arg2
(declare (type ctype type1 type2))
(cond ((eq type1 type2)
type1)
+ ((csubtypep type1 type2) type2)
+ ((csubtypep type2 type1) type1)
((or (union-type-p type1)
(union-type-p type2))
;; Unions of UNION-TYPE should have the UNION-TYPE-TYPES
((type1 eq) (type2 eq))
(declare (type ctype type1 type2))
(cond ((eq type1 type2)
+ ;; FIXME: For some reason, this doesn't catch e.g. type1 =
+ ;; type2 = (SPECIFIER-TYPE
+ ;; 'SOME-UNKNOWN-TYPE). Investigate. - CSR, 2002-04-10
type1)
((or (intersection-type-p type1)
(intersection-type-p type2))
#+sb-xc-host (coerce types 'list)
#-sb-xc-host (coerce-to-list types)))))
+(defun maybe-distribute-one-union (union-type types)
+ (let* ((intersection (apply #'type-intersection types))
+ (union (mapcar (lambda (x) (type-intersection x intersection))
+ (union-type-types union-type))))
+ (if (notany (lambda (x) (or (hairy-type-p x)
+ (intersection-type-p x)))
+ union)
+ union
+ nil)))
+
(defun type-intersection (&rest input-types)
(let ((simplified-types (simplified-compound-types input-types
#'intersection-type-p
;; always achieve that by the distributive rule. But we don't want
;; to just apply the distributive rule, since it would be too easy
;; to end up with unreasonably huge type expressions. So instead
- ;; we punt to HAIRY-TYPE when this comes up.
+ ;; we try to generate a simple type by distributing the union; if
+ ;; the type can't be made simple, we punt to HAIRY-TYPE.
(if (and (> (length simplified-types) 1)
(some #'union-type-p simplified-types))
- (make-hairy-type
- :specifier `(and ,@(map 'list #'type-specifier 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)))
+ (if distributed
+ (apply #'type-union distributed)
+ (make-hairy-type
+ :specifier `(and ,@(map 'list #'type-specifier simplified-types)))))
(make-compound-type-or-something #'%make-intersection-type
simplified-types
(some #'type-enumerable
(frob t *universal-type*))
(setf *universal-fun-type*
(make-fun-type :wild-args t
- :returns *wild-type*)))
+ :returns *wild-type*)))
(!define-type-method (named :simple-=) (type1 type2)
;; FIXME: BUG 85: This assertion failed when I added it in
(values (or (eq type1 *empty-type*) (eq type2 *wild-type*)) t))
(!define-type-method (named :complex-subtypep-arg1) (type1 type2)
- (aver (not (eq type1 *wild-type*))) ; * isn't really a type.
- ;; FIXME: Why does this (old CMU CL) assertion hold? Perhaps 'cause
- ;; the HAIRY-TYPE COMPLEX-SUBTYPEP-ARG2 method takes precedence over
- ;; this COMPLEX-SUBTYPE-ARG1 method? (I miss CLOS..)
- (aver (not (hairy-type-p type2)))
- ;; Besides the old CMU CL assertion above, we also need to avoid
- ;; compound types, else we could get into trouble with
- ;; (SUBTYPEP T '(OR (SATISFIES FOO) (SATISFIES BAR)))
- ;; or
- ;; (SUBTYPEP T '(AND (SATISFIES FOO) (SATISFIES BAR))).
- (aver (not (compound-type-p type2)))
- ;; Then, since TYPE2 is reasonably tractable, we're good to go.
- (values (eq type1 *empty-type*) t))
+ ;; This AVER causes problems if we write accurate methods for the
+ ;; union (and possibly intersection) types which then delegate to
+ ;; us; while a user shouldn't get here, because of the odd status of
+ ;; *wild-type* a type-intersection executed by the compiler can. -
+ ;; CSR, 2002-04-10
+ ;;
+ ;; (aver (not (eq type1 *wild-type*))) ; * isn't really a type.
+ (cond ((eq type1 *empty-type*)
+ t)
+ (;; When TYPE2 might be the universal type in disguise
+ (type-might-contain-other-types-p type2)
+ ;; Now that the UNION and HAIRY COMPLEX-SUBTYPEP-ARG2 methods
+ ;; can delegate to us (more or less as CALL-NEXT-METHOD) when
+ ;; they're uncertain, we can't just barf on COMPOUND-TYPE and
+ ;; HAIRY-TYPEs as we used to. Instead we deal with the
+ ;; problem (where at least part of the problem is cases like
+ ;; (SUBTYPEP T '(SATISFIES FOO))
+ ;; or
+ ;; (SUBTYPEP T '(AND (SATISFIES FOO) (SATISFIES BAR)))
+ ;; where the second type is a hairy type like SATISFIES, or
+ ;; is a compound type which might contain a hairy type) by
+ ;; returning uncertainty.
+ (values nil nil))
+ (t
+ ;; By elimination, TYPE1 is the universal type.
+ (aver (or (eq type1 *wild-type*) (eq type1 *universal-type*)))
+ ;; This case would have been picked off by the SIMPLE-SUBTYPEP
+ ;; method, and so shouldn't appear here.
+ (aver (not (eq type2 *universal-type*)))
+ ;; Since TYPE2 is not EQ *UNIVERSAL-TYPE* and is not the
+ ;; universal type in disguise, TYPE2 is not a superset of TYPE1.
+ (values nil t))))
(!define-type-method (named :complex-subtypep-arg2) (type1 type2)
(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
(cond ((eq type2 *universal-type*)
(values t t))
((hairy-type-p type1)
- (values nil nil))
+ (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
complement-type2)))
(if intersection2
(values (eq intersection2 *empty-type*) t)
- (values nil nil))))
+ (invoke-complex-subtypep-arg1-method type1 type2))))
(t
- (values nil nil)))))
+ (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
(return (values nil nil)))
(when equal
(return (values nil t))))
- ;; This (TYPE= TYPE1 TYPE2) branch would never be
- ;; taken, as type1 and type2 will only be equal if
+ ;; 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.
- ;; ((type= type1 type2) (values t t))
+ ;; 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
(return (values nil nil)))
(when equal
(return (values nil t))))
- ;; 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).
+ ;; 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)))))
(!define-type-method (hairy :simple-intersection2 :complex-intersection2)
(type1 type2)
- (declare (ignore type1 type2))
- nil)
+ (if (type= type1 type2)
+ type1
+ nil))
(!define-type-method (hairy :simple-=) (type1 type2)
(if (equal (hairy-type-specifier type1)
(lb (if (consp l) (1+ (car l)) l))
(h (canonicalized-bound high 'integer))
(hb (if (consp h) (1- (car h)) h)))
- (when (and hb lb (< hb lb))
- (error "Lower bound ~S is greater than upper bound ~S." l h))
- (make-numeric-type :class 'integer
- :complexp :real
- :enumerable (not (null (and l h)))
- :low lb
- :high hb)))
+ (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:
+ (specifier-type 'nil)
+ (make-numeric-type :class 'integer
+ :complexp :real
+ :enumerable (not (null (and l h)))
+ :low lb
+ :high hb))))
(defmacro !def-bounded-type (type class format)
`(!def-type-translator ,type (&optional (low '*) (high '*))
(let ((lb (canonicalized-bound low ',type))
(hb (canonicalized-bound high ',type)))
- (unless (numeric-bound-test* lb hb <= <)
- (error "Lower bound ~S is not less than upper bound ~S." low high))
- (make-numeric-type :class ',class :format ',format :low lb :high hb))))
+ (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
+ (specifier-type 'nil)
+ (make-numeric-type :class ',class :format ',format :low lb :high hb)))))
(!def-bounded-type rational rational nil)
;;; subtype of the MEMBER type.
(!define-type-method (member :complex-subtypep-arg2) (type1 type2)
(cond ((not (type-enumerable type1)) (values nil t))
- ((types-equal-or-intersect type1 type2) (values nil nil))
+ ((types-equal-or-intersect type1 type2)
+ (invoke-complex-subtypep-arg1-method type1 type2))
(t (values nil t))))
(!define-type-method (member :simple-intersection2) (type1 type2)
'list
`(or ,@(mapcar #'type-specifier (union-type-types type)))))
+;;; Two union types are equal if they are each subtypes of each
+;;; other. We need to be this clever because our complex subtypep
+;;; methods are now more accurate; we don't get infinite recursion
+;;; because the simple-subtypep method delegates to complex-subtypep
+;;; of the individual types of type1. - CSR, 2002-04-09
+;;;
+;;; Previous comment, now obsolete, but worth keeping around because
+;;; it is true, though too strong a condition:
+;;;
;;; Two union types are equal if their subtypes are equal sets.
(!define-type-method (union :simple-=) (type1 type2)
- (type=-set (union-type-types type1)
- (union-type-types type2)))
+ (multiple-value-bind (subtype certain?)
+ (csubtypep type1 type2)
+ (if subtype
+ (csubtypep type2 type1)
+ ;; we might as well become as certain as possible.
+ (if certain?
+ (values nil t)
+ (multiple-value-bind (subtype certain?)
+ (csubtypep type2 type1)
+ (declare (ignore subtype))
+ (values nil certain?))))))
+
+(!define-type-method (union :complex-=) (type1 type2)
+ (declare (ignore type1))
+ (if (some #'hairy-type-p (union-type-types type2))
+ (values nil nil)
+ (values nil t)))
-;;; Similarly, a union type is a subtype of another if every element
-;;; of TYPE1 is a subtype of some element of TYPE2.
-(!define-type-method (union :simple-subtypep) (type1 type2)
+;;; Similarly, a union type is a subtype of another if and only if
+;;; every element of TYPE1 is a subtype of TYPE2.
+(defun union-simple-subtypep (type1 type2)
(every/type (swapped-args-fun #'union-complex-subtypep-arg2)
type2
(union-type-types type1)))
+(!define-type-method (union :simple-subtypep) (type1 type2)
+ (union-simple-subtypep type1 type2))
+
(defun union-complex-subtypep-arg1 (type1 type2)
(every/type (swapped-args-fun #'csubtypep)
type2
(union-type-types type1)))
+
(!define-type-method (union :complex-subtypep-arg1) (type1 type2)
(union-complex-subtypep-arg1 type1 type2))
(defun union-complex-subtypep-arg2 (type1 type2)
- (any/type #'csubtypep type1 (union-type-types type2)))
+ (multiple-value-bind (sub-value sub-certain?)
+ ;; was: (any/type #'csubtypep type1 (union-type-types type2)),
+ ;; which turns out to be too restrictive, causing bug 91.
+ ;;
+ ;; the following reimplementation might look dodgy. It is
+ ;; dodgy. It depends on the union :complex-= method not doing
+ ;; very much work -- certainly, not using subtypep. Reasoning:
+ (progn
+ ;; At this stage, we know that type2 is a union type and type1
+ ;; isn't. We might as well check this, though:
+ (aver (union-type-p type2))
+ (aver (not (union-type-p type1)))
+ ;; A is a subset of (B1 u B2)
+ ;; <=> A n (B1 u B2) = A
+ ;; <=> (A n B1) u (A n B2) = A
+ ;;
+ ;; But, we have to be careful not to delegate this type= to
+ ;; something that could invoke subtypep, which might get us
+ ;; back here -> stack explosion. We therefore ensure that the
+ ;; second type (which is the one that's dispatched on) is
+ ;; either a union type (where we've ensured that the complex-=
+ ;; method will not call subtypep) or something with no union
+ ;; types involved, in which case we'll never come back here.
+ ;;
+ ;; If we don't do this, then e.g.
+ ;; (SUBTYPEP '(MEMBER 3) '(OR (SATISFIES FOO) (SATISFIES BAR)))
+ ;; would loop infinitely, as the member :complex-= method is
+ ;; implemented in terms of subtypep.
+ ;;
+ ;; Ouch. - CSR, 2002-04-10
+ (type= type1
+ (apply #'type-union
+ (mapcar (lambda (x) (type-intersection type1 x))
+ (union-type-types type2)))))
+ (if sub-certain?
+ (values sub-value sub-certain?)
+ ;; The ANY/TYPE expression above is a sufficient condition for
+ ;; subsetness, but not a necessary one, so we might get a more
+ ;; certain answer by this CALL-NEXT-METHOD-ish step when the
+ ;; ANY/TYPE expression is uncertain.
+ (invoke-complex-subtypep-arg1-method type1 type2))))
+
(!define-type-method (union :complex-subtypep-arg2) (type1 type2)
(union-complex-subtypep-arg2 type1 type2))
;; CSUBTYPEP, in order to avoid possibly invoking any methods which
;; might in turn invoke (TYPE-INTERSECTION2 TYPE1 TYPE2) and thus
;; cause infinite recursion.
- (cond ((union-complex-subtypep-arg2 type1 type2)
+ ;;
+ ;; Within this method, type2 is guaranteed to be a union type:
+ (aver (union-type-p type2))
+ ;; Make sure to call only the applicable methods...
+ (cond ((and (union-type-p type1)
+ (union-simple-subtypep type1 type2)) type1)
+ ((and (union-type-p type1)
+ (union-simple-subtypep type2 type1)) type2)
+ ((and (not (union-type-p type1))
+ (union-complex-subtypep-arg2 type1 type2))
type1)
- ((union-complex-subtypep-arg1 type2 type1)
+ ((and (not (union-type-p type1))
+ (union-complex-subtypep-arg1 type2 type1))
type2)
(t
;; KLUDGE: This code accumulates a sequence of TYPE-UNION2