Commit | Line | Data |
---|---|---|
ce543a9f JG |
1 | ;;; conditions.scm --- The R6RS conditions library |
2 | ||
3 | ;; Copyright (C) 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 02110-1301 USA | |
18 | \f | |
19 | ||
20 | (library (rnrs conditions (6)) | |
21 | (export &condition | |
22 | condition | |
23 | simple-conditions | |
24 | condition? | |
25 | condition-predicate | |
26 | condition-accessor | |
27 | define-condition-type | |
28 | ||
29 | &message | |
30 | make-message-condition | |
31 | message-condition? | |
32 | condition-message | |
33 | ||
34 | &warning | |
35 | make-warning | |
36 | warning? | |
37 | ||
38 | &serious | |
39 | make-serious-condition | |
40 | serious-condition? | |
41 | ||
42 | &error | |
43 | make-error | |
44 | error? | |
45 | ||
46 | &violation | |
47 | make-violation | |
48 | violation? | |
49 | ||
50 | &assertion | |
51 | make-assertion-violation | |
52 | assertion-violation? | |
53 | ||
54 | &irritants | |
55 | make-irritants-condition | |
56 | irritants-condition? | |
57 | condition-irritants | |
58 | ||
59 | &who | |
60 | make-who-condition | |
61 | who-condition? | |
62 | condition-who | |
63 | ||
64 | &non-continuable | |
65 | make-non-continuable-violation | |
66 | non-continuable-violation? | |
67 | ||
68 | &implementation-restriction | |
2359a9a4 | 69 | make-implementation-restriction-violation |
ce543a9f JG |
70 | implementation-restriction-violation? |
71 | ||
72 | &lexical | |
73 | make-lexical-violation | |
74 | lexical-violation? | |
75 | ||
76 | &syntax | |
77 | make-syntax-violation | |
78 | syntax-violation? | |
79 | syntax-violation-form | |
80 | syntax-violation-subform | |
81 | ||
82 | &undefined | |
83 | make-undefined-violation | |
84 | undefined-violation?) | |
2470bda7 | 85 | (import (only (guile) and=> @@) |
2359a9a4 JG |
86 | (rnrs base (6)) |
87 | (rnrs lists (6)) | |
88 | (rnrs records procedural (6))) | |
89 | ||
ce543a9f JG |
90 | (define &compound-condition (make-record-type-descriptor |
91 | '&compound-condition #f #f #f #f | |
92 | '#((immutable components)))) | |
93 | (define compound-condition? (record-predicate &compound-condition)) | |
94 | ||
95 | (define make-compound-condition | |
96 | (record-constructor (make-record-constructor-descriptor | |
97 | &compound-condition #f #f))) | |
23988e8c AR |
98 | (define simple-conditions |
99 | (let ((compound-ref (record-accessor &compound-condition 0))) | |
100 | (lambda (condition) | |
101 | (cond ((compound-condition? condition) | |
102 | (compound-ref condition)) | |
103 | ((condition-internal? condition) | |
104 | (list condition)) | |
105 | (else | |
106 | (assertion-violation 'simple-conditions | |
107 | "not a condition" | |
108 | condition)))))) | |
ce543a9f | 109 | |
2359a9a4 JG |
110 | (define (condition? obj) |
111 | (or (compound-condition? obj) (condition-internal? obj))) | |
ce543a9f JG |
112 | |
113 | (define condition | |
114 | (lambda conditions | |
115 | (define (flatten cond) | |
2359a9a4 | 116 | (if (compound-condition? cond) (simple-conditions cond) (list cond))) |
ce543a9f JG |
117 | (or (for-all condition? conditions) |
118 | (raise (make-assertion-violation))) | |
2359a9a4 JG |
119 | (if (or (null? conditions) (> (length conditions) 1)) |
120 | (make-compound-condition (apply append (map flatten conditions))) | |
121 | (car conditions)))) | |
122 | ||
123 | (define-syntax define-condition-type | |
124 | (syntax-rules () | |
125 | ((_ condition-type supertype constructor predicate | |
126 | (field accessor) ...) | |
127 | (letrec-syntax | |
128 | ((transform-fields | |
129 | (syntax-rules () | |
130 | ((_ (f a) . rest) | |
131 | (cons '(immutable f a) (transform-fields rest))) | |
132 | ((_ ((f a))) '((immutable f a))) | |
133 | ((_ ()) '()) | |
134 | ((_) '()))) | |
135 | ||
136 | (generate-accessors | |
137 | (syntax-rules () | |
138 | ((_ counter (f a) . rest) | |
00f79aa4 JG |
139 | (begin (define a |
140 | (condition-accessor | |
141 | condition-type | |
142 | (record-accessor condition-type counter))) | |
2359a9a4 JG |
143 | (generate-accessors (+ counter 1) rest))) |
144 | ((_ counter ((f a))) | |
00f79aa4 JG |
145 | (define a |
146 | (condition-accessor | |
147 | condition-type (record-accessor condition-type counter)))) | |
2359a9a4 JG |
148 | ((_ counter ()) (begin)) |
149 | ((_ counter) (begin))))) | |
150 | (begin | |
151 | (define condition-type | |
152 | (make-record-type-descriptor | |
153 | 'condition-type supertype #f #f #f | |
154 | (list->vector (transform-fields (field accessor) ...)))) | |
155 | (define constructor | |
156 | (record-constructor | |
157 | (make-record-constructor-descriptor condition-type #f #f))) | |
158 | (define predicate (condition-predicate condition-type)) | |
159 | (generate-accessors 0 (field accessor) ...)))))) | |
160 | ||
161 | (define &condition (@@ (rnrs records procedural) &condition)) | |
162 | (define &condition-constructor-descriptor | |
163 | (make-record-constructor-descriptor &condition #f #f)) | |
164 | (define condition-internal? (record-predicate &condition)) | |
ce543a9f | 165 | |
ce543a9f JG |
166 | (define (condition-predicate rtd) |
167 | (let ((rtd-predicate (record-predicate rtd))) | |
168 | (lambda (obj) | |
169 | (cond ((compound-condition? obj) | |
2359a9a4 | 170 | (exists rtd-predicate (simple-conditions obj))) |
ce543a9f JG |
171 | ((condition-internal? obj) (rtd-predicate obj)) |
172 | (else #f))))) | |
173 | ||
174 | (define (condition-accessor rtd proc) | |
175 | (let ((rtd-predicate (record-predicate rtd))) | |
176 | (lambda (obj) | |
177 | (cond ((rtd-predicate obj) (proc obj)) | |
178 | ((compound-condition? obj) | |
2359a9a4 | 179 | (and=> (find rtd-predicate (simple-conditions obj)) proc)) |
ce543a9f JG |
180 | (else #f))))) |
181 | ||
182 | (define-condition-type &message &condition | |
183 | make-message-condition message-condition? | |
184 | (message condition-message)) | |
185 | ||
186 | (define-condition-type &warning &condition make-warning warning?) | |
187 | ||
188 | (define &serious (@@ (rnrs records procedural) &serious)) | |
189 | (define make-serious-condition | |
190 | (@@ (rnrs records procedural) make-serious-condition)) | |
2359a9a4 | 191 | (define serious-condition? (condition-predicate &serious)) |
ce543a9f JG |
192 | |
193 | (define-condition-type &error &serious make-error error?) | |
194 | ||
195 | (define &violation (@@ (rnrs records procedural) &violation)) | |
196 | (define make-violation (@@ (rnrs records procedural) make-violation)) | |
2359a9a4 | 197 | (define violation? (condition-predicate &violation)) |
ce543a9f JG |
198 | |
199 | (define &assertion (@@ (rnrs records procedural) &assertion)) | |
200 | (define make-assertion-violation | |
201 | (@@ (rnrs records procedural) make-assertion-violation)) | |
2359a9a4 | 202 | (define assertion-violation? (condition-predicate &assertion)) |
ce543a9f JG |
203 | |
204 | (define-condition-type &irritants &condition | |
205 | make-irritants-condition irritants-condition? | |
206 | (irritants condition-irritants)) | |
207 | ||
208 | (define-condition-type &who &condition | |
209 | make-who-condition who-condition? | |
210 | (who condition-who)) | |
211 | ||
212 | (define-condition-type &non-continuable &violation | |
213 | make-non-continuable-violation | |
214 | non-continuable-violation?) | |
215 | ||
216 | (define-condition-type &implementation-restriction | |
217 | &violation | |
218 | make-implementation-restriction-violation | |
219 | implementation-restriction-violation?) | |
220 | ||
221 | (define-condition-type &lexical &violation | |
222 | make-lexical-violation lexical-violation?) | |
223 | ||
224 | (define-condition-type &syntax &violation | |
ace75ab7 | 225 | make-syntax-violation syntax-violation? |
ce543a9f JG |
226 | (form syntax-violation-form) |
227 | (subform syntax-violation-subform)) | |
228 | ||
229 | (define-condition-type &undefined &violation | |
0113507e JG |
230 | make-undefined-violation undefined-violation?) |
231 | ||
232 | ;; Condition types that are used by (rnrs files), (rnrs io ports), and | |
233 | ;; (rnrs io simple). These are defined here so as to be easily shareable by | |
234 | ;; these three libraries. | |
235 | ||
236 | (define-condition-type &i/o &error make-i/o-error i/o-error?) | |
237 | (define-condition-type &i/o-read &i/o make-i/o-read-error i/o-read-error?) | |
238 | (define-condition-type &i/o-write &i/o make-i/o-write-error i/o-write-error?) | |
239 | (define-condition-type &i/o-invalid-position | |
240 | &i/o make-i/o-invalid-position-error i/o-invalid-position-error? | |
241 | (position i/o-error-position)) | |
242 | (define-condition-type &i/o-filename | |
243 | &i/o make-i/o-filename-error i/o-filename-error? | |
244 | (filename i/o-error-filename)) | |
245 | (define-condition-type &i/o-file-protection | |
246 | &i/o-filename make-i/o-file-protection-error i/o-file-protection-error?) | |
247 | (define-condition-type &i/o-file-is-read-only | |
248 | &i/o-file-protection make-i/o-file-is-read-only-error | |
249 | i/o-file-is-read-only-error?) | |
250 | (define-condition-type &i/o-file-already-exists | |
251 | &i/o-filename make-i/o-file-already-exists-error | |
252 | i/o-file-already-exists-error?) | |
253 | (define-condition-type &i/o-file-does-not-exist | |
254 | &i/o-filename make-i/o-file-does-not-exist-error | |
255 | i/o-file-does-not-exist-error?) | |
256 | (define-condition-type &i/o-port &i/o make-i/o-port-error i/o-port-error? | |
257 | (port i/o-error-port)) | |
258 | ) |