From: Guillermo J. Rozas Date: Fri, 7 Aug 1987 15:36:46 +0000 (+0000) Subject: Make Psbtobin and Bintopsb handle bit strings. X-Git-Tag: 20090517-FFI~13180 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=86f19d4de91d27c6f54d4a3d25fce925bd333d31;p=mit-scheme.git Make Psbtobin and Bintopsb handle bit strings. --- diff --git a/v7/src/microcode/bintopsb.c b/v7/src/microcode/bintopsb.c index a1e46d8ca..46dffa3b9 100644 --- a/v7/src/microcode/bintopsb.c +++ b/v7/src/microcode/bintopsb.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, 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. @@ -52,10 +52,13 @@ static Pointer *Mem_Base; 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; @@ -75,25 +78,36 @@ Load_Data(Count, To_Where) */ #ifndef isalpha + /* Just in case the stdio library atypically contains the character macros, just like the C book claims. */ + #include + #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 @@ -102,7 +116,8 @@ print_a_char(c, name) char *name; { switch(c) - { case '\n': OUT("\\n"); + { + case '\n': OUT("\\n"); case '\t': OUT("\\t"); case '\b': OUT("\\b"); case '\r': OUT("\\r"); @@ -114,7 +129,8 @@ print_a_char(c, name) 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 */ @@ -123,62 +139,82 @@ print_a_char(c, name) } } -#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++; \ +} + +#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)) void print_a_fixnum(val) @@ -200,7 +236,8 @@ 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"); @@ -208,27 +245,43 @@ print_a_fixnum(val) return; } -#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; +} + void print_a_bignum(from) Pointer *from; @@ -243,7 +296,9 @@ print_a_bignum(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; @@ -255,47 +310,93 @@ print_a_bignum(from) (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; } -#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; +} + 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(); @@ -304,27 +405,37 @@ double val; 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; } } @@ -336,102 +447,131 @@ double val; /* 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; \ + } \ + } \ } /* 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; \ +} /* 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; @@ -444,9 +584,10 @@ fast Pointer **FObj; 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); } @@ -463,6 +604,7 @@ fast Pointer **FObj; NIntegers += 1; NBits += fixnum_to_bits; /* Fall Through */ + case TC_CHARACTER: Process_Character: Mem_Base[*Area] = Make_Non_Pointer(Code, *Obj); @@ -470,6 +612,7 @@ fast Pointer **FObj; **FObj = This; *FObj += 1; /* Fall through */ + case TC_MANIFEST_SPECIAL_NM_VECTOR: case TC_PRIMITIVE_EXTERNAL: case_simple_Non_Pointer: @@ -541,9 +684,17 @@ fast Pointer **FObj; 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: @@ -556,84 +707,104 @@ fast Pointer **FObj; /* 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); \ + } \ } +#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 /* 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); @@ -643,7 +814,8 @@ do_it() (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); @@ -655,21 +827,28 @@ do_it() 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); @@ -692,21 +871,26 @@ do_it() /* 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; @@ -722,11 +906,13 @@ do_it() /* 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 @@ -750,6 +936,7 @@ do_it() 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"); @@ -759,17 +946,21 @@ do_it() 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"); /* External Objects */ @@ -790,7 +981,9 @@ do_it() Free_Cobjects = &Mem_Base[Constant_Objects_Start]; for (; Constant_Objects > 0; Constant_Objects -= 1) + { print_external_object(Free_Cobjects); + } #endif @@ -802,7 +995,9 @@ do_it() for (Free_Objects = &Mem_Base[NROOTS]; Free_Objects < Free_Cobjects; Free_Objects += 1) + { print_an_object(*Free_Objects); + } #if false /* Pure Objects */ @@ -811,7 +1006,9 @@ do_it() for (Free_Objects = &Mem_Base[Pure_Start]; Free_Objects < Free_Cobjects; Free_Objects += 1) + { print_an_object(*Free_Objects); + } /* Constant Objects */ @@ -819,7 +1016,9 @@ do_it() for (Free_Objects = &Mem_Base[Constant_Start]; Free_Objects < Free_Cobjects; Free_Objects += 1) + { print_an_object(*Free_Objects); + } #endif return; @@ -835,8 +1034,9 @@ static struct Option_Struct Options[] = {"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; } diff --git a/v7/src/microcode/psbmap.h b/v7/src/microcode/psbmap.h index c414e24dc..9fb9c2fba 100644 --- a/v7/src/microcode/psbmap.h +++ b/v7/src/microcode/psbmap.h @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, 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 @@ -47,6 +47,7 @@ MIT in each case. */ #include "config.h" #include "object.h" #include "bignum.h" +#include "bitstr.h" #include "gc.h" #include "types.h" #include "sdata.h" @@ -60,7 +61,7 @@ extern double frexp(), ldexp(); #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 diff --git a/v7/src/microcode/psbtobin.c b/v7/src/microcode/psbtobin.c index d23b78a9b..71fb7b49e 100644 --- a/v7/src/microcode/psbtobin.c +++ b/v7/src/microcode/psbtobin.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, 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. @@ -105,7 +105,7 @@ read_a_char() 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); } @@ -259,6 +259,59 @@ read_an_integer(The_Type, To, Slot) } } +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; +} + /* Underflow and Overflow */ /* dflmax and dflmin exist in the Berserkely FORTRAN library */ @@ -353,6 +406,10 @@ Read_External(N, Table, To) 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++); @@ -364,7 +421,7 @@ Read_External(N, Table, To) 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; } @@ -602,31 +659,39 @@ long 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); @@ -641,9 +706,12 @@ Read_Header_and_Allocate() 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) diff --git a/v8/src/microcode/bintopsb.c b/v8/src/microcode/bintopsb.c index 3d14385be..9e551cab7 100644 --- a/v8/src/microcode/bintopsb.c +++ b/v8/src/microcode/bintopsb.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, 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. @@ -52,10 +52,13 @@ static Pointer *Mem_Base; 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; @@ -75,25 +78,36 @@ Load_Data(Count, To_Where) */ #ifndef isalpha + /* Just in case the stdio library atypically contains the character macros, just like the C book claims. */ + #include + #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 @@ -102,7 +116,8 @@ print_a_char(c, name) char *name; { switch(c) - { case '\n': OUT("\\n"); + { + case '\n': OUT("\\n"); case '\t': OUT("\\t"); case '\b': OUT("\\b"); case '\r': OUT("\\r"); @@ -114,7 +129,8 @@ print_a_char(c, name) 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 */ @@ -123,62 +139,82 @@ print_a_char(c, name) } } -#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++; \ +} + +#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)) void print_a_fixnum(val) @@ -200,7 +236,8 @@ 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"); @@ -208,27 +245,43 @@ print_a_fixnum(val) return; } -#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; +} + void print_a_bignum(from) Pointer *from; @@ -243,7 +296,9 @@ print_a_bignum(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; @@ -255,47 +310,93 @@ print_a_bignum(from) (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; } -#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; +} + 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(); @@ -304,27 +405,37 @@ double val; 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; } } @@ -336,102 +447,131 @@ double val; /* 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; \ + } \ + } \ } /* 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; \ +} /* 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; @@ -444,9 +584,10 @@ fast Pointer **FObj; 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); } @@ -463,6 +604,7 @@ fast Pointer **FObj; NIntegers += 1; NBits += fixnum_to_bits; /* Fall Through */ + case TC_CHARACTER: Process_Character: Mem_Base[*Area] = Make_Non_Pointer(Code, *Obj); @@ -470,6 +612,7 @@ fast Pointer **FObj; **FObj = This; *FObj += 1; /* Fall through */ + case TC_MANIFEST_SPECIAL_NM_VECTOR: case TC_PRIMITIVE_EXTERNAL: case_simple_Non_Pointer: @@ -541,9 +684,17 @@ fast Pointer **FObj; 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: @@ -556,84 +707,104 @@ fast Pointer **FObj; /* 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); \ + } \ } +#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 /* 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); @@ -643,7 +814,8 @@ do_it() (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); @@ -655,21 +827,28 @@ do_it() 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); @@ -692,21 +871,26 @@ do_it() /* 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; @@ -722,11 +906,13 @@ do_it() /* 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 @@ -750,6 +936,7 @@ do_it() 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"); @@ -759,17 +946,21 @@ do_it() 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"); /* External Objects */ @@ -790,7 +981,9 @@ do_it() Free_Cobjects = &Mem_Base[Constant_Objects_Start]; for (; Constant_Objects > 0; Constant_Objects -= 1) + { print_external_object(Free_Cobjects); + } #endif @@ -802,7 +995,9 @@ do_it() for (Free_Objects = &Mem_Base[NROOTS]; Free_Objects < Free_Cobjects; Free_Objects += 1) + { print_an_object(*Free_Objects); + } #if false /* Pure Objects */ @@ -811,7 +1006,9 @@ do_it() for (Free_Objects = &Mem_Base[Pure_Start]; Free_Objects < Free_Cobjects; Free_Objects += 1) + { print_an_object(*Free_Objects); + } /* Constant Objects */ @@ -819,7 +1016,9 @@ do_it() for (Free_Objects = &Mem_Base[Constant_Start]; Free_Objects < Free_Cobjects; Free_Objects += 1) + { print_an_object(*Free_Objects); + } #endif return; @@ -835,8 +1034,9 @@ static struct Option_Struct Options[] = {"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; } diff --git a/v8/src/microcode/psbmap.h b/v8/src/microcode/psbmap.h index cd440c2ff..d35fcfc23 100644 --- a/v8/src/microcode/psbmap.h +++ b/v8/src/microcode/psbmap.h @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, 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 @@ -47,6 +47,7 @@ MIT in each case. */ #include "config.h" #include "object.h" #include "bignum.h" +#include "bitstr.h" #include "gc.h" #include "types.h" #include "sdata.h" @@ -60,7 +61,7 @@ extern double frexp(), ldexp(); #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 diff --git a/v8/src/microcode/psbtobin.c b/v8/src/microcode/psbtobin.c index 37267fece..49cf78eb9 100644 --- a/v8/src/microcode/psbtobin.c +++ b/v8/src/microcode/psbtobin.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, 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. @@ -105,7 +105,7 @@ read_a_char() 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); } @@ -259,6 +259,59 @@ read_an_integer(The_Type, To, Slot) } } +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; +} + /* Underflow and Overflow */ /* dflmax and dflmin exist in the Berserkely FORTRAN library */ @@ -353,6 +406,10 @@ Read_External(N, Table, To) 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++); @@ -364,7 +421,7 @@ Read_External(N, Table, To) 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; } @@ -602,31 +659,39 @@ long 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); @@ -641,9 +706,12 @@ Read_Header_and_Allocate() 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)