/[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 - (hide annotations)
Fri Nov 24 04:53:49 2006 UTC (7 years, 4 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 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.9 (in-package :meta-cvs)
6 kaz 1.1
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.5
17     (eval-when (:compile-toplevel :load-toplevel :execute)
18 kaz 1.7 (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.5 (defun super-restart-case-expander (clause top-sym out-sym closure-var)
45     (destructuring-bind (name lambda-list &rest body) clause
46 kaz 1.7 (multiple-value-bind (interactive-spec test-spec
47     report-spec body)
48     (parse-restart-case-keywords body)
49 kaz 1.5 `(,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.6 Firstly, the special syntax :REPORT (STRING ...) is accepted.
66     This is a shorthand for
67 kaz 1.5
68 kaz 1.6 :REPORT (LAMBDA (STREAM) (FORMAT STREAM STRING ...)))
69 kaz 1.5
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.6 (return (progn ,expr)))
102     ,out-sym
103     (return (funcall ,closure-var)))))))

  ViewVC Help
Powered by ViewVC 1.1.5