/* -*-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
extern char * Type_Names [];
-void
+static void
DEFUN (do_printing, (stream, Expr, Detailed),
outf_channel stream AND SCHEME_OBJECT Expr AND Boolean 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;
return;
case TC_CONSTANT:
- if (Temp_Address == 0)
- {
- outf (stream, "#T");
- return;
- }
break;
case TC_COMPILED_ENTRY:
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)
outf (stream, "\n[Stack ends abruptly.]\n");
break;
}
- *******************************/
if (Return_Hook_Address == (STACK_LOC (0)))
{
Temp = (STACK_POP ());
/* -*-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
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: \
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) \
/* -*-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
preserve_signal_mask ();
Set_Time_Zone (Zone_Working);
Import_Registers ();
-\f
+ \f
Repeat_Dispatch:
switch (Which_Way)
- {
+ {
case PRIM_APPLY:
PROCEED_AFTER_PRIMITIVE();
case CODE_MAP(PRIM_APPLY):
LOG_FUTURES();
case CODE_MAP(PRIM_REENTER):
goto Perform_Application;
-\f
+ \f
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);
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);
}
- }
-\f
+ \f
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;
- }
-\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;
+ }
+ \f
Eval_Non_Trapping:
Eval_Ucode_Hook();
switch (OBJECT_TYPE (Fetch_Expression()))
- {
+ {
default:
#if FALSE
Eval_Error(ERR_UNDEFINED_USER_TYPE);
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:
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());
Export_Registers();
Microcode_Termination (TERM_BROKEN_HEART);
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* Interpret(), continued */
case TC_COMBINATION:
{
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, {});
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());
goto return_from_compiled_code;
}
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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());
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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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();
case TC_MANIFEST_SPECIAL_NM_VECTOR:
Eval_Error(ERR_EXECUTE_MANIFEST_VECTOR);
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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, {});
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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* Interpret(), continued */
-/* Now restore the continuation saved during an earlier part
- * of the EVAL cycle and continue as directed.
- */
+ /* 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
*/
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:
Save_Env();
Do_Another_Then(RC_COMB_2_PROCEDURE, COMB_2_ARG_1);
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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)
define_compiler_restart (RC_COMP_UNBOUND_P_RESTART,
comp_unbound_p_restart)
-\f
+ \f
define_compiler_restart (RC_COMP_ASSIGNMENT_RESTART,
comp_assignment_restart)
define_compiler_restart (RC_COMP_ERROR_RESTART,
comp_error_restart)
\f
- 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();
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());
-\f
+ \f
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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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 */
-\f
-/* 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 */
+ \f
+ /* 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 */
-\f
-/* 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 */
+ \f
+ /* 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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* Interpret(), continued */
case RC_EXECUTE_DEFINITION_FINISH:
{
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);
}
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
Import_Registers_Except_Val();
break;
#endif
-\f
+ \f
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;
- }
-\f
-/* Internal_Apply, the core of the application mechanism.
+ \f
+ /* 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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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;
Stop_Trapping ();
}
-Apply_Non_Trapping:
+ Apply_Non_Trapping:
- if ((PENDING_INTERRUPTS()) != 0)
+ if ((PENDING_INTERRUPTS()) != 0)
{
long Interrupts;
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));
&& ((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);
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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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))
goto internal_apply_inapplicable;
}
- case TC_PROCEDURE:
+ case TC_PROCEDURE:
{
fast long nargs;
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;
}
}
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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();
goto Pop_Return;
}
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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);
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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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;
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,
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 */
-\f
-/* 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 */
+ \f
+ /* 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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* Interpret(), continued */
- case TC_COMPILED_ENTRY:
+ case TC_COMPILED_ENTRY:
{
apply_compiled_setup
(STACK_ENV_EXTRA_SLOTS +
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 ());
- }
-\f
- 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 ());
+ }
+ \f
+ 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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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:
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;
-\f
+ \f
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.
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 ());
}
break;
}
-\f
+ \f
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;
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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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();
Restore_Cont();
goto Repeat_Dispatch;
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* Interpret(), continued */
-/* The following two return codes are both used to restore
- a saved history object. The difference is that the first
- does not copy the history object while the second does.
- In both cases, the Expression register contains the history
- object and the next item to be popped off the stack contains
- the offset back to the previous restore history return code.
+ /* 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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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();
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:
Stack_Pointer = (STACK_LOCATIVE_OFFSET (Stack_Pointer, 1));
break;
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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();
Restore_Env();
Reduces_To_Nth(SEQUENCE_3);
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* Interpret(), continued */
case RC_SNAP_NEED_THUNK:
/* Don't snap thunk twice; evaluation of the thunk's body might
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:
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;
}
/* -*-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
{
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");
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]));
\f
#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) ||
FASL_FILE_BAD_VERSION :
FASL_FILE_BAD_SUBVERSION));
}
+
#endif /* INHIBIT_FASL_VERSION_CHECK */
\f
#ifndef INHIBIT_COMPILED_VERSION_CHECK
/* -*-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
#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
#define UNMARKED_HISTORY_TYPE TC_HUNK3_A
#define MARKED_HISTORY_TYPE TC_HUNK3_B
+
+#define case_TC_FIXNUMs case TC_FIXNUM
/* -*-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
preserve_signal_mask ();
Set_Time_Zone (Zone_Working);
Import_Registers ();
-\f
+ \f
Repeat_Dispatch:
switch (Which_Way)
- {
+ {
case PRIM_APPLY:
PROCEED_AFTER_PRIMITIVE();
case CODE_MAP(PRIM_APPLY):
LOG_FUTURES();
case CODE_MAP(PRIM_REENTER):
goto Perform_Application;
-\f
+ \f
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);
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);
}
- }
-\f
+ \f
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;
- }
-\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;
+ }
+ \f
Eval_Non_Trapping:
Eval_Ucode_Hook();
switch (OBJECT_TYPE (Fetch_Expression()))
- {
+ {
default:
#if FALSE
Eval_Error(ERR_UNDEFINED_USER_TYPE);
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:
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());
Export_Registers();
Microcode_Termination (TERM_BROKEN_HEART);
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* Interpret(), continued */
case TC_COMBINATION:
{
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, {});
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());
goto return_from_compiled_code;
}
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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());
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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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();
case TC_MANIFEST_SPECIAL_NM_VECTOR:
Eval_Error(ERR_EXECUTE_MANIFEST_VECTOR);
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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, {});
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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* Interpret(), continued */
-/* Now restore the continuation saved during an earlier part
- * of the EVAL cycle and continue as directed.
- */
+ /* 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
*/
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:
Save_Env();
Do_Another_Then(RC_COMB_2_PROCEDURE, COMB_2_ARG_1);
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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)
define_compiler_restart (RC_COMP_UNBOUND_P_RESTART,
comp_unbound_p_restart)
-\f
+ \f
define_compiler_restart (RC_COMP_ASSIGNMENT_RESTART,
comp_assignment_restart)
define_compiler_restart (RC_COMP_ERROR_RESTART,
comp_error_restart)
\f
- 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();
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());
-\f
+ \f
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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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 */
-\f
-/* 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 */
+ \f
+ /* 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 */
-\f
-/* 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 */
+ \f
+ /* 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 */
-\f
-/* Interpret(), continued */
+ if (value == UNASSIGNED_OBJECT)
+ value = bogus_unassigned;
+
+ /* Interpret() continues on the next page */
+ \f
+ /* 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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* Interpret(), continued */
case RC_EXECUTE_DEFINITION_FINISH:
{
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);
}
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
Import_Registers_Except_Val();
break;
#endif
-\f
+ \f
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;
- }
-\f
-/* Internal_Apply, the core of the application mechanism.
+ \f
+ /* 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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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;
Stop_Trapping ();
}
-Apply_Non_Trapping:
+ Apply_Non_Trapping:
- if ((PENDING_INTERRUPTS()) != 0)
+ if ((PENDING_INTERRUPTS()) != 0)
{
long Interrupts;
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));
&& ((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);
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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* Interpret(), continued */
- case TC_RECORD:
+ case TC_RECORD:
{
SCHEME_OBJECT record_type = (VECTOR_REF (Function, 0));
if ((RECORD_P (record_type))
goto internal_apply_inapplicable;
}
- case TC_PROCEDURE:
+ case TC_PROCEDURE:
{
fast long nargs;
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;
}
}
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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();
goto Pop_Return;
}
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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);
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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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;
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,
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 */
-\f
-/* 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 */
+ \f
+ /* 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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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 ());
- }
-\f
+ {
+ apply_compiled_backout ();
+ Prepare_Apply_Interrupt ();
+ Interrupt (PENDING_INTERRUPTS ());
+ }
+ \f
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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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:
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;
-\f
+ \f
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.
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 ());
}
break;
}
-\f
+ \f
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;
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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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();
Restore_Cont();
goto Repeat_Dispatch;
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* Interpret(), continued */
-/* The following two return codes are both used to restore
- a saved history object. The difference is that the first
- does not copy the history object while the second does.
- In both cases, the Expression register contains the history
- object and the next item to be popped off the stack contains
- the offset back to the previous restore history return code.
+ /* 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 */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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();
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:
Stack_Pointer = (STACK_LOCATIVE_OFFSET (Stack_Pointer, 1));
break;
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* 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();
Restore_Env();
Reduces_To_Nth(SEQUENCE_3);
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
+ /* Interpret() continues on the next page */
+ \f
+ /* Interpret(), continued */
case RC_SNAP_NEED_THUNK:
/* Don't snap thunk twice; evaluation of the thunk's body might
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:
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;
}
/* -*-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
#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
projects / mit-scheme.git / commitdiff