Commit | Line | Data |
---|---|---|
33df2ec7 AW |
1 | ;;; Error handling in the REPL |
2 | ||
3 | ;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc. | |
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 JOR |
36 | (define (error-string stack key args) |
37 | (with-output-to-string | |
38 | (lambda () | |
39 | (pmatch args | |
40 | ((,subr ,msg ,args . ,rest) | |
41 | (display-error (vector-ref stack 0) (current-output-port) | |
42 | subr msg args rest)) | |
43 | (else | |
44 | (format #t "Throw to key `~a' with args `~s'." key args)))))) | |
45 | ||
33df2ec7 AW |
46 | (define* (call-with-error-handling thunk #:key |
47 | (on-error 'debug) (post-error 'catch) | |
48 | (pass-keys '(quit))) | |
49 | (let ((in (current-input-port)) | |
50 | (out (current-output-port)) | |
51 | (err (current-error-port))) | |
52 | (define (with-saved-ports thunk) | |
53 | (with-input-from-port in | |
54 | (lambda () | |
55 | (with-output-to-port out | |
56 | (lambda () | |
57 | (with-error-to-port err | |
58 | thunk)))))) | |
54d9a994 | 59 | |
b9badc35 AW |
60 | (define (debug-trap-handler frame trap-idx trap-name) |
61 | (let* ((tag (and (pair? (fluid-ref %stacks)) | |
62 | (cdar (fluid-ref %stacks)))) | |
63 | (stack (narrow-stack->vector | |
64 | (make-stack frame) | |
65 | ;; Take the stack from the given frame, cutting 0 | |
66 | ;; frames. | |
67 | 0 | |
68 | ;; Narrow the end of the stack to the most recent | |
69 | ;; start-stack. | |
70 | tag | |
71 | ;; And one more frame, because %start-stack | |
72 | ;; invoking the start-stack thunk has its own frame | |
73 | ;; too. | |
74 | 0 (and tag 1))) | |
75 | (error-msg (format #f "Trap ~d: ~a" trap-idx trap-name)) | |
76 | (debug (make-debug stack 0 error-msg))) | |
77 | (with-saved-ports | |
78 | (lambda () | |
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") | |
82 | ((@ (system repl repl) start-repl) #:debug debug))))) | |
83 | ||
33df2ec7 | 84 | (catch #t |
b9badc35 AW |
85 | (lambda () |
86 | (with-default-trap-handler debug-trap-handler | |
87 | (lambda () (%start-stack #t thunk)))) | |
33df2ec7 AW |
88 | |
89 | (case post-error | |
d286c8ce | 90 | ((report) |
33df2ec7 AW |
91 | (lambda (key . args) |
92 | (if (memq key pass-keys) | |
93 | (apply throw key args) | |
94 | (begin | |
95 | (pmatch args | |
96 | ((,subr ,msg ,args . ,rest) | |
97 | (with-saved-ports | |
98 | (lambda () | |
99 | (run-hook before-error-hook) | |
100 | (display-error #f err subr msg args rest) | |
101 | (run-hook after-error-hook) | |
102 | (force-output err)))) | |
103 | (else | |
104 | (format err "\nERROR: uncaught throw to `~a', args: ~a\n" | |
105 | key args))) | |
106 | (if #f #f))))) | |
d286c8ce AW |
107 | ((catch) |
108 | (lambda (key . args) | |
109 | (if (memq key pass-keys) | |
110 | (apply throw key args)))) | |
33df2ec7 AW |
111 | (else |
112 | (if (procedure? post-error) | |
113 | post-error ; a handler proc | |
114 | (error "Unknown post-error strategy" post-error)))) | |
54d9a994 | 115 | |
33df2ec7 AW |
116 | (case on-error |
117 | ((debug) | |
118 | (lambda (key . args) | |
867961f9 AW |
119 | (let* ((tag (and (pair? (fluid-ref %stacks)) |
120 | (cdar (fluid-ref %stacks)))) | |
121 | (stack (narrow-stack->vector | |
122 | (make-stack #t) | |
123 | ;; Cut three frames from the top of the stack: | |
124 | ;; make-stack, this one, and the throw handler. | |
54d9a994 | 125 | 3 |
867961f9 AW |
126 | ;; Narrow the end of the stack to the most recent |
127 | ;; start-stack. | |
128 | tag | |
129 | ;; And one more frame, because %start-stack invoking | |
130 | ;; the start-stack thunk has its own frame too. | |
131 | 0 (and tag 1))) | |
54d9a994 JOR |
132 | (error-msg (error-string stack key args)) |
133 | (debug (make-debug stack 0 error-msg))) | |
33df2ec7 AW |
134 | (with-saved-ports |
135 | (lambda () | |
54d9a994 | 136 | (format #t error-msg) |
867961f9 AW |
137 | (format #t "Entering a new prompt. ") |
138 | (format #t "Type `,bt' for a backtrace or `,q' to continue.\n") | |
139 | ((@ (system repl repl) start-repl) #:debug debug)))))) | |
33df2ec7 AW |
140 | ((pass) |
141 | (lambda (key . args) | |
142 | ;; fall through to rethrow | |
143 | #t)) | |
144 | (else | |
145 | (if (procedure? on-error) | |
146 | on-error ; pre-unwind handler | |
147 | (error "Unknown on-error strategy" on-error))))))) | |
148 | ||
149 | (define-syntax with-error-handling | |
150 | (syntax-rules () | |
151 | ((_ form) | |
152 | (call-with-error-handling (lambda () form))))) |