Commit | Line | Data |
---|---|---|
bce5cb56 | 1 | ;;; srfi-35.scm --- Conditions -*- coding: utf-8 -*- |
c9de3d45 | 2 | |
0c65f52c | 3 | ;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. |
c9de3d45 LC |
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 | |
83ba2d37 | 8 | ;; version 3 of the License, or (at your option) any later version. |
c9de3d45 LC |
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 | ||
bce5cb56 | 19 | ;;; Author: Ludovic Courtès <ludo@gnu.org> |
c9de3d45 LC |
20 | |
21 | ;;; Commentary: | |
22 | ||
23 | ;; This is an implementation of SRFI-35, "Conditions". Conditions are a | |
24 | ;; means to convey information about exceptional conditions between parts of | |
25 | ;; a program. | |
26 | ||
27 | ;;; Code: | |
28 | ||
29 | (define-module (srfi srfi-35) | |
30 | #:use-module (srfi srfi-1) | |
31 | #:export (make-condition-type condition-type? | |
32 | make-condition condition? condition-has-type? condition-ref | |
33 | make-compound-condition extract-condition | |
34 | define-condition-type condition | |
35 | &condition | |
36 | &message message-condition? condition-message | |
37 | &serious serious-condition? | |
38 | &error error?)) | |
39 | ||
816e3edf LC |
40 | (cond-expand-provide (current-module) '(srfi-35)) |
41 | ||
c9de3d45 LC |
42 | \f |
43 | ;;; | |
44 | ;;; Condition types. | |
45 | ;;; | |
46 | ||
47 | (define %condition-type-vtable | |
48 | ;; The vtable of all condition types. | |
49 | ;; vtable fields: vtable, self, printer | |
50 | ;; user fields: id, parent, all-field-names | |
5f8d67ad AW |
51 | (let ((s (make-vtable (string-append standard-vtable-fields "prprpr") |
52 | (lambda (ct port) | |
53 | (format port "#<condition-type ~a ~a>" | |
54 | (condition-type-id ct) | |
55 | (number->string (object-address ct) | |
56 | 16)))))) | |
57 | (set-struct-vtable-name! s 'condition-type) | |
58 | s)) | |
c9de3d45 | 59 | |
5565279a LC |
60 | (define (%make-condition-type layout id parent all-fields) |
61 | (let ((struct (make-struct %condition-type-vtable 0 | |
62 | (make-struct-layout layout) ;; layout | |
63 | print-condition ;; printer | |
64 | id parent all-fields))) | |
65 | ||
66 | ;; Hack to associate STRUCT with a name, providing a better name for | |
67 | ;; GOOPS classes as returned by `class-of' et al. | |
68 | (set-struct-vtable-name! struct (cond ((symbol? id) id) | |
69 | ((string? id) (string->symbol id)) | |
70 | (else (string->symbol "")))) | |
71 | struct)) | |
72 | ||
c9de3d45 LC |
73 | (define (condition-type? obj) |
74 | "Return true if OBJ is a condition type." | |
75 | (and (struct? obj) | |
76 | (eq? (struct-vtable obj) | |
77 | %condition-type-vtable))) | |
78 | ||
79 | (define (condition-type-id ct) | |
80 | (and (condition-type? ct) | |
ceedcfaa | 81 | (struct-ref ct (+ vtable-offset-user 0)))) |
c9de3d45 LC |
82 | |
83 | (define (condition-type-parent ct) | |
84 | (and (condition-type? ct) | |
ceedcfaa | 85 | (struct-ref ct (+ vtable-offset-user 1)))) |
c9de3d45 LC |
86 | |
87 | (define (condition-type-all-fields ct) | |
88 | (and (condition-type? ct) | |
ceedcfaa | 89 | (struct-ref ct (+ vtable-offset-user 2)))) |
c9de3d45 LC |
90 | |
91 | ||
92 | (define (struct-layout-for-condition field-names) | |
93 | ;; Return a string denoting the layout required to hold the fields listed | |
94 | ;; in FIELD-NAMES. | |
95 | (let loop ((field-names field-names) | |
96 | (layout '("pr"))) | |
97 | (if (null? field-names) | |
98 | (string-concatenate/shared layout) | |
99 | (loop (cdr field-names) | |
100 | (cons "pr" layout))))) | |
101 | ||
102 | (define (print-condition c port) | |
67231cef LC |
103 | ;; Print condition C to PORT in a way similar to how records print: |
104 | ;; #<condition TYPE [FIELD: VALUE ...] ADDRESS>. | |
105 | (define (field-values) | |
106 | (let* ((type (struct-vtable c)) | |
107 | (strings (fold (lambda (field result) | |
108 | (cons (format #f "~A: ~S" field | |
109 | (condition-ref c field)) | |
110 | result)) | |
111 | '() | |
112 | (condition-type-all-fields type)))) | |
113 | (string-join (reverse strings) " "))) | |
114 | ||
115 | (format port "#<condition ~a [~a] ~a>" | |
116 | (condition-type-id (condition-type c)) | |
117 | (field-values) | |
118 | (number->string (object-address c) 16))) | |
c9de3d45 LC |
119 | |
120 | (define (make-condition-type id parent field-names) | |
121 | "Return a new condition type named ID, inheriting from PARENT, and with the | |
122 | fields whose names are listed in FIELD-NAMES. FIELD-NAMES must be a list of | |
123 | symbols and must not contain names already used by PARENT or one of its | |
124 | supertypes." | |
125 | (if (symbol? id) | |
126 | (if (condition-type? parent) | |
127 | (let ((parent-fields (condition-type-all-fields parent))) | |
128 | (if (and (every symbol? field-names) | |
129 | (null? (lset-intersection eq? | |
130 | field-names parent-fields))) | |
131 | (let* ((all-fields (append parent-fields field-names)) | |
132 | (layout (struct-layout-for-condition all-fields))) | |
5565279a LC |
133 | (%make-condition-type layout |
134 | id parent all-fields)) | |
c9de3d45 LC |
135 | (error "invalid condition type field names" |
136 | field-names))) | |
137 | (error "parent is not a condition type" parent)) | |
138 | (error "condition type identifier is not a symbol" id))) | |
139 | ||
140 | (define (make-compound-condition-type id parents) | |
141 | ;; Return a compound condition type made of the types listed in PARENTS. | |
142 | ;; All fields from PARENTS are kept, even same-named ones, since they are | |
143 | ;; needed by `extract-condition'. | |
bc4ee34e LC |
144 | (cond ((null? parents) |
145 | (error "`make-compound-condition-type' passed empty parent list" | |
146 | id)) | |
147 | ((null? (cdr parents)) | |
148 | (car parents)) | |
149 | (else | |
150 | (let* ((all-fields (append-map condition-type-all-fields | |
151 | parents)) | |
152 | (layout (struct-layout-for-condition all-fields))) | |
5565279a LC |
153 | (%make-condition-type layout |
154 | id | |
155 | parents ;; list of parents! | |
156 | all-fields))))) | |
c9de3d45 LC |
157 | |
158 | \f | |
159 | ;;; | |
160 | ;;; Conditions. | |
161 | ;;; | |
162 | ||
163 | (define (condition? c) | |
164 | "Return true if C is a condition." | |
165 | (and (struct? c) | |
166 | (condition-type? (struct-vtable c)))) | |
167 | ||
168 | (define (condition-type c) | |
169 | (and (struct? c) | |
170 | (let ((vtable (struct-vtable c))) | |
171 | (if (condition-type? vtable) | |
172 | vtable | |
173 | #f)))) | |
174 | ||
175 | (define (condition-has-type? c type) | |
176 | "Return true if condition C has type TYPE." | |
177 | (if (and (condition? c) (condition-type? type)) | |
178 | (let loop ((ct (condition-type c))) | |
179 | (or (eq? ct type) | |
180 | (and ct | |
181 | (let ((parent (condition-type-parent ct))) | |
182 | (if (list? parent) | |
183 | (any loop parent) ;; compound condition | |
184 | (loop (condition-type-parent ct))))))) | |
185 | (throw 'wrong-type-arg "condition-has-type?" | |
186 | "Wrong type argument"))) | |
187 | ||
188 | (define (condition-ref c field-name) | |
189 | "Return the value of the field named FIELD-NAME from condition C." | |
190 | (if (condition? c) | |
191 | (if (symbol? field-name) | |
192 | (let* ((type (condition-type c)) | |
193 | (fields (condition-type-all-fields type)) | |
194 | (index (list-index (lambda (name) | |
195 | (eq? name field-name)) | |
196 | fields))) | |
197 | (if index | |
198 | (struct-ref c index) | |
199 | (error "invalid field name" field-name))) | |
200 | (error "field name is not a symbol" field-name)) | |
201 | (throw 'wrong-type-arg "condition-ref" | |
202 | "Wrong type argument: ~S" c))) | |
203 | ||
204 | (define (make-condition-from-values type values) | |
205 | (apply make-struct type 0 values)) | |
206 | ||
207 | (define (make-condition type . field+value) | |
208 | "Return a new condition of type TYPE with fields initialized as specified | |
209 | by FIELD+VALUE, a sequence of field names (symbols) and values." | |
210 | (if (condition-type? type) | |
211 | (let* ((all-fields (condition-type-all-fields type)) | |
212 | (inits (fold-right (lambda (field inits) | |
213 | (let ((v (memq field field+value))) | |
214 | (if (pair? v) | |
215 | (cons (cadr v) inits) | |
216 | (error "field not specified" | |
217 | field)))) | |
218 | '() | |
219 | all-fields))) | |
220 | (make-condition-from-values type inits)) | |
221 | (throw 'wrong-type-arg "make-condition" | |
222 | "Wrong type argument: ~S" type))) | |
223 | ||
224 | (define (make-compound-condition . conditions) | |
225 | "Return a new compound condition composed of CONDITIONS." | |
226 | (let* ((types (map condition-type conditions)) | |
227 | (ct (make-compound-condition-type 'compound types)) | |
228 | (inits (append-map (lambda (c) | |
229 | (let ((ct (condition-type c))) | |
230 | (map (lambda (f) | |
231 | (condition-ref c f)) | |
232 | (condition-type-all-fields ct)))) | |
233 | conditions))) | |
234 | (make-condition-from-values ct inits))) | |
235 | ||
236 | (define (extract-condition c type) | |
237 | "Return a condition of condition type TYPE with the field values specified | |
238 | by C." | |
239 | ||
240 | (define (first-field-index parents) | |
241 | ;; Return the index of the first field of TYPE within C. | |
242 | (let loop ((parents parents) | |
243 | (index 0)) | |
244 | (let ((parent (car parents))) | |
245 | (cond ((null? parents) | |
246 | #f) | |
247 | ((eq? parent type) | |
248 | index) | |
249 | ((pair? parent) | |
250 | (or (loop parent index) | |
251 | (loop (cdr parents) | |
252 | (+ index | |
253 | (apply + (map condition-type-all-fields | |
254 | parent)))))) | |
255 | (else | |
256 | (let ((shift (length (condition-type-all-fields parent)))) | |
257 | (loop (cdr parents) | |
258 | (+ index shift)))))))) | |
259 | ||
260 | (define (list-fields start-index field-names) | |
261 | ;; Return a list of the form `(FIELD-NAME VALUE...)'. | |
262 | (let loop ((index start-index) | |
263 | (field-names field-names) | |
264 | (result '())) | |
265 | (if (null? field-names) | |
266 | (reverse! result) | |
267 | (loop (+ 1 index) | |
268 | (cdr field-names) | |
269 | (cons* (struct-ref c index) | |
270 | (car field-names) | |
271 | result))))) | |
272 | ||
273 | (if (and (condition? c) (condition-type? type)) | |
274 | (let* ((ct (condition-type c)) | |
275 | (parent (condition-type-parent ct))) | |
276 | (cond ((eq? type ct) | |
277 | c) | |
278 | ((pair? parent) | |
279 | ;; C is a compound condition. | |
280 | (let ((field-index (first-field-index parent))) | |
281 | ;;(format #t "field-index: ~a ~a~%" field-index | |
282 | ;; (list-fields field-index | |
283 | ;; (condition-type-all-fields type))) | |
284 | (apply make-condition type | |
285 | (list-fields field-index | |
286 | (condition-type-all-fields type))))) | |
287 | (else | |
288 | ;; C does not have type TYPE. | |
289 | #f))) | |
290 | (throw 'wrong-type-arg "extract-condition" | |
291 | "Wrong type argument"))) | |
292 | ||
293 | \f | |
294 | ;;; | |
295 | ;;; Syntax. | |
296 | ;;; | |
297 | ||
0c65f52c AW |
298 | (define-syntax-rule (define-condition-type name parent pred (field-name field-accessor) ...) |
299 | (begin | |
300 | (define name | |
301 | (make-condition-type 'name parent '(field-name ...))) | |
302 | (define (pred c) | |
303 | (condition-has-type? c name)) | |
304 | (define (field-accessor c) | |
305 | (condition-ref c 'field-name)) | |
306 | ...)) | |
307 | ||
308 | (define-syntax-rule (compound-condition (type ...) (field ...)) | |
de784acd | 309 | ;; Create a compound condition using `make-compound-condition-type'. |
0c65f52c AW |
310 | (condition ((make-compound-condition-type '%compound `(,type ...)) |
311 | field ...))) | |
de784acd LC |
312 | |
313 | (define-syntax condition-instantiation | |
314 | ;; Build the `(make-condition type ...)' call. | |
315 | (syntax-rules () | |
316 | ((_ type (out ...)) | |
317 | (make-condition type out ...)) | |
318 | ((_ type (out ...) (field-name field-value) rest ...) | |
319 | (condition-instantiation type (out ... 'field-name field-value) rest ...)))) | |
320 | ||
321 | (define-syntax condition | |
322 | (syntax-rules () | |
323 | ((_ (type field ...)) | |
324 | (condition-instantiation type () field ...)) | |
325 | ((_ (type field ...) ...) | |
326 | (compound-condition (type ...) (field ... ...))))) | |
c9de3d45 LC |
327 | |
328 | \f | |
329 | ;;; | |
330 | ;;; Standard condition types. | |
331 | ;;; | |
332 | ||
333 | (define &condition | |
334 | ;; The root condition type. | |
335 | (make-struct %condition-type-vtable 0 | |
336 | (make-struct-layout "") | |
337 | (lambda (c port) | |
338 | (display "<&condition>")) | |
339 | '&condition #f '() '())) | |
340 | ||
341 | (define-condition-type &message &condition | |
342 | message-condition? | |
343 | (message condition-message)) | |
344 | ||
345 | (define-condition-type &serious &condition | |
346 | serious-condition?) | |
347 | ||
348 | (define-condition-type &error &serious | |
349 | error?) | |
350 | ||
c9de3d45 | 351 | ;;; srfi-35.scm ends here |