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 / psbtobin.c < prev    next >
C/C++ Source or Header  |  2000-01-18  |  41KB  |  1,526 lines
  1. /* -*-C-*-
  2.  
  3. $Id: psbtobin.c,v 9.58 2000/01/18 05:09:07 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 portable format binary
  23.    files to internal format. */
  24.  
  25. /* Cheap renames */
  26.  
  27. #include "psbmap.h"
  28. #include "float.h"
  29. #include "limits.h"
  30. #define portable_file input_file
  31. #define internal_file output_file
  32.  
  33. #undef HEAP_MALLOC
  34. #define HEAP_MALLOC malloc
  35.  
  36. static Boolean
  37.   band_p = false,
  38.   allow_compiled_p = false,
  39.   allow_nmv_p = false,
  40.   warn_portable_p = true,
  41.   c_compiled_p = false;
  42.  
  43. static long
  44.   Dumped_Object_Addr, Dumped_Compiler_Utilities,
  45.   Dumped_Heap_Base, Dumped_Heap_Limit, Heap_Objects, Heap_Count,
  46.   Dumped_Const_Base, Dumped_Const_Limit, Const_Objects, Const_Count,
  47.   Dumped_Pure_Base, Dumped_Pure_Limit, Pure_Objects, Pure_Count,
  48.   Primitive_Table_Length, Max_Stack_Offset,
  49.   C_Code_Table_Length, C_Code_Reserved_Entries;
  50.  
  51. static SCHEME_OBJECT
  52.   * Heap, * Constant_Space, * Constant_Top, * Stack_Top,
  53.   * Heap_Base, * Heap_Table, * Heap_Object_Limit,
  54.   * Heap_Pointers, * Free,
  55.   * Const_Base, * Const_Table, * Const_Object_Limit,
  56.   * Const_Pointers, * Free_Const,
  57.   * Pure_Base, * Pure_Table, * Pure_Object_Limit,
  58.   * Pure_Pointers, * Free_Pure;
  59.  
  60. static long
  61. DEFUN (Write_Data, (Count, From_Where),
  62.        long Count AND
  63.        SCHEME_OBJECT *From_Where)
  64. {
  65.   return (fwrite (((char *) From_Where),
  66.           (sizeof (SCHEME_OBJECT)),
  67.           Count,
  68.           internal_file));
  69. }
  70.  
  71. #include "fasl.h"
  72. #include "dump.c"
  73.  
  74. #ifndef MAKE_FORMAT_WORD
  75. #define MAKE_FORMAT_WORD(h,l) 0
  76. #endif
  77.  
  78. #ifndef WRITE_LABEL_DESCRIPTOR
  79. #define WRITE_LABEL_DESCRIPTOR(e,f,o) do { } while (0)
  80. #endif
  81.  
  82. #ifndef MAKE_LINKAGE_SECTION_HEADER
  83. #define MAKE_LINKAGE_SECTION_HEADER(kind,count)    0
  84. #endif
  85.  
  86. /*
  87.    The following two lines appears by courtesy of your friendly
  88.    VMS C compiler and runtime library.
  89.  
  90.    Bug in version 4 VMS scanf.
  91.  */
  92.  
  93. #ifndef vms
  94.  
  95. #define VMS_BUG(stmt)
  96.  
  97. #define read_hex_digit(var)                        \
  98. {                                    \
  99.   VMS_BUG (var = 0);                            \
  100.   fscanf (portable_file, "%1lx", &var);                    \
  101. }
  102.  
  103. #else
  104.  
  105. #define VMS_BUG(stmt)            stmt
  106.  
  107. #define read_hex_digit (var)                        \
  108. {                                    \
  109.   var = (read_hex_digit_procedure ());                    \
  110. }
  111.  
  112. long
  113. read_hex_digit_procedure ()
  114. {
  115.   long digit;
  116.   int c;
  117.  
  118.   while ((c = fgetc (portable_file)) == ' ')
  119.   {};
  120.   digit = ((c >= 'a') ? (c - 'a' + 10)
  121.        : ((c >= 'A') ? (c - 'A' + 10)
  122.           : ((c >= '0') ? (c - '0')
  123.              : fprintf (stderr, "Losing big: %d\n", c))));
  124.   return (digit);
  125. }
  126.  
  127. #endif
  128.  
  129. static void
  130. DEFUN_VOID (inconsistency)
  131. {
  132.   /* Provide some context (2 lines). */
  133.   char yow[100];
  134.  
  135.   fgets (&yow[0], 100, portable_file);
  136.   fprintf (stderr, "%s\n", &yow[0]);
  137.   fgets (&yow[0], 100, portable_file);
  138.   fprintf (stderr, "%s\n", &yow[0]);
  139.  
  140.   quit (1);
  141.   /*NOTREACHED*/
  142. }
  143.  
  144. #define OUT(c)    return ((long) ((c) & UCHAR_MAX))
  145.  
  146. static long
  147. DEFUN_VOID (read_a_char)
  148. {
  149.   fast char C;
  150.  
  151.   C = getc (portable_file);
  152.   if (C != '\\')
  153.     OUT (C);
  154.  
  155.   C = getc (portable_file);
  156.   switch (C)
  157.   {
  158.     case 'n':  OUT ('\n');
  159.     case 't':  OUT ('\t');
  160.     case 'b':  OUT ('\b');
  161.     case 'r':  OUT ('\r');
  162.     case 'f':  OUT ('\f');
  163.     case '\\': OUT ('\\');
  164.     case '0':  OUT ('\0');
  165.     case 'X':
  166.     {
  167.       long Code;
  168.  
  169.       if (warn_portable_p)
  170.       {
  171.     warn_portable_p = false;
  172.     fprintf (stderr,
  173.          "%s: File is not Portable.  Character Code Found.\n",
  174.          program_name);
  175.       }
  176.       VMS_BUG (Code = 0);
  177.       fscanf (portable_file, "%ld", &Code);
  178.       getc (portable_file);            /* Space */
  179.       OUT (Code);
  180.     }
  181.     default  : OUT (C);
  182.   }
  183. }
  184.  
  185. static SCHEME_OBJECT *
  186. DEFUN (read_a_char_pointer, (to), SCHEME_OBJECT * to)
  187. {
  188.   long len, maxlen;
  189.   char * str;
  190.  
  191.   VMS_BUG (len = 0);
  192.   fscanf (portable_file, "%ld", &len);
  193.  
  194.   maxlen = (len + 1);        /* null terminated */
  195.   str = ((char *) to);
  196.   getc (portable_file);        /* space */
  197.  
  198.   while (--len >= 0)
  199.     *str++ = ((char) (read_a_char ()));
  200.   *str = '\0';
  201.   return (to + (BYTES_TO_WORDS (maxlen)));
  202. }
  203.  
  204. static SCHEME_OBJECT *
  205. DEFUN (read_a_string_internal, (To, maxlen),
  206.        SCHEME_OBJECT * To AND long maxlen)
  207. {
  208.   long ilen, Pointer_Count;
  209.   fast char *str;
  210.   fast long len;
  211.  
  212.   str = ((char *) (&To[STRING_CHARS]));
  213.   VMS_BUG (ilen = 0);
  214.   fscanf (portable_file, "%ld", &ilen);
  215.   len = ilen;
  216.  
  217.   if (maxlen == -1)
  218.     maxlen = len;
  219.  
  220.   /* Null terminated */
  221.  
  222.   maxlen += 1;
  223.  
  224.   Pointer_Count = (STRING_CHARS + (char_to_pointer (maxlen)));
  225.   To[STRING_HEADER] =
  226.     (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (Pointer_Count - 1)));
  227.   To[STRING_LENGTH_INDEX] = ((SCHEME_OBJECT) len);
  228.  
  229.   /* Space */
  230.  
  231.   getc (portable_file);
  232.   while (--len >= 0)
  233.     *str++ = ((char) (read_a_char ()));
  234.   *str = '\0';
  235.   return (To + Pointer_Count);
  236. }
  237.  
  238. static SCHEME_OBJECT *
  239. DEFUN (read_a_string, (To, Slot),
  240.        SCHEME_OBJECT * To AND SCHEME_OBJECT * Slot)
  241. {
  242.   long maxlen;
  243.  
  244.   *Slot = (MAKE_POINTER_OBJECT (TC_CHARACTER_STRING, To));
  245.   VMS_BUG (maxlen = 0);
  246.   fscanf (portable_file, "%ld", &maxlen);
  247.   return (read_a_string_internal (To, maxlen));
  248. }
  249.  
  250. static SCHEME_OBJECT *
  251. DEFUN (read_an_integer, (The_Type, To, Slot),
  252.        int The_Type AND SCHEME_OBJECT * To AND SCHEME_OBJECT * Slot)
  253. {
  254.   Boolean negative;
  255.   fast long length_in_bits;
  256.  
  257.   getc (portable_file);                /* Space */
  258.   negative = ((getc (portable_file)) == '-');
  259.   {
  260.     long l;
  261.     VMS_BUG (l = 0);
  262.     fscanf (portable_file, "%ld", (&l));
  263.     length_in_bits = l;
  264.   }
  265.   if ((length_in_bits <= fixnum_to_bits)
  266.       && (The_Type == TC_FIXNUM))
  267.   {
  268.     /* The most negative fixnum is handled in the bignum case */
  269.     fast long Value = 0;
  270.     fast int Normalization;
  271.     fast long ndigits;
  272.     long digit;
  273.  
  274.     if (length_in_bits != 0)
  275.     {
  276.       for (Normalization = 0,
  277.       ndigits = hex_digits (length_in_bits);
  278.       --ndigits >= 0;
  279.       Normalization += 4)
  280.       {
  281.     read_hex_digit (digit);
  282.     Value += (digit << Normalization);
  283.       }
  284.     }
  285.     if (negative)
  286.       Value = -Value;
  287.  
  288.     *Slot = (LONG_TO_FIXNUM (Value));
  289.     return (To);
  290.   }
  291.   else if (length_in_bits == 0)
  292.     {
  293.       SCHEME_OBJECT bignum = (MAKE_POINTER_OBJECT (TC_BIG_FIXNUM, To));
  294.       long gc_length = (BIGNUM_LENGTH_TO_GC_LENGTH (0));
  295.       (*To) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, gc_length));
  296.       BIGNUM_SET_HEADER (bignum, 0, 0);
  297.       (*Slot) = bignum;
  298.       return (To + gc_length + 1);
  299.     }
  300.   else
  301.     {
  302.       SCHEME_OBJECT bignum = (MAKE_POINTER_OBJECT (TC_BIG_FIXNUM, To));
  303.       bignum_length_type length = (BIGNUM_BITS_TO_DIGITS (length_in_bits));
  304.       long gc_length = (BIGNUM_LENGTH_TO_GC_LENGTH (length));
  305.       bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
  306.       fast bignum_digit_type accumulator = 0;
  307.       fast int bits_in_digit =
  308.     ((length_in_bits < BIGNUM_DIGIT_LENGTH)
  309.      ? length_in_bits
  310.      : BIGNUM_DIGIT_LENGTH);
  311.       fast int position = 0;
  312.       long original_length_in_bits = length_in_bits;
  313.       long hex_digit, low_digit;
  314.      
  315.       while (length_in_bits > 0)
  316.     {
  317.       read_hex_digit (hex_digit);
  318.       if (bits_in_digit > 4)
  319.         {
  320.           accumulator |= (hex_digit << position);
  321.           length_in_bits -= 4;
  322.           position += 4;
  323.           bits_in_digit -= 4;
  324.         }
  325.       else if (bits_in_digit == 4)
  326.         {
  327.           (*scan++) = (accumulator | (hex_digit << position));
  328.           accumulator = 0;
  329.           position = 0;
  330.           length_in_bits -= 4;
  331.           bits_in_digit =
  332.         ((length_in_bits < BIGNUM_DIGIT_LENGTH)
  333.          ? length_in_bits
  334.          : BIGNUM_DIGIT_LENGTH);
  335.         }
  336.       else
  337.         {
  338.           (*scan++) =
  339.         (accumulator |
  340.          ((hex_digit & ((1 << bits_in_digit) - 1)) << position));
  341.           accumulator = (hex_digit >> bits_in_digit);
  342.           position = (4 - bits_in_digit);
  343.           length_in_bits -= 4;
  344.           if (length_in_bits <= 0)
  345.           {
  346.         (*scan) = accumulator;
  347.         break;
  348.           }
  349.           else if (length_in_bits >= BIGNUM_DIGIT_LENGTH)
  350.         bits_in_digit = BIGNUM_DIGIT_LENGTH;
  351.           else
  352.         bits_in_digit = length_in_bits;
  353.         }
  354.     }
  355.       (*To) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, gc_length));
  356.       BIGNUM_SET_HEADER (bignum, length, negative);
  357.  
  358.       /* The following test depends on BIGNUM_DIGITs being long */
  359.  
  360.       low_digit = (- (BIGNUM_REF (bignum, 0)));
  361.       if (negative
  362.       && (The_Type == TC_FIXNUM)
  363.       && (original_length_in_bits == (fixnum_to_bits + 1))
  364.       && (LONG_TO_FIXNUM_P (low_digit)))
  365.       {
  366.     *Slot = (LONG_TO_FIXNUM (low_digit));
  367.     return (To);
  368.       }
  369.       else
  370.       {
  371.     *Slot = bignum;
  372.     return (To + gc_length + 1);
  373.       }
  374.     }
  375. }
  376.  
  377. SCHEME_OBJECT *
  378. DEFUN (read_a_bignum, (The_Type, To, Slot),
  379.        int The_Type AND SCHEME_OBJECT * To AND SCHEME_OBJECT * Slot)
  380. {
  381.   return (read_an_integer (The_Type, To, Slot));
  382. }
  383.  
  384. static SCHEME_OBJECT *
  385. DEFUN (read_a_bit_string, (To, Slot),
  386.        SCHEME_OBJECT * To AND SCHEME_OBJECT * Slot)
  387. {
  388.   long size_in_bits, size_in_words;
  389.   SCHEME_OBJECT the_bit_string;
  390.  
  391.   VMS_BUG (size_in_bits = 0);
  392.   fscanf (portable_file, "%ld", &size_in_bits);
  393.   size_in_words = (1 + (BIT_STRING_LENGTH_TO_GC_LENGTH (size_in_bits)));
  394.  
  395.   the_bit_string = (MAKE_POINTER_OBJECT (TC_BIT_STRING, To));
  396.   *To++ = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, size_in_words));
  397.   *To = size_in_bits;
  398.   To += size_in_words;
  399.  
  400.   if (size_in_bits != 0)
  401.   {
  402.     unsigned long temp;
  403.     fast SCHEME_OBJECT *scan;
  404.     fast long bits_remaining, bits_accumulated;
  405.     fast SCHEME_OBJECT accumulator;
  406.  
  407.     accumulator = 0;
  408.     bits_accumulated = 0;
  409.     scan = (BIT_STRING_LOW_PTR (the_bit_string));
  410.     for (bits_remaining = size_in_bits;
  411.     bits_remaining > 0;
  412.     bits_remaining -= 4)
  413.     {
  414.       read_hex_digit (temp);
  415.       if ((bits_accumulated + 4) > OBJECT_LENGTH)
  416.       {
  417.     accumulator |=
  418.       ((temp & LOW_MASK (OBJECT_LENGTH - bits_accumulated)) <<
  419.        bits_accumulated);
  420.     *(INC_BIT_STRING_PTR (scan)) = accumulator;
  421.     accumulator = (temp >> (OBJECT_LENGTH - bits_accumulated));
  422.     bits_accumulated -= (OBJECT_LENGTH - 4);
  423.     temp &= LOW_MASK (bits_accumulated);
  424.       }
  425.       else
  426.       {
  427.     accumulator |= (temp << bits_accumulated);
  428.     bits_accumulated += 4;
  429.       }
  430.     }
  431.     if (bits_accumulated != 0)
  432.     {
  433.       *(INC_BIT_STRING_PTR (scan)) = accumulator;
  434.     }
  435.   }
  436.   *Slot = the_bit_string;
  437.   return (To);
  438. }
  439.  
  440. /* Underflow and Overflow */
  441.  
  442. /* dflmax and dflmin exist in the Berserkely FORTRAN library */
  443.  
  444. static double the_max = 0.0;
  445.  
  446. #define dflmin()    0.0    /* Cop out */
  447. #define dflmax()    ((the_max == 0.0) ? (compute_max ()) : the_max)
  448.  
  449. static double
  450. DEFUN_VOID (compute_max)
  451. {
  452.   fast double Result;
  453.   fast int expt;
  454.  
  455.   Result = 0.0;
  456.   for (expt = DBL_MAX_EXP; expt != 0; expt >>= 1)
  457.     Result += (ldexp (1.0, expt));
  458.   the_max = Result;
  459.   return (Result);
  460. }
  461.  
  462. static long
  463. DEFUN (read_signed_decimal, (stream), fast FILE * stream)
  464. {
  465.   fast int c = (getc (stream));
  466.   fast long result = (-1);
  467.   int negative_p = 0;
  468.   while (c == ' ')
  469.     c = (getc (stream));
  470.  
  471.   if (c == '+')
  472.     c = (getc (stream));
  473.   else if (c == '-')
  474.   {
  475.     negative_p = 1;
  476.     c = (getc (stream));
  477.   }
  478.  
  479.   if ((c >= '0') && (c <= '9'))
  480.   {
  481.     result = (c - '0');
  482.     c = (getc (stream));
  483.     while ((c >= '0') && (c <= '9'))
  484.     {
  485.       result = ((result * 10) + (c - '0'));
  486.       c = (getc (stream));
  487.     }
  488.   }
  489.   if (c != EOF)
  490.     ungetc (c, stream);
  491.  
  492.   if (result == (-1))
  493.   {
  494.     fprintf (stderr, "%s: Unable to read expected decimal integer\n",
  495.          program_name);
  496.     inconsistency ();
  497.   }
  498.   return (negative_p ? (-result) : result);
  499. }
  500.  
  501. static double
  502. DEFUN_VOID (read_a_flonum)
  503. {
  504.   Boolean negative;
  505.   long exponent;
  506.   long size_in_bits;
  507.   fast double Result;
  508.  
  509.   getc (portable_file);                /* Space */
  510.   negative = ((getc (portable_file)) == '-');
  511.   /* Hair here because portable file format incorrect for flonum 0. */
  512.   exponent = (read_signed_decimal (portable_file));
  513.   if (exponent == 0)
  514.   {
  515.     int c = (getc (portable_file));
  516.     if (c == '\n')
  517.       return (0);
  518.     ungetc (c, portable_file);
  519.   }
  520.   size_in_bits = (read_signed_decimal (portable_file));
  521.   if (size_in_bits == 0)
  522.     return (0);
  523.  
  524.   if ((exponent > DBL_MAX_EXP) || (exponent < DBL_MIN_EXP))
  525.   {
  526.     /* Skip over mantissa */
  527.  
  528.     while ((getc (portable_file)) != '\n')
  529.       ;
  530.     fprintf (stderr,
  531.          "%s: Floating point exponent too %s!\n",
  532.          program_name,
  533.          ((exponent < 0) ? "small" : "large"));
  534.     Result = ((exponent < 0) ? (dflmin ()) : (dflmax ()));
  535.   }
  536.   else
  537.   {
  538.     fast long ndigits;
  539.     fast double Normalization;
  540.     long digit;
  541.  
  542.     if (size_in_bits > DBL_MANT_DIG)
  543.       fprintf (stderr,
  544.            "%s: Some precision may be lost.",
  545.            program_name);
  546.     getc (portable_file);            /* Space */
  547.     for (ndigits = (hex_digits (size_in_bits)),
  548.      Result = 0.0,
  549.      Normalization = (1.0 / 16.0);
  550.      --ndigits >= 0;
  551.      Normalization /= 16.0)
  552.     {
  553.       read_hex_digit (digit);
  554.       Result += (((double ) digit) * Normalization);
  555.     }
  556.     Result = (ldexp (Result, ((int) exponent)));
  557.   }
  558.   if (negative)
  559.     Result = -Result;
  560.  
  561.   return (Result);
  562. }
  563.  
  564. static SCHEME_OBJECT *
  565. DEFUN (Read_External, (N, Table, To),
  566.        long N
  567.        AND fast SCHEME_OBJECT * Table
  568.        AND SCHEME_OBJECT * To)
  569. {
  570.   fast SCHEME_OBJECT *Until = &Table[N];
  571.   int The_Type;
  572.  
  573.   while (Table < Until)
  574.   {
  575.     VMS_BUG (The_Type = 0);
  576.     fscanf (portable_file, "%2x", &The_Type);
  577.     switch (The_Type)
  578.     {
  579.       case TC_CHARACTER_STRING:
  580.         To = (read_a_string (To, Table++));
  581.     continue;
  582.  
  583.       case TC_BIT_STRING:
  584.     To = (read_a_bit_string (To, Table++));
  585.     continue;
  586.  
  587.       case TC_FIXNUM:
  588.     To = (read_an_integer (The_Type, To, Table++));
  589.     continue;
  590.     
  591.       case TC_BIG_FIXNUM:
  592.     To = (read_a_bignum (The_Type, To, Table++));
  593.     continue;
  594.  
  595.       case TC_CHARACTER:
  596.       {
  597.     long the_char_code;
  598.  
  599.     getc (portable_file);    /* Space */
  600.     VMS_BUG (the_char_code = 0);
  601.     fscanf (portable_file, "%3lx", &the_char_code);
  602.     *Table++ = (MAKE_OBJECT (TC_CHARACTER, the_char_code));
  603.     continue;
  604.       }
  605.  
  606.       case TC_BIG_FLONUM:
  607.       {
  608.     double The_Flonum = (read_a_flonum ());
  609.  
  610.     ALIGN_FLOAT (To);
  611.     *Table++ = (MAKE_POINTER_OBJECT (TC_BIG_FLONUM, To));
  612.     *To++ = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (float_to_pointer)));
  613.     *((double *) To) = The_Flonum;
  614.     To += float_to_pointer;
  615.     continue;
  616.       }
  617.  
  618.       default:
  619.     fprintf (stderr,
  620.          "%s: Unknown external object found; Type = 0x%02x\n",
  621.          program_name, The_Type);
  622.     inconsistency ();
  623.     /*NOTREACHED*/
  624.     }
  625.   }
  626.   return (To);
  627. }
  628.  
  629. #define DEBUG 0
  630.  
  631. #if (DEBUG > 2)
  632.  
  633. static void
  634. DEFUN (print_external_objects, (area_name, Table, N),
  635.        char * area_name
  636.        AND fast SCHEME_OBJECT * Table
  637.        AND fast long N)
  638. {
  639.   fast SCHEME_OBJECT * Table_End = &Table[N];
  640.  
  641.   fprintf (stderr, "%s External Objects:\n", area_name);
  642.   fprintf (stderr, "Table = 0x%x; N = %d\n", Table, N);
  643.  
  644.   for ( ; Table < Table_End; Table++)
  645.   {
  646.     switch (OBJECT_TYPE (*Table))
  647.     {
  648.       case TC_FIXNUM:
  649.       {
  650.         fprintf (stderr,
  651.          "Table[%6d] = Fixnum %d\n",
  652.          (N - (Table_End - Table)),
  653.          (FIXNUM_TO_LONG (*Table)));
  654.     break;
  655.       }
  656.       case TC_CHARACTER:
  657.         fprintf (stderr,
  658.          "Table[%6d] = Character %c = 0x%02x\n",
  659.          (N - (Table_End - Table)),
  660.          (OBJECT_DATUM (*Table)),
  661.          (OBJECT_DATUM (*Table)));
  662.     break;
  663.  
  664.       case TC_CHARACTER_STRING:
  665.         fprintf (stderr,
  666.          "Table[%6d] = string \"%s\"\n",
  667.          (N - (Table_End - Table)),
  668.          ((char *) MEMORY_LOC (*Table, STRING_CHARS)));
  669.     break;
  670.  
  671.       case TC_BIG_FIXNUM:
  672.     fprintf (stderr,
  673.          "Table[%6d] = Bignum\n",
  674.          (N - (Table_End - Table)));
  675.     break;
  676.  
  677.       case TC_BIG_FLONUM:
  678.     fprintf (stderr,
  679.          "Table[%6d] = Flonum %lf\n",
  680.          (N - (Table_End - Table)),
  681.          (* ((double *) MEMORY_LOC (*Table, 1))));
  682.     break;
  683.  
  684.       default:
  685.         fprintf (stderr,
  686.          "Table[%6d] = Unknown External Object 0x%8x\n",
  687.          (N - (Table_End - Table)),
  688.          *Table);
  689.     break;
  690.     }
  691.   }
  692.   return;
  693. }
  694.  
  695. #endif /* DEBUG > 1 */
  696.  
  697. #if (DEBUG > 0)
  698.  
  699. #define WHEN(condition, message)    when (condition, message)
  700.  
  701. static void
  702. DEFUN (when, (what, message), Boolean what AND char * message)
  703. {
  704.   if (what)
  705.   {
  706.     fprintf (stderr, "%s: Inconsistency: %s!\n",
  707.          program_name, (message));
  708.     inconsistency ();
  709.   }
  710.   return;
  711. }
  712.  
  713. #else /* DEBUG <= 0 */
  714.  
  715. #define WHEN(what, message) do { } while (0)
  716.  
  717. #endif /* DEBUG > 0 */
  718.  
  719. #if (DEBUG > 1)
  720.  
  721. #define DEBUGGING(action)        action
  722.  
  723. #define READ_HEADER_FAILURE(string) do                    \
  724. {                                    \
  725.   fprintf (stderr, "Unable to read header field \"%s\".\n", (string));    \
  726. } while (0)
  727.  
  728. #define READ_HEADER_SUCCESS(string, format, value) do            \
  729. {                                    \
  730.   fprintf (stderr, "%s: ", (string));                    \
  731.   fprintf (stderr, (format), (value));                    \
  732.   fprintf (stderr, "\n");                        \
  733. } while (0)
  734.  
  735. #else /* DEBUG <= 1 */
  736.  
  737. #define DEBUGGING(action) do { } while (0)
  738.  
  739. #define READ_HEADER_FAILURE(s) do { } while (0)
  740. #define READ_HEADER_SUCCESS(s,f,v) do { } while (0)
  741.  
  742. #endif /* DEBUG > 0 */
  743.  
  744. #if (DEBUG > 2)
  745.  
  746. #define XDEBUGGING(action) DEBUGGING(action)
  747.  
  748. #else /* DEBUG <= 2 */
  749.  
  750. #define XDEBUGGING(action) do { } while (0)
  751.  
  752. #endif /* DEBUG > 2 */
  753.  
  754. void
  755. DEFUN (relocation_error, (addr), long addr)
  756. {
  757.   fprintf (stderr, "%s: Out of range address %d.\n",
  758.        program_name, addr);
  759.   inconsistency ();
  760.   /*NOTREACHED*/
  761. }
  762.  
  763. #define Relocate_Into(Where, Addr) do                    \
  764. {                                    \
  765.   long _addr = (Addr);                            \
  766.                                     \
  767.   if ((_addr >= Dumped_Heap_Base) && (_addr < Dumped_Heap_Limit))    \
  768.     (Where) = &Heap_Pointers[_addr - Dumped_Heap_Base];            \
  769.   else if ((_addr >= Dumped_Const_Base)                    \
  770.        && (_addr < Dumped_Const_Limit))                \
  771.     (Where) = &Const_Pointers[_addr - Dumped_Const_Base];        \
  772.   else if ((_addr >= Dumped_Pure_Base)                    \
  773.        && (_addr < Dumped_Pure_Limit))                \
  774.     (Where) = &Pure_Pointers[_addr - Dumped_Pure_Base];            \
  775.   else                                    \
  776.     (void) relocation_error (_addr);                    \
  777. } while (0)
  778.  
  779. #ifndef Conditional_Bug
  780.  
  781. #define Relocate(Addr)                            \
  782. ((((Addr) >= Dumped_Heap_Base) && ((Addr) < Dumped_Heap_Limit))        \
  783.  ? &Heap_Pointers[(Addr) - Dumped_Heap_Base]                \
  784.  : ((((Addr) >= Dumped_Const_Base) && ((Addr) < Dumped_Const_Limit))    \
  785.     ? &Const_Pointers[(Addr) - Dumped_Const_Base]            \
  786.     : ((((Addr) >= Dumped_Pure_Base) && ((Addr) < Dumped_Pure_Limit))    \
  787.        ? &Pure_Pointers[(Addr) - Dumped_Pure_Base]            \
  788.        : ((relocation_error (Addr)), ((SCHEME_OBJECT *) NULL)))))
  789.  
  790. #else
  791.  
  792. static SCHEME_OBJECT * Relocate_Temp;
  793.  
  794. #define Relocate(Addr)                            \
  795.   (Relocate_Into (Relocate_Temp, Addr), Relocate_Temp)
  796.  
  797. #endif
  798.  
  799. static SCHEME_OBJECT *
  800. DEFUN (Read_Pointers_and_Relocate, (how_many, to),
  801.        fast long how_many AND fast SCHEME_OBJECT * to)
  802. {
  803.   int The_Type;
  804.   long The_Datum;
  805.  
  806.   while ((--how_many) >= 0)
  807.   {
  808.     VMS_BUG (The_Type = 0);
  809.     VMS_BUG (The_Datum = 0);
  810.     fscanf (portable_file, "%2x %lx", &The_Type, &The_Datum);
  811.     switch (The_Type)
  812.     {
  813.       case CONSTANT_CODE:
  814.         WHEN (((The_Datum < 0) || (The_Datum >= Const_Objects)),
  815.           "CONSTANT_CODE too large");
  816.     *to++ = Const_Table[The_Datum];
  817.     continue;
  818.  
  819.       case HEAP_CODE:
  820.         WHEN (((The_Datum < 0) || (The_Datum >= Heap_Objects)),
  821.           "HEAP_CODE too large");
  822.     *to++ = Heap_Table[The_Datum];
  823.     continue;
  824.     
  825.       case PURE_CODE:
  826.         WHEN (((The_Datum < 0) || (The_Datum >= Pure_Objects)),
  827.           "PURE_CODE too large");
  828.     *to++ = Pure_Table[The_Datum];
  829.     continue;
  830.  
  831.       case TC_MANIFEST_NM_VECTOR:
  832.     *to++ = (MAKE_OBJECT (The_Type, The_Datum));
  833.         {
  834.       fast long count;
  835.  
  836.       count = The_Datum;
  837.       how_many -= count;
  838.       while (--count >= 0)
  839.       {
  840.         VMS_BUG (*to = 0);
  841.         fscanf (portable_file, "%lx", to++);
  842.       }
  843.     }
  844.     continue;
  845.  
  846.       case TC_BROKEN_HEART:
  847.     if (The_Datum != 0)
  848.     {
  849.       fprintf (stderr, "%s: Broken Heart found.\n", program_name);
  850.       inconsistency ();
  851.     }
  852.     /* fall through */
  853.  
  854.       case TC_PCOMB0:
  855.       case TC_PRIMITIVE:
  856.       case TC_MANIFEST_SPECIAL_NM_VECTOR:
  857.       case_simple_Non_Pointer:
  858.     *to++ = (MAKE_OBJECT (The_Type, The_Datum));
  859.     continue;
  860.  
  861.       case TC_COMPILED_ENTRY:
  862.       {
  863.     SCHEME_OBJECT * temp, * entry_addr;
  864.     long base_type, base_datum;
  865.  
  866.     VMS_BUG (base_type = 0);
  867.     VMS_BUG (base_datum = 0);
  868.     fscanf (portable_file, "%02x %lx", &base_type, &base_datum);
  869.     temp = (Relocate (base_datum));
  870.     if (c_compiled_p)
  871.       entry_addr = &temp[The_Datum];
  872.     else
  873.       entry_addr = ((SCHEME_OBJECT *) (&(((char *) temp) [The_Datum])));
  874.     *to++ = (MAKE_POINTER_OBJECT (base_type, entry_addr));
  875.     continue;
  876.       }
  877.  
  878.       case TC_C_COMPILED_TAG:
  879.       {
  880.     if (! c_compiled_p)
  881.     {
  882.       fprintf (stderr, "%s: C-compiled code descriptors found.\n",
  883.            program_name);
  884.       inconsistency ();
  885.     }
  886.     switch (The_Datum)
  887.     {
  888.       case C_COMPILED_FAKE_NMV:
  889.       {
  890.         long nmv_length;
  891.  
  892.         VMS_BUG (nmv_length = 0);
  893.         fscanf (portable_file, "%lx", &nmv_length);
  894.         *to++ = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, nmv_length));
  895.         continue;
  896.       }
  897.  
  898.       case C_COMPILED_ENTRY_FORMAT:
  899.       {
  900.         long low_byte, high_byte, offset, format;
  901.  
  902.         VMS_BUG (low_byte = 0);
  903.         VMS_BUG (high_byte = 0);
  904.         VMS_BUG (offset = 0);
  905.         fscanf (portable_file, "%ld %ld %lx",
  906.             &low_byte, &high_byte, &offset);
  907.         format = (MAKE_FORMAT_WORD (high_byte, low_byte));
  908.         to += 1;
  909.         WRITE_LABEL_DESCRIPTOR (to, format, offset);
  910.         continue;
  911.       }
  912.  
  913.       case C_COMPILED_ENTRY_CODE:
  914.       {
  915.         long entry_number;
  916.  
  917.         VMS_BUG (entry_number = 0);
  918.         fscanf (portable_file, "%lx", &entry_number);
  919.         *to++ = ((SCHEME_OBJECT) entry_number);
  920.         continue;
  921.       }
  922.  
  923.       case C_COMPILED_CLOSURE_HEADER:
  924.       {
  925.         long header_datum;
  926.  
  927.         VMS_BUG (header_datum = 0);
  928.         fscanf (portable_file, "%lx", &header_datum);
  929.         *to++ = (MAKE_OBJECT (TC_MANIFEST_CLOSURE, header_datum));
  930.         continue;
  931.       }
  932.  
  933.       case C_COMPILED_MULTI_CLOSURE_HEADER:
  934.       {
  935.         long nentries;
  936.  
  937.         VMS_BUG (nentries = 0);
  938.         fscanf (portable_file, "%lx", &nentries);
  939.         to += 1;
  940.         WRITE_LABEL_DESCRIPTOR (to, nentries, 0);
  941.         continue;
  942.       }
  943.  
  944.       case C_COMPILED_LINKAGE_HEADER:
  945.       {
  946.         long kind, count;
  947.  
  948.         VMS_BUG (kind = 0);
  949.         VMS_BUG (count = 0);
  950.         fscanf (portable_file, "%lx %lx", &kind, &count);
  951.         *to++ = (MAKE_LINKAGE_SECTION_HEADER (kind, count));
  952.         continue;
  953.       }
  954.  
  955.       case C_COMPILED_RAW_QUAD:
  956.       {
  957.         long quad_datum;
  958.  
  959.         VMS_BUG (quad_datum = 0);
  960.         fscanf (portable_file, "%lx", &quad_datum);
  961.         *to++ = (ADDR_TO_SCHEME_ADDR (Relocate (quad_datum)));
  962.         continue;
  963.       }
  964.  
  965.       case C_COMPILED_EXECUTE_ENTRY:
  966.       {
  967.         long offset, block_base;
  968.         SCHEME_OBJECT * temp;
  969.  
  970.         VMS_BUG (offset = 0);
  971.         VMS_BUG (block_base = 0);
  972.         fscanf (portable_file, "%lx %lx", &offset, &block_base);
  973.         temp = (Relocate (block_base));
  974.         *to++ = (ADDR_TO_SCHEME_ADDR (&temp[offset]));
  975.         continue;
  976.       }
  977.  
  978.       case C_COMPILED_EXECUTE_ARITY:
  979.       {
  980.         long arity;
  981.  
  982.         VMS_BUG (arity = 0);
  983.         fscanf (portable_file, "%lx", &arity);
  984.         *to++ = ((SCHEME_OBJECT) arity);
  985.         continue;
  986.       }
  987.  
  988.       default:
  989.       {
  990.         fprintf (stderr, "%s: Unknown C compiled tag found.\n",
  991.              program_name);
  992.         inconsistency ();
  993.       }
  994.     }
  995.     continue;
  996.       }
  997.  
  998.       case TC_STACK_ENVIRONMENT:
  999.     *to++ = (MAKE_POINTER_OBJECT (The_Type, (Stack_Top - The_Datum)));
  1000.     continue;
  1001.     
  1002.       case TC_REFERENCE_TRAP:
  1003.     if (The_Datum <= TRAP_MAX_IMMEDIATE)
  1004.     {
  1005.       *to++ = (MAKE_OBJECT (The_Type, The_Datum));
  1006.       continue;
  1007.     }
  1008.     /* It is a pointer, fall through. */
  1009.  
  1010.       default:
  1011.     /* Should be stricter */
  1012.     *to++ = (MAKE_POINTER_OBJECT (The_Type, (Relocate (The_Datum))));
  1013.     continue;
  1014.     }
  1015.   }
  1016.   return (to);
  1017. }
  1018.  
  1019. static Boolean primitive_warn = false;
  1020.  
  1021. static SCHEME_OBJECT *
  1022. DEFUN (read_primitives, (how_many, where),
  1023.        fast long how_many
  1024.        AND fast SCHEME_OBJECT * where)
  1025. {
  1026.   long arity;
  1027.  
  1028.   while (--how_many >= 0)
  1029.   {
  1030.     VMS_BUG (arity = 0);
  1031.     fscanf (portable_file, "%ld", &arity);
  1032.     if (arity == ((long) UNKNOWN_PRIMITIVE_ARITY))
  1033.       primitive_warn = true;
  1034.     *where++ = (LONG_TO_FIXNUM (arity));
  1035.     where = (read_a_string_internal (where, ((long) -1)));
  1036.   }
  1037.   return (where);
  1038. }
  1039.  
  1040. static SCHEME_OBJECT *
  1041. DEFUN (read_c_code_blocks, (nreserved, length, area),
  1042.        long nreserved AND long length AND SCHEME_OBJECT * area)
  1043. {
  1044.   if (length != 0)
  1045.   {
  1046.     *area++ = (LONG_TO_FIXNUM (nreserved));
  1047.     while (--length >= 0)
  1048.     {
  1049.       long nentries;
  1050.  
  1051.       VMS_BUG (nentries = 0);
  1052.       fscanf (portable_file, "%ld", &nentries);
  1053.       *area++ = (LONG_TO_FIXNUM (nentries));
  1054.       area = (read_a_char_pointer (area));
  1055.     }
  1056.   }
  1057.   return (area);
  1058. }
  1059.  
  1060. #define READ_HEADER_NO_ERROR(string, format, value, flag) do        \
  1061. {                                    \
  1062.   VMS_BUG (value = 0);                            \
  1063.   if (fscanf (portable_file, format, &(value)) == EOF)            \
  1064.   {                                    \
  1065.     (flag) = (false);                            \
  1066.     READ_HEADER_FAILURE (string);                    \
  1067.   }                                    \
  1068.   else                                    \
  1069.   {                                    \
  1070.     (flag) = (true);                            \
  1071.     READ_HEADER_SUCCESS (string, format, value);            \
  1072.   }                                    \
  1073. } while (0)
  1074.  
  1075. #define READ_HEADER(string, format, value) do                \
  1076. {                                    \
  1077.   VMS_BUG (value = 0);                            \
  1078.   if (fscanf (portable_file, format, &(value)) == EOF)            \
  1079.   {                                    \
  1080.     READ_HEADER_FAILURE (string);                    \
  1081.     short_header_read ();                        \
  1082.   }                                    \
  1083.   else                                    \
  1084.     READ_HEADER_SUCCESS (string, format, value);            \
  1085. } while (0)
  1086.  
  1087. static void
  1088. DEFUN_VOID (short_header_read)
  1089. {
  1090.   fprintf (stderr, "%s: Header is not complete!\n", program_name);
  1091.   quit (1);
  1092. }
  1093.  
  1094. /* Header:
  1095.  
  1096.                  Portable Version
  1097.                       Machine
  1098.                       Version
  1099.                   Sub Version
  1100.                     Flags
  1101.                    Heap Count
  1102.                     Heap Base
  1103.                  Heap Objects
  1104.                    Constant Count
  1105.                 Constant Base
  1106.                  Constant Objects
  1107.                    Pure Count
  1108.                     Pure Base
  1109.                  Pure Objects
  1110.                   & Dumped Object
  1111.              Maximum Stack Offset
  1112.                 Number of flonums
  1113.                Number of integers
  1114.            Number of bits in integers
  1115.             Number of bit strings
  1116.         Number of bits in bit strings
  1117.           Number of character strings
  1118.           Number of characters in strings
  1119.              Number of primitives
  1120.        Number of characters in primitives
  1121.                      CPU type
  1122.           Compiled code interface version
  1123.             Compiler utilities vector
  1124.               Number of C code blocks
  1125.     Number of characters in C code blocks
  1126.          Number of reserved C entries
  1127.  
  1128.   */
  1129.  
  1130. static SCHEME_OBJECT * Lowest_Allocated_Address, * Highest_Allocated_Address;
  1131.  
  1132. static long
  1133. DEFUN_VOID (Read_Header_and_Allocate)
  1134. {
  1135.   Boolean ok;
  1136.  
  1137.   long
  1138.     Portable_Version, Machine,
  1139.     Version, Sub_Version, Flags,
  1140.     NFlonums, NIntegers, NBits,
  1141.     NBitstrs, NBBits, NStrings, NChars,
  1142.     NPChars, NCChars, Size, initial_delta;
  1143.  
  1144.   /* We don't use READ_HEADER here because it is not an error if
  1145.      there is no first word.
  1146.      .bin (and .psb) files can contain multiple objects.
  1147.    */
  1148.  
  1149.   compiler_utilities = SHARP_F;
  1150.   READ_HEADER_NO_ERROR ("Portable Version", "%ld", Portable_Version, ok);
  1151.   if (! ok)
  1152.     return (-1);
  1153.  
  1154.   if (Portable_Version != PORTABLE_VERSION)
  1155.   {
  1156.     fprintf (stderr, "%s: Portable version mismatch:\n", program_name);
  1157.     fprintf (stderr, "Portable File Version %4d\n", Portable_Version);
  1158.     fprintf (stderr, "Expected:     Version %4d\n", PORTABLE_VERSION);
  1159.     quit (1);
  1160.   }
  1161.  
  1162.   READ_HEADER ("Machine", "%ld", Machine);
  1163.   READ_HEADER ("Version", "%ld", Version);
  1164.   READ_HEADER ("Sub Version", "%ld", Sub_Version);
  1165.  
  1166.   if ((Version != FASL_FORMAT_VERSION)        ||
  1167.       (Sub_Version != FASL_SUBVERSION))
  1168.   {
  1169.     fprintf (stderr, "%s: Binary version mismatch:\n", program_name);
  1170.     fprintf (stderr,
  1171.          "Portable File Version %4d; Binary Version %4d; Subversion %4d\n",
  1172.          Portable_Version, Version, Sub_Version);
  1173.     fprintf (stderr,
  1174.          "Expected:     Version %4d; Binary Version %4d; Subversion %4d\n",
  1175.          PORTABLE_VERSION, FASL_FORMAT_VERSION, FASL_SUBVERSION);
  1176.     quit (1);
  1177.   }
  1178.  
  1179.   READ_HEADER ("Flags", "%ld", Flags);
  1180.   READ_FLAGS (Flags);
  1181.  
  1182.   if (band_p)
  1183.     allow_nmv_p = true;
  1184.   if ((Machine != FASL_INTERNAL_FORMAT)
  1185.       && ((nmv_p && (! allow_nmv_p))
  1186.       || (compiled_p && (! allow_compiled_p) && (! c_compiled_p))))
  1187.   {
  1188.     if (compiled_p)
  1189.       fprintf (stderr, "%s: %s\n", program_name,
  1190.            "Portable file contains \"non-portable\" compiled code.");
  1191.     else
  1192.       fprintf (stderr, "%s: %s\n", program_name,
  1193.            "Portable file contains \"unexpected\" non-marked vectors.");
  1194.     fprintf (stderr, "Machine specified in the portable file: %4d\n",
  1195.          Machine);
  1196.     fprintf (stderr, "Machine Expected:                       %4d\n",
  1197.          FASL_INTERNAL_FORMAT);
  1198.     quit (1);
  1199.   }
  1200.  
  1201.   if (compiled_p
  1202.       && c_compiled_p
  1203.       && (COMPILER_PROCESSOR_TYPE != COMPILER_LOSING_C_TYPE))
  1204.   {
  1205.     fprintf (stderr,
  1206.          "Portable file contains descriptors for code compiled to C.\n");
  1207.     fprintf (stderr,
  1208.          "The microcode is not configured to handle such code.\n");
  1209.     quit (1);
  1210.   }
  1211.  
  1212.   READ_HEADER ("Heap Count", "%ld", Heap_Count);
  1213.   READ_HEADER ("Dumped Heap Base", "%ld", Dumped_Heap_Base);
  1214.   READ_HEADER ("Heap Objects", "%ld", Heap_Objects);
  1215.  
  1216.   READ_HEADER ("Constant Count", "%ld", Const_Count);
  1217.   READ_HEADER ("Dumped Constant Base", "%ld", Dumped_Const_Base);
  1218.   READ_HEADER ("Constant Objects", "%ld", Const_Objects);
  1219.  
  1220.   READ_HEADER ("Pure Count", "%ld", Pure_Count);
  1221.   READ_HEADER ("Dumped Pure Base", "%ld", Dumped_Pure_Base);
  1222.   READ_HEADER ("Pure Objects", "%ld", Pure_Objects);
  1223.  
  1224.   READ_HEADER ("& Dumped Object", "%ld", Dumped_Object_Addr);
  1225.   READ_HEADER ("Max Stack Offset", "%ld", Max_Stack_Offset);
  1226.  
  1227.   READ_HEADER ("Number of flonums", "%ld", NFlonums);
  1228.   READ_HEADER ("Number of integers", "%ld", NIntegers);
  1229.   READ_HEADER ("Number of bits in integers", "%ld", NBits);
  1230.   READ_HEADER ("Number of bit strings", "%ld", NBitstrs);
  1231.   READ_HEADER ("Number of bits in bit strings", "%ld", NBBits);
  1232.   READ_HEADER ("Number of character strings", "%ld", NStrings);
  1233.   READ_HEADER ("Number of characters in strings", "%ld", NChars);
  1234.  
  1235.   READ_HEADER ("Primitive Table Length", "%ld", Primitive_Table_Length);
  1236.   READ_HEADER ("Number of characters in primitives", "%ld", NPChars);
  1237.  
  1238.   READ_HEADER ("CPU type", "%ld", compiler_processor_type);
  1239.   READ_HEADER ("Compiled code interface version", "%ld",
  1240.            compiler_interface_version);
  1241.   READ_HEADER ("Compiler utilities vector", "%ld", Dumped_Compiler_Utilities);
  1242.  
  1243.   READ_HEADER ("Number of C code blocks", "%ld", C_Code_Table_Length);
  1244.   READ_HEADER ("Number of characters in C code blocks", "%ld", NCChars);
  1245.   READ_HEADER ("Number of reserved C entries", "%ld", C_Code_Reserved_Entries);
  1246.  
  1247.   Dumped_Heap_Limit = Dumped_Heap_Base + Heap_Count;
  1248.   Dumped_Const_Limit = Dumped_Const_Base + Const_Count;
  1249.   Dumped_Pure_Limit = Dumped_Pure_Base + Pure_Count;
  1250.  
  1251.   initial_delta = (TRAP_MAX_IMMEDIATE + 1);
  1252.   if (Max_Stack_Offset > initial_delta)
  1253.     initial_delta = Max_Stack_Offset;
  1254.  
  1255.   Size = (
  1256.       /* SNMV headers for constant and pure space */
  1257.       6
  1258.       /* Float alignment of the different arenas */
  1259.       + (5 * ((FLOATING_ALIGNMENT + 1) / (sizeof (SCHEME_OBJECT))))
  1260.       /* All pointers must have datum greater than this */
  1261.       + initial_delta
  1262.       /* Incoming heap */
  1263.       + (Heap_Count + Heap_Objects)
  1264.       /* Incoming constant space */
  1265.       + (Const_Count + Const_Objects)
  1266.       /* Incoming pure space */
  1267.       + (Pure_Count + Pure_Objects)
  1268.       /* Maximum space taken up by flonums */
  1269.       + (flonum_to_pointer (NFlonums))
  1270.       /* Maximum space taken up by integers */
  1271.       + ((NIntegers * (2 + (BYTES_TO_WORDS (sizeof (bignum_digit_type)))))
  1272.          + (BYTES_TO_WORDS (BIGNUM_BITS_TO_DIGITS (NBits))))
  1273.       /* Maximum space taken up by strings */
  1274.       + ((NStrings * (1 + STRING_CHARS))
  1275.          + (char_to_pointer (NChars)))
  1276.       /* Maximum space taken up by bit strings */
  1277.       + ((NBitstrs * (1 + BIT_STRING_FIRST_WORD))
  1278.          + (BIT_STRING_LENGTH_TO_GC_LENGTH (NBBits)))
  1279.       /* space taken by the primitive table */
  1280.       + ((Primitive_Table_Length * (2 + STRING_CHARS))
  1281.          + (char_to_pointer (NPChars)))
  1282.       /* Space taken up by the C code block IDs */
  1283.       + (1 + (2 * C_Code_Table_Length) + (char_to_pointer (NCChars))));
  1284.  
  1285.   ALLOCATE_HEAP_SPACE (Size,
  1286.                Lowest_Allocated_Address,
  1287.                Highest_Allocated_Address);
  1288.   if (Lowest_Allocated_Address == NULL)
  1289.   {
  1290.     fprintf (stderr,
  1291.          "%s: Memory Allocation Failed.  Size = %ld Scheme Objects\n",
  1292.          program_name, Size);
  1293.     quit (1);
  1294.   }
  1295.   Heap = (Lowest_Allocated_Address + initial_delta);
  1296.   return (Size - initial_delta);
  1297. }
  1298.  
  1299. static void
  1300. DEFUN_VOID (do_it)
  1301. {
  1302.   while (1)
  1303.   {
  1304.     SCHEME_OBJECT
  1305.       * primitive_table, * primitive_table_end,
  1306.       * c_code_table, * c_code_table_end,
  1307.       * Dumped_Object;
  1308.     Boolean result;
  1309.     long Size;
  1310.  
  1311.     Size = (Read_Header_and_Allocate ());
  1312.     if (Size < 0)
  1313.       return;
  1314.  
  1315.     if (band_p)
  1316.       warn_portable_p = false;
  1317.     Stack_Top = Heap;
  1318.     DEBUGGING (fprintf (stderr, "Stack_Top: 0x%x\n", Stack_Top));
  1319.  
  1320.     Heap_Table = &Heap[Size - Heap_Objects];
  1321.     Const_Table = &Heap_Table[- Const_Objects];
  1322.     Pure_Table = &Const_Table[- Pure_Objects];
  1323.  
  1324.     /* The various 2s below are for SNMV headers in constant/pure markers. */
  1325.  
  1326.     Constant_Space = &Heap[0];
  1327.     ALIGN_FLOAT (Constant_Space);
  1328.     
  1329.     Pure_Base = &Constant_Space[2];
  1330.     Pure_Object_Limit
  1331.       = (Read_External (Pure_Objects, Pure_Table, Pure_Base));
  1332.     Pure_Pointers = Pure_Object_Limit;
  1333.     ALIGN_FLOAT (Pure_Pointers);
  1334.  
  1335.     XDEBUGGING (print_external_objects ("Pure", Pure_Table, Pure_Objects));
  1336.     DEBUGGING (fprintf (stderr, "Pure_Base: 0x%x\n", Pure_Base));
  1337.     DEBUGGING (fprintf (stderr, "Pure_Pointers: 0x%x\n", Pure_Pointers));
  1338.  
  1339.     Const_Base = &Pure_Pointers[Pure_Count + 2];
  1340.     Const_Object_Limit
  1341.       = (Read_External (Const_Objects, Const_Table, Const_Base));
  1342.     Const_Pointers = Const_Object_Limit;
  1343.     ALIGN_FLOAT (Const_Pointers);
  1344.  
  1345.     XDEBUGGING (print_external_objects ("Constant", Const_Table,
  1346.                     Const_Objects));
  1347.     DEBUGGING (fprintf (stderr, "Const_Base: 0x%x\n", Const_Base));
  1348.     DEBUGGING (fprintf (stderr, "Const_Pointers: 0x%x\n", Const_Pointers));
  1349.  
  1350.     Constant_Top = &Const_Pointers[Const_Count + 2];
  1351.  
  1352.     Heap_Base = Constant_Top;
  1353.     ALIGN_FLOAT (Heap_Base);
  1354.     Heap_Object_Limit
  1355.       = (Read_External (Heap_Objects, Heap_Table, Heap_Base));
  1356.     Heap_Pointers = Heap_Object_Limit;
  1357.     ALIGN_FLOAT (Heap_Pointers);
  1358.  
  1359.     XDEBUGGING (print_external_objects ("Heap", Heap_Table, Heap_Objects));
  1360.     DEBUGGING (fprintf (stderr, "Heap_Base: 0x%x\n", Heap_Base));
  1361.     DEBUGGING (fprintf (stderr, "Heap_Pointers: 0x%x\n", Heap_Pointers));
  1362.  
  1363.     primitive_table = &Heap_Pointers[Heap_Count];
  1364.  
  1365.     WHEN ((primitive_table > &Heap[Size]), "primitive_table overran memory.");
  1366.  
  1367.     /* Read the normal objects */
  1368.  
  1369.     Free_Pure = (Read_Pointers_and_Relocate (Pure_Count, Pure_Pointers));
  1370.     WHEN ((Free_Pure > (Const_Base - 2)),
  1371.       "Free_Pure overran Const_Base");
  1372.     WHEN ((Free_Pure < (Const_Base - 2)),
  1373.       "Free_Pure did not reach Const_Base");
  1374.  
  1375.     Free_Const = (Read_Pointers_and_Relocate (Const_Count, Const_Pointers));
  1376.     WHEN ((Free_Const > (Constant_Top - 2)),
  1377.       "Free_Const overran Constant_Top");
  1378.     WHEN ((Free_Const < (Constant_Top - 2)),
  1379.       "Free_Const did not reach Constant_Top");
  1380.  
  1381.     Free = (Read_Pointers_and_Relocate (Heap_Count, Heap_Pointers));
  1382.  
  1383.     WHEN ((Free > primitive_table), "Free overran primitive_table");
  1384.     WHEN ((Free < primitive_table), "Free did not reach primitive_table");
  1385.  
  1386.     primitive_table_end
  1387.       = (read_primitives (Primitive_Table_Length, primitive_table));
  1388.  
  1389.     if (primitive_warn)
  1390.     {
  1391.       fprintf (stderr, "%s:\n", program_name);
  1392.       fprintf
  1393.     (stderr,
  1394.      "NOTE: The binary file contains primitives with unknown arity.\n");
  1395.     }
  1396.  
  1397.     c_code_table = primitive_table_end;
  1398.     c_code_table_end
  1399.       = (read_c_code_blocks (C_Code_Reserved_Entries,
  1400.                  C_Code_Table_Length,
  1401.                  c_code_table));
  1402.  
  1403.     WHEN ((c_code_table_end > Pure_Table),
  1404.       "c_code_table_end overran Pure_Table");
  1405.     /*
  1406.       c_code_table_end can be well below Pure_Table, since
  1407.       the memory allocation is conservative (it rounds up), and all
  1408.       the slack ends up between them.
  1409.       */
  1410.  
  1411.     /* Dump the objects */
  1412.  
  1413.     Relocate_Into (Dumped_Object, Dumped_Object_Addr);
  1414.  
  1415.     DEBUGGING (fprintf (stderr, "Dumping:\n"));
  1416.     DEBUGGING (fprintf (stderr,
  1417.             "Heap = 0x%x; Heap Count = %d\n",
  1418.             Heap_Base, (Free - Heap_Base)));
  1419.     DEBUGGING (fprintf (stderr,
  1420.             "Pure Space = 0x%x; Pure Count = %d\n",
  1421.             Pure_Base, (Free_Pure - Pure_Base)));
  1422.     DEBUGGING (fprintf (stderr,
  1423.             "Constant Space = 0x%x; Constant Count = %d\n",
  1424.             Const_Base, (Free_Const - Const_Base)));
  1425.     DEBUGGING (fprintf (stderr,
  1426.             "& Dumped Object = 0x%x; Dumped Object = 0x%x\n",
  1427.             Dumped_Object, * Dumped_Object));
  1428.     DEBUGGING (fprintf (stderr, "Primitive_Table_Length = %ld; ",
  1429.             Primitive_Table_Length));
  1430.     DEBUGGING (fprintf (stderr, "Primitive_Table_Size = %ld\n",
  1431.             (primitive_table_end - primitive_table)));
  1432.  
  1433.     if (Dumped_Compiler_Utilities != 0)
  1434.     {
  1435.       /* This knows the format of the utilities vector. */ 
  1436.       SCHEME_OBJECT * uv = (Relocate (Dumped_Compiler_Utilities));
  1437.       unsigned long len = uv[0];
  1438.  
  1439.       uv[len - 1] = ((SCHEME_OBJECT)
  1440.              (((unsigned long) uv[len - 1])
  1441.               * (sizeof (SCHEME_OBJECT))));
  1442.       uv[len - 0] = ((SCHEME_OBJECT)
  1443.              (((unsigned long) uv[len - 0])
  1444.               * (sizeof (SCHEME_OBJECT))));
  1445.       compiler_utilities = (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, uv));
  1446.     }
  1447.  
  1448.     /* Is there a Pure/Constant block? */
  1449.  
  1450.     if ((Const_Objects == 0) && (Const_Count == 0)
  1451.     && (Pure_Objects == 0) && (Pure_Count == 0))
  1452.       result = (Write_File (Dumped_Object,
  1453.                 (Free - Heap_Base), Heap_Base,
  1454.                 0, Stack_Top,
  1455.                 primitive_table, Primitive_Table_Length,
  1456.                 ((long) (primitive_table_end - primitive_table)),
  1457.                 c_code_table, C_Code_Table_Length,
  1458.                 ((long) (c_code_table_end - c_code_table)),
  1459.                 compiled_p, band_p));
  1460.     else
  1461.     {
  1462.       long Pure_Length, Total_Length;
  1463.  
  1464.       Pure_Length = ((Const_Base - Pure_Base) + 1);
  1465.       Total_Length = ((Constant_Top - Pure_Base) + 1);
  1466.       Pure_Base[-2] = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR,
  1467.                     Pure_Length));
  1468.       Pure_Base[-1] = (MAKE_OBJECT (PURE_PART, Total_Length));
  1469.       Const_Base[-2] = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
  1470.       Const_Base[-1] = (MAKE_OBJECT (CONSTANT_PART, Pure_Length));
  1471.       Free_Const[0] = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
  1472.       Free_Const[1] = (MAKE_OBJECT (END_OF_BLOCK, Total_Length));
  1473.  
  1474.       result = (Write_File (Dumped_Object,
  1475.                 (Free - Heap_Base), Heap_Base,
  1476.                 (Total_Length + 1), (Pure_Base - 2),
  1477.                 primitive_table, Primitive_Table_Length,
  1478.                 ((long) (primitive_table_end - primitive_table)),
  1479.                 c_code_table, C_Code_Table_Length,
  1480.                 ((long) (c_code_table_end - c_code_table)),
  1481.                 compiled_p, band_p));
  1482.     }
  1483.  
  1484.     if (!result)
  1485.     {
  1486.       fprintf (stderr, "%s: Error writing the output file.\n", program_name);
  1487.       quit (1);
  1488.     }
  1489.     free ((char *) Lowest_Allocated_Address);
  1490.   }
  1491. }
  1492.  
  1493. /* Top level */
  1494.  
  1495. static Boolean
  1496.   help_p = false,
  1497.   help_sup_p;
  1498.  
  1499. static struct keyword_struct
  1500.   options[] = {
  1501.     KEYWORD ("allow_nmv", &allow_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL),
  1502.     KEYWORD ("allow_cc", &allow_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL),
  1503.     KEYWORD ("help", &help_p, BOOLEAN_KYWRD, BFRMT, &help_sup_p),
  1504.     OUTPUT_KEYWORD (),
  1505.     INPUT_KEYWORD (),
  1506.     END_KEYWORD ()
  1507.     };
  1508.  
  1509. int
  1510. DEFUN (main, (argc, argv),
  1511.        int argc AND
  1512.        char **argv)
  1513. {
  1514.   parse_keywords (argc, argv, options, false);
  1515.   if (help_sup_p && help_p)
  1516.     print_usage_and_exit (options, 0);
  1517.     /*NOTREACHED*/
  1518.  
  1519.   allow_nmv_p = (allow_nmv_p || allow_compiled_p);
  1520.  
  1521.   setup_io ("r", "wb");
  1522.   do_it ();
  1523.   quit (0);
  1524.   return (0);
  1525. }
  1526.