versions.
2) Make Psbtobin and Bintopsb use a new programmable command line
parser.
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.32 1988/01/04 18:58:17 cph Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bintopsb.c,v 9.33 1988/02/10 15:41:50 jinx Exp $
*
* This File contains the code to translate internal format binary
* files to portable format.
\f
/* IO definitions */
-#define Internal_File Input_File
-#define Portable_File Output_File
-
#include "psbmap.h"
#include "trap.h"
+#define internal_file input_file
+#define portable_file output_file
long
Load_Data(Count, To_Where)
{
extern int fread();
- return (fread(To_Where, sizeof(Pointer), Count, Internal_File));
+ return (fread(To_Where, sizeof(Pointer), Count, internal_file));
}
-#define Reloc_or_Load_Debug false
-
-#include "fasl.h"
#define INHIBIT_FASL_VERSION_CHECK
+#define INHIBIT_COMPILED_VERSION_CHECK
#include "load.c"
#include "bltdef.h"
\f
/* This is in some libraries but not others */
-static char punctuation[] = "'\",<.>/?;:{}[]|`~=+-_()*&^%$#@!";
+static char
+ punctuation[] = "'\",<.>/?;:{}[]|`~=+-_()*&^%$#@!";
Boolean
ispunct(c)
static Boolean
shuffle_bytes_p = false,
+ allow_nmv_p = false,
upgrade_traps_p = false,
upgrade_primitives_p = false,
upgrade_lengths_p = false,
allow_compiled_p = false,
- allow_nmv_p = false;
+ upgrade_compiled_p = false;
static long
Heap_Relocation, Constant_Relocation,
static Pointer
*Mem_Base,
*Free_Objects, *Free_Cobjects,
- *compiled_entry_table, *compiled_entry_pointer, *compiled_entry_table_end,
+ *compiled_entry_table, *compiled_entry_pointer,
+ *compiled_entry_table_end,
*primitive_table, *primitive_table_end;
static long
\f
#define OUT(s) \
{ \
- fprintf(Portable_File, (s)); \
+ fprintf(portable_file, (s)); \
break; \
}
default:
if ((isalpha(c)) || (isdigit(c)) || (ispunct(c)))
{
- putc(c, Portable_File);
+ putc(c, portable_file);
}
else
{
fprintf(stderr,
"%s: %s: File may not be portable: c = 0x%x\n",
- Program_Name, name, ((int) c));
+ program_name, name, ((int) c));
/* This does not follow C conventions, but eliminates ambiguity */
- fprintf(Portable_File, "\X%x ", ((int) c));
+ fprintf(portable_file, "\X%x ", ((int) c));
}
}
return;
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((Code), Old_Contents); \
} \
{
temp = temp >> 1;
}
- fprintf(Portable_File, "%02x %c ",
+ fprintf(portable_file, "%02x %c ",
TC_FIXNUM,
(val < 0 ? '-' : '+'));
if (val == 0)
{
- fprintf(Portable_File, "0\n");
+ fprintf(portable_file, "0\n");
}
else
{
- fprintf(Portable_File, "%ld ", size_in_bits);
+ fprintf(portable_file, "%ld ", size_in_bits);
temp = ((val < 0) ? -val : val);
while (temp != 0)
{
- fprintf(Portable_File, "%01lx", (temp & 0xf));
+ fprintf(portable_file, "%01lx", (temp & 0xf));
temp = temp >> 4;
}
- fprintf(Portable_File, "\n");
+ fprintf(portable_file, "\n");
}
return;
}
fast long len;
fast char *string;
{
- fprintf(Portable_File, "%ld ", len);
+ fprintf(portable_file, "%ld ", len);
if (shuffle_bytes_p)
{
while(len > 0)
print_a_char(*string++, "print_a_string");
}
}
- putc('\n', Portable_File);
+ putc('\n', portable_file);
return;
}
\f
maxlen = pointer_to_char((Get_Integer(*from++)) - 1);
len = STRING_LENGTH_TO_LONG(*from++);
- fprintf(Portable_File,
+ fprintf(portable_file,
"%02x %ld ",
TC_CHARACTER_STRING,
(compact_p ? len : maxlen));
long arity, length;
char *name;
{
- fprintf(Portable_File, "%ld ", arity);
+ fprintf(portable_file, "%ld ", arity);
print_a_string_internal(length, name);
return;
}
temp = LEN(the_number);
if (temp == 0)
{
- fprintf(Portable_File, "%02x + 0\n",
+ fprintf(portable_file, "%02x + 0\n",
(compact_p ? TC_FIXNUM : TC_BIG_FIXNUM));
}
else
temp = temp >> 1;
}
\f
- fprintf(Portable_File, "%02x %c %ld ",
+ fprintf(portable_file, "%02x %c %ld ",
(compact_p ? TC_FIXNUM : TC_BIG_FIXNUM),
(NEG_BIGNUM(the_number) ? '-' : '+'),
size_in_bits);
size_in_bits > 3;
size_in_bits -= 4)
{
- fprintf(Portable_File, "%01lx", (temp & 0xf));
+ fprintf(portable_file, "%01lx", (temp & 0xf));
temp = temp >> 4;
}
}
if (size_in_bits > 0)
{
- fprintf(Portable_File, "%01lx\n", (temp & 0xf));
+ fprintf(portable_file, "%01lx\n", (temp & 0xf));
}
else
{
- fprintf(Portable_File, "\n");
+ fprintf(portable_file, "\n");
}
}
return;
the_bit_string = Make_Pointer(TC_BIT_STRING, from);
bits_remaining = bit_string_length(the_bit_string);
- fprintf(Portable_File, "%02x %ld", TC_BIT_STRING, bits_remaining);
+ fprintf(portable_file, "%02x %ld", TC_BIT_STRING, bits_remaining);
if (bits_remaining != 0)
{
- fprintf(Portable_File, " ");
+ fprintf(portable_file, " ");
scan = bit_string_low_ptr(the_bit_string);
for (leftover_bits = 0;
bits_remaining > 0;
leftover_bits += ((bits_remaining > POINTER_LENGTH) ?
(POINTER_LENGTH - 4) :
(bits_remaining - 4));
- fprintf(Portable_File, "%01lx", (accumulator & 0xf));
+ fprintf(portable_file, "%01lx", (accumulator & 0xf));
}
else
{
for(accumulator = next_word; leftover_bits >= 4; leftover_bits -= 4)
{
- fprintf(Portable_File, "%01lx", (accumulator & 0xf));
+ fprintf(portable_file, "%01lx", (accumulator & 0xf));
accumulator = accumulator >> 4;
}
}
if (leftover_bits != 0)
{
- fprintf(Portable_File, "%01lx", (accumulator & 0xf));
+ fprintf(portable_file, "%01lx", (accumulator & 0xf));
}
}
- fprintf(Portable_File, "\n");
+ fprintf(portable_file, "\n");
return;
}
\f
int expt;
extern double frexp();
- fprintf(Portable_File, "%02x %c ",
+ fprintf(portable_file, "%02x %c ",
TC_BIG_FLONUM,
((val < 0.0) ? '-' : '+'));
if (val == 0.0)
{
- fprintf(Portable_File, "0\n");
+ fprintf(portable_file, "0\n");
return;
}
mant = frexp(((val < 0.0) ? -val : val), &expt);
if (temp >= 1.0)
temp -= 1.0;
}
- fprintf(Portable_File, "%ld %ld ", expt, size_in_bits);
+ fprintf(portable_file, "%ld %ld ", expt, size_in_bits);
for (size_in_bits = hex_digits(size_in_bits);
size_in_bits > 0;
digit += 1;
}
}
- fprintf(Portable_File, "%01x", digit);
+ fprintf(portable_file, "%01x", digit);
}
- putc('\n', Portable_File);
+ putc('\n', portable_file);
return;
}
\f
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 \
{ \
*Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer(OBJECT_TYPE(This), (Fre)); \
Mem_Base[(Fre)++] = Old_Contents; \
} \
}
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 \
{ \
*Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer(OBJECT_TYPE(This), (Fre)); \
Mem_Base[(Fre)++] = Old_Contents; \
Mem_Base[(Fre)++] = *Old_Address++; \
} \
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 \
{ \
*Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer(OBJECT_TYPE(This), (Fre)); \
Mem_Base[(Fre)++] = Old_Contents; \
Mem_Base[(Fre)++] = *Old_Address++; \
Mem_Base[(Fre)++] = *Old_Address++; \
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 \
{ \
*Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer(OBJECT_TYPE(This), (Fre)); \
Mem_Base[(Fre)++] = Old_Contents; \
Mem_Base[(Fre)++] = *Old_Address++; \
Mem_Base[(Fre)++] = *Old_Address++; \
} \
}
\f
-#define Do_Compiled_Entry(COde, Rel, Fre, Scn, Obj, FObj) \
+#define Do_Compiled_Entry(Code, Rel, Fre, Scn, Obj, FObj) \
{ \
long offset; \
Pointer *saved; \
#define Do_Pointer(Scn, Action) \
{ \
+ long the_datum; \
+ \
Old_Address = Get_Pointer(This); \
- if (Datum(This) < Const_Base) \
+ the_datum = OBJECT_DATUM(This); \
+ if ((the_datum >= Heap_Base) && \
+ (the_datum < Dumped_Heap_Top)) \
{ \
Action(HEAP_CODE, Heap_Relocation, Free, \
Scn, Objects, Free_Objects); \
} \
- else if (Datum(This) < Dumped_Constant_Top) \
+ \
+ /* \
+ \
+ Currently constant space is not supported \
+ \
+ else if ((the_datum >= Const_Base) && \
+ (the_datum < Dumped_Constant_Top)) \
{ \
Action(CONSTANT_CODE, Constant_Relocation, Free_Constant, \
Scn, Constant_Objects, Free_Cobjects); \
} \
+ \
+ */ \
+ \
else \
{ \
- fprintf(stderr, \
- "%s: File is not portable: Pointer to stack.\n", \
- Program_Name); \
- quit(1); \
+ out_of_range_pointer(This); \
} \
(Scn) += 1; \
break; \
}
\f
-/* Primitive upgrading code. */
-
-#define PRIMITIVE_UPGRADE_SPACE 2048
-static Pointer *internal_renumber_table;
-static Pointer *external_renumber_table;
-static Pointer *external_prim_name_table;
-static Boolean found_ext_prims = false;
+void
+out_of_range_pointer(ptr)
+ Pointer ptr;
+{
+ fprintf(stderr,
+ "%s: The input file is not portable: Out of range pointer.\n",
+ program_name);
+ fprintf(stderr, "Heap_Base = 0x%lx;\tHeap_Top = 0x%lx\n",
+ Heap_Base, Dumped_Heap_Top);
+ fprintf(stderr, "Const_Base = 0x%lx;\tConst_Top = 0x%lx\n",
+ Const_Base, Dumped_Constant_Top);
+ fprintf(stderr, "ptr = 0x%02x|0x%lx\n",
+ OBJECT_TYPE(ptr), OBJECT_DATUM(ptr));
+ quit(1);
+}
Pointer *
relocate(object)
Pointer object;
{
+ long the_datum;
Pointer *result;
- result = (Get_Pointer(object) + ((Datum(object) < Const_Base) ?
- Heap_Relocation :
- Constant_Relocation));
+
+ result = Get_Pointer(object);
+ the_datum = OBJECT_DATUM(object);
+
+ if ((the_datum >= Heap_Base) &&
+ (the_datum < Dumped_Heap_Top))
+ {
+ result += Heap_Relocation;
+ }
+
+#if false
+
+ /* Currently constant space is not supported */
+
+ else if (( the_datum >= Const_Base) &&
+ (the_datum < Dumped_Constant_Top))
+ {
+ result += Constant_Relocation;
+ }
+
+#endif /* false */
+
+ else
+ {
+ out_of_range_pointer(object);
+ }
return (result);
}
+\f
+/* Primitive upgrading code. */
+
+#define PRIMITIVE_UPGRADE_SPACE 2048
+
+static Pointer
+ *internal_renumber_table,
+ *external_renumber_table,
+ *external_prim_name_table;
+
+static Boolean
+ found_ext_prims = false;
Pointer
upgrade_primitive(prim)
Pointer prim;
{
- long datum, type, new_type, code;
+ long the_datum, the_type, new_type, code;
Pointer new;
- datum = OBJECT_DATUM(prim);
- type = OBJECT_TYPE(prim);
- if (type != TC_PRIMITIVE_EXTERNAL)
+ the_datum = OBJECT_DATUM(prim);
+ the_type = OBJECT_TYPE(prim);
+ if (the_type != TC_PRIMITIVE_EXTERNAL)
{
- code = datum;
- new_type = type;
+ code = the_datum;
+ new_type = the_type;
}
else
{
found_ext_prims = true;
- code = (datum + (MAX_BUILTIN_PRIMITIVE + 1));
+ code = (the_datum + (MAX_BUILTIN_PRIMITIVE + 1));
new_type = TC_PRIMITIVE;
}
\f
internal_renumber_table[code] = new;
external_renumber_table[Primitive_Table_Length] = prim;
Primitive_Table_Length += 1;
- if (type == TC_PRIMITIVE_EXTERNAL)
+ if (the_type == TC_PRIMITIVE_EXTERNAL)
{
NPChars +=
- STRING_LENGTH_TO_LONG((((Pointer *) (external_prim_name_table[datum]))
+ STRING_LENGTH_TO_LONG((((Pointer *)
+ (external_prim_name_table[the_datum]))
[STRING_LENGTH]));
}
else
{
- NPChars += strlen(builtin_prim_name_table[datum]);
+ NPChars += strlen(builtin_prim_name_table[the_datum]);
}
return (new);
}
length += (MAX_BUILTIN_PRIMITIVE + 1);
if (length > PRIMITIVE_UPGRADE_SPACE)
{
- fprintf(stderr, "%s: Too many primitives.\n", Program_Name);
+ fprintf(stderr, "%s: Too many primitives.\n", program_name);
fprintf(stderr,
"Increase PRIMITIVE_UPGRADE_SPACE and recompile %s.\n",
- Program_Name);
+ program_name);
quit(1);
}
for (count = 0; count < length; count += 1)
This = Mem_Base[*Area];
#ifdef PRIMITIVE_EXTERNAL_REUSED
- if (upgrade_primitives_p && (Type_Code(This) == TC_PRIMITIVE_EXTERNAL))
+ if (upgrade_primitives_p &&
+ (OBJECT_TYPE(This) == TC_PRIMITIVE_EXTERNAL))
{
Mem_Base[*Area] = upgrade_primitive(This);
*Area += 1;
else if (!allow_nmv_p)
{
fprintf(stderr, "%s: File is not portable: NMH found\n",
- Program_Name);
+ program_name);
}
*Area += (1 + OBJECT_DATUM(This));
break;
if (OBJECT_DATUM(This) != 0)
{
fprintf(stderr, "%s: Broken Heart found in scan.\n",
- Program_Name);
+ program_name);
quit(1);
}
*Area += 1;
{
fprintf(stderr,
"%s: File contains compiled code.\n",
- Program_Name);
+ program_name);
quit(1);
}
Do_Pointer(*Area, Do_Compiled_Entry);
case TC_STACK_ENVIRONMENT:
fprintf(stderr,
"%s: File contains stack environments.\n",
- Program_Name);
+ program_name);
quit(1);
\f
case TC_FIXNUM:
{
long kind;
- kind = Datum(This);
+ kind = OBJECT_DATUM(This);
if (upgrade_traps_p)
{
}
fprintf(stderr,
"%s: Bad old unassigned object. 0x%x.\n",
- Program_Name, This);
+ program_name, This);
quit(1);
}
if (kind <= TRAP_MAX_IMMEDIATE)
{
fprintf(stderr,
"%s: Cannot upgrade environments.\n",
- Program_Name);
+ program_name);
quit(1);
}
/* Fall through */
case TC_FUTURE:
case_simple_Vector:
- if (Type_Code(This) == TC_BIT_STRING)
+ if (OBJECT_TYPE(This) == TC_BIT_STRING)
{
Do_Pointer(*Area, Do_Bit_String);
}
default:
Bad_Type:
fprintf(stderr, "%s: Unknown Type Code 0x%x found.\n",
- Program_Name, Type_Code(This));
+ program_name, OBJECT_TYPE(This));
quit(1);
}
}
{
while (--count >= 0)
{
- switch(Type_Code(*from))
+ switch(OBJECT_TYPE(*from))
{
case TC_FIXNUM:
{
break;
case TC_CHARACTER:
- fprintf(Portable_File, "%02x %03x\n",
+ 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);
+ program_name, *from);
quit(1);
}
}
print_objects(from, to)
fast Pointer *from, *to;
{
- fast long datum, type;
+ fast long the_datum, the_type;
while(from < to)
{
- type = OBJECT_TYPE(*from);
- datum = OBJECT_DATUM(*from);
+ the_type = OBJECT_TYPE(*from);
+ the_datum = OBJECT_DATUM(*from);
from += 1;
- if (type == TC_MANIFEST_NM_VECTOR)
+ if (the_type == TC_MANIFEST_NM_VECTOR)
{
- fprintf(Portable_File, "%02x %lx\n", type, datum);
- while (--datum >= 0)
+ fprintf(portable_file, "%02x %lx\n", the_type, the_datum);
+ while (--the_datum >= 0)
{
- fprintf(Portable_File, "%lx\n", ((unsigned long) *from++));
+ fprintf(portable_file, "%lx\n", ((unsigned long) *from++));
}
}
- else if (type == TC_COMPILED_EXPRESSION)
+ else if (the_type == TC_COMPILED_EXPRESSION)
{
Pointer base;
long offset;
- Sign_Extend(compiled_entry_table[datum], offset);
- base = compiled_entry_table[datum + 1];
+ Sign_Extend(compiled_entry_table[the_datum], offset);
+ base = compiled_entry_table[the_datum + 1];
- fprintf(Portable_File, "%02x %lx %02x %lx\n",
+ 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);
+ fprintf(portable_file, "%02x %lx\n", the_type, the_datum);
}
}
return;
if (what)
{
fprintf(stderr, "%s: Inconsistency: %s!\n",
- Program_Name, (message));
+ program_name, (message));
quit(1);
}
return;
#define PRINT_HEADER(name, format, obj) \
{ \
- fprintf(Portable_File, (format), (obj)); \
- fprintf(Portable_File, "\n"); \
+ fprintf(portable_file, (format), (obj)); \
+ fprintf(portable_file, "\n"); \
fprintf(stderr, "%s: ", (name)); \
fprintf(stderr, (format), (obj)); \
fprintf(stderr, "\n"); \
#define PRINT_HEADER(name, format, obj) \
{ \
- fprintf(Portable_File, (format), (obj)); \
- fprintf(Portable_File, "\n"); \
+ fprintf(portable_file, (format), (obj)); \
+ fprintf(portable_file, "\n"); \
}
#endif /* DEBUG */
/* Load the Data */
- if (!Read_Header())
+ if (Read_Header() != FASL_FILE_FINE)
{
fprintf(stderr,
- "%s: Input file does not appear to be in FASL format.\n",
- Program_Name);
+ "%s: Input file does not appear to be in an appropriate format.\n",
+ program_name);
quit(1);
}
((Machine_Type != FASL_INTERNAL_FORMAT) &&
(!shuffle_bytes_p)))
{
- fprintf(stderr, "%s:\n", Program_Name);
+ fprintf(stderr, "%s:\n", program_name);
fprintf(stderr,
"FASL File Version %ld Subversion %ld Machine Type %ld\n",
Version, Sub_Version , Machine_Type);
FASL_READ_VERSION, FASL_READ_SUBVERSION, FASL_INTERNAL_FORMAT);
quit(1);
}
+\f
+ if ((((compiler_processor_type != 0) &&
+ (dumped_processor_type != 0) &&
+ (compiler_processor_type != dumped_processor_type)) ||
+ ((compiler_interface_version != 0) &&
+ (dumped_interface_version != 0) &&
+ (compiler_interface_version != dumped_interface_version))) &&
+ (!upgrade_compiled_p))
+ {
+ fprintf(stderr, "\nread_file:\n");
+ fprintf(stderr,
+ "FASL File: compiled code interface %4d; processor %4d.\n",
+ dumped_interface_version, dumped_processor_type);
+ fprintf(stderr,
+ "Expected: compiled code interface %4d; processor %4d.\n",
+ compiler_interface_version, compiler_processor_type);
+ quit(1);
+ }
+ if (compiler_processor_type != 0)
+ {
+ dumped_processor_type = compiler_processor_type;
+ }
+ if (compiler_interface_version != 0)
+ {
+ dumped_interface_version = compiler_interface_version;
+ }
- /* Constant Space not currently supported */
+ /* Constant Space and bands not currently supported */
+
+ if (band_p)
+ {
+ fprintf(stderr, "%s: Input file is a band.\n", program_name);
+ quit(1);
+ }
if (Const_Count != 0)
{
fprintf(stderr,
"%s: Input file has a constant space area.\n",
- Program_Name);
+ program_name);
quit(1);
}
\f
+ allow_compiled_p = (allow_compiled_p || upgrade_compiled_p);
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);
+ program_name);
quit(1);
}
upgrade_traps_p = (Sub_Version < FASL_REFERENCE_TRAP);
upgrade_primitives_p = (Sub_Version < FASL_MERGED_PRIMITIVES);
upgrade_lengths_p = upgrade_primitives_p;
+
+ DEBUGGING(fprintf(stderr,
+ "Dumped Heap Base = 0x%08x\n",
+ Heap_Base));
+
+ DEBUGGING(fprintf(stderr,
+ "Dumped Constant Base = 0x%08x\n",
+ Const_Base));
+
+ DEBUGGING(fprintf(stderr,
+ "Dumped Constant Top = 0x%08x\n",
+ Dumped_Constant_Top));
+
+ DEBUGGING(fprintf(stderr,
+ "Heap Count = %6d\n",
+ Heap_Count));
+
+ DEBUGGING(fprintf(stderr,
+ "Constant Count = %6d\n",
+ Const_Count));
\f
{
long Size;
{
fprintf(stderr,
"%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n",
- Program_Name, Size);
+ program_name, Size);
quit(1);
}
}
Initial_Align_Float(Heap);
Load_Data(Heap_Count, &Heap[0]);
Load_Data(Const_Count, &Heap[Heap_Count]);
- Load_Data(Primitive_Table_Size, &Heap[Heap_Count + Const_Count]);
- Heap_Relocation = &Heap[0] - Get_Pointer(Heap_Base);
- Constant_Relocation = &Heap[Heap_Count] - Get_Pointer(Const_Base);
-
- DEBUGGING(fprintf(stderr,
- "Dumped Heap Base = 0x%08x\n",
- Heap_Base));
-
- DEBUGGING(fprintf(stderr,
- "Dumped Constant Base = 0x%08x\n",
- Const_Base));
-
- DEBUGGING(fprintf(stderr,
- "Dumped Constant Top = 0x%08x\n",
- Dumped_Constant_Top));
-
- DEBUGGING(fprintf(stderr,
- "Heap Count = %6d\n",
- Heap_Count));
-
- DEBUGGING(fprintf(stderr,
- "Constant Count = %6d\n",
- Const_Count));
+ Heap_Relocation = ((&Heap[0]) - (Get_Pointer(Heap_Base)));
+ Constant_Relocation = ((&Heap[Heap_Count]) - (Get_Pointer(Const_Base)));
\f
- /* Determine primitive information. */
+ /* Setup compiled code and primitive tables. */
compiled_entry_table = &Heap[Heap_Count + Const_Count];
compiled_entry_pointer = compiled_entry_table;
fast Pointer *table;
fast long count, char_count;
+ Load_Data(Primitive_Table_Size, primitive_table);
for (char_count = 0,
count = Primitive_Table_Length,
table = primitive_table;
if (found_ext_prims)
{
- fprintf(stderr, "%s:\n", Program_Name);
+ fprintf(stderr, "%s:\n", program_name);
fprintf(stderr, "NOTE: The arity of some primitives is not known.\n");
fprintf(stderr, " The portable file has %ld as their arity.\n",
UNKNOWN_PRIMITIVE_ARITY);
PRINT_HEADER("Number of primitives", "%ld", Primitive_Table_Length);
PRINT_HEADER("Number of characters in primitives", "%ld", NPChars);
+
+ if (!compiled_p)
+ {
+ dumped_processor_type = 0;
+ dumped_interface_version = 0;
+ }
+
+ PRINT_HEADER("CPU type", "%ld", dumped_processor_type);
+ PRINT_HEADER("Compiled code interface version", "%ld",
+ dumped_interface_version);
+#if false
+ PRINT_HEADER("Compiler utilities vector", "%ld",
+ OBJECT_DATUM(dumped_utilities));
+#endif
\f
/* External Objects */
{
Pointer obj;
fast Pointer *table;
- fast long count, datum;
+ fast long count, the_datum;
for (count = Primitive_Table_Length,
table = external_renumber_table;
--count >= 0;)
{
obj = *table++;
- datum = OBJECT_DATUM(obj);
+ the_datum = OBJECT_DATUM(obj);
if (OBJECT_TYPE(obj) == TC_PRIMITIVE_EXTERNAL)
{
Pointer *strobj;
- strobj = ((Pointer *) (external_prim_name_table[datum]));
+ strobj = ((Pointer *) (external_prim_name_table[the_datum]));
print_a_primitive(((long) UNKNOWN_PRIMITIVE_ARITY),
(STRING_LENGTH_TO_LONG(strobj[STRING_LENGTH])),
((char *) &strobj[STRING_CHARS]));
}
else
{
- char *string;
+ char *str;
- string = builtin_prim_name_table[datum];
- print_a_primitive(((long) builtin_prim_arity_table[datum]),
- ((long) strlen(string)),
- string);
+ str = builtin_prim_name_table[the_datum];
+ print_a_primitive(((long) builtin_prim_arity_table[the_datum]),
+ ((long) strlen(str)),
+ str);
}
}
}
\f
/* Top Level */
-/* The boolean value here is what value to store when the option is present. */
+Boolean ci_version_sup_p, ci_processor_sup_p;
-static struct Option_Struct Options[] =
- {{"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}};
+/* The boolean value here is what value to store when the option is present. */
-static int Noptions = 5;
+static struct keyword_struct
+ options[] = {
+ KEYWORD("swap_bytes", &shuffle_bytes_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD("compact", &compact_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD("null_nmv", &null_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD("allow_nmv", &allow_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD("allow_cc", &allow_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD("upgrade_cc", &upgrade_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD("ci_version", &compiler_interface_version, INT_KYWRD, "%ld",
+ &ci_version_sup_p),
+ KEYWORD("ci_processor", &compiler_processor_type, INT_KYWRD, "%ld",
+ &ci_processor_sup_p),
+ OUTPUT_KEYWORD(),
+ INPUT_KEYWORD(),
+ END_KEYWORD()
+ };
main(argc, argv)
int argc;
char *argv[];
{
- Setup_Program(argc, argv, Noptions, Options);
+ parse_keywords(argc, argv, options, false);
+ setup_io();
do_it();
quit(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/fasload.c,v 9.33 1988/02/06 20:40:36 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasload.c,v 9.34 1988/02/10 15:43:35 jinx Exp $
The "fast loader" which reads in and relocates binary files and then
interns symbols. It is called with one argument: the (character
string) name of a file to load. It is called as a primitive, and
returns a single object read in.
*/
-\f
+
#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)
-
-#include "fasl.h"
#include "load.c"
\f
long
long value, heap_length;
Boolean file_opened;
- if (Type_Code(name) != TC_CHARACTER_STRING)
+ if (OBJECT_TYPE(name) != TC_CHARACTER_STRING)
{
return (ERR_ARG_1_WRONG_TYPE);
}
case FASL_FILE_BAD_INTERFACE:
return (ERR_FASLOAD_COMPILED_MISMATCH);
}
- }
-
- if (File_Load_Debug)
+ }
+
+ if (Or2(Reloc_Debug, File_Load_Debug))
{
- printf("\nMachine type %d, Version %d, Subversion %d\n",
- Machine_Type, Version, Sub_Version);
+ print_fasl_information();
}
if (!Test_Pure_Space_Top(Free_Constant + Const_Count))
Align_Float(Free);
#endif
- if (Load_Data(Heap_Count, ((char *) Free)) != Heap_Count)
+ if ((Load_Data(Heap_Count, ((char *) Free))) != Heap_Count)
{
Close_Dump_File();
Primitive_Error(ERR_IO_ERROR);
NORMALIZE_REGION(((char *) Free), Heap_Count);
Free += Heap_Count;
- if (Load_Data(Const_Count, ((char *) Free_Constant)) != Const_Count)
+ if ((Load_Data(Const_Count, ((char *) Free_Constant))) != Const_Count)
{
Close_Dump_File();
Primitive_Error(ERR_IO_ERROR);
Free_Constant += Const_Count;
table = Free;
- if (Load_Data(Primitive_Table_Size, ((char *) Free)) !=
+ if ((Load_Data(Primitive_Table_Size, ((char *) Free))) !=
Primitive_Table_Size)
{
Close_Dump_File();
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/load.c,v 9.25 1988/02/06 20:41:11 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/load.c,v 9.26 1988/02/10 15:43:53 jinx Rel $
*
* This file contains common code for reading internal
* format binary files.
band_p;
static long
- Version, Sub_Version, Machine_Type,
- Dumped_Object,
+ Machine_Type, Version, Sub_Version,
+ Dumped_Object, Dumped_Stack_Top,
Heap_Base, Heap_Count,
Const_Base, Const_Count,
Dumped_Heap_Top, Dumped_Constant_Top,
- Dumped_Stack_Top,
Primitive_Table_Size, Primitive_Table_Length,
dumped_processor_type, dumped_interface_version;
Ext_Prim_Vector,
dumped_utilities;
\f
+void
+print_fasl_information()
+{
+ printf("FASL File Information:\n\n");
+ printf("Machine = %ld; Version = %ld; Subversion = %ld\n",
+ Machine_Type, Version, Sub_Version);
+ if ((dumped_processor_type != 0) || (dumped_interface_version != 0))
+ {
+ printf("Compiled code interface version = %ld; Processor type = %ld\n",
+ dumped_interface_version, dumped_processor_type);
+ }
+ if (band_p)
+ {
+ printf("The file contains a dumped image (band).\n");
+ }
+
+ printf("\nRelocation Information:\n\n");
+ printf("Heap Count = %ld; Heap Base = 0x%lx; Heap Top = 0x%lx\n",
+ Heap_Count, Heap_Base, Dumped_Heap_Top);
+ printf("Const Count = %ld; Const Base = 0x%lx; Const Top = 0x%lx\n",
+ Const_Count, Const_Base, Dumped_Constant_Top);
+ printf("Stack Top = 0x%lx\n", Dumped_Stack_Top);
+
+ printf("\nDumped Objects:\n\n");
+ printf("Dumped object at 0x%lx (as read from file)\n", Dumped_Object);
+ printf("Compiled code utilities vector = 0x%lx\n", dumped_utilities);
+ if (Ext_Prim_Vector != NIL)
+ {
+ printf("External primitives vector = 0x%lx\n", Ext_Prim_Vector);
+ }
+ else
+ {
+ printf("Length of primitive table = %ld\n", Primitive_Table_Length);
+ }
+ return;
+}
+\f
long
Read_Header()
{
dumped_interface_version = CI_VERSION(temp);
dumped_utilities = Buffer[FASL_Offset_Ut_Base];
}
-
- if (Reloc_or_Load_Debug)
- {
- printf("FASL File Information:\n\n");
- printf("Machine = %ld; Version = %ld; Subversion = %ld\n",
- Machine_Type, Version, Sub_Version);
- printf("Dumped processor type = %ld; Dumped interface version = %ld\n",
- dumped_processor_type, dumped_interface_version);
- if (band_p)
- {
- printf("The file contains a dumped image (band).\n");
- }
-
- printf("\nRelocation Information:\n\n");
- printf("Heap Count = %ld; Heap Base = 0x%lx; Dumped Heap Top = 0x%lx\n",
- Heap_Count, Heap_Base, Dumped_Heap_Top);
- printf("Const Count = %ld; Const Base = 0x%lx, Dumped Constant Top = 0x%lx\n",
- Const_Count, Const_Base, Dumped_Constant_Top);
- printf("Dumped Stack Top = 0x%lx, Ext Prim Vector = 0x%lx\n",
- Dumped_Stack_Top, Ext_Prim_Vector);
-
- printf("\nDumped Objects:\n\n");
- printf("Length of primitive table = %ld\n", Primitive_Table_Length);
- printf("Dumped utilities = 0x%lx\n", dumped_utilities);
- printf("Dumped Object (as read from file) = 0x%lx\n", Dumped_Object);
- }
\f
#ifndef INHIBIT_FASL_VERSION_CHECK
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.30 1988/02/06 20:37:50 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/ppband.c,v 9.31 1988/02/10 15:42:58 jinx Exp $
*
* Dumps Scheme FASL in user-readable form .
*/
exit(1);
}
\f
-#define Reloc_or_Load_Debug true
#define INHIBIT_COMPILED_VERSION_CHECK
-
-#include "fasl.h"
#include "load.c"
#ifdef Heap_In_Low_Memory
argv[0]);
exit(1);
}
+ print_fasl_information();
printf("Dumped object (relocated) at 0x%lx\n", Relocate(Dumped_Object));
}
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/Attic/psbmap.h,v 9.25 1987/11/23 04:55:56 cph Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/psbmap.h,v 9.26 1988/02/10 15:44:07 jinx Rel $
*
* This file contains macros and declarations for Bintopsb.c
* and Psbtobin.c
from the included files.
*/
-#include <stdio.h>
#define fast register
+#include <stdio.h>
#include "config.h"
#include "object.h"
#include "bignum.h"
#include "missing.c"
#endif
-#define PORTABLE_VERSION 4
+#define PORTABLE_VERSION 5
/* Number of objects which, when traced recursively, point at all other
objects dumped. Currently only the dumped object.
#define NULL_NMV_P (1 << 1)
#define COMPILED_P (1 << 2)
#define NMV_P (1 << 3)
+#define BAND_P (1 << 4)
#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))
+ (nmv_p ? NMV_P : 0) | \
+ (band_p ? BAND_P : 0))
#define READ_FLAGS(f) \
{ \
null_nmv_p = ((f) & NULL_NMV_P); \
compiled_p = ((f) & COMPILED_P); \
nmv_p = ((f) & NMV_P); \
+ band_p = ((f) & BAND_P); \
}
/*
static Pointer *Memory_Base;
#endif
-static FILE *Input_File, *Output_File;
+static long
+ compiler_processor_type = 0,
+ compiler_interface_version = 0;
-static char *Program_Name;
+static Pointer
+ compiler_utilities = NIL;
\f
-/* Argument List Parsing */
+/* Utilities */
-struct Option_Struct
-{
- char *name;
- Boolean value;
- Boolean *ptr;
-};
+static char
+ *input_file_name = "-",
+ *output_file_name = "-";
+
+FILE *input_file, *output_file;
Boolean
strequal(s1, s2)
- fast char *s1, *s2;
+ register char *s1, *s2;
{
- while (*s1 != '\0')
+ for ( ; *s1 != '\0'; s1++, s2++)
{
- if (*s1++ != *s2++)
+ if (*s1 != *s2)
{
- return false;
+ return (false);
}
}
return (*s2 == '\0');
}
-
-char *
-Find_Options(argc, argv, Noptions, Options)
- int argc;
- char **argv;
- int Noptions;
- struct Option_Struct Options[];
-{
- for ( ; --argc >= 0; argv++)
- {
- char *this;
- int n;
-
- this = *argv;
- for (n = 0;
- ((n < Noptions) && (!strequal(this, Options[n].name)));
- n++)
- {};
- if (n >= Noptions)
- {
- return (this);
- }
- *(Options[n].ptr) = Options[n].value;
- }
- return (NULL);
-}
\f
-/* Usage information */
-
void
-Print_Options(n, options, where)
- int n;
- struct Option_Struct *options;
- FILE *where;
+setup_io()
{
- if (--n < 0)
+ if (strequal(input_file_name, "-"))
{
- return;
+ input_file = stdin;
}
- fprintf(where, "[%s]", options->name);
- options += 1;
- for (; --n >= 0; options += 1)
+ else
{
- fprintf(where, " [%s]", options->name);
+ input_file = fopen(input_file_name, "r");
+ if (input_file == ((FILE *) NULL))
+ {
+ fprintf(stderr, "%s: failed to open %s for input.\n",
+ input_file_name);
+ exit(1);
+ }
}
- return;
-}
-void
-Print_Usage_and_Exit(noptions, options, io_options)
- int noptions;
- struct Option_Struct *options;
- char *io_options;
-{
- fprintf(stderr, "usage: %s%s%s",
- Program_Name,
- (((io_options == NULL) ||
- (io_options[0] == '\0')) ? "" : " "),
- io_options);
- if (noptions != 0)
+ if (strequal(output_file_name, "-"))
{
- putc(' ', stderr);
- Print_Options(noptions, options, stderr);
+ output_file = stdout;
}
- putc('\n', stderr);
- exit(1);
-}
-\f
-/* Top level of program */
-
-/* When debugging force arguments on command line */
-
-#ifdef DEBUG
-#undef unix
-#endif
-
-#ifdef unix
-
-/* On unix use io redirection */
-
-void
-Setup_Program(argc, argv, Noptions, Options)
- int argc;
- char *argv[];
- int Noptions;
- struct Option_Struct *Options;
-{
- Program_Name = argv[0];
- Input_File = stdin;
- Output_File = stdout;
- if (((argc - 1) > Noptions) ||
- (Find_Options((argc - 1), &argv[1], Noptions, Options) != NULL))
+ else
{
- Print_Usage_and_Exit(Noptions, Options, "");
+ output_file = fopen(output_file_name, "w");
+ if (output_file == ((FILE *) NULL))
+ {
+ fprintf(stderr, "%s: failed to open %s for output.\n",
+ output_file_name);
+ fclose(input_file);
+ exit(1);
+ }
}
return;
}
-#define quit exit
-\f
-#else /* not unix */
-
-/* Otherwise use command line arguments */
-
-void
-Setup_Program(argc, argv, Noptions, Options)
- int argc;
- char *argv[];
- int Noptions;
- struct Option_Struct *Options;
-{
- Program_Name = argv[0];
- if ((argc < 3) ||
- ((argc - 3) > Noptions) ||
- (Find_Options((argc - 3), &argv[3], Noptions, Options) != NULL))
- {
- Print_Usage_and_Exit(Noptions, Options, "input_file output_file");
- }
- Input_File = ((strequal(argv[1], "-")) ?
- stdin :
- fopen(argv[1], "r"));
- if (Input_File == NULL)
- {
- perror("Open failed.");
- exit(1);
- }
- Output_File = ((strequal(argv[2], "-")) ?
- stdout :
- fopen(argv[2], "w"));
- if (Output_File == NULL)
- {
- perror("Open failed.");
- fclose(Input_File);
- exit(1);
- }
- fprintf(stderr, "%s: Reading from %s, writing to %s.\n",
- Program_Name, argv[1], argv[2]);
- return;
-}
-\f
void
quit(code)
int code;
{
- fclose(Input_File);
- fclose(Output_File);
- /* VMS brain dammage */
+ fclose(input_file);
+ fclose(output_file);
+#ifdef vms
+ /* This assumes that it is only invoked with 0 in tail recursive psn. */
if (code != 0)
{
exit(code);
}
- return;
+ else
+ {
+ return;
+ }
+#else /* not vms */
+ exit(code);
+#endif /*vms */
}
+\f
+/* Include the command line parser */
+
+#define boolean Boolean
+#include "comlin.c"
-#endif /* unix */
+#define INPUT_KEYWORD() \
+KEYWORD("input", &input_file_name, STRING_KYWRD, SFRMT, NULL)
+#define OUTPUT_KEYWORD() \
+KEYWORD("output", &output_file_name, STRING_KYWRD, SFRMT, NULL)
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.31 1988/01/04 18:55:54 cph Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/psbtobin.c,v 9.32 1988/02/10 15:43:12 jinx Exp $
*
* This File contains the code to translate portable format binary
* files to internal format.
\f
/* Cheap renames */
-#define Portable_File Input_File
-#define Internal_File Output_File
-
#include "psbmap.h"
+#define portable_file input_file
+#define internal_file output_file
static Boolean
+ band_p = false;
allow_compiled_p = false,
allow_nmv_p = false;
{
extern int fwrite();
- return (fwrite(((char *) From_Where), sizeof(Pointer), Count, Internal_File));
+ return (fwrite(((char *) From_Where), sizeof(Pointer),
+ Count, internal_file));
}
#include "fasl.h"
/* Provide some context (2 lines). */
char yow[100];
- fgets(&yow[0], 100, Portable_File);
+ fgets(&yow[0], 100, portable_file);
fprintf(stderr, "%s\n", &yow[0]);
- fgets(&yow[0], 100, Portable_File);
+ fgets(&yow[0], 100, portable_file);
fprintf(stderr, "%s\n", &yow[0]);
quit(1);
{
fast char C;
- C = getc(Portable_File);
+ C = getc(portable_file);
if (C != '\\')
{
OUT(C);
}
- C = getc(Portable_File);
+ C = getc(portable_file);
switch(C)
{
case 'n': OUT('\n');
fprintf(stderr,
"%s: File is not Portable. Character Code Found.\n",
- Program_Name);
- fscanf(Portable_File, "%ld", &Code);
- getc(Portable_File); /* Space */
+ program_name);
+ fscanf(portable_file, "%ld", &Code);
+ getc(portable_file); /* Space */
OUT(Code);
}
case '\\': OUT('\\');
long maxlen;
{
long ilen, Pointer_Count;
- fast char *string;
+ fast char *str;
fast long len;
- string = ((char *) (&To[STRING_CHARS]));
- fscanf(Portable_File, "%ld", &ilen);
+ str = ((char *) (&To[STRING_CHARS]));
+ fscanf(portable_file, "%ld", &ilen);
len = ilen;
if (maxlen == -1)
/* Space */
- getc(Portable_File);
+ getc(portable_file);
while (--len >= 0)
{
- *string++ = ((char) read_a_char());
+ *str++ = ((char) read_a_char());
}
- *string = '\0';
+ *str = '\0';
return (To + Pointer_Count);
}
long maxlen;
*Slot = Make_Pointer(TC_CHARACTER_STRING, To);
- fscanf(Portable_File, "%ld", &maxlen);
+ fscanf(portable_file, "%ld", &maxlen);
return (read_a_string_internal(To, maxlen));
}
\f
#define read_hex_digit(var) \
{ \
- fscanf(Portable_File, "%1lx", &var); \
+ fscanf(portable_file, "%1lx", &var); \
}
#else
long digit;
int c;
- while ((c = fgetc(Portable_File)) == ' ')
+ while ((c = fgetc(portable_file)) == ' ')
{};
digit = ((c >= 'a') ? (c - 'a' + 10)
: ((c >= 'A') ? (c - 'A' + 10)
Boolean negative;
long size_in_bits;
- getc(Portable_File); /* Space */
- negative = ((getc(Portable_File)) == '-');
- fscanf(Portable_File, "%ld", &size_in_bits);
+ getc(portable_file); /* Space */
+ negative = ((getc(portable_file)) == '-');
+ fscanf(portable_file, "%ld", &size_in_bits);
if ((size_in_bits <= fixnum_to_bits) &&
(The_Type == TC_FIXNUM))
{
{
fprintf(stderr,
"%s: Fixnum too large, coercing to bignum.\n",
- Program_Name);
+ program_name);
}
size = bits_to_bigdigit(size_in_bits);
ndigits = hex_digits(size_in_bits);
long size_in_bits, size_in_words;
Pointer the_bit_string;
- fscanf(Portable_File, "%ld", &size_in_bits);
+ fscanf(portable_file, "%ld", &size_in_bits);
size_in_words = (1 + bits_to_pointers (size_in_bits));
the_bit_string = Make_Pointer(TC_BIT_STRING, To);
long size_in_bits, exponent;
fast double Result;
- getc(Portable_File); /* Space */
- negative = ((getc(Portable_File)) == '-');
+ getc(portable_file); /* Space */
+ negative = ((getc(portable_file)) == '-');
VMS_BUG(exponent = 0);
VMS_BUG(size_in_bits = 0);
- fscanf(Portable_File, "%ld %ld", &exponent, &size_in_bits);
+ fscanf(portable_file, "%ld %ld", &exponent, &size_in_bits);
if (size_in_bits == 0)
{
Result = 0.0;
{
/* Skip over mantissa */
- while (getc(Portable_File) != '\n')
+ while (getc(portable_file) != '\n')
{};
fprintf(stderr,
"%s: Floating point exponent too %s!\n",
- Program_Name,
+ program_name,
((exponent < 0) ? "small" : "large"));
Result = ((exponent < 0) ? dflmin() : dflmax());
}
{
fprintf(stderr,
"%s: Some precision may be lost.",
- Program_Name);
+ program_name);
}
- getc(Portable_File); /* Space */
+ getc(portable_file); /* Space */
for (ndigits = hex_digits(size_in_bits),
Result = 0.0,
Normalization = (1.0 / 16.0);
while (Table < Until)
{
- fscanf(Portable_File, "%2x", &The_Type);
+ fscanf(portable_file, "%2x", &The_Type);
switch(The_Type)
{
case TC_CHARACTER_STRING:
{
long the_char_code;
- getc(Portable_File); /* Space */
+ getc(portable_file); /* Space */
VMS_BUG(the_char_code = 0);
- fscanf( Portable_File, "%3lx", &the_char_code);
+ fscanf( portable_file, "%3lx", &the_char_code);
*Table++ = Make_Non_Pointer( TC_CHARACTER, the_char_code);
continue;
}
default:
fprintf(stderr,
"%s: Unknown external object found; Type = 0x%02x\n",
- Program_Name, The_Type);
+ program_name, The_Type);
inconsistency();
/*NOTREACHED*/
}
default:
fprintf(stderr,
"%s: Unknown External Object Reference with Type 0x%02x",
- Program_Name,
+ program_name,
Type_Code(*From));
inconsistency();
}
{
VMS_BUG(The_Type = 0);
VMS_BUG(The_Datum = 0);
- fscanf(Portable_File, "%2x %lx", &The_Type, &The_Datum);
+ fscanf(portable_file, "%2x %lx", &The_Type, &The_Datum);
switch(The_Type)
{
case CONSTANT_CODE:
while (--count >= 0)
{
VMS_BUG(*To = 0);
- fscanf(Portable_File, "%lx", To++);
+ fscanf(portable_file, "%lx", To++);
}
}
continue;
Pointer *temp;
long base_type, base_datum;
- fscanf(Portable_File, "%02x %lx", &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]))));
case TC_BROKEN_HEART:
if (The_Datum != 0)
{
- fprintf(stderr, "%s: Broken Heart Found\n", Program_Name);
+ fprintf(stderr, "%s: Broken Heart Found\n", program_name);
inconsistency();
}
/* fall through */
while (--how_many >= 0)
{
- fscanf(Portable_File, "%ld", &arity);
+ fscanf(portable_file, "%ld", &arity);
if (arity == ((long) UNKNOWN_PRIMITIVE_ARITY))
{
primitive_warn = true;
if (what)
{
fprintf(stderr, "%s: Inconsistency: %s!\n",
- Program_Name, (message));
+ program_name, (message));
quit(1);
}
return;
#define READ_HEADER(string, format, value) \
{ \
- fscanf(Input_File, format, &(value)); \
+ fscanf(portable_file, format, &(value)); \
fprintf(stderr, "%s: ", (string)); \
fprintf(stderr, (format), (value)); \
fprintf(stderr, "\n"); \
#define READ_HEADER(string, format, value) \
{ \
- fscanf(Input_File, format, &(value)); \
+ if (fscanf(portable_file, format, &(value)) == EOF) \
+ { \
+ short_header_read(); \
+ } \
}
#endif /* DEBUG */
\f
+void
+short_header_read()
+{
+ fprintf(stderr, "%s: Header is not complete!\n", program_name);
+ quit(1);
+}
+
long
Read_Header_and_Allocate()
{
if (Portable_Version != PORTABLE_VERSION)
{
+ fprintf(stderr, "%s: Portable version mismatch:\n", program_name);
fprintf(stderr, "Portable File Version %4d\n", Portable_Version);
fprintf(stderr, "Expected: Version %4d\n", PORTABLE_VERSION);
quit(1);
if ((Version != FASL_FORMAT_VERSION) ||
(Sub_Version != FASL_SUBVERSION))
{
+ fprintf(stderr, "%s: Binary version mismatch:\n", program_name);
fprintf(stderr,
- "Portable File Version %4d Subversion %4d Binary Version %4d\n",
+ "Portable File Version %4d; Binary Version %4d; Subversion %4d\n",
Portable_Version, Version, Sub_Version);
fprintf(stderr,
- "Expected: Version %4d Subversion %4d Binary Version %4d\n",
+ "Expected: Version %4d; Binary Version %4d; Subversion %4d\n",
PORTABLE_VERSION, FASL_FORMAT_VERSION, FASL_SUBVERSION);
quit(1);
}
{
if (compiled_p)
{
- fprintf(stderr,
- "%s: Portable file contains \"invalid\" compiled code.\n",
- Program_Name);
+ fprintf(stderr, "%s: %s\n", program_name,
+ "Portable file contains \"non-portable\" compiled code.");
}
else
{
- fprintf(stderr,
- "%s: Portable file contains \"random\" non-marked vectors.\n",
- Program_Name);
+ fprintf(stderr, "%s: %s\n", program_name,
+ "Portable file contains \"unexpected\" non-marked vectors.");
}
- fprintf(stderr, "Portable File Machine %4d\n", Machine);
- fprintf(stderr, "Expected: Machine %4d\n", FASL_INTERNAL_FORMAT);
+ fprintf(stderr, "Machine specified in the portable file: %4d\n",
+ Machine);
+ fprintf(stderr, "Machine Expected: %4d\n",
+ FASL_INTERNAL_FORMAT);
quit(1);
}
\f
READ_HEADER("Primitive Table Length", "%ld", Primitive_Table_Length);
READ_HEADER("Number of characters in primitives", "%ld", NPChars);
+ READ_HEADER("CPU type", "%ld", compiler_processor_type);
+ READ_HEADER("Compiled code interface version", "%ld",
+ compiler_interface_version);
+#if false
+ READ_HEADER("Compiler utilities vector", "%ld", compiler_utilities);
+#endif
+
Size = (6 + /* SNMV */
HEAP_BUFFER_SPACE +
Heap_Count + Heap_Objects +
{
fprintf(stderr,
"%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n",
- Program_Name, Size);
+ program_name, Size);
quit(1);
}
Heap += HEAP_BUFFER_SPACE;
if (primitive_warn)
{
- fprintf(stderr, "%s:\n", Program_Name);
+ fprintf(stderr, "%s:\n", program_name);
fprintf(stderr,
"NOTE: The binary file contains primitives with unknown arity.\n");
}
(Free - Heap_Base), Heap_Base,
0, Stack_Top,
primitive_table, Primitive_Table_Length,
- ((long) (primitive_table_end - primitive_table)));
+ ((long) (primitive_table_end - primitive_table)),
+ compiled_p, band_p);
}
else
{
(Free - Heap_Base), Heap_Base,
Total_Length, (Pure_Base - 2),
primitive_table, Primitive_Table_Length,
- ((long) (primitive_table_end - primitive_table)));
+ ((long) (primitive_table_end - primitive_table)),
+ compiled_p, band_p);
}
}
if (!result)
{
- fprintf(stderr, "%s: Error writing the output file.\n", Program_Name);
+ fprintf(stderr, "%s: Error writing the output file.\n", program_name);
quit(1);
}
return;
\f
/* Top level */
-static struct Option_Struct Options[] =
- {{"Allow_Compiled", true, &allow_compiled_p},
- {"Allow_NMVs", true, &allow_nmv_p}};
-
-static int Noptions = 2;
+static struct keyword_struct
+ options[] = {
+ KEYWORD("allow_nmv", &allow_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD("allow_cc", &allow_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ OUTPUT_KEYWORD(),
+ INPUT_KEYWORD(),
+ END_KEYWORD()
+ };
main(argc, argv)
int argc;
char *argv[];
{
- Setup_Program(argc, argv, Noptions, Options);
+ parse_keywords(argc, argv, options, false);
+ setup_io();
do_it();
quit(0);
}
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.32 1988/01/04 18:58:17 cph Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/bintopsb.c,v 9.33 1988/02/10 15:41:50 jinx Exp $
*
* This File contains the code to translate internal format binary
* files to portable format.
\f
/* IO definitions */
-#define Internal_File Input_File
-#define Portable_File Output_File
-
#include "psbmap.h"
#include "trap.h"
+#define internal_file input_file
+#define portable_file output_file
long
Load_Data(Count, To_Where)
{
extern int fread();
- return (fread(To_Where, sizeof(Pointer), Count, Internal_File));
+ return (fread(To_Where, sizeof(Pointer), Count, internal_file));
}
-#define Reloc_or_Load_Debug false
-
-#include "fasl.h"
#define INHIBIT_FASL_VERSION_CHECK
+#define INHIBIT_COMPILED_VERSION_CHECK
#include "load.c"
#include "bltdef.h"
\f
/* This is in some libraries but not others */
-static char punctuation[] = "'\",<.>/?;:{}[]|`~=+-_()*&^%$#@!";
+static char
+ punctuation[] = "'\",<.>/?;:{}[]|`~=+-_()*&^%$#@!";
Boolean
ispunct(c)
static Boolean
shuffle_bytes_p = false,
+ allow_nmv_p = false,
upgrade_traps_p = false,
upgrade_primitives_p = false,
upgrade_lengths_p = false,
allow_compiled_p = false,
- allow_nmv_p = false;
+ upgrade_compiled_p = false;
static long
Heap_Relocation, Constant_Relocation,
static Pointer
*Mem_Base,
*Free_Objects, *Free_Cobjects,
- *compiled_entry_table, *compiled_entry_pointer, *compiled_entry_table_end,
+ *compiled_entry_table, *compiled_entry_pointer,
+ *compiled_entry_table_end,
*primitive_table, *primitive_table_end;
static long
\f
#define OUT(s) \
{ \
- fprintf(Portable_File, (s)); \
+ fprintf(portable_file, (s)); \
break; \
}
default:
if ((isalpha(c)) || (isdigit(c)) || (ispunct(c)))
{
- putc(c, Portable_File);
+ putc(c, portable_file);
}
else
{
fprintf(stderr,
"%s: %s: File may not be portable: c = 0x%x\n",
- Program_Name, name, ((int) c));
+ program_name, name, ((int) c));
/* This does not follow C conventions, but eliminates ambiguity */
- fprintf(Portable_File, "\X%x ", ((int) c));
+ fprintf(portable_file, "\X%x ", ((int) c));
}
}
return;
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((Code), Old_Contents); \
} \
{
temp = temp >> 1;
}
- fprintf(Portable_File, "%02x %c ",
+ fprintf(portable_file, "%02x %c ",
TC_FIXNUM,
(val < 0 ? '-' : '+'));
if (val == 0)
{
- fprintf(Portable_File, "0\n");
+ fprintf(portable_file, "0\n");
}
else
{
- fprintf(Portable_File, "%ld ", size_in_bits);
+ fprintf(portable_file, "%ld ", size_in_bits);
temp = ((val < 0) ? -val : val);
while (temp != 0)
{
- fprintf(Portable_File, "%01lx", (temp & 0xf));
+ fprintf(portable_file, "%01lx", (temp & 0xf));
temp = temp >> 4;
}
- fprintf(Portable_File, "\n");
+ fprintf(portable_file, "\n");
}
return;
}
fast long len;
fast char *string;
{
- fprintf(Portable_File, "%ld ", len);
+ fprintf(portable_file, "%ld ", len);
if (shuffle_bytes_p)
{
while(len > 0)
print_a_char(*string++, "print_a_string");
}
}
- putc('\n', Portable_File);
+ putc('\n', portable_file);
return;
}
\f
maxlen = pointer_to_char((Get_Integer(*from++)) - 1);
len = STRING_LENGTH_TO_LONG(*from++);
- fprintf(Portable_File,
+ fprintf(portable_file,
"%02x %ld ",
TC_CHARACTER_STRING,
(compact_p ? len : maxlen));
long arity, length;
char *name;
{
- fprintf(Portable_File, "%ld ", arity);
+ fprintf(portable_file, "%ld ", arity);
print_a_string_internal(length, name);
return;
}
temp = LEN(the_number);
if (temp == 0)
{
- fprintf(Portable_File, "%02x + 0\n",
+ fprintf(portable_file, "%02x + 0\n",
(compact_p ? TC_FIXNUM : TC_BIG_FIXNUM));
}
else
temp = temp >> 1;
}
\f
- fprintf(Portable_File, "%02x %c %ld ",
+ fprintf(portable_file, "%02x %c %ld ",
(compact_p ? TC_FIXNUM : TC_BIG_FIXNUM),
(NEG_BIGNUM(the_number) ? '-' : '+'),
size_in_bits);
size_in_bits > 3;
size_in_bits -= 4)
{
- fprintf(Portable_File, "%01lx", (temp & 0xf));
+ fprintf(portable_file, "%01lx", (temp & 0xf));
temp = temp >> 4;
}
}
if (size_in_bits > 0)
{
- fprintf(Portable_File, "%01lx\n", (temp & 0xf));
+ fprintf(portable_file, "%01lx\n", (temp & 0xf));
}
else
{
- fprintf(Portable_File, "\n");
+ fprintf(portable_file, "\n");
}
}
return;
the_bit_string = Make_Pointer(TC_BIT_STRING, from);
bits_remaining = bit_string_length(the_bit_string);
- fprintf(Portable_File, "%02x %ld", TC_BIT_STRING, bits_remaining);
+ fprintf(portable_file, "%02x %ld", TC_BIT_STRING, bits_remaining);
if (bits_remaining != 0)
{
- fprintf(Portable_File, " ");
+ fprintf(portable_file, " ");
scan = bit_string_low_ptr(the_bit_string);
for (leftover_bits = 0;
bits_remaining > 0;
leftover_bits += ((bits_remaining > POINTER_LENGTH) ?
(POINTER_LENGTH - 4) :
(bits_remaining - 4));
- fprintf(Portable_File, "%01lx", (accumulator & 0xf));
+ fprintf(portable_file, "%01lx", (accumulator & 0xf));
}
else
{
for(accumulator = next_word; leftover_bits >= 4; leftover_bits -= 4)
{
- fprintf(Portable_File, "%01lx", (accumulator & 0xf));
+ fprintf(portable_file, "%01lx", (accumulator & 0xf));
accumulator = accumulator >> 4;
}
}
if (leftover_bits != 0)
{
- fprintf(Portable_File, "%01lx", (accumulator & 0xf));
+ fprintf(portable_file, "%01lx", (accumulator & 0xf));
}
}
- fprintf(Portable_File, "\n");
+ fprintf(portable_file, "\n");
return;
}
\f
int expt;
extern double frexp();
- fprintf(Portable_File, "%02x %c ",
+ fprintf(portable_file, "%02x %c ",
TC_BIG_FLONUM,
((val < 0.0) ? '-' : '+'));
if (val == 0.0)
{
- fprintf(Portable_File, "0\n");
+ fprintf(portable_file, "0\n");
return;
}
mant = frexp(((val < 0.0) ? -val : val), &expt);
if (temp >= 1.0)
temp -= 1.0;
}
- fprintf(Portable_File, "%ld %ld ", expt, size_in_bits);
+ fprintf(portable_file, "%ld %ld ", expt, size_in_bits);
for (size_in_bits = hex_digits(size_in_bits);
size_in_bits > 0;
digit += 1;
}
}
- fprintf(Portable_File, "%01x", digit);
+ fprintf(portable_file, "%01x", digit);
}
- putc('\n', Portable_File);
+ putc('\n', portable_file);
return;
}
\f
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 \
{ \
*Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer(OBJECT_TYPE(This), (Fre)); \
Mem_Base[(Fre)++] = Old_Contents; \
} \
}
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 \
{ \
*Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer(OBJECT_TYPE(This), (Fre)); \
Mem_Base[(Fre)++] = Old_Contents; \
Mem_Base[(Fre)++] = *Old_Address++; \
} \
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 \
{ \
*Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer(OBJECT_TYPE(This), (Fre)); \
Mem_Base[(Fre)++] = Old_Contents; \
Mem_Base[(Fre)++] = *Old_Address++; \
Mem_Base[(Fre)++] = *Old_Address++; \
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 \
{ \
*Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer(OBJECT_TYPE(This), (Fre)); \
Mem_Base[(Fre)++] = Old_Contents; \
Mem_Base[(Fre)++] = *Old_Address++; \
Mem_Base[(Fre)++] = *Old_Address++; \
} \
}
\f
-#define Do_Compiled_Entry(COde, Rel, Fre, Scn, Obj, FObj) \
+#define Do_Compiled_Entry(Code, Rel, Fre, Scn, Obj, FObj) \
{ \
long offset; \
Pointer *saved; \
#define Do_Pointer(Scn, Action) \
{ \
+ long the_datum; \
+ \
Old_Address = Get_Pointer(This); \
- if (Datum(This) < Const_Base) \
+ the_datum = OBJECT_DATUM(This); \
+ if ((the_datum >= Heap_Base) && \
+ (the_datum < Dumped_Heap_Top)) \
{ \
Action(HEAP_CODE, Heap_Relocation, Free, \
Scn, Objects, Free_Objects); \
} \
- else if (Datum(This) < Dumped_Constant_Top) \
+ \
+ /* \
+ \
+ Currently constant space is not supported \
+ \
+ else if ((the_datum >= Const_Base) && \
+ (the_datum < Dumped_Constant_Top)) \
{ \
Action(CONSTANT_CODE, Constant_Relocation, Free_Constant, \
Scn, Constant_Objects, Free_Cobjects); \
} \
+ \
+ */ \
+ \
else \
{ \
- fprintf(stderr, \
- "%s: File is not portable: Pointer to stack.\n", \
- Program_Name); \
- quit(1); \
+ out_of_range_pointer(This); \
} \
(Scn) += 1; \
break; \
}
\f
-/* Primitive upgrading code. */
-
-#define PRIMITIVE_UPGRADE_SPACE 2048
-static Pointer *internal_renumber_table;
-static Pointer *external_renumber_table;
-static Pointer *external_prim_name_table;
-static Boolean found_ext_prims = false;
+void
+out_of_range_pointer(ptr)
+ Pointer ptr;
+{
+ fprintf(stderr,
+ "%s: The input file is not portable: Out of range pointer.\n",
+ program_name);
+ fprintf(stderr, "Heap_Base = 0x%lx;\tHeap_Top = 0x%lx\n",
+ Heap_Base, Dumped_Heap_Top);
+ fprintf(stderr, "Const_Base = 0x%lx;\tConst_Top = 0x%lx\n",
+ Const_Base, Dumped_Constant_Top);
+ fprintf(stderr, "ptr = 0x%02x|0x%lx\n",
+ OBJECT_TYPE(ptr), OBJECT_DATUM(ptr));
+ quit(1);
+}
Pointer *
relocate(object)
Pointer object;
{
+ long the_datum;
Pointer *result;
- result = (Get_Pointer(object) + ((Datum(object) < Const_Base) ?
- Heap_Relocation :
- Constant_Relocation));
+
+ result = Get_Pointer(object);
+ the_datum = OBJECT_DATUM(object);
+
+ if ((the_datum >= Heap_Base) &&
+ (the_datum < Dumped_Heap_Top))
+ {
+ result += Heap_Relocation;
+ }
+
+#if false
+
+ /* Currently constant space is not supported */
+
+ else if (( the_datum >= Const_Base) &&
+ (the_datum < Dumped_Constant_Top))
+ {
+ result += Constant_Relocation;
+ }
+
+#endif /* false */
+
+ else
+ {
+ out_of_range_pointer(object);
+ }
return (result);
}
+\f
+/* Primitive upgrading code. */
+
+#define PRIMITIVE_UPGRADE_SPACE 2048
+
+static Pointer
+ *internal_renumber_table,
+ *external_renumber_table,
+ *external_prim_name_table;
+
+static Boolean
+ found_ext_prims = false;
Pointer
upgrade_primitive(prim)
Pointer prim;
{
- long datum, type, new_type, code;
+ long the_datum, the_type, new_type, code;
Pointer new;
- datum = OBJECT_DATUM(prim);
- type = OBJECT_TYPE(prim);
- if (type != TC_PRIMITIVE_EXTERNAL)
+ the_datum = OBJECT_DATUM(prim);
+ the_type = OBJECT_TYPE(prim);
+ if (the_type != TC_PRIMITIVE_EXTERNAL)
{
- code = datum;
- new_type = type;
+ code = the_datum;
+ new_type = the_type;
}
else
{
found_ext_prims = true;
- code = (datum + (MAX_BUILTIN_PRIMITIVE + 1));
+ code = (the_datum + (MAX_BUILTIN_PRIMITIVE + 1));
new_type = TC_PRIMITIVE;
}
\f
internal_renumber_table[code] = new;
external_renumber_table[Primitive_Table_Length] = prim;
Primitive_Table_Length += 1;
- if (type == TC_PRIMITIVE_EXTERNAL)
+ if (the_type == TC_PRIMITIVE_EXTERNAL)
{
NPChars +=
- STRING_LENGTH_TO_LONG((((Pointer *) (external_prim_name_table[datum]))
+ STRING_LENGTH_TO_LONG((((Pointer *)
+ (external_prim_name_table[the_datum]))
[STRING_LENGTH]));
}
else
{
- NPChars += strlen(builtin_prim_name_table[datum]);
+ NPChars += strlen(builtin_prim_name_table[the_datum]);
}
return (new);
}
length += (MAX_BUILTIN_PRIMITIVE + 1);
if (length > PRIMITIVE_UPGRADE_SPACE)
{
- fprintf(stderr, "%s: Too many primitives.\n", Program_Name);
+ fprintf(stderr, "%s: Too many primitives.\n", program_name);
fprintf(stderr,
"Increase PRIMITIVE_UPGRADE_SPACE and recompile %s.\n",
- Program_Name);
+ program_name);
quit(1);
}
for (count = 0; count < length; count += 1)
This = Mem_Base[*Area];
#ifdef PRIMITIVE_EXTERNAL_REUSED
- if (upgrade_primitives_p && (Type_Code(This) == TC_PRIMITIVE_EXTERNAL))
+ if (upgrade_primitives_p &&
+ (OBJECT_TYPE(This) == TC_PRIMITIVE_EXTERNAL))
{
Mem_Base[*Area] = upgrade_primitive(This);
*Area += 1;
else if (!allow_nmv_p)
{
fprintf(stderr, "%s: File is not portable: NMH found\n",
- Program_Name);
+ program_name);
}
*Area += (1 + OBJECT_DATUM(This));
break;
if (OBJECT_DATUM(This) != 0)
{
fprintf(stderr, "%s: Broken Heart found in scan.\n",
- Program_Name);
+ program_name);
quit(1);
}
*Area += 1;
{
fprintf(stderr,
"%s: File contains compiled code.\n",
- Program_Name);
+ program_name);
quit(1);
}
Do_Pointer(*Area, Do_Compiled_Entry);
case TC_STACK_ENVIRONMENT:
fprintf(stderr,
"%s: File contains stack environments.\n",
- Program_Name);
+ program_name);
quit(1);
\f
case TC_FIXNUM:
{
long kind;
- kind = Datum(This);
+ kind = OBJECT_DATUM(This);
if (upgrade_traps_p)
{
}
fprintf(stderr,
"%s: Bad old unassigned object. 0x%x.\n",
- Program_Name, This);
+ program_name, This);
quit(1);
}
if (kind <= TRAP_MAX_IMMEDIATE)
{
fprintf(stderr,
"%s: Cannot upgrade environments.\n",
- Program_Name);
+ program_name);
quit(1);
}
/* Fall through */
case TC_FUTURE:
case_simple_Vector:
- if (Type_Code(This) == TC_BIT_STRING)
+ if (OBJECT_TYPE(This) == TC_BIT_STRING)
{
Do_Pointer(*Area, Do_Bit_String);
}
default:
Bad_Type:
fprintf(stderr, "%s: Unknown Type Code 0x%x found.\n",
- Program_Name, Type_Code(This));
+ program_name, OBJECT_TYPE(This));
quit(1);
}
}
{
while (--count >= 0)
{
- switch(Type_Code(*from))
+ switch(OBJECT_TYPE(*from))
{
case TC_FIXNUM:
{
break;
case TC_CHARACTER:
- fprintf(Portable_File, "%02x %03x\n",
+ 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);
+ program_name, *from);
quit(1);
}
}
print_objects(from, to)
fast Pointer *from, *to;
{
- fast long datum, type;
+ fast long the_datum, the_type;
while(from < to)
{
- type = OBJECT_TYPE(*from);
- datum = OBJECT_DATUM(*from);
+ the_type = OBJECT_TYPE(*from);
+ the_datum = OBJECT_DATUM(*from);
from += 1;
- if (type == TC_MANIFEST_NM_VECTOR)
+ if (the_type == TC_MANIFEST_NM_VECTOR)
{
- fprintf(Portable_File, "%02x %lx\n", type, datum);
- while (--datum >= 0)
+ fprintf(portable_file, "%02x %lx\n", the_type, the_datum);
+ while (--the_datum >= 0)
{
- fprintf(Portable_File, "%lx\n", ((unsigned long) *from++));
+ fprintf(portable_file, "%lx\n", ((unsigned long) *from++));
}
}
- else if (type == TC_COMPILED_EXPRESSION)
+ else if (the_type == TC_COMPILED_EXPRESSION)
{
Pointer base;
long offset;
- Sign_Extend(compiled_entry_table[datum], offset);
- base = compiled_entry_table[datum + 1];
+ Sign_Extend(compiled_entry_table[the_datum], offset);
+ base = compiled_entry_table[the_datum + 1];
- fprintf(Portable_File, "%02x %lx %02x %lx\n",
+ 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);
+ fprintf(portable_file, "%02x %lx\n", the_type, the_datum);
}
}
return;
if (what)
{
fprintf(stderr, "%s: Inconsistency: %s!\n",
- Program_Name, (message));
+ program_name, (message));
quit(1);
}
return;
#define PRINT_HEADER(name, format, obj) \
{ \
- fprintf(Portable_File, (format), (obj)); \
- fprintf(Portable_File, "\n"); \
+ fprintf(portable_file, (format), (obj)); \
+ fprintf(portable_file, "\n"); \
fprintf(stderr, "%s: ", (name)); \
fprintf(stderr, (format), (obj)); \
fprintf(stderr, "\n"); \
#define PRINT_HEADER(name, format, obj) \
{ \
- fprintf(Portable_File, (format), (obj)); \
- fprintf(Portable_File, "\n"); \
+ fprintf(portable_file, (format), (obj)); \
+ fprintf(portable_file, "\n"); \
}
#endif /* DEBUG */
/* Load the Data */
- if (!Read_Header())
+ if (Read_Header() != FASL_FILE_FINE)
{
fprintf(stderr,
- "%s: Input file does not appear to be in FASL format.\n",
- Program_Name);
+ "%s: Input file does not appear to be in an appropriate format.\n",
+ program_name);
quit(1);
}
((Machine_Type != FASL_INTERNAL_FORMAT) &&
(!shuffle_bytes_p)))
{
- fprintf(stderr, "%s:\n", Program_Name);
+ fprintf(stderr, "%s:\n", program_name);
fprintf(stderr,
"FASL File Version %ld Subversion %ld Machine Type %ld\n",
Version, Sub_Version , Machine_Type);
FASL_READ_VERSION, FASL_READ_SUBVERSION, FASL_INTERNAL_FORMAT);
quit(1);
}
+\f
+ if ((((compiler_processor_type != 0) &&
+ (dumped_processor_type != 0) &&
+ (compiler_processor_type != dumped_processor_type)) ||
+ ((compiler_interface_version != 0) &&
+ (dumped_interface_version != 0) &&
+ (compiler_interface_version != dumped_interface_version))) &&
+ (!upgrade_compiled_p))
+ {
+ fprintf(stderr, "\nread_file:\n");
+ fprintf(stderr,
+ "FASL File: compiled code interface %4d; processor %4d.\n",
+ dumped_interface_version, dumped_processor_type);
+ fprintf(stderr,
+ "Expected: compiled code interface %4d; processor %4d.\n",
+ compiler_interface_version, compiler_processor_type);
+ quit(1);
+ }
+ if (compiler_processor_type != 0)
+ {
+ dumped_processor_type = compiler_processor_type;
+ }
+ if (compiler_interface_version != 0)
+ {
+ dumped_interface_version = compiler_interface_version;
+ }
- /* Constant Space not currently supported */
+ /* Constant Space and bands not currently supported */
+
+ if (band_p)
+ {
+ fprintf(stderr, "%s: Input file is a band.\n", program_name);
+ quit(1);
+ }
if (Const_Count != 0)
{
fprintf(stderr,
"%s: Input file has a constant space area.\n",
- Program_Name);
+ program_name);
quit(1);
}
\f
+ allow_compiled_p = (allow_compiled_p || upgrade_compiled_p);
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);
+ program_name);
quit(1);
}
upgrade_traps_p = (Sub_Version < FASL_REFERENCE_TRAP);
upgrade_primitives_p = (Sub_Version < FASL_MERGED_PRIMITIVES);
upgrade_lengths_p = upgrade_primitives_p;
+
+ DEBUGGING(fprintf(stderr,
+ "Dumped Heap Base = 0x%08x\n",
+ Heap_Base));
+
+ DEBUGGING(fprintf(stderr,
+ "Dumped Constant Base = 0x%08x\n",
+ Const_Base));
+
+ DEBUGGING(fprintf(stderr,
+ "Dumped Constant Top = 0x%08x\n",
+ Dumped_Constant_Top));
+
+ DEBUGGING(fprintf(stderr,
+ "Heap Count = %6d\n",
+ Heap_Count));
+
+ DEBUGGING(fprintf(stderr,
+ "Constant Count = %6d\n",
+ Const_Count));
\f
{
long Size;
{
fprintf(stderr,
"%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n",
- Program_Name, Size);
+ program_name, Size);
quit(1);
}
}
Initial_Align_Float(Heap);
Load_Data(Heap_Count, &Heap[0]);
Load_Data(Const_Count, &Heap[Heap_Count]);
- Load_Data(Primitive_Table_Size, &Heap[Heap_Count + Const_Count]);
- Heap_Relocation = &Heap[0] - Get_Pointer(Heap_Base);
- Constant_Relocation = &Heap[Heap_Count] - Get_Pointer(Const_Base);
-
- DEBUGGING(fprintf(stderr,
- "Dumped Heap Base = 0x%08x\n",
- Heap_Base));
-
- DEBUGGING(fprintf(stderr,
- "Dumped Constant Base = 0x%08x\n",
- Const_Base));
-
- DEBUGGING(fprintf(stderr,
- "Dumped Constant Top = 0x%08x\n",
- Dumped_Constant_Top));
-
- DEBUGGING(fprintf(stderr,
- "Heap Count = %6d\n",
- Heap_Count));
-
- DEBUGGING(fprintf(stderr,
- "Constant Count = %6d\n",
- Const_Count));
+ Heap_Relocation = ((&Heap[0]) - (Get_Pointer(Heap_Base)));
+ Constant_Relocation = ((&Heap[Heap_Count]) - (Get_Pointer(Const_Base)));
\f
- /* Determine primitive information. */
+ /* Setup compiled code and primitive tables. */
compiled_entry_table = &Heap[Heap_Count + Const_Count];
compiled_entry_pointer = compiled_entry_table;
fast Pointer *table;
fast long count, char_count;
+ Load_Data(Primitive_Table_Size, primitive_table);
for (char_count = 0,
count = Primitive_Table_Length,
table = primitive_table;
if (found_ext_prims)
{
- fprintf(stderr, "%s:\n", Program_Name);
+ fprintf(stderr, "%s:\n", program_name);
fprintf(stderr, "NOTE: The arity of some primitives is not known.\n");
fprintf(stderr, " The portable file has %ld as their arity.\n",
UNKNOWN_PRIMITIVE_ARITY);
PRINT_HEADER("Number of primitives", "%ld", Primitive_Table_Length);
PRINT_HEADER("Number of characters in primitives", "%ld", NPChars);
+
+ if (!compiled_p)
+ {
+ dumped_processor_type = 0;
+ dumped_interface_version = 0;
+ }
+
+ PRINT_HEADER("CPU type", "%ld", dumped_processor_type);
+ PRINT_HEADER("Compiled code interface version", "%ld",
+ dumped_interface_version);
+#if false
+ PRINT_HEADER("Compiler utilities vector", "%ld",
+ OBJECT_DATUM(dumped_utilities));
+#endif
\f
/* External Objects */
{
Pointer obj;
fast Pointer *table;
- fast long count, datum;
+ fast long count, the_datum;
for (count = Primitive_Table_Length,
table = external_renumber_table;
--count >= 0;)
{
obj = *table++;
- datum = OBJECT_DATUM(obj);
+ the_datum = OBJECT_DATUM(obj);
if (OBJECT_TYPE(obj) == TC_PRIMITIVE_EXTERNAL)
{
Pointer *strobj;
- strobj = ((Pointer *) (external_prim_name_table[datum]));
+ strobj = ((Pointer *) (external_prim_name_table[the_datum]));
print_a_primitive(((long) UNKNOWN_PRIMITIVE_ARITY),
(STRING_LENGTH_TO_LONG(strobj[STRING_LENGTH])),
((char *) &strobj[STRING_CHARS]));
}
else
{
- char *string;
+ char *str;
- string = builtin_prim_name_table[datum];
- print_a_primitive(((long) builtin_prim_arity_table[datum]),
- ((long) strlen(string)),
- string);
+ str = builtin_prim_name_table[the_datum];
+ print_a_primitive(((long) builtin_prim_arity_table[the_datum]),
+ ((long) strlen(str)),
+ str);
}
}
}
\f
/* Top Level */
-/* The boolean value here is what value to store when the option is present. */
+Boolean ci_version_sup_p, ci_processor_sup_p;
-static struct Option_Struct Options[] =
- {{"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}};
+/* The boolean value here is what value to store when the option is present. */
-static int Noptions = 5;
+static struct keyword_struct
+ options[] = {
+ KEYWORD("swap_bytes", &shuffle_bytes_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD("compact", &compact_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD("null_nmv", &null_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD("allow_nmv", &allow_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD("allow_cc", &allow_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD("upgrade_cc", &upgrade_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD("ci_version", &compiler_interface_version, INT_KYWRD, "%ld",
+ &ci_version_sup_p),
+ KEYWORD("ci_processor", &compiler_processor_type, INT_KYWRD, "%ld",
+ &ci_processor_sup_p),
+ OUTPUT_KEYWORD(),
+ INPUT_KEYWORD(),
+ END_KEYWORD()
+ };
main(argc, argv)
int argc;
char *argv[];
{
- Setup_Program(argc, argv, Noptions, Options);
+ parse_keywords(argc, argv, options, false);
+ setup_io();
do_it();
quit(0);
}
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.30 1988/02/06 20:37:50 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/ppband.c,v 9.31 1988/02/10 15:42:58 jinx Exp $
*
* Dumps Scheme FASL in user-readable form .
*/
exit(1);
}
\f
-#define Reloc_or_Load_Debug true
#define INHIBIT_COMPILED_VERSION_CHECK
-
-#include "fasl.h"
#include "load.c"
#ifdef Heap_In_Low_Memory
argv[0]);
exit(1);
}
+ print_fasl_information();
printf("Dumped object (relocated) at 0x%lx\n", Relocate(Dumped_Object));
}
else
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.25 1987/11/23 04:55:56 cph Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbmap.h,v 9.26 1988/02/10 15:44:07 jinx Rel $
*
* This file contains macros and declarations for Bintopsb.c
* and Psbtobin.c
from the included files.
*/
-#include <stdio.h>
#define fast register
+#include <stdio.h>
#include "config.h"
#include "object.h"
#include "bignum.h"
#include "missing.c"
#endif
-#define PORTABLE_VERSION 4
+#define PORTABLE_VERSION 5
/* Number of objects which, when traced recursively, point at all other
objects dumped. Currently only the dumped object.
#define NULL_NMV_P (1 << 1)
#define COMPILED_P (1 << 2)
#define NMV_P (1 << 3)
+#define BAND_P (1 << 4)
#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))
+ (nmv_p ? NMV_P : 0) | \
+ (band_p ? BAND_P : 0))
#define READ_FLAGS(f) \
{ \
null_nmv_p = ((f) & NULL_NMV_P); \
compiled_p = ((f) & COMPILED_P); \
nmv_p = ((f) & NMV_P); \
+ band_p = ((f) & BAND_P); \
}
/*
static Pointer *Memory_Base;
#endif
-static FILE *Input_File, *Output_File;
+static long
+ compiler_processor_type = 0,
+ compiler_interface_version = 0;
-static char *Program_Name;
+static Pointer
+ compiler_utilities = NIL;
\f
-/* Argument List Parsing */
+/* Utilities */
-struct Option_Struct
-{
- char *name;
- Boolean value;
- Boolean *ptr;
-};
+static char
+ *input_file_name = "-",
+ *output_file_name = "-";
+
+FILE *input_file, *output_file;
Boolean
strequal(s1, s2)
- fast char *s1, *s2;
+ register char *s1, *s2;
{
- while (*s1 != '\0')
+ for ( ; *s1 != '\0'; s1++, s2++)
{
- if (*s1++ != *s2++)
+ if (*s1 != *s2)
{
- return false;
+ return (false);
}
}
return (*s2 == '\0');
}
-
-char *
-Find_Options(argc, argv, Noptions, Options)
- int argc;
- char **argv;
- int Noptions;
- struct Option_Struct Options[];
-{
- for ( ; --argc >= 0; argv++)
- {
- char *this;
- int n;
-
- this = *argv;
- for (n = 0;
- ((n < Noptions) && (!strequal(this, Options[n].name)));
- n++)
- {};
- if (n >= Noptions)
- {
- return (this);
- }
- *(Options[n].ptr) = Options[n].value;
- }
- return (NULL);
-}
\f
-/* Usage information */
-
void
-Print_Options(n, options, where)
- int n;
- struct Option_Struct *options;
- FILE *where;
+setup_io()
{
- if (--n < 0)
+ if (strequal(input_file_name, "-"))
{
- return;
+ input_file = stdin;
}
- fprintf(where, "[%s]", options->name);
- options += 1;
- for (; --n >= 0; options += 1)
+ else
{
- fprintf(where, " [%s]", options->name);
+ input_file = fopen(input_file_name, "r");
+ if (input_file == ((FILE *) NULL))
+ {
+ fprintf(stderr, "%s: failed to open %s for input.\n",
+ input_file_name);
+ exit(1);
+ }
}
- return;
-}
-void
-Print_Usage_and_Exit(noptions, options, io_options)
- int noptions;
- struct Option_Struct *options;
- char *io_options;
-{
- fprintf(stderr, "usage: %s%s%s",
- Program_Name,
- (((io_options == NULL) ||
- (io_options[0] == '\0')) ? "" : " "),
- io_options);
- if (noptions != 0)
+ if (strequal(output_file_name, "-"))
{
- putc(' ', stderr);
- Print_Options(noptions, options, stderr);
+ output_file = stdout;
}
- putc('\n', stderr);
- exit(1);
-}
-\f
-/* Top level of program */
-
-/* When debugging force arguments on command line */
-
-#ifdef DEBUG
-#undef unix
-#endif
-
-#ifdef unix
-
-/* On unix use io redirection */
-
-void
-Setup_Program(argc, argv, Noptions, Options)
- int argc;
- char *argv[];
- int Noptions;
- struct Option_Struct *Options;
-{
- Program_Name = argv[0];
- Input_File = stdin;
- Output_File = stdout;
- if (((argc - 1) > Noptions) ||
- (Find_Options((argc - 1), &argv[1], Noptions, Options) != NULL))
+ else
{
- Print_Usage_and_Exit(Noptions, Options, "");
+ output_file = fopen(output_file_name, "w");
+ if (output_file == ((FILE *) NULL))
+ {
+ fprintf(stderr, "%s: failed to open %s for output.\n",
+ output_file_name);
+ fclose(input_file);
+ exit(1);
+ }
}
return;
}
-#define quit exit
-\f
-#else /* not unix */
-
-/* Otherwise use command line arguments */
-
-void
-Setup_Program(argc, argv, Noptions, Options)
- int argc;
- char *argv[];
- int Noptions;
- struct Option_Struct *Options;
-{
- Program_Name = argv[0];
- if ((argc < 3) ||
- ((argc - 3) > Noptions) ||
- (Find_Options((argc - 3), &argv[3], Noptions, Options) != NULL))
- {
- Print_Usage_and_Exit(Noptions, Options, "input_file output_file");
- }
- Input_File = ((strequal(argv[1], "-")) ?
- stdin :
- fopen(argv[1], "r"));
- if (Input_File == NULL)
- {
- perror("Open failed.");
- exit(1);
- }
- Output_File = ((strequal(argv[2], "-")) ?
- stdout :
- fopen(argv[2], "w"));
- if (Output_File == NULL)
- {
- perror("Open failed.");
- fclose(Input_File);
- exit(1);
- }
- fprintf(stderr, "%s: Reading from %s, writing to %s.\n",
- Program_Name, argv[1], argv[2]);
- return;
-}
-\f
void
quit(code)
int code;
{
- fclose(Input_File);
- fclose(Output_File);
- /* VMS brain dammage */
+ fclose(input_file);
+ fclose(output_file);
+#ifdef vms
+ /* This assumes that it is only invoked with 0 in tail recursive psn. */
if (code != 0)
{
exit(code);
}
- return;
+ else
+ {
+ return;
+ }
+#else /* not vms */
+ exit(code);
+#endif /*vms */
}
+\f
+/* Include the command line parser */
+
+#define boolean Boolean
+#include "comlin.c"
-#endif /* unix */
+#define INPUT_KEYWORD() \
+KEYWORD("input", &input_file_name, STRING_KYWRD, SFRMT, NULL)
+#define OUTPUT_KEYWORD() \
+KEYWORD("output", &output_file_name, STRING_KYWRD, SFRMT, NULL)
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.31 1988/01/04 18:55:54 cph Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbtobin.c,v 9.32 1988/02/10 15:43:12 jinx Exp $
*
* This File contains the code to translate portable format binary
* files to internal format.
\f
/* Cheap renames */
-#define Portable_File Input_File
-#define Internal_File Output_File
-
#include "psbmap.h"
+#define portable_file input_file
+#define internal_file output_file
static Boolean
+ band_p = false;
allow_compiled_p = false,
allow_nmv_p = false;
{
extern int fwrite();
- return (fwrite(((char *) From_Where), sizeof(Pointer), Count, Internal_File));
+ return (fwrite(((char *) From_Where), sizeof(Pointer),
+ Count, internal_file));
}
#include "fasl.h"
/* Provide some context (2 lines). */
char yow[100];
- fgets(&yow[0], 100, Portable_File);
+ fgets(&yow[0], 100, portable_file);
fprintf(stderr, "%s\n", &yow[0]);
- fgets(&yow[0], 100, Portable_File);
+ fgets(&yow[0], 100, portable_file);
fprintf(stderr, "%s\n", &yow[0]);
quit(1);
{
fast char C;
- C = getc(Portable_File);
+ C = getc(portable_file);
if (C != '\\')
{
OUT(C);
}
- C = getc(Portable_File);
+ C = getc(portable_file);
switch(C)
{
case 'n': OUT('\n');
fprintf(stderr,
"%s: File is not Portable. Character Code Found.\n",
- Program_Name);
- fscanf(Portable_File, "%ld", &Code);
- getc(Portable_File); /* Space */
+ program_name);
+ fscanf(portable_file, "%ld", &Code);
+ getc(portable_file); /* Space */
OUT(Code);
}
case '\\': OUT('\\');
long maxlen;
{
long ilen, Pointer_Count;
- fast char *string;
+ fast char *str;
fast long len;
- string = ((char *) (&To[STRING_CHARS]));
- fscanf(Portable_File, "%ld", &ilen);
+ str = ((char *) (&To[STRING_CHARS]));
+ fscanf(portable_file, "%ld", &ilen);
len = ilen;
if (maxlen == -1)
/* Space */
- getc(Portable_File);
+ getc(portable_file);
while (--len >= 0)
{
- *string++ = ((char) read_a_char());
+ *str++ = ((char) read_a_char());
}
- *string = '\0';
+ *str = '\0';
return (To + Pointer_Count);
}
long maxlen;
*Slot = Make_Pointer(TC_CHARACTER_STRING, To);
- fscanf(Portable_File, "%ld", &maxlen);
+ fscanf(portable_file, "%ld", &maxlen);
return (read_a_string_internal(To, maxlen));
}
\f
#define read_hex_digit(var) \
{ \
- fscanf(Portable_File, "%1lx", &var); \
+ fscanf(portable_file, "%1lx", &var); \
}
#else
long digit;
int c;
- while ((c = fgetc(Portable_File)) == ' ')
+ while ((c = fgetc(portable_file)) == ' ')
{};
digit = ((c >= 'a') ? (c - 'a' + 10)
: ((c >= 'A') ? (c - 'A' + 10)
Boolean negative;
long size_in_bits;
- getc(Portable_File); /* Space */
- negative = ((getc(Portable_File)) == '-');
- fscanf(Portable_File, "%ld", &size_in_bits);
+ getc(portable_file); /* Space */
+ negative = ((getc(portable_file)) == '-');
+ fscanf(portable_file, "%ld", &size_in_bits);
if ((size_in_bits <= fixnum_to_bits) &&
(The_Type == TC_FIXNUM))
{
{
fprintf(stderr,
"%s: Fixnum too large, coercing to bignum.\n",
- Program_Name);
+ program_name);
}
size = bits_to_bigdigit(size_in_bits);
ndigits = hex_digits(size_in_bits);
long size_in_bits, size_in_words;
Pointer the_bit_string;
- fscanf(Portable_File, "%ld", &size_in_bits);
+ fscanf(portable_file, "%ld", &size_in_bits);
size_in_words = (1 + bits_to_pointers (size_in_bits));
the_bit_string = Make_Pointer(TC_BIT_STRING, To);
long size_in_bits, exponent;
fast double Result;
- getc(Portable_File); /* Space */
- negative = ((getc(Portable_File)) == '-');
+ getc(portable_file); /* Space */
+ negative = ((getc(portable_file)) == '-');
VMS_BUG(exponent = 0);
VMS_BUG(size_in_bits = 0);
- fscanf(Portable_File, "%ld %ld", &exponent, &size_in_bits);
+ fscanf(portable_file, "%ld %ld", &exponent, &size_in_bits);
if (size_in_bits == 0)
{
Result = 0.0;
{
/* Skip over mantissa */
- while (getc(Portable_File) != '\n')
+ while (getc(portable_file) != '\n')
{};
fprintf(stderr,
"%s: Floating point exponent too %s!\n",
- Program_Name,
+ program_name,
((exponent < 0) ? "small" : "large"));
Result = ((exponent < 0) ? dflmin() : dflmax());
}
{
fprintf(stderr,
"%s: Some precision may be lost.",
- Program_Name);
+ program_name);
}
- getc(Portable_File); /* Space */
+ getc(portable_file); /* Space */
for (ndigits = hex_digits(size_in_bits),
Result = 0.0,
Normalization = (1.0 / 16.0);
while (Table < Until)
{
- fscanf(Portable_File, "%2x", &The_Type);
+ fscanf(portable_file, "%2x", &The_Type);
switch(The_Type)
{
case TC_CHARACTER_STRING:
{
long the_char_code;
- getc(Portable_File); /* Space */
+ getc(portable_file); /* Space */
VMS_BUG(the_char_code = 0);
- fscanf( Portable_File, "%3lx", &the_char_code);
+ fscanf( portable_file, "%3lx", &the_char_code);
*Table++ = Make_Non_Pointer( TC_CHARACTER, the_char_code);
continue;
}
default:
fprintf(stderr,
"%s: Unknown external object found; Type = 0x%02x\n",
- Program_Name, The_Type);
+ program_name, The_Type);
inconsistency();
/*NOTREACHED*/
}
default:
fprintf(stderr,
"%s: Unknown External Object Reference with Type 0x%02x",
- Program_Name,
+ program_name,
Type_Code(*From));
inconsistency();
}
{
VMS_BUG(The_Type = 0);
VMS_BUG(The_Datum = 0);
- fscanf(Portable_File, "%2x %lx", &The_Type, &The_Datum);
+ fscanf(portable_file, "%2x %lx", &The_Type, &The_Datum);
switch(The_Type)
{
case CONSTANT_CODE:
while (--count >= 0)
{
VMS_BUG(*To = 0);
- fscanf(Portable_File, "%lx", To++);
+ fscanf(portable_file, "%lx", To++);
}
}
continue;
Pointer *temp;
long base_type, base_datum;
- fscanf(Portable_File, "%02x %lx", &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]))));
case TC_BROKEN_HEART:
if (The_Datum != 0)
{
- fprintf(stderr, "%s: Broken Heart Found\n", Program_Name);
+ fprintf(stderr, "%s: Broken Heart Found\n", program_name);
inconsistency();
}
/* fall through */
while (--how_many >= 0)
{
- fscanf(Portable_File, "%ld", &arity);
+ fscanf(portable_file, "%ld", &arity);
if (arity == ((long) UNKNOWN_PRIMITIVE_ARITY))
{
primitive_warn = true;
if (what)
{
fprintf(stderr, "%s: Inconsistency: %s!\n",
- Program_Name, (message));
+ program_name, (message));
quit(1);
}
return;
#define READ_HEADER(string, format, value) \
{ \
- fscanf(Input_File, format, &(value)); \
+ fscanf(portable_file, format, &(value)); \
fprintf(stderr, "%s: ", (string)); \
fprintf(stderr, (format), (value)); \
fprintf(stderr, "\n"); \
#define READ_HEADER(string, format, value) \
{ \
- fscanf(Input_File, format, &(value)); \
+ if (fscanf(portable_file, format, &(value)) == EOF) \
+ { \
+ short_header_read(); \
+ } \
}
#endif /* DEBUG */
\f
+void
+short_header_read()
+{
+ fprintf(stderr, "%s: Header is not complete!\n", program_name);
+ quit(1);
+}
+
long
Read_Header_and_Allocate()
{
if (Portable_Version != PORTABLE_VERSION)
{
+ fprintf(stderr, "%s: Portable version mismatch:\n", program_name);
fprintf(stderr, "Portable File Version %4d\n", Portable_Version);
fprintf(stderr, "Expected: Version %4d\n", PORTABLE_VERSION);
quit(1);
if ((Version != FASL_FORMAT_VERSION) ||
(Sub_Version != FASL_SUBVERSION))
{
+ fprintf(stderr, "%s: Binary version mismatch:\n", program_name);
fprintf(stderr,
- "Portable File Version %4d Subversion %4d Binary Version %4d\n",
+ "Portable File Version %4d; Binary Version %4d; Subversion %4d\n",
Portable_Version, Version, Sub_Version);
fprintf(stderr,
- "Expected: Version %4d Subversion %4d Binary Version %4d\n",
+ "Expected: Version %4d; Binary Version %4d; Subversion %4d\n",
PORTABLE_VERSION, FASL_FORMAT_VERSION, FASL_SUBVERSION);
quit(1);
}
{
if (compiled_p)
{
- fprintf(stderr,
- "%s: Portable file contains \"invalid\" compiled code.\n",
- Program_Name);
+ fprintf(stderr, "%s: %s\n", program_name,
+ "Portable file contains \"non-portable\" compiled code.");
}
else
{
- fprintf(stderr,
- "%s: Portable file contains \"random\" non-marked vectors.\n",
- Program_Name);
+ fprintf(stderr, "%s: %s\n", program_name,
+ "Portable file contains \"unexpected\" non-marked vectors.");
}
- fprintf(stderr, "Portable File Machine %4d\n", Machine);
- fprintf(stderr, "Expected: Machine %4d\n", FASL_INTERNAL_FORMAT);
+ fprintf(stderr, "Machine specified in the portable file: %4d\n",
+ Machine);
+ fprintf(stderr, "Machine Expected: %4d\n",
+ FASL_INTERNAL_FORMAT);
quit(1);
}
\f
READ_HEADER("Primitive Table Length", "%ld", Primitive_Table_Length);
READ_HEADER("Number of characters in primitives", "%ld", NPChars);
+ READ_HEADER("CPU type", "%ld", compiler_processor_type);
+ READ_HEADER("Compiled code interface version", "%ld",
+ compiler_interface_version);
+#if false
+ READ_HEADER("Compiler utilities vector", "%ld", compiler_utilities);
+#endif
+
Size = (6 + /* SNMV */
HEAP_BUFFER_SPACE +
Heap_Count + Heap_Objects +
{
fprintf(stderr,
"%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n",
- Program_Name, Size);
+ program_name, Size);
quit(1);
}
Heap += HEAP_BUFFER_SPACE;
if (primitive_warn)
{
- fprintf(stderr, "%s:\n", Program_Name);
+ fprintf(stderr, "%s:\n", program_name);
fprintf(stderr,
"NOTE: The binary file contains primitives with unknown arity.\n");
}
(Free - Heap_Base), Heap_Base,
0, Stack_Top,
primitive_table, Primitive_Table_Length,
- ((long) (primitive_table_end - primitive_table)));
+ ((long) (primitive_table_end - primitive_table)),
+ compiled_p, band_p);
}
else
{
(Free - Heap_Base), Heap_Base,
Total_Length, (Pure_Base - 2),
primitive_table, Primitive_Table_Length,
- ((long) (primitive_table_end - primitive_table)));
+ ((long) (primitive_table_end - primitive_table)),
+ compiled_p, band_p);
}
}
if (!result)
{
- fprintf(stderr, "%s: Error writing the output file.\n", Program_Name);
+ fprintf(stderr, "%s: Error writing the output file.\n", program_name);
quit(1);
}
return;
\f
/* Top level */
-static struct Option_Struct Options[] =
- {{"Allow_Compiled", true, &allow_compiled_p},
- {"Allow_NMVs", true, &allow_nmv_p}};
-
-static int Noptions = 2;
+static struct keyword_struct
+ options[] = {
+ KEYWORD("allow_nmv", &allow_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD("allow_cc", &allow_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ OUTPUT_KEYWORD(),
+ INPUT_KEYWORD(),
+ END_KEYWORD()
+ };
main(argc, argv)
int argc;
char *argv[];
{
- Setup_Program(argc, argv, Noptions, Options);
+ parse_keywords(argc, argv, options, false);
+ setup_io();
do_it();
quit(0);
}
projects / mit-scheme.git / commitdiff