Commit | Line | Data |
---|---|---|
33df2ec7 AW |
1 | ;;; Error handling in the REPL |
2 | ||
e15aa022 | 3 | ;; Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 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 | 25 | #:use-module (system repl debug) |
f5e772b2 | 26 | #:use-module (ice-9 format) |
33df2ec7 AW |
27 | #:export (call-with-error-handling |
28 | with-error-handling)) | |
29 | ||
30 | ||
31 | \f | |
32 | ||
33 | ;;; | |
34 | ;;; Error handling via repl debugging | |
35 | ;;; | |
36 | ||
54d9a994 | 37 | (define (error-string stack key args) |
f87db657 AW |
38 | (call-with-output-string |
39 | (lambda (port) | |
40 | (let ((frame (and (< 0 (vector-length stack)) (vector-ref stack 0)))) | |
41 | (print-exception port frame key args))))) | |
42 | ||
33df2ec7 AW |
43 | (define* (call-with-error-handling thunk #:key |
44 | (on-error 'debug) (post-error 'catch) | |
b0e556d4 | 45 | (pass-keys '(quit)) (trap-handler 'debug)) |
33df2ec7 AW |
46 | (let ((in (current-input-port)) |
47 | (out (current-output-port)) | |
48 | (err (current-error-port))) | |
49 | (define (with-saved-ports thunk) | |
50 | (with-input-from-port in | |
51 | (lambda () | |
52 | (with-output-to-port out | |
53 | (lambda () | |
54 | (with-error-to-port err | |
55 | thunk)))))) | |
54d9a994 | 56 | |
b9badc35 AW |
57 | (define (debug-trap-handler frame trap-idx trap-name) |
58 | (let* ((tag (and (pair? (fluid-ref %stacks)) | |
59 | (cdar (fluid-ref %stacks)))) | |
60 | (stack (narrow-stack->vector | |
61 | (make-stack frame) | |
62 | ;; Take the stack from the given frame, cutting 0 | |
63 | ;; frames. | |
64 | 0 | |
65 | ;; Narrow the end of the stack to the most recent | |
66 | ;; start-stack. | |
67 | tag | |
68 | ;; And one more frame, because %start-stack | |
69 | ;; invoking the start-stack thunk has its own frame | |
70 | ;; too. | |
71 | 0 (and tag 1))) | |
ee02e238 AW |
72 | (error-msg (if trap-idx |
73 | (format #f "Trap ~d: ~a" trap-idx trap-name) | |
74 | trap-name)) | |
e15aa022 | 75 | (debug (make-debug stack 0 error-msg))) |
b9badc35 AW |
76 | (with-saved-ports |
77 | (lambda () | |
ee02e238 AW |
78 | (if trap-idx |
79 | (begin | |
80 | (format #t "~a~%" error-msg) | |
81 | (format #t "Entering a new prompt. ") | |
82 | (format #t "Type `,bt' for a backtrace or `,q' to continue.\n"))) | |
b9badc35 AW |
83 | ((@ (system repl repl) start-repl) #:debug debug))))) |
84 | ||
b0e556d4 AW |
85 | (define (null-trap-handler frame trap-idx trap-name) |
86 | #t) | |
87 | ||
88 | (define le-trap-handler | |
89 | (case trap-handler | |
90 | ((debug) debug-trap-handler) | |
91 | ((pass) null-trap-handler) | |
92 | ((disabled) #f) | |
93 | (else (error "Unknown trap-handler strategy" trap-handler)))) | |
94 | ||
33df2ec7 | 95 | (catch #t |
b9badc35 | 96 | (lambda () |
b0e556d4 | 97 | (with-default-trap-handler le-trap-handler |
b9badc35 | 98 | (lambda () (%start-stack #t thunk)))) |
33df2ec7 AW |
99 | |
100 | (case post-error | |
d286c8ce | 101 | ((report) |
33df2ec7 AW |
102 | (lambda (key . args) |
103 | (if (memq key pass-keys) | |
104 | (apply throw key args) | |
105 | (begin | |
f87db657 AW |
106 | (with-saved-ports |
107 | (lambda () | |
108 | (run-hook before-error-hook) | |
109 | (print-exception err #f key args) | |
110 | (run-hook after-error-hook) | |
111 | (force-output err))) | |
33df2ec7 | 112 | (if #f #f))))) |
d286c8ce AW |
113 | ((catch) |
114 | (lambda (key . args) | |
115 | (if (memq key pass-keys) | |
116 | (apply throw key args)))) | |
33df2ec7 AW |
117 | (else |
118 | (if (procedure? post-error) | |
67d65584 AW |
119 | (lambda (k . args) |
120 | (apply (if (memq k pass-keys) throw post-error) k args)) | |
33df2ec7 | 121 | (error "Unknown post-error strategy" post-error)))) |
54d9a994 | 122 | |
33df2ec7 AW |
123 | (case on-error |
124 | ((debug) | |
125 | (lambda (key . args) | |
80993527 MW |
126 | (if (not (memq key pass-keys)) |
127 | (let* ((tag (and (pair? (fluid-ref %stacks)) | |
128 | (cdar (fluid-ref %stacks)))) | |
129 | (stack (narrow-stack->vector | |
130 | (make-stack #t) | |
131 | ;; Cut three frames from the top of the stack: | |
132 | ;; make-stack, this one, and the throw handler. | |
133 | 3 | |
134 | ;; Narrow the end of the stack to the most recent | |
135 | ;; start-stack. | |
136 | tag | |
137 | ;; And one more frame, because %start-stack invoking | |
138 | ;; the start-stack thunk has its own frame too. | |
139 | 0 (and tag 1))) | |
140 | (error-msg (error-string stack key args)) | |
e15aa022 | 141 | (debug (make-debug stack 0 error-msg))) |
80993527 MW |
142 | (with-saved-ports |
143 | (lambda () | |
144 | (format #t "~a~%" error-msg) | |
145 | (format #t "Entering a new prompt. ") | |
146 | (format #t "Type `,bt' for a backtrace or `,q' to continue.\n") | |
147 | ((@ (system repl repl) start-repl) #:debug debug))))))) | |
bb455e4f AW |
148 | ((report) |
149 | (lambda (key . args) | |
150 | (if (not (memq key pass-keys)) | |
151 | (begin | |
152 | (with-saved-ports | |
153 | (lambda () | |
154 | (run-hook before-error-hook) | |
155 | (print-exception err #f key args) | |
156 | (run-hook after-error-hook) | |
157 | (force-output err))) | |
158 | (if #f #f))))) | |
159 | ((backtrace) | |
160 | (lambda (key . args) | |
161 | (if (not (memq key pass-keys)) | |
162 | (let* ((tag (and (pair? (fluid-ref %stacks)) | |
163 | (cdar (fluid-ref %stacks)))) | |
164 | (frames (narrow-stack->vector | |
165 | (make-stack #t) | |
166 | ;; Narrow as above, for the debugging case. | |
167 | 3 tag 0 (and tag 1)))) | |
168 | (with-saved-ports | |
169 | (lambda () | |
170 | (print-frames frames) | |
171 | (run-hook before-error-hook) | |
172 | (print-exception err #f key args) | |
173 | (run-hook after-error-hook) | |
174 | (force-output err))) | |
175 | (if #f #f))))) | |
33df2ec7 AW |
176 | ((pass) |
177 | (lambda (key . args) | |
178 | ;; fall through to rethrow | |
179 | #t)) | |
180 | (else | |
181 | (if (procedure? on-error) | |
67d65584 AW |
182 | (lambda (k . args) |
183 | (apply (if (memq k pass-keys) throw on-error) k args)) | |
33df2ec7 AW |
184 | (error "Unknown on-error strategy" on-error))))))) |
185 | ||
0c65f52c AW |
186 | (define-syntax-rule (with-error-handling form) |
187 | (call-with-error-handling (lambda () form))) |