+(defun add-combination-test-constraints (use constraints
+ consequent-constraints
+ alternative-constraints
+ quick-p)
+ (flet ((add (fun x y not-p)
+ (add-complement-constraints quick-p
+ fun x y not-p
+ constraints
+ consequent-constraints
+ alternative-constraints))
+ (prop (triples target)
+ (map nil (lambda (constraint)
+ (destructuring-bind (kind x y &optional not-p)
+ constraint
+ (when (and kind x y)
+ (add-test-constraint quick-p
+ kind x y
+ not-p constraints
+ target))))
+ triples)))
+ (when (eq (combination-kind use) :known)
+ (binding* ((info (combination-fun-info use) :exit-if-null)
+ (propagate (fun-info-constraint-propagate-if
+ info)
+ :exit-if-null))
+ (multiple-value-bind (lvar type if else)
+ (funcall propagate use constraints)
+ (prop if consequent-constraints)
+ (prop else alternative-constraints)
+ (when (and lvar type)
+ (add 'typep (ok-lvar-lambda-var lvar constraints)
+ type nil)
+ (return-from add-combination-test-constraints)))))
+ (let* ((name (lvar-fun-name
+ (basic-combination-fun use)))
+ (args (basic-combination-args use))
+ (ptype (gethash name *backend-predicate-types*)))
+ (when ptype
+ (add 'typep (ok-lvar-lambda-var (first args)
+ constraints)
+ ptype nil)))))
+