[Guile-commits] GNU Guile branch, master, updated. release_1-9-13-105-gc0f6c16

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=c0f6c1638bb920d5cf5ec3210d91bc9fb0c70319

The branch, master has been updated
       via  c0f6c1638bb920d5cf5ec3210d91bc9fb0c70319 (commit)
      from  43ecaffc2f564dbb03af446671097a548378df82 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit c0f6c1638bb920d5cf5ec3210d91bc9fb0c70319
Author: Andreas Rottmann <address@hidden>
Date:   Thu Nov 25 23:03:12 2010 +0100

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

-----------------------------------------------------------------------

Summary of changes:
 module/rnrs/base.scm                  |   30 ++++++++++++++++++++++++------
 module/rnrs/conditions.scm            |   15 ++++-----------
 module/rnrs/records/inspection.scm    |   30 ++++++++++++++++--------------
 module/rnrs/records/syntactic.scm     |   10 ++++++----
 test-suite/tests/r6rs-conditions.test |   14 +++++++++++++-
 5 files changed, 63 insertions(+), 36 deletions(-)

diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm
index 6320420..a6ae1b9 100644
--- a/module/rnrs/base.scm
+++ b/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
@@ -145,12 +147,28 @@
    (@ (rnrs conditions) make-message-condition))
  (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 (condition
-           (make-assertion-violation)
-           (make-who-condition who)
-           (make-message-condition message)
-           (make-irritants-condition 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-message-condition
+                   (format #f "assertion failed: ~s" 'expression))))))))
 
 )
diff --git a/module/rnrs/conditions.scm b/module/rnrs/conditions.scm
index 6885ada..959411b 100644
--- a/module/rnrs/conditions.scm
+++ b/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)))
-              ((_ ((f a))) '((immutable f a)))
-              ((_ ()) '())
+               (cons '(immutable f a) (transform-fields . rest)))
               ((_) '())))
 
            (generate-accessors
@@ -140,13 +138,8 @@
                          (condition-accessor 
                           condition-type
                           (record-accessor condition-type counter)))
-                      (generate-accessors (+ counter 1) rest)))
-              ((_ counter ((f a)))
-               (define a 
-                  (condition-accessor 
-                   condition-type (record-accessor condition-type counter))))
-              ((_ counter ()) (begin))
-              ((_ counter) (begin)))))  
+                      (generate-accessors (+ counter 1) . rest)))
+              ((_ counter) (begin)))))
         (begin
           (define condition-type 
             (make-record-type-descriptor 
diff --git a/module/rnrs/records/inspection.scm 
b/module/rnrs/records/inspection.scm
index 315ef0c..68b78a9 100644
--- a/module/rnrs/records/inspection.scm
+++ b/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)
-    (if (not (record-type-descriptor? rtd)) (raise 
(make-assertion-violation))))
+  (define (guarantee-rtd who rtd)
+    (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))
-  (define (record-type-uid rtd) (ensure-rtd rtd) (struct-ref rtd 
rtd-index-uid))
+    (struct-ref (guarantee-rtd 'record-type-parent rtd) rtd-index-parent))
+  (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 rtd rtd-index-field-bit-field) k))
+    (bitwise-bit-set? (struct-ref (guarantee-rtd 'record-field-mutable? rtd)
+                                  rtd-index-field-bit-field)
+                      k))
 )
diff --git a/module/rnrs/records/syntactic.scm 
b/module/rnrs/records/syntactic.scm
index 5070212..6431fcf 100644
--- a/module/rnrs/records/syntactic.scm
+++ b/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 (error))))
+                    (else (lose)))))
+           (else (lose))))
     (map f fields))
   
   (define-syntax define-record-type0
diff --git a/test-suite/tests/r6rs-conditions.test 
b/test-suite/tests/r6rs-conditions.test
index 9432f37..7480b9c 100644
--- a/test-suite/tests/r6rs-conditions.test
+++ b/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)))))


hooks/post-receive
-- 
GNU Guile