module/srfi/srfi-35.scm

   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