-;;; 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?)
- (funcall op thing i)
- (unless sub-certain? (setf certain? nil))
- (when sub-value (return (values t t)))))))
-(defun every/type (op thing list)
- (declare (type function op))
- (dolist (i list (values t t))
- (multiple-value-bind (sub-value sub-certain?)
- (funcall op thing i)
- (unless sub-certain? (return (values nil nil)))
- (unless sub-value (return (values nil t))))))
-
-;;; 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 fun 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)