1 : %{
2 : /*
3 : Copyright (C) 2007, Bruce Ediger
4 :
5 : This file is part of cl.
6 :
7 : cl 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
10 : (at your option) any later version.
11 :
12 : cl is distributed in the hope that it will be useful,
13 : but WITHOUT ANY WARRANTY; without even the implied warranty of
14 : MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 : GNU General Public License for more details.
16 :
17 : You should have received a copy of the GNU General Public License
18 : along with cl; if not, write to the Free Software
19 : Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
20 :
21 : */
22 : #include <stdio.h>
23 : #include <errno.h> /* errno */
24 : #include <string.h> /* strerror() */
25 : #include <stdlib.h> /* malloc(), free(), strtoul() */
26 : #include <unistd.h> /* getopt() */
27 : #include <signal.h> /* signal(), etc */
28 : #include <setjmp.h> /* setjmp(), longjmp(), jmp_buf */
29 : #include <sys/time.h> /* gettimeofday(), struct timeval */
30 :
31 : extern char *optarg;
32 :
33 : #include <node.h>
34 : #include <hashtable.h>
35 : #include <atom.h>
36 : #include <graph.h>
37 : #include <abbreviations.h>
38 : #include <spine_stack.h>
39 : #include <bracket_abstraction.h>
40 :
41 : #ifdef YYBISON
42 : #define YYERROR_VERBOSE
43 : #endif
44 :
45 : /* flags, binary on/off for various outputs */
46 : int debug_reduction = 0;
47 : int elaborate_output = 0;
48 : int trace_reduction = 0;
49 : int reduction_timer = 0;
50 : int single_step = 0;
51 : int memory_info = 0;
52 : int count_reductions = 0; /* produce a count of reductions */
53 :
54 : int reduction_timeout = 0; /* how long to let a graph reduction run, seconds */
55 : int max_reduction_count = 0; /* when non-zero, how many reductions to perform */
56 :
57 : int prompting = 1;
58 :
59 : /* Signal handling. in_reduce_graph used to (a) handle
60 : * contrl-C interruptions (b) reduction-run-time timeouts,
61 : * (c) getting out of single-stepped graph reduction in reduce_graph()
62 : */
63 : void sigint_handler(int signo);
64 : sigjmp_buf in_reduce_graph;
65 : int interpreter_interrupted = 0;
66 : int reduction_interrupted = 0;
67 :
68 : void top_level_cleanup(int syntax_error_processing);
69 :
70 : struct node *reduce_tree(struct node *root);
71 : struct node *execute_bracket_abstraction(
72 : struct node *(*bafunc)(struct node *, struct node *),
73 : struct node *abstracted_var,
74 : struct node *root
75 : );
76 : float elapsed_time(struct timeval before, struct timeval after);
77 : void usage(char *progname);
78 :
79 : struct filename_node {
80 : const char *filename;
81 : struct filename_node *next;
82 : };
83 :
84 : /* from lex.l */
85 : extern void set_yyin_stdin(void);
86 : extern void set_yyin(const char *filename);
87 : extern void reset_yyin(void);
88 : extern void push_and_open(const char *filename);
89 :
90 : extern int yylex(void);
91 : int yyerror(char *s1);
92 :
93 : /* Various "treat as combinator" flags.
94 : * For example: S_as_combinator, when set (default) causes
95 : * the lexer to treat "S" as an S-combinator. When unset,
96 : * the lexer treats "S" as any other variable. This can interact
97 : * strangely with bracket abstraction, which assumes that its
98 : * own use of "S" (again, as example) always constitutes a combinator.
99 : */
100 : int S_as_combinator = 1;
101 : int K_as_combinator = 1;
102 : int I_as_combinator = 1;
103 : int B_as_combinator = 1;
104 : int C_as_combinator = 1;
105 : int W_as_combinator = 1;
106 : int T_as_combinator = 1;
107 : int M_as_combinator = 1;
108 :
109 : %}
110 :
111 : %union{
112 : const char *identifier;
113 : const char *string_constant;
114 : int numerical_constant;
115 : struct node *node;
116 : enum combinatorName cn;
117 : struct node *(*bafunc)(struct node *, struct node *);
118 : }
119 :
120 :
121 : %token <node> TK_EOL
122 : %token TK_LPAREN TK_RPAREN TK_LBRACK TK_RBRACK
123 : %token <identifier> TK_IDENTIFIER
124 : %token <cn> TK_PRIMITIVE
125 : %token <string_constant> STRING_LITERAL
126 : %token <node> TK_REDUCE TK_TIMEOUT
127 : %token <numerical_constant> NUMERICAL_CONSTANT
128 : %token <identifier> TK_ALGORITHM_NAME
129 : %token TK_DEF TK_TIME TK_LOAD TK_ELABORATE TK_TRACE TK_SINGLE_STEP TK_DEBUG
130 : %token TK_MAX_COUNT TK_SET_BRACKET_ABSTRACTION
131 :
132 : %type <node> expression stmnt application term constant interpreter_command
133 : %type <node> bracket_abstraction
134 : %type <bafunc> abstraction_algorithm
135 :
136 : %%
137 :
138 : program
139 69 : : stmnt { top_level_cleanup(0); }
140 69 : | program stmnt { top_level_cleanup(0); }
141 5737 : | error /* magic token - yacc unwinds to here on syntax error */
142 12 : { top_level_cleanup(1); }
143 12 : ;
144 :
145 : stmnt
146 : : expression TK_EOL
147 : {
148 306 : print_graph($1, 0, 0);
149 306 : $$ = reduce_tree($1);
150 305 : if (!reduction_interrupted)
151 297 : print_graph($$->left, 0, 0);
152 305 : free_node($$);
153 : }
154 305 : | TK_DEF TK_IDENTIFIER expression TK_EOL
155 : {
156 5145 : abbreviation_add($2, $3);
157 5145 : ++$3->refcnt;
158 5145 : free_node($3);
159 : }
160 5145 : | interpreter_command
161 331 : | TK_EOL { $$ = NULL; /* blank lines */ }
162 331 : ;
163 :
164 : interpreter_command
165 4 : : TK_TIME TK_EOL { reduction_timer ^= 1; }
166 4 : | TK_ELABORATE TK_EOL { elaborate_output ^= 1; }
167 3 : | TK_DEBUG TK_EOL { debug_reduction ^= 1; }
168 3 : | TK_TRACE TK_EOL { trace_reduction ^= 1; }
169 3 : | TK_SINGLE_STEP TK_EOL { single_step ^= 1; }
170 3 : | TK_LOAD STRING_LITERAL TK_EOL { push_and_open($2); }
171 1 : | TK_TIMEOUT NUMERICAL_CONSTANT TK_EOL { reduction_timeout = $2; }
172 4 : | TK_MAX_COUNT NUMERICAL_CONSTANT TK_EOL { max_reduction_count = $2; }
173 3 : | TK_SET_BRACKET_ABSTRACTION TK_ALGORITHM_NAME TK_EOL { default_bracket_abstraction = determine_bracket_abstraction($2); }
174 1 : ;
175 :
176 : expression
177 20304 : : application { $$ = $1; }
178 20304 : | term { $$ = $1; }
179 1813 : | TK_REDUCE expression
180 : {
181 : struct node *tmp;
182 79 : tmp = reduce_tree($2);
183 79 : --tmp->left->refcnt;
184 79 : $$ = tmp->left;
185 79 : tmp->left = NULL;
186 79 : free_node(tmp);
187 : }
188 79 : | bracket_abstraction abstraction_algorithm expression
189 : {
190 177 : $$ = execute_bracket_abstraction($2, $1, $3);
191 177 : ++$1->refcnt;
192 177 : free_node($1);
193 177 : ++$3->refcnt;
194 177 : free_node($3);
195 : }
196 177 : ;
197 :
198 : abstraction_algorithm
199 88 : : TK_ALGORITHM_NAME { $$ = determine_bracket_abstraction($1); }
200 88 : | { $$ = default_bracket_abstraction; }
201 89 : ;
202 :
203 : application
204 20304 : : term term { $$ = new_application($1, $2); }
205 20304 : | application term { $$ = new_application($1, $2); }
206 56123 : ;
207 :
208 : bracket_abstraction
209 : : TK_LBRACK TK_IDENTIFIER TK_RBRACK
210 177 : { $$ = new_term($2); }
211 177 : ;
212 :
213 : term
214 80730 : : constant { $$ = $1; }
215 80730 : | TK_IDENTIFIER
216 : {
217 1153 : $$ = abbreviation_lookup($1);
218 1153 : if (!$$)
219 541 : $$ = new_term($1);
220 : }
221 1153 : | TK_LPAREN expression TK_RPAREN { $$ = $2; }
222 16662 : ;
223 :
224 : constant
225 80730 : : TK_PRIMITIVE { $$ = new_combinator($1); }
226 : ;
227 :
228 : %%
229 :
230 : int
231 : main(int ac, char **av)
232 71 : {
233 : int c, r;
234 71 : struct filename_node *p, *load_files = NULL, *load_tail = NULL;
235 71 : struct hashtable *h = init_hashtable(64, 10);
236 : struct node *(*dba)(struct node *, struct node *);
237 : extern int yyparse();
238 :
239 71 : setup_abbreviation_table(h);
240 71 : setup_atom_table(h);
241 :
242 217 : while (-1 != (c = getopt(ac, av, "deL:mN:pstT:C:B:x")))
243 : {
244 76 : switch (c)
245 : {
246 : case 'd':
247 2 : debug_reduction = 1;
248 2 : break;
249 : case 'e':
250 1 : elaborate_output = 1;
251 1 : break;
252 : case 'L':
253 2 : p = malloc(sizeof(*p));
254 2 : p->filename = Atom_string(optarg);
255 2 : p->next = NULL;
256 2 : if (load_tail)
257 0 : load_tail->next = p;
258 2 : load_tail = p;
259 2 : if (!load_files)
260 2 : load_files = p;
261 2 : break;
262 : case 'm':
263 2 : memory_info = 1;
264 2 : break;
265 : case 'p':
266 56 : prompting = 0;
267 56 : break;
268 : case 's':
269 1 : single_step = 1;
270 1 : break;
271 : case 'T':
272 0 : reduction_timeout = strtol(optarg, NULL, 10);
273 0 : break;
274 : case 't':
275 2 : trace_reduction = 1;
276 2 : break;
277 : case 'x':
278 1 : usage(av[0]);
279 1 : exit(0);
280 : break;
281 : case 'B':
282 1 : dba = determine_bracket_abstraction(optarg);
283 1 : if (dba) default_bracket_abstraction = dba;
284 : else {
285 0 : fprintf(stderr, "Unknown bracket abstraction algoritm \"%s\"\n", optarg);
286 0 : usage(av[0]);
287 : }
288 1 : break;
289 : case 'C':
290 : /* Turn *off* selected combinators: they become mere identifiers */
291 8 : switch(optarg[0])
292 : {
293 : case 'S':
294 1 : S_as_combinator = 0;
295 1 : break;
296 : case 'K':
297 1 : K_as_combinator = 0;
298 1 : break;
299 : case 'I':
300 1 : I_as_combinator = 0;
301 1 : break;
302 : case 'B':
303 1 : B_as_combinator = 0;
304 1 : break;
305 : case 'C':
306 1 : C_as_combinator = 0;
307 1 : break;
308 : case 'W':
309 1 : W_as_combinator = 0;
310 1 : break;
311 : case 'M':
312 1 : M_as_combinator = 0;
313 1 : break;
314 : case 'T':
315 1 : T_as_combinator = 0;
316 1 : break;
317 : default:
318 0 : fprintf(stderr, "Unknown primitive combinator \"%s\"\n", optarg);
319 0 : usage(av[0]);
320 : break;
321 : }
322 8 : break;
323 : case 'N':
324 0 : max_reduction_count = strtol(optarg, NULL, 10);
325 0 : if (max_reduction_count < 0) max_reduction_count = 0;
326 : break;
327 : }
328 : }
329 :
330 70 : init_node_allocation(memory_info);
331 :
332 70 : if (load_files)
333 : {
334 : struct filename_node *t, *z;
335 2 : int old_prompt = prompting;
336 2 : prompting = 0;
337 4 : for (z = load_files; z; z = t)
338 : {
339 : FILE *fin;
340 :
341 2 : t = z->next;
342 :
343 2 : printf("load file named \"%s\"\n",
344 : z->filename);
345 :
346 2 : if (!(fin = fopen(z->filename, "r")))
347 : {
348 0 : fprintf(stderr, "Problem reading \"%s\": %s\n",
349 : z->filename, strerror(errno));
350 0 : continue;
351 : }
352 :
353 2 : set_yyin(z->filename);
354 :
355 2 : r = yyparse();
356 :
357 2 : reset_yyin();
358 :
359 2 : if (r)
360 0 : printf("Problem with file \"%s\"\n", z->filename);
361 :
362 2 : free(z);
363 2 : fin = NULL;
364 : }
365 2 : prompting = old_prompt;
366 : }
367 :
368 70 : set_yyin_stdin();
369 :
370 : do {
371 70 : if (prompting) printf("CL> ");
372 70 : r = yyparse();
373 69 : } while (r);
374 69 : if (prompting) printf("\n");
375 :
376 69 : if (memory_info) fprintf(stderr, "Memory usage indicators:\n");
377 69 : free_all_nodes(memory_info);
378 69 : free_hashtable(h);
379 69 : free_all_spine_stacks(memory_info);
380 :
381 69 : return r;
382 : }
383 :
384 : void top_level_cleanup(int syntax_error_occurred)
385 5818 : {
386 5818 : reset_node_allocation();
387 5818 : reduction_interrupted = 0;
388 5818 : if (prompting && !syntax_error_occurred) printf("CL> ");
389 5818 : }
390 :
391 : int
392 : yyerror(char *s1)
393 6 : {
394 6 : fprintf(stderr, "%s\n", s1);
395 :
396 6 : return 0;
397 : }
398 :
399 :
400 : void
401 : sigint_handler(int signo)
402 7 : {
403 : /* the "return value" of 1 or 2 comes out in the
404 : * call to sigsetjmp() in reduce_tree().
405 : */
406 7 : siglongjmp(in_reduce_graph, signo == SIGINT? 1: 2);
407 : }
408 :
409 : /*
410 : * Function reduce_tree() exists to wrap reduce_graph()
411 : * at the topmost level. It wraps with setting signal handlers,
412 : * taking before & after timestamps, setting jmp_buf structs, etc.
413 : */
414 : struct node *
415 : reduce_tree(struct node *real_root)
416 385 : {
417 : void (*old_sigint_handler)(int);
418 : void (*old_sigalm_handler)(int);
419 : struct timeval before, after;
420 : int cc;
421 385 : struct node *new_root = new_application(real_root, NULL);
422 :
423 : /* new_root - points to a "dummy" node, necessary for I and
424 : * K reductions, if the expression is something like "I x" or
425 : * K a b. */
426 385 : ++new_root->refcnt;
427 385 : MARK_RIGHT_BRANCH_TRAVERSED(new_root);
428 :
429 385 : old_sigint_handler = signal(SIGINT, sigint_handler);
430 385 : old_sigalm_handler = signal(SIGALRM, sigint_handler);
431 :
432 385 : if (!(cc = sigsetjmp(in_reduce_graph, 1)))
433 : {
434 385 : alarm(reduction_timeout);
435 385 : gettimeofday(&before, NULL);
436 385 : reduce_graph(new_root);
437 374 : alarm(0);
438 374 : gettimeofday(&after, NULL);
439 : } else {
440 10 : const char *phrase = "Unset";
441 10 : alarm(0);
442 10 : gettimeofday(&after, NULL);
443 10 : switch (cc)
444 : {
445 : case 1:
446 4 : phrase = "Interrupt";
447 4 : reduction_interrupted = 1;
448 4 : break;
449 : case 2:
450 3 : reduction_interrupted = 1;
451 3 : phrase = "Timeout";
452 3 : break;
453 : case 3:
454 1 : phrase = "Terminated";
455 1 : reduction_interrupted = 1;
456 1 : break;
457 : case 4:
458 2 : phrase = "Reduction limit";
459 2 : reduction_interrupted = 0;
460 2 : break;
461 : default:
462 0 : phrase = "Unknown";
463 : break;
464 : }
465 10 : printf("%s\n", phrase);
466 10 : ++interpreter_interrupted;
467 : }
468 :
469 384 : signal(SIGINT, old_sigint_handler);
470 384 : signal(SIGALRM, old_sigalm_handler);
471 :
472 384 : if (reduction_timer)
473 3 : printf("elapsed time %.3f seconds\n", elapsed_time(before, after));
474 :
475 384 : return new_root;
476 : }
477 :
478 : /*
479 : * Function execute_bracket_abstraction() exists to wrap various bracket
480 : * abstraction functions. It wraps with setting signal handlers,
481 : * taking before & after timestamps, setting jmp_buf structs, etc.
482 : */
483 : struct node *
484 : execute_bracket_abstraction(
485 : struct node *(*bafunc)(struct node *, struct node *),
486 : struct node *abstracted_var,
487 : struct node *root
488 : )
489 177 : {
490 177 : struct node *r = NULL;
491 : void (*old_sigint_handler)(int);
492 : void (*old_sigalm_handler)(int);
493 : struct timeval before, after;
494 : int cc;
495 :
496 177 : old_sigint_handler = signal(SIGINT, sigint_handler);
497 177 : old_sigalm_handler = signal(SIGALRM, sigint_handler);
498 :
499 177 : if (!(cc = sigsetjmp(in_reduce_graph, 1)))
500 : {
501 177 : alarm(reduction_timeout);
502 177 : gettimeofday(&before, NULL);
503 177 : r = (bafunc)(abstracted_var, root);
504 177 : alarm(0);
505 177 : gettimeofday(&after, NULL);
506 : } else {
507 0 : const char *phrase = "Unset";
508 0 : alarm(0);
509 0 : gettimeofday(&after, NULL);
510 0 : switch (cc)
511 : {
512 0 : case 1: phrase = "Interrupt"; break;
513 0 : case 2: phrase = "Timeout"; break;
514 0 : case 3: phrase = "Terminated";break;
515 : default:
516 0 : phrase = "Unknown";
517 : break;
518 : }
519 0 : printf("%s\n", phrase);
520 : }
521 :
522 177 : signal(SIGINT, old_sigint_handler);
523 177 : signal(SIGALRM, old_sigalm_handler);
524 :
525 177 : if (reduction_timer)
526 1 : printf("elapsed time %.3f seconds\n", elapsed_time(before, after));
527 :
528 177 : return r;
529 : }
530 :
531 : /* utility function elapsed_time() */
532 : float
533 : elapsed_time(struct timeval before, struct timeval after)
534 4 : {
535 4 : float r = 0.0;
536 :
537 4 : if (before.tv_usec > after.tv_usec)
538 : {
539 0 : after.tv_usec += 1000000;
540 0 : --after.tv_sec;
541 : }
542 :
543 4 : r = (float)(after.tv_sec - before.tv_sec)
544 : + (1.0E-6)*(float)(after.tv_usec - before.tv_usec);
545 :
546 4 : return r;
547 : }
548 :
549 : void
550 : usage(char *progname)
551 1 : {
552 1 : fprintf(stderr, "%s: Combinatory Logic like language interpreter\n",
553 : progname);
554 1 : fprintf(stderr, "Flags:\n"
555 : "-d debug reductions\n"
556 : "-e elaborate output\n"
557 : "-L filename Load and interpret a filenamed filename\n"
558 : "-m on exit, print memory usage summary\n"
559 : "-N number perform up to number reductions\n"
560 : "-s single-step reductions\n"
561 : "-T number evaluate an expression for up to number seconds\n"
562 : "-t trace reductions\n"
563 : "-C combinator treat combinator as a non-primitive. Combinator one of S, K, I, B, C, W, M, T\n"
564 : "-B algoritm Use algorithm as default for bracket abstraction. One of curry, tromp, grz, btmk\n"
565 : ""
566 : );
567 1 : }
|
