promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bintopsb.c,v 9.26 1987/06/05 04:10:41 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bintopsb.c,v 9.27 1987/08/07 15:34:56 jinx Exp $
*
* This File contains the code to translate internal format binary
* files to portable format.
static long Heap_Relocation, Constant_Relocation;
static long Free, Scan, Free_Constant, Scan_Constant;
static long Objects, Constant_Objects;
-static long NFlonums, NIntegers, NStrings;
-static long NBits, NChars;
static Pointer *Free_Objects, *Free_Cobjects;
+static long NFlonums;
+static long NIntegers, NBits;
+static long NBitstrs, NBBits;
+static long NStrings, NChars;
+
long
Load_Data(Count, To_Where)
long Count;
*/
#ifndef isalpha
+
/* Just in case the stdio library atypically contains the character
macros, just like the C book claims. */
+
#include <ctype.h>
+
#endif
#ifndef ispunct
+
/* This is in some libraries but not others */
+
static char punctuation[] = "'\",<.>/?;:{}[]|`~=+-_()*&^%$#@!";
-Boolean ispunct(c)
-fast char c;
-{ fast char *s = &punctuation[0];
- while (*s != '\0') if (*s++ == c) return true;
+Boolean
+ispunct(c)
+ fast char c;
+{
+ fast char *;
+
+ s = &punctuation[0];
+ while (*s != '\0')
+ if (*s++ == c)
+ return true;
return false;
}
#endif
-#define OUT(s) \
-fprintf(Portable_File, s); \
+#define OUT(s) \
+fprintf(Portable_File, s); \
break
void
char *name;
{
switch(c)
- { case '\n': OUT("\\n");
+ {
+ case '\n': OUT("\\n");
case '\t': OUT("\\t");
case '\b': OUT("\\b");
case '\r': OUT("\\r");
if ((isalpha(c)) || (isdigit(c)) || (ispunct(c)))
putc(c, Portable_File);
else
- { fprintf(stderr,
+ {
+ fprintf(stderr,
"%s: %s: File may not be portable: c = 0x%x\n",
Program_Name, name, ((int) c));
/* This does not follow C conventions, but eliminates ambiguity */
}
}
\f
-#define Do_String(Code, Rel, Fre, Scn, Obj, FObj) \
+#define Do_Compound(Code, Rel, Fre, Scn, Obj, FObj, kernel_code) \
{ \
Old_Address += (Rel); \
Old_Contents = *Old_Address; \
+ \
if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
Mem_Base[(Scn)] = \
Make_New_Pointer((Code), Old_Contents); \
else \
{ \
- fast long i; \
- \
- Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
- (Obj) += 1; \
- *(FObj)++ = Make_Non_Pointer(TC_CHARACTER_STRING, 0); \
- *(FObj)++ = Old_Contents; \
- i = Get_Integer(Old_Contents); \
- NStrings += 1; \
- NChars += pointer_to_char(i-1); \
- while(--i >= 0) \
- *(FObj)++ = *Old_Address++; \
+ kernel_code; \
} \
}
-void
-print_a_string(from)
- Pointer *from;
-{ fast long len;
- fast char *string;
- long maxlen;
+#define standard_kernel(kernel_code, type, Code, Scn, Obj, FObj) \
+{ \
+ fast long length; \
+ \
+ Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
+ length = Get_Integer(Old_Contents); \
+ kernel_code; \
+ *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
+ (Obj) += 1; \
+ *(FObj)++ = Make_Non_Pointer((type), 0); \
+ *(FObj)++ = Old_Contents; \
+ while(--length >= 0) \
+ *(FObj)++ = *Old_Address++; \
+}
+\f
+#define do_string_kernel() \
+{ \
+ NStrings += 1; \
+ NChars += pointer_to_char(length - 1); \
+}
- maxlen = pointer_to_char((Get_Integer(*from++))-1);
- len = Get_Integer(*from++);
- fprintf(Portable_File, "%02x %ld %ld ",
- TC_CHARACTER_STRING,
- (Compact_P ? len : maxlen),
- len);
- string = ((char *) from);
- if (Shuffle_Bytes)
- { while(len > 0)
- {
- print_a_char(string[3], "print_a_string");
- if (len > 1)
- print_a_char(string[2], "print_a_string");
- if (len > 2)
- print_a_char(string[1], "print_a_string");
- if (len > 3)
- print_a_char(string[0], "print_a_string");
- len -= 4;
- string += 4;
- }
- }
- else while(--len >= 0) print_a_char(*string++, "print_a_string");
- putc('\n', Portable_File);
- return;
+#define do_bignum_kernel() \
+{ \
+ NIntegers += 1; \
+ NBits += bignum_to_bits(LEN(BIGNUM(Old_Address))); \
}
+
+#define do_bit_string_kernel() \
+{ \
+ NBitstrs += 1; \
+ NBBits += Old_Address[BIT_STRING_LENGTH_OFFSET]; \
+}
+
+#define do_flonum_kernel(Code, Scn, Obj, FObj) \
+{ \
+ Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
+ NFlonums += 1; \
+ *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
+ (Obj) += 1; \
+ *(FObj)++ = Make_Non_Pointer(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(), 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, \
+ 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, \
+ 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
print_a_fixnum(val)
fprintf(Portable_File, "%ld ", size_in_bits);
temp = ((val < 0) ? -val : val);
while (temp != 0)
- { fprintf(Portable_File, "%01lx", (temp % 16));
+ {
+ fprintf(Portable_File, "%01lx", (temp & 0xf));
temp = temp >> 4;
}
fprintf(Portable_File, "\n");
return;
}
\f
-#define Do_Bignum(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer((Code), Old_Contents); \
- else \
- { fast long length; \
- Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
- NIntegers += 1; \
- NBits += bignum_to_bits(LEN(BIGNUM(Old_Address))); \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
- (Obj) += 1; \
- *(FObj)++ = Make_Non_Pointer(TC_BIG_FIXNUM, 0); \
- *(FObj)++ = Old_Contents; \
- for (length = Get_Integer(Old_Contents); \
- --length >= 0; ) \
- *(FObj)++ = *Old_Address++; \
- } \
-}
+void
+print_a_string(from)
+ Pointer *from;
+{
+ fast long len;
+ fast char *string;
+ long maxlen;
+ maxlen = pointer_to_char((Get_Integer(*from++))-1);
+ len = Get_Integer(*from++);
+ fprintf(Portable_File, "%02x %ld %ld ",
+ TC_CHARACTER_STRING,
+ (Compact_P ? len : maxlen),
+ len);
+ string = ((char *) from);
+ if (Shuffle_Bytes)
+ {
+ while(len > 0)
+ {
+ print_a_char(string[3], "print_a_string");
+ if (len > 1)
+ print_a_char(string[2], "print_a_string");
+ if (len > 2)
+ print_a_char(string[1], "print_a_string");
+ if (len > 3)
+ print_a_char(string[0], "print_a_string");
+ len -= 4;
+ string += 4;
+ }
+ }
+ else
+ while(--len >= 0)
+ print_a_char(*string++, "print_a_string");
+ putc('\n', Portable_File);
+ return;
+}
+\f
void
print_a_bignum(from)
Pointer *from;
fprintf(Portable_File, "%02x + 0\n",
(Compact_P ? TC_FIXNUM : TC_BIG_FIXNUM));
else
- { fast long tail;
+ {
+ fast long tail;
+
for (size_in_bits = ((temp - 1) * SHIFT),
temp = ((long) (*Bignum_Top(the_number)));
temp != 0;
(NEG_BIGNUM(the_number) ? '-' : '+'),
size_in_bits);
tail = size_in_bits % SHIFT;
- if (tail == 0) tail = SHIFT;
+ if (tail == 0)
+ tail = SHIFT;
temp = 0;
size_in_bits = 0;
the_top = Bignum_Top(the_number);
for(the_number = Bignum_Bottom(the_number);
the_number <= the_top;
the_number += 1)
- { temp |= (((unsigned long) (*the_number)) << size_in_bits);
+ {
+ temp |= (((unsigned long) (*the_number)) << size_in_bits);
for (size_in_bits += ((the_number != the_top) ? SHIFT : tail);
size_in_bits > 3;
size_in_bits -= 4)
- { fprintf(Portable_File, "%01lx", temp % 16);
+ {
+ fprintf(Portable_File, "%01lx", (temp & 0xf));
temp = temp >> 4;
}
}
- if (size_in_bits > 0) fprintf(Portable_File, "%01lx\n", temp);
- else fprintf(Portable_File, "\n");
+ if (size_in_bits > 0)
+ fprintf(Portable_File, "%01lx\n", (temp & 0xf));
+ else
+ fprintf(Portable_File, "\n");
}
return;
}
\f
-#define Do_Flonum(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer((Code), Old_Contents); \
- else \
- { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
- Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
- (Obj) += 1; \
- *(FObj)++ = Make_Non_Pointer(TC_BIG_FLONUM, 0); \
- *((double *) (FObj)) = *((double *) Old_Address); \
- (FObj) += float_to_pointer; \
- NFlonums += 1; \
- } \
-}
+/* The following procedure assumes that a C long is at least 4 bits. */
+
+print_a_bit_string(from)
+ Pointer *from;
+{
+ Pointer the_bit_string;
+ fast long bits_remaining, leftover_bits;
+ fast Pointer accumulator, next_word, *scan;
+
+ the_bit_string = Make_Pointer(TC_BIT_STRING, from);
+ bits_remaining = bit_string_length(the_bit_string);
+ fprintf(Portable_File, "%02x %ld", TC_BIT_STRING, bits_remaining);
+
+ if (bits_remaining != 0)
+ {
+ fprintf(Portable_File, " ");
+ scan = bit_string_low_ptr(the_bit_string);
+ for (leftover_bits = 0;
+ bits_remaining > 0;
+ bits_remaining -= POINTER_LENGTH)
+ {
+ next_word = *(inc_bit_string_ptr(scan));
+
+ if (bits_remaining < POINTER_LENGTH)
+ next_word &= low_mask(bits_remaining);
+
+ if (leftover_bits != 0)
+ {
+ accumulator &= low_mask(leftover_bits);
+ accumulator |=
+ ((next_word & low_mask(4 - leftover_bits)) << leftover_bits);
+ next_word = (next_word >> (4 - leftover_bits));
+ leftover_bits += ((bits_remaining > POINTER_LENGTH) ?
+ (POINTER_LENGTH - 4) :
+ (bits_remaining - 4));
+ fprintf(Portable_File, "%01lx", (accumulator & 0xf));
+ }
+ else
+ {
+ leftover_bits = ((bits_remaining > POINTER_LENGTH) ?
+ POINTER_LENGTH :
+ bits_remaining);
+ }
+ for(accumulator = next_word; leftover_bits >= 4; leftover_bits -= 4)
+ {
+ fprintf(Portable_File, "%01lx", (accumulator & 0xf));
+ accumulator = accumulator >> 4;
+ }
+ }
+ if (leftover_bits != 0)
+ fprintf(Portable_File, "%01lx", (accumulator & 0xf));
+ }
+ fprintf(Portable_File, "\n");
+ return;
+}
+\f
print_a_flonum(val)
-double val;
-{ fast long size_in_bits;
+ double val;
+{
+ fast long size_in_bits;
fast double mant, temp;
int expt;
extern double frexp();
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);
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;
+ {
+ temp *= 2.0;
+ if (temp >= 1.0)
+ temp -= 1.0;
}
fprintf(Portable_File, "%ld %ld ", expt, size_in_bits);
+
for (size_in_bits = hex_digits(size_in_bits);
size_in_bits > 0;
size_in_bits -= 1)
- { fast unsigned int digit = 0;
+ {
+ fast unsigned int digit;
+
+ digit = 0;
for (expt = 4; --expt >= 0;)
- { mant *= 2.0;
+ {
+ mant *= 2.0;
digit = digit << 1;
if (mant >= 1.0)
- { mant -= 1.0;
+ {
+ mant -= 1.0;
digit += 1;
}
}
\f
/* Normal Objects */
-#define Do_Cell(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer(Type_Code(This), Old_Contents); \
- else \
- { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- } \
+#define Do_Cell(Code, Rel, Fre, Scn, Obj, FObj) \
+{ \
+ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ Mem_Base[(Scn)] = \
+ Make_New_Pointer(Type_Code(This), Old_Contents); \
+ else \
+ { \
+ *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
+ Mem_Base[(Fre)++] = Old_Contents; \
+ } \
}
-#define Do_Pair(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer(Type_Code(This), Old_Contents); \
- else \
- { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- Mem_Base[(Fre)++] = *Old_Address++; \
- } \
+#define Do_Pair(Code, Rel, Fre, Scn, Obj, FObj) \
+{ \
+ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ Mem_Base[(Scn)] = \
+ Make_New_Pointer(Type_Code(This), Old_Contents); \
+ else \
+ { \
+ *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
+ Mem_Base[(Fre)++] = Old_Contents; \
+ Mem_Base[(Fre)++] = *Old_Address++; \
+ } \
}
-#define Do_Triple(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer(Type_Code(This), Old_Contents); \
- else \
- { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- Mem_Base[(Fre)++] = *Old_Address++; \
- Mem_Base[(Fre)++] = *Old_Address++; \
- } \
+#define Do_Triple(Code, Rel, Fre, Scn, Obj, FObj) \
+{ \
+ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ Mem_Base[(Scn)] = \
+ Make_New_Pointer(Type_Code(This), Old_Contents); \
+ else \
+ { \
+ *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
+ Mem_Base[(Fre)++] = Old_Contents; \
+ Mem_Base[(Fre)++] = *Old_Address++; \
+ Mem_Base[(Fre)++] = *Old_Address++; \
+ } \
}
-#define Do_Vector(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer(Type_Code(This), Old_Contents); \
- else \
- { fast long len = Get_Integer(Old_Contents); \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- while (len > 0) \
- { Mem_Base[(Fre)++] = *Old_Address++; \
- len -= 1; \
- } \
- } \
+#define Do_Vector(Code, Rel, Fre, Scn, Obj, FObj) \
+{ \
+ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ Mem_Base[(Scn)] = \
+ Make_New_Pointer(Type_Code(This), Old_Contents); \
+ else \
+ { \
+ fast long len; \
+ \
+ len = Get_Integer(Old_Contents); \
+ *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
+ Mem_Base[(Fre)++] = Old_Contents; \
+ while (len > 0) \
+ { \
+ Mem_Base[(Fre)++] = *Old_Address++; \
+ len -= 1; \
+ } \
+ } \
}
\f
/* Common Pointer Code */
-#define Do_Pointer(Scn, Action) \
-Old_Address = Get_Pointer(This); \
-if (Datum(This) < Const_Base) \
- Action(HEAP_CODE, Heap_Relocation, Free, \
- Scn, Objects, Free_Objects) \
-else if (Datum(This) < Dumped_Constant_Top) \
-Action(CONSTANT_CODE, Constant_Relocation, Free_Constant, \
- Scn, Constant_Objects, Free_Cobjects) \
-else \
-{ fprintf(stderr, \
- "%s: File is not portable: Pointer to stack.\n", \
- Program_Name); \
- exit(1); \
-} \
-(Scn) += 1; \
-break
+#define Do_Pointer(Scn, Action) \
+{ \
+ Old_Address = Get_Pointer(This); \
+ if (Datum(This) < Const_Base) \
+ { \
+ Action(HEAP_CODE, Heap_Relocation, Free, \
+ Scn, Objects, Free_Objects); \
+ } \
+ else if (Datum(This) < Dumped_Constant_Top) \
+ { \
+ Action(CONSTANT_CODE, Constant_Relocation, Free_Constant, \
+ Scn, Constant_Objects, Free_Cobjects); \
+ } \
+ else \
+ { \
+ fprintf(stderr, \
+ "%s: File is not portable: Pointer to stack.\n", \
+ Program_Name); \
+ exit(1); \
+ } \
+ (Scn) += 1; \
+ break; \
+}
\f
/* Processing of a single area */
-#define Do_Area(Code, Area, Bound, Obj, FObj) \
+#define Do_Area(Code, Area, Bound, Obj, FObj) \
Process_Area(Code, &Area, &Bound, &Obj, &FObj)
Process_Area(Code, Area, Bound, Obj, FObj)
-int Code;
-fast long *Area, *Bound;
-fast long *Obj;
-fast Pointer **FObj;
-{ fast Pointer This, *Old_Address, Old_Contents;
+ int Code;
+ fast long *Area, *Bound;
+ fast long *Obj;
+ fast Pointer **FObj;
+{
+ fast Pointer This, *Old_Address, Old_Contents;
+
while(*Area != *Bound)
- { This = Mem_Base[*Area];
+ {
+ This = Mem_Base[*Area];
Switch_by_GC_Type(This)
- { case TC_MANIFEST_NM_VECTOR:
+ {
+ case TC_MANIFEST_NM_VECTOR:
if (Null_NMV)
- { fast int i = Get_Integer(This);
+ {
+ fast int i;
+
+ i = Get_Integer(This);
*Area += 1;
for ( ; --i >= 0; *Area += 1)
Mem_Base[*Area] = NIL;
break;
case TC_BROKEN_HEART:
- /* [Broken Heart 0] is the cdr of fasdumped symbols. */
+ /* [Broken Heart 0] is the cdr of fasdumped symbols. */
if (Get_Integer(This) != 0)
- { fprintf(stderr, "%s: Broken Heart found in scan.\n",
+ {
+ fprintf(stderr, "%s: Broken Heart found in scan.\n",
Program_Name);
exit(1);
}
NIntegers += 1;
NBits += fixnum_to_bits;
/* Fall Through */
+
case TC_CHARACTER:
Process_Character:
Mem_Base[*Area] = Make_Non_Pointer(Code, *Obj);
**FObj = This;
*FObj += 1;
/* Fall through */
+
case TC_MANIFEST_SPECIAL_NM_VECTOR:
case TC_PRIMITIVE_EXTERNAL:
case_simple_Non_Pointer:
exit(1);
}
/* Fall through */
+
case TC_FUTURE:
case_simple_Vector:
- Do_Pointer(*Area, Do_Vector);
+ if (Type_Code(This) == TC_BIT_STRING)
+ {
+ Do_Pointer(*Area, Do_Bit_String);
+ }
+ else
+ {
+ Do_Pointer(*Area, Do_Vector);
+ }
default:
Bad_Type:
\f
/* Output macros */
-#define print_an_object(obj) \
-fprintf(Portable_File, "%02x %lx\n", \
- Type_Code(obj), Get_Integer(obj))
-
-#define print_external_object(from) \
-{ switch(Type_Code(*from)) \
- { case TC_FIXNUM: \
- { long Value; \
- Sign_Extend(*from++, Value); \
- print_a_fixnum(Value); \
- break; \
- } \
- case TC_BIG_FIXNUM: \
- from += 1; \
- print_a_bignum(from); \
- from += 1 + Get_Integer(*from); \
- break; \
- case TC_CHARACTER_STRING: \
- from += 1; \
- print_a_string(from); \
- from += 1 + Get_Integer(*from); \
- break; \
- case TC_BIG_FLONUM: \
- print_a_flonum(*((double *) (from+1))); \
- from += 1 + float_to_pointer; \
- break; \
- case TC_CHARACTER: \
- fprintf(Portable_File, "%02x %03x\n", \
- TC_CHARACTER, (*from & MASK_EXTNDD_CHAR)); \
- from += 1; \
- break; \
- default: \
- fprintf(stderr, \
- "%s: Bad Object to print externally %lx\n", \
- Program_Name, *from); \
- exit(1); \
- } \
+#define print_external_object(from) \
+{ \
+ switch(Type_Code(*from)) \
+ { \
+ case TC_FIXNUM: \
+ { \
+ long Value; \
+ \
+ Sign_Extend(*from++, Value); \
+ print_a_fixnum(Value); \
+ break; \
+ } \
+ \
+ case TC_BIT_STRING: \
+ print_a_bit_string(++from); \
+ from += 1 + Get_Integer(*from); \
+ break; \
+ \
+ case TC_BIG_FIXNUM: \
+ print_a_bignum(++from); \
+ from += 1 + Get_Integer(*from); \
+ break; \
+ \
+ case TC_CHARACTER_STRING: \
+ print_a_string(++from); \
+ from += 1 + Get_Integer(*from); \
+ break; \
+ \
+ case TC_BIG_FLONUM: \
+ print_a_flonum( *((double *) (from + 1))); \
+ from += 1 + float_to_pointer; \
+ break; \
+ \
+ case TC_CHARACTER: \
+ fprintf(Portable_File, "%02x %03x\n", \
+ TC_CHARACTER, (*from & MASK_EXTNDD_CHAR)); \
+ from += 1; \
+ break; \
+ \
+ default: \
+ fprintf(stderr, \
+ "%s: Bad Object to print externally %lx\n", \
+ Program_Name, *from); \
+ exit(1); \
+ } \
}
\f
+#define print_an_object(obj) \
+fprintf(Portable_File, "%02x %lx\n", \
+ Type_Code(obj), Get_Integer(obj))
+
/* Debugging Aids and Consistency Checks */
#ifdef DEBUG
When(what, message)
-Boolean what;
-char *message;
-{ if (what)
- { fprintf(stderr, "%s: Inconsistency: %s!\n",
+ Boolean what;
+ char *message;
+{
+ if (what)
+ {
+ fprintf(stderr, "%s: Inconsistency: %s!\n",
Program_Name, (message));
exit(1);
}
return;
}
-#define print_header(name, obj, format) \
-fprintf(Portable_File, (format), (obj)); \
-fprintf(stderr, "%s: ", (name)); \
-fprintf(stderr, (format), (obj))
+#define print_header(name, obj, format) \
+{ \
+ fprintf(Portable_File, (format), (obj)); \
+ fprintf(stderr, "%s: ", (name)); \
+ fprintf(stderr, (format), (obj)); \
+}
#else
#define When(what, message)
-#define print_header(name, obj, format) \
-fprintf(Portable_File, (format), (obj))
+#define print_header(name, obj, format) \
+{ \
+ fprintf(Portable_File, (format), (obj)); \
+}
#endif
\f
/* The main program */
do_it()
-{ Pointer *Heap;
+{
+ Pointer *Heap;
long Initial_Free;
/* Load the Data */
if (!Read_Header())
- { fprintf(stderr,
+ {
+ fprintf(stderr,
"%s: Input file does not appear to be in FASL format.\n",
Program_Name);
exit(1);
(Sub_Version > FASL_SUBVERSION) ||
(Sub_Version < FASL_OLDEST_SUPPORTED) ||
((Machine_Type != FASL_INTERNAL_FORMAT) && (!Shuffle_Bytes)))
- { fprintf(stderr, "%s:\n", Program_Name);
+ {
+ fprintf(stderr, "%s:\n", Program_Name);
fprintf(stderr,
"FASL File Version %ld Subversion %ld Machine Type %ld\n",
Version, Sub_Version , Machine_Type);
if (Machine_Type == FASL_INTERNAL_FORMAT)
Shuffle_Bytes = false;
+
upgrade_traps = (Sub_Version < FASL_REFERENCE_TRAP);
/* Constant Space not currently supported */
if (Const_Count != 0)
- { fprintf(stderr,
+ {
+ fprintf(stderr,
"%s: Input file has a constant space area.\n",
Program_Name);
exit(1);
}
- { long Size = ((3 * (Heap_Count + Const_Count)) + NROOTS + 1);
+ {
+ long Size;
+
+ Size = ((3 * (Heap_Count + Const_Count)) + NROOTS + 1);
Allocate_Heap_Space(Size + HEAP_BUFFER_SPACE);
+
if (Heap == NULL)
- { fprintf(stderr,
+ {
+ fprintf(stderr,
"%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n",
Program_Name, Size);
exit(1);
\f
/* Reformat the data */
- NFlonums = NIntegers = NStrings = NBits = NChars = 0;
+ NFlonums = NIntegers = NStrings = 0;
+ NBits = NBBits = NChars = 0;
Mem_Base = &Heap[Heap_Count + Const_Count];
+
if (Ext_Prim_Vector == NIL)
- { Mem_Base[0] = Make_Non_Pointer(TC_CELL, 2);
+ {
+ Mem_Base[0] = Make_Non_Pointer(TC_CELL, 2);
Mem_Base[1] = Make_New_Pointer(TC_CELL, Dumped_Object);
Mem_Base[2] = NIL;
Initial_Free = NROOTS + 1;
Scan = 1;
}
else
- { Mem_Base[0] = Ext_Prim_Vector; /* Has CELL TYPE */
+ {
+ Mem_Base[0] = Ext_Prim_Vector; /* Has CELL TYPE */
Mem_Base[1] = Make_New_Pointer(TC_CELL, Dumped_Object);
Initial_Free = NROOTS;
Scan = 0;
}
+
Free = Initial_Free;
Free_Objects = &Mem_Base[Heap_Count + Initial_Free];
Objects = 0;
/* 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(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, Fre_Pure, Pure_Objects, Free_Pobjects);
- if (Scan == Free) break;
+ if (Scan == Free)
+ break;
}
#endif
\f
print_header("Flags", Make_Flags(), "%ld\n");
print_header("Version", FASL_FORMAT_VERSION, "%ld\n");
print_header("Sub Version", FASL_SUBVERSION, "%ld\n");
+
print_header("Heap Count", (Free - NROOTS), "%ld\n");
print_header("Heap Base", NROOTS, "%ld\n");
print_header("Heap Objects", Objects, "%ld\n");
print_header("Pure Count", 0, "%ld\n");
print_header("Pure Base", Free_Constant, "%ld\n");
print_header("Pure Objects", 0, "%ld\n");
+
print_header("Constant Count", 0, "%ld\n");
print_header("Constant Base", Free_Constant, "%ld\n");
print_header("Constant Objects", 0, "%ld\n");
+ print_header("& Dumped Object", (Get_Integer(Mem_Base[1])), "%ld\n");
+ print_header("& Ext Prim Vector", (Get_Integer(Mem_Base[0])), "%ld\n");
+
print_header("Number of flonums", NFlonums, "%ld\n");
print_header("Number of integers", NIntegers, "%ld\n");
- print_header("Number of strings", NStrings, "%ld\n");
print_header("Number of bits in integers", NBits, "%ld\n");
+ print_header("Number of bit strings", NBitstrs, "%ld\n");
+ print_header("Number of bits in bit strings", NBBits, "%ld\n");
+ print_header("Number of character strings", NStrings, "%ld\n");
print_header("Number of characters in strings", NChars, "%ld\n");
- print_header("& Dumped Object", (Get_Integer(Mem_Base[1])), "%ld\n");
- print_header("& Ext Prim Vector", (Get_Integer(Mem_Base[0])), "%ld\n");
\f
/* External Objects */
Free_Cobjects = &Mem_Base[Constant_Objects_Start];
for (; Constant_Objects > 0; Constant_Objects -= 1)
+ {
print_external_object(Free_Cobjects);
+ }
#endif
\f
for (Free_Objects = &Mem_Base[NROOTS];
Free_Objects < Free_Cobjects;
Free_Objects += 1)
+ {
print_an_object(*Free_Objects);
+ }
#if false
/* Pure Objects */
for (Free_Objects = &Mem_Base[Pure_Start];
Free_Objects < Free_Cobjects;
Free_Objects += 1)
+ {
print_an_object(*Free_Objects);
+ }
/* Constant Objects */
for (Free_Objects = &Mem_Base[Constant_Start];
Free_Objects < Free_Cobjects;
Free_Objects += 1)
+ {
print_an_object(*Free_Objects);
+ }
#endif
return;
{"Swap_Bytes", true, &Shuffle_Bytes}};
main(argc, argv)
-int argc;
-char *argv[];
-{ Setup_Program(argc, argv, Noptions, Options);
+ int argc;
+ char *argv[];
+{
+ Setup_Program(argc, argv, Noptions, Options);
return;
}
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/psbmap.h,v 9.21 1987/01/22 14:33:52 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/psbmap.h,v 9.22 1987/08/07 15:36:46 jinx Rel $
*
* This file contains macros and declarations for Bintopsb.c
* and Psbtobin.c
#include "config.h"
#include "object.h"
#include "bignum.h"
+#include "bitstr.h"
#include "gc.h"
#include "types.h"
#include "sdata.h"
#include "missing.c"
#endif
-#define PORTABLE_VERSION 1
+#define PORTABLE_VERSION 2
/* Number of objects which, when traced recursively, point at all other
objects dumped. Currently the dumped object and the external
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/psbtobin.c,v 9.25 1987/06/05 04:11:31 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/psbtobin.c,v 9.26 1987/08/07 15:34:27 jinx Exp $
*
* This File contains the code to translate portable format binary
* files to internal format.
fprintf(stderr,
"%s: File is not Portable. Character Code Found.\n",
Program_Name);
- fscanf(Portable_File, "%d", &Code);
+ fscanf(Portable_File, "%ld", &Code);
getc(Portable_File); /* Space */
OUT(Code);
}
}
}
\f
+Pointer *
+read_a_bit_string(To, Slot)
+ Pointer *To, *Slot;
+{
+ long size_in_bits, size_in_words;
+ Pointer the_bit_string;
+
+ fscanf(Portable_File, "%ld", &size_in_bits);
+ size_in_words = (1 + bits_to_pointers (size_in_bits));
+
+ the_bit_string = Make_Pointer(TC_BIT_STRING, To);
+ *To++ = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, size_in_words);
+ *To = size_in_bits;
+ To += size_in_words;
+
+ if (size_in_bits != 0)
+ {
+ unsigned long temp;
+ fast Pointer *scan;
+ fast long bits_remaining, bits_accumulated;
+ fast Pointer accumulator, next_word;
+
+ accumulator = 0;
+ bits_accumulated = 0;
+ scan = bit_string_low_ptr(the_bit_string);
+ for(bits_remaining = size_in_bits;
+ bits_remaining > 0;
+ bits_remaining -= 4)
+ {
+ read_hex_digit(temp);
+ if ((bits_accumulated + 4) > POINTER_LENGTH)
+ {
+ accumulator |=
+ ((temp & low_mask(POINTER_LENGTH - bits_accumulated)) <<
+ bits_accumulated);
+ *(inc_bit_string_ptr(scan)) = accumulator;
+ accumulator = (temp >> (POINTER_LENGTH - bits_accumulated));
+ bits_accumulated -= (POINTER_LENGTH - 4);
+ temp &= low_mask(bits_accumulated);
+ }
+ else
+ {
+ accumulator |= (temp << bits_accumulated);
+ bits_accumulated += 4;
+ }
+ }
+ if (bits_accumulated != 0)
+ *(inc_bit_string_ptr(scan)) = accumulator;
+ }
+ *Slot = the_bit_string;
+ return To;
+}
+\f
/* Underflow and Overflow */
/* dflmax and dflmin exist in the Berserkely FORTRAN library */
To = read_a_string(To, Table++);
continue;
+ case TC_BIT_STRING:
+ To = read_a_bit_string(To, Table++);
+ continue;
+
case TC_FIXNUM:
case TC_BIG_FIXNUM:
To = read_an_integer(The_Type, To, Table++);
getc(Portable_File); /* Space */
VMS_BUG(the_char_code = 0);
- fscanf( Portable_File, "%3x", &the_char_code);
+ fscanf( Portable_File, "%3lx", &the_char_code);
*Table++ = Make_Non_Pointer( TC_CHARACTER, the_char_code);
continue;
}
Read_Header_and_Allocate()
{
long Portable_Version, Flags, Version, Sub_Version;
- long NFlonums, NIntegers, NStrings, NBits, NChars;
+ long NFlonums, NIntegers, NBits, NBitstrs, NBBits, NStrings, NChars;
long Size;
/* Read Header */
fscanf(Input_File, "%ld %ld %ld %ld",
&Portable_Version, &Flags, &Version, &Sub_Version);
+
fscanf(Input_File, "%ld %ld %ld",
&Heap_Count, &Dumped_Heap_Base, &Heap_Objects);
+
fscanf(Input_File, "%ld %ld %ld",
&Constant_Count, &Dumped_Constant_Base, &Constant_Objects);
+
fscanf(Input_File, "%ld %ld %ld",
&Pure_Count, &Dumped_Pure_Base, &Pure_Objects);
- fscanf(Input_File, "%ld %ld %ld %ld %ld",
- &NFlonums, &NIntegers, &NStrings, &NBits, &NChars);
+
fscanf(Input_File, "%ld %ld",
&Dumped_Object_Addr, &Dumped_Ext_Prim_Addr);
+ fscanf(Input_File, "%ld %ld %ld %ld %ld %ld %ld",
+ &NFlonums,
+ &NIntegers, &NBits,
+ &NBitstrs, &NBBits,
+ &NStrings, &NChars);
+
if ((Portable_Version != PORTABLE_VERSION) ||
(Version != FASL_FORMAT_VERSION) ||
(Sub_Version != FASL_SUBVERSION))
{
fprintf(stderr,
"FASL File Version %4d Subversion %4d Portable Version %4d\n",
- Version, Sub_Version , Portable_Version);
+ Version, Sub_Version, Portable_Version);
fprintf(stderr,
"Expected: Version %4d Subversion %4d Portable Version %4d\n",
FASL_FORMAT_VERSION, FASL_SUBVERSION, PORTABLE_VERSION);
Constant_Count + Constant_Objects +
Pure_Count + Pure_Objects +
flonum_to_pointer(NFlonums) +
- ((NIntegers * bignum_header_to_pointer) +
+ ((NIntegers * (1 + bignum_header_to_pointer)) +
(bigdigit_to_pointer(bits_to_bigdigit(NBits)))) +
- ((NStrings * STRING_CHARS) + (char_to_pointer(NChars))));
+ ((NStrings * (1 + STRING_CHARS)) +
+ (char_to_pointer(NChars))) +
+ ((NBitstrs * (1 + BIT_STRING_FIRST_WORD)) +
+ (bits_to_pointers(NBBits))));
Allocate_Heap_Space(Size);
if (Heap == NULL)
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/bintopsb.c,v 9.26 1987/06/05 04:10:41 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/bintopsb.c,v 9.27 1987/08/07 15:34:56 jinx Exp $
*
* This File contains the code to translate internal format binary
* files to portable format.
static long Heap_Relocation, Constant_Relocation;
static long Free, Scan, Free_Constant, Scan_Constant;
static long Objects, Constant_Objects;
-static long NFlonums, NIntegers, NStrings;
-static long NBits, NChars;
static Pointer *Free_Objects, *Free_Cobjects;
+static long NFlonums;
+static long NIntegers, NBits;
+static long NBitstrs, NBBits;
+static long NStrings, NChars;
+
long
Load_Data(Count, To_Where)
long Count;
*/
#ifndef isalpha
+
/* Just in case the stdio library atypically contains the character
macros, just like the C book claims. */
+
#include <ctype.h>
+
#endif
#ifndef ispunct
+
/* This is in some libraries but not others */
+
static char punctuation[] = "'\",<.>/?;:{}[]|`~=+-_()*&^%$#@!";
-Boolean ispunct(c)
-fast char c;
-{ fast char *s = &punctuation[0];
- while (*s != '\0') if (*s++ == c) return true;
+Boolean
+ispunct(c)
+ fast char c;
+{
+ fast char *;
+
+ s = &punctuation[0];
+ while (*s != '\0')
+ if (*s++ == c)
+ return true;
return false;
}
#endif
-#define OUT(s) \
-fprintf(Portable_File, s); \
+#define OUT(s) \
+fprintf(Portable_File, s); \
break
void
char *name;
{
switch(c)
- { case '\n': OUT("\\n");
+ {
+ case '\n': OUT("\\n");
case '\t': OUT("\\t");
case '\b': OUT("\\b");
case '\r': OUT("\\r");
if ((isalpha(c)) || (isdigit(c)) || (ispunct(c)))
putc(c, Portable_File);
else
- { fprintf(stderr,
+ {
+ fprintf(stderr,
"%s: %s: File may not be portable: c = 0x%x\n",
Program_Name, name, ((int) c));
/* This does not follow C conventions, but eliminates ambiguity */
}
}
\f
-#define Do_String(Code, Rel, Fre, Scn, Obj, FObj) \
+#define Do_Compound(Code, Rel, Fre, Scn, Obj, FObj, kernel_code) \
{ \
Old_Address += (Rel); \
Old_Contents = *Old_Address; \
+ \
if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
Mem_Base[(Scn)] = \
Make_New_Pointer((Code), Old_Contents); \
else \
{ \
- fast long i; \
- \
- Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
- (Obj) += 1; \
- *(FObj)++ = Make_Non_Pointer(TC_CHARACTER_STRING, 0); \
- *(FObj)++ = Old_Contents; \
- i = Get_Integer(Old_Contents); \
- NStrings += 1; \
- NChars += pointer_to_char(i-1); \
- while(--i >= 0) \
- *(FObj)++ = *Old_Address++; \
+ kernel_code; \
} \
}
-void
-print_a_string(from)
- Pointer *from;
-{ fast long len;
- fast char *string;
- long maxlen;
+#define standard_kernel(kernel_code, type, Code, Scn, Obj, FObj) \
+{ \
+ fast long length; \
+ \
+ Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
+ length = Get_Integer(Old_Contents); \
+ kernel_code; \
+ *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
+ (Obj) += 1; \
+ *(FObj)++ = Make_Non_Pointer((type), 0); \
+ *(FObj)++ = Old_Contents; \
+ while(--length >= 0) \
+ *(FObj)++ = *Old_Address++; \
+}
+\f
+#define do_string_kernel() \
+{ \
+ NStrings += 1; \
+ NChars += pointer_to_char(length - 1); \
+}
- maxlen = pointer_to_char((Get_Integer(*from++))-1);
- len = Get_Integer(*from++);
- fprintf(Portable_File, "%02x %ld %ld ",
- TC_CHARACTER_STRING,
- (Compact_P ? len : maxlen),
- len);
- string = ((char *) from);
- if (Shuffle_Bytes)
- { while(len > 0)
- {
- print_a_char(string[3], "print_a_string");
- if (len > 1)
- print_a_char(string[2], "print_a_string");
- if (len > 2)
- print_a_char(string[1], "print_a_string");
- if (len > 3)
- print_a_char(string[0], "print_a_string");
- len -= 4;
- string += 4;
- }
- }
- else while(--len >= 0) print_a_char(*string++, "print_a_string");
- putc('\n', Portable_File);
- return;
+#define do_bignum_kernel() \
+{ \
+ NIntegers += 1; \
+ NBits += bignum_to_bits(LEN(BIGNUM(Old_Address))); \
}
+
+#define do_bit_string_kernel() \
+{ \
+ NBitstrs += 1; \
+ NBBits += Old_Address[BIT_STRING_LENGTH_OFFSET]; \
+}
+
+#define do_flonum_kernel(Code, Scn, Obj, FObj) \
+{ \
+ Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
+ NFlonums += 1; \
+ *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
+ (Obj) += 1; \
+ *(FObj)++ = Make_Non_Pointer(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(), 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, \
+ 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, \
+ 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
print_a_fixnum(val)
fprintf(Portable_File, "%ld ", size_in_bits);
temp = ((val < 0) ? -val : val);
while (temp != 0)
- { fprintf(Portable_File, "%01lx", (temp % 16));
+ {
+ fprintf(Portable_File, "%01lx", (temp & 0xf));
temp = temp >> 4;
}
fprintf(Portable_File, "\n");
return;
}
\f
-#define Do_Bignum(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer((Code), Old_Contents); \
- else \
- { fast long length; \
- Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
- NIntegers += 1; \
- NBits += bignum_to_bits(LEN(BIGNUM(Old_Address))); \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
- (Obj) += 1; \
- *(FObj)++ = Make_Non_Pointer(TC_BIG_FIXNUM, 0); \
- *(FObj)++ = Old_Contents; \
- for (length = Get_Integer(Old_Contents); \
- --length >= 0; ) \
- *(FObj)++ = *Old_Address++; \
- } \
-}
+void
+print_a_string(from)
+ Pointer *from;
+{
+ fast long len;
+ fast char *string;
+ long maxlen;
+ maxlen = pointer_to_char((Get_Integer(*from++))-1);
+ len = Get_Integer(*from++);
+ fprintf(Portable_File, "%02x %ld %ld ",
+ TC_CHARACTER_STRING,
+ (Compact_P ? len : maxlen),
+ len);
+ string = ((char *) from);
+ if (Shuffle_Bytes)
+ {
+ while(len > 0)
+ {
+ print_a_char(string[3], "print_a_string");
+ if (len > 1)
+ print_a_char(string[2], "print_a_string");
+ if (len > 2)
+ print_a_char(string[1], "print_a_string");
+ if (len > 3)
+ print_a_char(string[0], "print_a_string");
+ len -= 4;
+ string += 4;
+ }
+ }
+ else
+ while(--len >= 0)
+ print_a_char(*string++, "print_a_string");
+ putc('\n', Portable_File);
+ return;
+}
+\f
void
print_a_bignum(from)
Pointer *from;
fprintf(Portable_File, "%02x + 0\n",
(Compact_P ? TC_FIXNUM : TC_BIG_FIXNUM));
else
- { fast long tail;
+ {
+ fast long tail;
+
for (size_in_bits = ((temp - 1) * SHIFT),
temp = ((long) (*Bignum_Top(the_number)));
temp != 0;
(NEG_BIGNUM(the_number) ? '-' : '+'),
size_in_bits);
tail = size_in_bits % SHIFT;
- if (tail == 0) tail = SHIFT;
+ if (tail == 0)
+ tail = SHIFT;
temp = 0;
size_in_bits = 0;
the_top = Bignum_Top(the_number);
for(the_number = Bignum_Bottom(the_number);
the_number <= the_top;
the_number += 1)
- { temp |= (((unsigned long) (*the_number)) << size_in_bits);
+ {
+ temp |= (((unsigned long) (*the_number)) << size_in_bits);
for (size_in_bits += ((the_number != the_top) ? SHIFT : tail);
size_in_bits > 3;
size_in_bits -= 4)
- { fprintf(Portable_File, "%01lx", temp % 16);
+ {
+ fprintf(Portable_File, "%01lx", (temp & 0xf));
temp = temp >> 4;
}
}
- if (size_in_bits > 0) fprintf(Portable_File, "%01lx\n", temp);
- else fprintf(Portable_File, "\n");
+ if (size_in_bits > 0)
+ fprintf(Portable_File, "%01lx\n", (temp & 0xf));
+ else
+ fprintf(Portable_File, "\n");
}
return;
}
\f
-#define Do_Flonum(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer((Code), Old_Contents); \
- else \
- { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
- Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
- (Obj) += 1; \
- *(FObj)++ = Make_Non_Pointer(TC_BIG_FLONUM, 0); \
- *((double *) (FObj)) = *((double *) Old_Address); \
- (FObj) += float_to_pointer; \
- NFlonums += 1; \
- } \
-}
+/* The following procedure assumes that a C long is at least 4 bits. */
+
+print_a_bit_string(from)
+ Pointer *from;
+{
+ Pointer the_bit_string;
+ fast long bits_remaining, leftover_bits;
+ fast Pointer accumulator, next_word, *scan;
+
+ the_bit_string = Make_Pointer(TC_BIT_STRING, from);
+ bits_remaining = bit_string_length(the_bit_string);
+ fprintf(Portable_File, "%02x %ld", TC_BIT_STRING, bits_remaining);
+
+ if (bits_remaining != 0)
+ {
+ fprintf(Portable_File, " ");
+ scan = bit_string_low_ptr(the_bit_string);
+ for (leftover_bits = 0;
+ bits_remaining > 0;
+ bits_remaining -= POINTER_LENGTH)
+ {
+ next_word = *(inc_bit_string_ptr(scan));
+
+ if (bits_remaining < POINTER_LENGTH)
+ next_word &= low_mask(bits_remaining);
+
+ if (leftover_bits != 0)
+ {
+ accumulator &= low_mask(leftover_bits);
+ accumulator |=
+ ((next_word & low_mask(4 - leftover_bits)) << leftover_bits);
+ next_word = (next_word >> (4 - leftover_bits));
+ leftover_bits += ((bits_remaining > POINTER_LENGTH) ?
+ (POINTER_LENGTH - 4) :
+ (bits_remaining - 4));
+ fprintf(Portable_File, "%01lx", (accumulator & 0xf));
+ }
+ else
+ {
+ leftover_bits = ((bits_remaining > POINTER_LENGTH) ?
+ POINTER_LENGTH :
+ bits_remaining);
+ }
+ for(accumulator = next_word; leftover_bits >= 4; leftover_bits -= 4)
+ {
+ fprintf(Portable_File, "%01lx", (accumulator & 0xf));
+ accumulator = accumulator >> 4;
+ }
+ }
+ if (leftover_bits != 0)
+ fprintf(Portable_File, "%01lx", (accumulator & 0xf));
+ }
+ fprintf(Portable_File, "\n");
+ return;
+}
+\f
print_a_flonum(val)
-double val;
-{ fast long size_in_bits;
+ double val;
+{
+ fast long size_in_bits;
fast double mant, temp;
int expt;
extern double frexp();
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);
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;
+ {
+ temp *= 2.0;
+ if (temp >= 1.0)
+ temp -= 1.0;
}
fprintf(Portable_File, "%ld %ld ", expt, size_in_bits);
+
for (size_in_bits = hex_digits(size_in_bits);
size_in_bits > 0;
size_in_bits -= 1)
- { fast unsigned int digit = 0;
+ {
+ fast unsigned int digit;
+
+ digit = 0;
for (expt = 4; --expt >= 0;)
- { mant *= 2.0;
+ {
+ mant *= 2.0;
digit = digit << 1;
if (mant >= 1.0)
- { mant -= 1.0;
+ {
+ mant -= 1.0;
digit += 1;
}
}
\f
/* Normal Objects */
-#define Do_Cell(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer(Type_Code(This), Old_Contents); \
- else \
- { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- } \
+#define Do_Cell(Code, Rel, Fre, Scn, Obj, FObj) \
+{ \
+ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ Mem_Base[(Scn)] = \
+ Make_New_Pointer(Type_Code(This), Old_Contents); \
+ else \
+ { \
+ *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
+ Mem_Base[(Fre)++] = Old_Contents; \
+ } \
}
-#define Do_Pair(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer(Type_Code(This), Old_Contents); \
- else \
- { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- Mem_Base[(Fre)++] = *Old_Address++; \
- } \
+#define Do_Pair(Code, Rel, Fre, Scn, Obj, FObj) \
+{ \
+ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ Mem_Base[(Scn)] = \
+ Make_New_Pointer(Type_Code(This), Old_Contents); \
+ else \
+ { \
+ *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
+ Mem_Base[(Fre)++] = Old_Contents; \
+ Mem_Base[(Fre)++] = *Old_Address++; \
+ } \
}
-#define Do_Triple(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer(Type_Code(This), Old_Contents); \
- else \
- { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- Mem_Base[(Fre)++] = *Old_Address++; \
- Mem_Base[(Fre)++] = *Old_Address++; \
- } \
+#define Do_Triple(Code, Rel, Fre, Scn, Obj, FObj) \
+{ \
+ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ Mem_Base[(Scn)] = \
+ Make_New_Pointer(Type_Code(This), Old_Contents); \
+ else \
+ { \
+ *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
+ Mem_Base[(Fre)++] = Old_Contents; \
+ Mem_Base[(Fre)++] = *Old_Address++; \
+ Mem_Base[(Fre)++] = *Old_Address++; \
+ } \
}
-#define Do_Vector(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer(Type_Code(This), Old_Contents); \
- else \
- { fast long len = Get_Integer(Old_Contents); \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- while (len > 0) \
- { Mem_Base[(Fre)++] = *Old_Address++; \
- len -= 1; \
- } \
- } \
+#define Do_Vector(Code, Rel, Fre, Scn, Obj, FObj) \
+{ \
+ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ Mem_Base[(Scn)] = \
+ Make_New_Pointer(Type_Code(This), Old_Contents); \
+ else \
+ { \
+ fast long len; \
+ \
+ len = Get_Integer(Old_Contents); \
+ *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
+ Mem_Base[(Fre)++] = Old_Contents; \
+ while (len > 0) \
+ { \
+ Mem_Base[(Fre)++] = *Old_Address++; \
+ len -= 1; \
+ } \
+ } \
}
\f
/* Common Pointer Code */
-#define Do_Pointer(Scn, Action) \
-Old_Address = Get_Pointer(This); \
-if (Datum(This) < Const_Base) \
- Action(HEAP_CODE, Heap_Relocation, Free, \
- Scn, Objects, Free_Objects) \
-else if (Datum(This) < Dumped_Constant_Top) \
-Action(CONSTANT_CODE, Constant_Relocation, Free_Constant, \
- Scn, Constant_Objects, Free_Cobjects) \
-else \
-{ fprintf(stderr, \
- "%s: File is not portable: Pointer to stack.\n", \
- Program_Name); \
- exit(1); \
-} \
-(Scn) += 1; \
-break
+#define Do_Pointer(Scn, Action) \
+{ \
+ Old_Address = Get_Pointer(This); \
+ if (Datum(This) < Const_Base) \
+ { \
+ Action(HEAP_CODE, Heap_Relocation, Free, \
+ Scn, Objects, Free_Objects); \
+ } \
+ else if (Datum(This) < Dumped_Constant_Top) \
+ { \
+ Action(CONSTANT_CODE, Constant_Relocation, Free_Constant, \
+ Scn, Constant_Objects, Free_Cobjects); \
+ } \
+ else \
+ { \
+ fprintf(stderr, \
+ "%s: File is not portable: Pointer to stack.\n", \
+ Program_Name); \
+ exit(1); \
+ } \
+ (Scn) += 1; \
+ break; \
+}
\f
/* Processing of a single area */
-#define Do_Area(Code, Area, Bound, Obj, FObj) \
+#define Do_Area(Code, Area, Bound, Obj, FObj) \
Process_Area(Code, &Area, &Bound, &Obj, &FObj)
Process_Area(Code, Area, Bound, Obj, FObj)
-int Code;
-fast long *Area, *Bound;
-fast long *Obj;
-fast Pointer **FObj;
-{ fast Pointer This, *Old_Address, Old_Contents;
+ int Code;
+ fast long *Area, *Bound;
+ fast long *Obj;
+ fast Pointer **FObj;
+{
+ fast Pointer This, *Old_Address, Old_Contents;
+
while(*Area != *Bound)
- { This = Mem_Base[*Area];
+ {
+ This = Mem_Base[*Area];
Switch_by_GC_Type(This)
- { case TC_MANIFEST_NM_VECTOR:
+ {
+ case TC_MANIFEST_NM_VECTOR:
if (Null_NMV)
- { fast int i = Get_Integer(This);
+ {
+ fast int i;
+
+ i = Get_Integer(This);
*Area += 1;
for ( ; --i >= 0; *Area += 1)
Mem_Base[*Area] = NIL;
break;
case TC_BROKEN_HEART:
- /* [Broken Heart 0] is the cdr of fasdumped symbols. */
+ /* [Broken Heart 0] is the cdr of fasdumped symbols. */
if (Get_Integer(This) != 0)
- { fprintf(stderr, "%s: Broken Heart found in scan.\n",
+ {
+ fprintf(stderr, "%s: Broken Heart found in scan.\n",
Program_Name);
exit(1);
}
NIntegers += 1;
NBits += fixnum_to_bits;
/* Fall Through */
+
case TC_CHARACTER:
Process_Character:
Mem_Base[*Area] = Make_Non_Pointer(Code, *Obj);
**FObj = This;
*FObj += 1;
/* Fall through */
+
case TC_MANIFEST_SPECIAL_NM_VECTOR:
case TC_PRIMITIVE_EXTERNAL:
case_simple_Non_Pointer:
exit(1);
}
/* Fall through */
+
case TC_FUTURE:
case_simple_Vector:
- Do_Pointer(*Area, Do_Vector);
+ if (Type_Code(This) == TC_BIT_STRING)
+ {
+ Do_Pointer(*Area, Do_Bit_String);
+ }
+ else
+ {
+ Do_Pointer(*Area, Do_Vector);
+ }
default:
Bad_Type:
\f
/* Output macros */
-#define print_an_object(obj) \
-fprintf(Portable_File, "%02x %lx\n", \
- Type_Code(obj), Get_Integer(obj))
-
-#define print_external_object(from) \
-{ switch(Type_Code(*from)) \
- { case TC_FIXNUM: \
- { long Value; \
- Sign_Extend(*from++, Value); \
- print_a_fixnum(Value); \
- break; \
- } \
- case TC_BIG_FIXNUM: \
- from += 1; \
- print_a_bignum(from); \
- from += 1 + Get_Integer(*from); \
- break; \
- case TC_CHARACTER_STRING: \
- from += 1; \
- print_a_string(from); \
- from += 1 + Get_Integer(*from); \
- break; \
- case TC_BIG_FLONUM: \
- print_a_flonum(*((double *) (from+1))); \
- from += 1 + float_to_pointer; \
- break; \
- case TC_CHARACTER: \
- fprintf(Portable_File, "%02x %03x\n", \
- TC_CHARACTER, (*from & MASK_EXTNDD_CHAR)); \
- from += 1; \
- break; \
- default: \
- fprintf(stderr, \
- "%s: Bad Object to print externally %lx\n", \
- Program_Name, *from); \
- exit(1); \
- } \
+#define print_external_object(from) \
+{ \
+ switch(Type_Code(*from)) \
+ { \
+ case TC_FIXNUM: \
+ { \
+ long Value; \
+ \
+ Sign_Extend(*from++, Value); \
+ print_a_fixnum(Value); \
+ break; \
+ } \
+ \
+ case TC_BIT_STRING: \
+ print_a_bit_string(++from); \
+ from += 1 + Get_Integer(*from); \
+ break; \
+ \
+ case TC_BIG_FIXNUM: \
+ print_a_bignum(++from); \
+ from += 1 + Get_Integer(*from); \
+ break; \
+ \
+ case TC_CHARACTER_STRING: \
+ print_a_string(++from); \
+ from += 1 + Get_Integer(*from); \
+ break; \
+ \
+ case TC_BIG_FLONUM: \
+ print_a_flonum( *((double *) (from + 1))); \
+ from += 1 + float_to_pointer; \
+ break; \
+ \
+ case TC_CHARACTER: \
+ fprintf(Portable_File, "%02x %03x\n", \
+ TC_CHARACTER, (*from & MASK_EXTNDD_CHAR)); \
+ from += 1; \
+ break; \
+ \
+ default: \
+ fprintf(stderr, \
+ "%s: Bad Object to print externally %lx\n", \
+ Program_Name, *from); \
+ exit(1); \
+ } \
}
\f
+#define print_an_object(obj) \
+fprintf(Portable_File, "%02x %lx\n", \
+ Type_Code(obj), Get_Integer(obj))
+
/* Debugging Aids and Consistency Checks */
#ifdef DEBUG
When(what, message)
-Boolean what;
-char *message;
-{ if (what)
- { fprintf(stderr, "%s: Inconsistency: %s!\n",
+ Boolean what;
+ char *message;
+{
+ if (what)
+ {
+ fprintf(stderr, "%s: Inconsistency: %s!\n",
Program_Name, (message));
exit(1);
}
return;
}
-#define print_header(name, obj, format) \
-fprintf(Portable_File, (format), (obj)); \
-fprintf(stderr, "%s: ", (name)); \
-fprintf(stderr, (format), (obj))
+#define print_header(name, obj, format) \
+{ \
+ fprintf(Portable_File, (format), (obj)); \
+ fprintf(stderr, "%s: ", (name)); \
+ fprintf(stderr, (format), (obj)); \
+}
#else
#define When(what, message)
-#define print_header(name, obj, format) \
-fprintf(Portable_File, (format), (obj))
+#define print_header(name, obj, format) \
+{ \
+ fprintf(Portable_File, (format), (obj)); \
+}
#endif
\f
/* The main program */
do_it()
-{ Pointer *Heap;
+{
+ Pointer *Heap;
long Initial_Free;
/* Load the Data */
if (!Read_Header())
- { fprintf(stderr,
+ {
+ fprintf(stderr,
"%s: Input file does not appear to be in FASL format.\n",
Program_Name);
exit(1);
(Sub_Version > FASL_SUBVERSION) ||
(Sub_Version < FASL_OLDEST_SUPPORTED) ||
((Machine_Type != FASL_INTERNAL_FORMAT) && (!Shuffle_Bytes)))
- { fprintf(stderr, "%s:\n", Program_Name);
+ {
+ fprintf(stderr, "%s:\n", Program_Name);
fprintf(stderr,
"FASL File Version %ld Subversion %ld Machine Type %ld\n",
Version, Sub_Version , Machine_Type);
if (Machine_Type == FASL_INTERNAL_FORMAT)
Shuffle_Bytes = false;
+
upgrade_traps = (Sub_Version < FASL_REFERENCE_TRAP);
/* Constant Space not currently supported */
if (Const_Count != 0)
- { fprintf(stderr,
+ {
+ fprintf(stderr,
"%s: Input file has a constant space area.\n",
Program_Name);
exit(1);
}
- { long Size = ((3 * (Heap_Count + Const_Count)) + NROOTS + 1);
+ {
+ long Size;
+
+ Size = ((3 * (Heap_Count + Const_Count)) + NROOTS + 1);
Allocate_Heap_Space(Size + HEAP_BUFFER_SPACE);
+
if (Heap == NULL)
- { fprintf(stderr,
+ {
+ fprintf(stderr,
"%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n",
Program_Name, Size);
exit(1);
\f
/* Reformat the data */
- NFlonums = NIntegers = NStrings = NBits = NChars = 0;
+ NFlonums = NIntegers = NStrings = 0;
+ NBits = NBBits = NChars = 0;
Mem_Base = &Heap[Heap_Count + Const_Count];
+
if (Ext_Prim_Vector == NIL)
- { Mem_Base[0] = Make_Non_Pointer(TC_CELL, 2);
+ {
+ Mem_Base[0] = Make_Non_Pointer(TC_CELL, 2);
Mem_Base[1] = Make_New_Pointer(TC_CELL, Dumped_Object);
Mem_Base[2] = NIL;
Initial_Free = NROOTS + 1;
Scan = 1;
}
else
- { Mem_Base[0] = Ext_Prim_Vector; /* Has CELL TYPE */
+ {
+ Mem_Base[0] = Ext_Prim_Vector; /* Has CELL TYPE */
Mem_Base[1] = Make_New_Pointer(TC_CELL, Dumped_Object);
Initial_Free = NROOTS;
Scan = 0;
}
+
Free = Initial_Free;
Free_Objects = &Mem_Base[Heap_Count + Initial_Free];
Objects = 0;
/* 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(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, Fre_Pure, Pure_Objects, Free_Pobjects);
- if (Scan == Free) break;
+ if (Scan == Free)
+ break;
}
#endif
\f
print_header("Flags", Make_Flags(), "%ld\n");
print_header("Version", FASL_FORMAT_VERSION, "%ld\n");
print_header("Sub Version", FASL_SUBVERSION, "%ld\n");
+
print_header("Heap Count", (Free - NROOTS), "%ld\n");
print_header("Heap Base", NROOTS, "%ld\n");
print_header("Heap Objects", Objects, "%ld\n");
print_header("Pure Count", 0, "%ld\n");
print_header("Pure Base", Free_Constant, "%ld\n");
print_header("Pure Objects", 0, "%ld\n");
+
print_header("Constant Count", 0, "%ld\n");
print_header("Constant Base", Free_Constant, "%ld\n");
print_header("Constant Objects", 0, "%ld\n");
+ print_header("& Dumped Object", (Get_Integer(Mem_Base[1])), "%ld\n");
+ print_header("& Ext Prim Vector", (Get_Integer(Mem_Base[0])), "%ld\n");
+
print_header("Number of flonums", NFlonums, "%ld\n");
print_header("Number of integers", NIntegers, "%ld\n");
- print_header("Number of strings", NStrings, "%ld\n");
print_header("Number of bits in integers", NBits, "%ld\n");
+ print_header("Number of bit strings", NBitstrs, "%ld\n");
+ print_header("Number of bits in bit strings", NBBits, "%ld\n");
+ print_header("Number of character strings", NStrings, "%ld\n");
print_header("Number of characters in strings", NChars, "%ld\n");
- print_header("& Dumped Object", (Get_Integer(Mem_Base[1])), "%ld\n");
- print_header("& Ext Prim Vector", (Get_Integer(Mem_Base[0])), "%ld\n");
\f
/* External Objects */
Free_Cobjects = &Mem_Base[Constant_Objects_Start];
for (; Constant_Objects > 0; Constant_Objects -= 1)
+ {
print_external_object(Free_Cobjects);
+ }
#endif
\f
for (Free_Objects = &Mem_Base[NROOTS];
Free_Objects < Free_Cobjects;
Free_Objects += 1)
+ {
print_an_object(*Free_Objects);
+ }
#if false
/* Pure Objects */
for (Free_Objects = &Mem_Base[Pure_Start];
Free_Objects < Free_Cobjects;
Free_Objects += 1)
+ {
print_an_object(*Free_Objects);
+ }
/* Constant Objects */
for (Free_Objects = &Mem_Base[Constant_Start];
Free_Objects < Free_Cobjects;
Free_Objects += 1)
+ {
print_an_object(*Free_Objects);
+ }
#endif
return;
{"Swap_Bytes", true, &Shuffle_Bytes}};
main(argc, argv)
-int argc;
-char *argv[];
-{ Setup_Program(argc, argv, Noptions, Options);
+ int argc;
+ char *argv[];
+{
+ Setup_Program(argc, argv, Noptions, Options);
return;
}
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbmap.h,v 9.21 1987/01/22 14:33:52 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbmap.h,v 9.22 1987/08/07 15:36:46 jinx Rel $
*
* This file contains macros and declarations for Bintopsb.c
* and Psbtobin.c
#include "config.h"
#include "object.h"
#include "bignum.h"
+#include "bitstr.h"
#include "gc.h"
#include "types.h"
#include "sdata.h"
#include "missing.c"
#endif
-#define PORTABLE_VERSION 1
+#define PORTABLE_VERSION 2
/* Number of objects which, when traced recursively, point at all other
objects dumped. Currently the dumped object and the external
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbtobin.c,v 9.25 1987/06/05 04:11:31 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbtobin.c,v 9.26 1987/08/07 15:34:27 jinx Exp $
*
* This File contains the code to translate portable format binary
* files to internal format.
fprintf(stderr,
"%s: File is not Portable. Character Code Found.\n",
Program_Name);
- fscanf(Portable_File, "%d", &Code);
+ fscanf(Portable_File, "%ld", &Code);
getc(Portable_File); /* Space */
OUT(Code);
}
}
}
\f
+Pointer *
+read_a_bit_string(To, Slot)
+ Pointer *To, *Slot;
+{
+ long size_in_bits, size_in_words;
+ Pointer the_bit_string;
+
+ fscanf(Portable_File, "%ld", &size_in_bits);
+ size_in_words = (1 + bits_to_pointers (size_in_bits));
+
+ the_bit_string = Make_Pointer(TC_BIT_STRING, To);
+ *To++ = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, size_in_words);
+ *To = size_in_bits;
+ To += size_in_words;
+
+ if (size_in_bits != 0)
+ {
+ unsigned long temp;
+ fast Pointer *scan;
+ fast long bits_remaining, bits_accumulated;
+ fast Pointer accumulator, next_word;
+
+ accumulator = 0;
+ bits_accumulated = 0;
+ scan = bit_string_low_ptr(the_bit_string);
+ for(bits_remaining = size_in_bits;
+ bits_remaining > 0;
+ bits_remaining -= 4)
+ {
+ read_hex_digit(temp);
+ if ((bits_accumulated + 4) > POINTER_LENGTH)
+ {
+ accumulator |=
+ ((temp & low_mask(POINTER_LENGTH - bits_accumulated)) <<
+ bits_accumulated);
+ *(inc_bit_string_ptr(scan)) = accumulator;
+ accumulator = (temp >> (POINTER_LENGTH - bits_accumulated));
+ bits_accumulated -= (POINTER_LENGTH - 4);
+ temp &= low_mask(bits_accumulated);
+ }
+ else
+ {
+ accumulator |= (temp << bits_accumulated);
+ bits_accumulated += 4;
+ }
+ }
+ if (bits_accumulated != 0)
+ *(inc_bit_string_ptr(scan)) = accumulator;
+ }
+ *Slot = the_bit_string;
+ return To;
+}
+\f
/* Underflow and Overflow */
/* dflmax and dflmin exist in the Berserkely FORTRAN library */
To = read_a_string(To, Table++);
continue;
+ case TC_BIT_STRING:
+ To = read_a_bit_string(To, Table++);
+ continue;
+
case TC_FIXNUM:
case TC_BIG_FIXNUM:
To = read_an_integer(The_Type, To, Table++);
getc(Portable_File); /* Space */
VMS_BUG(the_char_code = 0);
- fscanf( Portable_File, "%3x", &the_char_code);
+ fscanf( Portable_File, "%3lx", &the_char_code);
*Table++ = Make_Non_Pointer( TC_CHARACTER, the_char_code);
continue;
}
Read_Header_and_Allocate()
{
long Portable_Version, Flags, Version, Sub_Version;
- long NFlonums, NIntegers, NStrings, NBits, NChars;
+ long NFlonums, NIntegers, NBits, NBitstrs, NBBits, NStrings, NChars;
long Size;
/* Read Header */
fscanf(Input_File, "%ld %ld %ld %ld",
&Portable_Version, &Flags, &Version, &Sub_Version);
+
fscanf(Input_File, "%ld %ld %ld",
&Heap_Count, &Dumped_Heap_Base, &Heap_Objects);
+
fscanf(Input_File, "%ld %ld %ld",
&Constant_Count, &Dumped_Constant_Base, &Constant_Objects);
+
fscanf(Input_File, "%ld %ld %ld",
&Pure_Count, &Dumped_Pure_Base, &Pure_Objects);
- fscanf(Input_File, "%ld %ld %ld %ld %ld",
- &NFlonums, &NIntegers, &NStrings, &NBits, &NChars);
+
fscanf(Input_File, "%ld %ld",
&Dumped_Object_Addr, &Dumped_Ext_Prim_Addr);
+ fscanf(Input_File, "%ld %ld %ld %ld %ld %ld %ld",
+ &NFlonums,
+ &NIntegers, &NBits,
+ &NBitstrs, &NBBits,
+ &NStrings, &NChars);
+
if ((Portable_Version != PORTABLE_VERSION) ||
(Version != FASL_FORMAT_VERSION) ||
(Sub_Version != FASL_SUBVERSION))
{
fprintf(stderr,
"FASL File Version %4d Subversion %4d Portable Version %4d\n",
- Version, Sub_Version , Portable_Version);
+ Version, Sub_Version, Portable_Version);
fprintf(stderr,
"Expected: Version %4d Subversion %4d Portable Version %4d\n",
FASL_FORMAT_VERSION, FASL_SUBVERSION, PORTABLE_VERSION);
Constant_Count + Constant_Objects +
Pure_Count + Pure_Objects +
flonum_to_pointer(NFlonums) +
- ((NIntegers * bignum_header_to_pointer) +
+ ((NIntegers * (1 + bignum_header_to_pointer)) +
(bigdigit_to_pointer(bits_to_bigdigit(NBits)))) +
- ((NStrings * STRING_CHARS) + (char_to_pointer(NChars))));
+ ((NStrings * (1 + STRING_CHARS)) +
+ (char_to_pointer(NChars))) +
+ ((NBitstrs * (1 + BIT_STRING_FIRST_WORD)) +
+ (bits_to_pointers(NBBits))));
Allocate_Heap_Space(Size);
if (Heap == NULL)
projects / mit-scheme.git / commitdiff