Remove @prompt memoizer

* libguile/memoize.h:
* libguile/memoize.c (MAKMEMO_CALL_WITH_PROMPT, memoize, unmemoize):
  Remove the @prompt memoizer in favor of recognizing call-with-prompt
  primcalls.  Rename SCM_M_PROMPT to SCM_M_CALL_WITH_PROMPT, and pass a
  thunk instead of an expression so that it has normal applicative
  order.

* libguile/expand.c (PRIMITIVE_REF, PRIMCALL, expand): Produce primcalls
  from forms whose car is a primitive.
  (expand_atat): Recognize (@@ primitive FOO) as being a primitive-ref.

* module/ice-9/boot-9.scm (call-with-prompt): Instead of dispatching to
  the wonky @prompt memoizer, residualize a primcall to
  call-with-prompt.  The memoizer will DTRT to allow call-with-prompt to
  be interpreted correctly without needing an additional binding.

* module/ice-9/eval.scm (primitive-eval): Change the 'prompt clause to a
  call to call-with-prompt.

* module/language/tree-il/primitives.scm: No more need to recognize
  @prompt.

* libguile/eval.c (eval): Adapt to SCM_M_PROMPT renaming to
  SCM_M_CALL_WITH_PROMPT, and apply the thunk.

* libguile/throw.c (pre_init_throw): Adapt to scm_abort_to_prompt_star
  rename.

8 files changed, 57 insertions, 66 deletions

diff --git a/libguile/eval.c b/libguile/eval.c
index f743ed78e..8494e10a0 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -436,7 +436,7 @@ eval (SCM x, SCM env)
           return SCM_UNSPECIFIED;
         }
 
-    case SCM_M_PROMPT:
+    case SCM_M_CALL_WITH_PROMPT:
       {
         SCM vm, k, res;
         scm_i_jmp_buf registers;
@@ -465,7 +465,7 @@ eval (SCM x, SCM env)
             goto apply_proc;
           }
         
-        res = eval (CADR (mx), env);
+        res = scm_call_0 (eval (CADR (mx), env));
         scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack);
         return res;
       }
diff --git a/libguile/expand.c b/libguile/expand.c
index cb32e371c..396df3b07 100644
--- a/libguile/expand.c
+++ b/libguile/expand.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012,2013
  * Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
@@ -56,8 +56,8 @@ static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];
   SCM_MAKE_EXPANDED_VOID(src)
 #define CONST_(src, exp) \
   SCM_MAKE_EXPANDED_CONST(src, exp)
-#define PRIMITIVE_REF_TYPE(src, name) \
-  SCM_MAKE_EXPANDED_PRIMITIVE_REF_TYPE(src, name)
+#define PRIMITIVE_REF(src, name) \
+  SCM_MAKE_EXPANDED_PRIMITIVE_REF(src, name)
 #define LEXICAL_REF(src, name, gensym) \
   SCM_MAKE_EXPANDED_LEXICAL_REF(src, name, gensym)
 #define LEXICAL_SET(src, name, gensym, exp) \
@@ -74,6 +74,8 @@ static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];
   SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, name, exp)
 #define CONDITIONAL(src, test, consequent, alternate) \
   SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate)
+#define PRIMCALL(src, name, exps) \
+  SCM_MAKE_EXPANDED_PRIMCALL(src, name, exps)
 #define CALL(src, proc, exps) \
   SCM_MAKE_EXPANDED_CALL(src, proc, exps)
 #define SEQ(src, head, tail) \
@@ -195,12 +197,13 @@ 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_SYMBOL (sym_call_with_prompt, "call-with-prompt");
 SCM_GLOBAL_SYMBOL (scm_sym_quote, "quote");
 SCM_GLOBAL_SYMBOL (scm_sym_set_x, "set!");
 SCM_SYMBOL (sym_lambda_star, "lambda*");
 SCM_SYMBOL (sym_eval, "eval");
 SCM_SYMBOL (sym_load, "load");
+SCM_SYMBOL (sym_primitive, "primitive");
 
 SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, "quasiquote");
@@ -356,17 +359,22 @@ expand (SCM exp, SCM env)
         {
           SCM arg_exps = SCM_EOL;
           SCM args = SCM_EOL;
-          SCM proc = CAR (exp);
+          SCM proc = expand (CAR (exp), env);
           
           for (arg_exps = CDR (exp); scm_is_pair (arg_exps);
                arg_exps = CDR (arg_exps))
             args = scm_cons (expand (CAR (arg_exps), env), args);
-          if (scm_is_null (arg_exps))
-            return CALL (scm_source_properties (exp),
-                         expand (proc, env),
-                         scm_reverse_x (args, SCM_UNDEFINED));
-          else
+          args = scm_reverse_x (args, SCM_UNDEFINED);
+
+          if (!scm_is_null (arg_exps))
             syntax_error ("expected a proper list", exp, SCM_UNDEFINED);
+
+          if (SCM_EXPANDED_TYPE (proc) == SCM_EXPANDED_PRIMITIVE_REF)
+            return PRIMCALL (scm_source_properties (exp),
+                             SCM_EXPANDED_REF (proc, PRIMITIVE_REF, NAME),
+                             args);
+          else
+            return CALL (scm_source_properties (exp), proc, args);
         }
     }
   else if (scm_is_symbol (exp))
@@ -423,9 +431,12 @@ static SCM
 expand_atat (SCM expr, SCM env SCM_UNUSED)
 {
   ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
-  ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
   ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr);
 
+  if (scm_is_eq (CADR (expr), sym_primitive))
+    return PRIMITIVE_REF (scm_source_properties (expr), CADDR (expr));
+
+  ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
   return MODULE_REF (scm_source_properties (expr),
                      CADR (expr), CADDR (expr), SCM_BOOL_F);
 }
diff --git a/libguile/memoize.c b/libguile/memoize.c
index f20241c20..f4a4c9ef7 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -112,8 +112,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)))
+#define MAKMEMO_CALL_WITH_PROMPT(tag, thunk, handler) \
+  MAKMEMO (SCM_M_CALL_WITH_PROMPT, scm_cons (tag, scm_cons (thunk, handler)))
 
 
 /* Primitives for the evaluator */
@@ -144,7 +144,7 @@ static const char *const memoized_tags[] =
   "toplevel-set!",
   "module-ref",
   "module-set!",
-  "prompt",
+  "call-with-prompt",
 };
 
 static int
@@ -267,16 +267,25 @@ memoize (SCM exp, SCM env)
 
     case SCM_EXPANDED_PRIMCALL:
       {
-        SCM proc, args;
+        SCM name, args;
+        int nargs;
 
-        if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
-          proc = MAKMEMO_TOP_REF (REF (exp, PRIMCALL, NAME));
-        else
-          proc = MAKMEMO_MOD_REF (list_of_guile, REF (exp, PRIMCALL, NAME),
-                                  SCM_BOOL_F);
+        name = REF (exp, PRIMCALL, NAME);
         args = memoize_exps (REF (exp, PRIMCALL, ARGS), env);
-
-        return MAKMEMO_CALL (proc, scm_ilength (args), args);
+        nargs = scm_ilength (args);
+
+        if (nargs == 3
+            && scm_is_eq (name, scm_from_latin1_symbol ("call-with-prompt")))
+          return MAKMEMO_CALL_WITH_PROMPT (CAR (args),
+                                           CADR (args),
+                                           CADDR (args));
+        else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
+          return MAKMEMO_CALL (MAKMEMO_TOP_REF (name), nargs, args);
+        else
+          return MAKMEMO_CALL (MAKMEMO_MOD_REF (list_of_guile, name,
+                                                SCM_BOOL_F),
+                               nargs,
+                               args);
       }
 
     case SCM_EXPANDED_SEQ:
@@ -525,13 +534,11 @@ static SCM m_apply (SCM proc, SCM arg, SCM rest);
 static SCM m_call_cc (SCM proc);
 static SCM m_call_values (SCM prod, SCM cons);
 static SCM m_dynamic_wind (SCM pre, SCM exp, SCM post);
-static SCM m_prompt (SCM tag, SCM exp, SCM handler);
 
 SCM_DEFINE_REST_MEMOIZER ("@apply", m_apply, 2);
 SCM_DEFINE_MEMOIZER ("@call-with-current-continuation", m_call_cc, 1);
 SCM_DEFINE_MEMOIZER ("@call-with-values", m_call_values, 2);
 SCM_DEFINE_MEMOIZER ("@dynamic-wind", m_dynamic_wind, 3);
-SCM_DEFINE_MEMOIZER ("@prompt", m_prompt, 3);
 
 
 
@@ -598,16 +605,6 @@ static SCM m_dynamic_wind (SCM in, SCM expr, SCM out)
 }
 #undef FUNC_NAME
 
-static SCM m_prompt (SCM tag, SCM exp, SCM handler)
-#define FUNC_NAME "@prompt"
-{
-  SCM_VALIDATE_MEMOIZED (1, tag);
-  SCM_VALIDATE_MEMOIZED (2, exp);
-  SCM_VALIDATE_MEMOIZED (3, handler);
-  return MAKMEMO_PROMPT (tag, exp, handler);
-}
-#undef FUNC_NAME
-
 
 
 
@@ -768,8 +765,8 @@ 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,
+    case SCM_M_CALL_WITH_PROMPT:
+      return scm_list_4 (scm_from_latin1_symbol ("call-with-prompt"),
                          unmemoize (CAR (args)),
                          unmemoize (CADR (args)),
                          unmemoize (CDDR (args)));
diff --git a/libguile/memoize.h b/libguile/memoize.h
index da78b06fa..764aa42cc 100644
--- a/libguile/memoize.h
+++ b/libguile/memoize.h
@@ -51,7 +51,6 @@ 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;
@@ -90,7 +89,7 @@ enum
     SCM_M_TOPLEVEL_SET,
     SCM_M_MODULE_REF,
     SCM_M_MODULE_SET,
-    SCM_M_PROMPT
+    SCM_M_CALL_WITH_PROMPT
   };
 
 
diff --git a/libguile/throw.c b/libguile/throw.c
index ae131d0ad..de157faa2 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013 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
@@ -510,7 +510,7 @@ static SCM
 pre_init_throw (SCM k, SCM args)
 {
   if (find_pre_init_catch ())
-    return scm_at_abort (sym_pre_init_catch_tag, scm_cons (k, args));
+    return scm_abort_to_prompt_star (sym_pre_init_catch_tag, scm_cons (k, args));
   else
     { 
       static int error_printing_error = 0;
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 82a0875cf..4a884d871 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -62,7 +62,7 @@
       %default-prompt-tag)))
 
 (define (call-with-prompt tag thunk handler)
-  (@prompt tag (thunk) handler))
+  ((@@ primitive call-with-prompt) tag thunk handler))
 (define (abort-to-prompt tag . args)
   (abort-to-prompt* tag args))
 
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index 90bc25457..3b5964b68 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -477,10 +477,11 @@
                  (with-fluids (((car fluids) (car vals)))
                    (lp (cdr fluids) (cdr vals)))))))
         
-        (('prompt (tag exp . handler))
-         (@prompt (eval tag env)
-                  (eval exp env)
-                  (eval handler env)))
+        (('call-with-prompt (tag thunk . handler))
+         (call-with-prompt
+          (eval tag env)
+          (eval thunk 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 6e578aab4..fb300822b 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -77,7 +77,7 @@
 
     fluid-ref fluid-set!
 
-    @prompt call-with-prompt
+    call-with-prompt
     abort-to-prompt* abort-to-prompt
     make-prompt-tag
 
@@ -187,7 +187,7 @@
     dynamic-wind
     @dynamic-wind
     values
-    @prompt call-with-prompt
+    call-with-prompt
     @abort abort-to-prompt))
 
 ;; Procedures that cause a nonlocal, non-resumable abort.
@@ -587,23 +587,6 @@
               (else #f)))
 
 (hashq-set! *primitive-expand-table*
-            '@prompt
-            (case-lambda
-              ((src tag exp handler)
-               (let ((args-sym (gensym)))
-                 (make-prompt
-                  src tag exp
-                  ;; If handler itself is a lambda, the inliner can do some
-                  ;; trickery here.
-                  (make-lambda-case
-                   (tree-il-src handler) '() #f 'args #f '() (list args-sym)
-                   (make-primcall #f 'apply
-                                  (list handler
-                                        (make-lexical-ref #f 'args args-sym)))
-                   #f))))
-              (else #f)))
-
-(hashq-set! *primitive-expand-table*
             'call-with-prompt
             (case-lambda
               ((src tag thunk handler)