From: Stephen Adams Date: Wed, 26 Jul 1995 23:38:51 +0000 (+0000) Subject: Monster typo last version managed to duplicate most of the file. X-Git-Tag: 20090517-FFI~6140 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d4a2f94cfef8d6524debada48f06c9735dbe3a3e;p=mit-scheme.git Monster typo last version managed to duplicate most of the file. --- diff --git a/v8/src/microcode/interp.c b/v8/src/microcode/interp.c index ed28054da..cf60b7dc8 100644 --- a/v8/src/microcode/interp.c +++ b/v8/src/microcode/interp.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: interp.c,v 9.85 1995/07/26 21:16:17 adams Exp $ +$Id: interp.c,v 9.86 1995/07/26 23:38:51 adams Exp $ Copyright (c) 1988-1995 Massachusetts Institute of Technology @@ -2244,2245 +2244,6 @@ Primitive_Internal_Apply: Restore_Env(); Reduces_To_Nth(SEQUENCE_3); -/* Interpret() continues on the next page */ - -/* -*-C-*- - -$Id: interp.c,v 9.85 1995/07/26 21:16:17 adams Exp $ - -Copyright (c) 1988-94 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. */ - -/* This file contains the heart of the SCode interpreter. */ - -#define In_Main_Interpreter true -#include "scheme.h" -#include "locks.h" -#include "trap.h" -#include "lookup.h" -#include "winder.h" -#include "history.h" -#include "cmpint.h" -#include "zones.h" -#include "prmcon.h" - -extern PTR EXFUN (obstack_chunk_alloc, (unsigned int size)); -extern void EXFUN (free, (PTR ptr)); -#define obstack_chunk_free free -extern void EXFUN (back_out_of_primitive_internal, (void)); -extern void EXFUN (preserve_signal_mask, (void)); - -/* 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 Scode 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. - * - * 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. - */ - -#define Prepare_Pop_Return_Interrupt(Return_Code, Contents_of_Val) \ -{ \ - SCHEME_OBJECT temp; \ - \ - temp = (Contents_of_Val); \ - Store_Return(Return_Code); \ - Save_Cont(); \ - Store_Return(RC_RESTORE_VALUE); \ - Store_Expression(temp); \ - Save_Cont(); \ -} - -#define Interrupt(Masked_Code) \ -{ \ - Export_Registers(); \ - Setup_Interrupt(Masked_Code); \ - Import_Registers(); \ - goto Perform_Application; \ -} - -#define Immediate_GC(N) \ -{ \ - Request_GC(N); \ - Interrupt(PENDING_INTERRUPTS()); \ -} - -#define Eval_GC_Check(Amount) \ -if (GC_Check(Amount)) \ -{ \ - Prepare_Eval_Repeat(); \ - Immediate_GC(Amount); \ -} - -#define Prepare_Eval_Repeat() \ -{ \ - Will_Push(CONTINUATION_SIZE+1); \ - STACK_PUSH (Fetch_Env()); \ - Store_Return(RC_EVAL_ERROR); \ - Save_Cont(); \ - Pushed(); \ -} - -#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 BACK_OUT_AFTER_PRIMITIVE() \ -{ \ - Export_Registers(); \ - back_out_of_primitive_internal (); \ - Import_Registers(); \ -} - -#define Reduces_To(Expr) \ - { Store_Expression(Expr); \ - New_Reduction(Fetch_Expression(), Fetch_Env()); \ - goto Do_Expression; \ - } - -#define Reduces_To_Nth(N) \ - Reduces_To(FAST_MEMORY_REF (Fetch_Expression(), (N))) - -#define Do_Nth_Then(Return_Code, N, Extra) \ - { Store_Return(Return_Code); \ - Save_Cont(); \ - Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), (N))); \ - New_Subproblem(Fetch_Expression(), Fetch_Env()); \ - Extra; \ - goto Do_Expression; \ - } - -#define Do_Another_Then(Return_Code, N) \ - { Store_Return(Return_Code); \ - Save_Cont(); \ - Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), (N))); \ - Reuse_Subproblem(Fetch_Expression(), Fetch_Env()); \ - goto Do_Expression; \ - } - - /***********************/ - /* Macros for Stepping */ - /***********************/ - -#define Fetch_Trapper(field) \ - MEMORY_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) - -/* 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 SCHEME_OBJECT *Arg, Orig_Arg; \ - \ - Arg = &(STACK_REF((Arg_No - 1) + STACK_ENV_FIRST_ARG)); \ - Orig_Arg = *Arg; \ - \ - if (OBJECT_TYPE (*Arg) != TC_FUTURE) \ - { \ - Pop_Return_Error(Err_No); \ - } \ - \ - while ((OBJECT_TYPE (*Arg) == TC_FUTURE) && (Future_Has_Value(*Arg))) \ - { \ - if (Future_Is_Keep_Slot(*Arg)) \ - { \ - Log_Touch_Of_Future(*Arg); \ - } \ - *Arg = Future_Value(*Arg); \ - } \ - if (OBJECT_TYPE (*Arg) != TC_FUTURE) \ - { \ - goto Apply_Non_Trapping; \ - } \ - \ - TOUCH_SETUP(*Arg); \ - *Arg = Orig_Arg; \ - 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 SCHEME_OBJECT *Arg, Orig_Answer; \ - \ - Arg = &(Object); \ - Orig_Answer = *Arg; \ - \ - while (OBJECT_TYPE (*Arg) == TC_FUTURE) \ - { \ - if (Future_Has_Value(*Arg)) \ - { \ - if (Future_Is_Keep_Slot(*Arg)) \ - { \ - Log_Touch_Of_Future(*Arg); \ - } \ - *Arg = Future_Value(*Arg); \ - } \ - else \ - { \ - Prepare_Apply_Interrupt (); \ - TOUCH_SETUP (*Arg); \ - *Arg = Orig_Answer; \ - goto Internal_Apply; \ - } \ - } \ - Name = *Arg; \ -} - -/* Future handling macros continue on the next page */ - -/* 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 SCHEME_OBJECT Orig_Val = Val; \ - \ - while (OBJECT_TYPE (Val) == TC_FUTURE) \ - { \ - if (Future_Has_Value(Val)) \ - { \ - if (Future_Is_Keep_Slot(Val)) \ - { \ - Log_Touch_Of_Future(Val); \ - } \ - Val = Future_Value(Val); \ - } \ - else \ - { \ - Save_Cont(); \ - Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS + 2)); \ - Store_Return(RC_RESTORE_VALUE); \ - Store_Expression(Orig_Val); \ - Save_Cont(); \ - STACK_PUSH (Val); \ - STACK_PUSH (Get_Fixed_Obj_Slot(System_Scheduler)); \ - STACK_PUSH (STACK_FRAME_HEADER + 1); \ - Pushed(); \ - goto Internal_Apply; \ - } \ - } \ -} - -/* This saves stuff unnecessarily in most cases. - For example, when Which_Way is PRIM_APPLY, Val, Env, Expr, - and Return_Code are undefined. - */ - -#define LOG_FUTURES() \ -{ \ - if (Must_Report_References()) \ - { \ - Save_Cont(); \ - Will_Push(CONTINUATION_SIZE + 2); \ - STACK_PUSH (Val); \ - Save_Env(); \ - Store_Return(RC_REPEAT_DISPATCH); \ - Store_Expression(LONG_TO_FIXNUM(CODE_MAP(Which_Way))); \ - Save_Cont(); \ - Pushed(); \ - Call_Future_Logging(); \ - } \ -} - -#else /* not COMPILE_FUTURES */ - -#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) \ -} - -#define LOG_FUTURES() - -#endif /* COMPILE_FUTURES */ - -/* Notes on Repeat_Dispatch: - - The codes used (values of Which_Way) are divided into two groups: - Those for which the primitive has already backed out, and those for - which the back out code has not yet been executed, and is therefore - executed below. - - Under most circumstances the distinction is moot, but if there are - futures in the system, and future touches must be logged, the code - must be set up to "interrupt" the dispatch, and proceed it later. - The primitive back out code must be done before the furure is - logged, so all of these codes are split into two versions: one set - before doing the back out, and another afterwards. - */ - -/* This is assumed to be larger (in absolute value) than any PRIM_ - and ERR_. - */ -#define PRIM_BIAS_AMOUNT 1000 - -#if (MAX_ERROR >= PRIM_BIAS_AMOUNT) -#include "Inconsistency: errors.h and interp.c" -#endif - -#define CODE_MAP(code) \ -((code < 0) ? \ - (code - PRIM_BIAS_AMOUNT) : \ - (code + PRIM_BIAS_AMOUNT)) - -#define CODE_UNMAP(code) \ -((code < 0) ? \ - (code + PRIM_BIAS_AMOUNT) : \ - (code - PRIM_BIAS_AMOUNT)) - -#define CODE_MAPPED_P(code) \ -((code < (- PRIM_BIAS_AMOUNT)) || \ - (code >= PRIM_BIAS_AMOUNT)) - -#define PROCEED_AFTER_PRIMITIVE() \ -{ \ - (Regs [REGBLOCK_PRIMITIVE]) = SHARP_F; \ - LOG_FUTURES (); \ -} - -/* - The EVAL/APPLY ying/yang - */ - - -interpreter_state_t interpreter_state = NULL_INTERPRETER_STATE; - -void -DEFUN (bind_interpreter_state, (s), interpreter_state_t s) -{ - (s -> previous_state) = interpreter_state; - (s -> nesting_level) = - ((interpreter_state == NULL_INTERPRETER_STATE) - ? 0 - : (1 + (interpreter_state -> nesting_level))); - (s -> dstack_position) = dstack_position; - interpreter_state = s; -} - -void -DEFUN (unbind_interpreter_state, (s), interpreter_state_t s) -{ - interpreter_state = s; - { - long old_mask = (FETCH_INTERRUPT_MASK ()); - SET_INTERRUPT_MASK (0); - dstack_set_position (s -> dstack_position); - SET_INTERRUPT_MASK (old_mask); - } - interpreter_state = (s -> previous_state); -} - -void -DEFUN (abort_to_interpreter, (argument), int argument) -{ - if (interpreter_state == NULL_INTERPRETER_STATE) - { - outf_fatal ("abort_to_interpreter: Interpreter not set up.\n"); - termination_init_error (); - } - - interpreter_throw_argument = argument; - { - long old_mask = (FETCH_INTERRUPT_MASK ()); - SET_INTERRUPT_MASK (0); - dstack_set_position (interpreter_catch_dstack_position); - SET_INTERRUPT_MASK (old_mask); - } - obstack_free ((&scratch_obstack), 0); - obstack_init (&scratch_obstack); - longjmp (interpreter_catch_env, argument); -} - -int -DEFUN_VOID (abort_to_interpreter_argument) -{ - return (interpreter_throw_argument); -} - -extern void EXFUN (Interpret, (Boolean)); - -void -DEFUN (Interpret, (pop_return_p), Boolean pop_return_p) -{ - long Which_Way; - fast SCHEME_OBJECT * Reg_Block, * Reg_Stack_Pointer, * Reg_History; - struct interpreter_state_s new_state; - extern long enter_compiled_expression(); - extern long apply_compiled_procedure(); - extern long return_to_compiled_code(); - - Reg_Block = &Registers[0]; - - /* 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. The code should do a primitive - * backout in these cases, but not in others (apply, eval, etc.), since - * the primitive itself will have left the state of the interpreter ready - * for operation. - */ - - bind_interpreter_state (&new_state); - preserve_signal_mask (); - Which_Way = (setjmp (interpreter_catch_env)); - Set_Time_Zone (Zone_Working); - Import_Registers (); - -Repeat_Dispatch: - switch (Which_Way) - { - case PRIM_APPLY: - PROCEED_AFTER_PRIMITIVE(); - case CODE_MAP(PRIM_APPLY): - goto Internal_Apply; - - case PRIM_NO_TRAP_APPLY: - PROCEED_AFTER_PRIMITIVE(); - case CODE_MAP(PRIM_NO_TRAP_APPLY): - goto Apply_Non_Trapping; - - case PRIM_DO_EXPRESSION: - Val = Fetch_Expression(); - PROCEED_AFTER_PRIMITIVE(); - case CODE_MAP(PRIM_DO_EXPRESSION): - Reduces_To(Val); - - case PRIM_NO_TRAP_EVAL: - Val = Fetch_Expression(); - PROCEED_AFTER_PRIMITIVE(); - case CODE_MAP(PRIM_NO_TRAP_EVAL): - New_Reduction(Val, Fetch_Env()); - goto Eval_Non_Trapping; - - case 0: /* first time */ - if (pop_return_p) - goto Pop_Return; - else - break; /* fall into eval */ - - case PRIM_POP_RETURN: - PROCEED_AFTER_PRIMITIVE(); - case CODE_MAP(PRIM_POP_RETURN): - goto Pop_Return; - - case PRIM_NO_TRAP_POP_RETURN: - PROCEED_AFTER_PRIMITIVE(); - case CODE_MAP(PRIM_NO_TRAP_POP_RETURN): - goto Pop_Return_Non_Trapping; - - case PRIM_REENTER: - BACK_OUT_AFTER_PRIMITIVE(); - LOG_FUTURES(); - case CODE_MAP(PRIM_REENTER): - goto Perform_Application; - - case PRIM_TOUCH: - { - SCHEME_OBJECT temp; - - temp = Val; - BACK_OUT_AFTER_PRIMITIVE(); - Val = temp; - LOG_FUTURES(); - } - /* fall through */ - case CODE_MAP(PRIM_TOUCH): - TOUCH_SETUP(Val); - goto Internal_Apply; - - case PRIM_INTERRUPT: - BACK_OUT_AFTER_PRIMITIVE(); - LOG_FUTURES(); - /* fall through */ - case CODE_MAP(PRIM_INTERRUPT): - Save_Cont(); - Interrupt(PENDING_INTERRUPTS()); - - case ERR_ARG_1_WRONG_TYPE: - BACK_OUT_AFTER_PRIMITIVE(); - LOG_FUTURES(); - /* fall through */ - case CODE_MAP(ERR_ARG_1_WRONG_TYPE): - ARG_TYPE_ERROR(1, ERR_ARG_1_WRONG_TYPE); - - case ERR_ARG_2_WRONG_TYPE: - BACK_OUT_AFTER_PRIMITIVE(); - LOG_FUTURES(); - /* fall through */ - case CODE_MAP(ERR_ARG_2_WRONG_TYPE): - ARG_TYPE_ERROR(2, ERR_ARG_2_WRONG_TYPE); - - case ERR_ARG_3_WRONG_TYPE: - BACK_OUT_AFTER_PRIMITIVE(); - LOG_FUTURES(); - /* fall through */ - case CODE_MAP(ERR_ARG_3_WRONG_TYPE): - ARG_TYPE_ERROR(3, ERR_ARG_3_WRONG_TYPE); - - default: - { - if (!CODE_MAPPED_P(Which_Way)) - { - BACK_OUT_AFTER_PRIMITIVE(); - LOG_FUTURES(); - } - else - { - Which_Way = CODE_UNMAP(Which_Way); - } - Pop_Return_Error(Which_Way); - } - } - -Do_Expression: - - if (0 && Eval_Debug) - { - Print_Expression ((Fetch_Expression ()), "Eval, expression"); - outf_console ("\n"); - } - -/* The expression register has an Scode 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 Scode 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. - */ - -/* 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 && - (! WITHIN_CRITICAL_SECTION_P()) && - ((Fetch_Eval_Trapper ()) != SHARP_F)) - { - Stop_Trapping (); - Will_Push (4); - STACK_PUSH (Fetch_Env ()); - STACK_PUSH (Fetch_Expression ()); - STACK_PUSH (Fetch_Eval_Trapper ()); - STACK_PUSH (STACK_FRAME_HEADER + 2); - Pushed (); - goto Apply_Non_Trapping; - } - -Eval_Non_Trapping: - Eval_Ucode_Hook(); - switch (OBJECT_TYPE (Fetch_Expression())) - { - default: -#if FALSE - Eval_Error(ERR_UNDEFINED_USER_TYPE); -#else - /* fall through to self evaluating. */ -#endif - - case TC_BIG_FIXNUM: /* The self evaluating items */ - case TC_BIG_FLONUM: - case TC_CHARACTER_STRING: - case TC_CHARACTER: - case TC_COMPILED_CODE_BLOCK: - case TC_COMPLEX: - case TC_CONTROL_POINT: - case TC_DELAYED: - case TC_ENTITY: - case TC_ENVIRONMENT: - case TC_EXTENDED_PROCEDURE: - case TC_FIXNUM: - case TC_HUNK3_A: - case TC_HUNK3_B: - case TC_INTERNED_SYMBOL: - case TC_LIST: - case TC_NON_MARKED_VECTOR: - case TC_NULL: - case TC_PRIMITIVE: - case TC_PROCEDURE: - case TC_QUAD: - case TC_RATNUM: - case TC_REFERENCE_TRAP: - case TC_RETURN_CODE: - case TC_UNINTERNED_SYMBOL: - case TC_TRUE: - case TC_VECTOR: - case TC_VECTOR_16B: - case TC_VECTOR_1B: - Val = Fetch_Expression(); - break; - - case TC_ACCESS: - Will_Push(CONTINUATION_SIZE); - Do_Nth_Then(RC_EXECUTE_ACCESS_FINISH, ACCESS_ENVIRONMENT, Pushed()); - - case TC_ASSIGNMENT: - Will_Push(CONTINUATION_SIZE + 1); - Save_Env(); - Do_Nth_Then(RC_EXECUTE_ASSIGNMENT_FINISH, ASSIGN_VALUE, Pushed()); - - case TC_BROKEN_HEART: - Export_Registers(); - Microcode_Termination (TERM_BROKEN_HEART); - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case TC_COMBINATION: - { - long Array_Length; - - Array_Length = (VECTOR_LENGTH (Fetch_Expression()) - 1); -#ifdef USE_STACKLETS - /* Save_Env, Finger */ - Eval_GC_Check - (New_Stacklet_Size (Array_Length + 1 + 1 + CONTINUATION_SIZE)); -#endif /* USE_STACKLETS */ - Will_Push(Array_Length + 1 + 1 + CONTINUATION_SIZE); - Stack_Pointer = (STACK_LOC (- Array_Length)); - STACK_PUSH (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, Array_Length)); - /* The finger: last argument number */ - Pushed(); - if (Array_Length == 0) - { - STACK_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: - Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 1); - Save_Env(); - Do_Nth_Then(RC_COMB_1_PROCEDURE, COMB_1_ARG_1, {}); - - case TC_COMBINATION_2: - Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 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: - Will_Push(CONTINUATION_SIZE + 1); - Save_Env(); - Do_Nth_Then(RC_CONDITIONAL_DECIDE, COND_PREDICATE, Pushed()); - - case TC_COMPILED_ENTRY: - { - SCHEME_OBJECT compiled_expression; - - compiled_expression = (Fetch_Expression ()); - execute_compiled_setup(); - Store_Expression (compiled_expression); - Export_Registers(); - Which_Way = enter_compiled_expression(); - goto return_from_compiled_code; - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case TC_DEFINITION: - Will_Push(CONTINUATION_SIZE + 1); - Save_Env(); - Do_Nth_Then(RC_EXECUTE_DEFINITION_FINISH, DEFINE_VALUE, Pushed()); - - case TC_DELAY: - /* Deliberately omitted: Eval_GC_Check(2); */ - Val = MAKE_POINTER_OBJECT (TC_DELAYED, Free); - Free[THUNK_ENVIRONMENT] = Fetch_Env(); - Free[THUNK_PROCEDURE] = - FAST_MEMORY_REF (Fetch_Expression(), DELAY_OBJECT); - Free += 2; - break; - - case TC_DISJUNCTION: - Will_Push(CONTINUATION_SIZE + 1); - Save_Env(); - Do_Nth_Then(RC_DISJUNCTION_DECIDE, OR_PREDICATE, Pushed()); - - case TC_EXTENDED_LAMBDA: /* Close the procedure */ - /* Deliberately omitted: Eval_GC_Check(2); */ - Val = MAKE_POINTER_OBJECT (TC_EXTENDED_PROCEDURE, Free); - Free[PROCEDURE_LAMBDA_EXPR] = Fetch_Expression(); - Free[PROCEDURE_ENVIRONMENT] = Fetch_Env(); - Free += 2; - break; - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - -#ifdef COMPILE_FUTURES - case TC_FUTURE: - if (Future_Has_Value(Fetch_Expression())) - { SCHEME_OBJECT Future = Fetch_Expression(); - if (Future_Is_Keep_Slot(Future)) Log_Touch_Of_Future(Future); - Reduces_To_Nth(FUTURE_VALUE); - } - Prepare_Eval_Repeat(); - Will_Push(STACK_ENV_EXTRA_SLOTS+2); - STACK_PUSH (Fetch_Expression()); /* Arg: FUTURE object */ - STACK_PUSH (Get_Fixed_Obj_Slot(System_Scheduler)); - STACK_PUSH (STACK_FRAME_HEADER+1); - Pushed(); - goto Internal_Apply; -#endif - - case TC_IN_PACKAGE: - Will_Push(CONTINUATION_SIZE); - Do_Nth_Then(RC_EXECUTE_IN_PACKAGE_CONTINUE, - IN_PACKAGE_ENVIRONMENT, Pushed()); - - case TC_LAMBDA: /* Close the procedure */ - case TC_LEXPR: - /* Deliberately omitted: Eval_GC_Check(2); */ - Val = MAKE_POINTER_OBJECT (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 */ - -/* Interpret(), continued */ - - /* - The argument to Will_Eventually_Push is determined by how much - will be on the stack if we back out of the primitive. - */ - - case TC_PCOMB0: - Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG); - Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG); - Store_Expression (OBJECT_NEW_TYPE (TC_PRIMITIVE, (Fetch_Expression ()))); - goto Primitive_Internal_Apply; - - case TC_PCOMB1: - Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 1); - Do_Nth_Then(RC_PCOMB1_APPLY, PCOMB1_ARG_SLOT, {}); - - case TC_PCOMB2: - Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 2); - Save_Env(); - Do_Nth_Then(RC_PCOMB2_DO_1, PCOMB2_ARG_2_SLOT, {}); - - case TC_PCOMB3: - Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 3); - Save_Env(); - Do_Nth_Then(RC_PCOMB3_DO_2, PCOMB3_ARG_3_SLOT, {}); - - case TC_SCODE_QUOTE: - Val = FAST_MEMORY_REF (Fetch_Expression(), SCODE_QUOTE_OBJECT); - break; - - case TC_SEQUENCE_2: - Will_Push(CONTINUATION_SIZE + 1); - Save_Env(); - Do_Nth_Then(RC_SEQ_2_DO_2, SEQUENCE_1, Pushed()); - - case TC_SEQUENCE_3: - Will_Push(CONTINUATION_SIZE + 1); - Save_Env(); - Do_Nth_Then(RC_SEQ_3_DO_2, SEQUENCE_1, Pushed()); - - case TC_THE_ENVIRONMENT: - Val = Fetch_Env(); break; - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case TC_VARIABLE: - { - long temp; - -#ifndef No_In_Line_Lookup - - fast SCHEME_OBJECT *cell; - - Set_Time_Zone(Zone_Lookup); - cell = OBJECT_ADDRESS (Fetch_Expression()); - lookup(cell, Fetch_Env(), cell, repeat_variable_lookup); - -lookup_end_restart: - - Val = MEMORY_FETCH (cell[0]); - if (OBJECT_TYPE (Val) != TC_REFERENCE_TRAP) - { - Set_Time_Zone(Zone_Working); - goto Pop_Return; - } - - get_trap_kind(temp, Val); - switch(temp) - { - case TRAP_DANGEROUS: - case TRAP_UNBOUND_DANGEROUS: - case TRAP_UNASSIGNED_DANGEROUS: - case TRAP_FLUID_DANGEROUS: - case TRAP_COMPILER_CACHED_DANGEROUS: - cell = OBJECT_ADDRESS (Fetch_Expression()); - temp = - deep_lookup_end(deep_lookup(Fetch_Env(), - cell[VARIABLE_SYMBOL], - cell), - cell); - Import_Val(); - if (temp != PRIM_DONE) - break; - Set_Time_Zone(Zone_Working); - goto Pop_Return; - - case TRAP_COMPILER_CACHED: - cell = MEMORY_LOC (FAST_MEMORY_REF (Val, TRAP_EXTRA), - TRAP_EXTENSION_CELL); - goto lookup_end_restart; - - case TRAP_FLUID: - cell = lookup_fluid(Val); - goto lookup_end_restart; - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case TRAP_UNBOUND: - temp = ERR_UNBOUND_VARIABLE; - break; - - case TRAP_UNASSIGNED: - temp = ERR_UNASSIGNED_VARIABLE; - break; - - default: - temp = ERR_ILLEGAL_REFERENCE_TRAP; - break; - } - -#else /* No_In_Line_Lookup */ - - Set_Time_Zone(Zone_Lookup); - temp = Lex_Ref(Fetch_Env(), Fetch_Expression()); - Import_Val(); - if (temp == PRIM_DONE) - goto Pop_Return; - -#endif /* No_In_Line_Lookup */ - - /* Back out of the evaluation. */ - - Set_Time_Zone(Zone_Working); - - if (temp == PRIM_INTERRUPT) - { - Prepare_Eval_Repeat(); - Interrupt(PENDING_INTERRUPTS()); - } - - Eval_Error(temp); - } - - SITE_EXPRESSION_DISPATCH_HOOK() - }; - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - -/* Now restore the continuation saved during an earlier part - * of the EVAL cycle and continue as directed. - */ - -Pop_Return: - if (Microcode_Does_Stepping && - Trapping && - (! WITHIN_CRITICAL_SECTION_P()) && - ((Fetch_Return_Trapper ()) != SHARP_F)) - { - Will_Push(3); - Stop_Trapping(); - STACK_PUSH (Val); - STACK_PUSH (Fetch_Return_Trapper()); - STACK_PUSH (STACK_FRAME_HEADER+1); - Pushed(); - goto Apply_Non_Trapping; - } -Pop_Return_Non_Trapping: - Pop_Return_Ucode_Hook(); - Restore_Cont(); - if (Consistency_Check && - (OBJECT_TYPE (Fetch_Return()) != TC_RETURN_CODE)) - { STACK_PUSH (Val); /* For possible stack trace */ - Save_Cont(); - Export_Registers(); - Microcode_Termination (TERM_BAD_STACK); - } - if (0 && Eval_Debug) - { - Print_Return ("Pop_Return, return code"); - Print_Expression (Val, "Pop_Return, value"); - outf_console ("\n"); - }; - - /* Dispatch on the return code. A BREAK here will cause - * a "goto Pop_Return" to occur, since this is the most - * common occurrence. - */ - - switch (OBJECT_DATUM (Fetch_Return())) - { - case RC_COMB_1_PROCEDURE: - Restore_Env(); - STACK_PUSH (Val); /* Arg. 1 */ - STACK_PUSH (SHARP_F); /* Operator */ - STACK_PUSH (STACK_FRAME_HEADER + 1); - Finished_Eventual_Pushing(CONTINUATION_SIZE); - Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_1_FN); - - case RC_COMB_2_FIRST_OPERAND: - Restore_Env(); - STACK_PUSH (Val); - Save_Env(); - Do_Another_Then(RC_COMB_2_PROCEDURE, COMB_2_ARG_1); - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_COMB_2_PROCEDURE: - Restore_Env(); - STACK_PUSH (Val); /* Arg 1, just calculated */ - STACK_PUSH (SHARP_F); /* Function */ - STACK_PUSH (STACK_FRAME_HEADER + 2); - Finished_Eventual_Pushing(CONTINUATION_SIZE); - Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_2_FN); - - case RC_COMB_APPLY_FUNCTION: - End_Subproblem(); - goto Internal_Apply_Val; - - case RC_COMB_SAVE_VALUE: - { long Arg_Number; - - Restore_Env(); - Arg_Number = OBJECT_DATUM (STACK_REF(STACK_COMB_FINGER))-1; - STACK_REF(STACK_COMB_FIRST_ARG+Arg_Number) = Val; - STACK_REF(STACK_COMB_FINGER) = - MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, Arg_Number); - /* DO NOT count on the type code being NMVector here, since - the stack parser may create them with #F here! */ - if (Arg_Number > 0) - { Save_Env(); - Do_Another_Then(RC_COMB_SAVE_VALUE, - (COMB_ARG_1_SLOT - 1) + Arg_Number); - } - STACK_PUSH (FAST_MEMORY_REF (Fetch_Expression(), 0)); /* Frame Size */ - Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT); - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - -#define define_compiler_restart(return_code, entry) \ - case return_code: \ - { \ - extern long entry(); \ - compiled_code_restart(); \ - Export_Registers(); \ - Which_Way = entry(); \ - goto return_from_compiled_code; \ - } - - define_compiler_restart (RC_COMP_INTERRUPT_RESTART, - comp_interrupt_restart) - - define_compiler_restart (RC_COMP_LOOKUP_APPLY_RESTART, - comp_lookup_apply_restart) - - define_compiler_restart (RC_COMP_REFERENCE_RESTART, - comp_reference_restart) - - define_compiler_restart (RC_COMP_ACCESS_RESTART, - comp_access_restart) - - define_compiler_restart (RC_COMP_UNASSIGNED_P_RESTART, - comp_unassigned_p_restart) - - define_compiler_restart (RC_COMP_UNBOUND_P_RESTART, - comp_unbound_p_restart) - - define_compiler_restart (RC_COMP_ASSIGNMENT_RESTART, - comp_assignment_restart) - - define_compiler_restart (RC_COMP_DEFINITION_RESTART, - comp_definition_restart) - - define_compiler_restart (RC_COMP_SAFE_REFERENCE_RESTART, - comp_safe_reference_restart) - - define_compiler_restart (RC_COMP_LOOKUP_TRAP_RESTART, - comp_lookup_trap_restart) - - define_compiler_restart (RC_COMP_ASSIGNMENT_TRAP_RESTART, - comp_assignment_trap_restart) - - define_compiler_restart (RC_COMP_OP_REF_TRAP_RESTART, - comp_op_lookup_trap_restart) - - define_compiler_restart (RC_COMP_CACHE_REF_APPLY_RESTART, - comp_cache_lookup_apply_restart) - - define_compiler_restart (RC_COMP_SAFE_REF_TRAP_RESTART, - comp_safe_lookup_trap_restart) - - define_compiler_restart (RC_COMP_UNASSIGNED_TRAP_RESTART, - comp_unassigned_p_trap_restart) - - define_compiler_restart (RC_COMP_LINK_CACHES_RESTART, - comp_link_caches_restart) - - define_compiler_restart (RC_COMP_ERROR_RESTART, - comp_error_restart) - - case RC_REENTER_COMPILED_CODE: - compiled_code_restart(); - Export_Registers(); - Which_Way = return_to_compiled_code(); - goto return_from_compiled_code; - - case RC_CONDITIONAL_DECIDE: - Pop_Return_Val_Check(); - End_Subproblem(); - Restore_Env(); - Reduces_To_Nth ((Val == SHARP_F) ? COND_ALTERNATIVE : COND_CONSEQUENT); - - case RC_DISJUNCTION_DECIDE: - /* Return predicate if it isn't #F; else do ALTERNATIVE */ - Pop_Return_Val_Check(); - End_Subproblem(); - Restore_Env(); - if (Val != SHARP_F) goto Pop_Return; - Reduces_To_Nth(OR_ALTERNATIVE); - - case RC_END_OF_COMPUTATION: - { - /* Signals bottom of stack */ - - interpreter_state_t previous_state; - - previous_state = interpreter_state->previous_state; - Export_Registers(); - if (previous_state == NULL_INTERPRETER_STATE) - { - termination_end_of_computation (); - /*NOTREACHED*/ - } - else - { - dstack_position = interpreter_catch_dstack_position; - interpreter_state = previous_state; - return; - } - } - - case RC_EVAL_ERROR: - /* Should be called RC_REDO_EVALUATION. */ - Store_Env(STACK_POP ()); - Reduces_To(Fetch_Expression()); - - case RC_EXECUTE_ACCESS_FINISH: - { - long Result; - SCHEME_OBJECT value; - - Pop_Return_Val_Check(); - value = Val; - - if (ENVIRONMENT_P (Val)) - { Result = Symbol_Lex_Ref(value, - FAST_MEMORY_REF (Fetch_Expression(), - ACCESS_NAME)); - Import_Val(); - if (Result == PRIM_DONE) - { - End_Subproblem(); - break; - } - if (Result != PRIM_INTERRUPT) - { - Val = value; - Pop_Return_Error(Result); - } - Prepare_Pop_Return_Interrupt(RC_EXECUTE_ACCESS_FINISH, value); - Interrupt(PENDING_INTERRUPTS()); - } - Val = value; - Pop_Return_Error(ERR_BAD_FRAME); - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_EXECUTE_ASSIGNMENT_FINISH: - { - long temp; - SCHEME_OBJECT value; - Lock_Handle set_serializer; - -#ifndef No_In_Line_Lookup - - SCHEME_OBJECT bogus_unassigned; - fast SCHEME_OBJECT *cell; - - Set_Time_Zone(Zone_Lookup); - Restore_Env(); - cell = OBJECT_ADDRESS (MEMORY_REF (Fetch_Expression(), ASSIGN_NAME)); - lookup(cell, Fetch_Env(), cell, repeat_assignment_lookup); - - value = Val; - bogus_unassigned = Get_Fixed_Obj_Slot(Non_Object); - if (value == bogus_unassigned) - value = UNASSIGNED_OBJECT; - -assignment_end_before_lock: - - setup_lock(set_serializer, cell); - -assignment_end_after_lock: - - Val = *cell; - - if (OBJECT_TYPE (*cell) != TC_REFERENCE_TRAP) - { -normal_assignment_done: - *cell = value; - remove_lock(set_serializer); - Set_Time_Zone(Zone_Working); - End_Subproblem(); - goto Pop_Return; - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - get_trap_kind(temp, *cell); - switch(temp) - { - case TRAP_DANGEROUS: - case TRAP_UNBOUND_DANGEROUS: - case TRAP_UNASSIGNED_DANGEROUS: - case TRAP_FLUID_DANGEROUS: - case TRAP_COMPILER_CACHED_DANGEROUS: - remove_lock(set_serializer); - cell = OBJECT_ADDRESS (MEMORY_REF (Fetch_Expression(), ASSIGN_NAME)); - temp = - deep_assignment_end(deep_lookup(Fetch_Env(), - cell[VARIABLE_SYMBOL], - cell), - cell, - value, - false); -external_assignment_return: - Import_Val(); - if (temp != PRIM_DONE) - break; - Set_Time_Zone(Zone_Working); - End_Subproblem(); - goto Pop_Return; - - case TRAP_COMPILER_CACHED: - { - SCHEME_OBJECT extension, references; - - extension = FAST_MEMORY_REF (Val, TRAP_EXTRA); - references = FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES); - - if ((FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR)) - != SHARP_F) - { - - /* There are uuo links. - wimp out and let deep_assignment_end handle it. - */ - - remove_lock(set_serializer); - temp = deep_assignment_end(cell, - fake_variable_object, - value, - false); - goto external_assignment_return; - } - cell = MEMORY_LOC (extension, TRAP_EXTENSION_CELL); - update_lock(set_serializer, cell); - goto assignment_end_after_lock; - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case TRAP_FLUID: - remove_lock(set_serializer); - cell = lookup_fluid(Val); - goto assignment_end_before_lock; - - case TRAP_UNBOUND: - remove_lock(set_serializer); - temp = ERR_UNBOUND_VARIABLE; - break; - - case TRAP_UNASSIGNED: - Val = bogus_unassigned; - goto normal_assignment_done; - - default: - remove_lock(set_serializer); - temp = ERR_ILLEGAL_REFERENCE_TRAP; - break; - } - - if (value == UNASSIGNED_OBJECT) - value = bogus_unassigned; - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - -#else /* No_In_Line_Lookup */ - - value = Val; - Set_Time_Zone(Zone_Lookup); - Restore_Env(); - temp = Lex_Set(Fetch_Env(), - MEMORY_REF (Fetch_Expression(), ASSIGN_NAME), - value); - Import_Val(); - if (temp == PRIM_DONE) - { - End_Subproblem(); - Set_Time_Zone(Zone_Working); - break; - } - -#endif /* No_In_Line_Lookup */ - - Set_Time_Zone(Zone_Working); - Save_Env(); - if (temp != PRIM_INTERRUPT) - { - Val = value; - Pop_Return_Error(temp); - } - - Prepare_Pop_Return_Interrupt(RC_EXECUTE_ASSIGNMENT_FINISH, - value); - Interrupt(PENDING_INTERRUPTS()); - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_EXECUTE_DEFINITION_FINISH: - { - SCHEME_OBJECT value; - long result; - - value = Val; - Restore_Env(); - Export_Registers(); - result = Local_Set(Fetch_Env(), - FAST_MEMORY_REF (Fetch_Expression(), DEFINE_NAME), - Val); - Import_Registers(); - if (result == PRIM_DONE) - { - End_Subproblem(); - break; - } - Save_Env(); - if (result == PRIM_INTERRUPT) - { - Prepare_Pop_Return_Interrupt(RC_EXECUTE_DEFINITION_FINISH, - value); - Interrupt(PENDING_INTERRUPTS()); - } - Val = value; - 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); - - case RC_HARDWARE_TRAP: - { - /* This just reinvokes the handler */ - - SCHEME_OBJECT info, handler; - info = (STACK_REF (0)); - - Save_Cont(); - if ((! (Valid_Fixed_Obj_Vector())) || - ((handler = (Get_Fixed_Obj_Slot(Trap_Handler))) == SHARP_F)) - { - outf_fatal ("There is no trap handler for recovery!\n"); - termination_trap (); - /*NOTREACHED*/ - } - Will_Push(STACK_ENV_EXTRA_SLOTS + 2); - STACK_PUSH (info); - STACK_PUSH (handler); - STACK_PUSH (STACK_FRAME_HEADER + 1); - Pushed(); - goto Internal_Apply; - } - -/* Internal_Apply, the core of the application mechanism. - - Branch here to perform a function application. - - At this point the top of the stack contains an application frame - which consists of the following elements (see sdata.h): - - A header specifying the frame length. - - A procedure. - - The actual (evaluated) arguments. - - No registers (except the stack pointer) are meaning full at this point. - Before interrupts or errors are processed, some registers are cleared - to avoid holding onto garbage if a garbage collection occurs. -*/ - -#define Prepare_Apply_Interrupt() \ -{ \ - Store_Expression (SHARP_F); \ - Prepare_Pop_Return_Interrupt (RC_INTERNAL_APPLY_VAL, \ - (STACK_REF (STACK_ENV_FUNCTION))); \ -} - -#define Apply_Error(N) \ -{ \ - Store_Expression (SHARP_F); \ - Store_Return (RC_INTERNAL_APPLY_VAL); \ - Val = (STACK_REF (STACK_ENV_FUNCTION)); \ - Pop_Return_Error (N); \ -} - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_INTERNAL_APPLY_VAL: -Internal_Apply_Val: - - STACK_REF (STACK_ENV_FUNCTION) = Val; - - case RC_INTERNAL_APPLY: -Internal_Apply: - - if (Microcode_Does_Stepping && - Trapping && - (! WITHIN_CRITICAL_SECTION_P()) && - ((Fetch_Apply_Trapper ()) != SHARP_F)) - { - long Count; - - Count = (OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER))); - (* (STACK_LOC (0))) = (Fetch_Apply_Trapper ()); - STACK_PUSH (STACK_FRAME_HEADER + Count); - Stop_Trapping (); - } - -Apply_Non_Trapping: - - if ((PENDING_INTERRUPTS()) != 0) - { - long Interrupts; - - Interrupts = (PENDING_INTERRUPTS()); - Prepare_Apply_Interrupt (); - Interrupt(Interrupts); - } - -Perform_Application: - - Apply_Ucode_Hook(); - - { - fast SCHEME_OBJECT Function, orig_proc; - - Apply_Future_Check (Function, (STACK_REF (STACK_ENV_FUNCTION))); - orig_proc = Function; - -apply_dispatch: - switch (OBJECT_TYPE (Function)) - { - case TC_ENTITY: - { - fast long nargs, nactuals; - SCHEME_OBJECT data; - - /* Will_Pushed ommited since frame must be contiguous. - combination code must ensure one more slot. - */ - - /* This code assumes that adding 1 to nactuals takes care - of everything, including type code, etc. - */ - - nargs = (STACK_POP ()); - nactuals = (OBJECT_DATUM (nargs)); - data = (MEMORY_REF (Function, ENTITY_DATA)); - if ((VECTOR_P (data)) - && (nactuals < (VECTOR_LENGTH (data))) - && ((VECTOR_REF (data, nactuals)) != SHARP_F) - && ((VECTOR_REF (data, 0)) - == (Get_Fixed_Obj_Slot (ARITY_DISPATCHER_TAG)))) - { - SCHEME_OBJECT nproc = (VECTOR_REF (data, nactuals)); - - if ((Function == orig_proc) && (nproc != Function)) - { - Function = nproc; - STACK_PUSH (nargs); - STACK_REF (STACK_ENV_FUNCTION) = nproc; - goto apply_dispatch; - } - else - { - Function = orig_proc; - STACK_REF (STACK_ENV_FUNCTION - 1) = orig_proc; - } - } - - STACK_PUSH (FAST_MEMORY_REF (Function, ENTITY_OPERATOR)); - STACK_PUSH (nargs + 1); - /* This must be done to prevent an infinite push loop by - an entity whose handler is the entity itself or some - other such loop. Of course, it will die if stack overflow - interrupts are disabled. - */ - Stack_Check (Stack_Pointer); - goto Internal_Apply; - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case TC_RECORD: - { - SCHEME_OBJECT record_type = (VECTOR_REF (Function, 0)); - if ((RECORD_P (record_type)) - && ((OBJECT_TYPE (FAST_MEMORY_REF (record_type, 0))) - == TC_TRUE) - && ((VECTOR_LENGTH (record_type)) >= 2) - && ((VECTOR_REF (record_type, 1)) != SHARP_F) - && ((VECTOR_REF (record_type, 1)) != Function)) - { - SCHEME_OBJECT nargs_object = (STACK_POP ()); - STACK_PUSH (VECTOR_REF (record_type, 1)); - STACK_PUSH - (MAKE_OBJECT ((OBJECT_TYPE (nargs_object)), - ((OBJECT_DATUM (nargs_object)) + 1))); - Stack_Check (Stack_Pointer); - goto Internal_Apply; - } - else - goto internal_apply_inapplicable; - } - - case TC_PROCEDURE: - { - fast long nargs; - - nargs = OBJECT_DATUM (STACK_POP ()); - Function = FAST_MEMORY_REF (Function, PROCEDURE_LAMBDA_EXPR); - - { - fast SCHEME_OBJECT formals; - - Apply_Future_Check(formals, - FAST_MEMORY_REF (Function, LAMBDA_FORMALS)); - - if ((nargs != VECTOR_LENGTH (formals)) && - ((OBJECT_TYPE (Function) != TC_LEXPR) || - (nargs < VECTOR_LENGTH (formals)))) - { - STACK_PUSH (STACK_FRAME_HEADER + nargs - 1); - Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); - } - } - - if (0 && Eval_Debug) - { - Print_Expression(LONG_TO_UNSIGNED_FIXNUM(nargs), - "APPLY: Number of arguments"); - } - - if (GC_Check(nargs + 1)) - { - STACK_PUSH (STACK_FRAME_HEADER + nargs - 1); - Prepare_Apply_Interrupt (); - Immediate_GC(nargs + 1); - } - - { - fast SCHEME_OBJECT *scan; - fast SCHEME_OBJECT temp; - - scan = Free; - temp = (MAKE_POINTER_OBJECT (TC_ENVIRONMENT, scan)); - *scan++ = MAKE_OBJECT (TC_MANIFEST_VECTOR, nargs); - while(--nargs >= 0) - *scan++ = (STACK_POP ()); - Free = scan; - Store_Env(temp); - Reduces_To(FAST_MEMORY_REF (Function, LAMBDA_SCODE)); - } - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case TC_CONTROL_POINT: - { - if (OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER)) != - STACK_ENV_FIRST_ARG) - { - Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); - } - Val = (STACK_REF (STACK_ENV_FIRST_ARG)); - Our_Throw(false, Function); - Apply_Stacklet_Backout(); - Our_Throw_Part_2(); - goto Pop_Return; - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - /* - After checking the number of arguments, remove the - frame header since primitives do not expect it. - - NOTE: This code must match the application code which - follows Primitive_Internal_Apply. - */ - - case TC_PRIMITIVE: - { - fast long nargs; - - if (!IMPLEMENTED_PRIMITIVE_P(Function)) - { - Apply_Error(ERR_UNIMPLEMENTED_PRIMITIVE); - } - - /* Note that the first test below will fail for lexpr - primitives. */ - - nargs = ((OBJECT_DATUM (STACK_REF(STACK_ENV_HEADER))) - - (STACK_ENV_FIRST_ARG - 1)); - if (nargs != PRIMITIVE_ARITY(Function)) - { - if (PRIMITIVE_ARITY(Function) != LEXPR_PRIMITIVE_ARITY) - { - Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); - } - Regs[REGBLOCK_LEXPR_ACTUALS] = ((SCHEME_OBJECT) nargs); - } - - Stack_Pointer = (STACK_LOC (STACK_ENV_FIRST_ARG)); - Store_Expression (Function); - EXPORT_REGS_BEFORE_PRIMITIVE (); - PRIMITIVE_APPLY (Val, Function); - IMPORT_REGS_AFTER_PRIMITIVE (); - POP_PRIMITIVE_FRAME (nargs); - if (Must_Report_References()) - { - Store_Expression(Val); - Store_Return(RC_RESTORE_VALUE); - Save_Cont(); - Call_Future_Logging(); - } - goto Pop_Return; - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case TC_EXTENDED_PROCEDURE: - { - SCHEME_OBJECT lambda, temp; - long nargs, nparams, formals, params, auxes, - rest_flag, size; - - fast long i; - fast SCHEME_OBJECT *scan; - - nargs = OBJECT_DATUM (STACK_POP ()) - STACK_FRAME_HEADER; - - if (0 && Eval_Debug) - { - Print_Expression - (LONG_TO_UNSIGNED_FIXNUM (nargs+STACK_FRAME_HEADER), - "APPLY: Number of arguments"); - } - - lambda = FAST_MEMORY_REF (Function, PROCEDURE_LAMBDA_EXPR); - Apply_Future_Check(Function, - FAST_MEMORY_REF (lambda, ELAMBDA_NAMES)); - nparams = VECTOR_LENGTH (Function) - 1; - - Apply_Future_Check(Function, Get_Count_Elambda(lambda)); - formals = Elambda_Formals_Count(Function); - params = Elambda_Opts_Count(Function) + formals; - rest_flag = Elambda_Rest_Flag(Function); - auxes = nparams - (params + rest_flag); - - if ((nargs < formals) || (!rest_flag && (nargs > params))) - { - STACK_PUSH (STACK_FRAME_HEADER + nargs); - Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); - } - - /* size includes the procedure slot, but not the header. */ - size = params + rest_flag + auxes + 1; - if (GC_Check(size + 1 + ((nargs > params) ? - (2 * (nargs - params)) : - 0))) - { - STACK_PUSH (STACK_FRAME_HEADER + nargs); - Prepare_Apply_Interrupt (); - Immediate_GC(size + 1 + ((nargs > params) ? - (2 * (nargs - params)) : - 0)); - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - scan = Free; - temp = (MAKE_POINTER_OBJECT (TC_ENVIRONMENT, scan)); - *scan++ = MAKE_OBJECT (TC_MANIFEST_VECTOR, size); - - if (nargs <= params) - { - for (i = (nargs + 1); --i >= 0; ) - *scan++ = (STACK_POP ()); - for (i = (params - nargs); --i >= 0; ) - *scan++ = UNASSIGNED_OBJECT; - if (rest_flag) - *scan++ = EMPTY_LIST; - for (i = auxes; --i >= 0; ) - *scan++ = UNASSIGNED_OBJECT; - } - else - { - /* rest_flag must be true. */ - SCHEME_OBJECT list; - - list = MAKE_POINTER_OBJECT (TC_LIST, (scan + size)); - for (i = (params + 1); --i >= 0; ) - *scan++ = (STACK_POP ()); - *scan++ = list; - for (i = auxes; --i >= 0; ) - *scan++ = UNASSIGNED_OBJECT; - /* Now scan == OBJECT_ADDRESS (list) */ - for (i = (nargs - params); --i >= 0; ) - { - *scan++ = (STACK_POP ()); - *scan = MAKE_POINTER_OBJECT (TC_LIST, (scan + 1)); - scan += 1; - } - scan[-1] = EMPTY_LIST; - } - - Free = scan; - Store_Env (temp); - Reduces_To(Get_Body_Elambda(lambda)); - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case TC_COMPILED_ENTRY: - { - apply_compiled_setup - (STACK_ENV_EXTRA_SLOTS + - (OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER)))); - Export_Registers (); - Which_Way = apply_compiled_procedure(); - -return_from_compiled_code: - Import_Registers (); - switch (Which_Way) - { - case PRIM_DONE: - { - compiled_code_done (); - goto Pop_Return; - } - - case PRIM_APPLY: - { - compiler_apply_procedure - (STACK_ENV_EXTRA_SLOTS + - OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER))); - goto Internal_Apply; - } - - case PRIM_INTERRUPT: - { - compiled_error_backout (); - Save_Cont (); - Interrupt (PENDING_INTERRUPTS ()); - } - - case PRIM_APPLY_INTERRUPT: - { - apply_compiled_backout (); - Prepare_Apply_Interrupt (); - Interrupt (PENDING_INTERRUPTS ()); - } - - case ERR_INAPPLICABLE_OBJECT: - /* This error code means that apply_compiled_procedure - was called on an object which is not a compiled procedure, - or it was called in a system without compiler support. - - Fall through... - */ - - case ERR_WRONG_NUMBER_OF_ARGUMENTS: - { - apply_compiled_backout (); - Apply_Error (Which_Way); - } - - case ERR_EXECUTE_MANIFEST_VECTOR: - { - /* This error code means that enter_compiled_expression - was called in a system without compiler support. - This is a kludge! - */ - - execute_compiled_backout (); - Val = - (OBJECT_NEW_TYPE (TC_COMPILED_ENTRY, (Fetch_Expression ()))); - Pop_Return_Error (Which_Way); - } - - case ERR_INAPPLICABLE_CONTINUATION: - { - /* This error code means that return_to_compiled_code - saw a non-continuation on the stack, or was called - in a system without compiler support. - */ - - Store_Expression (SHARP_F); - Store_Return (RC_REENTER_COMPILED_CODE); - Pop_Return_Error (Which_Way); - } - - default: - compiled_error_backout (); - Pop_Return_Error (Which_Way); - } - } - - default: - internal_apply_inapplicable: - Apply_Error (ERR_INAPPLICABLE_OBJECT); - } /* End of switch in RC_INTERNAL_APPLY */ - } /* End of RC_INTERNAL_APPLY case */ - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_MOVE_TO_ADJACENT_POINT: - /* Expression contains the space in which we are moving */ - { - long From_Count; - SCHEME_OBJECT Thunk, New_Location; - - From_Count = - (UNSIGNED_FIXNUM_TO_LONG (STACK_REF (TRANSLATE_FROM_DISTANCE))); - if (From_Count != 0) - { SCHEME_OBJECT Current = STACK_REF(TRANSLATE_FROM_POINT); - STACK_REF(TRANSLATE_FROM_DISTANCE) = - (LONG_TO_UNSIGNED_FIXNUM (From_Count - 1)); - Thunk = FAST_MEMORY_REF (Current, STATE_POINT_AFTER_THUNK); - New_Location = FAST_MEMORY_REF (Current, STATE_POINT_NEARER_POINT); - STACK_REF(TRANSLATE_FROM_POINT) = New_Location; - if ((From_Count == 1) && - (STACK_REF(TRANSLATE_TO_DISTANCE) == LONG_TO_UNSIGNED_FIXNUM(0))) - Stack_Pointer = (STACK_LOC (4)); - else Save_Cont(); - } - else - { - long To_Count; - fast SCHEME_OBJECT To_Location; - fast long i; - - To_Count = - (UNSIGNED_FIXNUM_TO_LONG (STACK_REF (TRANSLATE_TO_DISTANCE)) - 1); - To_Location = STACK_REF(TRANSLATE_TO_POINT); - for (i = 0; i < To_Count; i++) - { - To_Location = - (FAST_MEMORY_REF (To_Location, STATE_POINT_NEARER_POINT)); - } - Thunk = FAST_MEMORY_REF (To_Location, STATE_POINT_BEFORE_THUNK); - New_Location = To_Location; - STACK_REF(TRANSLATE_TO_DISTANCE) = LONG_TO_UNSIGNED_FIXNUM(To_Count); - if (To_Count == 0) - { - Stack_Pointer = (STACK_LOC (4)); - } - else - { - Save_Cont(); - } - } - if ((Fetch_Expression ()) != SHARP_F) - { - MEMORY_SET - ((Fetch_Expression ()), STATE_SPACE_NEAREST_POINT, New_Location); - } - else - { - Current_State_Point = New_Location; - } - Will_Push(2); - STACK_PUSH (Thunk); - STACK_PUSH (STACK_FRAME_HEADER); - Pushed(); - goto Internal_Apply; - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_INVOKE_STACK_THREAD: - /* Used for WITH_THREADED_STACK primitive */ - Will_Push(3); - STACK_PUSH (Val); /* Value calculated by thunk */ - STACK_PUSH (Fetch_Expression()); - STACK_PUSH (STACK_FRAME_HEADER+1); - Pushed(); - goto Internal_Apply; - - case RC_JOIN_STACKLETS: - Our_Throw(true, Fetch_Expression()); - Join_Stacklet_Backout(); - Our_Throw_Part_2(); - break; - - case RC_NORMAL_GC_DONE: - Val = (Fetch_Expression ()); - if (GC_Space_Needed < 0) - { - /* Paranoia */ - - GC_Space_Needed = 0; - } - if (GC_Check (GC_Space_Needed)) - termination_gc_out_of_space (); - GC_Space_Needed = 0; - EXIT_CRITICAL_SECTION ({ Save_Cont(); Export_Registers(); }); - End_GC_Hook (); - break; - - case RC_PCOMB1_APPLY: - End_Subproblem(); - STACK_PUSH (Val); /* Argument value */ - Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG); - Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), PCOMB1_FN_SLOT)); - -Primitive_Internal_Apply: - if (Microcode_Does_Stepping && - Trapping && - (! WITHIN_CRITICAL_SECTION_P()) && - ((Fetch_Apply_Trapper ()) != SHARP_F)) - { - /* Does this work in the stacklet case? - We may have a non-contiguous frame. -- Jinx - */ - Will_Push(3); - STACK_PUSH (Fetch_Expression()); - STACK_PUSH (Fetch_Apply_Trapper()); - STACK_PUSH (STACK_FRAME_HEADER + 1 + - PRIMITIVE_N_PARAMETERS(Fetch_Expression())); - Pushed(); - Stop_Trapping(); - goto Apply_Non_Trapping; - } - - /* NOTE: This code must match the code in the TC_PRIMITIVE - case of Internal_Apply. - This code is simpler because: - 1) The arity was checked at syntax time. - 2) We don't have to deal with "lexpr" primitives. - 3) We don't need to worry about unimplemented primitives because - unimplemented primitives will cause an error at invocation. - */ - - { - fast SCHEME_OBJECT primitive = (Fetch_Expression ()); - EXPORT_REGS_BEFORE_PRIMITIVE (); - PRIMITIVE_APPLY (Val, primitive); - IMPORT_REGS_AFTER_PRIMITIVE (); - POP_PRIMITIVE_FRAME (PRIMITIVE_ARITY (primitive)); - if (Must_Report_References ()) - { - Store_Expression (Val); - Store_Return (RC_RESTORE_VALUE); - Save_Cont (); - Call_Future_Logging (); - } - break; - } - - case RC_PCOMB2_APPLY: - End_Subproblem(); - STACK_PUSH (Val); /* Value of arg. 1 */ - Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG); - Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), PCOMB2_FN_SLOT)); - goto Primitive_Internal_Apply; - - case RC_PCOMB2_DO_1: - Restore_Env(); - STACK_PUSH (Val); /* Save value of arg. 2 */ - Do_Another_Then(RC_PCOMB2_APPLY, PCOMB2_ARG_1_SLOT); - - case RC_PCOMB3_APPLY: - End_Subproblem(); - STACK_PUSH (Val); /* Save value of arg. 1 */ - Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG); - Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), PCOMB3_FN_SLOT)); - goto Primitive_Internal_Apply; - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_PCOMB3_DO_1: - { - SCHEME_OBJECT Temp; - - Temp = (STACK_POP ()); /* Value of arg. 3 */ - Restore_Env(); - STACK_PUSH (Temp); /* Save arg. 3 again */ - STACK_PUSH (Val); /* Save arg. 2 */ - Do_Another_Then(RC_PCOMB3_APPLY, PCOMB3_ARG_1_SLOT); - } - - case RC_PCOMB3_DO_2: - Restore_Then_Save_Env(); - STACK_PUSH (Val); /* Save value of arg. 3 */ - Do_Another_Then(RC_PCOMB3_DO_1, PCOMB3_ARG_2_SLOT); - - case RC_POP_RETURN_ERROR: - case RC_RESTORE_VALUE: - Val = Fetch_Expression(); - break; - - case RC_PRIMITIVE_CONTINUE: - Export_Registers (); - Val = (continue_primitive ()); - Import_Registers (); - break; - - case RC_REPEAT_DISPATCH: - Which_Way = (FIXNUM_TO_LONG (Fetch_Expression ())); - Restore_Env(); - Val = (STACK_POP ()); - Restore_Cont(); - goto Repeat_Dispatch; - -/* Interpret() continues on the next page */ - -/* 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: - { - SCHEME_OBJECT Stacklet; - - Prev_Restore_History_Offset = OBJECT_DATUM (STACK_POP ()); - Stacklet = (STACK_POP ()); - History = OBJECT_ADDRESS (Fetch_Expression()); - if (Prev_Restore_History_Offset == 0) - { - Prev_Restore_History_Stacklet = NULL; - } - else if (Stacklet == SHARP_F) - { - Prev_Restore_History_Stacklet = NULL; - } - else - { - Prev_Restore_History_Stacklet = OBJECT_ADDRESS (Stacklet); - } - break; - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_RESTORE_HISTORY: - { - SCHEME_OBJECT Stacklet; - - Export_Registers(); - if (! Restore_History(Fetch_Expression())) - { - Import_Registers(); - Save_Cont(); - Will_Push(CONTINUATION_SIZE); - Store_Expression(Val); - Store_Return(RC_RESTORE_VALUE); - Save_Cont(); - Pushed(); - Immediate_GC((Free > MemTop) ? 0 : ((MemTop-Free)+1)); - } - Import_Registers(); - Prev_Restore_History_Offset = OBJECT_DATUM (STACK_POP ()); - Stacklet = (STACK_POP ()); - if (Prev_Restore_History_Offset == 0) - Prev_Restore_History_Stacklet = NULL; - else - { if (Stacklet == SHARP_F) - { Prev_Restore_History_Stacklet = NULL; - Get_End_Of_Stacklet()[-Prev_Restore_History_Offset] = - MAKE_OBJECT (TC_RETURN_CODE, RC_RESTORE_HISTORY); - } - else - { Prev_Restore_History_Stacklet = OBJECT_ADDRESS (Stacklet); - Prev_Restore_History_Stacklet[-Prev_Restore_History_Offset] = - MAKE_OBJECT (TC_RETURN_CODE, RC_RESTORE_HISTORY); - } - } - break; - } - - case RC_RESTORE_FLUIDS: - Fluid_Bindings = Fetch_Expression(); - break; - - case RC_RESTORE_INT_MASK: - SET_INTERRUPT_MASK (UNSIGNED_FIXNUM_TO_LONG (Fetch_Expression())); - if (GC_Check (0)) - Request_GC (0); - if ((PENDING_INTERRUPTS ()) != 0) - { - Store_Return (RC_RESTORE_VALUE); - Store_Expression (Val); - Save_Cont (); - Interrupt (PENDING_INTERRUPTS ()); - } - break; - - case RC_STACK_MARKER: - /* Frame consists of the return code followed by two objects. - The first object has already been popped into the Expression - register, so just pop the second argument. */ - Stack_Pointer = (STACK_LOCATIVE_OFFSET (Stack_Pointer, 1)); - break; - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_RESTORE_TO_STATE_POINT: - { SCHEME_OBJECT Where_To_Go = Fetch_Expression(); - Will_Push(CONTINUATION_SIZE); - /* Restore the contents of Val after moving to point */ - Store_Expression(Val); - Store_Return(RC_RESTORE_VALUE); - Save_Cont(); - Pushed(); - Export_Registers(); - Translate_To_Point(Where_To_Go); - break; /* We never get here.... */ - } - - 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 */ /* Interpret(), continued */