Some tweaks to the R6RS support

* module/rnrs/base.scm (error, assert): Define -- they were missing.
  (assertion-violation): Properly treat a #f `who' argument.

* module/rnrs/conditions.scm (condition): Use `assertion-violation'
  instead of the undefined `raise'.
  (define-condition-type): Fix for multiple fields.
* test-suite/tests/r6rs-conditions.test: Test accessors of a
  multiple-field condition.  Also import `(rnrs base)' to allow
  stand-alone running of the tests; apparently the `@' references
  scattered throughout the R6RS modules make the libraries sensitive to
  their load order -- for instance, trying to load `(rnrs conditions)'
  before `(rnrs base)' is loaded fails.

* module/rnrs/records/inspection.scm: Use `assertion-violation' instead
  of an explicit `raise'.
* module/rnrs/records/syntactic.scm (process-fields): Use
  `syntax-violation' instead of bogus invocations of `error'.

module/rnrs/base.scm

@@ -73,7 +73,7 @@
 	  let-syntax letrec-syntax
 
 	  syntax-rules identifier-syntax)
-  (import (rename (guile) 
+  (import (rename (except (guile) error raise)
                   (quotient div) 
                   (modulo mod)
                   (exact->inexact inexact)
@@ -137,6 +137,8 @@
    (@ (rnrs exceptions) raise))
  (define condition
    (@ (rnrs conditions) condition))
+ (define make-error
+   (@ (rnrs conditions) make-error))
  (define make-assertion-violation
    (@ (rnrs conditions) make-assertion-violation))
  (define make-who-condition
@@ -146,11 +148,27 @@
  (define make-irritants-condition
    (@ (rnrs conditions) make-irritants-condition))
 
+ (define (error who message . irritants)
+   (raise (apply condition
+                 (append (list (make-error))
+                         (if who (list (make-who-condition who)) '())
+                         (list (make-message-condition message)
+                               (make-irritants-condition irritants))))))
+ 
  (define (assertion-violation who message . irritants)
+   (raise (apply condition
+                 (append (list (make-assertion-violation))
+                         (if who (list (make-who-condition who)) '())
+                         (list (make-message-condition message)
+                               (make-irritants-condition irritants))))))
+
+ (define-syntax assert
+   (syntax-rules ()
+     ((_ expression)
+      (if (not expression)
           (raise (condition
                   (make-assertion-violation)
-           (make-who-condition who)
+                  (make-message-condition
-           (make-message-condition message)
+                   (format #f "assertion failed: ~s" 'expression))))))))
-           (make-irritants-condition irritants))))
 
 )

module/rnrs/conditions.scm

@@ -115,7 +115,7 @@
       (define (flatten cond)
 	(if (compound-condition? cond) (simple-conditions cond) (list cond)))
       (or (for-all condition? conditions)
-	  (raise (make-assertion-violation)))
+	  (assertion-violation 'condition "non-condition argument" conditions))
       (if (or (null? conditions) (> (length conditions) 1))
 	  (make-compound-condition (apply append (map flatten conditions)))
 	  (car conditions))))
@@ -128,9 +128,7 @@
 	   ((transform-fields
 	     (syntax-rules ()
 	       ((_ (f a) . rest)
-		(cons '(immutable f a) (transform-fields rest)))
+		(cons '(immutable f a) (transform-fields . rest)))
-	       ((_ ((f a))) '((immutable f a)))
-	       ((_ ()) '())
 	       ((_) '())))
 
 	    (generate-accessors
@@ -140,12 +138,7 @@
                          (condition-accessor 
                           condition-type
                           (record-accessor condition-type counter)))
-		       (generate-accessors (+ counter 1) rest)))
+		       (generate-accessors (+ counter 1) . rest)))
-	       ((_ counter ((f a)))
-		(define a 
-                  (condition-accessor 
-                   condition-type (record-accessor condition-type counter))))
-	       ((_ counter ()) (begin))
 	       ((_ counter) (begin)))))
 	 (begin
 	   (define condition-type 

module/rnrs/records/inspection.scm

@@ -30,8 +30,6 @@
 	  record-field-mutable?)
   (import (rnrs arithmetic bitwise (6))
           (rnrs base (6))
-	  (rnrs conditions (6))
-          (rnrs exceptions (6))
 	  (rnrs records procedural (6))
 	  (only (guile) struct-ref struct-vtable vtable-index-layout @@))
 
@@ -55,25 +53,29 @@
     (or (and (record-internal? record)
 	     (let ((rtd (struct-vtable record)))
 	       (and (not (struct-ref rtd rtd-index-opaque?)) rtd)))
-	(raise (make-assertion-violation))))
+	(assertion-violation 'record-rtd "not a record" record)))
 
-  (define (ensure-rtd rtd)
+  (define (guarantee-rtd who rtd)
-    (if (not (record-type-descriptor? rtd)) (raise (make-assertion-violation))))
+    (if (record-type-descriptor? rtd)
+        rtd
+        (assertion-violation who "not a record type descriptor" rtd)))
 
   (define (record-type-name rtd) 
-    (ensure-rtd rtd) (struct-ref rtd rtd-index-name))
+    (struct-ref (guarantee-rtd 'record-type-name rtd) rtd-index-name))
   (define (record-type-parent rtd) 
-    (ensure-rtd rtd) (struct-ref rtd rtd-index-parent))
+    (struct-ref (guarantee-rtd 'record-type-parent rtd) rtd-index-parent))
-  (define (record-type-uid rtd) (ensure-rtd rtd) (struct-ref rtd rtd-index-uid))
+  (define (record-type-uid rtd)
+    (struct-ref (guarantee-rtd 'record-type-uid rtd) rtd-index-uid))
   (define (record-type-generative? rtd) 
-    (ensure-rtd rtd) (not (record-type-uid rtd)))
+    (not (record-type-uid (guarantee-rtd 'record-type-generative? rtd))))
   (define (record-type-sealed? rtd) 
-    (ensure-rtd rtd) (struct-ref rtd rtd-index-sealed?))
+    (struct-ref (guarantee-rtd 'record-type-sealed? rtd) rtd-index-sealed?))
   (define (record-type-opaque? rtd) 
-    (ensure-rtd rtd) (struct-ref rtd rtd-index-opaque?))
+    (struct-ref (guarantee-rtd 'record-type-opaque? rtd) rtd-index-opaque?))
   (define (record-type-field-names rtd)
-    (ensure-rtd rtd) (struct-ref rtd rtd-index-field-names))
+    (struct-ref (guarantee-rtd 'record-type-field-names rtd) rtd-index-field-names))
   (define (record-field-mutable? rtd k)
-    (ensure-rtd rtd)
+    (bitwise-bit-set? (struct-ref (guarantee-rtd 'record-field-mutable? rtd)
-    (bitwise-bit-set? (struct-ref rtd rtd-index-field-bit-field) k))
+                                  rtd-index-field-bit-field)
+                      k))
 )

module/rnrs/records/syntactic.scm

@@ -85,14 +85,16 @@
 	record-name-str "-" (symbol->string field-name) "-set!")))
     
     (define (f x)
+      (define (lose)
+        (syntax-violation 'define-record-type "invalid field specifier" x))
       (cond ((symbol? x) (list 'immutable x (guess-accessor-name x) #f))
-	    ((not (list? x)) (error))
+	    ((not (list? x)) (lose))
 	    ((eq? (car x) 'immutable)
 	     (cons 'immutable
 		   (case (length x)
 		     ((2) (list (cadr x) (guess-accessor-name (cadr x)) #f))
 		     ((3) (list (cadr x) (caddr x) #f))
-		     (else (error)))))
+		     (else (lose)))))
 	    ((eq? (car x) 'mutable)
 	     (cons 'mutable
 		   (case (length x)
@@ -100,8 +102,8 @@
 				(guess-accessor-name (cadr x))
 				(guess-mutator-name (cadr x))))
 		     ((4) (cdr x))
-		     (else (error)))))
+		     (else (lose)))))
-	    (else (error))))
+	    (else (lose))))
     (map f fields))
   
   (define-syntax define-record-type0

test-suite/tests/r6rs-conditions.test

@@ -18,11 +18,16 @@
 
 
 (define-module (test-suite test-rnrs-conditions)
+  :use-module ((rnrs base) :version (6))
   :use-module ((rnrs conditions) :version (6))
   :use-module (test-suite lib))
 
 (define-condition-type &a &condition make-a-condition a-condition? (foo a-foo))
 (define-condition-type &b &condition make-b-condition b-condition? (bar b-bar))
+(define-condition-type &c &condition make-c-condition c-condition?
+  (baz c-baz)
+  (qux c-qux)
+  (frobotz c-frobotz))
 
 (with-test-prefix "condition?"
   (pass-if "condition? is #t for simple conditions"
@@ -96,4 +101,11 @@
 (with-test-prefix "define-condition-type"
   (pass-if "define-condition-type produces proper accessors"
     (let ((c (condition (make-a-condition 'foo) (make-b-condition 'bar))))
-      (and (eq? (a-foo c) 'foo) (eq? (b-bar c) 'bar)))))
+      (and (eq? (a-foo c) 'foo) (eq? (b-bar c) 'bar))))
+  (pass-if "define-condition-type works for multiple fields"
+    (let ((c (condition (make-a-condition 'foo)
+                        (make-c-condition 1 2 3))))
+      (and (eq? (a-foo c) 'foo)
+           (= (c-baz c) 1)
+           (= (c-qux c) 2)
+           (= (c-frobotz c) 3)))))