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

Contents of /meta-cvs/F-9AB435A23565E6385CE7F4F347D7A205

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations)
Sun Feb 10 04:41:02 2002 UTC (12 years, 2 months ago) by kaz
Branch: MAIN
Changes since 1.2: +1 -1 lines
Remove spurious argument from chatter-terse call.
1 kaz 1.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     (defun mcvs-error-handler (condition)
38     (let ((*print-escape* nil))
39 kaz 1.2 (restart-destructure (others (continue continue)
40     (retry retry))
41 kaz 1.1 (ecase *mcvs-error-treatment*
42     ((:interactive)
43     (when (null (compute-restarts))
44     (print-object condition *error-output*)
45     (throw 'mcvs-terminate t))
46     (let* (command-list
47     (menu (with-output-to-string (stream)
48     (format stream "~%The following error has occured:~%~%")
49     (format stream " ~a~%~%" condition)
50     (format stream "You have these alternatives:~%~%")
51     (format stream " ?) Re-print this menu.~%" continue)
52     (when continue
53 kaz 1.2 (format stream " C) (Continue) ~a~%" continue)
54 kaz 1.1 (format stream " A) Auto-continue all continuable errors.~%")
55     (push (list "C" #'(lambda ()
56     (invoke-restart continue)))
57     command-list)
58     (push (list "A" #'(lambda ()
59     (setf *mcvs-error-treatment*
60     :continue)
61     (invoke-restart continue)))
62 kaz 1.2 command-list))
63     (when retry
64     (format stream " R) (Retry) ~a~%" retry)
65     (push (list "R" #'(lambda ()
66     (invoke-restart retry)))
67 kaz 1.1 command-list))
68     (when others
69     (let ((counter 0))
70     (dolist (restart others)
71     (format stream " ~a) ~a~%" (incf counter) restart)
72     (push (list (format nil "~a" counter)
73     #'(lambda ()
74     (invoke-restart restart)))
75     command-list))))
76     (format stream " T) Terminate gracefully.~%~%")
77     (push (list "T" #'(lambda ()
78     (throw 'mcvs-terminate t)))
79     command-list))))
80     (write-string menu)
81     (loop
82     (write-string ">")
83     (let* ((line (read-line))
84     (command (find line command-list
85     :key #'first
86     :test #'string-equal)))
87     (cond
88     ((string= line "?")
89     (write-string menu))
90     (command
91     (funcall (second command)))
92     (t (format t "What?~%")))))))
93     ((:continue)
94     (when continue
95 kaz 1.3 (chatter-terse "Auto-continuing error:~%")
96 kaz 1.1 (chatter-terse " ~a~%" condition)
97     (invoke-restart continue))
98     (print-object condition *error-output*)
99     (throw 'mcvs-terminate t))
100     ((:terminate)
101     (print-object condition *error-output*)
102     (throw 'mcvs-terminate t))
103     ((:decline)
104     (return-from mcvs-error-handler nil))))))

  ViewVC Help
Powered by ViewVC 1.1.5