mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

SRFI 34

Browse source
This commit is contained in:
Neil Jerram 2003-04-30 00:06:33 +00:00
parent c8e1d35451
commit a1a5dfa888
6 changed files with 250 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

4
srfi/ChangeLog
View file

@ -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.

3
srfi/Makefile.am
View file

@ -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)

78
srfi/srfi-34.scm Normal file
View 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.

6
test-suite/ChangeLog
View file

@ -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

1
test-suite/Makefile.am
View file

@ -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 \

159
test-suite/tests/srfi-34.test Normal file
View 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)))
)