- (let ((associated ())
- (other ()))
- (dolist (alist *condition-restarts*)
- (if (eq (car alist) condition)
- (setq associated (cdr alist))
- (setq other (append (cdr alist) other))))
- (collect ((res))
- (let ((stack *restart-test-stack*))
- (dolist (restart-cluster *restart-clusters*)
- (dolist (restart restart-cluster)
- (when (and (or (not condition)
- (memq restart associated)
- (not (memq restart other)))
- ;; A call to COMPUTE-RESTARTS -- from an error, from
- ;; user code, whatever -- inside the test function
- ;; would cause infinite recursion here, so we disable
- ;; each restart using *restart-test-stack* for the
- ;; duraction of the test call.
- (not (memq restart stack))
- (let ((*restart-test-stack* (cons restart stack)))
- (declare (truly-dynamic-extent *restart-test-stack*))
- (funcall (restart-test-function restart) condition)))
- (res restart)))))
- (res))))
+ (collect ((result))
+ (map-restarts (lambda (restart) (result restart)) condition)
+ (result)))
+
+(defun %find-restart (identifier &optional condition (call-test-p t))
+ (flet ((eq-restart-p (restart)
+ (when (eq identifier restart)
+ (return-from %find-restart restart)))
+ (named-restart-p (restart)
+ (when (eq identifier (restart-name restart))
+ (return-from %find-restart restart))))
+ ;; TODO Question for reviewer: does the compiler infer this dx
+ ;; automatically?
+ (declare (truly-dynamic-extent #'eq-restart-p #'named-restart-p))
+ (if (typep identifier 'restart)
+ ;; TODO Questions for reviewer:
+ ;;
+ ;; The code under #+previous-... below breaks the abstraction
+ ;; introduced by MAP-RESTARTS, but is about twice as
+ ;; fast as #+equivalent-... . Also, it is a common case due to
+ ;;
+ ;; (INVOKE-RESTART RESTART)
+ ;; -> (FIND-RESTART-OR-CONTROL-ERROR RESTART)
+ ;; -> (FIND-RESTART RESTART)
+ ;;
+ ;; However, both #+previous-... and #+equivalent-... may be
+ ;; wrong altogether because of
+ ;; https://bugs.launchpad.net/sbcl/+bug/774410:
+ ;; The behavior expected in that report can be achieved by the
+ ;; following line (which is, of course, the slowest of all
+ ;; possibilities):
+ (map-restarts #'eq-restart-p condition call-test-p)
+
+ #+equivalent-to-previous-sbcl-behavior--faster-but-see-bug-774410
+ (map-restarts #'eq-restart-p nil nil)
+
+ #+previous-behavior--fastest-but-see-bug-774410
+ (and (find-if (lambda (cluster) (find identifier cluster)) *restart-clusters*)
+ identifier)
+
+ (map-restarts #'named-restart-p condition call-test-p))))