src/utilities.lisp: New function `invoke-associated-restart'.

Does what it says on the tin.  Not really sure why this isn't part of
Common Lisp.

diff --git a/doc/SYMBOLS b/doc/SYMBOLS
index 3b73a9979779d05d26f6b652f1eca52f3e7b1379..07fedc1f33fc7565d1f4244ddca7e9633beab338 100644 (file)
--- 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 5767c3ea297df85d6dd7b0a8d7bfee14662d4570..3f3cf762fb058f8395687248176e0fc2d89281ca 100644 (file)
--- 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 0415a90fed193ee950fc8ee01ca0e8e7334f3d3b..0f6a54b0d3a562d855c49177e9cad2924cd3bd30 100644 (file)
--- 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.