(!define-superclasses function ((function)) !cold-init-forms)
;;; The union or intersection of two FUNCTION types is FUNCTION.
-(!define-type-method (function :simple-union) (type1 type2)
+(!define-type-method (function :simple-union2) (type1 type2)
(declare (ignore type1 type2))
(specifier-type 'function))
(!define-type-method (function :simple-intersection2) (type1 type2)
(t
type)))
-;;; Return the minmum number of arguments that a function can be
+;;; Return the minimum number of arguments that a function can be
;;; called with, and the maximum number or NIL. If not a function
;;; type, return NIL, NIL.
(defun function-type-nargs (type)
;;; This has the virtue of always keeping the VALUES type specifier
;;; outermost, and retains all of the information that is really
;;; useful for static type analysis. We want to know what is always
-;;; true of each value independently. It is worthless to know that IF
+;;; true of each value independently. It is worthless to know that if
;;; the first value is B0 then the second will be B1.
;;;
;;; If the VALUES count signatures differ, then we produce a result with
(values (not res) t)
(values nil nil))))
+;;; the type method dispatch case of TYPE-UNION2
+(defun %type-union2 (type1 type2)
+ ;; As in %TYPE-INTERSECTION2, it seems to be a good idea to give
+ ;; both argument orders a chance at COMPLEX-INTERSECTION2. Unlike
+ ;; %TYPE-INTERSECTION2, though, I don't have a specific case which
+ ;; demonstrates this is actually necessary. Also unlike
+ ;; %TYPE-INTERSECTION2, there seems to be no need to distinguish
+ ;; between not finding a method and having a method return NIL.
+ (flet ((1way (x y)
+ (!invoke-type-method :simple-union2 :complex-union2
+ x y
+ :default nil)))
+ (declare (inline 1way))
+ (or (1way type1 type2)
+ (1way type2 type1))))
+
;;; Find a type which includes both types. Any inexactness is
;;; represented by the fuzzy element types; we return a single value
;;; that is precise to the best of our knowledge. This result is
-;;; simplified into the canonical form, thus is not a UNION type
-;;; unless there is no other way to represent the result.
-(defun-cached (type-union :hash-function type-cache-hash
- :hash-bits 8
- :init-wrapper !cold-init-forms)
+;;; simplified into the canonical form, thus is not a UNION-TYPE
+;;; unless we find no other way to represent the result.
+(defun-cached (type-union2 :hash-function type-cache-hash
+ :hash-bits 8
+ :init-wrapper !cold-init-forms)
((type1 eq) (type2 eq))
+ ;; KLUDGE: This was generated from TYPE-INTERSECTION2 by Ye Olde Cut And
+ ;; Paste technique of programming. If it stays around (as opposed to
+ ;; e.g. fading away in favor of some CLOS solution) the shared logic
+ ;; should probably become shared code. -- WHN 2001-03-16
(declare (type ctype type1 type2))
- (if (eq type1 type2)
- type1
- (let ((res (!invoke-type-method :simple-union :complex-union
- type1 type2
- :default :vanilla)))
- (cond ((eq res :vanilla)
- (or (vanilla-union type1 type2)
- (make-union-type-or-something (list type1 type2))))
- (res)
- (t
- (make-union-type-or-something (list type1 type2)))))))
+ (cond ((eq type1 type2)
+ type1)
+ ((or (union-type-p type1)
+ (union-type-p type2))
+ ;; Unions of UNION-TYPE should have the UNION-TYPE-TYPES
+ ;; values broken out and united separately. The full TYPE-UNION
+ ;; function knows how to do this, so let it handle it.
+ (type-union type1 type2))
+ (t
+ ;; the ordinary case: we dispatch to type methods
+ (%type-union2 type1 type2))))
;;; the type method dispatch case of TYPE-INTERSECTION2
(defun %type-intersection2 (type1 type2)
((or (intersection-type-p type1)
(intersection-type-p type2))
;; Intersections of INTERSECTION-TYPE should have the
- ;; INTERSECTION-TYPE-TYPES objects broken out and intersected
+ ;; INTERSECTION-TYPE-TYPES values broken out and intersected
;; separately. The full TYPE-INTERSECTION function knows how
;; to do that, so let it handle it.
(type-intersection type1 type2))
;;; shared logic for unions and intersections: Stuff TYPE into the
;;; vector TYPES, finding pairs of types which can be simplified by
-;;; SIMPLIFY2 and replacing them by their simplified forms.
-(defun accumulate-compound-type (type types simplify2)
+;;; SIMPLIFY2 (TYPE-UNION2 or TYPE-INTERSECTION2) and replacing them
+;;; by their simplified forms.
+(defun accumulate1-compound-type (type types %compound-type-p simplify2)
(declare (type ctype type))
- (declare (type (vector t) types))
+ (declare (type (vector ctype) types))
(declare (type function simplify2))
+ ;; Any input object satisfying %COMPOUND-TYPE-P should've been
+ ;; broken into components before it reached us.
+ (assert (not (funcall %compound-type-p type)))
(dotimes (i (length types) (vector-push-extend type types))
(let ((simplified2 (funcall simplify2 type (aref types i))))
(when simplified2
;; Discard the old (AREF TYPES I).
(setf (aref types i) (vector-pop types))
- ;; Add the new SIMPLIFIED2 to TYPES, by tail recursing.
+ ;; Merge the new SIMPLIFIED2 into TYPES, by tail recursing.
+ ;; (Note that the tail recursion is indirect: we go through
+ ;; ACCUMULATE, not ACCUMULATE1, so that if SIMPLIFIED2 is
+ ;; handled properly if it satisfies %COMPOUND-TYPE-P.)
(return (accumulate-compound-type simplified2
types
+ %compound-type-p
simplify2)))))
+ ;; Voila.
+ (values))
+
+;;; shared logic for unions and intersections: Use
+;;; ACCUMULATE1-COMPOUND-TYPE to merge TYPE into TYPES, either
+;;; all in one step or, if %COMPOUND-TYPE-P is satisfied,
+;;; component by component.
+(defun accumulate-compound-type (type types %compound-type-p simplify2)
+ (declare (type function %compound-type-p simplify2))
+ (flet ((accumulate1 (x)
+ (accumulate1-compound-type x types %compound-type-p simplify2)))
+ (declare (inline accumulate1))
+ (if (funcall %compound-type-p type)
+ (map nil #'accumulate1 (compound-type-types type))
+ (accumulate1 type)))
(values))
+;;; shared logic for unions and intersections: Return a vector of
+;;; types representing the same types as INPUT-TYPES, but with
+;;; COMPOUND-TYPEs satisfying %COMPOUND-TYPE-P broken up into their
+;;; component types, and with any SIMPLY2 simplifications applied.
+(defun simplified-compound-types (input-types %compound-type-p simplify2)
+ (let ((simplified-types (make-array (length input-types)
+ :fill-pointer 0
+ :element-type 'ctype
+ ;; (This INITIAL-ELEMENT shouldn't
+ ;; matter, but helps avoid type
+ ;; warnings at compile time.)
+ :initial-element *empty-type*)))
+ (dolist (input-type input-types)
+ (accumulate-compound-type input-type
+ simplified-types
+ %compound-type-p
+ simplify2))
+ simplified-types))
+
;;; 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-VECTOR is short.
+;;; 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)
(declare (type function constructor))
- (declare (type (vector t) types))
+ (declare (type (vector ctype) types))
(declare (type ctype identity))
(case (length types)
(0 identity)
- (1 (the ctype (aref types 0)))
- (t (funcall constructor enumerable (coerce types 'list)))))
+ (1 (aref types 0))
+ (t (funcall constructor
+ enumerable
+ ;; FIXME: This should be just (COERCE TYPES 'LIST), but as
+ ;; of sbcl-0.6.11.17 the COERCE optimizer is really
+ ;; 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
+ ;; before we know what 'LIST is. Once the COERCE
+ ;; optimizer is less brain-dead, we can make this
+ ;; (COERCE TYPES 'LIST) again.
+ #+sb-xc-host (coerce types 'list)
+ #-sb-xc-host (coerce-to-list types)))))
(defun type-intersection (&rest input-types)
- (let (;; components of our result, accumulated as a vector
- (simplified-types (make-array (length input-types) :fill-pointer 0)))
- (flet ((accumulate (type)
- (accumulate-compound-type type
- simplified-types
- #'type-intersection2)))
- (declare (inline accumulate))
- (dolist (type input-types)
- (if (intersection-type-p type)
- (map nil #'accumulate (intersection-type-types type))
- (accumulate type)))
- ;; We want to have a canonical representation of types (or failing
- ;; that, punt to HAIRY-TYPE). Canonical representation would have
- ;; intersections inside unions but not vice versa, since you can
- ;; 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.
- (if (and (> (length simplified-types) 1)
- (some #'union-type-p simplified-types))
- (make-hairy-type
- :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*)))))
-
-;;; FIXME: Define TYPE-UNION similar to TYPE-INTERSECTION.
+ (let ((simplified-types (simplified-compound-types input-types
+ #'intersection-type-p
+ #'type-intersection2)))
+ (declare (type (vector ctype) simplified-types))
+ ;; We want to have a canonical representation of types (or failing
+ ;; that, punt to HAIRY-TYPE). Canonical representation would have
+ ;; intersections inside unions but not vice versa, since you can
+ ;; 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.
+ (if (and (> (length simplified-types) 1)
+ (some #'union-type-p simplified-types))
+ (make-hairy-type
+ :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*))))
+
+(defun type-union (&rest 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*)))
\f
;;;; built-in types
;;(assert (not (eq type2 *wild-type*))) ; * isn't really a type.
(hierarchical-intersection2 type1 type2))
+(!define-type-method (named :complex-union2) (type1 type2)
+ ;; Perhaps when bug 85 is fixed this can be reenabled.
+ ;;(assert (not (eq type2 *wild-type*))) ; * isn't really a type.
+ (hierarchical-union2 type1 type2))
+
(!define-type-method (named :unparse) (x)
(named-type-name x))
\f
(declare (ignore type1 type2))
nil)
-(!define-type-method (hairy :complex-union) (type1 type2)
- (make-union-type-or-something (list type1 type2)))
-
(!define-type-method (hairy :simple-=) (type1 type2)
(if (equal (hairy-type-specifier type1)
(hairy-type-specifier type2))
(!def-type-translator satisfies (&whole whole fun)
(declare (ignore fun))
- ;; Check legality of arguments of arguments.
+ ;; Check legality of arguments.
(destructuring-bind (satisfies predicate-name) whole
(declare (ignore satisfies))
(unless (symbolp predicate-name)
(error 'simple-type-error
:datum predicate-name
- :expected-type symbol
+ :expected-type 'symbol
:format-control "~S is not a symbol."
:format-arguments (list predicate-name))))
+ ;; Create object.
(make-hairy-type :specifier whole))
\f
;;;; numeric types
;;;
;;; ### 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-union) (type1 type2)
+(!define-type-method (number :simple-union2) (type1 type2)
(declare (type numeric-type type1 type2))
(cond ((csubtypep type1 type2) type2)
((csubtypep type2 type1) type1)
(make-numeric-type :complexp :complex)
(let ((type (specifier-type spec)))
(unless (numeric-type-p type)
- (error "Component type for Complex is not numeric: ~S." spec))
+ (error "The component type for COMPLEX is not numeric: ~S" spec))
(when (eq (numeric-type-complexp type) :complex)
- (error "Component type for Complex is complex: ~S." spec))
+ (error "The component type for COMPLEX is complex: ~S" spec))
(let ((res (copy-numeric-type type)))
(setf (numeric-type-complexp res) :complex)
res))))
(t
(make-member-type :members (members))))))))
-;;; We don't need a :COMPLEX-UNION, since the only interesting case is
+;;; We don't need a :COMPLEX-UNION2, since the only interesting case is
;;; a union type, and the member/union interaction is handled by the
;;; union type method.
-(!define-type-method (member :simple-union) (type1 type2)
+(!define-type-method (member :simple-union2) (type1 type2)
(let ((mem1 (member-type-members type1))
(mem2 (member-type-members type2)))
(cond ((subsetp mem1 mem2) type2)
(type=-set (intersection-type-types type1)
(intersection-type-types type2)))
-(!define-type-method (intersection :simple-subtypep) (type1 type2)
- (let ((certain? t))
- (dolist (t1 (intersection-type-types type1) (values nil certain?))
- (multiple-value-bind (subtypep validp)
- (intersection-complex-subtypep-arg2 t1 type2)
- (cond ((not validp)
- (setf certain? nil))
- (subtypep
- (return (values t t))))))))
-
-(!define-type-method (intersection :complex-subtypep-arg1) (type1 type2)
- (any/type (swapped-args-fun #'csubtypep)
- type2
- (intersection-type-types type1)))
-
-(defun intersection-complex-subtypep-arg2 (type1 type2)
- (every/type #'csubtypep type1 (intersection-type-types type2)))
+(flet ((intersection-complex-subtypep-arg1 (type1 type2)
+ (any/type (swapped-args-fun #'csubtypep)
+ type2
+ (intersection-type-types type1))))
+ (!define-type-method (intersection :simple-subtypep) (type1 type2)
+ (every/type #'intersection-complex-subtypep-arg1
+ type1
+ (intersection-type-types 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)
- (intersection-complex-subtypep-arg2 type1 type2))
+ (every/type #'csubtypep type1 (intersection-type-types type2)))
(!def-type-translator and (&whole whole &rest type-specifiers)
(apply #'type-intersection
\f
;;;; union types
-;;; Make a union type from the specifier types, setting ENUMERABLE in
-;;; the result if all are enumerable; or take the easy way out if we
-;;; recognize a special case which can be represented more simply.
-(defun make-union-type-or-something (types)
- (declare (list types))
- (cond ((null types)
- *empty-type*)
- ((null (cdr types))
- (first types))
- (t
- (%make-union-type (every #'type-enumerable types) types))))
-
(!define-type-class union)
;;; The LIST type has a special name. Other union types just get
(!define-type-method (union :complex-subtypep-arg2) (type1 type2)
(union-complex-subtypep-arg2 type1 type2))
-(!define-type-method (union :complex-union) (type1 type2)
- (let ((class1 (type-class-info type1)))
- (collect ((res))
- (let ((this-type type1))
- (dolist (type (union-type-types type2)
- (if (res)
- (make-union-type-or-something (cons this-type (res)))
- this-type))
- (cond ((eq (type-class-info type) class1)
- (let ((union (funcall (type-class-simple-union class1)
- this-type type)))
- (if union
- (setq this-type union)
- (res type))))
- ((csubtypep type this-type))
- ((csubtypep type1 type) (return type2))
- (t
- (res type))))))))
-
-;;; For the union of union types, we let the :COMPLEX-UNION method do
-;;; the work.
-(!define-type-method (union :simple-union) (type1 type2)
- (let ((res type1))
- (dolist (t2 (union-type-types type2) res)
- (setq res (type-union res t2)))))
-
(!define-type-method (union :simple-intersection2 :complex-intersection2)
(type1 type2)
;; The CSUBTYPEP clauses here let us simplify e.g.
((union-complex-subtypep-arg1 type2 type1)
type2)
(t
- (let (;; a component of TYPE2 whose intersection with TYPE1
- ;; is nonempty
- (nontriv-t2 nil))
- (dolist (t2 (union-type-types type2) (or nontriv-t2 *empty-type*))
- (unless (eq *empty-type* (type-intersection type1 t2))
- (if nontriv-t2 ; if this is second nonempty intersection
- (return nil) ; too many: can't find nice result
- (setf nontriv-t2 t2))))))))
+ ;; KLUDGE: This code accumulates a sequence of TYPE-UNION2
+ ;; operations in a particular order, and gives up if any of
+ ;; the sub-unions turn out not to be simple. In other cases
+ ;; ca. sbcl-0.6.11.15, that approach to taking a union was a
+ ;; bad idea, since it can overlook simplifications which
+ ;; might occur if the terms were accumulated in a different
+ ;; order. It's possible that that will be a problem here too.
+ ;; However, I can't think of a good example to demonstrate
+ ;; it, and without an example to demonstrate it I can't write
+ ;; test cases, and without test cases I don't want to
+ ;; complicate the code to address what's still a hypothetical
+ ;; problem. So I punted. -- WHN 2001-03-20
+ (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)))))))
(!def-type-translator or (&rest type-specifiers)
- (reduce #'type-union
- (mapcar #'specifier-type type-specifiers)
- :initial-value *empty-type*))
+ (apply #'type-union
+ (mapcar #'specifier-type
+ type-specifiers)))
\f
;;;; CONS types
;;; Give up if a precise type is not possible, to avoid returning
;;; overly general types.
-(!define-type-method (cons :simple-union) (type1 type2)
+(!define-type-method (cons :simple-union2) (type1 type2)
(declare (type cons-type type1 type2))
(let ((car-type1 (cons-type-car-type type1))
(car-type2 (cons-type-car-type type2))
(when val (return))
(when (types-intersect x-type y-type)
(return-from type-difference nil))))))
-
(let ((y-mem (find-if #'member-type-p y-types)))
(when y-mem
(let ((members (member-type-members y-mem)))
(multiple-value-bind (val win) (ctypep member x-type)
(when (or (not win) val)
(return-from type-difference nil)))))))))
-
- (cond ((null (res)) *empty-type*)
- ((null (rest (res))) (first (res)))
- (t
- (make-union-type-or-something (res)))))))
+ (apply #'type-union (res)))))
\f
(!def-type-translator array (&optional (element-type '*)
(dimensions '*))
projects / sbcl.git / blobdiff