mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
Deprecate dynamic roots
* libguile/root.h: * libguile/root.c: Remove these files. * libguile/deprecated.h: * libguile/deprecated.c (scm_internal_cwdr, scm_call_with_dynamic_root) (scm_dynamic_root, scm_apply_with_dynamic_root): Deprecate. Remove all root.h usage, which was vestigial. * module/ice-9/serialize.scm: Use (current-thread) instead of (dynamic-root).
This commit is contained in:
parent
f927c70d42
commit
dc2a560264
47 changed files with 179 additions and 297 deletions
6
NEWS
6
NEWS
|
@ -109,6 +109,12 @@ scm_dynwind_block_asyncs.
|
|||
Use `scm_make_mutex_with_kind' instead. See "Mutexes and Condition
|
||||
Variables" in the manual, for more.
|
||||
|
||||
** Dynamic roots deprecated
|
||||
|
||||
This was a facility that predated threads, was unused as far as we can
|
||||
tell, and was never documented. Still, a grep of your code for
|
||||
dynamic-root or dynamic_root would not be amiss.
|
||||
|
||||
* Bug fixes
|
||||
** cancel-thread uses asynchronous interrupts, not pthread_cancel
|
||||
|
||||
|
|
|
@ -88,7 +88,6 @@ extern "C" {
|
|||
#include "libguile/r6rs-ports.h"
|
||||
#include "libguile/random.h"
|
||||
#include "libguile/read.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/scmsigs.h"
|
||||
#include "libguile/script.h"
|
||||
#include "libguile/simpos.h"
|
||||
|
|
|
@ -192,7 +192,6 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \
|
|||
random.c \
|
||||
rdelim.c \
|
||||
read.c \
|
||||
root.c \
|
||||
rw.c \
|
||||
scmsigs.c \
|
||||
script.c \
|
||||
|
@ -297,7 +296,6 @@ DOT_X_FILES = \
|
|||
random.x \
|
||||
rdelim.x \
|
||||
read.x \
|
||||
root.x \
|
||||
rw.x \
|
||||
scmsigs.x \
|
||||
script.x \
|
||||
|
@ -400,7 +398,6 @@ DOT_DOC_FILES = \
|
|||
random.doc \
|
||||
rdelim.doc \
|
||||
read.doc \
|
||||
root.doc \
|
||||
rw.doc \
|
||||
scmsigs.doc \
|
||||
script.doc \
|
||||
|
@ -644,7 +641,6 @@ modinclude_HEADERS = \
|
|||
rdelim.h \
|
||||
read.h \
|
||||
regex-posix.h \
|
||||
root.h \
|
||||
rw.h \
|
||||
scmsigs.h \
|
||||
script.h \
|
||||
|
|
|
@ -34,7 +34,6 @@
|
|||
#include "libguile/eq.h"
|
||||
#include "libguile/eval.h"
|
||||
#include "libguile/feature.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/vectors.h"
|
||||
#include "libguile/bitvectors.h"
|
||||
#include "libguile/srfi-4.h"
|
||||
|
|
|
@ -39,7 +39,6 @@
|
|||
#include "libguile/eval.h"
|
||||
#include "libguile/fports.h"
|
||||
#include "libguile/feature.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/strings.h"
|
||||
#include "libguile/srfi-13.h"
|
||||
#include "libguile/srfi-4.h"
|
||||
|
|
|
@ -27,7 +27,6 @@
|
|||
#include "libguile/atomics-internal.h"
|
||||
#include "libguile/eval.h"
|
||||
#include "libguile/throw.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/smob.h"
|
||||
#include "libguile/dynwind.h"
|
||||
#include "libguile/deprecation.h"
|
||||
|
|
|
@ -25,7 +25,6 @@
|
|||
|
||||
|
||||
#include "libguile/__scm.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/threads.h"
|
||||
|
||||
|
||||
|
|
|
@ -30,7 +30,6 @@
|
|||
|
||||
#include "libguile/async.h"
|
||||
#include "libguile/debug.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/stackchk.h"
|
||||
#include "libguile/smob.h"
|
||||
#include "libguile/ports.h"
|
||||
|
|
|
@ -51,7 +51,6 @@
|
|||
#include "libguile/dynwind.h"
|
||||
#include "libguile/modules.h"
|
||||
#include "libguile/ports.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/fluids.h"
|
||||
#include "libguile/programs.h"
|
||||
#include "libguile/memoize.h"
|
||||
|
|
|
@ -730,6 +730,162 @@ scm_unlock_mutex_timed (SCM mx, SCM cond, SCM timeout)
|
|||
}
|
||||
|
||||
|
||||
|
||||
|
||||
/* {call-with-dynamic-root}
|
||||
*
|
||||
* Suspending the current thread to evaluate a thunk on the
|
||||
* same C stack but under a new root.
|
||||
*
|
||||
* Calls to call-with-dynamic-root return exactly once (unless
|
||||
* the process is somehow exitted). */
|
||||
|
||||
/* cwdr fills out both of these structures, and then passes a pointer
|
||||
to them through scm_internal_catch to the cwdr_body and
|
||||
cwdr_handler functions, to tell them how to behave and to get
|
||||
information back from them.
|
||||
|
||||
A cwdr is a lot like a catch, except there is no tag (all
|
||||
exceptions are caught), and the body procedure takes the arguments
|
||||
passed to cwdr as A1 and ARGS. The handler is also special since
|
||||
it is not directly run from scm_internal_catch. It is executed
|
||||
outside the new dynamic root. */
|
||||
|
||||
struct cwdr_body_data {
|
||||
/* Arguments to pass to the cwdr body function. */
|
||||
SCM a1, args;
|
||||
|
||||
/* Scheme procedure to use as body of cwdr. */
|
||||
SCM body_proc;
|
||||
};
|
||||
|
||||
struct cwdr_handler_data {
|
||||
/* Do we need to run the handler? */
|
||||
int run_handler;
|
||||
|
||||
/* The tag and args to pass it. */
|
||||
SCM tag, args;
|
||||
};
|
||||
|
||||
|
||||
/* Invoke the body of a cwdr, assuming that the throw handler has
|
||||
already been set up. DATA points to a struct set up by cwdr that
|
||||
says what proc to call, and what args to apply it to.
|
||||
|
||||
With a little thought, we could replace this with scm_body_thunk,
|
||||
but I don't want to mess with that at the moment. */
|
||||
static SCM
|
||||
cwdr_body (void *data)
|
||||
{
|
||||
struct cwdr_body_data *c = (struct cwdr_body_data *) data;
|
||||
|
||||
return scm_apply (c->body_proc, c->a1, c->args);
|
||||
}
|
||||
|
||||
/* Record the fact that the body of the cwdr has thrown. Record
|
||||
enough information to invoke the handler later when the dynamic
|
||||
root has been deestablished. */
|
||||
|
||||
static SCM
|
||||
cwdr_handler (void *data, SCM tag, SCM args)
|
||||
{
|
||||
struct cwdr_handler_data *c = (struct cwdr_handler_data *) data;
|
||||
|
||||
c->run_handler = 1;
|
||||
c->tag = tag;
|
||||
c->args = args;
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
|
||||
SCM
|
||||
scm_internal_cwdr (scm_t_catch_body body, void *body_data,
|
||||
scm_t_catch_handler handler, void *handler_data,
|
||||
SCM_STACKITEM *stack_start)
|
||||
{
|
||||
struct cwdr_handler_data my_handler_data;
|
||||
scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack;
|
||||
SCM answer;
|
||||
scm_t_dynstack *old_dynstack;
|
||||
|
||||
/* Exit caller's dynamic state.
|
||||
*/
|
||||
old_dynstack = scm_dynstack_capture_all (dynstack);
|
||||
scm_dynstack_unwind (dynstack, SCM_DYNSTACK_FIRST (dynstack));
|
||||
|
||||
scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
|
||||
scm_dynwind_current_dynamic_state (scm_make_dynamic_state (SCM_UNDEFINED));
|
||||
|
||||
my_handler_data.run_handler = 0;
|
||||
answer = scm_i_with_continuation_barrier (body, body_data,
|
||||
cwdr_handler, &my_handler_data,
|
||||
NULL, NULL);
|
||||
|
||||
scm_dynwind_end ();
|
||||
|
||||
/* Enter caller's dynamic state.
|
||||
*/
|
||||
scm_dynstack_wind (dynstack, SCM_DYNSTACK_FIRST (old_dynstack));
|
||||
|
||||
/* Now run the real handler iff the body did a throw. */
|
||||
if (my_handler_data.run_handler)
|
||||
return handler (handler_data, my_handler_data.tag, my_handler_data.args);
|
||||
else
|
||||
return answer;
|
||||
}
|
||||
|
||||
/* The original CWDR for invoking Scheme code with a Scheme handler. */
|
||||
|
||||
static SCM
|
||||
cwdr (SCM proc, SCM a1, SCM args, SCM handler, SCM_STACKITEM *stack_start)
|
||||
{
|
||||
struct cwdr_body_data c;
|
||||
|
||||
c.a1 = a1;
|
||||
c.args = args;
|
||||
c.body_proc = proc;
|
||||
|
||||
return scm_internal_cwdr (cwdr_body, &c,
|
||||
scm_handle_by_proc, &handler,
|
||||
stack_start);
|
||||
}
|
||||
|
||||
SCM_DEFINE (scm_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0,
|
||||
(SCM thunk, SCM handler),
|
||||
"Call @var{thunk} with a new dynamic state and within\n"
|
||||
"a continuation barrier. The @var{handler} catches all\n"
|
||||
"otherwise uncaught throws and executes within the same\n"
|
||||
"dynamic context as @var{thunk}.")
|
||||
#define FUNC_NAME s_scm_call_with_dynamic_root
|
||||
{
|
||||
SCM_STACKITEM stack_place;
|
||||
scm_c_issue_deprecation_warning
|
||||
("call-with-dynamic-root is deprecated. There is no replacement.");
|
||||
return cwdr (thunk, SCM_EOL, SCM_EOL, handler, &stack_place);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_dynamic_root, "dynamic-root", 0, 0, 0,
|
||||
(),
|
||||
"Return an object representing the current dynamic root.\n\n"
|
||||
"These objects are only useful for comparison using @code{eq?}.\n")
|
||||
#define FUNC_NAME s_scm_dynamic_root
|
||||
{
|
||||
scm_c_issue_deprecation_warning
|
||||
("dynamic-root is deprecated. There is no replacement.");
|
||||
return SCM_I_CURRENT_THREAD->continuation_root;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM
|
||||
scm_apply_with_dynamic_root (SCM proc, SCM a1, SCM args, SCM handler)
|
||||
{
|
||||
SCM_STACKITEM stack_place;
|
||||
scm_c_issue_deprecation_warning
|
||||
("scm_apply_with_dynamic_root is deprecated. There is no replacement.");
|
||||
return cwdr (proc, a1, args, handler, &stack_place);
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
void
|
||||
|
|
|
@ -244,6 +244,18 @@ SCM_DEPRECATED SCM scm_lock_mutex_timed (SCM m, SCM timeout, SCM owner);
|
|||
|
||||
|
||||
|
||||
SCM_DEPRECATED SCM scm_internal_cwdr (scm_t_catch_body body,
|
||||
void *body_data,
|
||||
scm_t_catch_handler handler,
|
||||
void *handler_data,
|
||||
SCM_STACKITEM *stack_start);
|
||||
SCM_DEPRECATED SCM scm_call_with_dynamic_root (SCM thunk, SCM handler);
|
||||
SCM_DEPRECATED SCM scm_dynamic_root (void);
|
||||
SCM_DEPRECATED SCM scm_apply_with_dynamic_root (SCM proc, SCM a1,
|
||||
SCM args, SCM handler);
|
||||
|
||||
|
||||
|
||||
void scm_i_init_deprecated (void);
|
||||
|
||||
#endif
|
||||
|
|
|
@ -28,7 +28,6 @@
|
|||
#include "libguile/stackchk.h"
|
||||
#include "libguile/strorder.h"
|
||||
#include "libguile/async.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/smob.h"
|
||||
#include "libguile/arrays.h"
|
||||
#include "libguile/vectors.h"
|
||||
|
|
|
@ -51,7 +51,6 @@
|
|||
#include "libguile/print.h"
|
||||
#include "libguile/procprop.h"
|
||||
#include "libguile/programs.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/smob.h"
|
||||
#include "libguile/srcprop.h"
|
||||
#include "libguile/stackchk.h"
|
||||
|
|
|
@ -28,7 +28,6 @@
|
|||
#endif
|
||||
|
||||
#include "libguile/_scm.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/strings.h"
|
||||
#include "libguile/validate.h"
|
||||
#include "libguile/fluids.h"
|
||||
|
|
|
@ -24,7 +24,6 @@
|
|||
|
||||
|
||||
#include "libguile/__scm.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/vectors.h"
|
||||
|
||||
|
||||
|
|
|
@ -43,7 +43,6 @@ extern unsigned long * __libc_ia64_register_backing_store_base;
|
|||
#include "libguile/arrays.h"
|
||||
#include "libguile/async.h"
|
||||
#include "libguile/ports.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/strings.h"
|
||||
#include "libguile/vectors.h"
|
||||
#include "libguile/hashtab.h"
|
||||
|
|
|
@ -45,7 +45,6 @@ extern unsigned long * __libc_ia64_register_backing_store_base;
|
|||
#include "libguile/arrays.h"
|
||||
#include "libguile/async.h"
|
||||
#include "libguile/ports.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/simpos.h"
|
||||
#include "libguile/strings.h"
|
||||
#include "libguile/vectors.h"
|
||||
|
|
|
@ -54,7 +54,6 @@
|
|||
#include "libguile/print.h"
|
||||
#include "libguile/smob.h"
|
||||
#include "libguile/validate.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/hashtab.h"
|
||||
#include "libguile/deprecation.h"
|
||||
#include "libguile/eval.h"
|
||||
|
|
|
@ -31,7 +31,6 @@
|
|||
#include "libguile/alist.h"
|
||||
#include "libguile/hash.h"
|
||||
#include "libguile/eval.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/vectors.h"
|
||||
#include "libguile/ports.h"
|
||||
#include "libguile/bdw-gc.h"
|
||||
|
|
|
@ -28,7 +28,6 @@
|
|||
#include "libguile/eval.h"
|
||||
#include "libguile/ports.h"
|
||||
#include "libguile/procprop.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/smob.h"
|
||||
#include "libguile/strings.h"
|
||||
|
||||
|
|
|
@ -412,7 +412,6 @@ scm_i_init_guile (void *base)
|
|||
scm_smob_prehistory ();
|
||||
scm_init_variable ();
|
||||
scm_init_continuations (); /* requires smob_prehistory */
|
||||
scm_init_root (); /* requires continuations */
|
||||
scm_init_threads (); /* requires smob_prehistory */
|
||||
scm_init_gsubr ();
|
||||
scm_init_procprop ();
|
||||
|
|
|
@ -29,7 +29,6 @@
|
|||
#include "libguile/_scm.h"
|
||||
#include "libguile/async.h"
|
||||
#include "libguile/ports.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/smob.h"
|
||||
#include "libguile/hashtab.h"
|
||||
|
||||
|
|
|
@ -37,7 +37,6 @@
|
|||
#include "libguile/loader.h"
|
||||
#include "libguile/modules.h"
|
||||
#include "libguile/read.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/srfi-13.h"
|
||||
#include "libguile/strings.h"
|
||||
#include "libguile/throw.h"
|
||||
|
|
|
@ -62,7 +62,6 @@
|
|||
#include "libguile/_scm.h"
|
||||
#include "libguile/feature.h"
|
||||
#include "libguile/ports.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/smob.h"
|
||||
#include "libguile/strings.h"
|
||||
#include "libguile/bdw-gc.h"
|
||||
|
|
|
@ -26,7 +26,6 @@
|
|||
#include "libguile/async.h"
|
||||
#include "libguile/hashtab.h"
|
||||
#include "libguile/alist.h"
|
||||
#include "libguile/root.h"
|
||||
|
||||
#include "libguile/objprop.h"
|
||||
|
||||
|
|
|
@ -51,7 +51,6 @@
|
|||
|
||||
#include "libguile/keywords.h"
|
||||
#include "libguile/hashtab.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/strings.h"
|
||||
#include "libguile/mallocs.h"
|
||||
#include "libguile/validate.h"
|
||||
|
|
|
@ -44,7 +44,6 @@
|
|||
#include "libguile/struct.h"
|
||||
#include "libguile/ports.h"
|
||||
#include "libguile/ports-internal.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/strings.h"
|
||||
#include "libguile/strports.h"
|
||||
#include "libguile/vectors.h"
|
||||
|
|
|
@ -29,7 +29,6 @@
|
|||
#include "libguile/procs.h"
|
||||
#include "libguile/gsubr.h"
|
||||
#include "libguile/smob.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/vectors.h"
|
||||
#include "libguile/weak-table.h"
|
||||
#include "libguile/programs.h"
|
||||
|
|
|
@ -49,7 +49,6 @@
|
|||
#include "libguile/print.h"
|
||||
#include "libguile/procprop.h"
|
||||
#include "libguile/programs.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/smob.h"
|
||||
#include "libguile/srcprop.h"
|
||||
#include "libguile/stackchk.h"
|
||||
|
|
|
@ -33,7 +33,6 @@
|
|||
#include "libguile/modules.h"
|
||||
#include "libguile/ports.h"
|
||||
#include "libguile/rdelim.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/strings.h"
|
||||
#include "libguile/strports.h"
|
||||
#include "libguile/validate.h"
|
||||
|
|
|
@ -47,7 +47,6 @@
|
|||
#include "libguile/ports.h"
|
||||
#include "libguile/ports-internal.h"
|
||||
#include "libguile/fports.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/strings.h"
|
||||
#include "libguile/strports.h"
|
||||
#include "libguile/vectors.h"
|
||||
|
|
200
libguile/root.c
200
libguile/root.c
|
@ -1,200 +0,0 @@
|
|||
/* Copyright (C) 1995,1996,1997,1998,1999,2000, 2001, 2002, 2006, 2008, 2009, 2012 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 3 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., 51 Franklin Street, Fifth Floor, Boston, MA
|
||||
* 02110-1301 USA
|
||||
*/
|
||||
|
||||
|
||||
|
||||
#ifdef HAVE_CONFIG_H
|
||||
# include <config.h>
|
||||
#endif
|
||||
|
||||
#include <string.h>
|
||||
#include <stdio.h>
|
||||
|
||||
#include "libguile/_scm.h"
|
||||
#include "libguile/stackchk.h"
|
||||
#include "libguile/dynwind.h"
|
||||
#include "libguile/eval.h"
|
||||
#include "libguile/smob.h"
|
||||
#include "libguile/pairs.h"
|
||||
#include "libguile/throw.h"
|
||||
#include "libguile/fluids.h"
|
||||
#include "libguile/ports.h"
|
||||
|
||||
#include "libguile/root.h"
|
||||
|
||||
|
||||
/* {call-with-dynamic-root}
|
||||
*
|
||||
* Suspending the current thread to evaluate a thunk on the
|
||||
* same C stack but under a new root.
|
||||
*
|
||||
* Calls to call-with-dynamic-root return exactly once (unless
|
||||
* the process is somehow exitted). */
|
||||
|
||||
/* cwdr fills out both of these structures, and then passes a pointer
|
||||
to them through scm_internal_catch to the cwdr_body and
|
||||
cwdr_handler functions, to tell them how to behave and to get
|
||||
information back from them.
|
||||
|
||||
A cwdr is a lot like a catch, except there is no tag (all
|
||||
exceptions are caught), and the body procedure takes the arguments
|
||||
passed to cwdr as A1 and ARGS. The handler is also special since
|
||||
it is not directly run from scm_internal_catch. It is executed
|
||||
outside the new dynamic root. */
|
||||
|
||||
struct cwdr_body_data {
|
||||
/* Arguments to pass to the cwdr body function. */
|
||||
SCM a1, args;
|
||||
|
||||
/* Scheme procedure to use as body of cwdr. */
|
||||
SCM body_proc;
|
||||
};
|
||||
|
||||
struct cwdr_handler_data {
|
||||
/* Do we need to run the handler? */
|
||||
int run_handler;
|
||||
|
||||
/* The tag and args to pass it. */
|
||||
SCM tag, args;
|
||||
};
|
||||
|
||||
|
||||
/* Invoke the body of a cwdr, assuming that the throw handler has
|
||||
already been set up. DATA points to a struct set up by cwdr that
|
||||
says what proc to call, and what args to apply it to.
|
||||
|
||||
With a little thought, we could replace this with scm_body_thunk,
|
||||
but I don't want to mess with that at the moment. */
|
||||
static SCM
|
||||
cwdr_body (void *data)
|
||||
{
|
||||
struct cwdr_body_data *c = (struct cwdr_body_data *) data;
|
||||
|
||||
return scm_apply (c->body_proc, c->a1, c->args);
|
||||
}
|
||||
|
||||
/* Record the fact that the body of the cwdr has thrown. Record
|
||||
enough information to invoke the handler later when the dynamic
|
||||
root has been deestablished. */
|
||||
|
||||
static SCM
|
||||
cwdr_handler (void *data, SCM tag, SCM args)
|
||||
{
|
||||
struct cwdr_handler_data *c = (struct cwdr_handler_data *) data;
|
||||
|
||||
c->run_handler = 1;
|
||||
c->tag = tag;
|
||||
c->args = args;
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
|
||||
SCM
|
||||
scm_internal_cwdr (scm_t_catch_body body, void *body_data,
|
||||
scm_t_catch_handler handler, void *handler_data,
|
||||
SCM_STACKITEM *stack_start)
|
||||
{
|
||||
struct cwdr_handler_data my_handler_data;
|
||||
scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack;
|
||||
SCM answer;
|
||||
scm_t_dynstack *old_dynstack;
|
||||
|
||||
/* Exit caller's dynamic state.
|
||||
*/
|
||||
old_dynstack = scm_dynstack_capture_all (dynstack);
|
||||
scm_dynstack_unwind (dynstack, SCM_DYNSTACK_FIRST (dynstack));
|
||||
|
||||
scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
|
||||
scm_dynwind_current_dynamic_state (scm_make_dynamic_state (SCM_UNDEFINED));
|
||||
|
||||
my_handler_data.run_handler = 0;
|
||||
answer = scm_i_with_continuation_barrier (body, body_data,
|
||||
cwdr_handler, &my_handler_data,
|
||||
NULL, NULL);
|
||||
|
||||
scm_dynwind_end ();
|
||||
|
||||
/* Enter caller's dynamic state.
|
||||
*/
|
||||
scm_dynstack_wind (dynstack, SCM_DYNSTACK_FIRST (old_dynstack));
|
||||
|
||||
/* Now run the real handler iff the body did a throw. */
|
||||
if (my_handler_data.run_handler)
|
||||
return handler (handler_data, my_handler_data.tag, my_handler_data.args);
|
||||
else
|
||||
return answer;
|
||||
}
|
||||
|
||||
/* The original CWDR for invoking Scheme code with a Scheme handler. */
|
||||
|
||||
static SCM
|
||||
cwdr (SCM proc, SCM a1, SCM args, SCM handler, SCM_STACKITEM *stack_start)
|
||||
{
|
||||
struct cwdr_body_data c;
|
||||
|
||||
c.a1 = a1;
|
||||
c.args = args;
|
||||
c.body_proc = proc;
|
||||
|
||||
return scm_internal_cwdr (cwdr_body, &c,
|
||||
scm_handle_by_proc, &handler,
|
||||
stack_start);
|
||||
}
|
||||
|
||||
SCM_DEFINE (scm_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0,
|
||||
(SCM thunk, SCM handler),
|
||||
"Call @var{thunk} with a new dynamic state and within\n"
|
||||
"a continuation barrier. The @var{handler} catches all\n"
|
||||
"otherwise uncaught throws and executes within the same\n"
|
||||
"dynamic context as @var{thunk}.")
|
||||
#define FUNC_NAME s_scm_call_with_dynamic_root
|
||||
{
|
||||
SCM_STACKITEM stack_place;
|
||||
return cwdr (thunk, SCM_EOL, SCM_EOL, handler, &stack_place);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_dynamic_root, "dynamic-root", 0, 0, 0,
|
||||
(),
|
||||
"Return an object representing the current dynamic root.\n\n"
|
||||
"These objects are only useful for comparison using @code{eq?}.\n")
|
||||
#define FUNC_NAME s_scm_dynamic_root
|
||||
{
|
||||
return SCM_I_CURRENT_THREAD->continuation_root;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM
|
||||
scm_apply_with_dynamic_root (SCM proc, SCM a1, SCM args, SCM handler)
|
||||
{
|
||||
SCM_STACKITEM stack_place;
|
||||
return cwdr (proc, a1, args, handler, &stack_place);
|
||||
}
|
||||
|
||||
|
||||
|
||||
void
|
||||
scm_init_root ()
|
||||
{
|
||||
#include "libguile/root.x"
|
||||
}
|
||||
|
||||
/*
|
||||
Local Variables:
|
||||
c-file-style: "gnu"
|
||||
End:
|
||||
*/
|
|
@ -1,48 +0,0 @@
|
|||
/* classes: h_files */
|
||||
|
||||
#ifndef SCM_ROOT_H
|
||||
#define SCM_ROOT_H
|
||||
|
||||
/* Copyright (C) 1996,1998,2000,2001, 2002, 2006, 2008, 2009 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 3 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., 51 Franklin Street, Fifth Floor, Boston, MA
|
||||
* 02110-1301 USA
|
||||
*/
|
||||
|
||||
|
||||
|
||||
#include "libguile/__scm.h"
|
||||
#include "libguile/debug.h"
|
||||
#include "libguile/throw.h"
|
||||
|
||||
|
||||
|
||||
SCM_API SCM scm_internal_cwdr (scm_t_catch_body body,
|
||||
void *body_data,
|
||||
scm_t_catch_handler handler,
|
||||
void *handler_data,
|
||||
SCM_STACKITEM *stack_start);
|
||||
SCM_API SCM scm_call_with_dynamic_root (SCM thunk, SCM handler);
|
||||
SCM_API SCM scm_dynamic_root (void);
|
||||
SCM_API SCM scm_apply_with_dynamic_root (SCM proc, SCM a1, SCM args, SCM handler);
|
||||
SCM_INTERNAL void scm_init_root (void);
|
||||
|
||||
#endif /* SCM_ROOT_H */
|
||||
|
||||
/*
|
||||
Local Variables:
|
||||
c-file-style: "gnu"
|
||||
End:
|
||||
*/
|
|
@ -30,7 +30,6 @@
|
|||
#include "libguile/_scm.h"
|
||||
#include "libguile/fports.h"
|
||||
#include "libguile/ports.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/rw.h"
|
||||
#include "libguile/strings.h"
|
||||
#include "libguile/validate.h"
|
||||
|
|
|
@ -45,7 +45,6 @@
|
|||
|
||||
#include "libguile/async.h"
|
||||
#include "libguile/eval.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/vectors.h"
|
||||
#include "libguile/threads.h"
|
||||
|
||||
|
|
|
@ -33,7 +33,6 @@
|
|||
#include "libguile/hashtab.h"
|
||||
#include "libguile/hash.h"
|
||||
#include "libguile/ports.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/gc.h"
|
||||
|
||||
#include "libguile/validate.h"
|
||||
|
|
|
@ -24,7 +24,6 @@
|
|||
|
||||
#include "libguile/_scm.h"
|
||||
#include "libguile/ports.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/threads.h"
|
||||
#include "libguile/dynwind.h"
|
||||
|
||||
|
|
|
@ -32,7 +32,6 @@
|
|||
#include "libguile/macros.h"
|
||||
#include "libguile/procprop.h"
|
||||
#include "libguile/modules.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/strings.h"
|
||||
#include "libguile/vm.h" /* to capture vm stacks */
|
||||
#include "libguile/frames.h" /* vm frames */
|
||||
|
|
|
@ -36,7 +36,6 @@
|
|||
|
||||
#include "libguile/_scm.h"
|
||||
#include "libguile/chars.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/strings.h"
|
||||
#include "libguile/ports.h"
|
||||
#include "libguile/ports-internal.h"
|
||||
|
|
|
@ -33,7 +33,6 @@
|
|||
#include "libguile/eval.h"
|
||||
#include "libguile/ports.h"
|
||||
#include "libguile/read.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/strings.h"
|
||||
#include "libguile/modules.h"
|
||||
#include "libguile/validate.h"
|
||||
|
|
|
@ -52,7 +52,6 @@
|
|||
#include <nproc.h>
|
||||
|
||||
#include "libguile/validate.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/eval.h"
|
||||
#include "libguile/async.h"
|
||||
#include "libguile/ports.h"
|
||||
|
|
|
@ -27,7 +27,6 @@
|
|||
#include "libguile/__scm.h"
|
||||
#include "libguile/procs.h"
|
||||
#include "libguile/throw.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/dynstack.h"
|
||||
#include "libguile/iselect.h"
|
||||
#include "libguile/continuations.h"
|
||||
|
|
|
@ -26,7 +26,6 @@
|
|||
#include "libguile/gc.h"
|
||||
#include "libguile/numbers.h"
|
||||
#include "libguile/ports.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/strings.h"
|
||||
#include "libguile/struct.h"
|
||||
#include "libguile/validate.h"
|
||||
|
|
|
@ -25,7 +25,6 @@
|
|||
#include "libguile/_scm.h"
|
||||
#include "libguile/eq.h"
|
||||
#include "libguile/ports.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/smob.h"
|
||||
#include "libguile/deprecation.h"
|
||||
|
||||
|
|
|
@ -25,7 +25,6 @@
|
|||
|
||||
#include "libguile/_scm.h"
|
||||
#include "libguile/eq.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/strings.h"
|
||||
|
||||
#include "libguile/validate.h"
|
||||
|
|
|
@ -32,7 +32,6 @@
|
|||
#include "libguile/ports.h"
|
||||
#include "libguile/ports-internal.h"
|
||||
#include "libguile/fports.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/strings.h"
|
||||
#include "libguile/vectors.h"
|
||||
|
||||
|
|
|
@ -71,16 +71,16 @@
|
|||
(lambda ()
|
||||
(lock-mutex admin-mutex)
|
||||
(set! outer-owner owner)
|
||||
(if (not (eqv? outer-owner (dynamic-root)))
|
||||
(if (not (eqv? outer-owner (current-thread)))
|
||||
(begin
|
||||
(unlock-mutex admin-mutex)
|
||||
(lock-mutex serialization-mutex)
|
||||
(set! owner (dynamic-root)))
|
||||
(set! owner (current-thread)))
|
||||
(unlock-mutex admin-mutex)))
|
||||
thunk
|
||||
(lambda ()
|
||||
(lock-mutex admin-mutex)
|
||||
(if (not (eqv? outer-owner (dynamic-root)))
|
||||
(if (not (eqv? outer-owner (current-thread)))
|
||||
(begin
|
||||
(set! owner #f)
|
||||
(unlock-mutex serialization-mutex)))
|
||||
|
@ -95,7 +95,7 @@
|
|||
(lambda ()
|
||||
(lock-mutex admin-mutex)
|
||||
(set! outer-owner owner)
|
||||
(if (eqv? outer-owner (dynamic-root))
|
||||
(if (eqv? outer-owner (current-thread))
|
||||
(begin
|
||||
(set! owner #f)
|
||||
(unlock-mutex serialization-mutex)))
|
||||
|
@ -103,7 +103,7 @@
|
|||
thunk
|
||||
(lambda ()
|
||||
(lock-mutex admin-mutex)
|
||||
(if (eqv? outer-owner (dynamic-root))
|
||||
(if (eqv? outer-owner (current-thread))
|
||||
(begin
|
||||
(unlock-mutex admin-mutex)
|
||||
(lock-mutex serialization-mutex)
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue