/[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 - (hide 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 kaz 1.3 ;;; This source file is part of the Meta-CVS program,
2 kaz 1.2 ;;; which is distributed under the GNU license.
3     ;;; Copyright 2002 Kaz Kylheku
4    
5 kaz 1.1 (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 kaz 1.3.8.1
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