|
DataMuseum.dkPresents historical artifacts from the history of: DKUUG/EUUG Conference tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about DKUUG/EUUG Conference tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - downloadIndex: ┃ T i ┃
Length: 49333 (0xc0b5)
Types: TextFile
Names: »interpret.c«
└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
└─ ⟦this⟧ »EUUGD11/gnu-31mar87/scheme/microcode/interpret.c«
/* Hey EMACS, this is -*- C -*- code! */
/****************************************************************
* *
* Copyright (c) 1985 *
* Massachusetts Institute of Technology *
* *
* This material was developed by the Scheme project at the *
* Massachusetts Institute of Technology, Department of *
* Electrical Engineering and Computer Science. Permission to *
* copy this software, to redistribute it, and to use it for any *
* purpose is granted, subject to the following restrictions and *
* understandings. *
* *
* 1. Any copy made of this software must include this copyright *
* notice in full. *
* *
* 2. Users of this software agree to make their best efforts (a)*
* to return to the MIT Scheme project any improvements or *
* extensions that they make, so that these may be included in *
* future releases; and (b) to inform MIT of noteworthy uses of *
* this software. *
* *
* 3. All materials developed as a consequence of the use of *
* this software shall duly acknowledge such use, in accordance *
* with the usual standards of acknowledging credit in academic *
* research. *
* *
* 4. MIT has made no warrantee or representation that the *
* operation of this software will be error-free, and MIT is *
* under no obligation to provide any services, by way of *
* maintenance, update, or otherwise. *
* *
* 5. In conjunction with products arising from the use of this *
* material, there shall be no use of the name of the *
* Massachusetts Institute of Technology nor of any adaptation *
* thereof in any advertising, promotional, or sales literature *
* without prior written consent from MIT in each case. *
* *
****************************************************************/
/* File: INTERPRET.C
*
* This file contains the heart of the Scheme S-Code
* interpreter
*/
#define In_Main_Interpreter true
#include "scheme.h"
#include "zones.h"
\f
/* In order to make the interpreter tail recursive (i.e.
* to avoid calling procedures and thus saving unnecessary
* state information), the main body of the interpreter
* is coded in a continuation passing style.
*
* Basically, this is done by dispatching on the type code
* for an S-Code item. At each dispatch, some processing
* is done which may include setting the return address
* register, saving the current continuation (return address
* and current expression) and jumping to the start of
* the interpreter.
*
* It may be helpful to think of this program as being what
* you would get if you wrote the straightforward Scheme
* interpreter and then converted it into continuation
* passing style as follows. At every point where you would
* call EVAL to handle a sub-form, you put a jump back to
* Do_Expression. Now, if there was code after the call to
* EVAL you first push a "return code" (using Save_Cont) on
* the stack and move the code that used to be after the
* call down into the part of this file after the tag
* Pop_Return.
*
* Notice that because of the callER saves convention used
* here, all of the registers which are of interest have
* been SAVEd on the racks by the time interpretation arrives
* at Do_Expression (the top of EVAL).
*
* For notes on error handling and interrupts, see the file
* UTILS.C. For information about primitives, see PRIM1.C
*
* This file is divided into two parts. The first
* corresponds is called the EVAL dispatch, and is ordered
* alphabetically by the SCode item handled. The second,
* called the return dispatch, begins at Pop_Return and is
* ordered alphabetically by return code name.
*/
\f
#define Interrupt(Masked_Code) \
{ Export_Registers(); \
Setup_Interrupt(Masked_Code); \
Import_Registers(); \
goto Perform_Application; \
}
#define Immediate_GC() \
{ Request_GC(); \
Interrupt(IntCode & IntEnb); \
}
#define Immed_GC_If_Needed(Check_Addr) \
{ if GC_Check(Check_Addr) Immediate_GC(); \
}
#define Eval_Error(Err) \
{ Export_Registers(); \
Do_Micro_Error(Err, false); \
Import_Registers(); \
goto Internal_Apply; \
}
#define Pop_Return_Error(Err) \
{ Export_Registers(); \
Do_Micro_Error(Err, true); \
Import_Registers(); \
goto Internal_Apply; \
}
#define Prepare_Pop_Return_Interrupt(Return_Code, Contents_of_Val) \
Store_Return(Return_Code); \
Val = Contents_of_Val; \
Save_Cont()
\f
#define Reduces_To(Expr) \
{ Store_Expression(Expr); \
New_Reduction(Fetch_Expression(), Fetch_Env()); \
goto Do_Expression; \
}
#define Reduces_To_Nth(N) \
Reduces_To(Fast_Vector_Ref(Fetch_Expression(), (N)))
#define Do_Nth_Then(Return_Code, N) \
{ Store_Return(Return_Code); \
Save_Cont(); \
Store_Expression(Fast_Vector_Ref(Fetch_Expression(), (N))); \
New_Subproblem(Fetch_Expression(), Fetch_Env()); \
goto Do_Expression; \
}
#define Do_Another_Then(Return_Code, N) \
{ Store_Return(Return_Code); \
Save_Cont(); \
Store_Expression(Fast_Vector_Ref(Fetch_Expression(), (N))); \
Reuse_Subproblem(Fetch_Expression(), Fetch_Env()); \
goto Do_Expression; \
}
#define N_Args_Primitive(Function) \
Arg_Count_Table[Get_Integer(Function)]
#define Environment_P(Obj) (Obj == NIL || (Type_Code(Obj) == TC_ENVIRONMENT))
\f
#ifdef COMPILE_HISTORY
#define New_Subproblem(Expr, Env) \
{ fast Pointer *Rib; \
History = Get_Pointer(History[HIST_NEXT_SUBPROBLEM]); \
History[HIST_MARK] |= DANGER_BIT; \
Rib = Get_Pointer(History[HIST_RIB]); \
Rib[RIB_MARK] |= DANGER_BIT; \
Rib[RIB_ENV] = Env; \
Rib[RIB_EXP] = Expr; \
}
#define Reuse_Subproblem(Expr, Env) \
{ fast Pointer *Rib; \
Rib = Get_Pointer(History[HIST_RIB]); \
Rib[RIB_MARK] |= DANGER_BIT; \
Rib[RIB_ENV] = Env; \
Rib[RIB_EXP] = Expr; \
}
#define New_Reduction(Expr, Env) \
{ fast Pointer *Rib; \
Rib = Get_Pointer(Fast_Vector_Ref(History[HIST_RIB], \
RIB_NEXT_REDUCTION)); \
History[HIST_RIB] = Make_Pointer(TC_HUNK3, Rib); \
Rib[RIB_ENV] = Env; \
Rib[RIB_EXP] = Expr; \
Rib[RIB_MARK] &= ~DANGER_BIT; \
}
#define End_Subproblem() \
History[HIST_MARK] &= ~DANGER_BIT; \
History = Get_Pointer(History[HIST_PREV_SUBPROBLEM]);
#else /* COMPILE_HISTORY */
#define New_Subproblem(Expr, Env) { }
#define Reuse_Subproblem(Expr, Env) { }
#define New_Reduction(Expr, Env) { }
#define End_Subproblem() { }
#endif /* COMPILE_HISTORY */
\f
/***********************/
/* Macros for Stepping */
/***********************/
#define Fetch_Trapper(field) \
Vector_Ref(Get_Fixed_Obj_Slot(Stepper_State), (field))
#define Fetch_Eval_Trapper() Fetch_Trapper(HUNK_CXR0)
#define Fetch_Apply_Trapper() Fetch_Trapper(HUNK_CXR1)
#define Fetch_Return_Trapper() Fetch_Trapper(HUNK_CXR2)
\f
/* Macros for handling FUTUREs */
#ifdef COMPILE_FUTURES
/* Arg_Type_Error handles the error returns from primitives which type check
their arguments and restarts them or suspends if the argument is a future. */
#define Arg_Type_Error(Arg_No, Err_No) \
{ fast Pointer *Arg = & (Stack_Pointer[Arg_No-1]); \
if (Type_Code(*Arg) != TC_FUTURE) Pop_Return_Error(Err_No); \
while ((Type_Code(*Arg) == TC_FUTURE) && (Future_Has_Value(*Arg))) \
*Arg = Future_Value(*Arg); \
if (Type_Code(*Arg) != TC_FUTURE) goto Prim_No_Trap_Apply; \
Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \
Save_Cont(); \
Push(*Arg); /* Arg 1: The future itself */ \
Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
Push(STACK_FRAME_HEADER+1); \
Pushed(); \
goto Apply_Non_Trapping; \
}
/* Apply_Future_Check is called at apply time to guarantee that certain
objects (the procedure itself, and its LAMBDA components for user defined
procedures) are not futures
*/
#define Apply_Future_Check(Name, Object) \
{ fast Pointer *Arg = &(Object); \
while (Type_Code(*Arg) == TC_FUTURE) \
{ if (Future_Has_Value(*Arg)) *Arg = Future_Value(*Arg); \
else \
{ \
Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \
Store_Return(RC_INTERNAL_APPLY); \
Val = NIL; \
Save_Cont(); \
Push(*Arg); \
Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
Push(STACK_FRAME_HEADER+1); \
Pushed(); \
goto Internal_Apply; \
} \
} \
Name = *Arg; \
}
/* Future handling macros continue on the next page */
\f
/* Future handling macros, continued */
/* Pop_Return_Val_Check suspends the process if the value calculated by
a recursive call to EVAL is an undetermined future */
#define Pop_Return_Val_Check() \
{ fast Pointer Orig_Val = Val; \
while (Type_Code(Val) == TC_FUTURE) \
{ if (Future_Has_Value(Val)) Val = Future_Value(Val); \
else \
{ \
Will_Push((2*CONTINUATION_SIZE) + (STACK_ENV_EXTRA_SLOTS+2)); \
Save_Cont(); \
Store_Return(RC_RESTORE_VALUE); \
Store_Expression(Orig_Val); \
Save_Cont(); \
Push(Val); \
Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
Push(STACK_FRAME_HEADER+1); \
Pushed(); \
goto Internal_Apply; \
} \
} \
}
#else /* Not compiling FUTURES code */
#define Pop_Return_Val_Check()
#define Apply_Future_Check(Name, Object) Name = (Object)
#define Arg_Type_Error(Arg_No, Err_No) Pop_Return_Error(Err_No)
#endif
\f
/* The EVAL/APPLY ying/yang */
void Interpret(dumped_p)
Boolean dumped_p;
{ int Which_Way;
fast Pointer Reg_Val, Reg_Expression, *Reg_Stack_Pointer;
/* Primitives jump back here for errors, requests to
* evaluate an expression, apply a function, or handle an
* interrupt request. On errors or interrupts they leave
* their arguments on the stack, the primitive itself in
* Expression, and a RESTART_PRIMITIVE continuation in the
* return register. In the other cases, they have removed
* their stack frames entirely.
*/
Which_Way = setjmp(*Back_To_Eval);
Set_Time_Zone(Zone_Working);
Import_Registers();
switch (Which_Way)
{ case PRIM_APPLY: goto Internal_Apply;
case PRIM_NO_TRAP_APPLY: goto Apply_Non_Trapping;
case PRIM_DO_EXPRESSION: Reduces_To(Fetch_Expression());
case PRIM_NO_TRAP_EVAL: New_Reduction(Fetch_Expression(),Fetch_Env());
goto Eval_Non_Trapping;
case 0: if (!dumped_p) break; /* Else fall through */
case PRIM_POP_RETURN: goto Pop_Return;
default: Pop_Return_Error(Which_Way);
case PRIM_TRANSLATE: goto Translate_To_Point;
case PRIM_INTERRUPT:
{ Save_Cont();
Interrupt(IntEnb & IntCode);
}
case ERR_ARG_1_WRONG_TYPE: Arg_Type_Error(1, ERR_ARG_1_WRONG_TYPE);
case ERR_ARG_2_WRONG_TYPE: Arg_Type_Error(2, ERR_ARG_2_WRONG_TYPE);
case ERR_ARG_3_WRONG_TYPE: Arg_Type_Error(3, ERR_ARG_3_WRONG_TYPE);
}
\f
/*****************/
/* Do_Expression */
/*****************/
Do_Expression:
if (Eval_Debug)
{ Print_Expression(Fetch_Expression(), "Eval, expression");
CRLF();
}
/* The expression register has an S-Code item in it which
* should be evaluated and the result left in Val.
*
* A "break" after the code for any operation indicates that
* all processing for this operation has been completed, and
* the next step will be to pop a return code off the stack
* and proceed at Pop_Return. This is sometimes called
* "executing the continuation" since the return code can be
* considered the continuation to be performed after the
* operation.
*
* An operation can terminate with a Reduces_To or
* Reduces_To_Nth macro. This indicates that the value of
* the current S-Code item is the value returned when the
* new expression is evaluated. Therefore no new
* continuation is created and processing continues at
* Do_Expression with the new expression in the expression
* register.
*
* Finally, an operation can terminate with a Do_Nth_Then
* macro. This indicates that another expression must be
* evaluated and them some additional processing will be
* performed before the value of this S-Code item available.
* Thus a new continuation is created and placed on the
* stack (using Save_Cont), the new expression is placed in
* the Expression register, and processing continues at
* Do_Expression.
*/
\f
/* Handling of Eval Trapping.
If we are handling traps and there is an Eval Trap set,
turn off all trapping and then go to Internal_Apply to call the
user supplied eval hook with the expression to be evaluated and the
environment.
*/
if (Microcode_Does_Stepping && Trapping &&
(Fetch_Eval_Trapper() != NIL))
{ Stop_Trapping();
Will_Push(4)
Push(Fetch_Env());
Push(Fetch_Expression());
Push(Fetch_Eval_Trapper());
Push(STACK_FRAME_HEADER+2);
Pushed();
goto Apply_Non_Trapping;
}
\f
Eval_Non_Trapping:
Eval_Ucode_Hook();
switch (Type_Code(Fetch_Expression()))
{ case TC_BIG_FIXNUM: /* The self evaluating items */
case TC_BIG_FLONUM:
case TC_CHARACTER_STRING:
#if (TC_CHARACTER != TC_FIXNUM)
case TC_CHARACTER:
#endif
case TC_COMPILED_PROCEDURE:
case TC_CONTROL_POINT:
case TC_DELAYED:
case TC_ENVIRONMENT:
case TC_EXTENDED_FIXNUM:
case TC_EXTENDED_PROCEDURE:
case TC_FIXNUM:
case TC_HUNK3:
case TC_LIST:
case TC_NON_MARKED_VECTOR:
case TC_NULL:
case TC_PRIMITIVE:
case TC_PRIMITIVE_EXTERNAL:
case TC_PROCEDURE:
case TC_UNINTERNED_SYMBOL:
case TC_INTERNED_SYMBOL:
case TC_TRUE:
case TC_UNASSIGNED:
case TC_VECTOR:
case TC_VECTOR_16B:
case TC_VECTOR_1B:
#ifndef COMPILER
case TC_COMPILED_EXPRESSION:
#endif
Val = Fetch_Expression(); break;
case TC_ACCESS:
Do_Nth_Then(RC_EXECUTE_ACCESS_FINISH, ACCESS_ENVIRONMENT);
case TC_ASSIGNMENT:
Save_Env();
Do_Nth_Then(RC_EXECUTE_ASSIGNMENT_FINISH, ASSIGN_VALUE);
case TC_BROKEN_HEART:
Export_Registers();
Microcode_Termination(TERM_BROKEN_HEART);
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
case TC_COMBINATION:
{ long Array_Length = Vector_Length(Fetch_Expression())-1;
Will_Push(Array_Length + 4); /* 3 for Save_Env + Save_Cont */
/* 1 more for finger */
Stack_Pointer -= Array_Length;
Push(Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Array_Length));
/* The finger: last argument number */
Pushed();
if (Array_Length == 0)
{ Push(STACK_FRAME_HEADER); /* Frame size */
Do_Nth_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT);
}
Save_Env();
Do_Nth_Then(RC_COMB_SAVE_VALUE, Array_Length+1);
}
case TC_COMBINATION_1:
Save_Env();
Do_Nth_Then(RC_COMB_1_PROCEDURE, COMB_1_ARG_1);
case TC_COMBINATION_2:
Save_Env();
Do_Nth_Then(RC_COMB_2_FIRST_OPERAND, COMB_2_ARG_2);
case TC_COMMENT:
Reduces_To_Nth(COMMENT_EXPRESSION);
case TC_CONDITIONAL:
Save_Env();
Do_Nth_Then(RC_CONDITIONAL_DECIDE, COND_PREDICATE);
#ifdef COMPILER
case TC_COMPILED_EXPRESSION:
Push((Pointer) Return_To_Interpreter);
Store_Expression((Pointer) Get_Integer(Fetch_Expression()));
goto Enter_Compiled_Code;
#endif
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
case TC_DEFINITION:
Save_Env();
Do_Nth_Then(RC_EXECUTE_DEFINITION_FINISH, DEFINE_VALUE);
case TC_DELAY:
/* Deliberately omitted: Immed_GC_If_Needed(Free+2); */
Val = Make_Pointer(TC_DELAYED, Free);
Free[THUNK_ENVIRONMENT] = Fetch_Env();
Free[THUNK_PROCEDURE] =
Fast_Vector_Ref(Fetch_Expression(), DELAY_OBJECT);
Free += 2;
break;
case TC_DISJUNCTION:
Save_Env();
Do_Nth_Then(RC_DISJUNCTION_DECIDE, OR_PREDICATE);
case TC_EXTENDED_LAMBDA: /* Close the procedure */
/* Deliberately omitted: Immed_GC_If_Needed(Free+2); */
Val = Make_Pointer(TC_EXTENDED_PROCEDURE, Free);
Free[PROCEDURE_LAMBDA_EXPR] = Fetch_Expression();
Free[PROCEDURE_ENVIRONMENT] = Fetch_Env();
Free += 2;
break;
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
#ifdef COMPILE_FUTURES
case TC_FUTURE:
if (Future_Has_Value(Fetch_Expression()))
Reduces_To_Nth(FUTURE_VALUE);
Will_Push(1 + CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2));
Push(Fetch_Env());
Store_Return(RC_EVAL_ERROR);
Save_Cont();
Push(Fetch_Expression()); /* Arg: FUTURE object */
Push(Get_Fixed_Obj_Slot(System_Scheduler));
Push(STACK_FRAME_HEADER+1);
Pushed();
goto Internal_Apply;
#endif
case TC_IN_PACKAGE:
Do_Nth_Then(RC_EXECUTE_IN_PACKAGE_CONTINUE,
IN_PACKAGE_ENVIRONMENT);
case TC_LAMBDA: /* Close the procedure */
case TC_LEXPR:
/* Deliberately omitted: Immed_GC_If_Needed(Free+2); */
Val = Make_Pointer(TC_PROCEDURE, Free);
Free[PROCEDURE_LAMBDA_EXPR] = Fetch_Expression();
Free[PROCEDURE_ENVIRONMENT] = Fetch_Env();
Free += 2;
break;
case TC_MANIFEST_NM_VECTOR:
case TC_MANIFEST_SPECIAL_NM_VECTOR:
Eval_Error(ERR_EXECUTE_MANIFEST_VECTOR);
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
case TC_PCOMB0:
/* ASSUMPTION: The syntaxer is hereby assumed NEVER to generate primitive
combinations unless the primitive itself is output in the code stream.
Therefore, we don't have to explicitly check here that the expression
register has a primitive in it.
*/
Primitive_Internal_Apply:
if (Microcode_Does_Stepping && Trapping &&
(Fetch_Apply_Trapper() != NIL))
{ Push(Fetch_Expression());
Push(Fetch_Apply_Trapper());
Push(STACK_FRAME_HEADER + 1 + N_Args_Primitive(Fetch_Expression()));
Stop_Trapping();
goto Apply_Non_Trapping;
}
Prim_No_Trap_Apply:
Export_Registers();
Metering_Apply_Primitive(Val, Get_Integer(Fetch_Expression()));
/* Any primitive which does not do a long jump can have it's primitive
frame popped off here. At this point, it is guaranteed that the
primitive is in the expression register in case the primitive needs
to back out.
*/
Import_Registers_Except_Val();
Pop_Primitive_Frame(N_Args_Primitive(Fetch_Expression()));
break;
case TC_PCOMB1: Do_Nth_Then(RC_PCOMB1_APPLY, PCOMB1_ARG_SLOT);
case TC_PCOMB2:
Save_Env();
Do_Nth_Then(RC_PCOMB2_DO_1, PCOMB2_ARG_2_SLOT);
case TC_PCOMB3:
Save_Env();
Do_Nth_Then(RC_PCOMB3_DO_2, PCOMB3_ARG_3_SLOT);
case TC_SCODE_QUOTE:
Val = Fast_Vector_Ref(Fetch_Expression(), SCODE_QUOTE_OBJECT);
break;
case TC_SEQUENCE_2:
Save_Env();
Do_Nth_Then(RC_SEQ_2_DO_2, SEQUENCE_1);
case TC_SEQUENCE_3:
Save_Env();
Do_Nth_Then(RC_SEQ_3_DO_2, SEQUENCE_1);
case TC_THE_ENVIRONMENT:
Val = Fetch_Env(); break;
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
case TC_VARIABLE:
/* ASSUMPTION: The SYMBOL slot does NOT contain a future */
{ long Result, Frame_No;
fast Pointer *Location, *Frame;
Pointer *Variable_Object;
Set_Time_Zone(Zone_Lookup);
#ifndef No_In_Line_Lookup
Frame = Get_Pointer(Fetch_Env());
Variable_Object = Get_Pointer(Fetch_Expression());
if (Type_Code(Variable_Object[VARIABLE_COMPILED_TYPE]) ==
FORMAL_REF)
{ fast long i;
Frame_No = Get_Integer(Variable_Object[VARIABLE_FRAME_NO]);
for (i=0; i < Frame_No; i++)
Frame = Get_Pointer(Fast_Vector_Ref(Frame[HEAP_ENV_FUNCTION],
PROCEDURE_ENVIRONMENT));
Location = &(Frame[Get_Integer(Variable_Object[VARIABLE_OFFSET])]);
Val = *Location;
if (Dangerous(Val))
Variable_Object[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
#ifdef COMPILE_FUTURES
else if ((Type_Code(Val) == TC_FUTURE) && (Future_Spliceable(Val)))
{ Val = Future_Value(Val);
*Location = Val;
Set_Time_Zone(Zone_Working);
break;
}
#endif
else { Set_Time_Zone(Zone_Working); break; }
}
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
else if (Type_Code(Variable_Object[VARIABLE_COMPILED_TYPE]) ==
GLOBAL_REF)
{ Location = Nth_Vector_Loc(Variable_Object[VARIABLE_SYMBOL],
SYMBOL_GLOBAL_VALUE);
Val = *Location;
if (Dangerous(Val))
Variable_Object[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
#ifdef COMPILE_FUTURES
else if ((Type_Code(Val) == TC_FUTURE) && (Future_Spliceable(Val)))
{ Val = Future_Value(Val);
*Location = Val;
Set_Time_Zone(Zone_Working);
break;
}
#endif
else { Set_Time_Zone(Zone_Working); break; }
}
#endif
Result = Lex_Ref(Fetch_Env(), Fetch_Expression());
Import_Val();
Set_Time_Zone(Zone_Working);
if (Result == PRIM_DONE) break;
Eval_Error(Result);
}
case TC_RETURN_CODE:
default: Eval_Error(ERR_UNDEFINED_USER_TYPE);
};
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
/* Now restore the continuation saved during an earlier part
* of the EVAL cycle and continue as directed.
*/
Pop_Return:
Pop_Return_Ucode_Hook();
Restore_Cont();
if (Consistency_Check &&
(Type_Code(Fetch_Return()) != TC_RETURN_CODE))
{ Export_Registers();
Microcode_Termination(TERM_BAD_STACK);
}
if (Eval_Debug)
{ Print_Return("Pop_Return, return code");
Print_Expression(Val, "Pop_Return, value");
CRLF();
};
/* Dispatch on the return code. A BREAK here will cause
* a "goto Pop_Return" to occur, since this is the most
* common occurrence.
*/
switch (Get_Integer(Fetch_Return()))
{ case RC_COMB_1_PROCEDURE:
Restore_Env();
Will_Push(3);
Push(Val); /* Arg. 1 */
Push(NIL); /* Operator */
Push(STACK_FRAME_HEADER+1);
Pushed();
Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_1_FN);
case RC_COMB_2_FIRST_OPERAND:
Will_Push(1);
Restore_Env();
Push(Val);
Save_Env();
Pushed();
Do_Another_Then(RC_COMB_2_PROCEDURE, COMB_2_ARG_1);
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
case RC_COMB_2_PROCEDURE:
Restore_Env();
Will_Push(3);
Push(Val); /* Arg 1, just calculated */
Push(NIL); /* Function */
Push(STACK_FRAME_HEADER+2);
Pushed();
Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_2_FN);
case RC_COMB_APPLY_FUNCTION:
End_Subproblem();
Stack_Pointer[STACK_ENV_FUNCTION] = Val;
goto Internal_Apply;
case RC_COMB_SAVE_VALUE:
{ long Arg_Number;
Pointer Function;
Restore_Env();
Arg_Number = Get_Integer(Stack_Pointer[STACK_COMB_FINGER])-1;
Stack_Pointer[STACK_COMB_FIRST_ARG+Arg_Number] = Val;
Stack_Pointer[STACK_COMB_FINGER] =
Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Arg_Number);
if (Arg_Number > 0)
{ Save_Env();
Do_Another_Then(RC_COMB_SAVE_VALUE,
(COMB_ARG_1_SLOT - 1) + Arg_Number);
}
Push(Fast_Vector_Ref(Fetch_Expression(), 0)); /* Frame Size */
Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT);
}
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
#ifdef COMPILER
case RC_COMPILER_ENTRY_GC:
Store_Expression((Pointer) Compiler_Entry_GC);
goto Enter_Compiled_Code;
case RC_COMPILER_RECURSION_GC:
Store_Expression((Pointer) Compiler_Recursion_GC);
goto Enter_Compiled_Code;
#endif
case RC_CONDITIONAL_DECIDE:
Pop_Return_Val_Check();
End_Subproblem();
Restore_Env();
Reduces_To_Nth((Val==NIL)? COND_ALTERNATIVE : COND_CONSEQUENT);
case RC_DISJUNCTION_DECIDE:
/* Return predicate if it isn't NIL; else do ALTERNATIVE */
Pop_Return_Val_Check();
End_Subproblem();
Restore_Env();
if (Val != NIL) goto Pop_Return;
Reduces_To_Nth(OR_ALTERNATIVE);
case RC_END_OF_COMPUTATION:
/* Signals bottom of stack */
Export_Registers();
Microcode_Termination(TERM_END_OF_COMPUTATION);
case RC_EVAL_ERROR:
Store_Env(Pop());
Reduces_To(Fetch_Expression());
case RC_EXECUTE_ACCESS_FINISH:
{ long Result;
Pop_Return_Val_Check();
if (Environment_P(Val))
{ Result = Symbol_Lex_Ref(Val,
Fast_Vector_Ref(Fetch_Expression(), ACCESS_NAME));
Import_Val();
if (Result != PRIM_DONE) Pop_Return_Error(Result);
End_Subproblem();
break;
}
Pop_Return_Error(ERR_BAD_FRAME);
}
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
case RC_EXECUTE_ASSIGNMENT_FINISH:
{ long Result, Frame_No;
fast Pointer Frame = Pop();
fast long i;
Pointer The_Non_Object, Store_Value, Variable;
Set_Time_Zone(Zone_Lookup);
The_Non_Object = Get_Fixed_Obj_Slot(Non_Object);
Store_Value = (Val==The_Non_Object) ? UNASSIGNED_OBJECT : Val;
Variable = Fast_Vector_Ref(Fetch_Expression(), ASSIGN_NAME);
Store_Env(Frame);
#ifndef No_In_Line_Lookup
if (Type_Code(Vector_Ref(Variable,
VARIABLE_COMPILED_TYPE)) == FORMAL_REF)
{ Frame_No = Get_Integer(Vector_Ref(Variable, VARIABLE_FRAME_NO));
for (i=0; i < Frame_No; i++)
Frame = Fast_Vector_Ref(Fast_Vector_Ref(Frame, HEAP_ENV_FUNCTION),
PROCEDURE_ENVIRONMENT);
Val = Vector_Ref(Frame,
Get_Integer(Vector_Ref(Variable, VARIABLE_OFFSET)));
if (!Dangerous(Val))
{ if (Val==UNASSIGNED_OBJECT) Val = The_Non_Object;
Vector_Set(Frame,
Get_Integer(Fast_Vector_Ref(Variable, VARIABLE_OFFSET)),
Store_Value);
Set_Time_Zone(Zone_Working);
End_Subproblem();
break;
}
Vector_Set(Variable, VARIABLE_COMPILED_TYPE, UNCOMPILED_VARIABLE);
}
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
else if (Type_Code(Vector_Ref(Variable,
VARIABLE_COMPILED_TYPE)) == GLOBAL_REF)
{ Val = Vector_Ref(Fast_Vector_Ref(Variable, VARIABLE_SYMBOL),
SYMBOL_GLOBAL_VALUE);
if (!Dangerous(Val))
{ if (Val==UNASSIGNED_OBJECT) Val = The_Non_Object;
Vector_Set(Vector_Ref(Variable, VARIABLE_SYMBOL),
SYMBOL_GLOBAL_VALUE, Store_Value);
Set_Time_Zone(Zone_Working);
End_Subproblem();
break;
}
Vector_Set(Variable, VARIABLE_COMPILED_TYPE, UNCOMPILED_VARIABLE);
}
#endif
Result = Lex_Set(Fetch_Env(), Variable, Store_Value);
Import_Val();
Set_Time_Zone(Zone_Working);
if (Result == PRIM_DONE)
{ End_Subproblem();
break;
}
Save_Env();
Pop_Return_Error(Result);
}
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
case RC_EXECUTE_DEFINITION_FINISH:
{ Pointer Saved_Val;
long Result;
Saved_Val = Val;
Restore_Env();
Result = Local_Set(Fetch_Env(),
Fast_Vector_Ref(Fetch_Expression(), DEFINE_NAME),
Val);
Import_Val();
if (Result==PRIM_DONE)
{ End_Subproblem();
break;
}
Save_Env();
if (Result==PRIM_INTERRUPT)
{ Prepare_Pop_Return_Interrupt(RC_EXECUTE_DEFINITION_FINISH,
Saved_Val);
Interrupt(IntCode & IntEnb);
}
Pop_Return_Error(Result);
};
case RC_EXECUTE_IN_PACKAGE_CONTINUE:
Pop_Return_Val_Check();
if (Environment_P(Val))
{ End_Subproblem();
Store_Env(Val);
Reduces_To_Nth(IN_PACKAGE_EXPRESSION);
}
Pop_Return_Error(ERR_BAD_FRAME);
#ifdef COMPILE_FUTURES
case RC_FINISH_GLOBAL_INT:
Export_Registers();
Val = Global_Int_Part_2(Fetch_Expression(), Val);
Import_Registers_Except_Val();
break;
#endif
case RC_HALT:
Export_Registers();
Microcode_Termination(TERM_TERM_HANDLER);
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
#define Prepare_Apply_Interrupt() \
Prepare_Pop_Return_Interrupt(RC_INTERNAL_APPLY, NIL)
#define Apply_Error(N) \
{ Store_Return(RC_INTERNAL_APPLY); \
Val = NIL; \
Pop_Return_Error(N); \
}
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
case RC_INTERNAL_APPLY:
Internal_Apply:
/* Branch here to perform a function application. At this point
it is necessary that the top of the stack contain a frame
for evaluation of the function to be applied. This frame
DOES NOT contain "finger" and "combination" slots, although
if the frame is to be copied into the heap, it will have NIL's
in the "finger" and "combination" slots which will correspond
to "potentially-dangerous" and "auxilliary variables" slots.
Note, also, that unlike most return codes Val is not used here.
Thus, the error and interrupt macros above set it to NIL so that it
will not 'hold on' to anything if a GC occurs. Similarly, the
contents of Expression are discarded.
*/
if (Microcode_Does_Stepping && Trapping &&
(Fetch_Apply_Trapper() != NIL))
{ long Count = Get_Integer(Stack_Pointer[STACK_ENV_HEADER]);
*Stack_Pointer = Fetch_Apply_Trapper();
Push(STACK_FRAME_HEADER+Count);
Stop_Trapping();
}
Apply_Non_Trapping:
{ long Interrupts;
Pointer Function;
Store_Expression(NIL);
Interrupts = IntEnb & IntCode;
if (Interrupts != 0)
{ Prepare_Apply_Interrupt();
Interrupt(Interrupts);
}
Perform_Application:
Apply_Future_Check(Function, Stack_Pointer[STACK_ENV_FUNCTION]);
Apply_Ucode_Hook();
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
switch(Type_Code(Function))
{ case TC_PROCEDURE:
{ Pointer Lambda_Expr, *Temp1, Temp2;
long NParams, Size;
fast long NArgs;
Apply_Future_Check(Lambda_Expr,
Fast_Vector_Ref(Function, PROCEDURE_LAMBDA_EXPR));
Temp1 = Get_Pointer(Lambda_Expr);
Apply_Future_Check(Temp2, Temp1[LAMBDA_FORMALS]);
NArgs = Get_Integer(Pop());
NParams = Vector_Length(Temp2);
if (Eval_Debug)
{ Print_Expression(NArgs, "APPLY: Number of arguments");
Print_Expression(NParams, " Number of parameters");
}
if (Type_Code(Lambda_Expr) == TC_LAMBDA)
{ if (NArgs != NParams)
{ Push(STACK_FRAME_HEADER+NArgs-1);
Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
}
}
else if (NArgs < NParams)
{ Push(STACK_FRAME_HEADER+NArgs-1);
Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
}
Size = NArgs + (HEAP_ENV_EXTRA_SLOTS - 1);
if (GC_Check(Free + Size))
{ Push(STACK_FRAME_HEADER+NArgs-1);
Prepare_Apply_Interrupt();
Immediate_GC();
}
/* Store Environment Frame into heap, putting extra slots
for Potentially Dangerous and Auxiliaries */
Store_Env(Make_Pointer(TC_ENVIRONMENT, Free));
*Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Size);
*Free++ = NIL; /* For PD list and Aux list */
*Free++ = NIL;
for (; --NArgs >= 0; ) *Free++ = Pop();
Reduces_To(Temp1[LAMBDA_SCODE]);
}
case TC_CONTROL_POINT:
if (Get_Integer(Stack_Pointer[STACK_ENV_HEADER]) !=
STACK_ENV_FIRST_ARG)
Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS)
Val = Stack_Pointer[STACK_ENV_FIRST_ARG];
Export_Registers();
Throw(Function);
Import_Registers_Except_Val();
goto Pop_Return;
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
case TC_PRIMITIVE_EXTERNAL:
{ long NArgs, Proc = Address(Function);
if (Proc > MAX_EXTERNAL_PRIMITIVE)
Apply_Error(ERR_UNDEFINED_PRIMITIVE);
NArgs = Ext_Prim_Desc[Proc].arity;
if (Get_Integer(Stack_Pointer[STACK_ENV_HEADER]) !=
STACK_ENV_FIRST_ARG+NArgs-1)
Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
Stack_Pointer += STACK_ENV_FIRST_ARG;
/* Remove the frame overhead, since the primitives
just expect arguments on the stack */
Store_Expression(Function);
Repeat_External_Primitive:
/* Reinitialize Proc in case we "goto Repeat_External..." */
Proc = Get_Integer(Fetch_Expression());
Export_Registers();
Val = (*(Ext_Prim_Desc[Proc].proc))();
Set_Time_Zone(Zone_Working);
Import_Registers_Except_Val();
Pop_Primitive_Frame(Ext_Prim_Desc[Proc].arity);
goto Pop_Return;
}
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
case TC_EXTENDED_PROCEDURE:
{ Pointer Lambda_Expr, *List_Car, Temp;
long NArgs, NParams, Formals, Params, Auxes,
Rest_Flag, Size, i, Finger;
/* Selectors for the various parts */
#define Get_Body_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_SCODE))
#define Get_Names_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_NAMES))
#define Get_Count_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_ARG_COUNT))
#define Elambda_Formals_Count(Addr) \
((((long) Addr) & EL_FORMALS_MASK) >> EL_FORMALS_SHIFT)
#define Elambda_Opts_Count(Addr) \
(((long) Addr) & EL_OPTS_MASK)
#define Elambda_Rest_Flag(Addr) \
((((long) Addr) & EL_REST_MASK) >> EL_REST_SHIFT)
Apply_Future_Check(Lambda_Expr,
Fast_Vector_Ref(Function,
PROCEDURE_LAMBDA_EXPR));
Apply_Future_Check(Temp, Fast_Vector_Ref(Lambda_Expr,
ELAMBDA_NAMES));
NParams = Vector_Length(Temp) - 1;
Apply_Future_Check(Temp, Get_Count_Elambda(Lambda_Expr));
Formals = Elambda_Formals_Count(Temp);
/* Formals DOES NOT include the name of the lambda */
Params = Elambda_Opts_Count(Temp) + Formals;
Rest_Flag = Elambda_Rest_Flag(Temp);
NArgs = Get_Integer(Pop()) - 1;
Auxes = NParams - (Params + Rest_Flag);
if ((NArgs < Formals) ||
(!Rest_Flag && (NArgs > Params)))
{ Push(STACK_FRAME_HEADER+NArgs);
Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
}
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
Size = Params + Rest_Flag + Auxes +
(HEAP_ENV_EXTRA_SLOTS + 1);
List_Car = Free + Size;
if (GC_Check(Free + Size +
((NArgs > Params) ?
2 * (NArgs - Params) : 0)))
{ Push(STACK_FRAME_HEADER+NArgs);
Prepare_Apply_Interrupt();
Immediate_GC();
}
Store_Env(Make_Pointer(TC_ENVIRONMENT, Free));
*Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Size-1);
/* Environment Header */
*Free++ = NIL; /* Aux list */
*Free++ = NIL; /* PD list */
Size = 1 + ((NArgs < Params) ? NArgs : Params);
for (i = 0; i < Size; i++) *Free++ = Pop();
for (i--; i < Params; i++)
*Free++ = UNASSIGNED_OBJECT;
if (Rest_Flag)
if (NArgs <= i) *Free++ = NIL;
else
{ *Free++ = Make_Pointer(TC_LIST, List_Car);
for (; i < NArgs; i++, List_Car++)
{ *List_Car++ = Pop();
*List_Car = Make_Pointer(TC_LIST, List_Car+1);
}
List_Car[-1] = NIL;
}
for (i = 0; i < Auxes; i++) *Free++ = UNASSIGNED_OBJECT;
Free = List_Car;
Reduces_To(Get_Body_Elambda(Lambda_Expr));
}
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
case TC_PRIMITIVE:
{ long Number_Of_Args = N_Args_Primitive(Function);
if (Get_Integer(Stack_Pointer[STACK_ENV_HEADER]) !=
STACK_ENV_FIRST_ARG+Number_Of_Args-1)
Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
Stack_Pointer += STACK_ENV_FIRST_ARG;
/* Remove the frame overhead, since the primitives
just expect arguments on the stack */
Store_Expression(Function);
goto Prim_No_Trap_Apply;
}
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
#ifdef COMPILER
case TC_COMPILED_PROCEDURE:
{ long Size, i;
Pointer *To, *Final_Stack, Code_Address;
Apply_Future_Check(Code_Address,
Fast_Vector_Ref(Function, COMP_PROCEDURE_ADDRESS));
Size = 1+Get_Integer(Stack_Pointer[STACK_ENV_HEADER]);
To = Stack_Pointer-4;
Final_Stack = To;
for (i=0; i < Size; i++) *To++ = *Stack_Pointer++;
Export_Registers();
Stop_History();
Import_Registers_Except_Val();
Push((Pointer) Return_To_Interpreter);
if (Consistency_Check && (Stack_Pointer != To))
{ printf("\nEntering compiled code & stack doesn't match.\n");
Export_Registers();
Microcode_Termination(TERM_EXIT);
}
Stack_Pointer = Final_Stack;
Store_Expression(Code_Address);
Enter_Compiled_Code:
/* Assumption is that Expression has a jump address */
Export_Registers();
Which_Way = Enter_Compiler();
Import_Registers();
switch (Which_Way)
{ default:
Store_Return(RC_INTERNAL_APPLY);
Store_Expression(NIL);
Pop_Return_Error(Which_Way);
case PRIM_APPLY: goto Internal_Apply;
case PRIM_INTERRUPT: Interrupt(IntCode & IntEnb);
case PRIM_DONE: goto Pop_Return;
}
}
#endif
default:
Apply_Error(ERR_INAPPLICABLE_OBJECT);
} /* End of switch in RC_INTERNAL_APPLY */
} /* End of RC_INTERNAL_APPLY case */
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
case RC_MOVE_TO_ADJACENT_POINT:
{ Pointer Next_Point, This_Root, This_Space, Thunk;
/* Interrupts off here, in theory */
Next_Point = Fetch_Expression();
This_Root = Vector_Ref(Next_Point, STATE_POINT_NEARER_POINT);
This_Space = Vector_Ref(This_Root, STATE_POINT_NEARER_POINT);
Vector_Set(This_Root, STATE_POINT_NEARER_POINT, Next_Point);
Vector_Set(This_Space, STATE_SPACE_NEAREST_POINT, Next_Point);
Thunk = Vector_Ref(Next_Point, STATE_POINT_BACKWARD_THUNK);
Vector_Set(This_Root, STATE_POINT_FORWARD_THUNK, Thunk);
Vector_Set(This_Root, STATE_POINT_BACKWARD_THUNK,
Vector_Ref(Next_Point, STATE_POINT_FORWARD_THUNK));
Vector_Set(Next_Point, STATE_POINT_BACKWARD_THUNK, NIL);
Vector_Set(Next_Point, STATE_POINT_FORWARD_THUNK, NIL);
Vector_Set(Next_Point, STATE_POINT_NEARER_POINT, This_Space);
/* Having updated the structures, time to call the thunk */
/* Interrupts on again here, in theory */
Will_Push(2);
Push(Thunk);
Push(STACK_FRAME_HEADER);
Pushed();
goto Internal_Apply;
}
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
case RC_INVOKE_STACK_THREAD:
/* Used for WITH_THREADED_STACK primitive */
Will_Push(3);
Push(Val); /* Value calculated by thunk */
Push(Fetch_Expression());
Push(STACK_FRAME_HEADER+1);
Pushed();
goto Internal_Apply;
case RC_NORMAL_GC_DONE:
End_GC_Hook();
Val = Fetch_Expression();
break;
case RC_PCOMB1_APPLY:
End_Subproblem();
Push(Val); /* Argument value */
Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB1_FN_SLOT));
goto Primitive_Internal_Apply;
case RC_PCOMB2_APPLY:
End_Subproblem();
Push(Val); /* Value of arg. 1 */
Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB2_FN_SLOT));
goto Primitive_Internal_Apply;
case RC_PCOMB2_DO_1:
Restore_Env();
Push(Val); /* Save value of arg. 2 */
Do_Another_Then(RC_PCOMB2_APPLY, PCOMB2_ARG_1_SLOT);
case RC_PCOMB3_APPLY:
End_Subproblem();
Push(Val); /* Save value of arg. 1 */
Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB3_FN_SLOT));
goto Primitive_Internal_Apply;
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
case RC_PCOMB3_DO_1:
{ Pointer Temp;
Temp = Pop(); /* Value of arg. 3 */
Restore_Env();
Push(Temp); /* Save arg. 3 again */
Push(Val); /* Save arg. 2 */
Do_Another_Then(RC_PCOMB3_APPLY, PCOMB3_ARG_1_SLOT);
}
case RC_PCOMB3_DO_2:
Will_Push(1);
Restore_Then_Save_Env();
Push(Val); /* Save value of arg. 3 */
Pushed();
Do_Another_Then(RC_PCOMB3_DO_1, PCOMB3_ARG_2_SLOT);
case RC_POP_RETURN_ERROR:
case RC_RESTORE_VALUE:
Val = Fetch_Expression();
break;
#ifdef COMPILER
case RC_POP_TO_COMPILED_CODE:
/* ASSUMPTION: Compiled code calls to the interpreter require the results
be touched before returning to the compiled code. This may be very wrong.
*/
Pop_Return_Val_Check();
Registers[REGBLOCK_VAL] = Val;
goto Enter_Compiled_Code;
#endif
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
case RC_PURIFY_GC_1:
{ Pointer Result, GC_Daemon_Proc;
Will_Push(4);
Export_Registers();
Result = Purify_Pass_2(Fetch_Expression());
Import_Registers();
if (Result==NIL)
{ Val = NIL;
break;
}
GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon);
if (GC_Daemon_Proc==NIL)
{ Val = TRUTH;
break;
}
Store_Expression(NIL);
Store_Return(RC_PURIFY_GC_2);
Save_Cont();
Push(GC_Daemon_Proc);
Push(STACK_FRAME_HEADER);
Pushed();
goto Internal_Apply;
}
case RC_PURIFY_GC_2:
Val = TRUTH;
break;
case RC_REPEAT_PRIMITIVE:
if (Type_Code(Fetch_Expression()) == TC_PRIMITIVE_EXTERNAL)
goto Repeat_External_Primitive;
else goto Primitive_Internal_Apply;
case RC_RESTORE_CONTROL_POINT:
Export_Registers();
Throw(Fetch_Expression());
Import_Registers_Except_Val();
break;
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
/* The following two return codes are both used to restore
a saved history object. The difference is that the first
does not copy the history object while the second does.
In both cases, the Expression register contains the history
object and the next item to be popped off the stack contains
the offset back to the previous restore history return code.
ASSUMPTION: History objects are never created using futures.
*/
case RC_RESTORE_DONT_COPY_HISTORY:
{ long Offset = Get_Integer(Pop());
History = Get_Pointer(Fetch_Expression());
if (Offset==0) Previous_Restore_History = NULL;
else Previous_Restore_History = Stack_Pointer+Offset;
break;
}
case RC_RESTORE_HISTORY:
{ long Offset;
Export_Registers();
if (! Restore_History(Fetch_Expression()))
{ Import_Registers();
Will_Push(2*CONTINUATION_SIZE);
Save_Cont();
Store_Expression(Val);
Store_Return(RC_RESTORE_VALUE);
Save_Cont();
Pushed();
Immediate_GC();
}
Import_Registers();
Offset = Get_Integer(Pop());
if (Offset==0) Previous_Restore_History = NULL;
else
{ /* In addition to calculating the address of the previous
restore history return code, it must be changed so that it,
too, will copy the history when it is restored. */
Previous_Restore_History = Stack_Pointer+Offset;
Previous_Restore_History[CONTINUATION_RETURN_CODE-
(1+CONTINUATION_SIZE)] =
Make_Non_Pointer(TC_RETURN_CODE, RC_RESTORE_HISTORY);
}
break;
}
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
case RC_RESTORE_INT_MASK:
IntEnb = Get_Integer(Fetch_Expression());
break;
case RC_RESTORE_TO_STATE_POINT:
/* ASSUMPTION: State points, which are created only by the interpreter,
never contain FUTUREs except possibly as the thunks (which are handled
by the apply code).
*/
{ Pointer Saved_State;
fast Pointer Tag, Nearer_Point;
Saved_State = Fetch_Expression();
Will_Push(2);
/* Set up so that after going to the saved state point we will
restore the current contents of Val */
Store_Expression(Val);
Store_Return(RC_RESTORE_VALUE);
Save_Cont();
Pushed();
Store_Expression(Saved_State);
Translate_To_Point:
/* Come here either to restore back to a state point, or to go off
to one in the first place. In either case, Expression contains
the state point to go to.
*/
Tag = Get_Fixed_Obj_Slot(State_Point_Tag);
Store_Return(RC_MOVE_TO_ADJACENT_POINT);
for (Nearer_Point = Vector_Ref(Fetch_Expression(),
STATE_POINT_NEARER_POINT);
Vector_Ref(Nearer_Point, STATE_POINT_TAG) == Tag;
Nearer_Point = Vector_Ref(Nearer_Point, STATE_POINT_NEARER_POINT))
{ Save_Cont();
Store_Expression(Nearer_Point);
}
Will_Push(0); /* Check stack space */
Pushed();
break;
} /* End of RC_RESTORE_STATE_POINT */
/* case RC_RESTORE_VALUE is with RC_POP_RETURN_ERROR */
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
case RC_RETURN_TRAP_POINT:
Store_Return(Old_Return_Code);
Save_Cont();
Return_Hook_Address = NULL;
Stop_Trapping();
Push(Val);
Push(Fetch_Return_Trapper());
Push(STACK_FRAME_HEADER+1);
goto Apply_Non_Trapping;
case RC_SEQ_2_DO_2:
End_Subproblem();
Restore_Env();
Reduces_To_Nth(SEQUENCE_2);
case RC_SEQ_3_DO_2:
Restore_Then_Save_Env();
Do_Another_Then(RC_SEQ_3_DO_3, SEQUENCE_2);
case RC_SEQ_3_DO_3:
End_Subproblem();
Restore_Env();
Reduces_To_Nth(SEQUENCE_3);
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
case RC_SNAP_NEED_THUNK:
Vector_Set(Fetch_Expression(), THUNK_SNAPPED, TRUTH);
Vector_Set(Fetch_Expression(), THUNK_VALUE, Val);
break;
case RC_AFTER_MEMORY_UPDATE:
case RC_BAD_INTERRUPT_CONTINUE:
case RC_COMPLETE_GC_DONE:
case RC_REDO_CMPLR_ASSIGNMENT:
case RC_REDO_CMPLR_REFERENCE:
case RC_REENTER_COMPILED_CODE:
case RC_RESTARTABLE_EXIT:
case RC_RESTART_EXECUTION:
case RC_RESTORE_CONTINUATION:
case RC_RESTORE_STEPPER:
#ifndef COMPILER
case RC_COMPILER_ENTRY_GC:
case RC_COMPILER_RECURSION_GC:
case RC_POP_TO_COMPILED_CODE:
#endif
Export_Registers();
Microcode_Termination(TERM_UNIMPLEMENTED_CONTINUATION);
default:
Export_Registers();
Microcode_Termination(TERM_NON_EXISTENT_CONTINUATION);
};
goto Pop_Return;
}