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" } /* diff --git a/libguile/control.h b/libguile/control.h index a0e313193..3ec965705 100644 --- a/libguile/control.h +++ b/libguile/control.h @@ -41,12 +41,11 @@ struct scm_prompt_registers }; -SCM_INTERNAL SCM scm_c_make_prompt (SCM vm, SCM k, SCM handler, - scm_t_uint8 escape_only_p); +SCM_INTERNAL SCM scm_c_make_prompt (SCM vm, SCM k, scm_t_uint8 escape_only_p); SCM_INTERNAL SCM scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv) SCM_NORETURN; -SCM_INTERNAL void scm_register_control (void); +SCM_INTERNAL void scm_init_control (void); #endif /* SCM_CONTROL_H */ diff --git a/libguile/eval.c b/libguile/eval.c index 48eb09e93..1b466de44 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -31,6 +31,7 @@ #include "libguile/alist.h" #include "libguile/async.h" #include "libguile/continuations.h" +#include "libguile/control.h" #include "libguile/debug.h" #include "libguile/deprecation.h" #include "libguile/dynwind.h" @@ -424,6 +425,38 @@ eval (SCM x, SCM env) return SCM_UNSPECIFIED; } + case SCM_M_PROMPT: + { + SCM prompt, handler, res; + + prompt = scm_c_make_prompt (scm_the_vm (), eval (CAR (mx), env), 0); + handler = eval (CDDR (mx), env); + scm_i_set_dynwinds (scm_cons (prompt, scm_i_dynwinds ())); + + if (SCM_PROMPT_SETJMP (prompt)) + { + /* The prompt exited nonlocally. The args are on the VM stack. */ + size_t i, n; + SCM vals = SCM_EOL; + n = scm_to_size_t (SCM_PROMPT_REGISTERS (prompt)->sp[0]); + for (i = 0; i < n; i++) + vals = scm_cons (SCM_PROMPT_REGISTERS (prompt)->sp[-(i + 1)], vals); + /* The abort did reset the VM's registers, but then these values + were pushed on; so we need to pop them ourselves. */ + SCM_VM_DATA (scm_the_vm ())->sp -= n + 1; + /* FIXME NULLSTACK */ + + /* FIXME mark cont as non-reentrant */ + proc = handler; + args = vals; + goto apply_proc; + } + + res = eval (CADR (mx), env); + scm_i_set_dynwinds (CDR (scm_i_dynwinds ())); + return res; + } + default: abort (); } diff --git a/libguile/init.c b/libguile/init.c index 1288f7f77..e72b9460f 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -454,7 +454,6 @@ scm_i_init_guile (SCM_STACKITEM *base) scm_bootstrap_programs (); scm_bootstrap_vm (); scm_register_foreign (); - scm_register_control (); scm_init_strings (); /* Requires array-handle */ scm_init_struct (); /* Requires strings */ @@ -471,6 +470,7 @@ scm_i_init_guile (SCM_STACKITEM *base) scm_init_async (); /* requires smob_prehistory */ scm_init_boolean (); scm_init_chars (); + scm_init_control (); #ifdef GUILE_DEBUG_MALLOC scm_init_debug_malloc (); #endif diff --git a/libguile/memoize.c b/libguile/memoize.c index 4c1a1017b..e2fcfee0d 100644 --- a/libguile/memoize.c +++ b/libguile/memoize.c @@ -223,6 +223,8 @@ scm_t_bits scm_tc16_memoized; MAKMEMO (SCM_M_MODULE_REF, scm_cons (mod, scm_cons (var, public))) #define MAKMEMO_MOD_SET(val, mod, var, public) \ MAKMEMO (SCM_M_MODULE_SET, scm_cons (val, scm_cons (mod, scm_cons (var, public)))) +#define MAKMEMO_PROMPT(tag, exp, handler) \ + MAKMEMO (SCM_M_PROMPT, scm_cons (tag, scm_cons (exp, handler))) @@ -247,6 +249,7 @@ static const char *const memoized_tags[] = "toplevel-set!", "module-ref", "module-set!", + "prompt", }; static int @@ -276,6 +279,7 @@ static SCM scm_m_let (SCM xorig, SCM env); static SCM scm_m_letrec (SCM xorig, SCM env); static SCM scm_m_letstar (SCM xorig, SCM env); static SCM scm_m_or (SCM xorig, SCM env); +static SCM scm_m_at_prompt (SCM xorig, SCM env); static SCM scm_m_quote (SCM xorig, SCM env); static SCM scm_m_set_x (SCM xorig, SCM env); @@ -413,6 +417,7 @@ SCM_SYNTAX (s_let, "let", scm_m_let); SCM_SYNTAX (s_letrec, "letrec", scm_m_letrec); SCM_SYNTAX (s_letstar, "let*", scm_m_letstar); SCM_SYNTAX (s_or, "or", scm_m_or); +SCM_SYNTAX (s_at_prompt, "@prompt", scm_m_at_prompt); SCM_SYNTAX (s_quote, "quote", scm_m_quote); SCM_SYNTAX (s_set_x, "set!", scm_m_set_x); SCM_SYNTAX (s_atapply, "@apply", scm_m_apply); @@ -439,6 +444,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_let, "let"); SCM_GLOBAL_SYMBOL (scm_sym_letrec, "letrec"); SCM_GLOBAL_SYMBOL (scm_sym_letstar, "let*"); SCM_GLOBAL_SYMBOL (scm_sym_or, "or"); +SCM_GLOBAL_SYMBOL (scm_sym_at_prompt, "@prompt"); SCM_GLOBAL_SYMBOL (scm_sym_quote, "quote"); SCM_GLOBAL_SYMBOL (scm_sym_set_x, "set!"); SCM_SYMBOL (sym_eval, "eval"); @@ -980,6 +986,17 @@ scm_m_or (SCM expr, SCM env SCM_UNUSED) return CDR (ret); } +static SCM +scm_m_at_prompt (SCM expr, SCM env) +{ + ASSERT_SYNTAX (scm_ilength (expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (expr) == 4, s_expression, expr); + + return MAKMEMO_PROMPT (memoize (CADR (expr), env), + memoize (CADDR (expr), env), + memoize (CADDDR (expr), env)); +} + static SCM scm_m_quote (SCM expr, SCM env SCM_UNUSED) { @@ -1159,6 +1176,11 @@ unmemoize (const SCM expr) scm_i_finite_list_copy (CADR (args)), CADDR (args)), unmemoize (CAR (args))); + case SCM_M_PROMPT: + return scm_list_4 (scm_sym_at_prompt, + unmemoize (CAR (args)), + unmemoize (CADR (args)), + unmemoize (CDDR (args))); default: abort (); } diff --git a/libguile/memoize.h b/libguile/memoize.h index 818cdbd83..26bd5b1c1 100644 --- a/libguile/memoize.h +++ b/libguile/memoize.h @@ -51,6 +51,7 @@ SCM_API SCM scm_sym_atat; SCM_API SCM scm_sym_atapply; SCM_API SCM scm_sym_atcall_cc; SCM_API SCM scm_sym_at_call_with_values; +SCM_API SCM scm_sym_at_prompt; SCM_API SCM scm_sym_delay; SCM_API SCM scm_sym_at_dynamic_wind; SCM_API SCM scm_sym_eval_when; @@ -88,7 +89,8 @@ enum SCM_M_TOPLEVEL_REF, SCM_M_TOPLEVEL_SET, SCM_M_MODULE_REF, - SCM_M_MODULE_SET + SCM_M_MODULE_SET, + SCM_M_PROMPT }; diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 925c8d317..7a1700101 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -1454,18 +1454,17 @@ VM_DEFINE_INSTRUCTION (83, prompt, "prompt", 4, 2, 0) { scm_t_int32 offset; scm_t_uint8 escape_only_p; - SCM k, handler, prompt; + SCM k, prompt; escape_only_p = FETCH (); FETCH_OFFSET (offset); - POP (handler); POP (k); SYNC_REGISTER (); /* Push the prompt onto the dynamic stack. The setjmp itself has to be local to this procedure. */ /* FIXME: do more error checking */ - prompt = scm_c_make_prompt (vm, k, handler, escape_only_p); + prompt = scm_c_make_prompt (vm, k, escape_only_p); scm_i_set_dynwinds (scm_cons (prompt, scm_i_dynwinds ())); if (SCM_PROMPT_SETJMP (prompt)) { diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 098ad51f1..6dc2b68e1 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -401,6 +401,10 @@ (define (and=> value procedure) (and value (procedure value))) (define call/cc call-with-current-continuation) +;;; Delimited continuations +(define (prompt tag thunk handler) + (@prompt tag (thunk) handler)) + ;;; apply-to-args is functionally redundant with apply and, worse, ;;; is less general than apply since it only takes two arguments. ;;; diff --git a/module/ice-9/control.scm b/module/ice-9/control.scm index 75e9d3739..a621e8d7c 100644 --- a/module/ice-9/control.scm +++ b/module/ice-9/control.scm @@ -19,24 +19,14 @@ ;;; Code: (define-module (ice-9 control) - #:use-module (language tree-il primitives) - #:export (% prompt control)) + #:re-export (prompt) + #:export (% control)) -(eval-when (eval load compile) - (load-extension "libguile" "scm_init_control") - (add-interesting-primitive! '@prompt) - (add-interesting-primitive! '@control) +;; the same as abort. +(define (control tag . args) + (apply abort tag args)) - (define (prompt tag thunk handler) - (@prompt tag thunk handler #f)) - - (define (control tag . args) - (apply @control tag 'throw args)) - - (define-syntax % - (syntax-rules () - ((_ expr handler) - (prompt (lambda () expr) handler)))) - - (add-interesting-primitive! 'prompt) - (add-interesting-primitive! 'control)) +(define-syntax % + (syntax-rules () + ((_ expr handler) + (prompt (lambda () expr) handler)))) diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm index 0e02cbc75..f7cb6ce3e 100644 --- a/module/ice-9/eval.scm +++ b/module/ice-9/eval.scm @@ -309,6 +309,11 @@ (vals (map (lambda (x) (eval x env)) vals))) (with-fluids* fluids vals (lambda () (eval exp env))))) + (('prompt (tag exp . handler)) + (@prompt (eval tag env) + (eval exp env) + (eval handler env))) + (('call/cc proc) (call/cc (eval proc env))) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 58b75fc10..b78339618 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -63,6 +63,8 @@ fluid-ref fluid-set! + @prompt prompt + struct? struct-vtable make-struct struct-ref struct-set! bytevector-u8-ref bytevector-u8-set!