opposite value from that desired.
2) Eliminate all remaining uses of Request_Interrupt .
3) Clean up the eventual pushing stuff in interpret.c .
4) Fix a potential stacklet bug in error-procedure.
5) Make the compiled code interface always update memtop on interrupts
or gc.
6) Eliminate some code in non-stacklet version in interpret.c
7) Bintopsb and Psbtobin have been updated to handle compiled code.
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.29 1987/11/17 08:02:39 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bintopsb.c,v 9.30 1987/11/20 08:21:12 jinx Exp $
*
* This File contains the code to translate internal format binary
* files to portable format.
\f
/* Global data */
-static Boolean Shuffle_Bytes = false;
-static Boolean upgrade_traps = false;
-static Boolean upgrade_primitives = false;
-
/* Needed to upgrade */
#define TC_PRIMITIVE_EXTERNAL 0x10
-static Boolean upgrade_lengths = false;
-
#define STRING_LENGTH_TO_LONG(value) \
-((long) (upgrade_lengths ? Get_Integer(value) : (value)))
-
-static Pointer *Mem_Base;
-static long Heap_Relocation, Constant_Relocation;
-static long Free, Scan, Free_Constant, Scan_Constant;
-static long Objects, Constant_Objects;
-static Pointer *Free_Objects, *Free_Cobjects;
-static Pointer *primitive_table;
-
-static long NFlonums;
-static long NIntegers, NBits;
-static long NBitstrs, NBBits;
-static long NStrings, NChars;
-static long NPChars;
+((long) (upgrade_lengths_p ? Get_Integer(value) : (value)))
+
+static Boolean
+ shuffle_bytes_p = false,
+ upgrade_traps_p = false,
+ upgrade_primitives_p = false,
+ upgrade_lengths_p = false,
+ allow_compiled_p = false,
+ allow_nmv_p = false;
+
+static long
+ Heap_Relocation, Constant_Relocation,
+ Free, Scan, Free_Constant, Scan_Constant,
+ Objects, Constant_Objects;
+
+static Pointer
+ *Mem_Base,
+ *Free_Objects, *Free_Cobjects,
+ *compiled_entry_table, *compiled_entry_pointer, *compiled_entry_table_end,
+ *primitive_table, *primitive_table_end;
+
+static long
+ NFlonums,
+ NIntegers, NBits,
+ NBitstrs, NBBits,
+ NStrings, NChars,
+ NPChars;
\f
#define OUT(s) \
-fprintf(Portable_File, s); \
-break
+{ \
+ fprintf(Portable_File, (s)); \
+ break; \
+}
void
print_a_char(c, name)
fast char *string;
{
fprintf(Portable_File, "%ld ", len);
- if (Shuffle_Bytes)
+ if (shuffle_bytes_p)
{
while(len > 0)
{
fprintf(Portable_File,
"%02x %ld ",
TC_CHARACTER_STRING,
- (Compact_P ? len : maxlen));
+ (compact_p ? len : maxlen));
print_a_string_internal(len, ((char *) from));
return;
if (temp == 0)
{
fprintf(Portable_File, "%02x + 0\n",
- (Compact_P ? TC_FIXNUM : TC_BIG_FIXNUM));
+ (compact_p ? TC_FIXNUM : TC_BIG_FIXNUM));
}
else
{
}
\f
fprintf(Portable_File, "%02x %c %ld ",
- (Compact_P ? TC_FIXNUM : TC_BIG_FIXNUM),
+ (compact_p ? TC_FIXNUM : TC_BIG_FIXNUM),
(NEG_BIGNUM(the_number) ? '-' : '+'),
size_in_bits);
tail = size_in_bits % SHIFT;
} \
}
\f
+#define Copy_Vector(Scn, Fre) \
+{ \
+ fast long len; \
+ \
+ len = OBJECT_DATUM(Old_Contents); \
+ *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
+ Mem_Base[(Fre)++] = Old_Contents; \
+ while (--len >= 0) \
+ { \
+ Mem_Base[(Fre)++] = *Old_Address++; \
+ } \
+}
+
#define Do_Vector(Code, Rel, Fre, Scn, Obj, FObj) \
{ \
Old_Address += (Rel); \
Old_Contents = *Old_Address; \
\
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ if (OBJECT_TYPE(Old_Contents) == TC_BROKEN_HEART) \
{ \
- Mem_Base[(Scn)] = Make_New_Pointer(Type_Code(This), Old_Contents); \
+ Mem_Base[(Scn)] = Make_New_Pointer(OBJECT_TYPE(This), \
+ Old_Contents); \
} \
else \
{ \
- fast long len; \
+ Mem_Base[(Scn)] = Make_Non_Pointer(OBJECT_TYPE(This), (Fre)); \
+ Copy_Vector(Scn, Fre); \
+ } \
+}
+\f
+#define Do_Compiled_Entry(COde, Rel, Fre, Scn, Obj, FObj) \
+{ \
+ long offset; \
+ Pointer *saved; \
\
- len = Get_Integer(Old_Contents); \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- while (len > 0) \
- { \
- Mem_Base[(Fre)++] = *Old_Address++; \
- len -= 1; \
- } \
+ Old_Address += (Rel); \
+ saved = Old_Address; \
+ Get_Compiled_Block(Old_Address, saved); \
+ Old_Contents = *Old_Address; \
+ \
+ Mem_Base[(Scn)] = \
+ Make_Non_Pointer(TC_COMPILED_EXPRESSION, \
+ (compiled_entry_pointer - compiled_entry_table)); \
+ \
+ offset = (((char *) saved) - ((char *) Old_Address)); \
+ *compiled_entry_pointer++ = MAKE_SIGNED_FIXNUM(offset); \
+ \
+ /* Base pointer */ \
+ \
+ if (OBJECT_TYPE(Old_Contents) == TC_BROKEN_HEART) \
+ { \
+ *compiled_entry_pointer++ = \
+ Make_New_Pointer(OBJECT_TYPE(This), Old_Contents); \
+ } \
+ else \
+ { \
+ *compiled_entry_pointer++ = \
+ Make_New_Pointer(OBJECT_TYPE(This), (Fre)); \
+ \
+ Copy_Vector(Scn, Fre); \
} \
}
\f
This = Mem_Base[*Area];
#ifdef PRIMITIVE_EXTERNAL_REUSED
- if (upgrade_primitives && (Type_Code(This) == TC_PRIMITIVE_EXTERNAL))
+ if (upgrade_primitives_p && (Type_Code(This) == TC_PRIMITIVE_EXTERNAL))
{
Mem_Base[*Area] = upgrade_primitive(This);
*Area += 1;
case TC_PRIMITIVE:
case TC_PCOMB0:
- if (upgrade_primitives)
+ if (upgrade_primitives_p)
{
Mem_Base[*Area] = upgrade_primitive(This);
}
break;
\f
case TC_MANIFEST_NM_VECTOR:
- if (Null_NMV)
+ nmv_p = true;
+ if (null_nmv_p)
{
fast int i;
}
break;
}
- fprintf(stderr, "%s: File is not portable: NMH found\n",
- Program_Name);
- *Area += 1 + Get_Integer(This);
+ else if (!allow_nmv_p)
+ {
+ fprintf(stderr, "%s: File is not portable: NMH found\n",
+ Program_Name);
+ }
+ *Area += (1 + OBJECT_DATUM(This));
break;
case TC_BROKEN_HEART:
*Area += 1;
break;
- case TC_STACK_ENVIRONMENT:
case_compiled_entry_point:
+ if (!allow_compiled_p)
+ {
+ fprintf(stderr,
+ "%s: File contains compiled code.\n",
+ Program_Name);
+ quit(1);
+ }
+ Do_Pointer(*Area, Do_Compiled_Entry);
+
+ case TC_STACK_ENVIRONMENT:
fprintf(stderr,
- "%s: File is not portable: Compiled code.\n",
+ "%s: File contains stack environments.\n",
Program_Name);
quit(1);
-
+\f
case TC_FIXNUM:
NIntegers += 1;
NBits += fixnum_to_bits;
case_simple_Non_Pointer:
*Area += 1;
break;
-\f
- case_Cell:
- Do_Pointer(*Area, Do_Cell);
case TC_REFERENCE_TRAP:
{
kind = Datum(This);
- if (upgrade_traps)
+ if (upgrade_traps_p)
{
/* It is an old UNASSIGNED object. */
if (kind == 0)
case_Pair:
Do_Pointer(*Area, Do_Pair);
+ case_Cell:
+ Do_Pointer(*Area, Do_Cell);
+
case TC_VARIABLE:
case_Triple:
Do_Pointer(*Area, Do_Triple);
Do_Pointer(*Area, Do_String);
case TC_ENVIRONMENT:
- if (upgrade_traps)
+ if (upgrade_traps_p)
{
fprintf(stderr,
"%s: Cannot upgrade environments.\n",
}
}
\f
-/* Output macros */
+/* Output procedures */
-#define print_external_object(from) \
-{ \
- switch(Type_Code(*from)) \
- { \
- case TC_FIXNUM: \
- { \
- long Value; \
- \
- Sign_Extend(*from++, Value); \
- print_a_fixnum(Value); \
- break; \
- } \
- \
- case TC_BIT_STRING: \
- print_a_bit_string(++from); \
- from += (1 + Get_Integer(*from)); \
- break; \
- \
- case TC_BIG_FIXNUM: \
- print_a_bignum(++from); \
- from += (1 + Get_Integer(*from)); \
- break; \
- \
- case TC_CHARACTER_STRING: \
- print_a_string(++from); \
- from += (1 + Get_Integer(*from)); \
- break; \
- \
- case TC_BIG_FLONUM: \
- print_a_flonum( *((double *) (from + 1))); \
- from += (1 + float_to_pointer); \
- break; \
- \
- case TC_CHARACTER: \
- fprintf(Portable_File, "%02x %03x\n", \
- TC_CHARACTER, (*from & MASK_EXTNDD_CHAR)); \
- from += 1; \
- break; \
- \
- default: \
- fprintf(stderr, \
- "%s: Bad Object to print externally %lx\n", \
- Program_Name, *from); \
- quit(1); \
- } \
+void
+print_external_objects(from, count)
+ fast Pointer *from;
+ fast long count;
+{
+ while (--count >= 0)
+ {
+ switch(Type_Code(*from))
+ {
+ case TC_FIXNUM:
+ {
+ long Value;
+
+ Sign_Extend(*from++, Value);
+ print_a_fixnum(Value);
+ break;
+ }
+
+ case TC_BIT_STRING:
+ print_a_bit_string(++from);
+ from += (1 + OBJECT_DATUM(*from));
+ break;
+
+ case TC_BIG_FIXNUM:
+ print_a_bignum(++from);
+ from += (1 + OBJECT_DATUM(*from));
+ break;
+
+ case TC_CHARACTER_STRING:
+ print_a_string(++from);
+ from += (1 + OBJECT_DATUM(*from));
+ break;
+
+ case TC_BIG_FLONUM:
+ print_a_flonum(*((double *) (from + 1)));
+ from += (1 + float_to_pointer);
+ break;
+
+ case TC_CHARACTER:
+ fprintf(Portable_File, "%02x %03x\n",
+ TC_CHARACTER, (*from & MASK_EXTNDD_CHAR));
+ from += 1;
+ break;
+
+ default:
+ fprintf(stderr,
+ "%s: Bad Object to print externally %lx\n",
+ Program_Name, *from);
+ quit(1);
+ }
+ }
+ return;
}
+\f
+void
+print_objects(from, to)
+ fast Pointer *from, *to;
+{
+ fast long datum, type;
-#define print_an_object(obj) \
-{ \
- fprintf(Portable_File, "%02x %lx\n", \
- Type_Code(obj), Get_Integer(obj)); \
+ while(from < to)
+ {
+
+ type = OBJECT_TYPE(*from);
+ datum = OBJECT_DATUM(*from);
+ from += 1;
+
+ if (type == TC_MANIFEST_NM_VECTOR)
+ {
+ fprintf(Portable_File, "%02x %lx\n", type, datum);
+ while (--datum >= 0)
+ {
+ fprintf(Portable_File, "%lx\n", ((unsigned long) *from++));
+ }
+ }
+ else if (type == TC_COMPILED_EXPRESSION)
+ {
+ Pointer base;
+ long offset;
+
+ Sign_Extend(compiled_entry_table[datum], offset);
+ base = compiled_entry_table[datum + 1];
+
+ fprintf(Portable_File, "%02x %lx %02x %lx\n",
+ TC_COMPILED_EXPRESSION, offset,
+ OBJECT_TYPE(base), OBJECT_DATUM(base));
+ }
+ else
+ {
+ fprintf(Portable_File, "%02x %lx\n", type, datum);
+ }
+ }
+ return;
}
\f
/* Debugging Aids and Consistency Checks */
return;
}
-#define PRINT_HEADER(name, obj, format) \
+#define PRINT_HEADER(name, format, obj) \
{ \
fprintf(Portable_File, (format), (obj)); \
+ fprintf(Portable_File, "\n"); \
fprintf(stderr, "%s: ", (name)); \
fprintf(stderr, (format), (obj)); \
+ fprintf(stderr, "\n"); \
}
#else /* not DEBUG */
#define WHEN(what, message)
-#define PRINT_HEADER(name, obj, format) \
+#define PRINT_HEADER(name, format, obj) \
{ \
fprintf(Portable_File, (format), (obj)); \
+ fprintf(Portable_File, "\n"); \
}
#endif /* DEBUG */
(Sub_Version > FASL_READ_SUBVERSION) ||
(Sub_Version < FASL_OLDEST_SUBVERSION) ||
((Machine_Type != FASL_INTERNAL_FORMAT) &&
- (!Shuffle_Bytes)))
+ (!shuffle_bytes_p)))
{
fprintf(stderr, "%s:\n", Program_Name);
fprintf(stderr,
quit(1);
}
- if (Machine_Type == FASL_INTERNAL_FORMAT)
- {
- Shuffle_Bytes = false;
- }
-
- upgrade_traps = (Sub_Version < FASL_REFERENCE_TRAP);
- upgrade_primitives = (Sub_Version < FASL_MERGED_PRIMITIVES);
- upgrade_lengths = upgrade_primitives;
-
/* Constant Space not currently supported */
if (Const_Count != 0)
Program_Name);
quit(1);
}
+\f
+ allow_nmv_p = (allow_nmv_p || allow_compiled_p);
+ if (null_nmv_p && allow_nmv_p)
+ {
+ fprintf(stderr,
+ "%s: NMVs are both allowed and to be nulled out!\n",
+ Program_Name);
+ quit(1);
+ }
+
+ if (Machine_Type == FASL_INTERNAL_FORMAT)
+ {
+ shuffle_bytes_p = false;
+ }
+
+ upgrade_traps_p = (Sub_Version < FASL_REFERENCE_TRAP);
+ upgrade_primitives_p = (Sub_Version < FASL_MERGED_PRIMITIVES);
+ upgrade_lengths_p = upgrade_primitives_p;
\f
{
long Size;
+ /* This is way larger than needed, but... what the hell? */
+
Size = ((3 * (Heap_Count + Const_Count)) +
(NROOTS + 1) +
- (upgrade_primitives ?
+ (upgrade_primitives_p ?
(3 * PRIMITIVE_UPGRADE_SPACE) :
- Primitive_Table_Size));
+ Primitive_Table_Size) +
+ (allow_compiled_p ?
+ (2 * (Heap_Count + Const_Count)) :
+ 0));
+
Allocate_Heap_Space(Size + HEAP_BUFFER_SPACE);
if (Heap == NULL)
\f
/* Determine primitive information. */
- primitive_table = &Heap[Heap_Count + Const_Count];
- if (upgrade_primitives)
+ compiled_entry_table = &Heap[Heap_Count + Const_Count];
+ compiled_entry_pointer = compiled_entry_table;
+ compiled_entry_table_end = compiled_entry_table;
+
+ if (allow_compiled_p)
{
- Mem_Base = setup_primitive_upgrade(primitive_table);
+ compiled_entry_table_end += (2 * (Heap_Count + Const_Count));
+ }
+
+ primitive_table = compiled_entry_table_end;
+ if (upgrade_primitives_p)
+ {
+ primitive_table_end = setup_primitive_upgrade(primitive_table);
}
else
{
table += (2 + Get_Integer(table[1 + STRING_HEADER]));
}
NPChars = char_count;
- Mem_Base = &primitive_table[Primitive_Table_Size];
+ primitive_table_end = &primitive_table[Primitive_Table_Size];
}
+ Mem_Base = primitive_table_end;
\f
/* Reformat the data */
/* Header */
- PRINT_HEADER("Portable Version", PORTABLE_VERSION, "%ld\n");
- PRINT_HEADER("Flags", Make_Flags(), "%ld\n");
- PRINT_HEADER("Version", FASL_FORMAT_VERSION, "%ld\n");
- PRINT_HEADER("Sub Version", FASL_SUBVERSION, "%ld\n");
+ PRINT_HEADER("Portable Version", "%ld", PORTABLE_VERSION);
+ PRINT_HEADER("Machine", "%ld", FASL_INTERNAL_FORMAT);
+ PRINT_HEADER("Version", "%ld", FASL_FORMAT_VERSION);
+ PRINT_HEADER("Sub Version", "%ld", FASL_SUBVERSION);
+ PRINT_HEADER("Flags", "%ld", (MAKE_FLAGS()));
- PRINT_HEADER("Heap Count", (Free - NROOTS), "%ld\n");
- PRINT_HEADER("Heap Base", NROOTS, "%ld\n");
- PRINT_HEADER("Heap Objects", Objects, "%ld\n");
+ PRINT_HEADER("Heap Count", "%ld", (Free - NROOTS));
+ PRINT_HEADER("Heap Base", "%ld", NROOTS);
+ PRINT_HEADER("Heap Objects", "%ld", Objects);
/* Currently Constant and Pure not supported, but the header is ready */
- PRINT_HEADER("Pure Count", 0, "%ld\n");
- PRINT_HEADER("Pure Base", Free_Constant, "%ld\n");
- PRINT_HEADER("Pure Objects", 0, "%ld\n");
+ PRINT_HEADER("Pure Count", "%ld", 0);
+ PRINT_HEADER("Pure Base", "%ld", Free_Constant);
+ PRINT_HEADER("Pure Objects", "%ld", 0);
- PRINT_HEADER("Constant Count", 0, "%ld\n");
- PRINT_HEADER("Constant Base", Free_Constant, "%ld\n");
- PRINT_HEADER("Constant Objects", 0, "%ld\n");
+ PRINT_HEADER("Constant Count", "%ld", 0);
+ PRINT_HEADER("Constant Base", "%ld", Free_Constant);
+ PRINT_HEADER("Constant Objects", "%ld", 0);
- PRINT_HEADER("& Dumped Object", (Get_Integer(Mem_Base[0])), "%ld\n");
+ PRINT_HEADER("& Dumped Object", "%ld", (OBJECT_DATUM(Mem_Base[0])));
- PRINT_HEADER("Number of flonums", NFlonums, "%ld\n");
- PRINT_HEADER("Number of integers", NIntegers, "%ld\n");
- PRINT_HEADER("Number of bits in integers", NBits, "%ld\n");
- PRINT_HEADER("Number of bit strings", NBitstrs, "%ld\n");
- PRINT_HEADER("Number of bits in bit strings", NBBits, "%ld\n");
- PRINT_HEADER("Number of character strings", NStrings, "%ld\n");
- PRINT_HEADER("Number of characters in strings", NChars, "%ld\n");
+ PRINT_HEADER("Number of flonums", "%ld", NFlonums);
+ PRINT_HEADER("Number of integers", "%ld", NIntegers);
+ PRINT_HEADER("Number of bits in integers", "%ld", NBits);
+ PRINT_HEADER("Number of bit strings", "%ld", NBitstrs);
+ PRINT_HEADER("Number of bits in bit strings", "%ld", NBBits);
+ PRINT_HEADER("Number of character strings", "%ld", NStrings);
+ PRINT_HEADER("Number of characters in strings", "%ld", NChars);
- PRINT_HEADER("Number of primitives", Primitive_Table_Length, "%ld\n");
- PRINT_HEADER("Number of characters in primitives", NPChars, "%ld\n");
+ PRINT_HEADER("Number of primitives", "%ld", Primitive_Table_Length);
+ PRINT_HEADER("Number of characters in primitives", "%ld", NPChars);
\f
/* External Objects */
- /* Heap External Objects */
-
- Free_Objects = &Mem_Base[Initial_Free + Heap_Count];
- for (; Objects > 0; Objects -= 1)
- {
- print_external_object(Free_Objects);
- }
+ print_external_objects(&Mem_Base[Initial_Free + Heap_Count],
+ Objects);
#if false
- /* Pure External Objects */
- Free_Cobjects = &Mem_Base[Pure_Objects_Start];
- for (; Pure_Objects > 0; Pure_Objects -= 1)
- {
- print_external_object(Free_Cobjects);
- }
-
- /* Constant External Objects */
-
- Free_Cobjects = &Mem_Base[Constant_Objects_Start];
- for (; Constant_Objects > 0; Constant_Objects -= 1)
- {
- print_external_object(Free_Cobjects);
- }
+ print_external_objects(&Mem_Base[Pure_Objects_Start],
+ Pure_Objects);
+ print_external_objects(&Mem_Base[Constant_Objects_Start],
+ Constant_Objects);
#endif
-\f
+
/* Pointer Objects */
- /* Heap Objects */
-
- Free_Cobjects = &Mem_Base[Free];
- for (Free_Objects = &Mem_Base[NROOTS];
- Free_Objects < Free_Cobjects;
- Free_Objects += 1)
- {
- print_an_object(*Free_Objects);
- }
+ print_objects(&Mem_Base[NROOTS], &Mem_Base[Free]);
#if false
- /* Pure Objects */
-
- Free_Cobjects = &Mem_Base[Free_Pure];
- for (Free_Objects = &Mem_Base[Pure_Start];
- Free_Objects < Free_Cobjects;
- Free_Objects += 1)
- {
- print_an_object(*Free_Objects);
- }
-
- /* Constant Objects */
-
- Free_Cobjects = &Mem_Base[Free_Constant];
- for (Free_Objects = &Mem_Base[Constant_Start];
- Free_Objects < Free_Cobjects;
- Free_Objects += 1)
- {
- print_an_object(*Free_Objects);
- }
+ print_objects(&Mem_Base[Pure_Start], &Mem_Base[Free_Pure]);
+ print_objects(&Mem_Base[Constant_Start], &Mem_Base[Free_Constant]);
#endif
\f
/* Primitives */
- if (upgrade_primitives)
+ if (upgrade_primitives_p)
{
Pointer obj;
fast Pointer *table;
\f
/* Top Level */
-static int Noptions = 3;
+/* The boolean value here is what value to store when the option is present. */
static struct Option_Struct Options[] =
- {{"Do_Not_Compact", false, &Compact_P},
- {"Null_Out_NMVs", true, &Null_NMV},
- {"Swap_Bytes", true, &Shuffle_Bytes}};
+ {{"Do_Not_Compact", false, &compact_p},
+ {"Null_Out_NMVs", true, &null_nmv_p},
+ {"Swap_Bytes", true, &shuffle_bytes_p},
+ {"Allow_Compiled", true, &allow_compiled_p},
+ {"Allow_NMVs", true, &allow_nmv_p}};
+
+static int Noptions = 5;
main(argc, argv)
int argc;
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.27 1987/11/17 08:12:25 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hooks.c,v 9.28 1987/11/20 08:19:46 jinx Exp $
*
* This file contains various hooks and handles which connect the
* primitives with the main interpreter.
{
Primitive_3_Args();
- Will_Push(CONTINUATION_SIZE+HISTORY_SIZE+STACK_ENV_EXTRA_SLOTS+4);
+ /*
+ This is done outside the Will_Push because the space for it
+ is guaranteed by the interpreter before it gets here.
+ If done inside, this could break when using stacklets.
+ */
Back_Out_Of_Primitive();
Save_Cont();
+ Will_Push(HISTORY_SIZE+STACK_ENV_EXTRA_SLOTS+4);
Stop_History();
/* Stepping should be cleared here! */
Push(Arg3);
PRIMITIVE_ABORT( PRIM_APPLY);
/*NOTREACHED*/
}
-
+\f
/* (GET-FIXED-OBJECTS-VECTOR)
Returns the current fixed objects vector. This vector is used
for communication between the interpreter and the runtime
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.35 1987/11/17 08:13:04 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.c,v 9.36 1987/11/20 08:18:21 jinx Exp $
*
* This file contains the heart of the Scheme Scode
* interpreter
}
#define Environment_P(Obj) (Obj == NIL || (Type_Code(Obj) == TC_ENVIRONMENT))
-
-#define MAGIC_RESERVE_SIZE 6 /* See SPMD.SCM */
-#define Reserve_Stack_Space() Will_Eventually_Push(MAGIC_RESERVE_SIZE)
\f
/***********************/
/* Macros for Stepping */
/* Interpret(), continued */
case TC_COMBINATION:
- { long Array_Length = Vector_Length(Fetch_Expression())-1;
- Eval_GC_Check(New_Stacklet_Size(Array_Length+1+1+CONTINUATION_SIZE));
- Will_Push(Array_Length + 1+1+CONTINUATION_SIZE); /* Save_Env, Finger */
+ {
+ long Array_Length;
+
+ Array_Length = (Vector_Length(Fetch_Expression()) - 1);
+#ifdef USE_STACKLETS
+ /* Save_Env, Finger */
+ Eval_GC_Check(New_Stacklet_Size(Array_Length + 1 + 1 + CONTINUATION_SIZE));
+#endif /* USE_STACKLETS */
+ Will_Push(Array_Length + 1 + 1 + CONTINUATION_SIZE);
Stack_Pointer = Simulate_Pushing(Array_Length);
Push(Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Array_Length));
- /* The finger: last argument number */
+ /* The finger: last argument number */
Pushed();
if (Array_Length == 0)
- { Push(STACK_FRAME_HEADER); /* Frame size */
+ {
+ Push(STACK_FRAME_HEADER); /* Frame size */
Do_Nth_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT, {});
}
Save_Env();
}
case TC_COMBINATION_1:
- Reserve_Stack_Space(); /* STACK_ENV_EXTRA_SLOTS+2+CONTINUATION_SIZE */
+ Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 1);
Save_Env();
Do_Nth_Then(RC_COMB_1_PROCEDURE, COMB_1_ARG_1, {});
case TC_COMBINATION_2:
- Reserve_Stack_Space(); /* STACK_ENV_EXTRA_SLOTS+3+CONTINUATION_SIZE */
+ Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 2);
Save_Env();
Do_Nth_Then(RC_COMB_2_FIRST_OPERAND, COMB_2_ARG_2, {});
\f
/* Interpret(), continued */
+ /*
+ The argument to Will_Eventually_Push is determined by how much
+ will be on the stack if we back out of the primitive.
+ */
+
case TC_PCOMB0:
- /* In case we back out */
- Reserve_Stack_Space(); /* CONTINUATION_SIZE */
- Finished_Eventual_Pushing(); /* of this primitive */
+ Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
+ Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
Store_Expression(Make_New_Pointer(TC_PRIMITIVE, Fetch_Expression()));
goto Primitive_Internal_Apply;
case TC_PCOMB1:
- Reserve_Stack_Space(); /* 1+CONTINUATION_SIZE */
- Do_Nth_Then(RC_PCOMB1_APPLY, PCOMB1_ARG_SLOT, {});
+ Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 1);
+ Do_Nth_Then(RC_PCOMB1_APPLY, PCOMB1_ARG_SLOT, {});
case TC_PCOMB2:
- Reserve_Stack_Space(); /* 2+CONTINUATION_SIZE */
+ Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 2);
Save_Env();
Do_Nth_Then(RC_PCOMB2_DO_1, PCOMB2_ARG_2_SLOT, {});
case TC_PCOMB3:
- Reserve_Stack_Space(); /* 3+CONTINUATION_SIZE */
+ Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 3);
Save_Env();
Do_Nth_Then(RC_PCOMB3_DO_2, PCOMB3_ARG_3_SLOT, {});
*/
switch (Get_Integer(Fetch_Return()))
- { case RC_COMB_1_PROCEDURE:
+ {
+ case RC_COMB_1_PROCEDURE:
Restore_Env();
Push(Val); /* Arg. 1 */
Push(NIL); /* Operator */
- Push(STACK_FRAME_HEADER+1);
- Finished_Eventual_Pushing();
+ Push(STACK_FRAME_HEADER + 1);
+ Finished_Eventual_Pushing(CONTINUATION_SIZE);
Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_1_FN);
case RC_COMB_2_FIRST_OPERAND:
Restore_Env();
Push(Val); /* Arg 1, just calculated */
Push(NIL); /* Function */
- Push(STACK_FRAME_HEADER+2);
- Finished_Eventual_Pushing();
+ Push(STACK_FRAME_HEADER + 2);
+ Finished_Eventual_Pushing(CONTINUATION_SIZE);
Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_2_FN);
case RC_COMB_APPLY_FUNCTION:
case RC_PCOMB1_APPLY:
End_Subproblem();
Push(Val); /* Argument value */
- Finished_Eventual_Pushing();
+ Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB1_FN_SLOT));
Primitive_Internal_Apply:
case RC_PCOMB2_APPLY:
End_Subproblem();
Push(Val); /* Value of arg. 1 */
- Finished_Eventual_Pushing();
+ Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB2_FN_SLOT));
goto Primitive_Internal_Apply;
case RC_PCOMB3_APPLY:
End_Subproblem();
Push(Val); /* Save value of arg. 1 */
- Finished_Eventual_Pushing();
+ Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB3_FN_SLOT));
goto Primitive_Internal_Apply;
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.26 1987/11/17 08:13:39 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.h,v 9.27 1987/11/20 08:17:10 jinx Exp $
*
* Macros used by the interpreter and some utilities.
*
#endif
+/*
+ N in Will_Eventually_Push is the maximum contiguous (single return code)
+ amount that this operation may take. On the average case it may use less.
+ M in Finished_Eventual_Pushing is the amount not yet pushed.
+ */
+
#define Will_Eventually_Push(N) Internal_Will_Push(N)
-#define Finished_Eventual_Pushing() /* No op */
+#define Finished_Eventual_Pushing(M) /* No op */
/* Primitive stack operations:
* These operations hide the direction of stack growth.
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/intrpt.h,v 1.1 1987/11/17 18:26:12 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/intrpt.h,v 1.2 1987/11/20 08:16:43 jinx Exp $
*
* Interrupt manipulation utilities.
*/
#define COMPILER_SETUP_INTERRUPT() \
{ \
- Regs[REGBLOCK_MEMTOP] = ((INTERRUPT_PENDING_P(INT_Mask)) ? \
- ((Pointer) MemTop) : \
- ((Pointer) -1)); \
+ Regs[REGBLOCK_MEMTOP] = ((INTERRUPT_PENDING_P(INT_Mask)) ? \
+ ((Pointer) -1) : \
+ ((Pointer) MemTop)); \
}
#define FETCH_INTERRUPT_MASK() (IntEnb)
/* Compatibility */
#define COMPILER_SET_MEMTOP() COMPILER_SETUP_INTERRUPT()
-
-#define Request_Interrupt(code) REQUEST_INTERRUPT(code)
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/psbmap.h,v 9.23 1987/11/17 08:18:32 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/psbmap.h,v 9.24 1987/11/20 08:13:32 jinx Exp $
*
* This file contains macros and declarations for Bintopsb.c
* and Psbtobin.c
#include "missing.c"
#endif
-#define PORTABLE_VERSION 3
+#define PORTABLE_VERSION 4
/* Number of objects which, when traced recursively, point at all other
objects dumped. Currently only the dumped object.
to an external object.
*/
-#define CONSTANT_CODE TC_FIXNUM
-#define HEAP_CODE TC_CHARACTER
+#define CONSTANT_CODE TC_FIXNUM
+#define HEAP_CODE TC_CHARACTER
-#define fixnum_to_bits FIXNUM_LENGTH
-#define bignum_to_bits(len) ((len) * SHIFT)
-#define bits_to_bigdigit(nbits) (((nbits) + (SHIFT-1)) / SHIFT)
+#define fixnum_to_bits FIXNUM_LENGTH
+#define bignum_to_bits(len) ((len) * SHIFT)
+#define bits_to_bigdigit(nbits) (((nbits) + (SHIFT-1)) / SHIFT)
-#define hex_digits(nbits) (((nbits) + 3) / 4)
+#define hex_digits(nbits) (((nbits) + 3) / 4)
-#define to_pointer(size) \
- (((size) + (sizeof(Pointer) - 1)) / sizeof(Pointer))
+/*
+ This assumes that a bignum header is 2 Pointers.
+ The bignum code is not very portable, unfortunately
+ */
-#define bigdigit_to_pointer(ndig) \
- to_pointer((ndig) * sizeof(bigdigit))
+#define bignum_header_to_pointer Align(0)
-/* This assumes that a bignum header is 2 Pointers.
- The bignum code is not very portable, unfortunately */
+#define to_pointer(size) \
+ (((size) + (sizeof(Pointer) - 1)) / sizeof(Pointer))
-#define bignum_header_to_pointer Align(0)
+#define bigdigit_to_pointer(ndig) \
+ to_pointer((ndig) * sizeof(bigdigit))
-#define float_to_pointer \
+#define float_to_pointer \
to_pointer(sizeof(double))
-#define flonum_to_pointer(nchars) \
+
+#define flonum_to_pointer(nchars) \
((nchars) * (1 + float_to_pointer))
-#define char_to_pointer(nchars) \
+#define char_to_pointer(nchars) \
to_pointer(nchars)
-#define pointer_to_char(npoints) \
+
+#define pointer_to_char(npoints) \
((npoints) * sizeof(Pointer))
\f
-/* Global data */
+/* Status flags */
-/* If true, make all integers fixnums if possible, and all strings as
- short as possible (trim extra stuff). */
+#define COMPACT_P (1 << 0)
+#define NULL_NMV_P (1 << 1)
+#define COMPILED_P (1 << 2)
+#define NMV_P (1 << 3)
+
+#define MAKE_FLAGS() \
+((compact_p ? COMPACT_P : 0) | \
+ (null_nmv_p ? NULL_NMV_P : 0) | \
+ (compiled_p ? COMPILED_P : 0) | \
+ (nmv_p ? NMV_P : 0))
+
+#define READ_FLAGS(f) \
+{ \
+ compact_p = ((f) & COMPACT_P); \
+ null_nmv_p = ((f) & NULL_NMV_P); \
+ compiled_p = ((f) & COMPILED_P); \
+ nmv_p = ((f) & NMV_P); \
+}
+
+/*
+ If true, make all integers fixnums if possible, and all strings as
+ short as possible (trim extra stuff).
+ */
-static Boolean Compact_P = true;
+static Boolean compact_p = true;
/* If true, null out all elements of random non-marked vectors. */
-static Boolean Null_NMV = false;
+static Boolean null_nmv_p = false;
+
+/* If true, the portable file contains compiled code. */
+
+static Boolean compiled_p = false;
+
+/* If true, the portable file contains "random" non-marked vectors. */
+
+static Boolean nmv_p = false;
+
+/* Global data */
#ifndef Heap_In_Low_Memory
static Pointer *Memory_Base;
static char *Program_Name;
\f
-/* Status flags */
-
-#define COMPACT_P 1
-#define NULL_NMV 2
-
-#define Make_Flags() \
-((Compact_P ? COMPACT_P : 0) | \
- (Null_NMV ? NULL_NMV : 0))
-
-#define Read_Flags(f) \
-Compact_P = ((f) & COMPACT_P); \
-Null_NMV = ((f) & NULL_NMV)
-\f
/* Argument List Parsing */
-struct Option_Struct { char *name;
- Boolean value;
- Boolean *ptr;
- };
+struct Option_Struct
+{
+ char *name;
+ Boolean value;
+ Boolean *ptr;
+};
Boolean
strequal(s1, s2)
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.28 1987/11/17 08:05:02 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/psbtobin.c,v 9.29 1987/11/20 08:20:36 jinx Exp $
*
* This File contains the code to translate portable format binary
* files to internal format.
#include "translate.h"
-static long Dumped_Object_Addr;
-static long Dumped_Heap_Base, Heap_Objects, Heap_Count;
-static long Dumped_Constant_Base, Constant_Objects, Constant_Count;
-static long Dumped_Pure_Base, Pure_Objects, Pure_Count;
-static long Primitive_Table_Length;
-
-static Pointer *Heap;
-static Pointer *Heap_Base, *Heap_Table, *Heap_Object_Base, *Free;
-static Pointer *Constant_Base, *Constant_Table,
- *Constant_Object_Base, *Free_Constant;
-static Pointer *Pure_Base, *Pure_Table, *Pure_Object_Base, *Free_Pure;
-static Pointer *primitive_table, *primitive_table_end;
-static Pointer *Stack_Top;
+static long
+ Dumped_Object_Addr,
+ Dumped_Heap_Base, Heap_Objects, Heap_Count,
+ Dumped_Constant_Base, Constant_Objects, Constant_Count,
+ Dumped_Pure_Base, Pure_Objects, Pure_Count,
+ Primitive_Table_Length;
+
+static Pointer
+ *Heap,
+ *Heap_Base, *Heap_Table, *Heap_Object_Base, *Free,
+ *Constant_Base, *Constant_Table,
+ *Constant_Object_Base, *Free_Constant,
+ *Pure_Base, *Pure_Table, *Pure_Object_Base, *Free_Pure,
+ *primitive_table, *primitive_table_end,
+ *Stack_Top;
long
Write_Data(Count, From_Where)
fast unsigned long Temp;
long Length;
- if ((The_Type == TC_FIXNUM) && (!Compact_P))
+ if ((The_Type == TC_FIXNUM) && (!compact_p))
{
fprintf(stderr,
"%s: Fixnum too large, coercing to bignum.\n",
Result += ldexp(1.0, expt);
}
the_max = Result;
- return Result;
+ return (Result);
}
\f
double
continue;
case TC_MANIFEST_NM_VECTOR:
- if (!(Null_NMV))
- {
- /* Unknown object! */
- fprintf(stderr,
- "%s: File is not portable: NMH found\n",
- Program_Name);
- }
*To++ = Make_Non_Pointer(The_Type, The_Datum);
{
fast long count;
N -= count;
while (--count >= 0)
{
- VMS_BUG(The_Type = 0);
- VMS_BUG(The_Datum = 0);
- fscanf(Portable_File, "%2x %lx", &The_Type, &The_Datum);
- *To++ = Make_Non_Pointer(The_Type, The_Datum);
+ VMS_BUG(*To = 0);
+ fscanf(Portable_File, "%lx", To++);
}
}
continue;
\f
+ case TC_COMPILED_EXPRESSION:
+ {
+ Pointer *temp;
+ long base_type, base_datum;
+
+ fscanf(Portable_File, "%02x %lx", &base_type, &base_datum);
+ temp = Relocate(base_datum);
+ *To++ = Make_Pointer(base_type,
+ ((Pointer *) (&(((char *) temp)[The_Datum]))));
+ break;
+ }
+
case TC_BROKEN_HEART:
if (The_Datum != 0)
{
#define READ_HEADER(string, format, value) \
{ \
- fscanf(Input_File, format, value); \
+ fscanf(Input_File, format, &(value)); \
fprintf(stderr, "%s: ", (string)); \
- fprintf(stderr, (format), (*(value))); \
+ fprintf(stderr, (format), (value)); \
fprintf(stderr, "\n"); \
}
\f
#define READ_HEADER(string, format, value) \
{ \
- fscanf(Input_File, format, value); \
+ fscanf(Input_File, format, &(value)); \
}
#endif /* DEBUG */
long
Read_Header_and_Allocate()
{
- long Portable_Version, Flags, Version, Sub_Version;
- long NFlonums, NIntegers, NBits, NBitstrs, NBBits, NStrings, NChars, NPChars;
- long Size;
+ long
+ Portable_Version, Machine,
+ Version, Sub_Version, Flags,
+ NFlonums, NIntegers, NBits,
+ NBitstrs, NBBits, NStrings, NChars,
+ NPChars,
+ Size;
+
+ READ_HEADER("Portable Version", "%ld", Portable_Version);
- /* Read Header */
+ if (Portable_Version != PORTABLE_VERSION)
+ {
+ fprintf(stderr, "Portable File Version %4d\n", Portable_Version);
+ fprintf(stderr, "Expected: Version %4d\n", PORTABLE_VERSION);
+ quit(1);
+ }
- READ_HEADER("Portable Version", "%ld", &Portable_Version);
- READ_HEADER("Flags", "%ld", &Flags);
- READ_HEADER("Version", "%ld", &Version);
- READ_HEADER("Sub Version", "%ld", &Sub_Version);
+ READ_HEADER("Machine", "%ld", Machine);
+ READ_HEADER("Version", "%ld", Version);
+ READ_HEADER("Sub Version", "%ld", Sub_Version);
- if ((Portable_Version != PORTABLE_VERSION) ||
- (Version != FASL_FORMAT_VERSION) ||
+ if ((Version != FASL_FORMAT_VERSION) ||
(Sub_Version != FASL_SUBVERSION))
{
fprintf(stderr,
- "Portable File Version %4d Subversion %4d Portable Version %4d\n",
- Version, Sub_Version, Portable_Version);
+ "Portable File Version %4d Subversion %4d Binary Version %4d\n",
+ Portable_Version, Version, Sub_Version);
fprintf(stderr,
- "Expected: Version %4d Subversion %4d Portable Version %4d\n",
- FASL_FORMAT_VERSION, FASL_SUBVERSION, PORTABLE_VERSION);
+ "Expected: Version %4d Subversion %4d Binary Version %4d\n",
+ PORTABLE_VERSION, FASL_FORMAT_VERSION, FASL_SUBVERSION);
quit(1);
}
+\f
+ READ_HEADER("Flags", "%ld", Flags);
+ READ_FLAGS(Flags);
- Read_Flags(Flags);
-
- READ_HEADER("Heap Count", "%ld", &Heap_Count);
- READ_HEADER("Dumped Heap Base", "%ld", &Dumped_Heap_Base);
- READ_HEADER("Heap Objects", "%ld", &Heap_Objects);
+ if ((compiled_p || nmv_p) && (Machine != FASL_INTERNAL_FORMAT))
+ {
+ if (compiled_p)
+ {
+ fprintf(stderr,
+ "%s: Portable file contains \"invalid\" compiled code.\n",
+ Program_Name);
+ }
+ else
+ {
+ fprintf(stderr,
+ "%s: Portable file contains \"random\" non-marked vectors.\n",
+ Program_Name);
+ }
+ fprintf(stderr, "Portable File Machine %4d\n", Machine);
+ fprintf(stderr, "Expected: Machine %4d\n", FASL_INTERNAL_FORMAT);
+ quit(1);
+ }
+\f
+ READ_HEADER("Heap Count", "%ld", Heap_Count);
+ READ_HEADER("Dumped Heap Base", "%ld", Dumped_Heap_Base);
+ READ_HEADER("Heap Objects", "%ld", Heap_Objects);
- READ_HEADER("Constant Count", "%ld", &Constant_Count);
- READ_HEADER("Dumped Constant Base", "%ld", &Dumped_Constant_Base);
- READ_HEADER("Constant Objects", "%ld", &Constant_Objects);
+ READ_HEADER("Constant Count", "%ld", Constant_Count);
+ READ_HEADER("Dumped Constant Base", "%ld", Dumped_Constant_Base);
+ READ_HEADER("Constant Objects", "%ld", Constant_Objects);
- READ_HEADER("Pure Count", "%ld", &Pure_Count);
- READ_HEADER("Dumped Pure Base", "%ld", &Dumped_Pure_Base);
- READ_HEADER("Pure Objects", "%ld", &Pure_Objects);
+ READ_HEADER("Pure Count", "%ld", Pure_Count);
+ READ_HEADER("Dumped Pure Base", "%ld", Dumped_Pure_Base);
+ READ_HEADER("Pure Objects", "%ld", Pure_Objects);
- READ_HEADER("& Dumped Object", "%ld", &Dumped_Object_Addr);
+ READ_HEADER("& Dumped Object", "%ld", Dumped_Object_Addr);
- READ_HEADER("Number of flonums", "%ld", &NFlonums);
- READ_HEADER("Number of integers", "%ld", &NIntegers);
- READ_HEADER("Number of bits in integers", "%ld", &NBits);
- READ_HEADER("Number of bit strings", "%ld", &NBitstrs);
- READ_HEADER("Number of bits in bit strings", "%ld", &NBBits);
- READ_HEADER("Number of character strings", "%ld", &NStrings);
- READ_HEADER("Number of characters in strings", "%ld", &NChars);
+ READ_HEADER("Number of flonums", "%ld", NFlonums);
+ READ_HEADER("Number of integers", "%ld", NIntegers);
+ READ_HEADER("Number of bits in integers", "%ld", NBits);
+ READ_HEADER("Number of bit strings", "%ld", NBitstrs);
+ READ_HEADER("Number of bits in bit strings", "%ld", NBBits);
+ READ_HEADER("Number of character strings", "%ld", NStrings);
+ READ_HEADER("Number of characters in strings", "%ld", NChars);
- READ_HEADER("Primitive Table Length", "%ld", &Primitive_Table_Length);
- READ_HEADER("Number of characters in primitives", "%ld", &NPChars);
+ READ_HEADER("Primitive Table Length", "%ld", Primitive_Table_Length);
+ READ_HEADER("Number of characters in primitives", "%ld", NPChars);
Size = (6 + /* SNMV */
HEAP_BUFFER_SPACE +
\f
/* Top level */
-static int Noptions = 0;
-
/* C does not usually like empty initialized arrays, so ... */
-static struct Option_Struct Options[] = {{"dummy", true, NULL}};
+static struct Option_Struct Options[] =
+ {{"dummy", true, NULL}};
+
+static int Noptions = 0;
main(argc, argv)
int argc;
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/stack.h,v 9.24 1987/11/17 08:16:42 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/stack.h,v 9.25 1987/11/20 08:16:13 jinx Rel $ */
/* This file contains macros for manipulating stacks and stacklets. */
\f
{ \
Microcode_Termination (TERM_STACK_OVERFLOW); \
} \
- Request_Interrupt (INT_Stack_Overflow); \
+ REQUEST_INTERRUPT (INT_Stack_Overflow); \
} \
} while (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/Attic/version.h,v 10.4 1987/11/18 19:30:26 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 10.5 1987/11/20 08:13:06 jinx Exp $
This file contains version information for the microcode. */
\f
#define VERSION 10
#endif
#ifndef SUBVERSION
-#define SUBVERSION 6
+#define SUBVERSION 7
#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.29 1987/11/17 08:02:39 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/bintopsb.c,v 9.30 1987/11/20 08:21:12 jinx Exp $
*
* This File contains the code to translate internal format binary
* files to portable format.
\f
/* Global data */
-static Boolean Shuffle_Bytes = false;
-static Boolean upgrade_traps = false;
-static Boolean upgrade_primitives = false;
-
/* Needed to upgrade */
#define TC_PRIMITIVE_EXTERNAL 0x10
-static Boolean upgrade_lengths = false;
-
#define STRING_LENGTH_TO_LONG(value) \
-((long) (upgrade_lengths ? Get_Integer(value) : (value)))
-
-static Pointer *Mem_Base;
-static long Heap_Relocation, Constant_Relocation;
-static long Free, Scan, Free_Constant, Scan_Constant;
-static long Objects, Constant_Objects;
-static Pointer *Free_Objects, *Free_Cobjects;
-static Pointer *primitive_table;
-
-static long NFlonums;
-static long NIntegers, NBits;
-static long NBitstrs, NBBits;
-static long NStrings, NChars;
-static long NPChars;
+((long) (upgrade_lengths_p ? Get_Integer(value) : (value)))
+
+static Boolean
+ shuffle_bytes_p = false,
+ upgrade_traps_p = false,
+ upgrade_primitives_p = false,
+ upgrade_lengths_p = false,
+ allow_compiled_p = false,
+ allow_nmv_p = false;
+
+static long
+ Heap_Relocation, Constant_Relocation,
+ Free, Scan, Free_Constant, Scan_Constant,
+ Objects, Constant_Objects;
+
+static Pointer
+ *Mem_Base,
+ *Free_Objects, *Free_Cobjects,
+ *compiled_entry_table, *compiled_entry_pointer, *compiled_entry_table_end,
+ *primitive_table, *primitive_table_end;
+
+static long
+ NFlonums,
+ NIntegers, NBits,
+ NBitstrs, NBBits,
+ NStrings, NChars,
+ NPChars;
\f
#define OUT(s) \
-fprintf(Portable_File, s); \
-break
+{ \
+ fprintf(Portable_File, (s)); \
+ break; \
+}
void
print_a_char(c, name)
fast char *string;
{
fprintf(Portable_File, "%ld ", len);
- if (Shuffle_Bytes)
+ if (shuffle_bytes_p)
{
while(len > 0)
{
fprintf(Portable_File,
"%02x %ld ",
TC_CHARACTER_STRING,
- (Compact_P ? len : maxlen));
+ (compact_p ? len : maxlen));
print_a_string_internal(len, ((char *) from));
return;
if (temp == 0)
{
fprintf(Portable_File, "%02x + 0\n",
- (Compact_P ? TC_FIXNUM : TC_BIG_FIXNUM));
+ (compact_p ? TC_FIXNUM : TC_BIG_FIXNUM));
}
else
{
}
\f
fprintf(Portable_File, "%02x %c %ld ",
- (Compact_P ? TC_FIXNUM : TC_BIG_FIXNUM),
+ (compact_p ? TC_FIXNUM : TC_BIG_FIXNUM),
(NEG_BIGNUM(the_number) ? '-' : '+'),
size_in_bits);
tail = size_in_bits % SHIFT;
} \
}
\f
+#define Copy_Vector(Scn, Fre) \
+{ \
+ fast long len; \
+ \
+ len = OBJECT_DATUM(Old_Contents); \
+ *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
+ Mem_Base[(Fre)++] = Old_Contents; \
+ while (--len >= 0) \
+ { \
+ Mem_Base[(Fre)++] = *Old_Address++; \
+ } \
+}
+
#define Do_Vector(Code, Rel, Fre, Scn, Obj, FObj) \
{ \
Old_Address += (Rel); \
Old_Contents = *Old_Address; \
\
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ if (OBJECT_TYPE(Old_Contents) == TC_BROKEN_HEART) \
{ \
- Mem_Base[(Scn)] = Make_New_Pointer(Type_Code(This), Old_Contents); \
+ Mem_Base[(Scn)] = Make_New_Pointer(OBJECT_TYPE(This), \
+ Old_Contents); \
} \
else \
{ \
- fast long len; \
+ Mem_Base[(Scn)] = Make_Non_Pointer(OBJECT_TYPE(This), (Fre)); \
+ Copy_Vector(Scn, Fre); \
+ } \
+}
+\f
+#define Do_Compiled_Entry(COde, Rel, Fre, Scn, Obj, FObj) \
+{ \
+ long offset; \
+ Pointer *saved; \
\
- len = Get_Integer(Old_Contents); \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- while (len > 0) \
- { \
- Mem_Base[(Fre)++] = *Old_Address++; \
- len -= 1; \
- } \
+ Old_Address += (Rel); \
+ saved = Old_Address; \
+ Get_Compiled_Block(Old_Address, saved); \
+ Old_Contents = *Old_Address; \
+ \
+ Mem_Base[(Scn)] = \
+ Make_Non_Pointer(TC_COMPILED_EXPRESSION, \
+ (compiled_entry_pointer - compiled_entry_table)); \
+ \
+ offset = (((char *) saved) - ((char *) Old_Address)); \
+ *compiled_entry_pointer++ = MAKE_SIGNED_FIXNUM(offset); \
+ \
+ /* Base pointer */ \
+ \
+ if (OBJECT_TYPE(Old_Contents) == TC_BROKEN_HEART) \
+ { \
+ *compiled_entry_pointer++ = \
+ Make_New_Pointer(OBJECT_TYPE(This), Old_Contents); \
+ } \
+ else \
+ { \
+ *compiled_entry_pointer++ = \
+ Make_New_Pointer(OBJECT_TYPE(This), (Fre)); \
+ \
+ Copy_Vector(Scn, Fre); \
} \
}
\f
This = Mem_Base[*Area];
#ifdef PRIMITIVE_EXTERNAL_REUSED
- if (upgrade_primitives && (Type_Code(This) == TC_PRIMITIVE_EXTERNAL))
+ if (upgrade_primitives_p && (Type_Code(This) == TC_PRIMITIVE_EXTERNAL))
{
Mem_Base[*Area] = upgrade_primitive(This);
*Area += 1;
case TC_PRIMITIVE:
case TC_PCOMB0:
- if (upgrade_primitives)
+ if (upgrade_primitives_p)
{
Mem_Base[*Area] = upgrade_primitive(This);
}
break;
\f
case TC_MANIFEST_NM_VECTOR:
- if (Null_NMV)
+ nmv_p = true;
+ if (null_nmv_p)
{
fast int i;
}
break;
}
- fprintf(stderr, "%s: File is not portable: NMH found\n",
- Program_Name);
- *Area += 1 + Get_Integer(This);
+ else if (!allow_nmv_p)
+ {
+ fprintf(stderr, "%s: File is not portable: NMH found\n",
+ Program_Name);
+ }
+ *Area += (1 + OBJECT_DATUM(This));
break;
case TC_BROKEN_HEART:
*Area += 1;
break;
- case TC_STACK_ENVIRONMENT:
case_compiled_entry_point:
+ if (!allow_compiled_p)
+ {
+ fprintf(stderr,
+ "%s: File contains compiled code.\n",
+ Program_Name);
+ quit(1);
+ }
+ Do_Pointer(*Area, Do_Compiled_Entry);
+
+ case TC_STACK_ENVIRONMENT:
fprintf(stderr,
- "%s: File is not portable: Compiled code.\n",
+ "%s: File contains stack environments.\n",
Program_Name);
quit(1);
-
+\f
case TC_FIXNUM:
NIntegers += 1;
NBits += fixnum_to_bits;
case_simple_Non_Pointer:
*Area += 1;
break;
-\f
- case_Cell:
- Do_Pointer(*Area, Do_Cell);
case TC_REFERENCE_TRAP:
{
kind = Datum(This);
- if (upgrade_traps)
+ if (upgrade_traps_p)
{
/* It is an old UNASSIGNED object. */
if (kind == 0)
case_Pair:
Do_Pointer(*Area, Do_Pair);
+ case_Cell:
+ Do_Pointer(*Area, Do_Cell);
+
case TC_VARIABLE:
case_Triple:
Do_Pointer(*Area, Do_Triple);
Do_Pointer(*Area, Do_String);
case TC_ENVIRONMENT:
- if (upgrade_traps)
+ if (upgrade_traps_p)
{
fprintf(stderr,
"%s: Cannot upgrade environments.\n",
}
}
\f
-/* Output macros */
+/* Output procedures */
-#define print_external_object(from) \
-{ \
- switch(Type_Code(*from)) \
- { \
- case TC_FIXNUM: \
- { \
- long Value; \
- \
- Sign_Extend(*from++, Value); \
- print_a_fixnum(Value); \
- break; \
- } \
- \
- case TC_BIT_STRING: \
- print_a_bit_string(++from); \
- from += (1 + Get_Integer(*from)); \
- break; \
- \
- case TC_BIG_FIXNUM: \
- print_a_bignum(++from); \
- from += (1 + Get_Integer(*from)); \
- break; \
- \
- case TC_CHARACTER_STRING: \
- print_a_string(++from); \
- from += (1 + Get_Integer(*from)); \
- break; \
- \
- case TC_BIG_FLONUM: \
- print_a_flonum( *((double *) (from + 1))); \
- from += (1 + float_to_pointer); \
- break; \
- \
- case TC_CHARACTER: \
- fprintf(Portable_File, "%02x %03x\n", \
- TC_CHARACTER, (*from & MASK_EXTNDD_CHAR)); \
- from += 1; \
- break; \
- \
- default: \
- fprintf(stderr, \
- "%s: Bad Object to print externally %lx\n", \
- Program_Name, *from); \
- quit(1); \
- } \
+void
+print_external_objects(from, count)
+ fast Pointer *from;
+ fast long count;
+{
+ while (--count >= 0)
+ {
+ switch(Type_Code(*from))
+ {
+ case TC_FIXNUM:
+ {
+ long Value;
+
+ Sign_Extend(*from++, Value);
+ print_a_fixnum(Value);
+ break;
+ }
+
+ case TC_BIT_STRING:
+ print_a_bit_string(++from);
+ from += (1 + OBJECT_DATUM(*from));
+ break;
+
+ case TC_BIG_FIXNUM:
+ print_a_bignum(++from);
+ from += (1 + OBJECT_DATUM(*from));
+ break;
+
+ case TC_CHARACTER_STRING:
+ print_a_string(++from);
+ from += (1 + OBJECT_DATUM(*from));
+ break;
+
+ case TC_BIG_FLONUM:
+ print_a_flonum(*((double *) (from + 1)));
+ from += (1 + float_to_pointer);
+ break;
+
+ case TC_CHARACTER:
+ fprintf(Portable_File, "%02x %03x\n",
+ TC_CHARACTER, (*from & MASK_EXTNDD_CHAR));
+ from += 1;
+ break;
+
+ default:
+ fprintf(stderr,
+ "%s: Bad Object to print externally %lx\n",
+ Program_Name, *from);
+ quit(1);
+ }
+ }
+ return;
}
+\f
+void
+print_objects(from, to)
+ fast Pointer *from, *to;
+{
+ fast long datum, type;
-#define print_an_object(obj) \
-{ \
- fprintf(Portable_File, "%02x %lx\n", \
- Type_Code(obj), Get_Integer(obj)); \
+ while(from < to)
+ {
+
+ type = OBJECT_TYPE(*from);
+ datum = OBJECT_DATUM(*from);
+ from += 1;
+
+ if (type == TC_MANIFEST_NM_VECTOR)
+ {
+ fprintf(Portable_File, "%02x %lx\n", type, datum);
+ while (--datum >= 0)
+ {
+ fprintf(Portable_File, "%lx\n", ((unsigned long) *from++));
+ }
+ }
+ else if (type == TC_COMPILED_EXPRESSION)
+ {
+ Pointer base;
+ long offset;
+
+ Sign_Extend(compiled_entry_table[datum], offset);
+ base = compiled_entry_table[datum + 1];
+
+ fprintf(Portable_File, "%02x %lx %02x %lx\n",
+ TC_COMPILED_EXPRESSION, offset,
+ OBJECT_TYPE(base), OBJECT_DATUM(base));
+ }
+ else
+ {
+ fprintf(Portable_File, "%02x %lx\n", type, datum);
+ }
+ }
+ return;
}
\f
/* Debugging Aids and Consistency Checks */
return;
}
-#define PRINT_HEADER(name, obj, format) \
+#define PRINT_HEADER(name, format, obj) \
{ \
fprintf(Portable_File, (format), (obj)); \
+ fprintf(Portable_File, "\n"); \
fprintf(stderr, "%s: ", (name)); \
fprintf(stderr, (format), (obj)); \
+ fprintf(stderr, "\n"); \
}
#else /* not DEBUG */
#define WHEN(what, message)
-#define PRINT_HEADER(name, obj, format) \
+#define PRINT_HEADER(name, format, obj) \
{ \
fprintf(Portable_File, (format), (obj)); \
+ fprintf(Portable_File, "\n"); \
}
#endif /* DEBUG */
(Sub_Version > FASL_READ_SUBVERSION) ||
(Sub_Version < FASL_OLDEST_SUBVERSION) ||
((Machine_Type != FASL_INTERNAL_FORMAT) &&
- (!Shuffle_Bytes)))
+ (!shuffle_bytes_p)))
{
fprintf(stderr, "%s:\n", Program_Name);
fprintf(stderr,
quit(1);
}
- if (Machine_Type == FASL_INTERNAL_FORMAT)
- {
- Shuffle_Bytes = false;
- }
-
- upgrade_traps = (Sub_Version < FASL_REFERENCE_TRAP);
- upgrade_primitives = (Sub_Version < FASL_MERGED_PRIMITIVES);
- upgrade_lengths = upgrade_primitives;
-
/* Constant Space not currently supported */
if (Const_Count != 0)
Program_Name);
quit(1);
}
+\f
+ allow_nmv_p = (allow_nmv_p || allow_compiled_p);
+ if (null_nmv_p && allow_nmv_p)
+ {
+ fprintf(stderr,
+ "%s: NMVs are both allowed and to be nulled out!\n",
+ Program_Name);
+ quit(1);
+ }
+
+ if (Machine_Type == FASL_INTERNAL_FORMAT)
+ {
+ shuffle_bytes_p = false;
+ }
+
+ upgrade_traps_p = (Sub_Version < FASL_REFERENCE_TRAP);
+ upgrade_primitives_p = (Sub_Version < FASL_MERGED_PRIMITIVES);
+ upgrade_lengths_p = upgrade_primitives_p;
\f
{
long Size;
+ /* This is way larger than needed, but... what the hell? */
+
Size = ((3 * (Heap_Count + Const_Count)) +
(NROOTS + 1) +
- (upgrade_primitives ?
+ (upgrade_primitives_p ?
(3 * PRIMITIVE_UPGRADE_SPACE) :
- Primitive_Table_Size));
+ Primitive_Table_Size) +
+ (allow_compiled_p ?
+ (2 * (Heap_Count + Const_Count)) :
+ 0));
+
Allocate_Heap_Space(Size + HEAP_BUFFER_SPACE);
if (Heap == NULL)
\f
/* Determine primitive information. */
- primitive_table = &Heap[Heap_Count + Const_Count];
- if (upgrade_primitives)
+ compiled_entry_table = &Heap[Heap_Count + Const_Count];
+ compiled_entry_pointer = compiled_entry_table;
+ compiled_entry_table_end = compiled_entry_table;
+
+ if (allow_compiled_p)
{
- Mem_Base = setup_primitive_upgrade(primitive_table);
+ compiled_entry_table_end += (2 * (Heap_Count + Const_Count));
+ }
+
+ primitive_table = compiled_entry_table_end;
+ if (upgrade_primitives_p)
+ {
+ primitive_table_end = setup_primitive_upgrade(primitive_table);
}
else
{
table += (2 + Get_Integer(table[1 + STRING_HEADER]));
}
NPChars = char_count;
- Mem_Base = &primitive_table[Primitive_Table_Size];
+ primitive_table_end = &primitive_table[Primitive_Table_Size];
}
+ Mem_Base = primitive_table_end;
\f
/* Reformat the data */
/* Header */
- PRINT_HEADER("Portable Version", PORTABLE_VERSION, "%ld\n");
- PRINT_HEADER("Flags", Make_Flags(), "%ld\n");
- PRINT_HEADER("Version", FASL_FORMAT_VERSION, "%ld\n");
- PRINT_HEADER("Sub Version", FASL_SUBVERSION, "%ld\n");
+ PRINT_HEADER("Portable Version", "%ld", PORTABLE_VERSION);
+ PRINT_HEADER("Machine", "%ld", FASL_INTERNAL_FORMAT);
+ PRINT_HEADER("Version", "%ld", FASL_FORMAT_VERSION);
+ PRINT_HEADER("Sub Version", "%ld", FASL_SUBVERSION);
+ PRINT_HEADER("Flags", "%ld", (MAKE_FLAGS()));
- PRINT_HEADER("Heap Count", (Free - NROOTS), "%ld\n");
- PRINT_HEADER("Heap Base", NROOTS, "%ld\n");
- PRINT_HEADER("Heap Objects", Objects, "%ld\n");
+ PRINT_HEADER("Heap Count", "%ld", (Free - NROOTS));
+ PRINT_HEADER("Heap Base", "%ld", NROOTS);
+ PRINT_HEADER("Heap Objects", "%ld", Objects);
/* Currently Constant and Pure not supported, but the header is ready */
- PRINT_HEADER("Pure Count", 0, "%ld\n");
- PRINT_HEADER("Pure Base", Free_Constant, "%ld\n");
- PRINT_HEADER("Pure Objects", 0, "%ld\n");
+ PRINT_HEADER("Pure Count", "%ld", 0);
+ PRINT_HEADER("Pure Base", "%ld", Free_Constant);
+ PRINT_HEADER("Pure Objects", "%ld", 0);
- PRINT_HEADER("Constant Count", 0, "%ld\n");
- PRINT_HEADER("Constant Base", Free_Constant, "%ld\n");
- PRINT_HEADER("Constant Objects", 0, "%ld\n");
+ PRINT_HEADER("Constant Count", "%ld", 0);
+ PRINT_HEADER("Constant Base", "%ld", Free_Constant);
+ PRINT_HEADER("Constant Objects", "%ld", 0);
- PRINT_HEADER("& Dumped Object", (Get_Integer(Mem_Base[0])), "%ld\n");
+ PRINT_HEADER("& Dumped Object", "%ld", (OBJECT_DATUM(Mem_Base[0])));
- PRINT_HEADER("Number of flonums", NFlonums, "%ld\n");
- PRINT_HEADER("Number of integers", NIntegers, "%ld\n");
- PRINT_HEADER("Number of bits in integers", NBits, "%ld\n");
- PRINT_HEADER("Number of bit strings", NBitstrs, "%ld\n");
- PRINT_HEADER("Number of bits in bit strings", NBBits, "%ld\n");
- PRINT_HEADER("Number of character strings", NStrings, "%ld\n");
- PRINT_HEADER("Number of characters in strings", NChars, "%ld\n");
+ PRINT_HEADER("Number of flonums", "%ld", NFlonums);
+ PRINT_HEADER("Number of integers", "%ld", NIntegers);
+ PRINT_HEADER("Number of bits in integers", "%ld", NBits);
+ PRINT_HEADER("Number of bit strings", "%ld", NBitstrs);
+ PRINT_HEADER("Number of bits in bit strings", "%ld", NBBits);
+ PRINT_HEADER("Number of character strings", "%ld", NStrings);
+ PRINT_HEADER("Number of characters in strings", "%ld", NChars);
- PRINT_HEADER("Number of primitives", Primitive_Table_Length, "%ld\n");
- PRINT_HEADER("Number of characters in primitives", NPChars, "%ld\n");
+ PRINT_HEADER("Number of primitives", "%ld", Primitive_Table_Length);
+ PRINT_HEADER("Number of characters in primitives", "%ld", NPChars);
\f
/* External Objects */
- /* Heap External Objects */
-
- Free_Objects = &Mem_Base[Initial_Free + Heap_Count];
- for (; Objects > 0; Objects -= 1)
- {
- print_external_object(Free_Objects);
- }
+ print_external_objects(&Mem_Base[Initial_Free + Heap_Count],
+ Objects);
#if false
- /* Pure External Objects */
- Free_Cobjects = &Mem_Base[Pure_Objects_Start];
- for (; Pure_Objects > 0; Pure_Objects -= 1)
- {
- print_external_object(Free_Cobjects);
- }
-
- /* Constant External Objects */
-
- Free_Cobjects = &Mem_Base[Constant_Objects_Start];
- for (; Constant_Objects > 0; Constant_Objects -= 1)
- {
- print_external_object(Free_Cobjects);
- }
+ print_external_objects(&Mem_Base[Pure_Objects_Start],
+ Pure_Objects);
+ print_external_objects(&Mem_Base[Constant_Objects_Start],
+ Constant_Objects);
#endif
-\f
+
/* Pointer Objects */
- /* Heap Objects */
-
- Free_Cobjects = &Mem_Base[Free];
- for (Free_Objects = &Mem_Base[NROOTS];
- Free_Objects < Free_Cobjects;
- Free_Objects += 1)
- {
- print_an_object(*Free_Objects);
- }
+ print_objects(&Mem_Base[NROOTS], &Mem_Base[Free]);
#if false
- /* Pure Objects */
-
- Free_Cobjects = &Mem_Base[Free_Pure];
- for (Free_Objects = &Mem_Base[Pure_Start];
- Free_Objects < Free_Cobjects;
- Free_Objects += 1)
- {
- print_an_object(*Free_Objects);
- }
-
- /* Constant Objects */
-
- Free_Cobjects = &Mem_Base[Free_Constant];
- for (Free_Objects = &Mem_Base[Constant_Start];
- Free_Objects < Free_Cobjects;
- Free_Objects += 1)
- {
- print_an_object(*Free_Objects);
- }
+ print_objects(&Mem_Base[Pure_Start], &Mem_Base[Free_Pure]);
+ print_objects(&Mem_Base[Constant_Start], &Mem_Base[Free_Constant]);
#endif
\f
/* Primitives */
- if (upgrade_primitives)
+ if (upgrade_primitives_p)
{
Pointer obj;
fast Pointer *table;
\f
/* Top Level */
-static int Noptions = 3;
+/* The boolean value here is what value to store when the option is present. */
static struct Option_Struct Options[] =
- {{"Do_Not_Compact", false, &Compact_P},
- {"Null_Out_NMVs", true, &Null_NMV},
- {"Swap_Bytes", true, &Shuffle_Bytes}};
+ {{"Do_Not_Compact", false, &compact_p},
+ {"Null_Out_NMVs", true, &null_nmv_p},
+ {"Swap_Bytes", true, &shuffle_bytes_p},
+ {"Allow_Compiled", true, &allow_compiled_p},
+ {"Allow_NMVs", true, &allow_nmv_p}};
+
+static int Noptions = 5;
main(argc, argv)
int argc;
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.35 1987/11/17 08:13:04 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/interp.c,v 9.36 1987/11/20 08:18:21 jinx Exp $
*
* This file contains the heart of the Scheme Scode
* interpreter
}
#define Environment_P(Obj) (Obj == NIL || (Type_Code(Obj) == TC_ENVIRONMENT))
-
-#define MAGIC_RESERVE_SIZE 6 /* See SPMD.SCM */
-#define Reserve_Stack_Space() Will_Eventually_Push(MAGIC_RESERVE_SIZE)
\f
/***********************/
/* Macros for Stepping */
/* Interpret(), continued */
case TC_COMBINATION:
- { long Array_Length = Vector_Length(Fetch_Expression())-1;
- Eval_GC_Check(New_Stacklet_Size(Array_Length+1+1+CONTINUATION_SIZE));
- Will_Push(Array_Length + 1+1+CONTINUATION_SIZE); /* Save_Env, Finger */
+ {
+ long Array_Length;
+
+ Array_Length = (Vector_Length(Fetch_Expression()) - 1);
+#ifdef USE_STACKLETS
+ /* Save_Env, Finger */
+ Eval_GC_Check(New_Stacklet_Size(Array_Length + 1 + 1 + CONTINUATION_SIZE));
+#endif /* USE_STACKLETS */
+ Will_Push(Array_Length + 1 + 1 + CONTINUATION_SIZE);
Stack_Pointer = Simulate_Pushing(Array_Length);
Push(Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Array_Length));
- /* The finger: last argument number */
+ /* The finger: last argument number */
Pushed();
if (Array_Length == 0)
- { Push(STACK_FRAME_HEADER); /* Frame size */
+ {
+ Push(STACK_FRAME_HEADER); /* Frame size */
Do_Nth_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT, {});
}
Save_Env();
}
case TC_COMBINATION_1:
- Reserve_Stack_Space(); /* STACK_ENV_EXTRA_SLOTS+2+CONTINUATION_SIZE */
+ Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 1);
Save_Env();
Do_Nth_Then(RC_COMB_1_PROCEDURE, COMB_1_ARG_1, {});
case TC_COMBINATION_2:
- Reserve_Stack_Space(); /* STACK_ENV_EXTRA_SLOTS+3+CONTINUATION_SIZE */
+ Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 2);
Save_Env();
Do_Nth_Then(RC_COMB_2_FIRST_OPERAND, COMB_2_ARG_2, {});
\f
/* Interpret(), continued */
+ /*
+ The argument to Will_Eventually_Push is determined by how much
+ will be on the stack if we back out of the primitive.
+ */
+
case TC_PCOMB0:
- /* In case we back out */
- Reserve_Stack_Space(); /* CONTINUATION_SIZE */
- Finished_Eventual_Pushing(); /* of this primitive */
+ Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
+ Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
Store_Expression(Make_New_Pointer(TC_PRIMITIVE, Fetch_Expression()));
goto Primitive_Internal_Apply;
case TC_PCOMB1:
- Reserve_Stack_Space(); /* 1+CONTINUATION_SIZE */
- Do_Nth_Then(RC_PCOMB1_APPLY, PCOMB1_ARG_SLOT, {});
+ Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 1);
+ Do_Nth_Then(RC_PCOMB1_APPLY, PCOMB1_ARG_SLOT, {});
case TC_PCOMB2:
- Reserve_Stack_Space(); /* 2+CONTINUATION_SIZE */
+ Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 2);
Save_Env();
Do_Nth_Then(RC_PCOMB2_DO_1, PCOMB2_ARG_2_SLOT, {});
case TC_PCOMB3:
- Reserve_Stack_Space(); /* 3+CONTINUATION_SIZE */
+ Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 3);
Save_Env();
Do_Nth_Then(RC_PCOMB3_DO_2, PCOMB3_ARG_3_SLOT, {});
*/
switch (Get_Integer(Fetch_Return()))
- { case RC_COMB_1_PROCEDURE:
+ {
+ case RC_COMB_1_PROCEDURE:
Restore_Env();
Push(Val); /* Arg. 1 */
Push(NIL); /* Operator */
- Push(STACK_FRAME_HEADER+1);
- Finished_Eventual_Pushing();
+ Push(STACK_FRAME_HEADER + 1);
+ Finished_Eventual_Pushing(CONTINUATION_SIZE);
Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_1_FN);
case RC_COMB_2_FIRST_OPERAND:
Restore_Env();
Push(Val); /* Arg 1, just calculated */
Push(NIL); /* Function */
- Push(STACK_FRAME_HEADER+2);
- Finished_Eventual_Pushing();
+ Push(STACK_FRAME_HEADER + 2);
+ Finished_Eventual_Pushing(CONTINUATION_SIZE);
Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_2_FN);
case RC_COMB_APPLY_FUNCTION:
case RC_PCOMB1_APPLY:
End_Subproblem();
Push(Val); /* Argument value */
- Finished_Eventual_Pushing();
+ Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB1_FN_SLOT));
Primitive_Internal_Apply:
case RC_PCOMB2_APPLY:
End_Subproblem();
Push(Val); /* Value of arg. 1 */
- Finished_Eventual_Pushing();
+ Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB2_FN_SLOT));
goto Primitive_Internal_Apply;
case RC_PCOMB3_APPLY:
End_Subproblem();
Push(Val); /* Save value of arg. 1 */
- Finished_Eventual_Pushing();
+ Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB3_FN_SLOT));
goto Primitive_Internal_Apply;
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/psbmap.h,v 9.23 1987/11/17 08:18:32 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbmap.h,v 9.24 1987/11/20 08:13:32 jinx Exp $
*
* This file contains macros and declarations for Bintopsb.c
* and Psbtobin.c
#include "missing.c"
#endif
-#define PORTABLE_VERSION 3
+#define PORTABLE_VERSION 4
/* Number of objects which, when traced recursively, point at all other
objects dumped. Currently only the dumped object.
to an external object.
*/
-#define CONSTANT_CODE TC_FIXNUM
-#define HEAP_CODE TC_CHARACTER
+#define CONSTANT_CODE TC_FIXNUM
+#define HEAP_CODE TC_CHARACTER
-#define fixnum_to_bits FIXNUM_LENGTH
-#define bignum_to_bits(len) ((len) * SHIFT)
-#define bits_to_bigdigit(nbits) (((nbits) + (SHIFT-1)) / SHIFT)
+#define fixnum_to_bits FIXNUM_LENGTH
+#define bignum_to_bits(len) ((len) * SHIFT)
+#define bits_to_bigdigit(nbits) (((nbits) + (SHIFT-1)) / SHIFT)
-#define hex_digits(nbits) (((nbits) + 3) / 4)
+#define hex_digits(nbits) (((nbits) + 3) / 4)
-#define to_pointer(size) \
- (((size) + (sizeof(Pointer) - 1)) / sizeof(Pointer))
+/*
+ This assumes that a bignum header is 2 Pointers.
+ The bignum code is not very portable, unfortunately
+ */
-#define bigdigit_to_pointer(ndig) \
- to_pointer((ndig) * sizeof(bigdigit))
+#define bignum_header_to_pointer Align(0)
-/* This assumes that a bignum header is 2 Pointers.
- The bignum code is not very portable, unfortunately */
+#define to_pointer(size) \
+ (((size) + (sizeof(Pointer) - 1)) / sizeof(Pointer))
-#define bignum_header_to_pointer Align(0)
+#define bigdigit_to_pointer(ndig) \
+ to_pointer((ndig) * sizeof(bigdigit))
-#define float_to_pointer \
+#define float_to_pointer \
to_pointer(sizeof(double))
-#define flonum_to_pointer(nchars) \
+
+#define flonum_to_pointer(nchars) \
((nchars) * (1 + float_to_pointer))
-#define char_to_pointer(nchars) \
+#define char_to_pointer(nchars) \
to_pointer(nchars)
-#define pointer_to_char(npoints) \
+
+#define pointer_to_char(npoints) \
((npoints) * sizeof(Pointer))
\f
-/* Global data */
+/* Status flags */
-/* If true, make all integers fixnums if possible, and all strings as
- short as possible (trim extra stuff). */
+#define COMPACT_P (1 << 0)
+#define NULL_NMV_P (1 << 1)
+#define COMPILED_P (1 << 2)
+#define NMV_P (1 << 3)
+
+#define MAKE_FLAGS() \
+((compact_p ? COMPACT_P : 0) | \
+ (null_nmv_p ? NULL_NMV_P : 0) | \
+ (compiled_p ? COMPILED_P : 0) | \
+ (nmv_p ? NMV_P : 0))
+
+#define READ_FLAGS(f) \
+{ \
+ compact_p = ((f) & COMPACT_P); \
+ null_nmv_p = ((f) & NULL_NMV_P); \
+ compiled_p = ((f) & COMPILED_P); \
+ nmv_p = ((f) & NMV_P); \
+}
+
+/*
+ If true, make all integers fixnums if possible, and all strings as
+ short as possible (trim extra stuff).
+ */
-static Boolean Compact_P = true;
+static Boolean compact_p = true;
/* If true, null out all elements of random non-marked vectors. */
-static Boolean Null_NMV = false;
+static Boolean null_nmv_p = false;
+
+/* If true, the portable file contains compiled code. */
+
+static Boolean compiled_p = false;
+
+/* If true, the portable file contains "random" non-marked vectors. */
+
+static Boolean nmv_p = false;
+
+/* Global data */
#ifndef Heap_In_Low_Memory
static Pointer *Memory_Base;
static char *Program_Name;
\f
-/* Status flags */
-
-#define COMPACT_P 1
-#define NULL_NMV 2
-
-#define Make_Flags() \
-((Compact_P ? COMPACT_P : 0) | \
- (Null_NMV ? NULL_NMV : 0))
-
-#define Read_Flags(f) \
-Compact_P = ((f) & COMPACT_P); \
-Null_NMV = ((f) & NULL_NMV)
-\f
/* Argument List Parsing */
-struct Option_Struct { char *name;
- Boolean value;
- Boolean *ptr;
- };
+struct Option_Struct
+{
+ char *name;
+ Boolean value;
+ Boolean *ptr;
+};
Boolean
strequal(s1, s2)
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.28 1987/11/17 08:05:02 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbtobin.c,v 9.29 1987/11/20 08:20:36 jinx Exp $
*
* This File contains the code to translate portable format binary
* files to internal format.
#include "translate.h"
-static long Dumped_Object_Addr;
-static long Dumped_Heap_Base, Heap_Objects, Heap_Count;
-static long Dumped_Constant_Base, Constant_Objects, Constant_Count;
-static long Dumped_Pure_Base, Pure_Objects, Pure_Count;
-static long Primitive_Table_Length;
-
-static Pointer *Heap;
-static Pointer *Heap_Base, *Heap_Table, *Heap_Object_Base, *Free;
-static Pointer *Constant_Base, *Constant_Table,
- *Constant_Object_Base, *Free_Constant;
-static Pointer *Pure_Base, *Pure_Table, *Pure_Object_Base, *Free_Pure;
-static Pointer *primitive_table, *primitive_table_end;
-static Pointer *Stack_Top;
+static long
+ Dumped_Object_Addr,
+ Dumped_Heap_Base, Heap_Objects, Heap_Count,
+ Dumped_Constant_Base, Constant_Objects, Constant_Count,
+ Dumped_Pure_Base, Pure_Objects, Pure_Count,
+ Primitive_Table_Length;
+
+static Pointer
+ *Heap,
+ *Heap_Base, *Heap_Table, *Heap_Object_Base, *Free,
+ *Constant_Base, *Constant_Table,
+ *Constant_Object_Base, *Free_Constant,
+ *Pure_Base, *Pure_Table, *Pure_Object_Base, *Free_Pure,
+ *primitive_table, *primitive_table_end,
+ *Stack_Top;
long
Write_Data(Count, From_Where)
fast unsigned long Temp;
long Length;
- if ((The_Type == TC_FIXNUM) && (!Compact_P))
+ if ((The_Type == TC_FIXNUM) && (!compact_p))
{
fprintf(stderr,
"%s: Fixnum too large, coercing to bignum.\n",
Result += ldexp(1.0, expt);
}
the_max = Result;
- return Result;
+ return (Result);
}
\f
double
continue;
case TC_MANIFEST_NM_VECTOR:
- if (!(Null_NMV))
- {
- /* Unknown object! */
- fprintf(stderr,
- "%s: File is not portable: NMH found\n",
- Program_Name);
- }
*To++ = Make_Non_Pointer(The_Type, The_Datum);
{
fast long count;
N -= count;
while (--count >= 0)
{
- VMS_BUG(The_Type = 0);
- VMS_BUG(The_Datum = 0);
- fscanf(Portable_File, "%2x %lx", &The_Type, &The_Datum);
- *To++ = Make_Non_Pointer(The_Type, The_Datum);
+ VMS_BUG(*To = 0);
+ fscanf(Portable_File, "%lx", To++);
}
}
continue;
\f
+ case TC_COMPILED_EXPRESSION:
+ {
+ Pointer *temp;
+ long base_type, base_datum;
+
+ fscanf(Portable_File, "%02x %lx", &base_type, &base_datum);
+ temp = Relocate(base_datum);
+ *To++ = Make_Pointer(base_type,
+ ((Pointer *) (&(((char *) temp)[The_Datum]))));
+ break;
+ }
+
case TC_BROKEN_HEART:
if (The_Datum != 0)
{
#define READ_HEADER(string, format, value) \
{ \
- fscanf(Input_File, format, value); \
+ fscanf(Input_File, format, &(value)); \
fprintf(stderr, "%s: ", (string)); \
- fprintf(stderr, (format), (*(value))); \
+ fprintf(stderr, (format), (value)); \
fprintf(stderr, "\n"); \
}
\f
#define READ_HEADER(string, format, value) \
{ \
- fscanf(Input_File, format, value); \
+ fscanf(Input_File, format, &(value)); \
}
#endif /* DEBUG */
long
Read_Header_and_Allocate()
{
- long Portable_Version, Flags, Version, Sub_Version;
- long NFlonums, NIntegers, NBits, NBitstrs, NBBits, NStrings, NChars, NPChars;
- long Size;
+ long
+ Portable_Version, Machine,
+ Version, Sub_Version, Flags,
+ NFlonums, NIntegers, NBits,
+ NBitstrs, NBBits, NStrings, NChars,
+ NPChars,
+ Size;
+
+ READ_HEADER("Portable Version", "%ld", Portable_Version);
- /* Read Header */
+ if (Portable_Version != PORTABLE_VERSION)
+ {
+ fprintf(stderr, "Portable File Version %4d\n", Portable_Version);
+ fprintf(stderr, "Expected: Version %4d\n", PORTABLE_VERSION);
+ quit(1);
+ }
- READ_HEADER("Portable Version", "%ld", &Portable_Version);
- READ_HEADER("Flags", "%ld", &Flags);
- READ_HEADER("Version", "%ld", &Version);
- READ_HEADER("Sub Version", "%ld", &Sub_Version);
+ READ_HEADER("Machine", "%ld", Machine);
+ READ_HEADER("Version", "%ld", Version);
+ READ_HEADER("Sub Version", "%ld", Sub_Version);
- if ((Portable_Version != PORTABLE_VERSION) ||
- (Version != FASL_FORMAT_VERSION) ||
+ if ((Version != FASL_FORMAT_VERSION) ||
(Sub_Version != FASL_SUBVERSION))
{
fprintf(stderr,
- "Portable File Version %4d Subversion %4d Portable Version %4d\n",
- Version, Sub_Version, Portable_Version);
+ "Portable File Version %4d Subversion %4d Binary Version %4d\n",
+ Portable_Version, Version, Sub_Version);
fprintf(stderr,
- "Expected: Version %4d Subversion %4d Portable Version %4d\n",
- FASL_FORMAT_VERSION, FASL_SUBVERSION, PORTABLE_VERSION);
+ "Expected: Version %4d Subversion %4d Binary Version %4d\n",
+ PORTABLE_VERSION, FASL_FORMAT_VERSION, FASL_SUBVERSION);
quit(1);
}
+\f
+ READ_HEADER("Flags", "%ld", Flags);
+ READ_FLAGS(Flags);
- Read_Flags(Flags);
-
- READ_HEADER("Heap Count", "%ld", &Heap_Count);
- READ_HEADER("Dumped Heap Base", "%ld", &Dumped_Heap_Base);
- READ_HEADER("Heap Objects", "%ld", &Heap_Objects);
+ if ((compiled_p || nmv_p) && (Machine != FASL_INTERNAL_FORMAT))
+ {
+ if (compiled_p)
+ {
+ fprintf(stderr,
+ "%s: Portable file contains \"invalid\" compiled code.\n",
+ Program_Name);
+ }
+ else
+ {
+ fprintf(stderr,
+ "%s: Portable file contains \"random\" non-marked vectors.\n",
+ Program_Name);
+ }
+ fprintf(stderr, "Portable File Machine %4d\n", Machine);
+ fprintf(stderr, "Expected: Machine %4d\n", FASL_INTERNAL_FORMAT);
+ quit(1);
+ }
+\f
+ READ_HEADER("Heap Count", "%ld", Heap_Count);
+ READ_HEADER("Dumped Heap Base", "%ld", Dumped_Heap_Base);
+ READ_HEADER("Heap Objects", "%ld", Heap_Objects);
- READ_HEADER("Constant Count", "%ld", &Constant_Count);
- READ_HEADER("Dumped Constant Base", "%ld", &Dumped_Constant_Base);
- READ_HEADER("Constant Objects", "%ld", &Constant_Objects);
+ READ_HEADER("Constant Count", "%ld", Constant_Count);
+ READ_HEADER("Dumped Constant Base", "%ld", Dumped_Constant_Base);
+ READ_HEADER("Constant Objects", "%ld", Constant_Objects);
- READ_HEADER("Pure Count", "%ld", &Pure_Count);
- READ_HEADER("Dumped Pure Base", "%ld", &Dumped_Pure_Base);
- READ_HEADER("Pure Objects", "%ld", &Pure_Objects);
+ READ_HEADER("Pure Count", "%ld", Pure_Count);
+ READ_HEADER("Dumped Pure Base", "%ld", Dumped_Pure_Base);
+ READ_HEADER("Pure Objects", "%ld", Pure_Objects);
- READ_HEADER("& Dumped Object", "%ld", &Dumped_Object_Addr);
+ READ_HEADER("& Dumped Object", "%ld", Dumped_Object_Addr);
- READ_HEADER("Number of flonums", "%ld", &NFlonums);
- READ_HEADER("Number of integers", "%ld", &NIntegers);
- READ_HEADER("Number of bits in integers", "%ld", &NBits);
- READ_HEADER("Number of bit strings", "%ld", &NBitstrs);
- READ_HEADER("Number of bits in bit strings", "%ld", &NBBits);
- READ_HEADER("Number of character strings", "%ld", &NStrings);
- READ_HEADER("Number of characters in strings", "%ld", &NChars);
+ READ_HEADER("Number of flonums", "%ld", NFlonums);
+ READ_HEADER("Number of integers", "%ld", NIntegers);
+ READ_HEADER("Number of bits in integers", "%ld", NBits);
+ READ_HEADER("Number of bit strings", "%ld", NBitstrs);
+ READ_HEADER("Number of bits in bit strings", "%ld", NBBits);
+ READ_HEADER("Number of character strings", "%ld", NStrings);
+ READ_HEADER("Number of characters in strings", "%ld", NChars);
- READ_HEADER("Primitive Table Length", "%ld", &Primitive_Table_Length);
- READ_HEADER("Number of characters in primitives", "%ld", &NPChars);
+ READ_HEADER("Primitive Table Length", "%ld", Primitive_Table_Length);
+ READ_HEADER("Number of characters in primitives", "%ld", NPChars);
Size = (6 + /* SNMV */
HEAP_BUFFER_SPACE +
\f
/* Top level */
-static int Noptions = 0;
-
/* C does not usually like empty initialized arrays, so ... */
-static struct Option_Struct Options[] = {{"dummy", true, NULL}};
+static struct Option_Struct Options[] =
+ {{"dummy", true, NULL}};
+
+static int Noptions = 0;
main(argc, argv)
int argc;
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 10.4 1987/11/18 19:30:26 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 10.5 1987/11/20 08:13:06 jinx Exp $
This file contains version information for the microcode. */
\f
#define VERSION 10
#endif
#ifndef SUBVERSION
-#define SUBVERSION 6
+#define SUBVERSION 7
#endif
#ifndef UCODE_TABLES_FILENAME
projects / mit-scheme.git / commitdiff