guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, wip-r6rs-libraries, updated. release_1


From: Julian Graham
Subject: [Guile-commits] GNU Guile branch, wip-r6rs-libraries, updated. release_1-9-8-87-gd51ffe9
Date: Sat, 27 Mar 2010 00:58:07 +0000

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

The branch, wip-r6rs-libraries has been updated
       via  d51ffe965183af1c63ba922ede1e3de8686c515b (commit)
       via  4180c1ac6a5c3adb4ca71444ae09a18ac67021d4 (commit)
      from  4123ca6b01730f59d3cbb6153c92ea926edc34a3 (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 d51ffe965183af1c63ba922ede1e3de8686c515b
Author: Julian Graham <address@hidden>
Date:   Fri Mar 26 20:57:52 2010 -0400

    Add `guard' form and test cases to R6RS (rnrs exceptions) library.
    
    * module/rnrs/6/exceptions.scm: (guard0, guard): New syntax.
    * module/rnrs/records/6/procedural.scm: (r6rs-raise-continuable): Can't
      use `raise' here because it's exported by (rnrs exceptions); use plain
      old `throw' instead.
    * test-suite/Makefile.am: Add tests/r6rs-exceptions.test to SCM_TESTS.
    * test-suite/tests/r6rs-exceptions.test: New file.

commit 4180c1ac6a5c3adb4ca71444ae09a18ac67021d4
Author: Julian Graham <address@hidden>
Date:   Fri Mar 26 20:47:39 2010 -0400

    Fix test suite title in comment
    
    * test-suite/tests/r6rs-records-procedural.test: `(rnrs control)' =>
      `(rnrs records procedural)'

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

Summary of changes:
 module/rnrs/6/exceptions.scm                  |   23 ++++++-
 module/rnrs/records/6/procedural.scm          |    2 +-
 test-suite/Makefile.am                        |    1 +
 test-suite/tests/r6rs-exceptions.test         |   98 +++++++++++++++++++++++++
 test-suite/tests/r6rs-records-procedural.test |    3 +-
 5 files changed, 124 insertions(+), 3 deletions(-)
 create mode 100644 test-suite/tests/r6rs-exceptions.test

diff --git a/module/rnrs/6/exceptions.scm b/module/rnrs/6/exceptions.scm
index eeea923..87dfe70 100644
--- a/module/rnrs/6/exceptions.scm
+++ b/module/rnrs/6/exceptions.scm
@@ -18,10 +18,11 @@
 
 
 (library (rnrs exceptions (6))
-  (export with-exception-handler raise raise-continuable)
+  (export guard with-exception-handler raise raise-continuable)
   (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))
@@ -48,4 +49,24 @@
                 (continuation handler-return)
                 (raise (make-non-continuable-violation))))
           *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)))))))))
+
+  (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))))))
 )
diff --git a/module/rnrs/records/6/procedural.scm 
b/module/rnrs/records/6/procedural.scm
index a14842e..da30fa4 100644
--- a/module/rnrs/records/6/procedural.scm
+++ b/module/rnrs/records/6/procedural.scm
@@ -273,6 +273,6 @@
     (throw 'r6rs:exception (make-raise-object-wrapper obj #f)))
   (define (r6rs-raise-continuable obj)
     (define (r6rs-raise-continuable-internal continuation)
-      (raise (make-raise-object-wrapper obj continuation)))
+      (throw 'r6rs:exception (make-raise-object-wrapper obj continuation)))
     (call/cc r6rs-raise-continuable-internal))
 )
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 3e10dc9..9cfacc7 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -72,6 +72,7 @@ SCM_TESTS = tests/alist.test                  \
            tests/r5rs_pitfall.test             \
            tests/r6rs-arithmetic-bitwise.test  \
            tests/r6rs-control.test             \
+           tests/r6rs-exceptions.test          \
            tests/r6rs-files.test               \
            tests/r6rs-hashtables.test          \
            tests/r6rs-ports.test               \
diff --git a/test-suite/tests/r6rs-exceptions.test 
b/test-suite/tests/r6rs-exceptions.test
new file mode 100644
index 0000000..54a4ddb
--- /dev/null
+++ b/test-suite/tests/r6rs-exceptions.test
@@ -0,0 +1,98 @@
+;;; r6rs-exceptions.test --- Test suite for R6RS (rnrs exceptions)
+
+;;      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-exceptions)
+  :use-module ((rnrs conditions) :version (6))
+  :use-module ((rnrs exceptions) :version (6))
+  :use-module (test-suite lib))
+
+(with-test-prefix "with-exception-handler"
+  (pass-if "handler invoked on raise"
+    (let ((success #f))
+      (call/cc
+       (lambda (continuation)
+        (with-exception-handler 
+         (lambda (condition) (set! success #t) (continuation))
+         (lambda () (raise (make-violation))))))
+      success))
+
+  (pass-if "handler not invoked unless raise"
+    (let ((success #f))
+      (call/cc 
+       (lambda (continuation)
+        (with-exception-handler
+         (lambda (condition) (continuation))
+         (lambda () (set! success #t)))))
+      success)))
+
+(with-test-prefix "raise"
+  (pass-if "raise causes &non-continuable after handler"
+    (let ((success #f))
+      (call/cc 
+       (lambda (continuation)
+        (with-exception-handler
+         (lambda (condition)
+           (set! success (non-continuable-violation? condition))
+           (continuation))
+         (lambda ()
+           (with-exception-handler
+            (lambda (condition) #f)
+            (lambda () (raise (make-violation))))))))
+      success)))
+
+(with-test-prefix "raise-continuable"
+  (pass-if "raise-continuable invokes continuation after handler"
+    (let ((handled #f)
+         (continued #f))
+      (call/cc
+       (lambda (continuation)
+        (with-exception-handler
+         (lambda (condition) (set! handled #t))
+         (lambda ()
+           (raise-continuable (make-violation))
+           (set! continued #t)))))
+      (and handled continued))))
+
+(with-test-prefix "guard"
+  (pass-if "guard with matching cond without else"
+    (let ((success #f))
+      (guard (condition ((error? condition) (set! success #t)))
+            (raise (make-error)))
+      success))
+
+  (pass-if "guard without matching cond without else"
+    (let ((success #f))
+      (call/cc 
+       (lambda (continuation)
+        (with-exception-handler
+         (lambda (condition) (set! success (error? condition)) (continuation))
+         (lambda ()
+           (guard (condition ((irritants-condition? condition) #f))
+                  (raise (make-error)))))))
+      success))
+           
+  (pass-if "guard with else and without matching cond"
+    (let ((success #f))
+      (guard (condition ((irritants-condition? condition) #f)
+                       (else (set! success #t)))
+            (raise (make-error)))
+      success))
+
+  (pass-if "guard with cond => syntax"
+    (guard (condition (condition => error?)) (raise (make-error)))))
diff --git a/test-suite/tests/r6rs-records-procedural.test 
b/test-suite/tests/r6rs-records-procedural.test
index 04b3459..a1621f1 100644
--- a/test-suite/tests/r6rs-records-procedural.test
+++ b/test-suite/tests/r6rs-records-procedural.test
@@ -1,4 +1,5 @@
-;;; r6rs-control.test --- Test suite for R6RS (rnrs control)
+;;; r6rs-records-procedural.test --- Test suite for R6RS 
+;;; (rnrs records procedural)
 
 ;;      Copyright (C) 2010 Free Software Foundation, Inc.
 ;;


hooks/post-receive
-- 
GNU Guile




reply via email to

[Prev in Thread] Current Thread [Next in Thread]