/[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.3 - (hide annotations)
Wed Mar 5 04:57:42 2003 UTC (11 years, 1 month ago) by kaz
Branch: mcvs-1-0-branch
CVS Tags: mcvs-1-0-branch~merged-to-HEAD-1, mcvs-1-0-branch~merged-to-HEAD-0, mcvs-1-0-11, mcvs-1-0-10, mcvs-1-0-13, mcvs-1-0-12, mcvs-1-0-9, mcvs-1-0-8, mcvs-1-0-7, mcvs-1-0-6
Changes since 1.3.8.2: +29 -23 lines
* code/restart.lisp (parse-restart-case-keywords): New function.
(super-restart-case-expander): Some logic factored out
into new function.
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 kaz 1.3.8.3 (defun parse-restart-case-keywords (body)
19     (let ((interactive-spec ())
20     (test-spec ())
21     (report-spec()))
22     (do ((key (first body) (first body))
23     (val (second body) (second body)))
24     ((not (member key '(:report :test :interactive))))
25     (pop body)
26     (pop body)
27     (case key
28     ((:interactive)
29     (setf interactive-spec `(:interactive-function (function ,val))))
30     ((:report)
31     (setf report-spec
32     (cond
33     ((stringp val)
34     `(:report-function #'(lambda (stream)
35     (write-string ,val stream))))
36     ((and (consp val) (stringp (first val)))
37     `(:report-function #'(lambda (stream)
38     (format stream ,@val))))
39     (t `(:report-function (function ,val))))))
40     ((:test)
41     (setf test-spec `(:test-function (function ,val))))))
42     (values interactive-spec test-spec report-spec body)))
43    
44 kaz 1.3.8.1 (defun super-restart-case-expander (clause top-sym out-sym closure-var)
45     (destructuring-bind (name lambda-list &rest body) clause
46 kaz 1.3.8.3 (multiple-value-bind (interactive-spec test-spec
47     report-spec body)
48     (parse-restart-case-keywords body)
49 kaz 1.3.8.1 `(,name
50     (macrolet
51     ((unwind (&body forms)
52     `(progn
53     (setf ,',closure-var
54     #'(lambda () ,@forms))
55     (go ,',out-sym)))
56     (retry ()
57     `(go ,',top-sym)))
58     #'(lambda ,lambda-list ,@body))
59     ,@interactive-spec ,@report-spec ,@test-spec)))))
60    
61     (defmacro super-restart-case (expr &rest clauses)
62     "This is a macro that is very similar to the standard RESTART-CASE, but
63     with a few refinements.
64    
65 kaz 1.3.8.2 Firstly, the special syntax :REPORT (STRING ...) is accepted.
66     This is a shorthand for
67 kaz 1.3.8.1
68 kaz 1.3.8.2 :REPORT (LAMBDA (STREAM) (FORMAT STREAM STRING ...)))
69 kaz 1.3.8.1
70     Secondly, unlike RESTART-CASE, SUPER-RESTART-CASE does not perform a
71     non-local exit before executing the body of a clause. A clause body is
72     executed in the dynamic context of the restart invocation. In other
73     words, SUPER-RESTART-CASE clause bodies behave like closures specified
74     to RESTART-BIND. When the last form in the clause body is executed,
75     control returns back to the context which invoked the restart.
76    
77     Thirdly, two special local macros may be used in the bodies of the
78     clauses to achieve control over the behavior.
79    
80     The macro (RETRY) will re-execute the entire SUPER-RESTART-CASE form
81     from the beginning. This provides an easy way to implement retry
82     behavior, without having to code an explicit loop.
83    
84     The macro (UNWIND [ FORMS ...]) causes FORMS to be evaluated after
85     performing a non-local exit back to the dynamic context of the
86     SUPER-RESTART-CASE form. When the last of the forms is evaluated, the
87     entire form terminates. As can be expected, the result of the entire
88     will be the value of the last form in (UNWIND ...)."
89     (let ((top-sym (gensym "TOP-"))
90     (out-sym (gensym "OUT-"))
91     (closure-var (gensym "CLOSURE-")))
92     `(let ((,closure-var nil))
93     (block nil
94     (tagbody
95     ,top-sym
96     (restart-bind
97     ,(mapcar #'(lambda (clause)
98     (super-restart-case-expander clause top-sym out-sym
99     closure-var))
100     clauses)
101 kaz 1.3.8.2 (return (progn ,expr)))
102     ,out-sym
103     (return (funcall ,closure-var)))))))

  ViewVC Help
Powered by ViewVC 1.1.5