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 / fasload.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  34KB  |  1,196 lines
  1. /* -*-C-*-
  2.  
  3. $Id: fasload.c,v 9.88 2000/12/05 21:23:44 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. /* The "fast loader" which reads in and relocates binary files and then
  23.    interns symbols.  It is called with one argument: the (character
  24.    string) name of a file to load.  It is called as a primitive, and
  25.    returns a single object read in. */
  26.  
  27. #include "scheme.h"
  28. #include "prims.h"
  29. #include "osscheme.h"
  30. #include "osfile.h"
  31. #include "osio.h"
  32. #include "gccode.h"
  33. #include "trap.h"
  34. #include "option.h"
  35. #include "prmcon.h"
  36.  
  37. static Tchannel load_channel;
  38.  
  39. #define Load_Data(size, buffer)                        \
  40.   ((long)                                \
  41.    ((OS_channel_read_load_file                        \
  42.      (load_channel,                            \
  43.       ((char *) (buffer)),                        \
  44.       ((size) * (sizeof (SCHEME_OBJECT)))))                \
  45.     / (sizeof (SCHEME_OBJECT))))
  46.  
  47. #include "load.c"
  48.  
  49. #ifdef STDC_HEADERS
  50. #  include <stdlib.h>
  51. #  include <string.h>
  52. #else
  53.    extern char * EXFUN (malloc, (int));
  54.    extern int EXFUN (strlen, (const char *));
  55.    extern char * EXFUN (strcpy, (char *, const char *));
  56. #endif
  57.  
  58. extern char * Error_Names [];
  59. extern char * Abort_Names [];
  60. extern SCHEME_OBJECT * load_renumber_table;
  61. extern SCHEME_OBJECT compiler_utilities;
  62.  
  63. extern SCHEME_OBJECT
  64.   EXFUN (intern_symbol, (SCHEME_OBJECT));
  65.  
  66. extern void
  67.   EXFUN (install_primitive_table, (SCHEME_OBJECT *, long)),
  68.   EXFUN (compiler_reset_error, (void)),
  69.   EXFUN (compiler_initialize, (long)),
  70.   EXFUN (compiler_reset, (SCHEME_OBJECT));
  71.  
  72. extern Boolean
  73.   EXFUN (install_c_code_table, (SCHEME_OBJECT *, long));
  74.  
  75. static long failed_heap_length = -1;
  76.  
  77. #define MODE_BAND        0
  78. #define MODE_CHANNEL        1
  79. #define MODE_FNAME        2
  80.  
  81. static void
  82. DEFUN (read_channel_continue, (header, mode, repeat_p),
  83.        SCHEME_OBJECT * header AND int mode AND Boolean repeat_p)
  84. {
  85.   extern Boolean EXFUN (update_allocator_parameters, (SCHEME_OBJECT *));
  86.   long value, heap_length;
  87.  
  88.   value = (initialize_variables_from_fasl_header (header));
  89.  
  90.   if (value != FASL_FILE_FINE)
  91.   {
  92.     if (mode != MODE_CHANNEL)
  93.       OS_channel_close_noerror (load_channel);
  94.     switch (value)
  95.     {
  96.       /* These may want to be separated further. */
  97.       case FASL_FILE_TOO_SHORT:
  98.       case FASL_FILE_NOT_FASL:
  99.       case FASL_FILE_BAD_MACHINE:
  100.       case FASL_FILE_BAD_VERSION:
  101.       case FASL_FILE_BAD_SUBVERSION:
  102.         signal_error_from_primitive (ERR_FASL_FILE_BAD_DATA);
  103.     /*NOTREACHED*/
  104.  
  105.       case FASL_FILE_BAD_PROCESSOR:
  106.       case FASL_FILE_BAD_INTERFACE:
  107.     signal_error_from_primitive (ERR_FASLOAD_COMPILED_MISMATCH);
  108.     /*NOTREACHED*/
  109.     }
  110.   }
  111.  
  112.   if (Or2 (Reloc_Debug, File_Load_Debug))
  113.     print_fasl_information();
  114.  
  115.   if (((mode == MODE_BAND)
  116.        && (! (update_allocator_parameters (Free_Constant + Const_Count))))
  117.       || ((mode != MODE_BAND)
  118.       && (! (TEST_CONSTANT_TOP (Free_Constant + Const_Count)))))
  119.   {
  120.     if (mode != MODE_CHANNEL)
  121.       OS_channel_close_noerror (load_channel);
  122.     signal_error_from_primitive (ERR_FASL_FILE_TOO_BIG);
  123.     /*NOTREACHED*/
  124.   }
  125.   if (mode == MODE_BAND)
  126.   {
  127.     SET_CONSTANT_TOP ();
  128.     ALIGN_FLOAT (Free);
  129.     SET_MEMTOP (Heap_Top);    
  130.   }
  131.  
  132.   heap_length = (Heap_Count
  133.          + Primitive_Table_Size
  134.          + Primitive_Table_Length
  135.          + C_Code_Table_Size);
  136.  
  137.   if (GC_Check (heap_length))
  138.   {
  139.     if (repeat_p
  140.     || (heap_length == failed_heap_length)
  141.     || (mode == MODE_BAND))
  142.     {
  143.       if (mode != MODE_CHANNEL)
  144.     OS_channel_close_noerror (load_channel);
  145.       signal_error_from_primitive (ERR_FASL_FILE_TOO_BIG);
  146.       /*NOTREACHED*/
  147.     }
  148.     else if (mode == MODE_CHANNEL)
  149.     {
  150.       SCHEME_OBJECT reentry_record[1];
  151.  
  152.       /* IMPORTANT: This KNOWS that it was called from BINARY-FASLOAD.
  153.      If this is ever called from elsewhere with MODE_CHANNEL,
  154.      it will have to be parameterized better.
  155.  
  156.      This reentry record must match the expectations of
  157.      continue_fasload below.
  158.        */     
  159.  
  160.       Request_GC (heap_length);
  161.  
  162.       /* This assumes that header == (Free + 1) */
  163.       header = Free;
  164.       Free += (FASL_HEADER_LENGTH + 1);
  165.       *header = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, FASL_HEADER_LENGTH));
  166.  
  167.       reentry_record[0] = (MAKE_POINTER_OBJECT (TC_NON_MARKED_VECTOR, header));
  168.       
  169.       suspend_primitive (CONT_FASLOAD,
  170.              ((sizeof (reentry_record))
  171.               / (sizeof (SCHEME_OBJECT))),
  172.              &reentry_record[0]);
  173.       immediate_interrupt ();
  174.       /*NOTREACHED*/
  175.     }
  176.     else
  177.     {
  178.       failed_heap_length = heap_length;
  179.       OS_channel_close_noerror (load_channel);
  180.       Request_GC (heap_length);
  181.       signal_interrupt_from_primitive ();
  182.       /*NOTREACHED*/
  183.     }
  184.   }
  185.   failed_heap_length = -1;
  186.  
  187.   if ((band_p) && (mode != MODE_BAND))
  188.   {
  189.     if (mode != MODE_CHANNEL)
  190.       OS_channel_close_noerror (load_channel);      
  191.     signal_error_from_primitive (ERR_FASLOAD_BAND);
  192.   }
  193.   return;
  194. }
  195.  
  196. static void
  197. DEFUN (read_channel_start, (channel, mode), Tchannel channel AND int mode)
  198. {
  199.   load_channel = channel;
  200.  
  201.   if (GC_Check (FASL_HEADER_LENGTH + 1))
  202.   {
  203.     if (mode != MODE_CHANNEL)
  204.       OS_channel_close_noerror (load_channel);
  205.     Request_GC (FASL_HEADER_LENGTH + 1);
  206.     signal_interrupt_from_primitive ();
  207.     /* NOTREACHED */
  208.   }
  209.  
  210.   if ((Load_Data (FASL_HEADER_LENGTH, ((char *) (Stack_Bottom + 1))))
  211.       != FASL_HEADER_LENGTH)
  212.   {
  213.     if (mode != MODE_CHANNEL)
  214.       OS_channel_close_noerror (load_channel);
  215.     signal_error_from_primitive (ERR_FASL_FILE_BAD_DATA);
  216.   }
  217.  
  218.   read_channel_continue ((Stack_Bottom + 1), mode, false);
  219.   return;
  220. }
  221.  
  222. static void
  223. DEFUN (read_file_start, (file_name, from_band_load),
  224.        CONST char * file_name AND Boolean from_band_load)
  225. {
  226.   Tchannel channel;
  227.  
  228.   channel = (OS_open_load_file (file_name));
  229.   
  230.   if (Per_File)
  231.     debug_edit_flags ();
  232.   if (channel == NO_CHANNEL)
  233.     error_bad_range_arg (1);
  234.   read_channel_start (channel, (from_band_load ? MODE_BAND : MODE_FNAME));
  235.   return;
  236. }
  237.  
  238. static void
  239. DEFUN (read_file_end, (mode, prim_table_ptr, c_code_table_ptr),
  240.        int mode
  241.        AND SCHEME_OBJECT ** prim_table_ptr
  242.        AND SCHEME_OBJECT ** c_code_table_ptr)
  243. {
  244.   SCHEME_OBJECT * prim_table, * c_code_table;
  245.   extern unsigned long checksum_area ();
  246.  
  247.   if ((Load_Data (Heap_Count, ((char *) Free))) != Heap_Count)
  248.   {
  249.     if (mode != MODE_CHANNEL)
  250.       OS_channel_close_noerror (load_channel);
  251.     signal_error_from_primitive (ERR_IO_ERROR);
  252.   }
  253.   computed_checksum =
  254.     (checksum_area (((unsigned long *) Free),
  255.             Heap_Count,
  256.             computed_checksum));
  257.   NORMALIZE_REGION(((char *) Free), Heap_Count);
  258.   Free += Heap_Count;
  259.  
  260.   if ((Load_Data (Const_Count, ((char *) Free_Constant))) != Const_Count)
  261.   {
  262.     SET_CONSTANT_TOP ();
  263.     if (mode != MODE_CHANNEL)
  264.       OS_channel_close_noerror (load_channel);
  265.     signal_error_from_primitive (ERR_IO_ERROR);
  266.   }
  267.   computed_checksum =
  268.     (checksum_area (((unsigned long *) Free_Constant),
  269.             Const_Count,
  270.             computed_checksum));
  271.   NORMALIZE_REGION (((char *) Free_Constant), Const_Count);
  272.   Free_Constant += Const_Count;
  273.   SET_CONSTANT_TOP ();
  274.  
  275.   prim_table = Free;
  276.   if ((Load_Data (Primitive_Table_Size, ((char *) prim_table)))
  277.       != Primitive_Table_Size)
  278.   {
  279.     if (mode != MODE_CHANNEL)
  280.       OS_channel_close_noerror (load_channel);
  281.     signal_error_from_primitive (ERR_IO_ERROR);
  282.   }
  283.   computed_checksum =
  284.     (checksum_area (((unsigned long *) prim_table),
  285.             Primitive_Table_Size,
  286.             computed_checksum));
  287.   NORMALIZE_REGION (((char *) prim_table), Primitive_Table_Size);
  288.   Free += Primitive_Table_Size;
  289.  
  290.   c_code_table = Free;
  291.   * c_code_table = FIXNUM_ZERO;
  292.   if ((C_Code_Table_Size != 0)
  293.       && ((Load_Data (C_Code_Table_Size, ((char *) c_code_table)))
  294.       != C_Code_Table_Size))
  295.   {
  296.     if (mode != MODE_CHANNEL)
  297.       OS_channel_close_noerror (load_channel);
  298.     signal_error_from_primitive (ERR_IO_ERROR);
  299.   }
  300.   computed_checksum =
  301.     (checksum_area (((unsigned long *) c_code_table),
  302.             C_Code_Table_Size,
  303.             computed_checksum));
  304.   NORMALIZE_REGION (((char *) c_code_table), C_Code_Table_Size);
  305.   Free += C_Code_Table_Size;
  306.  
  307.   if (mode != MODE_CHANNEL)
  308.     OS_channel_close_noerror (load_channel);
  309.  
  310.   if ((computed_checksum != ((unsigned long) 0))
  311.       && (dumped_checksum != SHARP_F))
  312.     signal_error_from_primitive (ERR_IO_ERROR);
  313.  
  314.   * prim_table_ptr = prim_table;
  315.   * c_code_table_ptr = c_code_table;
  316.   return;
  317. }
  318.  
  319. /* Statics used by Relocate, below */
  320.  
  321. relocation_type
  322.   heap_relocation,
  323.   const_relocation,
  324.   stack_relocation;
  325.  
  326. /* Relocate a pointer as read in from the file.  If the pointer used
  327.    to point into the heap, relocate it into the heap.  If it used to
  328.    be constant area, relocate it to constant area.  Otherwise give an
  329.    error.
  330. */
  331.  
  332. #ifdef ENABLE_DEBUGGING_TOOLS
  333.  
  334. static Boolean Warned = false;
  335.  
  336. static SCHEME_OBJECT *
  337. DEFUN (relocate, (P), long P)
  338. {
  339.   SCHEME_OBJECT * Result;
  340.  
  341.   if ((P >= Heap_Base) && (P < Dumped_Heap_Top))
  342.     Result = ((SCHEME_OBJECT *) (P + heap_relocation));
  343.   else if ((P >= Const_Base) && (P < Dumped_Constant_Top))
  344.     Result = ((SCHEME_OBJECT *) (P + const_relocation));
  345.   else if ((P >= Dumped_Constant_Top) && (P < Dumped_Stack_Top))
  346.     Result = ((SCHEME_OBJECT *) (P + stack_relocation));
  347.   else
  348.   {
  349.     outf_console ("Pointer out of range: 0x%lx\n", P);
  350.     if (!Warned)
  351.     {
  352.       outf_console ("Heap: %lx-%lx, Constant: %lx-%lx, Stack: ?-0x%lx\n",
  353.           ((long) Heap_Base), ((long) Dumped_Heap_Top),
  354.           ((long) Const_Base), ((long) Dumped_Constant_Top),
  355.           ((long) Dumped_Stack_Top));
  356.       Warned = true;
  357.     }
  358.     Result = ((SCHEME_OBJECT *) 0);
  359.   }
  360.   if (Reloc_Debug)
  361.     outf_console ("0x%06lx -> 0x%06lx\n", P, ((long) Result));
  362.   return (Result);
  363. }
  364.  
  365. #define RELOCATE relocate
  366. #define RELOCATE_INTO(Loc, P) (Loc) = relocate(P)
  367.  
  368. #else /* not ENABLE_DEBUGGING_TOOLS */
  369.  
  370. #define RELOCATE_INTO(Loc, P) do                    \
  371. {                                    \
  372.   long _P = (P);                            \
  373.                                     \
  374.   if ((P >= Heap_Base) && (_P < Dumped_Heap_Top))            \
  375.     (Loc) = ((SCHEME_OBJECT *) (_P + heap_relocation));            \
  376.   else if ((P >= Const_Base) && (_P < Dumped_Constant_Top))        \
  377.     (Loc) = ((SCHEME_OBJECT *) (_P + const_relocation));        \
  378.   else                                    \
  379.     (Loc) = ((SCHEME_OBJECT *) (_P + stack_relocation));        \
  380. } while (0)
  381.  
  382. #ifndef Conditional_Bug
  383.  
  384. #define RELOCATE(P)                            \
  385. ((((P) >= Heap_Base) && ((P) < Dumped_Heap_Top))            \
  386.  ? ((SCHEME_OBJECT *) ((P) + heap_relocation))                \
  387.  : ((((P) >= Const_Base) && ((P) < Dumped_Constant_Top))        \
  388.     ? ((SCHEME_OBJECT *) ((P) + const_relocation))            \
  389.     : ((SCHEME_OBJECT *) ((P) + stack_relocation))))
  390.  
  391. #else /* Conditional_Bug */
  392.  
  393. static SCHEME_OBJECT * relocate_temp;
  394.  
  395. #define RELOCATE(P)                            \
  396.   (RELOCATE_INTO (Relocate_Temp, P), relocate_temp)
  397.  
  398. #endif /* Conditional_Bug */
  399. #endif /* ENABLE_DEBUGGING_TOOLS */
  400.  
  401. /* Next_Pointer starts by pointing to the beginning of the block of
  402.    memory to be handled.  This loop relocates all pointers in the
  403.    block of memory.
  404. */
  405.  
  406. static long
  407. DEFUN (primitive_dumped_number, (datum), unsigned long datum)
  408. {
  409.   unsigned long high_bits = (datum >> HALF_DATUM_LENGTH);
  410.   return ((high_bits != 0) ? high_bits : datum);
  411. }
  412.  
  413. #define PRIMITIVE_DUMPED_NUMBER(prim)                    \
  414.   (primitive_dumped_number (OBJECT_DATUM (prim)))
  415.  
  416. static void
  417. DEFUN (Relocate_Block, (Scan, Stop_At),
  418.        fast SCHEME_OBJECT * Scan AND fast SCHEME_OBJECT * Stop_At)
  419. {
  420.   fast long address;
  421.   fast SCHEME_OBJECT Temp;
  422.  
  423.   if (Reloc_Debug)
  424.   {
  425.     outf_error
  426.       ("\nRelocate_Block: block = 0x%lx, length = 0x%lx, end = 0x%lx.\n",
  427.        ((long) Scan), ((long) ((Stop_At - Scan) - 1)), ((long) Stop_At));
  428.   }
  429.  
  430.   while (Scan < Stop_At)
  431.   {
  432.     Temp = * Scan;
  433.     Switch_by_GC_Type (Temp)
  434.     {
  435.       case TC_BROKEN_HEART:
  436.       case TC_MANIFEST_SPECIAL_NM_VECTOR:
  437.       case_Fasload_Non_Pointer:
  438. #ifdef EMPTY_LIST_VALUE
  439.     if (Temp == EMPTY_LIST_VALUE)
  440.       * Scan = EMPTY_LIST;
  441. #endif
  442.         Scan += 1;
  443.     break;
  444.  
  445.       case TC_PRIMITIVE:
  446.     *Scan++ = (load_renumber_table [PRIMITIVE_DUMPED_NUMBER (Temp)]);
  447.     break;
  448.  
  449.       case TC_PCOMB0:
  450.     *Scan++ =
  451.       OBJECT_NEW_TYPE
  452.         (TC_PCOMB0,
  453.          (load_renumber_table [PRIMITIVE_DUMPED_NUMBER (Temp)]));
  454.         break;
  455.  
  456.       case TC_MANIFEST_NM_VECTOR:
  457.         Scan += ((OBJECT_DATUM (Temp)) + 1);
  458.         break;
  459.  
  460.       case TC_LINKAGE_SECTION:
  461.       {
  462.     switch (READ_LINKAGE_KIND (Temp))
  463.     {
  464.       case REFERENCE_LINKAGE_KIND:
  465.       case ASSIGNMENT_LINKAGE_KIND:
  466.       {
  467.         /* Assumes that all others are objects of type TC_QUAD without
  468.            their type codes.
  469.            */
  470.  
  471.         fast long count;
  472.  
  473.         Scan++;
  474.         for (count = (READ_CACHE_LINKAGE_COUNT (Temp));
  475.          --count >= 0;
  476.          )
  477.         {
  478.           address = (SCHEME_ADDR_TO_OLD_DATUM (* Scan));
  479.           *Scan++ = (ADDR_TO_SCHEME_ADDR (RELOCATE (address)));
  480.         }
  481.         break;
  482.       }
  483.  
  484.       case OPERATOR_LINKAGE_KIND:
  485.       case GLOBAL_OPERATOR_LINKAGE_KIND:
  486.       {
  487.         fast long count;
  488.         fast char * word_ptr;
  489.         SCHEME_OBJECT * end_scan;
  490.  
  491.         START_OPERATOR_RELOCATION (Scan);
  492.         count = (READ_OPERATOR_LINKAGE_COUNT (Temp));
  493.         word_ptr = (FIRST_OPERATOR_LINKAGE_ENTRY (Scan));
  494.         end_scan = (END_OPERATOR_LINKAGE_AREA (Scan, count));
  495.  
  496.         while(--count >= 0)
  497.         {
  498.           Scan = ((SCHEME_OBJECT *) (word_ptr));
  499.           word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr));
  500.           EXTRACT_OPERATOR_LINKAGE_ADDRESS (address, Scan);
  501.           address = (SCHEME_ADDR_TO_OLD_DATUM (address));
  502.           address = ((long) (RELOCATE (address)));
  503.           STORE_OPERATOR_LINKAGE_ADDRESS ((ADDR_TO_SCHEME_ADDR (address)),
  504.                           Scan);
  505.         }
  506.         Scan = &end_scan[1];
  507.         END_OPERATOR_RELOCATION (Scan - 1);
  508.         break;
  509.       }
  510.  
  511.       case CLOSURE_PATTERN_LINKAGE_KIND:
  512.         Scan += (1 + (READ_CACHE_LINKAGE_COUNT (Temp)));
  513.         break;
  514.  
  515.       default:
  516.       {
  517.         gc_death (TERM_EXIT,
  518.               "Relocate_Block: Unknown compiler linkage kind.",
  519.               Scan, NULL);
  520.         /*NOTREACHED*/
  521.       }
  522.     }
  523.     break;
  524.       }
  525.  
  526.       case TC_MANIFEST_CLOSURE:
  527.       {
  528.     /* See comment about relocation in TC_LINKAGE_SECTION above. */
  529.  
  530.     fast long count;
  531.     fast char * word_ptr;
  532.     SCHEME_OBJECT * area_end;
  533.  
  534.     START_CLOSURE_RELOCATION (Scan);
  535.     Scan += 1;
  536.     count = (MANIFEST_CLOSURE_COUNT (Scan));
  537.     word_ptr = (FIRST_MANIFEST_CLOSURE_ENTRY (Scan));
  538.     area_end = (MANIFEST_CLOSURE_END (Scan, count));
  539.  
  540.     while ((--count) >= 0)
  541.     {
  542.       Scan = ((SCHEME_OBJECT *) (word_ptr));
  543.       word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr));
  544.       EXTRACT_CLOSURE_ENTRY_ADDRESS (address, Scan);
  545.       address = (SCHEME_ADDR_TO_OLD_DATUM (address));
  546.       address = ((long) (RELOCATE (address)));
  547.       STORE_CLOSURE_ENTRY_ADDRESS ((ADDR_TO_SCHEME_ADDR (address)), Scan);
  548.     }
  549.     END_CLOSURE_RELOCATION (area_end);
  550.     Scan = (area_end + 1);
  551.     break;
  552.       }
  553.  
  554. #ifdef BYTE_INVERSION
  555.       case TC_CHARACTER_STRING:
  556.     String_Inversion (RELOCATE (OBJECT_DATUM (Temp)));
  557.     goto normal_pointer;
  558. #endif
  559.  
  560.       case TC_REFERENCE_TRAP:
  561.     if ((OBJECT_DATUM (Temp)) <= TRAP_MAX_IMMEDIATE)
  562.     {
  563.       Scan += 1;
  564.       break;
  565.     }
  566.     /* It is a pointer, fall through. */
  567.  
  568.           /* Compiled entry points and stack environments work automagically. */
  569.     /* This should be more strict. */
  570.  
  571.       default:
  572. #ifdef BYTE_INVERSION
  573.       normal_pointer:
  574. #endif
  575.     address = (OBJECT_DATUM (Temp));
  576.     *Scan++ = (MAKE_POINTER_OBJECT ((OBJECT_TYPE (Temp)),
  577.                     (RELOCATE (address))));
  578.     break;
  579.       }
  580.   }
  581.   return;
  582. }
  583.  
  584. static Boolean
  585. DEFUN (check_primitive_numbers, (table, length),
  586.        fast SCHEME_OBJECT * table AND fast long length)
  587. {
  588.   fast long count;
  589.  
  590.   for (count = 0; count < length; count += 1)
  591.     if (table[count] != (MAKE_PRIMITIVE_OBJECT (count)))
  592.       return (false);
  593.   return (true);
  594. }
  595.  
  596. extern void EXFUN (get_band_parameters, (long * heap_size, long * const_size));
  597.  
  598. void
  599. DEFUN (get_band_parameters, (heap_size, const_size),
  600.        long * heap_size AND long * const_size)
  601. {
  602.   /* This assumes we have just aborted out of a band load. */
  603.   (*heap_size) = Heap_Count;
  604.   (*const_size) = Const_Count;
  605. }
  606.  
  607. static void
  608. DEFUN (Intern_Block, (Next_Pointer, Stop_At),
  609.        fast SCHEME_OBJECT * Next_Pointer AND fast SCHEME_OBJECT * Stop_At)
  610. {
  611.   if (Reloc_Debug)
  612.   {
  613.     outf_console ("Interning a block.\n");
  614.   }
  615.  
  616.   while (Next_Pointer < Stop_At)
  617.   {
  618.     switch (OBJECT_TYPE (*Next_Pointer))
  619.     {
  620.       case TC_MANIFEST_NM_VECTOR:
  621.         Next_Pointer += (1 + (OBJECT_DATUM (* Next_Pointer)));
  622.         break;
  623.  
  624.       case TC_INTERNED_SYMBOL:
  625.     if ((OBJECT_TYPE (MEMORY_REF (*Next_Pointer, SYMBOL_GLOBAL_VALUE))) ==
  626.         TC_BROKEN_HEART)
  627.     {
  628.       SCHEME_OBJECT old_symbol = (*Next_Pointer);
  629.       MEMORY_SET (old_symbol, SYMBOL_GLOBAL_VALUE, UNBOUND_OBJECT);
  630.       {
  631.         SCHEME_OBJECT new_symbol = (intern_symbol (old_symbol));
  632.         if (new_symbol != old_symbol)
  633.           {
  634.         (*Next_Pointer) = new_symbol;
  635.         MEMORY_SET
  636.           (old_symbol,
  637.            SYMBOL_NAME,
  638.            (OBJECT_NEW_TYPE (TC_BROKEN_HEART, new_symbol)));
  639.           }
  640.       }
  641.     }
  642.     else if ((OBJECT_TYPE (MEMORY_REF (*Next_Pointer, SYMBOL_NAME))) ==
  643.         TC_BROKEN_HEART)
  644.     {
  645.       *Next_Pointer =
  646.         (MAKE_OBJECT_FROM_OBJECTS
  647.          ((*Next_Pointer),
  648.           (FAST_MEMORY_REF ((*Next_Pointer), SYMBOL_NAME))));
  649.     }
  650.     Next_Pointer += 1;
  651.     break;
  652.  
  653.       default:
  654.     Next_Pointer += 1;
  655.     break;
  656.     }
  657.   }
  658.   if (Reloc_Debug)
  659.   {
  660.     outf_console ("Done interning block.\n");
  661.   }
  662.   return;
  663. }
  664.  
  665. /* This should be moved to config.h! */
  666.  
  667. #ifndef COMPUTE_RELOCATION
  668. #define COMPUTE_RELOCATION(new, old) (((relocation_type) (new)) - (old))
  669. #endif
  670.  
  671. static SCHEME_OBJECT
  672. DEFUN (load_file, (mode), int mode)
  673. {
  674.   SCHEME_OBJECT
  675.     * Orig_Heap,
  676.     * Constant_End, * Orig_Constant,
  677.     * temp, * primitive_table, * c_code_table;
  678.  
  679.   /* Read File */
  680.  
  681. #ifdef ENABLE_DEBUGGING_TOOLS
  682.   Warned = false;
  683. #endif
  684.  
  685.   load_renumber_table = Free;
  686.   Free += Primitive_Table_Length;
  687.   ALIGN_FLOAT (Free);
  688.   Orig_Heap = Free;
  689.   Orig_Constant = Free_Constant;
  690.   read_file_end (mode, &primitive_table, &c_code_table);
  691.   Constant_End = Free_Constant;
  692.   heap_relocation = (COMPUTE_RELOCATION (Orig_Heap, Heap_Base));
  693.  
  694.   /*
  695.     Magic!
  696.     The relocation of compiled code entry points depends on the fact
  697.     that fasdump never dumps the compiler utilities vector (which
  698.     contains entry points used by compiled code to invoke microcode
  699.     provided utilities, like return_to_interpreter).
  700.  
  701.     If the file is not a band, any pointers into constant space are
  702.     pointers into the compiler utilities vector.  const_relocation is
  703.     computed appropriately.
  704.  
  705.     Otherwise (the file is a band, and only bands can contain constant
  706.     space segments) the utilities vector stuff is relocated
  707.     automagically: the utilities vector is part of the band.
  708.    */
  709.  
  710.   if ((! band_p) && (dumped_utilities != SHARP_F))
  711.   {
  712.     if (compiler_utilities == SHARP_F)
  713.       signal_error_from_primitive (ERR_FASLOAD_COMPILED_MISMATCH);
  714.  
  715.     const_relocation =
  716.       (COMPUTE_RELOCATION ((OBJECT_ADDRESS (compiler_utilities)),
  717.                (OBJECT_DATUM (dumped_utilities))));
  718.     Dumped_Constant_Top =
  719.       (ADDRESS_TO_DATUM
  720.        (MEMORY_LOC (dumped_utilities,
  721.             (1 + (VECTOR_LENGTH (compiler_utilities))))));
  722.   }
  723.   else
  724.     const_relocation = (COMPUTE_RELOCATION (Orig_Constant, Const_Base));
  725.   stack_relocation = (COMPUTE_RELOCATION (Stack_Top, Dumped_Stack_Top));
  726.  
  727. #ifdef BYTE_INVERSION
  728.   Setup_For_String_Inversion ();
  729. #endif
  730.  
  731.   /* Setup the primitive and C code tables */
  732.  
  733.   install_primitive_table (primitive_table, Primitive_Table_Length);
  734.   if ((mode == MODE_BAND)
  735.       && (! (install_c_code_table (c_code_table, C_Code_Table_Length))))
  736.     signal_error_from_primitive (ERR_FASLOAD_COMPILED_MISMATCH);
  737.  
  738.   if ((mode != MODE_BAND)
  739.       || (heap_relocation != ((relocation_type) 0))
  740.       || (const_relocation != ((relocation_type) 0))
  741.       || (stack_relocation != ((relocation_type) 0))
  742.       || (! (check_primitive_numbers (load_renumber_table,
  743.                       Primitive_Table_Length))))
  744.   {
  745.     /* We need to relocate.  Oh well. */
  746.     if (Reloc_Debug)
  747.       outf_console
  748.     ("heap_relocation = %ld = %lx; const_relocation = %ld = %lx\n",
  749.      ((long) heap_relocation), ((long) heap_relocation),
  750.      ((long) const_relocation), ((long) const_relocation));
  751.  
  752.     /*
  753.       Relocate the new data.
  754.  
  755.       There are no pointers in the primitive table, thus
  756.       there is no need to relocate it.
  757.       */
  758.  
  759.     Relocate_Block (Orig_Heap, primitive_table);
  760.     Relocate_Block (Orig_Constant, Constant_End);
  761.   }
  762.  
  763. #ifdef BYTE_INVERSION
  764.   Finish_String_Inversion ();
  765. #endif
  766.  
  767.   if (mode != MODE_BAND)
  768.   {
  769.     /* Again, there are no symbols in the primitive table. */
  770.  
  771.     Intern_Block (Orig_Heap, primitive_table);
  772.     Intern_Block (Orig_Constant, Constant_End);
  773.   }
  774.  
  775. #ifdef PUSH_D_CACHE_REGION
  776.   if (dumped_interface_version != 0)
  777.   {
  778.     if (primitive_table != Orig_Heap)
  779.       PUSH_D_CACHE_REGION (Orig_Heap, (primitive_table - Orig_Heap));
  780.     if (Constant_End != Orig_Constant)
  781.       PUSH_D_CACHE_REGION (Orig_Constant, (Constant_End - Orig_Constant));
  782.   }
  783. #endif
  784.  
  785.   FASLOAD_RELOCATE_HOOK (Orig_Heap, primitive_table,
  786.              Orig_Constant, Constant_End);
  787.   RELOCATE_INTO (temp, Dumped_Object);
  788.   return (* temp);
  789. }
  790.  
  791. /* (BINARY-FASLOAD FILE-NAME-OR-CHANNEL)
  792.    Load the contents of FILE-NAME-OR-CHANNEL into memory.  The file
  793.    was presumably made by a call to PRIMITIVE-FASDUMP, and may contain
  794.    data for the heap and/or the pure area.  The value returned is the
  795.    object which was dumped.  Typically (but not always) this will be a
  796.    piece of SCode which is then evaluated to perform definitions in
  797.    some environment.
  798.    If a file name is given, the corresponding file is opened before
  799.    loading and closed after loading.  A channel remains open.
  800. */
  801.  
  802. DEFINE_PRIMITIVE ("BINARY-FASLOAD", Prim_binary_fasload, 1, 1, 0)
  803. {
  804.   SCHEME_OBJECT arg, result;
  805.   PRIMITIVE_HEADER (1);
  806.   
  807.   PRIMITIVE_CANONICALIZE_CONTEXT();
  808.   arg = (ARG_REF (1));
  809.   if (STRING_P (arg))
  810.   {
  811.     read_file_start ((STRING_ARG (1)), false);
  812.     result = (load_file (MODE_FNAME));
  813.   }
  814.   else
  815.   {
  816.     read_channel_start ((arg_channel (1)), MODE_CHANNEL);
  817.     result = (load_file (MODE_CHANNEL));
  818.   }
  819. #ifdef AUTOCLOBBER_BUG
  820.   *Free = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR,
  821.             ((PAGE_SIZE / (sizeof (SCHEME_OBJECT)))
  822.              - 1)));
  823.   Free += (PAGE_SIZE / (sizeof (SCHEME_OBJECT)));
  824. #endif
  825.   PRIMITIVE_RETURN (result);
  826. }
  827.  
  828. SCHEME_OBJECT
  829. DEFUN (continue_fasload, (reentry_record), SCHEME_OBJECT * reentry_record)
  830. {
  831.   SCHEME_OBJECT header;
  832.  
  833.   /* The reentry record was prepared by read_channel_continue above. */
  834.  
  835.   load_channel = (arg_channel (1));
  836.   header = (reentry_record[0]);
  837.   read_channel_continue ((VECTOR_LOC (header, 0)), MODE_CHANNEL, true);
  838.   PRIMITIVE_RETURN (load_file (MODE_CHANNEL));
  839. }
  840.  
  841. /* Band loading. */
  842.  
  843. static char *reload_band_name = 0;
  844. static Tptrvec reload_cleanups = 0;
  845.  
  846. DEFINE_PRIMITIVE ("RELOAD-BAND-NAME", Prim_reload_band_name, 0, 0,
  847.   "Return the filename from which the runtime system was last restored.\n\
  848. The result is a string, or #F if the system was not restored.")
  849. {
  850.   PRIMITIVE_HEADER (0);
  851.   PRIMITIVE_RETURN
  852.     ((reload_band_name != 0)
  853.      ? (char_pointer_to_string ((unsigned char *) reload_band_name))
  854.      : (option_band_file != 0)
  855.      ? (char_pointer_to_string ((unsigned char *) option_band_file))
  856.      : SHARP_F);
  857. }
  858.  
  859. typedef void EXFUN ((*Tcleanup), (void));
  860.  
  861. void
  862. DEFUN (add_reload_cleanup, (cleanup_procedure), Tcleanup cleanup_procedure)
  863. {
  864.   if (reload_cleanups == 0)
  865.     {
  866.       reload_cleanups = (ptrvec_allocate (1));
  867.       (* ((Tcleanup *) (PTRVEC_LOC (reload_cleanups, 0)))) = cleanup_procedure;
  868.     }
  869.   else
  870.     ptrvec_adjoin (reload_cleanups, (PTR) cleanup_procedure);
  871. }
  872.  
  873. void
  874. DEFUN_VOID (execute_reload_cleanups)
  875. {
  876.   PTR * scan = (PTRVEC_START (reload_cleanups));
  877.   PTR * end = (PTRVEC_END (reload_cleanups));
  878.   while (scan < end)
  879.     (* ((Tcleanup *) (scan++))) ();
  880. }
  881.  
  882. /* Utility for load band below. */
  883.  
  884. void
  885. DEFUN_VOID (compiler_reset_error)
  886. {
  887.   outf_fatal ("\ncompiler_reset_error: The band being restored and\n");
  888.   outf_fatal
  889.     ("the compiled code interface in this microcode are inconsistent.\n");
  890.   Microcode_Termination (TERM_COMPILER_DEATH);
  891. }
  892.  
  893. #ifndef START_BAND_LOAD
  894. #define START_BAND_LOAD() do                        \
  895. {                                    \
  896.   ENTER_CRITICAL_SECTION ("band load");                    \
  897. } while (0)
  898. #endif
  899.  
  900. #ifndef END_BAND_LOAD
  901. #define END_BAND_LOAD(success, dying) do                \
  902. {                                    \
  903.   if (success || dying)                            \
  904.     execute_reload_cleanups ();                        \
  905.   EXIT_CRITICAL_SECTION ({});                        \
  906. } while (0)
  907. #endif
  908.  
  909. struct memmag_state
  910. {
  911.   SCHEME_OBJECT * heap_bottom;
  912.   SCHEME_OBJECT * heap_top;
  913.   SCHEME_OBJECT * unused_heap_bottom;
  914.   SCHEME_OBJECT * unused_heap_top;
  915.   SCHEME_OBJECT * free;
  916.   SCHEME_OBJECT * memtop;
  917.   SCHEME_OBJECT * constant_space;
  918.   SCHEME_OBJECT * constant_top;
  919.   SCHEME_OBJECT * free_constant;
  920.   SCHEME_OBJECT * stack_pointer;
  921.   SCHEME_OBJECT * stack_bottom;
  922.   SCHEME_OBJECT * stack_top;
  923.   SCHEME_OBJECT * stack_guard;
  924. };
  925.  
  926. static void
  927. DEFUN (abort_band_load, (ap), PTR ap)
  928. {
  929.   struct memmag_state * mp = ((struct memmag_state *) ap);
  930.  
  931.   Heap_Bottom = mp->heap_bottom;
  932.   Heap_Top = mp->heap_top;
  933.   Unused_Heap_Bottom = mp->unused_heap_bottom;
  934.   Unused_Heap_Top = mp->unused_heap_top;
  935.   Free = mp->free;
  936.   Free_Constant = mp->free_constant;
  937.   Constant_Space = mp->constant_space;
  938.   Constant_Top = mp->constant_top;
  939.   Stack_Pointer = mp->stack_pointer;
  940.   Stack_Bottom = mp->stack_bottom;
  941.   Stack_Top = mp->stack_top;
  942.   Stack_Guard = mp->stack_guard;
  943.   SET_MEMTOP (mp->memtop);
  944.  
  945.   END_BAND_LOAD (false, false);
  946.   return;
  947. }
  948.  
  949. static void
  950. DEFUN (terminate_band_load, (ap), PTR ap)
  951. {
  952.   fputs ("\nload-band: ", stderr);
  953.   {
  954.     int abort_value = (abort_to_interpreter_argument ());
  955.     if (abort_value > 0)
  956.       outf_fatal ("Error %ld (%s)",
  957.            ((long) abort_value),
  958.            (Error_Names [abort_value]));
  959.     else
  960.       outf_fatal ("Abort %ld (%s)",
  961.            ((long) abort_value),
  962.            (Abort_Names [(-abort_value) - 1]));
  963.   }
  964.   outf_fatal (" past the point of no return.\n");
  965.   {
  966.     char * band_name = (* ((char **) ap));
  967.     if (band_name != 0)
  968.       {
  969.     outf_fatal ("band-name = \"%s\".\n", band_name);
  970.     free (band_name);
  971.       }
  972.   }
  973.   END_BAND_LOAD (false, true);
  974.   Microcode_Termination (TERM_DISK_RESTORE);
  975.   /*NOTREACHED*/
  976. }
  977.  
  978. /* (LOAD-BAND FILE-NAME)
  979.    Restores the heap and pure space from the contents of FILE-NAME,
  980.    which is typically a file created by DUMP-BAND.  The file can,
  981.    however, be any file which can be loaded with BINARY-FASLOAD.
  982. */
  983.  
  984. DEFINE_PRIMITIVE ("LOAD-BAND", Prim_band_load, 1, 1, 0)
  985. {
  986.   extern void EXFUN (reset_allocator_parameters, (void));
  987.   SCHEME_OBJECT result;
  988.   PRIMITIVE_HEADER (1);
  989.   PRIMITIVE_CANONICALIZE_CONTEXT ();
  990.  
  991.   {
  992.     CONST char * file_name = (STRING_ARG (1));
  993.     transaction_begin ();
  994.     {
  995.       struct memmag_state * mp = (dstack_alloc (sizeof (struct memmag_state)));
  996.  
  997.       mp->heap_bottom = Heap_Bottom;
  998.       mp->heap_top = Heap_Top;
  999.       mp->unused_heap_bottom = Unused_Heap_Bottom;
  1000.       mp->unused_heap_top = Unused_Heap_Top;
  1001.       mp->free = Free;
  1002.       mp->memtop = MemTop;
  1003.       mp->free_constant = Free_Constant;
  1004.       mp->constant_space = Constant_Space;
  1005.       mp->constant_top = Constant_Top;
  1006.       mp->stack_pointer = Stack_Pointer;
  1007.       mp->stack_bottom = Stack_Bottom;
  1008.       mp->stack_top = Stack_Top;
  1009.       mp->stack_guard = Stack_Guard;
  1010.       transaction_record_action (tat_abort, abort_band_load, mp);
  1011.     }  
  1012.  
  1013.     reset_allocator_parameters ();
  1014.     SET_MEMTOP (Heap_Top);
  1015.     START_BAND_LOAD ();
  1016.     read_file_start (file_name, true);
  1017.     transaction_commit ();
  1018.  
  1019.     /* Point of no return. */
  1020.     {
  1021.       long length = ((strlen (file_name)) + 1);
  1022.       char * band_name = (malloc (length));
  1023.       if (band_name != 0)
  1024.     strcpy (band_name, file_name);
  1025.       transaction_begin ();
  1026.       {
  1027.     char ** ap = (dstack_alloc (sizeof (char *)));
  1028.     (*ap) = band_name;
  1029.     transaction_record_action (tat_abort, terminate_band_load, ap);
  1030.       }
  1031.       result = (load_file (MODE_BAND));
  1032.       transaction_commit ();
  1033.       if (reload_band_name != 0)
  1034.     free (reload_band_name);
  1035.       reload_band_name = band_name;
  1036.     }
  1037.   }
  1038.   /* Reset implementation state paramenters */
  1039.   INITIALIZE_INTERRUPTS ();
  1040.   INITIALIZE_STACK ();
  1041.   SET_MEMTOP (Heap_Top - GC_Reserve);
  1042.   {
  1043.     SCHEME_OBJECT cutl = (MEMORY_REF (result, 1));
  1044.     if (cutl != SHARP_F)
  1045.       {
  1046.     compiler_utilities = cutl;
  1047.     compiler_reset (cutl);
  1048.       }
  1049.     else
  1050.       compiler_initialize (true);
  1051.   }
  1052.   /* Until the continuation is invoked. */
  1053.   SET_INTERRUPT_MASK (0);
  1054.   Restore_Fixed_Obj (SHARP_F);
  1055.   Fluid_Bindings = EMPTY_LIST;
  1056.   Current_State_Point = SHARP_F;
  1057.   /* Setup initial program */
  1058.   Store_Return (RC_END_OF_COMPUTATION);
  1059.   Store_Expression (SHARP_F);
  1060.   Save_Cont ();
  1061.   Store_Expression (MEMORY_REF (result, 0));
  1062.   Store_Env (MAKE_OBJECT (GLOBAL_ENV, GO_TO_GLOBAL));
  1063.   /* Clear various interpreter state parameters. */
  1064.   Trapping = false;
  1065.   Return_Hook_Address = 0;
  1066.   History = (Make_Dummy_History ());
  1067.   Prev_Restore_History_Stacklet = 0;
  1068.   Prev_Restore_History_Offset = 0;
  1069.   COMPILER_TRANSPORT_END ();
  1070.   END_BAND_LOAD (true, false);
  1071.   Band_Load_Hook ();
  1072.   /* Return in a non-standard way. */
  1073.   PRIMITIVE_ABORT (PRIM_DO_EXPRESSION);
  1074.   /*NOTREACHED*/
  1075.   PRIMITIVE_RETURN (UNSPECIFIC);
  1076. }
  1077.  
  1078. #ifdef BYTE_INVERSION
  1079.  
  1080. #define MAGIC_OFFSET (TC_FIXNUM + 1)
  1081.  
  1082. SCHEME_OBJECT String_Chain, Last_String;
  1083.  
  1084. void
  1085. DEFUN_VOID (Setup_For_String_Inversion)
  1086. {
  1087.   String_Chain = SHARP_F;
  1088.   Last_String = SHARP_F;
  1089.   return;
  1090. }
  1091.  
  1092. void
  1093. DEFUN_VOID (Finish_String_Inversion)
  1094. {
  1095.   if (Byte_Invert_Fasl_Files)
  1096.     while (String_Chain != SHARP_F)
  1097.     {
  1098.       long Count;
  1099.       SCHEME_OBJECT Next;
  1100.  
  1101.       Count = OBJECT_DATUM (FAST_MEMORY_REF (String_Chain, STRING_HEADER));
  1102.       Count = 4 * (Count - 2) + (OBJECT_TYPE (String_Chain)) - MAGIC_OFFSET;
  1103.       if (Reloc_Debug)
  1104.       {
  1105.     outf_console ("String at 0x%lx: restoring length of %ld.\n",
  1106.         ((long) (OBJECT_ADDRESS (String_Chain))),
  1107.         ((long) Count));
  1108.       }
  1109.       Next = (STRING_LENGTH (String_Chain));
  1110.       SET_STRING_LENGTH (String_Chain, Count);
  1111.       String_Chain = Next;
  1112.     }
  1113.   return;
  1114. }
  1115.  
  1116. #define print_char(C) outf_console (((C < ' ') || (C > '|')) ?    \
  1117.                   "\\%03o" : "%c", (C && UCHAR_MAX));
  1118.  
  1119. void
  1120. DEFUN (String_Inversion, (Orig_Pointer), SCHEME_OBJECT * Orig_Pointer)
  1121. {
  1122.   SCHEME_OBJECT *Pointer_Address;
  1123.   char *To_Char;
  1124.   long Code;
  1125.  
  1126.   if (!Byte_Invert_Fasl_Files)
  1127.     return;
  1128.  
  1129.   Code = OBJECT_TYPE (Orig_Pointer[STRING_LENGTH_INDEX]);
  1130.   if (Code == 0)    /* Already reversed? */
  1131.   {
  1132.     long Count, old_size, new_size, i;
  1133.  
  1134.     old_size = (OBJECT_DATUM (Orig_Pointer[STRING_HEADER]));
  1135.     new_size =
  1136.       2 + (((long) (Orig_Pointer[STRING_LENGTH_INDEX]))) / 4;
  1137.  
  1138.     if (Reloc_Debug)
  1139.     {
  1140.       outf_console ("\nString at 0x%lx with %ld characters",
  1141.           ((long) Orig_Pointer),
  1142.           ((long) (Orig_Pointer[STRING_LENGTH_INDEX])));
  1143.     }
  1144.  
  1145.     if (old_size != new_size)
  1146.     {
  1147.       outf_fatal ("\nWord count changed from %ld to %ld: ",
  1148.               ((long) old_size), ((long) new_size));
  1149.       outf_fatal ("\nWhich, of course, is impossible!!\n");
  1150.       Microcode_Termination (TERM_EXIT);
  1151.     }
  1152.  
  1153.     Count = ((long) (Orig_Pointer[STRING_LENGTH_INDEX])) % 4;
  1154.     if (Count == 0)
  1155.       Count = 4;
  1156.     if (Last_String == SHARP_F)
  1157.       String_Chain = MAKE_POINTER_OBJECT (Count + MAGIC_OFFSET, Orig_Pointer);
  1158.     else
  1159.       FAST_MEMORY_SET
  1160.     (Last_String, STRING_LENGTH_INDEX,
  1161.      (MAKE_POINTER_OBJECT ((Count + MAGIC_OFFSET), Orig_Pointer)));
  1162.  
  1163.     Last_String = (MAKE_POINTER_OBJECT (TC_NULL, Orig_Pointer));
  1164.     Orig_Pointer[STRING_LENGTH_INDEX] = SHARP_F;
  1165.     Count = (OBJECT_DATUM (Orig_Pointer[STRING_HEADER])) - 1;
  1166.     if (Reloc_Debug)
  1167.        outf_console ("\nCell count = %ld\n", ((long) Count));
  1168.     Pointer_Address = &(Orig_Pointer[STRING_CHARS]);
  1169.     To_Char = (char *) Pointer_Address;
  1170.     for (i = 0; i < Count; i++, Pointer_Address++)
  1171.     {
  1172.       int C1, C2, C3, C4;
  1173.  
  1174.       C4 = OBJECT_TYPE (*Pointer_Address) & 0xFF;
  1175.       C3 = (((long) *Pointer_Address)>>16) & 0xFF;
  1176.       C2 = (((long) *Pointer_Address)>>8) & 0xFF;
  1177.       C1 = ((long) *Pointer_Address) & 0xFF;
  1178.       if (Reloc_Debug || (old_size != new_size))
  1179.       {
  1180.     print_char(C1);
  1181.         print_char(C2);
  1182.         print_char(C3);
  1183.         print_char(C4);
  1184.       }
  1185.       *To_Char++ = C1;
  1186.       *To_Char++ = C2;
  1187.       *To_Char++ = C3;
  1188.       *To_Char++ = C4;
  1189.     }
  1190.   }
  1191.   if (Reloc_Debug)
  1192.     outf_console ("\n");
  1193.   return;
  1194. }
  1195. #endif /* BYTE_INVERSION */
  1196.