summaryrefslogtreecommitdiff
path: root/libguile/throw.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/throw.c')
-rw-r--r--libguile/throw.c144
1 files changed, 73 insertions, 71 deletions
diff --git a/libguile/throw.c b/libguile/throw.c
index 123544e79..2fd25fcc6 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -1,20 +1,21 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2014 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
- */
+/* Copyright 1995-1998,2000-2001,2003-2004,2006,2008,2009-2014,2017-2018
+ Free Software Foundation, Inc.
+
+ This file is part of Guile.
+
+ Guile 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.
+
+ Guile 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 Guile. If not, see
+ <https://www.gnu.org/licenses/>. */
@@ -25,25 +26,32 @@
#include <alloca.h>
#include <stdio.h>
#include <unistdio.h>
-#include "libguile/_scm.h"
-#include "libguile/smob.h"
-#include "libguile/eval.h"
-#include "libguile/eq.h"
-#include "libguile/control.h"
-#include "libguile/deprecation.h"
-#include "libguile/backtrace.h"
-#include "libguile/debug.h"
-#include "libguile/stackchk.h"
-#include "libguile/stacks.h"
-#include "libguile/fluids.h"
-#include "libguile/ports.h"
-#include "libguile/validate.h"
-#include "libguile/vm.h"
-#include "libguile/throw.h"
-#include "libguile/init.h"
-#include "libguile/strings.h"
-
-#include "libguile/private-options.h"
+
+#include "backtrace.h"
+#include "boolean.h"
+#include "control.h"
+#include "debug.h"
+#include "deprecation.h"
+#include "eq.h"
+#include "eval.h"
+#include "fluids.h"
+#include "gsubr.h"
+#include "init.h"
+#include "list.h"
+#include "modules.h"
+#include "numbers.h"
+#include "pairs.h"
+#include "ports.h"
+#include "private-options.h"
+#include "smob.h"
+#include "stackchk.h"
+#include "stacks.h"
+#include "strings.h"
+#include "symbols.h"
+#include "variable.h"
+#include "vm.h"
+
+#include "throw.h"
/* Pleasantly enough, the guts of catch are defined in Scheme, in terms
@@ -72,14 +80,15 @@ static SCM exception_handler_fluid;
static SCM
catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
{
- struct scm_vm *vp;
SCM eh, prompt_tag;
SCM res;
- scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack;
- scm_t_dynamic_state *dynamic_state = SCM_I_CURRENT_THREAD->dynamic_state;
- scm_i_jmp_buf registers;
- const void *prev_cookie;
- scm_t_ptrdiff saved_stack_depth;
+ scm_thread *t = SCM_I_CURRENT_THREAD;
+ scm_t_dynstack *dynstack = &t->dynstack;
+ scm_t_dynamic_state *dynamic_state = t->dynamic_state;
+ jmp_buf registers;
+ jmp_buf *prev_registers;
+ ptrdiff_t saved_stack_depth;
+ uint8_t *mra = NULL;
if (!scm_is_eq (tag, SCM_BOOL_T) && !scm_is_symbol (tag))
scm_wrong_type_arg ("catch", 1, tag);
@@ -101,32 +110,32 @@ catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
scm_c_vector_set_x (eh, 1, prompt_tag);
scm_c_vector_set_x (eh, 2, pre_unwind_handler);
- vp = scm_the_vm ();
- prev_cookie = vp->resumable_prompt_cookie;
- saved_stack_depth = vp->stack_top - vp->sp;
+ prev_registers = t->vm.registers;
+ saved_stack_depth = t->vm.stack_top - t->vm.sp;
/* Push the prompt and exception handler onto the dynamic stack. */
scm_dynstack_push_prompt (dynstack,
SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY,
prompt_tag,
- vp->stack_top - vp->fp,
+ t->vm.stack_top - t->vm.fp,
saved_stack_depth,
- vp->ip,
+ t->vm.ip,
+ mra,
&registers);
scm_dynstack_push_fluid (dynstack, exception_handler_fluid, eh,
dynamic_state);
- if (SCM_I_SETJMP (registers))
+ if (setjmp (registers))
{
/* A non-local return. */
SCM args;
- vp->resumable_prompt_cookie = prev_cookie;
+ t->vm.registers = prev_registers;
scm_gc_after_nonlocal_exit ();
/* FIXME: We know where the args will be on the stack; we could
avoid consing them. */
- args = scm_i_prompt_pop_abort_args_x (vp, saved_stack_depth);
+ args = scm_i_prompt_pop_abort_args_x (&t->vm, saved_stack_depth);
/* Cdr past the continuation. */
args = scm_cdr (args);
@@ -178,22 +187,19 @@ default_exception_handler (SCM k, SCM args)
static void
abort_to_prompt (SCM prompt_tag, SCM tag, SCM args)
{
- SCM *argv;
+ SCM *tag_and_argv;
size_t i;
long n;
- n = scm_ilength (args) + 1;
- argv = alloca (sizeof (SCM)*n);
- argv[0] = tag;
- for (i = 1; i < n; i++, args = scm_cdr (args))
- argv[i] = scm_car (args);
-
- scm_c_abort (scm_the_vm (), prompt_tag, n, argv, NULL);
-
- /* Oh, what, you're still here? The abort must have been reinstated. Actually,
- that's quite impossible, given that we're already in C-land here, so...
- abort! */
+ n = scm_ilength (args) + 2;
+ tag_and_argv = alloca (sizeof (SCM)*n);
+ tag_and_argv[0] = prompt_tag;
+ tag_and_argv[1] = tag;
+ for (i = 2; i < n; i++, args = scm_cdr (args))
+ tag_and_argv[i] = scm_car (args);
+ scm_i_vm_emergency_abort (tag_and_argv, n);
+ /* Unreachable. */
abort ();
}
@@ -263,7 +269,9 @@ scm_with_throw_handler (SCM key, SCM thunk, SCM handler)
SCM
scm_throw (SCM key, SCM args)
{
- return scm_apply_1 (scm_variable_ref (throw_var), key, args);
+ scm_apply_1 (scm_variable_ref (throw_var), key, args);
+ /* Should not be reached. */
+ abort ();
}
@@ -608,7 +616,7 @@ scm_handle_by_throw (void *handler_data SCM_UNUSED, SCM tag, SCM args)
SCM
scm_ithrow (SCM key, SCM args, int no_return SCM_UNUSED)
{
- return scm_throw (key, args);
+ scm_throw (key, args);
}
SCM_SYMBOL (scm_stack_overflow_key, "stack-overflow");
@@ -673,11 +681,5 @@ scm_init_throw ()
SCM_BOOL_F,
SCM_BOOL_F);
-#include "libguile/throw.x"
+#include "throw.x"
}
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/