promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hooks.c,v 9.24 1987/05/14 13:48:56 cph Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hooks.c,v 9.25 1987/08/01 06:56:26 jinx Exp $
*
* This file contains various hooks and handles which connect the
* primitives with the main interpreter.
Touch_In_Primitive( Arg2, scan_list);
number_of_args = 0;
while (Type_Code( scan_list) == TC_LIST)
- {
- number_of_args += 1;
- Touch_In_Primitive( Vector_Ref( scan_list, CONS_CDR), scan_list);
- }
+ {
+ number_of_args += 1;
+ Touch_In_Primitive( Vector_Ref( scan_list, CONS_CDR), scan_list);
+ }
if (scan_list != NIL)
- Primitive_Error( ERR_ARG_2_WRONG_TYPE);
+ {
+ signal_error_from_primitive( ERR_ARG_2_WRONG_TYPE);
+ }
#ifdef USE_STACKLETS
/* This is conservative: if the number of arguments is large enough
the Will_Push below may try to allocate space on the heap for the
i = number_of_args;
Touch_In_Primitive( Arg2, scan_list);
while (i > 0)
- {
+ {
#ifdef butterfly
- /* Check for abominable case of someone bashing the arg list. */
- if (Type_Code( scan_list) != TC_LIST)
- {
- Stack_Pointer = saved_stack_pointer;
- Primitive_Error( ERR_ARG_2_BAD_RANGE);
- }
-#endif
- *scan_stack++ = Vector_Ref( scan_list, CONS_CAR);
- Touch_In_Primitive( Vector_Ref( scan_list, CONS_CDR), scan_list);
- i -= 1;
+ /* Check for abominable case of someone bashing the arg list. */
+ if (Type_Code( scan_list) != TC_LIST)
+ {
+ Stack_Pointer = saved_stack_pointer;
+ signal_error_from_primitive( ERR_ARG_2_BAD_RANGE);
}
+#endif
+ *scan_stack++ = Vector_Ref( scan_list, CONS_CAR);
+ Touch_In_Primitive( Vector_Ref( scan_list, CONS_CDR), scan_list);
+ i -= 1;
+ }
Push( Arg1); /* The procedure */
Push( (STACK_FRAME_HEADER + number_of_args));
Pushed();
- longjmp( *Back_To_Eval, PRIM_APPLY);
+ PRIMITIVE_ABORT( PRIM_APPLY);
/*NOTREACHED*/
}
\f
*/ \
Pop_Primitive_Frame(1); \
if (Return_Hook_Address != NULL) \
- { *Return_Hook_Address = Old_Return_Code; \
+ { \
+ *Return_Hook_Address = Old_Return_Code; \
Return_Hook_Address = NULL; \
} \
/* Put down frames to restore history and interrupts so that these \
/* Will_Push(3); -- we just cleared the stack so there MUST be room */ \
Push(Control_Point); \
Push(Arg1); /* Function */ \
- Push(STACK_FRAME_HEADER+1);
+ Push(STACK_FRAME_HEADER+1); \
/* Pushed(); */
\f
#ifdef USE_STACKLETS
CONTINUATION_SIZE + \
HISTORY_SIZE)
-#define CWCC_2() \
-{ fast long i; \
- fast long Stack_Cells = (Stack_Top-Stack_Pointer); \
- Control_Point = Make_Pointer(TC_CONTROL_POINT, Free); \
- Free[STACKLET_LENGTH] = \
- Make_Non_Pointer(TC_MANIFEST_VECTOR, \
- Stack_Cells + STACKLET_HEADER_SIZE - 1); \
- Free[STACKLET_UNUSED_LENGTH] = \
- Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0); \
- Free += STACKLET_HEADER_SIZE; \
- for (i=0; i < Stack_Cells; i++) *Free++ = Pop(); \
- if (Consistency_Check) \
- if (Stack_Pointer != Stack_Top) \
- Microcode_Termination(TERM_BAD_STACK); \
- Will_Push(CONTINUATION_SIZE); \
- Store_Return(RC_JOIN_STACKLETS); \
- Store_Expression(Control_Point); \
- Save_Cont(); \
- Pushed(); \
+#define CWCC_2() \
+{ \
+ fast long i, Stack_Cells; \
+ \
+ Stack_Cells = (Stack_Top-Stack_Pointer); \
+ Control_Point = Make_Pointer(TC_CONTROL_POINT, Free); \
+ Free[STACKLET_LENGTH] = \
+ Make_Non_Pointer(TC_MANIFEST_VECTOR, \
+ Stack_Cells + STACKLET_HEADER_SIZE - 1); \
+ Free[STACKLET_UNUSED_LENGTH] = \
+ Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0); \
+ Free += STACKLET_HEADER_SIZE; \
+ for (i=0; i < Stack_Cells; i++) \
+ { \
+ *Free++ = Pop(); \
+ } \
+ if (Consistency_Check) \
+ { \
+ if (Stack_Pointer != Stack_Top) \
+ Microcode_Termination(TERM_BAD_STACK); \
+ } \
+ Will_Push(CONTINUATION_SIZE); \
+ Store_Return(RC_JOIN_STACKLETS); \
+ Store_Expression(Control_Point); \
+ Save_Cont(); \
+ Pushed(); \
}
#endif
\f
CWCC(RC_RESTORE_HISTORY);
Clear_Danger_Bit((Get_Pointer(Control_Point))[STACKLET_UNUSED_LENGTH]);
- longjmp(*Back_To_Eval, PRIM_APPLY);
+ PRIMITIVE_ABORT( PRIM_APPLY);
/*NOTREACHED*/
}
#endif
- longjmp(*Back_To_Eval, PRIM_APPLY);
+ PRIMITIVE_ABORT( PRIM_APPLY);
/*NOTREACHED*/
}
\f
Arg_1_Type(TC_FIXNUM);
Result = Make_Non_Pointer(TC_FIXNUM, IntEnb);
- IntEnb = Get_Integer(Arg1) | INT_Mask;
+ IntEnb = (Get_Integer(Arg1) | INT_Mask);
New_Compiler_MemTop();
- return Result;
+ PRIMITIVE_RETURN( Result);
}
/* (ERROR-PROCEDURE arg1 arg2 arg3)
Push(Get_Fixed_Obj_Slot(Error_Procedure));
Push(STACK_FRAME_HEADER+3);
Pushed();
- longjmp(*Back_To_Eval, PRIM_APPLY);
+ PRIMITIVE_ABORT( PRIM_APPLY);
/*NOTREACHED*/
}
Primitive_0_Args();
if (Valid_Fixed_Obj_Vector())
- return Get_Fixed_Obj_Slot(Me_Myself);
- else return NIL;
+ PRIMITIVE_RETURN( Get_Fixed_Obj_Slot(Me_Myself));
+ else
+ PRIMITIVE_RETURN( NIL);
}
\f
/* (FORCE DELAYED-OBJECT)
Arg_1_Type(TC_DELAYED);
if (Vector_Ref(Arg1, THUNK_SNAPPED) == TRUTH)
- return Vector_Ref(Arg1, THUNK_VALUE);
+ PRIMITIVE_RETURN( Vector_Ref(Arg1, THUNK_VALUE));
Pop_Primitive_Frame(1);
Will_Push(CONTINUATION_SIZE);
Store_Return(RC_SNAP_NEED_THUNK);
Pushed();
Store_Env(Fast_Vector_Ref(Arg1, THUNK_ENVIRONMENT));
Store_Expression(Fast_Vector_Ref(Arg1, THUNK_PROCEDURE));
- longjmp(*Back_To_Eval, PRIM_DO_EXPRESSION);
+ PRIMITIVE_ABORT( PRIM_DO_EXPRESSION);
/*NOTREACHED*/
}
\f
Primitive_4_Args();
guarantee_state_point();
- if (Arg1 == NIL) Old_Point = Current_State_Point;
+ if (Arg1 == NIL)
+ Old_Point = Current_State_Point;
else
- { Arg_1_Type(TC_VECTOR);
+ {
+ Arg_1_Type(TC_VECTOR);
if (Vector_Ref(Arg1, STATE_SPACE_TAG) !=
Get_Fixed_Obj_Slot(State_Space_Tag))
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ {
+ signal_error_from_primitive(ERR_ARG_1_WRONG_TYPE);
+ }
Old_Point = Fast_Vector_Ref(Arg1, STATE_SPACE_NEAREST_POINT);
}
Primitive_GC_If_Needed(STATE_POINT_SIZE);
Save_Cont();
Pushed();
Translate_To_Point(New_Point);
+ /*NOTREACHED*/
}
\f
/* (MAKE-STATE-SPACE MUTABLE?)
Free[STATE_POINT_DISTANCE_TO_ROOT] = Make_Unsigned_Fixnum(0);
Free += STATE_POINT_SIZE;
if (Arg1 == NIL)
- { Current_State_Point = New_Point;
- return NIL;
+ {
+ Current_State_Point = New_Point;
+ PRIMITIVE_RETURN( NIL);
}
else
- { Pointer New_Space = Make_Pointer(TC_VECTOR, Free);
+ {
+ Pointer New_Space;
+
+ New_Space = Make_Pointer(TC_VECTOR, Free);
Free[STATE_SPACE_HEADER] =
Make_Non_Pointer(TC_MANIFEST_VECTOR, STATE_SPACE_SIZE-1);
Free[STATE_SPACE_TAG] = Get_Fixed_Obj_Slot(State_Space_Tag);
Free[STATE_SPACE_NEAREST_POINT] = New_Point;
Free += STATE_SPACE_SIZE;
Fast_Vector_Set(New_Point, STATE_POINT_NEARER_POINT, New_Space);
- return New_Space;
+ PRIMITIVE_RETURN( New_Space);
}
}
\f
Primitive_1_Arg();
guarantee_state_point();
- if (Arg1 == NIL) return Current_State_Point;
+ if (Arg1 == NIL)
+ {
+ PRIMITIVE_RETURN( Current_State_Point);
+ }
Arg_1_Type(TC_VECTOR);
if (Fast_Vector_Ref(Arg1, STATE_SPACE_TAG) !=
Get_Fixed_Obj_Slot(State_Space_Tag))
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- return Vector_Ref(Arg1, STATE_SPACE_NEAREST_POINT);
+ {
+ signal_error_from_primitive(ERR_ARG_1_WRONG_TYPE);
+ }
+ PRIMITIVE_RETURN( Vector_Ref(Arg1, STATE_SPACE_NEAREST_POINT));
}
Built_In_Primitive(Prim_Set_Dynamic_State, 1, "SET-CURRENT-DYNAMIC-STATE!", 0xB)
Arg_1_Type(TC_VECTOR);
if (Fast_Vector_Ref(Arg1, STATE_POINT_TAG) !=
Get_Fixed_Obj_Slot(State_Point_Tag))
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ signal_error_from_primitive(ERR_ARG_1_WRONG_TYPE);
State_Space = Find_State_Space(Arg1);
- if (State_Space==NIL)
+ if (State_Space == NIL)
{
guarantee_state_point();
Result = Current_State_Point;
Result = Vector_Ref(State_Space, STATE_SPACE_NEAREST_POINT);
Vector_Set(State_Space, STATE_SPACE_NEAREST_POINT, Arg1);
}
- return Result;
+ PRIMITIVE_RETURN( Result);
}
\f
/* (SCODE-EVAL SCODE-EXPRESSION ENVIRONMENT)
Pop_Primitive_Frame(2);
Store_Env(Arg2);
Store_Expression(Arg1);
- longjmp(*Back_To_Eval, PRIM_DO_EXPRESSION);
+ PRIMITIVE_ABORT( PRIM_DO_EXPRESSION);
/*NOTREACHED*/
}
Arg_1_Type(TC_FIXNUM);
Result = Make_Unsigned_Fixnum(IntEnb);
- IntEnb = Get_Integer(Arg1) & INT_Mask;
+ IntEnb = (Get_Integer(Arg1) & INT_Mask);
New_Compiler_MemTop();
- return Result;
+ PRIMITIVE_RETURN( Result);
}
\f
/* (SET-CURRENT-HISTORY! TRIPLE)
History = Get_Pointer(Get_Fixed_Obj_Slot(Dummy_History));
#endif
Pop_Primitive_Frame( 1);
- longjmp( *Back_To_Eval, PRIM_POP_RETURN);
+ PRIMITIVE_ABORT( PRIM_POP_RETURN);
/*NOTREACHED*/
}
Primitive_1_Arg();
Arg_1_Type(TC_VECTOR);
+ if (Vector_Length(Arg1) < NFixed_Objects)
+ {
+ signal_error_from_primitive (ERR_ARG_1_BAD_RANGE);
+ }
+
if (Valid_Fixed_Obj_Vector())
+ {
Result = Get_Fixed_Obj_Slot(Me_Myself);
- else Result = NIL;
+ }
+ else
+ {
+ Result = NIL;
+ }
Set_Fixed_Obj_Hook(Arg1);
Set_Fixed_Obj_Slot(Me_Myself, Arg1);
- return Result;
+ PRIMITIVE_RETURN( Result);
}
\f
/* (TRANSLATE-TO-STATE-POINT STATE_POINT)
Arg_1_Type(TC_VECTOR);
if (Vector_Ref(Arg1, STATE_POINT_TAG) != Get_Fixed_Obj_Slot(State_Point_Tag))
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ signal_error_from_primitive(ERR_ARG_1_WRONG_TYPE);
Pop_Primitive_Frame(1);
Translate_To_Point(Arg1);
- /* This ends by longjmp-ing back to the interpreter */
/*NOTREACHED*/
}
Second_Rib = Get_Pointer(First_Rib[RIB_NEXT_REDUCTION]);
if (!((Dangerous(First_Rib[RIB_MARK])) ||
(First_Rib == Second_Rib)))
- { Set_Danger_Bit(Second_Rib[RIB_MARK]);
+ {
+ Set_Danger_Bit(Second_Rib[RIB_MARK]);
for (Rib = First_Rib;
Get_Pointer(Rib[RIB_NEXT_REDUCTION]) != First_Rib;
Rib = Get_Pointer(Rib[RIB_NEXT_REDUCTION]))
- { /* Look for one that points to the first rib */ }
+ {
+ /* Look for one that points to the first rib */
+ }
History[HIST_RIB] = Make_Pointer(Type_Code(History[HIST_RIB]), Rib);
}
Pop_Primitive_Frame(1);
Push(Arg1);
Push(STACK_FRAME_HEADER);
Pushed();
- longjmp(*Back_To_Eval, PRIM_APPLY);
+ PRIMITIVE_ABORT( PRIM_APPLY);
/*NOTREACHED*/
}
\f
Push(Arg2); /* Function to call */
Push(STACK_FRAME_HEADER+1);
Pushed();
- IntEnb = INT_Mask & Get_Integer(Arg1);
- longjmp(*Back_To_Eval, PRIM_APPLY);
+ IntEnb = (INT_Mask & Get_Integer(Arg1));
+ PRIMITIVE_ABORT( PRIM_APPLY);
/*NOTREACHED*/
}
{
long new_interrupt_mask;
Primitive_2_Args();
+
Arg_1_Type(TC_FIXNUM);
Pop_Primitive_Frame(2);
Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2));
IntEnb = new_interrupt_mask;
else
IntEnb = (new_interrupt_mask & IntEnb);
- longjmp(*Back_To_Eval, PRIM_APPLY);
+ PRIMITIVE_ABORT( PRIM_APPLY);
/*NOTREACHED*/
}
\f
Push(Arg2);
Push(STACK_FRAME_HEADER);
Pushed();
- longjmp(*Back_To_Eval, PRIM_APPLY);
+ PRIMITIVE_ABORT( PRIM_APPLY);
/*NOTREACHED*/
}
Push(Arg2); /* Function to call now */
Push(STACK_FRAME_HEADER);
Pushed();
- longjmp(*Back_To_Eval, PRIM_APPLY);
+ PRIMITIVE_ABORT( PRIM_APPLY);
/*NOTREACHED*/
}
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/intern.c,v 9.41 1987/05/15 18:19:45 cph Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/intern.c,v 9.42 1987/08/01 06:56:48 jinx Rel $
Utilities for manipulating symbols.
*/
fast long i, Value, End_Count;
Value = (LENGTH_MULTIPLIER * String_Length);
- End_Count =
- ((String_Length > MAX_HASH_CHARS) ? MAX_HASH_CHARS : String_Length);
+ End_Count = ((String_Length > MAX_HASH_CHARS) ?
+ MAX_HASH_CHARS :
+ String_Length);
for (i = 0; i < End_Count; i++)
Value = ((Value << SHIFT_AMOUNT) + (MAX_CHAR & String_Ptr[i]));
return (Value);
Hash (string)
Pointer string;
{
- return (Make_Signed_Fixnum (scheme_string_hash (string)));
+ return (MAKE_SIGNED_FIXNUM (scheme_string_hash (string)));
}
Boolean
*/
void
-Find_Symbol(Scheme_String)
- Pointer Scheme_String;
+Find_Symbol(scheme_string)
+ Pointer scheme_string;
{
- Pointer Ob_Array, The_Symbol, *Bucket;
- char *String, *Temp_String;
- long i, Hashed_Value;
-
- String = Scheme_String_To_C_String(Scheme_String);
- for (Temp_String = String, i = 0; *Temp_String == '\0'; i++)
- Temp_String++;
- Hashed_Value = Do_Hash(String, i);
- Ob_Array = Get_Fixed_Obj_Slot(OBArray);
- Hashed_Value %= Vector_Length(Ob_Array);
- Bucket = Nth_Vector_Loc(Ob_Array, Hashed_Value);
- while (*Bucket != NIL)
+ Pointer the_obarray, symbol, *bucket;
+ long hash_of_string;
+
+ hash_of_string = scheme_string_hash(scheme_string);
+ the_obarray = Get_Fixed_Obj_Slot(OBArray);
+ hash_of_string %= Vector_Length(the_obarray);
+ bucket = Nth_Vector_Loc(the_obarray, hash_of_string);
+ while (*bucket != NIL)
{
- if (string_equal(Scheme_String,
- Vector_Ref(Vector_Ref(*Bucket, CONS_CAR),
+ if (string_equal(scheme_string,
+ Vector_Ref(Vector_Ref(*bucket, CONS_CAR),
SYMBOL_NAME)))
{
- The_Symbol = Vector_Ref(*Bucket, CONS_CAR);
- printf("\nInterned Symbol: 0x%x", The_Symbol);
- Print_Expression(Vector_Ref(The_Symbol, SYMBOL_GLOBAL_VALUE),
+ symbol = Vector_Ref(*bucket, CONS_CAR);
+ printf("\nInterned Symbol: 0x%x", symbol);
+ Print_Expression(Vector_Ref(symbol, SYMBOL_GLOBAL_VALUE),
"Value");
printf("\n");
return;
}
- Bucket = Nth_Vector_Loc(*Bucket, CONS_CDR);
+ bucket = Nth_Vector_Loc(*bucket, CONS_CDR);
}
printf("\nNot interned.\n");
+ return;
}
\f
/* (STRING->SYMBOL STRING)
Primitive_1_Arg();
Arg_1_Type(TC_CHARACTER_STRING);
- return string_to_symbol(Arg1);
+ PRIMITIVE_RETURN( string_to_symbol(Arg1));
}
/* (INTERN-CHARACTER-LIST LIST)
extern Pointer list_to_string();
Primitive_1_Arg();
- return string_to_symbol(list_to_string(Arg1));
+ PRIMITIVE_RETURN( string_to_symbol(list_to_string(Arg1)));
}
/* (STRING-HASH STRING)
Primitive_1_Arg();
Arg_1_Type(TC_CHARACTER_STRING);
- return Hash(Arg1);
+ PRIMITIVE_RETURN( Hash(Arg1));
}
Built_In_Primitive (Prim_string_hash_mod, 2, "STRING-HASH-MOD", 0x8A)
Primitive_2_Args ();
CHECK_ARG (1, STRING_P);
- return
- (MAKE_UNSIGNED_FIXNUM
- ((scheme_string_hash (Arg1)) % (arg_nonnegative_integer (2))));
+ PRIMITIVE_RETURN (MAKE_UNSIGNED_FIXNUM
+ ((scheme_string_hash (Arg1)) %
+ (arg_nonnegative_integer (2))));
}
\f
/* (CHARACTER-LIST-HASH LIST)
{
Touch_In_Primitive(Vector_Ref(Arg1, CONS_CAR), This_Char);
if (Type_Code(This_Char) != TC_CHARACTER)
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ {
+ signal_error_from_primitive (ERR_ARG_1_WRONG_TYPE);
+ }
Range_Check(String[Length], This_Char,
'\0', ((char) MAX_CHAR),
ERR_ARG_1_WRONG_TYPE);
}
}
if (Arg1 != NIL)
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- return
- Make_Non_Pointer(TC_FIXNUM, Do_Hash(String, Length));
+ {
+ signal_error_from_primitive (ERR_ARG_1_WRONG_TYPE);
+ }
+ PRIMITIVE_RETURN (MAKE_SIGNED_FIXNUM(Do_Hash(String, Length)));
}
projects / mit-scheme.git / commitdiff