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/bchgcl.c,v 9.26 1987/02/12 01:14:59 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchgcl.c,v 9.27 1987/04/03 00:07:27 jinx Exp $ */
/* bchgcl, bchmmg, bchpur, and bchdmp can replace gcloop, memmag,
purify, and fasdump, respectively, to provide garbage collection
case_Cell:
relocate_normal_pointer(copy_cell(), 1);
+ case TC_REFERENCE_TRAP:
+ if (Datum(Temp) <= TRAP_MAX_IMMEDIATE)
+ {
+ /* It is a non pointer. */
+ break;
+ }
+ /* It is a pair, fall through. */
case_Pair:
relocate_normal_pointer(copy_pair(), 2);
+ case TC_VARIABLE:
case_Triple:
relocate_normal_pointer(copy_triple(), 3);
-#ifdef QUADRUPLE
case_Quadruple:
relocate_normal_pointer(copy_quadruple(), 4);
-#endif
-
- case TC_VARIABLE:
- relocate_normal_setup();
- { Pointer Compiled_Type = Old[VARIABLE_COMPILED_TYPE];
- if ((Type_Code(Compiled_Type) == AUX_REF) &&
- (!Is_Constant(Get_Pointer(Compiled_Type))) &&
- (Type_Code(Vector_Ref(Compiled_Type, 0)) != TC_BROKEN_HEART))
- { Old[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
- Old[VARIABLE_OFFSET] = NIL;
- }
- }
- relocate_normal_transport(copy_triple(), 3);
- relocate_normal_end();
#ifdef FLOATING_ALIGNMENT
case TC_BIG_FLONUM:
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/bchmmg.c,v 9.26 1987/02/12 01:17:03 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchmmg.c,v 9.27 1987/04/03 00:07:44 jinx Exp $ */
/* Memory management top level. Garbage collection to disk.
*/
Highest_Allocated_Address =
Allocate_Heap_Space(Real_Stack_Size + Our_Heap_Size +
- Our_Constant_Size + (2 * GC_BUFFER_SPACE));
- Highest_Allocated_Address -= (2 * GC_BUFFER_SPACE);
+ Our_Constant_Size + (2 * GC_BUFFER_SPACE) +
+ HEAP_BUFFER_SPACE);
/* Consistency check 2 */
if (Heap == NULL)
exit(1);
}
- /* Initialize the various global parameters.
- Floating alignment will have to be added here.
- */
+ /* Trim the system buffer space. */
+
+ Highest_Allocated_Address -= (2 * GC_BUFFER_SPACE);
+ Heap += HEAP_BUFFER_SPACE;
+ Initial_Align_Float(Heap);
+
Constant_Space = Heap + Our_Heap_Size;
gc_disk_buffer_1 = Constant_Space + Our_Constant_Size + Real_Stack_Size;
gc_disk_buffer_2 = (gc_disk_buffer_1 + GC_BUFFER_SPACE);
*Scan = Temp;
continue;
+ case GC_Special:
+ if (Type_Code(Temp) != TC_REFERENCE_TRAP)
+ {
+ /* No other special type makes sense here. */
+ goto fail;
+ }
+ if (Datum(Temp) <= TRAP_MAX_IMMEDIATE)
+ {
+ *Scan = Temp;
+ continue;
+ }
+ /* Otherwise, it is a pointer. Fall through */
+
/* Normal pointer types, the broken heart is in the first word.
Note that most special types are treated normally here.
The BH code updates *Scan if the object has been relocated.
Otherwise it falls through and we replace it with a full NIL.
Eliminating this assignment would keep old data (pl. of datum).
*/
-
case GC_Cell:
case GC_Pair:
case GC_Triple:
*Scan = NIL;
continue;
- case GC_Special:
case GC_Undefined:
default: /* Non Marked Headers and Broken Hearts */
+ fail:
fprintf(stderr,
"\nFix_Weak_Chain: Bad Object: Type = 0x%02x; Datum = %x\n",
Type_Code(Temp), Datum(Temp));
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/bintopsb.c,v 9.22 1987/03/12 14:52:23 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bintopsb.c,v 9.23 1987/04/03 00:05:18 jinx Exp $
*
* This File contains the code to translate internal format binary
* files to portable format.
#define Portable_File Output_File
#include "translate.h"
+#include "trap.h"
static Boolean Shuffle_Bytes = false;
-static Boolean Padded_Strings = true;
-static Boolean Dense_Types = true;
+static Boolean upgrade_traps = false;
static Pointer *Mem_Base;
static long Heap_Relocation, Constant_Relocation;
}
}
\f
-#define Do_String(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer((Code), Old_Contents); \
- else \
- { fast long i; \
- Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
- (Obj) += 1; \
- *(FObj)++ = STRING_0; \
- *(FObj)++ = Old_Contents; \
- i = Get_Integer(Old_Contents); \
- NStrings += 1; \
- NChars += (Padded_Strings ? \
- pointer_to_char(i-1) : \
- (1 + pointer_to_char(i-1))); \
- while(--i >= 0) *(FObj)++ = *Old_Address++; \
- } \
- if (Dangerous(This)) Set_Danger_Bit(Mem_Base[(Scn)]); \
+#define Do_String(Code, Rel, Fre, Scn, Obj, FObj) \
+{ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ Mem_Base[(Scn)] = \
+ Make_New_Pointer((Code), Old_Contents); \
+ else \
+ { fast long i; \
+ Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
+ *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
+ (Obj) += 1; \
+ *(FObj)++ = STRING_0; \
+ *(FObj)++ = Old_Contents; \
+ i = Get_Integer(Old_Contents); \
+ NStrings += 1; \
+ NChars += pointer_to_char(i-1); \
+ while(--i >= 0) *(FObj)++ = *Old_Address++; \
+ } \
}
print_a_string(from)
{ fast long len;
fast char *string;
long maxlen = pointer_to_char((Get_Integer(*from++))-1);
- if (!Padded_Strings) maxlen += 1;
len = Get_Integer(*from++);
fprintf(Portable_File, "%02x %ld %ld ",
TC_CHARACTER_STRING,
return;
}
\f
-#define Do_Bignum(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer((Code), Old_Contents); \
- else \
- { fast long length; \
- Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
- NIntegers += 1; \
- NBits += bignum_to_bits(LEN(BIGNUM(Old_Address))); \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
- (Obj) += 1; \
- *(FObj)++ = Make_Non_Pointer(TC_BIG_FIXNUM, 0); \
- *(FObj)++ = Old_Contents; \
- for (length = Get_Integer(Old_Contents); \
- --length >= 0; ) \
- *(FObj)++ = *Old_Address++; \
- } \
- if (Dangerous(This)) Set_Danger_Bit(Mem_Base[(Scn)]); \
+#define Do_Bignum(Code, Rel, Fre, Scn, Obj, FObj) \
+{ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ Mem_Base[(Scn)] = \
+ Make_New_Pointer((Code), Old_Contents); \
+ else \
+ { fast long length; \
+ Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
+ NIntegers += 1; \
+ NBits += bignum_to_bits(LEN(BIGNUM(Old_Address))); \
+ *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
+ (Obj) += 1; \
+ *(FObj)++ = Make_Non_Pointer(TC_BIG_FIXNUM, 0); \
+ *(FObj)++ = Old_Contents; \
+ for (length = Get_Integer(Old_Contents); \
+ --length >= 0; ) \
+ *(FObj)++ = *Old_Address++; \
+ } \
}
print_a_bignum(from)
return;
}
\f
-#define Do_Flonum(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer((Code), Old_Contents); \
- else \
- { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
- Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
- (Obj) += 1; \
- *(FObj)++ = Make_Non_Pointer(TC_BIG_FLONUM, 0); \
- *((double *) (FObj)) = *((double *) Old_Address); \
- (FObj) += float_to_pointer; \
- NFlonums += 1; \
- } \
- if (Dangerous(This)) Set_Danger_Bit(Mem_Base[(Scn)]); \
+#define Do_Flonum(Code, Rel, Fre, Scn, Obj, FObj) \
+{ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ Mem_Base[(Scn)] = \
+ Make_New_Pointer((Code), Old_Contents); \
+ else \
+ { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
+ (Obj) += 1; \
+ *(FObj)++ = Make_Non_Pointer(TC_BIG_FLONUM, 0); \
+ *((double *) (FObj)) = *((double *) Old_Address); \
+ (FObj) += float_to_pointer; \
+ NFlonums += 1; \
+ } \
}
print_a_flonum(val)
#define Do_Area(Code, Area, Bound, Obj, FObj) \
Process_Area(Code, &Area, &Bound, &Obj, &FObj)
-#if 0
-
-#ifdef DEBUG
-#define Show_Upgrade(This, New_Type) \
- fprintf(stderr, "Upgrading from 0x%02x|%06x to 0x%x\n", \
- Type_Code(This), Datum(This), New_Type);
-#else
-#define Show_Upgrade(This, New_Type)
-#endif
-
-#define Upgrade(New_Type) \
-{ Boolean Was_Dangerous = Dangerous(This); \
- Show_Upgrade(This, New_Type); \
- if (Dense_Types) goto Bad_Type; \
- This = Make_New_Pointer(New_Type, Datum(This)); \
- if (Was_Dangerous) Set_Danger_Bit(This); \
- Mem_Base[*Area] = This; \
- break; \
-}
-
-#endif 0
-
Process_Area(Code, Area, Bound, Obj, FObj)
int Code;
fast long *Area, *Bound;
*Area += 1;
break;
+ case_compiled_entry_point:
+ fprintf(stderr,
+ "%s: File is not portable: Compiled code.\n",
+ Program_Name);
+ exit(1);
+\f
case TC_FIXNUM:
NIntegers += 1;
NBits += fixnum_to_bits;
Mem_Base[*Area] = Make_Non_Pointer(Code, *Obj);
*Obj += 1;
**FObj = This;
- if (Dangerous(This))
- { Set_Danger_Bit(Mem_Base[*Area]);
- Clear_Danger_Bit(**FObj);
- }
*FObj += 1;
/* Fall through */
case TC_MANIFEST_SPECIAL_NM_VECTOR:
*Area += 1;
break;
- case_compiled_entry_point:
- fprintf(stderr,
- "%s: File is not portable: Compiled code.\n",
- Program_Name);
- exit(1);
-
case_Cell:
Do_Pointer(*Area, Do_Cell);
+ case TC_REFERENCE_TRAP:
+ {
+ long kind;
+
+ kind = Datum(This);
+
+ if (upgrade_traps)
+ {
+ /* It is an old UNASSIGNED object. */
+ if (kind == 0)
+ {
+ Mem_Base[*Area] = UNASSIGNED_OBJECT;
+ *Area += 1;
+ break;
+ }
+ if (kind == 1)
+ {
+ Mem_Base[*Area] = UNBOUND_OBJECT;
+ *Area += 1;
+ break;
+ }
+ fprintf(stderr,
+ "%s: Bad old unassigned object. 0x%x.\n",
+ Program_Name, This);
+ exit(1);
+ }
+ if (kind <= TRAP_MAX_IMMEDIATE)
+ {
+ /* It is a non pointer. */
+
+ *Area += 1;
+ break;
+ }
+ }
+ /* Fall through */
+\f
case TC_WEAK_CONS:
case_Pair:
Do_Pointer(*Area, Do_Pair);
Do_Pointer(*Area, Do_String);
case TC_ENVIRONMENT:
+ if (upgrade_traps)
+ {
+ fprintf(stderr,
+ "%s: Cannot upgrade environments.\n",
+ Program_Name);
+ exit(1);
+ }
+ /* Fall through */
case TC_FUTURE:
case_simple_Vector:
Do_Pointer(*Area, Do_Vector);
-#if 0
-
-/* This should be cleaned up: We can no longer do it like this
- since we have reused the types.
- */
-
- case OLD_TC_BROKEN_HEART:
- Upgrade(TC_BROKEN_HEART);
- case OLD_TC_SPECIAL_NM_VECTOR:
- Upgrade(TC_MANIFEST_SPECIAL_NM_VECTOR);
-#if 0
- case OLD_TC_UNASSIGNED:
- Upgrade(TC_UNASSIGNED);
- case OLD_TC_RETURN_CODE:
- Upgrade(TC_RETURN_CODE);
-#endif
- case OLD_TC_PCOMB0:
- Upgrade(TC_PCOMB0);
- case OLD_TC_THE_ENVIRONMENT:
- Upgrade(TC_THE_ENVIRONMENT);
- case OLD_TC_CHARACTER:
- Upgrade(TC_CHARACTER);
- case OLD_TC_FIXNUM:
- Upgrade(TC_FIXNUM);
-#if 0
- case OLD_TC_SEQUENCE_3:
- Upgrade(TC_SEQUENCE_3);
-#endif
- case OLD_TC_MANIFEST_NM_VECTOR:
- Upgrade(TC_MANIFEST_NM_VECTOR);
- case OLD_TC_VECTOR:
- Upgrade(TC_VECTOR);
-#if 0
- case OLD_TC_ENVIRONMENT:
- Upgrade(TC_ENVIRONMENT);
-#endif
- case OLD_TC_CONTROL_POINT:
- Upgrade(TC_CONTROL_POINT);
- case OLD_TC_COMBINATION:
- Upgrade(TC_COMBINATION);
- case OLD_TC_PCOMB3:
- Upgrade(TC_PCOMB3);
- case OLD_TC_PCOMB2:
- Upgrade(TC_PCOMB2);
-#endif 0
-
default:
Bad_Type:
fprintf(stderr, "%s: Unknown Type Code 0x%x found.\n",
if (Machine_Type == FASL_INTERNAL_FORMAT)
Shuffle_Bytes = false;
- if (Sub_Version < FASL_PADDED_STRINGS)
- Padded_Strings = false;
- if (Sub_Version < FASL_DENSE_TYPES)
- Dense_Types = false;
+ upgrade_traps = (Sub_Version < FASL_REFERENCE_TRAP);
/* Constant Space not currently supported */
}
{ long Size = ((3 * (Heap_Count + Const_Count)) + NROOTS + 1);
-#if 0
- Size += (FLOATING_ALIGNMENT+1)/sizeof(Pointer);
-#endif
- Allocate_Heap_Space(Size);
+ Allocate_Heap_Space(Size + HEAP_BUFFER_SPACE);
if (Heap == NULL)
{ fprintf(stderr,
"%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n",
exit(1);
}
}
-#if 0
- Align_Float(Heap);
-#endif
+ Heap += HEAP_BUFFER_SPACE;
+ Initial_Align_Float(Heap);
Load_Data(Heap_Count, &Heap[0]);
Load_Data(Const_Count, &Heap[Heap_Count]);
Heap_Relocation = &Heap[0] - Get_Pointer(Heap_Base);
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/bkpt.h,v 9.21 1987/01/22 14:16:39 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bkpt.h,v 9.22 1987/04/03 00:08:07 jinx Exp $
*
* This file contains breakpoint utilities.
* Disabled when not debugging the interpreter.
+ * It "shadows" definitions in default.h
*
*/
#define sp_nil ((sp_record_list) NULL)
#define debug_maxslots 64
-#define Eval_Ucode_Hook() \
- local_circle[local_slotno++] = Fetch_Expression(); \
- if (local_slotno >= debug_maxslots) local_slotno = 0; \
- if (local_nslots < debug_maxslots) local_nslots++
-
-#ifdef Using_Registers
-#define Pop_Return_Ucode_Hook() \
-if (SP_List != sp_nil) \
-{ Export_Registers(); \
- Pop_Return_Break_Point(); \
- Import_Registers(); \
+#define Eval_Ucode_Hook() \
+{ \
+ local_circle[local_slotno++] = Fetch_Expression(); \
+ if (local_slotno >= debug_maxslots) local_slotno = 0; \
+ if (local_nslots < debug_maxslots) local_nslots++; \
}
-#else
-#define Pop_Return_Ucode_Hook() \
-if (SP_List != sp_nil) \
- Pop_Return_Break_Point();
-#endif
+
+#define Pop_Return_Ucode_Hook() \
+{ \
+ if (SP_List != sp_nil) \
+ { Export_Registers(); \
+ Pop_Return_Break_Point(); \
+ Import_Registers(); \
+ } \
+}
+
+/* Not implemented yet */
+
+#define Apply_Ucode_Hook()
\f
/* For performance metering we note the time spent handling each
* primitive. This MIGHT help us figure out where all the time
}
#define Metering_Apply_Primitive(Loc, N) \
-{ long Start_Time = Sys_Clock(); \
+{ \
+ long Start_Time = Sys_Clock(); \
+ \
Loc = Apply_Primitive(N) \
perfinfo_data.primtime[N] += Sys_Clock() - Start_Time; \
-} \
-Set_Time_Zone(Zone_Working)
+ Set_Time_Zone(Zone_Working); \
+}
#endif
-
-/* Not implemented yet */
-#define Apply_Ucode_Hook()
#endif /* ifdef ENABLE_DEBUGGING_TOOLS */
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.28 1987/03/09 16:02:18 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.29 1987/04/03 00:08:22 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
{-heap heap-size}
{-stack stack-size}
{-constant constant-size}
- {-utabmd utab-filename}
+ {-utabmd utab-filename} or {-utab utab-filename}
{other arguments ignored by the core microcode}
with filespec either {-band band-name} or {{-}fasl file-name}
Pointer Result;
Primitive_0_Args();
- if (((position = Parse_Option("-utabmd", Saved_argc, Saved_argv, true))
- != NOT_THERE) &&
- (position != (Saved_argc - 1)))
+ if ((((position = Parse_Option("-utabmd", Saved_argc, Saved_argv, true))
+ != NOT_THERE) &&
+ (position != (Saved_argc - 1))) ||
+ (((position = Parse_Option("-utab", Saved_argc, Saved_argv, true))
+ != NOT_THERE) &&
+ (position != (Saved_argc - 1))))
{ Prefix = "";
Suffix = Saved_argv[position + 1];
}
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/config.h,v 9.22 1987/02/04 17:50:46 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/config.h,v 9.23 1987/04/03 00:09:46 jinx Exp $
*
* This file contains the configuration information and the information
* given on the command line on Unix.
machine where addresses are specified in bytes. The alignment
must be an integral multiple of the length of a long, since
it must pad with an explicit Pointer value.
+ This option is not completely working right now.
*/
#define FASL_HP_SPECTRUM 10
\f
/* These (pdp10 and nu) haven't worked in a while.
- * Should be upgraded some day.
+ * Should be upgraded or flushed some day.
*/
#ifdef pdp10
#define MAX_FLONUM_EXPONENT 127
#define HAS_FLOOR
#define HAS_FREXP
+
/* Not on these, however */
+
#ifdef vms
+
/* VMS C has not void type, thus make it go away */
#define void
/* Name conflict in VMS with system variable */
longjmp(Exit_Point, NORMAL_EXIT)
#else /* not a vms */
+
/* Vax Unix C compiler bug */
+
#define double_into_fixnum(what, target) \
{ long For_Vaxes_Sake = (long) what; \
target = Make_Non_Pointer(TC_FIXNUM, For_Vaxes_Sake); \
}
+
#endif /* not vms */
#endif /* vax */
-
+\f
#ifdef hp9000s200 /* and s300, pretty indistinguishable */
#define Heap_In_Low_Memory
#define UNSIGNED_SHIFT
#define MAX_FLONUM_EXPONENT 1023
#define HAS_FLOOR
#define HAS_FREXP
-#define term_type int /* C compiler bug in GC_Type */
+#define term_type int /* C compiler bug in GC_Type */
#endif
#ifdef hp9000s500
#ifdef spectrum
/* Heap resides in "Quad 1", and hence memory addresses have a 1
- in the second MSBit. This is taken care of in OBJECT.H, and is
+ in the second MSBit. This is taken care of in object.h, and is
still considered Heap_In_Low_Memory.
*/
#define Heap_In_Low_Memory
#include "Error: config.h: Unknown configuration."
#endif
+#ifdef noquick
+#define quick
+#else
+#define quick fast
+#endif
+
#if (ULONG_SIZE == 32)
#define b32
#endif
-
+\f
/* Default "segment" sizes */
+
#ifndef STACK_SIZE
#ifndef USE_STACKLETS
#define STACK_SIZE 30 /* Default Kcells for stack */
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/const.h,v 9.22 1987/02/04 17:49:56 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/const.h,v 9.23 1987/04/03 00:10:08 jinx Exp $
*
* Named constants used throughout the interpreter
*
#define NIL Make_Non_Pointer(TC_NULL, 0)
#define TRUTH Make_Non_Pointer(TC_TRUE, 0)
-#define UNASSIGNED_OBJECT Make_Non_Pointer(TC_UNASSIGNED, UNASSIGNED)
-#define UNBOUND_OBJECT Make_Non_Pointer(TC_UNASSIGNED, UNBOUND)
-#define UNCOMPILED_VARIABLE Make_Non_Pointer(UNCOMPILED_REF, 0)
#define FIXNUM_0 Make_Non_Pointer(TC_FIXNUM, 0)
-#define LOCAL_REF_0 Make_Non_Pointer(LOCAL_REF, 0)
#define BROKEN_HEART_0 Make_Non_Pointer(TC_BROKEN_HEART, 0)
#define STRING_0 Make_Non_Pointer(TC_CHARACTER_STRING, 0)
#else /* 32 bit word */
#define NIL 0x00000000
#define TRUTH 0x08000000
-#define UNASSIGNED_OBJECT 0x32000000
-#define UNBOUND_OBJECT 0x32000001
-#define UNCOMPILED_VARIABLE 0x08000000
#define FIXNUM_0 0x1A000000
-#define LOCAL_REF_0 0x00000000
#define BROKEN_HEART_0 0x22000000
#define STRING_0 0x1E000000
#endif /* b32 */
-/* Some names for flag values */
-
-#define SET_IT 0 /* Lookup */
-#define CLEAR_IT 1
-#define READ_IT 2
-#define TEST_IT 3
-
-#define FOUND_SLOT 1 /* Slot lookup */
-#define NO_SLOT 2
-#define FOUND_UNBOUND 4
-
#define NOT_THERE -1 /* Command line parser */
\f
/* Assorted sizes used in various places */
occurs */
#endif
-#define FILE_CHANNELS 15
+/* Some versions of stdio define this. */
+#ifndef _NFILE
+#define _NFILE 15
+#endif
+
+#define FILE_CHANNELS _NFILE
+
#define MAX_LIST_PRINT 10
#define ILLEGAL_PRIMITIVE -1
#define LENGTH_MULTIPLIER 5
#define SHIFT_AMOUNT 2
-/* For looking up variable definitions */
-
-#define UNCOMPILED_REF TC_TRUE
-#define GLOBAL_REF TC_UNINTERNED_SYMBOL
-#define FORMAL_REF TC_FIXNUM
-#define AUX_REF TC_ENVIRONMENT
-#define LOCAL_REF TC_NULL
-/* LOCAL_REF must be 0 in order for code in interpret.c to work fast */
+/* Last immediate reference trap. */
+
+#define TRAP_MAX_IMMEDIATE 9
/* For headers in pure / constant area */
/* VMS preprocessor does not like line continuations in conditionals */
#define Are_The_Constants_Incompatible \
-((TC_NULL != 0x00) || (TC_TRUE != 0x08) || (TC_UNASSIGNED != 0x32) || \
- (UNASSIGNED != 0) || (UNBOUND != 1) || (UNCOMPILED_REF != 0x08) || \
+((TC_NULL != 0x00) || (TC_TRUE != 0x08) || \
(TC_FIXNUM != 0x1A) || (TC_BROKEN_HEART != 0x22) || \
- (TC_CHARACTER_STRING != 0x1E) || (LOCAL_REF != 0x00))
+ (TC_CHARACTER_STRING != 0x1E))
/* The values used above are in sdata.h and types.h,
check for consistency if the check below fails. */
#if Are_The_Constants_Incompatible
-#include "Error: disagreement in const.h"
+#include "Error: const.h and types.h disagree"
#endif
/* These are the only entries in Registers[] needed by the microcode.
All other entries are used only by the compiled code interface. */
-#define REGBLOCK_MEMTOP 0
-#define REGBLOCK_STACKGUARD 1
-#define REGBLOCK_MINIMUM_LENGTH 2
+#define REGBLOCK_MEMTOP 0
+#define REGBLOCK_STACKGUARD 1
+#define REGBLOCK_VAL 2
+#define REGBLOCK_ENV 3
+#define REGBLOCK_TEMP 4
+#define REGBLOCK_EXPR 5
+#define REGBLOCK_RETURN 6
+#define REGBLOCK_MINIMUM_LENGTH 7
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/daemon.c,v 9.22 1987/02/02 15:16:12 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/daemon.c,v 9.23 1987/04/03 00:10:26 jinx Exp $
This file contains code for the Garbage Collection daemons.
There are currently two daemons, one for closing files which
Built_In_Primitive(Prim_Close_Lost_Open_Files, 1, "CLOSE-LOST-OPEN-FILES")
{ fast Pointer *Smash, Cell, Weak_Cell;
+ long channel_number;
Primitive_1_Arg();
for (Smash = Nth_Vector_Loc(Arg1, CONS_CDR), Cell = *Smash;
Cell != NIL;
Cell = *Smash)
- { Weak_Cell = Fast_Vector_Ref(Cell, CONS_CAR);
+ {
+ Weak_Cell = Fast_Vector_Ref(Cell, CONS_CAR);
if (Fast_Vector_Ref(Weak_Cell, CONS_CAR) == NIL)
- { (void)
- OS_file_close
- (Channels[Get_Integer(Fast_Vector_Ref(Weak_Cell, CONS_CDR))]);
+ {
+ channel_number = Get_Integer(Fast_Vector_Ref(Weak_Cell, CONS_CDR));
+ (void) OS_file_close (Channels[channel_number]);
+ Channels[channel_number] = NULL;
*Smash = Fast_Vector_Ref(Cell, CONS_CDR);
}
else
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/debug.c,v 9.22 1987/03/11 07:37:06 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/debug.c,v 9.23 1987/04/03 00:10:44 jinx Exp $
*
* Utilities to help with debugging
*/
#include "scheme.h"
#include "primitive.h"
+#include "trap.h"
+#include "lookup.h"
\f
void Show_Pure()
{ Pointer *Obj_Address;
}
}
\f
-void Show_Env(The_Env)
-Pointer The_Env;
-{ Pointer *Name_Ptr, *Value_Ptr, Aux_Ptr, Aux_Slot_Ptr;
- long Count, i;
- Value_Ptr = Nth_Vector_Loc(The_Env, HEAP_ENV_FUNCTION);
- if ((Type_Code(*Value_Ptr) == TC_PROCEDURE) ||
- (Type_Code(*Value_Ptr) == TC_EXTENDED_PROCEDURE))
- { Name_Ptr = Nth_Vector_Loc(*Value_Ptr, PROCEDURE_LAMBDA_EXPR);
- Name_Ptr = Nth_Vector_Loc(*Name_Ptr, LAMBDA_FORMALS);
- Count = Vector_Length(*Name_Ptr);
- Name_Ptr = Nth_Vector_Loc(*Name_Ptr, 1);
- for (i=0; i < Count; i++)
- { Print_Expression(*Name_Ptr++, "Name ");
- Print_Expression(*Value_Ptr++, " Value ");
+void
+Show_Env(The_Env)
+ Pointer The_Env;
+{
+ Pointer *name_ptr, procedure, *value_ptr, extension;
+ long count, i;
+
+ procedure = Vector_Ref(The_Env, ENVIRONMENT_FUNCTION);
+ value_ptr = Nth_Vector_Loc(The_Env, ENVIRONMENT_FIRST_ARG);
+
+ if (Type_Code(procedure) == AUX_LIST_TYPE)
+ {
+ extension = procedure;
+ procedure = Fast_Vector_Ref(extension, ENVIRONMENT_EXTENSION_PROCEDURE);
+ }
+ else
+ extension = NIL;
+
+ if ((Type_Code(procedure) != TC_PROCEDURE) &&
+ (Type_Code(procedure) != TC_EXTENDED_PROCEDURE))
+ {
+ printf("Not created by a procedure");
+ return;
+ }
+ name_ptr = Nth_Vector_Loc(procedure, PROCEDURE_LAMBDA_EXPR);
+ name_ptr = Nth_Vector_Loc(*name_ptr, LAMBDA_FORMALS);
+ count = Vector_Length(*name_ptr) - 1;
+
+ name_ptr = Nth_Vector_Loc(*name_ptr, 2);
+ for (i = 0; i < count; i++)
+ {
+ Print_Expression(*name_ptr++, "Name ");
+ Print_Expression(*value_ptr++, " Value ");
+ printf("\n");
+ }
+ if (extension != NIL)
+ {
+ printf("Auxilliary Variables\n");
+ count = Get_Integer(Vector_Ref(extension, AUX_LIST_COUNT));
+ for (i = 0, name_ptr = Nth_Vector_Loc(extension, AUX_LIST_FIRST);
+ i < count;
+ i++, name_ptr++)
+ {
+ Print_Expression(Vector_Ref(*name_ptr, CONS_CAR),
+ "Name ");
+ Print_Expression(Vector_Ref(*name_ptr, CONS_CAR),
+ " Value ");
printf("\n");
}
- Aux_Ptr = Vector_Ref(The_Env, HEAP_ENV_AUX_SLOT);
- if (Aux_Ptr != NIL)
- { printf("Auxilliary Variables\n");
- while (Aux_Ptr != NIL)
- { Aux_Slot_Ptr = Vector_Ref(Aux_Ptr, CONS_CAR);
- Print_Expression(Vector_Ref(Aux_Slot_Ptr, CONS_CAR),
- "Name ");
- Print_Expression(Vector_Ref(Aux_Slot_Ptr, CONS_CAR),
- " Value ");
- Aux_Ptr = Vector_Ref(Aux_Ptr, CONS_CDR);
- printf("\n");
- }
- }
}
- else printf("Not created by a procedure");
}
\f
/* For debugging, given a String, return either a "not interned"
Boolean Return_After_Print;
Temp_Address = Get_Integer(Expr);
Return_After_Print = false;
- if (Type_Code(Expr) > MAX_SAFE_TYPE) printf("{Dangerous}");
- switch(Safe_Type_Code(Expr))
+ switch(Type_Code(Expr))
{ case TC_ACCESS:
printf("[ACCESS (");
Expr = Vector_Ref(Expr, ACCESS_NAME);
case TC_DELAYED: printf("[DELAYED"); break;
case TC_DISJUNCTION: printf("[DISJUNCTION"); break;
case TC_ENVIRONMENT:
+ {
+ Pointer procedure;
+
printf("[ENVIRONMENT 0x%x]", Temp_Address);
printf(" (from ");
- Do_Printing(Vector_Ref(Expr, HEAP_ENV_FUNCTION), false);
+ procedure = Vector_Ref(Expr, ENVIRONMENT_FUNCTION);
+ if (Type_Code(procedure) == TC_QUAD)
+ procedure = Vector_Ref(procedure, ENVIRONMENT_EXTENSION_PROCEDURE);
+ Do_Printing(procedure, false);
printf(")");
return;
- case TC_EXTENDED_FIXNUM: printf("[EXTENDED_FIXNUM"); break;
+ }
case TC_EXTENDED_LAMBDA:
if (Detailed) printf("[EXTENDED_LAMBDA (");
Do_Printing(
/* Do_Printing, continued */
case TC_FUTURE: printf("[FUTURE"); break;
- case TC_HUNK3: printf("[HUNK3"); break;
+ case TC_HUNK3: printf("[TRIPLE"); break;
case TC_IN_PACKAGE: printf("[IN_PACKAGE"); break;
case TC_LAMBDA:
if (Detailed) printf("[LAMBDA (");
\f
/* Do_Printing, continued */
+ case TC_QUAD: printf("[QUAD"); break;
+ case TC_REFERENCE_TRAP:
+ {
+ printf("[REFERENCE-TRAP");
+ if (Datum(Expr) <= TRAP_MAX_IMMEDIATE)
+ break;
+ Print_Expression(Vector_Ref(Expr, TRAP_TAG), " tag");
+ Print_Expression(Vector_Ref(Expr, TRAP_EXTRA), " extra");
+ printf("]");
+ return;
+ }
case TC_RETURN_CODE:
printf("[RETURN_CODE ");
Print_Return_Name(Expr);
case TC_SEQUENCE_2: printf("[SEQUENCE_2"); break;
case TC_SEQUENCE_3: printf("[SEQUENCE_3"); break;
case TC_THE_ENVIRONMENT: printf("[THE_ENVIRONMENT"); break;
-
- case TC_TRAP:
- printf("[TRAP ");
- Print_Expression(Vector_Ref(Expr, TRAP_TAG), " tag");
- Print_Expression(Vector_Ref(Expr, TRAP_DEFAULT), " default");
- Print_Expression(Vector_Ref(Expr, TRAP_FROB), " frob");
- printf("]");
- return;
-
case TC_TRUE:
if (Temp_Address == 0)
{ printf("#!true");
}
printf("[TRUE");
break;
- case TC_UNASSIGNED:
- if (Temp_Address == UNBOUND)
- { printf("#!UNBOUND");
- return;
- }
- else if (Temp_Address == UNASSIGNED)
- { printf("#!UNASSIGNED");
- return;
- }
- else printf("[UNASSIGNED"); break;
case TC_VECTOR: printf("[VECTOR"); break;
case TC_VECTOR_16B: printf("[VECTOR_16B"); break;
case TC_VECTOR_1B: printf("[VECTOR_1B"); break;
}
else
{ Print_Expression(Temp, " ...");
- if (Safe_Type_Code(Temp) == TC_MANIFEST_NM_VECTOR)
+ if (Type_Code(Temp) == TC_MANIFEST_NM_VECTOR)
{ Stack_Pointer = Simulate_Popping(Get_Integer(Temp));
printf(" (skipping)");
}
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/dump.c,v 9.21 1987/01/22 14:23:24 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/dump.c,v 9.22 1987/04/03 00:11:11 jinx Exp $
*
* This file contains common code for dumping internal format binary files.
*/
#ifdef DEBUG
#ifndef Heap_In_Low_Memory
- printf("\nMemory_Base = 0x%x\n", Memory_Base);
+ fprintf(stderr, "\nMemory_Base = 0x%x\n", Memory_Base);
#endif
- printf("\nHeap_Relocation=0x%x, dumped as 0x%x\n",
- Heap_Relocation, Make_Pointer(TC_BROKEN_HEART, Heap_Relocation));
- printf("\nDumped object=0x%x, dumped as 0x%x\n",
- Dumped_Object, Make_Pointer(TC_BROKEN_HEART, Dumped_Object));
+ fprintf(stderr, "\nHeap_Relocation=0x%x, dumped as 0x%x\n",
+ Heap_Relocation, Make_Pointer(TC_BROKEN_HEART, Heap_Relocation));
+ fprintf(stderr, "\nDumped object=0x%x, dumped as 0x%x\n",
+ Dumped_Object, Make_Pointer(TC_BROKEN_HEART, Dumped_Object));
#endif
Buffer[FASL_Offset_Marker] = FASL_FILE_MARKER;
Buffer[FASL_Offset_Heap_Count] =
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/errors.h,v 9.23 1987/02/07 15:28:03 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/errors.h,v 9.24 1987/04/03 00:11:24 jinx Rel $
*
* Error and termination code declarations. This must correspond
* to UTABMD.SCM
#define ERR_INAPPLICABLE_CONTINUATION 0x30
#define ERR_COMPILED_CODE_ERROR 0x31
#define ERR_FLOATING_OVERFLOW 0x32
+#define ERR_UNIMPLEMENTED_PRIMITIVE 0x33
-#define MAX_ERROR 0x32
+#define MAX_ERROR 0x33
\f
/* Termination codes: the interpreter halts on these */
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/extern.h,v 9.22 1987/02/08 23:08:27 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/extern.h,v 9.23 1987/04/03 00:11:43 jinx Exp $
*
* External declarations.
*
#define Fluids_Debug false
#endif
\f
+/* The register block */
+
+extern Pointer Registers[];
+
extern Pointer
- Env, /* The environment */
- Ext_Val, /* The value returned from primitives or apply */
- Return, /* The return address code */
- Ext_Expression, /* Expression to EVALuate */
- *History, /* History register */
+ *Ext_History, /* History register */
*Free, /* Next free word in heap */
*MemTop, /* Top of heap space available */
*Ext_Stack_Pointer, /* Next available slot in control stack */
*Free_Stacklets, /* Free list of stacklets */
*Constant_Space, /* Bottom of constant+pure space */
*Free_Constant, /* Next free cell in constant+pure area */
- *Unused_Heap, /* Bottom of unused heap for GC */
- *Unused_Heap_Top, /* Top of unused heap for GC */
*Heap_Top, /* Top of current heap space */
*Heap_Bottom, /* Bottom of current heap space */
+ *Unused_Heap_Top, /* Top of unused heap for GC */
+ *Unused_Heap, /* Bottom of unused heap for GC */
*Local_Heap_Base, /* Per-processor CONSing area */
*Heap, /* Bottom of all heap space */
Current_State_Point, /* Dynamic state point */
extern char *OS_Name, *OS_Variant;
extern long Heap_Size, Constant_Size, Stack_Size;
extern Pointer *Highest_Allocated_Address;
-
-/* External primitive data */
-
-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();
\f
/* String utilities */
extern void Back_Trace(), Handle_Debug_Flags(),
Find_Symbol(), Show_Env(), Show_Pure(),
Print_Return(), Print_Expression(), Print_Primitive();
-
-/* Compiler Stuff */
-
-extern Pointer Registers[];
\f
/* Conditional utilities */
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/fasdump.c,v 9.22 1987/02/03 15:56:43 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasdump.c,v 9.23 1987/04/03 00:12:00 jinx Exp $
This file contains code for fasdump and dump-band.
*/
#include "primitive.h"
#define In_Fasdump
#include "gccode.h"
+#include "trap.h"
+#include "lookup.h"
#include "dump.c"
\f
/* Some statics used freely in this file */
Pointer *NewFree, *NewMemTop, *Fixup, *Orig_New_Free;
/* FASDUMP:
-
- Hair squared! ... in order to dump an object it must be traced
- (as in a garbage collection), but with some significant differences.
- First, the copy must have (a) the global value cell of symbols set
- to UNBOUND; (b) the danger bits cleared in symbols; and (c)
- variables uncompiled. Second, and worse, all the broken hearts
- created during the process must be restored to their original
- values. This last is done by growing the copy of the object in the
- bottom of spare heap, keeping track of the locations of broken
- hearts and original contents at the top of the spare heap.
+
+ Hair squared! ... in order to dump an object it must be traced (as
+ in a garbage collection), but with some significant differences.
+ First, the copy must have the global value cell of symbols set to
+ UNBOUND and variables uncompiled. Second, and worse, all the
+ broken hearts created during the process must be restored to their
+ original values. This last is done by growing the copy of the
+ object in the bottom of spare heap, keeping track of the locations
+ of broken hearts and original contents at the top of the spare
+ heap.
FASDUMP is called with three arguments:
Argument 1: Base of spare heap
standard Pure/Constant block.
*/
\f
-/* Copy of GCLoop, except (a) copies out of constant space into the
+/*
+ Copy of GCLoop, except (a) copies out of constant space into the
object to be dumped; (b) changes symbols and variables as
- described; (c) clears danger bits as described; (d) keeps track of
- broken hearts and their original contents (e) To_Pointer is now
- NewFree.
+ described; (c) keeps track of broken hearts and their original
+ contents (e) To_Pointer is now NewFree.
*/
#define Dump_Pointer(Code) \
To = NewFree;
Fixes = Fixup;
- if (Dump_Debug) printf( "Starting scan at 0x%08x\n", Scan);
-
for ( ; Scan != To; Scan++)
{ Temp = *Scan;
- if (Dump_Debug)
- { if (Temp != NIL)
- fprintf(stderr, "0x%08x: %02x|%06x ... ",
- Scan, Type_Code(Temp), Get_Integer(Temp));
- }
-
-/* DumpLoop continues on the next page */
-\f
-/* DumpLoop, continued */
-
Switch_by_GC_Type(Temp)
{ case TC_BROKEN_HEART:
if (Datum(Temp) != 0)
case TC_MANIFEST_NM_VECTOR:
case TC_MANIFEST_SPECIAL_NM_VECTOR:
Scan += Get_Integer(Temp);
- if (Dump_Debug)
- fprintf(stderr, "skipping %d cells.", Get_Integer(Temp));
break;
/* This should really be case_Fasdump_Non_Pointer,
and PRIMITIVE_EXTERNAL should be handled specially
*/
case_Non_Pointer:
- if (Dump_Debug) fprintf(stderr, "not a pointer.");
break;
case_compiled_entry_point:
case_Cell:
Setup_Pointer_for_Dump(Transport_Cell());
+ case TC_REFERENCE_TRAP:
+ if (Datum(Temp) <= TRAP_MAX_IMMEDIATE)
+ {
+ /* It is a non pointer. */
+ break;
+ }
+ /* Fall through. */
case TC_WEAK_CONS:
case_Fasdump_Pair:
Setup_Pointer_for_Dump(Transport_Pair());
\f
/* DumpLoop, continued */
-#ifdef QUADRUPLE
case_Quadruple:
Setup_Pointer_for_Dump(Transport_Quadruple());
-#endif
#ifdef FLOATING_ALIGNMENT
case TC_BIG_FLONUM:
Invalid_Type_Code();
} /* Switch_by_GC_Type */
- if (Dump_Debug) fprintf(stderr, "\n");
} /* For loop */
NewFree = To;
Fixup = Fixes;
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/fasl.h,v 9.22 1987/03/12 14:51:36 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasl.h,v 9.23 1987/04/03 00:12:15 jinx Exp $
Contains information relating to the format of FASL files.
Some information is contained in CONFIG.H.
/* FASL Version */
#define FASL_FILE_MARKER 0XFAFAFAFA
-#define FASL_FORMAT_ADDED_STACK 1
-#define FASL_FORMAT_VERSION 1
-#define FASL_SUBVERSION 5
/* The FASL file has a header which begins as follows: */
#define The_Version(P) Type_Code(P)
#define Make_Version(V, S, M) \
Make_Non_Pointer((V), (((S) << MACHINE_TYPE_LENGTH) | (M)))
-\f
+
#define WRITE_FLAG "w"
#define OPEN_FLAG "r"
-
-/* "Memorable" FASL sub-versions -- ones where we modified something
+\f
+/* "Memorable" FASL versions -- ones where we modified something
and want to remain backwards compatible.
*/
+/* Versions. */
+
+#define FASL_FORMAT_ADDED_STACK 1
+
+/* Subversions of highest numbered version. */
+
#define FASL_LONG_HEADER 3
#define FASL_DENSE_TYPES 4
#define FASL_PADDED_STRINGS 5
-#define FASL_OLDEST_SUPPORTED 5
+#define FASL_REFERENCE_TRAP 6
-#if 0
-/* Old Type Codes -- used for conversion purposes
- This is no longer possible, because some were re-used
- without changing the fasl file version.
-*/
+/* Current parameters. */
-#define OLD_TC_CHARACTER 0x40
-#define OLD_TC_PCOMB2 0x44
-#define OLD_TC_VECTOR 0x46
-#define OLD_TC_RETURN_CODE 0x48
-#define OLD_TC_COMPILED_PROCEDURE 0x49
-#define OLD_TC_ENVIRONMENT 0x4E
-#define OLD_TC_FIXNUM 0x50
-#define OLD_TC_CONTROL_POINT 0x56
-#define OLD_TC_BROKEN_HEART 0x58
-#define OLD_TC_COMBINATION 0x5E
-#define OLD_TC_MANIFEST_NM_VECTOR 0x60
-#define OLD_TC_PCOMB3 0x66
-#define OLD_TC_SPECIAL_NM_VECTOR 0x68
-#define OLD_TC_THE_ENVIRONMENT 0x70
-#define OLD_TC_VECTOR_1B 0x76
-#define OLD_TC_BIT_STRING 0x76
-#define OLD_TC_PCOMB0 0x78
-#define OLD_TC_VECTOR_16B 0x7E
-#define OLD_TC_UNASSIGNED 0x38
-#define OLD_TC_SEQUENCE_3 0x3C
-
-#endif 0
+#define FASL_FORMAT_VERSION FASL_FORMAT_ADDED_STACK
+#define FASL_SUBVERSION FASL_REFERENCE_TRAP
+#define FASL_OLDEST_SUPPORTED FASL_PADDED_STRINGS
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/fasload.c,v 9.22 1987/03/12 17:45:09 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasload.c,v 9.23 1987/04/03 00:12:33 jinx Exp $
The "fast loader" which reads in and relocates binary files and then
interns symbols. It is called with one argument: the (character
#include "scheme.h"
#include "primitive.h"
#include "gccode.h"
+#include "trap.h"
#define CCheck_or_Reloc_Debug Or2(Consistency_Check, Reloc_Debug)
#define Reloc_or_Load_Debug Or2(Reloc_Debug, File_Load_Debug)
"\nLoad_File: FASL File Version %4d Subversion %4d Machine Type %4d.\n",
Version, Sub_Version , Machine_Type);
fprintf(stderr,
- " Expected: Version %4d Subversion %4d Machine Type %4d.\n",
+ " Expected: Version %4d Subversion %4d Machine Type %4d.\n",
FASL_FORMAT_VERSION, FASL_SUBVERSION, FASL_INTERNAL_FORMAT);
CANNOT_LOAD:
fclose(File_Handle);
/* THEN FALL THROUGH */
#endif
- /* These work automagically */
+ case TC_REFERENCE_TRAP:
+ if (Datum(Temp) <= TRAP_MAX_IMMEDIATE)
+ {
+ Next_Pointer += 1;
+ break;
+ }
+ /* It is a pointer, fall through. */
case_compiled_entry_point:
+ /* Compiled entry points work automagically. */
default:
{ fast long Next = Datum(Temp);
*Next_Pointer++ = Make_Pointer(Type_Code(Temp), Relocate(Next));
Pointer *Next_Pointer, *Stop_At;
{ if (Reloc_Debug) printf("Interning a block.\n");
while (Next_Pointer <= Stop_At) /* BBN has < for <= */
- { if (Reloc_Debug && Dangerous(*Next_Pointer))
- printf("\nDangerous object at 0x%x: 0x%x",
- Next_Pointer, *Next_Pointer);
- switch (Safe_Type_Code(*Next_Pointer))
+ { switch (Type_Code(*Next_Pointer))
{ case TC_MANIFEST_NM_VECTOR:
Next_Pointer += Get_Integer(*Next_Pointer)+1;
break;
\f
Update_Ext_Prims(Next_Pointer, Stop_At)
fast Pointer *Next_Pointer, *Stop_At;
-{ for (;Next_Pointer < Stop_At; Next_Pointer++)
- { switch (Safe_Type_Code(*Next_Pointer))
+{ for ( ; Next_Pointer < Stop_At; Next_Pointer++)
+ { switch (Type_Code(*Next_Pointer))
{ case TC_MANIFEST_NM_VECTOR:
Next_Pointer += Get_Integer(*Next_Pointer);
break;
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/findprim.c,v 9.21 1987/01/22 14:11:56 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/findprim.c,v 9.22 1987/04/03 00:05:46 jinx Exp $
*
* Preprocessor to find and declare user defined primitives.
*
fprintf(output, "/%c User defined primitive declarations %c/\n\n",
'*', '*');
- fprintf(output, "#include \"scheme.h\"\n\n");
+ fprintf(output, "#include \"usrdef.h\"\n\n");
if (max < 0)
{
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/fixobj.h,v 9.23 1987/03/09 14:44:49 cph Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fixobj.h,v 9.24 1987/04/03 00:12:59 jinx Exp $
*
* Declarations of user offsets into the Fixed Objects Vector.
* This should correspond to the file UTABMD.SCM
*/
\f
-#define Non_Object 0x00 /* Value for UNBOUND variables */
+#define Non_Object 0x00 /* Used for unassigned variables */
#define System_Interrupt_Vector 0x01 /* Handlers for interrups */
#define System_Error_Vector 0x02 /* Handlers for errors */
#define OBArray 0x03 /* Array for interning symbols */
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/gc.h,v 9.21 1987/01/22 14:26:12 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gc.h,v 9.22 1987/04/03 00:13:13 jinx Rel $
*
* Garbage collection related macros of sufficient utility to be
* included in all compilations.
#define Set_Stack_Guard(Addr) Stack_Guard = Addr
#define New_Compiler_MemTop() \
- Registers[REGBLOCK_MEMTOP] = \
+ Regs[REGBLOCK_MEMTOP] = \
((IntCode & IntEnb)==0) ? ((Pointer) MemTop) : ((Pointer) -1)
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/gccode.h,v 9.21 1987/01/22 14:26:19 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gccode.h,v 9.22 1987/04/03 00:13:28 jinx Exp $
*
* This file contains the macros for use in code which does GC-like
* loops over memory. It is only included in a few files, unlike
*
*/
\f
-static Pointer *Low_Watch = ((Pointer *) NULL);
-static Pointer *High_Watch = ((Pointer *) NULL);
-static Boolean In_Range = false;
-
/* A SWITCH on GC types, duplicates information in GC_Type_Map[], but exists
for efficiency reasons. Macros must be used by convention: first
Switch_by_GC_Type, then each of the case_ macros (in any order). The
*/
#define Switch_by_GC_Type(P) \
- switch (Safe_Type_Code(P))
+ switch(Safe_Type_Code(P))
#define case_simple_Non_Pointer \
- case_simple_Non_Pointer_poppers \
case TC_NULL: \
case TC_TRUE: \
- case TC_UNASSIGNED: \
case TC_THE_ENVIRONMENT: \
- case TC_EXTENDED_FIXNUM: \
case TC_RETURN_CODE: \
case TC_PRIMITIVE: \
case TC_PCOMB0: \
case TC_STACK_ENVIRONMENT
-#if defined(MC68020)
-
-#define case_simple_Non_Pointer_poppers \
- case TC_PEA_INSTRUCTION: \
- case TC_JMP_INSTRUCTION: \
- case TC_DBF_INSTRUCTION:
-
-#else
-
-#define case_simple_Non_Pointer_poppers
-
-#endif
-
#define case_Fasdump_Non_Pointer \
case TC_FIXNUM: \
case TC_CHARACTER: \
TC_BROKEN_HEART
TC_MANIFEST_NM_VECTOR
TC_MANIFEST_SPECIAL_NM_VECTOR
+ TC_REFERENCE_TRAP
*/
#define case_compiled_entry_point \
case TC_CELL
/* No missing Cell types */
-
-/* Switch_by_GC_Type cases continue on the next page */
\f
-/* Switch_by_GC_Type cases continued */
-
#define case_Fasdump_Pair \
case TC_LIST: \
case TC_SCODE_QUOTE: \
case TC_HUNK3: \
case TC_CONDITIONAL: \
case TC_SEQUENCE_3: \
- case TC_PCOMB2: \
- case TC_TRAP
+ case TC_PCOMB2
-/* Missing Triple types (must be treated specially):
+/* Missing triple types (must be treated specially):
TC_VARIABLE
- */
-
-/* Switch_by_GC_Type cases continue on the next page */
+*/
\f
-/* Switch_by_GC_Type cases continued */
-
-/* There are currently no Quad types.
- Type Code -1 should be ok for now. -SMC */
-
#define case_Quadruple \
- case -1
+ case TC_QUAD
+
+/* No missing quad types. */
#define case_simple_Vector \
case TC_NON_MARKED_VECTOR: \
TC_BIG_FLONUM
*/
\f
+/* Macros for the garbage collector and related programs. */
+
#define NORMAL_GC 0
#define PURE_COPY 1
#define CONSTANT_COPY 2
/* Pointer setup for the GC Type handlers. */
+/* Check whether it has been relocated. */
+
#define Normal_BH(In_GC, then_what) \
-/* Has it already been relocated? */ \
if (Type_Code(*Old) == TC_BROKEN_HEART) \
{ *Scan = Make_New_Pointer(Type_Code(Temp), *Old); \
- if And2(In_GC, GC_Debug) \
- { if ((Get_Pointer(*Old) >= Low_Watch) && \
- (Get_Pointer(*Old) <= High_Watch)) \
- { fprintf(stderr, "0x%x: %x|%x ... From 0x%x", \
- Scan, Type_Code(Temp), Get_Integer(Temp), Old); \
- fprintf(stderr, ", To (BH) 0x%x\n", Datum(*Old)); \
- } \
- else if And2(In_GC, In_Range) \
- fprintf(stderr, ", To (BH) 0x%x", Datum(*Old)); \
- } \
then_what; \
}
-\f
+
#define Setup_Internal(In_GC, Extra_Code, BH_Code) \
if And2(In_GC, Consistency_Check) \
if ((Old >= Highest_Allocated_Address) || (Old < Heap)) \
{ fprintf(stderr, "Out of range pointer: %x.\n", Temp); \
Microcode_Termination(TERM_EXIT); \
} \
- \
-/* Does it need relocation? */ \
- \
if (Old >= Low_Constant) \
-{ if And3(In_GC, GC_Debug, In_Range) \
- fprintf(stderr, " (constant)"); \
continue; \
-} \
- \
-if And3(In_GC, GC_Debug, In_Range) \
- fprintf(stderr, "From 0x%x", Old); \
- \
BH_Code; \
-/* It must be transported to New Space */ \
-if And3(In_GC, GC_Debug, In_Range) \
- fprintf(stderr, ", To 0x%x", To); \
New_Address = (BROKEN_HEART_0 + C_To_Scheme(To)); \
Extra_Code; \
continue
*Scan = Future_Value(Temp); \
Scan -= 1
\f
-/* This is handled specially so the aux variable compilation
- mechanism will not hang onto "garbage" environments.
- */
-
-#define Transport_Variable() \
-{ Pointer Compiled_Type = Old[VARIABLE_COMPILED_TYPE]; \
- if ((Type_Code(Compiled_Type) == AUX_REF) && \
- (!Is_Constant(Get_Pointer(Compiled_Type))) && \
- (Type_Code(Vector_Ref(Compiled_Type, 0)) != TC_BROKEN_HEART)) \
- { Old[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE; \
- Old[VARIABLE_OFFSET] = NIL; \
- } \
-} \
-Transport_Triple()
-
-#define Purify_Transport_Variable() \
-{ Pointer Compiled_Type = Old[VARIABLE_COMPILED_TYPE]; \
- if ((Type_Code(Compiled_Type)==AUX_REF) && \
- (GC_Mode==PURE_COPY) && \
- ((!Is_Constant(Get_Pointer(Compiled_Type))) || \
- (!Is_Constant(Get_Pointer(Old[VARIABLE_OFFSET]))))) \
- { Old[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE; \
- Old[VARIABLE_OFFSET] = NIL; \
- } \
-} \
-Transport_Triple()
-
/* Weak Pointer code. The idea here is to support a post-GC pass which
removes any objects in the CAR of a WEAK_CONS cell which is no longer
referenced by other objects in the system.
/* Undefine Symbols */
#define Fasdump_Symbol(global_value) \
-*To++ = (*Old & ~DANGER_BIT); \
+*To++ = *Old; \
*To++ = global_value; \
Pointer_End()
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/gcloop.c,v 9.23 1987/02/08 23:09:10 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gcloop.c,v 9.24 1987/04/03 00:13:50 jinx Rel $
*
* This file contains the code for the most primitive part
* of garbage collection.
#define Setup_Pointer_for_GC(Extra_Code) \
GC_Pointer(Setup_Pointer(true, Extra_Code))
+
+#ifdef ENABLE_DEBUGGING_TOOLS
+static Pointer *gc_scan_trap = NULL;
+static Pointer *gc_free_trap = NULL;
+static Pointer gc_trap = Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_MAX_IMMEDIATE);
+#endif
\f
Pointer
*GCLoop(Scan, To_Pointer)
To = *To_Pointer;
Low_Constant = Constant_Space;
- if (GC_Debug)
- { fprintf(stderr, "Starting scan at 0x%08x\n", Scan);
- if (Low_Watch == ((Pointer *) NULL))
- { fprintf(stderr, "Enter low watch range and high watch range: ");
- scanf("%x %x", &Low_Watch, &High_Watch);
- }
- }
-
for ( ; Scan != To; Scan++)
{ Temp = *Scan;
- if (GC_Debug)
- { In_Range = (((Scan >= Low_Watch) && (Scan <= High_Watch)) ||
- ((Free >= Low_Watch) && (Free <= High_Watch)));
- if (In_Range)
- fprintf(stderr, "0x%08x: %02x|%06x ... ",
- Scan, Type_Code(Temp), Get_Integer(Temp));
+#ifdef ENABLE_DEBUGGING_TOOLS
+ if ((Temp == gc_trap) || (Scan == gc_scan_trap) || (To == gc_free_trap))
+ {
+ fprintf(stderr, "\nGCLoop: trap.\n");
}
-
-/* GCLoop continues on the next page */
-\f
-/* GCLoop, continued */
+#endif
Switch_by_GC_Type(Temp)
{ case TC_BROKEN_HEART:
case TC_MANIFEST_NM_VECTOR:
case TC_MANIFEST_SPECIAL_NM_VECTOR:
Scan += Get_Integer(Temp);
- if (GC_Debug && In_Range)
- fprintf(stderr, "skipping %d cells.", Get_Integer(Temp));
break;
case_Non_Pointer:
- if (GC_Debug && In_Range) fprintf(stderr, "not a pointer.");
break;
case_compiled_entry_point:
case_Cell:
Setup_Pointer_for_GC(Transport_Cell());
+ case TC_REFERENCE_TRAP:
+ if (Datum(Temp) <= TRAP_MAX_IMMEDIATE)
+ {
+ /* It is a non pointer. */
+ break;
+ }
+ /* It is a pair, fall through. */
case_Pair:
Setup_Pointer_for_GC(Transport_Pair());
+ case TC_VARIABLE:
case_Triple:
Setup_Pointer_for_GC(Transport_Triple());
- case TC_VARIABLE:
- Setup_Pointer_for_GC(Transport_Variable());
-
/* GCLoop continues on the next page */
\f
/* GCLoop, continued */
-#ifdef QUADRUPLE
case_Quadruple:
Setup_Pointer_for_GC(Transport_Quadruple());
-#endif
#ifdef FLOATING_ALIGNMENT
case TC_BIG_FLONUM:
Invalid_Type_Code();
} /* Switch_by_GC_Type */
- if (GC_Debug && In_Range) fprintf(stderr, "\n");
} /* For loop */
*To_Pointer = To;
return To;
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/gctype.c,v 9.21 1987/01/22 14:26:35 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/gctype.c,v 9.22 1987/04/03 00:14:08 jinx Exp $
*
* This file contains the table which maps between Types and
* GC Types.
GC_Pair, /* TC_INTERNED_SYMBOL */
GC_Vector, /* TC_CHARACTER_STRING,TC_VECTOR_8B */
GC_Pair, /* TC_ACCESS */
- GC_Non_Pointer, /* TC_EXTENDED_FIXNUM */
+ GC_Undefined, /* 0x20 */
GC_Pair, /* TC_DEFINITION */
GC_Special, /* TC_BROKEN_HEART */
GC_Pair, /* TC_ASSIGNMENT */
GC_Vector, /* TC_VECTOR_1B,TC_BIT_STRING */
GC_Non_Pointer, /* TC_PCOMB0 */
GC_Vector, /* TC_VECTOR_16B */
- GC_Non_Pointer, /* TC_UNASSIGNED */
+ GC_Special, /* TC_REFERENCE_TRAP */
GC_Triple, /* TC_SEQUENCE_3 */
GC_Triple, /* TC_CONDITIONAL */
GC_Pair, /* TC_DISJUNCTION */
GC_Cell, /* TC_CELL */
GC_Pair, /* TC_WEAK_CONS */
- GC_Triple, /* TC_TRAP */
+ GC_Quadruple, /* TC_QUAD */
GC_Compiled, /* TC_RETURN_ADDRESS */
GC_Pair, /* TC_COMPILER_LINK */
GC_Non_Pointer, /* TC_STACK_ENVIRONMENT */
GC_Undefined, /* 0x45 */
GC_Undefined, /* 0x46 */
GC_Undefined, /* 0x47 */
-#if defined(MC68020)
- GC_Non_Pointer, /* TC_PEA_INSTRUCTION */
-#else
GC_Undefined, /* 0x48 */
-#endif
GC_Undefined, /* 0x49 */
GC_Undefined, /* 0x4A */
GC_Undefined, /* 0x4B */
GC_Undefined, /* 0x4C */
GC_Undefined, /* 0x4D */
-#if defined(MC68020)
- GC_Non_Pointer, /* TC_JMP_INSTRUCTION */
-#else
GC_Undefined, /* 0x4E */
-#endif
GC_Undefined, /* 0x4F */
GC_Undefined, /* 0x50 */
-#if defined(MC68020)
- GC_Non_Pointer, /* TC_DBF_INSTRUCTION */
-#else
GC_Undefined, /* 0x51 */
-#endif
GC_Undefined, /* 0x52 */
GC_Undefined, /* 0x53 */
GC_Undefined, /* 0x54 */
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.21 1987/01/22 14:27:02 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hooks.c,v 9.22 1987/04/03 00:14:25 jinx Exp $
*
* This file contains various hooks and handles which connect the
* primitives with the main interpreter.
#endif
\f
/* (CATCH PROCEDURE)
- [Primitive number 0x03]
-
Creates a control point (a pointer to the current stack) and
passes it to PROCEDURE as its only argument. The inverse
operation, typically called THROW, is performed by using the
#endif
\f
/* (ENABLE-INTERRUPTS! INTERRUPTS)
- [Primitive number 0x06]
Changes the enabled interrupt bits to bitwise-or of INTERRUPTS
and previous value of interrupts. Returns the previous value.
See MASK_INTERRUPT_ENABLES for more information on interrupts.
longjmp(*Back_To_Eval, PRIM_APPLY);
}
-/* (GET_FIXED_OBJECTS_VECTOR)
- [Primitive number 0x7A]
+/* (GET-FIXED-OBJECTS-VECTOR)
Returns the current fixed objects vector. This vector is used
for communication between the interpreter and the runtime
system. See the file UTABCSCM.SCM in the runtime system for the
}
\f
/* (FORCE DELAYED-OBJECT)
- [Primitive number 0xAF]
Returns the memoized value of the DELAYED-OBJECT (created by a
DELAY special form) if it has already been calculated.
Otherwise, it calculates the value and memoizes it for future
longjmp(*Back_To_Eval, PRIM_DO_EXPRESSION); /*NOTREACHED*/
}
\f
-/* (EXECUTE_AT_NEW_POINT SPACE BEFORE DURING AFTER)
- [Primitive number 0xE2]
+/* (EXECUTE-AT-NEW-POINT SPACE BEFORE DURING AFTER)
Create a new state point in the specified state SPACE. To enter
the new point you must execute the BEFORE thunk. On the way out,
the AFTER thunk is executed. If SPACE is NIL, then the microcode
Translate_To_Point(New_Point);
}
\f
-/* (MAKE_STATE_SPACE MUTABLE?)
- [Primitive number 0xE1]
+/* (MAKE-STATE-SPACE MUTABLE?)
Creates a new state space for the dynamic winder. Used only
internally to the dynamic wind operations. If the arugment
is #!TRUE, then a real, mutable state space is created.
return Result;
}
\f
-/* (SCODE_EVAL SCODE-EXPRESSION ENVIRONMENT)
- [Primitive number 0x04]
+/* (SCODE-EVAL SCODE-EXPRESSION ENVIRONMENT)
Evaluate the piece of SCode (SCODE-EXPRESSION) in the
ENVIRONMENT. This is like Eval, except that it expects its input
to be syntaxed into SCode rather than just a list.
longjmp(*Back_To_Eval, PRIM_DO_EXPRESSION);
}
-/* (SET_INTERRUPT_ENABLES NEW-INT-ENABLES)
- [Primitive number 0x06]
+/* (SET-INTERRUPT-ENABLES! NEW-INT-ENABLES)
Changes the enabled interrupt bits to NEW-INT-ENABLES and
returns the previous value. See MASK_INTERRUPT_ENABLES for more
information on interrupts.
return Result;
}
\f
-/* (SET_CURRENT_HISTORY TRIPLE)
- [Primitive number 0x2F]
+/* (SET-CURRENT-HISTORY! TRIPLE)
Begins recording history into TRIPLE. The history structure is
somewhat complex and should be understood before trying to use
this primitive. It is used in the Read-Eval-Print loop in the
Scheme runtime system.
+
+ This primitive pops its own frame and escapes back to the interpreter
+ because it modifies one of the registers that the interpreter caches
+ (History).
+
+ The longjmp forces the interpreter to recache.
*/
-Built_In_Primitive(Prim_Set_Current_History, 1, "SET-CURRENT-HISTORY")
-{ Pointer Result;
+Built_In_Primitive(Prim_Set_Current_History, 1, "SET-CURRENT-HISTORY!")
+{
Primitive_1_Arg();
- Arg_1_Type(TC_HUNK3);
- Result = *History;
+
+ /* History is one of the few places where we still used danger bits.
+ Check explicitely.
+ */
+
+ if ((safe_pointer_type (Arg1)) != TC_HUNK3)
+ error_wrong_type_arg_1 ();
+
+ Val = *History;
#ifdef COMPILE_HISTORY
History = Get_Pointer(Arg1);
#else
History = Get_Pointer(Get_Fixed_Obj_Slot(Dummy_History));
#endif
- return Result;
+ Pop_Primitive_Frame( 1);
+ longjmp( *Back_To_Eval, PRIM_POP_RETURN);
+ /*NOTREACHED*/
}
-/* (SET_FIXED_OBJECTS_VECTOR VECTOR)
- [Primitive number 0x7B]
+/* (SET-FIXED-OBJECTS-VECTOR! VECTOR)
Replace the current fixed objects vector with VECTOR. The fixed
objects vector is used for communication between the Scheme
runtime system and the interpreter. The file UTABCSCM.SCM
return Result;
}
\f
-/* (TRANSLATE_TO_STATE_POINT STATE_POINT)
- [Primitive number 0xE3]
+/* (TRANSLATE-TO-STATE-POINT STATE_POINT)
Move to a new dynamic wind environment by performing all of the
necessary enter and exit forms to get from the current state to
the new state as specified by STATE_POINT.
/* This ends by longjmp-ing back to the interpreter */
}
-/* (WITH_HISTORY_DISABLED THUNK)
- [Primitive number 0x9C]
+/* (WITH-HISTORY-DISABLED THUNK)
THUNK must be a procedure or primitive procedure which takes no
arguments. Turns off the history collection mechanism. Removes
the most recent reduction (the expression which called the
longjmp(*Back_To_Eval, PRIM_APPLY);
}
\f
-/* (WITHIN_CONTROL_POINT CONTROL-POINT THUNK)
- [Primitive number 0xBF]
+/* (WITHIN-CONTROL-POINT CONTROL-POINT THUNK)
THUNK must be a procedure or primitive procedure which takes no
arguments. Restores the state of the machine from the control
point, and then calls the THUNK in this new state.
Pushed();
longjmp(*Back_To_Eval, PRIM_APPLY);
}
-/* (WITH_THREADED_STACK PROCEDURE THUNK)
- [Primitive number 0xBE]
+/* (WITH-THREADED-STACK PROCEDURE THUNK)
THUNK must be a procedure or primitive procedure which takes no
arguments. PROCEDURE must expect one argument. Basically this
primitive does (PROCEDURE (THUNK)) ... it calls the THUNK and
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/interp.c,v 9.21 1987/01/22 14:27:50 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.c,v 9.22 1987/04/03 00:14:51 jinx Exp $
*
* This file contains the heart of the Scheme Scode
* interpreter
#define In_Main_Interpreter true
#include "scheme.h"
+#include "locks.h"
+#include "trap.h"
+#include "lookup.h"
#include "zones.h"
\f
/* In order to make the interpreter tail recursive (i.e.
* ordered alphabetically by return code name.
*/
\f
-#define Interrupt(Masked_Code) \
- { Export_Registers(); \
- Setup_Interrupt(Masked_Code); \
- Import_Registers(); \
- goto Perform_Application; \
- }
+#define Interrupt(Masked_Code) \
+{ \
+ Export_Registers(); \
+ Setup_Interrupt(Masked_Code); \
+ Import_Registers(); \
+ goto Perform_Application; \
+}
#define Immediate_GC(N) \
- { Request_GC(N); \
- Interrupt(IntCode & IntEnb); \
- }
-
+{ \
+ Request_GC(N); \
+ Interrupt(IntCode & IntEnb); \
+}
+
#define Prepare_Eval_Repeat() \
- {Will_Push(CONTINUATION_SIZE+1); \
- Push(Fetch_Env()); \
- Store_Return(RC_EVAL_ERROR); \
- Save_Cont(); \
- Pushed(); \
- }
+{ \
+ Will_Push(CONTINUATION_SIZE+1); \
+ Push(Fetch_Env()); \
+ Store_Return(RC_EVAL_ERROR); \
+ Save_Cont(); \
+ Pushed(); \
+}
#define Eval_GC_Check(Amount) \
- if (GC_Check(Amount)) \
- { Prepare_Eval_Repeat(); \
- Immediate_GC(Amount); \
- }
+if (GC_Check(Amount)) \
+{ \
+ Prepare_Eval_Repeat(); \
+ Immediate_GC(Amount); \
+}
#define Eval_Error(Err) \
- { Export_Registers(); \
- Do_Micro_Error(Err, false); \
- Import_Registers(); \
- goto Internal_Apply; \
- }
+{ \
+ Export_Registers(); \
+ Do_Micro_Error(Err, false); \
+ Import_Registers(); \
+ goto Internal_Apply; \
+}
#define Pop_Return_Error(Err) \
- { Export_Registers(); \
- Do_Micro_Error(Err, true); \
- Import_Registers(); \
- goto Internal_Apply; \
- }
-
+{ \
+ Export_Registers(); \
+ Do_Micro_Error(Err, true); \
+ Import_Registers(); \
+ goto Internal_Apply; \
+}
+
#define Prepare_Pop_Return_Interrupt(Return_Code, Contents_of_Val) \
- Store_Return(Return_Code); \
- Val = Contents_of_Val; \
- Save_Cont()
+{ \
+ Store_Return(Return_Code); \
+ Save_Cont(); \
+ Store_Return(RC_RESTORE_VALUE); \
+ Store_Expression(Contents_of_Val); \
+ Save_Cont(); \
+}
\f
#define Reduces_To(Expr) \
{ Store_Expression(Expr); \
#define Environment_P(Obj) (Obj == NIL || (Type_Code(Obj) == TC_ENVIRONMENT))
-/* This makes local variable references faster */
-
-#if (LOCAL_REF == 0)
-#define Local_Offset(Ind) Ind
-#else
-#define Local_Offset(Ind) Get_Integer(Ind)
-#endif
-\f
-#ifdef COMPILE_FUTURES
-#define Splice_Future_Value(The_Loc) \
-{ while ((Type_Code(Val) == TC_FUTURE) && (Future_Spliceable(Val))) \
- { Pointer *Location; \
- Val = Future_Value(Val); \
- Location = The_Loc; \
- if Dangerous(*Location) Set_Danger_Bit(Val); \
- *Location = Val; \
- Clear_Danger_Bit(Val); \
- } \
- Set_Time_Zone(Zone_Working); \
- break; \
-}
-#else
-#define Splice_Future_Value(The_Loc) \
-{ Set_Time_Zone(Zone_Working); \
- break; \
-}
-#endif
-
-#ifdef TRAP_ON_REFERENCE
-#define Trap(Value) (Safe_Type_Code(Value) == TC_TRAP)
-#else
-#define Trap(Value) false
-#endif
-
#define MAGIC_RESERVE_SIZE 6 /* See SPMD.SCM */
#define Reserve_Stack_Space() Will_Eventually_Push(MAGIC_RESERVE_SIZE)
\f
their arguments and restarts them or suspends if the argument is a future. */
#define Arg_Type_Error(Arg_No, Err_No) \
-{ fast Pointer *Arg = &(Stack_Ref(Arg_No-1)); \
- fast Pointer Orig_Arg = *Arg; \
- if (Type_Code(*Arg) != TC_FUTURE) Pop_Return_Error(Err_No); \
+{ \
+ fast Pointer *Arg, Orig_Arg; \
+ \
+ Arg = &(Stack_Ref(Arg_No-1)); \
+ Orig_Arg = *Arg; \
+ \
+ if (Type_Code(*Arg) != TC_FUTURE) \
+ Pop_Return_Error(Err_No); \
+ \
while ((Type_Code(*Arg) == TC_FUTURE) && (Future_Has_Value(*Arg))) \
- { if (Future_Is_Keep_Slot(*Arg)) Log_Touch_Of_Future(*Arg); \
+ { \
+ if (Future_Is_Keep_Slot(*Arg)) Log_Touch_Of_Future(*Arg); \
*Arg = Future_Value(*Arg); \
} \
- if (Type_Code(*Arg) != TC_FUTURE) goto Prim_No_Trap_Apply; \
+ if (Type_Code(*Arg) != TC_FUTURE) \
+ goto Prim_No_Trap_Apply; \
+ \
Save_Cont(); \
Will_Push(STACK_ENV_EXTRA_SLOTS+2); \
Push(*Arg); /* Arg 1: The future itself */ \
*/
#define Apply_Future_Check(Name, Object) \
-{ fast Pointer *Arg = &(Object); \
- fast Pointer Orig_Answer = *Arg; \
+{ \
+ fast Pointer *Arg, Orig_Answer; \
+ \
+ Arg = &(Object); \
+ Orig_Answer = *Arg; \
+ \
while (Type_Code(*Arg) == TC_FUTURE) \
- { if (Future_Has_Value(*Arg)) \
- { if (Future_Is_Keep_Slot(*Arg)) Log_Touch_Of_Future(*Arg); \
+ { \
+ if (Future_Has_Value(*Arg)) \
+ { \
+ if (Future_Is_Keep_Slot(*Arg)) \
+ Log_Touch_Of_Future(*Arg); \
*Arg = Future_Value(*Arg); \
- } \
+ } \
else \
{ \
Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \
Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
Push(STACK_FRAME_HEADER+1); \
Pushed(); \
- *Arg = Orig_Answer; \
+ *Arg = Orig_Answer; \
goto Internal_Apply; \
} \
} \
a recursive call to EVAL is an undetermined future */
#define Pop_Return_Val_Check() \
-{ fast Pointer Orig_Val = Val; \
+{ \
+ fast Pointer Orig_Val = Val; \
+ \
while (Type_Code(Val) == TC_FUTURE) \
- { if (Future_Has_Value(Val)) \
- { if (Future_Is_Keep_Slot(Val)) Log_Touch_Of_Future(Val); \
+ { \
+ if (Future_Has_Value(Val)) \
+ { \
+ if (Future_Is_Keep_Slot(Val)) \
+ Log_Touch_Of_Future(Val); \
Val = Future_Value(Val); \
- } \
+ } \
else \
- { Save_Cont(); \
+ { \
+ Save_Cont(); \
Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \
Store_Return(RC_RESTORE_VALUE); \
Store_Expression(Orig_Val); \
}
#else /* Not compiling FUTURES code */
+
#define Pop_Return_Val_Check()
#define Apply_Future_Check(Name, Object) Name = (Object)
#define Arg_Type_Error(Arg_No, Err_No) Pop_Return_Error(Err_No)
+
#endif
\f
/* The EVAL/APPLY ying/yang */
void
Interpret(dumped_p)
Boolean dumped_p;
-{ long Which_Way;
- fast Pointer Reg_Val, Reg_Expression, *Reg_Stack_Pointer;
+{
+ long Which_Way;
+ fast Pointer *Reg_Block, *Reg_Stack_Pointer, *Reg_History;
+
extern long enter_compiled_expression();
extern long apply_compiled_procedure();
extern long return_to_compiled_code();
+ Reg_Block = &Registers[0];
+
/* Primitives jump back here for errors, requests to
* evaluate an expression, apply a function, or handle an
* interrupt request. On errors or interrupts they leave
Pushed();
Call_Future_Logging();
}
+\f
Repeat_Dispatch:
switch (Which_Way)
{ case PRIM_APPLY: goto Internal_Apply;
case ERR_ARG_3_WRONG_TYPE: Arg_Type_Error(3, ERR_ARG_3_WRONG_TYPE);
}
\f
- /*****************/
- /* Do_Expression */
- /*****************/
-
Do_Expression:
if (Eval_Debug)
*
* An operation can terminate with a Reduces_To or
* Reduces_To_Nth macro. This indicates that the value of
- * the current S-Code item is the value returned when the
+ * 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
*/
- if (Microcode_Does_Stepping && Trapping &&
- (Fetch_Eval_Trapper() != NIL))
+ if (Microcode_Does_Stepping && Trapping && (Fetch_Eval_Trapper() != NIL))
{ Stop_Trapping();
Will_Push(4);
Push(Fetch_Env());
case TC_CONTROL_POINT:
case TC_DELAYED:
case TC_ENVIRONMENT:
- case TC_EXTENDED_FIXNUM:
case TC_EXTENDED_PROCEDURE:
case TC_FIXNUM:
case TC_HUNK3:
+ case TC_INTERNED_SYMBOL:
case TC_LIST:
case TC_NON_MARKED_VECTOR:
case TC_NULL:
case TC_PRIMITIVE:
case TC_PRIMITIVE_EXTERNAL:
case TC_PROCEDURE:
+ case TC_QUAD:
case TC_UNINTERNED_SYMBOL:
- case TC_INTERNED_SYMBOL:
case TC_TRUE:
- case TC_UNASSIGNED:
case TC_VECTOR:
case TC_VECTOR_16B:
case TC_VECTOR_1B:
+ case TC_REFERENCE_TRAP:
Val = Fetch_Expression(); break;
case TC_ACCESS:
/* In case we back out */
Reserve_Stack_Space(); /* CONTINUATION_SIZE */
Finished_Eventual_Pushing(); /* of this primitive */
-/* ASSUMPTION: The syntaxer is hereby assumed NEVER to generate primitive
- combinations unless the primitive itself is output in the code stream.
- Therefore, we don't have to explicitly check here that the expression
- register has a primitive in it.
-*/
+
Primitive_Internal_Apply:
if (Microcode_Does_Stepping && Trapping &&
(Fetch_Apply_Trapper() != NIL))
{Will_Push(3);
Push(Fetch_Expression());
Push(Fetch_Apply_Trapper());
- Push(STACK_FRAME_HEADER + 1 + N_Args_Primitive(Fetch_Expression()));
+ Push(STACK_FRAME_HEADER + 1 +
+ N_Args_Primitive(Get_Integer(Fetch_Expression())));
Pushed();
Stop_Trapping();
goto Apply_Non_Trapping;
}
Prim_No_Trap_Apply:
- Export_Registers();
- Metering_Apply_Primitive(Val, Get_Integer(Fetch_Expression()));
-
-/* Any primitive which does not do a long jump can have it's primitive
- frame popped off here. At this point, it is guaranteed that the
- primitive is in the expression register in case the primitive needs
- to back out.
-*/
- Import_Registers_Except_Val();
- Pop_Primitive_Frame(N_Args_Primitive(Fetch_Expression()));
- if (Must_Report_References())
- { Store_Expression(Val);
- Store_Return(RC_RESTORE_VALUE);
- Save_Cont();
- Call_Future_Logging();
+ {
+ fast long primitive_code;
+
+ primitive_code = Get_Integer(Fetch_Expression());
+
+ Export_Registers_Before_Primitive();
+ Metering_Apply_Primitive(Val, primitive_code);
+ Import_Registers_After_Primitive();
+ Pop_Primitive_Frame(N_Args_Primitive(primitive_code));
+ if (Must_Report_References())
+ { Store_Expression(Val);
+ Store_Return(RC_RESTORE_VALUE);
+ Save_Cont();
+ Call_Future_Logging();
+ }
+ break;
}
- break;
\f
case TC_PCOMB1:
Reserve_Stack_Space(); /* 1+CONTINUATION_SIZE */
/* Interpret(), continued */
case TC_VARIABLE:
-/* ASSUMPTION: The SYMBOL slot does NOT contain a future */
- { fast Pointer Compilation_Type, *Variable_Object;
- int The_Type;
+ {
+ long temp;
- Set_Time_Zone(Zone_Lookup);
#ifndef No_In_Line_Lookup
- Variable_Object = Get_Pointer(Fetch_Expression());
- Compilation_Type = Variable_Object[VARIABLE_COMPILED_TYPE];
- The_Type = Type_Code(Compilation_Type);
+ fast Pointer *cell;
- if (The_Type == LOCAL_REF)
- { fast Pointer *Frame;
- Frame = Get_Pointer(Fetch_Env());
- Val = Without_Danger_Bit(Frame[Local_Offset(Compilation_Type)]);
- if (!Trap(Val))
- Splice_Future_Value(&(Frame[Local_Offset(Compilation_Type)]));
- }
- else if (The_Type == GLOBAL_REF)
- { Val = Vector_Ref(Compilation_Type, SYMBOL_GLOBAL_VALUE);
- if (Dangerous(Val))
- Variable_Object[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
- else if (!Trap(Val))
- Splice_Future_Value(Nth_Vector_Loc(Compilation_Type,
- SYMBOL_GLOBAL_VALUE));
+ Set_Time_Zone(Zone_Lookup);
+ cell = Get_Pointer(Fetch_Expression());
+ lookup(cell, Fetch_Env(), cell, repeat_variable_lookup);
+ Val = *cell;
+ if (Type_Code(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:
+ cell = Get_Pointer(Fetch_Expression());
+ temp =
+ deep_lookup_end(deep_lookup(Fetch_Env(), cell[VARIABLE_SYMBOL], cell),
+ cell);
+ goto external_lookup_return;
+
+ /* No need to recompile, pass the fake variable. */
+ case TRAP_FLUID:
+ temp = deep_lookup_end(lookup_fluid(Val), fake_variable_object);
+
+ external_lookup_return:
+ Import_Val();
+ if (temp != PRIM_DONE)
+ break;
+ Set_Time_Zone(Zone_Working);
+ goto Pop_Return;
+
+ case TRAP_UNBOUND:
+ temp = ERR_UNBOUND_VARIABLE;
+ break;
+
+ case TRAP_UNASSIGNED:
+ temp = ERR_UNASSIGNED_VARIABLE;
+ break;
+
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
- else if (The_Type == FORMAL_REF)
- { fast long Frame_No;
- fast Pointer *Frame;
-
- Frame = Get_Pointer(Fetch_Env());
- Frame_No = Get_Integer(Variable_Object[VARIABLE_FRAME_NO]);
- while(--Frame_No >= 0)
- Frame = Get_Pointer(Fast_Vector_Ref(Frame[HEAP_ENV_FUNCTION],
- PROCEDURE_ENVIRONMENT));
- Val = Frame[Local_Offset(Variable_Object[VARIABLE_OFFSET])];
- if (Dangerous(Val))
- Variable_Object[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
- else if (!Trap(Val))
- Splice_Future_Value(
- &(Frame[Local_Offset(Variable_Object[VARIABLE_OFFSET])]));
+ default:
+ temp = ERR_BROKEN_COMPILED_VARIABLE;
+ break;
}
-#endif
- /* Fall through in cases not handled above */
- { long Result;
- Result = Lex_Ref(Fetch_Env(), Fetch_Expression());
- Import_Val();
- Set_Time_Zone(Zone_Working);
- if (Result == PRIM_DONE) break;
- Eval_Error(Result);
+
+#else No_In_Line_Lookup
+
+ Set_Time_Zone(Zone_Lookup);
+ temp = Lex_Ref(Fetch_Env(), Fetch_Expression());
+ Import_Val();
+ if (temp == PRIM_DONE)
+ break;
+
+#endif No_In_Line_Lookup
+
+ /* Back out of the evaluation. */
+
+ Set_Time_Zone(Zone_Working);
+
+ if (temp == PRIM_INTERRUPT)
+ {
+ Prepare_Eval_Repeat();
+ Interrupt(IntCode & IntEnb);
}
+
+ Eval_Error(temp);
}
case TC_RETURN_CODE:
Microcode_Termination(TERM_END_OF_COMPUTATION);
case RC_EVAL_ERROR:
+ /* Should be called RC_REDO_EVALUATION. */
Store_Env(Pop());
Reduces_To(Fetch_Expression());
case RC_EXECUTE_ACCESS_FINISH:
- { long Result;
+ {
+ long Result;
+ Pointer value;
+
Pop_Return_Val_Check();
+ value = Val;
+
if (Environment_P(Val))
- { Result = Symbol_Lex_Ref(Val,
- Fast_Vector_Ref(Fetch_Expression(), ACCESS_NAME));
+ { Result = Symbol_Lex_Ref(value,
+ Fast_Vector_Ref(Fetch_Expression(),
+ ACCESS_NAME));
Import_Val();
- if (Result != PRIM_DONE) Pop_Return_Error(Result);
- End_Subproblem();
- break;
+ 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(IntCode & IntEnb);
}
+ Val = value;
Pop_Return_Error(ERR_BAD_FRAME);
}
/* Interpret(), continued */
case RC_EXECUTE_ASSIGNMENT_FINISH:
- { fast Pointer Compilation_Type, *Variable_Object;
- Pointer The_Non_Object, Store_Value;
- int The_Type;
+ {
+ long temp;
+ Pointer value;
+ Lock_Handle set_serializer;
+
+#ifndef No_In_Line_Lookup
+
+ Pointer bogus_unassigned;
+ fast Pointer *cell;
Set_Time_Zone(Zone_Lookup);
Restore_Env();
- The_Non_Object = Get_Fixed_Obj_Slot(Non_Object);
- Store_Value = (Val == The_Non_Object) ? UNASSIGNED_OBJECT : Val;
+ cell = Get_Pointer(Vector_Ref(Fetch_Expression(), ASSIGN_NAME));
+ lookup(cell, Fetch_Env(), cell, repeat_assignment_lookup);
+ setup_lock(set_serializer, cell);
+
+ value = Val;
+ bogus_unassigned = Get_Fixed_Obj_Slot(Non_Object);
+ if (value == bogus_unassigned)
+ value = UNASSIGNED_OBJECT;
+
+ if (Type_Code(*cell) != TC_REFERENCE_TRAP)
+ {
+ Val = *cell;
+
+ normal_assignment_done:
+ *cell = value;
+ remove_lock(set_serializer);
+ Set_Time_Zone(Zone_Working);
+ End_Subproblem();
+ goto Pop_Return;
+ }
-#ifndef No_In_Line_Lookup
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
- Variable_Object =
- Get_Pointer(Vector_Ref(Fetch_Expression(), ASSIGN_NAME));
- Compilation_Type = Variable_Object[VARIABLE_COMPILED_TYPE];
- The_Type = Type_Code(Compilation_Type);
-
- if (The_Type == LOCAL_REF)
- { fast Pointer *Frame;
- Frame = Get_Pointer(Fetch_Env());
- Val = Frame[Local_Offset(Compilation_Type)];
- if (Dangerous(Val))
- { Set_Danger_Bit(Store_Value);
- Clear_Danger_Bit(Val);
- }
- if (!Trap(Val))
- { Frame[Local_Offset(Compilation_Type)] = Store_Value;
- if (Val == UNASSIGNED_OBJECT) Val = The_Non_Object;
+ get_trap_kind(temp, *cell);
+ switch(temp)
+ {
+ case TRAP_DANGEROUS:
+ case TRAP_UNBOUND_DANGEROUS:
+ case TRAP_UNASSIGNED_DANGEROUS:
+ case TRAP_FLUID_DANGEROUS:
+ remove_lock(set_serializer);
+ cell = Get_Pointer(Vector_Ref(Fetch_Expression(), ASSIGN_NAME));
+ temp =
+ deep_assignment_end(deep_lookup(Fetch_Env(),
+ cell[VARIABLE_SYMBOL],
+ cell),
+ cell,
+ value,
+ false);
+ goto external_assignment_return;
+
+ case TRAP_UNASSIGNED:
+ Val = bogus_unassigned;
+ goto normal_assignment_done;
+
+ case TRAP_FLUID:
+ /* No need to recompile, pass the fake variable. */
+ remove_lock(set_serializer);
+ temp = deep_assignment_end(lookup_fluid(*cell),
+ fake_variable_object,
+ value,
+ false);
+
+ external_assignment_return:
+ Import_Val();
+ if (temp != PRIM_DONE)
+ break;
Set_Time_Zone(Zone_Working);
End_Subproblem();
+ goto Pop_Return;
+
+ case TRAP_UNBOUND:
+ remove_lock(set_serializer);
+ temp = ERR_UNBOUND_VARIABLE;
+ break;
+
+ default:
+ remove_lock(set_serializer);
+ temp = ERR_BROKEN_COMPILED_VARIABLE;
break;
- }
- }
- else if (The_Type == GLOBAL_REF)
- { Val = Vector_Ref(Compilation_Type, SYMBOL_GLOBAL_VALUE);
- if (!Dangerous(Val) && !Trap(Val))
- { Vector_Set(Compilation_Type, SYMBOL_GLOBAL_VALUE, Store_Value);
- if (Val == UNASSIGNED_OBJECT) Val = The_Non_Object;
- Set_Time_Zone(Zone_Working);
- End_Subproblem();
- break;
- }
- else if (Dangerous(Val))
- Variable_Object[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
}
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
- else if (The_Type == FORMAL_REF)
- { fast long Frame_No;
- fast Pointer *Frame;
-
- Frame = Get_Pointer(Fetch_Env());
- Frame_No = Get_Integer(Variable_Object[VARIABLE_FRAME_NO]);
- while(--Frame_No >= 0)
- Frame = Get_Pointer(Fast_Vector_Ref(Frame[HEAP_ENV_FUNCTION],
- PROCEDURE_ENVIRONMENT));
- Val = Frame[Local_Offset(Variable_Object[VARIABLE_OFFSET])];
- if (!Dangerous(Val) && !Trap(Val))
- { Frame[Local_Offset(Variable_Object[VARIABLE_OFFSET])] =
- Store_Value;
- if (Val==UNASSIGNED_OBJECT) Val = The_Non_Object;
- Set_Time_Zone(Zone_Working);
- End_Subproblem();
- break;
- }
- else if (Dangerous(Val))
- Variable_Object[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
+#else
+
+ Set_Time_Zone(Zone_Lookup);
+ Restore_Env();
+ temp = Lex_Set(Fetch_Env(),
+ Vector_Ref(Fetch_Expression(), ASSIGN_NAME),
+ value);
+ Import_Val();
+ if (temp == PRIM_DONE)
+ { End_Subproblem();
+ Set_Time_Zone(Zone_Working);
+ break;
}
+
#endif
- /* Fall through in cases not handled above */
- { long Result;
- Result = Lex_Set(Fetch_Env(),
- Vector_Ref(Fetch_Expression(), ASSIGN_NAME),
- Store_Value);
- Import_Val();
- Set_Time_Zone(Zone_Working);
- if (Result == PRIM_DONE)
- { End_Subproblem();
- break;
- }
- Save_Env();
- Pop_Return_Error(Result);
+
+ 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(IntCode & IntEnb);
}
/* Interpret() continues on the next page */
/* Interpret(), continued */
case RC_EXECUTE_DEFINITION_FINISH:
- { Pointer Saved_Val;
- long Result;
+ {
+ Pointer value;
+ long result;
- Saved_Val = Val;
+ value = Val;
Restore_Env();
- Result = Local_Set(Fetch_Env(),
+ Export_Registers();
+ result = Local_Set(Fetch_Env(),
Fast_Vector_Ref(Fetch_Expression(), DEFINE_NAME),
Val);
- Import_Val();
- if (Result==PRIM_DONE)
- { End_Subproblem();
+ Import_Registers();
+ if (result == PRIM_DONE)
+ {
+ End_Subproblem();
break;
}
Save_Env();
- if (Result==PRIM_INTERRUPT)
- { Prepare_Pop_Return_Interrupt(RC_EXECUTE_DEFINITION_FINISH,
- Saved_Val);
+ if (result == PRIM_INTERRUPT)
+ {
+ Prepare_Pop_Return_Interrupt(RC_EXECUTE_DEFINITION_FINISH,
+ value);
Interrupt(IntCode & IntEnb);
}
- Pop_Return_Error(Result);
- };
+ Val = value;
+ Pop_Return_Error(result);
+ }
case RC_EXECUTE_IN_PACKAGE_CONTINUE:
Pop_Return_Val_Check();
if (Environment_P(Val))
- { End_Subproblem();
+ {
+ End_Subproblem();
Store_Env(Val);
Reduces_To_Nth(IN_PACKAGE_EXPRESSION);
}
case RC_HALT:
Export_Registers();
Microcode_Termination(TERM_TERM_HANDLER);
-
-/* Interpret() continues on the next page */
\f
-/* Interpret(), continued */
+ case RC_INTERNAL_APPLY:
+
+Internal_Apply:
-#define Prepare_Apply_Interrupt() \
- Prepare_Pop_Return_Interrupt(RC_INTERNAL_APPLY, NIL)
+/* Branch here to perform a function application.
+
+ At this point the top of the stack contains an application frame
+ which consists of the following elements (see sdata.h):
+ - A header specifying the frame length.
+ - A procedure.
+ - The actual (evaluated) arguments.
+
+ No registers (except the stack pointer) are meaning full at this point.
+ Before interrupts or errors are processed, some registers are cleared
+ to avoid holding onto garbage if a garbage collection occurs.
+*/
+
+#define Prepare_Apply_Interrupt() \
+{ \
+ Store_Return(RC_INTERNAL_APPLY); \
+ Store_Expression(NIL); \
+ Save_Cont(); \
+}
#define Apply_Error(N) \
- { Store_Return(RC_INTERNAL_APPLY); \
- Val = NIL; \
- Pop_Return_Error(N); \
- }
+{ \
+ Store_Return(RC_INTERNAL_APPLY); \
+ Store_Expression(NIL); \
+ Val = NIL; \
+ Pop_Return_Error(N); \
+}
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
- case RC_INTERNAL_APPLY:
-Internal_Apply:
-
-/* Branch here to perform a function application. At this point
- it is necessary that the top of the stack contain a frame
- for evaluation of the function to be applied. This frame
- DOES NOT contain "finger" and "combination" slots, although
- if the frame is to be copied into the heap, it will have NIL's
- in the "finger" and "combination" slots which will correspond
- to "potentially-dangerous" and "auxilliary variables" slots.
-
- Note, also, that unlike most return codes Val is not used here.
- Thus, the error and interrupt macros above set it to NIL so that it
- will not 'hold on' to anything if a GC occurs. Similarly, the
- contents of Expression are discarded.
-*/
if (Microcode_Does_Stepping && Trapping &&
- (Fetch_Apply_Trapper() != NIL))
- { long Count = Get_Integer(Stack_Ref(STACK_ENV_HEADER));
+ (Fetch_Apply_Trapper() != NIL))
+ {
+ long Count;
+
+ Count = Get_Integer(Stack_Ref(STACK_ENV_HEADER));
Top_Of_Stack() = Fetch_Apply_Trapper();
Push(STACK_FRAME_HEADER+Count);
Stop_Trapping();
}
+
Apply_Non_Trapping:
- { long Interrupts;
- Pointer Function;
-
- Store_Expression(NIL);
- Interrupts = IntCode & IntEnb;
- if (Interrupts != 0)
- { Prepare_Apply_Interrupt();
- Interrupt(Interrupts);
- }
+
+ if ((IntCode & IntEnb) != 0)
+ {
+ long Interrupts;
+
+ Interrupts = (IntCode & IntEnb);
+ Store_Expression(NIL);
+ Val = NIL;
+ Prepare_Apply_Interrupt();
+ Interrupt(Interrupts);
+ }
Perform_Application:
+
+ Apply_Ucode_Hook();
+
+ {
+ fast Pointer Function;
+
Apply_Future_Check(Function, Stack_Ref(STACK_ENV_FUNCTION));
- Apply_Ucode_Hook();
+
+ switch(Type_Code(Function))
+ {
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
- switch(Type_Code(Function))
- { case TC_PROCEDURE:
- { Pointer Lambda_Expr, *Temp1, Temp2;
- long NParams, Size;
- fast long NArgs;
-
- Apply_Future_Check(Lambda_Expr,
- Fast_Vector_Ref(Function,
- PROCEDURE_LAMBDA_EXPR));
- Temp1 = Get_Pointer(Lambda_Expr);
- Apply_Future_Check(Temp2, Temp1[LAMBDA_FORMALS]);
- NArgs = Get_Integer(Pop());
- NParams = Vector_Length(Temp2);
- if (Eval_Debug)
- { Print_Expression(FIXNUM_0+NArgs,
- "APPLY: Number of arguments");
- Print_Expression(FIXNUM_0+NParams,
- " Number of parameters");
+ case TC_PROCEDURE:
+ {
+ fast long nargs;
+
+ nargs = Get_Integer(Pop());
+ Function = Fast_Vector_Ref(Function, PROCEDURE_LAMBDA_EXPR);
+
+ {
+ fast Pointer formals;
+
+ Apply_Future_Check(formals,
+ Fast_Vector_Ref(Function, LAMBDA_FORMALS));
+
+ if ((nargs != Vector_Length(formals)) &&
+ ((Type_Code(Function) != TC_LEXPR) ||
+ (nargs < Vector_Length(formals))))
+ {
+ Push(STACK_FRAME_HEADER + nargs - 1);
+ Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
+ }
}
- if (Type_Code(Lambda_Expr) == TC_LAMBDA)
- { if (NArgs != NParams)
- { Push(STACK_FRAME_HEADER+NArgs-1);
- Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
- }
+
+ if (Eval_Debug)
+ {
+ Print_Expression(Make_Unsigned_Fixnum(nargs),
+ "APPLY: Number of arguments");
}
- else if (NArgs < NParams)
- { Push(STACK_FRAME_HEADER+NArgs-1);
- Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
- }
- Size = NArgs + (HEAP_ENV_EXTRA_SLOTS - 1);
- if (GC_Check(Size))
- { Push(STACK_FRAME_HEADER+NArgs-1);
+
+ if (GC_Check(nargs + 1))
+ {
+ Push(STACK_FRAME_HEADER + nargs - 1);
Prepare_Apply_Interrupt();
- Immediate_GC(Size);
+ Immediate_GC(nargs + 1);
}
- /* Store Environment Frame into heap, putting extra slots
- for Potentially Dangerous and Auxiliaries */
- Store_Env(Make_Pointer(TC_ENVIRONMENT, Free));
- *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Size);
- *Free++ = NIL; /* For PD list and Aux list */
- *Free++ = NIL;
- for (; --NArgs >= 0; ) *Free++ = Pop();
- Reduces_To(Temp1[LAMBDA_SCODE]);
+
+ {
+ fast Pointer *scan;
+
+ scan = Free;
+ Store_Env(Make_Pointer(TC_ENVIRONMENT, scan));
+ *scan++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, nargs);
+ while(--nargs >= 0)
+ *scan++ = Pop();
+ Free = scan;
+ Reduces_To(Fast_Vector_Ref(Function, LAMBDA_SCODE));
+ }
}
/* Interpret() continues on the next page */
/* Interpret(), continued */
case TC_CONTROL_POINT:
+ {
if (Get_Integer(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();
Our_Throw_Part_2();
goto Pop_Return;
+ }
+
+/* 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.
+ */
+
+ case TC_PRIMITIVE:
+ {
+ if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) !=
+ STACK_ENV_FIRST_ARG + N_Args_Primitive(Get_Integer(Function)) - 1)
+ {
+ Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
+ }
+ Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG);
+ Store_Expression(Function);
+ goto Prim_No_Trap_Apply;
+ }
case TC_PRIMITIVE_EXTERNAL:
- { long NArgs, Proc = Datum(Function);
+ {
+ fast long NArgs, Proc;
+
+ Proc = Datum(Function);
if (Proc > MAX_EXTERNAL_PRIMITIVE)
+ {
Apply_Error(ERR_UNDEFINED_PRIMITIVE);
+ }
NArgs = Ext_Prim_Desc[Proc].arity;
if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) !=
- STACK_ENV_FIRST_ARG+NArgs-1)
+ (NArgs + (STACK_ENV_FIRST_ARG - 1)))
+ {
Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
+ }
Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG);
- /* Remove the frame overhead, since the primitives
- just expect arguments on the stack */
Store_Expression(Function);
+
Repeat_External_Primitive:
/* Reinitialize Proc in case we "goto Repeat_External..." */
Proc = Get_Integer(Fetch_Expression());
- Export_Registers();
+
+ Export_Registers_Before_Primitive();
Val = (*(Ext_Prim_Desc[Proc].proc))();
Set_Time_Zone(Zone_Working);
- Import_Registers_Except_Val();
+ Import_Registers_After_Primitive();
Pop_Primitive_Frame(Ext_Prim_Desc[Proc].arity);
+
goto Pop_Return;
}
/* Interpret(), continued */
case TC_EXTENDED_PROCEDURE:
- { Pointer Lambda_Expr, *List_Car, Temp;
- long NArgs, NParams, Formals, Params, Auxes,
- Rest_Flag, Size, i;
-
-/* Selectors for the various parts */
-
-#define Get_Body_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_SCODE))
-#define Get_Names_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_NAMES))
-#define Get_Count_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_ARG_COUNT))
-#define Elambda_Formals_Count(Addr) \
- ((((long) Addr) & EL_FORMALS_MASK) >> EL_FORMALS_SHIFT)
-#define Elambda_Opts_Count(Addr) \
- (((long) Addr) & EL_OPTS_MASK)
-#define Elambda_Rest_Flag(Addr) \
- ((((long) Addr) & EL_REST_MASK) >> EL_REST_SHIFT)
-
- Apply_Future_Check(Lambda_Expr,
- Fast_Vector_Ref(Function,
- PROCEDURE_LAMBDA_EXPR));
- Apply_Future_Check(Temp, Fast_Vector_Ref(Lambda_Expr,
- ELAMBDA_NAMES));
- NParams = Vector_Length(Temp) - 1;
- Apply_Future_Check(Temp, Get_Count_Elambda(Lambda_Expr));
- Formals = Elambda_Formals_Count(Temp);
- /* Formals DOES NOT include the name of the lambda */
- Params = Elambda_Opts_Count(Temp) + Formals;
- Rest_Flag = Elambda_Rest_Flag(Temp);
- NArgs = Get_Integer(Pop()) - 1;
- Auxes = NParams - (Params + Rest_Flag);
- if ((NArgs < Formals) ||
- (!Rest_Flag && (NArgs > Params)))
- { Push(STACK_FRAME_HEADER+NArgs);
+ {
+ Pointer lambda;
+ long nargs, nparams, formals, params, auxes,
+ rest_flag, size;
+
+ fast long i;
+ fast Pointer *scan;
+
+ nargs = Get_Integer(Pop()) - STACK_FRAME_HEADER;
+
+ if (Eval_Debug)
+ {
+ Print_Expression(Make_Unsigned_Fixnum(nargs+STACK_FRAME_HEADER),
+ "APPLY: Number of arguments");
+ }
+
+ lambda = Fast_Vector_Ref(Function, PROCEDURE_LAMBDA_EXPR);
+ Apply_Future_Check(Function,
+ Fast_Vector_Ref(lambda, ELAMBDA_NAMES));
+ nparams = Vector_Length(Function) - 1;
+
+ Apply_Future_Check(Function, Get_Count_Elambda(lambda));
+ formals = Elambda_Formals_Count(Function);
+ params = Elambda_Opts_Count(Function) + formals;
+ rest_flag = Elambda_Rest_Flag(Function);
+ auxes = nparams - (params + rest_flag);
+
+ if ((nargs < formals) || (!rest_flag && (nargs > params)))
+ {
+ Push(STACK_FRAME_HEADER + nargs);
Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
}
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- Size = Params + Rest_Flag + Auxes +
- (HEAP_ENV_EXTRA_SLOTS + 1);
- List_Car = Free + Size;
- if (GC_Check(Size + ((NArgs > Params) ?
- 2 * (NArgs - Params) : 0)))
- { Push(STACK_FRAME_HEADER+NArgs);
+ /* 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)))
+ {
+ Push(STACK_FRAME_HEADER + nargs);
Prepare_Apply_Interrupt();
- Immediate_GC(Size + ((NArgs > Params) ?
- 2 * (NArgs - Params) : 0));
+ Immediate_GC(size + 1 + ((nargs > params) ?
+ (2 * (nargs - params)) :
+ 0));
}
- Store_Env(Make_Pointer(TC_ENVIRONMENT, Free));
- *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Size-1);
- /* Environment Header */
- *Free++ = NIL; /* Aux list */
- *Free++ = NIL; /* PD list */
- Size = 1 + ((NArgs < Params) ? NArgs : Params);
- for (i = 0; i < Size; i++) *Free++ = Pop();
- for (i--; i < Params; i++)
- *Free++ = UNASSIGNED_OBJECT;
- if (Rest_Flag)
- if (NArgs <= i) *Free++ = NIL;
- else
- { *Free++ = Make_Pointer(TC_LIST, List_Car);
- for (; i < NArgs; i++, List_Car++)
- { *List_Car++ = Pop();
- *List_Car = Make_Pointer(TC_LIST, List_Car+1);
- }
- List_Car[-1] = NIL;
- }
- for (i = 0; i < Auxes; i++) *Free++ = UNASSIGNED_OBJECT;
- Free = List_Car;
- Reduces_To(Get_Body_Elambda(Lambda_Expr));
- }
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
- case TC_PRIMITIVE:
- { long Number_Of_Args = N_Args_Primitive(Function);
- if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) !=
- STACK_ENV_FIRST_ARG+Number_Of_Args-1)
- Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
- Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG);
- /* Remove the frame overhead, since the primitives
- just expect arguments on the stack */
- Store_Expression(Function);
- goto Prim_No_Trap_Apply;
+ scan = Free;
+ Store_Env(Make_Pointer(TC_ENVIRONMENT, scan));
+ *scan++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, size);
+
+ if (nargs <= params)
+ {
+ for (i = (nargs + 1); --i >= 0; )
+ *scan++ = Pop();
+ for (i = (params - nargs); --i >= 0; )
+ *scan++ = UNASSIGNED_OBJECT;
+ if (rest_flag)
+ *scan++ = NIL;
+ for (i = auxes; --i >= 0; )
+ *scan++ = UNASSIGNED_OBJECT;
+ }
+ else
+ {
+ /* rest_flag must be true. */
+ Pointer list;
+
+ list = Make_Pointer(TC_LIST, (scan + size));
+ for (i = (params + 1); --i >= 0; )
+ *scan++ = Pop();
+ *scan++ = list;
+ for (i = auxes; --i >= 0; )
+ *scan++ = UNASSIGNED_OBJECT;
+ /* Now scan == Get_Pointer(list) */
+ for (i = (nargs - params); --i >= 0; )
+ {
+ *scan++ = Pop();
+ *scan = Make_Pointer(TC_LIST, (scan + 1));
+ scan += 1;
+ }
+ scan[-1] = NIL;
+ }
+
+ Free = scan;
+ Reduces_To(Get_Body_Elambda(lambda));
}
/* Interpret() continues on the next page */
/* Interpret(), continued */
case TC_COMPILED_PROCEDURE:
- { apply_compiled_setup(STACK_ENV_EXTRA_SLOTS +
+ {
+ apply_compiled_setup(STACK_ENV_EXTRA_SLOTS +
Get_Integer( Stack_Ref( STACK_ENV_HEADER)));
Export_Registers();
Which_Way = apply_compiled_procedure();
break; /* We never get here.... */
}
-/* case RC_RESTORE_VALUE is with RC_POP_RETURN_ERROR */
-
case RC_RETURN_TRAP_POINT:
Store_Return(Old_Return_Code);
Will_Push(CONTINUATION_SIZE+3);
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/interp.h,v 9.21 1987/01/22 14:28:12 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.h,v 9.22 1987/04/03 00:15:49 jinx Exp $
*
* Macros used by the interpreter and some utilities.
*
/* OPEN CODED RACKS */
/********************/
-#ifndef ENABLE_DEBUGGING_TOOLS
-#ifdef In_Main_Interpreter
-#define Using_Registers
-#endif
-#endif
+/* Move from register to static storage and back */
-#ifdef Using_Registers
-#define Val Reg_Val
+#if defined(In_Main_Interpreter) && !defined(ENABLE_DEBUGGING_TOOLS)
+
+#define Regs Reg_Block
#define Stack_Pointer Reg_Stack_Pointer
-#define Expression Reg_Expression
+#define History Reg_History
+
+#define Import_Registers() \
+{ \
+ Reg_Stack_Pointer = Ext_Stack_Pointer; \
+ Reg_History = Ext_History; \
+}
+
+#define Export_Registers() \
+{ \
+ Ext_History = Reg_History; \
+ Ext_Stack_Pointer = Reg_Stack_Pointer; \
+}
+
#else
-#define Val Ext_Val
+
+#define Regs Registers
#define Stack_Pointer Ext_Stack_Pointer
-#define Expression Ext_Expression
+#define History Ext_History
+
+#define Import_Registers()
+#define Export_Registers()
+
#endif
+#define Import_Val()
+#define Import_Registers_Except_Val() Import_Registers()
+
+#define Import_Registers_After_Primitive()
+#define Export_Registers_Before_Primitive() Export_Registers()
+
+#define Env Regs[REGBLOCK_ENV]
+#define Val Regs[REGBLOCK_VAL]
+#define Expression Regs[REGBLOCK_EXPR]
+#define Return Regs[REGBLOCK_RETURN]
+\f
/* Internal_Will_Push is in stack.h. */
#ifdef ENABLE_DEBUGGING_TOOLS
#define Will_Eventually_Push(N) Internal_Will_Push(N)
#define Finished_Eventual_Pushing() /* No op */
-\f
+
/* Primitive stack operations:
* These operations hide the direction of stack growth.
* Throw in stack.h, Allocate_New_Stacklet in utils.c, apply, cwcc and
#define Store_Return(P) \
Return = Make_Non_Pointer(TC_RETURN_CODE, (P))
+#define Save_Env() Push(Env)
+#define Restore_Env() Env = Pop()
+#define Restore_Then_Save_Env() Env = Top_Of_Stack()
+
/* Note: Save_Cont must match the definitions in sdata.h */
#define Save_Cont() { Push(Expression); \
CONT_PRINT_EXPR_MESSAGE); \
CRLF(); \
}
-
-/* Racks operations continue on the next page */
-\f
-/* Rack operations continued */
-
-#define Save_Env() Push(Env)
-#define Restore_Env() Env = Pop()
-#define Restore_Then_Save_Env() Env = Top_Of_Stack()
-
-/* Move from register to static storage and back */
-
-#ifdef Using_Registers
-#define Import_Val() Reg_Val = Ext_Val
-
-#define Import_Registers_Except_Val() \
- { Reg_Expression = Ext_Expression; \
- Reg_Stack_Pointer = Ext_Stack_Pointer;\
- }
-
-#define Import_Registers() \
- { Import_Registers_Except_Val(); \
- Import_Val(); \
- }
-
-#define Export_Registers() { Ext_Val = Reg_Val; \
- Ext_Expression = Reg_Expression; \
- Ext_Stack_Pointer = Reg_Stack_Pointer;\
- }
-#else
-#define Import_Val()
-#define Import_Registers()
-#define Import_Registers_Except_Val()
-#define Export_Registers()
-#endif
\f
/* Random utility macros */
#define Pop_Primitive_Frame(NArgs) \
Stack_Pointer = Simulate_Popping(NArgs)
-#define N_Args_Primitive(Function) \
- ((int) Arg_Count_Table[Get_Integer(Function)])
+#define N_Args_Primitive(primitive_code) \
+ ((int) Arg_Count_Table[primitive_code])
#define Stop_Trapping() \
{ Trapping = false; \
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/list.c,v 9.21 1987/01/22 14:28:26 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/list.c,v 9.22 1987/04/03 00:16:13 jinx Exp $
*
* List creation and manipulation primitives.
*/
#include "primitive.h"
\f
/* (CONS LEFT RIGHT)
- [Primitive number 0x20]
Creates a pair with left component LEFT and right component
RIGHT.
*/
}
/* (CDR PAIR)
- [Primitive number 0x22]
Returns the second element in the pair. By convention, (CAR
NIL) is NIL.
*/
}
/* (CAR PAIR)
- [Primitive number 0x21]
Returns the first element in the pair. By convention, (CAR NIL)
is NIL.
*/
}
\f
/* (GENERAL_CAR_CDR LIST DIRECTIONS)
- [Primitive number 0x27]
DIRECTIONS encodes a string of CAR and CDR operations to be
performed on LIST as follows:
1 = NOP 101 = CDAR
}
/* (LENGTH LIST)
- [Primitive number 0x5D]
Returns the number of items in the list. By convention, (LENGTH
NIL) is 0. LENGTH will loop forever if given a circular
structure.
}
\f
/* (MEMQ ITEM LIST)
- [Primitive number 0x1C]
Searches LIST for ITEM, using EQ? as a test. Returns NIL if it
is not found, or the [first] tail of LIST whose CAR is ITEM.
*/
}
/* (SET_CAR PAIR VALUE)
- [Primitive number 0x23]
Stores VALUE in the CAR of PAIR. Returns (bad style to count on
this) the previous CAR of PAIR.
*/
}
/* (SET_CDR PAIR VALUE)
- [Primitive number 0x24]
Stores VALUE in the CDR of PAIR. Returns (bad style to count on
this) the previous CDR of PAIR.
*/
return Swap_Pointers(Nth_Vector_Loc(Arg1, CONS_CDR), Arg2);
}
\f
-/* (PAIR OBJECT)
- [Primitive number 0x7E]
+/* (PAIR? OBJECT)
Returns #!TRUE if OBJECT has the type-code LIST (ie if it was
created by CONS). Return NIL otherwise.
*/
else return NIL;
}
-/* (SYS_PAIR OBJECT)
- [Primitive number 0x85]
+/* (SYSTEM-PAIR? OBJECT)
Returns #!TRUE if the garbage collector type of OBJECT is PAIR.
*/
Built_In_Primitive(Prim_Sys_Pair, 1, "SYSTEM-PAIR?")
-{ Primitive_1_Arg();
+{
+ Primitive_1_Arg();
+
Touch_In_Primitive(Arg1, Arg1);
- if (GC_Type_List(Arg1)) return TRUTH;
- else return NIL;
+ if (GC_Type_List(Arg1))
+ return TRUTH;
+ else
+ return NIL;
}
\f
-/* (SYS_PAIR_CAR GC-PAIR)
- [Primitive number 0x86]
+/* (SYSTEM-PAIR-CAR GC-PAIR)
Same as CAR, but for anything of GC type PAIR.
*/
Built_In_Primitive(Prim_Sys_Pair_Car, 1, "SYSTEM-PAIR-CAR")
return Vector_Ref(Arg1, CONS_CAR);
}
-/* (SYS_PAIR_CDR GC-PAIR)
- [Primitive number 0x87]
+/* (SYSTEM-PAIR-CDR GC-PAIR)
Same as CDR, but for anything of GC type PAIR.
*/
Built_In_Primitive(Prim_Sys_Pair_Cdr, 1, "SYSTEM-PAIR-CDR")
return Vector_Ref(Arg1, CONS_CDR);
}
-/* (SYS_PAIR_CONS TYPE-CODE OBJECT-1 OBJECT-2)
- [Primitive number 0x84]
+/* (SYSTEM-PAIR-CONS TYPE-CODE OBJECT-1 OBJECT-2)
Like CONS, but returns an object with the specified type code
(not limited to type code LIST).
*/
}
\f
-/* (SYS_SET_CAR GC-PAIR NEW_CAR)
- [Primitive number 0x88]
+/* (SYSTEM-PAIR-SET-CAR! GC-PAIR NEW_CAR)
Same as SET_CAR, but for anything of GC type PAIR.
*/
Built_In_Primitive(Prim_Sys_Set_Car, 2, "SYSTEM-PAIR-SET-CAR!")
return Swap_Pointers(Nth_Vector_Loc(Arg1, CONS_CAR), Arg2);
}
-/* (SYS_SET_CDR GC-PAIR NEW_CDR)
- [Primitive number 0x89]
+/* (SYSTEM-PAIR-SET-CDR! GC-PAIR NEW_CDR)
Same as SET_CDR, but for anything of GC type PAIR.
*/
Built_In_Primitive(Prim_Sys_Set_Cdr, 2, "SYSTEM-PAIR-SET-CDR!")
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/memmag.c,v 9.26 1987/02/08 23:06:34 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/memmag.c,v 9.27 1987/04/03 00:17:25 jinx Exp $ */
/* Memory management top level.
/* Allocate */
Highest_Allocated_Address =
Allocate_Heap_Space(Stack_Allocation_Size(Our_Stack_Size) +
- 2*Our_Heap_Size + Our_Constant_Size);
+ (2 * Our_Heap_Size) +
+ Our_Constant_Size +
+ HEAP_BUFFER_SPACE);
/* Consistency check 2 */
if (Heap == NULL)
}
/* Initialize the various global parameters */
- Align_Float(Heap);
- Unused_Heap = Heap+Our_Heap_Size;
+ Heap += HEAP_BUFFER_SPACE;
+ Initial_Align_Float(Heap);
+ Unused_Heap = Heap + Our_Heap_Size;
Align_Float(Unused_Heap);
Constant_Space = Heap + 2*Our_Heap_Size;
Align_Float(Constant_Space);
either updates the new copy's CAR with the relocated version of the
object, or replaces it with NIL.
- This code could be implemented as a GC daemon, just like
- REHASH-GC-DAEMON, but there is no "good" way of getting Weak_Chain
- to it. Note that Weak_Chain points to Old Space unless no weak
- conses were found.
-
- This code should be reimplemented so it does not need to look at both
- old and new space at the same time. Only the "real" garbage collector
- should be allowed to do that.
+ Note that this is the only code in the system, besides the inner garbage
+ collector, which looks at both old and new space.
*/
void Fix_Weak_Chain()
*Scan = Temp;
continue;
+ case GC_Special:
+ if (Type_Code(Temp) != TC_REFERENCE_TRAP)
+ {
+ /* No other special type makes sense here. */
+ goto fail;
+ }
+ if (Datum(Temp) <= TRAP_MAX_IMMEDIATE)
+ {
+ *Scan = Temp;
+ continue;
+ }
+ /* Otherwise, it is a pointer. Fall through */
+
/* Normal pointer types, the broken heart is in the first word.
Note that most special types are treated normally here.
The BH code updates *Scan if the object has been relocated.
Otherwise it falls through and we replace it with a full NIL.
Eliminating this assignment would keep old data (pl. of datum).
*/
-
case GC_Cell:
case GC_Pair:
case GC_Triple:
*Scan = NIL;
continue;
- case GC_Special:
case GC_Undefined:
default: /* Non Marked Headers and Broken Hearts */
+ fail:
fprintf(stderr,
"\nFix_Weak_Chain: Bad Object: Type = 0x%02x; Datum = %x\n",
Type_Code(Temp), Datum(Temp));
return;
}
\f
-/* (GARBAGE_COLLECT SLACK)
- [Primitive number 0x3A]
+/* (GARBAGE-COLLECT SLACK)
Requests a garbage collection leaving the specified amount of slack
for the top of heap check on the next GC. The primitive ends by invoking
the GC daemon if there is one.
+
+ This primitive never returns normally. It always escapes into
+ the interpreter because some of its cached registers (eg. History)
+ have changed.
*/
Built_In_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT")
Arg_1_Type(TC_FIXNUM);
if (Free > Heap_Top)
- { fprintf(stderr, "\nGC has been delayed too long, and you are truly out of room!\n");
- fprintf(stderr, "Free=0x%x, MemTop=0x%x, Heap_Top=0x%x\n", Free, MemTop, Heap_Top);
+ { fprintf(stderr,
+ "\nGC has been delayed too long, and you are out of room!\n");
+ fprintf(stderr,
+ "Free = 0x%x; MemTop = 0x%x; Heap_Top = 0x%x\n",
+ Free, MemTop, Heap_Top);
Microcode_Termination(TERM_NO_SPACE);
}
GC_Reserve = Get_Integer(Arg1);
MemTop, GC_Space_Needed);
Microcode_Termination(TERM_NO_SPACE);
}
+ Pop_Primitive_Frame(1);
GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon);
if (GC_Daemon_Proc == NIL)
- return FIXNUM_0 + (MemTop - Free);
- Pop_Primitive_Frame(1);
+ {
+ Val = Make_Unsigned_Fixnum(MemTop - Free);
+ longjmp( *Back_To_Eval, PRIM_POP_RETURN);
+ /*NOTREACHED*/
+ }
Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+1));
Store_Return(RC_NORMAL_GC_DONE);
Store_Expression(FIXNUM_0 + (MemTop - Free));
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/object.h,v 9.20 1987/01/21 20:24:48 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/object.h,v 9.21 1987/04/03 00:18:15 jinx Exp $ */
/* This file contains definitions pertaining to the C view of
Scheme pointers: widths of fields, extraction macros, pre-computed
#define TYPE_CODE_LENGTH 8 /* Not CHAR_SIZE!! */
#define MAX_TYPE_CODE 0xFF /* ((1<<TYPE_CODE_LENGTH) - 1) */
-/* The danger bit is set in the value cell of an environment whenever a
- particular binding of a variable to a value has been shadowed by an
- auxiliary variable in a nested environment. It means that variables
- cached to this address must be recached since the address may be invalid.
- See lookup.c */
+/* The danger bit is being phased out. It is currently used by stacklets
+ and the history mechanism. The variable lookup code no longer uses it.
+ */
#define DANGER_TYPE 0x80 /* (1<<(TYPE_CODE_LENGTH-1)) */
#define MAX_SAFE_TYPE 0x7F /* (MAX_TYPE_CODE & ~DANGER_TYPE) */
extern Pointer *Memory_Base;
-/* The "-1" in the value returned is guarantee that there is one
+/* The "-1" in the value returned is a guarantee that there is one
word reserved exclusively for use by the garbage collector. */
-#define Allocate_Heap_Space(space) \
- (Memory_Base = ((Pointer *) (malloc ((sizeof (Pointer)) * (space)))), \
- Heap = Memory_Base, \
+#define Allocate_Heap_Space(space) \
+ (Memory_Base = ((Pointer *) (malloc ((sizeof (Pointer)) * (space)))), \
+ Heap = Memory_Base, \
((Memory_Base + (space)) - 1))
#define Get_Pointer(P) ((Pointer *) (Memory_Base + (pointer_datum (P))))
#define User_Vector_Ref(P, N) Vector_Ref(P, (N)+1)
#define User_Vector_Set(P, N, S) Vector_Set(P, (N)+1, S)
\f
-#ifdef FLOATING_ALIGNMENT
-
-#define Align_Float(Where) \
-while ((((long) ((Where) + 1)) & FLOATING_ALIGNMENT) != 0) \
- *Where++ = (Make_Non_Pointer (TC_MANIFEST_NM_VECTOR, 0));
-
-#else /* ifdef FLOATING_ALIGNMENT */
-
-#define Align_Float(Where)
-
-#endif /* ifdef FLOATING_ALIGNMENT */
-
#define fixnum_p(P) ((pointer_type (P)) == TC_FIXNUM)
#define Get_Float(P) (* ((double *) (Nth_Vector_Loc ((P), 1))))
#define Get_Integer(P) (pointer_datum (P))
(! (Is_Constant (Get_Pointer (Will_Contain)))) && \
(Pure_Test (Get_Pointer (Old_Pointer)))) \
Primitive_Error (ERR_WRITE_INTO_PURE_SPACE);
+\f
+#ifdef FLOATING_ALIGNMENT
+
+#define FLOATING_BUFFER_SPACE \
+ ((FLOATING_ALIGNMENT + 1)/sizeof(Pointer))
+
+#define HEAP_BUFFER_SPACE \
+ (TRAP_MAX_IMMEDIATE + 1 + FLOATING_BUFFER_SPACE)
+
+/* The space is there, find the correct position. */
+
+#define Initial_Align_Float(Where) \
+{ \
+ while ((((long) ((Where) + 1)) & FLOATING_ALIGNMENT) != 0) \
+ Where -= 1; \
+}
+
+#define Align_Float(Where) \
+{ \
+ while ((((long) ((Where) + 1)) & FLOATING_ALIGNMENT) != 0) \
+ *Where++ = (Make_Non_Pointer (TC_MANIFEST_NM_VECTOR, 0)); \
+}
+
+#else not FLOATING_ALIGNMENT
+
+#define HEAP_BUFFER_SPACE (TRAP_MAX_IMMEDIATE + 1)
+
+#define Initial_Align_Float(Where)
+#define Align_Float(Where)
+
+#endif FLOATING_ALIGNMENT
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/ppband.c,v 9.23 1987/02/11 18:09:32 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/ppband.c,v 9.24 1987/04/03 00:06:29 jinx Exp $
*
* Dumps Scheme FASL in user-readable form .
*/
{ Pointer *symbol;
symbol = &Data[From+SYMBOL_NAME];
if ((symbol >= end_of_memory) ||
- scheme_string(via(From+SYMBOL_NAME), false))
+ !scheme_string(via(From+SYMBOL_NAME), false))
printf("symbol not in memory; datum = %x\n", From);
return;
}
return;
case TC_CHARACTER_STRING: scheme_string(Points_To, true);
return;
- case TC_EXTENDED_FIXNUM: printf("%d\n", The_Datum);
- return;
case TC_FIXNUM: printf("%d\n", Points_To);
return;
/* Default cases */
- case TC_LIST: printf("[CONS "); break;
- case TC_WEAK_CONS: printf("[WEAK-CONS "); break;
- case TC_SCODE_QUOTE: printf("[QUOTE "); break;
- case TC_BIG_FLONUM: printf("[FLONUM "); break;
- case TC_COMBINATION_1: printf( "[COMB-1 "); break;
- case TC_EXTENDED_PROCEDURE: printf("[EPROCEDURE "); break;
- case TC_COMBINATION_2: printf("[COMB-2 "); break;
- case TC_BIG_FIXNUM: printf("[BIGNUM "); break;
+ case TC_LIST: printf("[LIST "); break;
+ case TC_CHARACTER: printf("[CHARACTER "); break;
+ case TC_SCODE_QUOTE: printf("[SCODE-QUOTE "); break;
+ case TC_PCOMB2: printf("[PCOMB2 "); break;
+ case TC_BIG_FLONUM: printf("[BIG-FLONUM "); break;
+ case TC_COMBINATION_1: printf("[COMBINATION-1 "); break;
+ case TC_EXTENDED_PROCEDURE: printf("[EXTENDED-PROCEDURE "); break;
+ case TC_VECTOR: printf("[VECTOR "); break;
+ case TC_RETURN_CODE: printf("[RETURN-CODE "); break;
+ case TC_COMBINATION_2: printf("[COMBINATION-2 "); break;
+ case TC_COMPILED_PROCEDURE: printf("[COMPILED-PROCEDURE "); break;
+ case TC_BIG_FIXNUM: printf("[BIG-FIXNUM "); break;
case TC_PROCEDURE: printf("[PROCEDURE "); break;
- case TC_PRIMITIVE_EXTERNAL: printf("[EXTERNAL-PRIMITIVE "); break;
+ case TC_PRIMITIVE_EXTERNAL: printf("[PRIMITIVE-EXTERNAL "); break;
case TC_DELAY: printf("[DELAY "); break;
+ case TC_ENVIRONMENT: printf("[ENVIRONMENT "); break;
case TC_DELAYED: printf("[DELAYED "); break;
- case TC_EXTENDED_LAMBDA: printf("[ELAMBDA "); break;
+ case TC_EXTENDED_LAMBDA: printf("[EXTENDED-LAMBDA "); break;
case TC_COMMENT: printf("[COMMENT "); break;
case TC_NON_MARKED_VECTOR: printf("[NON-MARKED-VECTOR "); break;
case TC_LAMBDA: printf("[LAMBDA "); break;
case TC_PRIMITIVE: printf("[PRIMITIVE "); break;
- case TC_SEQUENCE_2: printf("[SEQ-2 "); break;
- case TC_PCOMB1: printf("[PCOMB-1 "); break;
+ case TC_SEQUENCE_2: printf("[SEQUENCE-2 "); break;
+ case TC_PCOMB1: printf("[PCOMB1 "); break;
+ case TC_CONTROL_POINT: printf("[CONTROL-POINT "); break;
case TC_ACCESS: printf("[ACCESS "); break;
case TC_DEFINITION: printf("[DEFINITION "); break;
case TC_ASSIGNMENT: printf("[ASSIGNMENT "); break;
case TC_HUNK3: printf("[HUNK3 "); break;
case TC_IN_PACKAGE: printf("[IN-PACKAGE "); break;
+ case TC_COMBINATION: printf("[COMBINATION "); break;
+ case TC_COMPILED_EXPRESSION: printf("[COMPILED-EXPRESSION "); break;
case TC_LEXPR: printf("[LEXPR "); break;
+ case TC_PCOMB3: printf("[PCOMB3 "); break;
+
case TC_VARIABLE: printf("[VARIABLE "); break;
- case TC_CONDITIONAL: printf("[CONDITIONAL "); break;
- case TC_DISJUNCTION: printf("[DISJUNCTION "); break;
- case TC_UNASSIGNED: printf("[UNASSIGNED "); break;
- case TC_SEQUENCE_3: printf("[SEQUENCE-3 "); break;
- case TC_CHARACTER: printf("[CHARACTER "); break;
- case TC_PCOMB2: printf("[PCOMB-2 "); break;
- case TC_VECTOR: printf("[VECTOR "); break;
- case TC_RETURN_CODE: printf("[RETURN-CODE "); break;
- case TC_ENVIRONMENT: printf("[ENVIRONMENT "); break;
- case TC_CONTROL_POINT: printf("[CONTROL-POINT "); break;
- case TC_COMBINATION: printf("[COMBINATION "); break;
- case TC_PCOMB3: printf("[PCOMB-3 "); break;
case TC_THE_ENVIRONMENT: printf("[THE-ENVIRONMENT "); break;
+ case TC_FUTURE: printf("[FUTURE "); break;
case TC_VECTOR_1B: printf("[VECTOR-1B "); break;
- case TC_PCOMB0: printf("[PCOMB-0 "); break;
+ case TC_PCOMB0: printf("[PCOMB0 "); break;
case TC_VECTOR_16B: printf("[VECTOR-16B "); break;
+ case TC_SEQUENCE_3: printf("[SEQUENCE-3 "); break;
+ case TC_CONDITIONAL: printf("[CONDITIONAL "); break;
+ case TC_DISJUNCTION: printf("[DISJUNCTION "); break;
case TC_CELL: printf("[CELL "); break;
- case TC_FUTURE: printf("[FUTURE "); break;
- case TC_COMPILED_PROCEDURE: printf("[COMPILED-PROCEDURE "); break;
- case TC_COMPILED_EXPRESSION: printf("[COMPILED-EXPRESSION "); break;
+ case TC_WEAK_CONS: printf("[WEAK-CONS "); break;
+ case TC_REFERENCE_TRAP: printf("[REFERENCE-TRAP "); break;
case TC_RETURN_ADDRESS: printf("[RETURN-ADDRESS "); break;
+ case TC_COMPILER_LINK: printf("[COMPILER-LINK "); break;
+ case TC_STACK_ENVIRONMENT: printf("[STACK-ENVIRONMENT "); break;
+ case TC_COMPLEX: printf("[COMPLEX "); break;
+ case TC_QUAD: printf("[QUAD "); break;
default: printf("[02x%x ", Type); break;
}
printf("%x]\n", Points_To);
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.c,v 9.22 1987/02/03 15:59:58 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prim.c,v 9.23 1987/04/03 00:18:31 jinx Exp $
*
- * The leftovers ... primitives that don't seem to belong elsewhere
+ * The leftovers ... primitives that don't seem to belong elsewhere.
*
*/
#include "scheme.h"
#include "primitive.h"
-#include "prims.h"
\f
/* Random predicates: */
/* (NULL OBJECT)
- [Primitive number 0x0C]
Returns #!TRUE if OBJECT is NIL. Otherwise returns NIL. This is
the primitive known as NOT, NIL?, and NULL? in Scheme.
*/
Built_In_Primitive(Prim_Null, 1, "NULL?")
-{ Primitive_1_Arg();
+{
+ Primitive_1_Arg();
+
Touch_In_Primitive(Arg1, Arg1);
return (Arg1 == NIL) ? TRUTH : NIL;
}
/* (EQ? OBJECT-1 OBJECT-2)
- [Primitive number 0x0D]
- Returns #!TRUE if the two objects have the same type code,
- address portion, and danger bit. Returns NIL otherwise.
+ Returns #!TRUE if the two objects have the same type code
+ and datum. Returns NIL otherwise.
*/
Built_In_Primitive(Prim_Eq, 2, "EQ?")
-{ Primitive_2_Args();
+{
+ Primitive_2_Args();
+
if (Arg1 == Arg2) return TRUTH;
Touch_In_Primitive(Arg1, Arg1);
Touch_In_Primitive(Arg2, Arg2);
\f
/* Pointer manipulation */
-/* (MAKE_NON_POINTER NUMBER)
- [Primitive number 0xB1]
+/* (MAKE-NON-POINTER NUMBER)
Returns an (extended) fixnum with the same value as NUMBER. In
the CScheme interpreter this is basically a no-op, since fixnums
already store 24 bits.
*/
Built_In_Primitive(Prim_Make_Non_Pointer, 1, "MAKE-NON-POINTER")
-{ Primitive_1_Arg();
+{
+ Primitive_1_Arg();
+
Arg_1_Type(TC_FIXNUM);
return Arg1;
}
-/* (PRIMITIVE_DATUM OBJECT)
- [Primitive number 0xB0]
- Returns the address part of OBJECT.
+/* (PRIMITIVE-DATUM OBJECT)
+ Returns the datum part of OBJECT.
*/
Built_In_Primitive(Prim_Primitive_Datum, 1, "PRIMITIVE-DATUM")
-{ Primitive_1_Arg();
+{
+ Primitive_1_Arg();
+
return Make_New_Pointer(TC_ADDRESS, Arg1);
}
/* (PRIMITIVE-TYPE OBJECT)
- [Primitive number 0x10]
- Returns the type code of OBJECT as a number. This includes the
- danger bit, if it is set. THE OBJECT IS TOUCHED FIRST.
+ Returns the type code of OBJECT as a number.
+ Note: THE OBJECT IS TOUCHED FIRST.
*/
Built_In_Primitive(Prim_Prim_Type, 1, "PRIMITIVE-TYPE")
-{ Primitive_1_Arg();
+{
+ Primitive_1_Arg();
+
Touch_In_Primitive(Arg1, Arg1);
- return FIXNUM_0+Type_Code(Arg1);
+ return Make_Unsigned_Fixnum(Type_Code(Arg1));
}
/* (GC_TYPE OBJECT)
- [Primitive number 0xBC]
Returns a fixnum indicating the GC type of the object. The object
is NOT touched first.
*/
Built_In_Primitive(Prim_Gc_Type, 1, "GC-TYPE")
-{ Primitive_1_Arg();
+{
+ Primitive_1_Arg();
+
return Make_Non_Pointer(TC_FIXNUM, GC_Type(Arg1));
}
\f
/* (PRIMITIVE-TYPE? TYPE-CODE OBJECT)
- [Primitive number 0x0F]
Return #!TRUE if the type code of OBJECT is TYPE-CODE, NIL
- otherwise. The check includes the danger bit of OBJECT.
- THE OBJECT IS TOUCHED FIRST.
+ otherwise.
+ Note: THE OBJECT IS TOUCHED FIRST.
*/
Built_In_Primitive(Prim_Prim_Type_QM, 2, "PRIMITIVE-TYPE?")
-{ Primitive_2_Args();
+{
+ Primitive_2_Args();
+
Arg_1_Type(TC_FIXNUM);
Touch_In_Primitive(Arg2, Arg2);
- if (Type_Code(Arg2) == Get_Integer(Arg1)) return TRUTH;
- else return NIL;
+ if (Type_Code(Arg2) == Get_Integer(Arg1))
+ return TRUTH;
+ else
+ return NIL;
}
/* (PRIMITIVE-SET-TYPE TYPE-CODE OBJECT)
- [Primitive number 0x11]
-
- Returns a new object with TYPE-CODE and the address part of
- OBJECT. TOUCHES ITS SECOND ARGUMENT (for completeness sake).
+ Returns a new object with TYPE-CODE and the datum part of
+ OBJECT.
+ Note : IT TOUCHES ITS SECOND ARGUMENT (for completeness sake).
This is a "gc-safe" (paranoid) operation.
*/
Built_In_Primitive(Prim_Primitive_Set_Type, 2, "PRIMITIVE-SET-TYPE")
-{ long New_GC_Type, New_Type;
+{
+ long New_GC_Type, New_Type;
Primitive_2_Args();
+
Arg_1_Type(TC_FIXNUM);
Range_Check(New_Type, Arg1, 0, MAX_SAFE_TYPE, ERR_ARG_1_BAD_RANGE);
Touch_In_Primitive(Arg2, Arg2);
return Make_New_Pointer(New_Type, Arg2);
else Primitive_Error(ERR_ARG_1_BAD_RANGE); /*NOTREACHED*/
}
+\f
+/* Subprimitives.
+ Many primitives can be built out of these, and eventually should be.
+ These are extremely unsafe, since there is no consistency checking.
+ In particular, they are not gc-safe: You can screw yourself royally
+ by using them.
+*/
/* (&MAKE-OBJECT TYPE-CODE OBJECT)
- [Primitive number 0x8D]
-
- Makes a Scheme object whose datum field is the datum field of
- OBJECT, and whose type code is TYPE-CODE. It does not touch,
- and is not "gc-safe": You can screw yourself royally by using
- this.
+ Makes a Scheme object whose datum field is the datum field of
+ OBJECT, and whose type code is TYPE-CODE. It does not touch.
*/
Built_In_Primitive(Prim_And_Make_Object, 2, "&MAKE-OBJECT")
-{ long New_Type;
+{
+ long New_Type;
Primitive_2_Args();
+
Arg_1_Type(TC_FIXNUM);
Range_Check(New_Type, Arg1, 0, MAX_SAFE_TYPE, ERR_ARG_1_BAD_RANGE);
return Make_New_Pointer(New_Type, Arg2);
}
+
+/* (SYSTEM-MEMORY-REF OBJECT INDEX)
+ Fetches the index'ed slot in object.
+ Performs no type checking in object.
+*/
+
+Built_In_Primitive(Prim_System_Memory_Ref, 2, "SYSTEM-MEMORY-REF")
+{
+ Primitive_2_Args();
+
+ Arg_2_Type(TC_FIXNUM);
+ return Vector_Ref(Arg1, Get_Integer(Arg2));
+}
+
+/* (SYSTEM-MEMORY-SET! OBJECT INDEX VALUE)
+ Stores value in the index'ed slot in object.
+ Performs no type checking in object.
+*/
+
+Built_In_Primitive(Prim_System_Memory_Set, 3, "SYSTEM-MEMORY-SET!")
+{
+ long index;
+ Primitive_3_Args();
+
+ Arg_2_Type(TC_FIXNUM);
+ index = Get_Integer(Arg2);
+ return Swap_Pointers(Nth_Vector_Loc(Arg1, index), Arg3);
+}
\f
/* Playing with the danger bit */
/* (DANGEROUS? OBJECT)
- [Primitive number 0x49]
Returns #!TRUE if OBJECT has the danger bit set, NIL otherwise.
*/
Built_In_Primitive(Prim_Dangerous_QM, 1, "DANGEROUS?")
-{ Primitive_1_Arg();
+{
+ Primitive_1_Arg();
+
return (Dangerous(Arg1)) ? TRUTH : NIL;
}
-/* (DANGERIZE OBJECT)
- [Primitive number 0x48]
+/* (MAKE-OBJECT-DANGEROUS OBJECT)
Returns OBJECT, but with the danger bit set.
*/
-Built_In_Primitive(Prim_Dangerize, 1, "DANGERIZE")
-{ Primitive_1_Arg();
+Built_In_Primitive(Prim_Dangerize, 1, "MAKE-OBJECT-DANGEROUS")
+{
+ Primitive_1_Arg();
+
return Set_Danger_Bit(Arg1);
}
/* (UNDANGERIZE OBJECT)
- [Primitive number 0x47]
Returns OBJECT with the danger bit cleared. This does not
side-effect the object, it merely returns a new (non-dangerous)
pointer to the same item.
*/
Built_In_Primitive(Prim_Undangerize, 1, "UNDANGERIZE")
-{ Primitive_1_Arg();
- return Clear_Danger_Bit(Arg1);
-}
-\f
-/* Mapping between the internal and external representations of
- primitives, return addresses, external primitives, etc.
- */
-
-/* (MAP_CODE_TO_ADDRESS TYPE-CODE VALUE-CODE)
- [Primitive number 0x93]
- For return codes and primitives, this returns the internal
- representation of the return address or primitive address given
- the external representation. Currently in CScheme these two are
- the same. In the 68000 assembly version the internal
- representation is an actual address in memory.
-*/
-Built_In_Primitive(Prim_Map_Code_To_Address, 2, "MAP-CODE-TO-ADDRESS")
-{ long Code, Offset;
- Primitive_2_Args();
- Arg_1_Type(TC_FIXNUM);
- Arg_2_Type(TC_FIXNUM);
- Code = Get_Integer(Arg1);
- Offset = Get_Integer(Arg2);
- switch (Code)
- { case TC_RETURN_CODE:
- if (Offset > MAX_RETURN_CODE) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- break;
-
- case TC_PRIMITIVE:
- if (Offset > MAX_PRIMITIVE) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- break;
-
- default: Primitive_Error(ERR_ARG_1_BAD_RANGE);
- }
- return Make_Non_Pointer(Code, Offset);
-}
-\f
-/* (MAP_ADDRESS_TO_CODE TYPE-CODE ADDRESS)
- [Primitive number 0x90]
- This is the inverse operation for MAP_CODE_TO_ADDRESS.
- Given a machine ADDRESS and a TYPE-CODE (either return code or
- primitive) it finds the number for the external representation
- for the internal address.
-*/
-Built_In_Primitive(Prim_Map_Address_To_Code, 2, "MAP-ADDRESS-TO-CODE")
-{ long Code, Offset;
- Primitive_2_Args();
- Arg_1_Type(TC_FIXNUM);
- Code = Get_Integer(Arg1);
- Arg_2_Type(Code);
- Offset = Get_Integer(Arg2);
- switch (Code)
- { case TC_RETURN_CODE:
- if (Offset > MAX_RETURN_CODE)
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- break;
-
- case TC_PRIMITIVE:
- if (Offset > MAX_PRIMITIVE)
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- break;
-
- default:
- Primitive_Error(ERR_ARG_1_BAD_RANGE);
- }
- return FIXNUM_0+Offset;
-}
-
-/* (MAP_PRIM_ADDRESS_TO_ARITY INTERNAL-PRIMITIVE)
- [Primitive number 0x96]
- Given the internal representation of a primitive (in CScheme the
- internal and external representations are the same), return the
- number of arguments it requires.
-*/
-Built_In_Primitive(Prim_Map_Prim_Address_To_Arity, 1,
- "PRIMITIVE-PROCEDURE-ARITY")
-{ long Prim_Num;
- Primitive_1_Arg();
- if (Type_Code(Arg1) != TC_PRIMITIVE_EXTERNAL)
- { Arg_1_Type(TC_PRIMITIVE);
- Range_Check(Prim_Num, Arg1, 0, MAX_PRIMITIVE, ERR_ARG_1_BAD_RANGE);
- return FIXNUM_0 + (int) Arg_Count_Table[Prim_Num];
- }
- /* External primitives here */
- Prim_Num = Get_Integer(Arg1);
- if (Prim_Num <= MAX_EXTERNAL_PRIMITIVE)
- return FIXNUM_0 + Ext_Prim_Desc[Prim_Num].arity;
- if (Undefined_Externals==NIL) Primitive_Error(ERR_ARG_1_BAD_RANGE);
- if (Prim_Num > (MAX_EXTERNAL_PRIMITIVE+
- Get_Integer(User_Vector_Ref(Undefined_Externals, 0))))
- Primitive_Error(ERR_ARG_1_BAD_RANGE);
- return NIL;
-}
-\f
-/* Playing with non marked vectors. */
-
-/* (NON_MARKED_VECTOR_CONS LENGTH)
- [Primitive number 0x31]
- Creates a non-marked vector of the specified LENGTH. The
- contents of such a vector are not seen by the garbage collector.
- There are no ordinary operations which can be performed on
- non-marked vectors, but the SYS_VECTOR operations can be used
- with care. [This primitive appears to be a relic of days gone
- by.]
-*/
-Built_In_Primitive(Prim_Non_Marked_Vector_Cons, 1, "NON-MARKED-VECTOR-CONS")
-{ long Length;
+{
Primitive_1_Arg();
- Arg_1_Type(TC_FIXNUM);
- Length = Get_Integer(Arg1);
- Primitive_GC_If_Needed(Length+1);
- *Free = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Length);
- Free += Length+1;
- return Make_Pointer(TC_NON_MARKED_VECTOR, Free-(Length+1));
-}
-\f
-/* (INSERT_NON_MARKED_VECTOR TO-GC-VECTOR N FROM-GC-VECTOR)
- [Primitive number 0x19]
- This primitive performs a side-effect on the TO-GC-VECTOR. Both
- TO- and FROM-GC-VECTOR must be of the garbage collector type
- vector (i.e. vectors, strings, non-marked vectors, bignums,
- etc.). The FROM-GC-VECTOR is inserted in the middle of
- TO-GC-VECTOR, preceded by a non-marked vector header. The
- insertion begins at the Nth position of the vector with the
- non-marked header. Notice that this is really an "overwrite"
- rather than an insertion, since the length of the TO-GC-VECTOR
- does not change and the data which was formerly in the part of
- the vector now occupied by FROM-GC-VECTOR and its header has
- been lost. This primitive was added for the use of certain
- parts of the compiler and runtime system which need to make
- objects that have an internal part which is "hidden" from the
- garbage collector. The value returned is TO-GC-VECTOR.
-*/
-Built_In_Primitive(Prim_Insert_Non_Marked_Vector, 3,
- "INSERT-NON-MARKED-VECTOR!")
-{ Pointer *To,*From;
- long Index,NM_Length,Length,i;
- Primitive_3_Args();
- Arg_1_GC_Type(GC_Vector);
- Arg_2_Type(TC_FIXNUM);
- Arg_3_GC_Type(GC_Vector);
- Length = Vector_Length(Arg1);
- NM_Length = Vector_Length(Arg3);
- Range_Check(Index, Arg2, 0, Length-1, ERR_ARG_2_BAD_RANGE);
- if (Length-Index <= NM_Length)
- Primitive_Error(ERR_ARG_3_BAD_RANGE);
- From = Nth_Vector_Loc(Arg3, VECTOR_TYPE);
- To = Nth_Vector_Loc(Arg1, VECTOR_DATA+Index);
- for (i=0; i<=NM_Length; i++)
- *To++ = *From++;
- return Arg1;
+
+ return Clear_Danger_Bit(Arg1);
}
\f
/* Cells */
/* (MAKE-CELL CONTENTS)
- [Primitive number 0x61]
Creates a cell with contents CONTENTS.
*/
Built_In_Primitive(Prim_Make_Cell, 1, "MAKE-CELL")
-{ Primitive_1_Arg();
+{
+ Primitive_1_Arg();
+
Primitive_GC_If_Needed(1);
*Free++ = Arg1;
return Make_Pointer(TC_CELL, Free-1);
}
/* (CONTENTS CELL)
- [Primitive number 0x62]
Returns the contents of the cell CELL.
*/
Built_In_Primitive(Prim_Cell_Contents, 1, "CONTENTS")
-{ Primitive_1_Arg();
+{
+ Primitive_1_Arg();
+
Arg_1_Type(TC_CELL);
return(Vector_Ref(Arg1, CELL_CONTENTS));
}
/* (CELL? OBJECT)
- [Primitive number 0x63]
Returns #!TRUE if OBJECT has type-code CELL, otherwise returns
NIL.
*/
Built_In_Primitive(Prim_Cell, 1,"CELL?")
-{ Primitive_1_Arg();
+{
+ Primitive_1_Arg();
+
Touch_In_Primitive(Arg1,Arg1);
return (Type_Code(Arg1 == TC_CELL)) ? TRUTH : NIL;
}
/* (SET-CONTENTS! CELL VALUE)
- [Primitive number 0x8C]
Stores VALUE as contents of CELL. Returns (bad style to count
on this) the previous contents of CELL.
*/
Built_In_Primitive(Prim_Set_Cell_Contents, 2, "SET-CONTENTS!")
-{ Primitive_2_Args();
+{
+ Primitive_2_Args();
+
Arg_1_Type(TC_CELL);
Side_Effect_Impurify(Arg1, Arg2);
return Swap_Pointers(Nth_Vector_Loc(Arg1, CELL_CONTENTS), Arg2);
}
-\f
-/* Multiprocessor scheduling primitive */
-
-#ifndef butterfly
-#ifdef COMPILE_FUTURES
-Built_In_Primitive(Prim_Get_Work, 1, "GET-WORK")
-{ Pointer The_Queue, Queue_Head, Result;
- Primitive_1_Arg();
-
- The_Queue = Get_Fixed_Obj_Slot(The_Work_Queue);
- if (The_Queue != NIL) Queue_Head = Vector_Ref(The_Queue, CONS_CAR);
- if ((The_Queue==NIL) || (Queue_Head==NIL))
- if (Arg1 == NIL)
- { printf("\nNo work available, but some has been requested!\n");
- Microcode_Termination(TERM_EXIT);
- }
- else
- { Pop_Primitive_Frame(1);
- Will_Push(2*(STACK_ENV_EXTRA_SLOTS+1) + 1 + CONTINUATION_SIZE);
- Push(NIL); /* Upon return, no hope if there is no work */
- Push(Make_Non_Pointer(TC_PRIMITIVE, PC_GET_WORK));
- Push(STACK_FRAME_HEADER+1);
- Store_Expression(NIL);
- Store_Return(RC_INTERNAL_APPLY);
- Save_Cont();
- Push(Arg1);
- Push(STACK_FRAME_HEADER);
- Pushed();
- longjmp(*Back_To_Eval, PRIM_APPLY);
- }
- Result = Vector_Ref(Queue_Head, CONS_CAR);
- Queue_Head = Vector_Ref(Queue_Head, CONS_CDR);
- Vector_Set(The_Queue, CONS_CAR, Queue_Head);
- if (Queue_Head==NIL) Vector_Set(The_Queue, CONS_CDR, NIL);
- return Result;
-}
-#else /* #ifdef COMPILE_FUTURES */
-Built_In_Primitive(Prim_Get_Work, 1, "GET-WORK")
-{ Primitive_1_Arg();
- Primitive_Error(ERR_UNDEFINED_PRIMITIVE);
-}
-#endif /* #ifdef COMPILE_FUTURES */
-#endif /* #ifndef butterfly */
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/prims.h,v 9.20 1987/01/21 20:25:11 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prims.h,v 9.21 1987/04/03 00:18:49 jinx Exp $ */
/* This file contains some macros for defining primitives,
for argument type or value checking, and for accessing
#define Primitive_0_Args()
-#define Primitive_1_Args() fast Pointer Arg1 = Stack_Ref(0);\
- Primitive_0_Args()
+#define Primitive_1_Args() fast Pointer Arg1 = Stack_Ref(0)
-#define Primitive_2_Args() fast Pointer Arg2 = Stack_Ref(1);\
- Primitive_1_Args()
+#define Primitive_2_Args() Primitive_1_Args(); \
+ fast Pointer Arg2 = Stack_Ref(1)
-#define Primitive_3_Args() fast Pointer Arg3 = Stack_Ref(2);\
- Primitive_2_Args()
+#define Primitive_3_Args() Primitive_2_Args(); \
+ fast Pointer Arg3 = Stack_Ref(2)
-#define Primitive_4_Args() fast Pointer Arg4 = Stack_Ref(3);\
- Primitive_3_Args()
+#define Primitive_4_Args() Primitive_3_Args(); \
+ fast Pointer Arg4 = Stack_Ref(3)
-#define Primitive_5_Args() fast Pointer Arg5 = Stack_Ref(4);\
- Primitive_4_Args()
+#define Primitive_5_Args() Primitive_4_Args(); \
+ fast Pointer Arg5 = Stack_Ref(4)
-#define Primitive_6_Args() fast Pointer Arg6 = Stack_Ref(5);\
- Primitive_5_Args()
+#define Primitive_6_Args() Primitive_5_Args(); \
+ fast Pointer Arg6 = Stack_Ref(5)
-#define Primitive_7_Args() fast Pointer Arg7 = Stack_Ref(6);\
- Primitive_6_Args()
+#define Primitive_7_Args() Primitive_6_Args(); \
+ fast Pointer Arg7 = Stack_Ref(6)
#define Primitive_1_Arg() Primitive_1_Args()
\f
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/psbtobin.c,v 9.21 1987/01/22 14:13:43 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/psbtobin.c,v 9.22 1987/04/03 00:06:48 jinx Exp $
*
* This File contains the code to translate portable format binary
* files to internal format.
/* Align_Float(To); */
while (--N >= 0)
{ fscanf(Portable_File, "%2x %lx", &The_Type, &The_Datum);
- switch((The_Type) & SAFE_TYPE_MASK)
+ switch(The_Type)
{ case CONSTANT_CODE:
- if (The_Type > MAX_SAFE_TYPE)
- { *To = Constant_Table[The_Datum];
- Set_Danger_Bit(*To++);
- continue;
- }
*To++ = Constant_Table[The_Datum];
continue;
case HEAP_CODE:
- if (The_Type > MAX_SAFE_TYPE)
- { *To = Heap_Table[The_Datum];
- Set_Danger_Bit(*To++);
- continue;
- }
*To++ = Heap_Table[The_Datum];
continue;
*To++ = Make_Non_Pointer(The_Type, The_Datum);
continue;
+ case TC_REFERENCE_TRAP:
+ if (The_Datum <= TRAP_MAX_IMMEDIATE)
+ {
+ *To++ = Make_Non_Pointer(The_Type, The_Datum);
+ continue;
+ }
+ /* It is a pointer, fall through. */
default:
/* Should be stricter */
*To++ = Make_Pointer(The_Type, Relocate(The_Datum));
Read_Flags(Flags);
Size = (6 + /* SNMV */
+ HEAP_BUFFER_SPACE +
Heap_Count + Heap_Objects +
Constant_Count + Constant_Objects +
Pure_Count + Pure_Objects +
Program_Name, Size);
exit(1);
}
- return Size;
+ Heap += HEAP_BUFFER_SPACE;
+ Initial_Align_Float(Heap);
+ return (Size - HEAP_BUFFER_SPACE);
}
\f
do_it()
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/purify.c,v 9.24 1987/02/09 00:34:50 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purify.c,v 9.25 1987/04/03 00:19:30 jinx Exp $
*
* This file contains the code that copies objects into pure
* and constant space.
#define Indirect_BH(In_GC) \
if (Type_Code(*Old) == TC_BROKEN_HEART) continue;
-#define Transport_Indirect() \
+#define Transport_Vector_Indirect() \
Real_Transport_Vector(); \
*Get_Pointer(Temp) = New_Address
\f
\f
/* PurifyLoop, continued */
+ /*
+ Symbols, variables, and reference traps cannot be put into
+ pure space. The strings contained in the first two can, on the
+ other hand.
+ */
+
+ case TC_REFERENCE_TRAP:
+ if ((Datum(Temp) <= TRAP_MAX_IMMEDIATE) || (GC_Mode == PURE_COPY))
+ {
+ /* It is a non pointer. */
+ break;
+ }
+ goto purify_pair;
+
case TC_INTERNED_SYMBOL:
case TC_UNINTERNED_SYMBOL:
if (GC_Mode == PURE_COPY)
{ Temp = Vector_Ref(Temp, SYMBOL_NAME);
Purify_Pointer(Setup_Internal(false,
- Transport_Indirect(),
+ Transport_Vector_Indirect(),
Indirect_BH(false)));
}
/* Fall through */
case_Fasdump_Pair:
+ purify_pair:
Setup_Pointer_for_Purify(Transport_Pair());
case TC_WEAK_CONS:
Setup_Pointer_for_Purify(Transport_Weak_Cons());
-/* Because variables no longer contain pointers (except for the symbol),
- they are permitted into pure space now. */
-
case TC_VARIABLE:
- Setup_Pointer_for_Purify(Purify_Transport_Variable());
-
case_Triple:
Setup_Pointer_for_Purify(Transport_Triple());
\f
/* PurifyLoop, continued */
-#ifdef QUADRUPLE
case_Quadruple:
Setup_Pointer_for_Purify(Transport_Quadruple());
-#endif
/* No need to handle futures specially here, since PurifyLoop
is always invoked after running GCLoop, which will have
case TC_FUTURE:
case TC_ENVIRONMENT:
- if (GC_Mode == PURE_COPY) break;
+ if (GC_Mode == PURE_COPY)
+ {
+ /* This should actually do an indirect pair transport of
+ the procedure, at least.
+ */
+ break;
+ }
/* Fall through */
#ifndef FLOATING_ALIGNMENT
case TC_BIG_FLONUM:
}
\f
/* (PRIMITIVE-PURIFY OBJECT PURE?)
- [Primitive number 0xB4]
Copy an object from the heap into constant space. This requires
a spare heap, and is tricky to use -- it should only be used
through the wrapper provided in the Scheme runtime system.
multiprocessor, this primitive uses the master-gc-loop and it
should only be used as one would use master-gc-loop i.e. with
everyone else halted.
+
+ This primitive does not return normally. It always escapes into
+ the interpreter because some of its cached registers (eg. History)
+ have changed.
*/
Built_In_Primitive(Prim_Primitive_Purify, 2, "PRIMITIVE-PURIFY")
-{ long Saved_Zone;
- Pointer Object, Lost_Objects, Purify_Result;
-
+{
+ long Saved_Zone;
+ Pointer Object, Lost_Objects, Purify_Result, Daemon;
Primitive_2_Args();
+
Save_Time_Zone(Zone_Purify);
if ((Arg2 != TRUTH) && (Arg2 != NIL))
Primitive_Error(ERR_ARG_2_WRONG_TYPE);
Touch_In_Primitive(Arg1, Object);
Purify_Result = Purify(Object, Arg2);
- if (Get_Fixed_Obj_Slot(GC_Daemon) == NIL)
- return (Purify_Pass_2(Purify_Result));
Pop_Primitive_Frame(2);
+ Daemon = Get_Fixed_Obj_Slot(GC_Daemon);
+ if (Daemon == NIL)
+ {
+ Val = Purify_Pass_2(Purify_Result);
+ longjmp( *Back_To_Eval, PRIM_POP_RETURN);
+ /*NOTREACHED*/
+ }
Store_Expression(Purify_Result);
Store_Return(RC_PURIFY_GC_1);
Will_Push(CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
Save_Cont();
- Push(Get_Fixed_Obj_Slot(GC_Daemon));
+ Push(Daemon);
Push(STACK_FRAME_HEADER);
Pushed();
longjmp(*Back_To_Eval, 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/purutl.c,v 9.26 1987/02/09 00:37:58 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purutl.c,v 9.27 1987/04/03 00:19:50 jinx Exp $ */
/* Pure/Constant space utilities. */
}
\f
/* (IMPURIFY OBJECT)
- [Primitive number 0xBD]
*/
Built_In_Primitive(Prim_Impurify, 1, "IMPURIFY")
{ Pointer Result;
}
/* (PURE? OBJECT)
- [Primitive number 0xBB]
Returns #!TRUE if the object is pure (ie it doesn't point to any
other object, or it is in a pure section of the constant space).
*/
}
/* (CONSTANT? OBJECT)
- [Primitive number 0xBA]
Returns #!TRUE if the object is in constant space or isn't a
pointer.
*/
}
/* (GET-NEXT-CONSTANT)
- [Primitive number 0xE4]
Returns the next free address in constant space.
*/
Built_In_Primitive(Prim_Get_Next_Constant, 0, "GET-NEXT-CONSTANT")
Pointer *result;
dest = Free_Constant;
- if (!Test_Pure_Space_Top(dest+nobjects+6))
+ if (!Test_Pure_Space_Top(dest + nobjects + 6))
{ fprintf(stderr,
"copy_to_constant_space: Not enough constant space!\n");
Microcode_Termination(TERM_NO_SPACE);
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/scheme.h,v 9.21 1987/01/22 14:31:48 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/scheme.h,v 9.22 1987/04/03 00:20:06 jinx Exp $
*
* General declarations for the SCode interpreter. This
* file is INCLUDED by others and contains declarations only.
*/
\f
-/* "fast" is a register declaration if we aren't debugging code */
+/* Certain debuggers cannot really deal with variables in registers.
+ When debugging, NO_REGISTERS can be defined.
+*/
-#ifdef ENABLE_DEBUGGING_TOOLS
-#define Consistency_Check true
+#ifdef NO_REGISTERS
#define fast
#else
-#define Consistency_Check false
#define fast register
#endif
-#ifdef noquick
-#define quick
+#ifdef ENABLE_DEBUGGING_TOOLS
+#define Consistency_Check true
#else
-#define quick fast
+#define Consistency_Check false
#endif
#ifdef COMPILE_STEPPER
#define forward extern /* For forward references */
\f
+#include <setjmp.h>
+#include <stdio.h>
+
#include "config.h" /* Machine and OS configuration info */
-#include "bkpt.h" /* May shadow some defaults */
-#include "object.h" /* Scheme Object Representation */
-#include "scode.h" /* Scheme SCode Representation */
-#include "sdata.h" /* Scheme User Data Representation */
-#include "gc.h" /* Garbage Collector related macros */
-#include "history.h" /* History maintenance */
-#include "interpret.h" /* Macros for interpreter */
-#include "stack.h" /* Macros for stack (stacklet) manipulation */
-#include "futures.h" /* Support macros, etc. for FUTURE */
#include "types.h" /* Type code numbers */
+#include "const.h" /* Various named constants */
+#include "object.h" /* Scheme object representation */
+#include "gc.h" /* Garbage collector related macros */
+#include "scode.h" /* Scheme scode representation */
+#include "sdata.h" /* Scheme user data representation */
+#include "futures.h" /* Support macros, etc. for FUTURE */
#include "errors.h" /* Error code numbers */
#include "returns.h" /* Return code numbers */
-#include "const.h" /* Various named constants */
#include "fixobj.h" /* Format of fixed objects vector */
-#ifdef RENAME
-#include "rename.c" /* Rename of identifiers for some compilers */
-#endif
-#include <setjmp.h>
-#include <stdio.h>
+#include "stack.h" /* Macros for stack (stacklet) manipulation */
+#include "history.h" /* History maintenance */
+#include "interpret.h" /* Macros for interpreter */
#ifdef butterfly
#include "butterfly.h"
#endif
+#include "bkpt.h" /* Shadows some defaults */
#include "default.h" /* Defaults for various hooks. */
#include "extern.h" /* External declarations */
+#include "prim.h" /* Declarations for external primitives. */
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/scode.h,v 9.21 1987/01/22 14:31:54 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/scode.h,v 9.22 1987/04/03 00:20:19 jinx Rel $
*
* Format of the SCode representation of programs. Each of these
* is described in terms of the slots in the data structure.
/* COMBINATIONS come in several formats */
-/* Non-primitive combinations are vector-like: */
+/* General combinations are vector-like: */
#define COMB_VECTOR_HEADER 0
#define COMB_FN_SLOT 1
#define COMB_ARG_1_SLOT 2
#define COMMENT_EXPRESSION 0
#define COMMENT_TEXT 1
-/* COMPILED_CODE_ENTRY operation: */
-#define CCE_BYTE_ADDRESS 0
-
-/* CONDITIONAL operation (used for COND, IF, CONJUNCTION): */
+/* CONDITIONAL operation (used for COND, IF, AND): */
#define COND_PREDICATE 0
#define COND_CONSEQUENT 1
#define COND_ALTERNATIVE 2
#define DELAY_OBJECT 0
#define DELAY_UNUSED 1
-/* DISJUNCTION operation (formerly OR): */
+/* DISJUNCTION or OR operation: */
#define OR_PREDICATE 0
#define OR_ALTERNATIVE 1
+/* EXTENDED_LAMBDA operation:
+ * Support for optional parameters and auxiliary local variables. The
+ * Extended Lambda is similar to LAMBDA, except that it has an extra
+ * word called the ARG_COUNT. This contains an 8-bit count of the
+ * number of optional arguments, an 8-bit count of the number of
+ * required (formal) parameters, and a bit to indicate that additional
+ * (rest) arguments are allowed. The vector of argument names
+ * contains, of course, a size count which allows the calculation of
+ * the number of auxiliary variables required. Auxiliary variables
+ * are created for any internal DEFINEs which are found at syntax time
+ * in the body of a LAMBDA-like special form.
+ */
+
+#define ELAMBDA_SCODE 0
+#define ELAMBDA_NAMES 1
+#define ELAMBDA_ARG_COUNT 2
+
+/* Masks. The infomation on the number of each type of argument is
+ * separated at byte boundaries for easy extraction in the 68000 code.
+ */
+
+#define EL_OPTS_MASK 0xFF
+#define EL_FORMALS_MASK 0xFF00
+#define EL_REST_MASK 0x10000
+#define EL_FORMALS_SHIFT 8
+#define EL_REST_SHIFT 16
+
+/* Selectors */
+
+#define Get_Body_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_SCODE))
+#define Get_Names_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_NAMES))
+#define Get_Count_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_ARG_COUNT))
+#define Elambda_Formals_Count(Addr) \
+ ((((long) Addr) & EL_FORMALS_MASK) >> EL_FORMALS_SHIFT)
+#define Elambda_Opts_Count(Addr) \
+ (((long) Addr) & EL_OPTS_MASK)
+#define Elambda_Rest_Flag(Addr) \
+ ((((long) Addr) & EL_REST_MASK) >> EL_REST_SHIFT)
+\f
/* IN-PACKAGE operation: */
#define IN_PACKAGE_ENVIRONMENT 0
#define IN_PACKAGE_EXPRESSION 1
+/* LAMBDA operation:
+ * Object representing a LAMBDA expression with a fixed number of
+ * arguments. It consists of a list of the names of the arguments
+ * (the first is the name by which the procedure refers to itself) and
+ * the SCode for the procedure.
+ */
+
+#define LAMBDA_SCODE 0
+#define LAMBDA_FORMALS 1
+
+/* LEXPR
+ * Same as LAMBDA (q.v.) except additional arguments are permitted
+ * beyond those indicated in the LAMBDA_FORMALS list.
+ */
+
/* Primitive combinations with 0 arguments are not pointers */
/* Primitive combinations, 1 argument: */
#define SEQUENCE_1 0
#define SEQUENCE_2 1
#define SEQUENCE_3 2
+\f
+/* VARIABLE operation.
+ * Corresponds to a variable lookup or variable reference. Contains the
+ * symbol referenced, and (if it has been compiled) the frame and
+ * offset in the frame in which it was found. One of these cells is
+ * multiplexed by having its type code indicate one of several modes
+ * of reference: not yet compiled, local reference, formal reference,
+ * auxiliary reference, or global value reference.
+ * There are extra definitions in lookup.h.
+ */
+#define VARIABLE_SYMBOL 0
+#define VARIABLE_FRAME_NO 1
+#define VARIABLE_OFFSET 2
+#define VARIABLE_COMPILED_TYPE 1
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/sdata.h,v 9.21 1987/01/22 14:32:00 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/sdata.h,v 9.22 1987/04/03 00:20:33 jinx Exp $
*
* Description of the user data objects. This should parallel the
* file SDATA.SCM in the runtime system.
#define THUNK_VALUE 1
#define THUNK_ENVIRONMENT 0
#define THUNK_PROCEDURE 1
-\f
+
/* ENVIRONMENT
- * Associates identifiers with values. The identifiers are either from
- * a lambda-binding (as in a procedure call) or a run-time DEFINE (known
- * as an 'auxilliary' binding). The environment contains three things:
- * the list of identifiers which must be marked DANGEROUS if they are
- * created in this environment (the 'potentially dangerous' list); the
- * A-list associating auxilliary variables with their values; and the
- * values of lambda-bound variables. The names of the lambda-bound
- * variables are found by looking at the PROCEDURE which is stored in
- * the first formal value slot. This will contain a LEXPR or LAMBDA
- * object, which contains a list of names associated with the slots in
- * the environment. Notice that the FINGER used in the process of
- * constructing an environment frame is stored in the same place where
- * the potentially dangerous variables will eventually go.
- *
- * There are actually 3 data structures which are used at distinct
- * times to store an environment. A HEAP_ENVIRONMENT is the format
- * used by the interpreter for a completely formed environment in
- * which variable lookups will occur. A STACK_COMBINATION is the
- * structure built on the stack to evaluate normal (long)
- * combinations. It contains a slot for the finger and the
- * combination whose operands are being evaluated. Only some of the
- * argument slots in a stack-combination are meaningful: those which
- * have already been evaluated (those not "hidden" by the finger).
- * Finally, a STACK_ENVIRONMENT is the format used at Internal_Apply
- * just as an application is about to occur. This does NOT have slots
- * for auxilliary variables or the potentially dangerous list, since
- * primitives, compiled code, and control points don't need these
- * slots.
+ * Associates identifiers with values.
+ * The identifiers are either from a lambda-binding (as in a procedure
+ * call) or a incremental (run-time) DEFINE (known as an 'auxilliary'
+ * binding).
+ * When an environment frame is created, it only contains lambda
+ * bindings. If incremental defines are performed in it or its
+ * children, it acquires an extension which contains a list of the
+ * auxiliary bindings. Some of these bindings are fictitious in that
+ * their only purpose is to make the real bindings (if and when they
+ * occur) become automatically dangerous. Bindings become dangerous
+ * when they are shadowed by incremental bindings in children frames.
+ * Besides the lambda bindings, an environment frame contains a
+ * pointer to the procedure which created it. It is through this
+ * procedure that the parent frame is found.
*
- * The "life cycle" of an environment is: (a) it is born on the stack
- * during the evaluation of a COMBINATION as a STACK_COMBINATION; (b)
- * when all of the operands and the operator have been evaluated and
- * stored into this frame, the finger is removed and the function
- * is stored ... the result is a STACK_ENVIRONMENT; (c) finally, if
- * the operator is an interpreted procedure, the frame has is copied
- * onto the heap as a HEAP_ENVIRONMENT (i.e. by adding the two missing
- * slots). For the optimized combinations (COMBINATION-1, 2, 3 and
- * PCOMB0, 1, 2, 3), the STACK_ENVIRONMENT is used directly, without
- * ever creating a STACK_COMBINATION.
+ * An environment frame has three distinct stages in its formation:
+ * - A STACK_COMBINATION is the structure built on the stack to
+ * evaluate normal (long) combinations. It contains a slot for the
+ * finger and the combination whose operands are being evaluated.
+ * Only some of the argument slots in a stack-combination are
+ * meaningful: those which have already been evaluated (those not
+ * "hidden" by the finger). This is the first stage.
+ * - A STACK_ENVIRONMENT is the format used at Internal_Apply
+ * just as an application is about to occur.
+ * - An ENVIRONMENT is a real environment frame, containing
+ * associations between names and values. It is the final stage, and
+ * corresponds to the structure described above.
*/
\f
-/* ENVIRONMENT, continued */
-
-#define HEAP_ENV_EXTRA_SLOTS 3
- /* Slots over and above those used to store
- function (procedure) and its arguments in
- a HEAP environment */
-
-#define HEAP_ENV_HEADER 0
-#define HEAP_ENV_AUX_SLOT 1
-#define HEAP_ENV_P_DANGER 2
-#define HEAP_ENV_FUNCTION 3
-#define HEAP_ENV_FIRST_ARG 4
+#define ENVIRONMENT_HEADER 0
+#define ENVIRONMENT_FUNCTION 1
+#define ENVIRONMENT_FIRST_ARG 2
#define STACK_ENV_EXTRA_SLOTS 1
#define STACK_ENV_HEADER 0
#define GO_TO_GLOBAL 0
#define END_OF_CHAIN 1
-/* EXTENDED_FIXNUM
- * Not used in the C version. On the 68000 this is used for 24-bit
- * integers, while FIXNUM is used for 16-bit integers.
- */
-\f
-/* EXTENDED_LAMBDA
- * Support for optional parameters and auxiliary local variables. The
- * Extended Lambda is similar to LAMBDA, except that it has an extra
- * word called the ARG_COUNT. This contains an 8-bit count of the
- * number of optional arguments, an 8-bit count of the number of
- * required (formal) parameters, and a bit to indicate that additional
- * (rest) arguments are allowed. The vector of argument names
- * contains, of course, a size count which allows the calculation of
- * the number of auxiliary variables required. Auxiliary variables
- * are created for any internal DEFINEs which are found at syntax time
- * in the body of a LAMBDA-like special form.
- */
+/* Environment extension objects:
-#define ELAMBDA_SCODE 0
-#define ELAMBDA_NAMES 1
-#define ELAMBDA_ARG_COUNT 2
+ These objects replace the procedure in environment frames when an
+ aux slot is desired. The parent frame is copied into the extension
+ so that the "compiled" lookup code does not have to check whether
+ the frame has been extended or not.
-/* Masks. The infomation on the number of each type of argument is
- * separated at byte boundaries for easy extraction in the 68000 code.
+ Note that for the code to work, ENVIRONMENT_EXTENSION_PARENT_FRAME
+ must be equal to PROCEDURE_ENVIRONMENT.
+
+ The following constants are implicitely hard-coded in lookup.c,
+ where a new extension object is consed in extend_frame.
*/
-#define EL_OPTS_MASK 0xFF
-#define EL_FORMALS_MASK 0xFF00
-#define EL_REST_MASK 0x10000
-#define EL_FORMALS_SHIFT 8
-#define EL_REST_SHIFT 16
+#define ENVIRONMENT_EXTENSION_HEADER 0
+#define ENVIRONMENT_EXTENSION_PARENT_FRAME 1
+#define ENVIRONMENT_EXTENSION_PROCEDURE 2
+#define ENVIRONMENT_EXTENSION_COUNT 3
+#define ENVIRONMENT_EXTENSION_MIN_SIZE 4
+\f
+/* EXTENDED_FIXNUM
+ * Not used in the C version. On the 68000 this is used for 24-bit
+ * integers, while FIXNUM is used for 16-bit integers.
+ */
/* EXTENDED_PROCEDURE
- * Counterpart to EXTENDED_LAMBDA. Same format as PROCEDURE.
+ * Type of procedure created by evaluation of EXTENDED_LAMBDA.
+ * It's fields are the same as those for PROCEDURE.
*/
/* FALSE
#define HUNK_CXR0 0
#define HUNK_CXR1 1
#define HUNK_CXR2 2
-\f
+
/* INTERNED_SYMBOL
- * A symbol, such as the result of evaluating (QUOTE A). Some important
- * properties of symbols are that they have a print name, and may be
- * 'interned' so that all instances of a symbol with the same name share
- * a unique object. The storage pointed to by a symbol includes both
- * the print name (a string) and the value associated with a variable of
- * that name in the global environment. In looking for the value of a
- * variable in the global environment, the dangerous and potentially
- * dangerous bits are stored in the dangerous bits of these two cells as
- * indicated below.
+ * A symbol, such as the result of evaluating (QUOTE A). Some
+ * important properties of symbols are that they have a print name,
+ * and may be 'interned' so that all instances of a symbol with the
+ * same name share a unique object. The storage pointed to by a
+ * symbol includes both the print name (a string) and the value cell
+ * associated with a variable of that name in the global environment.
*/
#define SYMBOL_NAME 0
#define SYMBOL_GLOBAL_VALUE 1
-#define GLOBAL_P_DANGER 0
-#define GLOBAL_DANGER 1
-
-/* LAMBDA
- * Object representing a LAMBDA expression with a fixed number of
- * arguments. It consists of a list of the names of the arguments
- * (the first is the name by which the procedure refers to itself) and
- * the SCode for the procedure.
- */
-
-#define LAMBDA_SCODE 0
-#define LAMBDA_FORMALS 1
-
-/* LEXPR
- * Same as LAMBDA (q.v.) except additional arguments are permitted
- * beyond those indicated in the LAMBDA_FORMALS list.
- */
/* LIST
* Ordinary CONS cell as supplied to a user. Perhaps this data type is
#define PROCEDURE_LAMBDA_EXPR 0
#define PROCEDURE_ENVIRONMENT 1
\f
+/* REFERENCE_TRAP
+ * Causes the variable lookup code to trap.
+ * Used to implement a variety of features.
+ * This type code is really the collection of two, done this way for efficiency.
+ * Traps whose datum is less than TRAP_MAX_IMMEDIATE are immediate (not pointers).
+ * The rest are pairs. The garbage collector deals with them specially.
+ */
+
+#define TRAP_TAG 0
+#define TRAP_EXTRA 1
+
/* RETURN_CODE
* Represents an address where computation is to continue. These can be
* thought of as states in a finite state machine, labels in an assembly
#define TRANSLATE_TO_POINT 2
#define TRANSLATE_TO_DISTANCE 3
\f
-/* TRAP
- * Trap-on-reference object. Used as a placeholder for a variable's value
- * when special action must be taken at lookup time. Used to implement
- * fluid variables, active values, etc.
- */
-
-#define TRAP_TAG 0 /* NIL => fluid variable
- else handler procedure */
-#define TRAP_DEFAULT 1 /* Default value of this slot */
-#define TRAP_FROB 2 /* For user supplied handlers */
-#define TRAP_SIZE 3
-
/* TRUE
* The initial binding of the variable T is to an object of this type.
* This type is the beginnings of a possible move toward a system where
* predicates check for TRUE / FALSE rather than not-NULL / NULL.
*/
-/* UNASSIGNED
- * There are two objects made with a data type of UNASSIGNED. The first
- * (called the "unassigned object") is a value stored in an environment
- * to indicate that a variable is lambda-bound in that environment but
- * does not yet have an initial value. The second (called the "unbound
- * object") is stored in the global value slot of a value when it is
- * created, and will therefore be returned when a variable is referenced
- * in an environment where there are no bindings for it. The numbers
- * here show the data parts corresponding to the two interpretations.
- */
-
-#define UNASSIGNED 0
-#define UNBOUND 1
-
/* UNINTERNED_SYMBOL
* This indicates that the object is in the format of an INTERNED_SYMBOL
* but is not interned.
*/
-\f
-/* VARIABLE
- * Variable reference. Contains the symbol referenced, and (if it has
- * been compiled) the frame and offset in the frame in which it was
- * found. One of these cells is multiplexed by having its type code
- * indicate one of four modes of reference: not yet compiled, local
- * (formal) reference, auxiliary reference, or global value reference
- */
-#define VARIABLE_SYMBOL 0
-#define VARIABLE_FRAME_NO 1
-#define VARIABLE_OFFSET 2
-#define VARIABLE_COMPILED_TYPE 1
/* VECTOR
* A group of contiguous cells with a header (of type MANIFEST_VECTOR)
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/storage.c,v 9.26 1987/03/12 17:45:52 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/storage.c,v 9.27 1987/04/03 00:20:53 jinx Exp $
This file defines the storage for global variables for
the Scheme Interpreter. */
/*************/
Pointer
- Env, /* The environment */
- Val, /* The value returned from primitives or apply */
- Return, /* The return address code */
- Expression, /* Expression to EVALuate */
- *History, /* History register */
+ *Ext_History, /* History register */
*Free, /* Next free word in storage */
*MemTop, /* Top of free space available */
- *Stack_Pointer, /* Next available slot in control stack */
+ *Ext_Stack_Pointer, /* Next available slot in control stack */
*Stack_Top, /* Top of control stack */
*Stack_Guard, /* Guard area at end of stack */
*Free_Stacklets, /* Free list of stacklets */
*Constant_Space, /* Bottom of constant+pure space */
*Free_Constant, /* Next free cell in constant+pure area */
- *Unused_Heap_Top, *Unused_Heap,
- /* Top and bottom of 'other' heap for GC */
- *Heap_Top, *Heap_Bottom, /* Top and bottom of current heap area */
+ *Heap_Top, /* Top of current heap */
+ *Heap_Bottom, /* Bottom of current heap */
+ *Unused_Heap_Top, /* Top of other heap */
+ *Unused_Heap, /* Bottom of other heap */
*Local_Heap_Base, /* Per-processor CONSing area */
*Heap, /* Bottom of entire heap */
- Swap_Temp, /* Used by Swap_Pointers in default.h */
- Lookup_Base, /* Slot lookup returns result here */
- Fluid_Bindings=NIL, /* Fluid bindings AList */
- Current_State_Point=NIL, /* Used by dynamic winder */
- return_to_interpreter, /* Return address/code left by interpreter
- when calling compiled code */
- *last_return_code; /* Address of the most recent return code in the stack.
+ Current_State_Point = NIL, /* Used by dynamic winder */
+ Fluid_Bindings = NIL, /* Fluid bindings AList */
+ return_to_interpreter, /* Return address/code left by interpreter
+ when calling compiled code */
+ *last_return_code, /* Address of the most recent return code in the stack.
This is only meaningful while in compiled code.
*** This must be changed when stacklets are used. ***
*/
+ Swap_Temp; /* Used by Swap_Pointers in default.h */
\f
long IntCode, /* Interrupts requesting */
IntEnb, /* Interrupts enabled */
/* 081 */ (char) 2, /* GREATER-THAN-FIXNUM? */
/* 082 */ (char) 2, /* GREATER-THAN-BIGNUM? */
/* 083 */ (char) 1, /* STRING-HASH */
-/* 084 */ (char) 3, /* Sys-PAIR-CONS */
-/* 085 */ (char) 1, /* Sys-PAIR? */
-/* 086 */ (char) 1, /* Sys-PAIR-CAR */
-/* 087 */ (char) 1, /* Sys-PAIR-CDR */
-/* 088 */ (char) 2, /* Sys-PAIR-SET!-CAR */
-/* 089 */ (char) 2, /* Sys-PAIR-SET!-CDR */
+/* 084 */ (char) 3, /* SYS-PAIR-CONS */
+/* 085 */ (char) 1, /* SYS-PAIR? */
+/* 086 */ (char) 1, /* SYS-PAIR-CAR */
+/* 087 */ (char) 1, /* SYS-PAIR-CDR */
+/* 088 */ (char) 2, /* SYS-PAIR-SET!-CAR */
+/* 089 */ (char) 2, /* SYS-PAIR-SET!-CDR */
/* 08A */ (char) 0, /* unused */
/* 08B */ (char) 0, /* unused */
/* 08C */ (char) 2, /* SET-CONTENTS! */
/* 08D */ (char) 2, /* &MAKE-OBJECT */
-/* 08E */ (char) 1, /* Sys-HUNK3-CXR0 */
-/* 08F */ (char) 2, /* Sys-HUNK3-SET!-CXR0 */
+/* 08E */ (char) 1, /* SYSTEM-HUNK3-CXR0 */
+/* 08F */ (char) 2, /* SYSTEM-HUNK3-SET!-CXR0 */
/* 090 */ (char) 2, /* MAP-MACHINE-ADDRESS-TO-CODE */
-/* 091 */ (char) 1, /* Sys-HUNK3-CXR1 */
-/* 092 */ (char) 2, /* Sys-HUNK3-SET!-CXR1 */
+/* 091 */ (char) 1, /* SYSTEM-HUNK3-CXR1 */
+/* 092 */ (char) 2, /* SYSTEM-HUNK3-SET!-CXR1 */
/* 093 */ (char) 2, /* MAP-CODE-TO-MACHINE-ADDRESS */
-/* 094 */ (char) 1, /* Sys-HUNK3-CXR2 */
-/* 095 */ (char) 2, /* Sys-HUNK3-SET!-CXR2 */
+/* 094 */ (char) 1, /* SYSTEM-HUNK3-CXR2 */
+/* 095 */ (char) 2, /* SYSTEM-HUNK3-SET!-CXR2 */
/* 096 */ (char) 1, /* MAP-PRIMITIVE-ADDRESS-TO-ARITY */
-/* 097 */ (char) 2, /* Sys-LIST-TO-VECTOR */
-/* 098 */ (char) 3, /* Sys-SUBVECTOR-TO-LIST */
-/* 099 */ (char) 1, /* Sys-VECTOR? */
-/* 09A */ (char) 2, /* Sys-VECTOR-REF */
-/* 09B */ (char) 3, /* Sys-VECTOR-SET! */
+/* 097 */ (char) 2, /* SYSTEM-LIST->VECTOR */
+/* 098 */ (char) 3, /* SYSTEM-SUBVECTOR->LIST */
+/* 099 */ (char) 1, /* SYSTEM-VECTOR? */
+/* 09A */ (char) 2, /* SYSTEM-VECTOR-REF */
+/* 09B */ (char) 3, /* SYSTEM-VECTOR-SET! */
/* 09C */ (char) 1, /* WITH-HISTORY-DISABLED */
/* 09D */ (char) 0, /* unused */
/* 09E */ (char) 0, /* unused */
/* 192 */ (char) 0, /* RE-MATCH */
/* 193 */ (char) 0, /* RE-SEARCH-FORWARD */
/* 194 */ (char) 0, /* RE-SEARCH-BACKWARD */
-/* 195 */ (char) 0, /* SYS-MEMORY-REF */
-/* 196 */ (char) 0, /* SYS-MEMORY-SET */
+/* 195 */ (char) 2, /* SYS-MEMORY-REF */
+/* 196 */ (char) 3, /* SYS-MEMORY-SET! */
/* 197 */ (char) 2, /* BIT-STRING-FILL-X */
/* 198 */ (char) 2, /* BIT-STRING-MOVE-X */
/* 199 */ (char) 2, /* BIT-STRING-MOVEC-X */
Prim_Sys_Set_Cdr(), Prim_Sys_Subvector_To_List(),
Prim_Sys_Vector(), Prim_Sys_Vector_Ref(),
Prim_Sys_Vec_Set(), Prim_Sys_Vec_Size(),
- Prim_System_Clock(), Prim_Temp_Printer(),
+ Prim_System_Clock(),
+ Prim_System_Memory_Ref(), Prim_System_Memory_Set(),
+ Prim_Temp_Printer(),
Prim_Translate_File(), Prim_Translate_To_Point(),
Prim_Truncate(), Prim_Truncate_Flonum(), Prim_Truncate_String(),
Prim_Unassigned_Test(), Prim_Unbound_Test(),
Prim_Tty_Write_Byte(),
Prim_File_Read_Byte(),
Prim_File_Write_Byte(),
-#if 0
+#if false
Prim_And_Gcd(),
Prim_Save_Screen(),
Prim_Restore_Screen(),
Prim_Char_To_Syntax_Code(),
Prim_Quoted_Char_P(),
Prim_Microcode_Tables_Filename(),
-#if 0
- Prim_Find_Pascal_Program(),
- Prim_Execute_Pascal_Program(),
- Prim_Graphics_Move(),
- Prim_Graphics_Line(),
- Prim_Graphics_Pixel(),
- Prim_Graphics_Set_Drawing_Mode(),
- Prim_Alpha_Raster_P(),
- Prim_Toggle_Alpha_Raster(),
- Prim_Graphics_Raster_P(),
- Prim_Toggle_Graphics_Raster(),
- Prim_Graphics_Clear(),
- Prim_Graphics_Set_Line_Style(),
-#endif
Prim_Error_Procedure(),
Prim_Volume_Exists_P(),
Prim_Re_Char_Set_Adjoin(),
Prim_Re_Match(),
Prim_Re_Search_Forward(),
Prim_Re_Search_Backward(),
- Prim_Sys_Memory_Ref(),
- Prim_Sys_Memory_Set(),
/* new directory access primitives */
Prim_working_directory_pathname(),
/* 192 */ Prim_Re_Match,
/* 193 */ Prim_Re_Search_Forward,
/* 194 */ Prim_Re_Search_Backward,
-/* 195 */ Prim_Sys_Memory_Ref,
-/* 196 */ Prim_Sys_Memory_Set,
+/* 195 */ Prim_System_Memory_Ref,
+/* 196 */ Prim_System_Memory_Set,
/* 197 */ Prim_bit_string_fill_x,
/* 198 */ Prim_bit_string_move_x,
/* 199 */ Prim_bit_string_movec_x,
/* 0x05 in hooks */ "APPLY",
/* 0x06 in hooks */ "SET-INTERRUPT-ENABLES!",
/* 0x07 in fasload */ "STRING->SYMBOL",
-/* 0x08 in prim */ "GET-WORK",
+/* 0x08 in random */ "GET-WORK",
/* 0x09 in hooks */ "NON-REENTRANT-CALL-WITH-CURRENT-CONTINUATION",
/* 0x0A in hooks */ "CURRENT-DYNAMIC-STATE",
/* 0x0B in hooks */ "SET-CURRENT-DYNAMIC-STATE!",
/* 0x16 in sysprim */ "EXIT",
/* 0x17 in character */ "CHAR-CODE",
/* 0x18 in lookup */ "LEXICAL-UNASSIGNED?",
-/* 0x19 in prim */ "INSERT-NON-MARKED-VECTOR!",
+/* 0x19 in random */ "INSERT-NON-MARKED-VECTOR!",
/* 0x1A in sysprim */ "HALT",
/* 0x1B in character */ "CHAR->INTEGER",
/* 0x1C in list */ "MEMQ",
/* 0x2E in vector */ "VECTOR-REF",
/* 0x2F in hooks */ "SET-CURRENT-HISTORY!",
/* 0x30 in vector */ "VECTOR-SET!",
-/* 0x31 in prim */ "NON-MARKED-VECTOR-CONS",
+/* 0x31 in random */ "NON-MARKED-VECTOR-CONS",
/* 0x32 not here */ No_Name,
/* 0x33 in lookup */ "LEXICAL-UNBOUND?",
/* 0x34 in character */ "INTEGER->CHAR",
/* 0x8D in prim */ "&MAKE-OBJECT",
/* 0x8E in hunk */ "SYSTEM-HUNK3-CXR0",
/* 0x8F in hunk */ "SYSTEM-HUNK3-SET-CXR0!",
-/* 0x90 in prim */ "MAP-MACHINE-ADDRESS-TO-CODE",
+/* 0x90 in random */ "MAP-MACHINE-ADDRESS-TO-CODE",
/* 0x91 in hunk */ "SYSTEM-HUNK3-CXR1",
/* 0x92 in hunk */ "SYSTEM-HUNK3-SET-CXR1!",
-/* 0x93 in prim */ "MAP-CODE-TO-MACHINE-ADDRESS",
+/* 0x93 in random */ "MAP-CODE-TO-MACHINE-ADDRESS",
/* 0x94 in hunk */ "SYSTEM-HUNK3-CXR2",
/* 0x95 in hunk */ "SYSTEM-HUNK3-SET-CXR2!",
-/* 0x96 in prim */ "PRIMITIVE-PROCEDURE-ARITY",
+/* 0x96 in random */ "PRIMITIVE-PROCEDURE-ARITY",
/* 0x97 in vector */ "SYSTEM-LIST-TO-VECTOR",
/* 0x98 in vector */ "SYSTEM-SUBVECTOR-TO-LIST",
/* 0x99 in vector */ "SYSTEM-VECTOR?",
/* 0xCA in step */ "PRIMITIVE-EVAL-STEP",
/* 0xCB in step */ "PRIMITIVE-APPLY-STEP",
/* 0xCC in step */ "PRIMITIVE-RETURN-STEP",
-/* 0xCD in console */ "TTY-READ-CHAR-READY?",
-/* 0xCE in console */ "TTY-READ-CHAR",
-/* 0xCF in console */ "TTY-READ-CHAR-IMMEDIATE",
-/* 0xD0 in console */ "TTY-READ-FINISH",
+/* 0xCD in ttyio */ "TTY-READ-CHAR-READY?",
+/* 0xCE in ttyio */ "TTY-READ-CHAR",
+/* 0xCF in ttyio */ "TTY-READ-CHAR-IMMEDIATE",
+/* 0xD0 in ttyio */ "TTY-READ-FINISH",
/* 0xD1 in bitstr */ "BIT-STRING-ALLOCATE",
/* 0xD2 in bitstr */ "MAKE-BIT-STRING",
/* 0xD3 in bitstr */ "BIT-STRING?",
/* 0xFA in generic */ "SIN",
/* 0xFB in generic */ "COS",
/* 0xFC in generic */ "&ATAN",
-/* 0xFD in console */ "TTY-WRITE-CHAR",
-/* 0xFE in console */ "TTY-WRITE-STRING",
-/* 0xFF in console */ "TTY-BEEP",
-/* 0x100 in console */ "TTY-CLEAR",
+/* 0xFD in ttyio */ "TTY-WRITE-CHAR",
+/* 0xFE in ttyio */ "TTY-WRITE-STRING",
+/* 0xFF in ttyio */ "TTY-BEEP",
+/* 0x100 in ttyio */ "TTY-CLEAR",
/* 0x101 in extern */ "GET-EXTERNAL-COUNTS",
/* 0x102 in extern */ "GET-EXTERNAL-NAME",
/* 0x103 in extern */ "GET-EXTERNAL-NUMBER",
/* 0x192 in nihil */ "RE-MATCH",
/* 0x193 in nihil */ "RE-SEARCH-FORWARD",
/* 0x194 in nihil */ "RE-SEARCH-BACKWARD",
-/* 0x195 in nihil */ "SYSTEM-MEMORY-REF",
-/* 0x196 in nihil */ "SYSTEM-MEMORY-SET!",
+/* 0x195 in prim */ "SYSTEM-MEMORY-REF",
+/* 0x196 in prim */ "SYSTEM-MEMORY-SET!",
/* 0x197 in bitstr */ "BIT-STRING-FILL!",
/* 0x198 in bitstr */ "BIT-STRING-MOVE!",
/* 0x199 in bitstr */ "BIT-STRING-MOVEC!",
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/types.h,v 9.21 1987/01/22 14:34:14 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/types.h,v 9.22 1987/04/03 00:21:38 jinx Exp $
*
* Type code definitions, numerical order
*
*/
\f
#define TC_NULL 0x00
-#define TC_FALSE 0x00
-#define TC_MANIFEST_VECTOR 0x00
-#define GLOBAL_ENV 0x00
-
#define TC_LIST 0x01
#define TC_CHARACTER 0x02
#define TC_SCODE_QUOTE 0x03
-#define TC_PCOMB2 0x04 /* Was 0x44 */
+#define TC_PCOMB2 0x04
#define TC_UNINTERNED_SYMBOL 0x05
#define TC_BIG_FLONUM 0x06
#define TC_COMBINATION_1 0x07
#define TC_TRUE 0x08
#define TC_EXTENDED_PROCEDURE 0x09
-#define TC_VECTOR 0x0A /* Was 0x46 */
-#define TC_RETURN_CODE 0x0B /* Was 0x48 */
+#define TC_VECTOR 0x0A
+#define TC_RETURN_CODE 0x0B
#define TC_COMBINATION_2 0x0C
-#define TC_COMPILED_PROCEDURE 0x0D /* Was 0x49 */
+#define TC_COMPILED_PROCEDURE 0x0D
#define TC_BIG_FIXNUM 0x0E
#define TC_PROCEDURE 0x0F
#define TC_PRIMITIVE_EXTERNAL 0x10
#define TC_DELAY 0x11
-#define TC_ENVIRONMENT 0x12 /* Was 0x4E */
+#define TC_ENVIRONMENT 0x12
#define TC_DELAYED 0x13
#define TC_EXTENDED_LAMBDA 0x14
#define TC_COMMENT 0x15
#define TC_PRIMITIVE 0x18
#define TC_SEQUENCE_2 0x19
\f
-#define TC_FIXNUM 0x1A /* Was 0x50 */
-#define TC_ADDRESS 0x1A
- /* Notice that TC_FIXNUM and TC_ADDRESS are the same */
+#define TC_FIXNUM 0x1A
#define TC_PCOMB1 0x1B
-#define TC_CONTROL_POINT 0x1C /* Was 0x56 */
+#define TC_CONTROL_POINT 0x1C
#define TC_INTERNED_SYMBOL 0x1D
#define TC_CHARACTER_STRING 0x1E
-#define TC_VECTOR_8B 0x1E
- /* VECTOR_8B and STRING are the same */
#define TC_ACCESS 0x1F
-#define TC_EXTENDED_FIXNUM 0x20 /* Not used */
+/* UNUSED 0x20 */ /* Used to be EXTENDED_FIXNUM. */
#define TC_DEFINITION 0x21
-#define TC_BROKEN_HEART 0x22 /* Was 0x58 */
+#define TC_BROKEN_HEART 0x22
#define TC_ASSIGNMENT 0x23
#define TC_HUNK3 0x24
#define TC_IN_PACKAGE 0x25
-#define TC_COMBINATION 0x26 /* Was 0x5E */
-#define TC_MANIFEST_NM_VECTOR 0x27 /* Was 0x60 */
+#define TC_COMBINATION 0x26
+#define TC_MANIFEST_NM_VECTOR 0x27
#define TC_COMPILED_EXPRESSION 0x28
#define TC_LEXPR 0x29
-#define TC_PCOMB3 0x2A /* Was 0x66 */
-#define TC_MANIFEST_SPECIAL_NM_VECTOR 0x2B /* Was 0x68 */
+#define TC_PCOMB3 0x2A
+#define TC_MANIFEST_SPECIAL_NM_VECTOR 0x2B
#define TC_VARIABLE 0x2C
-#define TC_THE_ENVIRONMENT 0x2D /* Was 0x70 */
+#define TC_THE_ENVIRONMENT 0x2D
#define TC_FUTURE 0x2E
-#define TC_VECTOR_1B 0x2F /* Was 0x76 */
-#define TC_BIT_STRING 0x2F /* Was 0x76 */
- /* Notice TC_VECTOR_1B and TC_BIT_STRING are the same */
-#define TC_PCOMB0 0x30 /* Was 0x78 */
-#define TC_VECTOR_16B 0x31 /* Was 0x7E */
-#define TC_UNASSIGNED 0x32 /* Was 0x38 */
-#define TC_SEQUENCE_3 0x33 /* Was 0x3C */
+#define TC_VECTOR_1B 0x2F
+#define TC_PCOMB0 0x30
+#define TC_VECTOR_16B 0x31
+#define TC_REFERENCE_TRAP 0x32 /* Used to be UNASSIGNED. */
+#define TC_SEQUENCE_3 0x33
#define TC_CONDITIONAL 0x34
#define TC_DISJUNCTION 0x35
#define TC_CELL 0x36
#define TC_WEAK_CONS 0x37
-#define TC_TRAP 0x38
+#define TC_QUAD 0x38 /* Used to be TC_TRAP. */
#define TC_RETURN_ADDRESS 0x39
#define TC_COMPILER_LINK 0x3A
#define TC_STACK_ENVIRONMENT 0x3B
#define TC_COMPLEX 0x3C
-#if defined(MC68020)
-
-#define TC_PEA_INSTRUCTION 0x48
-#define TC_JMP_INSTRUCTION 0x4E
-#define TC_DBF_INSTRUCTION 0x51
+/* If you add a new type, don't forget to update gccode.h and gctype.c */
-#endif
+/* Aliases */
-/* If you add a new type, don't forget to update gccode.h and gctype.c */
+#define TC_FALSE TC_NULL
+#define TC_MANIFEST_VECTOR TC_NULL
+#define GLOBAL_ENV TC_NULL
+#define TC_BIT_STRING TC_VECTOR_1B
+#define TC_VECTOR_8B TC_CHARACTER_STRING
+#define TC_ADDRESS TC_FIXNUM
;;;; Machine Dependent Type Tables
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.23 1987/03/12 17:48:32 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.24 1987/04/03 00:22:18 jinx Exp $
(declare (usual-integrations))
INTERNED-SYMBOL ;1D
(STRING CHARACTER-STRING VECTOR-8B) ;1E
ACCESS ;1F
- EXTENDED-FIXNUM ;20
+ #F ;20
DEFINITION ;21
BROKEN-HEART ;22
ASSIGNMENT ;23
VECTOR-1B ;2F
PRIMITIVE-COMBINATION-0 ;30
VECTOR-16B ;31
- UNASSIGNED ;32
+ (REFERENCE-TRAP UNASSIGNED) ;32
SEQUENCE-3 ;33
CONDITIONAL ;34
DISJUNCTION ;35
CELL ;36
WEAK-CONS ;37
- TRAP ;38
+ QUAD ;38
COMPILER-RETURN-ADDRESS ;39
COMPILER-LINK ;3A
STACK-ENVIRONMENT ;3B
#F ;45
#F ;46
#F ;47
- #F ;48 reserved for PEA instruction on 68000
+ #F ;48
#F ;49
#F ;4A
#F ;4B
#F ;4C
#F ;4D
- #F ;4E reserved for JMP/JSR instruction on 68000
+ #F ;4E
#F ;4F
#F ;50
- #F ;51 reserved for DBF instruction on 68000
+ #F ;51
#F ;52
#F ;53
#F ;54
#F ;7F
))
\f
-;;; [] Return
+;;; [] Returns
(vector-set! (get-fixed-objects-vector)
5 ;(fixed-objects-vector-slot 'MICROCODE-RETURNS-VECTOR)
RE-MATCH ;$192
RE-SEARCH-FORWARD ;$193
RE-SEARCH-BACKWARD ;$194
- SYSTEM-MEMORY-REF ;$195
- SYSTEM-MEMORY-SET! ;$196
+ (SYSTEM-MEMORY-REF &OBJECT-REF) ;$195
+ (SYSTEM-MEMORY-SET! &OBJECT-SET!) ;$196
BIT-STRING-FILL! ;$197
BIT-STRING-MOVE! ;$198
BIT-STRING-MOVEC! ;$199
WRITE-INTO-PURE-SPACE ;1A
#F ;1B
#F ;1C
- ASSIGN-LAMBDA-NAME ;1D
+ #F ;1D
FAILED-ARG-1-COERCION ;1E
FAILED-ARG-2-COERCION ;1F
OUT-OF-FILE-HANDLES ;20
WRONG-TYPE-ARGUMENT-7 ;2D
WRONG-TYPE-ARGUMENT-8 ;2E
WRONG-TYPE-ARGUMENT-9 ;2F
+ INAPPLICABLE-CONTINUATION ;30
+ COMPILED-CODE-ERROR ;31
+ FLOATING-OVERFLOW ;32
+ UNIMPLEMENTED-PRIMITIVE ;33
))
\f
;;; [] Terminations
;;; This identification string is saved by the system.
-"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.23 1987/03/12 17:48:32 jinx Exp $"
+"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.24 1987/04/03 00:22:18 jinx Exp $"
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/utils.c,v 9.21 1987/02/02 15:15:54 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utils.c,v 9.22 1987/04/03 00:22:38 jinx Exp $ */
/* This file contains utilities for interrupts, errors, etc. */
long Save_Space;
Int_Vector = Get_Fixed_Obj_Slot(System_Interrupt_Vector);
- for (Int_Number=0, i=1; Int_Number < MAX_INTERRUPT_NUMBER;
- i = i<<1, Int_Number++) if ((Masked_Interrupts & i) != 0) goto OK;
- printf("Int_Vector %x\n", Int_Vector);
- printf("\nInterrupts = 0x%x, Mask= 0x%x, Masked = 0x%x\n",
+
+ for (Int_Number=0, i=1;
+ Int_Number < MAX_INTERRUPT_NUMBER;
+ i = i<<1, Int_Number++)
+ if ((Masked_Interrupts & i) != 0)
+ goto OK;
+
+ fprintf(stderr, "\nInterrupts = 0x%x, Mask= 0x%x, Masked = 0x%x\n",
IntCode, IntEnb, Masked_Interrupts);
+ fprintf(stderr, "Int_Vector %x\n", Int_Vector);
Microcode_Termination(TERM_NO_INTERRUPT_HANDLER);
+
OK:
- New_Int_Enb = (1<<Int_Number)-1;
+ New_Int_Enb = (1<<Int_Number) - 1;
Global_Interrupt_Hook();
if (Int_Number > Vector_Length(Int_Vector))
- { printf("\nInterrupt out of range: 0x%x (vector length = 0x%x)\n",
- Int_Number, Vector_Length(Int_Vector));
- printf("Interrupts = 0x%x, Mask= 0x%x, Masked = 0x%x\n",
- IntCode, IntEnb, Masked_Interrupts);
+ { fprintf(stderr,
+ "\nInterrupt out of range: 0x%x (vector length = 0x%x)\n",
+ Int_Number, Vector_Length(Int_Vector));
+ fprintf(stderr,
+ "Interrupts = 0x%x, Mask= 0x%x, Masked = 0x%x\n",
+ IntCode, IntEnb, Masked_Interrupts);
Microcode_Termination(TERM_NO_INTERRUPT_HANDLER);
}
else Handler = User_Vector_Ref(Int_Vector, Int_Number);
Back_Out_Of_Primitive ()
{
long nargs;
+ Pointer expression = Fetch_Expression();
/* When primitives are called from compiled code, the type code may
* not be in the expression register.
*/
- if (Safe_Type_Code(Fetch_Expression()) == 0)
- Store_Expression(Make_Non_Pointer(TC_PRIMITIVE, Fetch_Expression()));
+ if (Safe_Type_Code(expression) == 0)
+ {
+ expression = Make_Non_Pointer(TC_PRIMITIVE, expression);
+ Store_Expression(expression);
+ }
/* Setup a continuation to return to compiled code if the primitive is
* restarted and completes successfully.
*/
- nargs = N_Args_Primitive(Fetch_Expression());
+ nargs = N_Args_Primitive(Get_Integer(expression));
if (Type_Code(Stack_Ref(nargs)) == TC_RETURN_ADDRESS)
- { Pointer expression = Fetch_Expression();
+ {
+ /* This clobbers the expression register. */
compiler_apply_procedure(nargs);
Store_Expression(expression);
}
Print_Return("Return code");
printf( "\n");
}
+
Error_Exit_Hook();
+
if (Trace_On_Error)
- { printf( "\n\nStack trace:\n\n");
+ {
+ printf( "\n**** Stack Trace ****\n\n");
Back_Trace();
}
#ifdef ENABLE_DEBUGGING_TOOLS
-{ int *From = &(local_circle[0]), *To = &(debug_circle[0]), i;
- for (i=0; i < local_nslots; i++) *To++ = *From++;
- debug_nslots = local_nslots;
- debug_slotno = local_slotno;
-}
+ {
+ int *From = &(local_circle[0]), *To = &(debug_circle[0]), i;
+
+ for (i=0; i < local_nslots; i++) *To++ = *From++;
+ debug_nslots = local_nslots;
+ debug_slotno = local_slotno;
+ }
#endif
/* Do_Micro_Error continues on the next page. */
(Type_Code((Error_Vector =
Get_Fixed_Obj_Slot(System_Error_Vector))) !=
TC_VECTOR))
- { printf("\nBogus Error Vector! I'm terribly confused!\n");
+ {
+ fprintf(stderr,
+ "\nMicrocode Error: code = 0x%x; Bad error handlers vector.\n",
+ Err);
printf("\n**** Stack Trace ****\n\n");
Back_Trace();
Microcode_Termination(TERM_NO_ERROR_HANDLER, Err);
}
+
if (Err >= Vector_Length(Error_Vector))
- { if (Vector_Length(Error_Vector) == 0)
- { printf("\nEmpty Error Vector! I'm terribly confused!\n");
+ {
+ if (Vector_Length(Error_Vector) == 0)
+ {
+ fprintf(stderr,
+ "\nMicrocode Error: code = 0x%x; Empty error handlers vector.\n",
+ Err);
+ printf("\n**** Stack Trace ****\n\n");
+ Back_Trace();
Microcode_Termination(TERM_NO_ERROR_HANDLER, Err);
}
Handler = User_Vector_Ref(Error_Vector, ERR_BAD_ERROR_CODE);
}
- else Handler = User_Vector_Ref(Error_Vector, Err);
+ else
+ Handler = User_Vector_Ref(Error_Vector, Err);
+\f
+ /* This can NOT be folded into the Will_Push below since we cannot
+ afford to have the Will_Push put down its own continuation.
+ There is guaranteed to be enough space for this one
+ continuation; in fact, the Will_Push here is really unneeded!
+ */
+
if (From_Pop_Return)
- { /* This can NOT be folded into the Will_Push below since we cannot */
- /* afford to have the Will_Push put down its own continuation. */
- /* There is guaranteed to be enough space for this one */
- /* continuation; in fact, the Will_Push here is really unneeded! */
+ {
Will_Push(CONTINUATION_SIZE);
Save_Cont();
Pushed();
}
Will_Push(STACK_ENV_EXTRA_SLOTS+3+2*CONTINUATION_SIZE+HISTORY_SIZE+
(From_Pop_Return ? 0 : 1));
- if (From_Pop_Return) Store_Expression(Val);
- else Push(Fetch_Env());
- Store_Return(From_Pop_Return? RC_POP_RETURN_ERROR : RC_EVAL_ERROR);
+
+ if (From_Pop_Return)
+ Store_Expression(Val);
+ else
+ Push(Fetch_Env());
+
+ Store_Return((From_Pop_Return) ?
+ RC_POP_RETURN_ERROR :
+ RC_EVAL_ERROR);
Save_Cont();
+
/* Return from error handler will re-enable interrupts & restore history */
+
Stop_History();
Store_Return(RC_RESTORE_INT_MASK);
Store_Expression(FIXNUM_0 + IntEnb);
Save_Cont();
- Push(FIXNUM_0+IntEnb); /* Arg 2: Int. mask */
- Push(FIXNUM_0+Err); /* Arg 1: Err. No */
- Push(Handler); /* Function: Handler */
+ Push(Make_Unsigned_Fixnum(IntEnb)); /* Arg 2: Int. mask */
+ Push(Make_Unsigned_Fixnum(Err)); /* Arg 1: Err. No */
+ Push(Handler); /* Procedure: Handler */
Push(STACK_FRAME_HEADER+2);
Pushed();
- IntEnb = 0; /* Turn off interrupts */
+
+ IntEnb = 0; /* Turn off interrupts */
New_Compiler_MemTop();
}
\f
/* Restore_History pops a history object off the stack and
makes a COPY of it the current history collection object.
This is called only from the RC_RESTORE_HISTORY case in
- Basmod.
+ interpret.c .
*/
Boolean
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/version.h,v 9.34 1987/03/12 17:44:30 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 9.35 1987/04/03 00:23:01 jinx Exp $
This file contains version information for the microcode. */
\f
#define VERSION 9
#endif
#ifndef SUBVERSION
-#define SUBVERSION 34
+#define SUBVERSION 35
#endif
#ifndef UCODE_TABLES_FILENAME
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/bintopsb.c,v 9.22 1987/03/12 14:52:23 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/bintopsb.c,v 9.23 1987/04/03 00:05:18 jinx Exp $
*
* This File contains the code to translate internal format binary
* files to portable format.
#define Portable_File Output_File
#include "translate.h"
+#include "trap.h"
static Boolean Shuffle_Bytes = false;
-static Boolean Padded_Strings = true;
-static Boolean Dense_Types = true;
+static Boolean upgrade_traps = false;
static Pointer *Mem_Base;
static long Heap_Relocation, Constant_Relocation;
}
}
\f
-#define Do_String(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer((Code), Old_Contents); \
- else \
- { fast long i; \
- Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
- (Obj) += 1; \
- *(FObj)++ = STRING_0; \
- *(FObj)++ = Old_Contents; \
- i = Get_Integer(Old_Contents); \
- NStrings += 1; \
- NChars += (Padded_Strings ? \
- pointer_to_char(i-1) : \
- (1 + pointer_to_char(i-1))); \
- while(--i >= 0) *(FObj)++ = *Old_Address++; \
- } \
- if (Dangerous(This)) Set_Danger_Bit(Mem_Base[(Scn)]); \
+#define Do_String(Code, Rel, Fre, Scn, Obj, FObj) \
+{ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ Mem_Base[(Scn)] = \
+ Make_New_Pointer((Code), Old_Contents); \
+ else \
+ { fast long i; \
+ Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
+ *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
+ (Obj) += 1; \
+ *(FObj)++ = STRING_0; \
+ *(FObj)++ = Old_Contents; \
+ i = Get_Integer(Old_Contents); \
+ NStrings += 1; \
+ NChars += pointer_to_char(i-1); \
+ while(--i >= 0) *(FObj)++ = *Old_Address++; \
+ } \
}
print_a_string(from)
{ fast long len;
fast char *string;
long maxlen = pointer_to_char((Get_Integer(*from++))-1);
- if (!Padded_Strings) maxlen += 1;
len = Get_Integer(*from++);
fprintf(Portable_File, "%02x %ld %ld ",
TC_CHARACTER_STRING,
return;
}
\f
-#define Do_Bignum(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer((Code), Old_Contents); \
- else \
- { fast long length; \
- Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
- NIntegers += 1; \
- NBits += bignum_to_bits(LEN(BIGNUM(Old_Address))); \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
- (Obj) += 1; \
- *(FObj)++ = Make_Non_Pointer(TC_BIG_FIXNUM, 0); \
- *(FObj)++ = Old_Contents; \
- for (length = Get_Integer(Old_Contents); \
- --length >= 0; ) \
- *(FObj)++ = *Old_Address++; \
- } \
- if (Dangerous(This)) Set_Danger_Bit(Mem_Base[(Scn)]); \
+#define Do_Bignum(Code, Rel, Fre, Scn, Obj, FObj) \
+{ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ Mem_Base[(Scn)] = \
+ Make_New_Pointer((Code), Old_Contents); \
+ else \
+ { fast long length; \
+ Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
+ NIntegers += 1; \
+ NBits += bignum_to_bits(LEN(BIGNUM(Old_Address))); \
+ *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
+ (Obj) += 1; \
+ *(FObj)++ = Make_Non_Pointer(TC_BIG_FIXNUM, 0); \
+ *(FObj)++ = Old_Contents; \
+ for (length = Get_Integer(Old_Contents); \
+ --length >= 0; ) \
+ *(FObj)++ = *Old_Address++; \
+ } \
}
print_a_bignum(from)
return;
}
\f
-#define Do_Flonum(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer((Code), Old_Contents); \
- else \
- { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
- Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
- (Obj) += 1; \
- *(FObj)++ = Make_Non_Pointer(TC_BIG_FLONUM, 0); \
- *((double *) (FObj)) = *((double *) Old_Address); \
- (FObj) += float_to_pointer; \
- NFlonums += 1; \
- } \
- if (Dangerous(This)) Set_Danger_Bit(Mem_Base[(Scn)]); \
+#define Do_Flonum(Code, Rel, Fre, Scn, Obj, FObj) \
+{ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ Mem_Base[(Scn)] = \
+ Make_New_Pointer((Code), Old_Contents); \
+ else \
+ { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
+ (Obj) += 1; \
+ *(FObj)++ = Make_Non_Pointer(TC_BIG_FLONUM, 0); \
+ *((double *) (FObj)) = *((double *) Old_Address); \
+ (FObj) += float_to_pointer; \
+ NFlonums += 1; \
+ } \
}
print_a_flonum(val)
#define Do_Area(Code, Area, Bound, Obj, FObj) \
Process_Area(Code, &Area, &Bound, &Obj, &FObj)
-#if 0
-
-#ifdef DEBUG
-#define Show_Upgrade(This, New_Type) \
- fprintf(stderr, "Upgrading from 0x%02x|%06x to 0x%x\n", \
- Type_Code(This), Datum(This), New_Type);
-#else
-#define Show_Upgrade(This, New_Type)
-#endif
-
-#define Upgrade(New_Type) \
-{ Boolean Was_Dangerous = Dangerous(This); \
- Show_Upgrade(This, New_Type); \
- if (Dense_Types) goto Bad_Type; \
- This = Make_New_Pointer(New_Type, Datum(This)); \
- if (Was_Dangerous) Set_Danger_Bit(This); \
- Mem_Base[*Area] = This; \
- break; \
-}
-
-#endif 0
-
Process_Area(Code, Area, Bound, Obj, FObj)
int Code;
fast long *Area, *Bound;
*Area += 1;
break;
+ case_compiled_entry_point:
+ fprintf(stderr,
+ "%s: File is not portable: Compiled code.\n",
+ Program_Name);
+ exit(1);
+\f
case TC_FIXNUM:
NIntegers += 1;
NBits += fixnum_to_bits;
Mem_Base[*Area] = Make_Non_Pointer(Code, *Obj);
*Obj += 1;
**FObj = This;
- if (Dangerous(This))
- { Set_Danger_Bit(Mem_Base[*Area]);
- Clear_Danger_Bit(**FObj);
- }
*FObj += 1;
/* Fall through */
case TC_MANIFEST_SPECIAL_NM_VECTOR:
*Area += 1;
break;
- case_compiled_entry_point:
- fprintf(stderr,
- "%s: File is not portable: Compiled code.\n",
- Program_Name);
- exit(1);
-
case_Cell:
Do_Pointer(*Area, Do_Cell);
+ case TC_REFERENCE_TRAP:
+ {
+ long kind;
+
+ kind = Datum(This);
+
+ if (upgrade_traps)
+ {
+ /* It is an old UNASSIGNED object. */
+ if (kind == 0)
+ {
+ Mem_Base[*Area] = UNASSIGNED_OBJECT;
+ *Area += 1;
+ break;
+ }
+ if (kind == 1)
+ {
+ Mem_Base[*Area] = UNBOUND_OBJECT;
+ *Area += 1;
+ break;
+ }
+ fprintf(stderr,
+ "%s: Bad old unassigned object. 0x%x.\n",
+ Program_Name, This);
+ exit(1);
+ }
+ if (kind <= TRAP_MAX_IMMEDIATE)
+ {
+ /* It is a non pointer. */
+
+ *Area += 1;
+ break;
+ }
+ }
+ /* Fall through */
+\f
case TC_WEAK_CONS:
case_Pair:
Do_Pointer(*Area, Do_Pair);
Do_Pointer(*Area, Do_String);
case TC_ENVIRONMENT:
+ if (upgrade_traps)
+ {
+ fprintf(stderr,
+ "%s: Cannot upgrade environments.\n",
+ Program_Name);
+ exit(1);
+ }
+ /* Fall through */
case TC_FUTURE:
case_simple_Vector:
Do_Pointer(*Area, Do_Vector);
-#if 0
-
-/* This should be cleaned up: We can no longer do it like this
- since we have reused the types.
- */
-
- case OLD_TC_BROKEN_HEART:
- Upgrade(TC_BROKEN_HEART);
- case OLD_TC_SPECIAL_NM_VECTOR:
- Upgrade(TC_MANIFEST_SPECIAL_NM_VECTOR);
-#if 0
- case OLD_TC_UNASSIGNED:
- Upgrade(TC_UNASSIGNED);
- case OLD_TC_RETURN_CODE:
- Upgrade(TC_RETURN_CODE);
-#endif
- case OLD_TC_PCOMB0:
- Upgrade(TC_PCOMB0);
- case OLD_TC_THE_ENVIRONMENT:
- Upgrade(TC_THE_ENVIRONMENT);
- case OLD_TC_CHARACTER:
- Upgrade(TC_CHARACTER);
- case OLD_TC_FIXNUM:
- Upgrade(TC_FIXNUM);
-#if 0
- case OLD_TC_SEQUENCE_3:
- Upgrade(TC_SEQUENCE_3);
-#endif
- case OLD_TC_MANIFEST_NM_VECTOR:
- Upgrade(TC_MANIFEST_NM_VECTOR);
- case OLD_TC_VECTOR:
- Upgrade(TC_VECTOR);
-#if 0
- case OLD_TC_ENVIRONMENT:
- Upgrade(TC_ENVIRONMENT);
-#endif
- case OLD_TC_CONTROL_POINT:
- Upgrade(TC_CONTROL_POINT);
- case OLD_TC_COMBINATION:
- Upgrade(TC_COMBINATION);
- case OLD_TC_PCOMB3:
- Upgrade(TC_PCOMB3);
- case OLD_TC_PCOMB2:
- Upgrade(TC_PCOMB2);
-#endif 0
-
default:
Bad_Type:
fprintf(stderr, "%s: Unknown Type Code 0x%x found.\n",
if (Machine_Type == FASL_INTERNAL_FORMAT)
Shuffle_Bytes = false;
- if (Sub_Version < FASL_PADDED_STRINGS)
- Padded_Strings = false;
- if (Sub_Version < FASL_DENSE_TYPES)
- Dense_Types = false;
+ upgrade_traps = (Sub_Version < FASL_REFERENCE_TRAP);
/* Constant Space not currently supported */
}
{ long Size = ((3 * (Heap_Count + Const_Count)) + NROOTS + 1);
-#if 0
- Size += (FLOATING_ALIGNMENT+1)/sizeof(Pointer);
-#endif
- Allocate_Heap_Space(Size);
+ Allocate_Heap_Space(Size + HEAP_BUFFER_SPACE);
if (Heap == NULL)
{ fprintf(stderr,
"%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n",
exit(1);
}
}
-#if 0
- Align_Float(Heap);
-#endif
+ Heap += HEAP_BUFFER_SPACE;
+ Initial_Align_Float(Heap);
Load_Data(Heap_Count, &Heap[0]);
Load_Data(Const_Count, &Heap[Heap_Count]);
Heap_Relocation = &Heap[0] - Get_Pointer(Heap_Base);
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/const.h,v 9.22 1987/02/04 17:49:56 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/const.h,v 9.23 1987/04/03 00:10:08 jinx Exp $
*
* Named constants used throughout the interpreter
*
#define NIL Make_Non_Pointer(TC_NULL, 0)
#define TRUTH Make_Non_Pointer(TC_TRUE, 0)
-#define UNASSIGNED_OBJECT Make_Non_Pointer(TC_UNASSIGNED, UNASSIGNED)
-#define UNBOUND_OBJECT Make_Non_Pointer(TC_UNASSIGNED, UNBOUND)
-#define UNCOMPILED_VARIABLE Make_Non_Pointer(UNCOMPILED_REF, 0)
#define FIXNUM_0 Make_Non_Pointer(TC_FIXNUM, 0)
-#define LOCAL_REF_0 Make_Non_Pointer(LOCAL_REF, 0)
#define BROKEN_HEART_0 Make_Non_Pointer(TC_BROKEN_HEART, 0)
#define STRING_0 Make_Non_Pointer(TC_CHARACTER_STRING, 0)
#else /* 32 bit word */
#define NIL 0x00000000
#define TRUTH 0x08000000
-#define UNASSIGNED_OBJECT 0x32000000
-#define UNBOUND_OBJECT 0x32000001
-#define UNCOMPILED_VARIABLE 0x08000000
#define FIXNUM_0 0x1A000000
-#define LOCAL_REF_0 0x00000000
#define BROKEN_HEART_0 0x22000000
#define STRING_0 0x1E000000
#endif /* b32 */
-/* Some names for flag values */
-
-#define SET_IT 0 /* Lookup */
-#define CLEAR_IT 1
-#define READ_IT 2
-#define TEST_IT 3
-
-#define FOUND_SLOT 1 /* Slot lookup */
-#define NO_SLOT 2
-#define FOUND_UNBOUND 4
-
#define NOT_THERE -1 /* Command line parser */
\f
/* Assorted sizes used in various places */
occurs */
#endif
-#define FILE_CHANNELS 15
+/* Some versions of stdio define this. */
+#ifndef _NFILE
+#define _NFILE 15
+#endif
+
+#define FILE_CHANNELS _NFILE
+
#define MAX_LIST_PRINT 10
#define ILLEGAL_PRIMITIVE -1
#define LENGTH_MULTIPLIER 5
#define SHIFT_AMOUNT 2
-/* For looking up variable definitions */
-
-#define UNCOMPILED_REF TC_TRUE
-#define GLOBAL_REF TC_UNINTERNED_SYMBOL
-#define FORMAL_REF TC_FIXNUM
-#define AUX_REF TC_ENVIRONMENT
-#define LOCAL_REF TC_NULL
-/* LOCAL_REF must be 0 in order for code in interpret.c to work fast */
+/* Last immediate reference trap. */
+
+#define TRAP_MAX_IMMEDIATE 9
/* For headers in pure / constant area */
/* VMS preprocessor does not like line continuations in conditionals */
#define Are_The_Constants_Incompatible \
-((TC_NULL != 0x00) || (TC_TRUE != 0x08) || (TC_UNASSIGNED != 0x32) || \
- (UNASSIGNED != 0) || (UNBOUND != 1) || (UNCOMPILED_REF != 0x08) || \
+((TC_NULL != 0x00) || (TC_TRUE != 0x08) || \
(TC_FIXNUM != 0x1A) || (TC_BROKEN_HEART != 0x22) || \
- (TC_CHARACTER_STRING != 0x1E) || (LOCAL_REF != 0x00))
+ (TC_CHARACTER_STRING != 0x1E))
/* The values used above are in sdata.h and types.h,
check for consistency if the check below fails. */
#if Are_The_Constants_Incompatible
-#include "Error: disagreement in const.h"
+#include "Error: const.h and types.h disagree"
#endif
/* These are the only entries in Registers[] needed by the microcode.
All other entries are used only by the compiled code interface. */
-#define REGBLOCK_MEMTOP 0
-#define REGBLOCK_STACKGUARD 1
-#define REGBLOCK_MINIMUM_LENGTH 2
+#define REGBLOCK_MEMTOP 0
+#define REGBLOCK_STACKGUARD 1
+#define REGBLOCK_VAL 2
+#define REGBLOCK_ENV 3
+#define REGBLOCK_TEMP 4
+#define REGBLOCK_EXPR 5
+#define REGBLOCK_RETURN 6
+#define REGBLOCK_MINIMUM_LENGTH 7
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/fasl.h,v 9.22 1987/03/12 14:51:36 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/fasl.h,v 9.23 1987/04/03 00:12:15 jinx Exp $
Contains information relating to the format of FASL files.
Some information is contained in CONFIG.H.
/* FASL Version */
#define FASL_FILE_MARKER 0XFAFAFAFA
-#define FASL_FORMAT_ADDED_STACK 1
-#define FASL_FORMAT_VERSION 1
-#define FASL_SUBVERSION 5
/* The FASL file has a header which begins as follows: */
#define The_Version(P) Type_Code(P)
#define Make_Version(V, S, M) \
Make_Non_Pointer((V), (((S) << MACHINE_TYPE_LENGTH) | (M)))
-\f
+
#define WRITE_FLAG "w"
#define OPEN_FLAG "r"
-
-/* "Memorable" FASL sub-versions -- ones where we modified something
+\f
+/* "Memorable" FASL versions -- ones where we modified something
and want to remain backwards compatible.
*/
+/* Versions. */
+
+#define FASL_FORMAT_ADDED_STACK 1
+
+/* Subversions of highest numbered version. */
+
#define FASL_LONG_HEADER 3
#define FASL_DENSE_TYPES 4
#define FASL_PADDED_STRINGS 5
-#define FASL_OLDEST_SUPPORTED 5
+#define FASL_REFERENCE_TRAP 6
-#if 0
-/* Old Type Codes -- used for conversion purposes
- This is no longer possible, because some were re-used
- without changing the fasl file version.
-*/
+/* Current parameters. */
-#define OLD_TC_CHARACTER 0x40
-#define OLD_TC_PCOMB2 0x44
-#define OLD_TC_VECTOR 0x46
-#define OLD_TC_RETURN_CODE 0x48
-#define OLD_TC_COMPILED_PROCEDURE 0x49
-#define OLD_TC_ENVIRONMENT 0x4E
-#define OLD_TC_FIXNUM 0x50
-#define OLD_TC_CONTROL_POINT 0x56
-#define OLD_TC_BROKEN_HEART 0x58
-#define OLD_TC_COMBINATION 0x5E
-#define OLD_TC_MANIFEST_NM_VECTOR 0x60
-#define OLD_TC_PCOMB3 0x66
-#define OLD_TC_SPECIAL_NM_VECTOR 0x68
-#define OLD_TC_THE_ENVIRONMENT 0x70
-#define OLD_TC_VECTOR_1B 0x76
-#define OLD_TC_BIT_STRING 0x76
-#define OLD_TC_PCOMB0 0x78
-#define OLD_TC_VECTOR_16B 0x7E
-#define OLD_TC_UNASSIGNED 0x38
-#define OLD_TC_SEQUENCE_3 0x3C
-
-#endif 0
+#define FASL_FORMAT_VERSION FASL_FORMAT_ADDED_STACK
+#define FASL_SUBVERSION FASL_REFERENCE_TRAP
+#define FASL_OLDEST_SUPPORTED FASL_PADDED_STRINGS
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/fixobj.h,v 9.23 1987/03/09 14:44:49 cph Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/fixobj.h,v 9.24 1987/04/03 00:12:59 jinx Exp $
*
* Declarations of user offsets into the Fixed Objects Vector.
* This should correspond to the file UTABMD.SCM
*/
\f
-#define Non_Object 0x00 /* Value for UNBOUND variables */
+#define Non_Object 0x00 /* Used for unassigned variables */
#define System_Interrupt_Vector 0x01 /* Handlers for interrups */
#define System_Error_Vector 0x02 /* Handlers for errors */
#define OBArray 0x03 /* Array for interning symbols */
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/gctype.c,v 9.21 1987/01/22 14:26:35 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/gctype.c,v 9.22 1987/04/03 00:14:08 jinx Exp $
*
* This file contains the table which maps between Types and
* GC Types.
GC_Pair, /* TC_INTERNED_SYMBOL */
GC_Vector, /* TC_CHARACTER_STRING,TC_VECTOR_8B */
GC_Pair, /* TC_ACCESS */
- GC_Non_Pointer, /* TC_EXTENDED_FIXNUM */
+ GC_Undefined, /* 0x20 */
GC_Pair, /* TC_DEFINITION */
GC_Special, /* TC_BROKEN_HEART */
GC_Pair, /* TC_ASSIGNMENT */
GC_Vector, /* TC_VECTOR_1B,TC_BIT_STRING */
GC_Non_Pointer, /* TC_PCOMB0 */
GC_Vector, /* TC_VECTOR_16B */
- GC_Non_Pointer, /* TC_UNASSIGNED */
+ GC_Special, /* TC_REFERENCE_TRAP */
GC_Triple, /* TC_SEQUENCE_3 */
GC_Triple, /* TC_CONDITIONAL */
GC_Pair, /* TC_DISJUNCTION */
GC_Cell, /* TC_CELL */
GC_Pair, /* TC_WEAK_CONS */
- GC_Triple, /* TC_TRAP */
+ GC_Quadruple, /* TC_QUAD */
GC_Compiled, /* TC_RETURN_ADDRESS */
GC_Pair, /* TC_COMPILER_LINK */
GC_Non_Pointer, /* TC_STACK_ENVIRONMENT */
GC_Undefined, /* 0x45 */
GC_Undefined, /* 0x46 */
GC_Undefined, /* 0x47 */
-#if defined(MC68020)
- GC_Non_Pointer, /* TC_PEA_INSTRUCTION */
-#else
GC_Undefined, /* 0x48 */
-#endif
GC_Undefined, /* 0x49 */
GC_Undefined, /* 0x4A */
GC_Undefined, /* 0x4B */
GC_Undefined, /* 0x4C */
GC_Undefined, /* 0x4D */
-#if defined(MC68020)
- GC_Non_Pointer, /* TC_JMP_INSTRUCTION */
-#else
GC_Undefined, /* 0x4E */
-#endif
GC_Undefined, /* 0x4F */
GC_Undefined, /* 0x50 */
-#if defined(MC68020)
- GC_Non_Pointer, /* TC_DBF_INSTRUCTION */
-#else
GC_Undefined, /* 0x51 */
-#endif
GC_Undefined, /* 0x52 */
GC_Undefined, /* 0x53 */
GC_Undefined, /* 0x54 */
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/interp.c,v 9.21 1987/01/22 14:27:50 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/interp.c,v 9.22 1987/04/03 00:14:51 jinx Exp $
*
* This file contains the heart of the Scheme Scode
* interpreter
#define In_Main_Interpreter true
#include "scheme.h"
+#include "locks.h"
+#include "trap.h"
+#include "lookup.h"
#include "zones.h"
\f
/* In order to make the interpreter tail recursive (i.e.
* ordered alphabetically by return code name.
*/
\f
-#define Interrupt(Masked_Code) \
- { Export_Registers(); \
- Setup_Interrupt(Masked_Code); \
- Import_Registers(); \
- goto Perform_Application; \
- }
+#define Interrupt(Masked_Code) \
+{ \
+ Export_Registers(); \
+ Setup_Interrupt(Masked_Code); \
+ Import_Registers(); \
+ goto Perform_Application; \
+}
#define Immediate_GC(N) \
- { Request_GC(N); \
- Interrupt(IntCode & IntEnb); \
- }
-
+{ \
+ Request_GC(N); \
+ Interrupt(IntCode & IntEnb); \
+}
+
#define Prepare_Eval_Repeat() \
- {Will_Push(CONTINUATION_SIZE+1); \
- Push(Fetch_Env()); \
- Store_Return(RC_EVAL_ERROR); \
- Save_Cont(); \
- Pushed(); \
- }
+{ \
+ Will_Push(CONTINUATION_SIZE+1); \
+ Push(Fetch_Env()); \
+ Store_Return(RC_EVAL_ERROR); \
+ Save_Cont(); \
+ Pushed(); \
+}
#define Eval_GC_Check(Amount) \
- if (GC_Check(Amount)) \
- { Prepare_Eval_Repeat(); \
- Immediate_GC(Amount); \
- }
+if (GC_Check(Amount)) \
+{ \
+ Prepare_Eval_Repeat(); \
+ Immediate_GC(Amount); \
+}
#define Eval_Error(Err) \
- { Export_Registers(); \
- Do_Micro_Error(Err, false); \
- Import_Registers(); \
- goto Internal_Apply; \
- }
+{ \
+ Export_Registers(); \
+ Do_Micro_Error(Err, false); \
+ Import_Registers(); \
+ goto Internal_Apply; \
+}
#define Pop_Return_Error(Err) \
- { Export_Registers(); \
- Do_Micro_Error(Err, true); \
- Import_Registers(); \
- goto Internal_Apply; \
- }
-
+{ \
+ Export_Registers(); \
+ Do_Micro_Error(Err, true); \
+ Import_Registers(); \
+ goto Internal_Apply; \
+}
+
#define Prepare_Pop_Return_Interrupt(Return_Code, Contents_of_Val) \
- Store_Return(Return_Code); \
- Val = Contents_of_Val; \
- Save_Cont()
+{ \
+ Store_Return(Return_Code); \
+ Save_Cont(); \
+ Store_Return(RC_RESTORE_VALUE); \
+ Store_Expression(Contents_of_Val); \
+ Save_Cont(); \
+}
\f
#define Reduces_To(Expr) \
{ Store_Expression(Expr); \
#define Environment_P(Obj) (Obj == NIL || (Type_Code(Obj) == TC_ENVIRONMENT))
-/* This makes local variable references faster */
-
-#if (LOCAL_REF == 0)
-#define Local_Offset(Ind) Ind
-#else
-#define Local_Offset(Ind) Get_Integer(Ind)
-#endif
-\f
-#ifdef COMPILE_FUTURES
-#define Splice_Future_Value(The_Loc) \
-{ while ((Type_Code(Val) == TC_FUTURE) && (Future_Spliceable(Val))) \
- { Pointer *Location; \
- Val = Future_Value(Val); \
- Location = The_Loc; \
- if Dangerous(*Location) Set_Danger_Bit(Val); \
- *Location = Val; \
- Clear_Danger_Bit(Val); \
- } \
- Set_Time_Zone(Zone_Working); \
- break; \
-}
-#else
-#define Splice_Future_Value(The_Loc) \
-{ Set_Time_Zone(Zone_Working); \
- break; \
-}
-#endif
-
-#ifdef TRAP_ON_REFERENCE
-#define Trap(Value) (Safe_Type_Code(Value) == TC_TRAP)
-#else
-#define Trap(Value) false
-#endif
-
#define MAGIC_RESERVE_SIZE 6 /* See SPMD.SCM */
#define Reserve_Stack_Space() Will_Eventually_Push(MAGIC_RESERVE_SIZE)
\f
their arguments and restarts them or suspends if the argument is a future. */
#define Arg_Type_Error(Arg_No, Err_No) \
-{ fast Pointer *Arg = &(Stack_Ref(Arg_No-1)); \
- fast Pointer Orig_Arg = *Arg; \
- if (Type_Code(*Arg) != TC_FUTURE) Pop_Return_Error(Err_No); \
+{ \
+ fast Pointer *Arg, Orig_Arg; \
+ \
+ Arg = &(Stack_Ref(Arg_No-1)); \
+ Orig_Arg = *Arg; \
+ \
+ if (Type_Code(*Arg) != TC_FUTURE) \
+ Pop_Return_Error(Err_No); \
+ \
while ((Type_Code(*Arg) == TC_FUTURE) && (Future_Has_Value(*Arg))) \
- { if (Future_Is_Keep_Slot(*Arg)) Log_Touch_Of_Future(*Arg); \
+ { \
+ if (Future_Is_Keep_Slot(*Arg)) Log_Touch_Of_Future(*Arg); \
*Arg = Future_Value(*Arg); \
} \
- if (Type_Code(*Arg) != TC_FUTURE) goto Prim_No_Trap_Apply; \
+ if (Type_Code(*Arg) != TC_FUTURE) \
+ goto Prim_No_Trap_Apply; \
+ \
Save_Cont(); \
Will_Push(STACK_ENV_EXTRA_SLOTS+2); \
Push(*Arg); /* Arg 1: The future itself */ \
*/
#define Apply_Future_Check(Name, Object) \
-{ fast Pointer *Arg = &(Object); \
- fast Pointer Orig_Answer = *Arg; \
+{ \
+ fast Pointer *Arg, Orig_Answer; \
+ \
+ Arg = &(Object); \
+ Orig_Answer = *Arg; \
+ \
while (Type_Code(*Arg) == TC_FUTURE) \
- { if (Future_Has_Value(*Arg)) \
- { if (Future_Is_Keep_Slot(*Arg)) Log_Touch_Of_Future(*Arg); \
+ { \
+ if (Future_Has_Value(*Arg)) \
+ { \
+ if (Future_Is_Keep_Slot(*Arg)) \
+ Log_Touch_Of_Future(*Arg); \
*Arg = Future_Value(*Arg); \
- } \
+ } \
else \
{ \
Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \
Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
Push(STACK_FRAME_HEADER+1); \
Pushed(); \
- *Arg = Orig_Answer; \
+ *Arg = Orig_Answer; \
goto Internal_Apply; \
} \
} \
a recursive call to EVAL is an undetermined future */
#define Pop_Return_Val_Check() \
-{ fast Pointer Orig_Val = Val; \
+{ \
+ fast Pointer Orig_Val = Val; \
+ \
while (Type_Code(Val) == TC_FUTURE) \
- { if (Future_Has_Value(Val)) \
- { if (Future_Is_Keep_Slot(Val)) Log_Touch_Of_Future(Val); \
+ { \
+ if (Future_Has_Value(Val)) \
+ { \
+ if (Future_Is_Keep_Slot(Val)) \
+ Log_Touch_Of_Future(Val); \
Val = Future_Value(Val); \
- } \
+ } \
else \
- { Save_Cont(); \
+ { \
+ Save_Cont(); \
Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \
Store_Return(RC_RESTORE_VALUE); \
Store_Expression(Orig_Val); \
}
#else /* Not compiling FUTURES code */
+
#define Pop_Return_Val_Check()
#define Apply_Future_Check(Name, Object) Name = (Object)
#define Arg_Type_Error(Arg_No, Err_No) Pop_Return_Error(Err_No)
+
#endif
\f
/* The EVAL/APPLY ying/yang */
void
Interpret(dumped_p)
Boolean dumped_p;
-{ long Which_Way;
- fast Pointer Reg_Val, Reg_Expression, *Reg_Stack_Pointer;
+{
+ long Which_Way;
+ fast Pointer *Reg_Block, *Reg_Stack_Pointer, *Reg_History;
+
extern long enter_compiled_expression();
extern long apply_compiled_procedure();
extern long return_to_compiled_code();
+ Reg_Block = &Registers[0];
+
/* Primitives jump back here for errors, requests to
* evaluate an expression, apply a function, or handle an
* interrupt request. On errors or interrupts they leave
Pushed();
Call_Future_Logging();
}
+\f
Repeat_Dispatch:
switch (Which_Way)
{ case PRIM_APPLY: goto Internal_Apply;
case ERR_ARG_3_WRONG_TYPE: Arg_Type_Error(3, ERR_ARG_3_WRONG_TYPE);
}
\f
- /*****************/
- /* Do_Expression */
- /*****************/
-
Do_Expression:
if (Eval_Debug)
*
* An operation can terminate with a Reduces_To or
* Reduces_To_Nth macro. This indicates that the value of
- * the current S-Code item is the value returned when the
+ * 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
*/
- if (Microcode_Does_Stepping && Trapping &&
- (Fetch_Eval_Trapper() != NIL))
+ if (Microcode_Does_Stepping && Trapping && (Fetch_Eval_Trapper() != NIL))
{ Stop_Trapping();
Will_Push(4);
Push(Fetch_Env());
case TC_CONTROL_POINT:
case TC_DELAYED:
case TC_ENVIRONMENT:
- case TC_EXTENDED_FIXNUM:
case TC_EXTENDED_PROCEDURE:
case TC_FIXNUM:
case TC_HUNK3:
+ case TC_INTERNED_SYMBOL:
case TC_LIST:
case TC_NON_MARKED_VECTOR:
case TC_NULL:
case TC_PRIMITIVE:
case TC_PRIMITIVE_EXTERNAL:
case TC_PROCEDURE:
+ case TC_QUAD:
case TC_UNINTERNED_SYMBOL:
- case TC_INTERNED_SYMBOL:
case TC_TRUE:
- case TC_UNASSIGNED:
case TC_VECTOR:
case TC_VECTOR_16B:
case TC_VECTOR_1B:
+ case TC_REFERENCE_TRAP:
Val = Fetch_Expression(); break;
case TC_ACCESS:
/* In case we back out */
Reserve_Stack_Space(); /* CONTINUATION_SIZE */
Finished_Eventual_Pushing(); /* of this primitive */
-/* ASSUMPTION: The syntaxer is hereby assumed NEVER to generate primitive
- combinations unless the primitive itself is output in the code stream.
- Therefore, we don't have to explicitly check here that the expression
- register has a primitive in it.
-*/
+
Primitive_Internal_Apply:
if (Microcode_Does_Stepping && Trapping &&
(Fetch_Apply_Trapper() != NIL))
{Will_Push(3);
Push(Fetch_Expression());
Push(Fetch_Apply_Trapper());
- Push(STACK_FRAME_HEADER + 1 + N_Args_Primitive(Fetch_Expression()));
+ Push(STACK_FRAME_HEADER + 1 +
+ N_Args_Primitive(Get_Integer(Fetch_Expression())));
Pushed();
Stop_Trapping();
goto Apply_Non_Trapping;
}
Prim_No_Trap_Apply:
- Export_Registers();
- Metering_Apply_Primitive(Val, Get_Integer(Fetch_Expression()));
-
-/* Any primitive which does not do a long jump can have it's primitive
- frame popped off here. At this point, it is guaranteed that the
- primitive is in the expression register in case the primitive needs
- to back out.
-*/
- Import_Registers_Except_Val();
- Pop_Primitive_Frame(N_Args_Primitive(Fetch_Expression()));
- if (Must_Report_References())
- { Store_Expression(Val);
- Store_Return(RC_RESTORE_VALUE);
- Save_Cont();
- Call_Future_Logging();
+ {
+ fast long primitive_code;
+
+ primitive_code = Get_Integer(Fetch_Expression());
+
+ Export_Registers_Before_Primitive();
+ Metering_Apply_Primitive(Val, primitive_code);
+ Import_Registers_After_Primitive();
+ Pop_Primitive_Frame(N_Args_Primitive(primitive_code));
+ if (Must_Report_References())
+ { Store_Expression(Val);
+ Store_Return(RC_RESTORE_VALUE);
+ Save_Cont();
+ Call_Future_Logging();
+ }
+ break;
}
- break;
\f
case TC_PCOMB1:
Reserve_Stack_Space(); /* 1+CONTINUATION_SIZE */
/* Interpret(), continued */
case TC_VARIABLE:
-/* ASSUMPTION: The SYMBOL slot does NOT contain a future */
- { fast Pointer Compilation_Type, *Variable_Object;
- int The_Type;
+ {
+ long temp;
- Set_Time_Zone(Zone_Lookup);
#ifndef No_In_Line_Lookup
- Variable_Object = Get_Pointer(Fetch_Expression());
- Compilation_Type = Variable_Object[VARIABLE_COMPILED_TYPE];
- The_Type = Type_Code(Compilation_Type);
+ fast Pointer *cell;
- if (The_Type == LOCAL_REF)
- { fast Pointer *Frame;
- Frame = Get_Pointer(Fetch_Env());
- Val = Without_Danger_Bit(Frame[Local_Offset(Compilation_Type)]);
- if (!Trap(Val))
- Splice_Future_Value(&(Frame[Local_Offset(Compilation_Type)]));
- }
- else if (The_Type == GLOBAL_REF)
- { Val = Vector_Ref(Compilation_Type, SYMBOL_GLOBAL_VALUE);
- if (Dangerous(Val))
- Variable_Object[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
- else if (!Trap(Val))
- Splice_Future_Value(Nth_Vector_Loc(Compilation_Type,
- SYMBOL_GLOBAL_VALUE));
+ Set_Time_Zone(Zone_Lookup);
+ cell = Get_Pointer(Fetch_Expression());
+ lookup(cell, Fetch_Env(), cell, repeat_variable_lookup);
+ Val = *cell;
+ if (Type_Code(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:
+ cell = Get_Pointer(Fetch_Expression());
+ temp =
+ deep_lookup_end(deep_lookup(Fetch_Env(), cell[VARIABLE_SYMBOL], cell),
+ cell);
+ goto external_lookup_return;
+
+ /* No need to recompile, pass the fake variable. */
+ case TRAP_FLUID:
+ temp = deep_lookup_end(lookup_fluid(Val), fake_variable_object);
+
+ external_lookup_return:
+ Import_Val();
+ if (temp != PRIM_DONE)
+ break;
+ Set_Time_Zone(Zone_Working);
+ goto Pop_Return;
+
+ case TRAP_UNBOUND:
+ temp = ERR_UNBOUND_VARIABLE;
+ break;
+
+ case TRAP_UNASSIGNED:
+ temp = ERR_UNASSIGNED_VARIABLE;
+ break;
+
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
- else if (The_Type == FORMAL_REF)
- { fast long Frame_No;
- fast Pointer *Frame;
-
- Frame = Get_Pointer(Fetch_Env());
- Frame_No = Get_Integer(Variable_Object[VARIABLE_FRAME_NO]);
- while(--Frame_No >= 0)
- Frame = Get_Pointer(Fast_Vector_Ref(Frame[HEAP_ENV_FUNCTION],
- PROCEDURE_ENVIRONMENT));
- Val = Frame[Local_Offset(Variable_Object[VARIABLE_OFFSET])];
- if (Dangerous(Val))
- Variable_Object[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
- else if (!Trap(Val))
- Splice_Future_Value(
- &(Frame[Local_Offset(Variable_Object[VARIABLE_OFFSET])]));
+ default:
+ temp = ERR_BROKEN_COMPILED_VARIABLE;
+ break;
}
-#endif
- /* Fall through in cases not handled above */
- { long Result;
- Result = Lex_Ref(Fetch_Env(), Fetch_Expression());
- Import_Val();
- Set_Time_Zone(Zone_Working);
- if (Result == PRIM_DONE) break;
- Eval_Error(Result);
+
+#else No_In_Line_Lookup
+
+ Set_Time_Zone(Zone_Lookup);
+ temp = Lex_Ref(Fetch_Env(), Fetch_Expression());
+ Import_Val();
+ if (temp == PRIM_DONE)
+ break;
+
+#endif No_In_Line_Lookup
+
+ /* Back out of the evaluation. */
+
+ Set_Time_Zone(Zone_Working);
+
+ if (temp == PRIM_INTERRUPT)
+ {
+ Prepare_Eval_Repeat();
+ Interrupt(IntCode & IntEnb);
}
+
+ Eval_Error(temp);
}
case TC_RETURN_CODE:
Microcode_Termination(TERM_END_OF_COMPUTATION);
case RC_EVAL_ERROR:
+ /* Should be called RC_REDO_EVALUATION. */
Store_Env(Pop());
Reduces_To(Fetch_Expression());
case RC_EXECUTE_ACCESS_FINISH:
- { long Result;
+ {
+ long Result;
+ Pointer value;
+
Pop_Return_Val_Check();
+ value = Val;
+
if (Environment_P(Val))
- { Result = Symbol_Lex_Ref(Val,
- Fast_Vector_Ref(Fetch_Expression(), ACCESS_NAME));
+ { Result = Symbol_Lex_Ref(value,
+ Fast_Vector_Ref(Fetch_Expression(),
+ ACCESS_NAME));
Import_Val();
- if (Result != PRIM_DONE) Pop_Return_Error(Result);
- End_Subproblem();
- break;
+ 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(IntCode & IntEnb);
}
+ Val = value;
Pop_Return_Error(ERR_BAD_FRAME);
}
/* Interpret(), continued */
case RC_EXECUTE_ASSIGNMENT_FINISH:
- { fast Pointer Compilation_Type, *Variable_Object;
- Pointer The_Non_Object, Store_Value;
- int The_Type;
+ {
+ long temp;
+ Pointer value;
+ Lock_Handle set_serializer;
+
+#ifndef No_In_Line_Lookup
+
+ Pointer bogus_unassigned;
+ fast Pointer *cell;
Set_Time_Zone(Zone_Lookup);
Restore_Env();
- The_Non_Object = Get_Fixed_Obj_Slot(Non_Object);
- Store_Value = (Val == The_Non_Object) ? UNASSIGNED_OBJECT : Val;
+ cell = Get_Pointer(Vector_Ref(Fetch_Expression(), ASSIGN_NAME));
+ lookup(cell, Fetch_Env(), cell, repeat_assignment_lookup);
+ setup_lock(set_serializer, cell);
+
+ value = Val;
+ bogus_unassigned = Get_Fixed_Obj_Slot(Non_Object);
+ if (value == bogus_unassigned)
+ value = UNASSIGNED_OBJECT;
+
+ if (Type_Code(*cell) != TC_REFERENCE_TRAP)
+ {
+ Val = *cell;
+
+ normal_assignment_done:
+ *cell = value;
+ remove_lock(set_serializer);
+ Set_Time_Zone(Zone_Working);
+ End_Subproblem();
+ goto Pop_Return;
+ }
-#ifndef No_In_Line_Lookup
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
- Variable_Object =
- Get_Pointer(Vector_Ref(Fetch_Expression(), ASSIGN_NAME));
- Compilation_Type = Variable_Object[VARIABLE_COMPILED_TYPE];
- The_Type = Type_Code(Compilation_Type);
-
- if (The_Type == LOCAL_REF)
- { fast Pointer *Frame;
- Frame = Get_Pointer(Fetch_Env());
- Val = Frame[Local_Offset(Compilation_Type)];
- if (Dangerous(Val))
- { Set_Danger_Bit(Store_Value);
- Clear_Danger_Bit(Val);
- }
- if (!Trap(Val))
- { Frame[Local_Offset(Compilation_Type)] = Store_Value;
- if (Val == UNASSIGNED_OBJECT) Val = The_Non_Object;
+ get_trap_kind(temp, *cell);
+ switch(temp)
+ {
+ case TRAP_DANGEROUS:
+ case TRAP_UNBOUND_DANGEROUS:
+ case TRAP_UNASSIGNED_DANGEROUS:
+ case TRAP_FLUID_DANGEROUS:
+ remove_lock(set_serializer);
+ cell = Get_Pointer(Vector_Ref(Fetch_Expression(), ASSIGN_NAME));
+ temp =
+ deep_assignment_end(deep_lookup(Fetch_Env(),
+ cell[VARIABLE_SYMBOL],
+ cell),
+ cell,
+ value,
+ false);
+ goto external_assignment_return;
+
+ case TRAP_UNASSIGNED:
+ Val = bogus_unassigned;
+ goto normal_assignment_done;
+
+ case TRAP_FLUID:
+ /* No need to recompile, pass the fake variable. */
+ remove_lock(set_serializer);
+ temp = deep_assignment_end(lookup_fluid(*cell),
+ fake_variable_object,
+ value,
+ false);
+
+ external_assignment_return:
+ Import_Val();
+ if (temp != PRIM_DONE)
+ break;
Set_Time_Zone(Zone_Working);
End_Subproblem();
+ goto Pop_Return;
+
+ case TRAP_UNBOUND:
+ remove_lock(set_serializer);
+ temp = ERR_UNBOUND_VARIABLE;
+ break;
+
+ default:
+ remove_lock(set_serializer);
+ temp = ERR_BROKEN_COMPILED_VARIABLE;
break;
- }
- }
- else if (The_Type == GLOBAL_REF)
- { Val = Vector_Ref(Compilation_Type, SYMBOL_GLOBAL_VALUE);
- if (!Dangerous(Val) && !Trap(Val))
- { Vector_Set(Compilation_Type, SYMBOL_GLOBAL_VALUE, Store_Value);
- if (Val == UNASSIGNED_OBJECT) Val = The_Non_Object;
- Set_Time_Zone(Zone_Working);
- End_Subproblem();
- break;
- }
- else if (Dangerous(Val))
- Variable_Object[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
}
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
- else if (The_Type == FORMAL_REF)
- { fast long Frame_No;
- fast Pointer *Frame;
-
- Frame = Get_Pointer(Fetch_Env());
- Frame_No = Get_Integer(Variable_Object[VARIABLE_FRAME_NO]);
- while(--Frame_No >= 0)
- Frame = Get_Pointer(Fast_Vector_Ref(Frame[HEAP_ENV_FUNCTION],
- PROCEDURE_ENVIRONMENT));
- Val = Frame[Local_Offset(Variable_Object[VARIABLE_OFFSET])];
- if (!Dangerous(Val) && !Trap(Val))
- { Frame[Local_Offset(Variable_Object[VARIABLE_OFFSET])] =
- Store_Value;
- if (Val==UNASSIGNED_OBJECT) Val = The_Non_Object;
- Set_Time_Zone(Zone_Working);
- End_Subproblem();
- break;
- }
- else if (Dangerous(Val))
- Variable_Object[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
+#else
+
+ Set_Time_Zone(Zone_Lookup);
+ Restore_Env();
+ temp = Lex_Set(Fetch_Env(),
+ Vector_Ref(Fetch_Expression(), ASSIGN_NAME),
+ value);
+ Import_Val();
+ if (temp == PRIM_DONE)
+ { End_Subproblem();
+ Set_Time_Zone(Zone_Working);
+ break;
}
+
#endif
- /* Fall through in cases not handled above */
- { long Result;
- Result = Lex_Set(Fetch_Env(),
- Vector_Ref(Fetch_Expression(), ASSIGN_NAME),
- Store_Value);
- Import_Val();
- Set_Time_Zone(Zone_Working);
- if (Result == PRIM_DONE)
- { End_Subproblem();
- break;
- }
- Save_Env();
- Pop_Return_Error(Result);
+
+ 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(IntCode & IntEnb);
}
/* Interpret() continues on the next page */
/* Interpret(), continued */
case RC_EXECUTE_DEFINITION_FINISH:
- { Pointer Saved_Val;
- long Result;
+ {
+ Pointer value;
+ long result;
- Saved_Val = Val;
+ value = Val;
Restore_Env();
- Result = Local_Set(Fetch_Env(),
+ Export_Registers();
+ result = Local_Set(Fetch_Env(),
Fast_Vector_Ref(Fetch_Expression(), DEFINE_NAME),
Val);
- Import_Val();
- if (Result==PRIM_DONE)
- { End_Subproblem();
+ Import_Registers();
+ if (result == PRIM_DONE)
+ {
+ End_Subproblem();
break;
}
Save_Env();
- if (Result==PRIM_INTERRUPT)
- { Prepare_Pop_Return_Interrupt(RC_EXECUTE_DEFINITION_FINISH,
- Saved_Val);
+ if (result == PRIM_INTERRUPT)
+ {
+ Prepare_Pop_Return_Interrupt(RC_EXECUTE_DEFINITION_FINISH,
+ value);
Interrupt(IntCode & IntEnb);
}
- Pop_Return_Error(Result);
- };
+ Val = value;
+ Pop_Return_Error(result);
+ }
case RC_EXECUTE_IN_PACKAGE_CONTINUE:
Pop_Return_Val_Check();
if (Environment_P(Val))
- { End_Subproblem();
+ {
+ End_Subproblem();
Store_Env(Val);
Reduces_To_Nth(IN_PACKAGE_EXPRESSION);
}
case RC_HALT:
Export_Registers();
Microcode_Termination(TERM_TERM_HANDLER);
-
-/* Interpret() continues on the next page */
\f
-/* Interpret(), continued */
+ case RC_INTERNAL_APPLY:
+
+Internal_Apply:
-#define Prepare_Apply_Interrupt() \
- Prepare_Pop_Return_Interrupt(RC_INTERNAL_APPLY, NIL)
+/* Branch here to perform a function application.
+
+ At this point the top of the stack contains an application frame
+ which consists of the following elements (see sdata.h):
+ - A header specifying the frame length.
+ - A procedure.
+ - The actual (evaluated) arguments.
+
+ No registers (except the stack pointer) are meaning full at this point.
+ Before interrupts or errors are processed, some registers are cleared
+ to avoid holding onto garbage if a garbage collection occurs.
+*/
+
+#define Prepare_Apply_Interrupt() \
+{ \
+ Store_Return(RC_INTERNAL_APPLY); \
+ Store_Expression(NIL); \
+ Save_Cont(); \
+}
#define Apply_Error(N) \
- { Store_Return(RC_INTERNAL_APPLY); \
- Val = NIL; \
- Pop_Return_Error(N); \
- }
+{ \
+ Store_Return(RC_INTERNAL_APPLY); \
+ Store_Expression(NIL); \
+ Val = NIL; \
+ Pop_Return_Error(N); \
+}
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
- case RC_INTERNAL_APPLY:
-Internal_Apply:
-
-/* Branch here to perform a function application. At this point
- it is necessary that the top of the stack contain a frame
- for evaluation of the function to be applied. This frame
- DOES NOT contain "finger" and "combination" slots, although
- if the frame is to be copied into the heap, it will have NIL's
- in the "finger" and "combination" slots which will correspond
- to "potentially-dangerous" and "auxilliary variables" slots.
-
- Note, also, that unlike most return codes Val is not used here.
- Thus, the error and interrupt macros above set it to NIL so that it
- will not 'hold on' to anything if a GC occurs. Similarly, the
- contents of Expression are discarded.
-*/
if (Microcode_Does_Stepping && Trapping &&
- (Fetch_Apply_Trapper() != NIL))
- { long Count = Get_Integer(Stack_Ref(STACK_ENV_HEADER));
+ (Fetch_Apply_Trapper() != NIL))
+ {
+ long Count;
+
+ Count = Get_Integer(Stack_Ref(STACK_ENV_HEADER));
Top_Of_Stack() = Fetch_Apply_Trapper();
Push(STACK_FRAME_HEADER+Count);
Stop_Trapping();
}
+
Apply_Non_Trapping:
- { long Interrupts;
- Pointer Function;
-
- Store_Expression(NIL);
- Interrupts = IntCode & IntEnb;
- if (Interrupts != 0)
- { Prepare_Apply_Interrupt();
- Interrupt(Interrupts);
- }
+
+ if ((IntCode & IntEnb) != 0)
+ {
+ long Interrupts;
+
+ Interrupts = (IntCode & IntEnb);
+ Store_Expression(NIL);
+ Val = NIL;
+ Prepare_Apply_Interrupt();
+ Interrupt(Interrupts);
+ }
Perform_Application:
+
+ Apply_Ucode_Hook();
+
+ {
+ fast Pointer Function;
+
Apply_Future_Check(Function, Stack_Ref(STACK_ENV_FUNCTION));
- Apply_Ucode_Hook();
+
+ switch(Type_Code(Function))
+ {
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
- switch(Type_Code(Function))
- { case TC_PROCEDURE:
- { Pointer Lambda_Expr, *Temp1, Temp2;
- long NParams, Size;
- fast long NArgs;
-
- Apply_Future_Check(Lambda_Expr,
- Fast_Vector_Ref(Function,
- PROCEDURE_LAMBDA_EXPR));
- Temp1 = Get_Pointer(Lambda_Expr);
- Apply_Future_Check(Temp2, Temp1[LAMBDA_FORMALS]);
- NArgs = Get_Integer(Pop());
- NParams = Vector_Length(Temp2);
- if (Eval_Debug)
- { Print_Expression(FIXNUM_0+NArgs,
- "APPLY: Number of arguments");
- Print_Expression(FIXNUM_0+NParams,
- " Number of parameters");
+ case TC_PROCEDURE:
+ {
+ fast long nargs;
+
+ nargs = Get_Integer(Pop());
+ Function = Fast_Vector_Ref(Function, PROCEDURE_LAMBDA_EXPR);
+
+ {
+ fast Pointer formals;
+
+ Apply_Future_Check(formals,
+ Fast_Vector_Ref(Function, LAMBDA_FORMALS));
+
+ if ((nargs != Vector_Length(formals)) &&
+ ((Type_Code(Function) != TC_LEXPR) ||
+ (nargs < Vector_Length(formals))))
+ {
+ Push(STACK_FRAME_HEADER + nargs - 1);
+ Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
+ }
}
- if (Type_Code(Lambda_Expr) == TC_LAMBDA)
- { if (NArgs != NParams)
- { Push(STACK_FRAME_HEADER+NArgs-1);
- Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
- }
+
+ if (Eval_Debug)
+ {
+ Print_Expression(Make_Unsigned_Fixnum(nargs),
+ "APPLY: Number of arguments");
}
- else if (NArgs < NParams)
- { Push(STACK_FRAME_HEADER+NArgs-1);
- Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
- }
- Size = NArgs + (HEAP_ENV_EXTRA_SLOTS - 1);
- if (GC_Check(Size))
- { Push(STACK_FRAME_HEADER+NArgs-1);
+
+ if (GC_Check(nargs + 1))
+ {
+ Push(STACK_FRAME_HEADER + nargs - 1);
Prepare_Apply_Interrupt();
- Immediate_GC(Size);
+ Immediate_GC(nargs + 1);
}
- /* Store Environment Frame into heap, putting extra slots
- for Potentially Dangerous and Auxiliaries */
- Store_Env(Make_Pointer(TC_ENVIRONMENT, Free));
- *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Size);
- *Free++ = NIL; /* For PD list and Aux list */
- *Free++ = NIL;
- for (; --NArgs >= 0; ) *Free++ = Pop();
- Reduces_To(Temp1[LAMBDA_SCODE]);
+
+ {
+ fast Pointer *scan;
+
+ scan = Free;
+ Store_Env(Make_Pointer(TC_ENVIRONMENT, scan));
+ *scan++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, nargs);
+ while(--nargs >= 0)
+ *scan++ = Pop();
+ Free = scan;
+ Reduces_To(Fast_Vector_Ref(Function, LAMBDA_SCODE));
+ }
}
/* Interpret() continues on the next page */
/* Interpret(), continued */
case TC_CONTROL_POINT:
+ {
if (Get_Integer(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();
Our_Throw_Part_2();
goto Pop_Return;
+ }
+
+/* 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.
+ */
+
+ case TC_PRIMITIVE:
+ {
+ if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) !=
+ STACK_ENV_FIRST_ARG + N_Args_Primitive(Get_Integer(Function)) - 1)
+ {
+ Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
+ }
+ Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG);
+ Store_Expression(Function);
+ goto Prim_No_Trap_Apply;
+ }
case TC_PRIMITIVE_EXTERNAL:
- { long NArgs, Proc = Datum(Function);
+ {
+ fast long NArgs, Proc;
+
+ Proc = Datum(Function);
if (Proc > MAX_EXTERNAL_PRIMITIVE)
+ {
Apply_Error(ERR_UNDEFINED_PRIMITIVE);
+ }
NArgs = Ext_Prim_Desc[Proc].arity;
if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) !=
- STACK_ENV_FIRST_ARG+NArgs-1)
+ (NArgs + (STACK_ENV_FIRST_ARG - 1)))
+ {
Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
+ }
Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG);
- /* Remove the frame overhead, since the primitives
- just expect arguments on the stack */
Store_Expression(Function);
+
Repeat_External_Primitive:
/* Reinitialize Proc in case we "goto Repeat_External..." */
Proc = Get_Integer(Fetch_Expression());
- Export_Registers();
+
+ Export_Registers_Before_Primitive();
Val = (*(Ext_Prim_Desc[Proc].proc))();
Set_Time_Zone(Zone_Working);
- Import_Registers_Except_Val();
+ Import_Registers_After_Primitive();
Pop_Primitive_Frame(Ext_Prim_Desc[Proc].arity);
+
goto Pop_Return;
}
/* Interpret(), continued */
case TC_EXTENDED_PROCEDURE:
- { Pointer Lambda_Expr, *List_Car, Temp;
- long NArgs, NParams, Formals, Params, Auxes,
- Rest_Flag, Size, i;
-
-/* Selectors for the various parts */
-
-#define Get_Body_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_SCODE))
-#define Get_Names_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_NAMES))
-#define Get_Count_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_ARG_COUNT))
-#define Elambda_Formals_Count(Addr) \
- ((((long) Addr) & EL_FORMALS_MASK) >> EL_FORMALS_SHIFT)
-#define Elambda_Opts_Count(Addr) \
- (((long) Addr) & EL_OPTS_MASK)
-#define Elambda_Rest_Flag(Addr) \
- ((((long) Addr) & EL_REST_MASK) >> EL_REST_SHIFT)
-
- Apply_Future_Check(Lambda_Expr,
- Fast_Vector_Ref(Function,
- PROCEDURE_LAMBDA_EXPR));
- Apply_Future_Check(Temp, Fast_Vector_Ref(Lambda_Expr,
- ELAMBDA_NAMES));
- NParams = Vector_Length(Temp) - 1;
- Apply_Future_Check(Temp, Get_Count_Elambda(Lambda_Expr));
- Formals = Elambda_Formals_Count(Temp);
- /* Formals DOES NOT include the name of the lambda */
- Params = Elambda_Opts_Count(Temp) + Formals;
- Rest_Flag = Elambda_Rest_Flag(Temp);
- NArgs = Get_Integer(Pop()) - 1;
- Auxes = NParams - (Params + Rest_Flag);
- if ((NArgs < Formals) ||
- (!Rest_Flag && (NArgs > Params)))
- { Push(STACK_FRAME_HEADER+NArgs);
+ {
+ Pointer lambda;
+ long nargs, nparams, formals, params, auxes,
+ rest_flag, size;
+
+ fast long i;
+ fast Pointer *scan;
+
+ nargs = Get_Integer(Pop()) - STACK_FRAME_HEADER;
+
+ if (Eval_Debug)
+ {
+ Print_Expression(Make_Unsigned_Fixnum(nargs+STACK_FRAME_HEADER),
+ "APPLY: Number of arguments");
+ }
+
+ lambda = Fast_Vector_Ref(Function, PROCEDURE_LAMBDA_EXPR);
+ Apply_Future_Check(Function,
+ Fast_Vector_Ref(lambda, ELAMBDA_NAMES));
+ nparams = Vector_Length(Function) - 1;
+
+ Apply_Future_Check(Function, Get_Count_Elambda(lambda));
+ formals = Elambda_Formals_Count(Function);
+ params = Elambda_Opts_Count(Function) + formals;
+ rest_flag = Elambda_Rest_Flag(Function);
+ auxes = nparams - (params + rest_flag);
+
+ if ((nargs < formals) || (!rest_flag && (nargs > params)))
+ {
+ Push(STACK_FRAME_HEADER + nargs);
Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
}
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- Size = Params + Rest_Flag + Auxes +
- (HEAP_ENV_EXTRA_SLOTS + 1);
- List_Car = Free + Size;
- if (GC_Check(Size + ((NArgs > Params) ?
- 2 * (NArgs - Params) : 0)))
- { Push(STACK_FRAME_HEADER+NArgs);
+ /* 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)))
+ {
+ Push(STACK_FRAME_HEADER + nargs);
Prepare_Apply_Interrupt();
- Immediate_GC(Size + ((NArgs > Params) ?
- 2 * (NArgs - Params) : 0));
+ Immediate_GC(size + 1 + ((nargs > params) ?
+ (2 * (nargs - params)) :
+ 0));
}
- Store_Env(Make_Pointer(TC_ENVIRONMENT, Free));
- *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Size-1);
- /* Environment Header */
- *Free++ = NIL; /* Aux list */
- *Free++ = NIL; /* PD list */
- Size = 1 + ((NArgs < Params) ? NArgs : Params);
- for (i = 0; i < Size; i++) *Free++ = Pop();
- for (i--; i < Params; i++)
- *Free++ = UNASSIGNED_OBJECT;
- if (Rest_Flag)
- if (NArgs <= i) *Free++ = NIL;
- else
- { *Free++ = Make_Pointer(TC_LIST, List_Car);
- for (; i < NArgs; i++, List_Car++)
- { *List_Car++ = Pop();
- *List_Car = Make_Pointer(TC_LIST, List_Car+1);
- }
- List_Car[-1] = NIL;
- }
- for (i = 0; i < Auxes; i++) *Free++ = UNASSIGNED_OBJECT;
- Free = List_Car;
- Reduces_To(Get_Body_Elambda(Lambda_Expr));
- }
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
- case TC_PRIMITIVE:
- { long Number_Of_Args = N_Args_Primitive(Function);
- if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) !=
- STACK_ENV_FIRST_ARG+Number_Of_Args-1)
- Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
- Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG);
- /* Remove the frame overhead, since the primitives
- just expect arguments on the stack */
- Store_Expression(Function);
- goto Prim_No_Trap_Apply;
+ scan = Free;
+ Store_Env(Make_Pointer(TC_ENVIRONMENT, scan));
+ *scan++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, size);
+
+ if (nargs <= params)
+ {
+ for (i = (nargs + 1); --i >= 0; )
+ *scan++ = Pop();
+ for (i = (params - nargs); --i >= 0; )
+ *scan++ = UNASSIGNED_OBJECT;
+ if (rest_flag)
+ *scan++ = NIL;
+ for (i = auxes; --i >= 0; )
+ *scan++ = UNASSIGNED_OBJECT;
+ }
+ else
+ {
+ /* rest_flag must be true. */
+ Pointer list;
+
+ list = Make_Pointer(TC_LIST, (scan + size));
+ for (i = (params + 1); --i >= 0; )
+ *scan++ = Pop();
+ *scan++ = list;
+ for (i = auxes; --i >= 0; )
+ *scan++ = UNASSIGNED_OBJECT;
+ /* Now scan == Get_Pointer(list) */
+ for (i = (nargs - params); --i >= 0; )
+ {
+ *scan++ = Pop();
+ *scan = Make_Pointer(TC_LIST, (scan + 1));
+ scan += 1;
+ }
+ scan[-1] = NIL;
+ }
+
+ Free = scan;
+ Reduces_To(Get_Body_Elambda(lambda));
}
/* Interpret() continues on the next page */
/* Interpret(), continued */
case TC_COMPILED_PROCEDURE:
- { apply_compiled_setup(STACK_ENV_EXTRA_SLOTS +
+ {
+ apply_compiled_setup(STACK_ENV_EXTRA_SLOTS +
Get_Integer( Stack_Ref( STACK_ENV_HEADER)));
Export_Registers();
Which_Way = apply_compiled_procedure();
break; /* We never get here.... */
}
-/* case RC_RESTORE_VALUE is with RC_POP_RETURN_ERROR */
-
case RC_RETURN_TRAP_POINT:
Store_Return(Old_Return_Code);
Will_Push(CONTINUATION_SIZE+3);
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/object.h,v 9.20 1987/01/21 20:24:48 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/object.h,v 9.21 1987/04/03 00:18:15 jinx Exp $ */
/* This file contains definitions pertaining to the C view of
Scheme pointers: widths of fields, extraction macros, pre-computed
#define TYPE_CODE_LENGTH 8 /* Not CHAR_SIZE!! */
#define MAX_TYPE_CODE 0xFF /* ((1<<TYPE_CODE_LENGTH) - 1) */
-/* The danger bit is set in the value cell of an environment whenever a
- particular binding of a variable to a value has been shadowed by an
- auxiliary variable in a nested environment. It means that variables
- cached to this address must be recached since the address may be invalid.
- See lookup.c */
+/* The danger bit is being phased out. It is currently used by stacklets
+ and the history mechanism. The variable lookup code no longer uses it.
+ */
#define DANGER_TYPE 0x80 /* (1<<(TYPE_CODE_LENGTH-1)) */
#define MAX_SAFE_TYPE 0x7F /* (MAX_TYPE_CODE & ~DANGER_TYPE) */
extern Pointer *Memory_Base;
-/* The "-1" in the value returned is guarantee that there is one
+/* The "-1" in the value returned is a guarantee that there is one
word reserved exclusively for use by the garbage collector. */
-#define Allocate_Heap_Space(space) \
- (Memory_Base = ((Pointer *) (malloc ((sizeof (Pointer)) * (space)))), \
- Heap = Memory_Base, \
+#define Allocate_Heap_Space(space) \
+ (Memory_Base = ((Pointer *) (malloc ((sizeof (Pointer)) * (space)))), \
+ Heap = Memory_Base, \
((Memory_Base + (space)) - 1))
#define Get_Pointer(P) ((Pointer *) (Memory_Base + (pointer_datum (P))))
#define User_Vector_Ref(P, N) Vector_Ref(P, (N)+1)
#define User_Vector_Set(P, N, S) Vector_Set(P, (N)+1, S)
\f
-#ifdef FLOATING_ALIGNMENT
-
-#define Align_Float(Where) \
-while ((((long) ((Where) + 1)) & FLOATING_ALIGNMENT) != 0) \
- *Where++ = (Make_Non_Pointer (TC_MANIFEST_NM_VECTOR, 0));
-
-#else /* ifdef FLOATING_ALIGNMENT */
-
-#define Align_Float(Where)
-
-#endif /* ifdef FLOATING_ALIGNMENT */
-
#define fixnum_p(P) ((pointer_type (P)) == TC_FIXNUM)
#define Get_Float(P) (* ((double *) (Nth_Vector_Loc ((P), 1))))
#define Get_Integer(P) (pointer_datum (P))
(! (Is_Constant (Get_Pointer (Will_Contain)))) && \
(Pure_Test (Get_Pointer (Old_Pointer)))) \
Primitive_Error (ERR_WRITE_INTO_PURE_SPACE);
+\f
+#ifdef FLOATING_ALIGNMENT
+
+#define FLOATING_BUFFER_SPACE \
+ ((FLOATING_ALIGNMENT + 1)/sizeof(Pointer))
+
+#define HEAP_BUFFER_SPACE \
+ (TRAP_MAX_IMMEDIATE + 1 + FLOATING_BUFFER_SPACE)
+
+/* The space is there, find the correct position. */
+
+#define Initial_Align_Float(Where) \
+{ \
+ while ((((long) ((Where) + 1)) & FLOATING_ALIGNMENT) != 0) \
+ Where -= 1; \
+}
+
+#define Align_Float(Where) \
+{ \
+ while ((((long) ((Where) + 1)) & FLOATING_ALIGNMENT) != 0) \
+ *Where++ = (Make_Non_Pointer (TC_MANIFEST_NM_VECTOR, 0)); \
+}
+
+#else not FLOATING_ALIGNMENT
+
+#define HEAP_BUFFER_SPACE (TRAP_MAX_IMMEDIATE + 1)
+
+#define Initial_Align_Float(Where)
+#define Align_Float(Where)
+
+#endif FLOATING_ALIGNMENT
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/ppband.c,v 9.23 1987/02/11 18:09:32 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/ppband.c,v 9.24 1987/04/03 00:06:29 jinx Exp $
*
* Dumps Scheme FASL in user-readable form .
*/
{ Pointer *symbol;
symbol = &Data[From+SYMBOL_NAME];
if ((symbol >= end_of_memory) ||
- scheme_string(via(From+SYMBOL_NAME), false))
+ !scheme_string(via(From+SYMBOL_NAME), false))
printf("symbol not in memory; datum = %x\n", From);
return;
}
return;
case TC_CHARACTER_STRING: scheme_string(Points_To, true);
return;
- case TC_EXTENDED_FIXNUM: printf("%d\n", The_Datum);
- return;
case TC_FIXNUM: printf("%d\n", Points_To);
return;
/* Default cases */
- case TC_LIST: printf("[CONS "); break;
- case TC_WEAK_CONS: printf("[WEAK-CONS "); break;
- case TC_SCODE_QUOTE: printf("[QUOTE "); break;
- case TC_BIG_FLONUM: printf("[FLONUM "); break;
- case TC_COMBINATION_1: printf( "[COMB-1 "); break;
- case TC_EXTENDED_PROCEDURE: printf("[EPROCEDURE "); break;
- case TC_COMBINATION_2: printf("[COMB-2 "); break;
- case TC_BIG_FIXNUM: printf("[BIGNUM "); break;
+ case TC_LIST: printf("[LIST "); break;
+ case TC_CHARACTER: printf("[CHARACTER "); break;
+ case TC_SCODE_QUOTE: printf("[SCODE-QUOTE "); break;
+ case TC_PCOMB2: printf("[PCOMB2 "); break;
+ case TC_BIG_FLONUM: printf("[BIG-FLONUM "); break;
+ case TC_COMBINATION_1: printf("[COMBINATION-1 "); break;
+ case TC_EXTENDED_PROCEDURE: printf("[EXTENDED-PROCEDURE "); break;
+ case TC_VECTOR: printf("[VECTOR "); break;
+ case TC_RETURN_CODE: printf("[RETURN-CODE "); break;
+ case TC_COMBINATION_2: printf("[COMBINATION-2 "); break;
+ case TC_COMPILED_PROCEDURE: printf("[COMPILED-PROCEDURE "); break;
+ case TC_BIG_FIXNUM: printf("[BIG-FIXNUM "); break;
case TC_PROCEDURE: printf("[PROCEDURE "); break;
- case TC_PRIMITIVE_EXTERNAL: printf("[EXTERNAL-PRIMITIVE "); break;
+ case TC_PRIMITIVE_EXTERNAL: printf("[PRIMITIVE-EXTERNAL "); break;
case TC_DELAY: printf("[DELAY "); break;
+ case TC_ENVIRONMENT: printf("[ENVIRONMENT "); break;
case TC_DELAYED: printf("[DELAYED "); break;
- case TC_EXTENDED_LAMBDA: printf("[ELAMBDA "); break;
+ case TC_EXTENDED_LAMBDA: printf("[EXTENDED-LAMBDA "); break;
case TC_COMMENT: printf("[COMMENT "); break;
case TC_NON_MARKED_VECTOR: printf("[NON-MARKED-VECTOR "); break;
case TC_LAMBDA: printf("[LAMBDA "); break;
case TC_PRIMITIVE: printf("[PRIMITIVE "); break;
- case TC_SEQUENCE_2: printf("[SEQ-2 "); break;
- case TC_PCOMB1: printf("[PCOMB-1 "); break;
+ case TC_SEQUENCE_2: printf("[SEQUENCE-2 "); break;
+ case TC_PCOMB1: printf("[PCOMB1 "); break;
+ case TC_CONTROL_POINT: printf("[CONTROL-POINT "); break;
case TC_ACCESS: printf("[ACCESS "); break;
case TC_DEFINITION: printf("[DEFINITION "); break;
case TC_ASSIGNMENT: printf("[ASSIGNMENT "); break;
case TC_HUNK3: printf("[HUNK3 "); break;
case TC_IN_PACKAGE: printf("[IN-PACKAGE "); break;
+ case TC_COMBINATION: printf("[COMBINATION "); break;
+ case TC_COMPILED_EXPRESSION: printf("[COMPILED-EXPRESSION "); break;
case TC_LEXPR: printf("[LEXPR "); break;
+ case TC_PCOMB3: printf("[PCOMB3 "); break;
+
case TC_VARIABLE: printf("[VARIABLE "); break;
- case TC_CONDITIONAL: printf("[CONDITIONAL "); break;
- case TC_DISJUNCTION: printf("[DISJUNCTION "); break;
- case TC_UNASSIGNED: printf("[UNASSIGNED "); break;
- case TC_SEQUENCE_3: printf("[SEQUENCE-3 "); break;
- case TC_CHARACTER: printf("[CHARACTER "); break;
- case TC_PCOMB2: printf("[PCOMB-2 "); break;
- case TC_VECTOR: printf("[VECTOR "); break;
- case TC_RETURN_CODE: printf("[RETURN-CODE "); break;
- case TC_ENVIRONMENT: printf("[ENVIRONMENT "); break;
- case TC_CONTROL_POINT: printf("[CONTROL-POINT "); break;
- case TC_COMBINATION: printf("[COMBINATION "); break;
- case TC_PCOMB3: printf("[PCOMB-3 "); break;
case TC_THE_ENVIRONMENT: printf("[THE-ENVIRONMENT "); break;
+ case TC_FUTURE: printf("[FUTURE "); break;
case TC_VECTOR_1B: printf("[VECTOR-1B "); break;
- case TC_PCOMB0: printf("[PCOMB-0 "); break;
+ case TC_PCOMB0: printf("[PCOMB0 "); break;
case TC_VECTOR_16B: printf("[VECTOR-16B "); break;
+ case TC_SEQUENCE_3: printf("[SEQUENCE-3 "); break;
+ case TC_CONDITIONAL: printf("[CONDITIONAL "); break;
+ case TC_DISJUNCTION: printf("[DISJUNCTION "); break;
case TC_CELL: printf("[CELL "); break;
- case TC_FUTURE: printf("[FUTURE "); break;
- case TC_COMPILED_PROCEDURE: printf("[COMPILED-PROCEDURE "); break;
- case TC_COMPILED_EXPRESSION: printf("[COMPILED-EXPRESSION "); break;
+ case TC_WEAK_CONS: printf("[WEAK-CONS "); break;
+ case TC_REFERENCE_TRAP: printf("[REFERENCE-TRAP "); break;
case TC_RETURN_ADDRESS: printf("[RETURN-ADDRESS "); break;
+ case TC_COMPILER_LINK: printf("[COMPILER-LINK "); break;
+ case TC_STACK_ENVIRONMENT: printf("[STACK-ENVIRONMENT "); break;
+ case TC_COMPLEX: printf("[COMPLEX "); break;
+ case TC_QUAD: printf("[QUAD "); break;
default: printf("[02x%x ", Type); break;
}
printf("%x]\n", Points_To);
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/psbtobin.c,v 9.21 1987/01/22 14:13:43 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbtobin.c,v 9.22 1987/04/03 00:06:48 jinx Exp $
*
* This File contains the code to translate portable format binary
* files to internal format.
/* Align_Float(To); */
while (--N >= 0)
{ fscanf(Portable_File, "%2x %lx", &The_Type, &The_Datum);
- switch((The_Type) & SAFE_TYPE_MASK)
+ switch(The_Type)
{ case CONSTANT_CODE:
- if (The_Type > MAX_SAFE_TYPE)
- { *To = Constant_Table[The_Datum];
- Set_Danger_Bit(*To++);
- continue;
- }
*To++ = Constant_Table[The_Datum];
continue;
case HEAP_CODE:
- if (The_Type > MAX_SAFE_TYPE)
- { *To = Heap_Table[The_Datum];
- Set_Danger_Bit(*To++);
- continue;
- }
*To++ = Heap_Table[The_Datum];
continue;
*To++ = Make_Non_Pointer(The_Type, The_Datum);
continue;
+ case TC_REFERENCE_TRAP:
+ if (The_Datum <= TRAP_MAX_IMMEDIATE)
+ {
+ *To++ = Make_Non_Pointer(The_Type, The_Datum);
+ continue;
+ }
+ /* It is a pointer, fall through. */
default:
/* Should be stricter */
*To++ = Make_Pointer(The_Type, Relocate(The_Datum));
Read_Flags(Flags);
Size = (6 + /* SNMV */
+ HEAP_BUFFER_SPACE +
Heap_Count + Heap_Objects +
Constant_Count + Constant_Objects +
Pure_Count + Pure_Objects +
Program_Name, Size);
exit(1);
}
- return Size;
+ Heap += HEAP_BUFFER_SPACE;
+ Initial_Align_Float(Heap);
+ return (Size - HEAP_BUFFER_SPACE);
}
\f
do_it()
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/types.h,v 9.21 1987/01/22 14:34:14 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/types.h,v 9.22 1987/04/03 00:21:38 jinx Exp $
*
* Type code definitions, numerical order
*
*/
\f
#define TC_NULL 0x00
-#define TC_FALSE 0x00
-#define TC_MANIFEST_VECTOR 0x00
-#define GLOBAL_ENV 0x00
-
#define TC_LIST 0x01
#define TC_CHARACTER 0x02
#define TC_SCODE_QUOTE 0x03
-#define TC_PCOMB2 0x04 /* Was 0x44 */
+#define TC_PCOMB2 0x04
#define TC_UNINTERNED_SYMBOL 0x05
#define TC_BIG_FLONUM 0x06
#define TC_COMBINATION_1 0x07
#define TC_TRUE 0x08
#define TC_EXTENDED_PROCEDURE 0x09
-#define TC_VECTOR 0x0A /* Was 0x46 */
-#define TC_RETURN_CODE 0x0B /* Was 0x48 */
+#define TC_VECTOR 0x0A
+#define TC_RETURN_CODE 0x0B
#define TC_COMBINATION_2 0x0C
-#define TC_COMPILED_PROCEDURE 0x0D /* Was 0x49 */
+#define TC_COMPILED_PROCEDURE 0x0D
#define TC_BIG_FIXNUM 0x0E
#define TC_PROCEDURE 0x0F
#define TC_PRIMITIVE_EXTERNAL 0x10
#define TC_DELAY 0x11
-#define TC_ENVIRONMENT 0x12 /* Was 0x4E */
+#define TC_ENVIRONMENT 0x12
#define TC_DELAYED 0x13
#define TC_EXTENDED_LAMBDA 0x14
#define TC_COMMENT 0x15
#define TC_PRIMITIVE 0x18
#define TC_SEQUENCE_2 0x19
\f
-#define TC_FIXNUM 0x1A /* Was 0x50 */
-#define TC_ADDRESS 0x1A
- /* Notice that TC_FIXNUM and TC_ADDRESS are the same */
+#define TC_FIXNUM 0x1A
#define TC_PCOMB1 0x1B
-#define TC_CONTROL_POINT 0x1C /* Was 0x56 */
+#define TC_CONTROL_POINT 0x1C
#define TC_INTERNED_SYMBOL 0x1D
#define TC_CHARACTER_STRING 0x1E
-#define TC_VECTOR_8B 0x1E
- /* VECTOR_8B and STRING are the same */
#define TC_ACCESS 0x1F
-#define TC_EXTENDED_FIXNUM 0x20 /* Not used */
+/* UNUSED 0x20 */ /* Used to be EXTENDED_FIXNUM. */
#define TC_DEFINITION 0x21
-#define TC_BROKEN_HEART 0x22 /* Was 0x58 */
+#define TC_BROKEN_HEART 0x22
#define TC_ASSIGNMENT 0x23
#define TC_HUNK3 0x24
#define TC_IN_PACKAGE 0x25
-#define TC_COMBINATION 0x26 /* Was 0x5E */
-#define TC_MANIFEST_NM_VECTOR 0x27 /* Was 0x60 */
+#define TC_COMBINATION 0x26
+#define TC_MANIFEST_NM_VECTOR 0x27
#define TC_COMPILED_EXPRESSION 0x28
#define TC_LEXPR 0x29
-#define TC_PCOMB3 0x2A /* Was 0x66 */
-#define TC_MANIFEST_SPECIAL_NM_VECTOR 0x2B /* Was 0x68 */
+#define TC_PCOMB3 0x2A
+#define TC_MANIFEST_SPECIAL_NM_VECTOR 0x2B
#define TC_VARIABLE 0x2C
-#define TC_THE_ENVIRONMENT 0x2D /* Was 0x70 */
+#define TC_THE_ENVIRONMENT 0x2D
#define TC_FUTURE 0x2E
-#define TC_VECTOR_1B 0x2F /* Was 0x76 */
-#define TC_BIT_STRING 0x2F /* Was 0x76 */
- /* Notice TC_VECTOR_1B and TC_BIT_STRING are the same */
-#define TC_PCOMB0 0x30 /* Was 0x78 */
-#define TC_VECTOR_16B 0x31 /* Was 0x7E */
-#define TC_UNASSIGNED 0x32 /* Was 0x38 */
-#define TC_SEQUENCE_3 0x33 /* Was 0x3C */
+#define TC_VECTOR_1B 0x2F
+#define TC_PCOMB0 0x30
+#define TC_VECTOR_16B 0x31
+#define TC_REFERENCE_TRAP 0x32 /* Used to be UNASSIGNED. */
+#define TC_SEQUENCE_3 0x33
#define TC_CONDITIONAL 0x34
#define TC_DISJUNCTION 0x35
#define TC_CELL 0x36
#define TC_WEAK_CONS 0x37
-#define TC_TRAP 0x38
+#define TC_QUAD 0x38 /* Used to be TC_TRAP. */
#define TC_RETURN_ADDRESS 0x39
#define TC_COMPILER_LINK 0x3A
#define TC_STACK_ENVIRONMENT 0x3B
#define TC_COMPLEX 0x3C
-#if defined(MC68020)
-
-#define TC_PEA_INSTRUCTION 0x48
-#define TC_JMP_INSTRUCTION 0x4E
-#define TC_DBF_INSTRUCTION 0x51
+/* If you add a new type, don't forget to update gccode.h and gctype.c */
-#endif
+/* Aliases */
-/* If you add a new type, don't forget to update gccode.h and gctype.c */
+#define TC_FALSE TC_NULL
+#define TC_MANIFEST_VECTOR TC_NULL
+#define GLOBAL_ENV TC_NULL
+#define TC_BIT_STRING TC_VECTOR_1B
+#define TC_VECTOR_8B TC_CHARACTER_STRING
+#define TC_ADDRESS TC_FIXNUM
;;;; Machine Dependent Type Tables
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.23 1987/03/12 17:48:32 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.24 1987/04/03 00:22:18 jinx Exp $
(declare (usual-integrations))
INTERNED-SYMBOL ;1D
(STRING CHARACTER-STRING VECTOR-8B) ;1E
ACCESS ;1F
- EXTENDED-FIXNUM ;20
+ #F ;20
DEFINITION ;21
BROKEN-HEART ;22
ASSIGNMENT ;23
VECTOR-1B ;2F
PRIMITIVE-COMBINATION-0 ;30
VECTOR-16B ;31
- UNASSIGNED ;32
+ (REFERENCE-TRAP UNASSIGNED) ;32
SEQUENCE-3 ;33
CONDITIONAL ;34
DISJUNCTION ;35
CELL ;36
WEAK-CONS ;37
- TRAP ;38
+ QUAD ;38
COMPILER-RETURN-ADDRESS ;39
COMPILER-LINK ;3A
STACK-ENVIRONMENT ;3B
#F ;45
#F ;46
#F ;47
- #F ;48 reserved for PEA instruction on 68000
+ #F ;48
#F ;49
#F ;4A
#F ;4B
#F ;4C
#F ;4D
- #F ;4E reserved for JMP/JSR instruction on 68000
+ #F ;4E
#F ;4F
#F ;50
- #F ;51 reserved for DBF instruction on 68000
+ #F ;51
#F ;52
#F ;53
#F ;54
#F ;7F
))
\f
-;;; [] Return
+;;; [] Returns
(vector-set! (get-fixed-objects-vector)
5 ;(fixed-objects-vector-slot 'MICROCODE-RETURNS-VECTOR)
RE-MATCH ;$192
RE-SEARCH-FORWARD ;$193
RE-SEARCH-BACKWARD ;$194
- SYSTEM-MEMORY-REF ;$195
- SYSTEM-MEMORY-SET! ;$196
+ (SYSTEM-MEMORY-REF &OBJECT-REF) ;$195
+ (SYSTEM-MEMORY-SET! &OBJECT-SET!) ;$196
BIT-STRING-FILL! ;$197
BIT-STRING-MOVE! ;$198
BIT-STRING-MOVEC! ;$199
WRITE-INTO-PURE-SPACE ;1A
#F ;1B
#F ;1C
- ASSIGN-LAMBDA-NAME ;1D
+ #F ;1D
FAILED-ARG-1-COERCION ;1E
FAILED-ARG-2-COERCION ;1F
OUT-OF-FILE-HANDLES ;20
WRONG-TYPE-ARGUMENT-7 ;2D
WRONG-TYPE-ARGUMENT-8 ;2E
WRONG-TYPE-ARGUMENT-9 ;2F
+ INAPPLICABLE-CONTINUATION ;30
+ COMPILED-CODE-ERROR ;31
+ FLOATING-OVERFLOW ;32
+ UNIMPLEMENTED-PRIMITIVE ;33
))
\f
;;; [] Terminations
;;; This identification string is saved by the system.
-"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.23 1987/03/12 17:48:32 jinx Exp $"
+"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.24 1987/04/03 00:22:18 jinx Exp $"
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/version.h,v 9.34 1987/03/12 17:44:30 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 9.35 1987/04/03 00:23:01 jinx Exp $
This file contains version information for the microcode. */
\f
#define VERSION 9
#endif
#ifndef SUBVERSION
-#define SUBVERSION 34
+#define SUBVERSION 35
#endif
#ifndef UCODE_TABLES_FILENAME
projects / mit-scheme.git / commitdiff