| 1 | ;;; srfi-35.scm --- Conditions -*- coding: utf-8 -*- |
| 2 | |
| 3 | ;; Copyright (C) 2007, 2008, 2009, 2010, 2011 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 | |
| 19 | ;;; Author: Ludovic Courtès <ludo@gnu.org> |
| 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 | |
| 40 | (cond-expand-provide (current-module) '(srfi-35)) |
| 41 | |
| 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 |
| 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)) |
| 59 | |
| 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 | |
| 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) |
| 81 | (struct-ref ct (+ vtable-offset-user 0)))) |
| 82 | |
| 83 | (define (condition-type-parent ct) |
| 84 | (and (condition-type? ct) |
| 85 | (struct-ref ct (+ vtable-offset-user 1)))) |
| 86 | |
| 87 | (define (condition-type-all-fields ct) |
| 88 | (and (condition-type? ct) |
| 89 | (struct-ref ct (+ vtable-offset-user 2)))) |
| 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) |
| 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))) |
| 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))) |
| 133 | (%make-condition-type layout |
| 134 | id parent all-fields)) |
| 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'. |
| 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))) |
| 153 | (%make-condition-type layout |
| 154 | id |
| 155 | parents ;; list of parents! |
| 156 | all-fields))))) |
| 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 | |
| 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 ...)) |
| 309 | ;; Create a compound condition using `make-compound-condition-type'. |
| 310 | (condition ((make-compound-condition-type '%compound `(,type ...)) |
| 311 | field ...))) |
| 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 ... ...))))) |
| 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 | |
| 351 | ;;; srfi-35.scm ends here |