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