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
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
|
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
;;;; Raising and handling conditions
; An exception is an unusual situation detected by the virtual machine.
; A condition is a run-time system structure describing unusual situations,
; including exceptions.
; Usual exception handler vector.
(define (define-exception-handler opcode proc)
(vector-set! exception-handlers opcode proc))
(define (signal-exception opcode reason . args)
(really-signal-condition (make-exception opcode
(if reason
(enumerand->name reason exception)
#f)
args)))
(define exception-handlers
(make-vector op-count signal-exception))
; TRAP is the same as SIGNAL-CONDITION.
(define-exception-handler (enum op trap)
(lambda (opcode reason arg)
(really-signal-condition arg)))
; The time opcode sometimes needs a little help.
(define-exception-handler (enum op time)
(lambda (opcode reason option arg0 . maybe-arg1)
(if (= reason (enum exception arithmetic-overflow))
(+ (* arg0 1000) ; seconds
(car maybe-arg1)) ; milliseconds
(apply signal-exception opcode reason option arg0 maybe-arg1))))
; This is for generic arithmetic, mostly
(define (extend-opcode! opcode make-handler)
(let* ((except (lambda args
(apply signal-exception
opcode
#f ; lost our reason
args)))
(handler (make-handler except)))
(define-exception-handler opcode
(lambda (opcode reason . args)
(apply handler args)))))
; Raising and handling conditions.
; (fluid $condition-handlers) is a list of handler procedures.
; Each handler takes two arguments: the condition to be handled, and
; a thunk that can be called if the handler decides to decline handling
; the condition. The continuation to a call to a handler is that
; of the call to signal-condition.
(define (really-signal-condition condition)
(let loop ((hs (fluid $condition-handlers)))
((car hs) condition (lambda () (loop (cdr hs))))))
(define (with-handler h thunk)
(let-fluid $condition-handlers
(cons h (fluid $condition-handlers))
thunk))
(define $condition-handlers
(make-fluid #f))
; CURRENT-ERROR-PORT and WRITE-STRING are passed in to avoid circular
; module dependencies.
(define (initialize-exceptions! current-error-port write-string thunk)
(call-with-current-continuation
(lambda (k)
(set-fluid! $condition-handlers
(list (last-resort-condition-handler k
current-error-port
write-string)))
(set-exception-handlers! exception-handlers)
(thunk))))
(define (last-resort-condition-handler halt current-error-port write-string)
(let ((interrupt/keyboard (enum interrupt keyboard))
(losing? #f))
(lambda (condition punt)
(cond ((error? condition)
(primitive-catch
(lambda (c)
(if (not losing?)
(begin (set! losing? #t)
(report-utter-lossage condition
c
current-error-port
write-string)))
(halt 123))))
((and (interrupt? condition)
(= (cadr condition) interrupt/keyboard))
(halt 2))
(else
(unspecific)))))) ;proceed
; This will print a list of template id's, which you can look up in
; initial.debug to get some idea of what was going on.
(define (report-utter-lossage condition c current-error-port write-string)
(let ((out (current-error-port)))
(if out
(begin
(cond ((exception? condition)
(write-string (number->string (exception-opcode condition))
out)
(write-string " / " out))
((or (error? condition)
(warning? condition))
(write-string (car (condition-stuff condition)) out)
(write-string " / " out)))
(for-each (lambda (id+pc)
(if (number? (car id+pc))
(write-string (number->string
(car id+pc))
out))
(write-string " <- " out))
(continuation-preview c))
(write-char #\newline out)))))
(define (continuation-preview c)
(if (continuation? c)
(cons (cons (template-info (continuation-template c))
(continuation-pc c))
(continuation-preview (continuation-parent c)))
'()))
; ERROR is a compiler primitive, but if it weren't, it could be
; defined as follows:
;(define (error message . irritants)
; (signal-condition (make-condition 'error (cons message irritants))))
; Run THUNK, returning either the value returned by THUNK or any error
; that occurs.
(define (ignore-errors thunk)
(call-with-current-continuation
(lambda (k)
(with-handler (lambda (c next)
(if (error? c)
(k c)
(next)))
thunk))))
; Downgrade errors to warnings while executing THUNK. Returns #T if an
; error occured.
(define (report-errors-as-warnings thunk message . irritants)
(let ((condition (ignore-errors
(lambda ()
(thunk)
#f))))
(if condition
(begin
(apply warn message (append irritants (list condition)))
#t)
#f)))
; Define disclosers that are most important for error messages.
(define-method &disclose ((obj :closure))
(list 'procedure (template-ref (closure-template obj) 1)))
(define-method &disclose ((obj :location))
(list 'location (location-id obj)))
; (put 'with-handler 'scheme-indent-hook 1)
|
