summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNeil Jerram <neil@ossau.uklinux.net>2003-04-30 00:06:33 +0000
committerNeil Jerram <neil@ossau.uklinux.net>2003-04-30 00:06:33 +0000
commita1a5dfa888949818a216bc893c22dd7aa0c66a07 (patch)
treef2ce4946554285a4cc8af76a27750b44f273582f
parentc8e1d3545120c1924d997f2ea8fe06f1a5e38d49 (diff)
downloadguile-a1a5dfa888949818a216bc893c22dd7aa0c66a07.tar.gz
SRFI 34
-rw-r--r--srfi/ChangeLog4
-rw-r--r--srfi/Makefile.am3
-rw-r--r--srfi/srfi-34.scm78
-rw-r--r--test-suite/ChangeLog6
-rw-r--r--test-suite/Makefile.am1
-rw-r--r--test-suite/tests/srfi-34.test159
6 files changed, 250 insertions, 1 deletions
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 <neil@ossau.uklinux.net>
+
+ * srfi-34.scm: New file.
+
2003-04-23 Marius Vollmer <mvo@zagadka.de>
* 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 <neil@ossau.uklinux.net>
+
+;;; 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 (<var> <clause1> <clause2> ...) <body>)
+Each <clause> should have the same form as a `cond' clause.
+
+Semantics: Evaluating a guard form evaluates <body> with an exception
+handler that binds the raised object to <var> 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 <clause>'s <test> 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 <neil@ossau.uklinux.net>
+
+ * Makefile.am (SCM_TESTS): Add tests/srfi-34.test.
+
+ * tests/srfi-34.test: New file.
+
2003-04-23 Dirk Herrmann <D.Herrmann@tu-bs.de>
* 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)))
+
+)