(defun !has-superclasses-complex-subtypep-arg1 (type1 type2 info)
;; If TYPE2 might be concealing something related to our class
;; hierarchy
- (if (type-might-contain-other-types? type2)
- ;; too confusing, gotta punt
+ (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
;;; Since all function types are equivalent to FUNCTION, they are all
;;; subtypes of each other.
(!define-type-method (function :simple-subtypep) (type1 type2)
- (declare (ignore type1 type2))
- (values t t))
+ (flet ((fun-type-simple-p (type)
+ (not (or (fun-type-rest type)
+ (fun-type-keyp type))))
+ (every-csubtypep (types1 types2)
+ (loop
+ for a1 in types1
+ for a2 in types2
+ do (multiple-value-bind (res sure-p)
+ (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 (or win1 win2))))))))
+ (3and (csubtypep (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)))
+ (values nil nil))
+ ((not (and (= (length (fun-type-required type1))
+ (length (fun-type-required type2)))
+ (= (length (fun-type-optional type1))
+ (length (fun-type-optional type2)))))
+ (values nil t))
+ (t (3and (every-csubtypep (fun-type-required type1)
+ (fun-type-required type2))
+ (every-csubtypep (fun-type-optional type1)
+ (fun-type-optional type2)))))))))
(!define-superclasses function ((function)) !cold-init-forms)
;;; 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 aux)
- (parse-lambda-list lambda-list)
- (when aux
+ (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 #'specifier-type required))
(setf (args-type-optional result) (mapcar #'specifier-type optional))
(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))
(let ((res (specifier-type spec)))
(unless (unknown-type-p res)
(setf (info :type :builtin spec) res)
- (setf (info :type :kind spec) :primitive))))
+ ;; KLUDGE: the three copies of this idiom in this file (and
+ ;; the one in class.lisp as at sbcl-0.7.4.1x) should be
+ ;; coalesced, or perhaps the error-detecting code that
+ ;; disallows redefinition of :PRIMITIVE types should be
+ ;; rewritten to use *TYPE-SYSTEM-FINALIZED* (rather than
+ ;; *TYPE-SYSTEM-INITIALIZED*). The effect of this is not to
+ ;; cause redefinition errors when precompute-types is called
+ ;; for a second time while building the target compiler using
+ ;; the cross-compiler. -- CSR, trying to explain why this
+ ;; isn't completely wrong, 2002-06-07
+ (setf (info :type :kind spec) #+sb-xc-host :defined #-sb-xc-host :primitive))))
(values))
\f
;;;; general TYPE-UNION and TYPE-INTERSECTION operations
#+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
(macrolet ((frob (name var)
`(progn
(setq ,var (make-named-type :name ',name))
- (setf (info :type :kind ',name) :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
(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.
+ ;; 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? type2)
+ (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
(values nil nil))
(t
;; By elimination, TYPE1 is the universal type.
- (aver (eq type1 *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*)))
\f
;;;; hairy and unknown types
-(!define-type-method (hairy :unparse) (x) (hairy-type-specifier x))
-
+(!define-type-method (hairy :unparse) (x)
+ (hairy-type-specifier x))
+
(!define-type-method (hairy :simple-subtypep) (type1 type2)
(let ((hairy-spec1 (hairy-type-specifier type1))
(hairy-spec2 (hairy-type-specifier type2)))
;; 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? complement-type1)
- (type-might-contain-other-types? type2))
+ (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
(!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)
(t
(values nil t)))))
-(!define-superclasses number ((generic-number)) !cold-init-forms)
+(!define-superclasses number ((number)) !cold-init-forms)
;;; If the high bound of LOW is adjacent to the low bound of HIGH,
;;; then return true, otherwise NIL.
>= > t)))))))
(!cold-init-forms
- (setf (info :type :kind 'number) :primitive)
+ (setf (info :type :kind 'number) #+sb-xc-host :defined #-sb-xc-host :primitive)
(setf (info :type :builtin 'number)
(make-numeric-type :complexp nil)))
;; 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)
+ *empty-type*
(make-numeric-type :class 'integer
:complexp :real
:enumerable (not (null (and l h)))
;; 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)
+ *empty-type*
(make-numeric-type :class ',class :format ',format :low lb :high hb)))))
(!def-bounded-type rational rational nil)
(array-type-element-type type)))
(!define-type-method (array :simple-=) (type1 type2)
- (values (and (equal (array-type-dimensions type1)
- (array-type-dimensions type2))
- (eq (array-type-complexp type1)
- (array-type-complexp type2))
- (type= (specialized-element-type-maybe type1)
- (specialized-element-type-maybe type2)))
- t))
+ (if (or (unknown-type-p (array-type-element-type type1))
+ (unknown-type-p (array-type-element-type type2)))
+ (multiple-value-bind (equalp certainp)
+ (type= (array-type-element-type type1)
+ (array-type-element-type type2))
+ ;; by its nature, the call to TYPE= should never return NIL,
+ ;; T, as we don't know what the UNKNOWN-TYPE will grow up to
+ ;; be. -- CSR, 2002-08-19
+ (aver (not (and (not equalp) certainp)))
+ (values equalp certainp))
+ (values (and (equal (array-type-dimensions type1)
+ (array-type-dimensions type2))
+ (eq (array-type-complexp type1)
+ (array-type-complexp type2))
+ (type= (specialized-element-type-maybe type1)
+ (specialized-element-type-maybe type2)))
+ t)))
(!define-type-method (array :unparse) (type)
(let ((dims (array-type-dimensions type))
(eq complexp2 :maybe)
(eq complexp1 complexp2)))
(values nil t))
- ;; If either element type is wild, then they intersect.
- ;; Otherwise, the types must be identical.
- ((or (eq (array-type-element-type type1) *wild-type*)
- (eq (array-type-element-type type2) *wild-type*)
+ ;; Old comment:
+ ;;
+ ;; If either element type is wild, then they intersect.
+ ;; Otherwise, the types must be identical.
+ ;;
+ ;; FIXME: There seems to have been a fair amount of
+ ;; confusion about the distinction between requested element
+ ;; type and specialized element type; here is one of
+ ;; them. If we request an array to hold objects of an
+ ;; unknown type, we can do no better than represent that
+ ;; type as an array specialized on wild-type. We keep the
+ ;; requested element-type in the -ELEMENT-TYPE slot, and
+ ;; *WILD-TYPE* in the -SPECIALIZED-ELEMENT-TYPE. So, here,
+ ;; we must test for the SPECIALIZED slot being *WILD-TYPE*,
+ ;; not just the ELEMENT-TYPE slot. Maybe the return value
+ ;; in that specific case should be T, NIL? Or maybe this
+ ;; function should really be called
+ ;; ARRAY-TYPES-COULD-POSSIBLY-INTERSECT? In any case, this
+ ;; was responsible for bug #123, and this whole issue could
+ ;; do with a rethink and/or a rewrite. -- CSR, 2002-08-21
+ ((or (eq (array-type-specialized-element-type type1) *wild-type*)
+ (eq (array-type-specialized-element-type type2) *wild-type*)
(type= (specialized-element-type-maybe type1)
(specialized-element-type-maybe type2)))
(!define-type-method (member :unparse) (type)
(let ((members (member-type-members type)))
- (if (equal members '(nil))
- 'null
- `(member ,@members))))
+ (cond
+ ((equal members '(nil)) 'null)
+ ((type= type (specifier-type 'standard-char)) 'standard-char)
+ (t `(member ,@members)))))
(!define-type-method (member :simple-subtypep) (type1 type2)
(values (subsetp (member-type-members type1) (member-type-members type2))
(!define-type-class union)
-;;; The LIST type has a special name. Other union types just get
-;;; mechanically unparsed.
+;;; The LIST, FLOAT and REAL types have special names. Other union
+;;; types just get mechanically unparsed.
(!define-type-method (union :unparse) (type)
(declare (type ctype type))
- (if (type= type (specifier-type 'list))
- 'list
- `(or ,@(mapcar #'type-specifier (union-type-types type)))))
-
+ (cond
+ ((type= type (specifier-type 'list)) 'list)
+ ((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)
+ (t `(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 and only if
;;; every element of TYPE1 is a subtype of TYPE2.
-(!define-type-method (union :simple-subtypep) (type1 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)
- (multiple-value-bind (sub-value sub-certain?)
- (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
;; 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
projects / sbcl.git / blobdiff