[PATCH] Modify call/cc to invoke the prompt handler in some cases

---
 src/racket/src/eval.c |  141 ++++++++++++++++++++++++++-----------------------
 1 file changed, 76 insertions(+), 65 deletions(-)

diff --git a/src/racket/src/eval.c b/src/racket/src/eval.c
index 65d138e..4fe1fef 100644
--- a/src/racket/src/eval.c
+++ b/src/racket/src/eval.c
@@ -1490,6 +1490,23 @@ static int exec_dyn_wind_posts(Scheme_Dynamic_Wind *common, Scheme_Cont *c, int
   return common_depth;
 }
 
+static Scheme_Object *callcc_thunk(int argc, Scheme_Object **argv, Scheme_Object *prim)
+{
+  Scheme_Object *cont = SCHEME_PRIM_CLOSURE_ELS(prim)[0];
+  int num_rands = (int)SCHEME_PRIM_CLOSURE_ELS(prim)[1];
+  Scheme_Object *val = SCHEME_PRIM_CLOSURE_ELS(prim)[2];
+
+  if (num_rands == 1) {
+    Scheme_Object *a[1];
+    a[0] = val;
+    return _scheme_apply_multi(cont, 1, a);
+  }
+  else {
+    Scheme_Object** vals = (Scheme_Object**)val;
+    return _scheme_apply_multi(cont, num_rands, vals);
+  }
+}
+
 Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Object **rands, 
                                            Scheme_Object **old_runstack, int can_ec)
 {
@@ -1550,6 +1567,63 @@ Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Sc
     prompt = lookup_cont_prompt(c, &prompt_mc, &prompt_pos, LOOKUP_NO_PROMPT);
     barrier_prompt = check_barrier(prompt, prompt_mc, prompt_pos, c);
 
+    if (prompt &&
+        !(prompt->id && (prompt->id == c->prompt_id)
+          && !prompt_mc)) {
+      Scheme_Object* a[3];
+      Scheme_Object* thunk;
+      Scheme_Dynamic_Wind* dw;
+      Scheme_Meta_Continuation* mc;
+      c->composable = 1;
+ 
+      /* Remove extra dynamic wind records in call/cc continuation
+         to pretend it was composable to begin with */
+      dw = c->dw;
+      if (dw && dw->prompt_tag == c->prompt_tag)
+        c->dw = NULL;
+
+      for (; dw; dw = dw->prev) {
+        if (dw->prev && c->prompt_tag &&
+            (dw->prev->prompt_tag == c->prompt_tag)) {
+          dw->prev = NULL;
+          break;
+        }
+      }
+
+      /* Remove extra meta-continuation for composable */
+      mc = c->meta_continuation;
+      if (mc && mc->pseudo && mc->prompt_tag == c->prompt_tag)
+        c->meta_continuation = NULL;
+ 
+      for (; mc; mc = mc->next) {
+        if (mc->pseudo && mc->empty_to_next && mc->next
+            && SAME_OBJ(mc->next->prompt_tag, c->prompt_tag)) {
+          mc->next = NULL;
+          break;
+        }
+      }
+
+      a[0] = (Scheme_Object *)c;
+      a[1] = (Scheme_Object *)num_rands;
+      a[2] = (Scheme_Object *)value;
+      thunk = scheme_make_prim_closure_w_arity(callcc_thunk,
+                                               3, a,
+                                               "callcc-thunk",
+                                               0, 0);
+
+      p->cjs.jumping_to_continuation = (Scheme_Object *)prompt;
+      p->cjs.alt_full_continuation = NULL;
+      p->cjs.num_vals = 1;
+      p->cjs.val = thunk;
+      p->cjs.is_escape = 0;
+      p->cjs.skip_dws = 0;
+
+      MZ_RUNSTACK = old_runstack;
+      scheme_longjmp(*p->error_buf, 1);
+
+      return NULL;
+    }
+
     p->suspend_break++; /* restored at call/cc destination */
 
     /* Find `common', the intersection of dynamic-wind chain for 
@@ -1637,73 +1711,10 @@ Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Sc
         p->cjs.skip_dws = 0;
         scheme_longjmpup(&overflow->jmp->cont);
       }
-    } else {
-      /* The prompt is different than when we captured the continuation,
-         so we need to compose the continuation with the current prompt. */
-      p->cjs.jumping_to_continuation = (Scheme_Object *)prompt;
-      p->cjs.alt_full_continuation = NULL;
-      p->cjs.num_vals = 1;
-      p->cjs.val = (Scheme_Object *)c;
-      p->cjs.is_escape = 1;
-      p->cjs.skip_dws = 0;
-       
-      if (prompt_mc) {
-        /* The prompt is from a meta-continuation that's different
-           from the current one. Jump to the meta-continuation
-           and continue from there. Immediate destination is
-           in compose_continuation() in fun.c; the ultimate
-           destination is in scheme_finish_apply_for_prompt()
-           in fun.c.
-           We need to adjust the meta-continuation offsets in
-           common, based on the number that we're discarding
-           here. */
-        {
-          Scheme_Meta_Continuation *xmc;
-          int offset = 1;
-          for (xmc = p->meta_continuation; 
-               xmc->prompt_tag != prompt_mc->prompt_tag; 
-               xmc = xmc->next) {
-            if (xmc->overflow)
-              offset++;
-          }
-          c->common_next_meta -= offset;
-        }
-        p->meta_continuation = prompt_mc->next;
-        p->stack_start = prompt_mc->overflow->stack_start;
-        p->decompose_mc = prompt_mc;
-        scheme_longjmpup(&prompt_mc->overflow->jmp->cont);
-      } else if ((!prompt->boundary_overflow_id && !p->overflow)
-                 || (prompt->boundary_overflow_id
-                     && (prompt->boundary_overflow_id == p->overflow->id))) {
-        /* Jump directly to the prompt: destination is in
-           scheme_finish_apply_for_prompt() in fun.c. */
-        if (!p->meta_continuation)
-          scheme_signal_error("internal error: no meta-cont for escape");
-        if (p->meta_continuation->pseudo)
-          scheme_signal_error("internal error: trying to jump to a prompt in a meta-cont"
-                              " that starts with a pseudo prompt");
-        scheme_drop_prompt_meta_continuations(c->prompt_tag);
-        scheme_longjmp(*prompt->prompt_buf, 1);
-      } else {
-        /* Need to unwind overflows to get to the prompt. */
-        Scheme_Overflow *overflow;
-        scheme_drop_prompt_meta_continuations(c->prompt_tag);
-        overflow = p->overflow;
-        while (overflow->prev
-               && (!overflow->prev->id
-                   || (overflow->prev->id != prompt->boundary_overflow_id))) {
-          overflow = overflow->prev;
-        }
-        /* Immediate destination is in scheme_handle_stack_overflow().
-           Ultimate destination is in scheme_finish_apply_for_prompt()
-           in fun.c. */
-        p->overflow = overflow;
-        p->stack_start = overflow->stack_start;
-        scheme_longjmpup(&overflow->jmp->cont);
-      }
     }
-    return NULL;
   }
+
+  return NULL;
 }
 
 void scheme_escape_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Object **rands, Scheme_Object *alt_full)
-- 
1.7.10.4


--nFreZHaLTZJo0R7j--