Implement REFLECT_CODE_MULTIPLE_VALUES.

diff --git a/src/microcode/cmpint.c b/src/microcode/cmpint.c
index f04b1c6295c64d04d758bd769bfb266fc3cd616a..d5419a20bdd95a4e9cdfbda65850c0f7756b0e03 100644 (file)
--- 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 779de267af44ad37d443fbc37739625872fe3917..634258c817da9d7a179842f4bd069903f1a2dac3 100644 (file)
--- 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 eba399f472064bffb4c21ac86ca130b3cd8696e1..e1d39ac8389e53d451cd5a5de00ff403fc7156f0 100644 (file)
--- 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));