-;;; 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)
- (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))
- (unless sub-certain? (setf certain? nil))
- (when sub-value (return (values t t)))))))
-(defun every/type (op thing list &key list-first)
- (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))
- (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))
- (lambda (x y)
- (funcall op y x)))
-
-;;; Compute the intersection for types that intersect only when one is a
-;;; hierarchical subtype of the other.
-(defun vanilla-intersection (type1 type2)
- (multiple-value-bind (stp1 win1) (csubtypep type1 type2)
- (multiple-value-bind (stp2 win2) (csubtypep type2 type1)
- (cond (stp1 (values type1 t))
- (stp2 (values type2 t))
- ((and win1 win2) (values *empty-type* t))
- (t
- (values type1 nil))))))
-
-(defun vanilla-union (type1 type2)
+;;; Look for nice relationships for types that have nice relationships
+;;; only when one is a hierarchical subtype of the other.
+(defun hierarchical-intersection2 (type1 type2)
+ (multiple-value-bind (subtypep1 win1) (csubtypep type1 type2)
+ (multiple-value-bind (subtypep2 win2) (csubtypep type2 type1)
+ (cond (subtypep1 type1)
+ (subtypep2 type2)
+ ((and win1 win2) *empty-type*)
+ (t nil)))))
+(defun hierarchical-union2 (type1 type2)