1 ;;; srfi-35.scm --- Conditions -*- coding: utf-8 -*-
3 ;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
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.
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.
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
19 ;;; Author: Ludovic Courtès <ludo@gnu.org>
23 ;; This is an implementation of SRFI-35, "Conditions". Conditions are a
24 ;; means to convey information about exceptional conditions between parts of
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
36 &message message-condition? condition-message
37 &serious serious-condition?
40 (cond-expand-provide (current-module) '(srfi-35))
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
51 (let ((s (make-vtable (string-append standard-vtable-fields "prprpr")
53 (format port "#<condition-type ~a ~a>"
54 (condition-type-id ct)
55 (number->string (object-address ct)
57 (set-struct-vtable-name! s 'condition-type)
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)))
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 ""))))
73 (define (condition-type? obj)
74 "Return true if OBJ is a condition type."
76 (eq? (struct-vtable obj)
77 %condition-type-vtable)))
79 (define (condition-type-id ct)
80 (and (condition-type? ct)
81 (struct-ref ct (+ vtable-offset-user 0))))
83 (define (condition-type-parent ct)
84 (and (condition-type? ct)
85 (struct-ref ct (+ vtable-offset-user 1))))
87 (define (condition-type-all-fields ct)
88 (and (condition-type? ct)
89 (struct-ref ct (+ vtable-offset-user 2))))
92 (define (struct-layout-for-condition field-names)
93 ;; Return a string denoting the layout required to hold the fields listed
95 (let loop ((field-names field-names)
97 (if (null? field-names)
98 (string-concatenate/shared layout)
99 (loop (cdr field-names)
100 (cons "pr" layout)))))
102 (define (print-condition c port)
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))
112 (condition-type-all-fields type))))
113 (string-join (reverse strings) " ")))
115 (format port "#<condition ~a [~a] ~a>"
116 (condition-type-id (condition-type c))
118 (number->string (object-address c) 16)))
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
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)))
133 (%make-condition-type layout
134 id parent all-fields))
135 (error "invalid condition type field names"
137 (error "parent is not a condition type" parent))
138 (error "condition type identifier is not a symbol" id)))
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'.
144 (cond ((null? parents)
145 (error "`make-compound-condition-type' passed empty parent list"
147 ((null? (cdr parents))
150 (let* ((all-fields (append-map condition-type-all-fields
152 (layout (struct-layout-for-condition all-fields)))
153 (%make-condition-type layout
155 parents ;; list of parents!
163 (define (condition? c)
164 "Return true if C is a condition."
166 (condition-type? (struct-vtable c))))
168 (define (condition-type c)
170 (let ((vtable (struct-vtable c)))
171 (if (condition-type? vtable)
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)))
181 (let ((parent (condition-type-parent ct)))
183 (any loop parent) ;; compound condition
184 (loop (condition-type-parent ct)))))))
185 (throw 'wrong-type-arg "condition-has-type?"
186 "Wrong type argument")))
188 (define (condition-ref c field-name)
189 "Return the value of the field named FIELD-NAME from 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))
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)))
204 (define (make-condition-from-values type values)
205 (apply make-struct type 0 values))
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)))
215 (cons (cadr v) inits)
216 (error "field not specified"
220 (make-condition-from-values type inits))
221 (throw 'wrong-type-arg "make-condition"
222 "Wrong type argument: ~S" type)))
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)))
232 (condition-type-all-fields ct))))
234 (make-condition-from-values ct inits)))
236 (define (extract-condition c type)
237 "Return a condition of condition type TYPE with the field values specified
240 (define (first-field-index parents)
241 ;; Return the index of the first field of TYPE within C.
242 (let loop ((parents parents)
244 (let ((parent (car parents)))
245 (cond ((null? parents)
250 (or (loop parent index)
253 (apply + (map condition-type-all-fields
256 (let ((shift (length (condition-type-all-fields parent))))
258 (+ index shift))))))))
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)
265 (if (null? field-names)
269 (cons* (struct-ref c index)
273 (if (and (condition? c) (condition-type? type))
274 (let* ((ct (condition-type c))
275 (parent (condition-type-parent ct)))
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)))))
288 ;; C does not have type TYPE.
290 (throw 'wrong-type-arg "extract-condition"
291 "Wrong type argument")))
298 (define-syntax-rule (define-condition-type name parent pred (field-name field-accessor) ...)
301 (make-condition-type 'name parent '(field-name ...)))
303 (condition-has-type? c name))
304 (define (field-accessor c)
305 (condition-ref c 'field-name))
308 (define-syntax-rule (compound-condition (type ...) (field ...))
309 ;; Create a compound condition using `make-compound-condition-type'.
310 (condition ((make-compound-condition-type '%compound `(,type ...))
313 (define-syntax condition-instantiation
314 ;; Build the `(make-condition type ...)' call.
317 (make-condition type out ...))
318 ((_ type (out ...) (field-name field-value) rest ...)
319 (condition-instantiation type (out ... 'field-name field-value) rest ...))))
321 (define-syntax condition
323 ((_ (type field ...))
324 (condition-instantiation type () field ...))
325 ((_ (type field ...) ...)
326 (compound-condition (type ...) (field ... ...)))))
330 ;;; Standard condition types.
334 ;; The root condition type.
335 (make-struct %condition-type-vtable 0
336 (make-struct-layout "")
338 (display "<&condition>"))
339 '&condition #f '() '()))
341 (define-condition-type &message &condition
343 (message condition-message))
345 (define-condition-type &serious &condition
348 (define-condition-type &error &serious
351 ;;; srfi-35.scm ends here