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/Attic/fhooks.c,v 9.21 1987/01/22 14:24:45 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/fhooks.c,v 9.22 1987/04/03 00:43:16 jinx Exp $
*
* This file contains hooks and handles for the new fluid bindings
* scheme for multiprocessors.
#include "scheme.h"
#include "primitive.h"
+#include "trap.h"
+#include "lookup.h"
#include "locks.h"
-
+\f
/* (SET-FLUID-BINDINGS! NEW-BINDINGS)
- Sets the microcode fluid-bindings variable. Returns the previous value.
+ Sets the microcode fluid-bindings variable. Returns the previous value.
*/
+
Define_Primitive(Prim_Set_Fluid_Bindings, 1, "SET-FLUID-BINDINGS!")
-{ Pointer Result;
+{
+ Pointer Result;
Primitive_1_Arg();
- if (Arg1 != NIL) Arg_1_Type(TC_LIST);
+
+ if (Arg1 != NIL)
+ Arg_1_Type(TC_LIST);
+
Result = Fluid_Bindings;
Fluid_Bindings = Arg1;
return Result;
}
/* (GET-FLUID-BINDINGS NEW-BINDINGS)
- Gets the microcode fluid-bindings variable.
+ Gets the microcode fluid-bindings variable.
*/
+
Define_Primitive(Prim_Get_Fluid_Bindings, 0, "GET-FLUID-BINDINGS")
-{ Primitive_0_Args();
+{
+ Primitive_0_Args();
+
return Fluid_Bindings;
}
/* (WITH-SAVED-FLUID-BINDINGS THUNK)
- Executes THUNK, then restores the previous fluid bindings.
+ Executes THUNK, then restores the previous fluid bindings.
*/
+
Define_Primitive(Prim_With_Saved_Fluid_Bindings,1,"WITH-SAVED-FLUID-BINDINGS")
-{ Primitive_1_Arg();
+{
+ Primitive_1_Arg();
+
Pop_Primitive_Frame(1);
+
/* Save previous fluid bindings for later restore */
+
Will_Push(CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
Store_Expression(Fluid_Bindings);
Store_Return(RC_RESTORE_FLUIDS);
longjmp(*Back_To_Eval, PRIM_APPLY);
}
\f
+/* Utilities for the primitives below. */
+
+Pointer
+*lookup_slot(env, var)
+{
+ Pointer *cell, *hunk, value;
+ long trap_kind;
+
+ hunk = Get_Pointer(var);
+ lookup(cell, env, hunk, repeat_slot_lookup);
+
+ value = Fetch(cell[0]);
+
+ if (Type_Code(value) != TC_REFERENCE_TRAP)
+ {
+ return cell;
+ }
+
+ get_trap_kind(trap_kind, value);
+ switch(trap_kind)
+ {
+ case TRAP_DANGEROUS:
+ case TRAP_UNBOUND_DANGEROUS:
+ case TRAP_UNASSIGNED_DANGEROUS:
+ case TRAP_FLUID_DANGEROUS:
+ return deep_lookup(env, hunk[VARIABLE_SYMBOL], hunk);
+
+ case TRAP_FLUID:
+ case TRAP_UNBOUND:
+ case TRAP_UNASSIGNED:
+ return cell;
+
+ default:
+ Primitive_Error(ERR_BROKEN_COMPILED_VARIABLE);
+ }
+}
+\f
+Pointer
+new_fluid_binding(cell, value, force)
+ Pointer *cell;
+ Pointer value;
+ Boolean force;
+{
+ fast Pointer trap;
+ Lock_Handle set_serializer;
+ Pointer new_trap_value;
+ long new_trap_kind, trap_kind;
+
+ setup_lock(set_serializer, cell);
+
+ new_trap_kind = TRAP_FLUID;
+ trap = *cell;
+ new_trap_value = trap;
+
+ if (Type_Code(trap) == TC_REFERENCE_TRAP)
+ {
+ get_trap_kind(trap_kind, trap);
+ switch(trap_kind)
+ {
+ case TRAP_DANGEROUS:
+ Vector_Set(trap,
+ TRAP_TAG,
+ Make_Unsigned_Fixnum(TRAP_FLUID_DANGEROUS));
+
+ /* Fall through */
+ case TRAP_FLUID:
+ case TRAP_FLUID_DANGEROUS:
+ new_trap_kind = TRAP_NOP;
+ break;
+\f
+ case TRAP_UNBOUND:
+ case TRAP_UNBOUND_DANGEROUS:
+ if (!force)
+ {
+ remove_lock(set_serializer);
+ Primitive_Error(ERR_UNBOUND_VARIABLE);
+ }
+ /* Fall through */
+ case TRAP_UNASSIGNED:
+ case TRAP_UNASSIGNED_DANGEROUS:
+ new_trap_kind = Make_Unsigned_Fixnum((TRAP_FLUID | (trap_kind & 1)));
+ new_trap_value = UNASSIGNED_OBJECT;
+ break;
+
+ default:
+ remove_lock(set_serializer);
+ Primitive_Error(ERR_BROKEN_COMPILED_VARIABLE);
+ }
+ }
+
+ if (new_trap_kind != TRAP_NOP)
+ {
+ if (GC_allocate_test(2))
+ {
+ remove_lock(set_serializer);
+ Primitive_GC(2);
+ }
+ trap = Make_Pointer(TC_REFERENCE_TRAP, Free);
+ *Free++ = new_trap_kind;
+ *Free++ = new_trap_value;
+ *cell = trap;
+ }
+ remove_lock(set_serializer);
+
+ /* Fluid_Bindings is per processor private. */
+
+ Primitive_GC_If_Needed(4);
+ Free[CONS_CAR] = Make_Pointer(TC_LIST, (Free + 2));
+ Free[CONS_CDR] = Fluid_Bindings;
+ Fluid_Bindings = Make_Pointer(TC_LIST, Free);
+ Free += 2;
+ Free[CONS_CAR] = trap;
+ Free[CONS_CDR] = value;
+ Free += 2;
+
+ return NIL;
+}
+\f
/* (ADD-FLUID-BINDING! ENVIRONMENT SYMBOL-OR-VARIABLE VALUE)
Looks up symbol-or-variable in environment. If it has not been
fluidized, fluidizes it. A fluid binding with the specified
value is created in this interpreter's fluid bindings.
*/
-Define_Primitive(Prim_Add_Fluid_Binding, 3, "ADD-FLUID-BINDING!")
-{ Pointer Trap_Obj;
- int Temp_Obj;
+Define_Primitive(Prim_Add_Fluid_Binding, 3, "ADD-FLUID-BINDING!")
+{
+ Pointer *cell;
Primitive_3_Args();
- if (Arg1 != GLOBAL_ENV) Arg_1_Type(TC_ENVIRONMENT);
+
+ if (Arg1 != GLOBAL_ENV)
+ Arg_1_Type(TC_ENVIRONMENT);
+
switch (Type_Code(Arg2))
- { case TC_VARIABLE:
- Temp_Obj = Lookup_Slot(Arg2, Arg1);
- if (Temp_Obj == NO_SLOT || Temp_Obj == FOUND_UNBOUND)
- Primitive_Error(ERR_UNBOUND_VARIABLE);
+ {
+ case TC_VARIABLE:
+ cell = lookup_slot(Arg1, Arg2);
break;
+
case TC_INTERNED_SYMBOL:
case TC_UNINTERNED_SYMBOL:
- Temp_Obj = Symbol_Lookup_Slot(Arg1, Arg2);
- if (Temp_Obj == NO_SLOT || Temp_Obj == FOUND_UNBOUND)
- Primitive_Error(ERR_UNBOUND_VARIABLE);
+ cell = deep_lookup(Arg1, Arg2, fake_variable_object);
break;
+
default:
Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- }
- /* Lock region, check if the slot at Lookup_Base[Lookup_Offset] is
- a fluid already. Return it if so, make a new fluid and store it
- there if not, unlock the region. */
- {
-#ifdef COMPILE_FUTURES
- Lock_Handle Set_Serializer;
-#endif
- Pointer Found_Val, Safe_Val;
- if (Lookup_Offset == HEAP_ENV_FUNCTION) Primitive_Error(ERR_BAD_SET);
-#ifdef COMPILE_FUTURES
- Set_Serializer = Lock_Cell(Nth_Vector_Loc(Lookup_Base, Lookup_Offset));
-#endif
- Found_Val = Fast_Vector_Ref(Lookup_Base, Lookup_Offset);
- Safe_Val = Found_Val & ~DANGER_BIT;
- if (Type_Code(Safe_Val) == TC_TRAP) Trap_Obj = Found_Val;
- else
- { Primitive_GC_If_Needed(TRAP_SIZE);
- Trap_Obj = (Pointer) Free;
- *Free++ = NIL; /* Tag for fluids */
- *Free++ = Safe_Val;
- *Free++ = Arg2; /* For debugging purposes */
- Store_Type_Code(Trap_Obj,
- ((Found_Val==Safe_Val)?TC_TRAP:TC_TRAP|DANGER_TYPE));
- Fast_Vector_Set(Lookup_Base, Lookup_Offset, Trap_Obj);
- }
-#ifdef COMPILE_FUTURES
- Unlock_Cell(Set_Serializer);
-#endif
- Add_Fluid_Binding(Trap_Obj, Arg3);
- Val = NIL;
- return Val;
}
+
+ return new_fluid_binding(cell, Arg3, false);
}
\f
-/* (MAKE-FLUID-BINDING! ENVIRONMENT SYMBOL-OR-VARIABLE VALUE)
+/* (MAKE-FLUID-BINDING! ENVIRONMENT SYMBOL-OR-VARIABLE VALUE)
Looks up symbol-or-variable in environment. If it has not been
fluidized, fluidizes it. A fluid binding with the specified
value is created in this interpreter's fluid bindings. Unlike
and does not allow search of the global environment), an AUX
binding must be established in the last frame.
*/
-Define_Primitive(Prim_Make_Fluid_Binding, 3, "MAKE-FLUID-BINDING!")
-{ Pointer Trap_Obj;
+Define_Primitive(Prim_Make_Fluid_Binding, 3, "MAKE-FLUID-BINDING!")
+{
+ Pointer *cell;
+ fast Pointer env, previous;
Primitive_3_Args();
- if (Arg1 != GLOBAL_ENV) Arg_1_Type(TC_ENVIRONMENT);
+
+ if (Arg1 != GLOBAL_ENV)
+ Arg_1_Type(TC_ENVIRONMENT);
+
switch (Type_Code(Arg2))
- { /* Need to check for unbound in non-global env and build
- an AUX binding in that frame if so. Do nothing in
- usual case, unbound in global env.
- */
+ {
case TC_VARIABLE:
- Binding_Lookup_Slot(Arg2, Arg1);
+ cell = lookup_slot(Arg1, Arg2);
break;
+
case TC_INTERNED_SYMBOL:
case TC_UNINTERNED_SYMBOL:
- Symbol_Binding_Lookup_Slot(Arg1, Arg2);
+ cell = deep_lookup(Arg1, Arg2, fake_variable_object);
break;
+
default:
Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- }
- /* Lock region, check if the slot at Lookup_Base[Lookup_Offset] is
- a fluid already. Return it if so, make a new fluid and store it
- there if not, unlock the region. */
- {
-#ifdef COMPILE_FUTURES
- Lock_Handle Set_Serializer;
-#endif
- Pointer Found_Val, Safe_Val;
- if (Lookup_Offset == HEAP_ENV_FUNCTION) Primitive_Error(ERR_BAD_SET);
-#ifdef COMPILE_FUTURES
- Set_Serializer = Lock_Cell(Nth_Vector_Loc(Lookup_Base, Lookup_Offset));
-#endif
- Found_Val = Fast_Vector_Ref(Lookup_Base, Lookup_Offset);
- Safe_Val = Found_Val & ~DANGER_BIT;
- if (Type_Code(Safe_Val) == TC_TRAP) Trap_Obj = Found_Val;
- else
- { Primitive_GC_If_Needed(TRAP_SIZE);
- Trap_Obj = (Pointer) Free;
- *Free++ = NIL; /* Tag for fluids */
- /* Binding version always makes unbounds unassigned */
- *Free++ = (Safe_Val == UNBOUND_OBJECT) ? UNASSIGNED_OBJECT:Safe_Val;
- *Free++ = Arg2; /* For debugging purposes */
- Store_Type_Code(Trap_Obj,
- ((Found_Val==Safe_Val)?TC_TRAP:TC_TRAP|DANGER_TYPE));
- Fast_Vector_Set(Lookup_Base, Lookup_Offset, Trap_Obj);
- }
-#ifdef COMPILE_FUTURES
- Unlock_Cell(Set_Serializer);
-#endif
- Add_Fluid_Binding(Trap_Obj, Arg3);
- Val = NIL;
- return Val;
}
-}
\f
-Add_Fluid_Binding(Key, Value)
-Pointer Key, Value;
-{ Pointer New_Fluids;
-
- Primitive_GC_If_Needed(2 + 2);
- New_Fluids = Make_Pointer(TC_LIST, Free);
- *Free = Make_Pointer(TC_LIST, &Free[2]);
- Free += 1;
- *Free++ = Fluid_Bindings;
- *Free++ = Key;
- *Free++ = Value;
- Fluid_Bindings = New_Fluids;
-}
+ /* This only happens when global is not allowed,
+ it's expensive and will not be used, but is
+ provided for completeness.
+ */
-Symbol_Lookup_Slot(Frame, Symbol)
-Pointer Frame, Symbol;
-{ int result;
- Pointer *Variable = Free;
- Free += 3;
- Variable[VARIABLE_SYMBOL] = (Symbol);
- Variable[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
- result = Lookup_Slot(Make_Pointer(TC_VARIABLE, Variable), (Frame));
- if (Free == Variable+3) Free = Variable;
- return result;
-}
+ if (cell == unbound_trap_object)
+ {
+ long result;
+ Pointer symbol;
-Binding_Symbol_Lookup_Slot(Frame, Symbol)
-Pointer Frame, Symbol;
-{ int result;
- Pointer *Variable = Free;
- Free += 3;
- Variable[VARIABLE_SYMBOL] = (Symbol);
- Variable[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
- result = Binding_Lookup_Slot(Make_Pointer(TC_VARIABLE, Variable), (Frame));
- if (Free == Variable+3) Free = Variable;
- return result;
-}
+ env = Arg1;
+ if (Type_Code(env) == GLOBAL_ENV)
+ Primitive_Error(ERR_BAD_FRAME);
+
+ do
+ {
+ previous = env;
+ env = Fast_Vector_Ref(Vector_Ref(env, ENVIRONMENT_FUNCTION),
+ PROCEDURE_ENVIRONMENT);
+ } while (Type_Code(env) != GLOBAL_ENV);
-/* A version which creates a new binding if unbound in last frame */
-
-Symbol_Binding_Lookup_Slot(Frame, Symbol)
-Pointer Frame, Symbol;
-{ int result;
- Pointer *Variable = Free;
- Free += 3;
- Variable[VARIABLE_SYMBOL] = (Symbol);
- Variable[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
- result = Binding_Lookup_Slot(Make_Pointer(TC_VARIABLE, Variable), (Frame));
- if (Free == Variable+3) Free = Variable;
- return result;
-}
+ symbol = ((Type_Code(Arg2) == TC_VARIABLE) ?
+ Vector_Ref(Arg2, VARIABLE_SYMBOL) :
+ Arg2);
+ result = Local_Set(previous, symbol, UNASSIGNED_OBJECT);
+ if (result != PRIM_DONE)
+ {
+ if (result == PRIM_INTERRUPT)
+ Primitive_Interrupt();
+ Primitive_Error(result);
+ }
+ cell = deep_lookup(previous, symbol, fake_variable_object);
+ }
+
+ return new_fluid_binding(cell, Arg3, true);
+}
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/lookup.h,v 9.35 1987/04/03 00:47:02 jinx Exp $ */
+
+/* Macros and declarations for the variable lookup code. */
+
+extern Pointer
+ *deep_lookup(),
+ *lookup_fluid();
+
+extern long
+ deep_lookup_end(),
+ deep_assignment_end();
+
+extern Pointer
+ unbound_trap_object[],
+ uncompiled_trap_object[],
+ illegal_trap_object[],
+ fake_variable_object[];
+\f
+#define GC_allocate_test(N) GC_Check(N)
+
+#define AUX_LIST_TYPE TC_VECTOR
+
+#define AUX_CHUNK_SIZE 20
+#define AUX_LIST_COUNT ENVIRONMENT_EXTENSION_COUNT
+#define AUX_LIST_FIRST ENVIRONMENT_EXTENSION_MIN_SIZE
+#define AUX_LIST_INITIAL_SIZE (AUX_LIST_FIRST + AUX_CHUNK_SIZE)
+
+/* Variable compilation types. */
+
+#define LOCAL_REF TC_NULL
+#define GLOBAL_REF TC_UNINTERNED_SYMBOL
+#define FORMAL_REF TC_CHARACTER
+#define AUX_REF TC_FIXNUM
+#define UNCOMPILED_REF TC_TRUE
+
+/* Common constants. */
+
+#ifndef b32
+#define UNCOMPILED_VARIABLE Make_Non_Pointer(UNCOMPILED_REF, 0)
+#else
+#define UNCOMPILED_VARIABLE 0x08000000
+#endif
+
+/* Macros for speedy variable reference. */
+
+#if (LOCAL_REF == 0)
+
+#define Lexical_Offset(Ind) ((long) (Ind))
+#define Make_Local_Offset(Ind) ((Pointer) (Ind))
+
+#else
+
+#define Lexical_Offset(Ind) Get_Integer(Ind)
+#define Make_Local_Offset(Ind) Make_Non_Pointer(LOCAL_REF, Ind)
+
+#endif
+\f
+/* The code below depends on the following. */
+
+#if ((VARIABLE_OFFSET == VARIABLE_COMPILED_TYPE) || \
+ (VARIABLE_FRAME_NO != VARIABLE_COMPILED_TYPE))
+#include "error: trap.h inconsistency detected."
+#endif
+
+#define get_offset(hunk) Lexical_Offset(Fetch(hunk[VARIABLE_OFFSET]))
+
+#ifdef PARALLEL_PROCESSOR
+
+#define verify(type_code, variable, code, label) \
+{ \
+ variable = code; \
+ if (Type_Code(Fetch(hunk[VARIABLE_COMPILED_TYPE])) != \
+ type_code) \
+ goto label; \
+}
+
+#define verified_offset(variable, code) variable
+
+/* Unlike Lock_Cell, cell must be (Pointer *). This currently does
+ not matter, but might on a machine with address mapping.
+ */
+#define setup_lock(handle, cell) handle = Lock_Cell(cell)
+#define remove_lock(handle) Unlock_Cell(handle)
+
+#else
+
+#define verify(type_code, variable, code, label)
+#define verified_offset(variable, code) code
+#define setup_lock(handle, cell)
+#define remove_lock(ignore)
+
+#endif
+\f
+/* Pointer *cell, env, *hunk; */
+
+#define lookup(cell, env, hunk, label) \
+{ \
+ fast Pointer frame; \
+ long offset; \
+ \
+label: \
+ \
+ frame = Fetch(hunk[VARIABLE_COMPILED_TYPE]); \
+ \
+ switch (Type_Code(frame)) \
+ { \
+ case GLOBAL_REF: \
+ /* frame is a pointer to the same symbol. */ \
+ cell = Nth_Vector_Loc(frame, SYMBOL_GLOBAL_VALUE); \
+ break; \
+ \
+ case LOCAL_REF: \
+ cell = Nth_Vector_Loc(env, Lexical_Offset(frame)); \
+ break; \
+ \
+ case FORMAL_REF: \
+ { \
+ fast long depth; \
+ \
+ verify(FORMAL_REF, offset, get_offset(hunk), label); \
+ \
+ depth = Get_Integer(frame); \
+ frame = env; \
+ while(--depth >= 0) \
+ { \
+ frame = Fast_Vector_Ref(Vector_Ref(frame, ENVIRONMENT_FUNCTION), \
+ PROCEDURE_ENVIRONMENT); \
+ } \
+ \
+ cell = Nth_Vector_Loc(frame, \
+ verified_offset(offset, get_offset(hunk))); \
+ \
+ break; \
+ } \
+\f \
+ case AUX_REF: \
+ { \
+ fast long depth; \
+ \
+ verify(AUX_REF, offset, get_offset(hunk), label); \
+ \
+ depth = Get_Integer(frame); \
+ frame = env; \
+ while(--depth >= 0) \
+ { \
+ frame = Fast_Vector_Ref(Vector_Ref(frame, ENVIRONMENT_FUNCTION), \
+ PROCEDURE_ENVIRONMENT); \
+ } \
+ \
+ frame = Vector_Ref(frame, ENVIRONMENT_FUNCTION); \
+ if (Type_Code(frame) != AUX_LIST_TYPE) \
+ { \
+ cell = uncompiled_trap_object; \
+ break; \
+ } \
+ depth = verified_offset(offset, get_offset(hunk)); \
+ if (depth > Vector_Length(frame)) \
+ { \
+ cell = uncompiled_trap_object; \
+ break; \
+ } \
+ frame = Vector_Ref(frame, depth); \
+ if ((frame == NIL) || \
+ (Fast_Vector_Ref(frame, CONS_CAR) != hunk[VARIABLE_SYMBOL])) \
+ { \
+ cell = uncompiled_trap_object; \
+ break; \
+ } \
+ cell = Nth_Vector_Loc(frame, CONS_CDR); \
+ break; \
+ } \
+ \
+ default: \
+ /* Done here rather than in a separate case because of \
+ peculiarities of the bobcat compiler. \
+ */ \
+ cell = ((Type_Code(frame) == UNCOMPILED_REF) ? \
+ uncompiled_trap_object : \
+ illegal_trap_object); \
+ break; \
+ } \
+}
+\f
+#define lookup_primitive_type_test() \
+{ \
+ if (Type_Code(Arg1) != GLOBAL_ENV) Arg_1_Type(TC_ENVIRONMENT); \
+ if (Type_Code(Arg2) != TC_INTERNED_SYMBOL) \
+ Arg_2_Type(TC_UNINTERNED_SYMBOL); \
+}
+
+#define lookup_primitive_end(Result) \
+{ \
+ if (Result == PRIM_DONE) \
+ return Val; \
+ if (Result == PRIM_INTERRUPT) \
+ Primitive_Interrupt(); \
+ Primitive_Error(Result); \
+}
+
+#define standard_lookup_primitive(action) \
+{ \
+ long Result; \
+ \
+ lookup_primitive_type_test(); \
+ Result = action; \
+ lookup_primitive_end(Result); \
+ /*NOTREACHED*/ \
+}
+
+
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prim.h,v 9.35 1987/04/03 00:48:04 jinx Exp $ */
+
+/* External primitive definition structure. */
+
+typedef struct ext_desc /* User supplied primitive data */
+{
+ Pointer (*proc)(); /* Location of actual procedure */
+ int arity; /* Number of arguments */
+ char *name; /* Name of primitive */
+} External_Descriptor;
+
+extern External_Descriptor Ext_Prim_Desc[];
+extern long MAX_EXTERNAL_PRIMITIVE, Get_Ext_Number();
+extern Pointer Undefined_Externals, Make_Prim_Exts();
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/trap.h,v 9.35 1987/04/03 00:46:33 jinx Exp $ */
+\f
+/* Kinds of traps:
+
+ Note that for every trap there is a dangerous version.
+ The danger bit is the bottom bit of the trap number,
+ thus all dangerous traps are odd and viceversa.
+
+ For efficiency, some traps are immediate, while some are
+ pointer objects. The type code is multiplexed, and the
+ garbage collector handles it specially.
+
+ */
+
+/* The following are immediate traps: */
+
+#define TRAP_UNASSIGNED 0
+#define TRAP_UNASSIGNED_DANGEROUS 1
+#define TRAP_UNBOUND 2
+#define TRAP_UNBOUND_DANGEROUS 3
+#define TRAP_ILLEGAL 4
+#define TRAP_ILLEGAL_DANGEROUS 5 /* Unused. */
+
+/* TRAP_MAX_IMMEDIATE is defined in const.h */
+
+/* The following are not: */
+
+#define TRAP_NOP 10 /* Unused. */
+#define TRAP_DANGEROUS 11
+#define TRAP_FLUID 12
+#define TRAP_FLUID_DANGEROUS 13
+
+/* Trap utilities */
+
+#define get_trap_kind(variable, what) \
+{ \
+ variable = Datum(what); \
+ if (variable > TRAP_MAX_IMMEDIATE) \
+ variable = Datum(Vector_Ref(what, TRAP_TAG)); \
+}
+\f
+/* Common constants */
+
+#ifndef b32
+#define UNASSIGNED_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNASSIGNED)
+#define DANGEROUS_UNASSIGNED_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNASSIGNED_DANGEROUS)
+#define UNBOUND_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNBOUND)
+#define DANGEROUS_UNBOUND_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNBOUND_DANGEROUS)
+#else
+#define UNASSIGNED_OBJECT 0x32000000
+#define DANGEROUS_UNASSIGNED_OBJECT 0x32000001
+#define UNBOUND_OBJECT 0x32000002
+#define DANGEROUS_UNBOUND_OBJECT 0x32000003
+#endif
+
+#define DANGEROUS_OBJECT Make_Unsigned_Fixnum(TRAP_DANGEROUS)
+
+#if ((TC_REFERENCE_TRAP != 0x32) || (TC_TRUE != 0x08))
+#include "error: lookup.h and types.h are inconsistent"
+#endif
+
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/usrdef.h,v 9.35 1987/04/03 00:47:31 jinx Exp $ */
+
+/* Macros and header for usrdef.c and variants. */
+
+#include "config.h"
+#include "object.h"
+#include "prim.h"
+
+
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/lookup.h,v 9.35 1987/04/03 00:47:02 jinx Exp $ */
+
+/* Macros and declarations for the variable lookup code. */
+
+extern Pointer
+ *deep_lookup(),
+ *lookup_fluid();
+
+extern long
+ deep_lookup_end(),
+ deep_assignment_end();
+
+extern Pointer
+ unbound_trap_object[],
+ uncompiled_trap_object[],
+ illegal_trap_object[],
+ fake_variable_object[];
+\f
+#define GC_allocate_test(N) GC_Check(N)
+
+#define AUX_LIST_TYPE TC_VECTOR
+
+#define AUX_CHUNK_SIZE 20
+#define AUX_LIST_COUNT ENVIRONMENT_EXTENSION_COUNT
+#define AUX_LIST_FIRST ENVIRONMENT_EXTENSION_MIN_SIZE
+#define AUX_LIST_INITIAL_SIZE (AUX_LIST_FIRST + AUX_CHUNK_SIZE)
+
+/* Variable compilation types. */
+
+#define LOCAL_REF TC_NULL
+#define GLOBAL_REF TC_UNINTERNED_SYMBOL
+#define FORMAL_REF TC_CHARACTER
+#define AUX_REF TC_FIXNUM
+#define UNCOMPILED_REF TC_TRUE
+
+/* Common constants. */
+
+#ifndef b32
+#define UNCOMPILED_VARIABLE Make_Non_Pointer(UNCOMPILED_REF, 0)
+#else
+#define UNCOMPILED_VARIABLE 0x08000000
+#endif
+
+/* Macros for speedy variable reference. */
+
+#if (LOCAL_REF == 0)
+
+#define Lexical_Offset(Ind) ((long) (Ind))
+#define Make_Local_Offset(Ind) ((Pointer) (Ind))
+
+#else
+
+#define Lexical_Offset(Ind) Get_Integer(Ind)
+#define Make_Local_Offset(Ind) Make_Non_Pointer(LOCAL_REF, Ind)
+
+#endif
+\f
+/* The code below depends on the following. */
+
+#if ((VARIABLE_OFFSET == VARIABLE_COMPILED_TYPE) || \
+ (VARIABLE_FRAME_NO != VARIABLE_COMPILED_TYPE))
+#include "error: trap.h inconsistency detected."
+#endif
+
+#define get_offset(hunk) Lexical_Offset(Fetch(hunk[VARIABLE_OFFSET]))
+
+#ifdef PARALLEL_PROCESSOR
+
+#define verify(type_code, variable, code, label) \
+{ \
+ variable = code; \
+ if (Type_Code(Fetch(hunk[VARIABLE_COMPILED_TYPE])) != \
+ type_code) \
+ goto label; \
+}
+
+#define verified_offset(variable, code) variable
+
+/* Unlike Lock_Cell, cell must be (Pointer *). This currently does
+ not matter, but might on a machine with address mapping.
+ */
+#define setup_lock(handle, cell) handle = Lock_Cell(cell)
+#define remove_lock(handle) Unlock_Cell(handle)
+
+#else
+
+#define verify(type_code, variable, code, label)
+#define verified_offset(variable, code) code
+#define setup_lock(handle, cell)
+#define remove_lock(ignore)
+
+#endif
+\f
+/* Pointer *cell, env, *hunk; */
+
+#define lookup(cell, env, hunk, label) \
+{ \
+ fast Pointer frame; \
+ long offset; \
+ \
+label: \
+ \
+ frame = Fetch(hunk[VARIABLE_COMPILED_TYPE]); \
+ \
+ switch (Type_Code(frame)) \
+ { \
+ case GLOBAL_REF: \
+ /* frame is a pointer to the same symbol. */ \
+ cell = Nth_Vector_Loc(frame, SYMBOL_GLOBAL_VALUE); \
+ break; \
+ \
+ case LOCAL_REF: \
+ cell = Nth_Vector_Loc(env, Lexical_Offset(frame)); \
+ break; \
+ \
+ case FORMAL_REF: \
+ { \
+ fast long depth; \
+ \
+ verify(FORMAL_REF, offset, get_offset(hunk), label); \
+ \
+ depth = Get_Integer(frame); \
+ frame = env; \
+ while(--depth >= 0) \
+ { \
+ frame = Fast_Vector_Ref(Vector_Ref(frame, ENVIRONMENT_FUNCTION), \
+ PROCEDURE_ENVIRONMENT); \
+ } \
+ \
+ cell = Nth_Vector_Loc(frame, \
+ verified_offset(offset, get_offset(hunk))); \
+ \
+ break; \
+ } \
+\f \
+ case AUX_REF: \
+ { \
+ fast long depth; \
+ \
+ verify(AUX_REF, offset, get_offset(hunk), label); \
+ \
+ depth = Get_Integer(frame); \
+ frame = env; \
+ while(--depth >= 0) \
+ { \
+ frame = Fast_Vector_Ref(Vector_Ref(frame, ENVIRONMENT_FUNCTION), \
+ PROCEDURE_ENVIRONMENT); \
+ } \
+ \
+ frame = Vector_Ref(frame, ENVIRONMENT_FUNCTION); \
+ if (Type_Code(frame) != AUX_LIST_TYPE) \
+ { \
+ cell = uncompiled_trap_object; \
+ break; \
+ } \
+ depth = verified_offset(offset, get_offset(hunk)); \
+ if (depth > Vector_Length(frame)) \
+ { \
+ cell = uncompiled_trap_object; \
+ break; \
+ } \
+ frame = Vector_Ref(frame, depth); \
+ if ((frame == NIL) || \
+ (Fast_Vector_Ref(frame, CONS_CAR) != hunk[VARIABLE_SYMBOL])) \
+ { \
+ cell = uncompiled_trap_object; \
+ break; \
+ } \
+ cell = Nth_Vector_Loc(frame, CONS_CDR); \
+ break; \
+ } \
+ \
+ default: \
+ /* Done here rather than in a separate case because of \
+ peculiarities of the bobcat compiler. \
+ */ \
+ cell = ((Type_Code(frame) == UNCOMPILED_REF) ? \
+ uncompiled_trap_object : \
+ illegal_trap_object); \
+ break; \
+ } \
+}
+\f
+#define lookup_primitive_type_test() \
+{ \
+ if (Type_Code(Arg1) != GLOBAL_ENV) Arg_1_Type(TC_ENVIRONMENT); \
+ if (Type_Code(Arg2) != TC_INTERNED_SYMBOL) \
+ Arg_2_Type(TC_UNINTERNED_SYMBOL); \
+}
+
+#define lookup_primitive_end(Result) \
+{ \
+ if (Result == PRIM_DONE) \
+ return Val; \
+ if (Result == PRIM_INTERRUPT) \
+ Primitive_Interrupt(); \
+ Primitive_Error(Result); \
+}
+
+#define standard_lookup_primitive(action) \
+{ \
+ long Result; \
+ \
+ lookup_primitive_type_test(); \
+ Result = action; \
+ lookup_primitive_end(Result); \
+ /*NOTREACHED*/ \
+}
+
+
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/trap.h,v 9.35 1987/04/03 00:46:33 jinx Exp $ */
+\f
+/* Kinds of traps:
+
+ Note that for every trap there is a dangerous version.
+ The danger bit is the bottom bit of the trap number,
+ thus all dangerous traps are odd and viceversa.
+
+ For efficiency, some traps are immediate, while some are
+ pointer objects. The type code is multiplexed, and the
+ garbage collector handles it specially.
+
+ */
+
+/* The following are immediate traps: */
+
+#define TRAP_UNASSIGNED 0
+#define TRAP_UNASSIGNED_DANGEROUS 1
+#define TRAP_UNBOUND 2
+#define TRAP_UNBOUND_DANGEROUS 3
+#define TRAP_ILLEGAL 4
+#define TRAP_ILLEGAL_DANGEROUS 5 /* Unused. */
+
+/* TRAP_MAX_IMMEDIATE is defined in const.h */
+
+/* The following are not: */
+
+#define TRAP_NOP 10 /* Unused. */
+#define TRAP_DANGEROUS 11
+#define TRAP_FLUID 12
+#define TRAP_FLUID_DANGEROUS 13
+
+/* Trap utilities */
+
+#define get_trap_kind(variable, what) \
+{ \
+ variable = Datum(what); \
+ if (variable > TRAP_MAX_IMMEDIATE) \
+ variable = Datum(Vector_Ref(what, TRAP_TAG)); \
+}
+\f
+/* Common constants */
+
+#ifndef b32
+#define UNASSIGNED_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNASSIGNED)
+#define DANGEROUS_UNASSIGNED_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNASSIGNED_DANGEROUS)
+#define UNBOUND_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNBOUND)
+#define DANGEROUS_UNBOUND_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNBOUND_DANGEROUS)
+#else
+#define UNASSIGNED_OBJECT 0x32000000
+#define DANGEROUS_UNASSIGNED_OBJECT 0x32000001
+#define UNBOUND_OBJECT 0x32000002
+#define DANGEROUS_UNBOUND_OBJECT 0x32000003
+#endif
+
+#define DANGEROUS_OBJECT Make_Unsigned_Fixnum(TRAP_DANGEROUS)
+
+#if ((TC_REFERENCE_TRAP != 0x32) || (TC_TRUE != 0x08))
+#include "error: lookup.h and types.h are inconsistent"
+#endif
+
projects / mit-scheme.git / commitdiff