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
|
; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.
;; Converting from the simple conditions raised from the lower levels.
;; We offer the same interface as SIMPLE-SIGNALS, except we convert to
;; SRFI-35 conditions immediately. This is for backwards
;; compatibility only; the use of this stuff is deprecated.
(define (simple-condition->condition simple-condition)
(let ((type (sc:condition-type simple-condition))
(stuff (sc:condition-stuff simple-condition)))
(let ((shim
(condition (&simple-condition
(type type)
(stuff stuff))))
(converted
;; this is the stuff in simple-condition.scm
(cond
((sc:call-error? simple-condition)
(condition (&message (message (car stuff)))
(&call-error
(proc (cadr stuff))
(args (cddr stuff)))))
((sc:read-error? simple-condition)
(let* ((rev-stuff (reverse stuff)) ; brain damage
(port (car rev-stuff))
(irritants (reverse (cdr rev-stuff))))
(condition (&message (message (car stuff)))
(&irritants (values (cdr irritants)))
(&i/o-port-error (port port))
(&i/o-read-error))))
((sc:vm-exception? simple-condition)
(let ((opcode (sc:vm-exception-opcode simple-condition))
(reason (sc:vm-exception-reason simple-condition))
(arguments (sc:vm-exception-arguments simple-condition)))
(condition (&vm-exception
(opcode opcode)
(reason reason)
(arguments arguments))
(&message
;; kludge
(message (cadr (disclose-vm-condition opcode reason arguments)))))))
((sc:i/o-error? simple-condition)
(condition (&message (message (sc:i/o-error-message simple-condition)))
(&primitive-i/o-error
(status (sc:i/o-error-status simple-condition))
(operation (sc:i/o-error-operation simple-condition))
(arguments (sc:i/o-error-arguments simple-condition)))))
((sc:decoding-error? simple-condition)
(condition (&decoding-error
(encoding-name (sc:decoding-error-encoding-name simple-condition)))
(&irritants
(values (list (sc:decoding-error-bytes simple-condition)
(sc:decoding-error-start simple-condition))))
(&message
(message (sc:decoding-error-message simple-condition)))))
((sc:error? simple-condition)
(condition (&message (message (cadr simple-condition)))
(&error) ; probably not always true
(&irritants
(values (cddr simple-condition)))))
((sc:syntax-error? simple-condition)
(condition (&message (message (cadr simple-condition)))
(&syntax-error)
(&irritants
(values (cddr simple-condition)))))
((sc:warning? simple-condition)
(condition (&message (message (cadr simple-condition)))
(&warning)
(&irritants
(values (cddr simple-condition)))))
((sc:note? simple-condition)
(condition (&message (message (cadr simple-condition)))
(¬e)
(&irritants
(values (cddr simple-condition)))))
((sc:interrupt? simple-condition)
(condition (&interrupt (type (cadr simple-condition)))))
(else #f))))
(if converted
(make-compound-condition converted shim)
shim))))
(define (coerce-to-condition thing)
(if (condition? thing)
thing
(simple-condition->condition thing)))
(define (condition->simple-condition condition)
(if (simple-condition? condition)
(cons (simple-condition-type condition)
(simple-condition-stuff condition))
(let ((message (if (message-condition? condition)
(condition-message condition)
"unknown")))
(cond
((error? condition)
(list 'error message))
((warning? condition)
(list 'warning message))
((note? condition)
(list 'note message))
(else
(list 'unknown message))))))
(define (coerce-to-simple-condition condition)
(if (condition? condition)
(condition->simple-condition condition)
condition))
(sc:define-condition-decoder condition?
(lambda (condition)
(let ((simple-condition (condition->simple-condition condition)))
(values (car simple-condition)
(cdr simple-condition)))))
(define (signal-condition condition)
(really-signal-condition (coerce-to-condition condition)))
(define (make-condition type stuff)
(simple-condition->condition (cons type stuff)))
; Legacy code, copied verbatim from simple-signal.scm
(define (signal type . stuff)
(signal-condition (make-condition type stuff)))
; Error
(define (error message . irritants)
(apply signal 'error message irritants))
; Warn
(define (warn message . irritants)
(signal-condition (make-condition 'warning (cons message irritants))))
; Note
(define (note message . irritants)
(signal-condition (make-condition 'note (cons message irritants))))
; Syntax errors
(define (syntax-error message . rest) ; Must return a valid expression.
(signal-condition (make-condition 'syntax-error (cons message rest)))
''syntax-error)
; "Call error" - this means that the condition's "stuff" (cdr) is of
; the form (message procedure . args), and should be displayed appropriately.
; Proceeding from such an error should return the value that the call
; to the procedure on the args should have returned.
(define (call-error message proc . args)
(signal-condition (make-condition 'call-error
(cons message (cons proc args)))))
|
