:default :vanilla)))
(cond ((eq res :vanilla)
(or (vanilla-union type1 type2)
- (make-union-type (list type1 type2))))
+ (make-union-type-or-something (list type1 type2))))
(res)
(t
- (make-union-type (list type1 type2)))))))
+ (make-union-type-or-something (list type1 type2)))))))
;;; Return as restrictive a type as we can discover that is no more
-;;; restrictive than the intersection of Type1 and Type2. The second
+;;; restrictive than the intersection of TYPE1 and TYPE2. The second
;;; value is true if the result is exact. At worst, we randomly return
;;; one of the arguments as the first value (trying not to return a
;;; hairy type).
(values type1 nil))
(!define-type-method (hairy :complex-union) (type1 type2)
- (make-union-type (list type1 type2)))
+ (make-union-type-or-something (list type1 type2)))
(!define-type-method (hairy :simple-=) (type1 type2)
(if (equal (hairy-type-specifier type1)
t))
(!define-type-method (member :complex-subtypep-arg1) (type1 type2)
- (every/type #'ctypep
+ (every/type (swapped-args-fun #'ctypep)
type2
- (member-type-members type1)
- :list-first t))
+ (member-type-members type1)))
;;; We punt if the odd type is enumerable and intersects with the
;;; MEMBER type. If not enumerable, then it is definitely not a
(!define-type-method (intersection :complex-subtypep-arg1) (type1 type2)
(/show0 "entering INTERSECTION :COMPLEX-SUBTYPEP-ARG1")
- (any/type #'csubtypep
+ (any/type (swapped-args-fun #'csubtypep)
type2
- (intersection-type-types type1)
- :list-first t))
+ (intersection-type-types type1)))
(defun intersection-complex-subtypep-arg2 (type1 type2)
(every/type #'csubtypep type1 (intersection-type-types type2)))
(/show0 "entering INTERSECTION :COMPLEX-SUBTYPEP-ARG2")
(intersection-complex-subtypep-arg2 type1 type2))
-;;; Return a new type list where pairs of types whose intersections
-;;; can be represented simply have been replaced by their simple
-;;; representations.
-(defun simplify-intersection-type-types (%types)
- (/show0 "entering SIMPLE-INTERSECTION-TYPE-TYPES")
- (do* ((types (copy-list %types)) ; (to undestructivize the algorithm below)
- (i-types types (cdr i-types))
- (i-type (car i-types) (car i-types)))
- ((null i-types))
- (do* ((pre-j-types i-types (cdr pre-j-types))
- (j-types (cdr pre-j-types) (cdr pre-j-types))
- (j-type (car j-types) (car j-types)))
- ((null j-types))
- (multiple-value-bind (isect win) (type-intersection i-type j-type)
- (when win
- ;; Overwrite I-TYPES with the intersection, and delete
- ;; J-TYPES from the list.
- (setf (car i-types) isect
- (cdr pre-j-types) (cdr j-types)))))
- (/show0 "leaving SIMPLE-INTERSECTION-TYPE-TYPES")
- types))
+;;; shared logic for unions and intersections: Return a new type list
+;;; where pairs of types which can be simplified by SIMPLIFY2-FUN have
+;;; been replaced by their simplified forms.
+(defun simplify-types (types simplify2-fun)
+ (declare (type function simplify2-fun))
+ (let (;; our result, accumulated as a vector
+ (a (make-array (length types) :fill-pointer 0)))
+ (dolist (%type types (coerce a 'list))
+ ;; Merge TYPE into RESULT.
+ (iterate again ((type %type))
+ (dotimes (i (length a) (vector-push-extend type a))
+ (let ((ai (aref a i)))
+ (multiple-value-bind (simplified win?)
+ (funcall simplify2-fun type ai)
+ (when win?
+ (setf (aref a i) (vector-pop a))
+ ;; Give the new SIMPLIFIED its own chance to be
+ ;; pairwise simplified w.r.t. elements of A.
+ (return (again simplified))))))))))
+
+;;; FIXME: See FIXME note for DEFUN SIMPLIFY2-UNION.
+(defun simplify2-intersection (x y)
+ (let ((intersection (type-intersection x y)))
+ (if (and (or (intersection-type-p intersection)
+ (hairy-type-p intersection))
+ (not (intersection-type-p x))
+ (not (intersection-type-p y)))
+ (values nil nil)
+ (values intersection t))))
(!define-type-method (intersection :simple-intersection :complex-intersection)
(type1 type2)
;; could handle usefully (i.e. could without punting to HAIRY-TYPE).
(/show0 "entering type translator for AND")
(make-intersection-type-or-something
- (simplify-intersection-type-types
- (mapcar #'specifier-type type-specifiers))))
+ (simplify-types (mapcar #'specifier-type type-specifiers)
+ #'simplify2-intersection)))
|#
;;; (REMOVEME once INTERSECTION-TYPE works.)
(!def-type-translator and (&whole spec &rest types)
;;;; union types
;;; Make a union type from the specifier types, setting ENUMERABLE in
-;;; the result if all are enumerable.
-(defun make-union-type (types)
+;;; 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))
- (%make-union-type (every #'type-enumerable types) types))
+ (/show0 "entering MAKE-UNION-TYPE-OR-SOMETHING")
+ (cond ((null types)
+ *empty-type*)
+ ((null (cdr types))
+ (first types))
+ (t
+ (%make-union-type (every #'type-enumerable types) types))))
(!define-type-class union)
(return (values nil t)))))))
(!define-type-method (union :complex-subtypep-arg1) (type1 type2)
- (every/type #'csubtypep
+ (every/type (swapped-args-fun #'csubtypep)
type2
- (union-type-types type1)
- :list-first t))
+ (union-type-types type1)))
(defun union-complex-subtypep-arg2 (type1 type2)
(any/type #'csubtypep type1 (union-type-types type2)))
(let ((this-type type1))
(dolist (type (union-type-types type2)
(if (res)
- (make-union-type (cons this-type (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)
(setq res (type-union res int))
(unless w (setq win nil))))))
+;;; FIXME: Obviously, this could be implemented more efficiently if it
+;;; were a primitive. (Making it construct the entire result before
+;;; discarding it because it turns out to be insufficiently simple is
+;;; less than optimum.) A little less obviously, if it were a
+;;; primitive, we could use it a lot more -- basically everywhere we
+;;; do MAKE-UNION-TYPE-OR-SOMETHING. So perhaps this should become
+;;; a primitive; and SIMPLIFY2-INTERSECTION, too, for the same reason.
+(defun simplify2-union (x y)
+ (let ((union (type-union x y)))
+ (if (and (or (union-type-p union)
+ (hairy-type-p union))
+ (not (union-type-p x))
+ (not (union-type-p y)))
+ (values nil nil)
+ (values union t))))
+
(!def-type-translator or (&rest type-specifiers)
+ ;; FIXME: new code -- doesn't work?
+ #|
+ (make-union-type-or-something
+ (simplify-types (mapcar #'specifier-type type-specifiers)
+ #'simplify2-union))
+ |#
+ ;; old code
(reduce #'type-union
- (mapcar #'specifier-type type-specifiers)
- :initial-value *empty-type*))
+ (mapcar #'specifier-type type-specifiers)
+ :initial-value *empty-type*))
\f
;;;; CONS types
(cond ((null (res)) *empty-type*)
((null (rest (res))) (first (res)))
(t
- (make-union-type (res)))))))
+ (make-union-type-or-something (res)))))))
\f
(!def-type-translator array (&optional (element-type '*)
(dimensions '*))
\f
;;;; utilities
-;;; Like ANY and EVERY, except that we handle two-VALUES predicate
-;;; functions like SUBTYPEP. If the result is uncertain, then we
-;;; return (VALUES NIL NIL).
-;;;
-;;; If LIST-FIRST is true, then the list element is the first arg,
-;;; otherwise the second.
-(defun any/type (op thing list &key list-first)
+;;; sort of like ANY and EVERY, except:
+;;; * We handle two-VALUES predicate functions like SUBTYPEP. (And
+;;; if the result is uncertain, then we return (VALUES NIL NIL).)
+;;; * THING is just an atom, and we apply OP (an arity-2 function)
+;;; successively to THING and each element of LIST.
+(defun any/type (op thing list)
(declare (type function op))
(let ((certain? t))
(dolist (i list (values nil certain?))
(multiple-value-bind (sub-value sub-certain?)
- (if list-first
- (funcall op i thing)
- (funcall op thing i))
+ (funcall op thing i)
(unless sub-certain? (setf certain? nil))
(when sub-value (return (values t t)))))))
-(defun every/type (op thing list &key list-first)
+(defun every/type (op thing list)
(declare (type function op))
(dolist (i list (values t t))
(multiple-value-bind (sub-value sub-certain?)
- (if list-first
- (funcall op i thing)
- (funcall op thing i))
+ (funcall op thing i)
(unless sub-certain? (return (values nil nil)))
(unless sub-value (return (values nil t))))))
-;;; Reverse the order of arguments of a SUBTYPEP-like function.
-(declaim (inline swapped/type))
-(defun swapped/type (op)
- (declare (type function op))
+;;; Return a function like FUN, but expecting its (two) arguments in
+;;; the opposite order that FUN does.
+;;;
+;;; (This looks like a sort of general utility, but currently it's
+;;; used only in the implementation of the type system, so it's
+;;; internal to SB-KERNEL. -- WHN 2001-02-13)
+(declaim (inline swapped-args-fun))
+(defun swapped-args-fun (fun)
+ (declare (type function fun))
(lambda (x y)
- (funcall op y x)))
+ (funcall fun y x)))
;;; Compute the intersection for types that intersect only when one is a
;;; hierarchical subtype of the other.
projects / sbcl.git / commitdiff