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 / ppband.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  12KB  |  506 lines
  1. /* -*-C-*-
  2.  
  3. $Id: ppband.c,v 9.50 2000/12/05 21:23:47 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. /* Dumps Scheme FASL in user-readable form. */
  23.  
  24. #include <stdio.h>
  25. #include <ctype.h>
  26. #include "config.h"
  27. #include "errors.h"
  28. #include "types.h"
  29. #include "const.h"
  30. #include "object.h"
  31. #include "gccode.h"
  32. #include "sdata.h"
  33.  
  34. #define fast register
  35.  
  36. #undef HEAP_MALLOC
  37. #define HEAP_MALLOC malloc
  38.  
  39. /* These are needed when there is no compiler support. */
  40.  
  41. extern void EXFUN (gc_death,
  42.            (long code, char *, SCHEME_OBJECT *, SCHEME_OBJECT *));
  43.  
  44. extern char
  45.   gc_death_message_buffer[];
  46.  
  47. void
  48. DEFUN (gc_death, (code, message, scan, free),
  49.        long code AND char * message
  50.        AND SCHEME_OBJECT * scan AND SCHEME_OBJECT * free)
  51. {
  52.   fprintf (stderr, "gc_death: %s.\n", message);
  53.   exit (1);
  54. }
  55.  
  56. /* These are needed by load.c */
  57.  
  58. static SCHEME_OBJECT * memory_base;
  59.  
  60. #ifdef OS2
  61.  
  62. #include <fcntl.h>
  63. #include <io.h>
  64. #include <sys\types.h>
  65.  
  66. #define fread OS2_fread
  67. extern off_t EXFUN (OS2_fread, (char *, unsigned int, off_t, FILE *));
  68.  
  69. #define fwrite OS2_fwrite
  70. extern off_t EXFUN (OS2_fwrite, (char *, unsigned int, off_t, FILE *));
  71.  
  72. #endif /* OS2 */
  73.  
  74. long
  75. DEFUN (Load_Data, (Count, To_Where), long Count AND SCHEME_OBJECT *To_Where)
  76. {
  77. #ifdef OS2
  78.   setmode ((fileno (stdin)), O_BINARY);
  79. #endif /* OS2 */
  80.  
  81.   return (fread (((char *) To_Where),
  82.          (sizeof (SCHEME_OBJECT)),
  83.          Count,
  84.          stdin));
  85. }
  86.  
  87. #define INHIBIT_COMPILED_VERSION_CHECK
  88. #define INHIBIT_CHECKSUMS
  89. #include "load.c"
  90.  
  91. #ifdef HEAP_IN_LOW_MEMORY
  92. #if defined(hp9000s800) || defined(__hp9000s800)
  93. #  define File_To_Pointer(P)                        \
  94.     ((((long) (P)) & DATUM_MASK) / (sizeof (SCHEME_OBJECT)))
  95. #else
  96. #  define File_To_Pointer(P) ((P) / (sizeof (SCHEME_OBJECT)))
  97. #endif /* hp9000s800 */
  98. #else
  99. #  define File_To_Pointer(P) (P)
  100. #endif
  101.  
  102. #ifndef Conditional_Bug
  103. #  define Relocate(P)                            \
  104.     (((long) (P) < Const_Base) ?                    \
  105.      (File_To_Pointer (((long) (P)) - Heap_Base)) :            \
  106.      (Heap_Count + (File_To_Pointer (((long) (P)) - Const_Base))))
  107. #else
  108. #  define Relocate_Into(What, P)                    \
  109. if (((long) (P)) < Const_Base)                        \
  110.   (What) = (File_To_Pointer (((long) (P)) - Heap_Base));        \
  111. else                                    \
  112.   (What) = Heap_Count + (File_To_Pointer (((long) P) - Const_Base));
  113.  
  114. static long Relocate_Temp;
  115. #  define Relocate(P)    (Relocate_Into (Relocate_Temp, P), Relocate_Temp)
  116. #endif
  117.  
  118. static SCHEME_OBJECT *Data, *end_of_memory;
  119.  
  120. void
  121. DEFUN (print_long_as_string, (string), char *string)
  122. {
  123.   int i;
  124.   char *temp;
  125.   unsigned char c;
  126.  
  127.   temp = string;
  128.   putchar ('"');
  129.   for (i = 0; i < (sizeof (long)); i++)
  130.   {
  131.     c = *temp++;
  132.     if (isgraph ((int) c))
  133.       putchar (c);
  134.     else
  135.       putchar (' ');
  136.   }
  137.   printf ("\" = ");
  138.  
  139.   temp = string;
  140.   for (i = 0; i < (sizeof (long)); i++)
  141.   {
  142.     c = *temp++;
  143.     if (isgraph ((int) c))
  144.     {
  145.       printf ("    ");
  146.       putchar (c);
  147.     }
  148.     else
  149.     {
  150.       switch (c)
  151.       {
  152.     case '\0':
  153.       printf ("   \\0");
  154.       break;
  155.  
  156.     case ' ':
  157.       printf ("     ");
  158.       break;
  159.  
  160. #ifdef __STDC__
  161.     case '\a':
  162. #else
  163.     case '\007':
  164. #endif
  165.       printf ("   \\a");
  166.       break;
  167.  
  168.     case '\b':
  169.       printf ("   \\b");
  170.       break;
  171.  
  172.     case '\f':
  173.       printf ("   \\f");
  174.       break;
  175.  
  176.     case '\n':
  177.       printf ("   \\n");
  178.       break;
  179.  
  180.     case '\r':
  181.       printf ("   \\r");
  182.       break;
  183.  
  184.     case '\t':
  185.       printf ("   \\t");
  186.       break;
  187.  
  188.     case '\v':
  189.       printf ("   \\v");
  190.       break;
  191.  
  192.     default:
  193.       printf (" \\%03o", c);
  194.       break;
  195.       }
  196.     }
  197.   }
  198.   return;
  199. }
  200.  
  201. Boolean
  202. DEFUN (scheme_string, (From, Quoted), long From AND Boolean Quoted)
  203. {
  204.   fast long i, Count;
  205.   fast char *Chars;
  206.  
  207.   Chars = ((char *) &Data[From +  STRING_CHARS]);
  208.   if ((Chars < ((char *) end_of_memory))
  209.       && (Chars >= ((char *) Data)))
  210.   {
  211.     Count = ((long) (Data[From + STRING_LENGTH_INDEX]));
  212.     if (&Chars[Count] < ((char *) end_of_memory))
  213.     {
  214.       if (Quoted)
  215.     putchar ('\"');
  216.       for (i = 0; i < Count; i++)
  217.     printf ("%c", *Chars++);
  218.       if (Quoted)
  219.     putchar ('\"');
  220.       putchar ('\n');
  221.       return (true);
  222.     }
  223.   }
  224.   if (Quoted)
  225.     printf ("String not in memory; datum = %lx\n", From);
  226.   return (false);
  227. }
  228.  
  229. #define via(File_Address) Relocate (OBJECT_DATUM (Data[File_Address]))
  230.  
  231. void
  232. DEFUN (scheme_symbol, (From), long From)
  233. {
  234.   SCHEME_OBJECT *symbol;
  235.  
  236.   symbol = &Data[From+SYMBOL_NAME];
  237.   if ((symbol >= end_of_memory) ||
  238.       (!(scheme_string (via (From + SYMBOL_NAME), false))))
  239.     printf ("symbol not in memory; datum = %lx\n", From);
  240.   return;
  241. }
  242.  
  243. static char string_buffer[10];
  244.  
  245. #define PRINT_OBJECT(type, datum) do                    \
  246. {                                    \
  247.   printf ("[%s %lx]", type, datum);                    \
  248. } while (0)
  249.  
  250. #define NON_POINTER(string) do                        \
  251. {                                    \
  252.   the_string = string;                            \
  253.   Points_To = The_Datum;                        \
  254.   break;                                \
  255. } while (0)
  256.  
  257. #define POINTER(string) do                        \
  258. {                                    \
  259.   the_string = string;                            \
  260.   break;                                \
  261. } while (0)
  262.  
  263. char *Type_Names[] = TYPE_NAME_TABLE;
  264.  
  265. void
  266. DEFUN (Display, (Location, Type, The_Datum),
  267.                  long Location AND
  268.                  long Type AND
  269.                  long The_Datum)
  270. {
  271.   char string_buf[100];
  272.   char *the_string;
  273.   long Points_To;
  274.  
  275.   printf ("%5lx: %2lx|%6lx     ", Location, Type, The_Datum);
  276.   Points_To = Relocate ((SCHEME_OBJECT *) The_Datum);
  277.  
  278.   switch (Type)
  279.   { /* "Strange" cases */
  280.     case TC_NULL:
  281.       if (The_Datum == 0)
  282.       {
  283.     printf ("#F\n");
  284.     return;
  285.       }
  286.       NON_POINTER ("NULL");
  287.  
  288.     case TC_CONSTANT:
  289.       if (The_Datum == 0)
  290.       {
  291.     printf ("#T\n");
  292.     return;
  293.       }
  294.       /* fall through */
  295.  
  296.  
  297.     case TC_CHARACTER:
  298.     case TC_RETURN_CODE:
  299.     case TC_PRIMITIVE:
  300.     case TC_THE_ENVIRONMENT:
  301.     case TC_PCOMB0:
  302.     case TC_MANIFEST_SPECIAL_NM_VECTOR:
  303.     case TC_MANIFEST_NM_VECTOR:
  304.       NON_POINTER (Type_Names[Type]);
  305.  
  306.     case TC_INTERNED_SYMBOL:
  307.       PRINT_OBJECT ("INTERNED-SYMBOL", Points_To);
  308.       printf (" = ");
  309.       scheme_symbol (Points_To);
  310.       return;
  311.  
  312.     case TC_UNINTERNED_SYMBOL:
  313.       PRINT_OBJECT ("UNINTERNED-SYMBOL", Points_To);
  314.       printf (" = ");
  315.       scheme_symbol (Points_To);
  316.       return;
  317.  
  318.     case TC_CHARACTER_STRING:
  319.       PRINT_OBJECT ("CHARACTER-STRING", Points_To);
  320.       printf (" = ");
  321.       scheme_string (Points_To, true);
  322.       return;
  323.  
  324.     case TC_FIXNUM:
  325.       PRINT_OBJECT ("FIXNUM", The_Datum);
  326.       Points_To = (FIXNUM_TO_LONG ((MAKE_OBJECT (Type, The_Datum))));
  327.       printf (" = %ld\n", Points_To);
  328.       return;
  329.  
  330.     case TC_REFERENCE_TRAP:
  331.       if (The_Datum <= TRAP_MAX_IMMEDIATE)
  332.     NON_POINTER ("REFERENCE-TRAP");
  333.       else
  334.     POINTER ("REFERENCE-TRAP");
  335.  
  336.     case TC_BROKEN_HEART:
  337.       if (The_Datum == 0)
  338.     Points_To = 0;
  339.     default:
  340.       if (Type <= LAST_TYPE_CODE)
  341.     POINTER (Type_Names[Type]);
  342.       else
  343.       {
  344.     sprintf (&string_buf[0], "0x%02lx ", Type);
  345.     POINTER (&string_buf[0]);
  346.       }
  347.   }
  348.   PRINT_OBJECT (the_string, Points_To);
  349.   putchar ('\n');
  350.   return;
  351. }
  352.  
  353. SCHEME_OBJECT *
  354. DEFUN (show_area, (area, start, end, name),
  355.        fast SCHEME_OBJECT *area AND
  356.        long start AND
  357.        fast long end AND
  358.        char *name)
  359. {
  360.   fast long i;
  361.  
  362.   printf ("\n%s contents:\n\n", name);
  363.   for (i = start; i < end;  area++, i++)
  364.   {
  365.     if (((OBJECT_TYPE (*area)) == TC_MANIFEST_NM_VECTOR) ||
  366.     ((OBJECT_TYPE (*area)) == TC_MANIFEST_CLOSURE) ||
  367.     ((OBJECT_TYPE (*area)) == TC_LINKAGE_SECTION))
  368.     {
  369.       fast long j, count;
  370.  
  371.       count =
  372.     ((OBJECT_TYPE (*area) == TC_LINKAGE_SECTION)
  373.      ? (READ_CACHE_LINKAGE_COUNT (*area))
  374.      : (OBJECT_DATUM (*area)));
  375.       Display (i, (OBJECT_TYPE (*area)), (OBJECT_DATUM (*area)));
  376.       area += 1;
  377.       for (j = 0; j < count ; j++, area++)
  378.       {
  379.         printf ("          %08lx    = ", ((unsigned long) (*area)));
  380.     print_long_as_string ((char *) area);
  381.     putchar ('\n');
  382.       }
  383.       i += count;
  384.       area -= 1;
  385.     }
  386.     else
  387.       Display (i, (OBJECT_TYPE (*area)), (OBJECT_DATUM (*area)));
  388.   }
  389.   return (area);
  390. }
  391.  
  392. void
  393. DEFUN (main, (argc, argv),
  394.        int argc AND
  395.        char **argv)
  396. {
  397.   int counter = 0;
  398.  
  399.   while (1)
  400.   {
  401.     fast SCHEME_OBJECT *Next;
  402.     long total_length, load_length;
  403.  
  404.     if (argc == 1)
  405.     {
  406.       switch (Read_Header ())
  407.       {
  408.     case FASL_FILE_FINE :
  409.       if (counter != 0)
  410.         printf ("\f\n\t*** New object ***\n\n");
  411.           break;
  412.  
  413.       /* There should really be a difference between no header
  414.          and a short header.
  415.        */
  416.  
  417.     case FASL_FILE_TOO_SHORT:
  418.       exit (0);
  419.  
  420.     default:
  421.     {
  422.       fprintf (stderr,
  423.            "%s: Input does not appear to be in correct FASL format.\n",
  424.            argv[0]);
  425.       exit (1);
  426.       /* NOTREACHED */
  427.     }
  428.       }
  429.       print_fasl_information ();
  430.       printf ("Dumped object (relocated) at 0x%lx\n",
  431.           (Relocate (Dumped_Object)));
  432.     }
  433.     else
  434.     {
  435.       Const_Count = 0;
  436.       Primitive_Table_Size = 0;
  437.       sscanf (argv[1], "%lx", ((long) &Heap_Base));
  438.       sscanf (argv[2], "%lx", ((long) &Const_Base));
  439.       sscanf (argv[3], "%ld", ((long) &Heap_Count));
  440.       printf ("Heap Base = 0x%lx; Constant Base = 0x%lx; Heap Count = %ld\n",
  441.           Heap_Base, Const_Base, Heap_Count);
  442.     }
  443.  
  444.     load_length = (Heap_Count + Const_Count + Primitive_Table_Size);
  445.     Data = ((SCHEME_OBJECT *)
  446.         (malloc (sizeof (SCHEME_OBJECT) * (load_length + 4))));
  447.     if (Data == NULL)
  448.     {
  449.       fprintf (stderr, "Allocation of %ld words failed.\n", (load_length + 4));
  450.       exit (1);
  451.     }
  452.     total_length = (Load_Data (load_length, Data));
  453.     end_of_memory = &Data[total_length];
  454.     if (total_length != load_length)
  455.     {
  456.       printf ("The FASL file does not have the right length.\n");
  457.       printf ("Expected %ld objects.  Obtained %ld objects.\n\n",
  458.           ((long) load_length), ((long) total_length));
  459.       if (total_length < Heap_Count)
  460.     Heap_Count = total_length;
  461.       total_length -= Heap_Count;
  462.       if (total_length < Const_Count)
  463.     Const_Count = total_length;
  464.       total_length -= Const_Count;
  465.       if (total_length < Primitive_Table_Size)
  466.     Primitive_Table_Size = total_length;
  467.     }
  468.  
  469.     if (Heap_Count > 0)
  470.       Next = show_area (Data, 0, Heap_Count, "Heap");
  471.     if (Const_Count > 0)
  472.       Next = show_area (Next, Heap_Count, Const_Count, "Constant Space");
  473.     if ((Primitive_Table_Size > 0) && (Next < end_of_memory))
  474.     {
  475.       long arity, size;
  476.       fast long entries, count;
  477.  
  478.       /* This is done in case the file is short. */
  479.       end_of_memory[0] = ((SCHEME_OBJECT) 0);
  480.       end_of_memory[1] = ((SCHEME_OBJECT) 0);
  481.       end_of_memory[2] = ((SCHEME_OBJECT) 0);
  482.       end_of_memory[3] = ((SCHEME_OBJECT) 0);
  483.  
  484.       entries = Primitive_Table_Length;
  485.       printf ("\nPrimitive table: number of entries = %ld\n\n", entries);
  486.  
  487.       for (count = 0;
  488.        ((count < entries) && (Next < end_of_memory));
  489.        count += 1)
  490.       {
  491.     arity = (FIXNUM_TO_LONG (*Next));
  492.     Next += 1;
  493.     size = (OBJECT_DATUM (*Next));
  494.     printf ("Number = %3lx; Arity = %2ld; Name = ", count, arity);
  495.     scheme_string ((Next - Data), true);
  496.     Next += (1 + size);
  497.       }
  498.       printf ("\n");
  499.     }
  500.     if (argc != 1)
  501.       exit (0);
  502.     free ((char *) Data);
  503.     counter = 1;
  504.   }
  505. }
  506.