mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 20:00:19 +02:00
SRFI 34
This commit is contained in:
Neil Jerram
parent
c8e1d35451
commit
a1a5dfa888
6 changed files with 250 additions and 1 deletions
|
|
@ -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>
|
2003-04-23 Marius Vollmer <mvo@zagadka.de>
|
||||||
|
|
||||||
* srfi-1.scm: Removed stray "o" from exports list.
|
* srfi-1.scm: Removed stray "o" from exports list.
|
||||||
|
|
|
||||||
|
|
@ -67,7 +67,8 @@ srfi_DATA = srfi-1.scm \
|
||||||
srfi-14.scm \
|
srfi-14.scm \
|
||||||
srfi-16.scm \
|
srfi-16.scm \
|
||||||
srfi-17.scm \
|
srfi-17.scm \
|
||||||
srfi-19.scm
|
srfi-19.scm \
|
||||||
|
srfi-34.scm
|
||||||
|
|
||||||
EXTRA_DIST = $(srfi_DATA)
|
EXTRA_DIST = $(srfi_DATA)
|
||||||
ETAGS_ARGS = $(srfi_DATA)
|
ETAGS_ARGS = $(srfi_DATA)
|
||||||
|
|
|
||||||
78
srfi/srfi-34.scm
Normal file
78
srfi/srfi-34.scm
Normal file
|
|
@ -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.
|
||||||
|
|
@ -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>
|
2003-04-23 Dirk Herrmann <D.Herrmann@tu-bs.de>
|
||||||
|
|
||||||
* tests/syntax.test: Modified some tests to use eval when
|
* tests/syntax.test: Modified some tests to use eval when
|
||||||
|
|
|
||||||
|
|
@ -31,6 +31,7 @@ SCM_TESTS = tests/alist.test \
|
||||||
tests/srfi-13.test \
|
tests/srfi-13.test \
|
||||||
tests/srfi-14.test \
|
tests/srfi-14.test \
|
||||||
tests/srfi-19.test \
|
tests/srfi-19.test \
|
||||||
|
tests/srfi-34.test \
|
||||||
tests/srfi-4.test \
|
tests/srfi-4.test \
|
||||||
tests/srfi-9.test \
|
tests/srfi-9.test \
|
||||||
tests/strings.test \
|
tests/strings.test \
|
||||||
|
|
|
||||||
159
test-suite/tests/srfi-34.test
Normal file
159
test-suite/tests/srfi-34.test
Normal file
|
|
@ -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)))
|
||||||
|
|
||||||
|
)
|
||||||
Loading…
Add table
Add a link
Reference in a new issue