Test suite and fixes for R6RS (rnrs conditions) and

(rnrs records procedural).

* module/rnrs/6/conditions.scm: Fix export of
  make-implementation-restriction-violation; remove dependency on
  (rnrs syntax-case); remove redundant function
  compound-condition-components; rewrite define-condition-type using
  syntax-rules instead of syntax-case.
* module/rnrs/records/6/procedural.scm: Remove serious-condition?,
  violation? and assertion-violation? predicates, since they're not true
  condition predicates.
* test-suite/Makefile.am: Add tests/r6rs-conditions.test to SCM_TESTS.
* test-suite/tests/r6rs-conditions.test: New file.

module/rnrs/6/conditions.scm

@@ -66,7 +66,7 @@
 	  non-continuable-violation?
 
 	  &implementation-restriction
-	  make-implementation-restriction
+	  make-implementation-restriction-violation
 	  implementation-restriction-violation?
 
 	  &lexical
@@ -82,10 +82,11 @@
 	  &undefined
 	  make-undefined-violation
 	  undefined-violation?)
-  (import (rnrs base (6))
+  (import (only (guile) and=>)
-	  (rnrs records procedural (6))
+	  (rnrs base (6))
-	  (rnrs syntax-case (6)))
+	  (rnrs lists (6))
-	  
+	  (rnrs records procedural (6)))
+
   (define &compound-condition (make-record-type-descriptor 
 			       '&compound-condition #f #f #f #f
 			       '#((immutable components))))
@@ -94,64 +95,64 @@
   (define make-compound-condition 
     (record-constructor (make-record-constructor-descriptor 
 			 &compound-condition #f #f)))
-  (define compound-condition-components (record-accessor &compound-condition 0))
+  (define simple-conditions (record-accessor &compound-condition 0))
 
+  (define (condition? obj) 
+    (or (compound-condition? obj) (condition-internal? obj)))
+
+  (define condition
+    (lambda conditions
+      (define (flatten cond)
+	(if (compound-condition? cond) (simple-conditions cond) (list cond)))
+      (or (for-all condition? conditions)
+	  (raise (make-assertion-violation)))
+      (if (or (null? conditions) (> (length conditions) 1))
+	  (make-compound-condition (apply append (map flatten conditions)))
+	  (car conditions))))
+  
   (define-syntax define-condition-type
-    (lambda (stx)
+    (syntax-rules ()
-      (syntax-case stx ()
+      ((_ condition-type supertype constructor predicate
-	((_ condition-type supertype constructor predicate
+	  (field accessor) ...)
-	    (field accessor) ...)
+       (letrec-syntax
-	 (let*
+	   ((transform-fields
-	   ((fields (let* ((field-spec-syntax #'((field accessor) ...))
+	     (syntax-rules ()
-			  (field-specs (syntax->datum field-spec-syntax)))
+	       ((_ (f a) . rest)
-		     (list->vector (map (lambda (field-spec)
+		(cons '(immutable f a) (transform-fields rest)))
-					  (cons 'immutable field-spec))
+	       ((_ ((f a))) '((immutable f a)))
-					field-specs))))
+	       ((_ ()) '())
-	    (fields-syntax (datum->syntax stx fields)))
+	       ((_) '())))
-	  #`(begin
+
-	      (define condition-type 
+	    (generate-accessors
-		(make-record-type-descriptor 
+	     (syntax-rules ()
-		 #,(datum->syntax
+	       ((_ counter (f a) . rest)
-		    stx (list 'quote (syntax->datum #'condition-type)))
+		(begin (define a (record-accessor condition-type counter))
-		 supertype #f #f #f #,fields-syntax))
+		       (generate-accessors (+ counter 1) rest)))
-	      (define constructor
+	       ((_ counter ((f a)))
-		(record-constructor 
+		(define a (record-accessor condition-type counter)))
-		 (make-record-constructor-descriptor condition-type #f #f)))
+	       ((_ counter ()) (begin))
-	      (define predicate (record-predicate condition-type))
+	       ((_ counter) (begin)))))	 
-	      #,@(let f ((accessors '())
+	 (begin
-			 (counter 0))
+	   (define condition-type 
-		   (if (>= counter (vector-length fields))
+	     (make-record-type-descriptor 
-		       accessors
+	      'condition-type supertype #f #f #f 
-		       (f (cons #`(define #,(datum->syntax 
+	      (list->vector (transform-fields (field accessor) ...))))
-					     stx (caddr (vector-ref fields 
+	   (define constructor
-								    counter)))
+	     (record-constructor 
-				    (record-accessor condition-type #,counter))
+	      (make-record-constructor-descriptor condition-type #f #f)))
-				accessors)
+	   (define predicate (condition-predicate condition-type))
-			  (+ counter 1))))))))))
+	   (generate-accessors 0 (field accessor) ...))))))
-		       
+
   (define &condition (@@ (rnrs records procedural) &condition))
   (define &condition-constructor-descriptor
     (make-record-constructor-descriptor &condition #f #f))
   (define condition-internal? (record-predicate &condition))
 
-  (define condition
-    (lambda conditions
-      (define (flatten cond)
-	(if (compound-condition? cond)
-	    (fold append '() (map flatten (compound-condition-components cond)))
-	    cond))
-      (or (for-all condition? conditions)
-	  (raise (make-assertion-violation)))
-      (make-compound-condition (flatten conditions))))
-
-  (define (simple-conditions condition) (record-accessor &compound-condition 0))
-  (define (condition? obj) 
-    (or (compound-condition? obj) (condition-internal? obj)))
   (define (condition-predicate rtd)
     (let ((rtd-predicate (record-predicate rtd)))
       (lambda (obj)
 	(cond ((compound-condition? obj) 
-	       (find rtd-predicate (compound-condition-components obj)))
+	       (exists rtd-predicate (simple-conditions obj)))
 	      ((condition-internal? obj) (rtd-predicate obj))
 	      (else #f)))))
 
@@ -160,7 +161,7 @@
       (lambda (obj)
 	(cond ((rtd-predicate obj) (proc obj))
 	      ((compound-condition? obj) 
-	       (and=> (find rtd-predicate simple-conditions obj) proc))
+	       (and=> (find rtd-predicate (simple-conditions obj)) proc))
 	      (else #f)))))
 
   (define-condition-type &message &condition 
@@ -172,19 +173,18 @@
   (define &serious (@@ (rnrs records procedural) &serious))
   (define make-serious-condition 
     (@@ (rnrs records procedural) make-serious-condition))
-  (define serious-condition? (@@ (rnrs records procedural) serious-condition?))
+  (define serious-condition? (condition-predicate &serious))
 
   (define-condition-type &error &serious make-error error?)
 
   (define &violation (@@ (rnrs records procedural) &violation))
   (define make-violation (@@ (rnrs records procedural) make-violation))
-  (define violation? (@@ (rnrs records procedural) violation?))
+  (define violation? (condition-predicate &violation))
 
   (define &assertion (@@ (rnrs records procedural) &assertion))
   (define make-assertion-violation 
     (@@ (rnrs records procedural) make-assertion-violation))
-  (define assertion-violation? 
+  (define assertion-violation? (condition-predicate &assertion))
-    (@@ (rnrs records procedural) assertion-violation?))
 
   (define-condition-type &irritants &condition 
     make-irritants-condition irritants-condition?

module/rnrs/records/6/procedural.scm

@@ -236,7 +236,6 @@
 
   (define make-serious-condition 
     (record-constructor &serious-constructor-descriptor))
-  (define serious-condition? (record-predicate &serious))
 
   (define &violation (make-record-type-descriptor
 		      '&violation &serious #f #f #f '#()))
@@ -244,7 +243,6 @@
     (make-record-constructor-descriptor 
      &violation &serious-constructor-descriptor #f))
   (define make-violation (record-constructor &violation-constructor-descriptor))
-  (define violation? (record-predicate &violation))
 
   (define &assertion (make-record-type-descriptor
 		      '&assertion &violation #f #f #f '#()))
@@ -252,7 +250,6 @@
     (record-constructor 
      (make-record-constructor-descriptor
       &assertion &violation-constructor-descriptor #f)))
-  (define assertion-violation? (record-predicate &assertion))
 
   ;; Exception wrapper type, along with a wrapping `throw' implementation.
   ;; These are used in the current library, and so they are defined here and not

test-suite/Makefile.am

@@ -77,6 +77,7 @@ SCM_TESTS = tests/00-initial-env.test		\
 	    tests/r4rs.test			\
 	    tests/r5rs_pitfall.test		\
 	    tests/r6rs-arithmetic-bitwise.test	\
+	    tests/r6rs-conditions.test		\
 	    tests/r6rs-control.test		\
 	    tests/r6rs-exceptions.test		\
 	    tests/r6rs-files.test		\

test-suite/tests/r6rs-conditions.test

@@ -0,0 +1,91 @@
+;;; r6rs-conditions.test --- Test suite for R6RS (rnrs conditions)
+
+;;      Copyright (C) 2010 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 3 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
+
+
+(define-module (test-suite test-rnrs-conditions)
+  :use-module ((rnrs conditions) :version (6))
+  :use-module (test-suite lib))
+
+(with-test-prefix "condition?"
+  (pass-if "condition? is #t for simple conditions"
+    (condition? (make-error)))
+
+  (pass-if "condition? is #t for compound conditions"
+    (condition? (condition (make-error) (make-assertion-violation))))
+
+  (pass-if "condition? is #f for non-conditions"
+    (not (condition? 'foo))))
+
+(with-test-prefix "simple-conditions"
+  (pass-if "simple-conditions returns condition components"
+    (let* ((error (make-error))
+	   (assertion (make-assertion-violation))
+	   (c (condition error assertion))
+	   (scs (simple-conditions c)))
+      (equal? scs (list error assertion))))
+
+  (pass-if "simple-conditions flattens compound conditions"
+    (let* ((implementation-restriction 
+	    (make-implementation-restriction-violation))
+	   (error1 (make-error))
+	   (c1 (condition implementation-restriction error1))
+	   (error2 (make-error))
+	   (assertion (make-assertion-violation))
+	   (c2 (condition error2 assertion c1))
+	   (scs (simple-conditions c2)))
+      (equal? scs (list error2 assertion implementation-restriction error1)))))
+
+(with-test-prefix "condition-predicate"
+  (pass-if "returned procedure identifies matching simple conditions"
+    (let ((mp (condition-predicate &message))
+	  (mc (make-message-condition "test")))
+      (mp mc)))
+
+  (pass-if "returned procedure identifies matching compound conditions"
+    (let* ((sp (condition-predicate &serious))
+	   (vp (condition-predicate &violation))
+	   (sc (make-serious-condition))
+	   (vc (make-violation))
+	   (c (condition sc vc)))
+      (and (sp c) (vp c))))
+
+  (pass-if "returned procedure is #f for non-matching simple"
+    (let ((sp (condition-predicate &serious)))
+      (not (sp 'foo))))
+
+  (pass-if "returned procedure is #f for compound without match"
+    (let* ((ip (condition-predicate &irritants))
+	   (sc (make-serious-condition))
+	   (vc (make-violation))
+	   (c (condition sc vc)))
+      (not (ip c)))))
+
+(with-test-prefix "condition-accessor"
+  (pass-if "accessor applies proc to field from simple condition"
+    (let* ((proc (lambda (c) (condition-message c)))
+	   (ma (condition-accessor &message proc))
+	   (mc (make-message-condition "foo")))
+      (equal? (ma mc) "foo")))
+
+  (pass-if "accessor applies proc to field from compound condition"
+    (let* ((proc (lambda (c) (condition-message c)))
+	   (ma (condition-accessor &message proc))
+	   (mc (make-message-condition "foo"))
+	   (vc (make-violation))
+	   (c (condition vc mc)))
+      (equal? (ma c) "foo"))))