diff options
author | Andy Wingo <wingo@pobox.com> | 2010-02-19 22:44:24 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-02-19 22:44:24 +0100 |
commit | 747022e4cb5faef6e0a2c73f046bacd93bb99ab8 (patch) | |
tree | b37adc0822d4dafd24f6d8ee4ce1ac340ac56d45 /libguile/control.c | |
parent | 0bc8874c0461d532ca0251cf20af9bc5193b3cfa (diff) | |
download | guile-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.c | 70 |
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" } /* |