From a1a5dfa888949818a216bc893c22dd7aa0c66a07 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Wed, 30 Apr 2003 00:06:33 +0000 Subject: [PATCH] SRFI 34 --- srfi/ChangeLog | 4 + srfi/Makefile.am | 3 +- srfi/srfi-34.scm | 78 +++++++++++++++++ test-suite/ChangeLog | 6 ++ test-suite/Makefile.am | 1 + test-suite/tests/srfi-34.test | 159 ++++++++++++++++++++++++++++++++++ 6 files changed, 250 insertions(+), 1 deletion(-) create mode 100644 srfi/srfi-34.scm create mode 100644 test-suite/tests/srfi-34.test diff --git a/srfi/ChangeLog b/srfi/ChangeLog index e59cb9683..50d56fc29 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,7 @@ +2003-04-30 Neil Jerram + + * srfi-34.scm: New file. + 2003-04-23 Marius Vollmer * srfi-1.scm: Removed stray "o" from exports list. diff --git a/srfi/Makefile.am b/srfi/Makefile.am index d88b3e834..2c8eeab12 100644 --- a/srfi/Makefile.am +++ b/srfi/Makefile.am @@ -67,7 +67,8 @@ srfi_DATA = srfi-1.scm \ srfi-14.scm \ srfi-16.scm \ srfi-17.scm \ - srfi-19.scm + srfi-19.scm \ + srfi-34.scm EXTRA_DIST = $(srfi_DATA) ETAGS_ARGS = $(srfi_DATA) diff --git a/srfi/srfi-34.scm b/srfi/srfi-34.scm new file mode 100644 index 000000000..bd326beac --- /dev/null +++ b/srfi/srfi-34.scm @@ -0,0 +1,78 @@ +;;; srfi-34.scm --- Exception handling for programs + +;; Copyright (C) 2003 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 2.1 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +;;; Author: Neil Jerram + +;;; Commentary: + +;; This is an implementation of SRFI-34: Exception Handling for +;; Programs. For documentation please see the SRFI-34 document; this +;; module is not yet documented at all in the Guile manual. + +;;; Code: + +(define-module (srfi srfi-34) + #:export (with-exception-handler + raise) + #:export-syntax (guard)) + +(define throw-key 'srfi-34) + +(define (with-exception-handler handler thunk) + "Returns the result(s) of invoking THUNK. HANDLER must be a +procedure that accepts one argument. It is installed as the current +exception handler for the dynamic extent (as determined by +dynamic-wind) of the invocation of THUNK." + (lazy-catch throw-key + thunk + (lambda (key obj) + (handler obj)))) + +(define (raise obj) + "Invokes the current exception handler on OBJ. The handler is +called in the dynamic environment of the call to raise, except that +the current exception handler is that in place for the call to +with-exception-handler that installed the handler being called. The +handler's continuation is otherwise unspecified." + (throw throw-key obj)) + +(define-macro (guard var+clauses . body) + "Syntax: (guard (...) ) +Each should have the same form as a `cond' clause. + +Semantics: Evaluating a guard form evaluates with an exception +handler that binds the raised object to and within the scope of +that binding evaluates the clauses as if they were the clauses of a +cond expression. That implicit cond expression is evaluated with the +continuation and dynamic environment of the guard expression. If +every 's evaluates to false and there is no else +clause, then raise is re-invoked on the raised object within the +dynamic environment of the original call to raise except that the +current exception handler is that of the guard expression." + (let ((var (car var+clauses)) + (clauses (cdr var+clauses))) + `(catch ',throw-key + (lambda () + ,@body) + (lambda (key ,var) + (cond ,@(if (eq? (caar (last-pair clauses)) 'else) + clauses + (append clauses + `((else (throw key ,var)))))))))) + +;;; (srfi srfi-34) ends here. diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index aae712022..59ed71267 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,9 @@ +2003-04-30 Neil Jerram + + * Makefile.am (SCM_TESTS): Add tests/srfi-34.test. + + * tests/srfi-34.test: New file. + 2003-04-23 Dirk Herrmann * tests/syntax.test: Modified some tests to use eval when diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index ab9806473..0640bf197 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -31,6 +31,7 @@ SCM_TESTS = tests/alist.test \ tests/srfi-13.test \ tests/srfi-14.test \ tests/srfi-19.test \ + tests/srfi-34.test \ tests/srfi-4.test \ tests/srfi-9.test \ tests/strings.test \ diff --git a/test-suite/tests/srfi-34.test b/test-suite/tests/srfi-34.test new file mode 100644 index 000000000..b2d4139da --- /dev/null +++ b/test-suite/tests/srfi-34.test @@ -0,0 +1,159 @@ +;;;; srfi-34.test --- test suite for SRFI-34 -*- scheme -*- +;;;; +;;;; Copyright (C) 2003 Free Software Foundation, Inc. +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2, or (at your option) +;;;; any later version. +;;;; +;;;; This program 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 General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA + +(define-module (test-suite test-srfi-34) + :use-module (test-suite lib) + :use-module (srfi srfi-13) + :use-module (srfi srfi-34)) + +(define (expr-prints-and-evals-to? expr printout result) + (let ((actual-result *unspecified*)) + (let ((actual-printout + (string-trim-both + (with-output-to-string + (lambda () + (set! actual-result + (eval expr (current-module)))))))) + ;;(write (list actual-printout printout actual-result result)) + ;;(newline) + (and (equal? actual-printout printout) + (equal? actual-result result))))) + +(with-test-prefix "SRFI 34" + + (pass-if "example 1" + (expr-prints-and-evals-to? + '(call-with-current-continuation + (lambda (k) + (with-exception-handler (lambda (x) + (display "condition: ") + (write x) + (newline) + (k 'exception)) + (lambda () + (+ 1 (raise 'an-error)))))) + "condition: an-error" + 'exception)) + + ;; SRFI 34 specifies that the behaviour of the call/cc expression + ;; after printing "something went wrong" is unspecified, which is + ;; tricky to test for in a positive way ... Guile behaviour at time + ;; of writing is to signal a "lazy-catch handler did return" error, + ;; which feels about right to me. + (pass-if "example 2" + (expr-prints-and-evals-to? + '(false-if-exception + (call-with-current-continuation + (lambda (k) + (with-exception-handler (lambda (x) + (display "something went wrong") + (newline) + 'dont-care) + (lambda () + (+ 1 (raise 'an-error))))))) + "something went wrong" + #f)) + + (pass-if "example 3" + (expr-prints-and-evals-to? + '(guard (condition + (else + (display "condition: ") + (write condition) + (newline) + 'exception)) + (+ 1 (raise 'an-error))) + "condition: an-error" + 'exception)) + + (pass-if "example 4" + (expr-prints-and-evals-to? + '(guard (condition + (else + (display "something went wrong") + (newline) + 'dont-care)) + (+ 1 (raise 'an-error))) + "something went wrong" + 'dont-care)) + + (pass-if "example 5" + (expr-prints-and-evals-to? + '(call-with-current-continuation + (lambda (k) + (with-exception-handler (lambda (x) + (display "reraised ") (write x) (newline) + (k 'zero)) + (lambda () + (guard (condition + ((positive? condition) 'positive) + ((negative? condition) 'negative)) + (raise 1)))))) + "" + 'positive)) + + (pass-if "example 6" + (expr-prints-and-evals-to? + '(call-with-current-continuation + (lambda (k) + (with-exception-handler (lambda (x) + (display "reraised ") (write x) (newline) + (k 'zero)) + (lambda () + (guard (condition + ((positive? condition) 'positive) + ((negative? condition) 'negative)) + (raise -1)))))) + "" + 'negative)) + + (pass-if "example 7" + (expr-prints-and-evals-to? + '(call-with-current-continuation + (lambda (k) + (with-exception-handler (lambda (x) + (display "reraised ") (write x) (newline) + (k 'zero)) + (lambda () + (guard (condition + ((positive? condition) 'positive) + ((negative? condition) 'negative)) + (raise 0)))))) + "reraised 0" + 'zero)) + + (pass-if "example 8" + (expr-prints-and-evals-to? + '(guard (condition + ((assq 'a condition) => cdr) + ((assq 'b condition))) + (raise (list (cons 'a 42)))) + "" + 42)) + + (pass-if "example 9" + (expr-prints-and-evals-to? + '(guard (condition + ((assq 'a condition) => cdr) + ((assq 'b condition))) + (raise (list (cons 'b 23)))) + "" + '(b . 23))) + +) -- 2.20.1