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))) | |
2359a9a4 | 98 | (define simple-conditions (record-accessor &compound-condition 0)) |
ce543a9f | 99 | |
2359a9a4 JG |
100 | (define (condition? obj) |
101 | (or (compound-condition? obj) (condition-internal? obj))) | |
ce543a9f JG |
102 | |
103 | (define condition | |
104 | (lambda conditions | |
105 | (define (flatten cond) | |
2359a9a4 | 106 | (if (compound-condition? cond) (simple-conditions cond) (list cond))) |
ce543a9f JG |
107 | (or (for-all condition? conditions) |
108 | (raise (make-assertion-violation))) | |
2359a9a4 JG |
109 | (if (or (null? conditions) (> (length conditions) 1)) |
110 | (make-compound-condition (apply append (map flatten conditions))) | |
111 | (car conditions)))) | |
112 | ||
113 | (define-syntax define-condition-type | |
114 | (syntax-rules () | |
115 | ((_ condition-type supertype constructor predicate | |
116 | (field accessor) ...) | |
117 | (letrec-syntax | |
118 | ((transform-fields | |
119 | (syntax-rules () | |
120 | ((_ (f a) . rest) | |
121 | (cons '(immutable f a) (transform-fields rest))) | |
122 | ((_ ((f a))) '((immutable f a))) | |
123 | ((_ ()) '()) | |
124 | ((_) '()))) | |
125 | ||
126 | (generate-accessors | |
127 | (syntax-rules () | |
128 | ((_ counter (f a) . rest) | |
129 | (begin (define a (record-accessor condition-type counter)) | |
130 | (generate-accessors (+ counter 1) rest))) | |
131 | ((_ counter ((f a))) | |
132 | (define a (record-accessor condition-type counter))) | |
133 | ((_ counter ()) (begin)) | |
134 | ((_ counter) (begin))))) | |
135 | (begin | |
136 | (define condition-type | |
137 | (make-record-type-descriptor | |
138 | 'condition-type supertype #f #f #f | |
139 | (list->vector (transform-fields (field accessor) ...)))) | |
140 | (define constructor | |
141 | (record-constructor | |
142 | (make-record-constructor-descriptor condition-type #f #f))) | |
143 | (define predicate (condition-predicate condition-type)) | |
144 | (generate-accessors 0 (field accessor) ...)))))) | |
145 | ||
146 | (define &condition (@@ (rnrs records procedural) &condition)) | |
147 | (define &condition-constructor-descriptor | |
148 | (make-record-constructor-descriptor &condition #f #f)) | |
149 | (define condition-internal? (record-predicate &condition)) | |
ce543a9f | 150 | |
ce543a9f JG |
151 | (define (condition-predicate rtd) |
152 | (let ((rtd-predicate (record-predicate rtd))) | |
153 | (lambda (obj) | |
154 | (cond ((compound-condition? obj) | |
2359a9a4 | 155 | (exists rtd-predicate (simple-conditions obj))) |
ce543a9f JG |
156 | ((condition-internal? obj) (rtd-predicate obj)) |
157 | (else #f))))) | |
158 | ||
159 | (define (condition-accessor rtd proc) | |
160 | (let ((rtd-predicate (record-predicate rtd))) | |
161 | (lambda (obj) | |
162 | (cond ((rtd-predicate obj) (proc obj)) | |
163 | ((compound-condition? obj) | |
2359a9a4 | 164 | (and=> (find rtd-predicate (simple-conditions obj)) proc)) |
ce543a9f JG |
165 | (else #f))))) |
166 | ||
167 | (define-condition-type &message &condition | |
168 | make-message-condition message-condition? | |
169 | (message condition-message)) | |
170 | ||
171 | (define-condition-type &warning &condition make-warning warning?) | |
172 | ||
173 | (define &serious (@@ (rnrs records procedural) &serious)) | |
174 | (define make-serious-condition | |
175 | (@@ (rnrs records procedural) make-serious-condition)) | |
2359a9a4 | 176 | (define serious-condition? (condition-predicate &serious)) |
ce543a9f JG |
177 | |
178 | (define-condition-type &error &serious make-error error?) | |
179 | ||
180 | (define &violation (@@ (rnrs records procedural) &violation)) | |
181 | (define make-violation (@@ (rnrs records procedural) make-violation)) | |
2359a9a4 | 182 | (define violation? (condition-predicate &violation)) |
ce543a9f JG |
183 | |
184 | (define &assertion (@@ (rnrs records procedural) &assertion)) | |
185 | (define make-assertion-violation | |
186 | (@@ (rnrs records procedural) make-assertion-violation)) | |
2359a9a4 | 187 | (define assertion-violation? (condition-predicate &assertion)) |
ce543a9f JG |
188 | |
189 | (define-condition-type &irritants &condition | |
190 | make-irritants-condition irritants-condition? | |
191 | (irritants condition-irritants)) | |
192 | ||
193 | (define-condition-type &who &condition | |
194 | make-who-condition who-condition? | |
195 | (who condition-who)) | |
196 | ||
197 | (define-condition-type &non-continuable &violation | |
198 | make-non-continuable-violation | |
199 | non-continuable-violation?) | |
200 | ||
201 | (define-condition-type &implementation-restriction | |
202 | &violation | |
203 | make-implementation-restriction-violation | |
204 | implementation-restriction-violation?) | |
205 | ||
206 | (define-condition-type &lexical &violation | |
207 | make-lexical-violation lexical-violation?) | |
208 | ||
209 | (define-condition-type &syntax &violation | |
ace75ab7 | 210 | make-syntax-violation syntax-violation? |
ce543a9f JG |
211 | (form syntax-violation-form) |
212 | (subform syntax-violation-subform)) | |
213 | ||
214 | (define-condition-type &undefined &violation | |
0113507e JG |
215 | make-undefined-violation undefined-violation?) |
216 | ||
217 | ;; Condition types that are used by (rnrs files), (rnrs io ports), and | |
218 | ;; (rnrs io simple). These are defined here so as to be easily shareable by | |
219 | ;; these three libraries. | |
220 | ||
221 | (define-condition-type &i/o &error make-i/o-error i/o-error?) | |
222 | (define-condition-type &i/o-read &i/o make-i/o-read-error i/o-read-error?) | |
223 | (define-condition-type &i/o-write &i/o make-i/o-write-error i/o-write-error?) | |
224 | (define-condition-type &i/o-invalid-position | |
225 | &i/o make-i/o-invalid-position-error i/o-invalid-position-error? | |
226 | (position i/o-error-position)) | |
227 | (define-condition-type &i/o-filename | |
228 | &i/o make-i/o-filename-error i/o-filename-error? | |
229 | (filename i/o-error-filename)) | |
230 | (define-condition-type &i/o-file-protection | |
231 | &i/o-filename make-i/o-file-protection-error i/o-file-protection-error?) | |
232 | (define-condition-type &i/o-file-is-read-only | |
233 | &i/o-file-protection make-i/o-file-is-read-only-error | |
234 | i/o-file-is-read-only-error?) | |
235 | (define-condition-type &i/o-file-already-exists | |
236 | &i/o-filename make-i/o-file-already-exists-error | |
237 | i/o-file-already-exists-error?) | |
238 | (define-condition-type &i/o-file-does-not-exist | |
239 | &i/o-filename make-i/o-file-does-not-exist-error | |
240 | i/o-file-does-not-exist-error?) | |
241 | (define-condition-type &i/o-port &i/o make-i/o-port-error i/o-port-error? | |
242 | (port i/o-error-port)) | |
243 | ) |