-
Notifications
You must be signed in to change notification settings - Fork 0
/
recursive-restart.lisp
195 lines (177 loc) · 6.99 KB
/
recursive-restart.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
(defpackage :recursive-restart
(:use :common-lisp :alexandria)
(:export :recursive-restart-case
:restart-bind*
:restart-return
:do-restart
:handler-bind*
:handler-return))
(in-package :recursive-restart)
(defmacro recursive-restart-case (value-form &rest cases)
"RECURSIVE-RESTART-CASE has the same semantics as RESTART-CASE, except
you can re-invoke any of the restarts in a mutually recursive fashion.
Example:
(let ((invoked-bar nil))
(recursive-restart-case
(invoke-restart 'foo)
(foo ()
(format t \"Invoked FOO.~%\")
(if invoked-bar
:done
(invoke-restart 'bar)))
(bar ()
(format t \"Invoked BAR.~%\")
(setf invoked-bar t)
(format t \"Invoking FOO again...~%\")
(invoke-restart 'foo))))
"
(let ((case-gensyms (make-gensym-list (length cases) "CASE")))
(with-gensyms (re-entry-label value-form-entered restart-function restart-function-args block-name)
`(flet ,(loop for name in case-gensyms
for (_ lambda-list . body) in cases
collect `(,name ,lambda-list ,@body))
(let ((,value-form-entered nil)
(,restart-function nil)
(,restart-function-args nil))
(block ,block-name
(tagbody
,re-entry-label
(restart-case
(return-from ,block-name
(if (not ,value-form-entered)
(progn
(setf ,value-form-entered t)
,value-form)
(apply ,restart-function ,restart-function-args)))
,@(loop for (case-name _ . body) in cases
for function-name in case-gensyms
collect `(,case-name (&rest args)
(setf ,restart-function #',function-name)
(setf ,restart-function-args args)
(go ,re-entry-label)))))))))))
(defmacro restart-labels (bindings &body body)
`(recursive-restart-case
(progn ,@body)
,@bindings))
(defmacro restart-bind* (bindings &body body)
"Analogous to the relation between let and let*.
(restart-bind* ((retry (lambda (c) (invoke-restart 'continue)))
(continue (lambda (c) (print :retry))))
(error \"error!\"))
"
`(restart-bind (,(car bindings))
,(if (cdr bindings)
`(restart-bind* ,(cdr bindings)
,@body)
body)))
(defmacro restart-return (bindings &body body)
"The variation of restart-case whose behavior is the same but
the semantics are that of RESTART-BIND.
Just as RESTART-CASE, the condition is handled first (that is, it jumps
out of the RESTART-BIND scope with GO) and then
the restart function is called. Finally, RESTART-RETURN returns
the value of restart function."
(with-gensyms (block-name)
(let ((bindings2
(mapcar
(lambda (binding)
(destructuring-bind
(name function . key-value-pair)
binding
(with-gensyms (fn-name rest)
(list `(,fn-name
(&rest ,rest)
(return-from ,block-name
(apply ,function ,rest)))
`(,name (named-lambda ,(symbolicate name '-handler)
(&rest ,rest)
(apply #',fn-name ,rest))
,@key-value-pair)))))
bindings)))
`(block ,block-name
(flet ,(mapcar #'first bindings2)
(return-from ,block-name
(restart-bind
,(mapcar #'second bindings2)
,@body)))))))
(defmacro do-restart (bindings &body body)
"A construct that, after a restart is invoked, it jumps to the start and reevaluate
the body by default. Example:
(do-restart ((retry (lambda (c) (print :retry)))
(continue (lambda (c) (print :retry))))
(error \"error!\"))
"
(with-gensyms (start)
`(block nil
(tagbody
,start
(return
(restart-bind
,(mapcar
(lambda (binding)
(destructuring-bind
(name function . key-value-pair)
binding
(with-gensyms (rest)
`(,name (named-lambda ,(symbolicate name '-handler)
(&rest ,rest)
(prog1
(apply ,function ,rest)
(go ,start)))
,@key-value-pair))))
bindings)
,@body))))))
(defmacro handler-bind* (bindings &body body)
"Analogous to the relation between let and let*.
In standard handler-bind, the execution of the handler is
'run in a dynamic environment where none of these handler bindings are visible (to
avoid recursive errors).'
-- (http://www.lispworks.com/documentation/HyperSpec/Body/m_handle.htm)
(handler-bind* ((error (lambda (c) (print :error)))
(my-error (lambda (c) (print :my) (signal c))))
(error 'my-error))
"
`(handler-bind (,(car bindings))
,(if (cdr bindings)
`(handler-bind* ,(cdr bindings)
,@body)
body)))
(defmacro handler-return (bindings &body body)
"The variation of handler-case whose behavior is the same but
the semantics are that of HANDLER-BIND.
Just as HANDLER-CASE, the condition is handled first (that is, it jumps
out of the HANDLER-BIND scope with GO) and then
the handler function is called. Finally, HANDLER-RETURN returns
the value of the handler function. Example:
(restart-return ((retry (lambda (c) (print :retry)))
(continue (lambda (c) (print :retry))))
(error \"error!\"))
is equivalent to:
(restart-case
(error \"error!\")
(retry (c) (print :retry))
(continue (c) (print :retry)))
"
(with-gensyms (block-name)
(let ((bindings2
(mapcar
(lambda (binding)
(destructuring-bind
(name function . key-value-pair)
binding
(with-gensyms (fn-name rest)
(list `(,fn-name
(&rest ,rest)
(return-from ,block-name
(apply ,function ,rest)))
`(,name (named-lambda ,(symbolicate name '-handler)
(&rest ,rest)
(apply #',fn-name ,rest))
,@key-value-pair)))))
bindings)))
`(block ,block-name
(flet ,(mapcar #'first bindings2)
(return-from ,block-name
(handler-bind
,(mapcar #'second bindings2)
,@body)))))))