From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Sun, 5 Feb 2017 02:55:48 +0000 (-0700)
Subject: Implement REFLECT_CODE_MULTIPLE_VALUES.
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=95ec051fc97a27cf36998e34f3f34a10b2ae5e08;p=mit-scheme.git

Implement REFLECT_CODE_MULTIPLE_VALUES.
---

diff --git a/src/microcode/cmpint.c b/src/microcode/cmpint.c
index f04b1c629..d5419a20b 100644
--- a/src/microcode/cmpint.c
+++ b/src/microcode/cmpint.c
@@ -72,7 +72,8 @@ typedef enum
   REFLECT_CODE_INTERNAL_APPLY,
   REFLECT_CODE_RESTORE_INTERRUPT_MASK,
   REFLECT_CODE_STACK_MARKER,
-  REFLECT_CODE_CC_BKPT
+  REFLECT_CODE_CC_BKPT,
+  REFLECT_CODE_MULTIPLE_VALUES
 } reflect_code_t;
 
 #define PUSH_REFLECTION(code) do					\
@@ -1474,6 +1475,56 @@ apply_compiled_from_primitive (unsigned long n_args, SCHEME_OBJECT procedure)
     }
 }
 
+bool
+apply_values_from_primitive (unsigned long n_args)
+{
+  if ((reflect_to_interface == (STACK_REF (n_args)))
+      && ((ULONG_TO_FIXNUM (REFLECT_CODE_MULTIPLE_VALUES))
+	  == (STACK_REF (n_args + 1))))
+    {
+      SCHEME_OBJECT consumer = (STACK_REF (n_args + 2));
+      close_stack_gap (n_args, 3);
+      assert (CC_ENTRY_P (STACK_REF (n_args)));
+      apply_compiled_from_primitive (n_args, consumer);
+      return (true);
+    }
+
+  if ((return_to_interpreter == (STACK_REF (n_args)))
+      && (CHECK_RETURN_CODE (RC_MULTIPLE_VALUES, n_args + 1)))
+    {
+      SCHEME_OBJECT consumer = (STACK_REF (n_args + 2));
+      close_stack_gap (n_args + 1, 2);
+      apply_compiled_from_primitive (n_args, consumer);
+      return (true);
+    }
+
+  if ((CHECK_RETURN_CODE (RC_REENTER_COMPILED_CODE, n_args))
+      && (reflect_to_interface == (STACK_REF (n_args + 2)))
+      && ((ULONG_TO_FIXNUM (REFLECT_CODE_MULTIPLE_VALUES))
+	  == (STACK_REF (n_args + 3))))
+    {
+      SCHEME_OBJECT consumer = (STACK_REF (n_args + 4));
+      unsigned long lrc = (FIXNUM_TO_ULONG (CONT_EXP (n_args)));
+      close_stack_gap (n_args + 2, 3);
+      (STACK_REF (n_args + 1)) = lrc - 3;
+      assert (CC_ENTRY_P (STACK_REF (n_args + 2)));
+      STACK_PUSH (consumer);
+      PUSH_APPLY_FRAME_HEADER (n_args);
+      PRIMITIVE_ABORT (PRIM_APPLY);
+      /*NOTREACHED*/
+      return (true);
+    }
+
+  return (false);
+}
+
+void
+compiled_call_with_values (SCHEME_OBJECT producer)
+{
+  PUSH_REFLECTION (REFLECT_CODE_MULTIPLE_VALUES);
+  apply_compiled_from_primitive (0, producer);
+}
+
 void
 compiled_with_interrupt_mask (unsigned long old_mask,
 			      SCHEME_OBJECT receiver,
@@ -2066,6 +2117,13 @@ DEFINE_TRAMPOLINE (comutil_reflect_to_interface)
 	TAIL_CALL_2 (comutil_apply, procedure, frame_size);
       }
 
+    case REFLECT_CODE_MULTIPLE_VALUES:
+      {
+	SCHEME_OBJECT consumer = STACK_POP ();
+	STACK_PUSH (GET_VAL);
+	TAIL_CALL_2 (comutil_apply, consumer, 2);
+      }
+
     case REFLECT_CODE_RESTORE_INTERRUPT_MASK:
       SET_INTERRUPT_MASK (OBJECT_DATUM (STACK_POP ()));
       INVOKE_RETURN_ADDRESS ();
diff --git a/src/microcode/cmpint.h b/src/microcode/cmpint.h
index 779de267a..634258c81 100644
--- a/src/microcode/cmpint.h
+++ b/src/microcode/cmpint.h
@@ -412,6 +412,8 @@ extern long apply_compiled_procedure (void);
 extern long return_to_compiled_code (void);
 
 extern void apply_compiled_from_primitive (unsigned long, SCHEME_OBJECT);
+extern bool apply_values_from_primitive (unsigned long);
+extern void compiled_call_with_values (SCHEME_OBJECT);
 extern void compiled_with_interrupt_mask
   (unsigned long, SCHEME_OBJECT, unsigned long);
 extern void compiled_with_stack_marker (SCHEME_OBJECT);
diff --git a/src/microcode/hooks.c b/src/microcode/hooks.c
index eba399f47..e1d39ac83 100644
--- a/src/microcode/hooks.c
+++ b/src/microcode/hooks.c
@@ -120,17 +120,25 @@ Return zero or more values to the current continuation.")
   PRIMITIVE_HEADER (LEXPR);
   {
     unsigned long n_args = GET_LEXPR_ACTUALS;
-    unsigned long extra = 0;
 
 #ifdef CC_SUPPORT_P
-    if (return_to_interpreter == (STACK_REF (n_args)))
-      extra = 1;
+    if ((CC_ENTRY_P (STACK_REF (n_args)))
+	|| (CHECK_RETURN_CODE (RC_REENTER_COMPILED_CODE, n_args)))
+      {
+	if (apply_values_from_primitive (n_args))
+	  {
+	    UN_POP_PRIMITIVE_FRAME (n_args);
+	    PRIMITIVE_RETURN (UNSPECIFIC);
+	  }
+	else
+	  PRIMITIVE_RETURN (n_args == 0 ? UNSPECIFIC : (ARG_REF(1)));
+      }
 #endif
 
-    if (CHECK_RETURN_CODE (RC_MULTIPLE_VALUES, n_args+extra))
+    if (CHECK_RETURN_CODE (RC_MULTIPLE_VALUES, n_args))
       {
-	SCHEME_OBJECT consumer = (CONT_EXP (n_args+extra));
-	unsigned long n_words = CONTINUATION_SIZE+extra;
+	SCHEME_OBJECT consumer = (CONT_EXP (n_args));
+	unsigned long n_words = CONTINUATION_SIZE;
 	{
 	  SCHEME_OBJECT * scan_from = (STACK_LOC (n_args));
 	  SCHEME_OBJECT * scan_end = (STACK_LOC (0));
@@ -156,7 +164,14 @@ DEFINE_PRIMITIVE ("CALL-WITH-VALUES", Prim_call_with_values, 2, 2,
 Call PRODUCER and tail-apply its return values to CONSUMER.")
 {
   PRIMITIVE_HEADER (2);
-  canonicalize_primitive_context ();
+#ifdef CC_SUPPORT_P
+  if ((CC_ENTRY_P (STACK_REF (2))))
+    {
+      compiled_call_with_values (STACK_POP ());
+      UN_POP_PRIMITIVE_FRAME (2);
+      PRIMITIVE_RETURN (UNSPECIFIC);
+    }
+#endif
   {
     SCHEME_OBJECT producer = (STACK_POP ());
     STACK_PUSH (MAKE_RETURN_CODE (RC_MULTIPLE_VALUES));