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