-;;; 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))))