home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / bintopsb.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  70KB  |  2,495 lines
  1. /* -*-C-*-
  2.  
  3. $Id: bintopsb.c,v 9.72 2000/12/05 21:23:43 cph Exp $
  4.  
  5. Copyright (c) 1987-2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. /* This File contains the code to translate internal format binary
  23.    files to portable format. */
  24.  
  25. /* IO definitions */
  26.  
  27. #include "psbmap.h"
  28. #include "limits.h"
  29. #define internal_file input_file
  30. #define portable_file output_file
  31.  
  32. #undef HEAP_MALLOC
  33. #define HEAP_MALLOC malloc
  34.  
  35. static long
  36. DEFUN (Load_Data, (Count, To_Where), long Count AND SCHEME_OBJECT *To_Where)
  37. {
  38.   return (fread (((char *) To_Where),
  39.          (sizeof (SCHEME_OBJECT)),
  40.          Count,
  41.          internal_file));
  42. }
  43.  
  44. #define INHIBIT_FASL_VERSION_CHECK
  45. #define INHIBIT_COMPILED_VERSION_CHECK
  46. #define INHIBIT_CHECKSUMS
  47. #include "load.c"
  48. #include "bltdef.h"
  49. #include "trap.h"
  50.  
  51. /* Character macros and procedures */
  52.  
  53. #ifndef __IRIX__
  54. extern int strlen ();
  55. #endif
  56.  
  57. #ifndef isalpha
  58.  
  59. /* Just in case the stdio library atypically contains the character
  60.    macros, just like the C book claims. */
  61.  
  62. #include <ctype.h>
  63.  
  64. #endif /* isalpha */
  65.  
  66. #ifndef ispunct
  67.  
  68. /* This is in some libraries but not others */
  69.  
  70. static char
  71.   punctuation[] = "'\",<.>/?;:{}[]|`~=+-_()*&^%$#@!";
  72.  
  73. static Boolean
  74. DEFUN (ispunct_local, (c), fast char c)
  75. {
  76.   fast char * s;
  77.  
  78.   s = &punctuation[0];
  79.   while (*s != '\0')
  80.     if (*s++ == c)
  81.       return (true);
  82.   return (false);
  83. }
  84.  
  85. #define ispunct ispunct_local
  86.  
  87. #endif /* ispunct */
  88.  
  89. /* Needed to upgrade */
  90.  
  91. #define TC_PRIMITIVE_EXTERNAL    0x10
  92.  
  93. #define STRING_LENGTH_TO_LONG(value)                    \
  94.   ((long) (upgrade_lengths_p ? (OBJECT_DATUM (value)) : (value)))
  95.  
  96. /* In case there is no compiled code support. */
  97.  
  98. #ifndef FORMAT_WORD_LOW_BYTE
  99. #define FORMAT_WORD_LOW_BYTE(x) x
  100. #endif
  101.  
  102. #ifndef FORMAT_WORD_HIGH_BYTE
  103. #define FORMAT_WORD_HIGH_BYTE(x) x
  104. #endif
  105.  
  106. #ifndef COMPILED_ENTRY_FORMAT_WORD
  107. #define COMPILED_ENTRY_FORMAT_WORD(entry)    0
  108. #endif
  109.  
  110. #ifndef EXTRACT_EXECUTE_CACHE_ARITY
  111. #define EXTRACT_EXECUTE_CACHE_ARITY(v,a) do { } while (0)
  112. #endif
  113.  
  114. #if (COMPILER_PROCESSOR_TYPE != COMPILER_LOSING_C_TYPE)
  115.  
  116. #undef START_CLOSURE_RELOCATION
  117. #undef END_CLOSURE_RELOCATION
  118. #undef EXTRACT_CLOSURE_ENTRY_ADDRESS
  119. #undef STORE_CLOSURE_ENTRY_ADDRESS
  120. #undef EXTRACT_OPERATOR_LINKAGE_ADDRESS
  121. #undef STORE_OPERATOR_LINKAGE_ADDRESS
  122. #undef START_OPERATOR_RELOCATION
  123. #undef END_OPERATOR_RELOCATION
  124.  
  125. #define START_CLOSURE_RELOCATION(foo) do {} while (0)
  126. #define END_CLOSURE_RELOCATION(foo) do {} while (0)
  127. #define EXTRACT_CLOSURE_ENTRY_ADDRESS(var,addr) do {} while (0)
  128. #define STORE_CLOSURE_ENTRY_ADDRESS(var,addr) do {} while (0)
  129. #define EXTRACT_OPERATOR_LINKAGE_ADDRESS(var,addr) do {} while (0)
  130. #define STORE_OPERATOR_LINKAGE_ADDRESS(var,addr) do {} while (0)
  131. #define START_OPERATOR_RELOCATION(foo) do {} while (0)
  132. #define END_OPERATOR_RELOCATION(foo) do {} while (0)
  133.  
  134. #endif /* (COMPILER_PROCESSOR_TYPE != COMPILER_LOSING_C_TYPE) */
  135.  
  136. /* Global data */
  137.  
  138. static Boolean
  139.   allow_bands_p = false,
  140.   allow_compiled_p = false,
  141.   allow_constant_space_p = false,
  142.   allow_nmv_p = false,
  143.   c_compiled_p = false,
  144.   endian_invert_p = false,
  145.   shuffle_bytes_p = false,
  146.   swap_bytes_p = false,
  147.   upgrade_compiled_p = false,
  148.   upgrade_lengths_p = false,
  149.   upgrade_primitives_p = false,
  150.   upgrade_traps_p = false,
  151.   warn_portable_p = true;
  152.  
  153. static long
  154.   Heap_Relocation, Constant_Relocation,
  155.   Max_Stack_Offset,
  156.   Scan, Free, Objects,
  157.   Scan_Constant, Free_Constant, Constant_Objects,
  158.   Scan_Pure, Free_Pure, Pure_Objects;
  159.  
  160. static SCHEME_OBJECT
  161.   * Mem_Base, * Constant_Space, * Constant_Top,
  162.   * Free_Objects, * Free_Cobjects, * Free_Pobjects,
  163.   * compiled_entry_table, * compiled_entry_pointer,
  164.   * compiled_entry_table_end,
  165.   * compiled_block_table, * compiled_block_pointer,
  166.   * compiled_block_table_end,
  167.   * primitive_table, * primitive_table_end,
  168.   * c_code_table, * c_code_table_end;
  169.  
  170. static long
  171.   NFlonums,
  172.   NIntegers, NBits,
  173.   NBitstrs, NBBits,
  174.   NStrings, NChars,
  175.   NPChars, NCChars;
  176.  
  177. #define NO_ALIGNMENT(index) do { } while (0)
  178.  
  179. #ifdef FLOATING_ALIGNMENT
  180. #define INDEX_ALIGN_FLOAT(index) do                    \
  181. {                                    \
  182.   while (((((unsigned long) (& Mem_Base[(index) + 1]))            \
  183.        - ((unsigned long) (& Mem_Base[0])))                \
  184.       & FLOATING_ALIGNMENT)                        \
  185.      != 0)                                \
  186.     Mem_Base[(index)++] = SHARP_F;                    \
  187. } while (0)
  188. #endif /* FLOATING_ALIGNMENT */
  189.  
  190. #ifndef INDEX_ALIGN_FLOAT
  191. #define INDEX_ALIGN_FLOAT NO_ALIGNMENT
  192. #endif /* INDEX_ALIGN_FLOAT */
  193.  
  194. #define OUT(s)                                \
  195. {                                    \
  196.   fprintf (portable_file, (s));                        \
  197.   break;                                \
  198. }
  199.  
  200. static void
  201. DEFUN (print_a_char, (c, name), fast char c AND char * name)
  202. {
  203.   switch (c)
  204.   {
  205.     case '\n':  OUT ("\\n");
  206.     case '\t':  OUT ("\\t");
  207.     case '\b':  OUT ("\\b");
  208.     case '\r':  OUT ("\\r");
  209.     case '\f':  OUT ("\\f");
  210.     case '\\':  OUT ("\\\\");
  211.     case '\0':  OUT ("\\0");
  212.     case ' ' :  OUT (" ");
  213.  
  214.     default:
  215.     if ((isascii (c)) && ((isalpha (c)) || (isdigit (c)) || (ispunct (c))))
  216.       putc (c, portable_file);
  217.     else
  218.     {
  219.       unsigned int x = (((int) c) & ((1 << CHAR_BIT) - 1));
  220.       if (warn_portable_p)
  221.       {
  222.     fprintf (stderr,
  223.          "%s: %s: File may not be portable: c = 0x%x\n",
  224.          program_name, name, x);
  225.     warn_portable_p = false;
  226.       }
  227.       /* This does not follow C conventions, but eliminates ambiguity */
  228.       fprintf (portable_file, "\\X%d ", x);
  229.     }
  230.   }
  231.   return;
  232. }
  233.  
  234. #undef MAKE_BROKEN_HEART
  235. #define MAKE_BROKEN_HEART(offset) (BROKEN_HEART_ZERO + (offset))
  236.  
  237. #define DO_COMPOUND(Code, Rel, Fre, Scn, Obj, FObj, kernel_code) do    \
  238. {                                    \
  239.   Old_Address += (Rel);                            \
  240.   Old_Contents = (*Old_Address);                    \
  241.   if (BROKEN_HEART_P (Old_Contents))                    \
  242.     (Mem_Base [(Scn)]) = (OBJECT_NEW_TYPE ((Code), Old_Contents));    \
  243.   else                                    \
  244.     kernel_code;                            \
  245. } while (0)
  246.  
  247. #define STANDARD_KERNEL(kernel_code, type, Code, Scn, Obj, FObj) do    \
  248. {                                    \
  249.   (Mem_Base [(Scn)]) = (MAKE_OBJECT ((Code), (Obj)));            \
  250.   {                                    \
  251.     fast long length = (OBJECT_DATUM (Old_Contents));            \
  252.     kernel_code;                            \
  253.     (*Old_Address++) = (MAKE_BROKEN_HEART (Obj));            \
  254.     (Obj) += 1;                                \
  255.     (*(FObj)++) = (MAKE_OBJECT ((type), 0));                \
  256.     (*(FObj)++) = Old_Contents;                        \
  257.     while ((length--) > 0)                        \
  258.       (*(FObj)++) = (*Old_Address++);                    \
  259.   }                                    \
  260. } while (0)
  261.  
  262. #define DO_STRING_KERNEL() do                        \
  263. {                                    \
  264.   NStrings += 1;                            \
  265.   NChars += (pointer_to_char (length - 1));                \
  266. } while (0)
  267.  
  268. #define DO_BIGNUM_KERNEL() do                        \
  269. {                                    \
  270.   NIntegers += 1;                            \
  271.   NBits +=                                \
  272.     (((* ((bignum_digit_type *) (Old_Address + 1)))            \
  273.       & BIGNUM_DIGIT_MASK)                        \
  274.      * BIGNUM_DIGIT_LENGTH);                        \
  275. } while (0)
  276.  
  277. #define DO_BIT_STRING_KERNEL() do                    \
  278. {                                    \
  279.   NBitstrs += 1;                            \
  280.   NBBits += (Old_Address [BIT_STRING_LENGTH_OFFSET]);            \
  281. } while (0)
  282.  
  283. #define DO_FLONUM_KERNEL(Code, Scn, Obj, FObj) do            \
  284. {                                    \
  285.   int ctr;                                \
  286.   SCHEME_OBJECT * dest;                            \
  287.                                     \
  288.   (Mem_Base [(Scn)]) = (MAKE_OBJECT ((Code), (Obj)));            \
  289.   NFlonums += 1;                            \
  290.   (*Old_Address++) = (MAKE_BROKEN_HEART (Obj));                \
  291.   (Obj) += 1;                                \
  292.   (*(FObj)++) = (MAKE_OBJECT (TC_BIG_FLONUM, 0));            \
  293.   dest = (FObj);                            \
  294.   for (ctr = 0; ctr < float_to_pointer; ctr++)                \
  295.     *dest++ = (*Old_Address++);                        \
  296.   (FObj) = dest;                            \
  297. } while (0)
  298.  
  299. #define DO_STRING(Code, Rel, Fre, Scn, Obj, FObj)            \
  300.   DO_COMPOUND (Code, Rel, Fre, Scn, Obj, FObj,                \
  301.            STANDARD_KERNEL (DO_STRING_KERNEL (),            \
  302.                 TC_CHARACTER_STRING,            \
  303.                 Code, Scn, Obj, FObj))
  304.  
  305. #define DO_BIGNUM(Code, Rel, Fre, Scn, Obj, FObj)            \
  306.   DO_COMPOUND (Code, Rel, Fre, Scn, Obj, FObj,                \
  307.            STANDARD_KERNEL (DO_BIGNUM_KERNEL (), TC_BIG_FIXNUM,    \
  308.                 Code, Scn, Obj, FObj))
  309.  
  310. #define DO_BIT_STRING(Code, Rel, Fre, Scn, Obj, FObj)            \
  311.   DO_COMPOUND (Code, Rel, Fre, Scn, Obj, FObj,                \
  312.            STANDARD_KERNEL (DO_BIT_STRING_KERNEL (), TC_BIT_STRING,    \
  313.                 Code, Scn, Obj, FObj))
  314.  
  315. #define DO_FLONUM(Code, Rel, Fre, Scn, Obj, FObj)            \
  316.   DO_COMPOUND (Code, Rel, Fre, Scn, Obj, FObj,                \
  317.            DO_FLONUM_KERNEL (Code, Scn, Obj, FObj))
  318.  
  319. static void
  320. DEFUN (print_a_fixnum, (val), long val)
  321. {
  322.   fast long size_in_bits;
  323.   fast unsigned long temp;
  324.  
  325.   temp = ((val < 0) ? -val : val);
  326.   for (size_in_bits = 0; temp != 0; size_in_bits += 1)
  327.     temp = temp >> 1;
  328.   fprintf (portable_file, "%02x %c ", TC_FIXNUM, (val < 0 ? '-' : '+'));
  329.   if (val == 0)
  330.     fprintf (portable_file, "0\n");
  331.   else
  332.   {
  333.     fprintf (portable_file, "%ld ", size_in_bits);
  334.     temp = ((val < 0) ? -val : val);
  335.     while (temp != 0)
  336.     {
  337.       fprintf (portable_file, "%01lx", (temp & 0xf));
  338.       temp = temp >> 4;
  339.     }
  340.     fprintf (portable_file, "\n");
  341.   }
  342.   return;
  343. }
  344.  
  345. static void
  346. DEFUN (print_a_string_internal, (len, str), fast long len AND fast char * str)
  347. {
  348.   fprintf (portable_file, "%ld ", len);
  349.   if (shuffle_bytes_p)
  350.   {
  351.     while (len > 0)
  352.     {
  353.       print_a_char (str[3], "print_a_string");
  354.       if (len > 1)
  355.     print_a_char (str[2], "print_a_string");
  356.       if (len > 2)
  357.     print_a_char (str[1], "print_a_string");
  358.       if (len > 3)
  359.     print_a_char (str[0], "print_a_string");
  360.       len -= 4;
  361.       str += 4;
  362.     }
  363.   }
  364.   else
  365.     while (--len >= 0)
  366.       print_a_char (*str++, "print_a_string");
  367.   putc ('\n', portable_file);
  368.   return;
  369. }
  370.  
  371. static void
  372. DEFUN (print_a_string, (from), SCHEME_OBJECT * from)
  373. {
  374.   long len, maxlen;
  375.  
  376.   maxlen = ((pointer_to_char ((OBJECT_DATUM (*from++)) - 1)) - 1);
  377.   len = (STRING_LENGTH_TO_LONG (*from++));
  378.  
  379.   /* If compacting, do not compact strings that have non-default
  380.      maximum lengths.
  381.    */
  382.  
  383.   fprintf (portable_file,
  384.        "%02x %ld ",
  385.        TC_CHARACTER_STRING,
  386.        ((compact_p
  387.          && ((BYTES_TO_WORDS (len + 1)) == (BYTES_TO_WORDS (maxlen + 1))))
  388.         ? len
  389.         : maxlen));
  390.  
  391.   print_a_string_internal (len, ((char *) from));
  392.   return;
  393. }
  394.  
  395. static void
  396. DEFUN (print_a_primitive, (arity, length, name),
  397.        long arity AND long length AND char * name)
  398. {
  399.   fprintf (portable_file, "%ld ", arity);
  400.   print_a_string_internal (length, name);
  401.   return;
  402. }
  403.  
  404. static void
  405. DEFUN (print_a_c_code_block, (nentries, length, name),
  406.        long nentries AND long length AND char * name)
  407. {
  408.   fprintf (portable_file, "%ld ", nentries);
  409.   print_a_string_internal (length, name);
  410.   return;
  411. }
  412.  
  413. static long
  414. DEFUN (bignum_length, (bignum), SCHEME_OBJECT bignum)
  415. {
  416.   if (BIGNUM_ZERO_P (bignum))
  417.     return (0);
  418.   {
  419.     bignum_length_type index = ((BIGNUM_LENGTH (bignum)) - 1);
  420.     fast bignum_digit_type digit = (BIGNUM_REF (bignum, index));
  421.     fast long result;
  422.     if (index >= (LONG_MAX / BIGNUM_DIGIT_LENGTH))
  423.       goto loser;
  424.     result = (index * BIGNUM_DIGIT_LENGTH);
  425.     while (digit > 0)
  426.       {
  427.     result += 1;
  428.     if (result >= LONG_MAX)
  429.       goto loser;
  430.     digit >>= 1;
  431.       }
  432.     return (result);
  433.   }
  434.  loser:
  435.   fprintf (stderr, "%s: Bignum exceeds representable length.\n",
  436.        program_name);
  437.   quit (1);
  438.   /*NOTREACHED*/
  439.   return (0);
  440. }
  441.  
  442. static void
  443. DEFUN (print_a_bignum, (bignum_ptr), SCHEME_OBJECT * bignum_ptr)
  444. {
  445.   SCHEME_OBJECT bignum;
  446.  
  447.   bignum = (MAKE_POINTER_OBJECT (TC_BIG_FIXNUM, bignum_ptr));
  448.  
  449.   if (BIGNUM_ZERO_P (bignum))
  450.   {
  451.     fprintf (portable_file, "%02x + 0\n",
  452.          (compact_p ? TC_FIXNUM : TC_BIG_FIXNUM));
  453.     return;
  454.   }
  455.   {
  456.     int the_type = TC_BIG_FIXNUM;
  457.     bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
  458.     fast long length_in_bits = (bignum_length (bignum));
  459.     fast int bits_in_digit = 0;
  460.     fast bignum_digit_type accumulator;
  461.  
  462.     /* This attempts to preserve non-canonicalized bignums as such. 
  463.        The test below fails for the most negative fixnum represented
  464.        as a bignum
  465.      */ 
  466.  
  467.     if (compact_p && (length_in_bits > fixnum_to_bits))
  468.       the_type = TC_FIXNUM;
  469.  
  470.     fprintf (portable_file, "%02x %c %ld ",
  471.          the_type,
  472.          ((BIGNUM_NEGATIVE_P (bignum)) ? '-' : '+'),
  473.          length_in_bits);
  474.     accumulator = (*scan++);
  475.     bits_in_digit = ((length_in_bits < BIGNUM_DIGIT_LENGTH)
  476.              ? length_in_bits
  477.              : BIGNUM_DIGIT_LENGTH);
  478.     while (length_in_bits > 0)
  479.       {
  480.     if (bits_in_digit > 4)
  481.       {
  482.         fprintf (portable_file, "%01lx", (accumulator & 0xf));
  483.         length_in_bits -= 4;
  484.         accumulator >>= 4;
  485.         bits_in_digit -= 4;
  486.       }
  487.     else if (bits_in_digit == 4)
  488.       {
  489.         fprintf (portable_file, "%01lx", accumulator);
  490.         length_in_bits -= 4;
  491.         if (length_in_bits >= BIGNUM_DIGIT_LENGTH)
  492.           {
  493.         accumulator = (*scan++);
  494.         bits_in_digit = BIGNUM_DIGIT_LENGTH;
  495.           }
  496.         else if (length_in_bits > 0)
  497.           {
  498.         accumulator = (*scan++);
  499.         bits_in_digit = length_in_bits;
  500.           }
  501.         else
  502.           break;
  503.       }
  504.     else if (bits_in_digit < length_in_bits)
  505.       {
  506.         long carry = accumulator;
  507.         int diff_bits = (4 - bits_in_digit);
  508.         accumulator = (*scan++);
  509.         fprintf (portable_file, "%01lx",
  510.              (carry
  511.               | ((accumulator & ((1 << diff_bits) - 1)) <<
  512.              bits_in_digit)));
  513.         length_in_bits -= 4;
  514.         bits_in_digit = (BIGNUM_DIGIT_LENGTH - diff_bits);
  515.         if (length_in_bits >= bits_in_digit)
  516.           accumulator >>= diff_bits;
  517.         else if (length_in_bits > 0)
  518.           {
  519.         accumulator >>= diff_bits;
  520.         bits_in_digit = length_in_bits;
  521.           }
  522.         else
  523.           break;
  524.       }
  525.     else
  526.       {
  527.         fprintf (portable_file, "%01lx", accumulator);
  528.         break;
  529.       }
  530.       }
  531.   }
  532.   fprintf (portable_file, "\n");
  533.   return;
  534. }
  535.  
  536. /* The following procedure assumes that a C long is at least 4 bits. */
  537.  
  538. static void
  539. DEFUN (print_a_bit_string, (from), SCHEME_OBJECT * from)
  540. {
  541.   SCHEME_OBJECT the_bit_string;
  542.   fast long bits_remaining, leftover_bits;
  543.   fast SCHEME_OBJECT accumulator, next_word, *scan;
  544.  
  545.   the_bit_string = (MAKE_POINTER_OBJECT (TC_BIT_STRING, from));
  546.   bits_remaining = (BIT_STRING_LENGTH (the_bit_string));
  547.   fprintf (portable_file, "%02x %ld", TC_BIT_STRING, bits_remaining);
  548.  
  549.   if (bits_remaining != 0)
  550.   {
  551.     fprintf (portable_file, " ");
  552.     scan = (BIT_STRING_LOW_PTR (the_bit_string));
  553.     for (leftover_bits = 0;
  554.      bits_remaining > 0;
  555.      bits_remaining -= OBJECT_LENGTH)
  556.     {
  557.       next_word = (* (INC_BIT_STRING_PTR (scan)));
  558.  
  559.       if (bits_remaining < OBJECT_LENGTH)
  560.     next_word &= (LOW_MASK (bits_remaining));
  561.  
  562.       if (leftover_bits == 0)
  563.     leftover_bits = ((bits_remaining > OBJECT_LENGTH)
  564.              ? OBJECT_LENGTH
  565.              : bits_remaining);
  566.       else
  567.       {
  568.     accumulator &= (LOW_MASK (leftover_bits));
  569.     accumulator |=
  570.       ((next_word & (LOW_MASK (4 - leftover_bits))) << leftover_bits);
  571.     next_word = (next_word >> (4 - leftover_bits));
  572.     leftover_bits += ((bits_remaining > OBJECT_LENGTH)
  573.               ? (OBJECT_LENGTH - 4)
  574.               : (bits_remaining - 4));
  575.     fprintf (portable_file, "%01lx", (accumulator & 0xf));
  576.       }
  577.  
  578.       for (accumulator = next_word; leftover_bits >= 4; leftover_bits -= 4)
  579.       {
  580.     fprintf (portable_file, "%01lx", (accumulator & 0xf));
  581.     accumulator = (accumulator >> 4);
  582.       }
  583.     }
  584.     if (leftover_bits != 0)
  585.       fprintf (portable_file, "%01lx", (accumulator & 0xf));
  586.   }
  587.   fprintf (portable_file, "\n");
  588.   return;
  589. }
  590.  
  591. union flonum_u
  592. {
  593.   double dval;
  594.   unsigned long lval[float_to_pointer];
  595. };
  596.  
  597. static void
  598. DEFUN (print_a_flonum, (src), SCHEME_OBJECT * src)
  599. {
  600.   double val;
  601.   union flonum_u utemp;
  602.   fast long size_in_bits;
  603.   fast double mant, temp;
  604.   int expt, ctr;
  605.   extern double EXFUN (frexp, (double, int *));
  606.  
  607.   for (ctr = 0; ctr < float_to_pointer; ctr++)
  608.     utemp.lval[ctr] = ((unsigned long) src[ctr]);
  609.   val = utemp.dval;
  610.  
  611.   fprintf (portable_file, "%02x %c ",
  612.        TC_BIG_FLONUM,
  613.        ((val < 0.0) ? '-' : '+'));
  614.   if (val == 0.0)
  615.   {
  616.     fprintf (portable_file, "0\n");
  617.     return;
  618.   }
  619.   mant = frexp (((val < 0.0) ? -val : val), &expt);
  620.   size_in_bits = 1;
  621.  
  622.   for (temp = ((mant * 2.0) - 1.0); temp != 0; size_in_bits += 1)
  623.   {
  624.     temp *= 2.0;
  625.     if (temp >= 1.0)
  626.       temp -= 1.0;
  627.   }
  628.   fprintf (portable_file, "%d %ld ", expt, size_in_bits);
  629.  
  630.   for (size_in_bits = (hex_digits (size_in_bits));
  631.        size_in_bits > 0;
  632.        size_in_bits -= 1)
  633.   {
  634.     fast unsigned int digit;
  635.  
  636.     digit = 0;
  637.     for (expt = 4; --expt >= 0;)
  638.     {
  639.       mant *= 2.0;
  640.       digit = digit << 1;
  641.       if (mant >= 1.0)
  642.       {
  643.     mant -= 1.0;
  644.     digit += 1;
  645.       }
  646.     }
  647.     fprintf (portable_file, "%01x", digit);
  648.   }
  649.   putc ('\n', portable_file);
  650.   return;
  651. }
  652.  
  653. /* Normal Objects */
  654.  
  655. #define DO_CELL(Code, Rel, Fre, Scn, Obj, FObj) do            \
  656. {                                    \
  657.   Old_Address += (Rel);                            \
  658.   Old_Contents = (*Old_Address);                    \
  659.   if (BROKEN_HEART_P (Old_Contents))                    \
  660.     (Mem_Base [(Scn)]) =                        \
  661.       (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents));            \
  662.   else                                    \
  663.     {                                    \
  664.       (*Old_Address++) = (MAKE_BROKEN_HEART (Fre));            \
  665.       (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre)));        \
  666.       (Mem_Base [(Fre)++]) = Old_Contents;                \
  667.     }                                    \
  668. } while (0)
  669.  
  670. #define DO_PAIR(Code, Rel, Fre, Scn, Obj, FObj) do            \
  671. {                                    \
  672.   Old_Address += (Rel);                            \
  673.   Old_Contents = (*Old_Address);                    \
  674.   if (BROKEN_HEART_P (Old_Contents))                    \
  675.     (Mem_Base [(Scn)]) =                        \
  676.       (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents));            \
  677.   else                                    \
  678.     {                                    \
  679.       (*Old_Address++) = (MAKE_BROKEN_HEART (Fre));            \
  680.       (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre)));        \
  681.       (Mem_Base [(Fre)++]) = Old_Contents;                \
  682.       (Mem_Base [(Fre)++]) = (*Old_Address++);                \
  683.     }                                    \
  684. } while (0)
  685.  
  686. #define DO_TRIPLE(Code, Rel, Fre, Scn, Obj, FObj) do            \
  687. {                                    \
  688.   Old_Address += (Rel);                            \
  689.   Old_Contents = (*Old_Address);                    \
  690.   if (BROKEN_HEART_P (Old_Contents))                    \
  691.     (Mem_Base [(Scn)]) =                        \
  692.       (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents));            \
  693.   else                                    \
  694.     {                                    \
  695.       (*Old_Address++) = (MAKE_BROKEN_HEART (Fre));            \
  696.       (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre)));        \
  697.       (Mem_Base [(Fre)++]) = Old_Contents;                \
  698.       (Mem_Base [(Fre)++]) = (*Old_Address++);                \
  699.       (Mem_Base [(Fre)++]) = (*Old_Address++);                \
  700.     }                                    \
  701. } while (0)
  702.  
  703. #define DO_QUAD(Code, Rel, Fre, Scn, Obj, FObj) do            \
  704. {                                    \
  705.   Old_Address += (Rel);                            \
  706.   Old_Contents = (*Old_Address);                    \
  707.   if (BROKEN_HEART_P (Old_Contents))                    \
  708.     (Mem_Base [(Scn)]) =                        \
  709.       (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents));            \
  710.   else                                    \
  711.     {                                    \
  712.       (*Old_Address++) = (MAKE_BROKEN_HEART (Fre));            \
  713.       (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre)));        \
  714.       (Mem_Base [(Fre)++]) = Old_Contents;                \
  715.       (Mem_Base [(Fre)++]) = (*Old_Address++);                \
  716.       (Mem_Base [(Fre)++]) = (*Old_Address++);                \
  717.       (Mem_Base [(Fre)++]) = (*Old_Address++);                \
  718.     }                                    \
  719. } while (0)
  720.  
  721. #define DO_RAW_QUAD(Code, Rel, Fre, Scn, Obj, FObj) do            \
  722. {                                    \
  723.   Old_Address += (Rel);                            \
  724.   Old_Contents = (* Old_Address);                    \
  725.   if (BROKEN_HEART_P (Old_Contents))                    \
  726.     (Mem_Base [(Scn)]) = (OBJECT_DATUM (Old_Contents));            \
  727.   else                                    \
  728.     {                                    \
  729.       (*Old_Address++) = (MAKE_BROKEN_HEART (Fre));            \
  730.       (Mem_Base [(Scn)]) = (Fre);                    \
  731.       (Mem_Base [(Fre)++]) = Old_Contents;                \
  732.       (Mem_Base [(Fre)++]) = (*Old_Address++);                \
  733.       (Mem_Base [(Fre)++]) = (*Old_Address++);                \
  734.       (Mem_Base [(Fre)++]) = (*Old_Address++);                \
  735.     }                                    \
  736. } while (0)
  737.  
  738. #define COPY_VECTOR(Fre) do                        \
  739. {                                    \
  740.   fast long len = (OBJECT_DATUM (Old_Contents));            \
  741.   (*Old_Address++) = (MAKE_BROKEN_HEART (Fre));                \
  742.   (Mem_Base [(Fre)++]) = Old_Contents;                    \
  743.   while ((len--) > 0)                            \
  744.     (Mem_Base [(Fre)++]) = (*Old_Address++);                \
  745. } while (0)
  746.  
  747. /* This is a hack to get the cross compiler to work
  748.    accross different endianness.
  749. */
  750.  
  751. #define COPY_INVERTED_VECTOR(Fre) do                    \
  752. {                                    \
  753.   fast long len1, len2;                            \
  754.   SCHEME_OBJECT * Saved;                        \
  755.                                     \
  756.   len1 = (OBJECT_DATUM (Old_Contents));                    \
  757.   (*Old_Address++) = (MAKE_BROKEN_HEART (Fre));                \
  758.   (Mem_Base [(Fre)++]) = Old_Contents;                    \
  759.   if ((OBJECT_TYPE (* Old_Address)) != TC_MANIFEST_NM_VECTOR)        \
  760.   {                                    \
  761.     fprintf (stderr, "%s: Bad compiled code block found.\n",        \
  762.          program_name);                        \
  763.     quit (1);                                \
  764.   }                                    \
  765.   len2 = (OBJECT_DATUM (*Old_Address));                    \
  766.   (Mem_Base [(Fre)++]) = (*Old_Address++);                \
  767.   Old_Address += len2;                            \
  768.   Saved = Old_Address;                            \
  769.   len1 -= (len2 + 1);                            \
  770.   while ((len2--) > 0)                            \
  771.     (Mem_Base [(Fre)++]) = (*--Old_Address);                \
  772.   Old_Address = Saved;                            \
  773.   while ((len1--) > 0)                            \
  774.     (Mem_Base [(Fre)++]) = (*Old_Address++);                \
  775. } while (0)
  776.  
  777. #define DO_VECTOR_2(aligner, copier, Code, Rel, Fre, Scn, Obj, FObj) do    \
  778. {                                    \
  779.   Old_Address += (Rel);                            \
  780.   Old_Contents = (*Old_Address);                    \
  781.   if (BROKEN_HEART_P (Old_Contents))                    \
  782.     (Mem_Base [(Scn)]) =                        \
  783.       (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents));            \
  784.   else                                    \
  785.     {                                    \
  786.       aligner (Fre);                            \
  787.       (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre)));        \
  788.       copier (Fre);                            \
  789.     }                                    \
  790. } while (0)
  791.  
  792. #define DO_VECTOR(Code, Rel, Fre, Scn, Obj, FObj)            \
  793.   DO_VECTOR_2 (NO_ALIGNMENT, COPY_VECTOR,                \
  794.            Code, Rel, Fre, Scn, Obj, FObj)
  795.  
  796. #define DO_INVERTED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj)        \
  797.   DO_VECTOR_2 (NO_ALIGNMENT, COPY_INVERTED_VECTOR,            \
  798.            Code, Rel, Fre, Scn, Obj, FObj)
  799.  
  800. #ifdef HAS_COMPILER_SUPPORT
  801.  
  802. #define CHAR_OFFSET(a,b) (((char *) (a)) - ((char *) (b)))
  803. #define OBJ_OFFSET(a,b)  (((SCHEME_OBJECT *) (a)) - ((SCHEME_OBJECT *) (b)))
  804.  
  805. #define DO_ENTRY_INTERNAL(sub, copy, Code, Rel, Fre, Scn, Obj, FObj) do    \
  806. {                                    \
  807.   long offset;                                \
  808.   SCHEME_OBJECT * saved;                        \
  809.                                     \
  810.   Old_Address += (Rel);                            \
  811.   saved = Old_Address;                            \
  812.   Get_Compiled_Block (Old_Address, saved);                \
  813.   Old_Contents = (*Old_Address);                    \
  814.   entry_no = (compiled_entry_pointer - compiled_entry_table);        \
  815.   offset = (sub (saved, Old_Address));                    \
  816.   (*compiled_entry_pointer++) = (LONG_TO_UNSIGNED_FIXNUM (offset));    \
  817.   if (BROKEN_HEART_P (Old_Contents))                    \
  818.     (*compiled_entry_pointer++) =                    \
  819.       (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents));            \
  820.   else                                    \
  821.   {                                    \
  822.     INDEX_ALIGN_FLOAT (Fre);                        \
  823.     (*compiled_entry_pointer++) =                    \
  824.       (MAKE_OBJECT_FROM_OBJECTS (This, (Fre)));                \
  825.     copy (Fre);                                \
  826.   }                                    \
  827. } while (0)
  828.  
  829. #define DO_COMPILED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj)        \
  830.   DO_VECTOR_2 (INDEX_ALIGN_FLOAT, COPY_VECTOR,                \
  831.            Code, Rel, Fre, Scn, Obj, FObj)
  832.  
  833. #define DO_INVERTED_COMPILED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj)    \
  834.   DO_VECTOR_2 (INDEX_ALIGN_FLOAT, COPY_INVERTED_VECTOR,            \
  835.            Code, Rel, Fre, Scn, Obj, FObj)
  836.  
  837. #define DO_C_COMPILED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj)        \
  838.   DO_VECTOR_2 (INDEX_ALIGN_FLOAT, COPY_C_COMPILED_BLOCK,        \
  839.            Code, Rel, Fre, Scn, Obj, FObj)
  840.  
  841. #define DO_COMPILED_ENTRY(Code, Rel, Fre, Scn, Obj, FObj)        \
  842.   DO_ENTRY_INTERNAL (CHAR_OFFSET, COPY_VECTOR,                \
  843.              Code, Rel, Fre, Scn, Obj, FObj)
  844.  
  845. #define DO_C_COMPILED_ENTRY(Code, Rel, Fre, Scn, Obj, FObj)        \
  846.   DO_ENTRY_INTERNAL (OBJ_OFFSET, COPY_C_COMPILED_BLOCK,            \
  847.              Code, Rel, Fre, Scn, Obj, FObj)
  848.  
  849. /* This depends on the fact that a compiled code block has an NMV
  850.    header in the first or second words.
  851.  */
  852.  
  853. long
  854. DEFUN (copy_c_compiled_block, (Fre, Old_Contents, Old_Address),
  855.        long Fre AND SCHEME_OBJECT Old_Contents AND SCHEME_OBJECT * Old_Address)
  856. {
  857.   SCHEME_OBJECT preserved_nmv, preserved_loc;
  858.   SCHEME_OBJECT nmv_replacement
  859.     = (MAKE_OBJECT (TC_BROKEN_HEART,
  860.             (compiled_block_pointer
  861.              - compiled_block_table)));
  862.   fast long len = (OBJECT_DATUM (Old_Contents));
  863.  
  864.   *Old_Address++ = (MAKE_BROKEN_HEART (Fre));
  865.   if ((OBJECT_TYPE (Old_Contents)) != TC_MANIFEST_CLOSURE)
  866.   {
  867.     if ((OBJECT_TYPE (Old_Contents)) == TC_MANIFEST_NM_VECTOR)
  868.     {
  869.       preserved_nmv = Old_Contents;
  870.       preserved_loc = (LONG_TO_UNSIGNED_FIXNUM (Fre));
  871.       Old_Contents = nmv_replacement;
  872.     }
  873.     else if ((OBJECT_TYPE (*Old_Address)) == TC_MANIFEST_NM_VECTOR)
  874.     {
  875.       preserved_nmv = *Old_Address;
  876.       preserved_loc = (LONG_TO_UNSIGNED_FIXNUM ((Fre) + 1));
  877.       *Old_Address = nmv_replacement;
  878.     }
  879.     else
  880.     {
  881.       fprintf (stderr,
  882.            "%s: Improperly formatted C-compiled code block.\n",
  883.            program_name);
  884.       quit (1);
  885.     }
  886.  
  887.     *compiled_block_pointer++ = preserved_loc;
  888.     *compiled_block_pointer++ = preserved_nmv;
  889.   }
  890.  
  891.   (Mem_Base [(Fre)++]) = Old_Contents;
  892.   while ((len--) > 0)
  893.     (Mem_Base [(Fre)++]) = (*Old_Address++);
  894.   return (Fre);
  895. }
  896.  
  897. #define COPY_C_COMPILED_BLOCK(Fre) do                    \
  898. {                                    \
  899.   Fre = copy_c_compiled_block (Fre, Old_Contents, Old_Address);        \
  900. } while (0)
  901.  
  902. #else /* no HAS_COMPILER_SUPPORT */
  903.  
  904. #define COMPILER_BAD_STMT(name) do                    \
  905. {                                    \
  906.   fprintf (stderr,                            \
  907.        "%s: Invoking %s with no compiler support!\n",        \
  908.        program_name, name);                        \
  909.   quit (1);                                \
  910. } while (0)
  911.  
  912. #define DO_COMPILED_ENTRY(Code, Rel, Fre, Scn, Obj, FObj)        \
  913.   COMPILER_BAD_STMT ("DO_COMPILED_ENTRY")
  914.  
  915. #define DO_COMPILED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj)        \
  916.   COMPILER_BAD_STMT ("DO_COMPILED_BLOCK")
  917.  
  918. #define DO_INVERTED_COMPILED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj)    \
  919.   COMPILER_BAD_STMT ("DO_INVERTED_COMPILED_BLOCK")
  920.  
  921. #define DO_C_COMPILED_ENTRY(Code, Rel, Fre, Scn, Obj, FObj)        \
  922.   COMPILER_BAD_STMT ("DO_C_COMPILED_ENTRY")
  923.  
  924. #define  DO_C_COMPILED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj)
  925.   COMPILER_BAD_STMT ("DO_C_COMPILED_BLOCK")
  926.  
  927. #endif /* HAS_COMPILER_SUPPORT */
  928.  
  929. /* Constant/Pure space utilities */
  930.  
  931. static SCHEME_OBJECT *
  932. DEFUN (find_constant_top, (constant_space, count),
  933.        SCHEME_OBJECT * constant_space AND unsigned long count)
  934. {
  935.   SCHEME_OBJECT pattern = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0));
  936.   SCHEME_OBJECT * limit = (constant_space + count);
  937.  
  938.   while (((* (limit - 1)) == pattern)
  939.      && (limit > constant_space))
  940.     limit -= 1;
  941.   return (limit);
  942. }
  943.  
  944. static Boolean
  945. DEFUN (address_in_pure_space, (addr), SCHEME_OBJECT * addr)
  946. {
  947.   Boolean result = false;
  948.   SCHEME_OBJECT * where, * low_constant;
  949.  
  950.   low_constant = Constant_Space;
  951.   where = (Constant_Top - 1);
  952.  
  953.   while (where >= low_constant)
  954.   {
  955.     where -= (1 + (OBJECT_DATUM (* where)));
  956.     if (where < addr)
  957.     {
  958.       where += 1;        /* block start */
  959.       result = (addr <= (where + (OBJECT_DATUM (* where))));
  960.       break;
  961.     }
  962.   }
  963.   return (result);
  964. }
  965.  
  966. /* Common Pointer Code */
  967.  
  968. #define DO_POINTER(Scn, Action) do                    \
  969. {                                    \
  970.   long the_datum;                            \
  971.                                     \
  972.   Old_Address = (OBJECT_ADDRESS (This));                \
  973.   the_datum = (OBJECT_DATUM (This));                    \
  974.   if ((the_datum >= Heap_Base) && (the_datum < Dumped_Heap_Top))    \
  975.     Action (HEAP_CODE, Heap_Relocation, Free,                \
  976.         Scn, Objects, Free_Objects);                \
  977.   else if ((the_datum >= Const_Base)                    \
  978.        && (the_datum < Dumped_Constant_Top))            \
  979.   {                                    \
  980.     SCHEME_OBJECT * new_addr;                        \
  981.                                     \
  982.     new_addr = (Old_Address + Constant_Relocation);            \
  983.     if (address_in_pure_space (new_addr))                \
  984.       Action (PURE_CODE, Constant_Relocation, Free_Pure,        \
  985.           Scn, Pure_Objects, Free_Pobjects);            \
  986.     else                                \
  987.       Action (CONSTANT_CODE, Constant_Relocation, Free_Constant,    \
  988.           Scn, Constant_Objects, Free_Cobjects);            \
  989.   }                                    \
  990.   else                                    \
  991.     out_of_range_pointer (This);                    \
  992.   (Scn) += 1;                                \
  993. } while (0)
  994.  
  995. #define DO_RAW_POINTER(ptr, Scn, Action) do                \
  996. {                                    \
  997.   long the_datum;                            \
  998.                                     \
  999.   the_datum = (SCHEME_ADDR_TO_OLD_DATUM (ptr));                \
  1000.   Old_Address = (DATUM_TO_ADDRESS (the_datum));                \
  1001.   if ((the_datum >= Heap_Base) && (the_datum < Dumped_Heap_Top))    \
  1002.     Action (HEAP_CODE, Heap_Relocation, Free,                \
  1003.         Scn, Objects, Free_Objects);                \
  1004.   else if ((the_datum >= Const_Base)                    \
  1005.        && (the_datum < Dumped_Constant_Top))            \
  1006.   {                                    \
  1007.     SCHEME_OBJECT * new_addr;                        \
  1008.                                     \
  1009.     new_addr = (Old_Address + Constant_Relocation);            \
  1010.     if (address_in_pure_space (new_addr))                \
  1011.       Action (PURE_CODE, Constant_Relocation, Free_Pure,        \
  1012.           Scn, Pure_Objects, Free_Pobjects);            \
  1013.     else                                \
  1014.       Action (CONSTANT_CODE, Constant_Relocation, Free_Constant,    \
  1015.           Scn, Constant_Objects, Free_Cobjects);            \
  1016.   }                                    \
  1017.   else                                    \
  1018.     out_of_range_pointer (This);                    \
  1019. } while (0)
  1020.  
  1021. static void
  1022. DEFUN (out_of_range_pointer, (ptr), SCHEME_OBJECT ptr)
  1023. {
  1024.   fprintf (stderr,
  1025.        "%s: The input file is not portable: Out of range pointer.\n",
  1026.        program_name);
  1027.   fprintf (stderr, "Heap_Base =  0x%lx;\tHeap_Top = 0x%lx\n",
  1028.        Heap_Base, Dumped_Heap_Top);
  1029.   fprintf (stderr, "Const_Base = 0x%lx;\tConst_Top = 0x%lx\n",
  1030.        Const_Base, Dumped_Constant_Top);
  1031.   fprintf (stderr, "ptr = 0x%02x|0x%lx\n",
  1032.        (OBJECT_TYPE (ptr)), (OBJECT_DATUM (ptr)));
  1033.   quit (1);
  1034. }
  1035.  
  1036. static SCHEME_OBJECT *
  1037. DEFUN (relocate, (object), SCHEME_OBJECT object)
  1038. {
  1039.   long the_datum;
  1040.   SCHEME_OBJECT * result;
  1041.  
  1042.   result = (OBJECT_ADDRESS (object));
  1043.   the_datum = (OBJECT_DATUM (object));
  1044.  
  1045.   if ((the_datum >= Heap_Base) &&
  1046.       (the_datum < Dumped_Heap_Top))
  1047.     result += Heap_Relocation;
  1048.   else if ((the_datum >= Const_Base) &&
  1049.        (the_datum < Dumped_Constant_Top))
  1050.       result += Constant_Relocation;
  1051.   else
  1052.     out_of_range_pointer (object);
  1053.   return (result);
  1054. }
  1055.  
  1056. /* Primitive upgrading code. */
  1057.  
  1058. #define PRIMITIVE_UPGRADE_SPACE 2048
  1059.  
  1060. static SCHEME_OBJECT
  1061.   * internal_renumber_table,
  1062.   * external_renumber_table,
  1063.   * external_prim_name_table;
  1064.  
  1065. static Boolean
  1066.   found_ext_prims = false;
  1067.  
  1068. static SCHEME_OBJECT
  1069. DEFUN (upgrade_primitive, (prim), SCHEME_OBJECT prim)
  1070. {
  1071.   long the_datum, the_type, new_type, code;
  1072.   SCHEME_OBJECT new;
  1073.  
  1074.   the_datum = (OBJECT_DATUM (prim));
  1075.   the_type = (OBJECT_TYPE (prim));
  1076.   if (the_type != TC_PRIMITIVE_EXTERNAL)
  1077.   {
  1078.     code = the_datum;
  1079.     new_type = the_type;
  1080.   }
  1081.   else
  1082.   {
  1083.     found_ext_prims = true;
  1084.     code = (the_datum + (MAX_BUILTIN_PRIMITIVE + 1));
  1085.     new_type = TC_PRIMITIVE;
  1086.   }
  1087.  
  1088.   new = internal_renumber_table[code];
  1089.   if (new != SHARP_F)
  1090.     return (OBJECT_NEW_TYPE (new_type, new));
  1091.   else
  1092.   {
  1093.     /*
  1094.       This does not need to check for overflow because the worst case
  1095.       was checked in setup_primitive_upgrade;
  1096.      */
  1097.  
  1098.     new = (MAKE_OBJECT (new_type, Primitive_Table_Length));
  1099.     internal_renumber_table[code] = new;
  1100.     external_renumber_table[Primitive_Table_Length] = prim;
  1101.     Primitive_Table_Length += 1;
  1102.     if (the_type == TC_PRIMITIVE_EXTERNAL)
  1103.       NPChars +=
  1104.     STRING_LENGTH_TO_LONG ((((SCHEME_OBJECT *)
  1105.                  (external_prim_name_table[the_datum]))
  1106.                 [STRING_LENGTH_INDEX]));
  1107.     else
  1108.       NPChars += strlen (builtin_prim_name_table[the_datum]);
  1109.     return (new);
  1110.   }
  1111. }
  1112.  
  1113. static SCHEME_OBJECT *
  1114. DEFUN (setup_primitive_upgrade, (Heap), SCHEME_OBJECT * Heap)
  1115. {
  1116.   fast long count, length;
  1117.   SCHEME_OBJECT * old_prims_vector;
  1118.  
  1119.   internal_renumber_table = &Heap[0];
  1120.   external_renumber_table =
  1121.     &internal_renumber_table[PRIMITIVE_UPGRADE_SPACE];
  1122.   external_prim_name_table =
  1123.     &external_renumber_table[PRIMITIVE_UPGRADE_SPACE];
  1124.  
  1125.   old_prims_vector = (relocate (Ext_Prim_Vector));
  1126.   if (*old_prims_vector == SHARP_F)
  1127.     length = 0;
  1128.   else
  1129.   {
  1130.     old_prims_vector = (relocate (*old_prims_vector));
  1131.     length = (OBJECT_DATUM (*old_prims_vector));
  1132.     old_prims_vector += VECTOR_DATA;
  1133.     for (count = 0; count < length; count += 1)
  1134.     {
  1135.       SCHEME_OBJECT *temp;
  1136.  
  1137.       /* symbol */
  1138.       temp = (relocate (old_prims_vector[count]));
  1139.       /* string */
  1140.       temp = (relocate (temp[SYMBOL_NAME]));
  1141.       external_prim_name_table[count] = ((SCHEME_OBJECT) temp);
  1142.     }
  1143.   }
  1144.   length += (MAX_BUILTIN_PRIMITIVE + 1);
  1145.   if (length > PRIMITIVE_UPGRADE_SPACE)
  1146.   {
  1147.     fprintf (stderr, "%s: Too many primitives.\n", program_name);
  1148.     fprintf (stderr,
  1149.          "Increase PRIMITIVE_UPGRADE_SPACE and recompile %s.\n",
  1150.          program_name);
  1151.     quit (1);
  1152.   }
  1153.   for (count = 0; count < length; count += 1)
  1154.     internal_renumber_table[count] = SHARP_F;
  1155.  
  1156.   NPChars = 0;
  1157.   return (&external_prim_name_table[PRIMITIVE_UPGRADE_SPACE]);
  1158. }
  1159.  
  1160. /* Processing of a single area */
  1161.  
  1162. #define DO_AREA(code, Area, Bound, Obj, FObj)                \
  1163.   Process_Area (code, &Area, &Bound, &Obj, &FObj)
  1164.  
  1165. static void
  1166. DEFUN (Process_Area, (Code, Area, Bound, Obj, FObj),
  1167.        int Code
  1168.        AND fast long * Area
  1169.        AND fast long * Bound
  1170.        AND fast long * Obj
  1171.        AND fast SCHEME_OBJECT ** FObj)
  1172. {
  1173.   unsigned long entry_no;
  1174.   fast SCHEME_OBJECT This, * Old_Address, Old_Contents;
  1175.  
  1176.   while (*Area != *Bound)
  1177.   {
  1178.     This = Mem_Base[*Area];
  1179.  
  1180. #ifdef PRIMITIVE_EXTERNAL_REUSED
  1181.     if (upgrade_primitives_p &&
  1182.     ((OBJECT_TYPE (This)) == TC_PRIMITIVE_EXTERNAL))
  1183.     {
  1184.       Mem_Base[*Area] = (upgrade_primitive (This));
  1185.       *Area += 1;
  1186.       continue;
  1187.     }
  1188. #endif /* PRIMITIVE_EXTERNAL_REUSED */
  1189.  
  1190.     Switch_by_GC_Type (This)
  1191.     {
  1192.  
  1193. #ifndef PRIMITIVE_EXTERNAL_REUSED
  1194.  
  1195.       case TC_PRIMITIVE_EXTERNAL:
  1196.  
  1197. #endif /* PRIMITIVE_EXTERNAL_REUSED */
  1198.  
  1199.       case TC_PRIMITIVE:
  1200.       case TC_PCOMB0:
  1201.     if (upgrade_primitives_p)
  1202.       Mem_Base[*Area] = (upgrade_primitive (This));
  1203.     *Area += 1;
  1204.     break;
  1205.  
  1206.       case TC_MANIFEST_NM_VECTOR:
  1207.     nmv_p = true;
  1208.         if (null_nmv_p)
  1209.     {
  1210.       fast long i;
  1211.  
  1212.       i = (OBJECT_DATUM (This));
  1213.       *Area += 1;
  1214.       for ( ; --i >= 0; *Area += 1)
  1215.         Mem_Base[*Area] = SHARP_F;
  1216.       break;
  1217.     }
  1218.     else if (!allow_nmv_p)
  1219.     {
  1220.       if (((OBJECT_DATUM (This)) != 0) && warn_portable_p)
  1221.       {
  1222.         warn_portable_p = false;
  1223.         fprintf (stderr, "%s: File is not portable: NMH found\n",
  1224.              program_name);
  1225.       }
  1226.     }
  1227.     *Area += (1 + (OBJECT_DATUM (This)));
  1228.     break;
  1229.  
  1230.       case TC_BROKEN_HEART:
  1231.       {
  1232.     /* [Broken Heart | 0] is the cdr of fasdumped symbols. */
  1233.     /* [Broken Heart | x > 0] indicates a C compiled block. */
  1234.     unsigned long the_datum = (OBJECT_DATUM (This));
  1235.  
  1236.     if (the_datum == 0)
  1237.     {
  1238.       *Area += 1;
  1239.       break;
  1240.     }
  1241.     else if ((! allow_compiled_p)
  1242.          || (! c_compiled_p)
  1243.          || ((OBJECT_DATUM (This))
  1244.              >= (compiled_block_pointer - compiled_block_table))
  1245.          || ((*Area)
  1246.              != (UNSIGNED_FIXNUM_TO_LONG
  1247.              (compiled_block_table [the_datum]))))
  1248.     {
  1249.       fprintf (stderr, "%s: Broken Heart found in scan.\n",
  1250.            program_name);
  1251.       quit (1);
  1252.     }
  1253.     else
  1254.     {
  1255.       *Area += (1 + (OBJECT_DATUM (compiled_block_table [1 + the_datum])));
  1256.       break;
  1257.     }
  1258.       }
  1259.  
  1260.       case TC_MANIFEST_CLOSURE:
  1261.     if ((! allow_compiled_p) || (! c_compiled_p))
  1262.     {
  1263.       fprintf (stderr,
  1264.            "%s: File contains compiled closures.\n",
  1265.            program_name);
  1266.       quit (1);
  1267.     }
  1268.     else
  1269.     {
  1270.       char * word_ptr;
  1271.       long count, address = 0;
  1272.       SCHEME_OBJECT * area_end, * scan, * i_scan;
  1273.  
  1274.       i_scan = (&Mem_Base[*Area]);
  1275.       START_CLOSURE_RELOCATION (i_scan);
  1276.       scan = (i_scan + 1);
  1277.       count = (MANIFEST_CLOSURE_COUNT (scan));
  1278.       word_ptr = (FIRST_MANIFEST_CLOSURE_ENTRY (scan));
  1279.       area_end = (MANIFEST_CLOSURE_END (scan, count));
  1280.  
  1281.       while ((--count) >= 0)
  1282.       {
  1283.         scan = ((SCHEME_OBJECT *) (word_ptr));
  1284.         word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr));
  1285.         EXTRACT_CLOSURE_ENTRY_ADDRESS (address, scan);
  1286.         DO_RAW_POINTER (address, *Area, DO_C_COMPILED_ENTRY);
  1287.         STORE_CLOSURE_ENTRY_ADDRESS (entry_no, scan);
  1288.       }
  1289.  
  1290.       END_CLOSURE_RELOCATION (area_end);
  1291.       *Area += (1 + (area_end - i_scan));
  1292.       break;
  1293.     }
  1294.  
  1295.       case TC_LINKAGE_SECTION:
  1296.     if ((! allow_compiled_p) || (! c_compiled_p))
  1297.     {
  1298.       fprintf (stderr,
  1299.            "%s: File contains linked compiled code.\n",
  1300.            program_name);
  1301.       quit (1);
  1302.     }
  1303.     else
  1304.     {
  1305.       switch (READ_LINKAGE_KIND (This))
  1306.       {
  1307.         case REFERENCE_LINKAGE_KIND:
  1308.         case ASSIGNMENT_LINKAGE_KIND:
  1309.         {
  1310.           long count = (READ_CACHE_LINKAGE_COUNT (This));
  1311.  
  1312.           *Area += 1;
  1313.           while (--count >= 0)
  1314.           {
  1315.         DO_RAW_POINTER (Mem_Base[*Area], *Area, DO_RAW_QUAD);
  1316.         *Area += 1;
  1317.           }
  1318.           break;
  1319.         }
  1320.         
  1321.         case OPERATOR_LINKAGE_KIND:
  1322.         case GLOBAL_OPERATOR_LINKAGE_KIND:
  1323.         {
  1324.           char * word_ptr;
  1325.           long count, address = 0;
  1326.           SCHEME_OBJECT * area_end, * scan, * i_scan;
  1327.  
  1328.           i_scan = (&Mem_Base[*Area]);
  1329.           START_OPERATOR_RELOCATION (i_scan);
  1330.           count = (READ_OPERATOR_LINKAGE_COUNT (This));
  1331.           word_ptr = (FIRST_OPERATOR_LINKAGE_ENTRY (i_scan));
  1332.           area_end = (END_OPERATOR_LINKAGE_AREA (i_scan, count));
  1333.  
  1334.           while (--count >= 0)
  1335.           {
  1336.         scan = ((SCHEME_OBJECT *) word_ptr);
  1337.         word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr));
  1338.         EXTRACT_OPERATOR_LINKAGE_ADDRESS (address, scan);
  1339.         DO_RAW_POINTER (address, *Area, DO_C_COMPILED_ENTRY);
  1340.         STORE_OPERATOR_LINKAGE_ADDRESS (entry_no, scan);
  1341.           }
  1342.           END_OPERATOR_RELOCATION (area_end);
  1343.           *Area += (1 + (area_end - i_scan));
  1344.           break;
  1345.         }
  1346.  
  1347.         default:
  1348.         {
  1349.           fprintf (stderr, "%s: Unknown linkage kind.\n",
  1350.                program_name);
  1351.           quit (1);
  1352.         }
  1353.       }
  1354.       break;
  1355.     }
  1356.  
  1357.       case TC_COMPILED_CODE_BLOCK:
  1358.     compiled_p = true;
  1359.     if (! allow_compiled_p)
  1360.     {
  1361.       fprintf (stderr,
  1362.            "%s: File contains compiled code.\n",
  1363.            program_name);
  1364.       quit (1);
  1365.     }
  1366.     else if (c_compiled_p)
  1367.       DO_POINTER (*Area, DO_C_COMPILED_BLOCK);
  1368.     else if (endian_invert_p)
  1369.       DO_POINTER (*Area, DO_INVERTED_COMPILED_BLOCK);
  1370.     else
  1371.       DO_POINTER (*Area, DO_COMPILED_BLOCK);
  1372.     break;
  1373.  
  1374.       case_compiled_entry_point:
  1375.     compiled_p = true;
  1376.     if (! allow_compiled_p)
  1377.     {
  1378.       fprintf (stderr,
  1379.            "%s: File contains compiled code.\n",
  1380.            program_name);
  1381.       quit (1);
  1382.     }
  1383.     else if (c_compiled_p)
  1384.       DO_POINTER (*Area, DO_C_COMPILED_ENTRY);
  1385.     else
  1386.       DO_POINTER (*Area, DO_COMPILED_ENTRY);
  1387.     Mem_Base[*Area - 1] = (MAKE_OBJECT (TC_COMPILED_ENTRY, entry_no));
  1388.     break;
  1389.  
  1390.       case TC_STACK_ENVIRONMENT:
  1391.     if (! allow_bands_p)
  1392.     {
  1393.       fprintf (stderr,
  1394.            "%s: File contains stack environments.\n",
  1395.            program_name);
  1396.       quit (1);
  1397.     }
  1398.     else
  1399.     {
  1400.       unsigned long delta;
  1401.  
  1402.       delta = (((SCHEME_OBJECT *) Dumped_Stack_Top)
  1403.            - ((SCHEME_OBJECT *) (OBJECT_DATUM (This))));
  1404.       if (delta > Max_Stack_Offset)
  1405.         Max_Stack_Offset = delta;
  1406.       Mem_Base[*Area] = (MAKE_OBJECT (TC_STACK_ENVIRONMENT, delta));
  1407.       *Area += 1;
  1408.     }
  1409.     break;
  1410.  
  1411.       case TC_FIXNUM:
  1412.     NIntegers += 1;
  1413.     NBits += fixnum_to_bits;
  1414.     /* Fall Through */
  1415.  
  1416.       case TC_CHARACTER:
  1417.         Mem_Base[*Area] = (MAKE_OBJECT (Code, *Obj));
  1418.         *Obj += 1;
  1419.         **FObj = This;
  1420.         *FObj += 1;
  1421.     /* Fall through */
  1422.  
  1423.       case TC_MANIFEST_SPECIAL_NM_VECTOR:
  1424.       case_simple_Non_Pointer:
  1425.     *Area += 1;
  1426.     break;
  1427.  
  1428.       case TC_REFERENCE_TRAP:
  1429.       {
  1430.     long kind;
  1431.  
  1432.     kind = (OBJECT_DATUM (This));
  1433.  
  1434.     if (upgrade_traps_p)
  1435.     {
  1436.       /* It is an old UNASSIGNED object. */
  1437.       if (kind == 0)
  1438.       {
  1439.         Mem_Base[*Area] = UNASSIGNED_OBJECT;
  1440.         *Area += 1;
  1441.         break;
  1442.       }
  1443.       if (kind == 1)
  1444.       {
  1445.         Mem_Base[*Area] = UNBOUND_OBJECT;
  1446.         *Area += 1;
  1447.         break;
  1448.       }
  1449.       fprintf (stderr,
  1450.            "%s: Bad old unassigned object. 0x%x.\n",
  1451.            program_name, This);
  1452.       quit (1);
  1453.     }
  1454.     if (kind <= TRAP_MAX_IMMEDIATE)
  1455.     {
  1456.       /* It is a non pointer. */
  1457.  
  1458.       *Area += 1;
  1459.       break;
  1460.     }
  1461.       }
  1462.       /* Fall through */
  1463.  
  1464.       case TC_WEAK_CONS:
  1465.       case_Pair:
  1466.     DO_POINTER (*Area, DO_PAIR);
  1467.     break;
  1468.  
  1469.       case_Cell:
  1470.     DO_POINTER (*Area, DO_CELL);
  1471.     break;
  1472.  
  1473.       case TC_VARIABLE:
  1474.       case_Triple:
  1475.     DO_POINTER (*Area, DO_TRIPLE);
  1476.     break;
  1477.  
  1478.       case_Quadruple:
  1479.     DO_POINTER (*Area, DO_QUAD);
  1480.     break;
  1481.  
  1482.       case TC_BIG_FLONUM:
  1483.     DO_POINTER (*Area, DO_FLONUM);
  1484.     break;
  1485.  
  1486.       case TC_BIG_FIXNUM:
  1487.     DO_POINTER (*Area, DO_BIGNUM);
  1488.     break;
  1489.  
  1490.       case TC_CHARACTER_STRING:
  1491.     DO_POINTER (*Area, DO_STRING);
  1492.     break;
  1493.  
  1494.       case TC_ENVIRONMENT:
  1495.     if (upgrade_traps_p)
  1496.     {
  1497.       fprintf (stderr,
  1498.            "%s: Cannot upgrade environments.\n",
  1499.            program_name);
  1500.       quit (1);
  1501.     }
  1502.     /* Fall through */
  1503.  
  1504.       case TC_FUTURE:
  1505.       case_simple_Vector:
  1506.     if (BIT_STRING_P (This))
  1507.       DO_POINTER (*Area, DO_BIT_STRING);
  1508.     else
  1509.       DO_POINTER (*Area, DO_VECTOR);
  1510.     break;
  1511.  
  1512.       default:
  1513.     fprintf (stderr, "%s: Unknown Type Code 0x%x found.\n",
  1514.          program_name, (OBJECT_TYPE (This)));
  1515.     quit (1);
  1516.       }
  1517.   }
  1518. }
  1519.  
  1520. /* Output procedures */
  1521.  
  1522. static void
  1523. DEFUN (print_binary_objects, (from, count),
  1524.        fast SCHEME_OBJECT * from AND fast long count)
  1525. {
  1526.   while (--count >= 0)
  1527.   {
  1528.     switch (OBJECT_TYPE (* from))
  1529.     {
  1530.       case TC_FIXNUM:
  1531.     print_a_fixnum (FIXNUM_TO_LONG (*from));
  1532.     from += 1;
  1533.     break;
  1534.  
  1535.       case TC_BIT_STRING:
  1536.     print_a_bit_string (++from);
  1537.     from += (1 + (OBJECT_DATUM (*from)));
  1538.     break;
  1539.  
  1540.       case TC_BIG_FIXNUM:
  1541.     print_a_bignum (++from);
  1542.     from += (1 + (OBJECT_DATUM (*from)));
  1543.     break;
  1544.  
  1545.       case TC_CHARACTER_STRING:
  1546.     print_a_string (++from);
  1547.     from += (1 + (OBJECT_DATUM (*from)));
  1548.     break;
  1549.  
  1550.       case TC_BIG_FLONUM:
  1551.     print_a_flonum (from + 1);
  1552.     from += (1 + float_to_pointer);
  1553.     break;
  1554.  
  1555.       case TC_CHARACTER:
  1556.     fprintf (portable_file, "%02x %03x\n",
  1557.          TC_CHARACTER, ((*from) & MASK_MIT_ASCII));
  1558.     from += 1;
  1559.     break;
  1560.  
  1561. #ifdef FLOATING_ALIGNMENT
  1562.  
  1563.       case TC_MANIFEST_NM_VECTOR:
  1564.         if ((OBJECT_DATUM (*from)) == 0)
  1565.     {
  1566.       from += 1;
  1567.       count += 1;
  1568.       break;
  1569.     }
  1570.         /* fall through */
  1571.  
  1572. #endif /* FLOATING_ALIGNMENT */
  1573.  
  1574.       default:
  1575.     fprintf (stderr,
  1576.          "%s: Bad Binary Object to print %lx\n",
  1577.          program_name, *from);
  1578.     quit (1);
  1579.     }
  1580.   }
  1581.   return;
  1582. }
  1583.  
  1584. static void
  1585. DEFUN (print_c_compiled_entries, (entry, count),
  1586.        SCHEME_OBJECT * entry AND unsigned long count)
  1587. {
  1588.   while (count > 0)
  1589.   {
  1590.     unsigned long entry_index = (* ((unsigned long *) entry));
  1591.     unsigned long format = (COMPILED_ENTRY_FORMAT_WORD (entry));
  1592.     SCHEME_OBJECT * block;
  1593.  
  1594.     Get_Compiled_Block (block, entry);
  1595.     fprintf (portable_file, "%02x %lx %ld %ld %lx\n",
  1596.          TC_C_COMPILED_TAG,
  1597.          ((long) C_COMPILED_ENTRY_FORMAT),
  1598.          ((long) (FORMAT_WORD_LOW_BYTE (format))),
  1599.          ((long) (FORMAT_WORD_HIGH_BYTE (format))),
  1600.          ((long) (entry - block)));
  1601.     fprintf (portable_file, "%02x %lx %lx\n",
  1602.          TC_C_COMPILED_TAG,
  1603.          ((long) C_COMPILED_ENTRY_CODE),
  1604.          entry_index);
  1605.     count -= 1;
  1606.     entry += 2;
  1607.   }
  1608.   return;
  1609. }
  1610.  
  1611. static void
  1612. DEFUN (print_c_closure_entries, (entry, count),
  1613.        SCHEME_OBJECT * entry AND unsigned long count)
  1614. {
  1615.   while (count > 0)
  1616.   {
  1617.     unsigned long entry_index = (* ((unsigned long *) entry));
  1618.     unsigned long format = (COMPILED_ENTRY_FORMAT_WORD (entry));
  1619.     SCHEME_OBJECT * block, base;
  1620.     unsigned long entry_number = 0;
  1621.     long offset;
  1622.  
  1623.     EXTRACT_CLOSURE_ENTRY_ADDRESS (entry_number, entry);
  1624.     offset = (UNSIGNED_FIXNUM_TO_LONG
  1625.           (compiled_entry_table [entry_number]));
  1626.     base = compiled_entry_table[entry_number + 1];
  1627.  
  1628.     Get_Compiled_Block (block, entry);
  1629.     fprintf (portable_file, "%02x %lx %ld %ld %lx\n",
  1630.          TC_C_COMPILED_TAG,
  1631.          ((long) C_COMPILED_ENTRY_FORMAT),
  1632.          ((long) (FORMAT_WORD_LOW_BYTE (format))),
  1633.          ((long) (FORMAT_WORD_HIGH_BYTE (format))),
  1634.          ((long) (entry - block)));
  1635.     fprintf (portable_file, "%02x %lx %lx\n",
  1636.          TC_C_COMPILED_TAG,
  1637.          ((long) C_COMPILED_ENTRY_CODE),
  1638.          entry_index);
  1639.     fprintf (portable_file, "%02x %lx %lx %lx\n",
  1640.          TC_C_COMPILED_TAG,
  1641.          ((long) C_COMPILED_EXECUTE_ENTRY),
  1642.          offset,
  1643.          (OBJECT_DATUM (base)));
  1644.     count -= 1;
  1645.     entry += 3;
  1646.   }
  1647.   return;
  1648. }
  1649.  
  1650. static void
  1651. DEFUN (print_objects, (from, to),
  1652.        fast SCHEME_OBJECT * from AND fast SCHEME_OBJECT * to)
  1653. {
  1654.   fast long the_datum, the_type;
  1655.  
  1656.   while (from < to)
  1657.   {
  1658.     the_type = (OBJECT_TYPE (* from));
  1659.     the_datum = (OBJECT_DATUM (* from));
  1660.     from += 1;
  1661.  
  1662.     switch (the_type)
  1663.     {
  1664.       case TC_MANIFEST_NM_VECTOR:
  1665.       {
  1666.     fprintf (portable_file, "%02x %lx\n", the_type, the_datum);
  1667.     while (--the_datum >= 0)
  1668.       fprintf (portable_file, "%lx\n", ((unsigned long) *from++));
  1669.     break;
  1670.       }
  1671.  
  1672.       case TC_COMPILED_ENTRY:
  1673.       {
  1674.     SCHEME_OBJECT base;
  1675.     long offset;
  1676.  
  1677.     offset = (UNSIGNED_FIXNUM_TO_LONG (compiled_entry_table [the_datum]));
  1678.     base = compiled_entry_table[the_datum + 1];
  1679.  
  1680.     fprintf (portable_file, "%02x %lx %02x %lx\n",
  1681.          TC_COMPILED_ENTRY, offset,
  1682.          (OBJECT_TYPE (base)), (OBJECT_DATUM (base)));
  1683.     break;
  1684.       }
  1685.  
  1686.       case TC_LINKAGE_SECTION:
  1687.       {
  1688.     SCHEME_OBJECT header = (from[-1]);
  1689.  
  1690.     switch (READ_LINKAGE_KIND (header))
  1691.     {
  1692.       case REFERENCE_LINKAGE_KIND:
  1693.       case ASSIGNMENT_LINKAGE_KIND:
  1694.       {
  1695.         long count = (READ_CACHE_LINKAGE_COUNT (header));
  1696.  
  1697.         fprintf (portable_file, "%02x %lx %lx %lx\n",
  1698.              TC_C_COMPILED_TAG,
  1699.              ((long) C_COMPILED_LINKAGE_HEADER),
  1700.              ((long) (READ_LINKAGE_KIND (header))),
  1701.              ((long) count));
  1702.         while (--count >= 0)
  1703.         {
  1704.           unsigned long the_quad = ((unsigned long) *from++);
  1705.  
  1706.           fprintf (portable_file, "%02x %lx %lx\n",
  1707.                TC_C_COMPILED_TAG,
  1708.                ((long) C_COMPILED_RAW_QUAD),
  1709.                the_quad);
  1710.         }
  1711.         break;
  1712.       }
  1713.  
  1714.       case OPERATOR_LINKAGE_KIND:
  1715.       case GLOBAL_OPERATOR_LINKAGE_KIND:
  1716.       {
  1717.         char * word_ptr;
  1718.         long count = 0;
  1719.         SCHEME_OBJECT This, * area_end, * scan, * i_scan;
  1720.  
  1721.         i_scan = (from - 1);
  1722.         This = *i_scan;
  1723.         START_OPERATOR_RELOCATION (i_scan);
  1724.         count = (READ_OPERATOR_LINKAGE_COUNT (This));
  1725.         word_ptr = (FIRST_OPERATOR_LINKAGE_ENTRY (i_scan));
  1726.         area_end = (END_OPERATOR_LINKAGE_AREA (i_scan, count));
  1727.  
  1728.         fprintf (portable_file, "%02x %lx %lx %lx\n",
  1729.              TC_C_COMPILED_TAG,
  1730.              ((long) C_COMPILED_LINKAGE_HEADER),
  1731.              ((long) (READ_LINKAGE_KIND (header))),
  1732.              ((long) count));
  1733.  
  1734.         while (--count >= 0)
  1735.         {
  1736.           SCHEME_OBJECT base;
  1737.           long arity, offset, address = 0;
  1738.  
  1739.           scan = ((SCHEME_OBJECT *) word_ptr);
  1740.           word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr));
  1741.           EXTRACT_OPERATOR_LINKAGE_ADDRESS (address, scan);
  1742.           EXTRACT_EXECUTE_CACHE_ARITY (arity, scan);
  1743.  
  1744.           offset = (UNSIGNED_FIXNUM_TO_LONG
  1745.             (compiled_entry_table[address]));
  1746.           base = compiled_entry_table[address + 1];
  1747.  
  1748.           fprintf (portable_file, "%02x %lx %lx %lx\n",
  1749.                TC_C_COMPILED_TAG,
  1750.                ((long) C_COMPILED_EXECUTE_ENTRY),
  1751.                offset,
  1752.                (OBJECT_DATUM (base)));
  1753.           fprintf (portable_file, "%02x %lx %lx\n",
  1754.                TC_C_COMPILED_TAG,
  1755.                ((long) C_COMPILED_EXECUTE_ARITY),
  1756.                arity);
  1757.         }
  1758.         END_OPERATOR_RELOCATION (area_end);
  1759.         from += (area_end - i_scan);
  1760.         break;
  1761.       }
  1762.  
  1763.       default:
  1764.       {
  1765.         fprintf (stderr, "%s: Unknown linkage kind.\n",
  1766.              program_name);
  1767.         quit (1);
  1768.       }
  1769.     }
  1770.     break;
  1771.       }
  1772.  
  1773.       case TC_MANIFEST_CLOSURE:
  1774.       {
  1775.     unsigned long nentries;
  1776.     SCHEME_OBJECT * entry, * area_end;
  1777.  
  1778.     fprintf (portable_file, "%02x %lx %lx\n",
  1779.          TC_C_COMPILED_TAG,
  1780.          ((long) C_COMPILED_CLOSURE_HEADER),
  1781.          the_datum);
  1782.  
  1783.     nentries = (MANIFEST_CLOSURE_COUNT (from));
  1784.     entry = ((SCHEME_OBJECT *) (FIRST_MANIFEST_CLOSURE_ENTRY (from)));
  1785.     area_end = (MANIFEST_CLOSURE_END (from, nentries));
  1786.     
  1787.     if (entry != (from + 1))
  1788.       fprintf (portable_file, "%02x %lx %lx\n",
  1789.            TC_C_COMPILED_TAG,
  1790.            ((long) C_COMPILED_MULTI_CLOSURE_HEADER),
  1791.            nentries);
  1792.  
  1793.     print_c_closure_entries (entry, nentries);
  1794.     from = (area_end + 1);
  1795.     break;
  1796.       }
  1797.  
  1798.       case TC_BROKEN_HEART:
  1799.       if (the_datum == 0)
  1800.     goto ordinary_object;
  1801.       /* An NMV header fending off C-compiled code descriptors.
  1802.      This knows in detail the format
  1803.        */
  1804.       
  1805.       {
  1806.     unsigned long nmv_length;
  1807.  
  1808.     nmv_length = (OBJECT_DATUM (compiled_block_table [the_datum + 1]));
  1809.     fprintf (portable_file, "%02x %lx %lx\n",
  1810.          TC_C_COMPILED_TAG,
  1811.          ((long) C_COMPILED_FAKE_NMV),
  1812.          nmv_length);
  1813.  
  1814.     print_c_compiled_entries (from + 1, (nmv_length / 2));
  1815.     from += nmv_length;
  1816.     break;
  1817.       }
  1818.  
  1819.       default:
  1820.       ordinary_object:
  1821.       {
  1822.     fprintf (portable_file, "%02x %lx\n", the_type, the_datum);
  1823.     break;
  1824.       }
  1825.     }
  1826.   }
  1827.   return;
  1828. }
  1829.  
  1830. /* Debugging Aids and Consistency Checks */
  1831.  
  1832. #define DEBUG    0
  1833.  
  1834. #if (DEBUG > 0)
  1835.  
  1836. #define WHEN(condition, message)    when(condition, message)
  1837.  
  1838. static void
  1839. DEFUN (when, (what, message), Boolean what AND char * message)
  1840. {
  1841.   if (what)
  1842.   {
  1843.     fprintf (stderr, "%s: Inconsistency: %s!\n",
  1844.          program_name, (message));
  1845.     quit (1);
  1846.   }
  1847.   return;
  1848. }
  1849.  
  1850. #else /* DEBUG <= 0 */
  1851.  
  1852. #define WHEN(what, message) do { } while (0)
  1853.  
  1854. #endif /* DEBUG > 0 */
  1855.  
  1856. #if (DEBUG > 1)
  1857.  
  1858. #define DEBUGGING1(action)        action
  1859.  
  1860. #define WRITE_HEADER(name, format, obj) do                \
  1861. {                                    \
  1862.   fprintf (portable_file, (format), (obj));                \
  1863.   fprintf (portable_file, "\n");                    \
  1864.   fprintf (stderr, "%s: ", (name));                    \
  1865.   fprintf (stderr, (format), (obj));                    \
  1866.   fprintf (stderr, "\n");                        \
  1867. } while (0)
  1868.  
  1869. #else /* DEBUG <= 1 */
  1870.  
  1871. #define DEBUGGING1(action) do { } while (0)
  1872.  
  1873. #define WRITE_HEADER(name, format, obj) do                \
  1874. {                                    \
  1875.   fprintf (portable_file, (format), (obj));                \
  1876.   fprintf (portable_file, "\n");                    \
  1877. } while (0)
  1878.  
  1879. #endif /* DEBUG > 1 */
  1880.  
  1881. /* The main program */
  1882.  
  1883. static void
  1884. DEFUN_VOID (do_it)
  1885. {
  1886.   while (true)
  1887.   {
  1888.     /* Load the Data */
  1889.  
  1890.     SCHEME_OBJECT
  1891.       * Heap,
  1892.       * Lowest_Allocated_Address, 
  1893.       * Highest_Allocated_Address;
  1894.     long
  1895.       Heap_Start, Heap_Objects_Start,
  1896.       Constant_Start, Constant_Objects_Start,
  1897.       Pure_Start, Pure_Objects_Start;      
  1898.  
  1899.     switch (Read_Header ())
  1900.     {
  1901.       /* There should really be a difference between no header
  1902.      and a short header.
  1903.        */
  1904.  
  1905.       case FASL_FILE_TOO_SHORT:
  1906.     return;
  1907.  
  1908.       case FASL_FILE_FINE:
  1909.         break;
  1910.  
  1911.       default:
  1912.         fprintf (stderr,
  1913.          "%s: Input is not a Scheme binary file.\n",
  1914.          program_name);
  1915.     quit (1);
  1916.     /*NOTREACHED*/
  1917.     }
  1918.  
  1919.     if (   (Version > FASL_FORMAT_VERSION)
  1920.     || (Version < FASL_OLDEST_VERSION)
  1921.     || (Sub_Version > FASL_SUBVERSION)
  1922.     || (Sub_Version < FASL_OLDEST_SUBVERSION)
  1923.     || ((Machine_Type != FASL_INTERNAL_FORMAT) && (! swap_bytes_p)))
  1924.     {
  1925.       fprintf (stderr, "%s:\n", program_name);
  1926.       fprintf (stderr,
  1927.            "FASL File Version %ld Subversion %ld Machine Type %ld\n",
  1928.            Version, Sub_Version , Machine_Type);
  1929.       fprintf (stderr,
  1930.            "Expected: Version %d Subversion %d Machine Type %d\n",
  1931.            FASL_READ_VERSION, FASL_READ_SUBVERSION, FASL_INTERNAL_FORMAT);
  1932.       quit (1);
  1933.     }
  1934.  
  1935.     if ((((compiler_processor_type != COMPILER_NONE_TYPE)
  1936.       && (dumped_processor_type != COMPILER_NONE_TYPE)
  1937.       && (compiler_processor_type != dumped_processor_type))
  1938.      || ((compiler_interface_version != 0)
  1939.          && (dumped_interface_version != 0)
  1940.          && (compiler_interface_version != dumped_interface_version)))
  1941.     && (! upgrade_compiled_p))
  1942.     {
  1943.       fprintf (stderr, "\nread_file:\n");
  1944.       fprintf (stderr,
  1945.            "FASL File: compiled code interface %4d; processor %4d.\n",
  1946.            dumped_interface_version, dumped_processor_type);
  1947.       fprintf (stderr,
  1948.            "Expected:  compiled code interface %4d; processor %4d.\n",
  1949.            compiler_interface_version, compiler_processor_type);
  1950.       quit (1);
  1951.     }
  1952.     if (compiler_processor_type != 0)
  1953.       dumped_processor_type = compiler_processor_type;
  1954.     if (compiler_interface_version != 0)
  1955.       dumped_interface_version = compiler_interface_version;
  1956.     c_compiled_p = (compiler_processor_type == COMPILER_LOSING_C_TYPE);
  1957.     DEBUGGING1 (fprintf (stderr,
  1958.              "compiler_processor_type = %d; c_compiled_p = %s\n",
  1959.              compiler_processor_type,
  1960.              (c_compiled_p ? "true" : "false")));
  1961.  
  1962.     if (band_p && (! allow_bands_p))
  1963.     {
  1964.       fprintf (stderr, "%s: Input file is a band.\n", program_name);
  1965.       quit (1);
  1966.     }
  1967.  
  1968.     if ((Const_Count != 0) && (! allow_constant_space_p))
  1969.     {
  1970.       fprintf (stderr,
  1971.            "%s: Input file has a constant space area.\n",
  1972.            program_name);
  1973.       quit (1);
  1974.     }
  1975.  
  1976.     shuffle_bytes_p = swap_bytes_p;
  1977.     if (Machine_Type == FASL_INTERNAL_FORMAT)
  1978.       shuffle_bytes_p = false;
  1979.  
  1980.     upgrade_traps_p = (Sub_Version < FASL_REFERENCE_TRAP);
  1981.     upgrade_primitives_p = (Sub_Version < FASL_MERGED_PRIMITIVES);
  1982.     upgrade_lengths_p = upgrade_primitives_p;
  1983.  
  1984.     DEBUGGING1 (fprintf (stderr,
  1985.              "Dumped Heap Base = 0x%08x\n",
  1986.              Heap_Base));
  1987.  
  1988.     DEBUGGING1 (fprintf (stderr,
  1989.              "Dumped Constant Base = 0x%08x\n",
  1990.              Const_Base));
  1991.  
  1992.     DEBUGGING1 (fprintf (stderr,
  1993.              "Dumped Constant Top = 0x%08x\n",
  1994.              Dumped_Constant_Top));
  1995.  
  1996.     DEBUGGING1 (fprintf (stderr,
  1997.              "Heap Count = %6d\n",
  1998.              Heap_Count));
  1999.  
  2000.     DEBUGGING1 (fprintf (stderr,
  2001.              "Constant Count = %6d\n",
  2002.              Const_Count));
  2003.  
  2004.     {
  2005.       long Size;
  2006.  
  2007.       /* This is way larger than needed, but... what the hell? */
  2008.  
  2009.       Size = (
  2010.           /* All pointers must have datum > TRAP_MAX_IMMEDIATE */
  2011.             (2 * (TRAP_MAX_IMMEDIATE + 1))
  2012.           /* Floating alignment of Heap and Constant Space
  2013.          in incoming image, and of output arenas.
  2014.            */
  2015.           + (5 * ((FLOATING_ALIGNMENT + 1) / (sizeof (SCHEME_OBJECT))))
  2016.           /* Space taken by incoming image. */
  2017.           + (Heap_Count + Const_Count)
  2018.           /* We don't know the partition of the outgoing image,
  2019.          so, make each of the areas large enough:
  2020.          Heap pointers and external heap objects,
  2021.          Constant pointers and external constant objects,
  2022.          Pure pointers and exteranl pure objects
  2023.            */
  2024.           + (2 * (Heap_Count + (2 * Const_Count)))
  2025.           /* Space for the roots */
  2026.           + (NROOTS + 1)
  2027.           /* Space for the primitive table, or space to upgrade */
  2028.           + (upgrade_primitives_p
  2029.          ? (3 * PRIMITIVE_UPGRADE_SPACE)
  2030.          : Primitive_Table_Size)
  2031.           /* Everything might be compiled code blocks, requiring
  2032.          extra tables to map entries to objects, and block alignment
  2033.            */
  2034.           + (allow_compiled_p
  2035.          ? (2 + ((c_compiled_p ? 5 : 3) * (Heap_Count + Const_Count)))
  2036.          : 0)
  2037.           /* C code IDs */
  2038.           + C_Code_Table_Size);
  2039.  
  2040.       ALLOCATE_HEAP_SPACE (Size,
  2041.                Lowest_Allocated_Address,
  2042.                Highest_Allocated_Address);
  2043.  
  2044.       if (Lowest_Allocated_Address == ((SCHEME_OBJECT *) NULL))
  2045.       {
  2046.     fprintf (stderr,
  2047.          "%s: Memory Allocation Failed.  Size = %ld Scheme Objects\n",
  2048.          program_name, Size);
  2049.     quit (1);
  2050.       }
  2051.     }
  2052.  
  2053.     Heap = (Lowest_Allocated_Address + (TRAP_MAX_IMMEDIATE + 1));
  2054.     ALIGN_FLOAT (Heap);
  2055.     if ((Load_Data (Heap_Count, Heap)) != Heap_Count)
  2056.     {
  2057.       fprintf (stderr, "%s: Could not load the heap's contents.\n",
  2058.            program_name);
  2059.       quit (1);
  2060.     }
  2061.     Constant_Space = (Heap + Heap_Count);
  2062.     ALIGN_FLOAT (Constant_Space);
  2063.     if ((Load_Data (Const_Count, Constant_Space)) != Const_Count)
  2064.     {
  2065.       fprintf (stderr, "%s: Could not load constant space.\n",
  2066.            program_name);
  2067.       quit (1);
  2068.     }
  2069.     Constant_Top = (find_constant_top (Constant_Space,  Const_Count));
  2070.     Heap_Relocation = ((&Heap[0]) - (OBJECT_ADDRESS (Heap_Base)));
  2071.     Constant_Relocation = ((&Constant_Space[0]) -
  2072.                (OBJECT_ADDRESS (Const_Base)));
  2073.     Max_Stack_Offset = 0;
  2074.  
  2075.     /* Setup compiled code and primitive tables. */
  2076.  
  2077.     compiled_entry_table = &Constant_Space[Const_Count];
  2078.     compiled_entry_pointer = compiled_entry_table;
  2079.     compiled_entry_table_end = compiled_entry_pointer;
  2080.     if (allow_compiled_p)
  2081.       compiled_entry_table_end += (2 * (Heap_Count + Const_Count));
  2082.  
  2083.     compiled_block_table = compiled_entry_table_end;
  2084.     compiled_block_pointer = &compiled_block_table[2];
  2085.     compiled_block_table_end = compiled_block_pointer;
  2086.     if (allow_compiled_p && c_compiled_p)
  2087.       compiled_block_table_end += (2 *(Heap_Count + Const_Count));
  2088.  
  2089.     primitive_table = compiled_block_table_end;
  2090.     if (upgrade_primitives_p)
  2091.       primitive_table_end = (setup_primitive_upgrade (primitive_table));
  2092.     else
  2093.     {
  2094.       fast SCHEME_OBJECT * table;
  2095.       fast long count, char_count;
  2096.  
  2097.       if ((Load_Data (Primitive_Table_Size, primitive_table))
  2098.       != Primitive_Table_Size)
  2099.       {
  2100.     fprintf (stderr, "%s: Could not load the primitive table.\n",
  2101.          program_name);
  2102.     quit (1);
  2103.       }
  2104.       for (char_count = 0,
  2105.        count = Primitive_Table_Length,
  2106.        table = primitive_table;
  2107.        --count >= 0;)
  2108.       {
  2109.     char_count += (STRING_LENGTH_TO_LONG (table[1 + STRING_LENGTH_INDEX]));
  2110.     table += (2 + (OBJECT_DATUM (table[1 + STRING_HEADER])));
  2111.       }
  2112.       NPChars = char_count;
  2113.       primitive_table_end = (&primitive_table[Primitive_Table_Size]);
  2114.     }
  2115.  
  2116.     c_code_table = primitive_table_end;
  2117.     c_code_table_end = &c_code_table[C_Code_Table_Size];
  2118.     if (C_Code_Table_Size == 0)
  2119.       c_code_table[0] = (LONG_TO_UNSIGNED_FIXNUM (0));
  2120.     else
  2121.     {
  2122.       fast SCHEME_OBJECT * table;
  2123.       fast long count, char_count;
  2124.  
  2125.       if ((Load_Data (C_Code_Table_Size, c_code_table)) != C_Code_Table_Size)
  2126.       {
  2127.     fprintf (stderr, "%s: Could not load the C code table.\n",
  2128.          program_name);
  2129.     quit (1);
  2130.       }
  2131.       for (char_count = 0,
  2132.        count = C_Code_Table_Length,
  2133.        table = &c_code_table[1];
  2134.        --count >= 0; )
  2135.       {
  2136.     long slen;
  2137.  
  2138.     slen = (strlen ((char *) (table + 1)));
  2139.     table += (1 + (BYTES_TO_WORDS (1 + slen)));
  2140.     char_count += slen;
  2141.       }
  2142.       NCChars = char_count;
  2143.     }
  2144.  
  2145.     Mem_Base = c_code_table_end;
  2146.  
  2147.     /* Reformat the data */
  2148.  
  2149.     NFlonums = NIntegers = NStrings = 0;
  2150.     NBits = NBBits = NChars = 0;
  2151.  
  2152.     Heap_Start = (NROOTS + (TRAP_MAX_IMMEDIATE + 1));
  2153.     INDEX_ALIGN_FLOAT (Heap_Start);
  2154.     Heap_Objects_Start = (Heap_Start
  2155.               + (allow_compiled_p
  2156.                  ? (2 * Heap_Count)
  2157.                  : Heap_Count));
  2158.     if (! band_p)
  2159.       dumped_utilities = SHARP_F;
  2160.     Mem_Base[(Heap_Start - NROOTS) + 0] = dumped_utilities;
  2161.     if (dumped_utilities != SHARP_F)
  2162.     {
  2163.       /* This knows the format of the utilities vector. */ 
  2164.       SCHEME_OBJECT * uv = (relocate (dumped_utilities));
  2165.       unsigned long len = (OBJECT_DATUM (uv[0]));
  2166.  
  2167.       uv[len - 1] = ((SCHEME_OBJECT)
  2168.              (((unsigned long) uv[len - 1])
  2169.               / (sizeof (SCHEME_OBJECT))));
  2170.       uv[len - 0] = ((SCHEME_OBJECT)
  2171.              (((unsigned long) uv[len - 0])
  2172.               / (sizeof (SCHEME_OBJECT))));
  2173.     }
  2174.     Mem_Base[(Heap_Start - NROOTS) + 1]
  2175.       = (OBJECT_NEW_TYPE (TC_CELL, Dumped_Object));
  2176.     Scan = (Heap_Start - NROOTS);
  2177.     Free = Heap_Start;
  2178.     Free_Objects = &Mem_Base[Heap_Objects_Start];
  2179.     Objects = 0;
  2180.  
  2181.     Constant_Start = (Heap_Objects_Start + Heap_Count);
  2182.     INDEX_ALIGN_FLOAT (Constant_Start);
  2183.     Constant_Objects_Start = (Constant_Start
  2184.                   + (allow_compiled_p
  2185.                  ? (2 * Const_Count)
  2186.                  : Const_Count));
  2187.     Scan_Constant = Constant_Start;
  2188.     Free_Constant = Constant_Start;
  2189.     Free_Cobjects = &Mem_Base[Constant_Objects_Start];
  2190.     Constant_Objects = 0;
  2191.  
  2192.     Pure_Start = (Constant_Objects_Start + Const_Count);
  2193.     INDEX_ALIGN_FLOAT (Pure_Start);
  2194.     Pure_Objects_Start = (Pure_Start
  2195.               + (allow_compiled_p
  2196.                  ? (2 * Const_Count)
  2197.                  : Const_Count));
  2198.     Scan_Pure = Pure_Start;
  2199.     Free_Pure = Pure_Start;
  2200.     Free_Pobjects = &Mem_Base[Pure_Objects_Start];
  2201.     Pure_Objects = 0;
  2202.  
  2203.     if (Const_Count == 0)
  2204.       DO_AREA (HEAP_CODE, Scan, Free, Objects, Free_Objects);
  2205.     else
  2206.       while ((Scan != Free)
  2207.          || (Scan_Constant != Free_Constant)
  2208.          || (Scan_Pure != Free_Pure))
  2209.       {
  2210.     DO_AREA (HEAP_CODE, Scan, Free,
  2211.          Objects, Free_Objects);
  2212.     DO_AREA (CONSTANT_CODE, Scan_Constant, Free_Constant,
  2213.          Constant_Objects, Free_Cobjects);
  2214.     DO_AREA (PURE_CODE, Scan_Pure, Free_Pure,
  2215.          Pure_Objects, Free_Pobjects);
  2216.       }
  2217.  
  2218.     /* Consistency checks */
  2219.  
  2220.     WHEN (((Free - Heap_Start) > Heap_Count), "Free overran Heap");
  2221.  
  2222.     WHEN (((Free_Objects - &Mem_Base[Heap_Objects_Start])
  2223.        > Heap_Count),
  2224.       "Free_Objects overran Heap Object Space");
  2225.  
  2226.     WHEN (((Free_Constant - Constant_Start) > Const_Count),
  2227.       "Free_Constant overran Constant Space");
  2228.  
  2229.     WHEN (((Free_Cobjects - &Mem_Base[Constant_Objects_Start])
  2230.        > Const_Count),
  2231.       "Free_Cobjects overran Constant Object Space");
  2232.  
  2233.     WHEN (((Free_Pure - Pure_Start) > Const_Count),
  2234.       "Free_Pure overran Pure Space");
  2235.  
  2236.     WHEN (((Free_Cobjects - &Mem_Base[Pure_Objects_Start])
  2237.        > Const_Count),
  2238.       "Free_Cobjects overran Pure Object Space");
  2239.  
  2240.     /* Output the data */
  2241.  
  2242.     if (found_ext_prims)
  2243.     {
  2244.       fprintf (stderr, "%s:\n", program_name);
  2245.       fprintf (stderr, "NOTE: The arity of some primitives is not known.\n");
  2246.       fprintf (stderr, "      The portable file has %ld as their arity.\n",
  2247.            UNKNOWN_PRIMITIVE_ARITY);
  2248.       fprintf (stderr, "      You may want to fix this by hand.\n");
  2249.     }
  2250.  
  2251.     if (! compiled_p)
  2252.     {
  2253.       dumped_processor_type = 0;
  2254.       dumped_interface_version = 0;
  2255.     }
  2256.  
  2257.     /* Header:
  2258.                  Portable Version
  2259.                       Machine
  2260.                       Version
  2261.                   Sub Version
  2262.                     Flags
  2263.                    Heap Count
  2264.                     Heap Base
  2265.                  Heap Objects
  2266.                    Constant Count
  2267.                 Constant Base
  2268.                  Constant Objects
  2269.                    Pure Count
  2270.                     Pure Base
  2271.                  Pure Objects
  2272.                   & Dumped Object
  2273.              Maximum Stack Offset
  2274.                 Number of flonums
  2275.                Number of integers
  2276.            Number of bits in integers
  2277.             Number of bit strings
  2278.         Number of bits in bit strings
  2279.           Number of character strings
  2280.           Number of characters in strings
  2281.              Number of primitives
  2282.        Number of characters in primitives
  2283.                      CPU type
  2284.           Compiled code interface version
  2285.             Compiler utilities vector
  2286.               Number of C code blocks
  2287.     Number of characters in C code blocks
  2288.          Number of reserved C entries
  2289.      */
  2290.  
  2291.     WRITE_HEADER ("Portable Version", "%ld", PORTABLE_VERSION);
  2292.     WRITE_HEADER ("Machine", "%ld", FASL_INTERNAL_FORMAT);
  2293.     WRITE_HEADER ("Version", "%ld", FASL_FORMAT_VERSION);
  2294.     WRITE_HEADER ("Sub Version", "%ld", FASL_SUBVERSION);
  2295.     WRITE_HEADER ("Flags", "%ld", (MAKE_FLAGS ()));
  2296.  
  2297.     WRITE_HEADER ("Heap Count", "%ld", (Free - Heap_Start));
  2298.     WRITE_HEADER ("Heap Base", "%ld", Heap_Start);
  2299.     WRITE_HEADER ("Heap Objects", "%ld", Objects);
  2300.  
  2301.     WRITE_HEADER ("Constant Count", "%ld", (Free_Constant - Constant_Start));
  2302.     WRITE_HEADER ("Constant Base", "%ld", Constant_Start);
  2303.     WRITE_HEADER ("Constant Objects", "%ld", Constant_Objects);
  2304.  
  2305.     WRITE_HEADER ("Pure Count", "%ld", (Free_Pure - Pure_Start));
  2306.     WRITE_HEADER ("Pure Base", "%ld", Pure_Start);
  2307.     WRITE_HEADER ("Pure Objects", "%ld", Pure_Objects);
  2308.  
  2309.     WRITE_HEADER ("& Dumped Object", "%ld",
  2310.           (OBJECT_DATUM (Mem_Base[(Heap_Start - NROOTS) + 1])));
  2311.     WRITE_HEADER ("Maximum Stack Offset", "%ld", Max_Stack_Offset);
  2312.  
  2313.     WRITE_HEADER ("Number of flonums", "%ld", NFlonums);
  2314.     WRITE_HEADER ("Number of integers", "%ld", NIntegers);
  2315.     WRITE_HEADER ("Number of bits in integers", "%ld", NBits);
  2316.     WRITE_HEADER ("Number of bit strings", "%ld", NBitstrs);
  2317.     WRITE_HEADER ("Number of bits in bit strings", "%ld", NBBits);
  2318.     WRITE_HEADER ("Number of character strings", "%ld", NStrings);
  2319.     WRITE_HEADER ("Number of characters in strings", "%ld", NChars);
  2320.  
  2321.     WRITE_HEADER ("Number of primitives", "%ld", Primitive_Table_Length);
  2322.     WRITE_HEADER ("Number of characters in primitives", "%ld", NPChars);
  2323.  
  2324.     WRITE_HEADER ("CPU type", "%ld", dumped_processor_type);
  2325.     WRITE_HEADER ("Compiled code interface version", "%ld",
  2326.           dumped_interface_version);
  2327.     if (allow_bands_p)
  2328.       WRITE_HEADER ("Compiler utilities vector", "%ld",
  2329.             (OBJECT_DATUM (Mem_Base[(Heap_Start - NROOTS) + 0])));
  2330.     else
  2331.       WRITE_HEADER ("Compiler utilities vector", "%ld", 0);
  2332.  
  2333.     WRITE_HEADER ("Number of C code blocks", "%ld", C_Code_Table_Length);
  2334.     WRITE_HEADER ("Number of characters in C code blocks", "%ld", NCChars);
  2335.     WRITE_HEADER ("Number of reserved C entries", "%ld",
  2336.           (OBJECT_DATUM (c_code_table[0])));
  2337.  
  2338.     /* Binary Objects */
  2339.  
  2340.     print_binary_objects (&Mem_Base[Pure_Objects_Start], Pure_Objects);
  2341.     print_binary_objects (&Mem_Base[Constant_Objects_Start], Constant_Objects);
  2342.     print_binary_objects (&Mem_Base[Heap_Objects_Start], Objects);
  2343.  
  2344.     /* Normal Objects: pointers, simple non-pointers (e.g. SHARP_F) */
  2345.  
  2346.     print_objects (&Mem_Base[Pure_Start], &Mem_Base[Free_Pure]);
  2347.     print_objects (&Mem_Base[Constant_Start], &Mem_Base[Free_Constant]);
  2348.     print_objects (&Mem_Base[Heap_Start], &Mem_Base[Free]);
  2349.  
  2350.     /* Primitives */
  2351.  
  2352.     if (upgrade_primitives_p)
  2353.     {
  2354.       SCHEME_OBJECT obj;
  2355.       fast SCHEME_OBJECT *table;
  2356.       fast long count, the_datum;
  2357.  
  2358.       for (count = Primitive_Table_Length,
  2359.        table = external_renumber_table;
  2360.        --count >= 0;)
  2361.       {
  2362.     obj = *table++;
  2363.     the_datum = (OBJECT_DATUM (obj));
  2364.     if ((OBJECT_TYPE (obj)) == TC_PRIMITIVE_EXTERNAL)
  2365.     {
  2366.       SCHEME_OBJECT *strobj;
  2367.  
  2368.       strobj = ((SCHEME_OBJECT *) (external_prim_name_table[the_datum]));
  2369.       print_a_primitive (((long) UNKNOWN_PRIMITIVE_ARITY),
  2370.                  (STRING_LENGTH_TO_LONG
  2371.                   (strobj[STRING_LENGTH_INDEX])),
  2372.                  ((char *) &strobj[STRING_CHARS]));
  2373.     }
  2374.     else
  2375.     {
  2376.       char *str;
  2377.  
  2378.       str = builtin_prim_name_table[the_datum];
  2379.       print_a_primitive (((long) builtin_prim_arity_table[the_datum]),
  2380.                  ((long) strlen(str)),
  2381.                  str);
  2382.     }
  2383.       }
  2384.     }
  2385.     else
  2386.     {
  2387.       long count;
  2388.       SCHEME_OBJECT * table = primitive_table;
  2389.  
  2390.       for (count = Primitive_Table_Length; --count >= 0; )
  2391.       {
  2392.     long arity = (FIXNUM_TO_LONG (* table));
  2393.     table += 1;
  2394.     print_a_primitive
  2395.       (arity,
  2396.        (STRING_LENGTH_TO_LONG (table[STRING_LENGTH_INDEX])),
  2397.        ((char *) &table[STRING_CHARS]));
  2398.     table += (1 + (OBJECT_DATUM (table[STRING_HEADER])));
  2399.       }
  2400.     }
  2401.  
  2402.     /* C Code block information */
  2403.  
  2404.     {
  2405.       long count;
  2406.       SCHEME_OBJECT * table = &c_code_table[1];
  2407.  
  2408.       for (count = C_Code_Table_Length; --count >= 0; )
  2409.       {
  2410.     char * name;
  2411.     long nentries, namelen;
  2412.  
  2413.     nentries = (FIXNUM_TO_LONG (* table));
  2414.     name = ((char *) (table + 1));
  2415.     namelen = (strlen (name));
  2416.     print_a_c_code_block (nentries, namelen, name);
  2417.     table += (1 + (BYTES_TO_WORDS (namelen + 1)));
  2418.       }
  2419.     }
  2420.  
  2421.     fflush (portable_file);
  2422.     free ((char *) Lowest_Allocated_Address);
  2423.   }
  2424. }
  2425.  
  2426. /* Top Level */
  2427.  
  2428. static Boolean
  2429.   allow_constant_sup_p,
  2430.   ci_version_sup_p,
  2431.   ci_processor_sup_p,
  2432.   help_p = false,
  2433.   help_sup_p,
  2434.   warn_portable_sup_p;
  2435.  
  2436. /* The boolean value here is what value to store when the option is present. */
  2437.  
  2438. static struct keyword_struct
  2439.   options[] = {
  2440.     KEYWORD ("swap_bytes", &swap_bytes_p, BOOLEAN_KYWRD, BFRMT, NULL),
  2441.     KEYWORD ("compact", &compact_p, BOOLEAN_KYWRD, BFRMT, NULL),
  2442.     KEYWORD ("null_nmv", &null_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL),
  2443.     KEYWORD ("allow_nmv", &allow_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL),
  2444.     KEYWORD ("allow_cc", &allow_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL),
  2445.     KEYWORD ("upgrade_cc", &upgrade_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL),
  2446.     KEYWORD ("ci_version", &compiler_interface_version, INT_KYWRD, "%ld",
  2447.          &ci_version_sup_p),
  2448.     KEYWORD ("ci_processor", &compiler_processor_type, INT_KYWRD, "%ld",
  2449.          &ci_processor_sup_p),
  2450.     KEYWORD ("endian_invert", &endian_invert_p, BOOLEAN_KYWRD, BFRMT, NULL),
  2451.     KEYWORD ("allow_bands", &allow_bands_p, BOOLEAN_KYWRD, BFRMT, NULL),
  2452.     KEYWORD ("allow_constant_space", &allow_constant_space_p,
  2453.          BOOLEAN_KYWRD, BFRMT, &allow_constant_sup_p),
  2454.     KEYWORD ("warn_portable", &warn_portable_p, BOOLEAN_KYWRD, BFRMT,
  2455.          &warn_portable_sup_p),
  2456.     KEYWORD ("help", &help_p, BOOLEAN_KYWRD, BFRMT, &help_sup_p),
  2457.     OUTPUT_KEYWORD (),
  2458.     INPUT_KEYWORD (),
  2459.     END_KEYWORD ()
  2460.     };
  2461.  
  2462. int
  2463. DEFUN (main, (argc, argv), int argc AND char **argv)
  2464. {
  2465.   parse_keywords (argc, argv, options, false);
  2466.  
  2467.   if (help_sup_p && help_p)
  2468.   {
  2469.     print_usage_and_exit(options, 0);
  2470.     /*NOTREACHED*/
  2471.   }
  2472.  
  2473.   upgrade_compiled_p =
  2474.     (upgrade_compiled_p || ci_version_sup_p || ci_processor_sup_p);
  2475.   allow_compiled_p = (allow_compiled_p || upgrade_compiled_p
  2476.               || c_compiled_p || allow_bands_p);
  2477.   allow_nmv_p = (allow_nmv_p || allow_compiled_p || endian_invert_p);
  2478.   if (null_nmv_p && allow_nmv_p)
  2479.   {
  2480.     fprintf (stderr,
  2481.          "%s: NMVs are both allowed and to be nulled out!\n",
  2482.          program_name);
  2483.     quit (1);
  2484.   }
  2485.   if (allow_bands_p && warn_portable_p && (! warn_portable_sup_p))
  2486.     warn_portable_p = false;
  2487.   if (allow_bands_p && (! allow_constant_space_p) && (! allow_constant_sup_p))
  2488.     allow_constant_space_p = true;
  2489.  
  2490.   setup_io ("rb", "w");
  2491.   do_it ();
  2492.   quit (0);
  2493.   return (0);
  2494. }
  2495.