module/srfi/srfi-35.scm

   1 ;;; srfi-35.scm --- Conditions
   2
   3 ;; Copyright (C) 2007, 2008 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 2.1 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   (make-vtable-vtable "prprpr" 0
  52                       (lambda (ct port)
  53                         (if (eq? ct %condition-type-vtable)
  54                             (display "#<condition-type-vtable>")
  55                             (format port "#<condition-type ~a ~a>"
  56                                     (condition-type-id ct)
  57                                     (number->string (object-address ct)
  58                                                     16))))))
  59
  60 (define (condition-type? obj)
  61   "Return true if OBJ is a condition type."
  62   (and (struct? obj)
  63        (eq? (struct-vtable obj)
  64             %condition-type-vtable)))
  65
  66 (define (condition-type-id ct)
  67   (and (condition-type? ct)
  68        (struct-ref ct 3)))
  69
  70 (define (condition-type-parent ct)
  71   (and (condition-type? ct)
  72        (struct-ref ct 4)))
  73
  74 (define (condition-type-all-fields ct)
  75   (and (condition-type? ct)
  76        (struct-ref ct 5)))
  77
  78
  79 (define (struct-layout-for-condition field-names)
  80   ;; Return a string denoting the layout required to hold the fields listed
  81   ;; in FIELD-NAMES.
  82   (let loop ((field-names field-names)
  83              (layout      '("pr")))
  84     (if (null? field-names)
  85         (string-concatenate/shared layout)
  86         (loop (cdr field-names)
  87               (cons "pr" layout)))))
  88
  89 (define (print-condition c port)
  90   (format port "#<condition ~a ~a>"
  91           (condition-type-id (condition-type c))
  92           (number->string (object-address c) 16)))
  93
  94 (define (make-condition-type id parent field-names)
  95   "Return a new condition type named ID, inheriting from PARENT, and with the
  96 fields whose names are listed in FIELD-NAMES.  FIELD-NAMES must be a list of
  97 symbols and must not contain names already used by PARENT or one of its
  98 supertypes."
  99   (if (symbol? id)
 100       (if (condition-type? parent)
 101           (let ((parent-fields (condition-type-all-fields parent)))
 102             (if (and (every symbol? field-names)
 103                      (null? (lset-intersection eq?
 104                                                field-names parent-fields)))
 105                 (let* ((all-fields (append parent-fields field-names))
 106                        (layout     (struct-layout-for-condition all-fields)))
 107                   (make-struct %condition-type-vtable 0
 108                                (make-struct-layout layout) ;; layout
 109                                print-condition             ;; printer
 110                                id parent all-fields))
 111                 (error "invalid condition type field names"
 112                        field-names)))
 113           (error "parent is not a condition type" parent))
 114       (error "condition type identifier is not a symbol" id)))
 115
 116 (define (make-compound-condition-type id parents)
 117   ;; Return a compound condition type made of the types listed in PARENTS.
 118   ;; All fields from PARENTS are kept, even same-named ones, since they are
 119   ;; needed by `extract-condition'.
 120   (cond ((null? parents)
 121          (error "`make-compound-condition-type' passed empty parent list"
 122                 id))
 123         ((null? (cdr parents))
 124          (car parents))
 125         (else
 126          (let* ((all-fields (append-map condition-type-all-fields
 127                                         parents))
 128                 (layout     (struct-layout-for-condition all-fields)))
 129            (make-struct %condition-type-vtable 0
 130                         (make-struct-layout layout) ;; layout
 131                         print-condition             ;; printer
 132                         id
 133                         parents                     ;; list of parents!
 134                         all-fields
 135                         all-fields)))))
 136
 137 \f
 138 ;;;
 139 ;;; Conditions.
 140 ;;;
 141
 142 (define (condition? c)
 143   "Return true if C is a condition."
 144   (and (struct? c)
 145        (condition-type? (struct-vtable c))))
 146
 147 (define (condition-type c)
 148   (and (struct? c)
 149        (let ((vtable (struct-vtable c)))
 150          (if (condition-type? vtable)
 151              vtable
 152              #f))))
 153
 154 (define (condition-has-type? c type)
 155   "Return true if condition C has type TYPE."
 156   (if (and (condition? c) (condition-type? type))
 157       (let loop ((ct (condition-type c)))
 158         (or (eq? ct type)
 159             (and ct
 160                  (let ((parent (condition-type-parent ct)))
 161                    (if (list? parent)
 162                        (any loop parent) ;; compound condition
 163                        (loop (condition-type-parent ct)))))))
 164       (throw 'wrong-type-arg "condition-has-type?"
 165              "Wrong type argument")))
 166
 167 (define (condition-ref c field-name)
 168   "Return the value of the field named FIELD-NAME from condition C."
 169   (if (condition? c)
 170       (if (symbol? field-name)
 171           (let* ((type   (condition-type c))
 172                  (fields (condition-type-all-fields type))
 173                  (index  (list-index (lambda (name)
 174                                        (eq? name field-name))
 175                                      fields)))
 176             (if index
 177                 (struct-ref c index)
 178                 (error "invalid field name" field-name)))
 179           (error "field name is not a symbol" field-name))
 180       (throw 'wrong-type-arg "condition-ref"
 181              "Wrong type argument: ~S" c)))
 182
 183 (define (make-condition-from-values type values)
 184   (apply make-struct type 0 values))
 185
 186 (define (make-condition type . field+value)
 187   "Return a new condition of type TYPE with fields initialized as specified
 188 by FIELD+VALUE, a sequence of field names (symbols) and values."
 189   (if (condition-type? type)
 190       (let* ((all-fields (condition-type-all-fields type))
 191              (inits      (fold-right (lambda (field inits)
 192                                        (let ((v (memq field field+value)))
 193                                          (if (pair? v)
 194                                              (cons (cadr v) inits)
 195                                              (error "field not specified"
 196                                                     field))))
 197                                      '()
 198                                      all-fields)))
 199         (make-condition-from-values type inits))
 200       (throw 'wrong-type-arg "make-condition"
 201              "Wrong type argument: ~S" type)))
 202
 203 (define (make-compound-condition . conditions)
 204   "Return a new compound condition composed of CONDITIONS."
 205   (let* ((types  (map condition-type conditions))
 206          (ct     (make-compound-condition-type 'compound types))
 207          (inits  (append-map (lambda (c)
 208                                (let ((ct (condition-type c)))
 209                                  (map (lambda (f)
 210                                         (condition-ref c f))
 211                                       (condition-type-all-fields ct))))
 212                              conditions)))
 213     (make-condition-from-values ct inits)))
 214
 215 (define (extract-condition c type)
 216   "Return a condition of condition type TYPE with the field values specified
 217 by C."
 218
 219   (define (first-field-index parents)
 220     ;; Return the index of the first field of TYPE within C.
 221     (let loop ((parents parents)
 222                (index   0))
 223       (let ((parent (car parents)))
 224         (cond ((null? parents)
 225                #f)
 226               ((eq? parent type)
 227                index)
 228               ((pair? parent)
 229                (or (loop parent index)
 230                    (loop (cdr parents)
 231                          (+ index
 232                             (apply + (map condition-type-all-fields
 233                                           parent))))))
 234               (else
 235                (let ((shift (length (condition-type-all-fields parent))))
 236                  (loop (cdr parents)
 237                        (+ index shift))))))))
 238
 239   (define (list-fields start-index field-names)
 240     ;; Return a list of the form `(FIELD-NAME VALUE...)'.
 241     (let loop ((index       start-index)
 242                (field-names field-names)
 243                (result      '()))
 244       (if (null? field-names)
 245           (reverse! result)
 246           (loop (+ 1 index)
 247                 (cdr field-names)
 248                 (cons* (struct-ref c index)
 249                        (car field-names)
 250                        result)))))
 251
 252   (if (and (condition? c) (condition-type? type))
 253       (let* ((ct     (condition-type c))
 254              (parent (condition-type-parent ct)))
 255         (cond ((eq? type ct)
 256                c)
 257               ((pair? parent)
 258                ;; C is a compound condition.
 259                (let ((field-index (first-field-index parent)))
 260                  ;;(format #t "field-index: ~a ~a~%" field-index
 261                  ;;        (list-fields field-index
 262                  ;;                     (condition-type-all-fields type)))
 263                  (apply make-condition type
 264                         (list-fields field-index
 265                                      (condition-type-all-fields type)))))
 266               (else
 267                ;; C does not have type TYPE.
 268                #f)))
 269       (throw 'wrong-type-arg "extract-condition"
 270              "Wrong type argument")))
 271
 272 \f
 273 ;;;
 274 ;;; Syntax.
 275 ;;;
 276
 277 (define-macro (define-condition-type name parent pred . field-specs)
 278   `(begin
 279      (define ,name
 280        (make-condition-type ',name ,parent
 281                             ',(map car field-specs)))
 282      (define (,pred c)
 283        (condition-has-type? c ,name))
 284      ,@(map (lambda (field-spec)
 285               (let ((field-name (car field-spec))
 286                     (accessor   (cadr field-spec)))
 287                 `(define (,accessor c)
 288                    (condition-ref c ',field-name))))
 289             field-specs)))
 290
 291 (define-macro (condition . type-field-bindings)
 292   (cond ((null? type-field-bindings)
 293          (error "`condition' syntax error" type-field-bindings))
 294         (else
 295          ;; the poor man's hygienic macro
 296          (let ((mc   (gensym "mc"))
 297                (mcct (gensym "mcct")))
 298            `(let ((,mc   (@  (srfi srfi-35) make-condition))
 299                   (,mcct (@@ (srfi srfi-35) make-compound-condition-type)))
 300               (,mc (,mcct 'compound (list ,@(map car type-field-bindings)))
 301                    ,@(append-map (lambda (type-field-binding)
 302                                    (append-map (lambda (field+value)
 303                                                  (let ((f (car field+value))
 304                                                        (v (cadr field+value)))
 305                                                    `(',f ,v)))
 306                                                (cdr type-field-binding)))
 307                                  type-field-bindings)))))))
 308
 309 \f
 310 ;;;
 311 ;;; Standard condition types.
 312 ;;;
 313
 314 (define &condition
 315   ;; The root condition type.
 316   (make-struct %condition-type-vtable 0
 317                (make-struct-layout "")
 318                (lambda (c port)
 319                  (display "<&condition>"))
 320                '&condition #f '() '()))
 321
 322 (define-condition-type &message &condition
 323   message-condition?
 324   (message condition-message))
 325
 326 (define-condition-type &serious &condition
 327   serious-condition?)
 328
 329 (define-condition-type &error &serious
 330   error?)
 331
 332
 333 ;;; Local Variables:
 334 ;;; coding: latin-1
 335 ;;; End:
 336
 337 ;;; srfi-35.scm ends here