summaryrefslogtreecommitdiff
path: root/libguile/control.c
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2010-02-19 22:44:24 +0100
committerAndy Wingo <wingo@pobox.com>2010-02-19 22:44:24 +0100
commit747022e4cb5faef6e0a2c73f046bacd93bb99ab8 (patch)
treeb37adc0822d4dafd24f6d8ee4ce1ac340ac56d45 /libguile/control.c
parent0bc8874c0461d532ca0251cf20af9bc5193b3cfa (diff)
downloadguile-747022e4cb5faef6e0a2c73f046bacd93bb99ab8.tar.gz
prompt as part of guile's primitive language
* libguile/control.h: * libguile/control.c: Remove scm_atcontrol and scm_atprompt. (scm_c_make_prompt): Remove handler arg, as the handler is inline. (scm_abort): New primitive, exported to Scheme as `abort'. The compiler will also recognize calls to `abort', but this is the base case. (scm_init_control): Remove scm_register_control, just have this function, which adds `abort' to the `(guile)' module. * libguile/eval.c (eval): Add SCM_M_PROMPT case. * libguile/init.c (scm_i_init_guile): Change scm_register_control call into a nice orderly scm_init_control call. * libguile/memoize.h: (scm_sym_at_prompt, SCM_M_PROMPT): * libguile/memoize.c (MAKMEMO_PROMPT, scm_m_at_prompt, unmemoize): Add prompt support to the memoizer. * libguile/vm-i-system.c (prompt): Fix to not expect a handler on the stack. * module/ice-9/boot-9.scm (prompt): Add definition in terms of @prompt. * module/ice-9/control.scm: Simplify, and don't play with the compiler here, now that prompt and abort are primitive. * module/ice-9/eval.scm (primitive-eval): Add a prompt case. * module/language/tree-il/primitives.scm (*interesting-primitive-names*): Add @prompt and prompt.
Diffstat (limited to 'libguile/control.c')
-rw-r--r--libguile/control.c70
1 files changed, 34 insertions, 36 deletions
diff --git a/libguile/control.c b/libguile/control.c
index 43527ac74..a243be037 100644
--- a/libguile/control.c
+++ b/libguile/control.c
@@ -26,30 +26,8 @@
-SCM scm_atcontrol (SCM, SCM, SCM);
-SCM_DEFINE (scm_atcontrol, "@control", 3, 0, 0,
- (SCM tag, SCM type, SCM args),
- "Transfer control to the handler of a delimited continuation.")
-#define FUNC_NAME s_scm_atcontrol
-{
- abort ();
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM scm_atprompt (SCM, SCM, SCM, SCM);
-SCM_DEFINE (scm_atprompt, "@prompt", 4, 0, 0,
- (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler),
- "Begin a delimited continuation.")
-#define FUNC_NAME s_scm_atprompt
-{
- abort ();
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
SCM
-scm_c_make_prompt (SCM vm, SCM k, SCM handler, scm_t_uint8 escape_only_p)
+scm_c_make_prompt (SCM vm, SCM k, scm_t_uint8 escape_only_p)
{
scm_t_bits tag;
SCM ret;
@@ -68,7 +46,6 @@ scm_c_make_prompt (SCM vm, SCM k, SCM handler, scm_t_uint8 escape_only_p)
SCM_SET_CELL_OBJECT (ret, 1, k);
SCM_SET_CELL_WORD (ret, 2, (scm_t_bits)regs);
SCM_SET_CELL_OBJECT (ret, 3, scm_i_dynwinds ());
- SCM_SET_CELL_OBJECT (ret, 4, handler);
return ret;
}
@@ -132,22 +109,43 @@ scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv)
abort ();
}
-
-
-static void
-scm_init_control (void)
+SCM_DEFINE (scm_abort, "abort", 1, 0, 1, (SCM tag, SCM args),
+ "Abort to the nearest prompt with tag @var{tag}.")
+#define FUNC_NAME s_scm_abort
{
-#ifndef SCM_MAGIC_SNARFER
-#include "libguile/control.x"
-#endif
+ SCM *argv;
+ size_t i, n;
+
+ SCM_VALIDATE_LIST_COPYLEN (SCM_ARG2, args, n);
+ argv = alloca (sizeof (SCM)*n);
+ for (i = 0; i < n; i++, args = scm_cdr (args))
+ argv[i] = scm_car (args);
+
+ scm_c_abort (scm_the_vm (), tag, n, argv);
+
+ /* Oh, what, you're still here? The abort must have been reinstated. OK, pull
+ args back from the stack, and keep going... */
+
+ {
+ SCM vals = SCM_EOL;
+ struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ());
+ n = scm_to_size_t (vp->sp[0]);
+ for (i = 0; i < n; i++)
+ vals = scm_cons (vp->sp[-(i + 1)], vals);
+ /* The continuation call did reset the VM's registers, but then these values
+ were pushed on; so we need to pop them ourselves. */
+ vp->sp -= n + 1;
+ /* FIXME NULLSTACK */
+
+ return (scm_is_pair (vals) && scm_is_null (scm_cdr (vals)))
+ ? scm_car (vals) : scm_values (vals);
+ }
}
+#undef FUNC_NAME
-void
-scm_register_control (void)
+void scm_init_control (void)
{
- scm_c_register_extension ("libguile", "scm_init_control",
- (scm_t_extension_init_func)scm_init_control,
- NULL);
+#include "control.x"
}
/*