/[meta-cvs]/meta-cvs/F-1C43C940D8740CAA78752C1206316B55
ViewVC logotype

Contents of /meta-cvs/F-1C43C940D8740CAA78752C1206316B55

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3.8.1 - (show annotations)
Sun Mar 2 06:56:07 2003 UTC (11 years, 1 month ago) by kaz
Branch: mcvs-1-0-branch
Changes since 1.3: +84 -0 lines
* code/restart.lisp (super-restart-case-expander): New function.
(super-restart-case): New macro.

* code/create.lisp (mcvs-create): Rewrite a restart-bind
construct more succinctly using super-restart-case.
1 ;;; This source file is part of the Meta-CVS program,
2 ;;; which is distributed under the GNU license.
3 ;;; Copyright 2002 Kaz Kylheku
4
5 (provide "restart")
6
7 (defmacro can-restart-here ((format-string &rest format-args) &body forms)
8 (let ((restart-block (gensym "RESTART-"))
9 (stream (gensym "STREAM-")))
10 `(block ,restart-block
11 (restart-bind
12 ((continue #'(lambda () (return-from ,restart-block))
13 :report-function #'(lambda (,stream)
14 (format ,stream ,format-string ,@format-args))))
15 ,@forms))))
16
17 (eval-when (:compile-toplevel :load-toplevel :execute)
18 (defun super-restart-case-expander (clause top-sym out-sym closure-var)
19 (destructuring-bind (name lambda-list &rest body) clause
20 (let ((interactive-spec ())
21 (test-spec ())
22 (report-spec()))
23 (do ((key (first body) (first body))
24 (val (second body) (second body)))
25 ((not (member key '(:report :test :report-format :interactive))))
26 (pop body)
27 (pop body)
28 (case key
29 ((:interactive)
30 (setf interactive-spec `(:interactive-function (function ,val))))
31 ((:report)
32 (setf report-spec
33 (if (stringp val)
34 `(:report-function #'(lambda (stream)
35 (write-string ,val stream)))
36 `(:report-function (function ,val)))))
37 ((:report-format)
38 (setf report-spec
39 `(:report-function #'(lambda (stream)
40 (format stream ,@val)))))
41 ((:test)
42 (setf test-spec `(:test-function (function ,val))))))
43 `(,name
44 (macrolet
45 ((unwind (&body forms)
46 `(progn
47 (setf ,',closure-var
48 #'(lambda () ,@forms))
49 (go ,',out-sym)))
50 (retry ()
51 `(go ,',top-sym)))
52 #'(lambda ,lambda-list ,@body))
53 ,@interactive-spec ,@report-spec ,@test-spec)))))
54
55 (defmacro super-restart-case (expr &rest clauses)
56 "This is a macro that is very similar to the standard RESTART-CASE, but
57 with a few refinements.
58
59 Firstly, the special syntax :REPORT-FORMAT VALUE is accepted. VALUE must
60 be an argument list for the FORMAT function, starting with the format
61 string. This is a shorthand for
62
63 :REPORT (LAMBDA (STREAM) (FORMAT STREAM ...)))
64
65 Secondly, unlike RESTART-CASE, SUPER-RESTART-CASE does not perform a
66 non-local exit before executing the body of a clause. A clause body is
67 executed in the dynamic context of the restart invocation. In other
68 words, SUPER-RESTART-CASE clause bodies behave like closures specified
69 to RESTART-BIND. When the last form in the clause body is executed,
70 control returns back to the context which invoked the restart.
71
72 Thirdly, two special local macros may be used in the bodies of the
73 clauses to achieve control over the behavior.
74
75 The macro (RETRY) will re-execute the entire SUPER-RESTART-CASE form
76 from the beginning. This provides an easy way to implement retry
77 behavior, without having to code an explicit loop.
78
79 The macro (UNWIND [ FORMS ...]) causes FORMS to be evaluated after
80 performing a non-local exit back to the dynamic context of the
81 SUPER-RESTART-CASE form. When the last of the forms is evaluated, the
82 entire form terminates. As can be expected, the result of the entire
83 will be the value of the last form in (UNWIND ...)."
84 (let ((top-sym (gensym "TOP-"))
85 (out-sym (gensym "OUT-"))
86 (closure-var (gensym "CLOSURE-")))
87 `(let ((,closure-var nil))
88 (block nil
89 (tagbody
90 (go ,top-sym)
91 ,out-sym
92 (return (funcall ,closure-var))
93 ,top-sym
94 (restart-bind
95 ,(mapcar #'(lambda (clause)
96 (super-restart-case-expander clause top-sym out-sym
97 closure-var))
98 clauses)
99 (progn ,expr)))))))

  ViewVC Help
Powered by ViewVC 1.1.5