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

Contents of /meta-cvs/F-1C43C940D8740CAA78752C1206316B55

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (show annotations)
Fri Nov 24 04:53:49 2006 UTC (7 years, 5 months ago) by kaz
Branch: MAIN
CVS Tags: asdf-import-branch~merged-to-HEAD-0, mcvs-1-1-98, asdf-import-branch~branch-point, HEAD
Branch point for: asdf-import-branch
Changes since 1.8: +1 -1 lines
Stylistic change.

* code/add.lisp: Change in-package calls not to use the all-caps
"META-CVS" string string, but rather the :meta-cvs keyword.
* code/branch.lisp: Likewise.
* code/chatter.lisp: Likewise.
* code/checkout.lisp: Likewise.
* code/clisp-unix.lisp: Likewise.
* code/cmucl-unix.lisp: Likewise.
* code/convert.lisp: Likewise.
* code/create.lisp: Likewise.
* code/dirwalk.lisp: Likewise.
* code/error.lisp: Likewise.
* code/execute.lisp: Likewise.
* code/filt.lisp: Likewise.
* code/find-bind.lisp: Likewise.
* code/generic.lisp: Likewise.
* code/grab.lisp: Likewise.
* code/link.lisp: Likewise.
* code/main.lisp: Likewise.
* code/mapping.lisp: Likewise.
* code/memoize.lisp: Likewise.
* code/move.lisp: Likewise.
* code/multi-hash.lisp: Likewise.
* code/options.lisp: Likewise.
* code/paths.lisp: Likewise.
* code/print.lisp: Likewise.
* code/prop.lisp: Likewise.
* code/purge.lisp: Likewise.
* code/rcs-utils.lisp: Likewise.
* code/remap.lisp: Likewise.
* code/remove.lisp: Likewise.
* code/restart.lisp: Likewise.
* code/restore.lisp: Likewise.
* code/seqfuncs.lisp: Likewise.
* code/slot-refs.lisp: Likewise.
* code/split.lisp: Likewise.
* code/sync.lisp: Likewise.
* code/types.lisp: Likewise.
* code/unix.lisp: Likewise.
* code/update.lisp: Likewise.
* code/watch.lisp: Likewise.
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 (in-package :meta-cvs)
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 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 (defun super-restart-case-expander (clause top-sym out-sym closure-var)
45 (destructuring-bind (name lambda-list &rest body) clause
46 (multiple-value-bind (interactive-spec test-spec
47 report-spec body)
48 (parse-restart-case-keywords body)
49 `(,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 Firstly, the special syntax :REPORT (STRING ...) is accepted.
66 This is a shorthand for
67
68 :REPORT (LAMBDA (STREAM) (FORMAT STREAM STRING ...)))
69
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 (return (progn ,expr)))
102 ,out-sym
103 (return (funcall ,closure-var)))))))

  ViewVC Help
Powered by ViewVC 1.1.5