From c6995ba60c60c5c6892c56d9b4273acd96d6194c Mon Sep 17 00:00:00 2001 From: Stephen Adams Date: Wed, 16 Jul 1997 02:36:59 +0000 Subject: [PATCH] A hack: Introduced macro case_TC_FIXNUMs for generating case labels for selecting fixnums, whether there are one or two typecodes. This tidies up the support in the 8.0 sources for eitehr case, and allows more files to be shared between 7.4 and 8.0 --- v7/src/microcode/debug.c | 18 +- v7/src/microcode/gccode.h | 27 +- v7/src/microcode/interp.c | 1791 +++++++++++++++++++------------------ v7/src/microcode/load.c | 9 +- v7/src/microcode/types.h | 6 +- v8/src/microcode/interp.c | 1776 ++++++++++++++++++------------------ v8/src/microcode/types.h | 6 +- 7 files changed, 1811 insertions(+), 1822 deletions(-) diff --git a/v7/src/microcode/debug.c b/v7/src/microcode/debug.c index c32dab7f7..703e72298 100644 --- a/v7/src/microcode/debug.c +++ b/v7/src/microcode/debug.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: debug.c,v 9.48 1996/10/02 18:57:21 cph Exp $ +$Id: debug.c,v 9.49 1997/07/16 02:35:53 adams Exp $ Copyright (c) 1987-96 Massachusetts Institute of Technology @@ -433,7 +433,7 @@ DEFUN (Print_Expression, (expression, string), extern char * Type_Names []; -void +static void DEFUN (do_printing, (stream, Expr, Detailed), outf_channel stream AND SCHEME_OBJECT Expr AND Boolean Detailed) { @@ -475,10 +475,7 @@ DEFUN (do_printing, (stream, Expr, Detailed), Expr = (MEMORY_REF (Expr, DEFINE_NAME)); goto SPrint; - case TC_POSITIVE_FIXNUM: -#if (TC_POSITIVE_FIXNUM != TC_NEGATIVE_FIXNUM) - case TC_NEGATIVE_FIXNUM: -#endif + case_TC_FIXNUMs: outf (stream, "%ld", ((long) (FIXNUM_TO_LONG (Expr)))); return; @@ -624,11 +621,6 @@ DEFUN (do_printing, (stream, Expr, Detailed), return; case TC_CONSTANT: - if (Temp_Address == 0) - { - outf (stream, "#T"); - return; - } break; case TC_COMPILED_ENTRY: @@ -751,8 +743,7 @@ DEFUN (Back_Trace, (stream), outf_channel stream) Back_Trace_Entry_Hook(); Old_Stack = Stack_Pointer; while (true) - { - /**************************** I DON'T UNDERSTAND THIS -- JSM + { if ((STACK_LOCATIVE_DIFFERENCE (Stack_Top, (STACK_LOC (0)))) <= 0) { if ((STACK_LOC (0)) == Old_Stack) @@ -761,7 +752,6 @@ DEFUN (Back_Trace, (stream), outf_channel stream) outf (stream, "\n[Stack ends abruptly.]\n"); break; } - *******************************/ if (Return_Hook_Address == (STACK_LOC (0))) { Temp = (STACK_POP ()); diff --git a/v7/src/microcode/gccode.h b/v7/src/microcode/gccode.h index 914a1ec3c..664229b2b 100644 --- a/v7/src/microcode/gccode.h +++ b/v7/src/microcode/gccode.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: gccode.h,v 9.54 1995/07/26 23:27:53 adams Exp $ +$Id: gccode.h,v 9.55 1997/07/16 02:36:59 adams Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -56,18 +56,10 @@ MIT in each case. */ case TC_RETURN_CODE: \ case TC_THE_ENVIRONMENT -#if (TC_POSITIVE_FIXNUM != TC_NEGATIVE_FIXNUM) #define case_Fasload_Non_Pointer \ - case TC_POSITIVE_FIXNUM: \ - case TC_NEGATIVE_FIXNUM: \ + case_TC_FIXNUMs: \ case TC_CHARACTER: \ case_simple_Non_Pointer -#else -#define case_Fasload_Non_Pointer \ - case TC_POSITIVE_FIXNUM: \ - case TC_CHARACTER: \ - case_simple_Non_Pointer -#endif #define case_Non_Pointer \ case TC_PRIMITIVE: \ @@ -407,21 +399,6 @@ extern SCHEME_OBJECT * gc_objects_referencing_end; extern void EXFUN (check_transport_vector_lossage, (SCHEME_OBJECT *, SCHEME_OBJECT *, SCHEME_OBJECT *)); -#define CHECK_TRANSPORT_VECTOR_TERMINATION() \ -{ \ - if (! ((To <= Scan) \ - && (((Constant_Space <= To) && (To < Constant_Top)) \ - ? ((Constant_Space <= Scan) && (Scan < Constant_Top)) \ - : ((Heap_Bottom <= Scan) && (Scan < Heap_Top))))) \ - check_transport_vector_lossage (Scan, Saved_Scan, To); \ - if ((OBJECT_DATUM (*Old)) > 65536) \ - { \ - outf_error ("\nWarning: copying large vector: %d\n", \ - (OBJECT_DATUM (*Old))); \ - outf_flush_error (); \ - } \ -} - #define CHECK_TRANSPORT_VECTOR_TERMINATION() \ { \ if (! ((To <= Scan) \ diff --git a/v7/src/microcode/interp.c b/v7/src/microcode/interp.c index 52df6c1b3..1710ac739 100644 --- a/v7/src/microcode/interp.c +++ b/v7/src/microcode/interp.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: interp.c,v 9.87 1997/02/12 08:23:35 cph Exp $ +$Id: interp.c,v 9.88 1997/07/16 02:36:47 adams Exp $ Copyright (c) 1988-97 Massachusetts Institute of Technology @@ -472,10 +472,10 @@ DEFUN (Interpret, (pop_return_p), Boolean pop_return_p) preserve_signal_mask (); Set_Time_Zone (Zone_Working); Import_Registers (); - + Repeat_Dispatch: switch (Which_Way) - { + { case PRIM_APPLY: PROCEED_AFTER_PRIMITIVE(); case CODE_MAP(PRIM_APPLY): @@ -520,16 +520,16 @@ Repeat_Dispatch: LOG_FUTURES(); case CODE_MAP(PRIM_REENTER): goto Perform_Application; - + case PRIM_TOUCH: - { - SCHEME_OBJECT temp; + { + SCHEME_OBJECT temp; - temp = Val; - BACK_OUT_AFTER_PRIMITIVE(); - Val = temp; - LOG_FUTURES(); - } + temp = Val; + BACK_OUT_AFTER_PRIMITIVE(); + Val = temp; + LOG_FUTURES(); + } /* fall through */ case CODE_MAP(PRIM_TOUCH): TOUCH_SETUP(Val); @@ -565,83 +565,83 @@ Repeat_Dispatch: 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); + if (!CODE_MAPPED_P(Which_Way)) + { + BACK_OUT_AFTER_PRIMITIVE(); + LOG_FUTURES(); + } + else + { + Which_Way = CODE_UNMAP(Which_Way); + } + Pop_Return_Error(Which_Way); } - Pop_Return_Error(Which_Way); } - } - + Do_Expression: if (0 && Eval_Debug) - { - Print_Expression ((Fetch_Expression ()), "Eval, expression"); - outf_console ("\n"); - } + { + 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. - */ + /* 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. + /* 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 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; - } - + { + 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); @@ -674,7 +674,7 @@ Eval_Non_Trapping: case TC_REFERENCE_TRAP: case TC_RETURN_CODE: case TC_UNINTERNED_SYMBOL: - case TC_TRUE: + case TC_CONSTANT: case TC_VECTOR: case TC_VECTOR_16B: case TC_VECTOR_1B: @@ -682,11 +682,11 @@ Eval_Non_Trapping: break; case TC_ACCESS: - Will_Push(CONTINUATION_SIZE); + Will_Push(CONTINUATION_SIZE); Do_Nth_Then(RC_EXECUTE_ACCESS_FINISH, ACCESS_ENVIRONMENT, Pushed()); case TC_ASSIGNMENT: - Will_Push(CONTINUATION_SIZE + 1); + Will_Push(CONTINUATION_SIZE + 1); Save_Env(); Do_Nth_Then(RC_EXECUTE_ASSIGNMENT_FINISH, ASSIGN_VALUE, Pushed()); @@ -694,9 +694,9 @@ Eval_Non_Trapping: Export_Registers(); Microcode_Termination (TERM_BROKEN_HEART); -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ case TC_COMBINATION: { @@ -708,27 +708,27 @@ Eval_Non_Trapping: Eval_GC_Check (New_Stacklet_Size (Array_Length + 1 + 1 + CONTINUATION_SIZE)); #endif /* USE_STACKLETS */ - Will_Push(Array_Length + 1 + 1 + CONTINUATION_SIZE); + 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(); + Pushed(); if (Array_Length == 0) - { - STACK_PUSH (STACK_FRAME_HEADER); /* Frame size */ - Do_Nth_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT, {}); - } + { + 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); + 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); + Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 2); Save_Env(); Do_Nth_Then(RC_COMB_2_FIRST_OPERAND, COMB_2_ARG_2, {}); @@ -736,7 +736,7 @@ Eval_Non_Trapping: Reduces_To_Nth(COMMENT_EXPRESSION); case TC_CONDITIONAL: - Will_Push(CONTINUATION_SIZE + 1); + Will_Push(CONTINUATION_SIZE + 1); Save_Env(); Do_Nth_Then(RC_CONDITIONAL_DECIDE, COND_PREDICATE, Pushed()); @@ -752,12 +752,12 @@ Eval_Non_Trapping: goto return_from_compiled_code; } -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ case TC_DEFINITION: - Will_Push(CONTINUATION_SIZE + 1); + Will_Push(CONTINUATION_SIZE + 1); Save_Env(); Do_Nth_Then(RC_EXECUTE_DEFINITION_FINISH, DEFINE_VALUE, Pushed()); @@ -771,46 +771,47 @@ Eval_Non_Trapping: break; case TC_DISJUNCTION: - Will_Push(CONTINUATION_SIZE + 1); + 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); */ + /* 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 */ + /* 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); - } + { + 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); + 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(); + Pushed(); goto Internal_Apply; #endif case TC_IN_PACKAGE: - Will_Push(CONTINUATION_SIZE); + 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); */ + /* Deliberately omitted: Eval_GC_Check(2); */ Val = MAKE_POINTER_OBJECT (TC_PROCEDURE, Free); Free[PROCEDURE_LAMBDA_EXPR] = Fetch_Expression(); Free[PROCEDURE_ENVIRONMENT] = Fetch_Env(); @@ -821,32 +822,32 @@ Eval_Non_Trapping: case TC_MANIFEST_SPECIAL_NM_VECTOR: Eval_Error(ERR_EXECUTE_MANIFEST_VECTOR); -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* 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. - */ + /* + 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); + 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); + 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); + 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); + Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 3); Save_Env(); Do_Nth_Then(RC_PCOMB3_DO_2, PCOMB3_ARG_3_SLOT, {}); @@ -855,153 +856,154 @@ Eval_Non_Trapping: break; case TC_SEQUENCE_2: - Will_Push(CONTINUATION_SIZE + 1); + 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); + 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 */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ case TC_VARIABLE: - { - long temp; + { + long temp; #ifndef No_In_Line_Lookup - fast SCHEME_OBJECT *cell; + fast SCHEME_OBJECT *cell; - Set_Time_Zone(Zone_Lookup); - cell = OBJECT_ADDRESS (Fetch_Expression()); - lookup(cell, Fetch_Env(), cell, repeat_variable_lookup); + Set_Time_Zone(Zone_Lookup); + cell = OBJECT_ADDRESS (Fetch_Expression()); + lookup(cell, Fetch_Env(), cell, repeat_variable_lookup); -lookup_end_restart: + lookup_end_restart: - Val = MEMORY_FETCH (cell[0]); - if (OBJECT_TYPE (Val) != TC_REFERENCE_TRAP) - { - Set_Time_Zone(Zone_Working); - goto Pop_Return; - } + 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; + 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_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; + case TRAP_FLUID: + cell = lookup_fluid(Val); + goto lookup_end_restart; -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ - case TRAP_UNBOUND: - temp = ERR_UNBOUND_VARIABLE; - break; + case TRAP_UNBOUND: + temp = ERR_UNBOUND_VARIABLE; + break; - case TRAP_UNASSIGNED: - temp = ERR_UNASSIGNED_VARIABLE; - break; + case TRAP_UNASSIGNED: + temp = ERR_UNASSIGNED_VARIABLE; + break; - default: - temp = ERR_ILLEGAL_REFERENCE_TRAP; - 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; + 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. */ + /* Back out of the evaluation. */ - Set_Time_Zone(Zone_Working); + Set_Time_Zone(Zone_Working); - if (temp == PRIM_INTERRUPT) - { - Prepare_Eval_Repeat(); - Interrupt(PENDING_INTERRUPTS()); - } + if (temp == PRIM_INTERRUPT) + { + Prepare_Eval_Repeat(); + Interrupt(PENDING_INTERRUPTS()); + } - Eval_Error(temp); - } + Eval_Error(temp); + } SITE_EXPRESSION_DISPATCH_HOOK() - }; + }; -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* 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. - */ + /* 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); + { + Will_Push(3); Stop_Trapping(); STACK_PUSH (Val); STACK_PUSH (Fetch_Return_Trapper()); STACK_PUSH (STACK_FRAME_HEADER+1); - Pushed(); - goto Apply_Non_Trapping; - } + 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); - } + { + 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"); - }; + { + 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 @@ -1009,13 +1011,13 @@ Pop_Return_Non_Trapping: */ 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); + Finished_Eventual_Pushing(CONTINUATION_SIZE); Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_1_FN); case RC_COMB_2_FIRST_OPERAND: @@ -1024,57 +1026,58 @@ Pop_Return_Non_Trapping: Save_Env(); Do_Another_Then(RC_COMB_2_PROCEDURE, COMB_2_ARG_1); -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* 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); + 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; + 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); + 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); + 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 */ + /* 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; \ - } + 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_INTERRUPT_RESTART, + comp_interrupt_restart) define_compiler_restart (RC_COMP_LOOKUP_APPLY_RESTART, comp_lookup_apply_restart) @@ -1090,7 +1093,7 @@ Pop_Return_Non_Trapping: define_compiler_restart (RC_COMP_UNBOUND_P_RESTART, comp_unbound_p_restart) - + define_compiler_restart (RC_COMP_ASSIGNMENT_RESTART, comp_assignment_restart) @@ -1124,11 +1127,11 @@ Pop_Return_Non_Trapping: 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_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(); @@ -1145,225 +1148,226 @@ Pop_Return_Non_Trapping: Reduces_To_Nth(OR_ALTERNATIVE); case RC_END_OF_COMPUTATION: - { - /* Signals bottom of stack */ + { + /* Signals bottom of stack */ - interpreter_state_t previous_state; + 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; + 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; + { + long Result; + SCHEME_OBJECT value; - Pop_Return_Val_Check(); - value = Val; + 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()); + 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); } - Val = value; - Pop_Return_Error(ERR_BAD_FRAME); - } -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ case RC_EXECUTE_ASSIGNMENT_FINISH: - { - long temp; - SCHEME_OBJECT value; - Lock_Handle set_serializer; + { + 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); + SCHEME_OBJECT bogus_unassigned; + fast SCHEME_OBJECT *cell; -assignment_end_after_lock: + Set_Time_Zone(Zone_Lookup); + Restore_Env(); + cell = OBJECT_ADDRESS (MEMORY_REF (Fetch_Expression(), ASSIGN_NAME)); + lookup(cell, Fetch_Env(), cell, repeat_assignment_lookup); - 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; - } + value = Val; + bogus_unassigned = Get_Fixed_Obj_Slot(Non_Object); + if (value == bogus_unassigned) + value = UNASSIGNED_OBJECT; -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + assignment_end_before_lock: - 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; + setup_lock(set_serializer, cell); - case TRAP_COMPILER_CACHED: - { - SCHEME_OBJECT extension, references; + assignment_end_after_lock: - extension = FAST_MEMORY_REF (Val, TRAP_EXTRA); - references = FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES); + Val = *cell; - if ((FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR)) - != SHARP_F) + 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; + } - /* There are uuo links. - wimp out and let deep_assignment_end handle it. - */ + /* 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); - 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; - } + 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; -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + 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; + } - case TRAP_FLUID: - remove_lock(set_serializer); - cell = lookup_fluid(Val); - goto assignment_end_before_lock; + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ - case TRAP_UNBOUND: - remove_lock(set_serializer); - temp = ERR_UNBOUND_VARIABLE; - break; + case TRAP_FLUID: + remove_lock(set_serializer); + cell = lookup_fluid(Val); + goto assignment_end_before_lock; - case TRAP_UNASSIGNED: - Val = bogus_unassigned; - goto normal_assignment_done; + case TRAP_UNBOUND: + remove_lock(set_serializer); + temp = ERR_UNBOUND_VARIABLE; + break; - default: - remove_lock(set_serializer); - temp = ERR_ILLEGAL_REFERENCE_TRAP; - 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; + if (value == UNASSIGNED_OBJECT) + value = bogus_unassigned; -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* 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; - } + 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); - } + 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()); - } + Prepare_Pop_Return_Interrupt(RC_EXECUTE_ASSIGNMENT_FINISH, + value); + Interrupt(PENDING_INTERRUPTS()); + } -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ case RC_EXECUTE_DEFINITION_FINISH: { @@ -1378,17 +1382,17 @@ external_assignment_return: Val); Import_Registers(); if (result == PRIM_DONE) - { - End_Subproblem(); - break; - } + { + End_Subproblem(); + break; + } Save_Env(); if (result == PRIM_INTERRUPT) - { - Prepare_Pop_Return_Interrupt(RC_EXECUTE_DEFINITION_FINISH, - value); - Interrupt(PENDING_INTERRUPTS()); - } + { + Prepare_Pop_Return_Interrupt(RC_EXECUTE_DEFINITION_FINISH, + value); + Interrupt(PENDING_INTERRUPTS()); + } Val = value; Pop_Return_Error(result); } @@ -1396,11 +1400,11 @@ external_assignment_return: 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); - } + { + End_Subproblem(); + Store_Env(Val); + Reduces_To_Nth(IN_PACKAGE_EXPRESSION); + } Pop_Return_Error(ERR_BAD_FRAME); #ifdef COMPILE_FUTURES @@ -1410,80 +1414,80 @@ external_assignment_return: 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 */ + { + /* This just reinvokes the handler */ - SCHEME_OBJECT info, handler; - info = (STACK_REF (0)); + 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*/ + 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; } - 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. + + /* Internal_Apply, the core of the application mechanism. - Branch here to perform a function application. + 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. + 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. -*/ + 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))); \ -} + { \ + 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); \ -} + { \ + 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 */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ case RC_INTERNAL_APPLY_VAL: -Internal_Apply_Val: + Internal_Apply_Val: - STACK_REF (STACK_ENV_FUNCTION) = Val; + STACK_REF (STACK_ENV_FUNCTION) = Val; case RC_INTERNAL_APPLY: -Internal_Apply: + Internal_Apply: - if (Microcode_Does_Stepping && - Trapping && - (! WITHIN_CRITICAL_SECTION_P()) && - ((Fetch_Apply_Trapper ()) != SHARP_F)) + if (Microcode_Does_Stepping && + Trapping && + (! WITHIN_CRITICAL_SECTION_P()) && + ((Fetch_Apply_Trapper ()) != SHARP_F)) { long Count; @@ -1493,9 +1497,9 @@ Internal_Apply: Stop_Trapping (); } -Apply_Non_Trapping: + Apply_Non_Trapping: - if ((PENDING_INTERRUPTS()) != 0) + if ((PENDING_INTERRUPTS()) != 0) { long Interrupts; @@ -1504,31 +1508,31 @@ Apply_Non_Trapping: Interrupt(Interrupts); } -Perform_Application: + Perform_Application: - Apply_Ucode_Hook(); + Apply_Ucode_Hook(); - { - fast SCHEME_OBJECT Function, orig_proc; + { + fast SCHEME_OBJECT Function, orig_proc; - Apply_Future_Check (Function, (STACK_REF (STACK_ENV_FUNCTION))); - orig_proc = Function; + Apply_Future_Check (Function, (STACK_REF (STACK_ENV_FUNCTION))); + orig_proc = Function; -apply_dispatch: - switch (OBJECT_TYPE (Function)) + apply_dispatch: + switch (OBJECT_TYPE (Function)) { - case TC_ENTITY: + 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)); @@ -1538,22 +1542,22 @@ apply_dispatch: && ((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; + 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; + } } - else - { - Function = orig_proc; - STACK_REF (STACK_ENV_FUNCTION - 1) = orig_proc; - } - } STACK_PUSH (FAST_MEMORY_REF (Function, ENTITY_OPERATOR)); STACK_PUSH (nargs + 1); @@ -1561,21 +1565,21 @@ apply_dispatch: 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 */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ - case TC_RECORD: + 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) + == TC_CONSTANT) && ((VECTOR_LENGTH (record_type)) >= 2) && ((VECTOR_REF (record_type, 1)) != SHARP_F) && ((VECTOR_REF (record_type, 1)) != Function)) @@ -1592,7 +1596,7 @@ apply_dispatch: goto internal_apply_inapplicable; } - case TC_PROCEDURE: + case TC_PROCEDURE: { fast long nargs; @@ -1608,24 +1612,24 @@ apply_dispatch: if ((nargs != ((long) (VECTOR_LENGTH (formals)))) && ((OBJECT_TYPE (Function) != TC_LEXPR) || (nargs < ((long) (VECTOR_LENGTH (formals)))))) - { - STACK_PUSH (STACK_FRAME_HEADER + nargs - 1); - Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); - } + { + 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"); - } + { + 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); - } + { + STACK_PUSH (STACK_FRAME_HEADER + nargs - 1); + Prepare_Apply_Interrupt (); + Immediate_GC(nargs + 1); + } { fast SCHEME_OBJECT *scan; @@ -1642,17 +1646,17 @@ apply_dispatch: } } -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ - case TC_CONTROL_POINT: + case TC_CONTROL_POINT: { if (OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER)) != STACK_ENV_FIRST_ARG) - { - Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); - } + { + Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); + } Val = (STACK_REF (STACK_ENV_FIRST_ARG)); Our_Throw(false, Function); Apply_Stacklet_Backout(); @@ -1660,40 +1664,40 @@ apply_dispatch: goto Pop_Return; } -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ - /* - After checking the number of arguments, remove the - frame header since primitives do not expect it. + /* + 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. - */ + NOTE: This code must match the application code which + follows Primitive_Internal_Apply. + */ - case TC_PRIMITIVE: + case TC_PRIMITIVE: { fast long nargs; if (!IMPLEMENTED_PRIMITIVE_P(Function)) - { - Apply_Error(ERR_UNIMPLEMENTED_PRIMITIVE); - } + { + Apply_Error(ERR_UNIMPLEMENTED_PRIMITIVE); + } /* Note that the first test below will fail for lexpr - primitives. */ + 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); + if (PRIMITIVE_ARITY(Function) != LEXPR_PRIMITIVE_ARITY) + { + Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); + } + Regs[REGBLOCK_LEXPR_ACTUALS] = ((SCHEME_OBJECT) nargs); } - Regs[REGBLOCK_LEXPR_ACTUALS] = ((SCHEME_OBJECT) nargs); - } Stack_Pointer = (STACK_LOC (STACK_ENV_FIRST_ARG)); Store_Expression (Function); @@ -1702,24 +1706,24 @@ apply_dispatch: 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(); - } + { + Store_Expression(Val); + Store_Return(RC_RESTORE_VALUE); + Save_Cont(); + Call_Future_Logging(); + } goto Pop_Return; } -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ - case TC_EXTENDED_PROCEDURE: + case TC_EXTENDED_PROCEDURE: { SCHEME_OBJECT lambda, temp; long nargs, nparams, formals, params, auxes, - rest_flag, size; + rest_flag, size; fast long i; fast SCHEME_OBJECT *scan; @@ -1727,11 +1731,11 @@ apply_dispatch: 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"); - } + { + 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, @@ -1745,74 +1749,74 @@ apply_dispatch: 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); - } + { + 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 */ + { + 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; - } + { + 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; + /* 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; } - scan[-1] = EMPTY_LIST; - } Free = scan; Store_Env (temp); Reduces_To(Get_Body_Elambda(lambda)); } -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ - case TC_COMPILED_ENTRY: + case TC_COMPILED_ENTRY: { apply_compiled_setup (STACK_ENV_EXTRA_SLOTS + @@ -1820,166 +1824,167 @@ apply_dispatch: Export_Registers (); Which_Way = apply_compiled_procedure(); -return_from_compiled_code: + 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); - } + { + 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); + default: + internal_apply_inapplicable: + Apply_Error (ERR_INAPPLICABLE_OBJECT); } /* End of switch in RC_INTERNAL_APPLY */ - } /* End of RC_INTERNAL_APPLY case */ + } /* End of RC_INTERNAL_APPLY case */ -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* 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 + /* Expression contains the space in which we are moving */ { - 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)); - } + 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 - { - Save_Cont(); - } - } - if ((Fetch_Expression ()) != SHARP_F) - { - MEMORY_SET - ((Fetch_Expression ()), STATE_SPACE_NEAREST_POINT, New_Location); - } - else - { - Current_State_Point = New_Location; + { + 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; } - Will_Push(2); - STACK_PUSH (Thunk); - STACK_PUSH (STACK_FRAME_HEADER); - Pushed(); - goto Internal_Apply; - } -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ case RC_INVOKE_STACK_THREAD: /* Used for WITH_THREADED_STACK primitive */ - Will_Push(3); + Will_Push(3); STACK_PUSH (Val); /* Value calculated by thunk */ STACK_PUSH (Fetch_Expression()); STACK_PUSH (STACK_FRAME_HEADER+1); - Pushed(); + Pushed(); goto Internal_Apply; case RC_JOIN_STACKLETS: @@ -1991,42 +1996,42 @@ return_from_compiled_code: case RC_NORMAL_GC_DONE: Val = (Fetch_Expression ()); if (GC_Space_Needed < 0) - { - /* Paranoia */ + { + /* Paranoia */ - GC_Space_Needed = 0; - } + 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); + Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG); Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), PCOMB1_FN_SLOT)); -Primitive_Internal_Apply: + 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; - } + { + /* 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. @@ -2034,8 +2039,8 @@ Primitive_Internal_Apply: 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. - */ + unimplemented primitives will cause an error at invocation. + */ { fast SCHEME_OBJECT primitive = (Fetch_Expression ()); @@ -2052,11 +2057,11 @@ Primitive_Internal_Apply: } break; } - + case RC_PCOMB2_APPLY: End_Subproblem(); STACK_PUSH (Val); /* Value of arg. 1 */ - Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG); + Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG); Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), PCOMB2_FN_SLOT)); goto Primitive_Internal_Apply; @@ -2068,24 +2073,24 @@ Primitive_Internal_Apply: case RC_PCOMB3_APPLY: End_Subproblem(); STACK_PUSH (Val); /* Save value of arg. 1 */ - Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG); + 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 */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ case RC_PCOMB3_DO_1: - { - SCHEME_OBJECT Temp; + { + 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); - } + 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(); @@ -2110,81 +2115,84 @@ Primitive_Internal_Apply: Restore_Cont(); goto Repeat_Dispatch; -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* 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. + /* 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. -*/ + 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); + 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; } - break; - } -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ case RC_RESTORE_HISTORY: - { - SCHEME_OBJECT Stacklet; - - Export_Registers(); - if (! Restore_History(Fetch_Expression())) { + 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(); - 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); - } + 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; } - break; - } case RC_RESTORE_FLUIDS: Fluid_Bindings = Fetch_Expression(); @@ -2195,12 +2203,12 @@ Primitive_Internal_Apply: if (GC_Check (0)) Request_GC (0); if ((PENDING_INTERRUPTS ()) != 0) - { - Store_Return (RC_RESTORE_VALUE); - Store_Expression (Val); - Save_Cont (); - Interrupt (PENDING_INTERRUPTS ()); - } + { + Store_Return (RC_RESTORE_VALUE); + Store_Expression (Val); + Save_Cont (); + Interrupt (PENDING_INTERRUPTS ()); + } break; case RC_STACK_MARKER: @@ -2210,22 +2218,23 @@ Primitive_Internal_Apply: Stack_Pointer = (STACK_LOCATIVE_OFFSET (Stack_Pointer, 1)); break; -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* 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.... */ - } + { + 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(); @@ -2241,9 +2250,9 @@ Primitive_Internal_Apply: Restore_Env(); Reduces_To_Nth(SEQUENCE_3); -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ case RC_SNAP_NEED_THUNK: /* Don't snap thunk twice; evaluation of the thunk's body might @@ -2255,7 +2264,7 @@ Primitive_Internal_Apply: MEMORY_SET ((Fetch_Expression ()), THUNK_SNAPPED, SHARP_T); MEMORY_SET ((Fetch_Expression ()), THUNK_VALUE, Val); } - break; + break; case RC_AFTER_MEMORY_UPDATE: case RC_BAD_INTERRUPT_CONTINUE: @@ -2267,10 +2276,10 @@ Primitive_Internal_Apply: case RC_POP_FROM_COMPILED_CODE: Pop_Return_Error (ERR_INAPPLICABLE_CONTINUATION); - SITE_RETURN_DISPATCH_HOOK() + SITE_RETURN_DISPATCH_HOOK() - default: - Pop_Return_Error (ERR_INAPPLICABLE_CONTINUATION); - }; + default: + Pop_Return_Error (ERR_INAPPLICABLE_CONTINUATION); + }; goto Pop_Return; } diff --git a/v7/src/microcode/load.c b/v7/src/microcode/load.c index 74f9e2dc3..78dd7ed32 100644 --- a/v7/src/microcode/load.c +++ b/v7/src/microcode/load.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: load.c,v 9.37 1995/07/26 23:42:24 adams Exp $ +$Id: load.c,v 9.38 1997/07/16 02:36:19 adams Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -90,10 +90,10 @@ DEFUN_VOID (print_fasl_information) { printf ("FASL File Information:\n\n"); printf ("Machine = %ld; Version = %ld; Subversion = %ld\n", - Machine_Type, Version, Sub_Version); + Machine_Type, Version, Sub_Version); if ((dumped_processor_type != 0) || (dumped_interface_version != 0)) printf ("Compiled code interface version = %ld; Processor type = %ld\n", - dumped_interface_version, dumped_processor_type); + dumped_interface_version, dumped_processor_type); if (band_p) printf ("The file contains a dumped image (band).\n"); @@ -183,7 +183,6 @@ DEFUN (initialize_variables_from_fasl_header, (buffer), C_Code_Table_Size = 0; } else - { C_Code_Table_Length = (OBJECT_DATUM (buffer[FASL_Offset_C_Length])); C_Code_Table_Size = (OBJECT_DATUM (buffer[FASL_Offset_C_Size])); @@ -192,6 +191,7 @@ DEFUN (initialize_variables_from_fasl_header, (buffer), #ifndef INHIBIT_FASL_VERSION_CHECK /* The error messages here should be handled by the runtime system! */ + if ((Version != FASL_READ_VERSION) || #ifndef BYTE_INVERSION (Machine_Type != FASL_INTERNAL_FORMAT) || @@ -211,6 +211,7 @@ DEFUN (initialize_variables_from_fasl_header, (buffer), FASL_FILE_BAD_VERSION : FASL_FILE_BAD_SUBVERSION)); } + #endif /* INHIBIT_FASL_VERSION_CHECK */ #ifndef INHIBIT_COMPILED_VERSION_CHECK diff --git a/v7/src/microcode/types.h b/v7/src/microcode/types.h index 167894009..187cc216f 100644 --- a/v7/src/microcode/types.h +++ b/v7/src/microcode/types.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: types.h,v 9.35 1997/07/15 23:26:32 adams Exp $ +$Id: types.h,v 9.36 1997/07/16 02:35:09 adams Exp $ Copyright (c) 1987-92 Massachusetts Institute of Technology @@ -44,7 +44,7 @@ MIT in each case. */ #define TC_UNINTERNED_SYMBOL 0x05 #define TC_BIG_FLONUM 0x06 #define TC_COMBINATION_1 0x07 -#define TC_TRUE 0x08 +#define TC_CONSTANT 0x08 #define TC_EXTENDED_PROCEDURE 0x09 #define TC_VECTOR 0x0A #define TC_RETURN_CODE 0x0B @@ -195,3 +195,5 @@ MIT in each case. */ #define UNMARKED_HISTORY_TYPE TC_HUNK3_A #define MARKED_HISTORY_TYPE TC_HUNK3_B + +#define case_TC_FIXNUMs case TC_FIXNUM diff --git a/v8/src/microcode/interp.c b/v8/src/microcode/interp.c index be5a6bde2..663e5570b 100644 --- a/v8/src/microcode/interp.c +++ b/v8/src/microcode/interp.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: interp.c,v 9.89 1997/02/12 08:21:39 cph Exp $ +$Id: interp.c,v 9.90 1997/07/16 02:36:38 adams Exp $ Copyright (c) 1988-97 Massachusetts Institute of Technology @@ -472,10 +472,10 @@ DEFUN (Interpret, (pop_return_p), Boolean pop_return_p) preserve_signal_mask (); Set_Time_Zone (Zone_Working); Import_Registers (); - + Repeat_Dispatch: switch (Which_Way) - { + { case PRIM_APPLY: PROCEED_AFTER_PRIMITIVE(); case CODE_MAP(PRIM_APPLY): @@ -520,16 +520,16 @@ Repeat_Dispatch: LOG_FUTURES(); case CODE_MAP(PRIM_REENTER): goto Perform_Application; - + case PRIM_TOUCH: - { - SCHEME_OBJECT temp; + { + SCHEME_OBJECT temp; - temp = Val; - BACK_OUT_AFTER_PRIMITIVE(); - Val = temp; - LOG_FUTURES(); - } + temp = Val; + BACK_OUT_AFTER_PRIMITIVE(); + Val = temp; + LOG_FUTURES(); + } /* fall through */ case CODE_MAP(PRIM_TOUCH): TOUCH_SETUP(Val); @@ -565,83 +565,83 @@ Repeat_Dispatch: 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); + if (!CODE_MAPPED_P(Which_Way)) + { + BACK_OUT_AFTER_PRIMITIVE(); + LOG_FUTURES(); + } + else + { + Which_Way = CODE_UNMAP(Which_Way); + } + Pop_Return_Error(Which_Way); } - Pop_Return_Error(Which_Way); } - } - + Do_Expression: if (0 && Eval_Debug) - { - Print_Expression ((Fetch_Expression ()), "Eval, expression"); - outf_console ("\n"); - } + { + 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. - */ + /* 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. + /* 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 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; - } - + { + 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); @@ -660,10 +660,7 @@ Eval_Non_Trapping: case TC_ENTITY: case TC_ENVIRONMENT: case TC_EXTENDED_PROCEDURE: - case TC_POSITIVE_FIXNUM: -#if (TC_POSITIVE_FIXNUM != TC_NEGATIVE_FIXNUM) - case TC_NEGATIVE_FIXNUM: -#endif + case_TC_FIXNUMs: case TC_HUNK3_A: case TC_HUNK3_B: case TC_INTERNED_SYMBOL: @@ -685,11 +682,11 @@ Eval_Non_Trapping: break; case TC_ACCESS: - Will_Push(CONTINUATION_SIZE); + Will_Push(CONTINUATION_SIZE); Do_Nth_Then(RC_EXECUTE_ACCESS_FINISH, ACCESS_ENVIRONMENT, Pushed()); case TC_ASSIGNMENT: - Will_Push(CONTINUATION_SIZE + 1); + Will_Push(CONTINUATION_SIZE + 1); Save_Env(); Do_Nth_Then(RC_EXECUTE_ASSIGNMENT_FINISH, ASSIGN_VALUE, Pushed()); @@ -697,9 +694,9 @@ Eval_Non_Trapping: Export_Registers(); Microcode_Termination (TERM_BROKEN_HEART); -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ case TC_COMBINATION: { @@ -708,29 +705,30 @@ Eval_Non_Trapping: 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)); + Eval_GC_Check + (New_Stacklet_Size (Array_Length + 1 + 1 + CONTINUATION_SIZE)); #endif /* USE_STACKLETS */ - Will_Push(Array_Length + 1 + 1 + CONTINUATION_SIZE); + 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(); + Pushed(); if (Array_Length == 0) - { - STACK_PUSH (STACK_FRAME_HEADER); /* Frame size */ - Do_Nth_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT, {}); - } + { + 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); + 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); + Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 2); Save_Env(); Do_Nth_Then(RC_COMB_2_FIRST_OPERAND, COMB_2_ARG_2, {}); @@ -738,7 +736,7 @@ Eval_Non_Trapping: Reduces_To_Nth(COMMENT_EXPRESSION); case TC_CONDITIONAL: - Will_Push(CONTINUATION_SIZE + 1); + Will_Push(CONTINUATION_SIZE + 1); Save_Env(); Do_Nth_Then(RC_CONDITIONAL_DECIDE, COND_PREDICATE, Pushed()); @@ -754,12 +752,12 @@ Eval_Non_Trapping: goto return_from_compiled_code; } -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ case TC_DEFINITION: - Will_Push(CONTINUATION_SIZE + 1); + Will_Push(CONTINUATION_SIZE + 1); Save_Env(); Do_Nth_Then(RC_EXECUTE_DEFINITION_FINISH, DEFINE_VALUE, Pushed()); @@ -773,47 +771,47 @@ Eval_Non_Trapping: break; case TC_DISJUNCTION: - Will_Push(CONTINUATION_SIZE + 1); + 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); */ + /* 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 */ + /* 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); - } + { + 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); + 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(); + Pushed(); goto Internal_Apply; #endif case TC_IN_PACKAGE: - Will_Push(CONTINUATION_SIZE); + 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); */ + /* Deliberately omitted: Eval_GC_Check(2); */ Val = MAKE_POINTER_OBJECT (TC_PROCEDURE, Free); Free[PROCEDURE_LAMBDA_EXPR] = Fetch_Expression(); Free[PROCEDURE_ENVIRONMENT] = Fetch_Env(); @@ -824,32 +822,32 @@ Eval_Non_Trapping: case TC_MANIFEST_SPECIAL_NM_VECTOR: Eval_Error(ERR_EXECUTE_MANIFEST_VECTOR); -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* 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. - */ + /* + 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); + 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); + 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); + 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); + Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 3); Save_Env(); Do_Nth_Then(RC_PCOMB3_DO_2, PCOMB3_ARG_3_SLOT, {}); @@ -858,156 +856,157 @@ Eval_Non_Trapping: break; case TC_SEQUENCE_2: - Will_Push(CONTINUATION_SIZE + 1); + 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); + 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 */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ case TC_VARIABLE: - { - long temp; + { + long temp; #ifndef No_In_Line_Lookup - fast SCHEME_OBJECT *cell; - SCHEME_OBJECT orig_temp, Var; + fast SCHEME_OBJECT *cell; + SCHEME_OBJECT orig_temp, Var; - Var = Fetch_Expression(); - Set_Time_Zone(Zone_Lookup); - cell = OBJECT_ADDRESS (Fetch_Expression()); - lookup(cell, Fetch_Env(), cell, repeat_variable_lookup); + Var = Fetch_Expression(); + Set_Time_Zone(Zone_Lookup); + cell = OBJECT_ADDRESS (Fetch_Expression()); + lookup(cell, Fetch_Env(), cell, repeat_variable_lookup); -lookup_end_restart: + lookup_end_restart: - Val = MEMORY_FETCH (cell[0]); - if (OBJECT_TYPE (Val) != TC_REFERENCE_TRAP) - { - Set_Time_Zone(Zone_Working); - goto Pop_Return; - } + 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); - orig_temp = temp; - 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; + get_trap_kind(temp, Val); + orig_temp = temp; + 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_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; + case TRAP_FLUID: + cell = lookup_fluid(Val); + goto lookup_end_restart; -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ - case TRAP_UNBOUND: - temp = ERR_UNBOUND_VARIABLE; - break; + case TRAP_UNBOUND: + temp = ERR_UNBOUND_VARIABLE; + break; - case TRAP_UNASSIGNED: - temp = ERR_UNASSIGNED_VARIABLE; - break; + case TRAP_UNASSIGNED: + temp = ERR_UNASSIGNED_VARIABLE; + break; - default: - temp = ERR_ILLEGAL_REFERENCE_TRAP; - 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; + 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. */ + /* Back out of the evaluation. */ - Set_Time_Zone(Zone_Working); + Set_Time_Zone(Zone_Working); - if (temp == PRIM_INTERRUPT) - { - Prepare_Eval_Repeat(); - Interrupt(PENDING_INTERRUPTS()); + if (temp == PRIM_INTERRUPT) + { + Prepare_Eval_Repeat(); + Interrupt(PENDING_INTERRUPTS()); + } + + Eval_Error(temp); } - Eval_Error(temp); - } SITE_EXPRESSION_DISPATCH_HOOK() - }; + }; -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* 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. - */ + /* 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); + { + Will_Push(3); Stop_Trapping(); STACK_PUSH (Val); STACK_PUSH (Fetch_Return_Trapper()); STACK_PUSH (STACK_FRAME_HEADER+1); - Pushed(); - goto Apply_Non_Trapping; - } + 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); - } + { + 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"); - }; + { + 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 @@ -1015,13 +1014,13 @@ Pop_Return_Non_Trapping: */ 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); + Finished_Eventual_Pushing(CONTINUATION_SIZE); Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_1_FN); case RC_COMB_2_FIRST_OPERAND: @@ -1030,58 +1029,58 @@ Pop_Return_Non_Trapping: Save_Env(); Do_Another_Then(RC_COMB_2_PROCEDURE, COMB_2_ARG_1); -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* 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); + 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; + 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) + 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); + 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); + 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 */ + /* 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; \ - } + 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_INTERRUPT_RESTART, + comp_interrupt_restart) define_compiler_restart (RC_COMP_LOOKUP_APPLY_RESTART, comp_lookup_apply_restart) @@ -1097,7 +1096,7 @@ Pop_Return_Non_Trapping: define_compiler_restart (RC_COMP_UNBOUND_P_RESTART, comp_unbound_p_restart) - + define_compiler_restart (RC_COMP_ASSIGNMENT_RESTART, comp_assignment_restart) @@ -1134,11 +1133,11 @@ Pop_Return_Non_Trapping: 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_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(); @@ -1155,226 +1154,226 @@ Pop_Return_Non_Trapping: Reduces_To_Nth(OR_ALTERNATIVE); case RC_END_OF_COMPUTATION: - { - /* Signals bottom of stack */ + { + /* Signals bottom of stack */ - interpreter_state_t previous_state; + 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; + 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; + { + long Result; + SCHEME_OBJECT value; - Pop_Return_Val_Check(); - value = Val; + 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()); + 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); } - Val = value; - Pop_Return_Error(ERR_BAD_FRAME); - } -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ case RC_EXECUTE_ASSIGNMENT_FINISH: - { - long temp; - SCHEME_OBJECT value; - Lock_Handle set_serializer; + { + 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; + SCHEME_OBJECT bogus_unassigned; + fast SCHEME_OBJECT *cell; -assignment_end_before_lock: + Set_Time_Zone(Zone_Lookup); + Restore_Env(); + cell = OBJECT_ADDRESS (MEMORY_REF (Fetch_Expression(), ASSIGN_NAME)); + lookup(cell, Fetch_Env(), cell, repeat_assignment_lookup); - 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; - } + value = Val; + bogus_unassigned = Get_Fixed_Obj_Slot(Non_Object); + if (value == bogus_unassigned) + value = UNASSIGNED_OBJECT; -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + assignment_end_before_lock: - 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; + setup_lock(set_serializer, cell); - case TRAP_COMPILER_CACHED: - { - SCHEME_OBJECT extension, references; + assignment_end_after_lock: - extension = FAST_MEMORY_REF (Val, TRAP_EXTRA); - references = FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES); + Val = *cell; - if ((FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR)) - != SHARP_F) + 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; + } - /* There are uuo links. - wimp out and let deep_assignment_end handle it. - */ + /* 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); - 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; - } + 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; -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + 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; + } - case TRAP_FLUID: - remove_lock(set_serializer); - cell = lookup_fluid(Val); - goto assignment_end_before_lock; + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ - case TRAP_UNBOUND: - remove_lock(set_serializer); - temp = ERR_UNBOUND_VARIABLE; - break; + case TRAP_FLUID: + remove_lock(set_serializer); + cell = lookup_fluid(Val); + goto assignment_end_before_lock; - case TRAP_UNASSIGNED: - Val = bogus_unassigned; - goto normal_assignment_done; + case TRAP_UNBOUND: + remove_lock(set_serializer); + temp = ERR_UNBOUND_VARIABLE; + break; - default: - remove_lock(set_serializer); - temp = ERR_ILLEGAL_REFERENCE_TRAP; - break; - } + case TRAP_UNASSIGNED: + Val = bogus_unassigned; + goto normal_assignment_done; - if (value == UNASSIGNED_OBJECT) - value = bogus_unassigned; + default: + remove_lock(set_serializer); + temp = ERR_ILLEGAL_REFERENCE_TRAP; + break; + } -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + 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; - } + 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); - } + 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()); - } + Prepare_Pop_Return_Interrupt(RC_EXECUTE_ASSIGNMENT_FINISH, + value); + Interrupt(PENDING_INTERRUPTS()); + } -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ case RC_EXECUTE_DEFINITION_FINISH: { @@ -1389,17 +1388,17 @@ external_assignment_return: Val); Import_Registers(); if (result == PRIM_DONE) - { - End_Subproblem(); - break; - } + { + End_Subproblem(); + break; + } Save_Env(); if (result == PRIM_INTERRUPT) - { - Prepare_Pop_Return_Interrupt(RC_EXECUTE_DEFINITION_FINISH, - value); - Interrupt(PENDING_INTERRUPTS()); - } + { + Prepare_Pop_Return_Interrupt(RC_EXECUTE_DEFINITION_FINISH, + value); + Interrupt(PENDING_INTERRUPTS()); + } Val = value; Pop_Return_Error(result); } @@ -1407,11 +1406,11 @@ external_assignment_return: 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); - } + { + End_Subproblem(); + Store_Env(Val); + Reduces_To_Nth(IN_PACKAGE_EXPRESSION); + } Pop_Return_Error(ERR_BAD_FRAME); #ifdef COMPILE_FUTURES @@ -1421,80 +1420,80 @@ external_assignment_return: 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 */ + { + /* This just reinvokes the handler */ - SCHEME_OBJECT info, handler; - info = (STACK_REF (0)); + 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*/ + 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; } - 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. + + /* Internal_Apply, the core of the application mechanism. - Branch here to perform a function application. + 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. + 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. -*/ + 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))); \ -} + { \ + 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); \ -} + { \ + 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 */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ case RC_INTERNAL_APPLY_VAL: -Internal_Apply_Val: + Internal_Apply_Val: - STACK_REF (STACK_ENV_FUNCTION) = Val; + STACK_REF (STACK_ENV_FUNCTION) = Val; case RC_INTERNAL_APPLY: -Internal_Apply: + Internal_Apply: - if (Microcode_Does_Stepping && - Trapping && - (! WITHIN_CRITICAL_SECTION_P()) && - ((Fetch_Apply_Trapper ()) != SHARP_F)) + if (Microcode_Does_Stepping && + Trapping && + (! WITHIN_CRITICAL_SECTION_P()) && + ((Fetch_Apply_Trapper ()) != SHARP_F)) { long Count; @@ -1504,9 +1503,9 @@ Internal_Apply: Stop_Trapping (); } -Apply_Non_Trapping: + Apply_Non_Trapping: - if ((PENDING_INTERRUPTS()) != 0) + if ((PENDING_INTERRUPTS()) != 0) { long Interrupts; @@ -1515,31 +1514,31 @@ Apply_Non_Trapping: Interrupt(Interrupts); } -Perform_Application: + Perform_Application: - Apply_Ucode_Hook(); + Apply_Ucode_Hook(); - { - fast SCHEME_OBJECT Function, orig_proc; + { + fast SCHEME_OBJECT Function, orig_proc; - Apply_Future_Check (Function, (STACK_REF (STACK_ENV_FUNCTION))); - orig_proc = Function; + Apply_Future_Check (Function, (STACK_REF (STACK_ENV_FUNCTION))); + orig_proc = Function; -apply_dispatch: - switch (OBJECT_TYPE (Function)) + apply_dispatch: + switch (OBJECT_TYPE (Function)) { - case TC_ENTITY: + 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)); @@ -1549,22 +1548,22 @@ apply_dispatch: && ((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; + 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); @@ -1572,16 +1571,16 @@ apply_dispatch: 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 */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ - case TC_RECORD: + case TC_RECORD: { SCHEME_OBJECT record_type = (VECTOR_REF (Function, 0)); if ((RECORD_P (record_type)) @@ -1603,7 +1602,7 @@ apply_dispatch: goto internal_apply_inapplicable; } - case TC_PROCEDURE: + case TC_PROCEDURE: { fast long nargs; @@ -1619,24 +1618,24 @@ apply_dispatch: if ((nargs != ((long) (VECTOR_LENGTH (formals)))) && ((OBJECT_TYPE (Function) != TC_LEXPR) || (nargs < ((long) (VECTOR_LENGTH (formals)))))) - { - STACK_PUSH (STACK_FRAME_HEADER + nargs - 1); - Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); - } + { + 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"); - } + { + 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); - } + { + STACK_PUSH (STACK_FRAME_HEADER + nargs - 1); + Prepare_Apply_Interrupt (); + Immediate_GC(nargs + 1); + } { fast SCHEME_OBJECT *scan; @@ -1653,17 +1652,17 @@ apply_dispatch: } } -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ - case TC_CONTROL_POINT: + case TC_CONTROL_POINT: { if (OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER)) != STACK_ENV_FIRST_ARG) - { - Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); - } + { + Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); + } Val = (STACK_REF (STACK_ENV_FIRST_ARG)); Our_Throw(false, Function); Apply_Stacklet_Backout(); @@ -1671,39 +1670,40 @@ apply_dispatch: goto Pop_Return; } -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ - /* - After checking the number of arguments, remove the - frame header since primitives do not expect it. + /* + 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. - */ + NOTE: This code must match the application code which + follows Primitive_Internal_Apply. + */ - case TC_PRIMITIVE: + case TC_PRIMITIVE: { fast long nargs; if (!IMPLEMENTED_PRIMITIVE_P(Function)) - { - Apply_Error(ERR_UNIMPLEMENTED_PRIMITIVE); - } + { + Apply_Error(ERR_UNIMPLEMENTED_PRIMITIVE); + } - /* Note that the first test below will fail for lexpr primitives. */ + /* 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); + if (PRIMITIVE_ARITY(Function) != LEXPR_PRIMITIVE_ARITY) + { + Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); + } + Regs[REGBLOCK_LEXPR_ACTUALS] = ((SCHEME_OBJECT) nargs); } - Regs[REGBLOCK_LEXPR_ACTUALS] = ((SCHEME_OBJECT) nargs); - } Stack_Pointer = (STACK_LOC (STACK_ENV_FIRST_ARG)); Store_Expression (Function); @@ -1712,24 +1712,24 @@ apply_dispatch: 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(); - } + { + Store_Expression(Val); + Store_Return(RC_RESTORE_VALUE); + Save_Cont(); + Call_Future_Logging(); + } goto Pop_Return; } -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ - case TC_EXTENDED_PROCEDURE: + case TC_EXTENDED_PROCEDURE: { SCHEME_OBJECT lambda, temp; long nargs, nparams, formals, params, auxes, - rest_flag, size; + rest_flag, size; fast long i; fast SCHEME_OBJECT *scan; @@ -1737,10 +1737,11 @@ apply_dispatch: 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"); - } + { + 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, @@ -1754,237 +1755,242 @@ apply_dispatch: 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); - } + { + 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 */ + { + 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; - } + { + 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; + /* 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; } - scan[-1] = EMPTY_LIST; - } Free = scan; Store_Env (temp); Reduces_To(Get_Body_Elambda(lambda)); } -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ - case TC_COMPILED_ENTRY: + case TC_COMPILED_ENTRY: { - apply_compiled_setup (STACK_ENV_EXTRA_SLOTS + - (OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER)))); + 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: + return_from_compiled_code: Import_Registers (); switch (Which_Way) - { - case PRIM_DONE: { - compiled_code_done (); - goto Pop_Return; - } + 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; - } + { + 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 ()); - } + { + compiled_error_backout (); + Save_Cont (); + Interrupt (PENDING_INTERRUPTS ()); + } case PRIM_APPLY_INTERRUPT: - { - apply_compiled_backout (); - Prepare_Apply_Interrupt (); - Interrupt (PENDING_INTERRUPTS ()); - } - + { + apply_compiled_backout (); + Prepare_Apply_Interrupt (); + Interrupt (PENDING_INTERRUPTS ()); + } + 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... - */ + /* 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); - } + { + 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); - } + { + /* 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); - } + { + /* 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); - } + compiled_error_backout (); + Pop_Return_Error (Which_Way); + } } - default: - internal_apply_inapplicable: - Apply_Error (ERR_INAPPLICABLE_OBJECT); + default: + internal_apply_inapplicable: + Apply_Error (ERR_INAPPLICABLE_OBJECT); } /* End of switch in RC_INTERNAL_APPLY */ - } /* End of RC_INTERNAL_APPLY case */ + } /* End of RC_INTERNAL_APPLY case */ -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* 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 + /* Expression contains the space in which we are moving */ { - 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)); - } + 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 - { - Save_Cont(); - } - } - if ((Fetch_Expression ()) != SHARP_F) - { - MEMORY_SET - ((Fetch_Expression ()), STATE_SPACE_NEAREST_POINT, New_Location); - } - else - { - Current_State_Point = New_Location; + { + 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; } - Will_Push(2); - STACK_PUSH (Thunk); - STACK_PUSH (STACK_FRAME_HEADER); - Pushed(); - goto Internal_Apply; - } -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ case RC_INVOKE_STACK_THREAD: /* Used for WITH_THREADED_STACK primitive */ - Will_Push(3); + Will_Push(3); STACK_PUSH (Val); /* Value calculated by thunk */ STACK_PUSH (Fetch_Expression()); STACK_PUSH (STACK_FRAME_HEADER+1); - Pushed(); + Pushed(); goto Internal_Apply; case RC_JOIN_STACKLETS: @@ -1996,42 +2002,42 @@ return_from_compiled_code: case RC_NORMAL_GC_DONE: Val = (Fetch_Expression ()); if (GC_Space_Needed < 0) - { - /* Paranoia */ + { + /* Paranoia */ - GC_Space_Needed = 0; - } + 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); + Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG); Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), PCOMB1_FN_SLOT)); -Primitive_Internal_Apply: + 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; - } + { + /* 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. @@ -2039,8 +2045,8 @@ Primitive_Internal_Apply: 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. - */ + unimplemented primitives will cause an error at invocation. + */ { fast SCHEME_OBJECT primitive = (Fetch_Expression ()); @@ -2057,11 +2063,11 @@ Primitive_Internal_Apply: } break; } - + case RC_PCOMB2_APPLY: End_Subproblem(); STACK_PUSH (Val); /* Value of arg. 1 */ - Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG); + Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG); Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), PCOMB2_FN_SLOT)); goto Primitive_Internal_Apply; @@ -2073,24 +2079,24 @@ Primitive_Internal_Apply: case RC_PCOMB3_APPLY: End_Subproblem(); STACK_PUSH (Val); /* Save value of arg. 1 */ - Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG); + 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 */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ case RC_PCOMB3_DO_1: - { - SCHEME_OBJECT Temp; + { + 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); - } + 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(); @@ -2115,84 +2121,84 @@ Primitive_Internal_Apply: Restore_Cont(); goto Repeat_Dispatch; -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* 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. + /* 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. -*/ + 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); + 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; } - break; - } -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ case RC_RESTORE_HISTORY: - { - SCHEME_OBJECT Stacklet; - - Export_Registers(); - if (! Restore_History(Fetch_Expression())) { + 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(); - 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); - } + 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; } - break; - } case RC_RESTORE_FLUIDS: Fluid_Bindings = Fetch_Expression(); @@ -2203,12 +2209,12 @@ Primitive_Internal_Apply: if (GC_Check (0)) Request_GC (0); if ((PENDING_INTERRUPTS ()) != 0) - { - Store_Return (RC_RESTORE_VALUE); - Store_Expression (Val); - Save_Cont (); - Interrupt (PENDING_INTERRUPTS ()); - } + { + Store_Return (RC_RESTORE_VALUE); + Store_Expression (Val); + Save_Cont (); + Interrupt (PENDING_INTERRUPTS ()); + } break; case RC_STACK_MARKER: @@ -2218,23 +2224,23 @@ Primitive_Internal_Apply: Stack_Pointer = (STACK_LOCATIVE_OFFSET (Stack_Pointer, 1)); break; -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* 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.... */ - } + { + 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(); @@ -2250,9 +2256,9 @@ Primitive_Internal_Apply: Restore_Env(); Reduces_To_Nth(SEQUENCE_3); -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ + /* Interpret() continues on the next page */ + + /* Interpret(), continued */ case RC_SNAP_NEED_THUNK: /* Don't snap thunk twice; evaluation of the thunk's body might @@ -2264,7 +2270,7 @@ Primitive_Internal_Apply: MEMORY_SET ((Fetch_Expression ()), THUNK_SNAPPED, SHARP_T); MEMORY_SET ((Fetch_Expression ()), THUNK_VALUE, Val); } - break; + break; case RC_AFTER_MEMORY_UPDATE: case RC_BAD_INTERRUPT_CONTINUE: @@ -2276,10 +2282,10 @@ Primitive_Internal_Apply: case RC_POP_FROM_COMPILED_CODE: Pop_Return_Error (ERR_INAPPLICABLE_CONTINUATION); - SITE_RETURN_DISPATCH_HOOK() + SITE_RETURN_DISPATCH_HOOK() - default: - Pop_Return_Error (ERR_INAPPLICABLE_CONTINUATION); - }; + default: + Pop_Return_Error (ERR_INAPPLICABLE_CONTINUATION); + }; goto Pop_Return; } diff --git a/v8/src/microcode/types.h b/v8/src/microcode/types.h index 476342449..fb20c2846 100644 --- a/v8/src/microcode/types.h +++ b/v8/src/microcode/types.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: types.h,v 9.35 1995/07/27 00:27:08 adams Exp $ +$Id: types.h,v 9.36 1997/07/16 02:35:18 adams Exp $ Copyright (c) 1987-92 Massachusetts Institute of Technology @@ -193,8 +193,12 @@ MIT in each case. */ #define TC_BIT_STRING TC_VECTOR_1B #define TC_VECTOR_8B TC_CHARACTER_STRING #define TC_HUNK3 TC_HUNK3_B + #ifndef TC_NEGATIVE_FIXNUM #define TC_NEGATIVE_FIXNUM TC_POSITIVE_FIXNUM +#define case_TC_FIXNUMs case TC_POSITIVE_FIXNUM +#else +#define case_TC_FIXNUMs case TC_POSITIVE_FIXNUM: case TC_NEGATIVE_FIXNUM #endif #define UNMARKED_HISTORY_TYPE TC_HUNK3_A -- 2.25.1