/[meta-cvs]/meta-cvs/F-9AB435A23565E6385CE7F4F347D7A205
ViewVC logotype

Contents of /meta-cvs/F-9AB435A23565E6385CE7F4F347D7A205

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Sun Feb 10 16:55:04 2002 UTC (12 years, 2 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-5
Changes since 1.5: +1 -1 lines
Wording change; don't say termination is graceful when it's not clear
what that means.
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 (require "chatter")
6 (provide "error")
7
8 (defmacro restart-destructure ((rest-var &rest var-sym-pairs) &body forms)
9 (let ((restarts-sym (gensym "RESTARTS-")))
10 `(let ((,restarts-sym (compute-restarts)))
11 (let (,@(mapcar #'(lambda (var-sym-pair)
12 `(,(first var-sym-pair)
13 (find ',(second var-sym-pair) ,restarts-sym
14 :key #'restart-name)))
15 var-sym-pairs)
16 (,rest-var (remove-if #'(lambda (name)
17 (find name
18 ',(mapcar #'second
19 var-sym-pairs)))
20 ,restarts-sym :key #'restart-name)))
21 ,@forms))))
22
23 (defvar *mcvs-error-treatment* :interactive
24 "This variable is used by the top level error handler set up in mcvs-execute to
25 decide on what to do with a restartable error condition. If no restarts are
26 available, then this variable is ignored; the handler will print the error
27 message and terminate the program. If the error is restartable, then this
28 variable is examined. A value of :interactive indicates that a menu of options
29 should be presented to a user, who can choose to bail the program, or invoke
30 one of the available restarts. A value of :continue means to emit a warning
31 message and then invoke the a continue restart if one is available. If restarts
32 are available, but not ones that can be automatically selected by the handler,
33 then it will terminate the program. A value of :terminate means to terminate
34 on error, restartable or not. A value of :decline means to return normally
35 handling the error.")
36
37 (defvar *mcvs-errors-occured-p* nil)
38
39 (defun mcvs-error-handler (condition)
40 (let ((*print-escape* nil))
41 (setf *mcvs-errors-occured-p* t)
42 (restart-destructure (others (continue continue)
43 (retry retry))
44 (ecase *mcvs-error-treatment*
45 ((:interactive)
46 (when (null (compute-restarts))
47 (print-object condition *error-output*)
48 (throw 'mcvs-terminate t))
49 (let* (command-list
50 (menu (with-output-to-string (stream)
51 (format stream "~%The following error has occured:~%~%")
52 (format stream " ~a~%~%" condition)
53 (format stream "You have these alternatives:~%~%")
54 (format stream " ?) Re-print this menu.~%" continue)
55 (when continue
56 (format stream " C) (Continue) ~a~%" continue)
57 (format stream " A) Auto-continue all continuable errors.~%")
58 (push (list "C" #'(lambda ()
59 (invoke-restart continue)))
60 command-list)
61 (push (list "A" #'(lambda ()
62 (setf *mcvs-error-treatment*
63 :continue)
64 (invoke-restart continue)))
65 command-list))
66 (when retry
67 (format stream " R) (Retry) ~a~%" retry)
68 (push (list "R" #'(lambda ()
69 (invoke-restart retry)))
70 command-list))
71 (format stream " T) Terminate.~%")
72 (push (list "T" #'(lambda ()
73 (throw 'mcvs-terminate t)))
74 command-list)
75 (when others
76 (format stream "~%These special alternatives are also available:~%~%")
77 (let ((counter 0))
78 (dolist (restart others)
79 (format stream " ~a) ~a~%" (incf counter) restart)
80 (push (list (format nil "~a" counter)
81 #'(lambda ()
82 (invoke-restart restart)))
83 command-list))))
84 (terpri stream))))
85 (write-string menu)
86 (loop
87 (write-string ">")
88 (let* ((line (read-line))
89 (command (find line command-list
90 :key #'first
91 :test #'string-equal)))
92 (cond
93 ((string= line "?")
94 (write-string menu))
95 (command
96 (funcall (second command)))
97 (t (format t "What?~%")))))))
98 ((:continue)
99 (when continue
100 (chatter-terse "Auto-continuing error:~%")
101 (chatter-terse " ~a~%" condition)
102 (invoke-restart continue))
103 (print-object condition *error-output*)
104 (throw 'mcvs-terminate t))
105 ((:terminate)
106 (print-object condition *error-output*)
107 (throw 'mcvs-terminate t))
108 ((:decline)
109 (return-from mcvs-error-handler nil))))))

  ViewVC Help
Powered by ViewVC 1.1.5