From f7b60deb3e34c4655af26ac879a8d1f146209730 Mon Sep 17 00:00:00 2001
Message-Id: <f7b60deb3e34c4655af26ac879a8d1f146209730.1715287085.git.mdw@distorted.org.uk>
From: Mark Wooding <mdw@chiark.greenend.org.uk>
Date: Sun, 26 Mar 2017 15:16:18 +0100
Subject: [PATCH] src/utilities.lisp: New function `invoke-associated-restart'.
Organization: Straylight/Edgeware

From: Mark Wooding <mdw@distorted.org.uk>

Does what it says on the tin.  Not really sure why this isn't part of
Common Lisp.
---
 doc/SYMBOLS        |  9 +++++++++
 doc/misc.tex       |  9 +++++++++
 src/utilities.lisp | 24 ++++++++++++++++++++++++
 3 files changed, 42 insertions(+)

diff --git a/doc/SYMBOLS b/doc/SYMBOLS
index 3b73a99..07fedc1 100644
--- a/doc/SYMBOLS
+++ b/doc/SYMBOLS
@@ -2240,6 +2240,7 @@ utilities.lisp
   sb-mop:generic-function-methods               generic setf
   inconsistent-merge-error                      class
   instance-initargs                             generic
+  invoke-associated-restart                     function
   it
   lbuild-add                                    function
   lbuild-add-list                               function
@@ -2258,6 +2259,7 @@ utilities.lisp
   partial-order-minima                          function
   print-ugly-stuff                              function
   ref                                           function setf
+  simple-control-error                          class
   symbolicate                                   function
   update-position                               function
   whitespace-char-p                             function
@@ -2270,7 +2272,14 @@ cl:t
     cl:condition
       cl:serious-condition
         cl:error
+          cl:control-error
+            simple-control-error [cl:simple-error]
           inconsistent-merge-error
+          cl:simple-error [cl:simple-condition]
+            simple-control-error [cl:control-error]
+      cl:simple-condition
+        cl:simple-error [cl:error]
+          simple-control-error [cl:control-error]
     cl:standard-object
       sb-mop:metaobject
         sb-mop:specializer
diff --git a/doc/misc.tex b/doc/misc.tex
index 5767c3e..3f3cf76 100644
--- a/doc/misc.tex
+++ b/doc/misc.tex
@@ -211,6 +211,11 @@ These symbols are defined in the @|sod-utilities| package.
                            @[[ :read-only @<read-only-flag> @]]}
 \end{describe}
 
+\begin{describe}{cls}
+    {simple-control-error (control-error simple-error)
+        \&key :format-control :format-arguments}
+\end{describe}
+
 \begin{describe}{fun}
     {designated-condition
         \=@<default-type> @<datum> @<arguments>                 \\
@@ -218,6 +223,10 @@ These symbols are defined in the @|sod-utilities| package.
       \nlret @<condition>}
 \end{describe}
 
+\begin{describe}{fun}
+    {invoke-associated-restart @<restart> @<condition> \&rest @<arguments>}
+\end{describe}
+
 \begin{describe}{mac}
     {default-slot (@<instance> @<slot> @[@<slot-names>@])       \\ \ind
       @<form>^*}
diff --git a/src/utilities.lisp b/src/utilities.lisp
index 0415a90..0f6a54b 100644
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -972,6 +972,30 @@ (defun designated-condition (default-type datum arguments
     (t
      (error "Unexpected condition designator datum ~S" datum))))
 
+(export 'simple-control-error)
+(define-condition simple-control-error (control-error simple-error)
+  ())
+
+(export 'invoke-associated-restart)
+(defun invoke-associated-restart (restart condition &rest arguments)
+  "Invoke the active RESTART associated with CONDITION, with the ARGUMENTS.
+
+   Find an active restart designated by RESTART; if CONDITION is not nil,
+   then restrict the search to restarts associated with CONDITION, and
+   restarts not associated with any condition.  If no such restart is found
+   then signal an error of type `control-error'; otherwise invoke the restart
+   with the given ARGUMENTS."
+  (apply #'invoke-restart
+	 (or (find-restart restart condition)
+	     (error 'simple-control-error
+		    :format-control "~:[Restart ~S is not active~;~
+					No active `~(~A~)' restart~]~
+				     ~@[ for condition ~S~]"
+		    :format-arguments (list (symbolp restart)
+					    restart
+					    condition)))
+	 arguments))
+
 ;;;--------------------------------------------------------------------------
 ;;; CLOS hacking.
 
-- 
[mdw]