Changed support for stepper hooks. Return hooks now work more or less

like the apply and eval hooks.

diff --git a/v7/src/microcode/const.h b/v7/src/microcode/const.h
index 2a7a064f0dd9525dfb38c8753172dff76f397129..5fd187664af1e6834a35c8c39d41ca81f12f71e2 100644 (file)
--- a/v7/src/microcode/const.h
+++ b/v7/src/microcode/const.h
@@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising,
 promotional, or sales literature without prior written consent from
 MIT in each case. */
 
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/const.h,v 9.37 1991/03/21 23:26:21 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/const.h,v 9.38 1991/07/18 16:03:38 markf Exp $
  *
  * Named constants used throughout the interpreter
  *
@@ -127,6 +127,7 @@ MIT in each case. */
 #define PRIM_TOUCH                     -8
 #define PRIM_APPLY_INTERRUPT           -9
 #define PRIM_REENTER                   -10
+#define PRIM_NO_TRAP_POP_RETURN                -11
 
 #define ABORT_NAME_TABLE                                               \
 {                                                                      \
@@ -140,6 +141,7 @@ MIT in each case. */
   /* -8 */     "TOUCH",                                                \
   /* -9 */     "APPLY-INTERRUPT",                                      \
   /* -10 */    "REENTER"                                               \
+  /* -11 */    "NO-TRAP-POP-RETURN"                                    \
 }
 
 /* Some numbers of parameters which mean something special */

diff --git a/v7/src/microcode/interp.c b/v7/src/microcode/interp.c
index 8a98ac9d98b3cbec7687b15d135522b021b2555d..f97b8d7cf8b41fad3e3920e51e6e4d67301c3c16 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.62 1991/06/22 19:28:54 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.c,v 9.63 1991/07/18 15:58:12 markf Exp $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -487,6 +487,11 @@ Repeat_Dispatch:
     case CODE_MAP(PRIM_POP_RETURN):
       goto Pop_Return;
 
+    case PRIM_NO_TRAP_POP_RETURN:
+      PROCEED_AFTER_PRIMITIVE();
+    case CODE_MAP(PRIM_NO_TRAP_POP_RETURN):
+      goto Pop_Return_Non_Trapping;
+
     case PRIM_REENTER:
       BACK_OUT_AFTER_PRIMITIVE();
       LOG_FUTURES();
@@ -596,6 +601,7 @@ Do_Expression:
 
   if (Microcode_Does_Stepping &&
       Trapping &&
+      (! WITHIN_CRITICAL_SECTION_P()) &&
       ((Fetch_Eval_Trapper ()) != SHARP_F))
   {
     Stop_Trapping ();
@@ -942,6 +948,20 @@ lookup_end_restart:
  */
 
 Pop_Return:
+  if (Microcode_Does_Stepping &&
+      Trapping &&
+      (! WITHIN_CRITICAL_SECTION_P()) &&
+      ((Fetch_Return_Trapper ()) != SHARP_F))
+  {
+    Will_Push(3);
+      Stop_Trapping();
+      STACK_PUSH (Val);
+      STACK_PUSH (Fetch_Return_Trapper());
+      STACK_PUSH (STACK_FRAME_HEADER+1);
+    Pushed();
+    goto Apply_Non_Trapping;
+  }
+Pop_Return_Non_Trapping:
   Pop_Return_Ucode_Hook();
   Restore_Cont();
   if (Consistency_Check &&
@@ -1420,6 +1440,7 @@ Internal_Apply:
 
       if (Microcode_Does_Stepping &&
          Trapping &&
+         (! WITHIN_CRITICAL_SECTION_P()) &&
          ((Fetch_Apply_Trapper ()) != SHARP_F))
       {
        long Count;
@@ -1896,6 +1917,7 @@ return_from_compiled_code:
 Primitive_Internal_Apply:
       if (Microcode_Does_Stepping &&
          Trapping &&
+         (! WITHIN_CRITICAL_SECTION_P()) &&
          ((Fetch_Apply_Trapper ()) != SHARP_F))
       {
        /* Does this work in the stacklet case?
@@ -2140,18 +2162,6 @@ Primitive_Internal_Apply:
       break;                   /* We never get here.... */
     }
 
-    case RC_RETURN_TRAP_POINT:
-      Store_Return(Old_Return_Code);
-     Will_Push(CONTINUATION_SIZE+3);
-      Save_Cont();
-      Return_Hook_Address = NULL;
-      Stop_Trapping();
-      STACK_PUSH (Val);
-      STACK_PUSH (Fetch_Return_Trapper());
-      STACK_PUSH (STACK_FRAME_HEADER+1);
-     Pushed();
-      goto Apply_Non_Trapping;
-
     case RC_SEQ_2_DO_2:
       End_Subproblem();
       Restore_Env();

diff --git a/v7/src/microcode/interp.h b/v7/src/microcode/interp.h
index 3891a59013d3ebcb4baacaf42f03bbd536ae7c3f..9d2443cf8317a31910a51ec1ad2ae989ea7e08f1 100644 (file)
--- a/v7/src/microcode/interp.h
+++ b/v7/src/microcode/interp.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.h,v 9.33 1990/06/20 17:41:20 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.h,v 9.34 1991/07/18 15:59:41 markf Exp $
 
 Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
 
@@ -201,11 +201,6 @@ extern int EXFUN (abort_to_interpreter_argument, (void));
 #define Stop_Trapping()                                                        \
 {                                                                      \
   Trapping = false;                                                    \
-  if (Return_Hook_Address != NULL)                                     \
-  {                                                                    \
-    *Return_Hook_Address = Old_Return_Code;                            \
-  }                                                                    \
-  Return_Hook_Address = NULL;                                          \
 }
 \f
 /* Primitive utility macros */

diff --git a/v7/src/microcode/step.c b/v7/src/microcode/step.c
index bf89fb12a233f506944927ba5f6792365326cbf1..17a08a5425923c76c501174281c2024035ce3395 100644 (file)
--- a/v7/src/microcode/step.c
+++ b/v7/src/microcode/step.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/step.c,v 9.28 1990/06/20 17:42:08 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/step.c,v 9.29 1991/07/18 16:01:27 markf Exp $
 
 Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
 
@@ -47,9 +47,8 @@ MIT in each case. */
 */
 
 void
-Install_Traps(Hunk3, Return_Hook_Too)
+Install_Traps (Hunk3)
      SCHEME_OBJECT Hunk3;
-     Boolean Return_Hook_Too;
 {
   SCHEME_OBJECT Eval_Hook, Apply_Hook, Return_Hook;
 
@@ -58,18 +57,9 @@ Install_Traps(Hunk3, Return_Hook_Too)
   Apply_Hook = MEMORY_REF (Hunk3, HUNK_CXR1);
   Return_Hook = MEMORY_REF (Hunk3, HUNK_CXR2);
   Set_Fixed_Obj_Slot(Stepper_State, Hunk3);
-  Trapping = ((Eval_Hook != SHARP_F) | (Apply_Hook != SHARP_F));
-  if (Microcode_Does_Stepping && Return_Hook_Too && (Return_Hook != SHARP_F))
-  {
-    /* Here it is ... gross and ugly.  We know that the top of stack
-       has the existing return code to be clobbered, since it was put
-       there by Save_Cont.
-    */
-    Return_Hook_Address = (STACK_LOC (0));
-    Old_Return_Code = (*Return_Hook_Address);
-    (*Return_Hook_Address) =
-      (MAKE_OBJECT (TC_RETURN_CODE, RC_RETURN_TRAP_POINT));
-  }
+  Trapping = ((Eval_Hook != SHARP_F) |
+             (Apply_Hook != SHARP_F) |
+             (Return_Hook != SHARP_F));
   return;
 }
 \f
@@ -83,12 +73,14 @@ Install_Traps(Hunk3, Return_Hook_Too)
 DEFINE_PRIMITIVE ("PRIMITIVE-EVAL-STEP", Prim_eval_step, 3, 3, 0)
 {
   PRIMITIVE_HEADER (3);
+  CHECK_ARG (3, HUNK3_P);
   {
     SCHEME_OBJECT expression = (ARG_REF (1));
     SCHEME_OBJECT environment = (ARG_REF (2));
+    SCHEME_OBJECT hooks = (ARG_REF (3));
     PRIMITIVE_CANONICALIZE_CONTEXT ();
-    Install_Traps ((ARG_REF (3)), false);
     POP_PRIMITIVE_FRAME (3);
+    Install_Traps (hooks);
     Store_Expression (expression);
     Store_Env (environment);
   }
@@ -111,37 +103,40 @@ DEFINE_PRIMITIVE ("PRIMITIVE-APPLY-STEP", Prim_apply_step, 3, 3, 0)
   PRIMITIVE_CANONICALIZE_CONTEXT ();
   CHECK_ARG (3, HUNK3_P);
   {
-    SCHEME_OBJECT procedure = (ARG_REF (2));
-    SCHEME_OBJECT argument_list = (ARG_REF (3));
+    SCHEME_OBJECT hooks = (ARG_REF (3));
     fast long number_of_args = 0;
     {
-      fast SCHEME_OBJECT scan_list;
-      TOUCH_IN_PRIMITIVE (argument_list, scan_list);
-      while (PAIR_P (scan_list))
-       {
-         number_of_args += 1;
-         TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
-       }
-      if (scan_list != EMPTY_LIST)
-       error_wrong_type_arg (2);
-    }
-    Install_Traps ((ARG_REF (3)), true);
-    POP_PRIMITIVE_FRAME (3);
-    {
-      fast SCHEME_OBJECT * scan_stack = (STACK_LOC (- number_of_args));
-      fast SCHEME_OBJECT scan_list;
-      fast long i;
-    Will_Push (number_of_args + STACK_ENV_EXTRA_SLOTS + 1);
-      Stack_Pointer = scan_stack;
-      TOUCH_IN_PRIMITIVE (argument_list, scan_list);
-      for (i = number_of_args; (i > 0); i -= 1)
-       {
-         (*scan_stack++) = (PAIR_CAR (scan_list));
-         TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
-       }
-      STACK_PUSH (procedure);
-      STACK_PUSH (STACK_FRAME_HEADER + number_of_args);
-    Pushed ();
+      SCHEME_OBJECT procedure = (ARG_REF (1));
+      SCHEME_OBJECT argument_list = (ARG_REF (2));
+      {
+       fast SCHEME_OBJECT scan_list;
+       TOUCH_IN_PRIMITIVE (argument_list, scan_list);
+       while (PAIR_P (scan_list))
+         {
+           number_of_args += 1;
+           TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
+         }
+       if (scan_list != EMPTY_LIST)
+         error_wrong_type_arg (2);
+      }
+      POP_PRIMITIVE_FRAME (3);
+      Install_Traps (hooks);
+      {
+       fast SCHEME_OBJECT * scan_stack = (STACK_LOC (- number_of_args));
+       fast SCHEME_OBJECT scan_list;
+       fast long i;
+       Will_Push (number_of_args + STACK_ENV_EXTRA_SLOTS + 1);
+       Stack_Pointer = scan_stack;
+       TOUCH_IN_PRIMITIVE (argument_list, scan_list);
+       for (i = number_of_args; (i > 0); i -= 1)
+         {
+           (*scan_stack++) = (PAIR_CAR (scan_list));
+           TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
+         }
+       STACK_PUSH (procedure);
+       STACK_PUSH (STACK_FRAME_HEADER + number_of_args);
+       Pushed ();
+      }
     }
   }
   PRIMITIVE_ABORT (PRIM_NO_TRAP_APPLY);
@@ -152,16 +147,20 @@ DEFINE_PRIMITIVE ("PRIMITIVE-APPLY-STEP", Prim_apply_step, 3, 3, 0)
    Returns VALUE and intalls the eval-trap, apply-trap, and
    return-trap from HUNK3.  If any trap is '(), it is a null trap
    that does a normal EVAL, APPLY or return.
-
-   UGLY ... currently assumes that it is illegal to set a return trap
-   this way, so that we don't run into stack parsing problems.  If
-   this is ever changed, be sure to check for COMPILE_STEPPER flag! */
+*/
 
 DEFINE_PRIMITIVE ("PRIMITIVE-RETURN-STEP", Prim_return_step, 2, 2, 0)
 {
   PRIMITIVE_HEADER (2);
-  if ((MEMORY_REF ((ARG_REF (2)), HUNK_CXR2)) != SHARP_F)
-    error_bad_range_arg (2);
-  Install_Traps ((ARG_REF (2)), false);
-  PRIMITIVE_RETURN (ARG_REF (1));
+  PRIMITIVE_CANONICALIZE_CONTEXT ();
+  CHECK_ARG (2, HUNK3_P);
+  {
+    SCHEME_OBJECT value = (ARG_REF (1));
+    SCHEME_OBJECT hooks = (ARG_REF (2));
+
+    POP_PRIMITIVE_FRAME (2); 
+    Install_Traps (hooks);
+    Val = (value);
+    PRIMITIVE_ABORT (PRIM_NO_TRAP_POP_RETURN);
+  }
 }

diff --git a/v8/src/microcode/const.h b/v8/src/microcode/const.h
index 311d3f301ca4eb429e9f7c8be89e02f868924c74..cc08ade8e02546641baa9afad8694c52d990a938 100644 (file)
--- a/v8/src/microcode/const.h
+++ b/v8/src/microcode/const.h
@@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising,
 promotional, or sales literature without prior written consent from
 MIT in each case. */
 
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/const.h,v 9.37 1991/03/21 23:26:21 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/const.h,v 9.38 1991/07/18 16:03:38 markf Exp $
  *
  * Named constants used throughout the interpreter
  *
@@ -127,6 +127,7 @@ MIT in each case. */
 #define PRIM_TOUCH                     -8
 #define PRIM_APPLY_INTERRUPT           -9
 #define PRIM_REENTER                   -10
+#define PRIM_NO_TRAP_POP_RETURN                -11
 
 #define ABORT_NAME_TABLE                                               \
 {                                                                      \
@@ -140,6 +141,7 @@ MIT in each case. */
   /* -8 */     "TOUCH",                                                \
   /* -9 */     "APPLY-INTERRUPT",                                      \
   /* -10 */    "REENTER"                                               \
+  /* -11 */    "NO-TRAP-POP-RETURN"                                    \
 }
 
 /* Some numbers of parameters which mean something special */

diff --git a/v8/src/microcode/interp.c b/v8/src/microcode/interp.c
index ce2f202e6e66518dbf941ee6be2b42cc8d8817e6..9ae7039e40be91df0fd27bb46839da807621778d 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.62 1991/06/22 19:28:54 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/interp.c,v 9.63 1991/07/18 15:58:12 markf Exp $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -487,6 +487,11 @@ Repeat_Dispatch:
     case CODE_MAP(PRIM_POP_RETURN):
       goto Pop_Return;
 
+    case PRIM_NO_TRAP_POP_RETURN:
+      PROCEED_AFTER_PRIMITIVE();
+    case CODE_MAP(PRIM_NO_TRAP_POP_RETURN):
+      goto Pop_Return_Non_Trapping;
+
     case PRIM_REENTER:
       BACK_OUT_AFTER_PRIMITIVE();
       LOG_FUTURES();
@@ -596,6 +601,7 @@ Do_Expression:
 
   if (Microcode_Does_Stepping &&
       Trapping &&
+      (! WITHIN_CRITICAL_SECTION_P()) &&
       ((Fetch_Eval_Trapper ()) != SHARP_F))
   {
     Stop_Trapping ();
@@ -942,6 +948,20 @@ lookup_end_restart:
  */
 
 Pop_Return:
+  if (Microcode_Does_Stepping &&
+      Trapping &&
+      (! WITHIN_CRITICAL_SECTION_P()) &&
+      ((Fetch_Return_Trapper ()) != SHARP_F))
+  {
+    Will_Push(3);
+      Stop_Trapping();
+      STACK_PUSH (Val);
+      STACK_PUSH (Fetch_Return_Trapper());
+      STACK_PUSH (STACK_FRAME_HEADER+1);
+    Pushed();
+    goto Apply_Non_Trapping;
+  }
+Pop_Return_Non_Trapping:
   Pop_Return_Ucode_Hook();
   Restore_Cont();
   if (Consistency_Check &&
@@ -1420,6 +1440,7 @@ Internal_Apply:
 
       if (Microcode_Does_Stepping &&
          Trapping &&
+         (! WITHIN_CRITICAL_SECTION_P()) &&
          ((Fetch_Apply_Trapper ()) != SHARP_F))
       {
        long Count;
@@ -1896,6 +1917,7 @@ return_from_compiled_code:
 Primitive_Internal_Apply:
       if (Microcode_Does_Stepping &&
          Trapping &&
+         (! WITHIN_CRITICAL_SECTION_P()) &&
          ((Fetch_Apply_Trapper ()) != SHARP_F))
       {
        /* Does this work in the stacklet case?
@@ -2140,18 +2162,6 @@ Primitive_Internal_Apply:
       break;                   /* We never get here.... */
     }
 
-    case RC_RETURN_TRAP_POINT:
-      Store_Return(Old_Return_Code);
-     Will_Push(CONTINUATION_SIZE+3);
-      Save_Cont();
-      Return_Hook_Address = NULL;
-      Stop_Trapping();
-      STACK_PUSH (Val);
-      STACK_PUSH (Fetch_Return_Trapper());
-      STACK_PUSH (STACK_FRAME_HEADER+1);
-     Pushed();
-      goto Apply_Non_Trapping;
-
     case RC_SEQ_2_DO_2:
       End_Subproblem();
       Restore_Env();