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.

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 ();
 }
 
-
+SCM_DEFINE (scm_abort, "abort", 1, 0, 1, (SCM tag, SCM args),
-
+            "Abort to the nearest prompt with tag @var{tag}.")
-static void
+#define FUNC_NAME s_scm_abort
-scm_init_control (void)
 {
-#ifndef SCM_MAGIC_SNARFER
+  SCM *argv;
-#include "libguile/control.x"
+  size_t i, n;
-#endif
+
+  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
+void scm_init_control (void)
-scm_register_control (void)
 {
-  scm_c_register_extension ("libguile", "scm_init_control",
+#include "control.x"
-                            (scm_t_extension_init_func)scm_init_control,
-                            NULL);
 }
 
 /*

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_INTERNAL SCM scm_c_make_prompt (SCM vm, SCM k, scm_t_uint8 escape_only_p);
-                                    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 */

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 ();
     }

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

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 ();
     }

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
   };
 
 

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))
     {

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.
 ;;;

module/ice-9/control.scm

@@ -19,24 +19,14 @@
 ;;; Code:
 
 (define-module (ice-9 control)
-  #:use-module (language tree-il primitives)
+  #:re-export (prompt)
-  #:export (% prompt control))
+  #:export (% control))
-
-(eval-when (eval load compile)
-  (load-extension "libguile" "scm_init_control")
-  (add-interesting-primitive! '@prompt)
-  (add-interesting-primitive! '@control)
-
-  (define (prompt tag thunk handler)
-    (@prompt tag thunk handler #f))
 
+;; the same as abort.
 (define (control tag . args)
-    (apply @control tag 'throw args))
+  (apply abort tag args))
 
 (define-syntax %
   (syntax-rules ()
     ((_ expr handler)
      (prompt (lambda () expr) handler))))
-
-  (add-interesting-primitive! 'prompt)
-  (add-interesting-primitive! 'control))

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)))
 

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!