[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/01: commit to squish on previous
From: |
Andy Wingo |
Subject: |
[Guile-commits] 01/01: commit to squish on previous |
Date: |
Mon, 11 Nov 2019 14:58:09 -0500 (EST) |
wingo pushed a commit to branch wip-exceptions
in repository guile.
commit 192f8d38da955ee73513f16cf258d41d19ee863a
Author: Andy Wingo <address@hidden>
Date: Mon Nov 11 20:57:46 2019 +0100
commit to squish on previous
---
libguile/exceptions.c | 17 ++++++++++++++---
libguile/exceptions.h | 2 ++
libguile/throw.c | 21 ++++++++++++++-------
module/ice-9/boot-9.scm | 17 +++++++++++------
test-suite/tests/eval.test | 16 ++++++++--------
test-suite/tests/exceptions.test | 17 ++++++++---------
6 files changed, 57 insertions(+), 33 deletions(-)
diff --git a/libguile/exceptions.c b/libguile/exceptions.c
index ae61d0a..1fe281b 100644
--- a/libguile/exceptions.c
+++ b/libguile/exceptions.c
@@ -109,6 +109,7 @@ call_exception_handler (SCM clo, SCM exn)
SCM_KEYWORD (kw_unwind_p, "unwind?");
SCM_KEYWORD (kw_unwind_for_type, "unwind-for-type");
static SCM exception_handler_fluid;
+static SCM active_exception_handlers_fluid;
static SCM with_exception_handler_var;
static SCM raise_exception_var;
@@ -253,6 +254,15 @@ exception_has_type (SCM exn, SCM type)
+void
+scm_dynwind_throw_handler (void)
+{
+ scm_dynwind_fluid (active_exception_handlers_fluid, SCM_BOOL_F);
+}
+
+
+
+
/* Default exception handlers. */
/* Derive the an exit status from the arguments to (quit ...). */
@@ -489,10 +499,11 @@ scm_init_exceptions ()
scm_set_smob_apply (tc16_exception_handler, call_exception_handler, 1, 0, 0);
exception_handler_fluid = scm_make_thread_local_fluid (SCM_BOOL_F);
- /* This binding is later removed when the Scheme definitions of raise,
- with-exception-handler, and with-pre-unwind-exception-handler are
- created in boot-9.scm. */
+ active_exception_handlers_fluid = scm_make_thread_local_fluid (SCM_BOOL_F);
+ /* These binding are later removed when the Scheme definitions of
+ raise and with-exception-handler are created in boot-9.scm. */
scm_c_define ("%exception-handler", exception_handler_fluid);
+ scm_c_define ("%active-exception-handlers", active_exception_handlers_fluid);
with_exception_handler_var =
scm_c_define ("with-exception-handler", SCM_BOOL_F);
diff --git a/libguile/exceptions.h b/libguile/exceptions.h
index eaf8964..5f3869b 100644
--- a/libguile/exceptions.h
+++ b/libguile/exceptions.h
@@ -50,6 +50,8 @@ SCM_INTERNAL SCM scm_raise_exception (SCM exn) SCM_NORETURN;
SCM_INTERNAL SCM scm_exception_kind (SCM exn);
SCM_INTERNAL SCM scm_exception_args (SCM exn);
+SCM_INTERNAL void scm_dynwind_throw_handler (void);
+
/* This raises a `stack-overflow' exception, without running pre-unwind
handlers. */
SCM_API void scm_report_stack_overflow (void);
diff --git a/libguile/throw.c b/libguile/throw.c
index 0a45062..d03962a 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -23,18 +23,17 @@
# include <config.h>
#endif
-#include <alloca.h>
#include <stdio.h>
#include <unistdio.h>
#include "backtrace.h"
#include "boolean.h"
-#include "control.h"
#include "debug.h"
-#include "deprecation.h"
+#include "dynwind.h"
#include "eq.h"
#include "eval.h"
#include "exceptions.h"
+#include "fluids.h"
#include "gsubr.h"
#include "init.h"
#include "list.h"
@@ -109,6 +108,7 @@ struct scm_catch_data
void *handler_data;
scm_t_catch_handler pre_unwind_handler;
void *pre_unwind_handler_data;
+ SCM pre_unwind_running;
};
static SCM
@@ -126,10 +126,15 @@ catch_pre_unwind_handler (void *data, SCM exn)
struct scm_catch_data *catch_data = data;
SCM kind = scm_exception_kind (exn);
SCM args = scm_exception_args (exn);
- if (scm_is_eq (catch_data->tag, SCM_BOOL_T)
- || scm_is_eq (kind, catch_data->tag)) {
+ if ((scm_is_eq (catch_data->tag, SCM_BOOL_T)
+ || scm_is_eq (kind, catch_data->tag))
+ && scm_is_false (scm_fluid_ref (catch_data->pre_unwind_running))) {
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ scm_dynwind_throw_handler ();
+ scm_dynwind_fluid (catch_data->pre_unwind_running, SCM_BOOL_T);
catch_data->pre_unwind_handler (catch_data->pre_unwind_handler_data,
kind, args);
+ scm_dynwind_end ();
}
return scm_raise_exception (exn);
}
@@ -142,6 +147,8 @@ catch_body (void *data)
if (catch_data->pre_unwind_handler) {
SCM thunk = scm_c_make_thunk (catch_data->body, catch_data->body_data);
SCM handler = scm_c_make_exception_handler (catch_pre_unwind_handler,
data);
+ SCM fluid = scm_make_thread_local_fluid (SCM_BOOL_F);
+ catch_data->pre_unwind_running = fluid;
return scm_with_pre_unwind_exception_handler (handler, thunk);
}
@@ -156,7 +163,7 @@ scm_c_catch (SCM tag,
{
struct scm_catch_data data =
{ tag, body, body_data, handler, handler_data, pre_unwind_handler,
- pre_unwind_handler_data };
+ pre_unwind_handler_data, SCM_BOOL_F };
return scm_c_with_exception_handler (tag, catch_post_unwind_handler, &data,
catch_body, &data);
@@ -183,7 +190,7 @@ scm_c_with_throw_handler (SCM tag,
int lazy_catch_p)
{
struct scm_catch_data data =
- { tag, body, body_data, NULL, NULL, handler, handler_data };
+ { tag, body, body_data, NULL, NULL, handler, handler_data, SCM_BOOL_F };
if (lazy_catch_p)
/* Non-zero lazy_catch_p arguments have been deprecated since
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 057199d..3a3fd1c 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1539,6 +1539,8 @@ exception composed of such an instance."
val))
(define %exception-handler (steal-binding! '%exception-handler))
+ (define %active-exception-handlers
+ (steal-binding! '%active-exception-handlers))
(define %init-exceptions! (steal-binding! '%init-exceptions!))
(%init-exceptions! &compound-exception
@@ -1579,8 +1581,6 @@ exception composed of such an instance."
(exception-kind exn) (exception-args exn))
(primitive-exit 1))))
- (define %dynamic-handlers (make-thread-local-fluid))
-
(define* (raise-exception exn #:key (continuable? #f))
(define (capture-current-exception-handlers)
;; FIXME: This is quadratic.
@@ -1599,7 +1599,7 @@ exception composed of such an instance."
(and (exception? exn)
((exception-predicate type) exn)))
(else #f)))
- (let lp ((handlers (or (fluid-ref %dynamic-handlers)
+ (let lp ((handlers (or (fluid-ref %active-exception-handlers)
(capture-current-exception-handlers))))
(let ((handler (car handlers))
(handlers (cdr handlers)))
@@ -1620,7 +1620,7 @@ exception composed of such an instance."
(else
(lp handlers)))))
(else
- (with-fluids ((%dynamic-handlers handlers))
+ (with-fluids ((%active-exception-handlers handlers))
(cond
(continuable?
(handler exn))
@@ -1673,10 +1673,15 @@ for key @var{k}, then invoke @var{thunk}."
(scm-error 'wrong-type-arg "with-throw-handler"
"Wrong type argument in position ~a: ~a"
(list 1 k) (list k)))
+ (define running? (make-fluid))
(with-exception-handler
(lambda (exn)
- (when (or (eq? k #t) (eq? k (exception-kind exn)))
- (apply pre-unwind-handler (exception-kind exn) (exception-args
exn)))
+ (when (and (or (eq? k #t) (eq? k (exception-kind exn)))
+ (not (fluid-ref running?)))
+ (with-fluids ((%active-exception-handlers #f)
+ (running? #t))
+ (apply pre-unwind-handler (exception-kind exn)
+ (exception-args exn))))
(raise-exception exn))
thunk))
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index 8a52e11..71b06f7 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 391a19d..291e10e 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"