1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
|
;;; Error handling in the REPL
;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;; 02110-1301 USA
;;; Code:
(define-module (system repl error-handling)
#:use-module (system base pmatch)
#:use-module (system repl debug)
#:export (call-with-error-handling
with-error-handling))
;;;
;;; Error handling via repl debugging
;;;
(define* (call-with-error-handling thunk #:key
(on-error 'debug) (post-error 'catch)
(pass-keys '(quit)))
(let ((in (current-input-port))
(out (current-output-port))
(err (current-error-port)))
(define (with-saved-ports thunk)
(with-input-from-port in
(lambda ()
(with-output-to-port out
(lambda ()
(with-error-to-port err
thunk))))))
(catch #t
(lambda () (%start-stack #t thunk))
(case post-error
((catch)
(lambda (key . args)
(if (memq key pass-keys)
(apply throw key args)
(begin
(pmatch args
((,subr ,msg ,args . ,rest)
(with-saved-ports
(lambda ()
(run-hook before-error-hook)
(display-error #f err subr msg args rest)
(run-hook after-error-hook)
(force-output err))))
(else
(format err "\nERROR: uncaught throw to `~a', args: ~a\n"
key args)))
(if #f #f)))))
(else
(if (procedure? post-error)
post-error ; a handler proc
(error "Unknown post-error strategy" post-error))))
(case on-error
((debug)
(lambda (key . args)
(let ((stack (make-stack #t)))
(with-saved-ports
(lambda ()
(pmatch args
((,subr ,msg ,args . ,rest)
(format #t "Throw to key `~a':\n" key)
(display-error stack (current-output-port) subr msg args rest))
(else
(format #t "Throw to key `~a' with args `~s'." key args)))
(format #t "Entering a new prompt. Type `,bt' for a backtrace")
(format #t " or `,q' to return to the old prompt.\n")
(let ((debug
(make-debug
(narrow-stack->vector
stack
;; Cut three frames from the top of the stack:
;; make-stack, this one, and the throw handler.
3
;; Narrow the end of the stack to the most recent
;; start-stack.
(and (pair? (fluid-ref %stacks))
(cdar (fluid-ref %stacks))))
0)))
((@ (system repl repl) start-repl) #:debug debug)))))))
((pass)
(lambda (key . args)
;; fall through to rethrow
#t))
(else
(if (procedure? on-error)
on-error ; pre-unwind handler
(error "Unknown on-error strategy" on-error)))))))
(define-syntax with-error-handling
(syntax-rules ()
((_ form)
(call-with-error-handling (lambda () form)))))
|