From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Mon, 14 Aug 2017 21:12:10 +0000 (-0700)
Subject: ffi: Add re_enter_scheme to work with abort_to_c for glib mainloop.
X-Git-Tag: mit-scheme-pucked-9.2.12~90
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d3e649431b875e76abf678ea68a3931c15c25e92;p=mit-scheme.git

ffi: Add re_enter_scheme to work with abort_to_c for glib mainloop.
---

diff --git a/src/microcode/pruxffi.c b/src/microcode/pruxffi.c
index 796c457b7..72a4674d2 100644
--- a/src/microcode/pruxffi.c
+++ b/src/microcode/pruxffi.c
@@ -571,10 +571,6 @@ callout_pop (char * tos)
 
 static SCM run_callback = SHARP_F;
 extern SCHEME_OBJECT Re_Enter_Interpreter (void);
-#ifdef CC_IS_NATIVE
-extern void * C_Frame_Pointer;
-extern void * C_Stack_Pointer;
-#endif
 
 void
 callback_run_kernel (long callback_id, CallbackKernel kernel)
@@ -672,15 +668,6 @@ DEFINE_PRIMITIVE ("RUN-CALLBACK", Prim_run_callback, 0, 0, 0)
   }
 }
 
-/* This is mainly for src/glib/glibio.c, so it does not need to include
-   prim.h, scheme.h and everything. */
-void
-abort_to_c (void)
-{
-  PRIMITIVE_ABORT (PRIM_RETURN_TO_C);
-  /* NOTREACHED */
-}
-
 char *
 callback_lunseal (CallbackKernel expected)
 {
@@ -1029,7 +1016,7 @@ flovec_length (double *first)
 
 DEFINE_PRIMITIVE ("OUTF-ERROR", Prim_outf_error, 1, 1, 0)
 {
-  /* To avoid the normal i/o system when debugging a callback. */
+  /* To avoid the normal IO system when debugging a callback. */
 
   PRIMITIVE_HEADER (1);
   { 
@@ -1047,13 +1034,49 @@ DEFINE_PRIMITIVE ("OUTF-ERROR", Prim_outf_error, 1, 1, 0)
     PRIMITIVE_RETURN (UNSPECIFIC);
   }
 }
+
+/* Re-Entering the Interpreter
+
+   These functions are used by the glib plugin to (re)enter the
+   interpreter in a GSource dispatch method, and to throw out again to
+   return from the method. */
+
+void
+re_enter_scheme (void)
+{
+  assert (GET_PRIMITIVE == c_call_continue);
+  back_out_of_primitive ();
+  Re_Enter_Interpreter ();
+
+  assert (GET_PRIMITIVE == SHARP_F);
+  assert (GET_EXP == SHARP_F);
+  assert ((STACK_REF (0)) == (MAKE_RETURN_CODE (RC_INTERNAL_APPLY)));
+  assert ((STACK_REF (1)) == SHARP_F);
+  assert ((OBJECT_TYPE (STACK_REF (2))) == TC_FALSE);
+  assert ((STACK_REF (3)) == c_call_continue);
+
+  SET_PRIMITIVE (c_call_continue);
+  SET_LEXPR_ACTUALS (APPLY_FRAME_HEADER_N_ARGS (STACK_REF (2)));
+  stack_pointer = STACK_LOC (4);
+  alienate_float_environment ();
+}
+
+void
+abort_to_c (void)
+{
+  assert (GET_PRIMITIVE == c_call_continue);
+  back_out_of_primitive ();
+  PRIMITIVE_ABORT (PRIM_RETURN_TO_C);
+  /* NOTREACHED */
+}
 
 int
 interrupts_p (void)
 {
-  /* Just the pending interrupts bitmap, ignoring the INT_MASK. */
-  /* This is mainly for src/glib/glibio.c, which finds pending_
-     interrupts_p() useless; it is always /gc-ok. */
+  /* Just the interrupts bitmap, ignoring the INT_MASK, which often is
+     /gc-ok while a toolkit is running (making pending_interrupts_p()
+     useless).  This function allows the toolkit to see if the Scheme
+     machine has received an interrupt and needs to run. */
 
   return (GET_INT_CODE);
 }