home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / srcuc.zip / FINDPRIM.C < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-10  |  32.3 KB  |  1,274 lines
  1. /* -*-C-*-
  2.  
  3. $Header: /scheme/src/microcode/RCS/Findprim.c,v 9.46 1992/02/10 13:53:34 jinx Exp $
  4.  
  5. Copyright (c) 1987-1992 Massachusetts Institute of Technology
  6.  
  7. This material was developed by the Scheme project at the Massachusetts
  8. Institute of Technology, Department of Electrical Engineering and
  9. Computer Science.  Permission to copy this software, to redistribute
  10. it, and to use it for any purpose is granted, subject to the following
  11. restrictions and understandings.
  12.  
  13. 1. Any copy made of this software must include this copyright notice
  14. in full.
  15.  
  16. 2. Users of this software agree to make their best efforts (a) to
  17. return to the MIT Scheme project any improvements or extensions that
  18. they make, so that these may be included in future releases; and (b)
  19. to inform MIT of noteworthy uses of this software.
  20.  
  21. 3. All materials developed as a consequence of the use of this
  22. software shall duly acknowledge such use, in accordance with the usual
  23. standards of acknowledging credit in academic research.
  24.  
  25. 4. MIT has made no warrantee or representation that the operation of
  26. this software will be error-free, and MIT is under no obligation to
  27. provide any services, by way of maintenance, update, or otherwise.
  28.  
  29. 5. In conjunction with products arising from the use of this material,
  30. there shall be no use of the name of the Massachusetts Institute of
  31. Technology nor of any adaptation thereof in any advertising,
  32. promotional, or sales literature without prior written consent from
  33. MIT in each case. */
  34.  
  35. /* Preprocessor to find and declare defined primitives.  */
  36.  
  37. /*
  38.  * This program searches for a particular token which tags primitive
  39.  * definitions.  This token is also a macro defined in primitive.h.
  40.  * For each macro invocation it creates an entry in the primitives
  41.  * descriptor vector used by Scheme.  The entry consists of the C
  42.  * routine implementing the primitive, the (fixed) number of arguments
  43.  * it requires, and the name Scheme uses to refer to it.
  44.  *
  45.  * The output is a C source file to be compiled and linked with the
  46.  * Scheme microcode.
  47.  *
  48.  * This program understands the following options (must be given in
  49.  * this order):
  50.  *
  51.  * -o fname
  52.  *    Put the output file in fname.  The default is to put it on the
  53.  *    standard output.
  54.  *
  55.  * -e or -b n (exclusive)
  56.  *    -e: produce the old external primitive table instead of the
  57.  *    complete primitive table.
  58.  *    -b: Produce the old built-in primitive table instead of the
  59.  *    complete primitive table.  The table should have size n (in hex).
  60.  *
  61.  * -l fname
  62.  *    The list of files to examine is contained in fname, one file
  63.  *    per line.  Semicolons (';') introduce comment lines.
  64.  *
  65.  * Note that some output lines are done in a strange fashion because
  66.  * some C compilers (the vms C compiler, for example) remove comments
  67.  * even from within string quotes!!
  68.  *
  69.  */
  70.  
  71. /* Some utility imports and definitions. */
  72.  
  73. #include "ansidecl.h"
  74. #include <stdio.h>
  75.  
  76. #define ASSUME_ANSIDECL
  77.  
  78. /* For macros toupper, isalpha, etc,
  79.    supposedly on the standard library.  */
  80.  
  81. #include <ctype.h>
  82.  
  83. extern int EXFUN (strcmp, (CONST char *, CONST char *));
  84. extern int EXFUN (strlen, (CONST char *));
  85.  
  86. typedef int boolean;
  87. #define TRUE 1
  88. #define FALSE 0
  89.  
  90. #ifdef vms
  91. /* VMS version 3 has no void. */
  92. /* #define void */
  93. #  define NORMAL_EXIT() return
  94. #else
  95. #  define NORMAL_EXIT() exit(0)
  96. #endif
  97.  
  98. /* The 4.2 bsd vax compiler has a bug which forces the following. */
  99.  
  100. #define pseudo_void int
  101.  
  102. extern void EXFUN (exit, (int));
  103.  
  104. char *
  105. DEFUN (xmalloc, (length),
  106.        int length)
  107. {
  108.   char * result;
  109.   extern PTR EXFUN (malloc, (int));
  110.  
  111.   result = ((char *) (malloc (length)));
  112.   if (result == ((char *) 0))
  113.     {
  114.       fprintf (stderr, "malloc: unable to allocate %d bytes\n", length);
  115.       exit (1);
  116.     }
  117.   return (result);
  118. }
  119.  
  120. char *
  121. DEFUN (xrealloc, (ptr, length),
  122.        char * ptr AND
  123.        int length)
  124. {
  125.   char * result;
  126.   extern PTR EXFUN (realloc, (void *, int));
  127.  
  128.   result = ((char *) (realloc (ptr, length)));
  129.   if (result == ((char *) 0))
  130.     {
  131.       fprintf (stderr, "realloc: unable to allocate %d bytes\n", length);
  132.       exit (1);
  133.     }
  134.   return (result);
  135. }
  136.  
  137. #define FIND_INDEX_LENGTH(index, size)                    \
  138. {                                    \
  139.   char index_buffer [64];                        \
  140.                                     \
  141.   sprintf (index_buffer, "%x", (index));                \
  142.   (size) = (strlen (index_buffer));                    \
  143. }
  144.  
  145. #ifdef DEBUGGING
  146. #  define dprintf(one, two) fprintf(stderr, one, two)
  147. #else
  148. #  define dprintf(one, two)
  149. #endif
  150.  
  151. /* Maximum number of primitives that can be handled. */
  152.  
  153. boolean built_in_p;
  154.  
  155. char * token_array [4];
  156. char default_token [] = "Define_Primitive";
  157. char default_token_alternate [] = "DEFINE_PRIMITIVE";
  158. char built_in_token [] = "Built_In_Primitive";
  159. char external_token [] = "Define_Primitive";
  160.  
  161. typedef pseudo_void (* TOKEN_PROCESSOR) ();
  162. TOKEN_PROCESSOR token_processors [4];
  163.  
  164. char * the_kind;
  165. char default_kind [] = "Primitive";
  166. char built_in_kind [] = "Primitive";
  167. char external_kind [] = "External";
  168.  
  169. char * the_variable;
  170. char default_variable [] = "MAX_PRIMITIVE";
  171. char built_in_variable [] = "MAX_PRIMITIVE";
  172. char external_variable [] = "MAX_EXTERNAL_PRIMITIVE";
  173.  
  174. #define LEXPR_ARITY_STRING    "-1"
  175.  
  176. FILE * input;
  177. FILE * output;
  178. char * name;
  179. char * file_name;
  180.  
  181. struct descriptor
  182.   {
  183.     char * c_name;        /* The C name of the function */
  184.     char * arity;        /* Number of arguments */
  185.     char * scheme_name;        /* Scheme name of the primitive */
  186.     char * documentation;    /* Documentation string */
  187.     char * file_name;        /* File where found. */
  188.   };
  189.  
  190. int buffer_index;
  191. int buffer_length;
  192. struct descriptor (* data_buffer) [];
  193. struct descriptor ** result_buffer;
  194.  
  195. int max_scheme_name_length;
  196. int max_c_name_length;
  197. int max_arity_length;
  198. int max_documentation_length;
  199. int max_file_name_length;
  200. int max_index_length;
  201.  
  202. struct descriptor dummy_entry =
  203.   {"Dummy_Primitive", "0", "DUMMY-PRIMITIVE", "", "Findprim.c"};
  204.  
  205. char dummy_error_string [] =
  206.   "Microcode_Termination (TERM_BAD_PRIMITIVE)";
  207.  
  208. struct descriptor inexistent_entry =
  209.   {"Prim_inexistent", LEXPR_ARITY_STRING, "INEXISTENT-PRIMITIVE", "", "Findprim.c"};
  210.  
  211. char inexistent_error_string [] =
  212.   "signal_error_from_primitive (ERR_UNIMPLEMENTED_PRIMITIVE)";
  213.  
  214. /* forward references */
  215.  
  216. TOKEN_PROCESSOR EXFUN (scan, (void));
  217. boolean EXFUN (whitespace, (int c));
  218. int EXFUN (compare_descriptors, (struct descriptor * d1, struct descriptor * d2));
  219. int EXFUN (read_index, (char * arg, char * identification));
  220. int EXFUN (strcmp_ci, (char * s1, char * s2));
  221. pseudo_void EXFUN (create_alternate_entry, (void));
  222. pseudo_void EXFUN (create_builtin_entry, (void));
  223. pseudo_void EXFUN (create_normal_entry, (void));
  224. void EXFUN (dump, (boolean check));
  225. void EXFUN (grow_data_buffer, (void));
  226. void EXFUN (grow_token_buffer, (void));
  227. void EXFUN (initialize_builtin, (char * arg));
  228. void EXFUN (initialize_data_buffer, (void));
  229. void EXFUN (initialize_default, (void));
  230. void EXFUN (initialize_external, (void));
  231. void EXFUN (initialize_token_buffer, (void));
  232. void EXFUN (mergesort, (int low, int high,
  233.             struct descriptor ** array,
  234.             struct descriptor ** temp_array));
  235. void EXFUN (print_procedure, (FILE * output,
  236.                   struct descriptor * primitive_descriptor,
  237.                   char * error_string));
  238. void EXFUN (print_primitives, (FILE * output, int limit));
  239. void EXFUN (print_spaces, (FILE * output, int how_many));
  240. void EXFUN (print_entry, (FILE * output, int index,
  241.               struct descriptor * primitive_descriptor));
  242. void EXFUN (process, (void));
  243. void EXFUN (process_argument, (char * fn));
  244. void EXFUN (scan_to_token_start, (void));
  245. void EXFUN (skip_token, (void));
  246. void EXFUN (sort, (void));
  247. void EXFUN (update_from_entry, (struct descriptor * primitive_descriptor));
  248.  
  249. void
  250. DEFUN (main, (argc, argv),
  251.        int argc AND
  252.        char **argv)
  253. {
  254.   name = argv[0];
  255.  
  256.   /* Check for specified output file */
  257.  
  258.   if ((argc >= 2) && ((strcmp ("-o", argv[1])) == 0))
  259.     {
  260.       output = (fopen (argv[2], "w"));
  261.       if (output == NULL)
  262.     {
  263.       fprintf(stderr, "Error: %s can't open %s\n", name, argv[2]);
  264.       exit (1);
  265.     }
  266.       argv += 2;
  267.       argc -= 2;
  268.     }
  269.   else
  270.     output = stdout;
  271.  
  272.   initialize_data_buffer ();
  273.   initialize_token_buffer ();
  274.  
  275.   /* Check whether to produce the built-in table instead.
  276.      The argument after the option letter is the size of the
  277.      table to build.  */
  278.  
  279.   if ((argc >= 2) && ((strcmp ("-b", argv[1])) == 0))
  280.     {
  281.       initialize_builtin (argv[2]);
  282.       argv += 2;
  283.       argc -= 2;
  284.     }
  285.   else if ((argc >= 1) && ((strcmp ("-e", argv[1])) == 0))
  286.     {
  287.       initialize_external ();
  288.       argv += 1;
  289.       argc -= 1;
  290.     }
  291.   else
  292.     initialize_default ();
  293.  
  294.   /* Check whether there are any files left. */
  295.   if (argc == 1)
  296.     {
  297.       dump (FALSE);
  298.       goto done;
  299.     }
  300.  
  301.   if ((argc >= 2) && ((strcmp ("-l", argv[1])) == 0))
  302.     {
  303.       /* The list of files is stored in another file. */
  304.  
  305.       char fn [1024];
  306.       FILE * file_list_file;
  307.  
  308.       file_list_file = (fopen (argv[2], "r"));
  309.       if (file_list_file == NULL)
  310.     {
  311.       fprintf (stderr, "Error: %s can't open %s\n", name, argv[2]);
  312.       dump (TRUE);
  313.       exit (1);
  314.     }
  315.       while ((fgets (fn, 1024, file_list_file)) != NULL)
  316.     {
  317.       int i;
  318.  
  319.       i = (strlen (fn)) - 1;
  320.       if ((i >= 0) && (fn[i] == '\n'))
  321.         {
  322.           fn[i] = '\0';
  323.           i -= 1;
  324.         }
  325.       if ((i > 0) && (fn[0] != ';'))
  326.         {
  327.           char * arg;
  328.  
  329.           arg = (xmalloc ((strlen (fn)) + 1));
  330.           strcpy (arg, fn);
  331.           process_argument (arg);
  332.         }
  333.     }
  334.       fclose (file_list_file);
  335.     }
  336.   else
  337.     /* The list of files is in the argument list. */
  338.     while ((--argc) > 0)
  339.       process_argument (*++argv);
  340.  
  341.   if (! built_in_p)
  342.     {
  343.       dprintf ("About to sort %s\n", "");
  344.       sort ();
  345.     }
  346.   dprintf ("About to dump %s\n", "");
  347.   dump (TRUE);
  348.  
  349.  done:
  350.   if (output != stdout)
  351.     fclose (output);
  352.   NORMAL_EXIT ();
  353. }
  354.  
  355. void
  356. DEFUN (process_argument, (fn),
  357.        char * fn)
  358. {
  359.   file_name = fn;
  360.   if ((strcmp ("-", file_name)) == 0)
  361.     {
  362.       input = stdin;
  363.       file_name = "stdin";
  364.       dprintf ("About to process %s\n", "STDIN");
  365.       process ();
  366.     }
  367.   else if ((input = (fopen (file_name, "r"))) == NULL)
  368.     {
  369.       fprintf (stderr, "Error: %s can't open %s\n", name, file_name);
  370.       dump (TRUE);
  371.       exit (1);
  372.     }
  373.   else
  374.     {
  375.       dprintf ("About to process %s\n", file_name);
  376.       process ();
  377.       fclose (input);
  378.     }
  379.   return;
  380. }
  381.  
  382. /* Search for tokens and when found, create primitive entries. */
  383.  
  384. void
  385. DEFUN_VOID (process)
  386. {
  387.   TOKEN_PROCESSOR processor;
  388.  
  389.   while (TRUE)
  390.     {
  391.       processor = (scan ());
  392.       if (processor == NULL) break;
  393.       dprintf ("Process: place found.%s\n", "");
  394.       (* processor) ();
  395.     }
  396.   return;
  397. }
  398.  
  399. /* Search for token and stop when found.  If you hit open comment
  400.  * character, read until you hit close comment character.
  401.  * *** FIX *** : It is not a complete C parser, thus it may be fooled,
  402.  *      currently the token must always begin a line.
  403.  */
  404.  
  405. TOKEN_PROCESSOR
  406. DEFUN_VOID (scan)
  407. {
  408.   register int c;
  409.   char compare_buffer [1024];
  410.  
  411.   c = '\n';
  412.   while (c != EOF)
  413.     {
  414.       switch (c)
  415.     {
  416.     case '/':
  417.       if ((c = (getc (input)))  == '*')
  418.         {
  419.           c = (getc (input));
  420.           while (TRUE)
  421.         {
  422.           while (c != '*')
  423.             {
  424.               if (c == EOF)
  425.             {
  426.               fprintf (stderr,
  427.                    "Error: EOF in comment in file %s, or %s confused\n",
  428.                    file_name, name);
  429.               dump (TRUE);
  430.               exit (1);
  431.             }
  432.               c = (getc (input));
  433.             }
  434.           c = (getc (input));
  435.           if (c == '/') break;
  436.         }
  437.         }
  438.       else if (c != '\n') break;
  439.  
  440.     case '\n':
  441.       {
  442.         {
  443.           register char * scan_buffer;
  444.  
  445.           scan_buffer = (& (compare_buffer [0]));
  446.           while (TRUE)
  447.         {
  448.           c = (getc (input));
  449.           if (c == EOF)
  450.             return (NULL);
  451.           else if ((isalnum (c)) || (c == '_'))
  452.             (*scan_buffer++) = c;
  453.           else
  454.             {
  455.               ungetc (c, input);
  456.               (*scan_buffer++) = '\0';
  457.               break;
  458.             }
  459.         }
  460.         }
  461.         {
  462.           register char **scan_tokens;
  463.  
  464.           for (scan_tokens = (& (token_array [0]));
  465.            ((* scan_tokens) != NULL);
  466.            scan_tokens += 1)
  467.         if ((strcmp ((& (compare_buffer [0])), (* scan_tokens))) == 0)
  468.           return (token_processors [scan_tokens - token_array]);
  469.         }
  470.         break;
  471.       }
  472.  
  473.     default: {}
  474.     }
  475.       c = (getc (input));
  476.     }
  477.   return (NULL);
  478. }
  479.  
  480. /* Output Routines */
  481.  
  482. void
  483. DEFUN (dump, (check),
  484.        boolean check)
  485. {
  486.   register int max_index;
  487.   register int count;
  488.  
  489.   FIND_INDEX_LENGTH (buffer_index, max_index_length);
  490.   max_index = (buffer_index - 1);
  491.  
  492.   /* Print header. */
  493.   fprintf (output, "/%c Emacs: This is -*- C -*- code. %c/\n\n", '*', '*');
  494.   fprintf (output, "/%c %s primitive declarations. %c/\n\n",
  495.        '*', ((built_in_p) ? "Built in" : "User defined" ), '*');
  496.   fprintf (output, "#include \"usrdef.h\"\n\n");
  497.   fprintf (output,
  498.        "long %s = %d; /%c = 0x%x %c/\n\n",
  499.        the_variable, max_index, '*', max_index, '*');
  500.  
  501.   if (built_in_p)
  502.     fprintf (output,
  503.          "/%c The number of implemented primitives is %d. %c/\n\n",
  504.          '*', buffer_index, '*');
  505.  
  506.   if (buffer_index == 0)
  507.     {
  508.       if (check)
  509.     fprintf (stderr, "No primitives found!\n");
  510.  
  511.       /* C does not understand empty arrays, thus it must be faked. */
  512.       fprintf (output, "/%c C does not understand empty arrays, ", '*');
  513.       fprintf (output, "thus it must be faked. %c/\n\n", '*');
  514.     }
  515.   else
  516.     {
  517.       /* Print declarations. */
  518.       fprintf (output, "extern SCHEME_OBJECT\n");
  519.       for (count = 0; (count <= max_index); count += 1)
  520.       {
  521. #ifdef ASSUME_ANSIDECL
  522.     fprintf (output, "  EXFUN (%s, (void))",
  523.          (((* data_buffer) [count]) . c_name));
  524. #else
  525.     fprintf (output, "       %s ()",
  526.          (((* data_buffer) [count]) . c_name));
  527. #endif
  528.     if (count == max_index)
  529.       fprintf (output, ";\n\n");
  530.     else
  531.       fprintf (output, ",\n");
  532.       }
  533.     }
  534.  
  535.   print_procedure
  536.     (output, (& inexistent_entry), (& (inexistent_error_string [0])));
  537.   print_primitives (output, buffer_index);
  538.   return;
  539. }
  540.  
  541. void
  542. DEFUN (print_procedure, (output, primitive_descriptor, error_string),
  543.        FILE * output AND
  544.        struct descriptor * primitive_descriptor AND
  545.        char * error_string)
  546. {
  547.   fprintf (output, "SCHEME_OBJECT\n");
  548. #ifdef ASSUME_ANSIDECL
  549.   fprintf (output, "DEFUN_VOID (%s)\n",
  550.        (primitive_descriptor -> c_name));
  551. #else
  552.   fprintf (output, "%s ()\n",
  553.        (primitive_descriptor -> c_name));
  554. #endif
  555.   fprintf (output, "{\n");
  556.   fprintf (output, "  PRIMITIVE_HEADER (%s);\n",
  557.        (primitive_descriptor -> arity));
  558.   fprintf (output, "\n");
  559.   fprintf (output, "  %s;\n", error_string);
  560.   fprintf (output, "  /%cNOTREACHED%c/\n", '*', '*');
  561.   fprintf (output, "}\n");
  562.  
  563.   return;
  564. }
  565.  
  566. void
  567. DEFUN (print_primitives, (output, limit),
  568.        FILE * output AND
  569.        register int limit)
  570. {
  571.   register int last;
  572.   register int count;
  573.   register char * table_entry;
  574.  
  575.   last = (limit - 1);
  576.  
  577.   /* Print the procedure table. */
  578. #ifdef ASSUME_ANSIDECL
  579.   fprintf (output, "\f\nSCHEME_OBJECT EXFUN ((* (%s_Procedure_Table [])), (void)) = {\n",
  580.        the_kind);
  581. #else
  582.   fprintf (output, "\f\nSCHEME_OBJECT (* (%s_Procedure_Table [])) () = {\n",
  583.        the_kind);
  584. #endif
  585.   for (count = 0; (count < limit); count += 1)
  586.     {
  587.       print_entry (output, count, (result_buffer [count]));
  588.       fprintf (output, ",\n");
  589.     }
  590.   print_entry (output, (-1), (& inexistent_entry));
  591.   fprintf (output, "\n};\n");
  592.  
  593.   /* Print the names table. */
  594.   fprintf (output, "\f\nchar * %s_Name_Table [] = {\n", the_kind);
  595.   for (count = 0; (count < limit); count += 1)
  596.     {
  597.       fprintf (output, "  \"%s\",\n", ((result_buffer [count]) -> scheme_name));
  598.     }
  599.   fprintf (output, "  \"%s\"\n};\n", inexistent_entry.scheme_name);
  600.  
  601.   /* Print the documentation table. */
  602.   fprintf (output, "\f\nchar * %s_Documentation_Table [] = {\n", the_kind);
  603.   for (count = 0; (count < limit); count += 1)
  604.     {
  605.       fprintf (output, "  ");
  606.       table_entry = ((result_buffer [count]) -> documentation);
  607.       if ((table_entry [0]) == '\0')
  608.     fprintf (output, "((char *) 0),\n");
  609.       else
  610.     fprintf (output, "\"%s\",\n", table_entry);
  611.     }
  612.   fprintf (output, "  ((char *) 0)\n};\n");
  613.  
  614.   /* Print the arity table. */
  615.   fprintf (output, "\f\nint %s_Arity_Table [] = {\n", the_kind);
  616.   for (count = 0; (count < limit); count += 1)
  617.     {
  618.       fprintf (output, "  %s,\n", ((result_buffer [count]) -> arity));
  619.     }
  620.   fprintf (output, "  %s\n};\n", inexistent_entry.arity);
  621.  
  622.   /* Print the counts table. */
  623.   fprintf (output, "\f\nint %s_Count_Table [] = {\n", the_kind);
  624.   for (count = 0; (count < limit); count += 1)
  625.     {
  626.       fprintf (output,
  627.            "  (%s * sizeof(SCHEME_OBJECT)),\n",
  628.            ((result_buffer [count]) -> arity));
  629.     }
  630.   fprintf (output, "  (%s * sizeof(SCHEME_OBJECT))\n};\n", inexistent_entry.arity);
  631.  
  632.   return;
  633. }
  634.  
  635. void
  636. DEFUN (print_entry, (output, index, primitive_descriptor),
  637.        FILE * output AND
  638.        int index AND
  639.        struct descriptor * primitive_descriptor)
  640. {
  641.   int index_length;
  642.  
  643.   fprintf (output, "  %-*s ",
  644.        max_c_name_length, (primitive_descriptor -> c_name));
  645.   fprintf (output, "/%c ", '*');
  646.   fprintf (output, "%*s %-*s",
  647.        max_arity_length, (primitive_descriptor -> arity),
  648.        max_scheme_name_length, (primitive_descriptor -> scheme_name));
  649.   fprintf (output, " %s ", the_kind);
  650.   if (index >= 0)
  651.     {
  652.       FIND_INDEX_LENGTH (index, index_length);
  653.       print_spaces (output, (max_index_length - index_length));
  654.       fprintf (output, "0x%x", index);
  655.     }
  656.   else
  657.     {
  658.       print_spaces (output, (max_index_length - 1));
  659.       fprintf (output, "???");
  660.     }
  661.   fprintf (output, " in %s %c/", (primitive_descriptor -> file_name), '*');
  662.   return;
  663. }
  664.  
  665. void
  666. DEFUN (print_spaces, (output, how_many),
  667.        FILE * output AND
  668.        register int how_many)
  669. {
  670.   while ((--how_many) >= 0)
  671.     putc (' ', output);
  672.   return;
  673. }
  674.  
  675. /* Input Parsing */
  676.  
  677. char * token_buffer;
  678. int token_buffer_length;
  679.  
  680. void
  681. DEFUN_VOID (initialize_token_buffer)
  682. {
  683.   token_buffer_length = 80;
  684.   token_buffer = (xmalloc (token_buffer_length));
  685.   return;
  686. }
  687.  
  688. void
  689. DEFUN_VOID (grow_token_buffer)
  690. {
  691.   token_buffer_length *= 2;
  692.   token_buffer = (xrealloc (token_buffer, token_buffer_length));
  693.   return;
  694. }
  695.  
  696. #define TOKEN_BUFFER_DECLS()                        \
  697.   register char * TOKEN_BUFFER_scan;                    \
  698.   register char * TOKEN_BUFFER_end
  699.  
  700. #define TOKEN_BUFFER_START()                        \
  701. {                                    \
  702.   TOKEN_BUFFER_scan = token_buffer;                    \
  703.   TOKEN_BUFFER_end = (token_buffer + token_buffer_length);        \
  704. }
  705.  
  706. #define TOKEN_BUFFER_WRITE(c)                        \
  707. {                                    \
  708.   if (TOKEN_BUFFER_scan == TOKEN_BUFFER_end)                \
  709.     {                                    \
  710.       int n;                                \
  711.                                     \
  712.       n = (TOKEN_BUFFER_scan - token_buffer);                \
  713.       grow_token_buffer ();                        \
  714.       TOKEN_BUFFER_scan = (token_buffer + n);                \
  715.       TOKEN_BUFFER_end = (token_buffer + token_buffer_length);        \
  716.     }                                    \
  717.   (*TOKEN_BUFFER_scan++) = (c);                        \
  718. }
  719.  
  720. #define TOKEN_BUFFER_OVERWRITE(s)                    \
  721. {                                    \
  722.   int TOKEN_BUFFER_n;                            \
  723.                                     \
  724.   TOKEN_BUFFER_n = ((strlen (s)) + 1);                    \
  725.   while (TOKEN_BUFFER_n > token_buffer_length)                \
  726.     {                                    \
  727.       grow_token_buffer ();                        \
  728.       TOKEN_BUFFER_end = (token_buffer + token_buffer_length);        \
  729.     }                                    \
  730.   strcpy (token_buffer, s);                        \
  731.   TOKEN_BUFFER_scan = (token_buffer + TOKEN_BUFFER_n);            \
  732. }
  733.  
  734. #define TOKEN_BUFFER_FINISH(target, size)                \
  735. {                                    \
  736.   int TOKEN_BUFFER_n;                            \
  737.   char * TOKEN_BUFFER_result;                        \
  738.                                     \
  739.   TOKEN_BUFFER_n = (TOKEN_BUFFER_scan - token_buffer);            \
  740.   TOKEN_BUFFER_result = (xmalloc (TOKEN_BUFFER_n));            \
  741.   strcpy (TOKEN_BUFFER_result, token_buffer);                \
  742.   (target) = TOKEN_BUFFER_result;                    \
  743.   TOKEN_BUFFER_n -= 1;                            \
  744.   if ((size) < TOKEN_BUFFER_n)                        \
  745.     (size) = TOKEN_BUFFER_n;                        \
  746. }
  747.  
  748. enum tokentype
  749.   {
  750.     tokentype_integer,
  751.     tokentype_identifier,
  752.     tokentype_string,
  753.     tokentype_string_upcase
  754.   };
  755.  
  756. void
  757. DEFUN (copy_token, (target, size, token_type),
  758.        char ** target AND
  759.        int * size AND
  760.        register enum tokentype token_type)
  761. {
  762.   register int c;
  763.   TOKEN_BUFFER_DECLS ();
  764.  
  765.   TOKEN_BUFFER_START ();
  766.   c = (getc (input));
  767.   if (c == '\"')
  768.     {
  769.       while (1)
  770.     {
  771.       c = (getc (input));
  772.       if (c == '\"') break;
  773.       if (c == '\\')
  774.         {
  775.           TOKEN_BUFFER_WRITE (c);
  776.           c = (getc (input));
  777.           TOKEN_BUFFER_WRITE (c);
  778.         }
  779.       else
  780.         TOKEN_BUFFER_WRITE
  781.           (((token_type == tokentype_string_upcase) &&
  782.         (isalpha (c)) &&
  783.         (islower (c)))
  784.            ? (toupper (c))
  785.            : c);
  786.     }
  787.       TOKEN_BUFFER_WRITE ('\0');
  788.     }
  789.   else
  790.     {
  791.       TOKEN_BUFFER_WRITE (c);
  792.       while (1)
  793.     {
  794.       c = (getc (input));
  795.       if (whitespace (c)) break;
  796.       TOKEN_BUFFER_WRITE (c);
  797.     }
  798.       TOKEN_BUFFER_WRITE ('\0');
  799.       if ((strcmp (token_buffer, "LEXPR")) == 0)
  800.     {
  801.       TOKEN_BUFFER_OVERWRITE (LEXPR_ARITY_STRING);
  802.     }
  803.       else if ((token_type == tokentype_string) &&
  804.            ((strcmp (token_buffer, "0")) == 0))
  805.     TOKEN_BUFFER_OVERWRITE ("");
  806.     }
  807.   TOKEN_BUFFER_FINISH ((* target), (* size));
  808.   return;
  809. }
  810.  
  811. boolean
  812. DEFUN (whitespace, (c),
  813.        register int c)
  814. {
  815.   switch (c)
  816.     {
  817.     case ' ':
  818.     case '\t':
  819.     case '\n':
  820.     case '(':
  821.     case ')':
  822.     case ',': return TRUE;
  823.     default: return FALSE;
  824.     }
  825. }
  826.  
  827. void
  828. DEFUN_VOID (scan_to_token_start)
  829. {
  830.   register int c;
  831.  
  832.   while (whitespace (c = (getc (input)))) ;
  833.   ungetc (c, input);
  834.   return;
  835. }
  836.  
  837. void
  838. DEFUN_VOID (skip_token)
  839. {
  840.   register int c;
  841.  
  842.   while (! (whitespace (c = (getc (input))))) ;
  843.   ungetc (c, input);
  844.   return;
  845. }
  846.  
  847. void
  848. DEFUN_VOID (initialize_data_buffer)
  849. {
  850.   buffer_length = 0x200;
  851.   buffer_index = 0;
  852.   data_buffer =
  853.     ((struct descriptor (*) [])
  854.      (xmalloc (buffer_length * (sizeof (struct descriptor)))));
  855.   result_buffer =
  856.     ((struct descriptor **)
  857.      (xmalloc (buffer_length * (sizeof (struct descriptor *)))));
  858.  
  859.   max_c_name_length = 0;
  860.   max_arity_length = 0;
  861.   max_scheme_name_length = 0;
  862.   max_documentation_length = 0;
  863.   max_file_name_length = 0;
  864.   update_from_entry (& inexistent_entry);
  865.  
  866.   return;
  867. }
  868.  
  869. void
  870. DEFUN_VOID (grow_data_buffer)
  871. {
  872.   char * old_data_buffer = ((char *) data_buffer);
  873.   buffer_length *= 2;
  874.   data_buffer =
  875.     ((struct descriptor (*) [])
  876.      (xrealloc (((char *) data_buffer),
  877.         (buffer_length * (sizeof (struct descriptor))))));
  878.   {
  879.     register struct descriptor ** scan = result_buffer;
  880.     register struct descriptor ** end = (result_buffer + buffer_index);
  881.     register long offset = (((char *) data_buffer) - old_data_buffer);
  882.     while (scan < end)
  883.       {
  884.     (*scan) = ((struct descriptor *) (((char*) (*scan)) + offset));
  885.     scan += 1;
  886.       }
  887.   }
  888.   result_buffer =
  889.     ((struct descriptor **)
  890.      (xrealloc (((char *) result_buffer),
  891.         (buffer_length * (sizeof (struct descriptor *))))));
  892.   return;
  893. }
  894.  
  895. #define MAYBE_GROW_BUFFER()                        \
  896. {                                    \
  897.   if (buffer_index == buffer_length)                    \
  898.     grow_data_buffer ();                        \
  899. }
  900.  
  901. #define COPY_SCHEME_NAME(desc)                        \
  902. {                                    \
  903.   scan_to_token_start ();                        \
  904.   copy_token ((& ((desc) . scheme_name)),                \
  905.           (& max_scheme_name_length),                \
  906.           tokentype_string_upcase);                    \
  907. }
  908.  
  909. #define COPY_C_NAME(desc)                        \
  910. {                                    \
  911.   scan_to_token_start ();                        \
  912.   copy_token ((& ((desc) . c_name)),                    \
  913.           (& max_c_name_length),                    \
  914.           tokentype_identifier);                    \
  915. }
  916.  
  917. #define COPY_ARITY(desc)                        \
  918. {                                    \
  919.   scan_to_token_start ();                        \
  920.   copy_token ((& ((desc) . arity)),                    \
  921.           (& max_arity_length),                    \
  922.           tokentype_integer);                    \
  923. }
  924.  
  925. #define COPY_DOCUMENTATION(desc)                    \
  926. {                                    \
  927.   scan_to_token_start ();                        \
  928.   copy_token ((& ((desc) . documentation)),                \
  929.           (& max_documentation_length),                \
  930.           tokentype_string);                    \
  931. }
  932.  
  933. #define DEFAULT_DOCUMENTATION(desc)                    \
  934. {                                    \
  935.   ((desc) . documentation) = "";                    \
  936. }
  937.  
  938. #define COPY_FILE_NAME(desc)                        \
  939. {                                    \
  940.   int length;                                \
  941.                                     \
  942.   ((desc) . file_name) = file_name;                    \
  943.   length = (strlen (file_name));                    \
  944.   if (max_file_name_length < length)                    \
  945.     max_file_name_length = length;                    \
  946. }
  947.  
  948. void
  949. DEFUN_VOID (initialize_default)
  950. {
  951.   built_in_p = FALSE;
  952.   (token_array [0]) = (& (default_token [0]));
  953.   (token_array [1]) = (& (default_token_alternate [0]));
  954.   (token_array [2]) = NULL;
  955.   (token_processors [0]) = create_normal_entry;
  956.   (token_processors [1]) = create_alternate_entry;
  957.   (token_processors [2]) = NULL;
  958.   the_kind = (& (default_kind [0]));
  959.   the_variable = (& (default_variable [0]));
  960.   return;
  961. }
  962.  
  963. void
  964. DEFUN_VOID (initialize_external)
  965. {
  966.   built_in_p = FALSE;
  967.   (token_array [0]) = (& (external_token [0]));
  968.   (token_array [1]) = NULL;
  969.   (token_processors [0]) = create_normal_entry;
  970.   (token_processors [1]) = NULL;
  971.   the_kind = (& (external_kind [0]));
  972.   the_variable = (& (external_variable [0]));
  973.   return;
  974. }
  975.  
  976. void
  977. DEFUN (initialize_builtin, (arg),
  978.        char * arg)
  979. {
  980.   register int length;
  981.   register int index;
  982.  
  983.   built_in_p = TRUE;
  984.   length = (read_index (arg, "built_in_table_size"));
  985.   while (buffer_length < length)
  986.     grow_data_buffer ();
  987.   for (index = 0; (index < buffer_length); index += 1)
  988.     (result_buffer [index]) = NULL;
  989.   buffer_index = length;
  990.   (token_array [0]) = (& (built_in_token [0]));
  991.   (token_array [1]) = NULL;
  992.   (token_processors [0]) = create_builtin_entry;
  993.   (token_processors [1]) = NULL;
  994.   the_kind = (& (built_in_kind [0]));
  995.   the_variable = (& (built_in_variable [0]));
  996.   return;
  997. }
  998.  
  999. void
  1000. DEFUN (update_from_entry, (primitive_descriptor),
  1001.        register struct descriptor * primitive_descriptor)
  1002. {
  1003.   register int temp;
  1004.  
  1005.   temp = (strlen (primitive_descriptor -> scheme_name));
  1006.   if (max_scheme_name_length < temp)
  1007.     max_scheme_name_length = temp;
  1008.  
  1009.   temp = (strlen (primitive_descriptor -> c_name));
  1010.   if (max_c_name_length < temp)
  1011.     max_c_name_length = temp;
  1012.  
  1013.   temp = (strlen (primitive_descriptor -> arity));
  1014.   if (max_arity_length < temp)
  1015.     max_arity_length = temp;
  1016.  
  1017.   temp = (strlen (primitive_descriptor -> documentation));
  1018.   if (max_documentation_length < temp)
  1019.     max_documentation_length = temp;
  1020.  
  1021.   temp = (strlen (primitive_descriptor -> file_name));
  1022.   if (max_file_name_length < temp)
  1023.     max_file_name_length = temp;
  1024.  
  1025.   return;
  1026. }
  1027.  
  1028. pseudo_void
  1029. DEFUN_VOID (create_normal_entry)
  1030. {
  1031.   MAYBE_GROW_BUFFER ();
  1032.   COPY_C_NAME ((* data_buffer) [buffer_index]);
  1033.   COPY_ARITY ((* data_buffer) [buffer_index]);
  1034.   COPY_SCHEME_NAME ((* data_buffer) [buffer_index]);
  1035.   DEFAULT_DOCUMENTATION ((* data_buffer) [buffer_index]);
  1036.   COPY_FILE_NAME ((* data_buffer) [buffer_index]);
  1037.   (result_buffer [buffer_index]) = (& ((* data_buffer) [buffer_index]));
  1038.   buffer_index += 1;
  1039.   return;
  1040. }
  1041.  
  1042. pseudo_void
  1043. DEFUN_VOID (create_alternate_entry)
  1044. {
  1045.   MAYBE_GROW_BUFFER ();
  1046.   COPY_SCHEME_NAME ((* data_buffer) [buffer_index]);
  1047.   COPY_C_NAME ((* data_buffer) [buffer_index]);
  1048.   scan_to_token_start ();
  1049.   skip_token ();        /* min_args */
  1050.   COPY_ARITY ((* data_buffer) [buffer_index]);
  1051.   COPY_DOCUMENTATION ((* data_buffer) [buffer_index]);
  1052.   COPY_FILE_NAME ((* data_buffer) [buffer_index]);
  1053.   (result_buffer [buffer_index]) = (& ((* data_buffer) [buffer_index]));
  1054.   buffer_index += 1;
  1055.   return;
  1056. }
  1057.  
  1058. pseudo_void
  1059. DEFUN_VOID (create_builtin_entry)
  1060. {
  1061.   struct descriptor desc;
  1062.   register int length;
  1063.   int index;
  1064.   char * index_buffer;
  1065.  
  1066.   COPY_C_NAME (desc);
  1067.   COPY_ARITY (desc);
  1068.   COPY_SCHEME_NAME (desc);
  1069.   DEFAULT_DOCUMENTATION (desc);
  1070.   COPY_FILE_NAME (desc);
  1071.   index = 0;
  1072.   scan_to_token_start();
  1073.   copy_token ((& index_buffer), (& index), tokentype_integer);
  1074.   index = (read_index (index_buffer, "index"));
  1075.   length = (index + 1);
  1076.   if (buffer_length < length)
  1077.     {
  1078.       register int i;
  1079.  
  1080.       while (buffer_length < length)
  1081.     grow_data_buffer ();
  1082.       for (i = buffer_index; (i < buffer_length); i += 1)
  1083.     (result_buffer [i]) = NULL;
  1084.     }
  1085.   if (buffer_index < length)
  1086.     buffer_index = length;
  1087.   if ((result_buffer [index]) != NULL)
  1088.     {
  1089.       fprintf (stderr, "%s: redefinition of primitive %d.\n", name, index);
  1090.       fprintf (stderr, "previous definition:\n");
  1091.       FIND_INDEX_LENGTH (buffer_index, max_index_length);
  1092.       print_entry (stderr, index, (result_buffer [index]));
  1093.       fprintf (stderr, "\n");
  1094.       fprintf (stderr, "new definition:\n");
  1095.       print_entry (stderr, index, (& ((* data_buffer) [index])));
  1096.       fprintf (stderr, "\n");
  1097.       exit (1);
  1098.     }
  1099.   ((* data_buffer) [index]) = desc;
  1100.   (result_buffer [index]) = (& ((* data_buffer) [index]));
  1101.   return;
  1102. }
  1103.  
  1104. int
  1105. DEFUN (read_index, (arg, identification),
  1106.        char * arg AND
  1107.        char * identification)
  1108. {
  1109.   int result;
  1110.  
  1111.   result = 0;
  1112.   if (((arg [0]) == '0') && ((arg [1]) == 'x'))
  1113.     sscanf ((& (arg [2])), "%x", (& result));
  1114.   else
  1115.     sscanf ((& (arg [0])), "%d", (& result));
  1116.   if (result < 0)
  1117.     {
  1118.       fprintf (stderr, "%s: %s == %d\n", identification, result);
  1119.       exit (1);
  1120.     }
  1121.   return (result);
  1122. }
  1123.  
  1124. /* Sorting */
  1125.  
  1126. void
  1127. DEFUN_VOID (sort)
  1128. {
  1129.   register struct descriptor ** temp_buffer;
  1130.   register int count;
  1131.  
  1132.   if (buffer_index <= 0)
  1133.     return;
  1134.   temp_buffer =
  1135.     ((struct descriptor **)
  1136.      (xmalloc (buffer_index * (sizeof (struct descriptor *)))));
  1137.   for (count = 0; (count < buffer_index); count += 1)
  1138.     (temp_buffer [count]) = (result_buffer [count]);
  1139.   mergesort (0, (buffer_index - 1), result_buffer, temp_buffer);
  1140.   free (temp_buffer);
  1141.   return;
  1142. }
  1143.  
  1144. void
  1145. DEFUN (mergesort, (low, high, array, temp_array),
  1146.        int low AND
  1147.        register int high AND
  1148.        register struct descriptor ** array AND
  1149.        register struct descriptor ** temp_array)
  1150. {
  1151.   register int index;
  1152.   register int low1;
  1153.   register int low2;
  1154.   int high1;
  1155.   int high2;
  1156.  
  1157.   dprintf ("mergesort: low = %d", low);
  1158.   dprintf ("; high = %d", high);
  1159.  
  1160.   if (high <= low)
  1161.     {
  1162.       dprintf ("; done.%s\n", "");
  1163.       return;
  1164.     }
  1165.  
  1166.   low1 = low;
  1167.   high1 = ((low + high) / 2);
  1168.   low2 = (high1 + 1);
  1169.   high2 = high;
  1170.  
  1171.   dprintf ("; high1 = %d\n", high1);
  1172.  
  1173.   mergesort (low, high1, temp_array, array);
  1174.   mergesort (low2, high, temp_array, array);
  1175.  
  1176.   dprintf ("mergesort: low1 = %d", low1);
  1177.   dprintf ("; high1 = %d", high1);
  1178.   dprintf ("; low2 = %d", low2);
  1179.   dprintf ("; high2 = %d\n", high2);
  1180.  
  1181.   for (index = low; (index <= high); index += 1)
  1182.     {
  1183.       dprintf ("index = %d", index);
  1184.       dprintf ("; low1 = %d", low1);
  1185.       dprintf ("; low2 = %d\n", low2);
  1186.  
  1187.       if (low1 > high1)
  1188.     {
  1189.       (array [index]) = (temp_array [low2]);
  1190.       low2 += 1;
  1191.     }
  1192.       else if (low2 > high2)
  1193.     {
  1194.       (array [index]) = (temp_array [low1]);
  1195.       low1 += 1;
  1196.     }
  1197.       else
  1198.     {
  1199.       switch (compare_descriptors ((temp_array [low1]),
  1200.                        (temp_array [low2])))
  1201.         {
  1202.         case (-1):
  1203.           (array [index]) = (temp_array [low1]);
  1204.           low1 += 1;
  1205.           break;
  1206.  
  1207.         case 1:
  1208.           (array [index]) = (temp_array [low2]);
  1209.           low2 += 1;
  1210.           break;
  1211.  
  1212.         default:
  1213.           fprintf (stderr, "Error: bad comparison.\n");
  1214.           goto comparison_abort;
  1215.  
  1216.         case 0:
  1217.           {
  1218.         fprintf (stderr, "Error: repeated primitive.\n");
  1219.           comparison_abort:
  1220.         FIND_INDEX_LENGTH (buffer_index, max_index_length);
  1221.         output = stderr;
  1222.         fprintf (stderr, "definition 1:\n");
  1223.         print_entry (output, low1, (temp_array [low1]));
  1224.         fprintf (stderr, "\ndefinition 2:\n");
  1225.         print_entry (output, low2, (temp_array [low2]));
  1226.         fprintf (stderr, "\n");
  1227.         exit (1);
  1228.         break;
  1229.           }
  1230.         }
  1231.     }
  1232.     }
  1233.   return;
  1234. }
  1235.  
  1236. int
  1237. DEFUN (compare_descriptors, (d1, d2),
  1238.        struct descriptor * d1 AND
  1239.        struct descriptor * d2)
  1240. {
  1241.   int value;
  1242.  
  1243.   dprintf ("comparing \"%s\"", (d1 -> scheme_name));
  1244.   dprintf(" and \"%s\".\n", (d2 -> scheme_name));
  1245.   value = (strcmp_ci ((d1 -> scheme_name), (d2 -> scheme_name)));
  1246.   if (value > 0)
  1247.     return (1);
  1248.   else if (value < 0)
  1249.     return (-1);
  1250.   else
  1251.     return (0);
  1252. }
  1253.  
  1254. int
  1255. DEFUN (strcmp_ci, (s1, s2),
  1256.        register char * s1 AND
  1257.        register char * s2)
  1258. {
  1259.   int length1 = (strlen (s1));
  1260.   int length2 = (strlen (s2));
  1261.   register int length = ((length1 < length2) ? length1 : length2);
  1262.  
  1263.   while ((length--) > 0)
  1264.     {
  1265.       register int c1 = (*s1++);
  1266.       register int c2 = (*s2++);
  1267.       if (islower (c1)) c1 = (toupper (c1));
  1268.       if (islower (c2)) c2 = (toupper (c2));
  1269.       if (c1 < c2) return (-1);
  1270.       if (c1 > c2) return (1);
  1271.     }
  1272.   return (length1 - length2);
  1273. }
  1274.