/* -*-C-*-
-$Id: bintopsb.c,v 9.57 1993/10/14 21:42:22 gjr Exp $
+$Id: bintopsb.c,v 9.58 1993/11/07 01:39:06 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
/* IO definitions */
#include "psbmap.h"
-#include "trap.h"
#include "limits.h"
#define internal_file input_file
#define portable_file output_file
#undef HEAP_MALLOC
#define HEAP_MALLOC malloc
-long
-DEFUN (Load_Data, (Count, To_Where),
- long Count AND
- SCHEME_OBJECT *To_Where)
+static long
+DEFUN (Load_Data, (Count, To_Where), long Count AND SCHEME_OBJECT *To_Where)
{
return (fread (((char *) To_Where),
(sizeof (SCHEME_OBJECT)),
#define INHIBIT_CHECKSUMS
#include "load.c"
#include "bltdef.h"
-\f
+#include "trap.h"
+
/* Character macros and procedures */
extern int strlen ();
punctuation[] = "'\",<.>/?;:{}[]|`~=+-_()*&^%$#@!";
static Boolean
-DEFUN (ispunct_local, (c),
- fast char c)
+DEFUN (ispunct_local, (c), fast char c)
{
fast char * s;
s = &punctuation[0];
while (*s != '\0')
- {
if (*s++ == c)
- {
return (true);
- }
- }
return (false);
}
#endif /* ispunct */
\f
-/* Global data */
-
/* Needed to upgrade */
#define TC_PRIMITIVE_EXTERNAL 0x10
#define STRING_LENGTH_TO_LONG(value) \
((long) (upgrade_lengths_p ? (OBJECT_DATUM (value)) : (value)))
+/* In case there is no compiled code support. */
+
+#ifndef FORMAT_WORD_LOW_BYTE
+#define FORMAT_WORD_LOW_BYTE(x) x
+#endif
+
+#ifndef FORMAT_WORD_HIGH_BYTE
+#define FORMAT_WORD_HIGH_BYTE(x) x
+#endif
+
+#ifndef COMPILED_ENTRY_FORMAT_WORD
+#define COMPILED_ENTRY_FORMAT_WORD(entry) 0
+#endif
+
+#ifndef EXTRACT_EXECUTE_CACHE_ARITY
+#define EXTRACT_EXECUTE_CACHE_ARITY(v,a) do { } while (0)
+#endif
+
+/* Global data */
+
static Boolean
+ allow_bands_p = false,
allow_compiled_p = false,
+ allow_constant_space_p = false,
allow_nmv_p = false,
+ c_compiled_p = false,
+ endian_invert_p = false,
shuffle_bytes_p = false,
swap_bytes_p = false,
upgrade_compiled_p = false,
upgrade_lengths_p = false,
upgrade_primitives_p = false,
upgrade_traps_p = false,
- vax_invert_p = false;
+ warn_portable_p = true;
static long
Heap_Relocation, Constant_Relocation,
- Free, Scan, Free_Constant, Scan_Constant,
- Objects, Constant_Objects;
+ Max_Stack_Offset,
+ Scan, Free, Objects,
+ Scan_Constant, Free_Constant, Constant_Objects,
+ Scan_Pure, Free_Pure, Pure_Objects;
static SCHEME_OBJECT
- *Mem_Base,
- *Free_Objects, *Free_Cobjects,
- *compiled_entry_table, *compiled_entry_pointer,
- *compiled_entry_table_end,
- *primitive_table, *primitive_table_end;
+ * Mem_Base, * Constant_Space, * Constant_Top,
+ * Free_Objects, * Free_Cobjects, * Free_Pobjects,
+ * compiled_entry_table, * compiled_entry_pointer,
+ * compiled_entry_table_end,
+ * compiled_block_table, * compiled_block_pointer,
+ * compiled_block_table_end,
+ * primitive_table, * primitive_table_end,
+ * c_code_table, * c_code_table_end;
static long
NFlonums,
NIntegers, NBits,
NBitstrs, NBBits,
NStrings, NChars,
- NPChars;
+ NPChars, NCChars;
\f
#define OUT(s) \
{ \
- fprintf(portable_file, (s)); \
+ fprintf (portable_file, (s)); \
break; \
}
-void
-DEFUN (print_a_char, (c, name),
- fast char c AND
- char *name)
+static void
+DEFUN (print_a_char, (c, name), fast char c AND char * name)
{
- switch(c)
+ switch (c)
{
- case '\n': OUT("\\n");
- case '\t': OUT("\\t");
- case '\b': OUT("\\b");
- case '\r': OUT("\\r");
- case '\f': OUT("\\f");
- case '\\': OUT("\\\\");
- case '\0': OUT("\\0");
- case ' ' : OUT(" ");
+ case '\n': OUT ("\\n");
+ case '\t': OUT ("\\t");
+ case '\b': OUT ("\\b");
+ case '\r': OUT ("\\r");
+ case '\f': OUT ("\\f");
+ case '\\': OUT ("\\\\");
+ case '\0': OUT ("\\0");
+ case ' ' : OUT (" ");
default:
- if ((isascii(c)) && ((isalpha(c)) || (isdigit(c)) || (ispunct(c))))
- {
- putc(c, portable_file);
- }
+ if ((isascii (c)) && ((isalpha (c)) || (isdigit (c)) || (ispunct (c))))
+ putc (c, portable_file);
else
{
unsigned int x = (((int) c) & ((1 << CHAR_BIT) - 1));
- fprintf(stderr,
- "%s: %s: File may not be portable: c = 0x%x\n",
- program_name, name, x);
+ if (warn_portable_p)
+ {
+ fprintf (stderr,
+ "%s: %s: File may not be portable: c = 0x%x\n",
+ program_name, name, x);
+ warn_portable_p = false;
+ }
/* This does not follow C conventions, but eliminates ambiguity */
- fprintf(portable_file, "\\X%d ", x);
+ fprintf (portable_file, "\\X%d ", x);
}
}
return;
#undef MAKE_BROKEN_HEART
#define MAKE_BROKEN_HEART(offset) (BROKEN_HEART_ZERO + (offset))
-#define Do_Compound(Code, Rel, Fre, Scn, Obj, FObj, kernel_code) \
+#define DO_COMPOUND(Code, Rel, Fre, Scn, Obj, FObj, kernel_code) do \
{ \
Old_Address += (Rel); \
Old_Contents = (*Old_Address); \
if (BROKEN_HEART_P (Old_Contents)) \
(Mem_Base [(Scn)]) = (OBJECT_NEW_TYPE ((Code), Old_Contents)); \
else \
- { \
kernel_code; \
- } \
-}
+} while (0)
-#define standard_kernel(kernel_code, type, Code, Scn, Obj, FObj) \
+#define STANDARD_KERNEL(kernel_code, type, Code, Scn, Obj, FObj) do \
{ \
(Mem_Base [(Scn)]) = (MAKE_OBJECT ((Code), (Obj))); \
{ \
while ((length--) > 0) \
(*(FObj)++) = (*Old_Address++); \
} \
-}
+} while (0)
\f
-#define do_string_kernel() \
+#define DO_STRING_KERNEL() do \
{ \
NStrings += 1; \
NChars += (pointer_to_char (length - 1)); \
-}
+} while (0)
-#define do_bignum_kernel() \
+#define DO_BIGNUM_KERNEL() do \
{ \
NIntegers += 1; \
NBits += \
(((* ((bignum_digit_type *) (Old_Address + 1))) \
& BIGNUM_DIGIT_MASK) \
* BIGNUM_DIGIT_LENGTH); \
-}
+} while (0)
-#define do_bit_string_kernel() \
+#define DO_BIT_STRING_KERNEL() do \
{ \
NBitstrs += 1; \
NBBits += (Old_Address [BIT_STRING_LENGTH_OFFSET]); \
-}
+} while (0)
-#define do_flonum_kernel(Code, Scn, Obj, FObj) \
+#define DO_FLONUM_KERNEL(Code, Scn, Obj, FObj) do \
{ \
+ int ctr; \
+ SCHEME_OBJECT * dest; \
+ \
(Mem_Base [(Scn)]) = (MAKE_OBJECT ((Code), (Obj))); \
NFlonums += 1; \
(*Old_Address++) = (MAKE_BROKEN_HEART (Obj)); \
(Obj) += 1; \
- ALIGN_FLOAT (FObj); \
(*(FObj)++) = (MAKE_OBJECT (TC_BIG_FLONUM, 0)); \
- (* ((double *) (FObj))) = (* ((double *) Old_Address)); \
- (FObj) += float_to_pointer; \
-}
-
-#define Do_String(Code, Rel, Fre, Scn, Obj, FObj) \
- Do_Compound (Code, Rel, Fre, Scn, Obj, FObj, \
- standard_kernel (do_string_kernel (), \
+ dest = (FObj); \
+ for (ctr = 0; ctr < float_to_pointer; ctr++) \
+ *dest++ = (*Old_Address++); \
+ (FObj) = dest; \
+} while (0)
+
+#define DO_STRING(Code, Rel, Fre, Scn, Obj, FObj) \
+ DO_COMPOUND (Code, Rel, Fre, Scn, Obj, FObj, \
+ STANDARD_KERNEL (DO_STRING_KERNEL (), \
TC_CHARACTER_STRING, \
Code, Scn, Obj, FObj))
-#define Do_Bignum(Code, Rel, Fre, Scn, Obj, FObj) \
- Do_Compound (Code, Rel, Fre, Scn, Obj, FObj, \
- standard_kernel (do_bignum_kernel (), TC_BIG_FIXNUM, \
+#define DO_BIGNUM(Code, Rel, Fre, Scn, Obj, FObj) \
+ DO_COMPOUND (Code, Rel, Fre, Scn, Obj, FObj, \
+ STANDARD_KERNEL (DO_BIGNUM_KERNEL (), TC_BIG_FIXNUM, \
Code, Scn, Obj, FObj))
-#define Do_Bit_String(Code, Rel, Fre, Scn, Obj, FObj) \
- Do_Compound (Code, Rel, Fre, Scn, Obj, FObj, \
- standard_kernel (do_bit_string_kernel (), TC_BIT_STRING, \
+#define DO_BIT_STRING(Code, Rel, Fre, Scn, Obj, FObj) \
+ DO_COMPOUND (Code, Rel, Fre, Scn, Obj, FObj, \
+ STANDARD_KERNEL (DO_BIT_STRING_KERNEL (), TC_BIT_STRING, \
Code, Scn, Obj, FObj))
-#define Do_Flonum(Code, Rel, Fre, Scn, Obj, FObj) \
- Do_Compound (Code, Rel, Fre, Scn, Obj, FObj, \
- do_flonum_kernel (Code, Scn, Obj, FObj))
+#define DO_FLONUM(Code, Rel, Fre, Scn, Obj, FObj) \
+ DO_COMPOUND (Code, Rel, Fre, Scn, Obj, FObj, \
+ DO_FLONUM_KERNEL (Code, Scn, Obj, FObj))
\f
-void
-DEFUN (print_a_fixnum, (val),
- long val)
+static void
+DEFUN (print_a_fixnum, (val), long val)
{
fast long size_in_bits;
fast unsigned long temp;
temp = ((val < 0) ? -val : val);
for (size_in_bits = 0; temp != 0; size_in_bits += 1)
- {
temp = temp >> 1;
- }
- fprintf(portable_file, "%02x %c ",
- TC_FIXNUM,
- (val < 0 ? '-' : '+'));
+ 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;
}
\f
-void
-DEFUN (print_a_string_internal, (len, str),
- fast long len AND
- fast char *str)
+static void
+DEFUN (print_a_string_internal, (len, str), fast long len AND fast char * str)
{
- fprintf(portable_file, "%ld ", len);
+ fprintf (portable_file, "%ld ", len);
if (shuffle_bytes_p)
{
- while(len > 0)
+ while (len > 0)
{
- print_a_char(str[3], "print_a_string");
+ print_a_char (str[3], "print_a_string");
if (len > 1)
- {
- print_a_char(str[2], "print_a_string");
- }
+ print_a_char (str[2], "print_a_string");
if (len > 2)
- {
- print_a_char(str[1], "print_a_string");
- }
+ print_a_char (str[1], "print_a_string");
if (len > 3)
- {
- print_a_char(str[0], "print_a_string");
- }
+ print_a_char (str[0], "print_a_string");
len -= 4;
str += 4;
}
}
else
- {
- while(--len >= 0)
- {
- print_a_char(*str++, "print_a_string");
- }
- }
- putc('\n', portable_file);
+ while (--len >= 0)
+ print_a_char (*str++, "print_a_string");
+ putc ('\n', portable_file);
return;
}
\f
-void
-DEFUN (print_a_string, (from),
- SCHEME_OBJECT *from)
+static void
+DEFUN (print_a_string, (from), SCHEME_OBJECT * from)
{
- long len;
- long maxlen;
+ long len, maxlen;
- maxlen = (pointer_to_char ((OBJECT_DATUM (*from++)) - 1));
+ maxlen = ((pointer_to_char ((OBJECT_DATUM (*from++)) - 1)) - 1);
len = (STRING_LENGTH_TO_LONG (*from++));
+ /* If compacting, do not compact strings that have non-default
+ maximum lengths.
+ */
+
fprintf (portable_file,
"%02x %ld ",
TC_CHARACTER_STRING,
- (compact_p ? len : maxlen));
+ ((compact_p
+ && ((BYTES_TO_WORDS (len + 1)) == (BYTES_TO_WORDS (maxlen + 1))))
+ ? len
+ : maxlen));
print_a_string_internal (len, ((char *) from));
return;
}
-void
+static void
DEFUN (print_a_primitive, (arity, length, name),
- long arity AND
- long length AND
- char *name)
+ long arity AND long length AND char * name)
{
fprintf (portable_file, "%ld ", arity);
print_a_string_internal (length, name);
return;
}
+
+static void
+DEFUN (print_a_c_code_block, (nentries, length, name),
+ long nentries AND long length AND char * name)
+{
+ fprintf (portable_file, "%ld ", nentries);
+ print_a_string_internal (length, name);
+ return;
+}
\f
static long
-DEFUN (bignum_length, (bignum),
- SCHEME_OBJECT bignum)
+DEFUN (bignum_length, (bignum), SCHEME_OBJECT bignum)
{
if (BIGNUM_ZERO_P (bignum))
return (0);
/* NOTREACHED */
}
\f
-void
-DEFUN (print_a_bignum, (bignum_ptr),
- SCHEME_OBJECT *bignum_ptr)
+static void
+DEFUN (print_a_bignum, (bignum_ptr), SCHEME_OBJECT * bignum_ptr)
{
SCHEME_OBJECT bignum;
bignum = (MAKE_POINTER_OBJECT (TC_BIG_FIXNUM, bignum_ptr));
if (BIGNUM_ZERO_P (bignum))
- {
- fprintf (portable_file, "%02x + 0\n",
- (compact_p ? TC_FIXNUM : TC_BIG_FIXNUM));
- return;
- }
{
+ fprintf (portable_file, "%02x + 0\n",
+ (compact_p ? TC_FIXNUM : TC_BIG_FIXNUM));
+ return;
+ }
+ {
+ int the_type = TC_BIG_FIXNUM;
bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
fast long length_in_bits = (bignum_length (bignum));
fast int bits_in_digit = 0;
fast bignum_digit_type accumulator;
+
+ /* This attempts to preserve non-canonicalized bignums as such.
+ The test below fails for the most negative fixnum represented
+ as a bignum
+ */
+
+ if (compact_p && (length_in_bits > fixnum_to_bits))
+ the_type = TC_FIXNUM;
+
fprintf (portable_file, "%02x %c %ld ",
- (compact_p ? TC_FIXNUM : TC_BIG_FIXNUM),
+ the_type,
((BIGNUM_NEGATIVE_P (bignum)) ? '-' : '+'),
length_in_bits);
accumulator = (*scan++);
- bits_in_digit =
- ((length_in_bits < BIGNUM_DIGIT_LENGTH)
- ? length_in_bits
- : BIGNUM_DIGIT_LENGTH);
+ bits_in_digit = ((length_in_bits < BIGNUM_DIGIT_LENGTH)
+ ? length_in_bits
+ : BIGNUM_DIGIT_LENGTH);
while (length_in_bits > 0)
{
if (bits_in_digit > 4)
int diff_bits = (4 - bits_in_digit);
accumulator = (*scan++);
fprintf (portable_file, "%01lx",
- (carry |
- ((accumulator & ((1 << diff_bits) - 1)) <<
- bits_in_digit)));
+ (carry
+ | ((accumulator & ((1 << diff_bits) - 1)) <<
+ bits_in_digit)));
length_in_bits -= 4;
bits_in_digit = (BIGNUM_DIGIT_LENGTH - diff_bits);
if (length_in_bits >= bits_in_digit)
}
}
fprintf (portable_file, "\n");
+ return;
}
\f
/* The following procedure assumes that a C long is at least 4 bits. */
-void
-DEFUN (print_a_bit_string, (from),
- SCHEME_OBJECT *from)
+static void
+DEFUN (print_a_bit_string, (from), SCHEME_OBJECT * from)
{
SCHEME_OBJECT the_bit_string;
fast long bits_remaining, leftover_bits;
the_bit_string = (MAKE_POINTER_OBJECT (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, " ");
- scan = BIT_STRING_LOW_PTR(the_bit_string);
+ fprintf (portable_file, " ");
+ scan = (BIT_STRING_LOW_PTR (the_bit_string));
for (leftover_bits = 0;
bits_remaining > 0;
bits_remaining -= OBJECT_LENGTH)
{
- next_word = *(INC_BIT_STRING_PTR(scan));
+ next_word = (* (INC_BIT_STRING_PTR (scan)));
if (bits_remaining < OBJECT_LENGTH)
- next_word &= LOW_MASK(bits_remaining);
+ next_word &= (LOW_MASK (bits_remaining));
- if (leftover_bits != 0)
+ if (leftover_bits == 0)
+ leftover_bits = ((bits_remaining > OBJECT_LENGTH)
+ ? OBJECT_LENGTH
+ : bits_remaining);
+ else
{
- accumulator &= LOW_MASK(leftover_bits);
+ accumulator &= (LOW_MASK (leftover_bits));
accumulator |=
- ((next_word & LOW_MASK(4 - leftover_bits)) << leftover_bits);
+ ((next_word & (LOW_MASK (4 - leftover_bits))) << leftover_bits);
next_word = (next_word >> (4 - leftover_bits));
- leftover_bits += ((bits_remaining > OBJECT_LENGTH) ?
- (OBJECT_LENGTH - 4) :
- (bits_remaining - 4));
- fprintf(portable_file, "%01lx", (accumulator & 0xf));
- }
- else
- {
- leftover_bits = ((bits_remaining > OBJECT_LENGTH) ?
- OBJECT_LENGTH :
- bits_remaining);
+ leftover_bits += ((bits_remaining > OBJECT_LENGTH)
+ ? (OBJECT_LENGTH - 4)
+ : (bits_remaining - 4));
+ fprintf (portable_file, "%01lx", (accumulator & 0xf));
}
- for(accumulator = next_word; leftover_bits >= 4; leftover_bits -= 4)
+ for (accumulator = next_word; leftover_bits >= 4; leftover_bits -= 4)
{
- fprintf(portable_file, "%01lx", (accumulator & 0xf));
- accumulator = accumulator >> 4;
+ 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
-void
-DEFUN (print_a_flonum, (val),
- double val)
+union flonum_u
{
+ double dval;
+ unsigned long lval[float_to_pointer];
+};
+
+static void
+DEFUN (print_a_flonum, (src), SCHEME_OBJECT * src)
+{
+ double val;
+ union flonum_u utemp;
fast long size_in_bits;
fast double mant, temp;
- int expt;
+ int expt, ctr;
extern double EXFUN (frexp, (double, int *));
- fprintf(portable_file, "%02x %c ",
- TC_BIG_FLONUM,
- ((val < 0.0) ? '-' : '+'));
+ for (ctr = 0; ctr < float_to_pointer; ctr++)
+ utemp.lval[ctr] = ((unsigned long) src[ctr]);
+ val = utemp.dval;
+
+ 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);
+ mant = frexp (((val < 0.0) ? -val : val), &expt);
size_in_bits = 1;
- for(temp = ((mant * 2.0) - 1.0);
- temp != 0;
- size_in_bits += 1)
+ for (temp = ((mant * 2.0) - 1.0); temp != 0; size_in_bits += 1)
{
temp *= 2.0;
if (temp >= 1.0)
temp -= 1.0;
}
- fprintf(portable_file, "%d %ld ", expt, size_in_bits);
+ fprintf (portable_file, "%d %ld ", expt, size_in_bits);
- for (size_in_bits = hex_digits(size_in_bits);
+ for (size_in_bits = (hex_digits (size_in_bits));
size_in_bits > 0;
size_in_bits -= 1)
{
digit += 1;
}
}
- fprintf(portable_file, "%01x", digit);
+ fprintf (portable_file, "%01x", digit);
}
- putc('\n', portable_file);
+ putc ('\n', portable_file);
return;
}
\f
/* Normal Objects */
-#define Do_Cell(Code, Rel, Fre, Scn, Obj, FObj) \
+#define DO_CELL(Code, Rel, Fre, Scn, Obj, FObj) do \
{ \
Old_Address += (Rel); \
Old_Contents = (*Old_Address); \
(Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre))); \
(Mem_Base [(Fre)++]) = Old_Contents; \
} \
-}
+} while (0)
-#define Do_Pair(Code, Rel, Fre, Scn, Obj, FObj) \
+#define DO_PAIR(Code, Rel, Fre, Scn, Obj, FObj) do \
{ \
Old_Address += (Rel); \
Old_Contents = (*Old_Address); \
(Mem_Base [(Fre)++]) = Old_Contents; \
(Mem_Base [(Fre)++]) = (*Old_Address++); \
} \
-}
+} while (0)
-#define Do_Triple(Code, Rel, Fre, Scn, Obj, FObj) \
+#define DO_TRIPLE(Code, Rel, Fre, Scn, Obj, FObj) do \
{ \
Old_Address += (Rel); \
Old_Contents = (*Old_Address); \
(Mem_Base [(Fre)++]) = (*Old_Address++); \
(Mem_Base [(Fre)++]) = (*Old_Address++); \
} \
-}
+} while (0)
-#define Do_Quad(Code, Rel, Fre, Scn, Obj, FObj) \
+#define DO_QUAD(Code, Rel, Fre, Scn, Obj, FObj) do \
{ \
Old_Address += (Rel); \
Old_Contents = (*Old_Address); \
(Mem_Base [(Fre)++]) = (*Old_Address++); \
(Mem_Base [(Fre)++]) = (*Old_Address++); \
} \
-}
+} while (0)
+
+#define DO_RAW_QUAD(Code, Rel, Fre, Scn, Obj, FObj) do \
+{ \
+ Old_Address += (Rel); \
+ Old_Contents = (* Old_Address); \
+ if (BROKEN_HEART_P (Old_Contents)) \
+ (Mem_Base [(Scn)]) = (OBJECT_DATUM (Old_Contents)); \
+ else \
+ { \
+ (*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \
+ (Mem_Base [(Scn)]) = (Fre); \
+ (Mem_Base [(Fre)++]) = Old_Contents; \
+ (Mem_Base [(Fre)++]) = (*Old_Address++); \
+ (Mem_Base [(Fre)++]) = (*Old_Address++); \
+ (Mem_Base [(Fre)++]) = (*Old_Address++); \
+ } \
+} while (0)
\f
-#define Copy_Vector(Scn, Fre) \
+#define COPY_VECTOR(Fre) do \
{ \
fast long len = (OBJECT_DATUM (Old_Contents)); \
(*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \
(Mem_Base [(Fre)++]) = Old_Contents; \
while ((len--) > 0) \
(Mem_Base [(Fre)++]) = (*Old_Address++); \
-}
+} while (0)
-#define Do_Vector(Code, Rel, Fre, Scn, Obj, FObj) \
+#define DO_VECTOR(Code, Rel, Fre, Scn, Obj, FObj) do \
{ \
Old_Address += (Rel); \
Old_Contents = (*Old_Address); \
else \
{ \
(Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre))); \
- Copy_Vector (Scn, Fre); \
+ COPY_VECTOR (Fre); \
} \
-}
+} while (0)
-/* This is a hack to get the cross compiler to work from vaxen to other
- machines and viceversa. */
+/* This is a hack to get the cross compiler to work
+ accross different endianness.
+*/
-#define Do_Inverted_Block(Code, Rel, Fre, Scn, Obj, FObj) \
+#define DO_INVERTED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj) do \
{ \
Old_Address += (Rel); \
Old_Contents = (*Old_Address); \
if ((OBJECT_TYPE (*Old_Address)) != TC_MANIFEST_NM_VECTOR) \
{ \
fprintf (stderr, "%s: Bad compiled code block found.\n", \
- program_name); \
+ program_name); \
quit (1); \
} \
len2 = (OBJECT_DATUM (*Old_Address)); \
while ((len1--) > 0) \
(Mem_Base [(Fre)++]) = (*Old_Address++); \
} \
-}
+} while (0)
\f
#ifdef HAS_COMPILER_SUPPORT
-#define Do_Compiled_Entry(Code, Rel, Fre, Scn, Obj, FObj) \
+#define CHAR_OFFSET(a,b) (((char *) (a)) - ((char *) (b)))
+#define OBJ_OFFSET(a,b) (((SCHEME_OBJECT *) (a)) - ((SCHEME_OBJECT *) (b)))
+
+#define DO_ENTRY_INTERNAL(sub, copy, Code, Rel, Fre, Scn, Obj, FObj) do \
{ \
long offset; \
SCHEME_OBJECT * saved; \
+ \
Old_Address += (Rel); \
saved = Old_Address; \
Get_Compiled_Block (Old_Address, saved); \
Old_Contents = (*Old_Address); \
- (Mem_Base [(Scn)]) = \
- (MAKE_OBJECT \
- (TC_COMPILED_ENTRY, \
- (compiled_entry_pointer - compiled_entry_table))); \
- offset = (((char *) saved) - ((char *) Old_Address)); \
- (*compiled_entry_pointer++) = (LONG_TO_FIXNUM (offset)); \
- /* Base pointer */ \
+ entry_no = (compiled_entry_pointer - compiled_entry_table); \
+ offset = (sub (saved, Old_Address)); \
+ (*compiled_entry_pointer++) = (LONG_TO_UNSIGNED_FIXNUM (offset)); \
if (BROKEN_HEART_P (Old_Contents)) \
(*compiled_entry_pointer++) = \
(MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \
else \
- { \
- (*compiled_entry_pointer++) = \
- (MAKE_OBJECT_FROM_OBJECTS (This, (Fre))); \
- Copy_Vector (Scn, Fre); \
- } \
+ { \
+ (*compiled_entry_pointer++) = \
+ (MAKE_OBJECT_FROM_OBJECTS (This, (Fre))); \
+ copy (Fre); \
+ } \
+} while (0)
+
+#define DO_COMPILED_ENTRY(Code, Rel, Fre, Scn, Obj, FObj) \
+ DO_ENTRY_INTERNAL(CHAR_OFFSET, COPY_VECTOR, \
+ Code, Rel, Fre, Scn, Obj, FObj)
+
+#define DO_C_COMPILED_ENTRY(Code, Rel, Fre, Scn, Obj, FObj) \
+ DO_ENTRY_INTERNAL(OBJ_OFFSET, COPY_C_COMPILED_BLOCK, \
+ Code, Rel, Fre, Scn, Obj, FObj)
+
+#define DO_C_COMPILED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj) do \
+{ \
+ Old_Address += (Rel); \
+ Old_Contents = (* Old_Address); \
+ if (BROKEN_HEART_P (Old_Contents)) \
+ (Mem_Base [(Scn)]) = \
+ (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \
+ else \
+ { \
+ (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre))); \
+ COPY_C_COMPILED_BLOCK (Fre); \
+ } \
+} while (0)
+\f
+/* This depends on the fact that a compiled code block has an NMV
+ header in the first or second words.
+ */
+
+long
+DEFUN (copy_c_compiled_block, (Fre, Old_Contents, Old_Address),
+ long Fre AND SCHEME_OBJECT Old_Contents AND SCHEME_OBJECT * Old_Address)
+{
+ SCHEME_OBJECT preserved_nmv, preserved_loc;
+ SCHEME_OBJECT nmv_replacement
+ = (MAKE_OBJECT (TC_BROKEN_HEART,
+ (compiled_block_pointer
+ - compiled_block_table)));
+ fast long len = (OBJECT_DATUM (Old_Contents));
+
+ *Old_Address++ = (MAKE_BROKEN_HEART (Fre));
+ if ((OBJECT_TYPE (Old_Contents)) != TC_MANIFEST_CLOSURE)
+ {
+ if ((OBJECT_TYPE (Old_Contents)) == TC_MANIFEST_NM_VECTOR)
+ {
+ preserved_nmv = Old_Contents;
+ preserved_loc = (LONG_TO_UNSIGNED_FIXNUM (Fre));
+ Old_Contents = nmv_replacement;
+ }
+ else if ((OBJECT_TYPE (*Old_Address)) == TC_MANIFEST_NM_VECTOR)
+ {
+ preserved_nmv = *Old_Address;
+ preserved_loc = (LONG_TO_UNSIGNED_FIXNUM ((Fre) + 1));
+ *Old_Address = nmv_replacement;
+ }
+ else
+ {
+ fprintf (stderr,
+ "%s: Improperly formatted C-compiled code block.\n",
+ program_name);
+ quit (1);
+ }
+
+ *compiled_block_pointer++ = preserved_loc;
+ *compiled_block_pointer++ = preserved_nmv;
+ }
+
+ (Mem_Base [(Fre)++]) = Old_Contents;
+ while ((len--) > 0)
+ (Mem_Base [(Fre)++]) = (*Old_Address++);
+ return (Fre);
}
+#define COPY_C_COMPILED_BLOCK(Fre) do \
+{ \
+ Fre = copy_c_compiled_block (Fre, Old_Contents, Old_Address); \
+} while (0)
+
#else /* no HAS_COMPILER_SUPPORT */
-#define Do_Compiled_Entry(Code, Rel, Fre, Scn, Obj, FObj) \
+#define DO_COMPILED_ENTRY(Code, Rel, Fre, Scn, Obj, FObj) do \
{ \
fprintf \
(stderr, \
- "%s: Invoking Do_Compiled_Entry with no compiler support!\n", \
+ "%s: Invoking DO_COMPILED_ENTRY with no compiler support!\n", \
program_name); \
quit (1); \
-}
+} while (0)
+
+#define DO_C_COMPILED_ENTRY DO_COMPILED_ENTRY
+
+#define DO_C_COMPILED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj) do \
+{ \
+ fprintf \
+ (stderr, \
+ "%s: Invoking DO_C_COMPILED_BLOCK with no compiler support!\n", \
+ program_name); \
+ quit (1); \
+} while (0)
#endif /* HAS_COMPILER_SUPPORT */
\f
+/* Constant/Pure space utilities */
+
+static SCHEME_OBJECT *
+DEFUN (find_constant_top, (constant_space, count),
+ SCHEME_OBJECT * constant_space AND unsigned long count)
+{
+ SCHEME_OBJECT pattern = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0));
+ SCHEME_OBJECT * limit = (constant_space + count);
+
+ while (((* (limit - 1)) == pattern)
+ && (limit > constant_space))
+ limit -= 1;
+ return (limit);
+}
+
+static Boolean
+DEFUN (address_in_pure_space, (addr), SCHEME_OBJECT * addr)
+{
+ Boolean result = false;
+ SCHEME_OBJECT * where, * low_constant;
+
+ low_constant = Constant_Space;
+ where = (Constant_Top - 1);
+
+ while (where >= low_constant)
+ {
+ where -= (1 + (OBJECT_DATUM (* where)));
+ if (where < addr)
+ {
+ where += 1; /* block start */
+ result = (addr <= (where + (OBJECT_DATUM (* where))));
+ break;
+ }
+ }
+ return (result);
+}
+\f
/* Common Pointer Code */
-#define Do_Pointer(Scn, Action) \
+#define DO_POINTER(Scn, Action) do \
{ \
long the_datum; \
\
Old_Address = (OBJECT_ADDRESS (This)); \
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); \
- } \
- /* 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); \
- } \
- */ \
+ if ((the_datum >= Heap_Base) && (the_datum < Dumped_Heap_Top)) \
+ Action (HEAP_CODE, Heap_Relocation, Free, \
+ Scn, Objects, Free_Objects); \
+ else if ((the_datum >= Const_Base) \
+ && (the_datum < Dumped_Constant_Top)) \
+ { \
+ SCHEME_OBJECT * new_addr; \
+ \
+ new_addr = (Old_Address + Constant_Relocation); \
+ if (address_in_pure_space (new_addr)) \
+ Action (PURE_CODE, Constant_Relocation, Free_Pure, \
+ Scn, Pure_Objects, Free_Pobjects); \
+ else \
+ Action (CONSTANT_CODE, Constant_Relocation, Free_Constant, \
+ Scn, Constant_Objects, Free_Cobjects); \
+ } \
else \
- { \
- out_of_range_pointer (This); \
- } \
+ out_of_range_pointer (This); \
(Scn) += 1; \
- break; \
-}
+} while (0)
+
+#define DO_RAW_POINTER(ptr, Scn, Action) do \
+{ \
+ long the_datum; \
+ \
+ Old_Address = (SCHEME_ADDR_TO_ADDR (ptr)); \
+ the_datum = (ADDRESS_TO_DATUM (Old_Address)); \
+ if ((the_datum >= Heap_Base) && (the_datum < Dumped_Heap_Top)) \
+ Action (HEAP_CODE, Heap_Relocation, Free, \
+ Scn, Objects, Free_Objects); \
+ else if ((the_datum >= Const_Base) \
+ && (the_datum < Dumped_Constant_Top)) \
+ { \
+ SCHEME_OBJECT * new_addr; \
+ \
+ new_addr = (Old_Address + Constant_Relocation); \
+ if (address_in_pure_space (new_addr)) \
+ Action (PURE_CODE, Constant_Relocation, Free_Pure, \
+ Scn, Pure_Objects, Free_Pobjects); \
+ else \
+ Action (CONSTANT_CODE, Constant_Relocation, Free_Constant, \
+ Scn, Constant_Objects, Free_Cobjects); \
+ } \
+ else \
+ out_of_range_pointer (This); \
+} while (0)
\f
-void
-DEFUN (out_of_range_pointer, (ptr),
- SCHEME_OBJECT ptr)
+static void
+DEFUN (out_of_range_pointer, (ptr), SCHEME_OBJECT 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);
+ 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);
}
-SCHEME_OBJECT *
-DEFUN (relocate, (object),
- SCHEME_OBJECT object)
+static SCHEME_OBJECT *
+DEFUN (relocate, (object), SCHEME_OBJECT object)
{
long the_datum;
- SCHEME_OBJECT *result;
+ SCHEME_OBJECT * result;
- result = OBJECT_ADDRESS (object);
- the_datum = OBJECT_DATUM (object);
+ result = (OBJECT_ADDRESS (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) &&
+ else if ((the_datum >= Const_Base) &&
(the_datum < Dumped_Constant_Top))
- result += Constant_Relocation;
-
-#endif /* false */
-
+ result += Constant_Relocation;
else
- out_of_range_pointer(object);
+ out_of_range_pointer (object);
return (result);
}
\f
#define PRIMITIVE_UPGRADE_SPACE 2048
static SCHEME_OBJECT
- *internal_renumber_table,
- *external_renumber_table,
- *external_prim_name_table;
+ * internal_renumber_table,
+ * external_renumber_table,
+ * external_prim_name_table;
static Boolean
found_ext_prims = false;
-SCHEME_OBJECT
-DEFUN (upgrade_primitive, (prim),
- SCHEME_OBJECT prim)
+static SCHEME_OBJECT
+DEFUN (upgrade_primitive, (prim), SCHEME_OBJECT prim)
{
long the_datum, the_type, new_type, code;
SCHEME_OBJECT new;
- the_datum = OBJECT_DATUM (prim);
- the_type = OBJECT_TYPE (prim);
+ the_datum = (OBJECT_DATUM (prim));
+ the_type = (OBJECT_TYPE (prim));
if (the_type != TC_PRIMITIVE_EXTERNAL)
{
code = the_datum;
code = (the_datum + (MAX_BUILTIN_PRIMITIVE + 1));
new_type = TC_PRIMITIVE;
}
-\f
+
new = internal_renumber_table[code];
- if (new == SHARP_F)
+ if (new != SHARP_F)
+ return (OBJECT_NEW_TYPE (new_type, new));
+ else
{
/*
This does not need to check for overflow because the worst case
external_renumber_table[Primitive_Table_Length] = prim;
Primitive_Table_Length += 1;
if (the_type == TC_PRIMITIVE_EXTERNAL)
- {
NPChars +=
- STRING_LENGTH_TO_LONG((((SCHEME_OBJECT *)
- (external_prim_name_table[the_datum]))
- [STRING_LENGTH_INDEX]));
- }
+ STRING_LENGTH_TO_LONG ((((SCHEME_OBJECT *)
+ (external_prim_name_table[the_datum]))
+ [STRING_LENGTH_INDEX]));
else
- {
- NPChars += strlen(builtin_prim_name_table[the_datum]);
- }
+ NPChars += strlen (builtin_prim_name_table[the_datum]);
return (new);
}
- else
- {
- return (OBJECT_NEW_TYPE (new_type, new));
- }
}
\f
-SCHEME_OBJECT *
-DEFUN (setup_primitive_upgrade, (Heap),
- SCHEME_OBJECT * Heap)
+static SCHEME_OBJECT *
+DEFUN (setup_primitive_upgrade, (Heap), SCHEME_OBJECT * Heap)
{
fast long count, length;
- SCHEME_OBJECT *old_prims_vector;
+ SCHEME_OBJECT * old_prims_vector;
internal_renumber_table = &Heap[0];
external_renumber_table =
external_prim_name_table =
&external_renumber_table[PRIMITIVE_UPGRADE_SPACE];
- old_prims_vector = relocate(Ext_Prim_Vector);
+ old_prims_vector = (relocate (Ext_Prim_Vector));
if (*old_prims_vector == SHARP_F)
- {
length = 0;
- }
else
{
- old_prims_vector = relocate(*old_prims_vector);
- length = OBJECT_DATUM (*old_prims_vector);
+ old_prims_vector = (relocate (*old_prims_vector));
+ length = (OBJECT_DATUM (*old_prims_vector));
old_prims_vector += VECTOR_DATA;
for (count = 0; count < length; count += 1)
{
SCHEME_OBJECT *temp;
/* symbol */
- temp = relocate(old_prims_vector[count]);
+ temp = (relocate (old_prims_vector[count]));
/* string */
- temp = relocate(temp[SYMBOL_NAME]);
+ temp = (relocate (temp[SYMBOL_NAME]));
external_prim_name_table[count] = ((SCHEME_OBJECT) temp);
}
}
length += (MAX_BUILTIN_PRIMITIVE + 1);
if (length > PRIMITIVE_UPGRADE_SPACE)
{
- fprintf(stderr, "%s: Too many primitives.\n", program_name);
- fprintf(stderr,
- "Increase PRIMITIVE_UPGRADE_SPACE and recompile %s.\n",
- program_name);
- quit(1);
+ fprintf (stderr, "%s: Too many primitives.\n", program_name);
+ fprintf (stderr,
+ "Increase PRIMITIVE_UPGRADE_SPACE and recompile %s.\n",
+ program_name);
+ quit (1);
}
for (count = 0; count < length; count += 1)
- {
internal_renumber_table[count] = SHARP_F;
- }
+
NPChars = 0;
return (&external_prim_name_table[PRIMITIVE_UPGRADE_SPACE]);
}
\f
/* Processing of a single area */
-#define Do_Area(Code, Area, Bound, Obj, FObj) \
- Process_Area (Code, &Area, &Bound, &Obj, &FObj)
+#define DO_AREA(code, Area, Bound, Obj, FObj) \
+ Process_Area (code, &Area, &Bound, &Obj, &FObj)
-void
+static void
DEFUN (Process_Area, (Code, Area, Bound, Obj, FObj),
- int Code AND
- fast long *Area AND
- fast long *Bound AND
- fast long *Obj AND
- fast SCHEME_OBJECT **FObj)
+ int Code
+ AND fast long * Area
+ AND fast long * Bound
+ AND fast long * Obj
+ AND fast SCHEME_OBJECT ** FObj)
{
- fast SCHEME_OBJECT This, *Old_Address, Old_Contents;
+ unsigned long entry_no;
+ fast SCHEME_OBJECT This, * Old_Address, Old_Contents;
- while(*Area != *Bound)
+ while (*Area != *Bound)
{
This = Mem_Base[*Area];
#ifdef PRIMITIVE_EXTERNAL_REUSED
if (upgrade_primitives_p &&
- (OBJECT_TYPE (This) == TC_PRIMITIVE_EXTERNAL))
+ ((OBJECT_TYPE (This)) == TC_PRIMITIVE_EXTERNAL))
{
- Mem_Base[*Area] = upgrade_primitive(This);
+ Mem_Base[*Area] = (upgrade_primitive (This));
*Area += 1;
continue;
}
#endif /* PRIMITIVE_EXTERNAL_REUSED */
- Switch_by_GC_Type(This)
+ Switch_by_GC_Type (This)
{
#ifndef PRIMITIVE_EXTERNAL_REUSED
case TC_PRIMITIVE:
case TC_PCOMB0:
if (upgrade_primitives_p)
- {
- Mem_Base[*Area] = upgrade_primitive(This);
- }
+ Mem_Base[*Area] = (upgrade_primitive (This));
*Area += 1;
break;
\f
i = (OBJECT_DATUM (This));
*Area += 1;
for ( ; --i >= 0; *Area += 1)
- {
Mem_Base[*Area] = SHARP_F;
- }
break;
}
else if (!allow_nmv_p)
{
- fprintf(stderr, "%s: File is not portable: NMH found\n",
- program_name);
+ if (((OBJECT_DATUM (This)) != 0) && warn_portable_p)
+ {
+ warn_portable_p = false;
+ fprintf (stderr, "%s: File is not portable: NMH found\n",
+ program_name);
+ }
}
- *Area += (1 + OBJECT_DATUM (This));
+ *Area += (1 + (OBJECT_DATUM (This)));
break;
case TC_BROKEN_HEART:
- /* [Broken Heart 0] is the cdr of fasdumped symbols. */
- if (OBJECT_DATUM (This) != 0)
+ {
+ /* [Broken Heart | 0] is the cdr of fasdumped symbols. */
+ /* [Broken Heart | x > 0] indicates a C compiled block. */
+ unsigned long the_datum = (OBJECT_DATUM (This));
+
+ if (the_datum == 0)
{
- fprintf(stderr, "%s: Broken Heart found in scan.\n",
- program_name);
- quit(1);
+ *Area += 1;
+ break;
+ }
+ else if ((! allow_compiled_p)
+ || (! c_compiled_p)
+ || ((OBJECT_DATUM (This))
+ >= (compiled_block_pointer - compiled_block_table))
+ || ((*Area)
+ != (UNSIGNED_FIXNUM_TO_LONG
+ (compiled_block_table [the_datum]))))
+ {
+ fprintf (stderr, "%s: Broken Heart found in scan.\n",
+ program_name);
+ quit (1);
+ }
+ else
+ {
+ *Area += (1 + (OBJECT_DATUM (compiled_block_table [1 + the_datum])));
+ break;
}
- *Area += 1;
- break;
-
- case TC_MANIFEST_CLOSURE:
- case TC_LINKAGE_SECTION:
- {
- fprintf(stderr,
- "%s: File contains linked compiled code.\n",
- program_name);
- quit(1);
}
-
-
- case TC_COMPILED_CODE_BLOCK:
- compiled_p = true;
- if (vax_invert_p)
+\f
+ case TC_MANIFEST_CLOSURE:
+ if ((! allow_compiled_p) || (! c_compiled_p))
+ {
+ fprintf (stderr,
+ "%s: File contains compiled closures.\n",
+ program_name);
+ quit (1);
+ }
+ else
{
- Do_Pointer(*Area, Do_Inverted_Block);
+ char * word_ptr;
+ long count, address;
+ SCHEME_OBJECT * area_end, * scan, * i_scan;
+
+ i_scan = (&Mem_Base[*Area]);
+ START_CLOSURE_RELOCATION (i_scan);
+ scan = (i_scan + 1);
+ count = (MANIFEST_CLOSURE_COUNT (scan));
+ word_ptr = (FIRST_MANIFEST_CLOSURE_ENTRY (scan));
+ area_end = (MANIFEST_CLOSURE_END (scan, count));
+
+ while ((--count) >= 0)
+ {
+ scan = ((SCHEME_OBJECT *) (word_ptr));
+ word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr));
+ EXTRACT_CLOSURE_ENTRY_ADDRESS (address, scan);
+ DO_RAW_POINTER (address, *Area, DO_C_COMPILED_ENTRY);
+ STORE_CLOSURE_ENTRY_ADDRESS (entry_no, scan);
+ }
+
+ END_CLOSURE_RELOCATION (area_end);
+ *Area += (1 + (area_end - i_scan));
+ break;
}
- else if (allow_compiled_p)
+\f
+ case TC_LINKAGE_SECTION:
+ if ((! allow_compiled_p) || (! c_compiled_p))
{
- Do_Pointer(*Area, Do_Vector);
+ fprintf (stderr,
+ "%s: File contains linked compiled code.\n",
+ program_name);
+ quit (1);
}
else
{
- fprintf(stderr,
- "%s: File contains compiled code.\n",
- program_name);
- quit(1);
+ switch (READ_LINKAGE_KIND (This))
+ {
+ case REFERENCE_LINKAGE_KIND:
+ case ASSIGNMENT_LINKAGE_KIND:
+ {
+ long count = (READ_CACHE_LINKAGE_COUNT (This));
+
+ *Area += 1;
+ while (--count >= 0)
+ {
+ DO_RAW_POINTER (Mem_Base[*Area], *Area, DO_RAW_QUAD);
+ *Area += 1;
+ }
+ break;
+ }
+
+ case OPERATOR_LINKAGE_KIND:
+ case GLOBAL_OPERATOR_LINKAGE_KIND:
+ {
+ char * word_ptr;
+ long count, address;
+ SCHEME_OBJECT * area_end, * scan, * i_scan;
+
+ i_scan = (&Mem_Base[*Area]);
+ START_OPERATOR_RELOCATION (i_scan);
+ count = (READ_OPERATOR_LINKAGE_COUNT (This));
+ word_ptr = (FIRST_OPERATOR_LINKAGE_ENTRY (i_scan));
+ area_end = (END_OPERATOR_LINKAGE_AREA (i_scan, count));
+
+ while (--count >= 0)
+ {
+ scan = ((SCHEME_OBJECT *) word_ptr);
+ word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr));
+ EXTRACT_OPERATOR_LINKAGE_ADDRESS (address, scan);
+ DO_RAW_POINTER (address, *Area, DO_C_COMPILED_ENTRY);
+ STORE_OPERATOR_LINKAGE_ADDRESS (entry_no, scan);
+ }
+ END_OPERATOR_RELOCATION (area_end);
+ *Area += (1 + (area_end - i_scan));
+ break;
+ }
+
+ default:
+ {
+ fprintf (stderr, "%s: Unknown linkage kind.\n",
+ program_name);
+ quit (1);
+ }
+ }
+ break;
}
+\f
+ case TC_COMPILED_CODE_BLOCK:
+ compiled_p = true;
+ if (! allow_compiled_p)
+ {
+ fprintf (stderr,
+ "%s: File contains compiled code.\n",
+ program_name);
+ quit (1);
+ }
+ else if (c_compiled_p)
+ DO_POINTER (*Area, DO_C_COMPILED_BLOCK);
+ else if (endian_invert_p)
+ DO_POINTER (*Area, DO_INVERTED_BLOCK);
+ else
+ DO_POINTER (*Area, DO_VECTOR);
+ break;
case_compiled_entry_point:
compiled_p = true;
- if (!allow_compiled_p)
+ if (! allow_compiled_p)
{
- fprintf(stderr,
- "%s: File contains compiled code.\n",
- program_name);
- quit(1);
+ fprintf (stderr,
+ "%s: File contains compiled code.\n",
+ program_name);
+ quit (1);
}
- Do_Pointer(*Area, Do_Compiled_Entry);
+ else if (c_compiled_p)
+ DO_POINTER (*Area, DO_C_COMPILED_ENTRY);
+ else
+ DO_POINTER (*Area, DO_COMPILED_ENTRY);
+ Mem_Base[*Area - 1] = (MAKE_OBJECT (TC_COMPILED_ENTRY, entry_no));
+ break;
case TC_STACK_ENVIRONMENT:
- fprintf(stderr,
- "%s: File contains stack environments.\n",
- program_name);
- quit(1);
+ if (! allow_bands_p)
+ {
+ fprintf (stderr,
+ "%s: File contains stack environments.\n",
+ program_name);
+ quit (1);
+ }
+ else
+ {
+ unsigned long delta;
+
+ delta = (((SCHEME_OBJECT *) Dumped_Stack_Top)
+ - ((SCHEME_OBJECT *) (OBJECT_DATUM (This))));
+ if (delta > Max_Stack_Offset)
+ Max_Stack_Offset = delta;
+ Mem_Base[*Area] = (MAKE_OBJECT (TC_STACK_ENVIRONMENT, delta));
+ *Area += 1;
+ }
+ break;
\f
case TC_FIXNUM:
NIntegers += 1;
{
long kind;
- kind = OBJECT_DATUM (This);
+ kind = (OBJECT_DATUM (This));
if (upgrade_traps_p)
{
*Area += 1;
break;
}
- fprintf(stderr,
- "%s: Bad old unassigned object. 0x%x.\n",
- program_name, This);
- quit(1);
+ fprintf (stderr,
+ "%s: Bad old unassigned object. 0x%x.\n",
+ program_name, This);
+ quit (1);
}
if (kind <= TRAP_MAX_IMMEDIATE)
{
\f
case TC_WEAK_CONS:
case_Pair:
- Do_Pointer(*Area, Do_Pair);
+ DO_POINTER (*Area, DO_PAIR);
+ break;
case_Cell:
- Do_Pointer(*Area, Do_Cell);
+ DO_POINTER (*Area, DO_CELL);
+ break;
case TC_VARIABLE:
case_Triple:
- Do_Pointer(*Area, Do_Triple);
+ DO_POINTER (*Area, DO_TRIPLE);
+ break;
+
+ case_Quadruple:
+ DO_POINTER (*Area, DO_QUAD);
+ break;
case TC_BIG_FLONUM:
- Do_Pointer(*Area, Do_Flonum);
+ DO_POINTER (*Area, DO_FLONUM);
+ break;
case TC_BIG_FIXNUM:
- Do_Pointer(*Area, Do_Bignum);
+ DO_POINTER (*Area, DO_BIGNUM);
+ break;
case TC_CHARACTER_STRING:
- Do_Pointer(*Area, Do_String);
+ DO_POINTER (*Area, DO_STRING);
+ break;
case TC_ENVIRONMENT:
if (upgrade_traps_p)
{
- fprintf(stderr,
- "%s: Cannot upgrade environments.\n",
- program_name);
- quit(1);
+ fprintf (stderr,
+ "%s: Cannot upgrade environments.\n",
+ program_name);
+ quit (1);
}
/* Fall through */
case TC_FUTURE:
case_simple_Vector:
if (BIT_STRING_P (This))
- {
- Do_Pointer(*Area, Do_Bit_String);
- }
+ DO_POINTER (*Area, DO_BIT_STRING);
else
- {
- Do_Pointer(*Area, Do_Vector);
- }
+ DO_POINTER (*Area, DO_VECTOR);
+ break;
default:
Bad_Type:
- fprintf(stderr, "%s: Unknown Type Code 0x%x found.\n",
- program_name, OBJECT_TYPE (This));
- quit(1);
+ fprintf (stderr, "%s: Unknown Type Code 0x%x found.\n",
+ program_name, (OBJECT_TYPE (This)));
+ quit (1);
}
}
}
\f
/* Output procedures */
-void
-DEFUN (print_external_objects, (from, count),
- fast SCHEME_OBJECT *from AND
- fast long count)
+static void
+DEFUN (print_binary_objects, (from, count),
+ fast SCHEME_OBJECT * from AND fast long count)
{
while (--count >= 0)
{
- switch(OBJECT_TYPE (*from))
+ switch (OBJECT_TYPE (* from))
{
case TC_FIXNUM:
print_a_fixnum (FIXNUM_TO_LONG (*from));
break;
case TC_BIG_FLONUM:
- print_a_flonum (*((double *) (from + 1)));
+ print_a_flonum (from + 1);
from += (1 + float_to_pointer);
break;
#endif /* FLOATING_ALIGNMENT */
default:
- fprintf(stderr,
- "%s: Bad Object to print externally %lx\n",
- program_name, *from);
- quit(1);
+ fprintf (stderr,
+ "%s: Bad Binary Object to print %lx\n",
+ program_name, *from);
+ quit (1);
}
}
return;
}
\f
-void
+static void
+DEFUN (print_c_compiled_entries, (entry, count),
+ SCHEME_OBJECT * entry AND unsigned long count)
+{
+ while (count > 0)
+ {
+ unsigned long entry_index = (* ((unsigned long *) entry));
+ unsigned long format = (COMPILED_ENTRY_FORMAT_WORD (entry));
+ SCHEME_OBJECT * block;
+
+ Get_Compiled_Block (block, entry);
+ fprintf (portable_file, "%02x %lx %ld %ld %lx\n",
+ TC_C_COMPILED_TAG,
+ ((long) C_COMPILED_ENTRY_FORMAT),
+ ((long) (FORMAT_WORD_LOW_BYTE (format))),
+ ((long) (FORMAT_WORD_HIGH_BYTE (format))),
+ ((long) (entry - block)));
+ fprintf (portable_file, "%02x %lx %lx\n",
+ TC_C_COMPILED_TAG,
+ ((long) C_COMPILED_ENTRY_CODE),
+ entry_index);
+ count -= 1;
+ entry += 2;
+ }
+ return;
+}
+
+static void
+DEFUN (print_c_closure_entries, (entry, count),
+ SCHEME_OBJECT * entry AND unsigned long count)
+{
+ while (count > 0)
+ {
+ unsigned long entry_index = (* ((unsigned long *) entry));
+ unsigned long format = (COMPILED_ENTRY_FORMAT_WORD (entry));
+ SCHEME_OBJECT * block, base;
+ unsigned long entry_number;
+ long offset;
+
+ EXTRACT_CLOSURE_ENTRY_ADDRESS (entry_number, entry);
+ offset = (UNSIGNED_FIXNUM_TO_LONG
+ (compiled_entry_table [entry_number]));
+ base = compiled_entry_table[entry_number + 1];
+
+ Get_Compiled_Block (block, entry);
+ fprintf (portable_file, "%02x %lx %ld %ld %lx\n",
+ TC_C_COMPILED_TAG,
+ ((long) C_COMPILED_ENTRY_FORMAT),
+ ((long) (FORMAT_WORD_LOW_BYTE (format))),
+ ((long) (FORMAT_WORD_HIGH_BYTE (format))),
+ ((long) (entry - block)));
+ fprintf (portable_file, "%02x %lx %lx\n",
+ TC_C_COMPILED_TAG,
+ ((long) C_COMPILED_ENTRY_CODE),
+ entry_index);
+ fprintf (portable_file, "%02x %lx %lx %lx\n",
+ TC_C_COMPILED_TAG,
+ ((long) C_COMPILED_EXECUTE_ENTRY),
+ offset,
+ (OBJECT_DATUM (base)));
+ count -= 1;
+ entry += 3;
+ }
+ return;
+}
+\f
+static void
DEFUN (print_objects, (from, to),
- fast SCHEME_OBJECT *from AND
- fast SCHEME_OBJECT *to)
+ fast SCHEME_OBJECT * from AND fast SCHEME_OBJECT * to)
{
fast long the_datum, the_type;
- while(from < to)
+ while (from < to)
{
-
- the_type = OBJECT_TYPE (*from);
- the_datum = OBJECT_DATUM (*from);
+ the_type = (OBJECT_TYPE (* from));
+ the_datum = (OBJECT_DATUM (* from));
from += 1;
- if (the_type == TC_MANIFEST_NM_VECTOR)
+ switch (the_type)
{
- fprintf(portable_file, "%02x %lx\n", the_type, the_datum);
- while (--the_datum >= 0)
+ case TC_MANIFEST_NM_VECTOR:
{
- fprintf(portable_file, "%lx\n", ((unsigned long) *from++));
+ fprintf (portable_file, "%02x %lx\n", the_type, the_datum);
+ while (--the_datum >= 0)
+ fprintf (portable_file, "%lx\n", ((unsigned long) *from++));
+ break;
}
- }
- else if (the_type == TC_COMPILED_ENTRY)
- {
- SCHEME_OBJECT base;
- long offset;
- offset = (FIXNUM_TO_LONG (compiled_entry_table [the_datum]));
- base = compiled_entry_table[the_datum + 1];
+ case TC_COMPILED_ENTRY:
+ {
+ SCHEME_OBJECT base;
+ long offset;
- fprintf(portable_file, "%02x %lx %02x %lx\n",
- TC_COMPILED_ENTRY, offset,
- OBJECT_TYPE (base), OBJECT_DATUM (base));
- }
- else
- {
- fprintf(portable_file, "%02x %lx\n", the_type, the_datum);
+ offset = (UNSIGNED_FIXNUM_TO_LONG (compiled_entry_table [the_datum]));
+ base = compiled_entry_table[the_datum + 1];
+
+ fprintf (portable_file, "%02x %lx %02x %lx\n",
+ TC_COMPILED_ENTRY, offset,
+ (OBJECT_TYPE (base)), (OBJECT_DATUM (base)));
+ break;
+ }
+\f
+ case TC_LINKAGE_SECTION:
+ {
+ SCHEME_OBJECT header = (from[-1]);
+
+ switch (READ_LINKAGE_KIND (header))
+ {
+ case REFERENCE_LINKAGE_KIND:
+ case ASSIGNMENT_LINKAGE_KIND:
+ {
+ long count = (READ_CACHE_LINKAGE_COUNT (header));
+
+ fprintf (portable_file, "%02x %lx %lx %lx\n",
+ TC_C_COMPILED_TAG,
+ ((long) C_COMPILED_LINKAGE_HEADER),
+ ((long) (READ_LINKAGE_KIND (header))),
+ ((long) count));
+ while (--count >= 0)
+ {
+ unsigned long quad = ((unsigned long) *from++);
+
+ fprintf (portable_file, "%02x %lx %lx\n",
+ TC_C_COMPILED_TAG,
+ ((long) C_COMPILED_RAW_QUAD),
+ quad);
+ }
+ break;
+ }
+
+ case OPERATOR_LINKAGE_KIND:
+ case GLOBAL_OPERATOR_LINKAGE_KIND:
+ {
+ char * word_ptr;
+ long count, address;
+ SCHEME_OBJECT This, * area_end, * scan, * i_scan;
+
+ i_scan = (from - 1);
+ This = *i_scan;
+ START_OPERATOR_RELOCATION (i_scan);
+ count = (READ_OPERATOR_LINKAGE_COUNT (This));
+ word_ptr = (FIRST_OPERATOR_LINKAGE_ENTRY (i_scan));
+ area_end = (END_OPERATOR_LINKAGE_AREA (i_scan, count));
+
+ fprintf (portable_file, "%02x %lx %lx %lx\n",
+ TC_C_COMPILED_TAG,
+ ((long) C_COMPILED_LINKAGE_HEADER),
+ ((long) (READ_LINKAGE_KIND (header))),
+ ((long) count));
+
+ while (--count >= 0)
+ {
+ SCHEME_OBJECT base;
+ long arity, address, offset;
+
+ scan = ((SCHEME_OBJECT *) word_ptr);
+ word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr));
+ EXTRACT_OPERATOR_LINKAGE_ADDRESS (address, scan);
+ EXTRACT_EXECUTE_CACHE_ARITY (arity, scan);
+
+ offset = (UNSIGNED_FIXNUM_TO_LONG
+ (compiled_entry_table[address]));
+ base = compiled_entry_table[address + 1];
+
+ fprintf (portable_file, "%02x %lx %lx %lx\n",
+ TC_C_COMPILED_TAG,
+ ((long) C_COMPILED_EXECUTE_ENTRY),
+ offset,
+ (OBJECT_DATUM (base)));
+ fprintf (portable_file, "%02x %lx %lx\n",
+ TC_C_COMPILED_TAG,
+ ((long) C_COMPILED_EXECUTE_ARITY),
+ arity);
+ }
+ END_OPERATOR_RELOCATION (area_end);
+ from += (area_end - i_scan);
+ break;
+ }
+
+ default:
+ {
+ fprintf (stderr, "%s: Unknown linkage kind.\n",
+ program_name);
+ quit (1);
+ }
+ }
+ break;
+ }
+\f
+ case TC_MANIFEST_CLOSURE:
+ {
+ unsigned long nentries;
+ SCHEME_OBJECT * entry, * area_end;
+
+ fprintf (portable_file, "%02x %lx %lx\n",
+ TC_C_COMPILED_TAG,
+ ((long) C_COMPILED_CLOSURE_HEADER),
+ the_datum);
+
+ nentries = (MANIFEST_CLOSURE_COUNT (from));
+ entry = ((SCHEME_OBJECT *) (FIRST_MANIFEST_CLOSURE_ENTRY (from)));
+ area_end = (MANIFEST_CLOSURE_END (from, nentries));
+
+ if (entry != (from + 1))
+ fprintf (portable_file, "%02x %lx %lx\n",
+ TC_C_COMPILED_TAG,
+ ((long) C_COMPILED_MULTI_CLOSURE_HEADER),
+ nentries);
+
+ print_c_closure_entries (entry, nentries);
+ from = (area_end + 1);
+ break;
+ }
+
+ case TC_BROKEN_HEART:
+ if (the_datum == 0)
+ goto ordinary_object;
+ /* An NMV header fending off C-compiled code descriptors.
+ This knows in detail the format
+ */
+
+ {
+ unsigned long nmv_length;
+ SCHEME_OBJECT * entry;
+
+ nmv_length = (OBJECT_DATUM (compiled_block_table [the_datum + 1]));
+ fprintf (portable_file, "%02x %lx %lx\n",
+ TC_C_COMPILED_TAG,
+ ((long) C_COMPILED_FAKE_NMV),
+ nmv_length);
+
+ print_c_compiled_entries (from + 1, (nmv_length / 2));
+ from += nmv_length;
+ break;
+ }
+
+ default:
+ ordinary_object:
+ {
+ fprintf (portable_file, "%02x %lx\n", the_type, the_datum);
+ break;
+ }
}
}
return;
\f
/* Debugging Aids and Consistency Checks */
-#ifdef DEBUG
+#define DEBUG 0
-#define DEBUGGING(action) action
+#if (DEBUG > 0)
#define WHEN(condition, message) when(condition, message)
-void
-DEFUN (when, (what, message),
- Boolean what AND
- char *message)
+static void
+DEFUN (when, (what, message), Boolean what AND char * message)
{
if (what)
{
- fprintf(stderr, "%s: Inconsistency: %s!\n",
- program_name, (message));
- quit(1);
+ fprintf (stderr, "%s: Inconsistency: %s!\n",
+ program_name, (message));
+ quit (1);
}
return;
}
-#define WRITE_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 /* DEBUG <= 0 */
-#else /* not DEBUG */
+#define WHEN(what, message) do { } while (0)
-#define DEBUGGING(action)
+#endif /* DEBUG > 0 */
-#define WHEN(what, message)
+#if (DEBUG > 1)
-#define WRITE_HEADER(name, format, obj) \
+#define DEBUGGING1(action) action
+
+#define WRITE_HEADER(name, format, obj) do \
{ \
- 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"); \
+} while (0)
-#endif /* DEBUG */
+#else /* DEBUG <= 1 */
+
+#define DEBUGGING1(action) do { } while (0)
+
+#define WRITE_HEADER(name, format, obj) do \
+{ \
+ fprintf (portable_file, (format), (obj)); \
+ fprintf (portable_file, "\n"); \
+} while (0)
+
+#endif /* DEBUG > 1 */
\f
/* The main program */
-void
+static void
DEFUN_VOID (do_it)
{
while (true)
* Heap,
* Lowest_Allocated_Address,
* Highest_Allocated_Address;
- long Initial_Free;
+ long
+ Heap_Start, Heap_Objects_Start,
+ Constant_Start, Constant_Objects_Start,
+ Pure_Start, Pure_Objects_Start;
switch (Read_Header ())
{
/* NOTREACHED */
}
- if ((Version > FASL_READ_VERSION) ||
- (Version < FASL_OLDEST_VERSION) ||
- (Sub_Version > FASL_READ_SUBVERSION) ||
- (Sub_Version < FASL_OLDEST_SUBVERSION) ||
- ((Machine_Type != FASL_INTERNAL_FORMAT) &&
- (!swap_bytes_p)))
+ if ( (Version > FASL_FORMAT_VERSION)
+ || (Version < FASL_OLDEST_VERSION)
+ || (Sub_Version > FASL_SUBVERSION)
+ || (Sub_Version < FASL_OLDEST_SUBVERSION)
+ || ((Machine_Type != FASL_INTERNAL_FORMAT) && (! swap_bytes_p)))
{
fprintf (stderr, "%s:\n", program_name);
fprintf (stderr,
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))
+ if ((((compiler_processor_type != COMPILER_NONE_TYPE)
+ && (dumped_processor_type != COMPILER_NONE_TYPE)
+ && (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,
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 and bands not currently supported */
+ c_compiled_p = (compiler_processor_type == COMPILER_LOSING_C_TYPE);
+ DEBUGGING1 (fprintf (stderr,
+ "compiler_processor_type = %d; c_compiled_p = %s\n",
+ compiler_processor_type,
+ (c_compiled_p ? "true" : "false")));
- if (band_p)
+ if (band_p && (! allow_bands_p))
{
fprintf (stderr, "%s: Input file is a band.\n", program_name);
quit (1);
}
- if (Const_Count != 0)
+ if ((Const_Count != 0) && (! allow_constant_space_p))
{
fprintf (stderr,
"%s: Input file has a constant space area.\n",
\f
shuffle_bytes_p = swap_bytes_p;
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;
- DEBUGGING (fprintf (stderr,
- "Dumped Heap Base = 0x%08x\n",
- Heap_Base));
+ DEBUGGING1 (fprintf (stderr,
+ "Dumped Heap Base = 0x%08x\n",
+ Heap_Base));
- DEBUGGING (fprintf (stderr,
- "Dumped Constant Base = 0x%08x\n",
- Const_Base));
+ DEBUGGING1 (fprintf (stderr,
+ "Dumped Constant Base = 0x%08x\n",
+ Const_Base));
- DEBUGGING (fprintf (stderr,
- "Dumped Constant Top = 0x%08x\n",
- Dumped_Constant_Top));
+ DEBUGGING1 (fprintf (stderr,
+ "Dumped Constant Top = 0x%08x\n",
+ Dumped_Constant_Top));
- DEBUGGING (fprintf (stderr,
- "Heap Count = %6d\n",
- Heap_Count));
+ DEBUGGING1 (fprintf (stderr,
+ "Heap Count = %6d\n",
+ Heap_Count));
- DEBUGGING (fprintf (stderr,
- "Constant Count = %6d\n",
- Const_Count));
+ DEBUGGING1 (fprintf (stderr,
+ "Constant Count = %6d\n",
+ Const_Count));
\f
{
long Size;
/* This is way larger than needed, but... what the hell? */
- Size = ((TRAP_MAX_IMMEDIATE + 1) +
- ((FLOATING_ALIGNMENT + 1) / (sizeof (SCHEME_OBJECT))) +
- (3 * (Heap_Count + Const_Count)) +
- (NROOTS + 1) +
- (upgrade_primitives_p ?
- (3 * PRIMITIVE_UPGRADE_SPACE) :
- Primitive_Table_Size) +
- (allow_compiled_p ?
- (2 * (Heap_Count + Const_Count)) :
- 0));
+ Size = ((2 * (TRAP_MAX_IMMEDIATE + 1))
+ + (2 * ((FLOATING_ALIGNMENT + 1) / (sizeof (SCHEME_OBJECT))))
+ + (Heap_Count + Const_Count)
+ + (2 * (Heap_Count + (2 * Const_Count)))
+ + (NROOTS + 1)
+ + (upgrade_primitives_p
+ ? (3 * PRIMITIVE_UPGRADE_SPACE)
+ : Primitive_Table_Size) +
+ (allow_compiled_p
+ ? (2 + ((c_compiled_p ? 4 : 2) * (Heap_Count + Const_Count)))
+ : 0)
+ + C_Code_Table_Size);
ALLOCATE_HEAP_SPACE (Size,
Lowest_Allocated_Address,
program_name);
quit (1);
}
- if ((Load_Data (Const_Count, (Heap + Heap_Count))) != Const_Count)
+ Constant_Space = (Heap + Heap_Count);
+ ALIGN_FLOAT (Constant_Space);
+ if ((Load_Data (Const_Count, Constant_Space)) != Const_Count)
{
fprintf (stderr, "%s: Could not load constant space.\n",
program_name);
quit (1);
}
+ Constant_Top = (find_constant_top (Constant_Space, Const_Count));
Heap_Relocation = ((&Heap[0]) - (OBJECT_ADDRESS (Heap_Base)));
- Constant_Relocation = ((&Heap[Heap_Count]) -
+ Constant_Relocation = ((&Constant_Space[0]) -
(OBJECT_ADDRESS (Const_Base)));
+ Max_Stack_Offset = 0;
\f
/* Setup compiled code and primitive tables. */
- compiled_entry_table = &Heap[Heap_Count + Const_Count];
+ compiled_entry_table = &Constant_Space[Const_Count];
compiled_entry_pointer = compiled_entry_table;
- compiled_entry_table_end = compiled_entry_table;
-
+ compiled_entry_table_end = compiled_entry_pointer;
if (allow_compiled_p)
compiled_entry_table_end += (2 * (Heap_Count + Const_Count));
- primitive_table = compiled_entry_table_end;
+ compiled_block_table = compiled_entry_table_end;
+ compiled_block_pointer = &compiled_block_table[2];
+ compiled_block_table_end = compiled_block_pointer;
+ if (allow_compiled_p && c_compiled_p)
+ compiled_block_table_end += (2 *(Heap_Count + Const_Count));
+
+ primitive_table = compiled_block_table_end;
if (upgrade_primitives_p)
primitive_table_end = (setup_primitive_upgrade (primitive_table));
else
{
- fast SCHEME_OBJECT *table;
+ fast SCHEME_OBJECT * table;
fast long count, char_count;
- if ((Load_Data (Primitive_Table_Size, primitive_table)) !=
- Primitive_Table_Size)
+ if ((Load_Data (Primitive_Table_Size, primitive_table))
+ != Primitive_Table_Size)
{
fprintf (stderr, "%s: Could not load the primitive table.\n",
program_name);
NPChars = char_count;
primitive_table_end = (&primitive_table[Primitive_Table_Size]);
}
- Mem_Base = primitive_table_end;
+
+ c_code_table = primitive_table_end;
+ c_code_table_end = &c_code_table[C_Code_Table_Size];
+ if (C_Code_Table_Size != 0)
+ {
+ fast SCHEME_OBJECT * table;
+ fast long count, char_count;
+
+ if ((Load_Data (C_Code_Table_Size, c_code_table)) != C_Code_Table_Size)
+ {
+ fprintf (stderr, "%s: Could not load the C code table.\n",
+ program_name);
+ quit (1);
+ }
+ for (char_count = 0,
+ count = C_Code_Table_Length,
+ table = &c_code_table[1];
+ --count >= 0; )
+ {
+ long slen;
+
+ slen = (strlen ((char *) (table + 1)));
+ table += (1 + (BYTES_TO_WORDS (1 + slen)));
+ char_count += slen;
+ }
+ NCChars = char_count;
+ }
+
+ Mem_Base = c_code_table_end;
\f
/* Reformat the data */
NFlonums = NIntegers = NStrings = 0;
NBits = NBBits = NChars = 0;
- Mem_Base[0] = (OBJECT_NEW_TYPE (TC_CELL, Dumped_Object));
- Initial_Free = NROOTS;
- Scan = 0;
-
- Free = Initial_Free;
- Free_Objects = &Mem_Base[Heap_Count + Initial_Free];
+ Heap_Start = (NROOTS + (TRAP_MAX_IMMEDIATE + 1));
+ Heap_Objects_Start = (Heap_Start + Heap_Count);
+ Mem_Base[(Heap_Start - NROOTS) + 0]
+ = dumped_utilities;
+ Mem_Base[(Heap_Start - NROOTS) + 1]
+ = (OBJECT_NEW_TYPE (TC_CELL, Dumped_Object));
+ Scan = (Heap_Start - NROOTS);
+ Free = Heap_Start;
+ Free_Objects = &Mem_Base[Heap_Objects_Start];
Objects = 0;
- Free_Constant = (2 * Heap_Count) + Initial_Free;
- Scan_Constant = Free_Constant;
- Free_Cobjects = &Mem_Base[Const_Count + Free_Constant];
+ Constant_Start = (Heap_Objects_Start + Heap_Count);
+ Constant_Objects_Start = (Constant_Start + Const_Count);
+ Scan_Constant = Constant_Start;
+ Free_Constant = Constant_Start;
+ Free_Cobjects = &Mem_Base[Constant_Objects_Start];
Constant_Objects = 0;
-#if TRUE
+ Pure_Start = (Constant_Objects_Start + Const_Count);
+ Pure_Objects_Start = (Pure_Start + Const_Count);
+ Scan_Pure = Pure_Start;
+ Free_Pure = Pure_Start;
+ Free_Pobjects = &Mem_Base[Pure_Objects_Start];
+ Pure_Objects = 0;
- Do_Area (HEAP_CODE, Scan, Free, Objects, Free_Objects);
-
-#else
-
- /*
- When Constant Space finally becomes supported,
- something like this must be done.
- */
-
- while (true)
- {
- Do_Area (HEAP_CODE, Scan, Free,
- Objects, Free_Objects);
- Do_Area (CONSTANT_CODE, Scan_Constant, Free_Constant,
- Constant_Objects, Free_Cobjects);
- Do_Area (PURE_CODE, Scan_Pure, Free_Pure,
- Pure_Objects, Free_Pobjects);
- if (Scan == Free)
+ if (Const_Count == 0)
+ DO_AREA (HEAP_CODE, Scan, Free, Objects, Free_Objects);
+ else
+ while ((Scan != Free)
+ || (Scan_Constant != Free_Constant)
+ || (Scan_Pure != Free_Pure))
{
- break;
+ DO_AREA (HEAP_CODE, Scan, Free,
+ Objects, Free_Objects);
+ DO_AREA (CONSTANT_CODE, Scan_Constant, Free_Constant,
+ Constant_Objects, Free_Cobjects);
+ DO_AREA (PURE_CODE, Scan_Pure, Free_Pure,
+ Pure_Objects, Free_Pobjects);
}
- }
-#endif
-\f
/* Consistency checks */
- WHEN (((Free - Initial_Free) > Heap_Count), "Free overran Heap");
+ WHEN (((Free - Heap_Start) > Heap_Count), "Free overran Heap");
- WHEN (((Free_Objects - &Mem_Base[Initial_Free + Heap_Count]) >
- Heap_Count),
+ WHEN (((Free_Objects - &Mem_Base[Heap_Objects_Start])
+ > Heap_Count),
"Free_Objects overran Heap Object Space");
- WHEN (((Free_Constant - (Initial_Free + (2 * Heap_Count))) > Const_Count),
+ WHEN (((Free_Constant - Constant_Start) > Const_Count),
"Free_Constant overran Constant Space");
- WHEN (((Free_Cobjects - &Mem_Base[Initial_Free +
- (2 * Heap_Count) + Const_Count]) >
- Const_Count),
+ WHEN (((Free_Cobjects - &Mem_Base[Constant_Objects_Start])
+ > Const_Count),
"Free_Cobjects overran Constant Object Space");
+
+ WHEN (((Free_Pure - Pure_Start) > Const_Count),
+ "Free_Pure overran Pure Space");
+
+ WHEN (((Free_Cobjects - &Mem_Base[Pure_Objects_Start])
+ > Const_Count),
+ "Free_Cobjects overran Pure Object Space");
\f
/* Output the data */
WRITE_HEADER ("Sub Version", "%ld", FASL_SUBVERSION);
WRITE_HEADER ("Flags", "%ld", (MAKE_FLAGS ()));
- WRITE_HEADER ("Heap Count", "%ld", (Free - NROOTS));
- WRITE_HEADER ("Heap Base", "%ld", NROOTS);
+ WRITE_HEADER ("Heap Count", "%ld", (Free - Heap_Start));
+ WRITE_HEADER ("Heap Base", "%ld", Heap_Start);
WRITE_HEADER ("Heap Objects", "%ld", Objects);
- /* Currently Constant and Pure not supported, but the header is ready */
-
- WRITE_HEADER ("Pure Count", "%ld", 0);
- WRITE_HEADER ("Pure Base", "%ld", Free_Constant);
- WRITE_HEADER ("Pure Objects", "%ld", 0);
+ WRITE_HEADER ("Constant Count", "%ld", (Free_Constant - Constant_Start));
+ WRITE_HEADER ("Constant Base", "%ld", Constant_Start);
+ WRITE_HEADER ("Constant Objects", "%ld", Constant_Objects);
- WRITE_HEADER ("Constant Count", "%ld", 0);
- WRITE_HEADER ("Constant Base", "%ld", Free_Constant);
- WRITE_HEADER ("Constant Objects", "%ld", 0);
+ WRITE_HEADER ("Pure Count", "%ld", (Free_Pure - Pure_Start));
+ WRITE_HEADER ("Pure Base", "%ld", Pure_Start);
+ WRITE_HEADER ("Pure Objects", "%ld", Pure_Objects);
- WRITE_HEADER ("& Dumped Object", "%ld", (OBJECT_DATUM (Mem_Base[0])));
+ WRITE_HEADER ("& Dumped Object", "%ld",
+ (OBJECT_DATUM (Mem_Base[(TRAP_MAX_IMMEDIATE + 1) + 1])));
+ WRITE_HEADER ("Maximum Stack Offset", "%ld", Max_Stack_Offset);
WRITE_HEADER ("Number of flonums", "%ld", NFlonums);
WRITE_HEADER ("Number of integers", "%ld", NIntegers);
WRITE_HEADER ("Number of primitives", "%ld", Primitive_Table_Length);
WRITE_HEADER ("Number of characters in primitives", "%ld", NPChars);
- if (!compiled_p)
+ if (! compiled_p)
{
dumped_processor_type = 0;
dumped_interface_version = 0;
WRITE_HEADER ("CPU type", "%ld", dumped_processor_type);
WRITE_HEADER ("Compiled code interface version", "%ld",
dumped_interface_version);
-#if FALSE
- WRITE_HEADER ("Compiler utilities vector", "%ld",
- (OBJECT_DATUM (dumped_utilities)));
-#endif
-\f
- /* External Objects */
-
- print_external_objects (&Mem_Base[Initial_Free + Heap_Count],
- Objects);
-
-#if FALSE
-
- print_external_objects (&Mem_Base[Pure_Objects_Start],
- Pure_Objects);
- print_external_objects (&Mem_Base[Constant_Objects_Start],
- Constant_Objects);
+ if (allow_bands_p)
+ WRITE_HEADER ("Compiler utilities vector", "%ld",
+ (OBJECT_DATUM (Mem_Base[(TRAP_MAX_IMMEDIATE + 1) + 0])));
+ else
+ WRITE_HEADER ("Compiler utilities vector", "%ld", 0);
-#endif
+ WRITE_HEADER ("Number of C code blocks", "%ld", C_Code_Table_Length);
+ WRITE_HEADER ("Number of characters in C code blocks", "%ld", NCChars);
+ WRITE_HEADER ("Number of reserved C entries", "%ld",
+ (OBJECT_DATUM (c_code_table[0])));
- /* Pointer Objects */
+ /* Binary Objects */
- print_objects (&Mem_Base[NROOTS], &Mem_Base[Free]);
+ print_binary_objects (&Mem_Base[Pure_Objects_Start], Pure_Objects);
+ print_binary_objects (&Mem_Base[Constant_Objects_Start], Constant_Objects);
+ print_binary_objects (&Mem_Base[Heap_Objects_Start], Objects);
+\f
+ /* Normal Objects: pointers, simple non-pointers (e.g. SHARP_F) */
-#if FALSE
print_objects (&Mem_Base[Pure_Start], &Mem_Base[Free_Pure]);
print_objects (&Mem_Base[Constant_Start], &Mem_Base[Free_Constant]);
-#endif
-\f
+ print_objects (&Mem_Base[Heap_Start], &Mem_Base[Free]);
+
/* Primitives */
if (upgrade_primitives_p)
}
else
{
- fast SCHEME_OBJECT *table;
- fast long count;
- long arity;
+ long count;
+ SCHEME_OBJECT * table = primitive_table;
- for (count = Primitive_Table_Length, table = primitive_table;
- --count >= 0;)
+ for (count = Primitive_Table_Length; --count >= 0; )
{
- arity = (FIXNUM_TO_LONG (*table));
+ long arity = (FIXNUM_TO_LONG (* table));
table += 1;
- print_a_primitive (arity,
- (STRING_LENGTH_TO_LONG(table[STRING_LENGTH_INDEX])),
- ((char *) &table[STRING_CHARS]));
- table += (1 + OBJECT_DATUM (table[STRING_HEADER]));
+ print_a_primitive
+ (arity,
+ (STRING_LENGTH_TO_LONG (table[STRING_LENGTH_INDEX])),
+ ((char *) &table[STRING_CHARS]));
+ table += (1 + (OBJECT_DATUM (table[STRING_HEADER])));
}
}
+\f
+ /* C Code block information */
+
+ {
+ long count;
+ SCHEME_OBJECT * table = &c_code_table[1];
+
+ for (count = C_Code_Table_Length; --count >= 0; )
+ {
+ char * name;
+ long nentries, namelen;
+
+ nentries = (FIXNUM_TO_LONG (* table));
+ name = ((char *) (table + 1));
+ namelen = (strlen (name));
+ print_a_c_code_block (nentries, namelen, name);
+ table += (1 + (BYTES_TO_WORDS (namelen + 1)));
+ }
+ }
+
fflush (portable_file);
free ((char *) Lowest_Allocated_Address);
}
}
-\f
+
/* Top Level */
static Boolean
+ allow_constant_sup_p,
+ ci_version_sup_p,
+ ci_processor_sup_p,
help_p = false,
help_sup_p,
- ci_version_sup_p,
- ci_processor_sup_p;
+ warn_portable_sup_p;
/* The boolean value here is what value to store when the option is present. */
&ci_version_sup_p),
KEYWORD ("ci_processor", &compiler_processor_type, INT_KYWRD, "%ld",
&ci_processor_sup_p),
- KEYWORD ("vax_invert", &vax_invert_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD ("endian_invert", &endian_invert_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD ("allow_bands", &allow_bands_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD ("allow_constant_space", &allow_constant_space_p,
+ BOOLEAN_KYWRD, BFRMT, &allow_constant_sup_p),
+ KEYWORD ("warn_portable", &warn_portable_p, BOOLEAN_KYWRD, BFRMT,
+ &warn_portable_sup_p),
KEYWORD ("help", &help_p, BOOLEAN_KYWRD, BFRMT, &help_sup_p),
OUTPUT_KEYWORD (),
INPUT_KEYWORD (),
END_KEYWORD ()
};
-
+\f
void
-DEFUN (main, (argc, argv),
- int argc AND
- char **argv)
+DEFUN (main, (argc, argv), int argc AND char **argv)
{
parse_keywords (argc, argv, options, false);
upgrade_compiled_p =
(upgrade_compiled_p || ci_version_sup_p || ci_processor_sup_p);
- allow_compiled_p = (allow_compiled_p || upgrade_compiled_p);
- allow_nmv_p = (allow_nmv_p || allow_compiled_p || vax_invert_p);
+ allow_compiled_p = (allow_compiled_p || upgrade_compiled_p
+ || c_compiled_p || allow_bands_p);
+ allow_nmv_p = (allow_nmv_p || allow_compiled_p || endian_invert_p);
if (null_nmv_p && allow_nmv_p)
{
fprintf (stderr,
program_name);
quit (1);
}
+ if (allow_bands_p && warn_portable_p && (! warn_portable_sup_p))
+ warn_portable_p = false;
+ if (allow_bands_p && (! allow_constant_space_p) && (! allow_constant_sup_p))
+ allow_constant_space_p = true;
setup_io ("rb", "w");
do_it ();
/* -*-C-*-
-$Id: psbmap.h,v 9.39 1993/06/24 06:15:32 gjr Exp $
+$Id: psbmap.h,v 9.40 1993/11/07 01:39:01 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* This file contains macros and declarations for "Bintopsb.c"
- and "Psbtobin.c". */
-\f
+/* This file contains macros and declarations for "bintopsb.c"
+ and "psbtobin.c".
+ */
+
#ifndef PSBMAP_H_INCLUDED
#define PSBMAP_H_INCLUDED
from the included files.
*/
+#define WINNT_RAW_ADDRESSES
#define fast register
#include <stdio.h>
#include "sdata.h"
#include "const.h"
#include "gccode.h"
+#include "cmptype.h"
#define boolean Boolean
#include "comlin.h"
+#ifndef COMPILER_PROCESSOR_TYPE
+#define COMPILER_PROCESSOR_TYPE COMPILER_NONE_TYPE
+#endif
+\f
extern double
EXFUN (frexp, (double, int *)),
EXFUN (ldexp, (double, int));
-#define PORTABLE_VERSION 5
+#define PORTABLE_VERSION 6
/* Number of objects which, when traced recursively, point at all other
- objects dumped. Currently only the dumped object.
+ objects dumped.
+ Currently the dumped object, and the compiler utilities.
*/
-#define NROOTS 1
+#define NROOTS 2
/* Types to recognize external object references. Any occurrence of these
(which are external types and thus handled separately) means a reference
#define CONSTANT_CODE TC_FIXNUM
#define HEAP_CODE TC_CHARACTER
+#define PURE_CODE TC_BIG_FIXNUM
#define fixnum_to_bits FIXNUM_LENGTH
#define hex_digits(nbits) (((nbits) + 3) / 4)
#define COMPILED_P (1 << 2)
#define NMV_P (1 << 3)
#define BAND_P (1 << 4)
+#define C_CODE_P (1 << 5)
#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) | \
- (band_p ? BAND_P : 0))
-
-#define READ_FLAGS(f) \
+( (compact_p ? COMPACT_P : 0) \
+ | (null_nmv_p ? NULL_NMV_P : 0) \
+ | (compiled_p ? COMPILED_P : 0) \
+ | (nmv_p ? NMV_P : 0) \
+ | (band_p ? BAND_P : 0) \
+ | (c_compiled_p ? C_CODE_P : 0))
+
+#define READ_FLAGS(f) do \
{ \
compact_p = ((f) & COMPACT_P); \
null_nmv_p = ((f) & NULL_NMV_P); \
compiled_p = ((f) & COMPILED_P); \
nmv_p = ((f) & NMV_P); \
band_p = ((f) & BAND_P); \
-}
+ c_compiled_p = ((f) & C_CODE_P); \
+} while (0)
/*
If true, make all integers fixnums if possible, and all strings as
static Boolean nmv_p = false;
+#define TC_C_COMPILED_TAG TC_MANIFEST_CLOSURE
+#define C_COMPILED_FAKE_NMV 0
+#define C_COMPILED_ENTRY_FORMAT 1
+#define C_COMPILED_ENTRY_CODE 2
+#define C_COMPILED_CLOSURE_HEADER 3
+#define C_COMPILED_MULTI_CLOSURE_HEADER 4
+#define C_COMPILED_LINKAGE_HEADER 5
+#define C_COMPILED_RAW_QUAD 6
+#define C_COMPILED_EXECUTE_ENTRY 7
+#define C_COMPILED_EXECUTE_ARITY 8
+
/* Global data */
#ifndef HEAP_IN_LOW_MEMORY
#endif
static long
- compiler_processor_type = 0,
+ compiler_processor_type = COMPILER_PROCESSOR_TYPE,
compiler_interface_version = 0;
static SCHEME_OBJECT
FILE *input_file, *output_file;
-Boolean
+static Boolean
DEFUN (strequal, (s1, s2), register char * s1 AND register char * s2)
{
for ( ; *s1 != '\0'; s1++, s2++)
- {
if (*s1 != *s2)
- {
return (false);
- }
- }
return (*s2 == '\0');
}
-\f
-void
+
+static void
DEFUN (setup_io, (input_mode, output_mode),
CONST char * input_mode AND CONST char * output_mode)
{
if (strequal (input_file_name, "-"))
- {
input_file = stdin;
- }
else
{
input_file = (fopen (input_file_name, input_mode));
}
if (strequal (output_file_name, "-"))
- {
output_file = stdout;
- }
else
{
output_file = (fopen (output_file_name, output_mode));
return;
}
-void
+static void
DEFUN (quit, (code), int code)
{
fclose(input_file);
#ifdef vms
/* This assumes that it is only invoked with 0 in tail recursive psn. */
if (code != 0)
- {
exit(code);
- }
else
- {
return;
- }
#else /* not vms */
exit(code);
#endif /*vms */
}
\f
+#ifndef TERM_COMPILER_DEATH
+#define TERM_COMPILER_DEATH 0
+#endif
+
+void
+DEFUN (gc_death, (code, message, scan, free),
+ long code
+ AND char * message
+ AND SCHEME_OBJECT * scan
+ AND SCHEME_OBJECT * free)
+{
+ fprintf (stderr, "%s: %s\n", program_name, message);
+ quit (1);
+}
+
/* Include the command line parser */
#include "comlin.c"
/* -*-C-*-
-$Id: psbtobin.c,v 9.50 1993/10/14 19:17:26 gjr Exp $
+$Id: psbtobin.c,v 9.51 1993/11/07 01:39:13 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
static Boolean
band_p = false,
allow_compiled_p = false,
- allow_nmv_p = false;
+ allow_nmv_p = false,
+ warn_portable_p = true,
+ c_compiled_p = false;
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;
+ Dumped_Object_Addr, Dumped_Compiler_Utilities,
+ Dumped_Heap_Base, Dumped_Heap_Limit, Heap_Objects, Heap_Count,
+ Dumped_Const_Base, Dumped_Const_Limit, Const_Objects, Const_Count,
+ Dumped_Pure_Base, Dumped_Pure_Limit, Pure_Objects, Pure_Count,
+ Primitive_Table_Length, Max_Stack_Offset,
+ C_Code_Table_Length, C_Code_Reserved_Entries;
static SCHEME_OBJECT
- *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;
+ * Heap, * Constant_Space, * Constant_Top, * Stack_Top,
+ * Heap_Base, * Heap_Table, * Heap_Object_Limit, * Free,
+ * Const_Base, * Const_Table, * Const_Object_Limit, * Free_Const,
+ * Pure_Base, * Pure_Table, * Pure_Object_Limit, * Free_Pure;
-long
+static long
DEFUN (Write_Data, (Count, From_Where),
long Count AND
SCHEME_OBJECT *From_Where)
#include "fasl.h"
#include "dump.c"
+
+#ifndef MAKE_FORMAT_WORD
+#define MAKE_FORMAT_WORD(h,l) 0
+#endif
+
+#ifndef WRITE_LABEL_DESCRIPTOR
+#define WRITE_LABEL_DESCRIPTOR(e,f,o) do { } while (0)
+#endif
+
+#ifndef MAKE_LINKAGE_SECTION_HEADER
+#define MAKE_LINKAGE_SECTION_HEADER(kind,count) 0
+#endif
\f
-void
+static void
DEFUN_VOID (inconsistency)
{
/* Provide some context (2 lines). */
#define OUT(c) return ((long) ((c) & UCHAR_MAX))
-long
+static long
DEFUN_VOID (read_a_char)
{
fast char C;
{
long Code;
- fprintf (stderr,
- "%s: File is not Portable. Character Code Found.\n",
- program_name);
+ if (warn_portable_p)
+ {
+ warn_portable_p = false;
+ fprintf (stderr,
+ "%s: File is not Portable. Character Code Found.\n",
+ program_name);
+ }
fscanf (portable_file, "%ld", &Code);
getc (portable_file); /* Space */
OUT (Code);
}
}
\f
-SCHEME_OBJECT *
+static SCHEME_OBJECT *
+DEFUN (read_a_char_pointer, (to), SCHEME_OBJECT * to)
+{
+ long len, maxlen;
+ char * str;
+
+ fscanf (portable_file, "%ld", &len);
+
+ maxlen = (len + 1); /* null terminated */
+ str = ((char *) to);
+ getc (portable_file); /* space */
+
+ while (--len >= 0)
+ *str++ = ((char) (read_a_char ()));
+ *str = '\0';
+ return (to + (BYTES_TO_WORDS (maxlen)));
+}
+
+static SCHEME_OBJECT *
DEFUN (read_a_string_internal, (To, maxlen),
- SCHEME_OBJECT *To AND
- long maxlen)
+ SCHEME_OBJECT * To AND long maxlen)
{
long ilen, Pointer_Count;
fast char *str;
len = ilen;
if (maxlen == -1)
- {
maxlen = len;
- }
/* Null terminated */
maxlen += 1;
- Pointer_Count = STRING_CHARS + (char_to_pointer (maxlen));
+ Pointer_Count = (STRING_CHARS + (char_to_pointer (maxlen)));
To[STRING_HEADER] =
(MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (Pointer_Count - 1)));
To[STRING_LENGTH_INDEX] = ((SCHEME_OBJECT) len);
getc (portable_file);
while (--len >= 0)
- {
- *str++ = ((char) read_a_char ());
- }
+ *str++ = ((char) (read_a_char ()));
*str = '\0';
return (To + Pointer_Count);
}
-SCHEME_OBJECT *
+static SCHEME_OBJECT *
DEFUN (read_a_string, (To, Slot),
- SCHEME_OBJECT *To AND
- SCHEME_OBJECT *Slot)
+ SCHEME_OBJECT * To AND SCHEME_OBJECT * Slot)
{
long maxlen;
#endif
\f
-SCHEME_OBJECT *
+static SCHEME_OBJECT *
DEFUN (read_an_integer, (The_Type, To, Slot),
- int The_Type AND
- SCHEME_OBJECT *To AND
- SCHEME_OBJECT *Slot)
+ int The_Type AND SCHEME_OBJECT * To AND SCHEME_OBJECT * Slot)
{
Boolean negative;
fast long length_in_bits;
fscanf (portable_file, "%ld", (&l));
length_in_bits = l;
}
- if ((length_in_bits <= fixnum_to_bits) &&
- (The_Type == TC_FIXNUM))
+ if ((length_in_bits <= fixnum_to_bits)
+ && (The_Type == TC_FIXNUM))
{
/* The most negative fixnum is handled in the bignum case */
fast long Value = 0;
}
}
if (negative)
- {
Value = -Value;
- }
+
*Slot = (LONG_TO_FIXNUM (Value));
return (To);
}
accumulator = (hex_digit >> bits_in_digit);
position = (4 - bits_in_digit);
length_in_bits -= 4;
- if (length_in_bits >= BIGNUM_DIGIT_LENGTH)
+ if (length_in_bits <= 0)
+ {
+ (*scan) = accumulator;
+ break;
+ }
+ else if (length_in_bits >= BIGNUM_DIGIT_LENGTH)
bits_in_digit = BIGNUM_DIGIT_LENGTH;
- else if (length_in_bits > 0)
- bits_in_digit = length_in_bits;
else
- {
- (*scan) = accumulator;
- break;
- }
+ bits_in_digit = length_in_bits;
}
}
(*To) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, gc_length));
}
}
}
-\f
+
SCHEME_OBJECT *
+DEFUN (read_a_bignum, (The_Type, To, Slot),
+ int The_Type AND SCHEME_OBJECT * To AND SCHEME_OBJECT * Slot)
+{
+ return (read_an_integer (The_Type, To, Slot));
+}
+\f
+static SCHEME_OBJECT *
DEFUN (read_a_bit_string, (To, Slot),
- SCHEME_OBJECT *To AND
- SCHEME_OBJECT *Slot)
+ SCHEME_OBJECT * To AND SCHEME_OBJECT * Slot)
{
long size_in_bits, size_in_words;
SCHEME_OBJECT the_bit_string;
#define dflmin() 0.0 /* Cop out */
#define dflmax() ((the_max == 0.0) ? (compute_max ()) : the_max)
-double
+static double
DEFUN_VOID (compute_max)
{
fast double Result;
fast int expt;
Result = 0.0;
- for (expt = DBL_MAX_EXP;
- expt != 0;
- expt >>= 1)
- {
+ for (expt = DBL_MAX_EXP; expt != 0; expt >>= 1)
Result += (ldexp (1.0, expt));
- }
the_max = Result;
return (Result);
}
-long
-DEFUN (read_signed_decimal, (stream),
- fast FILE *stream)
+static long
+DEFUN (read_signed_decimal, (stream), fast FILE * stream)
{
fast int c = (getc (stream));
fast long result = (-1);
int negative_p = 0;
while (c == ' ')
- {
c = (getc (stream));
- }
- if (c == '-')
- {
- negative_p = 1;
+
+ if (c == '+')
c = (getc (stream));
- }
- else if (c == '+')
+ else if (c == '-')
{
+ negative_p = 1;
c = (getc (stream));
}
+
if ((c >= '0') && (c <= '9'))
{
result = (c - '0');
}
}
if (c != EOF)
- {
ungetc (c, stream);
- }
+
if (result == (-1))
{
fprintf (stderr, "%s: Unable to read expected decimal integer\n",
return (negative_p ? (-result) : result);
}
\f
-double
+static double
DEFUN_VOID (read_a_flonum)
{
Boolean negative;
/* Hair here because portable file format incorrect for flonum 0. */
exponent = (read_signed_decimal (portable_file));
if (exponent == 0)
- {
- int c = (getc (portable_file));
- if (c == '\n')
- {
- return (0);
- }
- ungetc (c, portable_file);
- }
+ {
+ int c = (getc (portable_file));
+ if (c == '\n')
+ return (0);
+ ungetc (c, portable_file);
+ }
size_in_bits = (read_signed_decimal (portable_file));
if (size_in_bits == 0)
- {
return (0);
- }
+
if ((exponent > DBL_MAX_EXP) || (exponent < DBL_MIN_EXP))
{
/* Skip over mantissa */
while ((getc (portable_file)) != '\n')
- {};
+ ;
fprintf (stderr,
"%s: Floating point exponent too %s!\n",
program_name,
long digit;
if (size_in_bits > DBL_MANT_DIG)
- {
fprintf (stderr,
"%s: Some precision may be lost.",
program_name);
- }
getc (portable_file); /* Space */
for (ndigits = (hex_digits (size_in_bits)),
Result = 0.0,
Result = (ldexp (Result, ((int) exponent)));
}
if (negative)
- {
Result = -Result;
- }
+
return (Result);
}
\f
-SCHEME_OBJECT *
+static SCHEME_OBJECT *
DEFUN (Read_External, (N, Table, To),
- long N AND
- fast SCHEME_OBJECT *Table AND
- SCHEME_OBJECT *To)
+ long N
+ AND fast SCHEME_OBJECT * Table
+ AND SCHEME_OBJECT * To)
{
fast SCHEME_OBJECT *Until = &Table[N];
int The_Type;
continue;
case TC_FIXNUM:
- case TC_BIG_FIXNUM:
To = (read_an_integer (The_Type, To, Table++));
continue;
+
+ case TC_BIG_FIXNUM:
+ To = (read_a_bignum (The_Type, To, Table++));
+ continue;
case TC_CHARACTER:
{
return (To);
}
\f
-#if FALSE
+#define DEBUG 0
-void
-DEFUN (Move_Memory, (From, N, To),
- fast SCHEME_OBJECT *From AND
- long N AND
- SCHEME_OBJECT *To)
+#if (DEBUG > 2)
+static void
+DEFUN (print_external_objects, (area_name, Table, N),
+ char * area_name
+ AND fast SCHEME_OBJECT * Table
+ AND fast long N)
{
- fast SCHEME_OBJECT *Until;
-
- Until = &From[N];
- while (From < Until)
- {
- *To++ = *From++;
- }
- return;
-}
-
-#endif
+ fast SCHEME_OBJECT * Table_End = &Table[N];
-#if FALSE
-
-/* This appears to be a fossil. */
-
-void
-DEFUN (Relocate_Objects, (from, how_many, disp),
- fast SCHEME_OBJECT *from AND
- long how_many AND
- fast long disp)
-{
- fast SCHEME_OBJECT *Until;
+ fprintf (stderr, "%s External Objects:\n", area_name);
+ fprintf (stderr, "Table = 0x%x; N = %d\n", Table, N);
- Until = &from[how_many];
- while (from < Until)
+ for ( ; Table < Table_End; Table++)
{
- switch (OBJECT_TYPE (*from))
+ switch (OBJECT_TYPE (*Table))
{
case TC_FIXNUM:
+ {
+ fprintf (stderr,
+ "Table[%6d] = Fixnum %d\n",
+ (N - (Table_End - Table)),
+ (FIXNUM_TO_LONG (*Table)));
+ break;
+ }
case TC_CHARACTER:
- from += 1;
- break;
+ fprintf (stderr,
+ "Table[%6d] = Character %c = 0x%02x\n",
+ (N - (Table_End - Table)),
+ (OBJECT_DATUM (*Table)),
+ (OBJECT_DATUM (*Table)));
+ break;
+
+ case TC_CHARACTER_STRING:
+ fprintf (stderr,
+ "Table[%6d] = string \"%s\"\n",
+ (N - (Table_End - Table)),
+ ((char *) MEMORY_LOC (*Table, STRING_CHARS)));
+ break;
case TC_BIG_FIXNUM:
+ fprintf (stderr,
+ "Table[%6d] = Bignum\n",
+ (N - (Table_End - Table)));
+ break;
+
case TC_BIG_FLONUM:
- case TC_CHARACTER_STRING:
- *from++ =
- (OBJECT_NEW_DATUM ((*from), (disp + (OBJECT_DATUM (*from)))));
+ fprintf (stderr,
+ "Table[%6d] = Flonum %lf\n",
+ (N - (Table_End - Table)),
+ (* ((double *) MEMORY_LOC (*Table, 1))));
break;
default:
- fprintf (stderr,
- "%s: Unknown External Object Reference with Type 0x%02x",
- program_name,
- (OBJECT_TYPE (*from)));
- inconsistency ();
+ fprintf (stderr,
+ "Table[%6d] = Unknown External Object 0x%8x\n",
+ (N - (Table_End - Table)),
+ *Table);
+ break;
}
}
return;
}
-#endif
+#endif /* DEBUG > 1 */
+\f
+#if (DEBUG > 0)
+
+#define WHEN(condition, message) when (condition, message)
+
+static void
+DEFUN (when, (what, message), Boolean what AND char * message)
+{
+ if (what)
+ {
+ fprintf (stderr, "%s: Inconsistency: %s!\n",
+ program_name, (message));
+ inconsistency ();
+ }
+ return;
+}
+
+#else /* DEBUG <= 0 */
+
+#define WHEN(what, message) do { } while (0)
+
+#endif /* DEBUG > 0 */
+
+#if (DEBUG > 1)
+
+#define DEBUGGING(action) action
+
+#define READ_HEADER_FAILURE(string) do \
+{ \
+ fprintf (stderr, "Unable to read header field \"%s\".\n", (string)); \
+} while (0)
+
+#define READ_HEADER_SUCCESS(string, format, value) do \
+{ \
+ fprintf (stderr, "%s: ", (string)); \
+ fprintf (stderr, (format), (value)); \
+ fprintf (stderr, "\n"); \
+} while (0)
+
+#else /* DEBUG <= 1 */
+
+#define DEBUGGING(action) do { } while (0)
+
+#define READ_HEADER_FAILURE(s) do { } while (0)
+#define READ_HEADER_SUCCESS(s,f,v) do { } while (0)
+
+#endif /* DEBUG > 0 */
+
+#if (DEBUG > 2)
+
+#define XDEBUGGING(action) DEBUGGING(action)
+
+#else /* DEBUG <= 2 */
+
+#define XDEBUGGING(action) do { } while (0)
+
+#endif /* DEBUG > 2 */
\f
-#define Relocate_Into(Where, Addr) \
+void
+relocation_error (long addr)
+{
+ fprintf (stderr, "%s: Out of range address %d.\n",
+ program_name, addr);
+ inconsistency ();
+ /*NOTREACHED*/
+}
+
+#define Relocate_Into(Where, Addr) do \
{ \
- if ((Addr) < Dumped_Pure_Base) \
- { \
- (Where) = &Heap_Object_Base[(Addr) - Dumped_Heap_Base]; \
- } \
- else if ((Addr) < Dumped_Constant_Base) \
- { \
- (Where) = &Pure_Base[(Addr) - Dumped_Pure_Base]; \
- } \
+ long _addr = (Addr); \
+ \
+ if ((_addr >= Dumped_Heap_Base) && (_addr < Dumped_Heap_Limit)) \
+ (Where) = &Heap_Object_Limit[_addr - Dumped_Heap_Base]; \
+ else if ((_addr >= Dumped_Const_Base) \
+ && (_addr < Dumped_Const_Limit)) \
+ (Where) = &Const_Object_Limit[_addr - Dumped_Const_Base]; \
+ else if ((_addr >= Dumped_Pure_Base) \
+ && (_addr < Dumped_Pure_Limit)) \
+ (Where) = &Pure_Object_Limit[_addr - Dumped_Pure_Base]; \
else \
- { \
- (Where) = &Constant_Base[(Addr) - Dumped_Constant_Base]; \
- } \
-}
+ (void) relocation_error (_addr); \
+} while (0)
#ifndef Conditional_Bug
#define Relocate(Addr) \
-(((Addr) < Dumped_Pure_Base) ? \
- &Heap_Object_Base[(Addr) - Dumped_Heap_Base] : \
- (((Addr) < Dumped_Constant_Base) ? \
- &Pure_Base[(Addr) - Dumped_Pure_Base] : \
- &Constant_Base[(Addr) - Dumped_Constant_Base]))
+((((Addr) >= Dumped_Heap_Base) && ((Addr) < Dumped_Heap_Limit)) \
+ ? &Heap_Object_Limit[(Addr) - Dumped_Heap_Base] \
+ : ((((Addr) >= Dumped_Const_Base) && ((Addr) < Dumped_Const_Limit)) \
+ ? &Const_Object_Limit[(Addr) - Dumped_Const_Base] \
+ : ((((Addr) >= Dumped_Pure_Base) && ((Addr) < Dumped_Pure_Limit)) \
+ ? &Pure_Object_Limit[(Addr) - Dumped_Pure_Base] \
+ : ((relocation_error (Addr)), ((SCHEME_OBJECT *) NULL)))))
#else
-static SCHEME_OBJECT *Relocate_Temp;
+static SCHEME_OBJECT * Relocate_Temp;
#define Relocate(Addr) \
(Relocate_Into (Relocate_Temp, Addr), Relocate_Temp)
#endif
\f
-SCHEME_OBJECT *
+static SCHEME_OBJECT *
DEFUN (Read_Pointers_and_Relocate, (how_many, to),
- fast long how_many AND
- fast SCHEME_OBJECT *to)
+ fast long how_many AND fast SCHEME_OBJECT * to)
{
int The_Type;
long The_Datum;
-#if FALSE
- ALIGN_FLOAT (to);
-#endif
-
while ((--how_many) >= 0)
{
VMS_BUG (The_Type = 0);
switch (The_Type)
{
case CONSTANT_CODE:
- *to++ = Constant_Table[The_Datum];
+ WHEN (((The_Datum < 0) || (The_Datum >= Const_Objects)),
+ "CONSTANT_CODE too large");
+ *to++ = Const_Table[The_Datum];
continue;
case HEAP_CODE:
+ WHEN (((The_Datum < 0) || (The_Datum >= Heap_Objects)),
+ "HEAP_CODE too large");
*to++ = Heap_Table[The_Datum];
continue;
+
+ case PURE_CODE:
+ WHEN (((The_Datum < 0) || (The_Datum >= Pure_Objects)),
+ "PURE_CODE too large");
+ *to++ = Pure_Table[The_Datum];
+ continue;
case TC_MANIFEST_NM_VECTOR:
*to++ = (MAKE_OBJECT (The_Type, The_Datum));
}
continue;
- case TC_COMPILED_ENTRY:
- {
- SCHEME_OBJECT *temp;
- long base_type, base_datum;
-
- fscanf (portable_file, "%02x %lx", &base_type, &base_datum);
- temp = (Relocate (base_datum));
- *to++ =
- (MAKE_POINTER_OBJECT
- (base_type, ((SCHEME_OBJECT *) (&(((char *) temp)[The_Datum])))));
- break;
- }
-
case TC_BROKEN_HEART:
if (The_Datum != 0)
{
case_simple_Non_Pointer:
*to++ = (MAKE_OBJECT (The_Type, The_Datum));
continue;
+\f
+ case TC_COMPILED_ENTRY:
+ {
+ SCHEME_OBJECT * temp, * entry_addr;
+ long base_type, base_datum;
+
+ fscanf (portable_file, "%02x %lx", &base_type, &base_datum);
+ temp = (Relocate (base_datum));
+ if (c_compiled_p)
+ entry_addr = &temp[The_Datum];
+ else
+ entry_addr = ((SCHEME_OBJECT *) (&(((char *) temp) [The_Datum])));
+ *to++ = (MAKE_POINTER_OBJECT (base_type, entry_addr));
+ continue;
+ }
- case TC_MANIFEST_CLOSURE:
- case TC_LINKAGE_SECTION:
+ case TC_C_COMPILED_TAG:
{
- fprintf (stderr, "%s: File contains linked compiled code.\n",
- program_name);
- inconsistency ();
+ if (! c_compiled_p)
+ {
+ fprintf (stderr, "%s: C-compiled code descriptors found.\n",
+ program_name);
+ inconsistency ();
+ }
+ switch (The_Datum)
+ {
+ case C_COMPILED_FAKE_NMV:
+ {
+ long nmv_length;
+
+ VMS_BUG (nmv_length = 0);
+ fscanf (portable_file, "%lx", &nmv_length);
+ *to++ = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, nmv_length));
+ continue;
+ }
+
+ case C_COMPILED_ENTRY_FORMAT:
+ {
+ long low_byte, high_byte, offset, format;
+
+ VMS_BUG (low_byte = 0);
+ VMS_BUG (high_byte = 0);
+ VMS_BUG (offset = 0);
+ fscanf (portable_file, "%ld %ld %lx",
+ &low_byte, &high_byte, &offset);
+ format = (MAKE_FORMAT_WORD (high_byte, low_byte));
+ to += 1;
+ WRITE_LABEL_DESCRIPTOR (to, format, offset);
+ continue;
+ }
+
+ case C_COMPILED_ENTRY_CODE:
+ {
+ long entry_number;
+
+ VMS_BUG (entry_number = 0);
+ fscanf (portable_file, "%lx", &entry_number);
+ *to++ = ((SCHEME_OBJECT) entry_number);
+ continue;
+ }
+\f
+ case C_COMPILED_CLOSURE_HEADER:
+ {
+ long header_datum;
+
+ VMS_BUG (header_datum = 0);
+ fscanf (portable_file, "%lx", &header_datum);
+ *to++ = (MAKE_OBJECT (TC_MANIFEST_CLOSURE, header_datum));
+ continue;
+ }
+
+ case C_COMPILED_MULTI_CLOSURE_HEADER:
+ {
+ long nentries;
+
+ VMS_BUG (nentries = 0);
+ fscanf (portable_file, "%lx", &nentries);
+ to += 1;
+ WRITE_LABEL_DESCRIPTOR (to, nentries, 0);
+ continue;
+ }
+
+ case C_COMPILED_LINKAGE_HEADER:
+ {
+ long kind, count;
+
+ VMS_BUG (kind = 0);
+ VMS_BUG (count = 0);
+ fscanf (portable_file, "%lx %lx", &kind, &count);
+ *to++ = (MAKE_LINKAGE_SECTION_HEADER (kind, count));
+ continue;
+ }
+
+ case C_COMPILED_RAW_QUAD:
+ {
+ long quad_datum;
+
+ VMS_BUG (quad_datum = 0);
+ fscanf (portable_file, "%lx", &quad_datum);
+ *to++ = (ADDR_TO_SCHEME_ADDR (Relocate (quad_datum)));
+ continue;
+ }
+
+ case C_COMPILED_EXECUTE_ENTRY:
+ {
+ long offset, block_base;
+ SCHEME_OBJECT * temp;
+
+ VMS_BUG (offset = 0);
+ VMS_BUG (block_base = 0);
+ fscanf (portable_file, "%lx %lx", &offset, &block_base);
+ temp = (Relocate (block_base));
+ *to++ = (ADDR_TO_SCHEME_ADDR (&temp[offset]));
+ continue;
+ }
+
+ case C_COMPILED_EXECUTE_ARITY:
+ {
+ long arity;
+
+ VMS_BUG (arity = 0);
+ fscanf (portable_file, "%lx", &arity);
+ *to++ = ((SCHEME_OBJECT) arity);
+ continue;
+ }
+\f
+ default:
+ {
+ fprintf (stderr, "%s: Unknown C compiled tag found.\n",
+ program_name);
+ inconsistency ();
+ }
+ }
+ continue;
}
+ case TC_STACK_ENVIRONMENT:
+ *to++ = (MAKE_POINTER_OBJECT (The_Type, (Stack_Top - The_Datum)));
+ continue;
+
case TC_REFERENCE_TRAP:
if (The_Datum <= TRAP_MAX_IMMEDIATE)
{
default:
/* Should be stricter */
- *to++ = (MAKE_POINTER_OBJECT (The_Type, Relocate (The_Datum)));
+ *to++ = (MAKE_POINTER_OBJECT (The_Type, (Relocate (The_Datum))));
continue;
}
}
-#if FALSE
- ALIGN_FLOAT (to);
-#endif
return (to);
}
\f
static Boolean primitive_warn = false;
-SCHEME_OBJECT *
+static SCHEME_OBJECT *
DEFUN (read_primitives, (how_many, where),
- fast long how_many AND
- fast SCHEME_OBJECT *where)
+ fast long how_many
+ AND fast SCHEME_OBJECT * where)
{
long arity;
{
fscanf (portable_file, "%ld", &arity);
if (arity == ((long) UNKNOWN_PRIMITIVE_ARITY))
- {
primitive_warn = true;
- }
*where++ = (LONG_TO_FIXNUM (arity));
where = (read_a_string_internal (where, ((long) -1)));
}
return (where);
}
-\f
-#ifdef DEBUG
-void
-DEFUN (print_external_objects, (area_name, Table, N),
- char *area_name AND
- fast SCHEME_OBJECT *Table AND
- fast long N)
+static SCHEME_OBJECT *
+DEFUN (read_c_code_blocks, (nreserved, length, area),
+ long nreserved AND long length AND SCHEME_OBJECT * area)
{
- fast SCHEME_OBJECT *Table_End = &Table[N];
-
- fprintf (stderr, "%s External Objects:\n", area_name);
- fprintf (stderr, "Table = 0x%x; N = %d\n", Table, N);
-
- for ( ; Table < Table_End; Table++)
+ if (length != 0)
{
- switch (OBJECT_TYPE (*Table))
+ *area++ = (LONG_TO_FIXNUM (nreserved));
+ while (--length >= 0)
{
- case TC_FIXNUM:
- {
- fprintf (stderr,
- "Table[%6d] = Fixnum %d\n",
- (N - (Table_End - Table)),
- (FIXNUM_TO_LONG (*Table)));
- break;
- }
- case TC_CHARACTER:
- fprintf (stderr,
- "Table[%6d] = Character %c = 0x%02x\n",
- (N - (Table_End - Table)),
- (OBJECT_DATUM (*Table)),
- (OBJECT_DATUM (*Table)));
- break;
-
- case TC_CHARACTER_STRING:
- fprintf (stderr,
- "Table[%6d] = string \"%s\"\n",
- (N - (Table_End - Table)),
- ((char *) MEMORY_LOC (*Table, STRING_CHARS)));
- break;
-
- case TC_BIG_FIXNUM:
- fprintf (stderr,
- "Table[%6d] = Bignum\n",
- (N - (Table_End - Table)));
- break;
-
- case TC_BIG_FLONUM:
- fprintf (stderr,
- "Table[%6d] = Flonum %lf\n",
- (N - (Table_End - Table)),
- (* ((double *) MEMORY_LOC (*Table, 1))));
- break;
+ long nentries;
- default:
- fprintf (stderr,
- "Table[%6d] = Unknown External Object 0x%8x\n",
- (N - (Table_End - Table)),
- *Table);
- break;
+ fscanf (portable_file, "%ld", &nentries);
+ *area++ = (LONG_TO_FIXNUM (nentries));
+ area = (read_a_char_pointer (area));
}
}
- return;
-}
-
-#define DEBUGGING(action) action
-
-#define WHEN(condition, message) when (condition, message)
-
-void
-DEFUN (when, (what, message),
- Boolean what AND
- char *message)
-{
- if (what)
- {
- fprintf (stderr, "%s: Inconsistency: %s!\n",
- program_name, (message));
- quit (1);
- }
- return;
+ return (area);
}
-
-#define READ_HEADER(string, format, value) \
+\f
+#define READ_HEADER_NO_ERROR(string, format, value, flag) do \
{ \
- fscanf (portable_file, format, &(value)); \
- fprintf (stderr, "%s: ", (string)); \
- fprintf (stderr, (format), (value)); \
- fprintf (stderr, "\n"); \
-}
-
-#else /* not DEBUG */
-
-#define DEBUGGING(action)
-
-#define WHEN(what, message)
+ if (fscanf (portable_file, format, &(value)) == EOF) \
+ { \
+ (flag) = (false); \
+ READ_HEADER_FAILURE (string); \
+ } \
+ else \
+ { \
+ (flag) = (true); \
+ READ_HEADER_SUCCESS (string, format, value); \
+ } \
+} while (0)
-#define READ_HEADER(string, format, value) \
+#define READ_HEADER(string, format, value) do \
{ \
if (fscanf (portable_file, format, &(value)) == EOF) \
{ \
+ READ_HEADER_FAILURE (string); \
short_header_read (); \
} \
-}
+ else \
+ READ_HEADER_SUCCESS (string, format, value); \
+} while (0)
-#endif /* DEBUG */
-\f
-void
+static void
DEFUN_VOID (short_header_read)
{
fprintf (stderr, "%s: Header is not complete!\n", program_name);
quit (1);
}
-
+\f
static SCHEME_OBJECT * Lowest_Allocated_Address, * Highest_Allocated_Address;
-long
+static long
DEFUN_VOID (Read_Header_and_Allocate)
{
+ Boolean ok;
+
long
Portable_Version, Machine,
Version, Sub_Version, Flags,
NFlonums, NIntegers, NBits,
NBitstrs, NBBits, NStrings, NChars,
- NPChars,
- Size;
+ NPChars, NCChars, Size, initial_delta;
-#if FALSE
- READ_HEADER ("Portable Version", "%ld", Portable_Version);
-#else
- if (fscanf (portable_file, "%ld", &Portable_Version) == EOF)
- {
+ /* We don't use READ_HEADER here because it is not an error if
+ there is no first word.
+ .bin (and .psb) files can contain multiple objects.
+ */
+
+ READ_HEADER_NO_ERROR ("Portable Version", "%ld", Portable_Version, ok);
+ if (! ok)
return (-1);
- }
-#endif
if (Portable_Version != PORTABLE_VERSION)
{
READ_HEADER ("Flags", "%ld", Flags);
READ_FLAGS (Flags);
- if (((compiled_p && (! allow_compiled_p)) ||
- (nmv_p && (! allow_nmv_p))) &&
- (Machine != FASL_INTERNAL_FORMAT))
+ if (((compiled_p && (! allow_compiled_p))
+ || (nmv_p && (! allow_nmv_p)))
+ && (Machine != FASL_INTERNAL_FORMAT))
{
if (compiled_p)
- {
fprintf (stderr, "%s: %s\n", program_name,
"Portable file contains \"non-portable\" compiled code.");
- }
else
- {
fprintf (stderr, "%s: %s\n", program_name,
"Portable file contains \"unexpected\" non-marked vectors.");
- }
fprintf (stderr, "Machine specified in the portable file: %4d\n",
Machine);
fprintf (stderr, "Machine Expected: %4d\n",
FASL_INTERNAL_FORMAT);
quit (1);
}
+\f
+ if (compiled_p
+ && c_compiled_p
+ && (COMPILER_PROCESSOR_TYPE != COMPILER_LOSING_C_TYPE))
+ {
+ fprintf (stderr,
+ "Portable file contains descriptors for code compiled to C.\n");
+ fprintf (stderr,
+ "The microcode is not configured to handle such code.\n");
+ quit (1);
+ }
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", Const_Count);
+ READ_HEADER ("Dumped Constant Base", "%ld", Dumped_Const_Base);
+ READ_HEADER ("Constant Objects", "%ld", Const_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 ("Max Stack Offset", "%ld", Max_Stack_Offset);
READ_HEADER ("Number of flonums", "%ld", NFlonums);
READ_HEADER ("Number of integers", "%ld", NIntegers);
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
+ READ_HEADER ("Compiler utilities vector", "%ld", Dumped_Compiler_Utilities);
- Size = (6 + /* SNMV */
- (TRAP_MAX_IMMEDIATE + 1) +
- Heap_Count + Heap_Objects +
- Constant_Count + Constant_Objects +
- Pure_Count + Pure_Objects +
- flonum_to_pointer (NFlonums) +
- ((NIntegers * (2 + (BYTES_TO_WORDS (sizeof (bignum_digit_type))))) +
- (BYTES_TO_WORDS (BIGNUM_BITS_TO_DIGITS (NBits)))) +
- ((NStrings * (1 + STRING_CHARS)) +
- (char_to_pointer (NChars))) +
- ((NBitstrs * (1 + BIT_STRING_FIRST_WORD)) +
- (BIT_STRING_LENGTH_TO_GC_LENGTH (NBBits))) +
- ((Primitive_Table_Length * (2 + STRING_CHARS)) +
- (char_to_pointer (NPChars))));
+ READ_HEADER ("Number of C code blocks", "%ld", C_Code_Table_Length);
+ READ_HEADER ("Number of characters in C code blocks", "%ld", NCChars);
+ READ_HEADER ("Number of reserved C entries", "%ld", C_Code_Reserved_Entries);
+\f
+ Dumped_Heap_Limit = Dumped_Heap_Base + Heap_Count;
+ Dumped_Const_Limit = Dumped_Const_Base + Const_Count;
+ Dumped_Pure_Limit = Dumped_Pure_Base + Pure_Count;
+
+ initial_delta = (TRAP_MAX_IMMEDIATE + 1);
+ if (Max_Stack_Offset > initial_delta)
+ initial_delta = Max_Stack_Offset;
+
+ Size = (6 /* SNMV */
+ + (2 * ((FLOATING_ALIGNMENT + 1) / (sizeof (SCHEME_OBJECT))))
+ + initial_delta
+ + (Heap_Count + Heap_Objects)
+ + (Const_Count + Const_Objects)
+ + (Pure_Count + Pure_Objects)
+ + (flonum_to_pointer (NFlonums))
+ + ((NIntegers * (2 + (BYTES_TO_WORDS (sizeof (bignum_digit_type)))))
+ + (BYTES_TO_WORDS (BIGNUM_BITS_TO_DIGITS (NBits))))
+ + ((NStrings * (1 + STRING_CHARS))
+ + (char_to_pointer (NChars)))
+ + ((NBitstrs * (1 + BIT_STRING_FIRST_WORD))
+ + (BIT_STRING_LENGTH_TO_GC_LENGTH (NBBits)))
+ + ((Primitive_Table_Length * (2 + STRING_CHARS))
+ + (char_to_pointer (NPChars)))
+ + (1 + (2 * C_Code_Table_Length) + (char_to_pointer (NCChars))));
ALLOCATE_HEAP_SPACE (Size,
Lowest_Allocated_Address,
program_name, Size);
quit (1);
}
- Heap = (Lowest_Allocated_Address + (TRAP_MAX_IMMEDIATE + 1));
- return (Size - (TRAP_MAX_IMMEDIATE + 1));
+ Heap = (Lowest_Allocated_Address + initial_delta);
+ return (Size - initial_delta);
}
\f
-void
+static void
DEFUN_VOID (do_it)
{
while (1)
{
- SCHEME_OBJECT *primitive_table_end;
+ SCHEME_OBJECT
+ * primitive_table, * primitive_table_end,
+ * c_code_table, * c_code_table_end,
+ * Dumped_Object;
Boolean result;
long Size;
Size = (Read_Header_and_Allocate ());
if (Size < 0)
- {
return;
- }
- Stack_Top = &Heap[Size];
+ if (band_p)
+ warn_portable_p = false;
+ Stack_Top = Heap;
DEBUGGING (fprintf (stderr, "Stack_Top: 0x%x\n", Stack_Top));
- Heap_Table = &Heap[0];
- Heap_Base = &Heap_Table[Heap_Objects];
- ALIGN_FLOAT (Heap_Base);
- Heap_Object_Base =
- Read_External (Heap_Objects, Heap_Table, Heap_Base);
- DEBUGGING (print_external_objects ("Heap", Heap_Table, Heap_Objects));
- DEBUGGING (fprintf (stderr, "Heap_Base: 0x%x\n", Heap_Base));
- DEBUGGING (fprintf (stderr, "Heap_Object_Base: 0x%x\n", Heap_Object_Base));
+ Heap_Table = &Heap[Size - Heap_Objects];
+ Const_Table = &Heap_Table[- Const_Objects];
+ Pure_Table = &Const_Table[- Pure_Objects];
- /* The various 2s below are for SNMV headers. */
+ /* The various 2s below are for SNMV headers in constant/pure markers. */
- Pure_Table = &Heap_Object_Base[Heap_Count];
- Pure_Base = &Pure_Table[Pure_Objects + 2];
- Pure_Object_Base =
- Read_External (Pure_Objects, Pure_Table, Pure_Base);
- DEBUGGING (print_external_objects ("Pure", Pure_Table, Pure_Objects));
+ Constant_Space = &Heap[0];
+ ALIGN_FLOAT (Constant_Space);
+
+ Pure_Base = &Constant_Space[2];
+ Pure_Object_Limit
+ = (Read_External (Pure_Objects, Pure_Table, Pure_Base));
+
+ XDEBUGGING (print_external_objects ("Pure", Pure_Table, Pure_Objects));
DEBUGGING (fprintf (stderr, "Pure_Base: 0x%x\n", Pure_Base));
- DEBUGGING (fprintf (stderr, "Pure_Object_Base: 0x%x\n", Pure_Object_Base));
+ DEBUGGING (fprintf (stderr, "Pure_Object_Limit: 0x%x\n",
+ Pure_Object_Limit));
- Constant_Table = &Heap[Size - Constant_Objects];
- Constant_Base = &Pure_Object_Base[Pure_Count + 2];
- Constant_Object_Base =
- Read_External (Constant_Objects, Constant_Table, Constant_Base);
- DEBUGGING (print_external_objects ("Constant",
- Constant_Table,
- Constant_Objects));
- DEBUGGING (fprintf (stderr, "Constant_Base: 0x%x\n", Constant_Base));
- DEBUGGING (fprintf (stderr, "Constant_Object_Base: 0x%x\n",
- Constant_Object_Base));
+ Const_Base = &Pure_Object_Limit[Pure_Count + 2];
+ Const_Object_Limit
+ = (Read_External (Const_Objects, Const_Table, Const_Base));
- primitive_table = &Constant_Object_Base[Constant_Count + 2];
+ XDEBUGGING (print_external_objects ("Constant", Const_Table,
+ Const_Objects));
+ DEBUGGING (fprintf (stderr, "Const_Base: 0x%x\n", Const_Base));
+ DEBUGGING (fprintf (stderr, "Const_Object_Limit: 0x%x\n",
+ Const_Object_Limit));
- WHEN ((primitive_table > Constant_Table),
- "primitive_table overran Constant_Table");
+ Constant_Top = &Const_Object_Limit[Const_Count + 2];
- /* Read the normal objects */
+ Heap_Base = Constant_Top;
+ ALIGN_FLOAT (Heap_Base);
+ Heap_Object_Limit
+ = (Read_External (Heap_Objects, Heap_Table, Heap_Base));
- Free =
- Read_Pointers_and_Relocate (Heap_Count, Heap_Object_Base);
+ XDEBUGGING (print_external_objects ("Heap", Heap_Table, Heap_Objects));
+ DEBUGGING (fprintf (stderr, "Heap_Base: 0x%x\n", Heap_Base));
+ DEBUGGING (fprintf (stderr, "Heap_Object_Limit: 0x%x\n",
+ Heap_Object_Limit));
- WHEN ((Free > Pure_Table),
- "Free overran Pure_Table");
- WHEN ((Free < Pure_Table),
- "Free did not reach Pure_Table");
+ primitive_table = &Heap_Object_Limit[Heap_Count];
- Free_Pure =
- Read_Pointers_and_Relocate (Pure_Count, Pure_Object_Base);
+ WHEN ((primitive_table > &Heap[Size]), "primitive_table overran memory.");
- WHEN ((Free_Pure > (Constant_Base - 2)),
- "Free_Pure overran Constant_Base");
- WHEN ((Free_Pure < (Constant_Base - 2)),
- "Free_Pure did not reach Constant_Base");
+ /* Read the normal objects */
- Free_Constant =
- Read_Pointers_and_Relocate (Constant_Count, Constant_Object_Base);
+ Free_Pure = (Read_Pointers_and_Relocate (Pure_Count, Pure_Object_Limit));
+ WHEN ((Free_Pure > (Const_Base - 2)),
+ "Free_Pure overran Const_Base");
+ WHEN ((Free_Pure < (Const_Base - 2)),
+ "Free_Pure did not reach Const_Base");
- WHEN ((Free_Constant > (primitive_table - 2)),
- "Free_Constant overran primitive_table");
- WHEN ((Free_Constant < (primitive_table - 2)),
- "Free_Constant did not reach primitive_table");
+ Free_Const = (Read_Pointers_and_Relocate (Const_Count,
+ Const_Object_Limit));
+ WHEN ((Free_Const > (Constant_Top - 2)),
+ "Free_Const overran Constant_Top");
+ WHEN ((Free_Const < (Constant_Top - 2)),
+ "Free_Const did not reach Constant_Top");
- primitive_table_end =
- read_primitives (Primitive_Table_Length, primitive_table);
+ Free = (Read_Pointers_and_Relocate (Heap_Count, Heap_Object_Limit));
- /*
- primitive_table_end can be well below Constant_Table, since
- the memory allocation is conservative (it rounds up), and all
- the slack ends up between them.
- */
+ WHEN ((Free > primitive_table), "Free overran primitive_table");
+ WHEN ((Free < primitive_table), "Free did not reach primitive_table");
- WHEN ((primitive_table_end > Constant_Table),
- "primitive_table_end overran Constant_Table");
+ primitive_table_end
+ = (read_primitives (Primitive_Table_Length, primitive_table));
if (primitive_warn)
{
fprintf (stderr, "%s:\n", program_name);
- fprintf (stderr,
- "NOTE: The binary file contains primitives with unknown arity.\n");
+ fprintf
+ (stderr,
+ "NOTE: The binary file contains primitives with unknown arity.\n");
}
- /* Dump the objects */
+ c_code_table = primitive_table_end;
+ c_code_table_end
+ = (read_c_code_blocks (C_Code_Reserved_Entries,
+ C_Code_Table_Length,
+ c_code_table));
- {
- SCHEME_OBJECT *Dumped_Object;
+ WHEN ((c_code_table_end > Pure_Table),
+ "c_code_table_end overran Pure_Table");
+ /*
+ c_code_table_end can be well below Pure_Table, since
+ the memory allocation is conservative (it rounds up), and all
+ the slack ends up between them.
+ */
+
+ /* Dump the objects */
Relocate_Into (Dumped_Object, Dumped_Object_Addr);
Pure_Base, (Free_Pure - Pure_Base)));
DEBUGGING (fprintf (stderr,
"Constant Space = 0x%x; Constant Count = %d\n",
- Constant_Base, (Free_Constant - Constant_Base)));
+ Const_Base, (Free_Const - Const_Base)));
DEBUGGING (fprintf (stderr,
"& Dumped Object = 0x%x; Dumped Object = 0x%x\n",
- Dumped_Object, *Dumped_Object));
+ Dumped_Object, * Dumped_Object));
DEBUGGING (fprintf (stderr, "Primitive_Table_Length = %ld; ",
Primitive_Table_Length));
DEBUGGING (fprintf (stderr, "Primitive_Table_Size = %ld\n",
/* Is there a Pure/Constant block? */
- if ((Constant_Objects == 0) && (Constant_Count == 0) &&
- (Pure_Objects == 0) && (Pure_Count == 0))
- {
- result = Write_File (Dumped_Object,
- (Free - Heap_Base), Heap_Base,
- 0, Stack_Top,
- primitive_table, Primitive_Table_Length,
- ((long) (primitive_table_end - primitive_table)),
- compiled_p, band_p);
- }
+ if ((Const_Objects == 0) && (Const_Count == 0)
+ && (Pure_Objects == 0) && (Pure_Count == 0))
+ result = (Write_File (Dumped_Object,
+ (Free - Heap_Base), Heap_Base,
+ 0, Stack_Top,
+ primitive_table, Primitive_Table_Length,
+ ((long) (primitive_table_end - primitive_table)),
+ c_code_table, C_Code_Table_Length,
+ ((long) (c_code_table_end - c_code_table)),
+ compiled_p, band_p));
else
{
long Pure_Length, Total_Length;
- Pure_Length = (Constant_Base - Pure_Base) + 1;
- Total_Length = (Free_Constant - Pure_Base) + 4;
- Pure_Base[-2] =
- MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, (Pure_Length - 1));
- Pure_Base[-1] =
- MAKE_OBJECT (PURE_PART, Total_Length);
- Constant_Base[-2] =
- MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- Constant_Base[-1] =
- MAKE_OBJECT (CONSTANT_PART, (Pure_Length - 1));
- Free_Constant[0] =
- MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- Free_Constant[1] =
- MAKE_OBJECT (END_OF_BLOCK, Total_Length);
+ Pure_Length = ((Const_Base - Pure_Base) + 1);
+ Total_Length = ((Constant_Top - Pure_Base) + 1);
+ Pure_Base[-2] = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR,
+ Pure_Length));
+ Pure_Base[-1] = (MAKE_OBJECT (PURE_PART, Total_Length));
+ Const_Base[-2] = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
+ Const_Base[-1] = (MAKE_OBJECT (CONSTANT_PART, Pure_Length));
+ Free_Const[0] = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
+ Free_Const[1] = (MAKE_OBJECT (END_OF_BLOCK, Total_Length));
result = (Write_File (Dumped_Object,
(Free - Heap_Base), Heap_Base,
- Total_Length, (Pure_Base - 2),
+ (Total_Length + 1), (Pure_Base - 2),
primitive_table, Primitive_Table_Length,
((long) (primitive_table_end - primitive_table)),
+ c_code_table, C_Code_Table_Length,
+ ((long) (c_code_table_end - c_code_table)),
compiled_p, band_p));
}
- }
+
if (!result)
{
fprintf (stderr, "%s: Error writing the output file.\n", program_name);
{
parse_keywords (argc, argv, options, false);
if (help_sup_p && help_p)
- {
print_usage_and_exit (options, 0);
/*NOTREACHED*/
- }
+
allow_nmv_p = (allow_nmv_p || allow_compiled_p);
setup_io ("r", "wb");
/* -*-C-*-
-$Id: bintopsb.c,v 9.57 1993/10/14 21:42:22 gjr Exp $
+$Id: bintopsb.c,v 9.58 1993/11/07 01:39:06 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
/* IO definitions */
#include "psbmap.h"
-#include "trap.h"
#include "limits.h"
#define internal_file input_file
#define portable_file output_file
#undef HEAP_MALLOC
#define HEAP_MALLOC malloc
-long
-DEFUN (Load_Data, (Count, To_Where),
- long Count AND
- SCHEME_OBJECT *To_Where)
+static long
+DEFUN (Load_Data, (Count, To_Where), long Count AND SCHEME_OBJECT *To_Where)
{
return (fread (((char *) To_Where),
(sizeof (SCHEME_OBJECT)),
#define INHIBIT_CHECKSUMS
#include "load.c"
#include "bltdef.h"
-\f
+#include "trap.h"
+
/* Character macros and procedures */
extern int strlen ();
punctuation[] = "'\",<.>/?;:{}[]|`~=+-_()*&^%$#@!";
static Boolean
-DEFUN (ispunct_local, (c),
- fast char c)
+DEFUN (ispunct_local, (c), fast char c)
{
fast char * s;
s = &punctuation[0];
while (*s != '\0')
- {
if (*s++ == c)
- {
return (true);
- }
- }
return (false);
}
#endif /* ispunct */
\f
-/* Global data */
-
/* Needed to upgrade */
#define TC_PRIMITIVE_EXTERNAL 0x10
#define STRING_LENGTH_TO_LONG(value) \
((long) (upgrade_lengths_p ? (OBJECT_DATUM (value)) : (value)))
+/* In case there is no compiled code support. */
+
+#ifndef FORMAT_WORD_LOW_BYTE
+#define FORMAT_WORD_LOW_BYTE(x) x
+#endif
+
+#ifndef FORMAT_WORD_HIGH_BYTE
+#define FORMAT_WORD_HIGH_BYTE(x) x
+#endif
+
+#ifndef COMPILED_ENTRY_FORMAT_WORD
+#define COMPILED_ENTRY_FORMAT_WORD(entry) 0
+#endif
+
+#ifndef EXTRACT_EXECUTE_CACHE_ARITY
+#define EXTRACT_EXECUTE_CACHE_ARITY(v,a) do { } while (0)
+#endif
+
+/* Global data */
+
static Boolean
+ allow_bands_p = false,
allow_compiled_p = false,
+ allow_constant_space_p = false,
allow_nmv_p = false,
+ c_compiled_p = false,
+ endian_invert_p = false,
shuffle_bytes_p = false,
swap_bytes_p = false,
upgrade_compiled_p = false,
upgrade_lengths_p = false,
upgrade_primitives_p = false,
upgrade_traps_p = false,
- vax_invert_p = false;
+ warn_portable_p = true;
static long
Heap_Relocation, Constant_Relocation,
- Free, Scan, Free_Constant, Scan_Constant,
- Objects, Constant_Objects;
+ Max_Stack_Offset,
+ Scan, Free, Objects,
+ Scan_Constant, Free_Constant, Constant_Objects,
+ Scan_Pure, Free_Pure, Pure_Objects;
static SCHEME_OBJECT
- *Mem_Base,
- *Free_Objects, *Free_Cobjects,
- *compiled_entry_table, *compiled_entry_pointer,
- *compiled_entry_table_end,
- *primitive_table, *primitive_table_end;
+ * Mem_Base, * Constant_Space, * Constant_Top,
+ * Free_Objects, * Free_Cobjects, * Free_Pobjects,
+ * compiled_entry_table, * compiled_entry_pointer,
+ * compiled_entry_table_end,
+ * compiled_block_table, * compiled_block_pointer,
+ * compiled_block_table_end,
+ * primitive_table, * primitive_table_end,
+ * c_code_table, * c_code_table_end;
static long
NFlonums,
NIntegers, NBits,
NBitstrs, NBBits,
NStrings, NChars,
- NPChars;
+ NPChars, NCChars;
\f
#define OUT(s) \
{ \
- fprintf(portable_file, (s)); \
+ fprintf (portable_file, (s)); \
break; \
}
-void
-DEFUN (print_a_char, (c, name),
- fast char c AND
- char *name)
+static void
+DEFUN (print_a_char, (c, name), fast char c AND char * name)
{
- switch(c)
+ switch (c)
{
- case '\n': OUT("\\n");
- case '\t': OUT("\\t");
- case '\b': OUT("\\b");
- case '\r': OUT("\\r");
- case '\f': OUT("\\f");
- case '\\': OUT("\\\\");
- case '\0': OUT("\\0");
- case ' ' : OUT(" ");
+ case '\n': OUT ("\\n");
+ case '\t': OUT ("\\t");
+ case '\b': OUT ("\\b");
+ case '\r': OUT ("\\r");
+ case '\f': OUT ("\\f");
+ case '\\': OUT ("\\\\");
+ case '\0': OUT ("\\0");
+ case ' ' : OUT (" ");
default:
- if ((isascii(c)) && ((isalpha(c)) || (isdigit(c)) || (ispunct(c))))
- {
- putc(c, portable_file);
- }
+ if ((isascii (c)) && ((isalpha (c)) || (isdigit (c)) || (ispunct (c))))
+ putc (c, portable_file);
else
{
unsigned int x = (((int) c) & ((1 << CHAR_BIT) - 1));
- fprintf(stderr,
- "%s: %s: File may not be portable: c = 0x%x\n",
- program_name, name, x);
+ if (warn_portable_p)
+ {
+ fprintf (stderr,
+ "%s: %s: File may not be portable: c = 0x%x\n",
+ program_name, name, x);
+ warn_portable_p = false;
+ }
/* This does not follow C conventions, but eliminates ambiguity */
- fprintf(portable_file, "\\X%d ", x);
+ fprintf (portable_file, "\\X%d ", x);
}
}
return;
#undef MAKE_BROKEN_HEART
#define MAKE_BROKEN_HEART(offset) (BROKEN_HEART_ZERO + (offset))
-#define Do_Compound(Code, Rel, Fre, Scn, Obj, FObj, kernel_code) \
+#define DO_COMPOUND(Code, Rel, Fre, Scn, Obj, FObj, kernel_code) do \
{ \
Old_Address += (Rel); \
Old_Contents = (*Old_Address); \
if (BROKEN_HEART_P (Old_Contents)) \
(Mem_Base [(Scn)]) = (OBJECT_NEW_TYPE ((Code), Old_Contents)); \
else \
- { \
kernel_code; \
- } \
-}
+} while (0)
-#define standard_kernel(kernel_code, type, Code, Scn, Obj, FObj) \
+#define STANDARD_KERNEL(kernel_code, type, Code, Scn, Obj, FObj) do \
{ \
(Mem_Base [(Scn)]) = (MAKE_OBJECT ((Code), (Obj))); \
{ \
while ((length--) > 0) \
(*(FObj)++) = (*Old_Address++); \
} \
-}
+} while (0)
\f
-#define do_string_kernel() \
+#define DO_STRING_KERNEL() do \
{ \
NStrings += 1; \
NChars += (pointer_to_char (length - 1)); \
-}
+} while (0)
-#define do_bignum_kernel() \
+#define DO_BIGNUM_KERNEL() do \
{ \
NIntegers += 1; \
NBits += \
(((* ((bignum_digit_type *) (Old_Address + 1))) \
& BIGNUM_DIGIT_MASK) \
* BIGNUM_DIGIT_LENGTH); \
-}
+} while (0)
-#define do_bit_string_kernel() \
+#define DO_BIT_STRING_KERNEL() do \
{ \
NBitstrs += 1; \
NBBits += (Old_Address [BIT_STRING_LENGTH_OFFSET]); \
-}
+} while (0)
-#define do_flonum_kernel(Code, Scn, Obj, FObj) \
+#define DO_FLONUM_KERNEL(Code, Scn, Obj, FObj) do \
{ \
+ int ctr; \
+ SCHEME_OBJECT * dest; \
+ \
(Mem_Base [(Scn)]) = (MAKE_OBJECT ((Code), (Obj))); \
NFlonums += 1; \
(*Old_Address++) = (MAKE_BROKEN_HEART (Obj)); \
(Obj) += 1; \
- ALIGN_FLOAT (FObj); \
(*(FObj)++) = (MAKE_OBJECT (TC_BIG_FLONUM, 0)); \
- (* ((double *) (FObj))) = (* ((double *) Old_Address)); \
- (FObj) += float_to_pointer; \
-}
-
-#define Do_String(Code, Rel, Fre, Scn, Obj, FObj) \
- Do_Compound (Code, Rel, Fre, Scn, Obj, FObj, \
- standard_kernel (do_string_kernel (), \
+ dest = (FObj); \
+ for (ctr = 0; ctr < float_to_pointer; ctr++) \
+ *dest++ = (*Old_Address++); \
+ (FObj) = dest; \
+} while (0)
+
+#define DO_STRING(Code, Rel, Fre, Scn, Obj, FObj) \
+ DO_COMPOUND (Code, Rel, Fre, Scn, Obj, FObj, \
+ STANDARD_KERNEL (DO_STRING_KERNEL (), \
TC_CHARACTER_STRING, \
Code, Scn, Obj, FObj))
-#define Do_Bignum(Code, Rel, Fre, Scn, Obj, FObj) \
- Do_Compound (Code, Rel, Fre, Scn, Obj, FObj, \
- standard_kernel (do_bignum_kernel (), TC_BIG_FIXNUM, \
+#define DO_BIGNUM(Code, Rel, Fre, Scn, Obj, FObj) \
+ DO_COMPOUND (Code, Rel, Fre, Scn, Obj, FObj, \
+ STANDARD_KERNEL (DO_BIGNUM_KERNEL (), TC_BIG_FIXNUM, \
Code, Scn, Obj, FObj))
-#define Do_Bit_String(Code, Rel, Fre, Scn, Obj, FObj) \
- Do_Compound (Code, Rel, Fre, Scn, Obj, FObj, \
- standard_kernel (do_bit_string_kernel (), TC_BIT_STRING, \
+#define DO_BIT_STRING(Code, Rel, Fre, Scn, Obj, FObj) \
+ DO_COMPOUND (Code, Rel, Fre, Scn, Obj, FObj, \
+ STANDARD_KERNEL (DO_BIT_STRING_KERNEL (), TC_BIT_STRING, \
Code, Scn, Obj, FObj))
-#define Do_Flonum(Code, Rel, Fre, Scn, Obj, FObj) \
- Do_Compound (Code, Rel, Fre, Scn, Obj, FObj, \
- do_flonum_kernel (Code, Scn, Obj, FObj))
+#define DO_FLONUM(Code, Rel, Fre, Scn, Obj, FObj) \
+ DO_COMPOUND (Code, Rel, Fre, Scn, Obj, FObj, \
+ DO_FLONUM_KERNEL (Code, Scn, Obj, FObj))
\f
-void
-DEFUN (print_a_fixnum, (val),
- long val)
+static void
+DEFUN (print_a_fixnum, (val), long val)
{
fast long size_in_bits;
fast unsigned long temp;
temp = ((val < 0) ? -val : val);
for (size_in_bits = 0; temp != 0; size_in_bits += 1)
- {
temp = temp >> 1;
- }
- fprintf(portable_file, "%02x %c ",
- TC_FIXNUM,
- (val < 0 ? '-' : '+'));
+ 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;
}
\f
-void
-DEFUN (print_a_string_internal, (len, str),
- fast long len AND
- fast char *str)
+static void
+DEFUN (print_a_string_internal, (len, str), fast long len AND fast char * str)
{
- fprintf(portable_file, "%ld ", len);
+ fprintf (portable_file, "%ld ", len);
if (shuffle_bytes_p)
{
- while(len > 0)
+ while (len > 0)
{
- print_a_char(str[3], "print_a_string");
+ print_a_char (str[3], "print_a_string");
if (len > 1)
- {
- print_a_char(str[2], "print_a_string");
- }
+ print_a_char (str[2], "print_a_string");
if (len > 2)
- {
- print_a_char(str[1], "print_a_string");
- }
+ print_a_char (str[1], "print_a_string");
if (len > 3)
- {
- print_a_char(str[0], "print_a_string");
- }
+ print_a_char (str[0], "print_a_string");
len -= 4;
str += 4;
}
}
else
- {
- while(--len >= 0)
- {
- print_a_char(*str++, "print_a_string");
- }
- }
- putc('\n', portable_file);
+ while (--len >= 0)
+ print_a_char (*str++, "print_a_string");
+ putc ('\n', portable_file);
return;
}
\f
-void
-DEFUN (print_a_string, (from),
- SCHEME_OBJECT *from)
+static void
+DEFUN (print_a_string, (from), SCHEME_OBJECT * from)
{
- long len;
- long maxlen;
+ long len, maxlen;
- maxlen = (pointer_to_char ((OBJECT_DATUM (*from++)) - 1));
+ maxlen = ((pointer_to_char ((OBJECT_DATUM (*from++)) - 1)) - 1);
len = (STRING_LENGTH_TO_LONG (*from++));
+ /* If compacting, do not compact strings that have non-default
+ maximum lengths.
+ */
+
fprintf (portable_file,
"%02x %ld ",
TC_CHARACTER_STRING,
- (compact_p ? len : maxlen));
+ ((compact_p
+ && ((BYTES_TO_WORDS (len + 1)) == (BYTES_TO_WORDS (maxlen + 1))))
+ ? len
+ : maxlen));
print_a_string_internal (len, ((char *) from));
return;
}
-void
+static void
DEFUN (print_a_primitive, (arity, length, name),
- long arity AND
- long length AND
- char *name)
+ long arity AND long length AND char * name)
{
fprintf (portable_file, "%ld ", arity);
print_a_string_internal (length, name);
return;
}
+
+static void
+DEFUN (print_a_c_code_block, (nentries, length, name),
+ long nentries AND long length AND char * name)
+{
+ fprintf (portable_file, "%ld ", nentries);
+ print_a_string_internal (length, name);
+ return;
+}
\f
static long
-DEFUN (bignum_length, (bignum),
- SCHEME_OBJECT bignum)
+DEFUN (bignum_length, (bignum), SCHEME_OBJECT bignum)
{
if (BIGNUM_ZERO_P (bignum))
return (0);
/* NOTREACHED */
}
\f
-void
-DEFUN (print_a_bignum, (bignum_ptr),
- SCHEME_OBJECT *bignum_ptr)
+static void
+DEFUN (print_a_bignum, (bignum_ptr), SCHEME_OBJECT * bignum_ptr)
{
SCHEME_OBJECT bignum;
bignum = (MAKE_POINTER_OBJECT (TC_BIG_FIXNUM, bignum_ptr));
if (BIGNUM_ZERO_P (bignum))
- {
- fprintf (portable_file, "%02x + 0\n",
- (compact_p ? TC_FIXNUM : TC_BIG_FIXNUM));
- return;
- }
{
+ fprintf (portable_file, "%02x + 0\n",
+ (compact_p ? TC_FIXNUM : TC_BIG_FIXNUM));
+ return;
+ }
+ {
+ int the_type = TC_BIG_FIXNUM;
bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
fast long length_in_bits = (bignum_length (bignum));
fast int bits_in_digit = 0;
fast bignum_digit_type accumulator;
+
+ /* This attempts to preserve non-canonicalized bignums as such.
+ The test below fails for the most negative fixnum represented
+ as a bignum
+ */
+
+ if (compact_p && (length_in_bits > fixnum_to_bits))
+ the_type = TC_FIXNUM;
+
fprintf (portable_file, "%02x %c %ld ",
- (compact_p ? TC_FIXNUM : TC_BIG_FIXNUM),
+ the_type,
((BIGNUM_NEGATIVE_P (bignum)) ? '-' : '+'),
length_in_bits);
accumulator = (*scan++);
- bits_in_digit =
- ((length_in_bits < BIGNUM_DIGIT_LENGTH)
- ? length_in_bits
- : BIGNUM_DIGIT_LENGTH);
+ bits_in_digit = ((length_in_bits < BIGNUM_DIGIT_LENGTH)
+ ? length_in_bits
+ : BIGNUM_DIGIT_LENGTH);
while (length_in_bits > 0)
{
if (bits_in_digit > 4)
int diff_bits = (4 - bits_in_digit);
accumulator = (*scan++);
fprintf (portable_file, "%01lx",
- (carry |
- ((accumulator & ((1 << diff_bits) - 1)) <<
- bits_in_digit)));
+ (carry
+ | ((accumulator & ((1 << diff_bits) - 1)) <<
+ bits_in_digit)));
length_in_bits -= 4;
bits_in_digit = (BIGNUM_DIGIT_LENGTH - diff_bits);
if (length_in_bits >= bits_in_digit)
}
}
fprintf (portable_file, "\n");
+ return;
}
\f
/* The following procedure assumes that a C long is at least 4 bits. */
-void
-DEFUN (print_a_bit_string, (from),
- SCHEME_OBJECT *from)
+static void
+DEFUN (print_a_bit_string, (from), SCHEME_OBJECT * from)
{
SCHEME_OBJECT the_bit_string;
fast long bits_remaining, leftover_bits;
the_bit_string = (MAKE_POINTER_OBJECT (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, " ");
- scan = BIT_STRING_LOW_PTR(the_bit_string);
+ fprintf (portable_file, " ");
+ scan = (BIT_STRING_LOW_PTR (the_bit_string));
for (leftover_bits = 0;
bits_remaining > 0;
bits_remaining -= OBJECT_LENGTH)
{
- next_word = *(INC_BIT_STRING_PTR(scan));
+ next_word = (* (INC_BIT_STRING_PTR (scan)));
if (bits_remaining < OBJECT_LENGTH)
- next_word &= LOW_MASK(bits_remaining);
+ next_word &= (LOW_MASK (bits_remaining));
- if (leftover_bits != 0)
+ if (leftover_bits == 0)
+ leftover_bits = ((bits_remaining > OBJECT_LENGTH)
+ ? OBJECT_LENGTH
+ : bits_remaining);
+ else
{
- accumulator &= LOW_MASK(leftover_bits);
+ accumulator &= (LOW_MASK (leftover_bits));
accumulator |=
- ((next_word & LOW_MASK(4 - leftover_bits)) << leftover_bits);
+ ((next_word & (LOW_MASK (4 - leftover_bits))) << leftover_bits);
next_word = (next_word >> (4 - leftover_bits));
- leftover_bits += ((bits_remaining > OBJECT_LENGTH) ?
- (OBJECT_LENGTH - 4) :
- (bits_remaining - 4));
- fprintf(portable_file, "%01lx", (accumulator & 0xf));
- }
- else
- {
- leftover_bits = ((bits_remaining > OBJECT_LENGTH) ?
- OBJECT_LENGTH :
- bits_remaining);
+ leftover_bits += ((bits_remaining > OBJECT_LENGTH)
+ ? (OBJECT_LENGTH - 4)
+ : (bits_remaining - 4));
+ fprintf (portable_file, "%01lx", (accumulator & 0xf));
}
- for(accumulator = next_word; leftover_bits >= 4; leftover_bits -= 4)
+ for (accumulator = next_word; leftover_bits >= 4; leftover_bits -= 4)
{
- fprintf(portable_file, "%01lx", (accumulator & 0xf));
- accumulator = accumulator >> 4;
+ 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
-void
-DEFUN (print_a_flonum, (val),
- double val)
+union flonum_u
{
+ double dval;
+ unsigned long lval[float_to_pointer];
+};
+
+static void
+DEFUN (print_a_flonum, (src), SCHEME_OBJECT * src)
+{
+ double val;
+ union flonum_u utemp;
fast long size_in_bits;
fast double mant, temp;
- int expt;
+ int expt, ctr;
extern double EXFUN (frexp, (double, int *));
- fprintf(portable_file, "%02x %c ",
- TC_BIG_FLONUM,
- ((val < 0.0) ? '-' : '+'));
+ for (ctr = 0; ctr < float_to_pointer; ctr++)
+ utemp.lval[ctr] = ((unsigned long) src[ctr]);
+ val = utemp.dval;
+
+ 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);
+ mant = frexp (((val < 0.0) ? -val : val), &expt);
size_in_bits = 1;
- for(temp = ((mant * 2.0) - 1.0);
- temp != 0;
- size_in_bits += 1)
+ for (temp = ((mant * 2.0) - 1.0); temp != 0; size_in_bits += 1)
{
temp *= 2.0;
if (temp >= 1.0)
temp -= 1.0;
}
- fprintf(portable_file, "%d %ld ", expt, size_in_bits);
+ fprintf (portable_file, "%d %ld ", expt, size_in_bits);
- for (size_in_bits = hex_digits(size_in_bits);
+ for (size_in_bits = (hex_digits (size_in_bits));
size_in_bits > 0;
size_in_bits -= 1)
{
digit += 1;
}
}
- fprintf(portable_file, "%01x", digit);
+ fprintf (portable_file, "%01x", digit);
}
- putc('\n', portable_file);
+ putc ('\n', portable_file);
return;
}
\f
/* Normal Objects */
-#define Do_Cell(Code, Rel, Fre, Scn, Obj, FObj) \
+#define DO_CELL(Code, Rel, Fre, Scn, Obj, FObj) do \
{ \
Old_Address += (Rel); \
Old_Contents = (*Old_Address); \
(Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre))); \
(Mem_Base [(Fre)++]) = Old_Contents; \
} \
-}
+} while (0)
-#define Do_Pair(Code, Rel, Fre, Scn, Obj, FObj) \
+#define DO_PAIR(Code, Rel, Fre, Scn, Obj, FObj) do \
{ \
Old_Address += (Rel); \
Old_Contents = (*Old_Address); \
(Mem_Base [(Fre)++]) = Old_Contents; \
(Mem_Base [(Fre)++]) = (*Old_Address++); \
} \
-}
+} while (0)
-#define Do_Triple(Code, Rel, Fre, Scn, Obj, FObj) \
+#define DO_TRIPLE(Code, Rel, Fre, Scn, Obj, FObj) do \
{ \
Old_Address += (Rel); \
Old_Contents = (*Old_Address); \
(Mem_Base [(Fre)++]) = (*Old_Address++); \
(Mem_Base [(Fre)++]) = (*Old_Address++); \
} \
-}
+} while (0)
-#define Do_Quad(Code, Rel, Fre, Scn, Obj, FObj) \
+#define DO_QUAD(Code, Rel, Fre, Scn, Obj, FObj) do \
{ \
Old_Address += (Rel); \
Old_Contents = (*Old_Address); \
(Mem_Base [(Fre)++]) = (*Old_Address++); \
(Mem_Base [(Fre)++]) = (*Old_Address++); \
} \
-}
+} while (0)
+
+#define DO_RAW_QUAD(Code, Rel, Fre, Scn, Obj, FObj) do \
+{ \
+ Old_Address += (Rel); \
+ Old_Contents = (* Old_Address); \
+ if (BROKEN_HEART_P (Old_Contents)) \
+ (Mem_Base [(Scn)]) = (OBJECT_DATUM (Old_Contents)); \
+ else \
+ { \
+ (*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \
+ (Mem_Base [(Scn)]) = (Fre); \
+ (Mem_Base [(Fre)++]) = Old_Contents; \
+ (Mem_Base [(Fre)++]) = (*Old_Address++); \
+ (Mem_Base [(Fre)++]) = (*Old_Address++); \
+ (Mem_Base [(Fre)++]) = (*Old_Address++); \
+ } \
+} while (0)
\f
-#define Copy_Vector(Scn, Fre) \
+#define COPY_VECTOR(Fre) do \
{ \
fast long len = (OBJECT_DATUM (Old_Contents)); \
(*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \
(Mem_Base [(Fre)++]) = Old_Contents; \
while ((len--) > 0) \
(Mem_Base [(Fre)++]) = (*Old_Address++); \
-}
+} while (0)
-#define Do_Vector(Code, Rel, Fre, Scn, Obj, FObj) \
+#define DO_VECTOR(Code, Rel, Fre, Scn, Obj, FObj) do \
{ \
Old_Address += (Rel); \
Old_Contents = (*Old_Address); \
else \
{ \
(Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre))); \
- Copy_Vector (Scn, Fre); \
+ COPY_VECTOR (Fre); \
} \
-}
+} while (0)
-/* This is a hack to get the cross compiler to work from vaxen to other
- machines and viceversa. */
+/* This is a hack to get the cross compiler to work
+ accross different endianness.
+*/
-#define Do_Inverted_Block(Code, Rel, Fre, Scn, Obj, FObj) \
+#define DO_INVERTED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj) do \
{ \
Old_Address += (Rel); \
Old_Contents = (*Old_Address); \
if ((OBJECT_TYPE (*Old_Address)) != TC_MANIFEST_NM_VECTOR) \
{ \
fprintf (stderr, "%s: Bad compiled code block found.\n", \
- program_name); \
+ program_name); \
quit (1); \
} \
len2 = (OBJECT_DATUM (*Old_Address)); \
while ((len1--) > 0) \
(Mem_Base [(Fre)++]) = (*Old_Address++); \
} \
-}
+} while (0)
\f
#ifdef HAS_COMPILER_SUPPORT
-#define Do_Compiled_Entry(Code, Rel, Fre, Scn, Obj, FObj) \
+#define CHAR_OFFSET(a,b) (((char *) (a)) - ((char *) (b)))
+#define OBJ_OFFSET(a,b) (((SCHEME_OBJECT *) (a)) - ((SCHEME_OBJECT *) (b)))
+
+#define DO_ENTRY_INTERNAL(sub, copy, Code, Rel, Fre, Scn, Obj, FObj) do \
{ \
long offset; \
SCHEME_OBJECT * saved; \
+ \
Old_Address += (Rel); \
saved = Old_Address; \
Get_Compiled_Block (Old_Address, saved); \
Old_Contents = (*Old_Address); \
- (Mem_Base [(Scn)]) = \
- (MAKE_OBJECT \
- (TC_COMPILED_ENTRY, \
- (compiled_entry_pointer - compiled_entry_table))); \
- offset = (((char *) saved) - ((char *) Old_Address)); \
- (*compiled_entry_pointer++) = (LONG_TO_FIXNUM (offset)); \
- /* Base pointer */ \
+ entry_no = (compiled_entry_pointer - compiled_entry_table); \
+ offset = (sub (saved, Old_Address)); \
+ (*compiled_entry_pointer++) = (LONG_TO_UNSIGNED_FIXNUM (offset)); \
if (BROKEN_HEART_P (Old_Contents)) \
(*compiled_entry_pointer++) = \
(MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \
else \
- { \
- (*compiled_entry_pointer++) = \
- (MAKE_OBJECT_FROM_OBJECTS (This, (Fre))); \
- Copy_Vector (Scn, Fre); \
- } \
+ { \
+ (*compiled_entry_pointer++) = \
+ (MAKE_OBJECT_FROM_OBJECTS (This, (Fre))); \
+ copy (Fre); \
+ } \
+} while (0)
+
+#define DO_COMPILED_ENTRY(Code, Rel, Fre, Scn, Obj, FObj) \
+ DO_ENTRY_INTERNAL(CHAR_OFFSET, COPY_VECTOR, \
+ Code, Rel, Fre, Scn, Obj, FObj)
+
+#define DO_C_COMPILED_ENTRY(Code, Rel, Fre, Scn, Obj, FObj) \
+ DO_ENTRY_INTERNAL(OBJ_OFFSET, COPY_C_COMPILED_BLOCK, \
+ Code, Rel, Fre, Scn, Obj, FObj)
+
+#define DO_C_COMPILED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj) do \
+{ \
+ Old_Address += (Rel); \
+ Old_Contents = (* Old_Address); \
+ if (BROKEN_HEART_P (Old_Contents)) \
+ (Mem_Base [(Scn)]) = \
+ (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \
+ else \
+ { \
+ (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre))); \
+ COPY_C_COMPILED_BLOCK (Fre); \
+ } \
+} while (0)
+\f
+/* This depends on the fact that a compiled code block has an NMV
+ header in the first or second words.
+ */
+
+long
+DEFUN (copy_c_compiled_block, (Fre, Old_Contents, Old_Address),
+ long Fre AND SCHEME_OBJECT Old_Contents AND SCHEME_OBJECT * Old_Address)
+{
+ SCHEME_OBJECT preserved_nmv, preserved_loc;
+ SCHEME_OBJECT nmv_replacement
+ = (MAKE_OBJECT (TC_BROKEN_HEART,
+ (compiled_block_pointer
+ - compiled_block_table)));
+ fast long len = (OBJECT_DATUM (Old_Contents));
+
+ *Old_Address++ = (MAKE_BROKEN_HEART (Fre));
+ if ((OBJECT_TYPE (Old_Contents)) != TC_MANIFEST_CLOSURE)
+ {
+ if ((OBJECT_TYPE (Old_Contents)) == TC_MANIFEST_NM_VECTOR)
+ {
+ preserved_nmv = Old_Contents;
+ preserved_loc = (LONG_TO_UNSIGNED_FIXNUM (Fre));
+ Old_Contents = nmv_replacement;
+ }
+ else if ((OBJECT_TYPE (*Old_Address)) == TC_MANIFEST_NM_VECTOR)
+ {
+ preserved_nmv = *Old_Address;
+ preserved_loc = (LONG_TO_UNSIGNED_FIXNUM ((Fre) + 1));
+ *Old_Address = nmv_replacement;
+ }
+ else
+ {
+ fprintf (stderr,
+ "%s: Improperly formatted C-compiled code block.\n",
+ program_name);
+ quit (1);
+ }
+
+ *compiled_block_pointer++ = preserved_loc;
+ *compiled_block_pointer++ = preserved_nmv;
+ }
+
+ (Mem_Base [(Fre)++]) = Old_Contents;
+ while ((len--) > 0)
+ (Mem_Base [(Fre)++]) = (*Old_Address++);
+ return (Fre);
}
+#define COPY_C_COMPILED_BLOCK(Fre) do \
+{ \
+ Fre = copy_c_compiled_block (Fre, Old_Contents, Old_Address); \
+} while (0)
+
#else /* no HAS_COMPILER_SUPPORT */
-#define Do_Compiled_Entry(Code, Rel, Fre, Scn, Obj, FObj) \
+#define DO_COMPILED_ENTRY(Code, Rel, Fre, Scn, Obj, FObj) do \
{ \
fprintf \
(stderr, \
- "%s: Invoking Do_Compiled_Entry with no compiler support!\n", \
+ "%s: Invoking DO_COMPILED_ENTRY with no compiler support!\n", \
program_name); \
quit (1); \
-}
+} while (0)
+
+#define DO_C_COMPILED_ENTRY DO_COMPILED_ENTRY
+
+#define DO_C_COMPILED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj) do \
+{ \
+ fprintf \
+ (stderr, \
+ "%s: Invoking DO_C_COMPILED_BLOCK with no compiler support!\n", \
+ program_name); \
+ quit (1); \
+} while (0)
#endif /* HAS_COMPILER_SUPPORT */
\f
+/* Constant/Pure space utilities */
+
+static SCHEME_OBJECT *
+DEFUN (find_constant_top, (constant_space, count),
+ SCHEME_OBJECT * constant_space AND unsigned long count)
+{
+ SCHEME_OBJECT pattern = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0));
+ SCHEME_OBJECT * limit = (constant_space + count);
+
+ while (((* (limit - 1)) == pattern)
+ && (limit > constant_space))
+ limit -= 1;
+ return (limit);
+}
+
+static Boolean
+DEFUN (address_in_pure_space, (addr), SCHEME_OBJECT * addr)
+{
+ Boolean result = false;
+ SCHEME_OBJECT * where, * low_constant;
+
+ low_constant = Constant_Space;
+ where = (Constant_Top - 1);
+
+ while (where >= low_constant)
+ {
+ where -= (1 + (OBJECT_DATUM (* where)));
+ if (where < addr)
+ {
+ where += 1; /* block start */
+ result = (addr <= (where + (OBJECT_DATUM (* where))));
+ break;
+ }
+ }
+ return (result);
+}
+\f
/* Common Pointer Code */
-#define Do_Pointer(Scn, Action) \
+#define DO_POINTER(Scn, Action) do \
{ \
long the_datum; \
\
Old_Address = (OBJECT_ADDRESS (This)); \
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); \
- } \
- /* 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); \
- } \
- */ \
+ if ((the_datum >= Heap_Base) && (the_datum < Dumped_Heap_Top)) \
+ Action (HEAP_CODE, Heap_Relocation, Free, \
+ Scn, Objects, Free_Objects); \
+ else if ((the_datum >= Const_Base) \
+ && (the_datum < Dumped_Constant_Top)) \
+ { \
+ SCHEME_OBJECT * new_addr; \
+ \
+ new_addr = (Old_Address + Constant_Relocation); \
+ if (address_in_pure_space (new_addr)) \
+ Action (PURE_CODE, Constant_Relocation, Free_Pure, \
+ Scn, Pure_Objects, Free_Pobjects); \
+ else \
+ Action (CONSTANT_CODE, Constant_Relocation, Free_Constant, \
+ Scn, Constant_Objects, Free_Cobjects); \
+ } \
else \
- { \
- out_of_range_pointer (This); \
- } \
+ out_of_range_pointer (This); \
(Scn) += 1; \
- break; \
-}
+} while (0)
+
+#define DO_RAW_POINTER(ptr, Scn, Action) do \
+{ \
+ long the_datum; \
+ \
+ Old_Address = (SCHEME_ADDR_TO_ADDR (ptr)); \
+ the_datum = (ADDRESS_TO_DATUM (Old_Address)); \
+ if ((the_datum >= Heap_Base) && (the_datum < Dumped_Heap_Top)) \
+ Action (HEAP_CODE, Heap_Relocation, Free, \
+ Scn, Objects, Free_Objects); \
+ else if ((the_datum >= Const_Base) \
+ && (the_datum < Dumped_Constant_Top)) \
+ { \
+ SCHEME_OBJECT * new_addr; \
+ \
+ new_addr = (Old_Address + Constant_Relocation); \
+ if (address_in_pure_space (new_addr)) \
+ Action (PURE_CODE, Constant_Relocation, Free_Pure, \
+ Scn, Pure_Objects, Free_Pobjects); \
+ else \
+ Action (CONSTANT_CODE, Constant_Relocation, Free_Constant, \
+ Scn, Constant_Objects, Free_Cobjects); \
+ } \
+ else \
+ out_of_range_pointer (This); \
+} while (0)
\f
-void
-DEFUN (out_of_range_pointer, (ptr),
- SCHEME_OBJECT ptr)
+static void
+DEFUN (out_of_range_pointer, (ptr), SCHEME_OBJECT 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);
+ 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);
}
-SCHEME_OBJECT *
-DEFUN (relocate, (object),
- SCHEME_OBJECT object)
+static SCHEME_OBJECT *
+DEFUN (relocate, (object), SCHEME_OBJECT object)
{
long the_datum;
- SCHEME_OBJECT *result;
+ SCHEME_OBJECT * result;
- result = OBJECT_ADDRESS (object);
- the_datum = OBJECT_DATUM (object);
+ result = (OBJECT_ADDRESS (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) &&
+ else if ((the_datum >= Const_Base) &&
(the_datum < Dumped_Constant_Top))
- result += Constant_Relocation;
-
-#endif /* false */
-
+ result += Constant_Relocation;
else
- out_of_range_pointer(object);
+ out_of_range_pointer (object);
return (result);
}
\f
#define PRIMITIVE_UPGRADE_SPACE 2048
static SCHEME_OBJECT
- *internal_renumber_table,
- *external_renumber_table,
- *external_prim_name_table;
+ * internal_renumber_table,
+ * external_renumber_table,
+ * external_prim_name_table;
static Boolean
found_ext_prims = false;
-SCHEME_OBJECT
-DEFUN (upgrade_primitive, (prim),
- SCHEME_OBJECT prim)
+static SCHEME_OBJECT
+DEFUN (upgrade_primitive, (prim), SCHEME_OBJECT prim)
{
long the_datum, the_type, new_type, code;
SCHEME_OBJECT new;
- the_datum = OBJECT_DATUM (prim);
- the_type = OBJECT_TYPE (prim);
+ the_datum = (OBJECT_DATUM (prim));
+ the_type = (OBJECT_TYPE (prim));
if (the_type != TC_PRIMITIVE_EXTERNAL)
{
code = the_datum;
code = (the_datum + (MAX_BUILTIN_PRIMITIVE + 1));
new_type = TC_PRIMITIVE;
}
-\f
+
new = internal_renumber_table[code];
- if (new == SHARP_F)
+ if (new != SHARP_F)
+ return (OBJECT_NEW_TYPE (new_type, new));
+ else
{
/*
This does not need to check for overflow because the worst case
external_renumber_table[Primitive_Table_Length] = prim;
Primitive_Table_Length += 1;
if (the_type == TC_PRIMITIVE_EXTERNAL)
- {
NPChars +=
- STRING_LENGTH_TO_LONG((((SCHEME_OBJECT *)
- (external_prim_name_table[the_datum]))
- [STRING_LENGTH_INDEX]));
- }
+ STRING_LENGTH_TO_LONG ((((SCHEME_OBJECT *)
+ (external_prim_name_table[the_datum]))
+ [STRING_LENGTH_INDEX]));
else
- {
- NPChars += strlen(builtin_prim_name_table[the_datum]);
- }
+ NPChars += strlen (builtin_prim_name_table[the_datum]);
return (new);
}
- else
- {
- return (OBJECT_NEW_TYPE (new_type, new));
- }
}
\f
-SCHEME_OBJECT *
-DEFUN (setup_primitive_upgrade, (Heap),
- SCHEME_OBJECT * Heap)
+static SCHEME_OBJECT *
+DEFUN (setup_primitive_upgrade, (Heap), SCHEME_OBJECT * Heap)
{
fast long count, length;
- SCHEME_OBJECT *old_prims_vector;
+ SCHEME_OBJECT * old_prims_vector;
internal_renumber_table = &Heap[0];
external_renumber_table =
external_prim_name_table =
&external_renumber_table[PRIMITIVE_UPGRADE_SPACE];
- old_prims_vector = relocate(Ext_Prim_Vector);
+ old_prims_vector = (relocate (Ext_Prim_Vector));
if (*old_prims_vector == SHARP_F)
- {
length = 0;
- }
else
{
- old_prims_vector = relocate(*old_prims_vector);
- length = OBJECT_DATUM (*old_prims_vector);
+ old_prims_vector = (relocate (*old_prims_vector));
+ length = (OBJECT_DATUM (*old_prims_vector));
old_prims_vector += VECTOR_DATA;
for (count = 0; count < length; count += 1)
{
SCHEME_OBJECT *temp;
/* symbol */
- temp = relocate(old_prims_vector[count]);
+ temp = (relocate (old_prims_vector[count]));
/* string */
- temp = relocate(temp[SYMBOL_NAME]);
+ temp = (relocate (temp[SYMBOL_NAME]));
external_prim_name_table[count] = ((SCHEME_OBJECT) temp);
}
}
length += (MAX_BUILTIN_PRIMITIVE + 1);
if (length > PRIMITIVE_UPGRADE_SPACE)
{
- fprintf(stderr, "%s: Too many primitives.\n", program_name);
- fprintf(stderr,
- "Increase PRIMITIVE_UPGRADE_SPACE and recompile %s.\n",
- program_name);
- quit(1);
+ fprintf (stderr, "%s: Too many primitives.\n", program_name);
+ fprintf (stderr,
+ "Increase PRIMITIVE_UPGRADE_SPACE and recompile %s.\n",
+ program_name);
+ quit (1);
}
for (count = 0; count < length; count += 1)
- {
internal_renumber_table[count] = SHARP_F;
- }
+
NPChars = 0;
return (&external_prim_name_table[PRIMITIVE_UPGRADE_SPACE]);
}
\f
/* Processing of a single area */
-#define Do_Area(Code, Area, Bound, Obj, FObj) \
- Process_Area (Code, &Area, &Bound, &Obj, &FObj)
+#define DO_AREA(code, Area, Bound, Obj, FObj) \
+ Process_Area (code, &Area, &Bound, &Obj, &FObj)
-void
+static void
DEFUN (Process_Area, (Code, Area, Bound, Obj, FObj),
- int Code AND
- fast long *Area AND
- fast long *Bound AND
- fast long *Obj AND
- fast SCHEME_OBJECT **FObj)
+ int Code
+ AND fast long * Area
+ AND fast long * Bound
+ AND fast long * Obj
+ AND fast SCHEME_OBJECT ** FObj)
{
- fast SCHEME_OBJECT This, *Old_Address, Old_Contents;
+ unsigned long entry_no;
+ fast SCHEME_OBJECT This, * Old_Address, Old_Contents;
- while(*Area != *Bound)
+ while (*Area != *Bound)
{
This = Mem_Base[*Area];
#ifdef PRIMITIVE_EXTERNAL_REUSED
if (upgrade_primitives_p &&
- (OBJECT_TYPE (This) == TC_PRIMITIVE_EXTERNAL))
+ ((OBJECT_TYPE (This)) == TC_PRIMITIVE_EXTERNAL))
{
- Mem_Base[*Area] = upgrade_primitive(This);
+ Mem_Base[*Area] = (upgrade_primitive (This));
*Area += 1;
continue;
}
#endif /* PRIMITIVE_EXTERNAL_REUSED */
- Switch_by_GC_Type(This)
+ Switch_by_GC_Type (This)
{
#ifndef PRIMITIVE_EXTERNAL_REUSED
case TC_PRIMITIVE:
case TC_PCOMB0:
if (upgrade_primitives_p)
- {
- Mem_Base[*Area] = upgrade_primitive(This);
- }
+ Mem_Base[*Area] = (upgrade_primitive (This));
*Area += 1;
break;
\f
i = (OBJECT_DATUM (This));
*Area += 1;
for ( ; --i >= 0; *Area += 1)
- {
Mem_Base[*Area] = SHARP_F;
- }
break;
}
else if (!allow_nmv_p)
{
- fprintf(stderr, "%s: File is not portable: NMH found\n",
- program_name);
+ if (((OBJECT_DATUM (This)) != 0) && warn_portable_p)
+ {
+ warn_portable_p = false;
+ fprintf (stderr, "%s: File is not portable: NMH found\n",
+ program_name);
+ }
}
- *Area += (1 + OBJECT_DATUM (This));
+ *Area += (1 + (OBJECT_DATUM (This)));
break;
case TC_BROKEN_HEART:
- /* [Broken Heart 0] is the cdr of fasdumped symbols. */
- if (OBJECT_DATUM (This) != 0)
+ {
+ /* [Broken Heart | 0] is the cdr of fasdumped symbols. */
+ /* [Broken Heart | x > 0] indicates a C compiled block. */
+ unsigned long the_datum = (OBJECT_DATUM (This));
+
+ if (the_datum == 0)
{
- fprintf(stderr, "%s: Broken Heart found in scan.\n",
- program_name);
- quit(1);
+ *Area += 1;
+ break;
+ }
+ else if ((! allow_compiled_p)
+ || (! c_compiled_p)
+ || ((OBJECT_DATUM (This))
+ >= (compiled_block_pointer - compiled_block_table))
+ || ((*Area)
+ != (UNSIGNED_FIXNUM_TO_LONG
+ (compiled_block_table [the_datum]))))
+ {
+ fprintf (stderr, "%s: Broken Heart found in scan.\n",
+ program_name);
+ quit (1);
+ }
+ else
+ {
+ *Area += (1 + (OBJECT_DATUM (compiled_block_table [1 + the_datum])));
+ break;
}
- *Area += 1;
- break;
-
- case TC_MANIFEST_CLOSURE:
- case TC_LINKAGE_SECTION:
- {
- fprintf(stderr,
- "%s: File contains linked compiled code.\n",
- program_name);
- quit(1);
}
-
-
- case TC_COMPILED_CODE_BLOCK:
- compiled_p = true;
- if (vax_invert_p)
+\f
+ case TC_MANIFEST_CLOSURE:
+ if ((! allow_compiled_p) || (! c_compiled_p))
+ {
+ fprintf (stderr,
+ "%s: File contains compiled closures.\n",
+ program_name);
+ quit (1);
+ }
+ else
{
- Do_Pointer(*Area, Do_Inverted_Block);
+ char * word_ptr;
+ long count, address;
+ SCHEME_OBJECT * area_end, * scan, * i_scan;
+
+ i_scan = (&Mem_Base[*Area]);
+ START_CLOSURE_RELOCATION (i_scan);
+ scan = (i_scan + 1);
+ count = (MANIFEST_CLOSURE_COUNT (scan));
+ word_ptr = (FIRST_MANIFEST_CLOSURE_ENTRY (scan));
+ area_end = (MANIFEST_CLOSURE_END (scan, count));
+
+ while ((--count) >= 0)
+ {
+ scan = ((SCHEME_OBJECT *) (word_ptr));
+ word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr));
+ EXTRACT_CLOSURE_ENTRY_ADDRESS (address, scan);
+ DO_RAW_POINTER (address, *Area, DO_C_COMPILED_ENTRY);
+ STORE_CLOSURE_ENTRY_ADDRESS (entry_no, scan);
+ }
+
+ END_CLOSURE_RELOCATION (area_end);
+ *Area += (1 + (area_end - i_scan));
+ break;
}
- else if (allow_compiled_p)
+\f
+ case TC_LINKAGE_SECTION:
+ if ((! allow_compiled_p) || (! c_compiled_p))
{
- Do_Pointer(*Area, Do_Vector);
+ fprintf (stderr,
+ "%s: File contains linked compiled code.\n",
+ program_name);
+ quit (1);
}
else
{
- fprintf(stderr,
- "%s: File contains compiled code.\n",
- program_name);
- quit(1);
+ switch (READ_LINKAGE_KIND (This))
+ {
+ case REFERENCE_LINKAGE_KIND:
+ case ASSIGNMENT_LINKAGE_KIND:
+ {
+ long count = (READ_CACHE_LINKAGE_COUNT (This));
+
+ *Area += 1;
+ while (--count >= 0)
+ {
+ DO_RAW_POINTER (Mem_Base[*Area], *Area, DO_RAW_QUAD);
+ *Area += 1;
+ }
+ break;
+ }
+
+ case OPERATOR_LINKAGE_KIND:
+ case GLOBAL_OPERATOR_LINKAGE_KIND:
+ {
+ char * word_ptr;
+ long count, address;
+ SCHEME_OBJECT * area_end, * scan, * i_scan;
+
+ i_scan = (&Mem_Base[*Area]);
+ START_OPERATOR_RELOCATION (i_scan);
+ count = (READ_OPERATOR_LINKAGE_COUNT (This));
+ word_ptr = (FIRST_OPERATOR_LINKAGE_ENTRY (i_scan));
+ area_end = (END_OPERATOR_LINKAGE_AREA (i_scan, count));
+
+ while (--count >= 0)
+ {
+ scan = ((SCHEME_OBJECT *) word_ptr);
+ word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr));
+ EXTRACT_OPERATOR_LINKAGE_ADDRESS (address, scan);
+ DO_RAW_POINTER (address, *Area, DO_C_COMPILED_ENTRY);
+ STORE_OPERATOR_LINKAGE_ADDRESS (entry_no, scan);
+ }
+ END_OPERATOR_RELOCATION (area_end);
+ *Area += (1 + (area_end - i_scan));
+ break;
+ }
+
+ default:
+ {
+ fprintf (stderr, "%s: Unknown linkage kind.\n",
+ program_name);
+ quit (1);
+ }
+ }
+ break;
}
+\f
+ case TC_COMPILED_CODE_BLOCK:
+ compiled_p = true;
+ if (! allow_compiled_p)
+ {
+ fprintf (stderr,
+ "%s: File contains compiled code.\n",
+ program_name);
+ quit (1);
+ }
+ else if (c_compiled_p)
+ DO_POINTER (*Area, DO_C_COMPILED_BLOCK);
+ else if (endian_invert_p)
+ DO_POINTER (*Area, DO_INVERTED_BLOCK);
+ else
+ DO_POINTER (*Area, DO_VECTOR);
+ break;
case_compiled_entry_point:
compiled_p = true;
- if (!allow_compiled_p)
+ if (! allow_compiled_p)
{
- fprintf(stderr,
- "%s: File contains compiled code.\n",
- program_name);
- quit(1);
+ fprintf (stderr,
+ "%s: File contains compiled code.\n",
+ program_name);
+ quit (1);
}
- Do_Pointer(*Area, Do_Compiled_Entry);
+ else if (c_compiled_p)
+ DO_POINTER (*Area, DO_C_COMPILED_ENTRY);
+ else
+ DO_POINTER (*Area, DO_COMPILED_ENTRY);
+ Mem_Base[*Area - 1] = (MAKE_OBJECT (TC_COMPILED_ENTRY, entry_no));
+ break;
case TC_STACK_ENVIRONMENT:
- fprintf(stderr,
- "%s: File contains stack environments.\n",
- program_name);
- quit(1);
+ if (! allow_bands_p)
+ {
+ fprintf (stderr,
+ "%s: File contains stack environments.\n",
+ program_name);
+ quit (1);
+ }
+ else
+ {
+ unsigned long delta;
+
+ delta = (((SCHEME_OBJECT *) Dumped_Stack_Top)
+ - ((SCHEME_OBJECT *) (OBJECT_DATUM (This))));
+ if (delta > Max_Stack_Offset)
+ Max_Stack_Offset = delta;
+ Mem_Base[*Area] = (MAKE_OBJECT (TC_STACK_ENVIRONMENT, delta));
+ *Area += 1;
+ }
+ break;
\f
case TC_FIXNUM:
NIntegers += 1;
{
long kind;
- kind = OBJECT_DATUM (This);
+ kind = (OBJECT_DATUM (This));
if (upgrade_traps_p)
{
*Area += 1;
break;
}
- fprintf(stderr,
- "%s: Bad old unassigned object. 0x%x.\n",
- program_name, This);
- quit(1);
+ fprintf (stderr,
+ "%s: Bad old unassigned object. 0x%x.\n",
+ program_name, This);
+ quit (1);
}
if (kind <= TRAP_MAX_IMMEDIATE)
{
\f
case TC_WEAK_CONS:
case_Pair:
- Do_Pointer(*Area, Do_Pair);
+ DO_POINTER (*Area, DO_PAIR);
+ break;
case_Cell:
- Do_Pointer(*Area, Do_Cell);
+ DO_POINTER (*Area, DO_CELL);
+ break;
case TC_VARIABLE:
case_Triple:
- Do_Pointer(*Area, Do_Triple);
+ DO_POINTER (*Area, DO_TRIPLE);
+ break;
+
+ case_Quadruple:
+ DO_POINTER (*Area, DO_QUAD);
+ break;
case TC_BIG_FLONUM:
- Do_Pointer(*Area, Do_Flonum);
+ DO_POINTER (*Area, DO_FLONUM);
+ break;
case TC_BIG_FIXNUM:
- Do_Pointer(*Area, Do_Bignum);
+ DO_POINTER (*Area, DO_BIGNUM);
+ break;
case TC_CHARACTER_STRING:
- Do_Pointer(*Area, Do_String);
+ DO_POINTER (*Area, DO_STRING);
+ break;
case TC_ENVIRONMENT:
if (upgrade_traps_p)
{
- fprintf(stderr,
- "%s: Cannot upgrade environments.\n",
- program_name);
- quit(1);
+ fprintf (stderr,
+ "%s: Cannot upgrade environments.\n",
+ program_name);
+ quit (1);
}
/* Fall through */
case TC_FUTURE:
case_simple_Vector:
if (BIT_STRING_P (This))
- {
- Do_Pointer(*Area, Do_Bit_String);
- }
+ DO_POINTER (*Area, DO_BIT_STRING);
else
- {
- Do_Pointer(*Area, Do_Vector);
- }
+ DO_POINTER (*Area, DO_VECTOR);
+ break;
default:
Bad_Type:
- fprintf(stderr, "%s: Unknown Type Code 0x%x found.\n",
- program_name, OBJECT_TYPE (This));
- quit(1);
+ fprintf (stderr, "%s: Unknown Type Code 0x%x found.\n",
+ program_name, (OBJECT_TYPE (This)));
+ quit (1);
}
}
}
\f
/* Output procedures */
-void
-DEFUN (print_external_objects, (from, count),
- fast SCHEME_OBJECT *from AND
- fast long count)
+static void
+DEFUN (print_binary_objects, (from, count),
+ fast SCHEME_OBJECT * from AND fast long count)
{
while (--count >= 0)
{
- switch(OBJECT_TYPE (*from))
+ switch (OBJECT_TYPE (* from))
{
case TC_FIXNUM:
print_a_fixnum (FIXNUM_TO_LONG (*from));
break;
case TC_BIG_FLONUM:
- print_a_flonum (*((double *) (from + 1)));
+ print_a_flonum (from + 1);
from += (1 + float_to_pointer);
break;
#endif /* FLOATING_ALIGNMENT */
default:
- fprintf(stderr,
- "%s: Bad Object to print externally %lx\n",
- program_name, *from);
- quit(1);
+ fprintf (stderr,
+ "%s: Bad Binary Object to print %lx\n",
+ program_name, *from);
+ quit (1);
}
}
return;
}
\f
-void
+static void
+DEFUN (print_c_compiled_entries, (entry, count),
+ SCHEME_OBJECT * entry AND unsigned long count)
+{
+ while (count > 0)
+ {
+ unsigned long entry_index = (* ((unsigned long *) entry));
+ unsigned long format = (COMPILED_ENTRY_FORMAT_WORD (entry));
+ SCHEME_OBJECT * block;
+
+ Get_Compiled_Block (block, entry);
+ fprintf (portable_file, "%02x %lx %ld %ld %lx\n",
+ TC_C_COMPILED_TAG,
+ ((long) C_COMPILED_ENTRY_FORMAT),
+ ((long) (FORMAT_WORD_LOW_BYTE (format))),
+ ((long) (FORMAT_WORD_HIGH_BYTE (format))),
+ ((long) (entry - block)));
+ fprintf (portable_file, "%02x %lx %lx\n",
+ TC_C_COMPILED_TAG,
+ ((long) C_COMPILED_ENTRY_CODE),
+ entry_index);
+ count -= 1;
+ entry += 2;
+ }
+ return;
+}
+
+static void
+DEFUN (print_c_closure_entries, (entry, count),
+ SCHEME_OBJECT * entry AND unsigned long count)
+{
+ while (count > 0)
+ {
+ unsigned long entry_index = (* ((unsigned long *) entry));
+ unsigned long format = (COMPILED_ENTRY_FORMAT_WORD (entry));
+ SCHEME_OBJECT * block, base;
+ unsigned long entry_number;
+ long offset;
+
+ EXTRACT_CLOSURE_ENTRY_ADDRESS (entry_number, entry);
+ offset = (UNSIGNED_FIXNUM_TO_LONG
+ (compiled_entry_table [entry_number]));
+ base = compiled_entry_table[entry_number + 1];
+
+ Get_Compiled_Block (block, entry);
+ fprintf (portable_file, "%02x %lx %ld %ld %lx\n",
+ TC_C_COMPILED_TAG,
+ ((long) C_COMPILED_ENTRY_FORMAT),
+ ((long) (FORMAT_WORD_LOW_BYTE (format))),
+ ((long) (FORMAT_WORD_HIGH_BYTE (format))),
+ ((long) (entry - block)));
+ fprintf (portable_file, "%02x %lx %lx\n",
+ TC_C_COMPILED_TAG,
+ ((long) C_COMPILED_ENTRY_CODE),
+ entry_index);
+ fprintf (portable_file, "%02x %lx %lx %lx\n",
+ TC_C_COMPILED_TAG,
+ ((long) C_COMPILED_EXECUTE_ENTRY),
+ offset,
+ (OBJECT_DATUM (base)));
+ count -= 1;
+ entry += 3;
+ }
+ return;
+}
+\f
+static void
DEFUN (print_objects, (from, to),
- fast SCHEME_OBJECT *from AND
- fast SCHEME_OBJECT *to)
+ fast SCHEME_OBJECT * from AND fast SCHEME_OBJECT * to)
{
fast long the_datum, the_type;
- while(from < to)
+ while (from < to)
{
-
- the_type = OBJECT_TYPE (*from);
- the_datum = OBJECT_DATUM (*from);
+ the_type = (OBJECT_TYPE (* from));
+ the_datum = (OBJECT_DATUM (* from));
from += 1;
- if (the_type == TC_MANIFEST_NM_VECTOR)
+ switch (the_type)
{
- fprintf(portable_file, "%02x %lx\n", the_type, the_datum);
- while (--the_datum >= 0)
+ case TC_MANIFEST_NM_VECTOR:
{
- fprintf(portable_file, "%lx\n", ((unsigned long) *from++));
+ fprintf (portable_file, "%02x %lx\n", the_type, the_datum);
+ while (--the_datum >= 0)
+ fprintf (portable_file, "%lx\n", ((unsigned long) *from++));
+ break;
}
- }
- else if (the_type == TC_COMPILED_ENTRY)
- {
- SCHEME_OBJECT base;
- long offset;
- offset = (FIXNUM_TO_LONG (compiled_entry_table [the_datum]));
- base = compiled_entry_table[the_datum + 1];
+ case TC_COMPILED_ENTRY:
+ {
+ SCHEME_OBJECT base;
+ long offset;
- fprintf(portable_file, "%02x %lx %02x %lx\n",
- TC_COMPILED_ENTRY, offset,
- OBJECT_TYPE (base), OBJECT_DATUM (base));
- }
- else
- {
- fprintf(portable_file, "%02x %lx\n", the_type, the_datum);
+ offset = (UNSIGNED_FIXNUM_TO_LONG (compiled_entry_table [the_datum]));
+ base = compiled_entry_table[the_datum + 1];
+
+ fprintf (portable_file, "%02x %lx %02x %lx\n",
+ TC_COMPILED_ENTRY, offset,
+ (OBJECT_TYPE (base)), (OBJECT_DATUM (base)));
+ break;
+ }
+\f
+ case TC_LINKAGE_SECTION:
+ {
+ SCHEME_OBJECT header = (from[-1]);
+
+ switch (READ_LINKAGE_KIND (header))
+ {
+ case REFERENCE_LINKAGE_KIND:
+ case ASSIGNMENT_LINKAGE_KIND:
+ {
+ long count = (READ_CACHE_LINKAGE_COUNT (header));
+
+ fprintf (portable_file, "%02x %lx %lx %lx\n",
+ TC_C_COMPILED_TAG,
+ ((long) C_COMPILED_LINKAGE_HEADER),
+ ((long) (READ_LINKAGE_KIND (header))),
+ ((long) count));
+ while (--count >= 0)
+ {
+ unsigned long quad = ((unsigned long) *from++);
+
+ fprintf (portable_file, "%02x %lx %lx\n",
+ TC_C_COMPILED_TAG,
+ ((long) C_COMPILED_RAW_QUAD),
+ quad);
+ }
+ break;
+ }
+
+ case OPERATOR_LINKAGE_KIND:
+ case GLOBAL_OPERATOR_LINKAGE_KIND:
+ {
+ char * word_ptr;
+ long count, address;
+ SCHEME_OBJECT This, * area_end, * scan, * i_scan;
+
+ i_scan = (from - 1);
+ This = *i_scan;
+ START_OPERATOR_RELOCATION (i_scan);
+ count = (READ_OPERATOR_LINKAGE_COUNT (This));
+ word_ptr = (FIRST_OPERATOR_LINKAGE_ENTRY (i_scan));
+ area_end = (END_OPERATOR_LINKAGE_AREA (i_scan, count));
+
+ fprintf (portable_file, "%02x %lx %lx %lx\n",
+ TC_C_COMPILED_TAG,
+ ((long) C_COMPILED_LINKAGE_HEADER),
+ ((long) (READ_LINKAGE_KIND (header))),
+ ((long) count));
+
+ while (--count >= 0)
+ {
+ SCHEME_OBJECT base;
+ long arity, address, offset;
+
+ scan = ((SCHEME_OBJECT *) word_ptr);
+ word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr));
+ EXTRACT_OPERATOR_LINKAGE_ADDRESS (address, scan);
+ EXTRACT_EXECUTE_CACHE_ARITY (arity, scan);
+
+ offset = (UNSIGNED_FIXNUM_TO_LONG
+ (compiled_entry_table[address]));
+ base = compiled_entry_table[address + 1];
+
+ fprintf (portable_file, "%02x %lx %lx %lx\n",
+ TC_C_COMPILED_TAG,
+ ((long) C_COMPILED_EXECUTE_ENTRY),
+ offset,
+ (OBJECT_DATUM (base)));
+ fprintf (portable_file, "%02x %lx %lx\n",
+ TC_C_COMPILED_TAG,
+ ((long) C_COMPILED_EXECUTE_ARITY),
+ arity);
+ }
+ END_OPERATOR_RELOCATION (area_end);
+ from += (area_end - i_scan);
+ break;
+ }
+
+ default:
+ {
+ fprintf (stderr, "%s: Unknown linkage kind.\n",
+ program_name);
+ quit (1);
+ }
+ }
+ break;
+ }
+\f
+ case TC_MANIFEST_CLOSURE:
+ {
+ unsigned long nentries;
+ SCHEME_OBJECT * entry, * area_end;
+
+ fprintf (portable_file, "%02x %lx %lx\n",
+ TC_C_COMPILED_TAG,
+ ((long) C_COMPILED_CLOSURE_HEADER),
+ the_datum);
+
+ nentries = (MANIFEST_CLOSURE_COUNT (from));
+ entry = ((SCHEME_OBJECT *) (FIRST_MANIFEST_CLOSURE_ENTRY (from)));
+ area_end = (MANIFEST_CLOSURE_END (from, nentries));
+
+ if (entry != (from + 1))
+ fprintf (portable_file, "%02x %lx %lx\n",
+ TC_C_COMPILED_TAG,
+ ((long) C_COMPILED_MULTI_CLOSURE_HEADER),
+ nentries);
+
+ print_c_closure_entries (entry, nentries);
+ from = (area_end + 1);
+ break;
+ }
+
+ case TC_BROKEN_HEART:
+ if (the_datum == 0)
+ goto ordinary_object;
+ /* An NMV header fending off C-compiled code descriptors.
+ This knows in detail the format
+ */
+
+ {
+ unsigned long nmv_length;
+ SCHEME_OBJECT * entry;
+
+ nmv_length = (OBJECT_DATUM (compiled_block_table [the_datum + 1]));
+ fprintf (portable_file, "%02x %lx %lx\n",
+ TC_C_COMPILED_TAG,
+ ((long) C_COMPILED_FAKE_NMV),
+ nmv_length);
+
+ print_c_compiled_entries (from + 1, (nmv_length / 2));
+ from += nmv_length;
+ break;
+ }
+
+ default:
+ ordinary_object:
+ {
+ fprintf (portable_file, "%02x %lx\n", the_type, the_datum);
+ break;
+ }
}
}
return;
\f
/* Debugging Aids and Consistency Checks */
-#ifdef DEBUG
+#define DEBUG 0
-#define DEBUGGING(action) action
+#if (DEBUG > 0)
#define WHEN(condition, message) when(condition, message)
-void
-DEFUN (when, (what, message),
- Boolean what AND
- char *message)
+static void
+DEFUN (when, (what, message), Boolean what AND char * message)
{
if (what)
{
- fprintf(stderr, "%s: Inconsistency: %s!\n",
- program_name, (message));
- quit(1);
+ fprintf (stderr, "%s: Inconsistency: %s!\n",
+ program_name, (message));
+ quit (1);
}
return;
}
-#define WRITE_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 /* DEBUG <= 0 */
-#else /* not DEBUG */
+#define WHEN(what, message) do { } while (0)
-#define DEBUGGING(action)
+#endif /* DEBUG > 0 */
-#define WHEN(what, message)
+#if (DEBUG > 1)
-#define WRITE_HEADER(name, format, obj) \
+#define DEBUGGING1(action) action
+
+#define WRITE_HEADER(name, format, obj) do \
{ \
- 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"); \
+} while (0)
-#endif /* DEBUG */
+#else /* DEBUG <= 1 */
+
+#define DEBUGGING1(action) do { } while (0)
+
+#define WRITE_HEADER(name, format, obj) do \
+{ \
+ fprintf (portable_file, (format), (obj)); \
+ fprintf (portable_file, "\n"); \
+} while (0)
+
+#endif /* DEBUG > 1 */
\f
/* The main program */
-void
+static void
DEFUN_VOID (do_it)
{
while (true)
* Heap,
* Lowest_Allocated_Address,
* Highest_Allocated_Address;
- long Initial_Free;
+ long
+ Heap_Start, Heap_Objects_Start,
+ Constant_Start, Constant_Objects_Start,
+ Pure_Start, Pure_Objects_Start;
switch (Read_Header ())
{
/* NOTREACHED */
}
- if ((Version > FASL_READ_VERSION) ||
- (Version < FASL_OLDEST_VERSION) ||
- (Sub_Version > FASL_READ_SUBVERSION) ||
- (Sub_Version < FASL_OLDEST_SUBVERSION) ||
- ((Machine_Type != FASL_INTERNAL_FORMAT) &&
- (!swap_bytes_p)))
+ if ( (Version > FASL_FORMAT_VERSION)
+ || (Version < FASL_OLDEST_VERSION)
+ || (Sub_Version > FASL_SUBVERSION)
+ || (Sub_Version < FASL_OLDEST_SUBVERSION)
+ || ((Machine_Type != FASL_INTERNAL_FORMAT) && (! swap_bytes_p)))
{
fprintf (stderr, "%s:\n", program_name);
fprintf (stderr,
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))
+ if ((((compiler_processor_type != COMPILER_NONE_TYPE)
+ && (dumped_processor_type != COMPILER_NONE_TYPE)
+ && (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,
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 and bands not currently supported */
+ c_compiled_p = (compiler_processor_type == COMPILER_LOSING_C_TYPE);
+ DEBUGGING1 (fprintf (stderr,
+ "compiler_processor_type = %d; c_compiled_p = %s\n",
+ compiler_processor_type,
+ (c_compiled_p ? "true" : "false")));
- if (band_p)
+ if (band_p && (! allow_bands_p))
{
fprintf (stderr, "%s: Input file is a band.\n", program_name);
quit (1);
}
- if (Const_Count != 0)
+ if ((Const_Count != 0) && (! allow_constant_space_p))
{
fprintf (stderr,
"%s: Input file has a constant space area.\n",
\f
shuffle_bytes_p = swap_bytes_p;
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;
- DEBUGGING (fprintf (stderr,
- "Dumped Heap Base = 0x%08x\n",
- Heap_Base));
+ DEBUGGING1 (fprintf (stderr,
+ "Dumped Heap Base = 0x%08x\n",
+ Heap_Base));
- DEBUGGING (fprintf (stderr,
- "Dumped Constant Base = 0x%08x\n",
- Const_Base));
+ DEBUGGING1 (fprintf (stderr,
+ "Dumped Constant Base = 0x%08x\n",
+ Const_Base));
- DEBUGGING (fprintf (stderr,
- "Dumped Constant Top = 0x%08x\n",
- Dumped_Constant_Top));
+ DEBUGGING1 (fprintf (stderr,
+ "Dumped Constant Top = 0x%08x\n",
+ Dumped_Constant_Top));
- DEBUGGING (fprintf (stderr,
- "Heap Count = %6d\n",
- Heap_Count));
+ DEBUGGING1 (fprintf (stderr,
+ "Heap Count = %6d\n",
+ Heap_Count));
- DEBUGGING (fprintf (stderr,
- "Constant Count = %6d\n",
- Const_Count));
+ DEBUGGING1 (fprintf (stderr,
+ "Constant Count = %6d\n",
+ Const_Count));
\f
{
long Size;
/* This is way larger than needed, but... what the hell? */
- Size = ((TRAP_MAX_IMMEDIATE + 1) +
- ((FLOATING_ALIGNMENT + 1) / (sizeof (SCHEME_OBJECT))) +
- (3 * (Heap_Count + Const_Count)) +
- (NROOTS + 1) +
- (upgrade_primitives_p ?
- (3 * PRIMITIVE_UPGRADE_SPACE) :
- Primitive_Table_Size) +
- (allow_compiled_p ?
- (2 * (Heap_Count + Const_Count)) :
- 0));
+ Size = ((2 * (TRAP_MAX_IMMEDIATE + 1))
+ + (2 * ((FLOATING_ALIGNMENT + 1) / (sizeof (SCHEME_OBJECT))))
+ + (Heap_Count + Const_Count)
+ + (2 * (Heap_Count + (2 * Const_Count)))
+ + (NROOTS + 1)
+ + (upgrade_primitives_p
+ ? (3 * PRIMITIVE_UPGRADE_SPACE)
+ : Primitive_Table_Size) +
+ (allow_compiled_p
+ ? (2 + ((c_compiled_p ? 4 : 2) * (Heap_Count + Const_Count)))
+ : 0)
+ + C_Code_Table_Size);
ALLOCATE_HEAP_SPACE (Size,
Lowest_Allocated_Address,
program_name);
quit (1);
}
- if ((Load_Data (Const_Count, (Heap + Heap_Count))) != Const_Count)
+ Constant_Space = (Heap + Heap_Count);
+ ALIGN_FLOAT (Constant_Space);
+ if ((Load_Data (Const_Count, Constant_Space)) != Const_Count)
{
fprintf (stderr, "%s: Could not load constant space.\n",
program_name);
quit (1);
}
+ Constant_Top = (find_constant_top (Constant_Space, Const_Count));
Heap_Relocation = ((&Heap[0]) - (OBJECT_ADDRESS (Heap_Base)));
- Constant_Relocation = ((&Heap[Heap_Count]) -
+ Constant_Relocation = ((&Constant_Space[0]) -
(OBJECT_ADDRESS (Const_Base)));
+ Max_Stack_Offset = 0;
\f
/* Setup compiled code and primitive tables. */
- compiled_entry_table = &Heap[Heap_Count + Const_Count];
+ compiled_entry_table = &Constant_Space[Const_Count];
compiled_entry_pointer = compiled_entry_table;
- compiled_entry_table_end = compiled_entry_table;
-
+ compiled_entry_table_end = compiled_entry_pointer;
if (allow_compiled_p)
compiled_entry_table_end += (2 * (Heap_Count + Const_Count));
- primitive_table = compiled_entry_table_end;
+ compiled_block_table = compiled_entry_table_end;
+ compiled_block_pointer = &compiled_block_table[2];
+ compiled_block_table_end = compiled_block_pointer;
+ if (allow_compiled_p && c_compiled_p)
+ compiled_block_table_end += (2 *(Heap_Count + Const_Count));
+
+ primitive_table = compiled_block_table_end;
if (upgrade_primitives_p)
primitive_table_end = (setup_primitive_upgrade (primitive_table));
else
{
- fast SCHEME_OBJECT *table;
+ fast SCHEME_OBJECT * table;
fast long count, char_count;
- if ((Load_Data (Primitive_Table_Size, primitive_table)) !=
- Primitive_Table_Size)
+ if ((Load_Data (Primitive_Table_Size, primitive_table))
+ != Primitive_Table_Size)
{
fprintf (stderr, "%s: Could not load the primitive table.\n",
program_name);
NPChars = char_count;
primitive_table_end = (&primitive_table[Primitive_Table_Size]);
}
- Mem_Base = primitive_table_end;
+
+ c_code_table = primitive_table_end;
+ c_code_table_end = &c_code_table[C_Code_Table_Size];
+ if (C_Code_Table_Size != 0)
+ {
+ fast SCHEME_OBJECT * table;
+ fast long count, char_count;
+
+ if ((Load_Data (C_Code_Table_Size, c_code_table)) != C_Code_Table_Size)
+ {
+ fprintf (stderr, "%s: Could not load the C code table.\n",
+ program_name);
+ quit (1);
+ }
+ for (char_count = 0,
+ count = C_Code_Table_Length,
+ table = &c_code_table[1];
+ --count >= 0; )
+ {
+ long slen;
+
+ slen = (strlen ((char *) (table + 1)));
+ table += (1 + (BYTES_TO_WORDS (1 + slen)));
+ char_count += slen;
+ }
+ NCChars = char_count;
+ }
+
+ Mem_Base = c_code_table_end;
\f
/* Reformat the data */
NFlonums = NIntegers = NStrings = 0;
NBits = NBBits = NChars = 0;
- Mem_Base[0] = (OBJECT_NEW_TYPE (TC_CELL, Dumped_Object));
- Initial_Free = NROOTS;
- Scan = 0;
-
- Free = Initial_Free;
- Free_Objects = &Mem_Base[Heap_Count + Initial_Free];
+ Heap_Start = (NROOTS + (TRAP_MAX_IMMEDIATE + 1));
+ Heap_Objects_Start = (Heap_Start + Heap_Count);
+ Mem_Base[(Heap_Start - NROOTS) + 0]
+ = dumped_utilities;
+ Mem_Base[(Heap_Start - NROOTS) + 1]
+ = (OBJECT_NEW_TYPE (TC_CELL, Dumped_Object));
+ Scan = (Heap_Start - NROOTS);
+ Free = Heap_Start;
+ Free_Objects = &Mem_Base[Heap_Objects_Start];
Objects = 0;
- Free_Constant = (2 * Heap_Count) + Initial_Free;
- Scan_Constant = Free_Constant;
- Free_Cobjects = &Mem_Base[Const_Count + Free_Constant];
+ Constant_Start = (Heap_Objects_Start + Heap_Count);
+ Constant_Objects_Start = (Constant_Start + Const_Count);
+ Scan_Constant = Constant_Start;
+ Free_Constant = Constant_Start;
+ Free_Cobjects = &Mem_Base[Constant_Objects_Start];
Constant_Objects = 0;
-#if TRUE
+ Pure_Start = (Constant_Objects_Start + Const_Count);
+ Pure_Objects_Start = (Pure_Start + Const_Count);
+ Scan_Pure = Pure_Start;
+ Free_Pure = Pure_Start;
+ Free_Pobjects = &Mem_Base[Pure_Objects_Start];
+ Pure_Objects = 0;
- Do_Area (HEAP_CODE, Scan, Free, Objects, Free_Objects);
-
-#else
-
- /*
- When Constant Space finally becomes supported,
- something like this must be done.
- */
-
- while (true)
- {
- Do_Area (HEAP_CODE, Scan, Free,
- Objects, Free_Objects);
- Do_Area (CONSTANT_CODE, Scan_Constant, Free_Constant,
- Constant_Objects, Free_Cobjects);
- Do_Area (PURE_CODE, Scan_Pure, Free_Pure,
- Pure_Objects, Free_Pobjects);
- if (Scan == Free)
+ if (Const_Count == 0)
+ DO_AREA (HEAP_CODE, Scan, Free, Objects, Free_Objects);
+ else
+ while ((Scan != Free)
+ || (Scan_Constant != Free_Constant)
+ || (Scan_Pure != Free_Pure))
{
- break;
+ DO_AREA (HEAP_CODE, Scan, Free,
+ Objects, Free_Objects);
+ DO_AREA (CONSTANT_CODE, Scan_Constant, Free_Constant,
+ Constant_Objects, Free_Cobjects);
+ DO_AREA (PURE_CODE, Scan_Pure, Free_Pure,
+ Pure_Objects, Free_Pobjects);
}
- }
-#endif
-\f
/* Consistency checks */
- WHEN (((Free - Initial_Free) > Heap_Count), "Free overran Heap");
+ WHEN (((Free - Heap_Start) > Heap_Count), "Free overran Heap");
- WHEN (((Free_Objects - &Mem_Base[Initial_Free + Heap_Count]) >
- Heap_Count),
+ WHEN (((Free_Objects - &Mem_Base[Heap_Objects_Start])
+ > Heap_Count),
"Free_Objects overran Heap Object Space");
- WHEN (((Free_Constant - (Initial_Free + (2 * Heap_Count))) > Const_Count),
+ WHEN (((Free_Constant - Constant_Start) > Const_Count),
"Free_Constant overran Constant Space");
- WHEN (((Free_Cobjects - &Mem_Base[Initial_Free +
- (2 * Heap_Count) + Const_Count]) >
- Const_Count),
+ WHEN (((Free_Cobjects - &Mem_Base[Constant_Objects_Start])
+ > Const_Count),
"Free_Cobjects overran Constant Object Space");
+
+ WHEN (((Free_Pure - Pure_Start) > Const_Count),
+ "Free_Pure overran Pure Space");
+
+ WHEN (((Free_Cobjects - &Mem_Base[Pure_Objects_Start])
+ > Const_Count),
+ "Free_Cobjects overran Pure Object Space");
\f
/* Output the data */
WRITE_HEADER ("Sub Version", "%ld", FASL_SUBVERSION);
WRITE_HEADER ("Flags", "%ld", (MAKE_FLAGS ()));
- WRITE_HEADER ("Heap Count", "%ld", (Free - NROOTS));
- WRITE_HEADER ("Heap Base", "%ld", NROOTS);
+ WRITE_HEADER ("Heap Count", "%ld", (Free - Heap_Start));
+ WRITE_HEADER ("Heap Base", "%ld", Heap_Start);
WRITE_HEADER ("Heap Objects", "%ld", Objects);
- /* Currently Constant and Pure not supported, but the header is ready */
-
- WRITE_HEADER ("Pure Count", "%ld", 0);
- WRITE_HEADER ("Pure Base", "%ld", Free_Constant);
- WRITE_HEADER ("Pure Objects", "%ld", 0);
+ WRITE_HEADER ("Constant Count", "%ld", (Free_Constant - Constant_Start));
+ WRITE_HEADER ("Constant Base", "%ld", Constant_Start);
+ WRITE_HEADER ("Constant Objects", "%ld", Constant_Objects);
- WRITE_HEADER ("Constant Count", "%ld", 0);
- WRITE_HEADER ("Constant Base", "%ld", Free_Constant);
- WRITE_HEADER ("Constant Objects", "%ld", 0);
+ WRITE_HEADER ("Pure Count", "%ld", (Free_Pure - Pure_Start));
+ WRITE_HEADER ("Pure Base", "%ld", Pure_Start);
+ WRITE_HEADER ("Pure Objects", "%ld", Pure_Objects);
- WRITE_HEADER ("& Dumped Object", "%ld", (OBJECT_DATUM (Mem_Base[0])));
+ WRITE_HEADER ("& Dumped Object", "%ld",
+ (OBJECT_DATUM (Mem_Base[(TRAP_MAX_IMMEDIATE + 1) + 1])));
+ WRITE_HEADER ("Maximum Stack Offset", "%ld", Max_Stack_Offset);
WRITE_HEADER ("Number of flonums", "%ld", NFlonums);
WRITE_HEADER ("Number of integers", "%ld", NIntegers);
WRITE_HEADER ("Number of primitives", "%ld", Primitive_Table_Length);
WRITE_HEADER ("Number of characters in primitives", "%ld", NPChars);
- if (!compiled_p)
+ if (! compiled_p)
{
dumped_processor_type = 0;
dumped_interface_version = 0;
WRITE_HEADER ("CPU type", "%ld", dumped_processor_type);
WRITE_HEADER ("Compiled code interface version", "%ld",
dumped_interface_version);
-#if FALSE
- WRITE_HEADER ("Compiler utilities vector", "%ld",
- (OBJECT_DATUM (dumped_utilities)));
-#endif
-\f
- /* External Objects */
-
- print_external_objects (&Mem_Base[Initial_Free + Heap_Count],
- Objects);
-
-#if FALSE
-
- print_external_objects (&Mem_Base[Pure_Objects_Start],
- Pure_Objects);
- print_external_objects (&Mem_Base[Constant_Objects_Start],
- Constant_Objects);
+ if (allow_bands_p)
+ WRITE_HEADER ("Compiler utilities vector", "%ld",
+ (OBJECT_DATUM (Mem_Base[(TRAP_MAX_IMMEDIATE + 1) + 0])));
+ else
+ WRITE_HEADER ("Compiler utilities vector", "%ld", 0);
-#endif
+ WRITE_HEADER ("Number of C code blocks", "%ld", C_Code_Table_Length);
+ WRITE_HEADER ("Number of characters in C code blocks", "%ld", NCChars);
+ WRITE_HEADER ("Number of reserved C entries", "%ld",
+ (OBJECT_DATUM (c_code_table[0])));
- /* Pointer Objects */
+ /* Binary Objects */
- print_objects (&Mem_Base[NROOTS], &Mem_Base[Free]);
+ print_binary_objects (&Mem_Base[Pure_Objects_Start], Pure_Objects);
+ print_binary_objects (&Mem_Base[Constant_Objects_Start], Constant_Objects);
+ print_binary_objects (&Mem_Base[Heap_Objects_Start], Objects);
+\f
+ /* Normal Objects: pointers, simple non-pointers (e.g. SHARP_F) */
-#if FALSE
print_objects (&Mem_Base[Pure_Start], &Mem_Base[Free_Pure]);
print_objects (&Mem_Base[Constant_Start], &Mem_Base[Free_Constant]);
-#endif
-\f
+ print_objects (&Mem_Base[Heap_Start], &Mem_Base[Free]);
+
/* Primitives */
if (upgrade_primitives_p)
}
else
{
- fast SCHEME_OBJECT *table;
- fast long count;
- long arity;
+ long count;
+ SCHEME_OBJECT * table = primitive_table;
- for (count = Primitive_Table_Length, table = primitive_table;
- --count >= 0;)
+ for (count = Primitive_Table_Length; --count >= 0; )
{
- arity = (FIXNUM_TO_LONG (*table));
+ long arity = (FIXNUM_TO_LONG (* table));
table += 1;
- print_a_primitive (arity,
- (STRING_LENGTH_TO_LONG(table[STRING_LENGTH_INDEX])),
- ((char *) &table[STRING_CHARS]));
- table += (1 + OBJECT_DATUM (table[STRING_HEADER]));
+ print_a_primitive
+ (arity,
+ (STRING_LENGTH_TO_LONG (table[STRING_LENGTH_INDEX])),
+ ((char *) &table[STRING_CHARS]));
+ table += (1 + (OBJECT_DATUM (table[STRING_HEADER])));
}
}
+\f
+ /* C Code block information */
+
+ {
+ long count;
+ SCHEME_OBJECT * table = &c_code_table[1];
+
+ for (count = C_Code_Table_Length; --count >= 0; )
+ {
+ char * name;
+ long nentries, namelen;
+
+ nentries = (FIXNUM_TO_LONG (* table));
+ name = ((char *) (table + 1));
+ namelen = (strlen (name));
+ print_a_c_code_block (nentries, namelen, name);
+ table += (1 + (BYTES_TO_WORDS (namelen + 1)));
+ }
+ }
+
fflush (portable_file);
free ((char *) Lowest_Allocated_Address);
}
}
-\f
+
/* Top Level */
static Boolean
+ allow_constant_sup_p,
+ ci_version_sup_p,
+ ci_processor_sup_p,
help_p = false,
help_sup_p,
- ci_version_sup_p,
- ci_processor_sup_p;
+ warn_portable_sup_p;
/* The boolean value here is what value to store when the option is present. */
&ci_version_sup_p),
KEYWORD ("ci_processor", &compiler_processor_type, INT_KYWRD, "%ld",
&ci_processor_sup_p),
- KEYWORD ("vax_invert", &vax_invert_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD ("endian_invert", &endian_invert_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD ("allow_bands", &allow_bands_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD ("allow_constant_space", &allow_constant_space_p,
+ BOOLEAN_KYWRD, BFRMT, &allow_constant_sup_p),
+ KEYWORD ("warn_portable", &warn_portable_p, BOOLEAN_KYWRD, BFRMT,
+ &warn_portable_sup_p),
KEYWORD ("help", &help_p, BOOLEAN_KYWRD, BFRMT, &help_sup_p),
OUTPUT_KEYWORD (),
INPUT_KEYWORD (),
END_KEYWORD ()
};
-
+\f
void
-DEFUN (main, (argc, argv),
- int argc AND
- char **argv)
+DEFUN (main, (argc, argv), int argc AND char **argv)
{
parse_keywords (argc, argv, options, false);
upgrade_compiled_p =
(upgrade_compiled_p || ci_version_sup_p || ci_processor_sup_p);
- allow_compiled_p = (allow_compiled_p || upgrade_compiled_p);
- allow_nmv_p = (allow_nmv_p || allow_compiled_p || vax_invert_p);
+ allow_compiled_p = (allow_compiled_p || upgrade_compiled_p
+ || c_compiled_p || allow_bands_p);
+ allow_nmv_p = (allow_nmv_p || allow_compiled_p || endian_invert_p);
if (null_nmv_p && allow_nmv_p)
{
fprintf (stderr,
program_name);
quit (1);
}
+ if (allow_bands_p && warn_portable_p && (! warn_portable_sup_p))
+ warn_portable_p = false;
+ if (allow_bands_p && (! allow_constant_space_p) && (! allow_constant_sup_p))
+ allow_constant_space_p = true;
setup_io ("rb", "w");
do_it ();
/* -*-C-*-
-$Id: psbmap.h,v 9.39 1993/06/24 06:15:32 gjr Exp $
+$Id: psbmap.h,v 9.40 1993/11/07 01:39:01 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* This file contains macros and declarations for "Bintopsb.c"
- and "Psbtobin.c". */
-\f
+/* This file contains macros and declarations for "bintopsb.c"
+ and "psbtobin.c".
+ */
+
#ifndef PSBMAP_H_INCLUDED
#define PSBMAP_H_INCLUDED
from the included files.
*/
+#define WINNT_RAW_ADDRESSES
#define fast register
#include <stdio.h>
#include "sdata.h"
#include "const.h"
#include "gccode.h"
+#include "cmptype.h"
#define boolean Boolean
#include "comlin.h"
+#ifndef COMPILER_PROCESSOR_TYPE
+#define COMPILER_PROCESSOR_TYPE COMPILER_NONE_TYPE
+#endif
+\f
extern double
EXFUN (frexp, (double, int *)),
EXFUN (ldexp, (double, int));
-#define PORTABLE_VERSION 5
+#define PORTABLE_VERSION 6
/* Number of objects which, when traced recursively, point at all other
- objects dumped. Currently only the dumped object.
+ objects dumped.
+ Currently the dumped object, and the compiler utilities.
*/
-#define NROOTS 1
+#define NROOTS 2
/* Types to recognize external object references. Any occurrence of these
(which are external types and thus handled separately) means a reference
#define CONSTANT_CODE TC_FIXNUM
#define HEAP_CODE TC_CHARACTER
+#define PURE_CODE TC_BIG_FIXNUM
#define fixnum_to_bits FIXNUM_LENGTH
#define hex_digits(nbits) (((nbits) + 3) / 4)
#define COMPILED_P (1 << 2)
#define NMV_P (1 << 3)
#define BAND_P (1 << 4)
+#define C_CODE_P (1 << 5)
#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) | \
- (band_p ? BAND_P : 0))
-
-#define READ_FLAGS(f) \
+( (compact_p ? COMPACT_P : 0) \
+ | (null_nmv_p ? NULL_NMV_P : 0) \
+ | (compiled_p ? COMPILED_P : 0) \
+ | (nmv_p ? NMV_P : 0) \
+ | (band_p ? BAND_P : 0) \
+ | (c_compiled_p ? C_CODE_P : 0))
+
+#define READ_FLAGS(f) do \
{ \
compact_p = ((f) & COMPACT_P); \
null_nmv_p = ((f) & NULL_NMV_P); \
compiled_p = ((f) & COMPILED_P); \
nmv_p = ((f) & NMV_P); \
band_p = ((f) & BAND_P); \
-}
+ c_compiled_p = ((f) & C_CODE_P); \
+} while (0)
/*
If true, make all integers fixnums if possible, and all strings as
static Boolean nmv_p = false;
+#define TC_C_COMPILED_TAG TC_MANIFEST_CLOSURE
+#define C_COMPILED_FAKE_NMV 0
+#define C_COMPILED_ENTRY_FORMAT 1
+#define C_COMPILED_ENTRY_CODE 2
+#define C_COMPILED_CLOSURE_HEADER 3
+#define C_COMPILED_MULTI_CLOSURE_HEADER 4
+#define C_COMPILED_LINKAGE_HEADER 5
+#define C_COMPILED_RAW_QUAD 6
+#define C_COMPILED_EXECUTE_ENTRY 7
+#define C_COMPILED_EXECUTE_ARITY 8
+
/* Global data */
#ifndef HEAP_IN_LOW_MEMORY
#endif
static long
- compiler_processor_type = 0,
+ compiler_processor_type = COMPILER_PROCESSOR_TYPE,
compiler_interface_version = 0;
static SCHEME_OBJECT
FILE *input_file, *output_file;
-Boolean
+static Boolean
DEFUN (strequal, (s1, s2), register char * s1 AND register char * s2)
{
for ( ; *s1 != '\0'; s1++, s2++)
- {
if (*s1 != *s2)
- {
return (false);
- }
- }
return (*s2 == '\0');
}
-\f
-void
+
+static void
DEFUN (setup_io, (input_mode, output_mode),
CONST char * input_mode AND CONST char * output_mode)
{
if (strequal (input_file_name, "-"))
- {
input_file = stdin;
- }
else
{
input_file = (fopen (input_file_name, input_mode));
}
if (strequal (output_file_name, "-"))
- {
output_file = stdout;
- }
else
{
output_file = (fopen (output_file_name, output_mode));
return;
}
-void
+static void
DEFUN (quit, (code), int code)
{
fclose(input_file);
#ifdef vms
/* This assumes that it is only invoked with 0 in tail recursive psn. */
if (code != 0)
- {
exit(code);
- }
else
- {
return;
- }
#else /* not vms */
exit(code);
#endif /*vms */
}
\f
+#ifndef TERM_COMPILER_DEATH
+#define TERM_COMPILER_DEATH 0
+#endif
+
+void
+DEFUN (gc_death, (code, message, scan, free),
+ long code
+ AND char * message
+ AND SCHEME_OBJECT * scan
+ AND SCHEME_OBJECT * free)
+{
+ fprintf (stderr, "%s: %s\n", program_name, message);
+ quit (1);
+}
+
/* Include the command line parser */
#include "comlin.c"
/* -*-C-*-
-$Id: psbtobin.c,v 9.50 1993/10/14 19:17:26 gjr Exp $
+$Id: psbtobin.c,v 9.51 1993/11/07 01:39:13 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
static Boolean
band_p = false,
allow_compiled_p = false,
- allow_nmv_p = false;
+ allow_nmv_p = false,
+ warn_portable_p = true,
+ c_compiled_p = false;
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;
+ Dumped_Object_Addr, Dumped_Compiler_Utilities,
+ Dumped_Heap_Base, Dumped_Heap_Limit, Heap_Objects, Heap_Count,
+ Dumped_Const_Base, Dumped_Const_Limit, Const_Objects, Const_Count,
+ Dumped_Pure_Base, Dumped_Pure_Limit, Pure_Objects, Pure_Count,
+ Primitive_Table_Length, Max_Stack_Offset,
+ C_Code_Table_Length, C_Code_Reserved_Entries;
static SCHEME_OBJECT
- *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;
+ * Heap, * Constant_Space, * Constant_Top, * Stack_Top,
+ * Heap_Base, * Heap_Table, * Heap_Object_Limit, * Free,
+ * Const_Base, * Const_Table, * Const_Object_Limit, * Free_Const,
+ * Pure_Base, * Pure_Table, * Pure_Object_Limit, * Free_Pure;
-long
+static long
DEFUN (Write_Data, (Count, From_Where),
long Count AND
SCHEME_OBJECT *From_Where)
#include "fasl.h"
#include "dump.c"
+
+#ifndef MAKE_FORMAT_WORD
+#define MAKE_FORMAT_WORD(h,l) 0
+#endif
+
+#ifndef WRITE_LABEL_DESCRIPTOR
+#define WRITE_LABEL_DESCRIPTOR(e,f,o) do { } while (0)
+#endif
+
+#ifndef MAKE_LINKAGE_SECTION_HEADER
+#define MAKE_LINKAGE_SECTION_HEADER(kind,count) 0
+#endif
\f
-void
+static void
DEFUN_VOID (inconsistency)
{
/* Provide some context (2 lines). */
#define OUT(c) return ((long) ((c) & UCHAR_MAX))
-long
+static long
DEFUN_VOID (read_a_char)
{
fast char C;
{
long Code;
- fprintf (stderr,
- "%s: File is not Portable. Character Code Found.\n",
- program_name);
+ if (warn_portable_p)
+ {
+ warn_portable_p = false;
+ fprintf (stderr,
+ "%s: File is not Portable. Character Code Found.\n",
+ program_name);
+ }
fscanf (portable_file, "%ld", &Code);
getc (portable_file); /* Space */
OUT (Code);
}
}
\f
-SCHEME_OBJECT *
+static SCHEME_OBJECT *
+DEFUN (read_a_char_pointer, (to), SCHEME_OBJECT * to)
+{
+ long len, maxlen;
+ char * str;
+
+ fscanf (portable_file, "%ld", &len);
+
+ maxlen = (len + 1); /* null terminated */
+ str = ((char *) to);
+ getc (portable_file); /* space */
+
+ while (--len >= 0)
+ *str++ = ((char) (read_a_char ()));
+ *str = '\0';
+ return (to + (BYTES_TO_WORDS (maxlen)));
+}
+
+static SCHEME_OBJECT *
DEFUN (read_a_string_internal, (To, maxlen),
- SCHEME_OBJECT *To AND
- long maxlen)
+ SCHEME_OBJECT * To AND long maxlen)
{
long ilen, Pointer_Count;
fast char *str;
len = ilen;
if (maxlen == -1)
- {
maxlen = len;
- }
/* Null terminated */
maxlen += 1;
- Pointer_Count = STRING_CHARS + (char_to_pointer (maxlen));
+ Pointer_Count = (STRING_CHARS + (char_to_pointer (maxlen)));
To[STRING_HEADER] =
(MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (Pointer_Count - 1)));
To[STRING_LENGTH_INDEX] = ((SCHEME_OBJECT) len);
getc (portable_file);
while (--len >= 0)
- {
- *str++ = ((char) read_a_char ());
- }
+ *str++ = ((char) (read_a_char ()));
*str = '\0';
return (To + Pointer_Count);
}
-SCHEME_OBJECT *
+static SCHEME_OBJECT *
DEFUN (read_a_string, (To, Slot),
- SCHEME_OBJECT *To AND
- SCHEME_OBJECT *Slot)
+ SCHEME_OBJECT * To AND SCHEME_OBJECT * Slot)
{
long maxlen;
#endif
\f
-SCHEME_OBJECT *
+static SCHEME_OBJECT *
DEFUN (read_an_integer, (The_Type, To, Slot),
- int The_Type AND
- SCHEME_OBJECT *To AND
- SCHEME_OBJECT *Slot)
+ int The_Type AND SCHEME_OBJECT * To AND SCHEME_OBJECT * Slot)
{
Boolean negative;
fast long length_in_bits;
fscanf (portable_file, "%ld", (&l));
length_in_bits = l;
}
- if ((length_in_bits <= fixnum_to_bits) &&
- (The_Type == TC_FIXNUM))
+ if ((length_in_bits <= fixnum_to_bits)
+ && (The_Type == TC_FIXNUM))
{
/* The most negative fixnum is handled in the bignum case */
fast long Value = 0;
}
}
if (negative)
- {
Value = -Value;
- }
+
*Slot = (LONG_TO_FIXNUM (Value));
return (To);
}
accumulator = (hex_digit >> bits_in_digit);
position = (4 - bits_in_digit);
length_in_bits -= 4;
- if (length_in_bits >= BIGNUM_DIGIT_LENGTH)
+ if (length_in_bits <= 0)
+ {
+ (*scan) = accumulator;
+ break;
+ }
+ else if (length_in_bits >= BIGNUM_DIGIT_LENGTH)
bits_in_digit = BIGNUM_DIGIT_LENGTH;
- else if (length_in_bits > 0)
- bits_in_digit = length_in_bits;
else
- {
- (*scan) = accumulator;
- break;
- }
+ bits_in_digit = length_in_bits;
}
}
(*To) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, gc_length));
}
}
}
-\f
+
SCHEME_OBJECT *
+DEFUN (read_a_bignum, (The_Type, To, Slot),
+ int The_Type AND SCHEME_OBJECT * To AND SCHEME_OBJECT * Slot)
+{
+ return (read_an_integer (The_Type, To, Slot));
+}
+\f
+static SCHEME_OBJECT *
DEFUN (read_a_bit_string, (To, Slot),
- SCHEME_OBJECT *To AND
- SCHEME_OBJECT *Slot)
+ SCHEME_OBJECT * To AND SCHEME_OBJECT * Slot)
{
long size_in_bits, size_in_words;
SCHEME_OBJECT the_bit_string;
#define dflmin() 0.0 /* Cop out */
#define dflmax() ((the_max == 0.0) ? (compute_max ()) : the_max)
-double
+static double
DEFUN_VOID (compute_max)
{
fast double Result;
fast int expt;
Result = 0.0;
- for (expt = DBL_MAX_EXP;
- expt != 0;
- expt >>= 1)
- {
+ for (expt = DBL_MAX_EXP; expt != 0; expt >>= 1)
Result += (ldexp (1.0, expt));
- }
the_max = Result;
return (Result);
}
-long
-DEFUN (read_signed_decimal, (stream),
- fast FILE *stream)
+static long
+DEFUN (read_signed_decimal, (stream), fast FILE * stream)
{
fast int c = (getc (stream));
fast long result = (-1);
int negative_p = 0;
while (c == ' ')
- {
c = (getc (stream));
- }
- if (c == '-')
- {
- negative_p = 1;
+
+ if (c == '+')
c = (getc (stream));
- }
- else if (c == '+')
+ else if (c == '-')
{
+ negative_p = 1;
c = (getc (stream));
}
+
if ((c >= '0') && (c <= '9'))
{
result = (c - '0');
}
}
if (c != EOF)
- {
ungetc (c, stream);
- }
+
if (result == (-1))
{
fprintf (stderr, "%s: Unable to read expected decimal integer\n",
return (negative_p ? (-result) : result);
}
\f
-double
+static double
DEFUN_VOID (read_a_flonum)
{
Boolean negative;
/* Hair here because portable file format incorrect for flonum 0. */
exponent = (read_signed_decimal (portable_file));
if (exponent == 0)
- {
- int c = (getc (portable_file));
- if (c == '\n')
- {
- return (0);
- }
- ungetc (c, portable_file);
- }
+ {
+ int c = (getc (portable_file));
+ if (c == '\n')
+ return (0);
+ ungetc (c, portable_file);
+ }
size_in_bits = (read_signed_decimal (portable_file));
if (size_in_bits == 0)
- {
return (0);
- }
+
if ((exponent > DBL_MAX_EXP) || (exponent < DBL_MIN_EXP))
{
/* Skip over mantissa */
while ((getc (portable_file)) != '\n')
- {};
+ ;
fprintf (stderr,
"%s: Floating point exponent too %s!\n",
program_name,
long digit;
if (size_in_bits > DBL_MANT_DIG)
- {
fprintf (stderr,
"%s: Some precision may be lost.",
program_name);
- }
getc (portable_file); /* Space */
for (ndigits = (hex_digits (size_in_bits)),
Result = 0.0,
Result = (ldexp (Result, ((int) exponent)));
}
if (negative)
- {
Result = -Result;
- }
+
return (Result);
}
\f
-SCHEME_OBJECT *
+static SCHEME_OBJECT *
DEFUN (Read_External, (N, Table, To),
- long N AND
- fast SCHEME_OBJECT *Table AND
- SCHEME_OBJECT *To)
+ long N
+ AND fast SCHEME_OBJECT * Table
+ AND SCHEME_OBJECT * To)
{
fast SCHEME_OBJECT *Until = &Table[N];
int The_Type;
continue;
case TC_FIXNUM:
- case TC_BIG_FIXNUM:
To = (read_an_integer (The_Type, To, Table++));
continue;
+
+ case TC_BIG_FIXNUM:
+ To = (read_a_bignum (The_Type, To, Table++));
+ continue;
case TC_CHARACTER:
{
return (To);
}
\f
-#if FALSE
+#define DEBUG 0
-void
-DEFUN (Move_Memory, (From, N, To),
- fast SCHEME_OBJECT *From AND
- long N AND
- SCHEME_OBJECT *To)
+#if (DEBUG > 2)
+static void
+DEFUN (print_external_objects, (area_name, Table, N),
+ char * area_name
+ AND fast SCHEME_OBJECT * Table
+ AND fast long N)
{
- fast SCHEME_OBJECT *Until;
-
- Until = &From[N];
- while (From < Until)
- {
- *To++ = *From++;
- }
- return;
-}
-
-#endif
+ fast SCHEME_OBJECT * Table_End = &Table[N];
-#if FALSE
-
-/* This appears to be a fossil. */
-
-void
-DEFUN (Relocate_Objects, (from, how_many, disp),
- fast SCHEME_OBJECT *from AND
- long how_many AND
- fast long disp)
-{
- fast SCHEME_OBJECT *Until;
+ fprintf (stderr, "%s External Objects:\n", area_name);
+ fprintf (stderr, "Table = 0x%x; N = %d\n", Table, N);
- Until = &from[how_many];
- while (from < Until)
+ for ( ; Table < Table_End; Table++)
{
- switch (OBJECT_TYPE (*from))
+ switch (OBJECT_TYPE (*Table))
{
case TC_FIXNUM:
+ {
+ fprintf (stderr,
+ "Table[%6d] = Fixnum %d\n",
+ (N - (Table_End - Table)),
+ (FIXNUM_TO_LONG (*Table)));
+ break;
+ }
case TC_CHARACTER:
- from += 1;
- break;
+ fprintf (stderr,
+ "Table[%6d] = Character %c = 0x%02x\n",
+ (N - (Table_End - Table)),
+ (OBJECT_DATUM (*Table)),
+ (OBJECT_DATUM (*Table)));
+ break;
+
+ case TC_CHARACTER_STRING:
+ fprintf (stderr,
+ "Table[%6d] = string \"%s\"\n",
+ (N - (Table_End - Table)),
+ ((char *) MEMORY_LOC (*Table, STRING_CHARS)));
+ break;
case TC_BIG_FIXNUM:
+ fprintf (stderr,
+ "Table[%6d] = Bignum\n",
+ (N - (Table_End - Table)));
+ break;
+
case TC_BIG_FLONUM:
- case TC_CHARACTER_STRING:
- *from++ =
- (OBJECT_NEW_DATUM ((*from), (disp + (OBJECT_DATUM (*from)))));
+ fprintf (stderr,
+ "Table[%6d] = Flonum %lf\n",
+ (N - (Table_End - Table)),
+ (* ((double *) MEMORY_LOC (*Table, 1))));
break;
default:
- fprintf (stderr,
- "%s: Unknown External Object Reference with Type 0x%02x",
- program_name,
- (OBJECT_TYPE (*from)));
- inconsistency ();
+ fprintf (stderr,
+ "Table[%6d] = Unknown External Object 0x%8x\n",
+ (N - (Table_End - Table)),
+ *Table);
+ break;
}
}
return;
}
-#endif
+#endif /* DEBUG > 1 */
+\f
+#if (DEBUG > 0)
+
+#define WHEN(condition, message) when (condition, message)
+
+static void
+DEFUN (when, (what, message), Boolean what AND char * message)
+{
+ if (what)
+ {
+ fprintf (stderr, "%s: Inconsistency: %s!\n",
+ program_name, (message));
+ inconsistency ();
+ }
+ return;
+}
+
+#else /* DEBUG <= 0 */
+
+#define WHEN(what, message) do { } while (0)
+
+#endif /* DEBUG > 0 */
+
+#if (DEBUG > 1)
+
+#define DEBUGGING(action) action
+
+#define READ_HEADER_FAILURE(string) do \
+{ \
+ fprintf (stderr, "Unable to read header field \"%s\".\n", (string)); \
+} while (0)
+
+#define READ_HEADER_SUCCESS(string, format, value) do \
+{ \
+ fprintf (stderr, "%s: ", (string)); \
+ fprintf (stderr, (format), (value)); \
+ fprintf (stderr, "\n"); \
+} while (0)
+
+#else /* DEBUG <= 1 */
+
+#define DEBUGGING(action) do { } while (0)
+
+#define READ_HEADER_FAILURE(s) do { } while (0)
+#define READ_HEADER_SUCCESS(s,f,v) do { } while (0)
+
+#endif /* DEBUG > 0 */
+
+#if (DEBUG > 2)
+
+#define XDEBUGGING(action) DEBUGGING(action)
+
+#else /* DEBUG <= 2 */
+
+#define XDEBUGGING(action) do { } while (0)
+
+#endif /* DEBUG > 2 */
\f
-#define Relocate_Into(Where, Addr) \
+void
+relocation_error (long addr)
+{
+ fprintf (stderr, "%s: Out of range address %d.\n",
+ program_name, addr);
+ inconsistency ();
+ /*NOTREACHED*/
+}
+
+#define Relocate_Into(Where, Addr) do \
{ \
- if ((Addr) < Dumped_Pure_Base) \
- { \
- (Where) = &Heap_Object_Base[(Addr) - Dumped_Heap_Base]; \
- } \
- else if ((Addr) < Dumped_Constant_Base) \
- { \
- (Where) = &Pure_Base[(Addr) - Dumped_Pure_Base]; \
- } \
+ long _addr = (Addr); \
+ \
+ if ((_addr >= Dumped_Heap_Base) && (_addr < Dumped_Heap_Limit)) \
+ (Where) = &Heap_Object_Limit[_addr - Dumped_Heap_Base]; \
+ else if ((_addr >= Dumped_Const_Base) \
+ && (_addr < Dumped_Const_Limit)) \
+ (Where) = &Const_Object_Limit[_addr - Dumped_Const_Base]; \
+ else if ((_addr >= Dumped_Pure_Base) \
+ && (_addr < Dumped_Pure_Limit)) \
+ (Where) = &Pure_Object_Limit[_addr - Dumped_Pure_Base]; \
else \
- { \
- (Where) = &Constant_Base[(Addr) - Dumped_Constant_Base]; \
- } \
-}
+ (void) relocation_error (_addr); \
+} while (0)
#ifndef Conditional_Bug
#define Relocate(Addr) \
-(((Addr) < Dumped_Pure_Base) ? \
- &Heap_Object_Base[(Addr) - Dumped_Heap_Base] : \
- (((Addr) < Dumped_Constant_Base) ? \
- &Pure_Base[(Addr) - Dumped_Pure_Base] : \
- &Constant_Base[(Addr) - Dumped_Constant_Base]))
+((((Addr) >= Dumped_Heap_Base) && ((Addr) < Dumped_Heap_Limit)) \
+ ? &Heap_Object_Limit[(Addr) - Dumped_Heap_Base] \
+ : ((((Addr) >= Dumped_Const_Base) && ((Addr) < Dumped_Const_Limit)) \
+ ? &Const_Object_Limit[(Addr) - Dumped_Const_Base] \
+ : ((((Addr) >= Dumped_Pure_Base) && ((Addr) < Dumped_Pure_Limit)) \
+ ? &Pure_Object_Limit[(Addr) - Dumped_Pure_Base] \
+ : ((relocation_error (Addr)), ((SCHEME_OBJECT *) NULL)))))
#else
-static SCHEME_OBJECT *Relocate_Temp;
+static SCHEME_OBJECT * Relocate_Temp;
#define Relocate(Addr) \
(Relocate_Into (Relocate_Temp, Addr), Relocate_Temp)
#endif
\f
-SCHEME_OBJECT *
+static SCHEME_OBJECT *
DEFUN (Read_Pointers_and_Relocate, (how_many, to),
- fast long how_many AND
- fast SCHEME_OBJECT *to)
+ fast long how_many AND fast SCHEME_OBJECT * to)
{
int The_Type;
long The_Datum;
-#if FALSE
- ALIGN_FLOAT (to);
-#endif
-
while ((--how_many) >= 0)
{
VMS_BUG (The_Type = 0);
switch (The_Type)
{
case CONSTANT_CODE:
- *to++ = Constant_Table[The_Datum];
+ WHEN (((The_Datum < 0) || (The_Datum >= Const_Objects)),
+ "CONSTANT_CODE too large");
+ *to++ = Const_Table[The_Datum];
continue;
case HEAP_CODE:
+ WHEN (((The_Datum < 0) || (The_Datum >= Heap_Objects)),
+ "HEAP_CODE too large");
*to++ = Heap_Table[The_Datum];
continue;
+
+ case PURE_CODE:
+ WHEN (((The_Datum < 0) || (The_Datum >= Pure_Objects)),
+ "PURE_CODE too large");
+ *to++ = Pure_Table[The_Datum];
+ continue;
case TC_MANIFEST_NM_VECTOR:
*to++ = (MAKE_OBJECT (The_Type, The_Datum));
}
continue;
- case TC_COMPILED_ENTRY:
- {
- SCHEME_OBJECT *temp;
- long base_type, base_datum;
-
- fscanf (portable_file, "%02x %lx", &base_type, &base_datum);
- temp = (Relocate (base_datum));
- *to++ =
- (MAKE_POINTER_OBJECT
- (base_type, ((SCHEME_OBJECT *) (&(((char *) temp)[The_Datum])))));
- break;
- }
-
case TC_BROKEN_HEART:
if (The_Datum != 0)
{
case_simple_Non_Pointer:
*to++ = (MAKE_OBJECT (The_Type, The_Datum));
continue;
+\f
+ case TC_COMPILED_ENTRY:
+ {
+ SCHEME_OBJECT * temp, * entry_addr;
+ long base_type, base_datum;
+
+ fscanf (portable_file, "%02x %lx", &base_type, &base_datum);
+ temp = (Relocate (base_datum));
+ if (c_compiled_p)
+ entry_addr = &temp[The_Datum];
+ else
+ entry_addr = ((SCHEME_OBJECT *) (&(((char *) temp) [The_Datum])));
+ *to++ = (MAKE_POINTER_OBJECT (base_type, entry_addr));
+ continue;
+ }
- case TC_MANIFEST_CLOSURE:
- case TC_LINKAGE_SECTION:
+ case TC_C_COMPILED_TAG:
{
- fprintf (stderr, "%s: File contains linked compiled code.\n",
- program_name);
- inconsistency ();
+ if (! c_compiled_p)
+ {
+ fprintf (stderr, "%s: C-compiled code descriptors found.\n",
+ program_name);
+ inconsistency ();
+ }
+ switch (The_Datum)
+ {
+ case C_COMPILED_FAKE_NMV:
+ {
+ long nmv_length;
+
+ VMS_BUG (nmv_length = 0);
+ fscanf (portable_file, "%lx", &nmv_length);
+ *to++ = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, nmv_length));
+ continue;
+ }
+
+ case C_COMPILED_ENTRY_FORMAT:
+ {
+ long low_byte, high_byte, offset, format;
+
+ VMS_BUG (low_byte = 0);
+ VMS_BUG (high_byte = 0);
+ VMS_BUG (offset = 0);
+ fscanf (portable_file, "%ld %ld %lx",
+ &low_byte, &high_byte, &offset);
+ format = (MAKE_FORMAT_WORD (high_byte, low_byte));
+ to += 1;
+ WRITE_LABEL_DESCRIPTOR (to, format, offset);
+ continue;
+ }
+
+ case C_COMPILED_ENTRY_CODE:
+ {
+ long entry_number;
+
+ VMS_BUG (entry_number = 0);
+ fscanf (portable_file, "%lx", &entry_number);
+ *to++ = ((SCHEME_OBJECT) entry_number);
+ continue;
+ }
+\f
+ case C_COMPILED_CLOSURE_HEADER:
+ {
+ long header_datum;
+
+ VMS_BUG (header_datum = 0);
+ fscanf (portable_file, "%lx", &header_datum);
+ *to++ = (MAKE_OBJECT (TC_MANIFEST_CLOSURE, header_datum));
+ continue;
+ }
+
+ case C_COMPILED_MULTI_CLOSURE_HEADER:
+ {
+ long nentries;
+
+ VMS_BUG (nentries = 0);
+ fscanf (portable_file, "%lx", &nentries);
+ to += 1;
+ WRITE_LABEL_DESCRIPTOR (to, nentries, 0);
+ continue;
+ }
+
+ case C_COMPILED_LINKAGE_HEADER:
+ {
+ long kind, count;
+
+ VMS_BUG (kind = 0);
+ VMS_BUG (count = 0);
+ fscanf (portable_file, "%lx %lx", &kind, &count);
+ *to++ = (MAKE_LINKAGE_SECTION_HEADER (kind, count));
+ continue;
+ }
+
+ case C_COMPILED_RAW_QUAD:
+ {
+ long quad_datum;
+
+ VMS_BUG (quad_datum = 0);
+ fscanf (portable_file, "%lx", &quad_datum);
+ *to++ = (ADDR_TO_SCHEME_ADDR (Relocate (quad_datum)));
+ continue;
+ }
+
+ case C_COMPILED_EXECUTE_ENTRY:
+ {
+ long offset, block_base;
+ SCHEME_OBJECT * temp;
+
+ VMS_BUG (offset = 0);
+ VMS_BUG (block_base = 0);
+ fscanf (portable_file, "%lx %lx", &offset, &block_base);
+ temp = (Relocate (block_base));
+ *to++ = (ADDR_TO_SCHEME_ADDR (&temp[offset]));
+ continue;
+ }
+
+ case C_COMPILED_EXECUTE_ARITY:
+ {
+ long arity;
+
+ VMS_BUG (arity = 0);
+ fscanf (portable_file, "%lx", &arity);
+ *to++ = ((SCHEME_OBJECT) arity);
+ continue;
+ }
+\f
+ default:
+ {
+ fprintf (stderr, "%s: Unknown C compiled tag found.\n",
+ program_name);
+ inconsistency ();
+ }
+ }
+ continue;
}
+ case TC_STACK_ENVIRONMENT:
+ *to++ = (MAKE_POINTER_OBJECT (The_Type, (Stack_Top - The_Datum)));
+ continue;
+
case TC_REFERENCE_TRAP:
if (The_Datum <= TRAP_MAX_IMMEDIATE)
{
default:
/* Should be stricter */
- *to++ = (MAKE_POINTER_OBJECT (The_Type, Relocate (The_Datum)));
+ *to++ = (MAKE_POINTER_OBJECT (The_Type, (Relocate (The_Datum))));
continue;
}
}
-#if FALSE
- ALIGN_FLOAT (to);
-#endif
return (to);
}
\f
static Boolean primitive_warn = false;
-SCHEME_OBJECT *
+static SCHEME_OBJECT *
DEFUN (read_primitives, (how_many, where),
- fast long how_many AND
- fast SCHEME_OBJECT *where)
+ fast long how_many
+ AND fast SCHEME_OBJECT * where)
{
long arity;
{
fscanf (portable_file, "%ld", &arity);
if (arity == ((long) UNKNOWN_PRIMITIVE_ARITY))
- {
primitive_warn = true;
- }
*where++ = (LONG_TO_FIXNUM (arity));
where = (read_a_string_internal (where, ((long) -1)));
}
return (where);
}
-\f
-#ifdef DEBUG
-void
-DEFUN (print_external_objects, (area_name, Table, N),
- char *area_name AND
- fast SCHEME_OBJECT *Table AND
- fast long N)
+static SCHEME_OBJECT *
+DEFUN (read_c_code_blocks, (nreserved, length, area),
+ long nreserved AND long length AND SCHEME_OBJECT * area)
{
- fast SCHEME_OBJECT *Table_End = &Table[N];
-
- fprintf (stderr, "%s External Objects:\n", area_name);
- fprintf (stderr, "Table = 0x%x; N = %d\n", Table, N);
-
- for ( ; Table < Table_End; Table++)
+ if (length != 0)
{
- switch (OBJECT_TYPE (*Table))
+ *area++ = (LONG_TO_FIXNUM (nreserved));
+ while (--length >= 0)
{
- case TC_FIXNUM:
- {
- fprintf (stderr,
- "Table[%6d] = Fixnum %d\n",
- (N - (Table_End - Table)),
- (FIXNUM_TO_LONG (*Table)));
- break;
- }
- case TC_CHARACTER:
- fprintf (stderr,
- "Table[%6d] = Character %c = 0x%02x\n",
- (N - (Table_End - Table)),
- (OBJECT_DATUM (*Table)),
- (OBJECT_DATUM (*Table)));
- break;
-
- case TC_CHARACTER_STRING:
- fprintf (stderr,
- "Table[%6d] = string \"%s\"\n",
- (N - (Table_End - Table)),
- ((char *) MEMORY_LOC (*Table, STRING_CHARS)));
- break;
-
- case TC_BIG_FIXNUM:
- fprintf (stderr,
- "Table[%6d] = Bignum\n",
- (N - (Table_End - Table)));
- break;
-
- case TC_BIG_FLONUM:
- fprintf (stderr,
- "Table[%6d] = Flonum %lf\n",
- (N - (Table_End - Table)),
- (* ((double *) MEMORY_LOC (*Table, 1))));
- break;
+ long nentries;
- default:
- fprintf (stderr,
- "Table[%6d] = Unknown External Object 0x%8x\n",
- (N - (Table_End - Table)),
- *Table);
- break;
+ fscanf (portable_file, "%ld", &nentries);
+ *area++ = (LONG_TO_FIXNUM (nentries));
+ area = (read_a_char_pointer (area));
}
}
- return;
-}
-
-#define DEBUGGING(action) action
-
-#define WHEN(condition, message) when (condition, message)
-
-void
-DEFUN (when, (what, message),
- Boolean what AND
- char *message)
-{
- if (what)
- {
- fprintf (stderr, "%s: Inconsistency: %s!\n",
- program_name, (message));
- quit (1);
- }
- return;
+ return (area);
}
-
-#define READ_HEADER(string, format, value) \
+\f
+#define READ_HEADER_NO_ERROR(string, format, value, flag) do \
{ \
- fscanf (portable_file, format, &(value)); \
- fprintf (stderr, "%s: ", (string)); \
- fprintf (stderr, (format), (value)); \
- fprintf (stderr, "\n"); \
-}
-
-#else /* not DEBUG */
-
-#define DEBUGGING(action)
-
-#define WHEN(what, message)
+ if (fscanf (portable_file, format, &(value)) == EOF) \
+ { \
+ (flag) = (false); \
+ READ_HEADER_FAILURE (string); \
+ } \
+ else \
+ { \
+ (flag) = (true); \
+ READ_HEADER_SUCCESS (string, format, value); \
+ } \
+} while (0)
-#define READ_HEADER(string, format, value) \
+#define READ_HEADER(string, format, value) do \
{ \
if (fscanf (portable_file, format, &(value)) == EOF) \
{ \
+ READ_HEADER_FAILURE (string); \
short_header_read (); \
} \
-}
+ else \
+ READ_HEADER_SUCCESS (string, format, value); \
+} while (0)
-#endif /* DEBUG */
-\f
-void
+static void
DEFUN_VOID (short_header_read)
{
fprintf (stderr, "%s: Header is not complete!\n", program_name);
quit (1);
}
-
+\f
static SCHEME_OBJECT * Lowest_Allocated_Address, * Highest_Allocated_Address;
-long
+static long
DEFUN_VOID (Read_Header_and_Allocate)
{
+ Boolean ok;
+
long
Portable_Version, Machine,
Version, Sub_Version, Flags,
NFlonums, NIntegers, NBits,
NBitstrs, NBBits, NStrings, NChars,
- NPChars,
- Size;
+ NPChars, NCChars, Size, initial_delta;
-#if FALSE
- READ_HEADER ("Portable Version", "%ld", Portable_Version);
-#else
- if (fscanf (portable_file, "%ld", &Portable_Version) == EOF)
- {
+ /* We don't use READ_HEADER here because it is not an error if
+ there is no first word.
+ .bin (and .psb) files can contain multiple objects.
+ */
+
+ READ_HEADER_NO_ERROR ("Portable Version", "%ld", Portable_Version, ok);
+ if (! ok)
return (-1);
- }
-#endif
if (Portable_Version != PORTABLE_VERSION)
{
READ_HEADER ("Flags", "%ld", Flags);
READ_FLAGS (Flags);
- if (((compiled_p && (! allow_compiled_p)) ||
- (nmv_p && (! allow_nmv_p))) &&
- (Machine != FASL_INTERNAL_FORMAT))
+ if (((compiled_p && (! allow_compiled_p))
+ || (nmv_p && (! allow_nmv_p)))
+ && (Machine != FASL_INTERNAL_FORMAT))
{
if (compiled_p)
- {
fprintf (stderr, "%s: %s\n", program_name,
"Portable file contains \"non-portable\" compiled code.");
- }
else
- {
fprintf (stderr, "%s: %s\n", program_name,
"Portable file contains \"unexpected\" non-marked vectors.");
- }
fprintf (stderr, "Machine specified in the portable file: %4d\n",
Machine);
fprintf (stderr, "Machine Expected: %4d\n",
FASL_INTERNAL_FORMAT);
quit (1);
}
+\f
+ if (compiled_p
+ && c_compiled_p
+ && (COMPILER_PROCESSOR_TYPE != COMPILER_LOSING_C_TYPE))
+ {
+ fprintf (stderr,
+ "Portable file contains descriptors for code compiled to C.\n");
+ fprintf (stderr,
+ "The microcode is not configured to handle such code.\n");
+ quit (1);
+ }
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", Const_Count);
+ READ_HEADER ("Dumped Constant Base", "%ld", Dumped_Const_Base);
+ READ_HEADER ("Constant Objects", "%ld", Const_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 ("Max Stack Offset", "%ld", Max_Stack_Offset);
READ_HEADER ("Number of flonums", "%ld", NFlonums);
READ_HEADER ("Number of integers", "%ld", NIntegers);
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
+ READ_HEADER ("Compiler utilities vector", "%ld", Dumped_Compiler_Utilities);
- Size = (6 + /* SNMV */
- (TRAP_MAX_IMMEDIATE + 1) +
- Heap_Count + Heap_Objects +
- Constant_Count + Constant_Objects +
- Pure_Count + Pure_Objects +
- flonum_to_pointer (NFlonums) +
- ((NIntegers * (2 + (BYTES_TO_WORDS (sizeof (bignum_digit_type))))) +
- (BYTES_TO_WORDS (BIGNUM_BITS_TO_DIGITS (NBits)))) +
- ((NStrings * (1 + STRING_CHARS)) +
- (char_to_pointer (NChars))) +
- ((NBitstrs * (1 + BIT_STRING_FIRST_WORD)) +
- (BIT_STRING_LENGTH_TO_GC_LENGTH (NBBits))) +
- ((Primitive_Table_Length * (2 + STRING_CHARS)) +
- (char_to_pointer (NPChars))));
+ READ_HEADER ("Number of C code blocks", "%ld", C_Code_Table_Length);
+ READ_HEADER ("Number of characters in C code blocks", "%ld", NCChars);
+ READ_HEADER ("Number of reserved C entries", "%ld", C_Code_Reserved_Entries);
+\f
+ Dumped_Heap_Limit = Dumped_Heap_Base + Heap_Count;
+ Dumped_Const_Limit = Dumped_Const_Base + Const_Count;
+ Dumped_Pure_Limit = Dumped_Pure_Base + Pure_Count;
+
+ initial_delta = (TRAP_MAX_IMMEDIATE + 1);
+ if (Max_Stack_Offset > initial_delta)
+ initial_delta = Max_Stack_Offset;
+
+ Size = (6 /* SNMV */
+ + (2 * ((FLOATING_ALIGNMENT + 1) / (sizeof (SCHEME_OBJECT))))
+ + initial_delta
+ + (Heap_Count + Heap_Objects)
+ + (Const_Count + Const_Objects)
+ + (Pure_Count + Pure_Objects)
+ + (flonum_to_pointer (NFlonums))
+ + ((NIntegers * (2 + (BYTES_TO_WORDS (sizeof (bignum_digit_type)))))
+ + (BYTES_TO_WORDS (BIGNUM_BITS_TO_DIGITS (NBits))))
+ + ((NStrings * (1 + STRING_CHARS))
+ + (char_to_pointer (NChars)))
+ + ((NBitstrs * (1 + BIT_STRING_FIRST_WORD))
+ + (BIT_STRING_LENGTH_TO_GC_LENGTH (NBBits)))
+ + ((Primitive_Table_Length * (2 + STRING_CHARS))
+ + (char_to_pointer (NPChars)))
+ + (1 + (2 * C_Code_Table_Length) + (char_to_pointer (NCChars))));
ALLOCATE_HEAP_SPACE (Size,
Lowest_Allocated_Address,
program_name, Size);
quit (1);
}
- Heap = (Lowest_Allocated_Address + (TRAP_MAX_IMMEDIATE + 1));
- return (Size - (TRAP_MAX_IMMEDIATE + 1));
+ Heap = (Lowest_Allocated_Address + initial_delta);
+ return (Size - initial_delta);
}
\f
-void
+static void
DEFUN_VOID (do_it)
{
while (1)
{
- SCHEME_OBJECT *primitive_table_end;
+ SCHEME_OBJECT
+ * primitive_table, * primitive_table_end,
+ * c_code_table, * c_code_table_end,
+ * Dumped_Object;
Boolean result;
long Size;
Size = (Read_Header_and_Allocate ());
if (Size < 0)
- {
return;
- }
- Stack_Top = &Heap[Size];
+ if (band_p)
+ warn_portable_p = false;
+ Stack_Top = Heap;
DEBUGGING (fprintf (stderr, "Stack_Top: 0x%x\n", Stack_Top));
- Heap_Table = &Heap[0];
- Heap_Base = &Heap_Table[Heap_Objects];
- ALIGN_FLOAT (Heap_Base);
- Heap_Object_Base =
- Read_External (Heap_Objects, Heap_Table, Heap_Base);
- DEBUGGING (print_external_objects ("Heap", Heap_Table, Heap_Objects));
- DEBUGGING (fprintf (stderr, "Heap_Base: 0x%x\n", Heap_Base));
- DEBUGGING (fprintf (stderr, "Heap_Object_Base: 0x%x\n", Heap_Object_Base));
+ Heap_Table = &Heap[Size - Heap_Objects];
+ Const_Table = &Heap_Table[- Const_Objects];
+ Pure_Table = &Const_Table[- Pure_Objects];
- /* The various 2s below are for SNMV headers. */
+ /* The various 2s below are for SNMV headers in constant/pure markers. */
- Pure_Table = &Heap_Object_Base[Heap_Count];
- Pure_Base = &Pure_Table[Pure_Objects + 2];
- Pure_Object_Base =
- Read_External (Pure_Objects, Pure_Table, Pure_Base);
- DEBUGGING (print_external_objects ("Pure", Pure_Table, Pure_Objects));
+ Constant_Space = &Heap[0];
+ ALIGN_FLOAT (Constant_Space);
+
+ Pure_Base = &Constant_Space[2];
+ Pure_Object_Limit
+ = (Read_External (Pure_Objects, Pure_Table, Pure_Base));
+
+ XDEBUGGING (print_external_objects ("Pure", Pure_Table, Pure_Objects));
DEBUGGING (fprintf (stderr, "Pure_Base: 0x%x\n", Pure_Base));
- DEBUGGING (fprintf (stderr, "Pure_Object_Base: 0x%x\n", Pure_Object_Base));
+ DEBUGGING (fprintf (stderr, "Pure_Object_Limit: 0x%x\n",
+ Pure_Object_Limit));
- Constant_Table = &Heap[Size - Constant_Objects];
- Constant_Base = &Pure_Object_Base[Pure_Count + 2];
- Constant_Object_Base =
- Read_External (Constant_Objects, Constant_Table, Constant_Base);
- DEBUGGING (print_external_objects ("Constant",
- Constant_Table,
- Constant_Objects));
- DEBUGGING (fprintf (stderr, "Constant_Base: 0x%x\n", Constant_Base));
- DEBUGGING (fprintf (stderr, "Constant_Object_Base: 0x%x\n",
- Constant_Object_Base));
+ Const_Base = &Pure_Object_Limit[Pure_Count + 2];
+ Const_Object_Limit
+ = (Read_External (Const_Objects, Const_Table, Const_Base));
- primitive_table = &Constant_Object_Base[Constant_Count + 2];
+ XDEBUGGING (print_external_objects ("Constant", Const_Table,
+ Const_Objects));
+ DEBUGGING (fprintf (stderr, "Const_Base: 0x%x\n", Const_Base));
+ DEBUGGING (fprintf (stderr, "Const_Object_Limit: 0x%x\n",
+ Const_Object_Limit));
- WHEN ((primitive_table > Constant_Table),
- "primitive_table overran Constant_Table");
+ Constant_Top = &Const_Object_Limit[Const_Count + 2];
- /* Read the normal objects */
+ Heap_Base = Constant_Top;
+ ALIGN_FLOAT (Heap_Base);
+ Heap_Object_Limit
+ = (Read_External (Heap_Objects, Heap_Table, Heap_Base));
- Free =
- Read_Pointers_and_Relocate (Heap_Count, Heap_Object_Base);
+ XDEBUGGING (print_external_objects ("Heap", Heap_Table, Heap_Objects));
+ DEBUGGING (fprintf (stderr, "Heap_Base: 0x%x\n", Heap_Base));
+ DEBUGGING (fprintf (stderr, "Heap_Object_Limit: 0x%x\n",
+ Heap_Object_Limit));
- WHEN ((Free > Pure_Table),
- "Free overran Pure_Table");
- WHEN ((Free < Pure_Table),
- "Free did not reach Pure_Table");
+ primitive_table = &Heap_Object_Limit[Heap_Count];
- Free_Pure =
- Read_Pointers_and_Relocate (Pure_Count, Pure_Object_Base);
+ WHEN ((primitive_table > &Heap[Size]), "primitive_table overran memory.");
- WHEN ((Free_Pure > (Constant_Base - 2)),
- "Free_Pure overran Constant_Base");
- WHEN ((Free_Pure < (Constant_Base - 2)),
- "Free_Pure did not reach Constant_Base");
+ /* Read the normal objects */
- Free_Constant =
- Read_Pointers_and_Relocate (Constant_Count, Constant_Object_Base);
+ Free_Pure = (Read_Pointers_and_Relocate (Pure_Count, Pure_Object_Limit));
+ WHEN ((Free_Pure > (Const_Base - 2)),
+ "Free_Pure overran Const_Base");
+ WHEN ((Free_Pure < (Const_Base - 2)),
+ "Free_Pure did not reach Const_Base");
- WHEN ((Free_Constant > (primitive_table - 2)),
- "Free_Constant overran primitive_table");
- WHEN ((Free_Constant < (primitive_table - 2)),
- "Free_Constant did not reach primitive_table");
+ Free_Const = (Read_Pointers_and_Relocate (Const_Count,
+ Const_Object_Limit));
+ WHEN ((Free_Const > (Constant_Top - 2)),
+ "Free_Const overran Constant_Top");
+ WHEN ((Free_Const < (Constant_Top - 2)),
+ "Free_Const did not reach Constant_Top");
- primitive_table_end =
- read_primitives (Primitive_Table_Length, primitive_table);
+ Free = (Read_Pointers_and_Relocate (Heap_Count, Heap_Object_Limit));
- /*
- primitive_table_end can be well below Constant_Table, since
- the memory allocation is conservative (it rounds up), and all
- the slack ends up between them.
- */
+ WHEN ((Free > primitive_table), "Free overran primitive_table");
+ WHEN ((Free < primitive_table), "Free did not reach primitive_table");
- WHEN ((primitive_table_end > Constant_Table),
- "primitive_table_end overran Constant_Table");
+ primitive_table_end
+ = (read_primitives (Primitive_Table_Length, primitive_table));
if (primitive_warn)
{
fprintf (stderr, "%s:\n", program_name);
- fprintf (stderr,
- "NOTE: The binary file contains primitives with unknown arity.\n");
+ fprintf
+ (stderr,
+ "NOTE: The binary file contains primitives with unknown arity.\n");
}
- /* Dump the objects */
+ c_code_table = primitive_table_end;
+ c_code_table_end
+ = (read_c_code_blocks (C_Code_Reserved_Entries,
+ C_Code_Table_Length,
+ c_code_table));
- {
- SCHEME_OBJECT *Dumped_Object;
+ WHEN ((c_code_table_end > Pure_Table),
+ "c_code_table_end overran Pure_Table");
+ /*
+ c_code_table_end can be well below Pure_Table, since
+ the memory allocation is conservative (it rounds up), and all
+ the slack ends up between them.
+ */
+
+ /* Dump the objects */
Relocate_Into (Dumped_Object, Dumped_Object_Addr);
Pure_Base, (Free_Pure - Pure_Base)));
DEBUGGING (fprintf (stderr,
"Constant Space = 0x%x; Constant Count = %d\n",
- Constant_Base, (Free_Constant - Constant_Base)));
+ Const_Base, (Free_Const - Const_Base)));
DEBUGGING (fprintf (stderr,
"& Dumped Object = 0x%x; Dumped Object = 0x%x\n",
- Dumped_Object, *Dumped_Object));
+ Dumped_Object, * Dumped_Object));
DEBUGGING (fprintf (stderr, "Primitive_Table_Length = %ld; ",
Primitive_Table_Length));
DEBUGGING (fprintf (stderr, "Primitive_Table_Size = %ld\n",
/* Is there a Pure/Constant block? */
- if ((Constant_Objects == 0) && (Constant_Count == 0) &&
- (Pure_Objects == 0) && (Pure_Count == 0))
- {
- result = Write_File (Dumped_Object,
- (Free - Heap_Base), Heap_Base,
- 0, Stack_Top,
- primitive_table, Primitive_Table_Length,
- ((long) (primitive_table_end - primitive_table)),
- compiled_p, band_p);
- }
+ if ((Const_Objects == 0) && (Const_Count == 0)
+ && (Pure_Objects == 0) && (Pure_Count == 0))
+ result = (Write_File (Dumped_Object,
+ (Free - Heap_Base), Heap_Base,
+ 0, Stack_Top,
+ primitive_table, Primitive_Table_Length,
+ ((long) (primitive_table_end - primitive_table)),
+ c_code_table, C_Code_Table_Length,
+ ((long) (c_code_table_end - c_code_table)),
+ compiled_p, band_p));
else
{
long Pure_Length, Total_Length;
- Pure_Length = (Constant_Base - Pure_Base) + 1;
- Total_Length = (Free_Constant - Pure_Base) + 4;
- Pure_Base[-2] =
- MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, (Pure_Length - 1));
- Pure_Base[-1] =
- MAKE_OBJECT (PURE_PART, Total_Length);
- Constant_Base[-2] =
- MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- Constant_Base[-1] =
- MAKE_OBJECT (CONSTANT_PART, (Pure_Length - 1));
- Free_Constant[0] =
- MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- Free_Constant[1] =
- MAKE_OBJECT (END_OF_BLOCK, Total_Length);
+ Pure_Length = ((Const_Base - Pure_Base) + 1);
+ Total_Length = ((Constant_Top - Pure_Base) + 1);
+ Pure_Base[-2] = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR,
+ Pure_Length));
+ Pure_Base[-1] = (MAKE_OBJECT (PURE_PART, Total_Length));
+ Const_Base[-2] = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
+ Const_Base[-1] = (MAKE_OBJECT (CONSTANT_PART, Pure_Length));
+ Free_Const[0] = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
+ Free_Const[1] = (MAKE_OBJECT (END_OF_BLOCK, Total_Length));
result = (Write_File (Dumped_Object,
(Free - Heap_Base), Heap_Base,
- Total_Length, (Pure_Base - 2),
+ (Total_Length + 1), (Pure_Base - 2),
primitive_table, Primitive_Table_Length,
((long) (primitive_table_end - primitive_table)),
+ c_code_table, C_Code_Table_Length,
+ ((long) (c_code_table_end - c_code_table)),
compiled_p, band_p));
}
- }
+
if (!result)
{
fprintf (stderr, "%s: Error writing the output file.\n", program_name);
{
parse_keywords (argc, argv, options, false);
if (help_sup_p && help_p)
- {
print_usage_and_exit (options, 0);
/*NOTREACHED*/
- }
+
allow_nmv_p = (allow_nmv_p || allow_compiled_p);
setup_io ("r", "wb");
projects / mit-scheme.git / commitdiff