summaryrefslogtreecommitdiff
path: root/test-suite/tests
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2019-11-08 15:31:00 +0100
committerAndy Wingo <wingo@pobox.com>2019-11-13 22:24:19 +0100
commitf4ca107f7fe0b6f1ca2c03b558f16077fc89db04 (patch)
tree2e444d63f7ecca2cb4ff5b52890e22aaea0810fe /test-suite/tests
parentf2c8ff5a52eb7073b50151d5d14d2e6ab351fa4f (diff)
downloadguile-f4ca107f7fe0b6f1ca2c03b558f16077fc89db04.tar.gz
Rebase throw/catch on top of raise-exception/with-exception-handler
* libguile/exceptions.c: * libguile/exceptions.h: New files. * libguile.h: Add exceptions.h. * libguile/Makefile.am (libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES): (DOT_X_FILES, DOT_DOC_FILES, modinclude_HEADERS): Add exceptions.c and exceptions.h. * libguile/init.c (scm_i_init_guile): Initialize exceptions. * libguile/threads.c (scm_spawn_thread): Use new names for scm_i_make_catch_handler and scm_c_make_thunk. * libguile/throw.c: Rewrite to be implemented in terms of with-exception-handler / raise-exception. * libguile/throw.h: Use data types from exceptions.h. Move scm_report_stack_overflow and scm_report_out_of_memory to exceptions.[ch]. * module/ice-9/boot-9.scm (&error, &programming-error) (&non-continuable, make-exception-from-throw, raise-exception) (with-exception-handler): New top-level definitions. (throw, catch, with-throw-handler): Rewrite in terms of with-exception-handler and raise-exception. : New top-level definitions. * module/ice-9/exceptions.scm: Adapt to re-export &error, &programming-error, &non-continuable, raise-exception, and with-exception-handler from boot-9. (make-quit-exception, guile-quit-exception-converter): New exception converters. (make-exception-from-throw): Override core binding. * test-suite/tests/eval.test ("inner trim with prompt tag"): Adapt to "with-exception-handler" being the procedure on the stack. ("outer trim with prompt tag"): Likewise. * test-suite/tests/exceptions.test (throw-test): Use pass-if-equal. * module/srfi/srfi-34.scm: Reimplement in terms of core exceptions, and make "guard" actually re-raise continuations with the original "raise" continuation.
Diffstat (limited to 'test-suite/tests')
-rw-r--r--test-suite/tests/eval.test16
-rw-r--r--test-suite/tests/exceptions.test17
2 files changed, 16 insertions, 17 deletions
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index 8a52e11f2..71b06f756 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -1,5 +1,6 @@
;;;; eval.test --- tests guile's evaluator -*- scheme -*-
-;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000-2001,2003-2015,2017,2019
+;;;; 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
@@ -387,12 +388,11 @@
(pass-if "inner trim with prompt tag"
(let* ((stack (make-tagged-trimmed-stack tag `(#t ,tag)))
(frames (stack->frames stack)))
- ;; the top frame on the stack is the lambda inside the 'catch, and the
- ;; next frame is the (catch 'result ...)
- (and (eq? (car (frame-call-representation (cadr frames)))
- 'catch)
- (eq? (car (frame-arguments (cadr frames)))
- 'result))))
+ ;; the top frame on the stack is the body of the catch, and the
+ ;; next frame is the with-exception-handler corresponding to the
+ ;; (catch 'result ...)
+ (eq? (car (frame-call-representation (cadr frames)))
+ 'with-exception-handler)))
(pass-if "outer trim with prompt tag"
(let* ((stack (make-tagged-trimmed-stack tag `(#t 0 ,tag)))
@@ -402,7 +402,7 @@
(and (eq? (car (frame-call-representation (car frames)))
'make-stack)
(eq? (car (frame-call-representation (car (last-pair frames))))
- 'with-throw-handler)))))
+ 'with-exception-handler)))))
;;;
;;; letrec init evaluation
diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test
index 391a19dca..291e10e26 100644
--- a/test-suite/tests/exceptions.test
+++ b/test-suite/tests/exceptions.test
@@ -24,15 +24,14 @@
(syntax-violation 'push "push used outside of throw-test" stx)))
(define-syntax-rule (throw-test title result expr ...)
- (pass-if title
- (equal? result
- (let ((stack '()))
- (syntax-parameterize ((push (syntax-rules ()
- ((push val)
- (set! stack (cons val stack))))))
- expr ...
- ;;(format #t "~a: ~s~%" title (reverse stack))
- (reverse stack))))))
+ (pass-if-equal title result
+ (let ((stack '()))
+ (syntax-parameterize ((push (syntax-rules ()
+ ((push val)
+ (set! stack (cons val stack))))))
+ expr ...
+ ;;(format #t "~a: ~s~%" title (reverse stack))
+ (reverse stack)))))
(with-test-prefix "throw/catch"