Hi,
I'm willing to install the attached patch soon: it adds support for
SRFI-35.
Guile-Lib already contains an implementation (by Andreas Rottmann).
However, it's based on GOOPS, which I wanted to avoid, so I "rolled my
own", using bare structs.
Running `srfi-35.test' is roughly 3 times faster with the struct-based
version than with the GOOPS-based version (part of which is due to the
loading time of GOOPS itself). I also measured the time taken to create
a condition type using the following snipped:
(use-modules (srfi srfi-35))
(let loop ((i 1000))
(if (<= i 0)
#t
(let ((top (make-condition-type 'top &condition '(a b c))))
(make-condition-type 'bottom top '(d e f))
(loop (1- i)))))
With the GOOPS-based version, we get:
$ time guile ,,srfi-35-prof.scm
real 0m10.251s
user 0m9.825s
sys 0m0.012s
With the struct-based version:
$ time guile -L . ,,srfi-35-prof.scm
real 0m0.077s
user 0m0.072s
sys 0m0.004s
So it has the potential to improve the startup time of SRFI-35-using
programs. ;-)
That's also an indication that it may be worth profiling `make-class'
(which is used by `make-condition-type' and Andreas' implementation).
If you have Guile-Lib installed, note that Guile-Lib's implementation
will still be used because the `site' directory appears before Guile's
directory in `%load-path'.
Thanks,
Ludovic.
--- orig/doc/ref/srfi-modules.texi
+++ mod/doc/ref/srfi-modules.texi
@@ -37,6 +37,8 @@
* SRFI-19:: Time/Date library.
* SRFI-26:: Specializing parameters
* SRFI-31:: A special form `rec' for recursive evaluation
+* SRFI-34:: Exception handling.
+* SRFI-35:: Conditions.
* SRFI-37:: args-fold program argument processor
* SRFI-39:: Parameter objects
* SRFI-55:: Requiring Features.
@@ -2402,6 +2404,196 @@
@end lisp
[EMAIL PROTECTED] SRFI-34
[EMAIL PROTECTED] SRFI-34 - Exception handling for programs
+
[EMAIL PROTECTED] SRFI-34
+Guile provides an implementation of
[EMAIL PROTECTED]://srfi.schemers.org/srfi-34/srfi-34.html, SRFI-34's exception
+handling mechanisms} as an alternative to its own built-in mechanisms
+(@pxref{Exceptions}). It can be made available as follows:
+
[EMAIL PROTECTED]
+(use-modules (srfi srfi-34))
[EMAIL PROTECTED] lisp
+
[EMAIL PROTECTED] FIXME: Document it.
+
+
[EMAIL PROTECTED] SRFI-35
[EMAIL PROTECTED] SRFI-35 - Conditions
+
[EMAIL PROTECTED] SRFI-35
[EMAIL PROTECTED] conditions
[EMAIL PROTECTED] exceptions
+
[EMAIL PROTECTED]://srfi.schemers.org/srfi-35/srfi-35.html, SRFI-35} implements
[EMAIL PROTECTED], a data structure akin to records designed to convey
+information about exceptional conditions between parts of a program. It
+is normally used in conjunction with SRFI-34's @code{raise}:
+
[EMAIL PROTECTED]
+(raise (condition (&message
+ (message "An error occurred"))))
[EMAIL PROTECTED] lisp
+
+Users can define @dfn{condition types} containing arbitrary information.
+Condition types may inherit from one another. This allows the part of
+the program that handles (or ``catches'') conditions to get accurate
+information about the exceptional condition that arose.
+
+SRFI-35 conditions are made available using:
+
[EMAIL PROTECTED]
+(use-modules (srfi srfi-35))
[EMAIL PROTECTED] lisp
+
+The procedures available to manipulate condition types are the
+following:
+
[EMAIL PROTECTED] {Scheme Procedure} make-condition-type id parent field-names
+Return a new condition type named @var{id}, inheriting from
[EMAIL PROTECTED], and with the fields whose names are listed in
[EMAIL PROTECTED] @var{field-names} must be a list of symbols and must
+not contain names already used by @var{parent} or one of its supertypes.
[EMAIL PROTECTED] deffn
+
[EMAIL PROTECTED] {Scheme Procedure} condition-type? obj
+Return true if @var{obj} is a condition type.
[EMAIL PROTECTED] deffn
+
+Conditions can be created and accessed with the following procedures:
+
[EMAIL PROTECTED] {Scheme Procedure} make-condition type . field+value
+Return a new condition of type @var{type} with fields initialized as
+specified by @var{field+value}, a sequence of field names (symbols) and
+values as in the following example:
+
[EMAIL PROTECTED]
+(let* ((&ct (make-condition-type 'foo &condition '(a b c))))
+ (make-condition &ct 'a 1 'b 2 'c 3))
[EMAIL PROTECTED] lisp
+
+Note that all fields of @var{type} and its supertypes must be specified.
[EMAIL PROTECTED] deffn
+
[EMAIL PROTECTED] {Scheme Procedure} make-compound-condition . conditions
+Return a new compound condition composed of @var{conditions}. The
+returned condition has the type of each condition of @var{conditions}
+(per @code{condition-has-type?}).
[EMAIL PROTECTED] deffn
+
[EMAIL PROTECTED] {Scheme Procedure} condition-has-type? c type
+Return true if condition @var{c} has type @var{type}.
[EMAIL PROTECTED] deffn
+
[EMAIL PROTECTED] {Scheme Procedure} condition-ref c field-name
+Return the value of the field named @var{field-name} from condition @var{c}.
+
+If @var{c} is a compound condition and several underlying condition
+types contain a field named @var{field-name}, then the value of the
+first such field is returned, using the order in which conditions were
+passed to @var{make-compound-condition}.
[EMAIL PROTECTED] deffn
+
[EMAIL PROTECTED] {Scheme Procedure} extract-condition c type
+Return a condition of condition type @var{type} with the field values
+specified by @var{c}.
+
+If @var{c} is a compound condition, extract the field values from the
+subcondition belonging to @var{type} that appeared first in the call to
[EMAIL PROTECTED] that created the the condition.
[EMAIL PROTECTED] deffn
+
+Convenience macros are also available to create condition types and
+conditions.
+
[EMAIL PROTECTED] {library syntax} define-condition-type type supertype predicate field-spec...
+Define a new condition type named @var{type} that inherits from
[EMAIL PROTECTED] In addition, bind @var{predicate} to a type predicate
+that returns true when passed a condition of type @var{type} or any of
+its subtypes. @var{field-spec} must have the form @code{(field
+accessor)} where @var{field} is the name of field of @var{type} and
[EMAIL PROTECTED] is the name of a procedure to access field @var{field} in
+conditions of type @var{type}.
+
+The example below defines condition type @code{&foo}, inheriting from
[EMAIL PROTECTED]&condition} with fields @code{a}, @code{b} and @code{c}:
+
[EMAIL PROTECTED]
+(define-condition-type &foo &condition
+ foo-condition?
+ (a foo-a)
+ (b foo-b)
+ (c foo-c))
[EMAIL PROTECTED] lisp
[EMAIL PROTECTED] deffn
+
[EMAIL PROTECTED] {library syntax} condition type-field-bindings...
+Return a new condition, or compound condition, initialized according to
[EMAIL PROTECTED] Each @var{type-field-binding} must have the
+form @code{(type field-specs...)}, where @var{type} is the name of a
+variable bound to condition type; each @var{field-spec} must have the
+form @code{(field-name value)} where @var{field-name} is a symbol
+denoting the field being initialized to @var{value}. As for
[EMAIL PROTECTED], all fields must be specified.
+
+The following example returns a simple condition:
+
[EMAIL PROTECTED]
+(condition (&message (message "An error occurred")))
[EMAIL PROTECTED] lisp
+
+The one below returns a compound condition:
+
[EMAIL PROTECTED]
+(condition (&message (message "An error occurred"))
+ (&serious))
[EMAIL PROTECTED] lisp
[EMAIL PROTECTED] deffn
+
+Finally, SRFI-35 defines a several standard condition types.
+
[EMAIL PROTECTED] &condition
+This condition type is the root of all condition types. It has no
+fields.
[EMAIL PROTECTED] defvar
+
[EMAIL PROTECTED] &message
+A condition type that carries a message describing the nature of the
+condition to humans.
[EMAIL PROTECTED] defvar
+
[EMAIL PROTECTED] {Scheme Procedure} message-condition? c
+Return true if @var{c} is of type @code{&message} or one of its
+subtypes.
[EMAIL PROTECTED] deffn
+
[EMAIL PROTECTED] {Scheme Procedure} condition-message c
+Return the message associated with message condition @var{c}.
[EMAIL PROTECTED] deffn
+
[EMAIL PROTECTED] &serious
+This type describes conditions serious enough that they cannot safely be
+ignored. It has no fields.
[EMAIL PROTECTED] defvar
+
[EMAIL PROTECTED] {Scheme Procedure} serious-condition? c
+Return true if @var{c} is of type @code{&serious} or one of its
+subtypes.
[EMAIL PROTECTED] deffn
+
[EMAIL PROTECTED] &error
+This condition describes errors, typically caused by something that has
+gone wrong in the interaction of the program with the external world or
+the user.
[EMAIL PROTECTED] defvar
+
[EMAIL PROTECTED] {Scheme Procedure} error? c
+Return true if @var{c} is of type @code{&error} or one of its subtypes.
[EMAIL PROTECTED] deffn
+
+
@node SRFI-37
@subsection SRFI-37 - args-fold
@cindex SRFI-37
--- orig/srfi/Makefile.am
+++ mod/srfi/Makefile.am
@@ -79,6 +79,7 @@
srfi-26.scm \
srfi-31.scm \
srfi-34.scm \
+ srfi-35.scm \
srfi-37.scm \
srfi-39.scm \
srfi-60.scm
--- orig/test-suite/Makefile.am
+++ mod/test-suite/Makefile.am
@@ -1,6 +1,6 @@
## Process this file with automake to produce Makefile.in.
##
-## Copyright 2001, 2002, 2003, 2004, 2005, 2006 Software Foundation, Inc.
+## Copyright 2001, 2002, 2003, 2004, 2005, 2006, 2007 Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -76,6 +76,7 @@
tests/srfi-26.test \
tests/srfi-31.test \
tests/srfi-34.test \
+ tests/srfi-35.test \
tests/srfi-37.test \
tests/srfi-39.test \
tests/srfi-60.test \
--- /dev/null
+++ /home/ludo/src/laas/guile-core--cvs/,,[EMAIL PROTECTED]/new-files-archive/./srfi/srfi-35.scm
@@ -0,0 +1,329 @@
+;;; 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 <[EMAIL PROTECTED]>
+
+;;; 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
--- /dev/null
+++ /home/ludo/src/laas/guile-core--cvs/,,[EMAIL PROTECTED]/new-files-archive/./test-suite/tests/srfi-35.test
@@ -0,0 +1,310 @@
+;;;; srfi-35.test --- Test suite for SRFI-35 -*- Scheme -*-
+;;;; Ludovic Courtès <[EMAIL PROTECTED]>
+;;;;
+;;;; Copyright (C) 2007 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-srfi-35)
+ :use-module (test-suite lib)
+ :use-module (srfi srfi-35))
+
+
+(with-test-prefix "condition types"
+ (pass-if "&condition"
+ (condition-type? &condition))
+
+ (pass-if "make-condition-type"
+ (condition-type? (make-condition-type 'foo &condition '(a b)))))
+
+
+
+(with-test-prefix "conditions"
+
+ (pass-if "&condition"
+ (let ((c (make-condition &condition)))
+ (and (condition? c)
+ (condition-has-type? c &condition))))
+
+ (pass-if "simple condition"
+ (let* ((ct (make-condition-type 'chbouib &condition '(a b)))
+ (c (make-condition ct 'b 1 'a 0)))
+ (and (condition? c)
+ (condition-has-type? c ct))))
+
+ (pass-if "simple condition with inheritance"
+ (let* ((top (make-condition-type 'foo &condition '(a b)))
+ (ct (make-condition-type 'bar top '(c d)))
+ (c (make-condition ct 'a 1 'b 2 'c 3 'd 4)))
+ (and (condition? c)
+ (condition-has-type? c ct)
+ (condition-has-type? c top))))
+
+ (pass-if "condition-ref"
+ (let* ((ct (make-condition-type 'chbouib &condition '(a b)))
+ (c (make-condition ct 'b 1 'a 0)))
+ (and (eq? (condition-ref c 'a) 0)
+ (eq? (condition-ref c 'b) 1))))
+
+ (pass-if "condition-ref with inheritance"
+ (let* ((top (make-condition-type 'foo &condition '(a b)))
+ (ct (make-condition-type 'bar top '(c d)))
+ (c (make-condition ct 'b 1 'a 0 'd 3 'c 2)))
+ (and (eq? (condition-ref c 'a) 0)
+ (eq? (condition-ref c 'b) 1)
+ (eq? (condition-ref c 'c) 2)
+ (eq? (condition-ref c 'd) 3))))
+
+ (pass-if "extract-condition"
+ (let* ((ct (make-condition-type 'chbouib &condition '(a b)))
+ (c (make-condition ct 'b 1 'a 0)))
+ (equal? c (extract-condition c ct)))))
+
+
+(with-test-prefix "compound conditions"
+ (pass-if "condition-has-type?"
+ (let* ((t1 (make-condition-type 'foo &condition '(a b)))
+ (t2 (make-condition-type 'bar &condition '(c d)))
+ (c1 (make-condition t1 'a 0 'b 1))
+ (c2 (make-condition t2 'c 2 'd 3))
+ (c (make-compound-condition c1 c2)))
+ (and (condition? c)
+ (condition-has-type? c t1)
+ (condition-has-type? c t2))))
+
+ (pass-if "condition-ref"
+ (let* ((t1 (make-condition-type 'foo &condition '(a b)))
+ (t2 (make-condition-type 'bar &condition '(c d)))
+ (c1 (make-condition t1 'a 0 'b 1))
+ (c2 (make-condition t2 'c 2 'd 3))
+ (c (make-compound-condition c1 c2)))
+ (equal? (map (lambda (field)
+ (condition-ref c field))
+ '(a b c d))
+ '(0 1 2 3))))
+
+ (pass-if "condition-ref with same-named fields"
+ (let* ((t1 (make-condition-type 'foo &condition '(a b)))
+ (t2 (make-condition-type 'bar &condition '(a c d)))
+ (c1 (make-condition t1 'a 0 'b 1))
+ (c2 (make-condition t2 'a -1 'c 2 'd 3))
+ (c (make-compound-condition c1 c2)))
+ (equal? (map (lambda (field)
+ (condition-ref c field))
+ '(a b c d))
+ '(0 1 2 3))))
+
+ (pass-if "extract-condition"
+ (let* ((t1 (make-condition-type 'foo &condition '(a b)))
+ (t2 (make-condition-type 'bar &condition '(c d)))
+ (c1 (make-condition t1 'a 0 'b 1))
+ (c2 (make-condition t2 'c 2 'd 3))
+ (c (make-compound-condition c1 c2)))
+ (and (equal? c1 (extract-condition c t1))
+ (equal? c2 (extract-condition c t2)))))
+
+ (pass-if "extract-condition with same-named fields"
+ (let* ((t1 (make-condition-type 'foo &condition '(a b)))
+ (t2 (make-condition-type 'bar &condition '(a c)))
+ (c1 (make-condition t1 'a 0 'b 1))
+ (c2 (make-condition t2 'a -1 'c 2))
+ (c (make-compound-condition c1 c2)))
+ (and (equal? c1 (extract-condition c t1))
+ (equal? c2 (extract-condition c t2))))))
+
+
+
+(with-test-prefix "syntax"
+ (pass-if "define-condition-type"
+ (let ((m (current-module)))
+ (eval '(define-condition-type &chbouib &condition
+ chbouib?
+ (one chbouib-one)
+ (two chbouib-two))
+ m)
+ (eval '(and (condition-type? &chbouib)
+ (procedure? chbouib?)
+ (let ((c (make-condition &chbouib 'one 1 'two 2)))
+ (and (condition? c)
+ (chbouib? c)
+ (eq? (chbouib-one c) 1)
+ (eq? (chbouib-two c) 2))))
+ m)))
+
+ (pass-if "condition"
+ (let* ((t (make-condition-type 'chbouib &condition '(a b)))
+ (c (condition (t (b 2) (a 1)))))
+ (and (condition? c)
+ (condition-has-type? c t)
+ (equal? (map (lambda (f)
+ (condition-ref c f))
+ '(a b))
+ '(1 2)))))
+
+ (pass-if-exception "condition with missing fields"
+ exception:miscellaneous-error
+ (let ((t (make-condition-type 'chbouib &condition '(a b c))))
+ (condition (t (a 1) (b 2)))))
+
+ (pass-if "compound condition"
+ (let* ((t1 (make-condition-type 'foo &condition '(a b)))
+ (t2 (make-condition-type 'bar &condition '(c d)))
+ (c1 (make-condition t1 'a 0 'b 1))
+ (c2 (make-condition t2 'c 2 'd 3))
+ (c (condition (t1 (a 0) (b 1))
+ (t2 (c 2) (d 3)))))
+ (and (equal? c1 (extract-condition c t1))
+ (equal? c2 (extract-condition c t2))))))
+
+
+;;;
+;;; Examples from the SRFI.
+;;;
+
+(define-condition-type &c &condition
+ c?
+ (x c-x))
+
+(define-condition-type &c1 &c
+ c1?
+ (a c1-a))
+
+(define-condition-type &c2 &c
+ c2?
+ (b c2-b))
+
+(define v1
+ (make-condition &c1 'x "V1" 'a "a1"))
+
+(define v2
+ (condition (&c2 (x "V2") (b "b2"))))
+
+(define v3
+ (condition (&c1 (x "V3/1") (a "a3"))
+ (&c2 (b "b3"))))
+
+(define v4
+ (make-compound-condition v1 v2))
+
+(define v5
+ (make-compound-condition v2 v3))
+
+
+(with-test-prefix "examples"
+
+ (pass-if "v1"
+ (condition? v1))
+
+ (pass-if "(c? v1)"
+ (c? v1))
+
+ (pass-if "(c1? v1)"
+ (c1? v1))
+
+ (pass-if "(not (c2? v1))"
+ (not (c2? v1)))
+
+ (pass-if "(c-x v1)"
+ (equal? (c-x v1) "V1"))
+
+ (pass-if "(c1-a v1)"
+ (equal? (c1-a v1) "a1"))
+
+
+ (pass-if "v2"
+ (condition? v2))
+
+ (pass-if "(c? v2)"
+ (c? v2))
+
+ (pass-if "(c2? v2)"
+ (c2? v2))
+
+ (pass-if "(not (c1? v2))"
+ (not (c1? v2)))
+
+ (pass-if "(c-x v2)"
+ (equal? (c-x v2) "V2"))
+
+ (pass-if "(c2-b v2)"
+ (equal? (c2-b v2) "b2"))
+
+
+ (pass-if "v3"
+ (condition? v3))
+
+ (pass-if "(c? v3)"
+ (c? v3))
+
+ (pass-if "(c1? v3)"
+ (c1? v3))
+
+ (pass-if "(c2? v3)"
+ (c2? v3))
+
+ (pass-if "(c-x v3)"
+ (equal? (c-x v3) "V3/1"))
+
+ (pass-if "(c1-a v3)"
+ (equal? (c1-a v3) "a3"))
+
+ (pass-if "(c2-b v3)"
+ (equal? (c2-b v3) "b3"))
+
+
+ (pass-if "v4"
+ (condition? v4))
+
+ (pass-if "(c? v4)"
+ (c? v4))
+
+ (pass-if "(c1? v4)"
+ (c1? v4))
+
+ (pass-if "(c2? v4)"
+ (c2? v4))
+
+ (pass-if "(c-x v4)"
+ (equal? (c-x v4) "V1"))
+
+ (pass-if "(c1-a v4)"
+ (equal? (c1-a v4) "a1"))
+
+ (pass-if "(c2-b v4)"
+ (equal? (c2-b v4) "b2"))
+
+
+ (pass-if "v5"
+ (condition? v5))
+
+ (pass-if "(c? v5)"
+ (c? v5))
+
+ (pass-if "(c1? v5)"
+ (c1? v5))
+
+ (pass-if "(c2? v5)"
+ (c2? v5))
+
+ (pass-if "(c-x v5)"
+ (equal? (c-x v5) "V2"))
+
+ (pass-if "(c1-a v5)"
+ (equal? (c1-a v5) "a3"))
+
+ (pass-if "(c2-b v5)"
+ (equal? (c2-b v5) "b2")))
+
_______________________________________________
Guile-devel mailing list
Guile-devel@gnu.org
http://lists.gnu.org/mailman/listinfo/guile-devel
