{
/* Used by callback trampolines after saving the callback args on
the CStack. */
- SCM primitive, prim_lexpr, * sp;
- SCM * callers_last_return_code;
-#ifdef CC_IS_NATIVE
- void * cfp = C_Frame_Pointer;
- void * csp = C_Stack_Pointer;
-#endif
+ SCM * saved_stack_pointer, * saved_last_return_code;
+ unsigned long nargs = GET_LEXPR_ACTUALS;
if (run_callback == SHARP_F)
{
if (run_callback == SHARP_F)
{
outf_error_line
- ("\nWarning: punted callback #%ld. Missing primitives!",
+ ("\nWarning: punted callback #%ld. Missing primitive!",
callback_id);
SET_VAL (FIXNUM_ZERO);
return;
}
}
+ if (GET_PRIMITIVE != c_call_continue)
+ abort_to_interpreter (ERR_CANNOT_RECURSE);
+ /*NOTREACHED*/
+
cstack_depth += 1;
CSTACK_PUSH (int, cstack_depth);
CSTACK_PUSH (CallbackKernel, kernel);
- primitive = GET_PRIMITIVE;
- prim_lexpr = GET_LEXPR_ACTUALS;
- callers_last_return_code = last_return_code;
-
- if (! (PRIMITIVE_P (primitive)))
- abort_to_interpreter (ERR_CANNOT_RECURSE);
- /*NOTREACHED*/
- assert (primitive == c_call_continue);
- sp = stack_pointer;
+ /* For a traceable stack... */
+ STACK_PUSH (c_call_continue);
+ PUSH_APPLY_FRAME_HEADER (nargs);
+ SET_RC (RC_INTERNAL_APPLY);
+ SET_EXP (c_call_continue);
+ SAVE_CONT ();
+ saved_last_return_code = last_return_code;
+ saved_stack_pointer = stack_pointer;
Will_Push ((2 * CONTINUATION_SIZE) + STACK_ENV_EXTRA_SLOTS + 1);
SET_RC (RC_END_OF_COMPUTATION);
- SET_EXP (primitive);
+ SET_EXP (run_callback);
SAVE_CONT ();
STACK_PUSH (run_callback);
PUSH_APPLY_FRAME_HEADER (0);
SET_RC (RC_INTERNAL_APPLY);
- SET_EXP (SHARP_F);
+ SET_EXP (run_callback);
SAVE_CONT ();
Pushed ();
+ SET_EXP (SHARP_F); /* fall through to pop_return */
Re_Enter_Interpreter ();
- if (stack_pointer != sp)
+ if (stack_pointer != saved_stack_pointer
+#ifdef ENABLE_DEBUGGING_TOOLS
+ || ((STACK_REF (0)) != (MAKE_RETURN_CODE (RC_INTERNAL_APPLY)))
+ || ((STACK_REF (1)) != c_call_continue)
+ || ((STACK_REF (2)) != (MAKE_OBJECT (0, nargs+1)))
+ || ((STACK_REF (3)) != c_call_continue)
+#endif
+ )
signal_error_from_primitive (ERR_STACK_HAS_SLIPPED);
/*NOTREACHED*/
- last_return_code = callers_last_return_code;
- SET_LEXPR_ACTUALS (prim_lexpr);
- SET_PRIMITIVE (primitive);
-#ifdef CC_IS_NATIVE
- C_Frame_Pointer = cfp;
- C_Stack_Pointer = csp;
-#endif
+ last_return_code = saved_last_return_code;
+ stack_pointer = STACK_LOC (4);
+ SET_PRIMITIVE (c_call_continue);
+ SET_LEXPR_ACTUALS (nargs);
cstack_depth -= 1;
}
}
kernel ();
- /* NOTREACHED */
+ /* This primitive is only run by the re-entered interpreter and,
+ with zero arguments, its apply frame is already gone. */
PRIMITIVE_RETURN (UNSPECIFIC);
}
}
/* Used by callback kernels, inside the interpreter. Thus it MAY GC
abort.
- Push a Scheme callback handler apply frame. This leaves the
- interpreter ready to tail-call the Scheme procedure. (The
- RUN-CALLBACK primitive apply frame is already gone.) The
- trampoline should abort with PRIM_APPLY. */
+ Push a Scheme callback handler apply frame. (The RUN-CALLBACK
+ primitive apply frame is already gone.) */
SCM handler, fixnum_id;
handler = valid_callback_handler ();
fixnum_id = valid_callback_id (callback_id);
- stop_history ();
-
- Will_Push (STACK_ENV_EXTRA_SLOTS + 3);
+ Will_Push (3 + STACK_ENV_EXTRA_SLOTS + CONTINUATION_SIZE);
STACK_PUSH (arglist);
STACK_PUSH (fixnum_id);
STACK_PUSH (handler);
PUSH_APPLY_FRAME_HEADER (2);
+ SET_RC (RC_INTERNAL_APPLY);
+ SET_EXP (run_callback);
+ SAVE_CONT ();
Pushed ();
}
callback_return (char * tos)
{
cstack_pop (tos);
- PRIMITIVE_ABORT (PRIM_APPLY);
}
\f
/* Converters */