module/rnrs/conditions.scm

   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
  69           make-implementation-restriction-violation
  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?)
  85   (import (only (guile) and=> @@)
  86           (rnrs base (6))
  87           (rnrs lists (6))
  88           (rnrs records procedural (6)))
  89
  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)))
  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))))))
 109
 110   (define (condition? obj)
 111     (or (compound-condition? obj) (condition-internal? obj)))
 112
 113   (define condition
 114     (lambda conditions
 115       (define (flatten cond)
 116         (if (compound-condition? cond) (simple-conditions cond) (list cond)))
 117       (or (for-all condition? conditions)
 118           (assertion-violation 'condition "non-condition argument" conditions))
 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                ((_) '())))
 133
 134             (generate-accessors
 135              (syntax-rules ()
 136                ((_ counter (f a) . rest)
 137                 (begin (define a
 138                          (condition-accessor
 139                           condition-type
 140                           (record-accessor condition-type counter)))
 141                        (generate-accessors (+ counter 1) . rest)))
 142                ((_ counter) (begin)))))
 143          (begin
 144            (define condition-type
 145              (make-record-type-descriptor
 146               'condition-type supertype #f #f #f
 147               (list->vector (transform-fields (field accessor) ...))))
 148            (define constructor
 149              (record-constructor
 150               (make-record-constructor-descriptor condition-type #f #f)))
 151            (define predicate (condition-predicate condition-type))
 152            (generate-accessors 0 (field accessor) ...))))))
 153
 154   (define &condition (@@ (rnrs records procedural) &condition))
 155   (define &condition-constructor-descriptor
 156     (make-record-constructor-descriptor &condition #f #f))
 157   (define condition-internal? (record-predicate &condition))
 158
 159   (define (condition-predicate rtd)
 160     (let ((rtd-predicate (record-predicate rtd)))
 161       (lambda (obj)
 162         (cond ((compound-condition? obj)
 163                (exists rtd-predicate (simple-conditions obj)))
 164               ((condition-internal? obj) (rtd-predicate obj))
 165               (else #f)))))
 166
 167   (define (condition-accessor rtd proc)
 168     (let ((rtd-predicate (record-predicate rtd)))
 169       (lambda (obj)
 170         (cond ((rtd-predicate obj) (proc obj))
 171               ((compound-condition? obj)
 172                (and=> (find rtd-predicate (simple-conditions obj)) proc))
 173               (else #f)))))
 174
 175   (define-condition-type &message &condition
 176     make-message-condition message-condition?
 177     (message condition-message))
 178
 179   (define-condition-type &warning &condition make-warning warning?)
 180
 181   (define &serious (@@ (rnrs records procedural) &serious))
 182   (define make-serious-condition
 183     (@@ (rnrs records procedural) make-serious-condition))
 184   (define serious-condition? (condition-predicate &serious))
 185
 186   (define-condition-type &error &serious make-error error?)
 187
 188   (define &violation (@@ (rnrs records procedural) &violation))
 189   (define make-violation (@@ (rnrs records procedural) make-violation))
 190   (define violation? (condition-predicate &violation))
 191
 192   (define &assertion (@@ (rnrs records procedural) &assertion))
 193   (define make-assertion-violation
 194     (@@ (rnrs records procedural) make-assertion-violation))
 195   (define assertion-violation? (condition-predicate &assertion))
 196
 197   (define-condition-type &irritants &condition
 198     make-irritants-condition irritants-condition?
 199     (irritants condition-irritants))
 200
 201   (define-condition-type &who &condition
 202     make-who-condition who-condition?
 203     (who condition-who))
 204
 205   (define-condition-type &non-continuable &violation
 206     make-non-continuable-violation
 207     non-continuable-violation?)
 208
 209   (define-condition-type &implementation-restriction
 210     &violation
 211     make-implementation-restriction-violation
 212     implementation-restriction-violation?)
 213
 214   (define-condition-type &lexical &violation
 215     make-lexical-violation lexical-violation?)
 216
 217   (define-condition-type &syntax &violation
 218     make-syntax-violation syntax-violation?
 219     (form syntax-violation-form)
 220     (subform syntax-violation-subform))
 221
 222   (define-condition-type &undefined &violation
 223     make-undefined-violation undefined-violation?)
 224
 225 )