1 /*
2 This file is part of tl-parser
3
4 tl-parser is free software: you can redistribute it and/or modify
5 it under the terms of the GNU General Public License as published by
6 the Free Software Foundation, either version 2 of the License, or
7 (at your option) any later version.
8
9 tl-parser is distributed in the hope that it will be useful,
10 but WITHOUT ANY WARRANTY; without even the implied warranty of
11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 GNU General Public License for more details.
13
14 You should have received a copy of the GNU General Public License
15 along with this tl-parser. If not, see <http://www.gnu.org/licenses/>.
16
17 Copyright Vitaly Valtman 2014
18
19 It is derivative work of VK/KittenPHP-DB-Engine (https://github.com/vk-com/kphp-kdb/)
20 Copyright 2012-2013 Vkontakte Ltd
21 2012-2013 Vitaliy Valtman
22
23 */
24
25 #define _FILE_OFFSET_BITS 64
26
27 #include <sys/types.h>
28 #include <sys/stat.h>
29 #include <fcntl.h>
30 #include <limits.h>
31 #include <stdio.h>
32 #include <stdlib.h>
33 #include <assert.h>
34 #include <string.h>
35 #include <time.h>
36 #include "portable_endian.h"
37 #include "tl-parser-tree.h"
38 #include "tl-parser.h"
39 #include "crc32.h"
40 #include "tl-tl.h"
41
42 extern int verbosity;
43 extern int schema_version;
44 extern int output_expressions;
45
46
47 int total_types_num;
48 int total_constructors_num;
49 int total_functions_num;
50
51
52 /*char *tstrdup (const char *s) {
53 assert (s);
54 char *r = talloc (strlen (s) + 1);
55 memcpy (r, s, strlen (s) + 1);
56 return r;
57 }*/
58
59 #define talloc(a) malloc(a)
60 #define tfree(a,b) free (a)
61 #define talloc0(a) calloc(a,1)
62 #define tstrdup(a) strdup(a)
63
64 typedef char error_int_must_be_4_byte[(sizeof (int) == 4) ? 1 : -1];
65 typedef char error_long_long_must_be_8_byte[(sizeof (long long) == 8) ? 1 : -1];
66
67 char curch;
68 struct parse parse;
69
70 struct tree *tree;
71
tree_alloc(void)72 struct tree *tree_alloc (void) {
73 struct tree *T = talloc (sizeof (*T));
74 assert (T);
75 memset (T, 0, sizeof (*T));
76 return T;
77 }
78
tree_add_child(struct tree * P,struct tree * C)79 void tree_add_child (struct tree *P, struct tree *C) {
80 if (P->nc == P->size) {
81 void **t = talloc (sizeof (void *) * (++P->size));
82 memcpy (t, P->c, sizeof (void *) * (P->size - 1));
83 if (P->c) {
84 tfree (P->c, sizeof (void *) * (P->size - 1));
85 }
86 P->c = (void *)t;
87 assert (P->c);
88 }
89 P->c[P->nc ++] = C;
90 }
91
tree_delete(struct tree * T)92 void tree_delete (struct tree *T) {
93 assert (T);
94 int i;
95 for (i = 0; i < T->nc; i++) {
96 assert (T->c[i]);
97 tree_delete (T->c[i]);
98 }
99 if (T->c) {
100 tfree (T->c, sizeof (void *) * T->nc);
101 }
102 tfree (T, sizeof (*T));
103 }
104
tree_del_child(struct tree * P)105 void tree_del_child (struct tree *P) {
106 assert (P->nc);
107 tree_delete (P->c[--P->nc]);
108 }
109
110
nextch(void)111 char nextch (void) {
112 if (parse.pos < parse.len - 1) {
113 curch = parse.text[++parse.pos];
114 } else {
115 curch = 0;
116 }
117 if (curch == 10) {
118 parse.line ++;
119 parse.line_pos = 0;
120 } else {
121 if (curch) {
122 parse.line_pos ++;
123 }
124 }
125 return curch;
126 }
127
128
save_parse(void)129 struct parse save_parse (void) {
130 return parse;
131 }
132
load_parse(struct parse _parse)133 void load_parse (struct parse _parse) {
134 parse = _parse;
135 curch = parse.pos > parse.len ? 0: parse.text[parse.pos] ;
136 }
137
is_whitespace(char c)138 int is_whitespace (char c) {
139 return (c <= 32);
140 }
141
is_uletter(char c)142 int is_uletter (char c) {
143 return (c >= 'A' && c <= 'Z');
144 }
145
is_lletter(char c)146 int is_lletter (char c) {
147 return (c >= 'a' && c <= 'z');
148 }
149
is_letter(char c)150 int is_letter (char c) {
151 return is_uletter (c) || is_lletter (c);
152 }
153
is_digit(char c)154 int is_digit (char c) {
155 return (c >= '0' && c <= '9');
156 }
157
is_hexdigit(char c)158 int is_hexdigit (char c) {
159 return is_digit (c) || (c >= 'a' && c <= 'f');
160 }
161
is_ident_char(char c)162 int is_ident_char (char c) {
163 return is_digit (c) || is_letter (c) || c == '_';
164 }
165
166 int last_error_pos;
167 int last_error_line;
168 int last_error_line_pos;
169 char *last_error;
170
parse_error(const char * e)171 void parse_error (const char *e) {
172 if (parse.pos > last_error_pos) {
173 last_error_pos = parse.pos;
174 last_error_line = parse.line;
175 last_error_line_pos = parse.line_pos;
176 if (last_error) {
177 tfree (last_error, strlen (last_error) + 1);
178 }
179 last_error = tstrdup (e);
180 }
181 }
182
tl_print_parse_error(void)183 void tl_print_parse_error (void) {
184 fprintf (stderr, "Error near line %d pos %d: `%s`\n", last_error_line + 1, last_error_line_pos + 1, last_error);
185 }
186
parse_lex(void)187 char *parse_lex (void) {
188 while (1) {
189 while (curch && is_whitespace (curch)) { nextch (); }
190 if (curch == '/' && nextch () == '/') {
191 while (nextch () != 10);
192 nextch ();
193 } else {
194 break;
195 }
196 }
197 if (!curch) {
198 parse.lex.len = 0;
199 parse.lex.type = lex_eof;
200 return (parse.lex.ptr = 0);
201 }
202 char *p = parse.text + parse.pos;
203 parse.lex.flags = 0;
204 switch (curch) {
205 case '-':
206 if (nextch () != '-' || nextch () != '-') {
207 parse_error ("Can not parse triple minus");
208 parse.lex.type = lex_error;
209 return (parse.lex.ptr = (void *)-1);
210 } else {
211 parse.lex.len = 3;
212 parse.lex.type = lex_triple_minus;
213 nextch ();
214 return (parse.lex.ptr = p);
215 }
216 case ':':
217 case ';':
218 case '(':
219 case ')':
220 case '[':
221 case ']':
222 case '{':
223 case '}':
224 case '=':
225 case '#':
226 case '?':
227 case '%':
228 case '<':
229 case '>':
230 case '+':
231 case ',':
232 case '*':
233 case '_':
234 case '!':
235 case '.':
236 nextch ();
237 parse.lex.len = 1;
238 parse.lex.type = lex_char;
239 return (parse.lex.ptr = p);
240 case 'a':
241 case 'b':
242 case 'c':
243 case 'd':
244 case 'e':
245 case 'f':
246 case 'g':
247 case 'h':
248 case 'i':
249 case 'j':
250 case 'k':
251 case 'l':
252 case 'm':
253 case 'n':
254 case 'o':
255 case 'p':
256 case 'q':
257 case 'r':
258 case 's':
259 case 't':
260 case 'u':
261 case 'v':
262 case 'w':
263 case 'x':
264 case 'y':
265 case 'z':
266 case 'A':
267 case 'B':
268 case 'C':
269 case 'D':
270 case 'E':
271 case 'F':
272 case 'G':
273 case 'H':
274 case 'I':
275 case 'J':
276 case 'K':
277 case 'L':
278 case 'M':
279 case 'N':
280 case 'O':
281 case 'P':
282 case 'Q':
283 case 'R':
284 case 'S':
285 case 'T':
286 case 'U':
287 case 'V':
288 case 'W':
289 case 'X':
290 case 'Y':
291 case 'Z':
292 parse.lex.flags = 0;
293 if (is_uletter (curch)) {
294 while (is_ident_char (nextch ()));
295 parse.lex.len = parse.text + parse.pos - p;
296 parse.lex.ptr = p;
297 if (parse.lex.len == 5 && !memcmp (parse.lex.ptr, "Final", 5)) {
298 parse.lex.type = lex_final;
299 } else if (parse.lex.len == 3 && !memcmp (parse.lex.ptr, "New", 3)) {
300 parse.lex.type = lex_new;
301 } else if (parse.lex.len == 5 && !memcmp (parse.lex.ptr, "Empty", 5)) {
302 parse.lex.type = lex_empty;
303 } else {
304 parse.lex.type = lex_uc_ident;
305 }
306 return (parse.lex.ptr = p);
307 }
308 while (is_ident_char (nextch ()));
309 if (curch == '.' && !is_letter (parse.text[parse.pos + 1])) {
310 parse.lex.len = parse.text + parse.pos - p;
311 parse.lex.type = lex_lc_ident;
312 return (parse.lex.ptr = p);
313 }
314 while (curch == '.') {
315 parse.lex.flags |= 1;
316 nextch ();
317 if (is_uletter (curch)) {
318 while (is_ident_char (nextch ()));
319 parse.lex.len = parse.text + parse.pos - p;
320 parse.lex.type = lex_uc_ident;
321 return (parse.lex.ptr = p);
322 }
323 if (is_lletter (curch)) {
324 while (is_ident_char (nextch ()));
325 } else {
326 parse_error ("Expected letter");
327 parse.lex.type = lex_error;
328 return (parse.lex.ptr = (void *)-1);
329 }
330 }
331 if (curch == '#') {
332 parse.lex.flags |= 2;
333 int i;
334 int ok = 1;
335 for (i = 0; i < 8; i++) {
336 if (!is_hexdigit (nextch())) {
337 if (curch == ' ' && i >= 5) {
338 ok = 2;
339 break;
340 } else {
341 parse_error ("Hex digit expected");
342 parse.lex.type = lex_error;
343 return (parse.lex.ptr = (void *)-1);
344 }
345 }
346 }
347 if (ok == 1) {
348 nextch ();
349 }
350 }
351 parse.lex.len = parse.text + parse.pos - p;
352 parse.lex.type = lex_lc_ident;
353 return (parse.lex.ptr = p);
354 case '0':
355 case '1':
356 case '2':
357 case '3':
358 case '4':
359 case '5':
360 case '6':
361 case '7':
362 case '8':
363 case '9':
364 while (is_digit (nextch ()));
365 parse.lex.len = parse.text + parse.pos - p;
366 parse.lex.type = lex_num;
367 return (parse.lex.ptr = p);
368 default:
369 parse_error ("Unknown lexem");
370 parse.lex.type = lex_error;
371 return (parse.lex.ptr = (void *)-1);
372 }
373
374 }
375
expect(char * s)376 int expect (char *s) {
377 if (!parse.lex.ptr || parse.lex.ptr == (void *)-1 || parse.lex.type == lex_error || parse.lex.type == lex_none || parse.lex.len != (int)strlen (s) || memcmp (s, parse.lex.ptr, parse.lex.len)) {
378 static char buf[1000];
379 sprintf (buf, "Expected %s", s);
380 parse_error (buf);
381 return -1;
382 } else {
383 parse_lex ();
384 }
385 return 1;
386 }
387
tl_init_parse_file(const char * fname)388 struct parse *tl_init_parse_file (const char *fname) {
389 FILE *f = fopen (fname, "rb");
390 if (f == NULL) {
391 fprintf (stderr, "Failed to open the input file.\n");
392 return NULL;
393 }
394 if (fseek (f, 0, SEEK_END) != 0) {
395 fprintf (stderr, "Can't seek to the end of the input file.\n");
396 return NULL;
397 }
398 long size = ftell (f);
399 if (size <= 0 || size > INT_MAX) {
400 fprintf (stderr, "Size is %ld. Too small or too big.\n", size);
401 return NULL;
402 }
403 fseek (f, 0, SEEK_SET);
404
405 static struct parse save;
406 save.text = talloc ((size_t)size);
407 save.len = fread (save.text, 1, (size_t)size, f);
408 assert (save.len == size);
409 fclose (f);
410 save.pos = 0;
411 save.line = 0;
412 save.line_pos = 0;
413 save.lex.ptr = save.text;
414 save.lex.len = 0;
415 save.lex.type = lex_none;
416 return &save;
417 }
418
419 #define PARSE_INIT(_type) struct parse save = save_parse (); struct tree *T = tree_alloc (); T->type = (_type); T->lex_line = parse.line; T->lex_line_pos = parse.line_pos; struct tree *S __attribute__ ((unused));
420 #define PARSE_FAIL load_parse (save); tree_delete (T); return 0;
421 #define PARSE_OK return T;
422 #define PARSE_TRY_PES(x) if (!(S = x ())) { PARSE_FAIL; } { tree_add_child (T, S); }
423 #define PARSE_TRY_OPT(x) if ((S = x ())) { tree_add_child (T, S); PARSE_OK }
424 #define PARSE_TRY(x) S = x ();
425 #define PARSE_ADD(_type) S = tree_alloc (); S->type = _type; tree_add_child (T, S);
426 #define EXPECT(s) if (expect (s) < 0) { PARSE_FAIL; }
427 #define LEX_CHAR(c) (parse.lex.type == lex_char && *parse.lex.ptr == c)
428 struct tree *parse_args (void);
429 struct tree *parse_expr (void);
430
parse_boxed_type_ident(void)431 struct tree *parse_boxed_type_ident (void) {
432 PARSE_INIT (type_boxed_type_ident);
433 if (parse.lex.type != lex_uc_ident) {
434 parse_error ("Can not parse boxed type");
435 PARSE_FAIL;
436 } else {
437 T->text = parse.lex.ptr;
438 T->len = parse.lex.len;
439 T->flags = parse.lex.flags;
440 parse_lex ();
441 PARSE_OK;
442 }
443 }
444
parse_full_combinator_id(void)445 struct tree *parse_full_combinator_id (void) {
446 PARSE_INIT (type_full_combinator_id);
447 if (parse.lex.type == lex_lc_ident || LEX_CHAR('_')) {
448 T->text = parse.lex.ptr;
449 T->len = parse.lex.len;
450 T->flags = parse.lex.flags;
451 parse_lex ();
452 PARSE_OK;
453 } else {
454 parse_error ("Can not parse full combinator id");
455 PARSE_FAIL;
456 }
457 }
458
parse_combinator_id(void)459 struct tree *parse_combinator_id (void) {
460 PARSE_INIT (type_combinator_id);
461 if (parse.lex.type == lex_lc_ident && !(parse.lex.flags & 2)) {
462 T->text = parse.lex.ptr;
463 T->len = parse.lex.len;
464 T->flags = parse.lex.flags;
465 parse_lex ();
466 PARSE_OK;
467 } else {
468 parse_error ("Can not parse combinator id");
469 PARSE_FAIL;
470 }
471 }
472
parse_var_ident(void)473 struct tree *parse_var_ident (void) {
474 PARSE_INIT (type_var_ident);
475 if ((parse.lex.type == lex_lc_ident || parse.lex.type == lex_uc_ident) && !(parse.lex.flags & 3)) {
476 T->text = parse.lex.ptr;
477 T->len = parse.lex.len;
478 T->flags = parse.lex.flags;
479 parse_lex ();
480 PARSE_OK;
481 } else {
482 parse_error ("Can not parse var ident");
483 PARSE_FAIL;
484 }
485 }
486
parse_var_ident_opt(void)487 struct tree *parse_var_ident_opt (void) {
488 PARSE_INIT (type_var_ident_opt);
489 if ((parse.lex.type == lex_lc_ident || parse.lex.type == lex_uc_ident)&& !(parse.lex.flags & 3)) {
490 T->text = parse.lex.ptr;
491 T->len = parse.lex.len;
492 T->flags = parse.lex.flags;
493 parse_lex ();
494 PARSE_OK;
495 } else if (LEX_CHAR ('_')) {
496 T->text = parse.lex.ptr;
497 T->len = parse.lex.len;
498 T->flags = parse.lex.flags;
499 parse_lex ();
500 PARSE_OK;
501 } else {
502 parse_error ("Can not parse var ident opt");
503 PARSE_FAIL;
504 }
505 }
506
parse_nat_const(void)507 struct tree *parse_nat_const (void) {
508 PARSE_INIT (type_nat_const);
509 if (parse.lex.type == lex_num) {
510 T->text = parse.lex.ptr;
511 T->len = parse.lex.len;
512 T->flags = parse.lex.flags;
513 parse_lex ();
514 PARSE_OK;
515 } else {
516 parse_error ("Can not parse nat const");
517 PARSE_FAIL;
518 }
519 }
520
parse_type_ident(void)521 struct tree *parse_type_ident (void) {
522 PARSE_INIT (type_type_ident);
523 if (parse.lex.type == lex_uc_ident && !(parse.lex.flags & 2)) {
524 T->text = parse.lex.ptr;
525 T->len = parse.lex.len;
526 T->flags = parse.lex.flags;
527 parse_lex ();
528 PARSE_OK;
529 } else if (parse.lex.type == lex_lc_ident && !(parse.lex.flags & 2)) {
530 T->text = parse.lex.ptr;
531 T->len = parse.lex.len;
532 T->flags = parse.lex.flags;
533 parse_lex ();
534 PARSE_OK;
535 } else if (LEX_CHAR ('#')) {
536 T->text = parse.lex.ptr;
537 T->len = parse.lex.len;
538 T->flags = parse.lex.flags;
539 parse_lex ();
540 PARSE_OK;
541 } else {
542 parse_error ("Can not parse type ident");
543 PARSE_FAIL;
544 }
545 }
546
parse_term(void)547 struct tree *parse_term (void) {
548 PARSE_INIT (type_term);
549 while (LEX_CHAR ('%')) {
550 EXPECT ("%")
551 PARSE_ADD (type_percent);
552 }
553 if (LEX_CHAR ('(')) {
554 EXPECT ("(");
555 PARSE_TRY_PES (parse_expr);
556 EXPECT (")");
557 PARSE_OK;
558 }
559 PARSE_TRY (parse_type_ident);
560 if (S) {
561 tree_add_child (T, S);
562 if (LEX_CHAR ('<')) {
563 EXPECT ("<");
564 while (1) {
565 PARSE_TRY_PES (parse_expr);
566 if (LEX_CHAR ('>')) { break; }
567 EXPECT (",");
568 }
569 EXPECT (">");
570 }
571 PARSE_OK;
572 }
573 PARSE_TRY_OPT (parse_type_ident);
574 PARSE_TRY_OPT (parse_var_ident);
575 PARSE_TRY_OPT (parse_nat_const);
576 PARSE_FAIL;
577 }
578
parse_nat_term(void)579 struct tree *parse_nat_term (void) {
580 PARSE_INIT (type_nat_term);
581 PARSE_TRY_PES (parse_term);
582 PARSE_OK;
583 }
584
parse_subexpr(void)585 struct tree *parse_subexpr (void) {
586 PARSE_INIT (type_subexpr);
587 int was_term = 0;
588 int cc = 0;
589
590 while (1) {
591 PARSE_TRY (parse_nat_const);
592 if (S) {
593 tree_add_child (T, S);
594 } else if (!was_term) {
595 was_term = 1;
596 PARSE_TRY (parse_term);
597 if (S) {
598 tree_add_child (T, S);
599 } else {
600 break;
601 }
602 }
603 cc ++;
604 if (!LEX_CHAR ('+')) {
605 break;
606 }
607 EXPECT ("+");
608 }
609 if (!cc) {
610 PARSE_FAIL;
611 } else {
612 PARSE_OK;
613 }
614 }
615
parse_expr(void)616 struct tree *parse_expr (void) {
617 PARSE_INIT (type_expr);
618 int cc = 0;
619 while (1) {
620 PARSE_TRY (parse_subexpr);
621 if (S) {
622 tree_add_child (T, S);
623 cc ++;
624 } else {
625 if (cc < 1) { PARSE_FAIL; }
626 else { PARSE_OK; }
627 }
628 }
629 }
630
631
632
parse_final_empty(void)633 struct tree *parse_final_empty (void) {
634 PARSE_INIT (type_final_empty);
635 EXPECT ("Empty");
636 PARSE_TRY_PES (parse_boxed_type_ident);
637 PARSE_OK;
638 }
639
parse_final_new(void)640 struct tree *parse_final_new (void) {
641 PARSE_INIT (type_final_new);
642 EXPECT ("New");
643 PARSE_TRY_PES (parse_boxed_type_ident);
644 PARSE_OK;
645 }
646
parse_final_final(void)647 struct tree *parse_final_final (void) {
648 PARSE_INIT (type_final_final);
649 EXPECT ("Final");
650 PARSE_TRY_PES (parse_boxed_type_ident);
651 PARSE_OK;
652 }
653
parse_partial_comb_app_decl(void)654 struct tree *parse_partial_comb_app_decl (void) {
655 PARSE_INIT (type_partial_comb_app_decl);
656 PARSE_TRY_PES (parse_combinator_id);
657 while (1) {
658 PARSE_TRY_PES (parse_subexpr);
659 if (LEX_CHAR (';')) { break; }
660 }
661 PARSE_OK;
662 }
663
parse_partial_type_app_decl(void)664 struct tree *parse_partial_type_app_decl (void) {
665 PARSE_INIT (type_partial_type_app_decl);
666 PARSE_TRY_PES (parse_boxed_type_ident);
667 if (LEX_CHAR ('<')) {
668 EXPECT ("<");
669 while (1) {
670 PARSE_TRY_PES (parse_expr);
671 if (LEX_CHAR ('>')) { break; }
672 EXPECT (",");
673 }
674 EXPECT (">");
675 PARSE_OK;
676 } else {
677 while (1) {
678 PARSE_TRY_PES (parse_subexpr);
679 if (LEX_CHAR (';')) { break; }
680 }
681 PARSE_OK;
682 }
683 }
684
685
686
687
parse_multiplicity(void)688 struct tree *parse_multiplicity (void) {
689 PARSE_INIT (type_multiplicity);
690 PARSE_TRY_PES (parse_nat_term);
691 PARSE_OK;
692 }
693
694
parse_type_term(void)695 struct tree *parse_type_term (void) {
696 PARSE_INIT (type_type_term);
697 PARSE_TRY_PES (parse_term);
698 PARSE_OK;
699 }
700
parse_optional_arg_def(void)701 struct tree *parse_optional_arg_def (void) {
702 PARSE_INIT (type_optional_arg_def);
703 PARSE_TRY_PES (parse_var_ident);
704 EXPECT (".");
705 PARSE_TRY_PES (parse_nat_const);
706 EXPECT ("?");
707 PARSE_OK;
708 }
709
parse_args4(void)710 struct tree *parse_args4 (void) {
711 PARSE_INIT (type_args4);
712 struct parse so = save_parse ();
713 PARSE_TRY (parse_optional_arg_def);
714 if (S) {
715 tree_add_child (T, S);
716 } else {
717 load_parse (so);
718 }
719 if (LEX_CHAR ('!')) {
720 PARSE_ADD (type_exclam);
721 EXPECT ("!");
722 }
723 PARSE_TRY_PES (parse_type_term);
724 PARSE_OK;
725 }
726
parse_args3(void)727 struct tree *parse_args3 (void) {
728 PARSE_INIT (type_args3);
729 PARSE_TRY_PES (parse_var_ident_opt);
730 EXPECT (":");
731 struct parse so = save_parse ();
732 PARSE_TRY (parse_optional_arg_def);
733 if (S) {
734 tree_add_child (T, S);
735 } else {
736 load_parse (so);
737 }
738 if (LEX_CHAR ('!')) {
739 PARSE_ADD (type_exclam);
740 EXPECT ("!");
741 }
742 PARSE_TRY_PES (parse_type_term);
743 PARSE_OK;
744 }
745
parse_args2(void)746 struct tree *parse_args2 (void) {
747 PARSE_INIT (type_args2);
748 PARSE_TRY (parse_var_ident_opt);
749 if (S && LEX_CHAR (':')) {
750 tree_add_child (T, S);
751 EXPECT (":");
752 } else {
753 load_parse (save);
754 }
755 struct parse so = save_parse ();
756 PARSE_TRY (parse_optional_arg_def);
757 if (S) {
758 tree_add_child (T, S);
759 } else {
760 load_parse (so);
761 }
762 struct parse save2 = save_parse ();
763 PARSE_TRY (parse_multiplicity);
764 if (S && LEX_CHAR ('*')) {
765 tree_add_child (T, S);
766 EXPECT ("*");
767 } else {
768 load_parse (save2);
769 }
770 EXPECT ("[");
771 while (1) {
772 if (LEX_CHAR (']')) { break; }
773 PARSE_TRY_PES (parse_args);
774 }
775 EXPECT ("]");
776 PARSE_OK;
777 }
778
parse_args1(void)779 struct tree *parse_args1 (void) {
780 PARSE_INIT (type_args1);
781 EXPECT ("(");
782 while (1) {
783 PARSE_TRY_PES (parse_var_ident_opt);
784 if (LEX_CHAR(':')) { break; }
785 }
786 EXPECT (":");
787 struct parse so = save_parse ();
788 PARSE_TRY (parse_optional_arg_def);
789 if (S) {
790 tree_add_child (T, S);
791 } else {
792 load_parse (so);
793 }
794 if (LEX_CHAR ('!')) {
795 PARSE_ADD (type_exclam);
796 EXPECT ("!");
797 }
798 PARSE_TRY_PES (parse_type_term);
799 EXPECT (")");
800 PARSE_OK;
801 }
802
parse_args(void)803 struct tree *parse_args (void) {
804 PARSE_INIT (type_args);
805 PARSE_TRY_OPT (parse_args1);
806 PARSE_TRY_OPT (parse_args2);
807 PARSE_TRY_OPT (parse_args3);
808 PARSE_TRY_OPT (parse_args4);
809 PARSE_FAIL;
810 }
811
parse_opt_args(void)812 struct tree *parse_opt_args (void) {
813 PARSE_INIT (type_opt_args);
814 while (1) {
815 PARSE_TRY_PES (parse_var_ident);
816 if (parse.lex.type == lex_char && *parse.lex.ptr == ':') { break;}
817 }
818 EXPECT (":");
819 PARSE_TRY_PES (parse_type_term);
820 PARSE_OK;
821 }
822
parse_final_decl(void)823 struct tree *parse_final_decl (void) {
824 PARSE_INIT (type_final_decl);
825 PARSE_TRY_OPT (parse_final_new);
826 PARSE_TRY_OPT (parse_final_final);
827 PARSE_TRY_OPT (parse_final_empty);
828 PARSE_FAIL;
829 }
830
parse_partial_app_decl(void)831 struct tree *parse_partial_app_decl (void) {
832 PARSE_INIT (type_partial_app_decl);
833 PARSE_TRY_OPT (parse_partial_type_app_decl);
834 PARSE_TRY_OPT (parse_partial_comb_app_decl);
835 PARSE_FAIL;
836 }
837
parse_result_type(void)838 struct tree *parse_result_type (void) {
839 PARSE_INIT (type_result_type);
840 PARSE_TRY_PES (parse_boxed_type_ident);
841 if (LEX_CHAR ('<')) {
842 EXPECT ("<");
843 while (1) {
844 PARSE_TRY_PES (parse_expr);
845 if (LEX_CHAR ('>')) { break; }
846 EXPECT (",");
847 }
848 EXPECT (">");
849 PARSE_OK;
850 } else {
851 while (1) {
852 if (LEX_CHAR (';')) { PARSE_OK; }
853 PARSE_TRY_PES (parse_subexpr);
854 }
855 }
856 }
857
parse_combinator_decl(void)858 struct tree *parse_combinator_decl (void) {
859 PARSE_INIT (type_combinator_decl);
860 PARSE_TRY_PES (parse_full_combinator_id)
861 while (1) {
862 if (LEX_CHAR ('{')) {
863 parse_lex ();
864 PARSE_TRY_PES (parse_opt_args);
865 EXPECT ("}");
866 } else {
867 break;
868 }
869 }
870 while (1) {
871 if (LEX_CHAR ('=')) { break; }
872 PARSE_TRY_PES (parse_args);
873 }
874 EXPECT ("=");
875 PARSE_ADD (type_equals);
876
877 PARSE_TRY_PES (parse_result_type);
878 PARSE_OK;
879 }
880
parse_builtin_combinator_decl(void)881 struct tree *parse_builtin_combinator_decl (void) {
882 PARSE_INIT (type_builtin_combinator_decl);
883 PARSE_TRY_PES (parse_full_combinator_id)
884 EXPECT ("?");
885 EXPECT ("=");
886 PARSE_TRY_PES (parse_boxed_type_ident);
887 PARSE_OK;
888 }
889
parse_declaration(void)890 struct tree *parse_declaration (void) {
891 PARSE_INIT (type_declaration);
892 PARSE_TRY_OPT (parse_combinator_decl);
893 PARSE_TRY_OPT (parse_partial_app_decl);
894 PARSE_TRY_OPT (parse_final_decl);
895 PARSE_TRY_OPT (parse_builtin_combinator_decl);
896 PARSE_FAIL;
897 }
898
parse_constr_declarations(void)899 struct tree *parse_constr_declarations (void) {
900 PARSE_INIT (type_constr_declarations);
901 if (parse.lex.type == lex_triple_minus || parse.lex.type == lex_eof) { PARSE_OK; }
902 while (1) {
903 PARSE_TRY_PES (parse_declaration);
904 EXPECT (";");
905 if (parse.lex.type == lex_eof || parse.lex.type == lex_triple_minus) { PARSE_OK; }
906 }
907 }
908
parse_fun_declarations(void)909 struct tree *parse_fun_declarations (void) {
910 PARSE_INIT (type_fun_declarations);
911 if (parse.lex.type == lex_triple_minus || parse.lex.type == lex_eof) { PARSE_OK; }
912 while (1) {
913 PARSE_TRY_PES (parse_declaration);
914 EXPECT (";");
915 if (parse.lex.type == lex_eof || parse.lex.type == lex_triple_minus) { PARSE_OK; }
916 }
917 }
918
parse_program(void)919 struct tree *parse_program (void) {
920 PARSE_INIT (type_tl_program);
921 while (1) {
922 PARSE_TRY_PES (parse_constr_declarations);
923 if (parse.lex.type == lex_eof) { PARSE_OK; }
924 if (parse.lex.type == lex_error || expect ("---") < 0 || expect ("functions") < 0 || expect ("---") < 0) { PARSE_FAIL; }
925
926 PARSE_TRY_PES (parse_fun_declarations);
927 if (parse.lex.type == lex_eof) { PARSE_OK; }
928 if (parse.lex.type == lex_error || expect ("---") < 0 || expect ("types") < 0 || expect ("---") < 0) { PARSE_FAIL; }
929 }
930 }
931
tl_parse_lex(struct parse * _parse)932 struct tree *tl_parse_lex (struct parse *_parse) {
933 assert (_parse);
934 load_parse (*_parse);
935 if (parse.lex.type == lex_none) {
936 parse_lex ();
937 }
938 if (parse.lex.type == lex_error) {
939 return 0;
940 }
941 return parse_program ();
942 }
943
mystrcmp2(const char * b,int len,const char * a)944 int mystrcmp2 (const char *b, int len, const char *a) {
945 int c = strncmp (b, a, len);
946 return c ? a[len] ? -1 : 0 : c;
947 }
948
mystrdup(const char * a,int len)949 char *mystrdup (const char *a, int len) {
950 char *z = talloc (len + 1);
951 memcpy (z, a, len);
952 z[len] = 0;
953 return z;
954 }
955
956 struct tl_program *tl_program_cur;
957 #define TL_TRY_PES(x) if (!(x)) { return 0; }
958
959 #define tl_type_cmp(a,b) (strcmp (a->id, b->id))
960 DEFINE_TREE (tl_type,struct tl_type *,tl_type_cmp,0)
961 struct tree_tl_type *tl_type_tree;
962
963 DEFINE_TREE (tl_constructor,struct tl_constructor *,tl_type_cmp,0)
964 struct tree_tl_constructor *tl_constructor_tree;
965 struct tree_tl_constructor *tl_function_tree;
966
967 DEFINE_TREE (tl_var,struct tl_var *,tl_type_cmp,0)
968
969 struct tl_var_value {
970 struct tl_combinator_tree *ptr;
971 struct tl_combinator_tree *val;
972 int num_val;
973 };
974
975 #define tl_var_value_cmp(a,b) (((char *)a.ptr) - ((char *)b.ptr))
976 struct tl_var_value empty;
DEFINE_TREE(var_value,struct tl_var_value,tl_var_value_cmp,empty)977 DEFINE_TREE (var_value, struct tl_var_value, tl_var_value_cmp, empty)
978 //tree_tl_var_t *tl_var_tree;
979
980 DEFINE_TREE (tl_field,char *,strcmp, 0)
981 //tree_tl_field_t *tl_field_tree;
982 #define TL_FAIL return 0;
983 #define TL_INIT(x) struct tl_combinator_tree *x = 0;
984 #define TL_TRY(f,x) { struct tl_combinator_tree *_t = f; if (!_t) { TL_FAIL;} x = tl_union (x, _t); if (!x) { TL_FAIL; }}
985 #define TL_ERROR(...) fprintf (stderr, __VA_ARGS__);
986 #define TL_WARNING(...) fprintf (stderr, __VA_ARGS__);
987
988 void tl_set_var_value (struct tree_var_value **T, struct tl_combinator_tree *var, struct tl_combinator_tree *value) {
989 struct tl_var_value t = {.ptr = var, .val = value, .num_val = 0};
990 if (tree_lookup_var_value (*T, t).ptr) {
991 *T = tree_delete_var_value (*T, t);
992 }
993 *T = tree_insert_var_value (*T, t, lrand48 ());
994 }
995
tl_set_var_value_num(struct tree_var_value ** T,struct tl_combinator_tree * var,struct tl_combinator_tree * value,long long num_value)996 void tl_set_var_value_num (struct tree_var_value **T, struct tl_combinator_tree *var, struct tl_combinator_tree *value, long long num_value) {
997 struct tl_var_value t = {.ptr = var, .val = value, .num_val = num_value};
998 if (tree_lookup_var_value (*T, t).ptr) {
999 *T = tree_delete_var_value (*T, t);
1000 }
1001 *T = tree_insert_var_value (*T, t, lrand48 ());
1002 }
1003
tl_get_var_value(struct tree_var_value ** T,struct tl_combinator_tree * var)1004 struct tl_combinator_tree *tl_get_var_value (struct tree_var_value **T, struct tl_combinator_tree *var) {
1005 struct tl_var_value t = {.ptr = var, .val = 0, .num_val = 0};
1006 struct tl_var_value r = tree_lookup_var_value (*T, t);
1007 return r.ptr ? r.val : 0;
1008 }
1009
tl_get_var_value_num(struct tree_var_value ** T,struct tl_combinator_tree * var)1010 int tl_get_var_value_num (struct tree_var_value **T, struct tl_combinator_tree *var) {
1011 struct tl_var_value t = {.ptr = var, .val = 0};
1012 struct tl_var_value r = tree_lookup_var_value (*T, t);
1013 return r.ptr ? r.num_val : 0;
1014 }
1015
1016 int namespace_level;
1017
1018 struct tree_tl_var *vars[10];
1019 struct tree_tl_field *fields[10];
1020 struct tl_var *last_num_var[10];
1021
tl_is_type_name(const char * id,int len)1022 int tl_is_type_name (const char *id, int len) {
1023 if (len == 1 && *id == '#') { return 1;}
1024 int ok = id[0] >= 'A' && id[0] <= 'Z';
1025 int i;
1026 for (i = 0; i < len - 1; i++) if (id[i] == '.') {
1027 ok = id[i + 1] >= 'A' && id[i + 1] <= 'Z';
1028 }
1029 return ok;
1030 }
1031
tl_add_field(char * id)1032 int tl_add_field (char *id) {
1033 assert (namespace_level < 10);
1034 assert (namespace_level >= 0);
1035 if (tree_lookup_tl_field (fields[namespace_level], id)) {
1036 return 0;
1037 }
1038 fields[namespace_level] = tree_insert_tl_field (fields[namespace_level], id, lrand48 ());
1039 return 1;
1040 }
1041
tl_clear_fields(void)1042 void tl_clear_fields (void) {
1043 // tree_act_tl_field (fields[namespace_level], (void *)free);
1044 fields[namespace_level] = tree_clear_tl_field (fields[namespace_level]);
1045 }
1046
tl_add_var(char * id,struct tl_combinator_tree * ptr,int type)1047 struct tl_var *tl_add_var (char *id, struct tl_combinator_tree *ptr, int type) {
1048 struct tl_var *v = talloc (sizeof (*v));
1049 v->id = tstrdup (id);
1050 v->type = type;
1051 v->ptr = ptr;
1052 v->flags = 0;
1053 if (tree_lookup_tl_var (vars[namespace_level], v)) {
1054 return 0;
1055 }
1056 vars[namespace_level] = tree_insert_tl_var (vars[namespace_level], v, lrand48 ());
1057 if (type) {
1058 last_num_var[namespace_level] = v;
1059 }
1060 return v;
1061 }
1062
tl_del_var(struct tl_var * v)1063 void tl_del_var (struct tl_var *v) {
1064 // free (v->id);
1065 tfree (v, sizeof (*v));
1066 }
1067
tl_clear_vars(void)1068 void tl_clear_vars (void) {
1069 tree_act_tl_var (vars[namespace_level], tl_del_var);
1070 vars[namespace_level] = tree_clear_tl_var (vars[namespace_level]);
1071 last_num_var[namespace_level] = 0;
1072 }
1073
tl_get_last_num_var(void)1074 struct tl_var *tl_get_last_num_var (void) {
1075 return last_num_var[namespace_level];
1076 }
1077
tl_get_var(char * _id,int len)1078 struct tl_var *tl_get_var (char *_id, int len) {
1079 char *id = mystrdup (_id, len);
1080 struct tl_var v = {.id = id};
1081 int i;
1082 for (i = namespace_level; i >= 0; i--) {
1083 struct tl_var *w = tree_lookup_tl_var (vars[i], &v);
1084 if (w) {
1085 tfree (id, len + 1);
1086 return w;
1087 }
1088 }
1089 tfree (id, len + 1);
1090 return 0;
1091 }
1092
namespace_push(void)1093 void namespace_push (void) {
1094 namespace_level ++;
1095 assert (namespace_level < 10);
1096 tl_clear_vars ();
1097 tl_clear_fields ();
1098 }
1099
namespace_pop(void)1100 void namespace_pop (void) {
1101 namespace_level --;
1102 assert (namespace_level >= 0);
1103 }
1104
tl_get_type(const char * _id,int len)1105 struct tl_type *tl_get_type (const char *_id, int len) {
1106 char *id = mystrdup (_id, len);
1107 struct tl_type _t = {.id = id};
1108 struct tl_type *r = tree_lookup_tl_type (tl_type_tree, &_t);
1109 tfree (id, len + 1);
1110 return r;
1111 }
1112
tl_add_type(const char * _id,int len,int params_num,long long params_types)1113 struct tl_type *tl_add_type (const char *_id, int len, int params_num, long long params_types) {
1114 char *id = talloc (len + 1);
1115 memcpy (id, _id, len);
1116 id[len] = 0;
1117 struct tl_type _t = {.id = id};
1118 struct tl_type *_r = 0;
1119 if ((_r = tree_lookup_tl_type (tl_type_tree, &_t))) {
1120 tfree (id, len + 1);
1121 if (params_num >= 0 && (_r->params_num != params_num || _r->params_types != params_types)) {
1122 TL_ERROR ("Wrong params_num or types for type %s\n", _r->id);
1123 return 0;
1124 }
1125 return _r;
1126 }
1127 struct tl_type *t = talloc (sizeof (*t));
1128 t->id = id;
1129 t->print_id = tstrdup (t->id);
1130 int i;
1131 for (i = 0; i < len; i++) if (t->print_id[i] == '.' || t->print_id[i] == '#' || t->print_id[i] == ' ') {
1132 t->print_id[i] = '$';
1133 }
1134 t->name = 0;
1135 t->constructors_num = 0;
1136 t->constructors = 0;
1137 t->flags = 0;
1138 t->real_id = 0;
1139 if (params_num >= 0) {
1140 assert (params_num <= 64);
1141 t->params_num = params_num;
1142 t->params_types = params_types;
1143 } else {
1144 t->flags |= 4;
1145 t->params_num = -1;
1146 }
1147 tl_type_tree = tree_insert_tl_type (tl_type_tree, t, lrand48 ());
1148 total_types_num ++;
1149 return t;
1150 }
1151
tl_add_type_param(struct tl_type * t,int x)1152 void tl_add_type_param (struct tl_type *t, int x) {
1153 assert (t->flags & 4);
1154 assert (t->params_num <= 64);
1155 if (x) {
1156 t->params_types |= (1ull << (t->params_num ++));
1157 } else {
1158 t->params_num ++;
1159 }
1160 }
1161
tl_type_set_params(struct tl_type * t,int x,long long y)1162 int tl_type_set_params (struct tl_type *t, int x, long long y) {
1163 if (t->flags & 4) {
1164 t->params_num = x;
1165 t->params_types = y;
1166 t->flags &= ~4;
1167 } else {
1168 if (t->params_num != x || t->params_types != y) {
1169 fprintf (stderr, "Wrong num of params (type %s)\n", t->id);
1170 return 0;
1171 }
1172 }
1173 return 1;
1174 }
1175
tl_type_finalize(struct tl_type * t)1176 void tl_type_finalize (struct tl_type *t) {
1177 t->flags &= ~4;
1178 }
1179
tl_get_constructor(const char * _id,int len)1180 struct tl_constructor *tl_get_constructor (const char *_id, int len) {
1181 char *id = mystrdup (_id, len);
1182 struct tl_constructor _t = {.id = id};
1183 struct tl_constructor *r = tree_lookup_tl_constructor (tl_constructor_tree, &_t);
1184 tfree (id, len + 1);
1185 return r;
1186 }
1187
tl_add_constructor(struct tl_type * a,const char * _id,int len,int force_magic)1188 struct tl_constructor *tl_add_constructor (struct tl_type *a, const char *_id, int len, int force_magic) {
1189 assert (a);
1190 if (a->flags & 1) {
1191 TL_ERROR ("New constructor for type `%s` after final statement\n", a->id);
1192 return 0;
1193 }
1194 int x = 0;
1195 while (x < len && (_id[x] != '#' || force_magic)) { x++; }
1196 char *id = talloc (x + 1);
1197 memcpy (id, _id, x);
1198 id[x] = 0;
1199
1200 unsigned magic = 0;
1201 if (x < len) {
1202 assert (len - x >= 6 && len - x <= 9);
1203 int i;
1204 for (i = 1; i < len - x; i++) {
1205 magic = (magic << 4) + (_id[x + i] <= '9' ? _id[x + i] - '0' : _id[x + i] - 'a' + 10);
1206 }
1207 assert (magic && magic != (unsigned)-1);
1208 }
1209
1210 len = x;
1211 if (*id != '_') {
1212 struct tl_constructor _t = {.id = id};
1213 if (tree_lookup_tl_constructor (tl_constructor_tree, &_t)) {
1214 TL_ERROR ("Duplicate constructor id `%s`\n", id);
1215 tfree (id, len + 1);
1216 return 0;
1217 }
1218 } else {
1219 assert (len == 1);
1220 }
1221
1222 struct tl_constructor *t = talloc (sizeof (*t));
1223 t->type = a;
1224 t->name = magic;
1225 t->id = id;
1226 t->print_id = tstrdup (id);
1227 t->real_id = 0;
1228
1229 int i;
1230 for (i = 0; i < len; i++) if (t->print_id[i] == '.' || t->print_id[i] == '#' || t->print_id[i] == ' ') {
1231 t->print_id[i] = '$';
1232 }
1233
1234 t->left = t->right = 0;
1235 a->constructors = realloc (a->constructors, sizeof (void *) * (a->constructors_num + 1));
1236 assert (a->constructors);
1237 a->constructors[a->constructors_num ++] = t;
1238 if (*id != '_') {
1239 tl_constructor_tree = tree_insert_tl_constructor (tl_constructor_tree, t, lrand48 ());
1240 } else {
1241 a->flags |= FLAG_DEFAULT_CONSTRUCTOR;
1242 }
1243 total_constructors_num ++;
1244 return t;
1245 }
1246
tl_get_function(const char * _id,int len)1247 struct tl_constructor *tl_get_function (const char *_id, int len) {
1248 char *id = mystrdup (_id, len);
1249 struct tl_constructor _t = {.id = id};
1250 struct tl_constructor *r = tree_lookup_tl_constructor (tl_function_tree, &_t);
1251 tfree (id, len + 1);
1252 return r;
1253 }
1254
tl_add_function(struct tl_type * a,const char * _id,int len,int force_magic)1255 struct tl_constructor *tl_add_function (struct tl_type *a, const char *_id, int len, int force_magic) {
1256 // assert (a);
1257 int x = 0;
1258 while (x < len && ((_id[x] != '#') || force_magic)) { x++; }
1259 char *id = talloc (x + 1);
1260 memcpy (id, _id, x);
1261 id[x] = 0;
1262
1263 unsigned magic = 0;
1264 if (x < len) {
1265 assert (len - x >= 6 && len - x <= 9);
1266 int i;
1267 for (i = 1; i < len - x; i++) {
1268 magic = (magic << 4) + (_id[x + i] <= '9' ? _id[x + i] - '0' : _id[x + i] - 'a' + 10);
1269 }
1270 assert (magic && magic != (unsigned)-1);
1271 }
1272
1273 len = x;
1274
1275 struct tl_constructor _t = {.id = id};
1276 if (tree_lookup_tl_constructor (tl_function_tree, &_t)) {
1277 TL_ERROR ("Duplicate function id `%s`\n", id);
1278 tfree (id, len + 1);
1279 return 0;
1280 }
1281
1282 struct tl_constructor *t = talloc (sizeof (*t));
1283 t->type = a;
1284 t->name = magic;
1285 t->id = id;
1286 t->print_id = tstrdup (id);
1287 t->real_id = 0;
1288
1289 int i;
1290 for (i = 0; i < len; i++) if (t->print_id[i] == '.' || t->print_id[i] == '#' || t->print_id[i] == ' ') {
1291 t->print_id[i] = '$';
1292 }
1293
1294 t->left = t->right = 0;
1295 tl_function_tree = tree_insert_tl_constructor (tl_function_tree, t, lrand48 ());
1296 total_functions_num ++;
1297 return t;
1298 }
1299
1300 static char buf[(1 << 20)];
1301 int buf_pos;
1302
alloc_ctree_node(void)1303 struct tl_combinator_tree *alloc_ctree_node (void) {
1304 struct tl_combinator_tree *T = talloc (sizeof (*T));
1305 assert (T);
1306 memset (T, 0, sizeof (*T));
1307 return T;
1308 }
1309
tl_tree_dup(struct tl_combinator_tree * T)1310 struct tl_combinator_tree *tl_tree_dup (struct tl_combinator_tree *T) {
1311 if (!T) { return 0; }
1312 struct tl_combinator_tree *S = talloc (sizeof (*S));
1313 memcpy (S, T, sizeof (*S));
1314 S->left = tl_tree_dup (T->left);
1315 S->right = tl_tree_dup (T->right);
1316 return S;
1317 }
1318
tl_tree_get_type(struct tl_combinator_tree * T)1319 struct tl_type *tl_tree_get_type (struct tl_combinator_tree *T) {
1320 assert (T->type == type_type);
1321 if (T->act == act_array) { return 0;}
1322 while (T->left) {
1323 T = T->left;
1324 if (T->act == act_array) { return 0;}
1325 assert (T->type == type_type);
1326 }
1327 assert (T->act == act_type || T->act == act_var || T->act == act_array);
1328 return T->act == act_type ? T->data : 0;
1329 }
1330
tl_tree_set_len(struct tl_combinator_tree * T)1331 void tl_tree_set_len (struct tl_combinator_tree *T) {
1332 TL_INIT (H);
1333 H = T;
1334 while (H->left) {
1335 H->left->type_len = H->type_len + 1;
1336 H = H->left;
1337 }
1338 assert (H->type == type_type);
1339 struct tl_type *t = H->data;
1340 assert (t);
1341 assert (H->type_len == t->params_num);
1342 }
1343
tl_buf_reset(void)1344 void tl_buf_reset (void) {
1345 buf_pos = 0;
1346 }
1347
tl_buf_add_string(char * s,int len)1348 void tl_buf_add_string (char *s, int len) {
1349 if (len < 0) { len = strlen (s); }
1350 buf[buf_pos ++] = ' ';
1351 memcpy (buf + buf_pos, s, len); buf_pos += len;
1352 buf[buf_pos] = 0;
1353 }
1354
tl_buf_add_string_nospace(char * s,int len)1355 void tl_buf_add_string_nospace (char *s, int len) {
1356 if (len < 0) { len = strlen (s); }
1357 // if (buf_pos) { buf[buf_pos ++] = ' '; }
1358 memcpy (buf + buf_pos, s, len); buf_pos += len;
1359 buf[buf_pos] = 0;
1360 }
1361
tl_buf_add_string_q(char * s,int len,int x)1362 void tl_buf_add_string_q (char *s, int len, int x) {
1363 if (x) {
1364 tl_buf_add_string (s, len);
1365 } else {
1366 tl_buf_add_string_nospace (s, len);
1367 }
1368 }
1369
1370
tl_buf_add_tree(struct tl_combinator_tree * T,int x)1371 void tl_buf_add_tree (struct tl_combinator_tree *T, int x) {
1372 if (!T) { return; }
1373 assert (T != (void *)-1l && T != (void *)-2l);
1374 switch (T->act) {
1375 case act_question_mark:
1376 tl_buf_add_string_q ("?", -1, x);
1377 return;
1378 case act_type:
1379 if ((T->flags & 1) && !(T->flags & 4)) {
1380 tl_buf_add_string_q ("%", -1, x);
1381 x = 0;
1382 }
1383 if (T->flags & 2) {
1384 tl_buf_add_string_q ((char *)T->data, -1, x);
1385 } else {
1386 struct tl_type *t = T->data;
1387 if (T->flags & 4) {
1388 assert (t->constructors_num == 1);
1389 tl_buf_add_string_q (t->constructors[0]->real_id ? t->constructors[0]->real_id : t->constructors[0]->id, -1, x);
1390 } else {
1391 tl_buf_add_string_q (t->real_id ? t->real_id : t->id, -1, x);
1392 }
1393 }
1394 return;
1395 case act_field:
1396 if (T->data) {
1397 tl_buf_add_string_q ((char *)T->data, -1, x);
1398 x = 0;
1399 tl_buf_add_string_q (":", -1, 0);
1400 }
1401 tl_buf_add_tree (T->left, x);
1402 tl_buf_add_tree (T->right, 1);
1403 return;
1404 case act_union:
1405 tl_buf_add_tree (T->left, x);
1406 tl_buf_add_tree (T->right, 1);
1407 return;
1408 case act_var:
1409 {
1410 if (T->data == (void *)-1l) { return; }
1411 struct tl_combinator_tree *v = T->data;
1412 tl_buf_add_string_q ((char *)v->data, -1, x);
1413 if (T->type == type_num && T->type_flags) {
1414 static char _buf[30];
1415 sprintf (_buf, "+%lld", T->type_flags);
1416 tl_buf_add_string_q (_buf, -1, 0);
1417 }
1418 }
1419 return;
1420 case act_arg:
1421 tl_buf_add_tree (T->left, x);
1422 tl_buf_add_tree (T->right, 1);
1423 return;
1424 case act_array:
1425 if (T->left && !(T->left->flags & 128)) {
1426 tl_buf_add_tree (T->left, x);
1427 x = 0;
1428 tl_buf_add_string_q ("*", -1, x);
1429 }
1430 tl_buf_add_string_q ("[", -1, x);
1431 tl_buf_add_tree (T->right, 1);
1432 tl_buf_add_string_q ("]", -1, 1);
1433 return;
1434 case act_plus:
1435 tl_buf_add_tree (T->left, x);
1436 tl_buf_add_string_q ("+", -1, 0);
1437 tl_buf_add_tree (T->right, 0);
1438 return;
1439 case act_nat_const:
1440 {
1441 static char _buf[30];
1442 snprintf (_buf, 29, "%lld", T->type_flags);
1443 tl_buf_add_string_q (_buf, -1, x);
1444 return;
1445 }
1446 case act_opt_field:
1447 {
1448 struct tl_combinator_tree *v = T->left->data;
1449 tl_buf_add_string_q ((char *)v->data, -1, x);
1450 tl_buf_add_string_q (".", -1, 0);
1451 static char _buf[30];
1452 sprintf (_buf, "%lld", T->left->type_flags);
1453 tl_buf_add_string_q (_buf, -1, 0);
1454 tl_buf_add_string_q ("?", -1, 0);
1455 tl_buf_add_tree (T->right, 0);
1456 return;
1457 }
1458
1459 default:
1460 fprintf (stderr, "%s %s\n", TL_ACT (T->act), TL_TYPE (T->type));
1461 assert (0);
1462 return;
1463 }
1464 }
1465
tl_count_combinator_name(struct tl_constructor * c)1466 int tl_count_combinator_name (struct tl_constructor *c) {
1467 assert (c);
1468 tl_buf_reset ();
1469 tl_buf_add_string_nospace (c->real_id ? c->real_id : c->id, -1);
1470 tl_buf_add_tree (c->left, 1);
1471 tl_buf_add_string ("=", -1);
1472 tl_buf_add_tree (c->right, 1);
1473 //fprintf (stderr, "%.*s\n", buf_pos, buf);
1474 if (!c->name) {
1475 c->name = compute_crc32 (buf, buf_pos);
1476 }
1477 return c->name;
1478 }
1479
tl_print_combinator(struct tl_constructor * c)1480 int tl_print_combinator (struct tl_constructor *c) {
1481 tl_buf_reset ();
1482 tl_buf_add_string_nospace (c->real_id ? c->real_id : c->id, -1);
1483 static char _buf[10];
1484 sprintf (_buf, "#%08x", c->name);
1485 tl_buf_add_string_nospace (_buf, -1);
1486 tl_buf_add_tree (c->left, 1);
1487 tl_buf_add_string ("=", -1);
1488 tl_buf_add_tree (c->right, 1);
1489 if (output_expressions >= 1) {
1490 fprintf (stderr, "%.*s\n", buf_pos, buf);
1491 }
1492 /* if (!c->name) {
1493 c->name = compute_crc32 (buf, buf_pos);
1494 }*/
1495 return c->name;
1496 }
1497
_tl_finish_subtree(struct tl_combinator_tree * R,int x,long long y)1498 int _tl_finish_subtree (struct tl_combinator_tree *R, int x, long long y) {
1499 assert (R->type == type_type);
1500 assert (R->type_len < 0);
1501 assert (R->act == act_arg || R->act == act_type);
1502 R->type_len = x;
1503 R->type_flags = y;
1504 if (R->act == act_type) {
1505 struct tl_type *t = R->data;
1506 assert (t);
1507 return tl_type_set_params (t, x, y);
1508 }
1509 assert ((R->right->type == type_type && R->right->type_len == 0) || R->right->type == type_num || R->right->type == type_num_value);
1510 return _tl_finish_subtree (R->left, x + 1, y * 2 + (R->right->type == type_num || R->right->type == type_num_value));
1511 }
1512
tl_finish_subtree(struct tl_combinator_tree * R)1513 int tl_finish_subtree (struct tl_combinator_tree *R) {
1514 assert (R);
1515 if (R->type != type_type) {
1516 return 1;
1517 }
1518 if (R->type_len >= 0) {
1519 if (R->type_len > 0) {
1520 TL_ERROR ("Not enough params\n");
1521 return 0;
1522 }
1523 return 1;
1524 }
1525 return _tl_finish_subtree (R, 0, 0);
1526 }
1527
tl_union(struct tl_combinator_tree * L,struct tl_combinator_tree * R)1528 struct tl_combinator_tree *tl_union (struct tl_combinator_tree *L, struct tl_combinator_tree *R) {
1529 if (!L) { return R; }
1530 if (!R) { return L; }
1531 TL_INIT (v);
1532 v = alloc_ctree_node ();
1533 v->left = L;
1534 v->right = R;
1535 switch (L->type) {
1536 case type_num:
1537 if (R->type != type_num_value) {
1538 TL_ERROR ("Union: type mistmatch\n");
1539 return 0;
1540 }
1541 tfree (v, sizeof (*v));
1542 L->type_flags += R->type_flags;
1543 return L;
1544 case type_num_value:
1545 if (R->type != type_num_value && R->type != type_num) {
1546 TL_ERROR ("Union: type mistmatch\n");
1547 return 0;
1548 }
1549 tfree (v, sizeof (*v));
1550 R->type_flags += L->type_flags;
1551 return R;
1552 case type_list_item:
1553 case type_list:
1554 if (R->type != type_list_item) {
1555 TL_ERROR ("Union: type mistmatch\n");
1556 return 0;
1557 }
1558 v->type = type_list;
1559 v->act = act_union;
1560 return v;
1561 case type_type:
1562 if (L->type_len == 0) {
1563 TL_ERROR ("Arguments number exceeds type arity\n");
1564 return 0;
1565 }
1566 if (R->type != type_num && R->type != type_type && R->type != type_num_value) {
1567 TL_ERROR ("Union: type mistmatch\n");
1568 return 0;
1569 }
1570 if (R->type_len < 0) {
1571 if (!tl_finish_subtree (R)) {
1572 return 0;
1573 }
1574 }
1575 if (R->type_len > 0) {
1576 TL_ERROR ("Argument type must have full number of arguments\n");
1577 return 0;
1578 }
1579 if (L->type_len > 0 && ((L->type_flags & 1) != (R->type == type_num || R->type == type_num_value))) {
1580 TL_ERROR ("Argument types mistmatch: L->type_flags = %lld, R->type = %s\n", L->flags, TL_TYPE (R->type));
1581 return 0;
1582 }
1583 v->type = type_type;
1584 v->act = act_arg;
1585 v->type_len = L->type_len > 0 ? L->type_len - 1 : -1;
1586 v->type_flags = L->type_flags >> 1;
1587 return v;
1588 default:
1589 assert (0);
1590 return 0;
1591 }
1592 }
1593
1594 struct tl_combinator_tree *tl_parse_any_term (struct tree *T, int s);
tl_parse_term(struct tree * T,int s)1595 struct tl_combinator_tree *tl_parse_term (struct tree *T, int s) {
1596 assert (T->type == type_term);
1597 int i = 0;
1598 while (i < T->nc && T->c[i]->type == type_percent) { i ++; s ++; }
1599 assert (i < T->nc);
1600 TL_INIT (L);
1601 while (i < T->nc) {
1602 TL_TRY (tl_parse_any_term (T->c[i], s), L);
1603 s = 0;
1604 i ++;
1605 }
1606 return L;
1607 }
1608
1609
tl_parse_type_term(struct tree * T,int s)1610 struct tl_combinator_tree *tl_parse_type_term (struct tree *T, int s) {
1611 assert (T->type == type_type_term);
1612 assert (T->nc == 1);
1613 struct tl_combinator_tree *Z = tl_parse_term (T->c[0], s);
1614 if (!Z || Z->type != type_type) { if (Z) { TL_ERROR ("type_term: found type %s\n", TL_TYPE (Z->type)); } TL_FAIL; }
1615 return Z;
1616 }
1617
tl_parse_nat_term(struct tree * T,int s)1618 struct tl_combinator_tree *tl_parse_nat_term (struct tree *T, int s) {
1619 assert (T->type == type_nat_term);
1620 assert (T->nc == 1);
1621 struct tl_combinator_tree *Z = tl_parse_term (T->c[0], s);
1622 if (!Z || (Z->type != type_num && Z->type != type_num_value)) { if (Z) { TL_ERROR ("nat_term: found type %s\n", TL_TYPE (Z->type)); }TL_FAIL; }
1623 return Z;
1624 }
1625
tl_parse_subexpr(struct tree * T,int s)1626 struct tl_combinator_tree *tl_parse_subexpr (struct tree *T, int s) {
1627 assert (T->type == type_subexpr);
1628 assert (T->nc >= 1);
1629 int i;
1630 TL_INIT (L);
1631 for (i = 0; i < T->nc; i++) {
1632 TL_TRY (tl_parse_any_term (T->c[i], s), L);
1633 s = 0;
1634 }
1635 return L;
1636 }
1637
tl_parse_expr(struct tree * T,int s)1638 struct tl_combinator_tree *tl_parse_expr (struct tree *T, int s) {
1639 assert (T->type == type_expr);
1640 assert (T->nc >= 1);
1641 int i;
1642 TL_INIT (L);
1643 for (i = 0; i < T->nc; i++) {
1644 TL_TRY (tl_parse_subexpr (T->c[i], s), L);
1645 s = 0;
1646 }
1647 return L;
1648 }
1649
tl_parse_nat_const(struct tree * T,int s)1650 struct tl_combinator_tree *tl_parse_nat_const (struct tree *T, int s) {
1651 assert (T->type == type_nat_const);
1652 assert (!T->nc);
1653 if (s > 0) {
1654 TL_ERROR ("Nat const can not preceed with %%\n");
1655 TL_FAIL;
1656 }
1657 assert (T->type == type_nat_const);
1658 assert (!T->nc);
1659 TL_INIT (L);
1660 L = alloc_ctree_node ();
1661 L->act = act_nat_const;
1662 L->type = type_num_value;
1663 int i;
1664 long long x = 0;
1665 for (i = 0; i < T->len; i++) {
1666 x = x * 10 + T->text[i] - '0';
1667 }
1668 L->type_flags = x;
1669 return L;
1670 }
1671
tl_parse_ident(struct tree * T,int s)1672 struct tl_combinator_tree *tl_parse_ident (struct tree *T, int s) {
1673 assert (T->type == type_type_ident || T->type == type_var_ident || T->type == type_boxed_type_ident);
1674 assert (!T->nc);
1675 struct tl_var *v = tl_get_var (T->text, T->len);
1676 TL_INIT (L);
1677 if (v) {
1678 L = alloc_ctree_node ();
1679 L->act = act_var;
1680 L->type = v->type ? type_num : type_type;
1681 if (L->type == type_num && s) {
1682 TL_ERROR ("Nat var can not preceed with %%\n");
1683 TL_FAIL;
1684 } else {
1685 if (s) {
1686 L->flags |= 1;
1687 }
1688 }
1689 L->type_len = 0;
1690 L->type_flags = 0;
1691 L->data = v->ptr;
1692 return L;
1693 }
1694
1695 /* if (!mystrcmp2 (T->text, T->len, "#") || !mystrcmp2 (T->text, T->len, "Type")) {
1696 L = alloc_ctree_node ();
1697 L->act = act_type;
1698 L->flags |= 2;
1699 L->data = tl_get_type (T->text, T->len);
1700 assert (L->data);
1701 L->type = type_type;
1702 L->type_len = 0;
1703 L->type_flags = 0;
1704 return L;
1705 }*/
1706
1707 struct tl_constructor *c = tl_get_constructor (T->text, T->len);
1708 if (c) {
1709 assert (c->type);
1710 if (c->type->constructors_num != 1) {
1711 TL_ERROR ("Constructor can be used only if it is the only constructor of the type\n");
1712 return 0;
1713 }
1714 c->type->flags |= 1;
1715 L = alloc_ctree_node ();
1716 L->act = act_type;
1717 L->flags |= 5;
1718 L->data = c->type;
1719 L->type = type_type;
1720 L->type_len = c->type->params_num;
1721 L->type_flags = c->type->params_types;
1722 return L;
1723 }
1724 int x = tl_is_type_name (T->text, T->len);
1725 if (x) {
1726 struct tl_type *t = tl_add_type (T->text, T->len, -1, 0);
1727 L = alloc_ctree_node ();
1728 if (s) {
1729 L->flags |= 1;
1730 t->flags |= 8;
1731 }
1732 L->act = act_type;
1733 L->data = t;
1734 L->type = type_type;
1735 L->type_len = t->params_num;
1736 L->type_flags = t->params_types;
1737 return L;
1738 } else {
1739 TL_ERROR ("Not a type/var ident `%.*s`\n", T->len, T->text);
1740 return 0;
1741 }
1742 }
1743
tl_parse_any_term(struct tree * T,int s)1744 struct tl_combinator_tree *tl_parse_any_term (struct tree *T, int s) {
1745 switch (T->type) {
1746 case type_type_term:
1747 return tl_parse_type_term (T, s);
1748 case type_nat_term:
1749 return tl_parse_nat_term (T, s);
1750 case type_term:
1751 return tl_parse_term (T, s);
1752 case type_expr:
1753 return tl_parse_expr (T, s);
1754 case type_subexpr:
1755 return tl_parse_subexpr (T, s);
1756 case type_nat_const:
1757 return tl_parse_nat_const (T, s);
1758 case type_type_ident:
1759 case type_var_ident:
1760 return tl_parse_ident (T, s);
1761 default:
1762 fprintf (stderr, "type = %d\n", T->type);
1763 assert (0);
1764 return 0;
1765 }
1766 }
1767
tl_parse_multiplicity(struct tree * T)1768 struct tl_combinator_tree *tl_parse_multiplicity (struct tree *T) {
1769 assert (T->type == type_multiplicity);
1770 assert (T->nc == 1);
1771 return tl_parse_nat_term (T->c[0], 0);
1772 }
1773
tl_parse_opt_args(struct tree * T)1774 struct tl_combinator_tree *tl_parse_opt_args (struct tree *T) {
1775 assert (T);
1776 assert (T->type == type_opt_args);
1777 assert (T->nc >= 2);
1778 TL_INIT (R);
1779 TL_TRY (tl_parse_type_term (T->c[T->nc - 1], 0), R);
1780 assert (R->type == type_type && !R->type_len);
1781 assert (tl_finish_subtree (R));
1782 struct tl_type *t = tl_tree_get_type (R);
1783 //assert (t);
1784 int tt = -1;
1785 if (t && !strcmp (t->id, "#")) {
1786 tt = 1;
1787 } else if (t && !strcmp (t->id, "Type")) {
1788 tt = 0;
1789 }
1790 if (tt < 0) {
1791 TL_ERROR ("Optargs can be only of type # or Type\n");
1792 TL_FAIL;
1793 }
1794
1795 int i;
1796 for (i = 0; i < T->nc - 1; i++) {
1797 if (T->c[i]->type != type_var_ident) {
1798 TL_ERROR ("Variable name expected\n");
1799 TL_FAIL;
1800 }
1801 if (T->c[i]->len == 1 && *T->c[i]->text == '_') {
1802 TL_ERROR ("Variables can not be unnamed\n");
1803 TL_FAIL;
1804 }
1805 }
1806 TL_INIT (H);
1807 // for (i = T->nc - 2; i >= (T->nc >= 2 ? 0 : -1); i--) {
1808 for (i = 0; i <= T->nc - 2; i++) {
1809 TL_INIT (S); S = alloc_ctree_node ();
1810 S->left = (i == T->nc - 2) ? R : tl_tree_dup (R) ; S->right = 0;
1811 S->type = type_list_item;
1812 S->type_len = 0;
1813 S->act = act_field;
1814 S->data = i >= 0 ? mystrdup (T->c[i]->text, T->c[i]->len) : 0;
1815 if (tt >= 0) {
1816 assert (S->data);
1817 tl_add_var (S->data, S, tt);
1818 }
1819 S->flags = 33;
1820 H = tl_union (H, S);
1821 }
1822 return H;
1823 }
1824
1825 struct tl_combinator_tree *tl_parse_args (struct tree *T);
tl_parse_args2(struct tree * T)1826 struct tl_combinator_tree *tl_parse_args2 (struct tree *T) {
1827 assert (T);
1828 assert (T->type == type_args2);
1829 assert (T->nc >= 1);
1830 TL_INIT (R);
1831 TL_INIT (L);
1832 int x = 0;
1833 char *field_name = 0;
1834 if (T->c[x]->type == type_var_ident_opt || T->c[x]->type == type_var_ident) {
1835 field_name = mystrdup (T->c[x]->text, T->c[x]->len);
1836 if (!tl_add_field (field_name)) {
1837 TL_ERROR ("Duplicate field name %s\n", field_name);
1838 TL_FAIL;
1839 }
1840 x ++;
1841 }
1842 //fprintf (stderr, "%d %d\n", x, T->nc);
1843 if (T->c[x]->type == type_multiplicity) {
1844 L = tl_parse_multiplicity (T->c[x]);
1845 if (!L) { TL_FAIL;}
1846 x ++;
1847 } else {
1848 struct tl_var *v = tl_get_last_num_var ();
1849 if (!v) {
1850 TL_ERROR ("Expected multiplicity or nat var\n");
1851 TL_FAIL;
1852 }
1853 L = alloc_ctree_node ();
1854 L->act = act_var;
1855 L->type = type_num;
1856 L->flags |= 128;
1857 L->type_len = 0;
1858 L->type_flags = 0;
1859 L->data = v->ptr;
1860 ((struct tl_combinator_tree *)(v->ptr))->flags |= 256;
1861 }
1862 namespace_push ();
1863 while (x < T->nc) {
1864 TL_TRY (tl_parse_args (T->c[x]), R);
1865 x ++;
1866 }
1867 namespace_pop ();
1868 struct tl_combinator_tree *S = alloc_ctree_node ();
1869 S->type = type_type;
1870 S->type_len = 0;
1871 S->act = act_array;
1872 S->left = L;
1873 S->right = R;
1874 //S->data = field_name;
1875
1876 struct tl_combinator_tree *H = alloc_ctree_node ();
1877 H->type = type_list_item;
1878 H->act = act_field;
1879 H->left = S;
1880 H->right = 0;
1881 H->data = field_name;
1882 H->type_len = 0;
1883
1884 return H;
1885 }
1886
1887 void tl_mark_vars (struct tl_combinator_tree *T);
tl_parse_args134(struct tree * T)1888 struct tl_combinator_tree *tl_parse_args134 (struct tree *T) {
1889 assert (T);
1890 assert (T->type == type_args1 || T->type == type_args3 || T->type == type_args4);
1891 assert (T->nc >= 1);
1892 TL_INIT (R);
1893 TL_TRY (tl_parse_type_term (T->c[T->nc - 1], 0), R);
1894 assert (tl_finish_subtree (R));
1895 assert (R->type == type_type && !R->type_len);
1896 struct tl_type *t = tl_tree_get_type (R);
1897 //assert (t);
1898 int tt = -1;
1899 if (t && !strcmp (t->id, "#")) {
1900 tt = 1;
1901 } else if (t && !strcmp (t->id, "Type")) {
1902 tt = 0;
1903 }
1904
1905 /* if (tt >= 0 && T->nc == 1) {
1906 TL_ERROR ("Variables can not be unnamed (type %d)\n", tt);
1907 }*/
1908 int last = T->nc - 2;
1909 int excl = 0;
1910 if (last >= 0 && T->c[last]->type == type_exclam) {
1911 excl ++;
1912 tl_mark_vars (R);
1913 last --;
1914 }
1915 if (last >= 0 && T->c[last]->type == type_optional_arg_def) {
1916 assert (T->c[last]->nc == 2);
1917 TL_INIT (E); E = alloc_ctree_node ();
1918 E->type = type_type;
1919 E->act = act_opt_field;
1920 E->left = tl_parse_ident (T->c[last]->c[0], 0);
1921 int i;
1922 long long x = 0;
1923 for (i = 0; i < T->c[last]->c[1]->len; i++) {
1924 x = x * 10 + T->c[last]->c[1]->text[i] - '0';
1925 }
1926 E->left->type_flags = x;
1927 E->type_flags = R->type_flags;
1928 E->type_len = R->type_len;
1929 E->right = R;
1930 R = E;
1931 last --;
1932 }
1933 int i;
1934 for (i = 0; i < last; i++) {
1935 if (T->c[i]->type != type_var_ident && T->c[i]->type != type_var_ident_opt) {
1936 TL_ERROR ("Variable name expected\n");
1937 TL_FAIL;
1938 }
1939 /* if (tt >= 0 && (T->nc == 1 || (T->c[i]->len == 1 && *T->c[i]->text == '_'))) {
1940 TL_ERROR ("Variables can not be unnamed\n");
1941 TL_FAIL;
1942 }*/
1943 }
1944 TL_INIT (H);
1945 // for (i = T->nc - 2; i >= (T->nc >= 2 ? 0 : -1); i--) {
1946 for (i = (last >= 0 ? 0 : -1); i <= last; i++) {
1947 TL_INIT (S); S = alloc_ctree_node ();
1948 S->left = (i == last) ? R : tl_tree_dup (R) ; S->right = 0;
1949 S->type = type_list_item;
1950 S->type_len = 0;
1951 S->act = act_field;
1952 S->data = i >= 0 ? mystrdup (T->c[i]->text, T->c[i]->len) : 0;
1953 if (excl) {
1954 S->flags |= FLAG_EXCL;
1955 }
1956 if (S->data && (T->c[i]->len >= 2 || *T->c[i]->text != '_')) {
1957 if (!tl_add_field (S->data)) {
1958 TL_ERROR ("Duplicate field name %s\n", (char *)S->data);
1959 TL_FAIL;
1960 }
1961 }
1962 if (tt >= 0) {
1963 //assert (S->data);
1964 char *name = S->data;
1965 if (!name) {
1966 static char s[20];
1967 sprintf (s, "%lld", lrand48 () * (1ll << 32) + lrand48 ());
1968 name = s;
1969 }
1970 struct tl_var *v = tl_add_var (name, S, tt);
1971 if (!v) {TL_FAIL;}
1972 v->flags |= 2;
1973 }
1974
1975 H = tl_union (H, S);
1976 }
1977 return H;
1978 }
1979
1980
tl_parse_args(struct tree * T)1981 struct tl_combinator_tree *tl_parse_args (struct tree *T) {
1982 assert (T->type == type_args);
1983 assert (T->nc == 1);
1984 switch (T->c[0]->type) {
1985 case type_args1:
1986 return tl_parse_args134 (T->c[0]);
1987 case type_args2:
1988 return tl_parse_args2 (T->c[0]);
1989 case type_args3:
1990 return tl_parse_args134 (T->c[0]);
1991 case type_args4:
1992 return tl_parse_args134 (T->c[0]);
1993 default:
1994 assert (0);
1995 return 0;
1996 }
1997 }
1998
tl_mark_vars(struct tl_combinator_tree * T)1999 void tl_mark_vars (struct tl_combinator_tree *T) {
2000 if (!T) { return; }
2001 if (T->act == act_var) {
2002 char *id = ((struct tl_combinator_tree *)(T->data))->data;
2003 struct tl_var *v = tl_get_var (id, strlen (id));
2004 assert (v);
2005 v->flags |= 1;
2006 }
2007 tl_mark_vars (T->left);
2008 tl_mark_vars (T->right);
2009 }
2010
tl_parse_result_type(struct tree * T)2011 struct tl_combinator_tree *tl_parse_result_type (struct tree *T) {
2012 assert (T->type == type_result_type);
2013 assert (T->nc >= 1);
2014 assert (T->nc <= 64);
2015
2016 TL_INIT (L);
2017
2018 if (tl_get_var (T->c[0]->text, T->c[0]->len)) {
2019 if (T->nc != 1) {
2020 TL_ERROR ("Variable can not take params\n");
2021 TL_FAIL;
2022 }
2023 L = alloc_ctree_node ();
2024 L->act = act_var;
2025 L->type = type_type;
2026 struct tl_var *v = tl_get_var (T->c[0]->text, T->c[0]->len);
2027 if (v->type) {
2028 TL_ERROR ("Type mistmatch\n");
2029 TL_FAIL;
2030 }
2031 L->data = v->ptr;
2032 // assert (v->ptr);
2033 } else {
2034 L = alloc_ctree_node ();
2035 L->act = act_type;
2036 L->type = type_type;
2037 struct tl_type *t = tl_add_type (T->c[0]->text, T->c[0]->len, -1, 0);
2038 assert (t);
2039 L->type_len = t->params_num;
2040 L->type_flags = t->params_types;
2041 L->data = t;
2042
2043 int i;
2044 for (i = 1; i < T->nc; i++) {
2045 TL_TRY (tl_parse_any_term (T->c[i], 0), L);
2046 assert (L->right);
2047 assert (L->right->type == type_num || L->right->type == type_num_value || (L->right->type == type_type && L->right->type_len == 0));
2048 }
2049 }
2050
2051 if (!tl_finish_subtree (L)) {
2052 TL_FAIL;
2053 }
2054
2055 tl_mark_vars (L);
2056 return L;
2057 }
2058
2059 int __ok;
tl_var_check_used(struct tl_var * v)2060 void tl_var_check_used (struct tl_var *v) {
2061 __ok = __ok && (v->flags & 3);
2062 }
2063
tl_parse_combinator_decl(struct tree * T,int fun)2064 int tl_parse_combinator_decl (struct tree *T, int fun) {
2065 assert (T->type == type_combinator_decl);
2066 assert (T->nc >= 3);
2067 namespace_level = 0;
2068 tl_clear_vars ();
2069 tl_clear_fields ();
2070 TL_INIT (L);
2071 TL_INIT (R);
2072
2073 int i = 1;
2074 while (i < T->nc - 2 && T->c[i]->type == type_opt_args) {
2075 TL_TRY (tl_parse_opt_args (T->c[i]), L);
2076 i++;
2077 }
2078 while (i < T->nc - 2 && T->c[i]->type == type_args) {
2079 TL_TRY (tl_parse_args (T->c[i]), L);
2080 i++;
2081 }
2082 assert (i == T->nc - 2 && T->c[i]->type == type_equals);
2083 i ++;
2084
2085 R = tl_parse_result_type (T->c[i]);
2086 if (!R) { TL_FAIL; }
2087
2088 struct tl_type *t = tl_tree_get_type (R);
2089 if (!fun && !t) {
2090 TL_ERROR ("Only functions can return variables\n");
2091 }
2092 assert (t || fun);
2093
2094 assert (namespace_level == 0);
2095 __ok = 1;
2096 tree_act_tl_var (vars[0], tl_var_check_used);
2097 if (!__ok) {
2098 TL_ERROR ("Not all variables are used in right side\n");
2099 TL_FAIL;
2100 }
2101
2102 if (tl_get_constructor (T->c[0]->text, T->c[0]->len) || tl_get_function (T->c[0]->text, T->c[0]->len)) {
2103 TL_ERROR ("Duplicate combinator id %.*s\n", T->c[0]->len, T->c[0]->text);
2104 return 0;
2105 }
2106 struct tl_constructor *c = !fun ? tl_add_constructor (t, T->c[0]->text, T->c[0]->len, 0) : tl_add_function (t, T->c[0]->text, T->c[0]->len, 0);
2107 if (!c) { TL_FAIL; }
2108 c->left = L;
2109 c->right = R;
2110
2111 if (!c->name) {
2112 tl_count_combinator_name (c);
2113 }
2114 tl_print_combinator (c);
2115
2116 return 1;
2117 }
2118
change_var_ptrs(struct tl_combinator_tree * O,struct tl_combinator_tree * D,struct tree_var_value ** V)2119 void change_var_ptrs (struct tl_combinator_tree *O, struct tl_combinator_tree *D, struct tree_var_value **V) {
2120 if (!O || !D) {
2121 assert (!O && !D);
2122 return;
2123 }
2124 if (O->act == act_field) {
2125 struct tl_type *t = tl_tree_get_type (O->left);
2126 if (t && (!strcmp (t->id, "#") || !strcmp (t->id, "Type"))) {
2127 tl_set_var_value (V, O, D);
2128 }
2129 }
2130 if (O->act == act_var) {
2131 assert (D->data == O->data);
2132 D->data = tl_get_var_value (V, O->data);
2133 assert (D->data);
2134 }
2135 change_var_ptrs (O->left, D->left, V);
2136 change_var_ptrs (O->right, D->right, V);
2137 }
2138
change_first_var(struct tl_combinator_tree * O,struct tl_combinator_tree ** X,struct tl_combinator_tree * Y)2139 struct tl_combinator_tree *change_first_var (struct tl_combinator_tree *O, struct tl_combinator_tree **X, struct tl_combinator_tree *Y) {
2140 if (!O) { return (void *)-2l; };
2141 if (O->act == act_field && !*X) {
2142 struct tl_type *t = tl_tree_get_type (O->left);
2143 if (t && !strcmp (t->id, "#")) {
2144 if (Y->type != type_num && Y->type != type_num_value) {
2145 TL_ERROR ("change_var: Type mistmatch\n");
2146 return 0;
2147 } else {
2148 *X = O;
2149 return (void *)-1l;
2150 }
2151 }
2152 if (t && !strcmp (t->id, "Type")) {
2153 if (Y->type != type_type || Y->type_len != 0) {
2154 TL_ERROR ("change_var: Type mistmatch\n");
2155 return 0;
2156 } else {
2157 *X = O;
2158 return (void *)-1l;
2159 }
2160 }
2161 }
2162 if (O->act == act_var) {
2163 if (O->data == *X) {
2164 struct tl_combinator_tree *R = tl_tree_dup (Y);
2165 if (O->type == type_num || O->type == type_num_value) { R->type_flags += O->type_flags; }
2166 return R;
2167 }
2168 }
2169 struct tl_combinator_tree *t;
2170 t = change_first_var (O->left, X, Y);
2171 if (!t) { return 0;}
2172 if (t == (void *)-1l) {
2173 t = change_first_var (O->right, X, Y);
2174 if (!t) { return 0;}
2175 if (t == (void *)-1l) { return (void *)-1l; }
2176 if (t != (void *)-2l) { return t;}
2177 return (void *)-1l;
2178 }
2179 if (t != (void *)-2l) {
2180 O->left = t;
2181 }
2182 t = change_first_var (O->right, X, Y);
2183 if (!t) { return 0;}
2184 if (t == (void *)-1l) {
2185 return O->left;
2186 }
2187 if (t != (void *)-2l) {
2188 O->right = t;
2189 }
2190 return O;
2191 }
2192
2193
2194 int uniformize (struct tl_combinator_tree *L, struct tl_combinator_tree *R, struct tree_var_value **T);
2195 struct tree_var_value **_T;
2196 int __tok;
check_nat_val(struct tl_var_value v)2197 void check_nat_val (struct tl_var_value v) {
2198 if (!__tok) { return; }
2199 long long x = v.num_val;
2200 struct tl_combinator_tree *L = v.val;
2201 if (L->type == type_type) { return;}
2202 while (1) {
2203 if (L->type == type_num_value) {
2204 if (x + L->type_flags < 0) {
2205 __tok = 0;
2206 return;
2207 } else {
2208 return;
2209 }
2210 }
2211 assert (L->type == type_num);
2212 x += L->type_flags;
2213 x += tl_get_var_value_num (_T, L->data);
2214 L = tl_get_var_value (_T, L->data);
2215 if (!L) { return;}
2216 }
2217 }
2218
check_constructors_equal(struct tl_combinator_tree * L,struct tl_combinator_tree * R,struct tree_var_value ** T)2219 int check_constructors_equal (struct tl_combinator_tree *L, struct tl_combinator_tree *R, struct tree_var_value **T) {
2220 if (!uniformize (L, R, T)) { return 0; }
2221 __tok = 1;
2222 _T = T;
2223 tree_act_var_value (*T, check_nat_val);
2224 return __tok;
2225 }
2226
reduce_type(struct tl_combinator_tree * A,struct tl_type * t)2227 struct tl_combinator_tree *reduce_type (struct tl_combinator_tree *A, struct tl_type *t) {
2228 assert (A);
2229 if (A->type_len == t->params_num) {
2230 assert (A->type_flags == t->params_types);
2231 A->act = act_type;
2232 A->type = type_type;
2233 A->left = A->right = 0;
2234 A->data = t;
2235 return A;
2236 }
2237 A->left = reduce_type (A->left, t);
2238 return A;
2239 }
2240
change_value_var(struct tl_combinator_tree * O,struct tree_var_value ** X)2241 struct tl_combinator_tree *change_value_var (struct tl_combinator_tree *O, struct tree_var_value **X) {
2242 if (!O) { return (void *)-2l; };
2243 while (O->act == act_var) {
2244 assert (O->data);
2245 if (!tl_get_var_value (X, O->data)) {
2246 break;
2247 }
2248 if (O->type == type_type) {
2249 O = tl_tree_dup (tl_get_var_value (X, O->data));
2250 } else {
2251 long long n = tl_get_var_value_num (X, O->data);
2252 struct tl_combinator_tree *T = tl_get_var_value (X, O->data);
2253 O->data = T->data;
2254 O->type = T->type;
2255 O->act = T->act;
2256 O->type_flags = O->type_flags + n + T->type_flags;
2257 }
2258 }
2259 if (O->act == act_field) {
2260 if (tl_get_var_value (X, O)) { return (void *)-1l; }
2261 }
2262 struct tl_combinator_tree *t;
2263 t = change_value_var (O->left, X);
2264 if (!t) { return 0;}
2265 if (t == (void *)-1l) {
2266 t = change_value_var (O->right, X);
2267 if (!t) { return 0;}
2268 if (t == (void *)-1l) { return (void *)-1l; }
2269 if (t != (void *)-2l) { return t;}
2270 return (void *)-1l;
2271 }
2272 if (t != (void *)-2l) {
2273 O->left = t;
2274 }
2275 t = change_value_var (O->right, X);
2276 if (!t) { return 0;}
2277 if (t == (void *)-1l) {
2278 return O->left;
2279 }
2280 if (t != (void *)-2l) {
2281 O->right = t;
2282 }
2283 return O;
2284 }
2285
tl_parse_partial_type_app_decl(struct tree * T)2286 int tl_parse_partial_type_app_decl (struct tree *T) {
2287 assert (T->type == type_partial_type_app_decl);
2288 assert (T->nc >= 1);
2289
2290 assert (T->c[0]->type == type_boxed_type_ident);
2291 struct tl_type *t = tl_get_type (T->c[0]->text, T->c[0]->len);
2292 if (!t) {
2293 TL_ERROR ("Can not make partial app for unknown type\n");
2294 return 0;
2295 }
2296
2297 tl_type_finalize (t);
2298
2299 struct tl_combinator_tree *L = tl_parse_ident (T->c[0], 0);
2300 assert (L);
2301 int i;
2302 tl_buf_reset ();
2303 int cc = T->nc - 1;
2304 for (i = 1; i < T->nc; i++) {
2305 TL_TRY (tl_parse_any_term (T->c[i], 0), L);
2306 tl_buf_add_tree (L->right, 1);
2307 }
2308
2309 while (L->type_len) {
2310 struct tl_combinator_tree *C = alloc_ctree_node ();
2311 C->act = act_var;
2312 C->type = (L->type_flags & 1) ? type_num : type_type;
2313 C->type_len = 0;
2314 C->type_flags = 0;
2315 C->data = (void *)-1l;
2316 L = tl_union (L, C);
2317 if (!L) { return 0; }
2318 }
2319
2320
2321 static char _buf[100000];
2322 snprintf (_buf, 100000, "%s%.*s", t->id, buf_pos, buf);
2323 struct tl_type *nt = tl_add_type (_buf, strlen (_buf), t->params_num - cc, t->params_types >> cc);
2324 assert (nt);
2325 //snprintf (_buf, 100000, "%s #", t->id);
2326 //nt->real_id = strdup (_buf);
2327
2328 for (i = 0; i < t->constructors_num; i++) {
2329 struct tl_constructor *c = t->constructors[i];
2330 struct tree_var_value *V = 0;
2331 TL_INIT (A);
2332 TL_INIT (B);
2333 A = tl_tree_dup (c->left);
2334 B = tl_tree_dup (c->right);
2335
2336 struct tree_var_value *W = 0;
2337 change_var_ptrs (c->left, A, &W);
2338 change_var_ptrs (c->right, B, &W);
2339
2340
2341 if (!check_constructors_equal (B, L, &V)) { continue; }
2342 B = reduce_type (B, nt);
2343 A = change_value_var (A, &V);
2344 if (A == (void *)-1l) { A = 0;}
2345 B = change_value_var (B, &V);
2346 assert (B != (void *)-1l);
2347 snprintf (_buf, 100000, "%s%.*s", c->id, buf_pos, buf);
2348
2349 struct tl_constructor *r = tl_add_constructor (nt, _buf, strlen (_buf), 1);
2350 snprintf (_buf, 100000, "%s", c->id);
2351 r->real_id = tstrdup (_buf);
2352
2353 r->left = A;
2354 r->right = B;
2355 if (!r->name) {
2356 tl_count_combinator_name (r);
2357 }
2358 tl_print_combinator (r);
2359 }
2360
2361 return 1;
2362 }
2363
tl_parse_partial_comb_app_decl(struct tree * T,int fun)2364 int tl_parse_partial_comb_app_decl (struct tree *T, int fun) {
2365 assert (T->type == type_partial_comb_app_decl);
2366
2367 struct tl_constructor *c = !fun ? tl_get_constructor (T->c[0]->text, T->c[0]->len) : tl_get_function (T->c[0]->text, T->c[0]->len);
2368 if (!c) {
2369 TL_ERROR ("Can not make partial app for undefined combinator\n");
2370 return 0;
2371 }
2372
2373 //TL_INIT (K);
2374 //static char buf[1000];
2375 //int x = sprintf (buf, "%s", c->id);
2376 TL_INIT (L);
2377 TL_INIT (R);
2378 L = tl_tree_dup (c->left);
2379 R = tl_tree_dup (c->right);
2380
2381
2382 struct tree_var_value *V = 0;
2383 change_var_ptrs (c->left, L, &V);
2384 change_var_ptrs (c->right, R, &V);
2385 V = tree_clear_var_value (V);
2386
2387 int i;
2388 tl_buf_reset ();
2389 for (i = 1; i < T->nc; i++) {
2390 TL_INIT (X);
2391 TL_INIT (Z);
2392 X = tl_parse_any_term (T->c[i], 0);
2393 struct tl_combinator_tree *K = 0;
2394 if (!(Z = change_first_var (L, &K, X))) {
2395 TL_FAIL;
2396 }
2397 L = Z;
2398 if (!K) {
2399 TL_ERROR ("Partial app: not enougth variables (i = %d)\n", i);
2400 TL_FAIL;
2401 }
2402 if (!(Z = change_first_var (R, &K, X))) {
2403 TL_FAIL;
2404 }
2405 assert (Z == R);
2406 tl_buf_add_tree (X, 1);
2407 }
2408
2409 static char _buf[100000];
2410 snprintf (_buf, 100000, "%s%.*s", c->id, buf_pos, buf);
2411 // fprintf (stderr, "Local id: %s\n", _buf);
2412
2413 struct tl_constructor *r = !fun ? tl_add_constructor (c->type, _buf, strlen (_buf), 1) : tl_add_function (c->type, _buf, strlen (_buf), 1);
2414 r->left = L;
2415 r->right = R;
2416 snprintf (_buf, 100000, "%s", c->id);
2417 r->real_id = tstrdup (_buf);
2418 if (!r->name) {
2419 tl_count_combinator_name (r);
2420 }
2421 tl_print_combinator (r);
2422 return 1;
2423 }
2424
2425
tl_parse_partial_app_decl(struct tree * T,int fun)2426 int tl_parse_partial_app_decl (struct tree *T, int fun) {
2427 assert (T->type == type_partial_app_decl);
2428 assert (T->nc == 1);
2429 if (T->c[0]->type == type_partial_comb_app_decl) {
2430 return tl_parse_partial_comb_app_decl (T->c[0], fun);
2431 } else {
2432 if (fun) {
2433 TL_ERROR ("Partial type app in functions block\n");
2434 TL_FAIL;
2435 }
2436 return tl_parse_partial_type_app_decl (T->c[0]);
2437 }
2438 }
2439
tl_parse_final_final(struct tree * T)2440 int tl_parse_final_final (struct tree *T) {
2441 assert (T->type == type_final_final);
2442 assert (T->nc == 1);
2443 struct tl_type *R;
2444 if ((R = tl_get_type (T->c[0]->text, T->c[0]->len))) {
2445 R->flags |= 1;
2446 return 1;
2447 } else {
2448 TL_ERROR ("Final statement for type `%.*s` before declaration\n", T->c[0]->len, T->c[0]->text);
2449 TL_FAIL;
2450 }
2451 }
2452
tl_parse_final_new(struct tree * T)2453 int tl_parse_final_new (struct tree *T) {
2454 assert (T->type == type_final_new);
2455 assert (T->nc == 1);
2456 if (tl_get_type (T->c[0]->text, T->c[0]->len)) {
2457 TL_ERROR ("New statement: type `%.*s` already declared\n", T->c[0]->len, T->c[0]->text);
2458 TL_FAIL;
2459 } else {
2460 return 1;
2461 }
2462 }
2463
tl_parse_final_empty(struct tree * T)2464 int tl_parse_final_empty (struct tree *T) {
2465 assert (T->type == type_final_empty);
2466 assert (T->nc == 1);
2467 if (tl_get_type (T->c[0]->text, T->c[0]->len)) {
2468 TL_ERROR ("New statement: type `%.*s` already declared\n", T->c[0]->len, T->c[0]->text);
2469 TL_FAIL;
2470 }
2471 struct tl_type *t = tl_add_type (T->c[0]->text, T->c[0]->len, 0, 0);
2472 assert (t);
2473 t->flags |= 1 | FLAG_EMPTY;
2474 return 1;
2475 }
2476
tl_parse_final_decl(struct tree * T,int fun)2477 int tl_parse_final_decl (struct tree *T, int fun) {
2478 assert (T->type == type_final_decl);
2479 assert (!fun);
2480 assert (T->nc == 1);
2481 switch (T->c[0]->type) {
2482 case type_final_new:
2483 return tl_parse_final_new (T->c[0]);
2484 case type_final_final:
2485 return tl_parse_final_final (T->c[0]);
2486 case type_final_empty:
2487 return tl_parse_final_empty (T->c[0]);
2488 default:
2489 assert (0);
2490 return 0;
2491 }
2492 }
2493
tl_parse_builtin_combinator_decl(struct tree * T,int fun)2494 int tl_parse_builtin_combinator_decl (struct tree *T, int fun) {
2495 if (fun) {
2496 TL_ERROR ("Builtin type can not be described in function block\n");
2497 return -1;
2498 }
2499 assert (T->type == type_builtin_combinator_decl);
2500 assert (T->nc == 2);
2501 assert (T->c[0]->type == type_full_combinator_id);
2502 assert (T->c[1]->type == type_boxed_type_ident);
2503
2504
2505 if ((!mystrcmp2 (T->c[0]->text, T->c[0]->len, "int") && !mystrcmp2 (T->c[1]->text, T->c[1]->len, "Int")) ||
2506 (!mystrcmp2 (T->c[0]->text, T->c[0]->len, "long") && !mystrcmp2 (T->c[1]->text, T->c[1]->len, "Long")) ||
2507 (!mystrcmp2 (T->c[0]->text, T->c[0]->len, "double") && !mystrcmp2 (T->c[1]->text, T->c[1]->len, "Double")) ||
2508 (!mystrcmp2 (T->c[0]->text, T->c[0]->len, "object") && !mystrcmp2 (T->c[1]->text, T->c[1]->len, "Object")) ||
2509 (!mystrcmp2 (T->c[0]->text, T->c[0]->len, "function") && !mystrcmp2 (T->c[1]->text, T->c[1]->len, "Function")) ||
2510 (!mystrcmp2 (T->c[0]->text, T->c[0]->len, "string") && !mystrcmp2 (T->c[1]->text, T->c[1]->len, "String"))) {
2511 struct tl_type *t = tl_add_type (T->c[1]->text, T->c[1]->len, 0, 0);
2512 if (!t) {
2513 return 0;
2514 }
2515 struct tl_constructor *c = tl_add_constructor (t, T->c[0]->text, T->c[0]->len, 0);
2516 if (!c) {
2517 return 0;
2518 }
2519
2520 c->left = alloc_ctree_node ();
2521 c->left->act = act_question_mark;
2522 c->left->type = type_list_item;
2523
2524 c->right = alloc_ctree_node ();
2525 c->right->act = act_type;
2526 c->right->data = t;
2527 c->right->type = type_type;
2528
2529 if (!c->name) {
2530 tl_count_combinator_name (c);
2531 }
2532 tl_print_combinator (c);
2533 } else {
2534 TL_ERROR ("Unknown builting type `%.*s`\n", T->c[0]->len, T->c[0]->text);
2535 return 0;
2536 }
2537
2538 return 1;
2539 }
2540
tl_parse_declaration(struct tree * T,int fun)2541 int tl_parse_declaration (struct tree *T, int fun) {
2542 assert (T->type == type_declaration);
2543 assert (T->nc == 1);
2544 switch (T->c[0]->type) {
2545 case type_combinator_decl:
2546 return tl_parse_combinator_decl (T->c[0], fun);
2547 case type_partial_app_decl:
2548 return tl_parse_partial_app_decl (T->c[0], fun);
2549 case type_final_decl:
2550 return tl_parse_final_decl (T->c[0], fun);
2551 case type_builtin_combinator_decl:
2552 return tl_parse_builtin_combinator_decl (T->c[0], fun);
2553 default:
2554 assert (0);
2555 return 0;
2556 }
2557 }
2558
tl_parse_constr_declarations(struct tree * T)2559 int tl_parse_constr_declarations (struct tree *T) {
2560 assert (T->type == type_constr_declarations);
2561 int i;
2562 for (i = 0; i < T->nc; i++) {
2563 TL_TRY_PES (tl_parse_declaration (T->c[i], 0));
2564 }
2565 return 1;
2566 }
2567
tl_parse_fun_declarations(struct tree * T)2568 int tl_parse_fun_declarations (struct tree *T) {
2569 assert (T->type == type_fun_declarations);
2570 int i;
2571 for (i = 0; i < T->nc; i++) {
2572 TL_TRY_PES (tl_parse_declaration (T->c[i], 1));
2573 }
2574 return 1;
2575 }
2576
tl_tree_lookup_value(struct tl_combinator_tree * L,void * var,struct tree_var_value ** T)2577 int tl_tree_lookup_value (struct tl_combinator_tree *L, void *var, struct tree_var_value **T) {
2578 if (!L) {
2579 return -1;
2580 }
2581 if (L->act == act_var && L->data == var) {
2582 return 0;
2583 }
2584 if (L->act == act_var) {
2585 struct tl_combinator_tree *E = tl_get_var_value (T, L->data);
2586 if (!E) { return -1;}
2587 else { return tl_tree_lookup_value (E, var, T); }
2588 }
2589 if (tl_tree_lookup_value (L->left, var, T) >= 0) { return 1; }
2590 if (tl_tree_lookup_value (L->right, var, T) >= 0) { return 1; }
2591 return -1;
2592 }
2593
tl_tree_lookup_value_nat(struct tl_combinator_tree * L,void * var,long long x,struct tree_var_value ** T)2594 int tl_tree_lookup_value_nat (struct tl_combinator_tree *L, void *var, long long x, struct tree_var_value **T) {
2595 assert (L);
2596 if (L->type == type_num_value) { return -1; }
2597 assert (L->type == type_num);
2598 assert (L->act == act_var);
2599 if (L->data == var) {
2600 return x == L->type_flags ? 0 : 1;
2601 } else {
2602 if (!tl_get_var_value (T, L->data)) {
2603 return -1;
2604 }
2605 return tl_tree_lookup_value_nat (tl_get_var_value (T, L->data), var, x + tl_get_var_value_num (T, L->data), T);
2606 }
2607
2608 }
2609
uniformize(struct tl_combinator_tree * L,struct tl_combinator_tree * R,struct tree_var_value ** T)2610 int uniformize (struct tl_combinator_tree *L, struct tl_combinator_tree *R, struct tree_var_value **T) {
2611 if (!L || !R) {
2612 assert (!L && !R);
2613 return 1;
2614 }
2615 if (R->act == act_var) {
2616 struct tl_combinator_tree *_ = R; R = L; L = _;
2617 }
2618
2619 if (L->type == type_type) {
2620 if (R->type != type_type || L->type_len != R->type_len || L->type_flags != R->type_flags) {
2621 return 0;
2622 }
2623 if (R->data == (void *)-1l || L->data == (void *)-1l) { return 1;}
2624 if (L->act == act_var) {
2625 int x = tl_tree_lookup_value (R, L->data, T);
2626 if (x > 0) {
2627 // if (tl_tree_lookup_value (R, L->data, T) > 0) {
2628 return 0;
2629 }
2630 if (x == 0) {
2631 return 1;
2632 }
2633 struct tl_combinator_tree *E = tl_get_var_value (T, L->data);
2634 if (!E) {
2635 tl_set_var_value (T, L->data, R);
2636 return 1;
2637 } else {
2638 return uniformize (E, R, T);
2639 }
2640 } else {
2641 if (L->act != R->act || L->data != R->data) {
2642 return 0;
2643 }
2644 return uniformize (L->left, R->left, T) && uniformize (L->right, R->right, T);
2645 }
2646 } else {
2647 assert (L->type == type_num || L->type == type_num_value);
2648 if (R->type != type_num && R->type != type_num_value) {
2649 return 0;
2650 }
2651 assert (R->type == type_num || R->type == type_num_value);
2652 if (R->data == (void *)-1l || L->data == (void *)-1l) { return 1;}
2653 long long x = 0;
2654 struct tl_combinator_tree *K = L;
2655 while (1) {
2656 x += K->type_flags;
2657 if (K->type == type_num_value) {
2658 break;
2659 }
2660 if (!tl_get_var_value (T, K->data)) {
2661 int s = tl_tree_lookup_value_nat (R, K->data, K->type_flags, T);
2662 if (s > 0) {
2663 return 0;
2664 }
2665 if (s == 0) {
2666 return 1;
2667 }
2668 /*tl_set_var_value_num (T, K->data, R, -x);
2669 return 1;*/
2670 break;
2671 }
2672 x += tl_get_var_value_num (T, K->data);
2673 K = tl_get_var_value (T, K->data);
2674 }
2675 long long y = 0;
2676 struct tl_combinator_tree *M = R;
2677 while (1) {
2678 y += M->type_flags;
2679 if (M->type == type_num_value) {
2680 break;
2681 }
2682 if (!tl_get_var_value (T, M->data)) {
2683 int s = tl_tree_lookup_value_nat (L, M->data, M->type_flags, T);
2684 if (s > 0) {
2685 return 0;
2686 }
2687 if (s == 0) {
2688 return 1;
2689 }
2690 /*tl_set_var_value_num (T, M->data, L, -y);
2691 return 1;*/
2692 break;
2693 }
2694 y += tl_get_var_value_num (T, M->data);
2695 M = tl_get_var_value (T, M->data);
2696 }
2697 if (K->type == type_num_value && M->type == type_num_value) {
2698 return x == y;
2699 }
2700 if (M->type == type_num_value) {
2701 tl_set_var_value_num (T, K->data, M, -(x - y + M->type_flags));
2702 return 1;
2703 } else if (K->type == type_num_value) {
2704 tl_set_var_value_num (T, M->data, K, -(y - x + K->type_flags));
2705 return 1;
2706 } else {
2707 if (x >= y) {
2708 tl_set_var_value_num (T, K->data, M, -(x - y + M->type_flags));
2709 } else {
2710 tl_set_var_value_num (T, M->data, K, -(y - x + K->type_flags));
2711 }
2712 return 1;
2713 }
2714 }
2715 return 0;
2716 }
2717
2718
tl_type_check(struct tl_type * t)2719 void tl_type_check (struct tl_type *t) {
2720 if (!__ok) return;
2721 if (!strcmp (t->id, "#")) { t->name = 0x70659eff; return; }
2722 if (!strcmp (t->id, "Type")) { t->name = 0x2cecf817; return; }
2723 if (t->constructors_num <= 0 && !(t->flags & FLAG_EMPTY)) {
2724 TL_ERROR ("Type %s has no constructors\n", t->id);
2725 __ok = 0;
2726 return;
2727 }
2728 int i, j;
2729 t->name = 0;
2730 for (i = 0; i < t->constructors_num; i++) {
2731 t->name ^= t->constructors[i]->name;
2732 }
2733 for (i = 0; i < t->constructors_num; i++) {
2734 for (j = i + 1; j < t->constructors_num; j++) {
2735 struct tree_var_value *v = 0;
2736 if (check_constructors_equal (t->constructors[i]->right, t->constructors[j]->right, &v)) {
2737 t->flags |= 16;
2738 }
2739 }
2740 }
2741 if ((t->flags & 24) == 24) {
2742 TL_WARNING ("Warning: Type %s has overlapping costructors, but it is used with `%%`\n", t->id);
2743 }
2744 int z = 0;
2745 int sid = 0;
2746 for (i = 0; i < t->constructors_num; i++) if (*t->constructors[i]->id == '_') {
2747 z ++;
2748 sid = i;
2749 }
2750 if (z > 1) {
2751 TL_ERROR ("Type %s has %d default constructors\n", t->id, z);
2752 __ok = 0;
2753 return;
2754 }
2755 if (z == 1 && (t->flags & 8)) {
2756 TL_ERROR ("Type %s has default constructors and used bare\n", t->id);
2757 __ok = 0;
2758 return;
2759 }
2760 if (z) {
2761 struct tl_constructor *c;
2762 c = t->constructors[sid];
2763 t->constructors[sid] = t->constructors[t->constructors_num - 1];
2764 t->constructors[t->constructors_num - 1] = c;
2765 }
2766 }
2767
tl_parse(struct tree * T)2768 struct tl_program *tl_parse (struct tree *T) {
2769 assert (T);
2770 assert (T->type == type_tl_program);
2771 int i;
2772 tl_program_cur = talloc (sizeof (*tl_program_cur));
2773 tl_add_type ("#", 1, 0, 0);
2774 tl_add_type ("Type", 4, 0, 0);
2775 for (i = 0; i < T->nc; i++) {
2776 if (T->c[i]->type == type_constr_declarations) { TL_TRY_PES (tl_parse_constr_declarations (T->c[i])); }
2777 else { TL_TRY_PES (tl_parse_fun_declarations (T->c[i])) }
2778 }
2779 __ok = 1;
2780 tree_act_tl_type (tl_type_tree, tl_type_check);
2781 if (!__ok) {
2782 return 0;
2783 }
2784 return tl_program_cur;
2785 }
2786
2787 FILE *__f;
2788 int num = 0;
2789
wint(int a)2790 void wint (int a) {
2791 // printf ("%d ", a);
2792 a = htole32 (a);
2793 assert (fwrite (&a, 1, 4, __f) == 4);
2794 }
2795
wdata(const void * x,int len)2796 void wdata (const void *x, int len) {
2797 assert (fwrite (x, 1, len, __f) == len);
2798 }
2799
wstr(const char * s)2800 void wstr (const char *s) {
2801 if (s) {
2802 // printf ("\"%s\" ", s);
2803 int x = strlen (s);
2804 if (x <= 254) {
2805 unsigned char x_c = (unsigned char)x;
2806 assert (fwrite (&x_c, 1, 1, __f) == 1);
2807 } else {
2808 fprintf (stderr, "String is too big...\n");
2809 assert (0);
2810 }
2811 wdata (s, x);
2812 x ++; // The header, containing the length, which is 1 byte
2813 int t = 0;
2814 if (x & 3) {
2815 // Let's hope it's truly zero on every platform
2816 wdata (&t, 4 - (x & 3));
2817 }
2818 } else {
2819 // printf ("<none> ");
2820 wint (0);
2821 }
2822 }
2823
wll(long long a)2824 void wll (long long a) {
2825 // printf ("%lld ", a);
2826 a = htole64 (a);
2827 assert (fwrite (&a, 1, 8, __f) == 8);
2828 }
2829
count_list_size(struct tl_combinator_tree * T)2830 int count_list_size (struct tl_combinator_tree *T) {
2831 assert (T->type == type_list || T->type == type_list_item);
2832 if (T->type == type_list_item) {
2833 return 1;
2834 } else {
2835 return count_list_size (T->left) + count_list_size (T->right);
2836 }
2837 }
2838
write_type_flags(long long flags)2839 void write_type_flags (long long flags) {
2840 int new_flags = 0;
2841 if (flags & 1) {
2842 new_flags |= FLAG_BARE;
2843 }
2844 if (flags & FLAG_DEFAULT_CONSTRUCTOR) {
2845 new_flags |= FLAG_DEFAULT_CONSTRUCTOR;
2846 }
2847 wint (new_flags);
2848 }
2849
write_field_flags(long long flags)2850 void write_field_flags (long long flags) {
2851 int new_flags = 0;
2852 //fprintf (stderr, "%lld\n", flags);
2853 if (flags & 1) {
2854 new_flags |= FLAG_BARE;
2855 }
2856 if (flags & 32) {
2857 new_flags |= FLAG_OPT_VAR;
2858 }
2859 if (flags & FLAG_EXCL) {
2860 new_flags |= FLAG_EXCL;
2861 }
2862 if (flags & FLAG_OPT_FIELD) {
2863 // new_flags |= FLAG_OPT_FIELD;
2864 new_flags |= 2;
2865 }
2866 if (flags & (1 << 21)) {
2867 new_flags |= 4;
2868 }
2869 wint (new_flags);
2870 }
2871
write_var_type_flags(long long flags)2872 void write_var_type_flags (long long flags) {
2873 int new_flags = 0;
2874 if (flags & 1) {
2875 new_flags |= FLAG_BARE;
2876 }
2877 if (new_flags & FLAG_BARE) {
2878 TL_ERROR ("Sorry, bare vars are not (yet ?) supported.\n");
2879 assert (!(new_flags & FLAG_BARE));
2880 }
2881 wint (new_flags);
2882 }
2883
2884 void write_tree (struct tl_combinator_tree *T, int extra, struct tree_var_value **v, int *last_var);
write_args(struct tl_combinator_tree * T,struct tree_var_value ** v,int * last_var)2885 void write_args (struct tl_combinator_tree *T, struct tree_var_value **v, int *last_var) {
2886 assert (T->type == type_list || T->type == type_list_item);
2887 if (T->type == type_list) {
2888 assert (T->act == act_union);
2889 assert (T->left);
2890 assert (T->right);
2891 write_args (T->left, v, last_var);
2892 write_args (T->right, v, last_var);
2893 return;
2894 }
2895 wint (TLS_ARG_V2);
2896 assert (T->act == act_field);
2897 assert (T->left);
2898 wstr (T->data && strcmp (T->data, "_") ? T->data : 0);
2899 long long f = T->flags;
2900 if (T->left->act == act_opt_field) {
2901 f |= (1 << 20);
2902 }
2903 if (T->left->act == act_type && T->left->data && (!strcmp (((struct tl_type *)T->left->data)->id, "#") || !strcmp (((struct tl_type *)T->left->data)->id, "Type"))) {
2904 write_field_flags (f | (1 << 21));
2905 wint (*last_var);
2906 *last_var = (*last_var) + 1;
2907 tl_set_var_value_num (v, T, 0, (*last_var) - 1);
2908 } else {
2909 write_field_flags (f);
2910 }
2911 write_tree (T->left, 0, v, last_var);
2912 }
2913
write_array(struct tl_combinator_tree * T,struct tree_var_value ** v,int * last_var)2914 void write_array (struct tl_combinator_tree *T, struct tree_var_value **v, int *last_var) {
2915 wint (TLS_ARRAY);
2916 write_tree (T->left, 0, v, last_var);
2917 write_tree (T->right, 0, v, last_var);
2918 }
2919
write_type_rec(struct tl_combinator_tree * T,int cc,struct tree_var_value ** v,int * last_var)2920 void write_type_rec (struct tl_combinator_tree *T, int cc, struct tree_var_value **v, int *last_var) {
2921 if (T->act == act_arg) {
2922 write_type_rec (T->left, cc + 1, v, last_var);
2923 if (T->right->type == type_num_value || T->right->type == type_num) {
2924 wint (TLS_EXPR_NAT);
2925 } else {
2926 wint (TLS_EXPR_TYPE);
2927 }
2928 write_tree (T->right, 0, v, last_var);
2929 } else {
2930 assert (T->act == act_var || T->act == act_type);
2931 if (T->act == act_var) {
2932 assert (!cc);
2933 wint (TLS_TYPE_VAR);
2934 wint (tl_get_var_value_num (v, T->data));
2935 write_var_type_flags (T->flags);
2936 //wint (T->flags);
2937 } else {
2938 wint (TLS_TYPE_EXPR);
2939 struct tl_type *t = T->data;
2940 wint (t->name);
2941 write_type_flags (T->flags);
2942 // wint (T->flags);
2943 wint (cc);
2944 // fprintf (stderr, "cc = %d\n", cc);
2945 }
2946 }
2947 }
2948
write_opt_type(struct tl_combinator_tree * T,struct tree_var_value ** v,int * last_var)2949 void write_opt_type (struct tl_combinator_tree *T, struct tree_var_value **v, int *last_var) {
2950 wint (tl_get_var_value_num (v, T->left->data));
2951 wint (T->left->type_flags);
2952 // write_tree (T->right, 0, v, last_var);
2953 assert (T);
2954 T = T->right;
2955 switch (T->type) {
2956 case type_type:
2957 if (T->act == act_array) {
2958 write_array (T, v, last_var);
2959 } else if (T->act == act_type || T->act == act_var || T->act == act_arg) {
2960 write_type_rec (T, 0, v, last_var);
2961 } else {
2962 assert (0);
2963 }
2964 break;
2965 default:
2966 assert (0);
2967 }
2968 }
2969
write_tree(struct tl_combinator_tree * T,int extra,struct tree_var_value ** v,int * last_var)2970 void write_tree (struct tl_combinator_tree *T, int extra, struct tree_var_value **v, int *last_var) {
2971 assert (T);
2972 switch (T->type) {
2973 case type_list_item:
2974 case type_list:
2975 if (extra) {
2976 wint (TLS_COMBINATOR_RIGHT_V2);
2977 }
2978 wint (count_list_size (T));
2979 write_args (T, v, last_var);
2980 break;
2981 case type_num_value:
2982 wint ((int)TLS_NAT_CONST);
2983 wint (T->type_flags);
2984 break;
2985 case type_num:
2986 wint ((int)TLS_NAT_VAR);
2987 wint (T->type_flags);
2988 wint (tl_get_var_value_num (v, T->data));
2989 break;
2990 case type_type:
2991 if (T->act == act_array) {
2992 write_array (T, v, last_var);
2993 } else if (T->act == act_type || T->act == act_var || T->act == act_arg) {
2994 write_type_rec (T, 0, v, last_var);
2995 } else {
2996 assert (T->act == act_opt_field);
2997 write_opt_type (T, v, last_var);
2998 }
2999 break;
3000 default:
3001 assert (0);
3002 }
3003 }
3004
write_type(struct tl_type * t)3005 void write_type (struct tl_type *t) {
3006 wint (TLS_TYPE);
3007 wint (t->name);
3008 wstr (t->id);
3009 wint (t->constructors_num);
3010 wint (t->flags);
3011 wint (t->params_num);
3012 wll (t->params_types);
3013 }
3014
is_builtin_type(const char * id)3015 int is_builtin_type (const char *id) {
3016 return !strcmp (id, "int") || !strcmp (id, "long") || !strcmp (id, "double") || !strcmp (id, "string")
3017 || !strcmp(id, "object") || !strcmp(id, "function");
3018 }
3019
write_combinator(struct tl_constructor * c)3020 void write_combinator (struct tl_constructor *c) {
3021 wint (c->name);
3022 wstr (c->id);
3023 wint (c->type ? c->type->name : 0);
3024 struct tree_var_value *T = 0;
3025 int x = 0;
3026 assert (c->right);
3027 if (c->left) {
3028 if (is_builtin_type (c->id)) {
3029 wint (TLS_COMBINATOR_LEFT_BUILTIN);
3030 } else {
3031 wint (TLS_COMBINATOR_LEFT);
3032 // FIXME: What is that?
3033 // wint (count_list_size (c->left));
3034 write_tree (c->left, 0, &T, &x);
3035 }
3036 } else {
3037 wint (TLS_COMBINATOR_LEFT);
3038 wint (0);
3039 }
3040 wint (TLS_COMBINATOR_RIGHT_V2);
3041 write_tree (c->right, 1, &T, &x);
3042 }
3043
write_constructor(struct tl_constructor * c)3044 void write_constructor (struct tl_constructor *c) {
3045 wint (TLS_COMBINATOR);
3046 write_combinator (c);
3047 }
3048
write_function(struct tl_constructor * c)3049 void write_function (struct tl_constructor *c) {
3050 wint (TLS_COMBINATOR);
3051 write_combinator (c);
3052 }
3053
write_type_constructors(struct tl_type * t)3054 void write_type_constructors (struct tl_type *t) {
3055 int i;
3056 for (i = 0; i < t->constructors_num; i++) {
3057 write_constructor (t->constructors[i]);
3058 }
3059 }
3060
write_types(FILE * f)3061 void write_types (FILE *f) {
3062 __f = f;
3063 wint (TLS_SCHEMA_V2);
3064 wint (0);
3065 #ifdef TL_PARSER_NEED_TIME
3066 wint (time (0));
3067 #else
3068 /* Make the tlo reproducible by default. Rationale: https://wiki.debian.org/ReproducibleBuilds/Howto#Introduction */
3069 wint (0);
3070 #endif
3071 num = 0;
3072 wint (total_types_num);
3073 tree_act_tl_type (tl_type_tree, write_type);
3074 wint (total_constructors_num);
3075 tree_act_tl_type (tl_type_tree, write_type_constructors);
3076 wint (total_functions_num);
3077 tree_act_tl_constructor (tl_function_tree, write_function);
3078 }
3079