Added SRFI-35 files.

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 <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

test-suite/tests/srfi-35.test

@@ -0,0 +1,310 @@
+;;;; srfi-35.test --- Test suite for SRFI-35               -*- Scheme -*-
+;;;; Ludovic Courtès <ludo@gnu.org>
+;;;;
+;;;; 	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")))
+