From d1c83d388aa35977a612eceda4cf52ef891cab0b Mon Sep 17 00:00:00 2001 From: Julian Graham Date: Fri, 26 Mar 2010 20:57:52 -0400 Subject: [PATCH] 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. --- 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 +++++++++++++++++++++++++++ 4 files changed, 122 insertions(+), 2 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 eeea9238b..87dfe70b9 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 a14842e1c..da30fa407 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 3a7e67650..b08233f36 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -78,6 +78,7 @@ SCM_TESTS = tests/00-initial-env.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 000000000..54a4ddbd6 --- /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))))) -- 2.20.1