Add the INTERNAL-APPLY-VAL return code. It replaces the procedure

with the current value of Val and then proceeds to apply.  Apply
errors use this return code rather than INTERNAL-APPLY to restart.
Under normal operation there is no change since a POP-RETURN-ERROR
return code (which restores Val) is pushed as well, so to make use of
this feature the top few frames of the stack must be eliminated before
invoking the continuation.

diff --git a/v7/src/microcode/interp.c b/v7/src/microcode/interp.c
index 8f8d9f5b51f1b1b150cad1dc2e3e872d03923ba9..ef3de0192b60224c8dc66d5bf176cf16f02e2d8d 100644 (file)
--- a/v7/src/microcode/interp.c
+++ b/v7/src/microcode/interp.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.c,v 9.53 1989/10/28 15:38:37 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.c,v 9.54 1990/01/29 22:32:57 jinx Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -253,9 +253,8 @@ if (GC_Check(Amount))                                                       \
     }                                                                  \
     else                                                               \
     {                                                                  \
-      Store_Return(RC_INTERNAL_APPLY);                                 \
-      Val = SHARP_F;                                                   \
-      TOUCH_SETUP(*Arg);                                               \
+      Prepare_Apply_Interrupt ();                                      \
+      TOUCH_SETUP (*Arg);                                              \
       *Arg = Orig_Answer;                                              \
       goto Internal_Apply;                                             \
     }                                                                  \
@@ -956,8 +955,7 @@ Pop_Return:
 
     case RC_COMB_APPLY_FUNCTION:
        End_Subproblem();
-       Stack_Ref(STACK_ENV_FUNCTION) = Val;
-       goto Internal_Apply;
+       goto Internal_Apply_Val;
 
     case RC_COMB_SAVE_VALUE:
       {        long Arg_Number;
@@ -1355,23 +1353,28 @@ external_assignment_return:
 
 #define Prepare_Apply_Interrupt()                                      \
 {                                                                      \
-  Store_Return(RC_INTERNAL_APPLY);                                     \
-  Store_Expression(SHARP_F);                                           \
-  Save_Cont();                                                         \
+  Store_Expression (SHARP_F);                                          \
+  Prepare_Pop_Return_Interrupt (RC_INTERNAL_APPLY_VAL,                 \
+                               (Stack_Ref (STACK_ENV_FUNCTION)));      \
 }
 
 #define Apply_Error(N)                                                 \
 {                                                                      \
-  Store_Return(RC_INTERNAL_APPLY);                                     \
-  Store_Expression(SHARP_F);                                           \
-  Val = SHARP_F;                                                       \
-  Pop_Return_Error(N);                                                 \
+  Store_Expression (SHARP_F);                                          \
+  Store_Return (RC_INTERNAL_APPLY_VAL);                                        \
+  Val = (Stack_Ref (STACK_ENV_FUNCTION));                              \
+  Pop_Return_Error (N);                                                        \
 }
 
 /* Interpret() continues on the next page */
 \f
 /* Interpret(), continued */
 
+    case RC_INTERNAL_APPLY_VAL:
+Internal_Apply_Val:
+
+       Stack_Ref (STACK_ENV_FUNCTION) = Val;
+
     case RC_INTERNAL_APPLY:
 Internal_Apply:
 
@@ -1381,10 +1384,10 @@ Internal_Apply:
       {
        long Count;
 
-       Count = OBJECT_DATUM (Stack_Ref(STACK_ENV_HEADER));
-        Top_Of_Stack() = Fetch_Apply_Trapper();
-        Push(STACK_FRAME_HEADER + Count);
-        Stop_Trapping();
+       Count = (OBJECT_DATUM (Stack_Ref (STACK_ENV_HEADER)));
+        Top_Of_Stack() = (Fetch_Apply_Trapper ());
+        Push (STACK_FRAME_HEADER + Count);
+        Stop_Trapping ();
       }
 
 Apply_Non_Trapping:
@@ -1394,9 +1397,7 @@ Apply_Non_Trapping:
        long Interrupts;
 
        Interrupts = (PENDING_INTERRUPTS());
-       Store_Expression(SHARP_F);
-       Val = SHARP_F;
-       Prepare_Apply_Interrupt();
+       Prepare_Apply_Interrupt ();
        Interrupt(Interrupts);
       }
 
@@ -1473,7 +1474,7 @@ Perform_Application:
             if (GC_Check(nargs + 1))
             {
              Push(STACK_FRAME_HEADER + nargs - 1);
-              Prepare_Apply_Interrupt();
+              Prepare_Apply_Interrupt ();
               Immediate_GC(nargs + 1);
             }
 
@@ -1496,12 +1497,12 @@ Perform_Application:
 
           case TC_CONTROL_POINT:
          {
-            if (OBJECT_DATUM (Stack_Ref(STACK_ENV_HEADER)) !=
+            if (OBJECT_DATUM (Stack_Ref (STACK_ENV_HEADER)) !=
                 STACK_ENV_FIRST_ARG)
            {
               Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
            }
-            Val = Stack_Ref(STACK_ENV_FIRST_ARG);
+            Val = (Stack_Ref (STACK_ENV_FIRST_ARG));
             Our_Throw(false, Function);
            Apply_Stacklet_Backout();
            Our_Throw_Part_2();
@@ -1605,7 +1606,7 @@ Perform_Application:
                                     0)))
             {
              Push(STACK_FRAME_HEADER + nargs);
-              Prepare_Apply_Interrupt();
+              Prepare_Apply_Interrupt ();
               Immediate_GC(size + 1 + ((nargs > params) ?
                                       (2 * (nargs - params)) :
                                       0));
@@ -1686,16 +1687,16 @@ return_from_compiled_code:
 
            case PRIM_INTERRUPT:
            {
-             compiled_error_backout();
-             Save_Cont();
-             Interrupt(PENDING_INTERRUPTS());
+             compiled_error_backout ();
+             Save_Cont ();
+             Interrupt (PENDING_INTERRUPTS ());
            }
 
            case PRIM_APPLY_INTERRUPT:
            {
-             apply_compiled_backout();
-             Prepare_Apply_Interrupt();
-             Interrupt(PENDING_INTERRUPTS());
+             apply_compiled_backout ();
+             Prepare_Apply_Interrupt ();
+             Interrupt (PENDING_INTERRUPTS ());
            }
 
            /* The assembly language interfaces return errors
@@ -1755,7 +1756,7 @@ return_from_compiled_code:
           }
 
           default:
-            Apply_Error(ERR_INAPPLICABLE_OBJECT);
+            Apply_Error (ERR_INAPPLICABLE_OBJECT);
         }       /* End of switch in RC_INTERNAL_APPLY */
       }         /* End of RC_INTERNAL_APPLY case */
 
@@ -2154,14 +2155,12 @@ Primitive_Internal_Apply:
     case RC_RESTORE_CONTINUATION:
     case RC_RESTORE_STEPPER:
     case RC_POP_FROM_COMPILED_CODE:
-      Export_Registers();
-      Microcode_Termination(TERM_UNIMPLEMENTED_CONTINUATION);
+      Pop_Return_Error (ERR_INAPPLICABLE_CONTINUATION);
 
     SITE_RETURN_DISPATCH_HOOK()
 
     default:
-      Export_Registers();
-      Microcode_Termination(TERM_NON_EXISTENT_CONTINUATION);
+      Pop_Return_Error (ERR_INAPPLICABLE_CONTINUATION);
   };
   goto Pop_Return;
 }

diff --git a/v8/src/microcode/interp.c b/v8/src/microcode/interp.c
index 4fd8384d49b3a03b49858e4c733c1a540dee3f67..23b373c3a690b0eefba32801704211bcc37a17b6 100644 (file)
--- a/v8/src/microcode/interp.c
+++ b/v8/src/microcode/interp.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/interp.c,v 9.53 1989/10/28 15:38:37 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/interp.c,v 9.54 1990/01/29 22:32:57 jinx Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -253,9 +253,8 @@ if (GC_Check(Amount))                                                       \
     }                                                                  \
     else                                                               \
     {                                                                  \
-      Store_Return(RC_INTERNAL_APPLY);                                 \
-      Val = SHARP_F;                                                   \
-      TOUCH_SETUP(*Arg);                                               \
+      Prepare_Apply_Interrupt ();                                      \
+      TOUCH_SETUP (*Arg);                                              \
       *Arg = Orig_Answer;                                              \
       goto Internal_Apply;                                             \
     }                                                                  \
@@ -956,8 +955,7 @@ Pop_Return:
 
     case RC_COMB_APPLY_FUNCTION:
        End_Subproblem();
-       Stack_Ref(STACK_ENV_FUNCTION) = Val;
-       goto Internal_Apply;
+       goto Internal_Apply_Val;
 
     case RC_COMB_SAVE_VALUE:
       {        long Arg_Number;
@@ -1355,23 +1353,28 @@ external_assignment_return:
 
 #define Prepare_Apply_Interrupt()                                      \
 {                                                                      \
-  Store_Return(RC_INTERNAL_APPLY);                                     \
-  Store_Expression(SHARP_F);                                           \
-  Save_Cont();                                                         \
+  Store_Expression (SHARP_F);                                          \
+  Prepare_Pop_Return_Interrupt (RC_INTERNAL_APPLY_VAL,                 \
+                               (Stack_Ref (STACK_ENV_FUNCTION)));      \
 }
 
 #define Apply_Error(N)                                                 \
 {                                                                      \
-  Store_Return(RC_INTERNAL_APPLY);                                     \
-  Store_Expression(SHARP_F);                                           \
-  Val = SHARP_F;                                                       \
-  Pop_Return_Error(N);                                                 \
+  Store_Expression (SHARP_F);                                          \
+  Store_Return (RC_INTERNAL_APPLY_VAL);                                        \
+  Val = (Stack_Ref (STACK_ENV_FUNCTION));                              \
+  Pop_Return_Error (N);                                                        \
 }
 
 /* Interpret() continues on the next page */
 \f
 /* Interpret(), continued */
 
+    case RC_INTERNAL_APPLY_VAL:
+Internal_Apply_Val:
+
+       Stack_Ref (STACK_ENV_FUNCTION) = Val;
+
     case RC_INTERNAL_APPLY:
 Internal_Apply:
 
@@ -1381,10 +1384,10 @@ Internal_Apply:
       {
        long Count;
 
-       Count = OBJECT_DATUM (Stack_Ref(STACK_ENV_HEADER));
-        Top_Of_Stack() = Fetch_Apply_Trapper();
-        Push(STACK_FRAME_HEADER + Count);
-        Stop_Trapping();
+       Count = (OBJECT_DATUM (Stack_Ref (STACK_ENV_HEADER)));
+        Top_Of_Stack() = (Fetch_Apply_Trapper ());
+        Push (STACK_FRAME_HEADER + Count);
+        Stop_Trapping ();
       }
 
 Apply_Non_Trapping:
@@ -1394,9 +1397,7 @@ Apply_Non_Trapping:
        long Interrupts;
 
        Interrupts = (PENDING_INTERRUPTS());
-       Store_Expression(SHARP_F);
-       Val = SHARP_F;
-       Prepare_Apply_Interrupt();
+       Prepare_Apply_Interrupt ();
        Interrupt(Interrupts);
       }
 
@@ -1473,7 +1474,7 @@ Perform_Application:
             if (GC_Check(nargs + 1))
             {
              Push(STACK_FRAME_HEADER + nargs - 1);
-              Prepare_Apply_Interrupt();
+              Prepare_Apply_Interrupt ();
               Immediate_GC(nargs + 1);
             }
 
@@ -1496,12 +1497,12 @@ Perform_Application:
 
           case TC_CONTROL_POINT:
          {
-            if (OBJECT_DATUM (Stack_Ref(STACK_ENV_HEADER)) !=
+            if (OBJECT_DATUM (Stack_Ref (STACK_ENV_HEADER)) !=
                 STACK_ENV_FIRST_ARG)
            {
               Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
            }
-            Val = Stack_Ref(STACK_ENV_FIRST_ARG);
+            Val = (Stack_Ref (STACK_ENV_FIRST_ARG));
             Our_Throw(false, Function);
            Apply_Stacklet_Backout();
            Our_Throw_Part_2();
@@ -1605,7 +1606,7 @@ Perform_Application:
                                     0)))
             {
              Push(STACK_FRAME_HEADER + nargs);
-              Prepare_Apply_Interrupt();
+              Prepare_Apply_Interrupt ();
               Immediate_GC(size + 1 + ((nargs > params) ?
                                       (2 * (nargs - params)) :
                                       0));
@@ -1686,16 +1687,16 @@ return_from_compiled_code:
 
            case PRIM_INTERRUPT:
            {
-             compiled_error_backout();
-             Save_Cont();
-             Interrupt(PENDING_INTERRUPTS());
+             compiled_error_backout ();
+             Save_Cont ();
+             Interrupt (PENDING_INTERRUPTS ());
            }
 
            case PRIM_APPLY_INTERRUPT:
            {
-             apply_compiled_backout();
-             Prepare_Apply_Interrupt();
-             Interrupt(PENDING_INTERRUPTS());
+             apply_compiled_backout ();
+             Prepare_Apply_Interrupt ();
+             Interrupt (PENDING_INTERRUPTS ());
            }
 
            /* The assembly language interfaces return errors
@@ -1755,7 +1756,7 @@ return_from_compiled_code:
           }
 
           default:
-            Apply_Error(ERR_INAPPLICABLE_OBJECT);
+            Apply_Error (ERR_INAPPLICABLE_OBJECT);
         }       /* End of switch in RC_INTERNAL_APPLY */
       }         /* End of RC_INTERNAL_APPLY case */
 
@@ -2154,14 +2155,12 @@ Primitive_Internal_Apply:
     case RC_RESTORE_CONTINUATION:
     case RC_RESTORE_STEPPER:
     case RC_POP_FROM_COMPILED_CODE:
-      Export_Registers();
-      Microcode_Termination(TERM_UNIMPLEMENTED_CONTINUATION);
+      Pop_Return_Error (ERR_INAPPLICABLE_CONTINUATION);
 
     SITE_RETURN_DISPATCH_HOOK()
 
     default:
-      Export_Registers();
-      Microcode_Termination(TERM_NON_EXISTENT_CONTINUATION);
+      Pop_Return_Error (ERR_INAPPLICABLE_CONTINUATION);
   };
   goto Pop_Return;
 }