Commit | Line | Data |
---|---|---|
33df2ec7 AW |
1 | ;;; Error handling in the REPL |
2 | ||
4b1eb2b2 | 3 | ;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc. |
33df2ec7 AW |
4 | |
5 | ;; This library is free software; you can redistribute it and/or | |
6 | ;; modify it under the terms of the GNU Lesser General Public | |
7 | ;; License as published by the Free Software Foundation; either | |
8 | ;; version 3 of the License, or (at your option) any later version. | |
9 | ;; | |
10 | ;; This library is distributed in the hope that it will be useful, | |
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;; Lesser General Public License for more details. | |
14 | ;; | |
15 | ;; You should have received a copy of the GNU Lesser General Public | |
16 | ;; License along with this library; if not, write to the Free Software | |
17 | ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA | |
18 | ;; 02110-1301 USA | |
19 | ||
20 | ;;; Code: | |
21 | ||
22 | (define-module (system repl error-handling) | |
23 | #:use-module (system base pmatch) | |
b9badc35 | 24 | #:use-module (system vm trap-state) |
33df2ec7 AW |
25 | #:use-module (system repl debug) |
26 | #:export (call-with-error-handling | |
27 | with-error-handling)) | |
28 | ||
29 | ||
30 | \f | |
31 | ||
32 | ;;; | |
33 | ;;; Error handling via repl debugging | |
34 | ;;; | |
35 | ||
54d9a994 | 36 | (define (error-string stack key args) |
f87db657 AW |
37 | (call-with-output-string |
38 | (lambda (port) | |
39 | (let ((frame (and (< 0 (vector-length stack)) (vector-ref stack 0)))) | |
40 | (print-exception port frame key args))))) | |
41 | ||
33df2ec7 AW |
42 | (define* (call-with-error-handling thunk #:key |
43 | (on-error 'debug) (post-error 'catch) | |
b0e556d4 | 44 | (pass-keys '(quit)) (trap-handler 'debug)) |
33df2ec7 AW |
45 | (let ((in (current-input-port)) |
46 | (out (current-output-port)) | |
47 | (err (current-error-port))) | |
48 | (define (with-saved-ports thunk) | |
49 | (with-input-from-port in | |
50 | (lambda () | |
51 | (with-output-to-port out | |
52 | (lambda () | |
53 | (with-error-to-port err | |
54 | thunk)))))) | |
54d9a994 | 55 | |
b9badc35 AW |
56 | (define (debug-trap-handler frame trap-idx trap-name) |
57 | (let* ((tag (and (pair? (fluid-ref %stacks)) | |
58 | (cdar (fluid-ref %stacks)))) | |
59 | (stack (narrow-stack->vector | |
60 | (make-stack frame) | |
61 | ;; Take the stack from the given frame, cutting 0 | |
62 | ;; frames. | |
63 | 0 | |
64 | ;; Narrow the end of the stack to the most recent | |
65 | ;; start-stack. | |
66 | tag | |
67 | ;; And one more frame, because %start-stack | |
68 | ;; invoking the start-stack thunk has its own frame | |
69 | ;; too. | |
70 | 0 (and tag 1))) | |
ee02e238 AW |
71 | (error-msg (if trap-idx |
72 | (format #f "Trap ~d: ~a" trap-idx trap-name) | |
73 | trap-name)) | |
a36c3a45 | 74 | (debug (make-debug stack 0 error-msg #t))) |
b9badc35 AW |
75 | (with-saved-ports |
76 | (lambda () | |
ee02e238 AW |
77 | (if trap-idx |
78 | (begin | |
79 | (format #t "~a~%" error-msg) | |
80 | (format #t "Entering a new prompt. ") | |
81 | (format #t "Type `,bt' for a backtrace or `,q' to continue.\n"))) | |
b9badc35 AW |
82 | ((@ (system repl repl) start-repl) #:debug debug))))) |
83 | ||
b0e556d4 AW |
84 | (define (null-trap-handler frame trap-idx trap-name) |
85 | #t) | |
86 | ||
87 | (define le-trap-handler | |
88 | (case trap-handler | |
89 | ((debug) debug-trap-handler) | |
90 | ((pass) null-trap-handler) | |
91 | ((disabled) #f) | |
92 | (else (error "Unknown trap-handler strategy" trap-handler)))) | |
93 | ||
33df2ec7 | 94 | (catch #t |
b9badc35 | 95 | (lambda () |
b0e556d4 | 96 | (with-default-trap-handler le-trap-handler |
b9badc35 | 97 | (lambda () (%start-stack #t thunk)))) |
33df2ec7 AW |
98 | |
99 | (case post-error | |
d286c8ce | 100 | ((report) |
33df2ec7 AW |
101 | (lambda (key . args) |
102 | (if (memq key pass-keys) | |
103 | (apply throw key args) | |
104 | (begin | |
f87db657 AW |
105 | (with-saved-ports |
106 | (lambda () | |
107 | (run-hook before-error-hook) | |
108 | (print-exception err #f key args) | |
109 | (run-hook after-error-hook) | |
110 | (force-output err))) | |
33df2ec7 | 111 | (if #f #f))))) |
d286c8ce AW |
112 | ((catch) |
113 | (lambda (key . args) | |
114 | (if (memq key pass-keys) | |
115 | (apply throw key args)))) | |
33df2ec7 AW |
116 | (else |
117 | (if (procedure? post-error) | |
67d65584 AW |
118 | (lambda (k . args) |
119 | (apply (if (memq k pass-keys) throw post-error) k args)) | |
33df2ec7 | 120 | (error "Unknown post-error strategy" post-error)))) |
54d9a994 | 121 | |
33df2ec7 AW |
122 | (case on-error |
123 | ((debug) | |
124 | (lambda (key . args) | |
80993527 MW |
125 | (if (not (memq key pass-keys)) |
126 | (let* ((tag (and (pair? (fluid-ref %stacks)) | |
127 | (cdar (fluid-ref %stacks)))) | |
128 | (stack (narrow-stack->vector | |
129 | (make-stack #t) | |
130 | ;; Cut three frames from the top of the stack: | |
131 | ;; make-stack, this one, and the throw handler. | |
132 | 3 | |
133 | ;; Narrow the end of the stack to the most recent | |
134 | ;; start-stack. | |
135 | tag | |
136 | ;; And one more frame, because %start-stack invoking | |
137 | ;; the start-stack thunk has its own frame too. | |
138 | 0 (and tag 1))) | |
139 | (error-msg (error-string stack key args)) | |
140 | (debug (make-debug stack 0 error-msg #f))) | |
141 | (with-saved-ports | |
142 | (lambda () | |
143 | (format #t "~a~%" error-msg) | |
144 | (format #t "Entering a new prompt. ") | |
145 | (format #t "Type `,bt' for a backtrace or `,q' to continue.\n") | |
146 | ((@ (system repl repl) start-repl) #:debug debug))))))) | |
bb455e4f AW |
147 | ((report) |
148 | (lambda (key . args) | |
149 | (if (not (memq key pass-keys)) | |
150 | (begin | |
151 | (with-saved-ports | |
152 | (lambda () | |
153 | (run-hook before-error-hook) | |
154 | (print-exception err #f key args) | |
155 | (run-hook after-error-hook) | |
156 | (force-output err))) | |
157 | (if #f #f))))) | |
158 | ((backtrace) | |
159 | (lambda (key . args) | |
160 | (if (not (memq key pass-keys)) | |
161 | (let* ((tag (and (pair? (fluid-ref %stacks)) | |
162 | (cdar (fluid-ref %stacks)))) | |
163 | (frames (narrow-stack->vector | |
164 | (make-stack #t) | |
165 | ;; Narrow as above, for the debugging case. | |
166 | 3 tag 0 (and tag 1)))) | |
167 | (with-saved-ports | |
168 | (lambda () | |
169 | (print-frames frames) | |
170 | (run-hook before-error-hook) | |
171 | (print-exception err #f key args) | |
172 | (run-hook after-error-hook) | |
173 | (force-output err))) | |
174 | (if #f #f))))) | |
33df2ec7 AW |
175 | ((pass) |
176 | (lambda (key . args) | |
177 | ;; fall through to rethrow | |
178 | #t)) | |
179 | (else | |
180 | (if (procedure? on-error) | |
67d65584 AW |
181 | (lambda (k . args) |
182 | (apply (if (memq k pass-keys) throw on-error) k args)) | |
33df2ec7 AW |
183 | (error "Unknown on-error strategy" on-error))))))) |
184 | ||
0c65f52c AW |
185 | (define-syntax-rule (with-error-handling form) |
186 | (call-with-error-handling (lambda () form))) |