[Guile-commits] GNU Guile branch, wip-r6rs-libraries, updated. release_1-9-8-91-g966b431

[Julian Graham]

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=966b4313d6d0223c7a7ab252f777f652c9a05d5a

The branch, wip-r6rs-libraries has been updated
       via  966b4313d6d0223c7a7ab252f777f652c9a05d5a (commit)
       via  dd97d9c7336fe3c3c8b9cd9513eb51234999cc28 (commit)
      from  60c40014aef5c8025558dd8f060624203222bf50 (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 966b4313d6d0223c7a7ab252f777f652c9a05d5a
Author: Julian Graham <address@hidden>
Date:   Sun Mar 28 19:40:16 2010 -0400

    Add R6RS `syntax-violation' to (rnrs syntax-case).
    
    * module/rnrs/6/exceptions.scm: Remove dependency on (rnrs syntax-case);
      rewrite guard and guard0 in using syntax-rules in terms of syntax-case.
    * module/rnrs/6/syntax-case.scm: Add syntax-violation implementation.

commit dd97d9c7336fe3c3c8b9cd9513eb51234999cc28
Author: Julian Graham <address@hidden>
Date:   Sun Mar 28 19:31:49 2010 -0400

    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.

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

Summary of changes:
 module/rnrs/6/conditions.scm          |  112 ++++++++++++++++----------------
 module/rnrs/6/exceptions.scm          |   29 ++++-----
 module/rnrs/6/syntax-case.scm         |   16 ++++-
 module/rnrs/records/6/procedural.scm  |    3 -
 test-suite/Makefile.am                |    1 +
 test-suite/tests/r6rs-conditions.test |   91 ++++++++++++++++++++++++++
 6 files changed, 174 insertions(+), 78 deletions(-)
 create mode 100644 test-suite/tests/r6rs-conditions.test

diff --git a/module/rnrs/6/conditions.scm b/module/rnrs/6/conditions.scm
index b6630c8..8ff2f34 100644
--- a/module/rnrs/6/conditions.scm
+++ b/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))
-         (rnrs records procedural (6))
-         (rnrs syntax-case (6)))
-         
+  (import (only (guile) and=>)
+         (rnrs base (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-syntax define-condition-type
-    (lambda (stx)
-      (syntax-case stx ()
-       ((_ condition-type supertype constructor predicate
-           (field accessor) ...)
-        (let*
-          ((fields (let* ((field-spec-syntax #'((field accessor) ...))
-                         (field-specs (syntax->datum field-spec-syntax)))
-                    (list->vector (map (lambda (field-spec)
-                                         (cons 'immutable field-spec))
-                                       field-specs))))
-           (fields-syntax (datum->syntax stx fields)))
-         #`(begin
-             (define condition-type 
-               (make-record-type-descriptor 
-                #,(datum->syntax
-                   stx (list 'quote (syntax->datum #'condition-type)))
-                supertype #f #f #f #,fields-syntax))
-             (define constructor
-               (record-constructor 
-                (make-record-constructor-descriptor condition-type #f #f)))
-             (define predicate (record-predicate condition-type))
-             #,@(let f ((accessors '())
-                        (counter 0))
-                  (if (>= counter (vector-length fields))
-                      accessors
-                      (f (cons #`(define #,(datum->syntax 
-                                            stx (caddr (vector-ref fields 
-                                                                   counter)))
-                                   (record-accessor condition-type #,counter))
-                               accessors)
-                         (+ counter 1))))))))))
-                      
-  (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? obj) 
+    (or (compound-condition? obj) (condition-internal? obj)))
 
   (define condition
     (lambda conditions
       (define (flatten cond)
-       (if (compound-condition? cond)
-           (fold append '() (map flatten (compound-condition-components cond)))
-           cond))
+       (if (compound-condition? cond) (simple-conditions cond) (list cond)))
       (or (for-all condition? conditions)
          (raise (make-assertion-violation)))
-      (make-compound-condition (flatten conditions))))
+      (if (or (null? conditions) (> (length conditions) 1))
+         (make-compound-condition (apply append (map flatten conditions)))
+         (car conditions))))
+  
+  (define-syntax define-condition-type
+    (syntax-rules ()
+      ((_ condition-type supertype constructor predicate
+         (field accessor) ...)
+       (letrec-syntax
+          ((transform-fields
+            (syntax-rules ()
+              ((_ (f a) . rest)
+               (cons '(immutable f a) (transform-fields rest)))
+              ((_ ((f a))) '((immutable f a)))
+              ((_ ()) '())
+              ((_) '())))
+
+           (generate-accessors
+            (syntax-rules ()
+              ((_ counter (f a) . rest)
+               (begin (define a (record-accessor condition-type counter))
+                      (generate-accessors (+ counter 1) rest)))
+              ((_ counter ((f a)))
+               (define a (record-accessor condition-type counter)))
+              ((_ counter ()) (begin))
+              ((_ counter) (begin)))))  
+        (begin
+          (define condition-type 
+            (make-record-type-descriptor 
+             'condition-type supertype #f #f #f 
+             (list->vector (transform-fields (field accessor) ...))))
+          (define constructor
+            (record-constructor 
+             (make-record-constructor-descriptor condition-type #f #f)))
+          (define predicate (condition-predicate condition-type))
+          (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 (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? 
-    (@@ (rnrs records procedural) assertion-violation?))
+  (define assertion-violation? (condition-predicate &assertion))
 
   (define-condition-type &irritants &condition 
     make-irritants-condition irritants-condition?
diff --git a/module/rnrs/6/exceptions.scm b/module/rnrs/6/exceptions.scm
index 87dfe70..70526f5 100644
--- a/module/rnrs/6/exceptions.scm
+++ b/module/rnrs/6/exceptions.scm
@@ -22,7 +22,6 @@
   (import (rnrs base (6))
           (rnrs conditions (6))
          (rnrs records procedural (6))
-         (rnrs syntax-case (6))
          (only (guile) with-throw-handler))
 
   (define raise (@@ (rnrs records procedural) r6rs-raise))
@@ -51,22 +50,18 @@
           *unspecified*))))
 
   (define-syntax guard0
-    (lambda (stx)
-      (syntax-case stx ()
-       ((_ (variable cond-clause ...) body)
-        (syntax (call/cc (lambda (continuation)
-                           (with-exception-handler
-                            (lambda (variable)
-                              (continuation (cond cond-clause ...)))
-                            (lambda () body)))))))))
+    (syntax-rules ()
+      ((_ (variable cond-clause ...) body)
+       (call/cc (lambda (continuation)
+                 (with-exception-handler
+                  (lambda (variable)
+                    (continuation (cond cond-clause ...)))
+                  (lambda () body)))))))
 
   (define-syntax guard
-    (lambda (stx)
-      (syntax-case stx (else)
-       ((_ (variable cond-clause ... . ((else else-clause ...))) body)
-        (syntax (guard0 (variable cond-clause ... (else else-clause ...))
-                        body)))
-       ((_ (variable cond-clause ...) body)
-        (syntax (guard0 (variable cond-clause ... (else (raise variable)))
-                        body))))))
+    (syntax-rules (else)
+      ((_ (variable cond-clause ... . ((else else-clause ...))) body)
+       (guard0 (variable cond-clause ... (else else-clause ...)) body))
+      ((_ (variable cond-clause ...) body)
+       (guard0 (variable cond-clause ... (else (raise variable))) body))))
 )
diff --git a/module/rnrs/6/syntax-case.scm b/module/rnrs/6/syntax-case.scm
index 91ca600..6aa1cef 100644
--- a/module/rnrs/6/syntax-case.scm
+++ b/module/rnrs/6/syntax-case.scm
@@ -50,6 +50,18 @@
 
                        quasisyntax
                        unsyntax
-                       unsyntax-splicing
+                       unsyntax-splicing)
+         (ice-9 optargs)
+         (rnrs base (6))
+         (rnrs conditions (6))
+         (rnrs exceptions (6))
+         (rnrs records procedural (6)))
 
-                       syntax-violation)))
+  (define* (syntax-violation who message form #:optional subform)
+    (let* ((conditions (list (make-message-condition message)
+                            (make-syntax-violation form subform)))
+          (conditions (if who
+                          (cons (make-who-condition who) conditions)
+                          conditions)))
+      (raise (apply condition conditions))))
+)
diff --git a/module/rnrs/records/6/procedural.scm 
b/module/rnrs/records/6/procedural.scm
index da30fa4..bd1d0d1 100644
--- a/module/rnrs/records/6/procedural.scm
+++ b/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
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 9cfacc7..3019d85 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -71,6 +71,7 @@ SCM_TESTS = tests/alist.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               \
diff --git a/test-suite/tests/r6rs-conditions.test 
b/test-suite/tests/r6rs-conditions.test
new file mode 100644
index 0000000..5883131
--- /dev/null
+++ b/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"))))


hooks/post-receive
-- 
GNU Guile