mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
329 lines
10 KiB
Scheme
329 lines
10 KiB
Scheme
;;; srfi-35.scm --- Conditions
|
||
|
||
;; Copyright (C) 2007 Free Software Foundation, Inc.
|
||
;;
|
||
;; This library is free software; you can redistribute it and/or
|
||
;; modify it under the terms of the GNU Lesser General Public
|
||
;; License as published by the Free Software Foundation; either
|
||
;; version 2.1 of the License, or (at your option) any later version.
|
||
;;
|
||
;; This library is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
;; Lesser General Public License for more details.
|
||
;;
|
||
;; You should have received a copy of the GNU Lesser General Public
|
||
;; License along with this library; if not, write to the Free Software
|
||
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||
|
||
;;; Author: Ludovic Courtès <ludo@gnu.org>
|
||
|
||
;;; Commentary:
|
||
|
||
;; This is an implementation of SRFI-35, "Conditions". Conditions are a
|
||
;; means to convey information about exceptional conditions between parts of
|
||
;; a program.
|
||
|
||
;;; Code:
|
||
|
||
(define-module (srfi srfi-35)
|
||
#:use-module (srfi srfi-1)
|
||
#:export (make-condition-type condition-type?
|
||
make-condition condition? condition-has-type? condition-ref
|
||
make-compound-condition extract-condition
|
||
define-condition-type condition
|
||
&condition
|
||
&message message-condition? condition-message
|
||
&serious serious-condition?
|
||
&error error?))
|
||
|
||
|
||
;;;
|
||
;;; Condition types.
|
||
;;;
|
||
|
||
(define %condition-type-vtable
|
||
;; The vtable of all condition types.
|
||
;; vtable fields: vtable, self, printer
|
||
;; user fields: id, parent, all-field-names
|
||
(make-vtable-vtable "prprpr" 0
|
||
(lambda (ct port)
|
||
(if (eq? ct %condition-type-vtable)
|
||
(display "#<condition-type-vtable>")
|
||
(format port "#<condition-type ~a ~a>"
|
||
(condition-type-id ct)
|
||
(number->string (object-address ct)
|
||
16))))))
|
||
|
||
(define (condition-type? obj)
|
||
"Return true if OBJ is a condition type."
|
||
(and (struct? obj)
|
||
(eq? (struct-vtable obj)
|
||
%condition-type-vtable)))
|
||
|
||
(define (condition-type-id ct)
|
||
(and (condition-type? ct)
|
||
(struct-ref ct 3)))
|
||
|
||
(define (condition-type-parent ct)
|
||
(and (condition-type? ct)
|
||
(struct-ref ct 4)))
|
||
|
||
(define (condition-type-all-fields ct)
|
||
(and (condition-type? ct)
|
||
(struct-ref ct 5)))
|
||
|
||
|
||
(define (struct-layout-for-condition field-names)
|
||
;; Return a string denoting the layout required to hold the fields listed
|
||
;; in FIELD-NAMES.
|
||
(let loop ((field-names field-names)
|
||
(layout '("pr")))
|
||
(if (null? field-names)
|
||
(string-concatenate/shared layout)
|
||
(loop (cdr field-names)
|
||
(cons "pr" layout)))))
|
||
|
||
(define (print-condition c port)
|
||
(format port "#<condition ~a ~a>"
|
||
(condition-type-id (condition-type c))
|
||
(number->string (object-address c) 16)))
|
||
|
||
(define (make-condition-type id parent field-names)
|
||
"Return a new condition type named ID, inheriting from PARENT, and with the
|
||
fields whose names are listed in FIELD-NAMES. FIELD-NAMES must be a list of
|
||
symbols and must not contain names already used by PARENT or one of its
|
||
supertypes."
|
||
(if (symbol? id)
|
||
(if (condition-type? parent)
|
||
(let ((parent-fields (condition-type-all-fields parent)))
|
||
(if (and (every symbol? field-names)
|
||
(null? (lset-intersection eq?
|
||
field-names parent-fields)))
|
||
(let* ((all-fields (append parent-fields field-names))
|
||
(layout (struct-layout-for-condition all-fields)))
|
||
(make-struct %condition-type-vtable 0
|
||
(make-struct-layout layout) ;; layout
|
||
print-condition ;; printer
|
||
id parent all-fields))
|
||
(error "invalid condition type field names"
|
||
field-names)))
|
||
(error "parent is not a condition type" parent))
|
||
(error "condition type identifier is not a symbol" id)))
|
||
|
||
(define (make-compound-condition-type id parents)
|
||
;; Return a compound condition type made of the types listed in PARENTS.
|
||
;; All fields from PARENTS are kept, even same-named ones, since they are
|
||
;; needed by `extract-condition'.
|
||
(let* ((all-fields (append-map condition-type-all-fields
|
||
parents))
|
||
(layout (struct-layout-for-condition all-fields)))
|
||
(make-struct %condition-type-vtable 0
|
||
(make-struct-layout layout) ;; layout
|
||
print-condition ;; printer
|
||
id
|
||
parents ;; list of parents!
|
||
all-fields
|
||
all-fields)))
|
||
|
||
|
||
;;;
|
||
;;; Conditions.
|
||
;;;
|
||
|
||
(define (condition? c)
|
||
"Return true if C is a condition."
|
||
(and (struct? c)
|
||
(condition-type? (struct-vtable c))))
|
||
|
||
(define (condition-type c)
|
||
(and (struct? c)
|
||
(let ((vtable (struct-vtable c)))
|
||
(if (condition-type? vtable)
|
||
vtable
|
||
#f))))
|
||
|
||
(define (condition-has-type? c type)
|
||
"Return true if condition C has type TYPE."
|
||
(if (and (condition? c) (condition-type? type))
|
||
(let loop ((ct (condition-type c)))
|
||
(or (eq? ct type)
|
||
(and ct
|
||
(let ((parent (condition-type-parent ct)))
|
||
(if (list? parent)
|
||
(any loop parent) ;; compound condition
|
||
(loop (condition-type-parent ct)))))))
|
||
(throw 'wrong-type-arg "condition-has-type?"
|
||
"Wrong type argument")))
|
||
|
||
(define (condition-ref c field-name)
|
||
"Return the value of the field named FIELD-NAME from condition C."
|
||
(if (condition? c)
|
||
(if (symbol? field-name)
|
||
(let* ((type (condition-type c))
|
||
(fields (condition-type-all-fields type))
|
||
(index (list-index (lambda (name)
|
||
(eq? name field-name))
|
||
fields)))
|
||
(if index
|
||
(struct-ref c index)
|
||
(error "invalid field name" field-name)))
|
||
(error "field name is not a symbol" field-name))
|
||
(throw 'wrong-type-arg "condition-ref"
|
||
"Wrong type argument: ~S" c)))
|
||
|
||
(define (make-condition-from-values type values)
|
||
(apply make-struct type 0 values))
|
||
|
||
(define (make-condition type . field+value)
|
||
"Return a new condition of type TYPE with fields initialized as specified
|
||
by FIELD+VALUE, a sequence of field names (symbols) and values."
|
||
(if (condition-type? type)
|
||
(let* ((all-fields (condition-type-all-fields type))
|
||
(inits (fold-right (lambda (field inits)
|
||
(let ((v (memq field field+value)))
|
||
(if (pair? v)
|
||
(cons (cadr v) inits)
|
||
(error "field not specified"
|
||
field))))
|
||
'()
|
||
all-fields)))
|
||
(make-condition-from-values type inits))
|
||
(throw 'wrong-type-arg "make-condition"
|
||
"Wrong type argument: ~S" type)))
|
||
|
||
(define (make-compound-condition . conditions)
|
||
"Return a new compound condition composed of CONDITIONS."
|
||
(let* ((types (map condition-type conditions))
|
||
(ct (make-compound-condition-type 'compound types))
|
||
(inits (append-map (lambda (c)
|
||
(let ((ct (condition-type c)))
|
||
(map (lambda (f)
|
||
(condition-ref c f))
|
||
(condition-type-all-fields ct))))
|
||
conditions)))
|
||
(make-condition-from-values ct inits)))
|
||
|
||
(define (extract-condition c type)
|
||
"Return a condition of condition type TYPE with the field values specified
|
||
by C."
|
||
|
||
(define (first-field-index parents)
|
||
;; Return the index of the first field of TYPE within C.
|
||
(let loop ((parents parents)
|
||
(index 0))
|
||
(let ((parent (car parents)))
|
||
(cond ((null? parents)
|
||
#f)
|
||
((eq? parent type)
|
||
index)
|
||
((pair? parent)
|
||
(or (loop parent index)
|
||
(loop (cdr parents)
|
||
(+ index
|
||
(apply + (map condition-type-all-fields
|
||
parent))))))
|
||
(else
|
||
(let ((shift (length (condition-type-all-fields parent))))
|
||
(loop (cdr parents)
|
||
(+ index shift))))))))
|
||
|
||
(define (list-fields start-index field-names)
|
||
;; Return a list of the form `(FIELD-NAME VALUE...)'.
|
||
(let loop ((index start-index)
|
||
(field-names field-names)
|
||
(result '()))
|
||
(if (null? field-names)
|
||
(reverse! result)
|
||
(loop (+ 1 index)
|
||
(cdr field-names)
|
||
(cons* (struct-ref c index)
|
||
(car field-names)
|
||
result)))))
|
||
|
||
(if (and (condition? c) (condition-type? type))
|
||
(let* ((ct (condition-type c))
|
||
(parent (condition-type-parent ct)))
|
||
(cond ((eq? type ct)
|
||
c)
|
||
((pair? parent)
|
||
;; C is a compound condition.
|
||
(let ((field-index (first-field-index parent)))
|
||
;;(format #t "field-index: ~a ~a~%" field-index
|
||
;; (list-fields field-index
|
||
;; (condition-type-all-fields type)))
|
||
(apply make-condition type
|
||
(list-fields field-index
|
||
(condition-type-all-fields type)))))
|
||
(else
|
||
;; C does not have type TYPE.
|
||
#f)))
|
||
(throw 'wrong-type-arg "extract-condition"
|
||
"Wrong type argument")))
|
||
|
||
|
||
;;;
|
||
;;; Syntax.
|
||
;;;
|
||
|
||
(define-macro (define-condition-type name parent pred . field-specs)
|
||
`(begin
|
||
(define ,name
|
||
(make-condition-type ',name ,parent
|
||
',(map car field-specs)))
|
||
(define (,pred c)
|
||
(condition-has-type? c ,name))
|
||
,@(map (lambda (field-spec)
|
||
(let ((field-name (car field-spec))
|
||
(accessor (cadr field-spec)))
|
||
`(define (,accessor c)
|
||
(condition-ref c ',field-name))))
|
||
field-specs)))
|
||
|
||
(define-macro (condition . type-field-bindings)
|
||
(cond ((null? type-field-bindings)
|
||
(error "`condition' syntax error" type-field-bindings))
|
||
(else
|
||
;; the poor man's hygienic macro
|
||
(let ((mc (gensym "mc"))
|
||
(mcct (gensym "mcct")))
|
||
`(let ((,mc (@ (srfi srfi-35) make-condition))
|
||
(,mcct (@@ (srfi srfi-35) make-compound-condition-type)))
|
||
(,mc (,mcct 'compound (list ,@(map car type-field-bindings)))
|
||
,@(append-map (lambda (type-field-binding)
|
||
(append-map (lambda (field+value)
|
||
(let ((f (car field+value))
|
||
(v (cadr field+value)))
|
||
`(',f ,v)))
|
||
(cdr type-field-binding)))
|
||
type-field-bindings)))))))
|
||
|
||
|
||
;;;
|
||
;;; Standard condition types.
|
||
;;;
|
||
|
||
(define &condition
|
||
;; The root condition type.
|
||
(make-struct %condition-type-vtable 0
|
||
(make-struct-layout "")
|
||
(lambda (c port)
|
||
(display "<&condition>"))
|
||
'&condition #f '() '()))
|
||
|
||
(define-condition-type &message &condition
|
||
message-condition?
|
||
(message condition-message))
|
||
|
||
(define-condition-type &serious &condition
|
||
serious-condition?)
|
||
|
||
(define-condition-type &error &serious
|
||
error?)
|
||
|
||
|
||
;;; Local Variables:
|
||
;;; coding: latin-1
|
||
;;; End:
|
||
|
||
;;; srfi-35.scm ends here
|