home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / interp.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  61KB  |  2,168 lines
  1. /* -*-C-*-
  2.  
  3. $Id: interp.c,v 9.90 2000/12/05 21:23:44 cph Exp $
  4.  
  5. Copyright (c) 1988-2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. /* This file contains the heart of the SCode interpreter. */
  23.  
  24. #define In_Main_Interpreter true
  25. #include "scheme.h"
  26. #include "locks.h"
  27. #include "trap.h"
  28. #include "lookup.h"
  29. #include "winder.h"
  30. #include "history.h"
  31. #include "cmpint.h"
  32. #include "zones.h"
  33. #include "prmcon.h"
  34.  
  35. extern PTR EXFUN (obstack_chunk_alloc, (unsigned int size));
  36. extern void EXFUN (free, (PTR ptr));
  37. #define obstack_chunk_free free
  38. extern void EXFUN (back_out_of_primitive_internal, (void));
  39. extern void EXFUN (preserve_signal_mask, (void));
  40.  
  41. #ifdef COMPILE_STEPPER
  42. #define Microcode_Does_Stepping    true
  43. #else
  44. #define Microcode_Does_Stepping    false
  45. #endif
  46.  
  47. /* In order to make the interpreter tail recursive (i.e.
  48.  * to avoid calling procedures and thus saving unnecessary
  49.  * state information), the main body of the interpreter
  50.  * is coded in a continuation passing style.
  51.  *
  52.  * Basically, this is done by dispatching on the type code
  53.  * for an Scode item.  At each dispatch, some processing
  54.  * is done which may include setting the return address
  55.  * register, saving the current continuation (return address
  56.  * and current expression) and jumping to the start of
  57.  * the interpreter.
  58.  *
  59.  * It may be helpful to think of this program as being what
  60.  * you would get if you wrote the straightforward Scheme
  61.  * interpreter and then converted it into continuation
  62.  * passing style as follows.  At every point where you would
  63.  * call EVAL to handle a sub-form, you put a jump back to
  64.  * Do_Expression.  Now, if there was code after the call to
  65.  * EVAL you first push a "return code" (using Save_Cont) on
  66.  * the stack and move the code that used to be after the
  67.  * call down into the part of this file after the tag
  68.  * Pop_Return.
  69.  *
  70.  * Notice that because of the caller saves convention used
  71.  * here, all of the registers which are of interest have
  72.  * been SAVEd on the racks by the time interpretation arrives
  73.  * at Do_Expression (the top of EVAL).
  74.  *
  75.  * For notes on error handling and interrupts, see the file
  76.  * utils.c.
  77.  *
  78.  * This file is divided into two parts. The first
  79.  * corresponds is called the EVAL dispatch, and is ordered
  80.  * alphabetically by the SCode item handled.  The second,
  81.  * called the return dispatch, begins at Pop_Return and is
  82.  * ordered alphabetically by return code name.
  83.  */
  84.  
  85. #define Prepare_Pop_Return_Interrupt(Return_Code, Contents_of_Val)    \
  86. {                                    \
  87.   SCHEME_OBJECT temp;                            \
  88.                                     \
  89.   temp = (Contents_of_Val);                        \
  90.   Store_Return(Return_Code);                        \
  91.   Save_Cont();                                \
  92.   Store_Return(RC_RESTORE_VALUE);                    \
  93.   Store_Expression(temp);                        \
  94.   Save_Cont();                                \
  95. }
  96.  
  97. #define Interrupt(Masked_Code)                        \
  98. {                                    \
  99.   Export_Registers();                            \
  100.   Setup_Interrupt(Masked_Code);                        \
  101.   Import_Registers();                            \
  102.   goto Perform_Application;                        \
  103. }
  104.  
  105. #define Immediate_GC(N)                            \
  106. {                                    \
  107.   Request_GC(N);                            \
  108.   Interrupt(PENDING_INTERRUPTS());                    \
  109. }
  110.  
  111. #define Eval_GC_Check(Amount)                        \
  112. if (GC_Check(Amount))                            \
  113. {                                    \
  114.   Prepare_Eval_Repeat();                        \
  115.   Immediate_GC(Amount);                            \
  116. }
  117.  
  118. #define Prepare_Eval_Repeat()                        \
  119. {                                    \
  120.  Will_Push(CONTINUATION_SIZE+1);                    \
  121.   STACK_PUSH (Fetch_Env());                        \
  122.   Store_Return(RC_EVAL_ERROR);                        \
  123.   Save_Cont();                                \
  124.  Pushed();                                \
  125. }
  126.  
  127. #define Eval_Error(Err)                            \
  128. {                                    \
  129.   Export_Registers();                            \
  130.   Do_Micro_Error(Err, false);                        \
  131.   Import_Registers();                            \
  132.   goto Internal_Apply;                            \
  133. }
  134.  
  135. #define Pop_Return_Error(Err)                        \
  136. {                                    \
  137.   Export_Registers();                            \
  138.   Do_Micro_Error(Err, true);                        \
  139.   Import_Registers();                            \
  140.   goto Internal_Apply;                            \
  141. }
  142.  
  143. #define BACK_OUT_AFTER_PRIMITIVE()                    \
  144. {                                    \
  145.   Export_Registers();                            \
  146.   back_out_of_primitive_internal ();                    \
  147.   Import_Registers();                            \
  148. }
  149.  
  150. #define Reduces_To(Expr)                        \
  151.     { Store_Expression(Expr);                    \
  152.           New_Reduction(Fetch_Expression(), Fetch_Env());        \
  153.           goto Do_Expression;                        \
  154.         }
  155.  
  156. #define Reduces_To_Nth(N)                        \
  157.         Reduces_To(FAST_MEMORY_REF (Fetch_Expression(), (N)))
  158.  
  159. #define Do_Nth_Then(Return_Code, N, Extra)                \
  160.     { Store_Return(Return_Code);                    \
  161.       Save_Cont();                            \
  162.       Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), (N)));    \
  163.       New_Subproblem(Fetch_Expression(), Fetch_Env());        \
  164.           Extra;                            \
  165.       goto Do_Expression;                        \
  166.         }
  167.  
  168. #define Do_Another_Then(Return_Code, N)                    \
  169.     { Store_Return(Return_Code);                    \
  170.           Save_Cont();                            \
  171.       Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), (N)));    \
  172.       Reuse_Subproblem(Fetch_Expression(), Fetch_Env());        \
  173.       goto Do_Expression;                        \
  174.         }
  175.  
  176.                       /***********************/
  177.                       /* Macros for Stepping */
  178.                       /***********************/
  179.  
  180. #define Fetch_Trapper(field)    \
  181.   MEMORY_REF (Get_Fixed_Obj_Slot(Stepper_State), (field))
  182.  
  183. #define Fetch_Eval_Trapper() Fetch_Trapper(HUNK_CXR0)
  184. #define Fetch_Apply_Trapper() Fetch_Trapper(HUNK_CXR1)
  185. #define Fetch_Return_Trapper() Fetch_Trapper(HUNK_CXR2)
  186.  
  187. /* Macros for handling FUTUREs */
  188.  
  189. #ifdef COMPILE_FUTURES
  190.  
  191. /* ARG_TYPE_ERROR handles the error returns from primitives which type check
  192.    their arguments and restarts them or suspends if the argument is a future.
  193.  */
  194.  
  195. #define ARG_TYPE_ERROR(Arg_No, Err_No)                    \
  196. {                                    \
  197.   fast SCHEME_OBJECT *Arg, Orig_Arg;                    \
  198.                                     \
  199.   Arg = &(STACK_REF((Arg_No - 1) + STACK_ENV_FIRST_ARG));        \
  200.   Orig_Arg = *Arg;                            \
  201.                                     \
  202.   if (OBJECT_TYPE (*Arg) != TC_FUTURE)                    \
  203.   {                                    \
  204.     Pop_Return_Error(Err_No);                        \
  205.   }                                    \
  206.                                     \
  207.   while ((OBJECT_TYPE (*Arg) == TC_FUTURE) && (Future_Has_Value(*Arg)))    \
  208.   {                                    \
  209.     if (Future_Is_Keep_Slot(*Arg))                    \
  210.     {                                    \
  211.       Log_Touch_Of_Future(*Arg);                    \
  212.     }                                    \
  213.     *Arg = Future_Value(*Arg);                        \
  214.   }                                    \
  215.   if (OBJECT_TYPE (*Arg) != TC_FUTURE)                    \
  216.   {                                    \
  217.     goto Apply_Non_Trapping;                        \
  218.   }                                    \
  219.                                     \
  220.   TOUCH_SETUP(*Arg);                            \
  221.   *Arg = Orig_Arg;                            \
  222.   goto Apply_Non_Trapping;                        \
  223. }
  224.  
  225. /* Apply_Future_Check is called at apply time to guarantee that certain
  226.    objects (the procedure itself, and its LAMBDA components for user defined
  227.    procedures) are not futures
  228. */
  229.  
  230. #define Apply_Future_Check(Name, Object)                \
  231. {                                    \
  232.   fast SCHEME_OBJECT *Arg, Orig_Answer;                    \
  233.                                     \
  234.   Arg = &(Object);                            \
  235.   Orig_Answer = *Arg;                            \
  236.                                     \
  237.   while (OBJECT_TYPE (*Arg) == TC_FUTURE)                \
  238.   {                                    \
  239.     if (Future_Has_Value(*Arg))                        \
  240.     {                                    \
  241.       if (Future_Is_Keep_Slot(*Arg))                    \
  242.       {                                    \
  243.     Log_Touch_Of_Future(*Arg);                    \
  244.       }                                    \
  245.       *Arg = Future_Value(*Arg);                    \
  246.     }                                    \
  247.     else                                \
  248.     {                                    \
  249.       Prepare_Apply_Interrupt ();                    \
  250.       TOUCH_SETUP (*Arg);                        \
  251.       *Arg = Orig_Answer;                        \
  252.       goto Internal_Apply;                        \
  253.     }                                    \
  254.   }                                    \
  255.   Name = *Arg;                                \
  256. }
  257.  
  258. /* Future handling macros continue on the next page */
  259.  
  260. /* Future handling macros, continued */
  261.  
  262. /* Pop_Return_Val_Check suspends the process if the value calculated by
  263.    a recursive call to EVAL is an undetermined future */
  264.  
  265. #define Pop_Return_Val_Check()                        \
  266. {                                    \
  267.   fast SCHEME_OBJECT Orig_Val = Val;                    \
  268.                                     \
  269.   while (OBJECT_TYPE (Val) == TC_FUTURE)                \
  270.   {                                    \
  271.     if (Future_Has_Value(Val))                        \
  272.     {                                    \
  273.       if (Future_Is_Keep_Slot(Val))                    \
  274.       {                                    \
  275.     Log_Touch_Of_Future(Val);                    \
  276.       }                                    \
  277.       Val = Future_Value(Val);                        \
  278.     }                                    \
  279.     else                                \
  280.     {                                    \
  281.       Save_Cont();                            \
  282.      Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS + 2));    \
  283.       Store_Return(RC_RESTORE_VALUE);                    \
  284.       Store_Expression(Orig_Val);                    \
  285.       Save_Cont();                            \
  286.       STACK_PUSH (Val);                            \
  287.       STACK_PUSH (Get_Fixed_Obj_Slot(System_Scheduler));        \
  288.       STACK_PUSH (STACK_FRAME_HEADER + 1);                \
  289.      Pushed();                                \
  290.       goto Internal_Apply;                        \
  291.     }                                    \
  292.   }                                    \
  293. }
  294.  
  295. /* This saves stuff unnecessarily in most cases.
  296.    For example, when Which_Way is PRIM_APPLY, Val, Env, Expr,
  297.    and Return_Code are undefined.
  298.  */
  299.  
  300. #define LOG_FUTURES()                            \
  301. {                                    \
  302.   if (Must_Report_References())                        \
  303.   {                                    \
  304.     Save_Cont();                            \
  305.    Will_Push(CONTINUATION_SIZE + 2);                    \
  306.     STACK_PUSH (Val);                            \
  307.     Save_Env();                                \
  308.     Store_Return(RC_REPEAT_DISPATCH);                    \
  309.     Store_Expression(LONG_TO_FIXNUM(CODE_MAP(Which_Way)));        \
  310.     Save_Cont();                            \
  311.    Pushed();                                \
  312.     Call_Future_Logging();                        \
  313.  }                                    \
  314. }
  315.  
  316. #else /* not COMPILE_FUTURES */
  317.  
  318. #define Pop_Return_Val_Check()
  319.  
  320. #define Apply_Future_Check(Name, Object)    Name = (Object)
  321.  
  322. #define ARG_TYPE_ERROR(Arg_No, Err_No)                    \
  323. {                                    \
  324.   Pop_Return_Error(Err_No)                        \
  325. }
  326.  
  327. #define LOG_FUTURES()
  328.  
  329. #endif /* COMPILE_FUTURES */
  330.  
  331. /* Notes on Repeat_Dispatch:
  332.  
  333.    The codes used (values of Which_Way) are divided into two groups:
  334.    Those for which the primitive has already backed out, and those for
  335.    which the back out code has not yet been executed, and is therefore
  336.    executed below.
  337.  
  338.    Under most circumstances the distinction is moot, but if there are
  339.    futures in the system, and future touches must be logged, the code
  340.    must be set up to "interrupt" the dispatch, and proceed it later.
  341.    The primitive back out code must be done before the furure is
  342.    logged, so all of these codes are split into two versions: one set
  343.    before doing the back out, and another afterwards.
  344.  */
  345.  
  346. /* This is assumed to be larger (in absolute value) than any PRIM_<mumble>
  347.    and ERR_<mumble>.
  348.  */
  349. #define PRIM_BIAS_AMOUNT 1000
  350.  
  351. #if (MAX_ERROR >= PRIM_BIAS_AMOUNT)
  352. #include "Inconsistency: errors.h and interp.c"
  353. #endif
  354.  
  355. #define CODE_MAP(code)                            \
  356. ((code < 0) ?                                \
  357.  (code - PRIM_BIAS_AMOUNT) :                        \
  358.  (code + PRIM_BIAS_AMOUNT))
  359.  
  360. #define CODE_UNMAP(code)                        \
  361. ((code < 0) ?                                \
  362.  (code + PRIM_BIAS_AMOUNT) :                        \
  363.  (code - PRIM_BIAS_AMOUNT))
  364.  
  365. #define CODE_MAPPED_P(code)                        \
  366. ((code < (- PRIM_BIAS_AMOUNT)) ||                    \
  367.  (code >= PRIM_BIAS_AMOUNT))
  368.  
  369. #define PROCEED_AFTER_PRIMITIVE()                    \
  370. {                                    \
  371.   (Regs [REGBLOCK_PRIMITIVE]) = SHARP_F;                \
  372.   LOG_FUTURES ();                            \
  373. }
  374.  
  375. /*
  376.   The EVAL/APPLY ying/yang
  377.  */
  378.  
  379.  
  380. interpreter_state_t interpreter_state = NULL_INTERPRETER_STATE;
  381.  
  382. void
  383. DEFUN (bind_interpreter_state, (s), interpreter_state_t s)
  384. {
  385.   (s -> previous_state) = interpreter_state;
  386.   (s -> nesting_level) =
  387.     ((interpreter_state == NULL_INTERPRETER_STATE)
  388.      ? 0
  389.      : (1 + (interpreter_state -> nesting_level)));
  390.   (s -> dstack_position) = dstack_position;
  391.   interpreter_state = s;
  392. }
  393.  
  394. void
  395. DEFUN (unbind_interpreter_state, (s), interpreter_state_t s)
  396. {
  397.   interpreter_state = s;
  398.   {
  399.     long old_mask = (FETCH_INTERRUPT_MASK ());
  400.     SET_INTERRUPT_MASK (0);
  401.     dstack_set_position (s -> dstack_position);
  402.     SET_INTERRUPT_MASK (old_mask);
  403.   }
  404.   interpreter_state = (s -> previous_state);
  405. }
  406.  
  407. void
  408. DEFUN (abort_to_interpreter, (argument), int argument)
  409. {
  410.   if (interpreter_state == NULL_INTERPRETER_STATE)
  411.   {
  412.     outf_fatal ("abort_to_interpreter: Interpreter not set up.\n");
  413.     termination_init_error ();
  414.   }
  415.   
  416.   interpreter_throw_argument = argument;
  417.   {
  418.     long old_mask = (FETCH_INTERRUPT_MASK ());
  419.     SET_INTERRUPT_MASK (0);
  420.     dstack_set_position (interpreter_catch_dstack_position);
  421.     SET_INTERRUPT_MASK (old_mask);
  422.   }
  423.   obstack_free ((&scratch_obstack), 0);
  424.   obstack_init (&scratch_obstack);
  425.   longjmp (interpreter_catch_env, argument);
  426. }
  427.  
  428. int
  429. DEFUN_VOID (abort_to_interpreter_argument)
  430. {
  431.   return (interpreter_throw_argument);
  432. }
  433.  
  434. extern void EXFUN (Interpret, (Boolean));
  435.  
  436. void
  437. DEFUN (Interpret, (pop_return_p), Boolean pop_return_p)
  438. {
  439.   long Which_Way;
  440.   fast SCHEME_OBJECT * Reg_Block, * Reg_Stack_Pointer, * Reg_History;
  441.   struct interpreter_state_s new_state;
  442.   extern long enter_compiled_expression();
  443.   extern long apply_compiled_procedure();
  444.   extern long return_to_compiled_code();
  445.  
  446.   Reg_Block = &Registers[0];
  447.  
  448.   /* Primitives jump back here for errors, requests to evaluate an
  449.    * expression, apply a function, or handle an interrupt request.  On
  450.    * errors or interrupts they leave their arguments on the stack, the
  451.    * primitive itself in Expression.  The code should do a primitive
  452.    * backout in these cases, but not in others (apply, eval, etc.), since
  453.    * the primitive itself will have left the state of the interpreter ready
  454.    * for operation.
  455.    */
  456.  
  457.   bind_interpreter_state (&new_state);
  458.   Which_Way = (setjmp (interpreter_catch_env));
  459.   preserve_signal_mask ();
  460.   Set_Time_Zone (Zone_Working);
  461.   Import_Registers ();
  462.  
  463. Repeat_Dispatch:
  464.   switch (Which_Way)
  465.     {
  466.     case PRIM_APPLY:
  467.       PROCEED_AFTER_PRIMITIVE();
  468.     case CODE_MAP(PRIM_APPLY):
  469.       goto Internal_Apply;
  470.  
  471.     case PRIM_NO_TRAP_APPLY:
  472.       PROCEED_AFTER_PRIMITIVE();
  473.     case CODE_MAP(PRIM_NO_TRAP_APPLY):
  474.       goto Apply_Non_Trapping;
  475.  
  476.     case PRIM_DO_EXPRESSION:
  477.       Val = Fetch_Expression();
  478.       PROCEED_AFTER_PRIMITIVE();
  479.     case CODE_MAP(PRIM_DO_EXPRESSION):
  480.       Reduces_To(Val);
  481.  
  482.     case PRIM_NO_TRAP_EVAL:
  483.       Val = Fetch_Expression();
  484.       PROCEED_AFTER_PRIMITIVE();
  485.     case CODE_MAP(PRIM_NO_TRAP_EVAL):
  486.       New_Reduction(Val, Fetch_Env());
  487.       goto Eval_Non_Trapping;
  488.  
  489.     case 0:            /* first time */
  490.       if (pop_return_p)
  491.     goto Pop_Return;
  492.       else
  493.     break;            /* fall into eval */
  494.  
  495.     case PRIM_POP_RETURN:
  496.       PROCEED_AFTER_PRIMITIVE();
  497.     case CODE_MAP(PRIM_POP_RETURN):
  498.       goto Pop_Return;
  499.  
  500.     case PRIM_NO_TRAP_POP_RETURN:
  501.       PROCEED_AFTER_PRIMITIVE();
  502.     case CODE_MAP(PRIM_NO_TRAP_POP_RETURN):
  503.       goto Pop_Return_Non_Trapping;
  504.  
  505.     case PRIM_REENTER:
  506.       BACK_OUT_AFTER_PRIMITIVE();
  507.       LOG_FUTURES();
  508.     case CODE_MAP(PRIM_REENTER):
  509.       goto Perform_Application;
  510.  
  511.     case PRIM_TOUCH:
  512.       {
  513.     SCHEME_OBJECT temp;
  514.  
  515.     temp = Val;
  516.     BACK_OUT_AFTER_PRIMITIVE();
  517.     Val = temp;
  518.     LOG_FUTURES();
  519.       }
  520.     /* fall through */
  521.     case CODE_MAP(PRIM_TOUCH):
  522.       TOUCH_SETUP(Val);
  523.       goto Internal_Apply;
  524.  
  525.     case PRIM_INTERRUPT:
  526.       BACK_OUT_AFTER_PRIMITIVE();
  527.       LOG_FUTURES();
  528.       /* fall through */
  529.     case CODE_MAP(PRIM_INTERRUPT):
  530.       Save_Cont();
  531.       Interrupt(PENDING_INTERRUPTS());
  532.  
  533.     case ERR_ARG_1_WRONG_TYPE:
  534.       BACK_OUT_AFTER_PRIMITIVE();
  535.       LOG_FUTURES();
  536.       /* fall through */
  537.     case CODE_MAP(ERR_ARG_1_WRONG_TYPE):
  538.       ARG_TYPE_ERROR(1, ERR_ARG_1_WRONG_TYPE);
  539.  
  540.     case ERR_ARG_2_WRONG_TYPE:
  541.       BACK_OUT_AFTER_PRIMITIVE();
  542.       LOG_FUTURES();
  543.       /* fall through */
  544.     case CODE_MAP(ERR_ARG_2_WRONG_TYPE):
  545.       ARG_TYPE_ERROR(2, ERR_ARG_2_WRONG_TYPE);
  546.  
  547.     case ERR_ARG_3_WRONG_TYPE:
  548.       BACK_OUT_AFTER_PRIMITIVE();
  549.       LOG_FUTURES();
  550.       /* fall through */
  551.     case CODE_MAP(ERR_ARG_3_WRONG_TYPE):
  552.       ARG_TYPE_ERROR(3, ERR_ARG_3_WRONG_TYPE);
  553.  
  554.     default:
  555.       {
  556.     if (!CODE_MAPPED_P(Which_Way))
  557.       {
  558.         BACK_OUT_AFTER_PRIMITIVE();
  559.         LOG_FUTURES();
  560.       }
  561.     else
  562.       {
  563.         Which_Way = CODE_UNMAP(Which_Way);
  564.       }
  565.     Pop_Return_Error(Which_Way);
  566.       }
  567.     }
  568.  
  569. Do_Expression:
  570.  
  571.   if (0 && Eval_Debug)
  572.     {
  573.       Print_Expression ((Fetch_Expression ()), "Eval, expression");
  574.       outf_console ("\n");
  575.     }
  576.  
  577.   /* The expression register has an Scode item in it which
  578.    * should be evaluated and the result left in Val.
  579.    *
  580.    * A "break" after the code for any operation indicates that
  581.    * all processing for this operation has been completed, and
  582.    * the next step will be to pop a return code off the stack
  583.    * and proceed at Pop_Return.  This is sometimes called
  584.    * "executing the continuation" since the return code can be
  585.    * considered the continuation to be performed after the
  586.    * operation.
  587.    *
  588.    * An operation can terminate with a Reduces_To or
  589.    * Reduces_To_Nth macro.  This indicates that the  value of
  590.    * the current Scode item is the value returned when the
  591.    * new expression is evaluated.  Therefore no new
  592.    * continuation is created and processing continues at
  593.    * Do_Expression with the new expression in the expression
  594.    * register.
  595.    *
  596.    * Finally, an operation can terminate with a Do_Nth_Then
  597.    * macro.  This indicates that another expression must be
  598.    * evaluated and them some additional processing will be
  599.    * performed before the value of this S-Code item available.
  600.    * Thus a new continuation is created and placed on the
  601.    * stack (using Save_Cont), the new expression is placed in
  602.    * the Expression register, and processing continues at
  603.    * Do_Expression.
  604.    */
  605.  
  606.   /* Handling of Eval Trapping.
  607.  
  608.      If we are handling traps and there is an Eval Trap set,
  609.      turn off all trapping and then go to Internal_Apply to call the
  610.      user supplied eval hook with the expression to be evaluated and the
  611.      environment. */
  612.  
  613.   if (Microcode_Does_Stepping &&
  614.       Trapping &&
  615.       (! WITHIN_CRITICAL_SECTION_P()) &&
  616.       ((Fetch_Eval_Trapper ()) != SHARP_F))
  617.     {
  618.       Stop_Trapping ();
  619.       Will_Push (4);
  620.       STACK_PUSH (Fetch_Env ());
  621.       STACK_PUSH (Fetch_Expression ());
  622.       STACK_PUSH (Fetch_Eval_Trapper ());
  623.       STACK_PUSH (STACK_FRAME_HEADER + 2);
  624.       Pushed ();
  625.       goto Apply_Non_Trapping;
  626.     }
  627.  
  628. Eval_Non_Trapping:
  629.   Eval_Ucode_Hook();
  630.   switch (OBJECT_TYPE (Fetch_Expression()))
  631.     {
  632.     default:
  633. #if FALSE
  634.       Eval_Error(ERR_UNDEFINED_USER_TYPE);
  635. #else
  636.       /* fall through to self evaluating. */
  637. #endif
  638.  
  639.     case TC_BIG_FIXNUM:         /* The self evaluating items */
  640.     case TC_BIG_FLONUM:
  641.     case TC_CHARACTER_STRING:
  642.     case TC_CHARACTER:
  643.     case TC_COMPILED_CODE_BLOCK:
  644.     case TC_COMPLEX:
  645.     case TC_CONTROL_POINT:
  646.     case TC_DELAYED:
  647.     case TC_ENTITY:
  648.     case TC_ENVIRONMENT:
  649.     case TC_EXTENDED_PROCEDURE:
  650.     case TC_FIXNUM:
  651.     case TC_HUNK3_A:
  652.     case TC_HUNK3_B:
  653.     case TC_INTERNED_SYMBOL:
  654.     case TC_LIST:
  655.     case TC_NON_MARKED_VECTOR:
  656.     case TC_NULL:
  657.     case TC_PRIMITIVE:
  658.     case TC_PROCEDURE:
  659.     case TC_QUAD:
  660.     case TC_RATNUM:
  661.     case TC_REFERENCE_TRAP:
  662.     case TC_RETURN_CODE:
  663.     case TC_UNINTERNED_SYMBOL:
  664.     case TC_CONSTANT:
  665.     case TC_VECTOR:
  666.     case TC_VECTOR_16B:
  667.     case TC_VECTOR_1B:
  668.       Val = Fetch_Expression();
  669.       break;
  670.  
  671.     case TC_ACCESS:
  672.       Will_Push(CONTINUATION_SIZE);
  673.       Do_Nth_Then(RC_EXECUTE_ACCESS_FINISH, ACCESS_ENVIRONMENT, Pushed());
  674.  
  675.     case TC_ASSIGNMENT:
  676.       Will_Push(CONTINUATION_SIZE + 1);
  677.       Save_Env();
  678.       Do_Nth_Then(RC_EXECUTE_ASSIGNMENT_FINISH, ASSIGN_VALUE, Pushed());
  679.  
  680.     case TC_BROKEN_HEART:
  681.       Export_Registers();
  682.       Microcode_Termination (TERM_BROKEN_HEART);
  683.  
  684.     case TC_COMBINATION:
  685.       {
  686.     long Array_Length;
  687.  
  688.     Array_Length = (VECTOR_LENGTH (Fetch_Expression()) - 1);
  689. #ifdef USE_STACKLETS
  690.     /* Save_Env, Finger */
  691.         Eval_GC_Check
  692.       (New_Stacklet_Size (Array_Length + 1 + 1 + CONTINUATION_SIZE));
  693. #endif /* USE_STACKLETS */
  694.     Will_Push(Array_Length + 1 + 1 + CONTINUATION_SIZE);
  695.     Stack_Pointer = (STACK_LOC (- Array_Length));
  696.         STACK_PUSH (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, Array_Length));
  697.     /* The finger: last argument number */
  698.     Pushed();
  699.         if (Array_Length == 0)
  700.       {
  701.         STACK_PUSH (STACK_FRAME_HEADER);   /* Frame size */
  702.         Do_Nth_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT, {});
  703.       }
  704.     Save_Env();
  705.     Do_Nth_Then(RC_COMB_SAVE_VALUE, Array_Length+1, {});
  706.       }
  707.  
  708.     case TC_COMBINATION_1:
  709.       Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 1);
  710.       Save_Env();
  711.       Do_Nth_Then(RC_COMB_1_PROCEDURE, COMB_1_ARG_1, {});
  712.  
  713.     case TC_COMBINATION_2:
  714.       Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 2);
  715.       Save_Env();
  716.       Do_Nth_Then(RC_COMB_2_FIRST_OPERAND, COMB_2_ARG_2, {});
  717.  
  718.     case TC_COMMENT:
  719.       Reduces_To_Nth(COMMENT_EXPRESSION);
  720.  
  721.     case TC_CONDITIONAL:
  722.       Will_Push(CONTINUATION_SIZE + 1);
  723.       Save_Env();
  724.       Do_Nth_Then(RC_CONDITIONAL_DECIDE, COND_PREDICATE, Pushed());
  725.  
  726.     case TC_COMPILED_ENTRY:
  727.       {
  728.     SCHEME_OBJECT compiled_expression;
  729.  
  730.     compiled_expression = (Fetch_Expression ());
  731.     execute_compiled_setup();
  732.     Store_Expression (compiled_expression);
  733.     Export_Registers();
  734.     Which_Way = enter_compiled_expression();
  735.     goto return_from_compiled_code;
  736.       }
  737.  
  738.     case TC_DEFINITION:
  739.       Will_Push(CONTINUATION_SIZE + 1);
  740.       Save_Env();
  741.       Do_Nth_Then(RC_EXECUTE_DEFINITION_FINISH, DEFINE_VALUE, Pushed());
  742.  
  743.     case TC_DELAY:
  744.       /* Deliberately omitted: Eval_GC_Check(2); */
  745.       Val = MAKE_POINTER_OBJECT (TC_DELAYED, Free);
  746.       Free[THUNK_ENVIRONMENT] = Fetch_Env();
  747.       Free[THUNK_PROCEDURE] =
  748.         FAST_MEMORY_REF (Fetch_Expression(), DELAY_OBJECT);
  749.       Free += 2;
  750.       break;
  751.  
  752.     case TC_DISJUNCTION:
  753.       Will_Push(CONTINUATION_SIZE + 1);
  754.       Save_Env();
  755.       Do_Nth_Then(RC_DISJUNCTION_DECIDE, OR_PREDICATE, Pushed());
  756.  
  757.     case TC_EXTENDED_LAMBDA:    /* Close the procedure */
  758.       /* Deliberately omitted: Eval_GC_Check(2); */
  759.       Val = MAKE_POINTER_OBJECT (TC_EXTENDED_PROCEDURE, Free);
  760.       Free[PROCEDURE_LAMBDA_EXPR] = Fetch_Expression();
  761.       Free[PROCEDURE_ENVIRONMENT] = Fetch_Env();
  762.       Free += 2;
  763.       break;
  764.  
  765. #ifdef COMPILE_FUTURES
  766.     case TC_FUTURE:
  767.       if (Future_Has_Value(Fetch_Expression()))
  768.     {
  769.       SCHEME_OBJECT Future = Fetch_Expression();
  770.       if (Future_Is_Keep_Slot(Future)) Log_Touch_Of_Future(Future);
  771.       Reduces_To_Nth(FUTURE_VALUE);
  772.     }
  773.       Prepare_Eval_Repeat();
  774.       Will_Push(STACK_ENV_EXTRA_SLOTS+2);
  775.       STACK_PUSH (Fetch_Expression());    /* Arg: FUTURE object */
  776.       STACK_PUSH (Get_Fixed_Obj_Slot(System_Scheduler));
  777.       STACK_PUSH (STACK_FRAME_HEADER+1);
  778.       Pushed();
  779.       goto Internal_Apply;
  780. #endif
  781.  
  782.     case TC_IN_PACKAGE:
  783.       Will_Push(CONTINUATION_SIZE);
  784.       Do_Nth_Then(RC_EXECUTE_IN_PACKAGE_CONTINUE,
  785.                   IN_PACKAGE_ENVIRONMENT, Pushed());
  786.  
  787.     case TC_LAMBDA:             /* Close the procedure */
  788.     case TC_LEXPR:
  789.       /* Deliberately omitted: Eval_GC_Check(2); */
  790.       Val = MAKE_POINTER_OBJECT (TC_PROCEDURE, Free);
  791.       Free[PROCEDURE_LAMBDA_EXPR] = Fetch_Expression();
  792.       Free[PROCEDURE_ENVIRONMENT] = Fetch_Env();
  793.       Free += 2;
  794.       break;
  795.  
  796.     case TC_MANIFEST_NM_VECTOR:
  797.     case TC_MANIFEST_SPECIAL_NM_VECTOR:
  798.       Eval_Error(ERR_EXECUTE_MANIFEST_VECTOR);
  799.  
  800.       /*
  801.     The argument to Will_Eventually_Push is determined by how much
  802.     will be on the stack if we back out of the primitive.
  803.     */
  804.  
  805.     case TC_PCOMB0:
  806.       Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
  807.       Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
  808.       Store_Expression (OBJECT_NEW_TYPE (TC_PRIMITIVE, (Fetch_Expression ())));
  809.       goto Primitive_Internal_Apply;
  810.  
  811.     case TC_PCOMB1:
  812.       Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 1);
  813.       Do_Nth_Then(RC_PCOMB1_APPLY, PCOMB1_ARG_SLOT, {});
  814.  
  815.     case TC_PCOMB2:
  816.       Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 2);
  817.       Save_Env();
  818.       Do_Nth_Then(RC_PCOMB2_DO_1, PCOMB2_ARG_2_SLOT, {});
  819.  
  820.     case TC_PCOMB3:
  821.       Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 3);
  822.       Save_Env();
  823.       Do_Nth_Then(RC_PCOMB3_DO_2, PCOMB3_ARG_3_SLOT, {});
  824.  
  825.     case TC_SCODE_QUOTE:
  826.       Val = FAST_MEMORY_REF (Fetch_Expression(), SCODE_QUOTE_OBJECT);
  827.       break;
  828.  
  829.     case TC_SEQUENCE_2:
  830.       Will_Push(CONTINUATION_SIZE + 1);
  831.       Save_Env();
  832.       Do_Nth_Then(RC_SEQ_2_DO_2, SEQUENCE_1, Pushed());
  833.  
  834.     case TC_SEQUENCE_3:
  835.       Will_Push(CONTINUATION_SIZE + 1);
  836.       Save_Env();
  837.       Do_Nth_Then(RC_SEQ_3_DO_2, SEQUENCE_1, Pushed());
  838.  
  839.     case TC_THE_ENVIRONMENT:
  840.       Val = Fetch_Env(); break;
  841.  
  842.     case TC_VARIABLE:
  843.       {
  844.     long temp;
  845.  
  846. #ifndef No_In_Line_Lookup
  847.  
  848.     fast SCHEME_OBJECT *cell;
  849.  
  850.     Set_Time_Zone(Zone_Lookup);
  851.     cell = OBJECT_ADDRESS (Fetch_Expression());
  852.     lookup(cell, Fetch_Env(), cell, repeat_variable_lookup);
  853.  
  854.       lookup_end_restart:
  855.  
  856.     Val = MEMORY_FETCH (cell[0]);
  857.     if (OBJECT_TYPE (Val) != TC_REFERENCE_TRAP)
  858.       {
  859.         Set_Time_Zone(Zone_Working);
  860.         goto Pop_Return;
  861.       }
  862.  
  863.     get_trap_kind(temp, Val);
  864.     switch(temp)
  865.       {
  866.       case TRAP_DANGEROUS:
  867.       case TRAP_UNBOUND_DANGEROUS:
  868.       case TRAP_UNASSIGNED_DANGEROUS:
  869.       case TRAP_FLUID_DANGEROUS:
  870.       case TRAP_COMPILER_CACHED_DANGEROUS:
  871.         cell = OBJECT_ADDRESS (Fetch_Expression());
  872.         temp =
  873.           deep_lookup_end(deep_lookup(Fetch_Env(),
  874.                       cell[VARIABLE_SYMBOL],
  875.                       cell),
  876.                   cell);
  877.         Import_Val();
  878.         if (temp != PRIM_DONE)
  879.           break;
  880.         Set_Time_Zone(Zone_Working);
  881.         goto Pop_Return;
  882.  
  883.       case TRAP_COMPILER_CACHED:
  884.         cell = MEMORY_LOC (FAST_MEMORY_REF (Val, TRAP_EXTRA),
  885.                    TRAP_EXTENSION_CELL);
  886.         goto lookup_end_restart;
  887.  
  888.       case TRAP_FLUID:
  889.         cell = lookup_fluid(Val);
  890.         goto lookup_end_restart;
  891.  
  892.       case TRAP_UNBOUND:
  893.         temp = ERR_UNBOUND_VARIABLE;
  894.         break;
  895.  
  896.       case TRAP_UNASSIGNED:
  897.         temp = ERR_UNASSIGNED_VARIABLE;
  898.         break;
  899.  
  900.       default:
  901.         temp = ERR_ILLEGAL_REFERENCE_TRAP;
  902.         break;
  903.       }
  904.  
  905. #else /* No_In_Line_Lookup */
  906.  
  907.     Set_Time_Zone(Zone_Lookup);
  908.     temp = Lex_Ref(Fetch_Env(), Fetch_Expression());
  909.     Import_Val();
  910.     if (temp == PRIM_DONE)
  911.       goto Pop_Return;
  912.  
  913. #endif /* No_In_Line_Lookup */
  914.  
  915.     /* Back out of the evaluation. */
  916.  
  917.     Set_Time_Zone(Zone_Working);
  918.  
  919.     if (temp == PRIM_INTERRUPT)
  920.       {
  921.         Prepare_Eval_Repeat();
  922.         Interrupt(PENDING_INTERRUPTS());
  923.       }
  924.  
  925.     Eval_Error(temp);
  926.       }
  927.  
  928.     SITE_EXPRESSION_DISPATCH_HOOK()
  929.       };
  930.  
  931.   /* Now restore the continuation saved during an earlier part
  932.    * of the EVAL cycle and continue as directed.
  933.    */
  934.  
  935. Pop_Return:
  936.   if (Microcode_Does_Stepping &&
  937.       Trapping &&
  938.       (! WITHIN_CRITICAL_SECTION_P()) &&
  939.       ((Fetch_Return_Trapper ()) != SHARP_F))
  940.     {
  941.       Will_Push(3);
  942.       Stop_Trapping();
  943.       STACK_PUSH (Val);
  944.       STACK_PUSH (Fetch_Return_Trapper());
  945.       STACK_PUSH (STACK_FRAME_HEADER+1);
  946.       Pushed();
  947.       goto Apply_Non_Trapping;
  948.     }
  949. Pop_Return_Non_Trapping:
  950.   Pop_Return_Ucode_Hook();
  951.   Restore_Cont();
  952.   if (Consistency_Check &&
  953.       (OBJECT_TYPE (Fetch_Return()) != TC_RETURN_CODE))
  954.     {
  955.       STACK_PUSH (Val);            /* For possible stack trace */
  956.       Save_Cont();
  957.       Export_Registers();
  958.       Microcode_Termination (TERM_BAD_STACK);
  959.     }
  960.   if (0 && Eval_Debug)
  961.     {
  962.       Print_Return ("Pop_Return, return code");
  963.       Print_Expression (Val, "Pop_Return, value");
  964.       outf_console ("\n");
  965.     };
  966.  
  967.   /* Dispatch on the return code.  A BREAK here will cause
  968.    * a "goto Pop_Return" to occur, since this is the most
  969.    * common occurrence.
  970.    */
  971.  
  972.   switch (OBJECT_DATUM (Fetch_Return()))
  973.     {
  974.     case RC_COMB_1_PROCEDURE:
  975.       Restore_Env();
  976.       STACK_PUSH (Val);                /* Arg. 1 */
  977.       STACK_PUSH (SHARP_F);                /* Operator */
  978.       STACK_PUSH (STACK_FRAME_HEADER + 1);
  979.       Finished_Eventual_Pushing(CONTINUATION_SIZE);
  980.       Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_1_FN);
  981.  
  982.     case RC_COMB_2_FIRST_OPERAND:
  983.       Restore_Env();
  984.       STACK_PUSH (Val);
  985.       Save_Env();
  986.       Do_Another_Then(RC_COMB_2_PROCEDURE, COMB_2_ARG_1);
  987.  
  988.     case RC_COMB_2_PROCEDURE:
  989.       Restore_Env();
  990.       STACK_PUSH (Val);                /* Arg 1, just calculated */
  991.       STACK_PUSH (SHARP_F);        /* Function */
  992.       STACK_PUSH (STACK_FRAME_HEADER + 2);
  993.       Finished_Eventual_Pushing(CONTINUATION_SIZE);
  994.       Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_2_FN);
  995.  
  996.     case RC_COMB_APPLY_FUNCTION:
  997.       End_Subproblem();
  998.       goto Internal_Apply_Val;
  999.  
  1000.     case RC_COMB_SAVE_VALUE:
  1001.       {    long Arg_Number;
  1002.  
  1003.       Restore_Env();
  1004.       Arg_Number = OBJECT_DATUM (STACK_REF(STACK_COMB_FINGER))-1;
  1005.       STACK_REF(STACK_COMB_FIRST_ARG+Arg_Number) = Val;
  1006.       STACK_REF(STACK_COMB_FINGER) =
  1007.     MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, Arg_Number);
  1008.       /* DO NOT count on the type code being NMVector here, since
  1009.      the stack parser may create them with #F here! */
  1010.       if (Arg_Number > 0)
  1011.         {
  1012.       Save_Env();
  1013.       Do_Another_Then(RC_COMB_SAVE_VALUE,
  1014.               (COMB_ARG_1_SLOT - 1) + Arg_Number);
  1015.         }
  1016.       STACK_PUSH (FAST_MEMORY_REF (Fetch_Expression(), 0)); /* Frame Size */
  1017.       Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT);
  1018.       }
  1019.  
  1020. #define define_compiler_restart(return_code, entry)            \
  1021.     case return_code:                            \
  1022.       {                                    \
  1023.     extern long entry();                        \
  1024.     compiled_code_restart();                    \
  1025.     Export_Registers();                        \
  1026.     Which_Way = entry();                        \
  1027.     goto return_from_compiled_code;                    \
  1028.       }
  1029.  
  1030.       define_compiler_restart (RC_COMP_INTERRUPT_RESTART,
  1031.                    comp_interrupt_restart)
  1032.  
  1033.       define_compiler_restart (RC_COMP_LOOKUP_APPLY_RESTART,
  1034.                    comp_lookup_apply_restart)
  1035.  
  1036.       define_compiler_restart (RC_COMP_REFERENCE_RESTART,
  1037.                    comp_reference_restart)
  1038.  
  1039.       define_compiler_restart (RC_COMP_ACCESS_RESTART,
  1040.                    comp_access_restart)
  1041.  
  1042.       define_compiler_restart (RC_COMP_UNASSIGNED_P_RESTART,
  1043.                    comp_unassigned_p_restart)
  1044.  
  1045.       define_compiler_restart (RC_COMP_UNBOUND_P_RESTART,
  1046.                    comp_unbound_p_restart)
  1047.  
  1048.       define_compiler_restart (RC_COMP_ASSIGNMENT_RESTART,
  1049.                    comp_assignment_restart)
  1050.  
  1051.       define_compiler_restart (RC_COMP_DEFINITION_RESTART,
  1052.                    comp_definition_restart)
  1053.  
  1054.       define_compiler_restart (RC_COMP_SAFE_REFERENCE_RESTART,
  1055.                    comp_safe_reference_restart)
  1056.  
  1057.       define_compiler_restart (RC_COMP_LOOKUP_TRAP_RESTART,
  1058.                    comp_lookup_trap_restart)
  1059.  
  1060.       define_compiler_restart (RC_COMP_ASSIGNMENT_TRAP_RESTART,
  1061.                    comp_assignment_trap_restart)
  1062.  
  1063.       define_compiler_restart (RC_COMP_OP_REF_TRAP_RESTART,
  1064.                    comp_op_lookup_trap_restart)
  1065.  
  1066.       define_compiler_restart (RC_COMP_CACHE_REF_APPLY_RESTART,
  1067.                    comp_cache_lookup_apply_restart)
  1068.  
  1069.       define_compiler_restart (RC_COMP_SAFE_REF_TRAP_RESTART,
  1070.                    comp_safe_lookup_trap_restart)
  1071.  
  1072.       define_compiler_restart (RC_COMP_UNASSIGNED_TRAP_RESTART,
  1073.                    comp_unassigned_p_trap_restart)
  1074.  
  1075.       define_compiler_restart (RC_COMP_LINK_CACHES_RESTART,
  1076.                    comp_link_caches_restart)
  1077.  
  1078.       define_compiler_restart (RC_COMP_ERROR_RESTART,
  1079.                    comp_error_restart)
  1080.  
  1081.     case RC_REENTER_COMPILED_CODE:
  1082.       compiled_code_restart();
  1083.       Export_Registers();
  1084.       Which_Way = return_to_compiled_code();
  1085.       goto return_from_compiled_code;
  1086.  
  1087.     case RC_CONDITIONAL_DECIDE:
  1088.       Pop_Return_Val_Check();
  1089.       End_Subproblem();
  1090.       Restore_Env();
  1091.       Reduces_To_Nth ((Val == SHARP_F) ? COND_ALTERNATIVE : COND_CONSEQUENT);
  1092.  
  1093.     case RC_DISJUNCTION_DECIDE:
  1094.       /* Return predicate if it isn't #F; else do ALTERNATIVE */
  1095.       Pop_Return_Val_Check();
  1096.       End_Subproblem();
  1097.       Restore_Env();
  1098.       if (Val != SHARP_F) goto Pop_Return;
  1099.       Reduces_To_Nth(OR_ALTERNATIVE);
  1100.  
  1101.     case RC_END_OF_COMPUTATION:
  1102.       {
  1103.     /* Signals bottom of stack */
  1104.  
  1105.     interpreter_state_t previous_state;
  1106.  
  1107.     previous_state = interpreter_state->previous_state;
  1108.     Export_Registers();
  1109.     if (previous_state == NULL_INTERPRETER_STATE)
  1110.       {
  1111.         termination_end_of_computation ();
  1112.         /*NOTREACHED*/
  1113.       }
  1114.     else
  1115.       {
  1116.         dstack_position = interpreter_catch_dstack_position;
  1117.         interpreter_state = previous_state;
  1118.         return;
  1119.       }
  1120.       }
  1121.  
  1122.     case RC_EVAL_ERROR:
  1123.       /* Should be called RC_REDO_EVALUATION. */
  1124.       Store_Env(STACK_POP ());
  1125.       Reduces_To(Fetch_Expression());
  1126.  
  1127.     case RC_EXECUTE_ACCESS_FINISH:
  1128.       {
  1129.     long Result;
  1130.     SCHEME_OBJECT value;
  1131.  
  1132.     Pop_Return_Val_Check();
  1133.     value = Val;
  1134.  
  1135.     if (ENVIRONMENT_P (Val))
  1136.       {
  1137.         Result = Symbol_Lex_Ref(value,
  1138.                     FAST_MEMORY_REF (Fetch_Expression(),
  1139.                              ACCESS_NAME));
  1140.         Import_Val();
  1141.         if (Result == PRIM_DONE)
  1142.           {
  1143.         End_Subproblem();
  1144.         break;
  1145.           }
  1146.         if (Result != PRIM_INTERRUPT)
  1147.           {
  1148.         Val = value;
  1149.         Pop_Return_Error(Result);
  1150.           }
  1151.         Prepare_Pop_Return_Interrupt(RC_EXECUTE_ACCESS_FINISH, value);
  1152.         Interrupt(PENDING_INTERRUPTS());
  1153.       }
  1154.     Val = value;
  1155.     Pop_Return_Error(ERR_BAD_FRAME);
  1156.       }
  1157.  
  1158.     case RC_EXECUTE_ASSIGNMENT_FINISH:
  1159.       {
  1160.     long temp;
  1161.     SCHEME_OBJECT value;
  1162. #ifdef DECLARE_LOCK
  1163.     DECLARE_LOCK (set_serializer);
  1164. #endif
  1165.  
  1166. #ifndef No_In_Line_Lookup
  1167.  
  1168.     SCHEME_OBJECT bogus_unassigned;
  1169.     fast SCHEME_OBJECT *cell;
  1170.  
  1171.     Set_Time_Zone(Zone_Lookup);
  1172.     Restore_Env();
  1173.     cell = OBJECT_ADDRESS (MEMORY_REF (Fetch_Expression(), ASSIGN_NAME));
  1174.     lookup(cell, Fetch_Env(), cell, repeat_assignment_lookup);
  1175.  
  1176.     value = Val;
  1177.     bogus_unassigned = Get_Fixed_Obj_Slot(Non_Object);
  1178.     if (value == bogus_unassigned)
  1179.       value = UNASSIGNED_OBJECT;
  1180.  
  1181.       assignment_end_before_lock:
  1182.  
  1183.     setup_lock(set_serializer, cell);
  1184.  
  1185.       assignment_end_after_lock:
  1186.  
  1187.     Val = *cell;
  1188.  
  1189.     if (OBJECT_TYPE (*cell) != TC_REFERENCE_TRAP)
  1190.       {
  1191.       normal_assignment_done:
  1192.         *cell = value;
  1193.         remove_lock(set_serializer);
  1194.         Set_Time_Zone(Zone_Working);
  1195.         End_Subproblem();
  1196.         goto Pop_Return;
  1197.       }
  1198.  
  1199.     get_trap_kind(temp, *cell);
  1200.     switch(temp)
  1201.       {
  1202.       case TRAP_DANGEROUS:
  1203.       case TRAP_UNBOUND_DANGEROUS:
  1204.       case TRAP_UNASSIGNED_DANGEROUS:
  1205.       case TRAP_FLUID_DANGEROUS:
  1206.       case TRAP_COMPILER_CACHED_DANGEROUS:
  1207.         remove_lock(set_serializer);
  1208.         cell
  1209.           = OBJECT_ADDRESS (MEMORY_REF (Fetch_Expression(), ASSIGN_NAME));
  1210.         temp
  1211.           = deep_assignment_end(deep_lookup(Fetch_Env(),
  1212.                         cell[VARIABLE_SYMBOL],
  1213.                         cell),
  1214.                     cell,
  1215.                     value,
  1216.                     false);
  1217.       external_assignment_return:
  1218.         Import_Val();
  1219.         if (temp != PRIM_DONE)
  1220.           break;
  1221.         Set_Time_Zone(Zone_Working);
  1222.         End_Subproblem();
  1223.         goto Pop_Return;
  1224.  
  1225.       case TRAP_COMPILER_CACHED:
  1226.         {
  1227.           SCHEME_OBJECT extension, references;
  1228.  
  1229.           extension = FAST_MEMORY_REF (Val, TRAP_EXTRA);
  1230.           references
  1231.         = FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES);
  1232.  
  1233.           if ((FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR))
  1234.           != SHARP_F)
  1235.         {
  1236.  
  1237.           /* There are uuo links.
  1238.              wimp out and let deep_assignment_end handle it.
  1239.              */
  1240.  
  1241.           remove_lock(set_serializer);
  1242.           temp = deep_assignment_end(cell,
  1243.                          fake_variable_object,
  1244.                          value,
  1245.                          false);
  1246.           goto external_assignment_return;
  1247.         }
  1248.           cell = MEMORY_LOC (extension, TRAP_EXTENSION_CELL);
  1249.           update_lock(set_serializer, cell);
  1250.           goto assignment_end_after_lock;
  1251.         }
  1252.  
  1253.       case TRAP_FLUID:
  1254.         remove_lock(set_serializer);
  1255.         cell = lookup_fluid(Val);
  1256.         goto assignment_end_before_lock;
  1257.  
  1258.       case TRAP_UNBOUND:
  1259.         remove_lock(set_serializer);
  1260.         temp = ERR_UNBOUND_VARIABLE;
  1261.         break;
  1262.  
  1263.       case TRAP_UNASSIGNED:
  1264.         Val = bogus_unassigned;
  1265.         goto normal_assignment_done;
  1266.  
  1267.       default:
  1268.         remove_lock(set_serializer);
  1269.         temp = ERR_ILLEGAL_REFERENCE_TRAP;
  1270.         break;
  1271.       }
  1272.  
  1273.     if (value == UNASSIGNED_OBJECT)
  1274.       value = bogus_unassigned;
  1275.  
  1276. #else /* No_In_Line_Lookup */
  1277.  
  1278.     value = Val;
  1279.     Set_Time_Zone(Zone_Lookup);
  1280.     Restore_Env();
  1281.     temp = Lex_Set(Fetch_Env(),
  1282.                MEMORY_REF (Fetch_Expression(), ASSIGN_NAME),
  1283.                value);
  1284.     Import_Val();
  1285.     if (temp == PRIM_DONE)
  1286.       {
  1287.         End_Subproblem();
  1288.         Set_Time_Zone(Zone_Working);
  1289.         break;
  1290.       }
  1291.  
  1292. #endif /* No_In_Line_Lookup */
  1293.  
  1294.     Set_Time_Zone(Zone_Working);
  1295.     Save_Env();
  1296.     if (temp != PRIM_INTERRUPT)
  1297.       {
  1298.         Val = value;
  1299.         Pop_Return_Error(temp);
  1300.       }
  1301.  
  1302.     Prepare_Pop_Return_Interrupt(RC_EXECUTE_ASSIGNMENT_FINISH,
  1303.                      value);
  1304.     Interrupt(PENDING_INTERRUPTS());
  1305.       }
  1306.  
  1307.     case RC_EXECUTE_DEFINITION_FINISH:
  1308.       {
  1309.     SCHEME_OBJECT value;
  1310.         long result;
  1311.  
  1312.     value = Val;
  1313.         Restore_Env();
  1314.     Export_Registers();
  1315.         result = Local_Set(Fetch_Env(),
  1316.                FAST_MEMORY_REF (Fetch_Expression(), DEFINE_NAME),
  1317.                Val);
  1318.         Import_Registers();
  1319.         if (result == PRIM_DONE)
  1320.       {
  1321.         End_Subproblem();
  1322.         break;
  1323.       }
  1324.     Save_Env();
  1325.     if (result == PRIM_INTERRUPT)
  1326.       {
  1327.         Prepare_Pop_Return_Interrupt(RC_EXECUTE_DEFINITION_FINISH,
  1328.                      value);
  1329.         Interrupt(PENDING_INTERRUPTS());
  1330.       }
  1331.     Val = value;
  1332.         Pop_Return_Error(result);
  1333.       }
  1334.  
  1335.     case RC_EXECUTE_IN_PACKAGE_CONTINUE:
  1336.       Pop_Return_Val_Check();
  1337.       if (ENVIRONMENT_P (Val))
  1338.     {
  1339.       End_Subproblem();
  1340.       Store_Env(Val);
  1341.       Reduces_To_Nth(IN_PACKAGE_EXPRESSION);
  1342.     }
  1343.       Pop_Return_Error(ERR_BAD_FRAME);
  1344.  
  1345. #ifdef COMPILE_FUTURES
  1346.     case RC_FINISH_GLOBAL_INT:
  1347.       Export_Registers();
  1348.       Val = Global_Int_Part_2(Fetch_Expression(), Val);
  1349.       Import_Registers_Except_Val();
  1350.       break;
  1351. #endif
  1352.  
  1353.     case RC_HALT:
  1354.       Export_Registers();
  1355.       Microcode_Termination (TERM_TERM_HANDLER);
  1356.  
  1357.     case RC_HARDWARE_TRAP:
  1358.       {
  1359.     /* This just reinvokes the handler */
  1360.     SCHEME_OBJECT info = (STACK_REF (0));
  1361.     SCHEME_OBJECT handler = SHARP_F;
  1362.     Save_Cont ();
  1363.     if (Valid_Fixed_Obj_Vector ())
  1364.       handler = (Get_Fixed_Obj_Slot (Trap_Handler));
  1365.     if (handler == SHARP_F)
  1366.       {
  1367.         outf_fatal ("There is no trap handler for recovery!\n");
  1368.         termination_trap ();
  1369.         /*NOTREACHED*/
  1370.       }
  1371.     Will_Push (STACK_ENV_EXTRA_SLOTS + 2);
  1372.     STACK_PUSH (info);
  1373.     STACK_PUSH (handler);
  1374.     STACK_PUSH (STACK_FRAME_HEADER + 1);
  1375.     Pushed ();
  1376.       }
  1377.       goto Internal_Apply;
  1378.  
  1379.     /* Internal_Apply, the core of the application mechanism.
  1380.  
  1381.        Branch here to perform a function application.
  1382.  
  1383.        At this point the top of the stack contains an application frame
  1384.        which consists of the following elements (see sdata.h):
  1385.        - A header specifying the frame length.
  1386.        - A procedure.
  1387.        - The actual (evaluated) arguments.
  1388.  
  1389.        No registers (except the stack pointer) are meaning full at this point.
  1390.        Before interrupts or errors are processed, some registers are cleared
  1391.        to avoid holding onto garbage if a garbage collection occurs.
  1392.        */
  1393.  
  1394. #define Prepare_Apply_Interrupt()                    \
  1395.       {                                    \
  1396.     Store_Expression (SHARP_F);                    \
  1397.     Prepare_Pop_Return_Interrupt                    \
  1398.       (RC_INTERNAL_APPLY_VAL, (STACK_REF (STACK_ENV_FUNCTION)));    \
  1399.       }
  1400.  
  1401. #define Apply_Error(N)                            \
  1402.       {                                    \
  1403.     Store_Expression (SHARP_F);                    \
  1404.     Store_Return (RC_INTERNAL_APPLY_VAL);                \
  1405.     Val = (STACK_REF (STACK_ENV_FUNCTION));                \
  1406.     Pop_Return_Error (N);                        \
  1407.       }
  1408.  
  1409.     case RC_INTERNAL_APPLY_VAL:
  1410.     Internal_Apply_Val:
  1411.  
  1412.     STACK_REF (STACK_ENV_FUNCTION) = Val;
  1413.  
  1414.     case RC_INTERNAL_APPLY:
  1415.     Internal_Apply:
  1416.  
  1417.     if (Microcode_Does_Stepping &&
  1418.     Trapping &&
  1419.     (! WITHIN_CRITICAL_SECTION_P()) &&
  1420.     ((Fetch_Apply_Trapper ()) != SHARP_F))
  1421.       {
  1422.     long Count;
  1423.  
  1424.     Count = (OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER)));
  1425.         (* (STACK_LOC (0))) = (Fetch_Apply_Trapper ());
  1426.         STACK_PUSH (STACK_FRAME_HEADER + Count);
  1427.         Stop_Trapping ();
  1428.       }
  1429.  
  1430.     Apply_Non_Trapping:
  1431.  
  1432.     if ((PENDING_INTERRUPTS()) != 0)
  1433.       {
  1434.     long Interrupts;
  1435.  
  1436.     Interrupts = (PENDING_INTERRUPTS());
  1437.     Prepare_Apply_Interrupt ();
  1438.     Interrupt(Interrupts);
  1439.       }
  1440.  
  1441.     Perform_Application:
  1442.  
  1443.     Apply_Ucode_Hook();
  1444.  
  1445.     {
  1446.       fast SCHEME_OBJECT Function, orig_proc;
  1447.  
  1448.       Apply_Future_Check (Function, (STACK_REF (STACK_ENV_FUNCTION)));
  1449.       orig_proc = Function;
  1450.  
  1451.     apply_dispatch:
  1452.       switch (OBJECT_TYPE (Function))
  1453.         {
  1454.     case TC_ENTITY:
  1455.       {
  1456.         fast long nargs, nactuals;
  1457.         SCHEME_OBJECT data;
  1458.  
  1459.         /* Will_Pushed ommited since frame must be contiguous.
  1460.            combination code must ensure one more slot.
  1461.            */
  1462.  
  1463.         /* This code assumes that adding 1 to nactuals takes care
  1464.            of everything, including type code, etc.
  1465.            */
  1466.  
  1467.         nargs = (STACK_POP ());
  1468.         nactuals = (OBJECT_DATUM (nargs));
  1469.         data = (MEMORY_REF (Function, ENTITY_DATA));
  1470.         if ((VECTOR_P (data))
  1471.         && (nactuals < ((long) (VECTOR_LENGTH (data))))
  1472.         && ((VECTOR_REF (data, nactuals)) != SHARP_F)
  1473.         && ((VECTOR_REF (data, 0))
  1474.             == (Get_Fixed_Obj_Slot (ARITY_DISPATCHER_TAG))))
  1475.           {
  1476.         SCHEME_OBJECT nproc = (VECTOR_REF (data, nactuals));
  1477.  
  1478.         if ((Function == orig_proc) && (nproc != Function))
  1479.           {
  1480.             Function = nproc;
  1481.             STACK_PUSH (nargs);
  1482.             STACK_REF (STACK_ENV_FUNCTION) = nproc;
  1483.             goto apply_dispatch;
  1484.           }
  1485.         else
  1486.           {
  1487.             Function = orig_proc;
  1488.             STACK_REF (STACK_ENV_FUNCTION - 1) = orig_proc;
  1489.           }
  1490.           }
  1491.         
  1492.         STACK_PUSH (FAST_MEMORY_REF (Function, ENTITY_OPERATOR));
  1493.         STACK_PUSH (nargs + 1);
  1494.         /* This must be done to prevent an infinite push loop by
  1495.            an entity whose handler is the entity itself or some
  1496.            other such loop.  Of course, it will die if stack overflow
  1497.            interrupts are disabled.
  1498.            */
  1499.         Stack_Check (Stack_Pointer);
  1500.         goto Internal_Apply;
  1501.       }
  1502.  
  1503.     case TC_RECORD:
  1504.       {
  1505.         SCHEME_OBJECT record_type = (VECTOR_REF (Function, 0));
  1506.         if ((RECORD_P (record_type))
  1507.         && ((OBJECT_TYPE (FAST_MEMORY_REF (record_type, 0)))
  1508.             == TC_CONSTANT)
  1509.         && ((VECTOR_LENGTH (record_type)) >= 2)
  1510.         && ((VECTOR_REF (record_type, 1)) != SHARP_F)
  1511.         && ((VECTOR_REF (record_type, 1)) != Function))
  1512.           {
  1513.         SCHEME_OBJECT nargs_object = (STACK_POP ());
  1514.         STACK_PUSH (VECTOR_REF (record_type, 1));
  1515.         STACK_PUSH
  1516.           (MAKE_OBJECT ((OBJECT_TYPE (nargs_object)),
  1517.                 ((OBJECT_DATUM (nargs_object)) + 1)));
  1518.         Stack_Check (Stack_Pointer);
  1519.         goto Internal_Apply;
  1520.           }
  1521.         else
  1522.           goto internal_apply_inapplicable;
  1523.       }
  1524.  
  1525.     case TC_PROCEDURE:
  1526.       {
  1527.         fast long nargs;
  1528.  
  1529.             nargs = OBJECT_DATUM (STACK_POP ());
  1530.         Function = FAST_MEMORY_REF (Function, PROCEDURE_LAMBDA_EXPR);
  1531.  
  1532.         {
  1533.           fast SCHEME_OBJECT formals;
  1534.  
  1535.           Apply_Future_Check(formals,
  1536.                  FAST_MEMORY_REF (Function, LAMBDA_FORMALS));
  1537.  
  1538.           if ((nargs != ((long) (VECTOR_LENGTH (formals))))
  1539.           && ((OBJECT_TYPE (Function) != TC_LEXPR)
  1540.               || (nargs < ((long) (VECTOR_LENGTH (formals))))))
  1541.         {
  1542.           STACK_PUSH (STACK_FRAME_HEADER + nargs - 1);
  1543.           Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
  1544.         }
  1545.         }
  1546.  
  1547.         if (0 && Eval_Debug)
  1548.           {
  1549.         Print_Expression(LONG_TO_UNSIGNED_FIXNUM(nargs),
  1550.                  "APPLY: Number of arguments");
  1551.           }
  1552.  
  1553.             if (GC_Check(nargs + 1))
  1554.           {
  1555.         STACK_PUSH (STACK_FRAME_HEADER + nargs - 1);
  1556.         Prepare_Apply_Interrupt ();
  1557.         Immediate_GC(nargs + 1);
  1558.           }
  1559.  
  1560.         {
  1561.           fast SCHEME_OBJECT *scan;
  1562.           fast SCHEME_OBJECT temp;
  1563.  
  1564.           scan = Free;
  1565.           temp = (MAKE_POINTER_OBJECT (TC_ENVIRONMENT, scan));
  1566.           *scan++ = MAKE_OBJECT (TC_MANIFEST_VECTOR, nargs);
  1567.           while(--nargs >= 0)
  1568.         *scan++ = (STACK_POP ());
  1569.           Free = scan;
  1570.           Store_Env(temp);
  1571.           Reduces_To(FAST_MEMORY_REF (Function, LAMBDA_SCODE));
  1572.         }
  1573.           }
  1574.  
  1575.     case TC_CONTROL_POINT:
  1576.       {
  1577.             if (OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER)) !=
  1578.                 STACK_ENV_FIRST_ARG)
  1579.           {
  1580.         Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
  1581.           }
  1582.             Val = (STACK_REF (STACK_ENV_FIRST_ARG));
  1583.             Our_Throw(false, Function);
  1584.         Apply_Stacklet_Backout();
  1585.         Our_Throw_Part_2();
  1586.             goto Pop_Return;
  1587.       }
  1588.  
  1589.     /*
  1590.       After checking the number of arguments, remove the
  1591.       frame header since primitives do not expect it.
  1592.  
  1593.       NOTE: This code must match the application code which
  1594.       follows Primitive_Internal_Apply.
  1595.       */
  1596.  
  1597.     case TC_PRIMITIVE:
  1598.           {
  1599.         fast long nargs;
  1600.  
  1601.         if (!IMPLEMENTED_PRIMITIVE_P(Function))
  1602.           {
  1603.         Apply_Error(ERR_UNIMPLEMENTED_PRIMITIVE);
  1604.           }
  1605.  
  1606.         /* Note that the first test below will fail for lexpr
  1607.            primitives. */
  1608.  
  1609.         nargs = ((OBJECT_DATUM (STACK_REF(STACK_ENV_HEADER))) -
  1610.              (STACK_ENV_FIRST_ARG - 1));
  1611.             if (nargs != PRIMITIVE_ARITY(Function))
  1612.           {
  1613.         if (PRIMITIVE_ARITY(Function) != LEXPR_PRIMITIVE_ARITY)
  1614.           {
  1615.             Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
  1616.           }
  1617.         Regs[REGBLOCK_LEXPR_ACTUALS] = ((SCHEME_OBJECT) nargs);
  1618.           }
  1619.  
  1620.             Stack_Pointer = (STACK_LOC (STACK_ENV_FIRST_ARG));
  1621.             Store_Expression (Function);
  1622.         EXPORT_REGS_BEFORE_PRIMITIVE ();
  1623.         PRIMITIVE_APPLY (Val, Function);
  1624.         IMPORT_REGS_AFTER_PRIMITIVE ();
  1625.         POP_PRIMITIVE_FRAME (nargs);
  1626.         if (Must_Report_References())
  1627.           {
  1628.         Store_Expression(Val);
  1629.         Store_Return(RC_RESTORE_VALUE);
  1630.         Save_Cont();
  1631.         Call_Future_Logging();
  1632.           }
  1633.         goto Pop_Return;
  1634.       }
  1635.  
  1636.     case TC_EXTENDED_PROCEDURE:
  1637.           {
  1638.         SCHEME_OBJECT lambda, temp;
  1639.             long nargs, nparams, formals, params, auxes,
  1640.           rest_flag, size;
  1641.  
  1642.         fast long i;
  1643.         fast SCHEME_OBJECT *scan;
  1644.  
  1645.             nargs = OBJECT_DATUM (STACK_POP ()) - STACK_FRAME_HEADER;
  1646.  
  1647.         if (0 && Eval_Debug)
  1648.           {
  1649.         Print_Expression
  1650.           (LONG_TO_UNSIGNED_FIXNUM (nargs+STACK_FRAME_HEADER),
  1651.            "APPLY: Number of arguments");
  1652.           }
  1653.  
  1654.             lambda = FAST_MEMORY_REF (Function, PROCEDURE_LAMBDA_EXPR);
  1655.         Apply_Future_Check(Function,
  1656.                    FAST_MEMORY_REF (lambda, ELAMBDA_NAMES));
  1657.             nparams = VECTOR_LENGTH (Function) - 1;
  1658.  
  1659.         Apply_Future_Check(Function, Get_Count_Elambda(lambda));
  1660.             formals = Elambda_Formals_Count(Function);
  1661.             params = Elambda_Opts_Count(Function) + formals;
  1662.             rest_flag = Elambda_Rest_Flag(Function);
  1663.             auxes = nparams - (params + rest_flag);
  1664.  
  1665.             if ((nargs < formals) || (!rest_flag && (nargs > params)))
  1666.           {
  1667.         STACK_PUSH (STACK_FRAME_HEADER + nargs);
  1668.         Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
  1669.           }
  1670.  
  1671.         /* size includes the procedure slot, but not the header. */
  1672.             size = params + rest_flag + auxes + 1;
  1673.             if (GC_Check(size + 1 + ((nargs > params) ?
  1674.                      (2 * (nargs - params)) :
  1675.                      0)))
  1676.           {
  1677.         STACK_PUSH (STACK_FRAME_HEADER + nargs);
  1678.         Prepare_Apply_Interrupt ();
  1679.         Immediate_GC(size + 1 + ((nargs > params) ?
  1680.                      (2 * (nargs - params)) :
  1681.                      0));
  1682.           }
  1683.  
  1684.         scan = Free;
  1685.         temp = (MAKE_POINTER_OBJECT (TC_ENVIRONMENT, scan));
  1686.         *scan++ = MAKE_OBJECT (TC_MANIFEST_VECTOR, size);
  1687.  
  1688.         if (nargs <= params)
  1689.           {
  1690.         for (i = (nargs + 1); --i >= 0; )
  1691.           *scan++ = (STACK_POP ());
  1692.         for (i = (params - nargs); --i >= 0; )
  1693.           *scan++ = UNASSIGNED_OBJECT;
  1694.         if (rest_flag)
  1695.           *scan++ = EMPTY_LIST;
  1696.         for (i = auxes; --i >= 0; )
  1697.           *scan++ = UNASSIGNED_OBJECT;
  1698.           }
  1699.         else
  1700.           {
  1701.         /* rest_flag must be true. */
  1702.         SCHEME_OBJECT list;
  1703.  
  1704.         list = MAKE_POINTER_OBJECT (TC_LIST, (scan + size));
  1705.         for (i = (params + 1); --i >= 0; )
  1706.           *scan++ = (STACK_POP ());
  1707.         *scan++ = list;
  1708.         for (i = auxes; --i >= 0; )
  1709.           *scan++ = UNASSIGNED_OBJECT;
  1710.         /* Now scan == OBJECT_ADDRESS (list) */
  1711.         for (i = (nargs - params); --i >= 0; )
  1712.           {
  1713.             *scan++ = (STACK_POP ());
  1714.             *scan = MAKE_POINTER_OBJECT (TC_LIST, (scan + 1));
  1715.             scan += 1;
  1716.           }
  1717.         scan[-1] = EMPTY_LIST;
  1718.           }
  1719.  
  1720.         Free = scan;
  1721.             Store_Env (temp);
  1722.             Reduces_To(Get_Body_Elambda(lambda));
  1723.           }
  1724.  
  1725.     case TC_COMPILED_ENTRY:
  1726.       {
  1727.         apply_compiled_setup
  1728.           (STACK_ENV_EXTRA_SLOTS +
  1729.            (OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER))));
  1730.         Export_Registers ();
  1731.         Which_Way = apply_compiled_procedure();
  1732.  
  1733.       return_from_compiled_code:
  1734.         Import_Registers ();
  1735.             switch (Which_Way)
  1736.           {
  1737.           case PRIM_DONE:
  1738.         {
  1739.           compiled_code_done ();
  1740.           goto Pop_Return;
  1741.         }
  1742.  
  1743.           case PRIM_APPLY:
  1744.         {
  1745.           compiler_apply_procedure
  1746.             (STACK_ENV_EXTRA_SLOTS +
  1747.              OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER)));
  1748.           goto Internal_Apply;
  1749.         }
  1750.  
  1751.           case PRIM_INTERRUPT:
  1752.         {
  1753.           compiled_error_backout ();
  1754.           Save_Cont ();
  1755.           Interrupt (PENDING_INTERRUPTS ());
  1756.         }
  1757.  
  1758.           case PRIM_APPLY_INTERRUPT:
  1759.         {
  1760.           apply_compiled_backout ();
  1761.           Prepare_Apply_Interrupt ();
  1762.           Interrupt (PENDING_INTERRUPTS ());
  1763.         }
  1764.  
  1765.           case ERR_INAPPLICABLE_OBJECT:
  1766.         /* This error code means that apply_compiled_procedure
  1767.            was called on an object which is not a compiled procedure,
  1768.            or it was called in a system without compiler support.
  1769.  
  1770.            Fall through...
  1771.            */
  1772.  
  1773.           case ERR_WRONG_NUMBER_OF_ARGUMENTS:
  1774.         {
  1775.           apply_compiled_backout ();
  1776.           Apply_Error (Which_Way);
  1777.         }
  1778.  
  1779.           case ERR_EXECUTE_MANIFEST_VECTOR:
  1780.         {
  1781.           /* This error code means that enter_compiled_expression
  1782.              was called in a system without compiler support.
  1783.              This is a kludge!
  1784.              */
  1785.  
  1786.           execute_compiled_backout ();
  1787.           Val
  1788.             = (OBJECT_NEW_TYPE
  1789.                (TC_COMPILED_ENTRY, (Fetch_Expression ())));
  1790.           Pop_Return_Error (Which_Way);
  1791.         }
  1792.  
  1793.           case ERR_INAPPLICABLE_CONTINUATION:
  1794.         {
  1795.           /* This error code means that return_to_compiled_code
  1796.              saw a non-continuation on the stack, or was called
  1797.              in a system without compiler support.
  1798.              */
  1799.  
  1800.           Store_Expression (SHARP_F);
  1801.           Store_Return (RC_REENTER_COMPILED_CODE);
  1802.           Pop_Return_Error (Which_Way);
  1803.         }
  1804.  
  1805.           default:
  1806.         compiled_error_backout ();
  1807.         Pop_Return_Error (Which_Way);
  1808.           }
  1809.           }
  1810.  
  1811.     default:
  1812.     internal_apply_inapplicable:
  1813.     Apply_Error (ERR_INAPPLICABLE_OBJECT);
  1814.         }       /* End of switch in RC_INTERNAL_APPLY */
  1815.     }         /* End of RC_INTERNAL_APPLY case */
  1816.  
  1817.     case RC_MOVE_TO_ADJACENT_POINT:
  1818.       /* Expression contains the space in which we are moving */
  1819.       {
  1820.     long From_Count;
  1821.     SCHEME_OBJECT Thunk, New_Location;
  1822.  
  1823.     From_Count =
  1824.       (UNSIGNED_FIXNUM_TO_LONG (STACK_REF (TRANSLATE_FROM_DISTANCE)));
  1825.     if (From_Count != 0)
  1826.       {
  1827.         SCHEME_OBJECT Current = STACK_REF(TRANSLATE_FROM_POINT);
  1828.         STACK_REF(TRANSLATE_FROM_DISTANCE) =
  1829.           (LONG_TO_UNSIGNED_FIXNUM (From_Count - 1));
  1830.         Thunk = FAST_MEMORY_REF (Current, STATE_POINT_AFTER_THUNK);
  1831.         New_Location = FAST_MEMORY_REF (Current, STATE_POINT_NEARER_POINT);
  1832.         STACK_REF(TRANSLATE_FROM_POINT) = New_Location;
  1833.         if ((From_Count == 1)
  1834.         && ((STACK_REF (TRANSLATE_TO_DISTANCE))
  1835.             == (LONG_TO_UNSIGNED_FIXNUM (0))))
  1836.           Stack_Pointer = (STACK_LOC (4));
  1837.         else Save_Cont();
  1838.       }
  1839.     else
  1840.       {
  1841.         long To_Count;
  1842.         fast SCHEME_OBJECT To_Location;
  1843.         fast long i;
  1844.  
  1845.         To_Count
  1846.           = ((UNSIGNED_FIXNUM_TO_LONG (STACK_REF (TRANSLATE_TO_DISTANCE)))
  1847.          -  1);
  1848.         To_Location = STACK_REF(TRANSLATE_TO_POINT);
  1849.         for (i = 0; i < To_Count; i++)
  1850.           {
  1851.         To_Location =
  1852.           (FAST_MEMORY_REF (To_Location, STATE_POINT_NEARER_POINT));
  1853.           }
  1854.         Thunk = FAST_MEMORY_REF (To_Location, STATE_POINT_BEFORE_THUNK);
  1855.         New_Location = To_Location;
  1856.         (STACK_REF (TRANSLATE_TO_DISTANCE))
  1857.           = (LONG_TO_UNSIGNED_FIXNUM (To_Count));
  1858.         if (To_Count == 0)
  1859.           {
  1860.         Stack_Pointer = (STACK_LOC (4));
  1861.           }
  1862.         else
  1863.           {
  1864.         Save_Cont ();
  1865.           }
  1866.       }
  1867.     if ((Fetch_Expression ()) != SHARP_F)
  1868.       {
  1869.         MEMORY_SET
  1870.           ((Fetch_Expression ()), STATE_SPACE_NEAREST_POINT, New_Location);
  1871.       }
  1872.     else
  1873.       {
  1874.         Current_State_Point = New_Location;
  1875.       }
  1876.     Will_Push(2);
  1877.     STACK_PUSH (Thunk);
  1878.     STACK_PUSH (STACK_FRAME_HEADER);
  1879.     Pushed();
  1880.     goto Internal_Apply;
  1881.       }
  1882.  
  1883.     case RC_INVOKE_STACK_THREAD:
  1884.       /* Used for WITH_THREADED_STACK primitive */
  1885.       Will_Push(3);
  1886.       STACK_PUSH (Val);        /* Value calculated by thunk */
  1887.       STACK_PUSH (Fetch_Expression());
  1888.       STACK_PUSH (STACK_FRAME_HEADER+1);
  1889.       Pushed();
  1890.       goto Internal_Apply;
  1891.  
  1892.     case RC_JOIN_STACKLETS:
  1893.       Our_Throw(true, Fetch_Expression());
  1894.       Join_Stacklet_Backout();
  1895.       Our_Throw_Part_2();
  1896.       break;
  1897.  
  1898.     case RC_NORMAL_GC_DONE:
  1899.       Val = (Fetch_Expression ());
  1900.       if (GC_Space_Needed < 0)
  1901.     {
  1902.       /* Paranoia */
  1903.  
  1904.       GC_Space_Needed = 0;
  1905.     }
  1906.       if (GC_Check (GC_Space_Needed))
  1907.     termination_gc_out_of_space ();
  1908.       GC_Space_Needed = 0;
  1909.       EXIT_CRITICAL_SECTION ({ Save_Cont(); Export_Registers(); });
  1910.       End_GC_Hook ();
  1911.       break;
  1912.  
  1913.     case RC_PCOMB1_APPLY:
  1914.       End_Subproblem();
  1915.       STACK_PUSH (Val);        /* Argument value */
  1916.       Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
  1917.       Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), PCOMB1_FN_SLOT));
  1918.  
  1919.     Primitive_Internal_Apply:
  1920.       if (Microcode_Does_Stepping &&
  1921.       Trapping &&
  1922.       (! WITHIN_CRITICAL_SECTION_P()) &&
  1923.       ((Fetch_Apply_Trapper ()) != SHARP_F))
  1924.     {
  1925.       /* Does this work in the stacklet case?
  1926.          We may have a non-contiguous frame. -- Jinx
  1927.          */
  1928.       Will_Push(3);
  1929.       STACK_PUSH (Fetch_Expression());
  1930.       STACK_PUSH (Fetch_Apply_Trapper());
  1931.       STACK_PUSH (STACK_FRAME_HEADER + 1 +
  1932.               PRIMITIVE_N_PARAMETERS(Fetch_Expression()));
  1933.       Pushed();
  1934.       Stop_Trapping();
  1935.       goto Apply_Non_Trapping;
  1936.     }
  1937.  
  1938.       /* NOTE: This code must match the code in the TC_PRIMITIVE
  1939.      case of Internal_Apply.
  1940.      This code is simpler because:
  1941.      1) The arity was checked at syntax time.
  1942.      2) We don't have to deal with "lexpr" primitives.
  1943.      3) We don't need to worry about unimplemented primitives because
  1944.      unimplemented primitives will cause an error at invocation.
  1945.      */
  1946.  
  1947.       {
  1948.     fast SCHEME_OBJECT primitive = (Fetch_Expression ());
  1949.     EXPORT_REGS_BEFORE_PRIMITIVE ();
  1950.     PRIMITIVE_APPLY (Val, primitive);
  1951.     IMPORT_REGS_AFTER_PRIMITIVE ();
  1952.     POP_PRIMITIVE_FRAME (PRIMITIVE_ARITY (primitive));
  1953.     if (Must_Report_References ())
  1954.       {
  1955.         Store_Expression (Val);
  1956.         Store_Return (RC_RESTORE_VALUE);
  1957.         Save_Cont ();
  1958.         Call_Future_Logging ();
  1959.       }
  1960.     break;
  1961.       }
  1962.  
  1963.     case RC_PCOMB2_APPLY:
  1964.       End_Subproblem();
  1965.       STACK_PUSH (Val);        /* Value of arg. 1 */
  1966.       Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
  1967.       Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), PCOMB2_FN_SLOT));
  1968.       goto Primitive_Internal_Apply;
  1969.  
  1970.     case RC_PCOMB2_DO_1:
  1971.       Restore_Env();
  1972.       STACK_PUSH (Val);        /* Save value of arg. 2 */
  1973.       Do_Another_Then(RC_PCOMB2_APPLY, PCOMB2_ARG_1_SLOT);
  1974.  
  1975.     case RC_PCOMB3_APPLY:
  1976.       End_Subproblem();
  1977.       STACK_PUSH (Val);        /* Save value of arg. 1 */
  1978.       Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
  1979.       Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), PCOMB3_FN_SLOT));
  1980.       goto Primitive_Internal_Apply;
  1981.  
  1982.     case RC_PCOMB3_DO_1:
  1983.       {
  1984.     SCHEME_OBJECT Temp;
  1985.  
  1986.     Temp = (STACK_POP ());        /* Value of arg. 3 */
  1987.     Restore_Env();
  1988.     STACK_PUSH (Temp);        /* Save arg. 3 again */
  1989.     STACK_PUSH (Val);        /* Save arg. 2 */
  1990.     Do_Another_Then(RC_PCOMB3_APPLY, PCOMB3_ARG_1_SLOT);
  1991.       }
  1992.  
  1993.     case RC_PCOMB3_DO_2:
  1994.       Restore_Then_Save_Env();
  1995.       STACK_PUSH (Val);        /* Save value of arg. 3 */
  1996.       Do_Another_Then(RC_PCOMB3_DO_1, PCOMB3_ARG_2_SLOT);
  1997.  
  1998.     case RC_POP_RETURN_ERROR:
  1999.     case RC_RESTORE_VALUE:
  2000.       Val = Fetch_Expression();
  2001.       break;
  2002.  
  2003.     case RC_PRIMITIVE_CONTINUE:
  2004.       Export_Registers ();
  2005.       Val = (continue_primitive ());
  2006.       Import_Registers ();
  2007.       break;
  2008.  
  2009.     case RC_REPEAT_DISPATCH:
  2010.       Which_Way = (FIXNUM_TO_LONG (Fetch_Expression ()));
  2011.       Restore_Env();
  2012.       Val = (STACK_POP ());
  2013.       Restore_Cont();
  2014.       goto Repeat_Dispatch;
  2015.  
  2016.       /* The following two return codes are both used to restore
  2017.      a saved history object.  The difference is that the first
  2018.      does not copy the history object while the second does.
  2019.      In both cases, the Expression register contains the history
  2020.      object and the next item to be popped off the stack contains
  2021.      the offset back to the previous restore history return code.
  2022.  
  2023.      ASSUMPTION: History objects are never created using futures.
  2024.      */
  2025.  
  2026.     case RC_RESTORE_DONT_COPY_HISTORY:
  2027.       {
  2028.     SCHEME_OBJECT Stacklet;
  2029.  
  2030.     Prev_Restore_History_Offset = OBJECT_DATUM (STACK_POP ());
  2031.     Stacklet = (STACK_POP ());
  2032.     History = OBJECT_ADDRESS (Fetch_Expression());
  2033.     if (Prev_Restore_History_Offset == 0)
  2034.       {
  2035.         Prev_Restore_History_Stacklet = NULL;
  2036.       }
  2037.     else if (Stacklet == SHARP_F)
  2038.       {
  2039.         Prev_Restore_History_Stacklet = NULL;
  2040.       }
  2041.     else
  2042.       {
  2043.         Prev_Restore_History_Stacklet = OBJECT_ADDRESS (Stacklet);
  2044.       }
  2045.     break;
  2046.       }
  2047.  
  2048.     case RC_RESTORE_HISTORY:
  2049.       {
  2050.     SCHEME_OBJECT Stacklet;
  2051.  
  2052.     Export_Registers();
  2053.     if (! Restore_History(Fetch_Expression()))
  2054.       {
  2055.         Import_Registers();
  2056.         Save_Cont();
  2057.         Will_Push(CONTINUATION_SIZE);
  2058.         Store_Expression(Val);
  2059.         Store_Return(RC_RESTORE_VALUE);
  2060.         Save_Cont();
  2061.         Pushed();
  2062.         Immediate_GC((Free > MemTop) ? 0 : ((MemTop-Free)+1));
  2063.       }
  2064.     Import_Registers();
  2065.     Prev_Restore_History_Offset = OBJECT_DATUM (STACK_POP ());
  2066.     Stacklet = (STACK_POP ());
  2067.     if (Prev_Restore_History_Offset == 0)
  2068.       Prev_Restore_History_Stacklet = NULL;
  2069.     else
  2070.       {
  2071.         if (Stacklet == SHARP_F)
  2072.           {
  2073.         Prev_Restore_History_Stacklet = NULL;
  2074.         Get_End_Of_Stacklet()[-Prev_Restore_History_Offset] =
  2075.           MAKE_OBJECT (TC_RETURN_CODE, RC_RESTORE_HISTORY);
  2076.           }
  2077.         else
  2078.           {
  2079.         Prev_Restore_History_Stacklet = OBJECT_ADDRESS (Stacklet);
  2080.         Prev_Restore_History_Stacklet[-Prev_Restore_History_Offset] =
  2081.           MAKE_OBJECT (TC_RETURN_CODE, RC_RESTORE_HISTORY);
  2082.           }
  2083.       }
  2084.     break;
  2085.       }
  2086.  
  2087.     case RC_RESTORE_FLUIDS:
  2088.       Fluid_Bindings = Fetch_Expression();
  2089.       break;
  2090.  
  2091.     case RC_RESTORE_INT_MASK:
  2092.       SET_INTERRUPT_MASK (UNSIGNED_FIXNUM_TO_LONG (Fetch_Expression()));
  2093.       if (GC_Check (0))
  2094.         Request_GC (0);
  2095.       if ((PENDING_INTERRUPTS ()) != 0)
  2096.     {
  2097.       Store_Return (RC_RESTORE_VALUE);
  2098.       Store_Expression (Val);
  2099.       Save_Cont ();
  2100.       Interrupt (PENDING_INTERRUPTS ());
  2101.     }
  2102.       break;
  2103.  
  2104.     case RC_STACK_MARKER:
  2105.       /* Frame consists of the return code followed by two objects.
  2106.      The first object has already been popped into the Expression
  2107.      register, so just pop the second argument. */
  2108.       Stack_Pointer = (STACK_LOCATIVE_OFFSET (Stack_Pointer, 1));
  2109.       break;
  2110.  
  2111.     case RC_RESTORE_TO_STATE_POINT:
  2112.       {
  2113.     SCHEME_OBJECT Where_To_Go = Fetch_Expression();
  2114.     Will_Push(CONTINUATION_SIZE);
  2115.     /* Restore the contents of Val after moving to point */
  2116.     Store_Expression(Val);
  2117.     Store_Return(RC_RESTORE_VALUE);
  2118.     Save_Cont();
  2119.     Pushed();
  2120.     Export_Registers();
  2121.     Translate_To_Point(Where_To_Go);
  2122.     break;            /* We never get here.... */
  2123.       }
  2124.  
  2125.     case RC_SEQ_2_DO_2:
  2126.       End_Subproblem();
  2127.       Restore_Env();
  2128.       Reduces_To_Nth(SEQUENCE_2);
  2129.  
  2130.     case RC_SEQ_3_DO_2:
  2131.       Restore_Then_Save_Env();
  2132.       Do_Another_Then(RC_SEQ_3_DO_3, SEQUENCE_2);
  2133.  
  2134.     case RC_SEQ_3_DO_3:
  2135.       End_Subproblem();
  2136.       Restore_Env();
  2137.       Reduces_To_Nth(SEQUENCE_3);
  2138.  
  2139.     case RC_SNAP_NEED_THUNK:
  2140.       /* Don't snap thunk twice; evaluation of the thunk's body might
  2141.      have snapped it already.  */
  2142.       if ((MEMORY_REF ((Fetch_Expression ()), THUNK_SNAPPED)) == SHARP_T)
  2143.     Val = (MEMORY_REF ((Fetch_Expression ()), THUNK_VALUE));
  2144.       else
  2145.     {
  2146.       MEMORY_SET ((Fetch_Expression ()), THUNK_SNAPPED, SHARP_T);
  2147.       MEMORY_SET ((Fetch_Expression ()), THUNK_VALUE, Val);
  2148.     }
  2149.       break;
  2150.  
  2151.     case RC_AFTER_MEMORY_UPDATE:
  2152.     case RC_BAD_INTERRUPT_CONTINUE:
  2153.     case RC_COMPLETE_GC_DONE:
  2154.     case RC_RESTARTABLE_EXIT:
  2155.     case RC_RESTART_EXECUTION:
  2156.     case RC_RESTORE_CONTINUATION:
  2157.     case RC_RESTORE_STEPPER:
  2158.     case RC_POP_FROM_COMPILED_CODE:
  2159.       Pop_Return_Error (ERR_INAPPLICABLE_CONTINUATION);
  2160.  
  2161.       SITE_RETURN_DISPATCH_HOOK()
  2162.  
  2163.     default:
  2164.       Pop_Return_Error (ERR_INAPPLICABLE_CONTINUATION);
  2165.     };
  2166.   goto Pop_Return;
  2167. }
  2168.