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