diff options
Diffstat (limited to 'tl-parser/tl-parser.c')
| m--------- | tl-parser | 0 | ||||
| -rw-r--r-- | tl-parser/tl-parser.c | 3014 |
2 files changed, 3014 insertions, 0 deletions
diff --git a/tl-parser b/tl-parser deleted file mode 160000 -Subproject 36bf1902ff3476c75d0b1f42b34a91e944123b3 diff --git a/tl-parser/tl-parser.c b/tl-parser/tl-parser.c new file mode 100644 index 0000000..c2fd179 --- /dev/null +++ b/tl-parser/tl-parser.c @@ -0,0 +1,3014 @@ +/* + This file is part of tl-parser + + tl-parser is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 2 of the License, or + (at your option) any later version. + + tl-parser is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this tl-parser. If not, see <http://www.gnu.org/licenses/>. + + Copyright Vitaly Valtman 2014 + + It is derivative work of VK/KittenPHP-DB-Engine (https://github.com/vk-com/kphp-kdb/) + Copyright 2012-2013 Vkontakte Ltd + 2012-2013 Vitaliy Valtman + +*/ + +#define _FILE_OFFSET_BITS 64 +#include "config.h" + +#include <unistd.h> +#include <sys/types.h> +#include <sys/stat.h> +#include <fcntl.h> +#include <stdio.h> +#include <stdlib.h> +#include <assert.h> +#include <string.h> +#include <time.h> +#include <zlib.h> +#include "portable_endian.h" +#include "tl-parser-tree.h" +#include "tl-parser.h" +#include "tl-tl.h" +#include "config.h" + +extern int verbosity; +extern int schema_version; +extern int output_expressions; + + +int total_types_num; +int total_constructors_num; +int total_functions_num; + + +/*char *tstrdup (const char *s) { + assert (s); + char *r = talloc (strlen (s) + 1); + memcpy (r, s, strlen (s) + 1); + return r; +}*/ + +#define talloc(a) malloc(a) +#define tfree(a,b) free (a) +#define talloc0(a) calloc(a,1) +#define tstrdup(a) strdup(a) + +typedef char error_int_must_be_4_byte[(sizeof (int) == 4) ? 1 : -1]; +typedef char error_long_long_must_be_8_byte[(sizeof (long long) == 8) ? 1 : -1]; + +char curch; +struct parse parse; + +struct tree *tree; + +struct tree *tree_alloc (void) { + struct tree *T = talloc (sizeof (*T)); + assert (T); + memset (T, 0, sizeof (*T)); + return T; +} + +#define CRC32_INITIAL crc32 (0, 0, 0) + +void tree_add_child (struct tree *P, struct tree *C) { + if (P->nc == P->size) { + void **t = talloc (sizeof (void *) * (++P->size)); + memcpy (t, P->c, sizeof (void *) * (P->size - 1)); + if (P->c) { + tfree (P->c, sizeof (void *) * (P->size - 1)); + } + P->c = (void *)t; + assert (P->c); + } + P->c[P->nc ++] = C; +} + +void tree_delete (struct tree *T) { + assert (T); + int i; + for (i = 0; i < T->nc; i++) { + assert (T->c[i]); + tree_delete (T->c[i]); + } + if (T->c) { + tfree (T->c, sizeof (void *) * T->nc); + } + tfree (T, sizeof (*T)); +} + +void tree_del_child (struct tree *P) { + assert (P->nc); + tree_delete (P->c[--P->nc]); +} + + +char nextch (void) { + if (parse.pos < parse.len - 1) { + curch = parse.text[++parse.pos]; + } else { + curch = 0; + } + if (curch == 10) { + parse.line ++; + parse.line_pos = 0; + } else { + if (curch) { + parse.line_pos ++; + } + } + return curch; +} + + +struct parse save_parse (void) { + return parse; +} + +void load_parse (struct parse _parse) { + parse = _parse; + curch = parse.pos > parse.len ? 0: parse.text[parse.pos] ; +} + +int is_whitespace (char c) { + return (c <= 32); +} + +int is_uletter (char c) { + return (c >= 'A' && c <= 'Z'); +} + +int is_lletter (char c) { + return (c >= 'a' && c <= 'z'); +} + +int is_letter (char c) { + return is_uletter (c) || is_lletter (c); +} + +int is_digit (char c) { + return (c >= '0' && c <= '9'); +} + +int is_hexdigit (char c) { + return is_digit (c) || (c >= 'a' && c <= 'f'); +} + +int is_ident_char (char c) { + return is_digit (c) || is_letter (c) || c == '_'; +} + +int last_error_pos; +int last_error_line; +int last_error_line_pos; +char *last_error; + +void parse_error (const char *e) { + if (parse.pos > last_error_pos) { + last_error_pos = parse.pos; + last_error_line = parse.line; + last_error_line_pos = parse.line_pos; + if (last_error) { + tfree (last_error, strlen (last_error) + 1); + } + last_error = tstrdup (e); + } +} + +void tl_print_parse_error (void) { + fprintf (stderr, "Error near line %d pos %d: `%s`\n", last_error_line + 1, last_error_line_pos + 1, last_error); +} + +char *parse_lex (void) { + while (1) { + while (curch && is_whitespace (curch)) { nextch (); } + if (curch == '/' && nextch () == '/') { + while (nextch () != 10); + nextch (); + } else { + break; + } + } + if (!curch) { + parse.lex.len = 0; + parse.lex.type = lex_eof; + return (parse.lex.ptr = 0); + } + char *p = parse.text + parse.pos; + parse.lex.flags = 0; + switch (curch) { + case '-': + if (nextch () != '-' || nextch () != '-') { + parse_error ("Can not parse triple minus"); + parse.lex.type = lex_error; + return (parse.lex.ptr = (void *)-1); + } else { + parse.lex.len = 3; + parse.lex.type = lex_triple_minus; + nextch (); + return (parse.lex.ptr = p); + } + case ':': + case ';': + case '(': + case ')': + case '[': + case ']': + case '{': + case '}': + case '=': + case '#': + case '?': + case '%': + case '<': + case '>': + case '+': + case ',': + case '*': + case '_': + case '!': + case '.': + nextch (); + parse.lex.len = 1; + parse.lex.type = lex_char; + return (parse.lex.ptr = p); + case 'a'...'z': + case 'A'...'Z': + parse.lex.flags = 0; + if (is_uletter (curch)) { + while (is_ident_char (nextch ())); + parse.lex.len = parse.text + parse.pos - p; + parse.lex.ptr = p; + if (parse.lex.len == 5 && !memcmp (parse.lex.ptr, "Final", 5)) { + parse.lex.type = lex_final; + } else if (parse.lex.len == 3 && !memcmp (parse.lex.ptr, "New", 3)) { + parse.lex.type = lex_new; + } else if (parse.lex.len == 5 && !memcmp (parse.lex.ptr, "Empty", 5)) { + parse.lex.type = lex_empty; + } else { + parse.lex.type = lex_uc_ident; + } + return (parse.lex.ptr = p); + } + while (is_ident_char (nextch ())); + if (curch == '.' && !is_letter (parse.text[parse.pos + 1])) { + parse.lex.len = parse.text + parse.pos - p; + parse.lex.type = lex_lc_ident; + return (parse.lex.ptr = p); + } + if (curch == '.') { + parse.lex.flags |= 1; + nextch (); + if (is_uletter (curch)) { + while (is_ident_char (nextch ())); + parse.lex.len = parse.text + parse.pos - p; + parse.lex.type = lex_uc_ident; + return (parse.lex.ptr = p); + } + if (is_lletter (curch)) { + while (is_ident_char (nextch ())); + } else { + parse_error ("Expected letter"); + parse.lex.type = lex_error; + return (parse.lex.ptr = (void *)-1); + } + } + if (curch == '#') { + parse.lex.flags |= 2; + int i; + int ok = 1; + for (i = 0; i < 8; i++) { + if (!is_hexdigit (nextch())) { + if (curch == ' ' && i >= 5) { + ok = 2; + break; + } else { + parse_error ("Hex digit expected"); + parse.lex.type = lex_error; + return (parse.lex.ptr = (void *)-1); + } + } + } + if (ok == 1) { + nextch (); + } + } + parse.lex.len = parse.text + parse.pos - p; + parse.lex.type = lex_lc_ident; + return (parse.lex.ptr = p); + case '0'...'9': + while (is_digit (nextch ())); + parse.lex.len = parse.text + parse.pos - p; + parse.lex.type = lex_num; + return (parse.lex.ptr = p); + default: + parse_error ("Unknown lexem"); + parse.lex.type = lex_error; + return (parse.lex.ptr = (void *)-1); + } + +} + +int expect (char *s) { + 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)) { + static char buf[1000]; + sprintf (buf, "Expected %s", s); + parse_error (buf); + return -1; + } else { + parse_lex (); + } + return 1; +} + +struct parse *tl_init_parse_file (const char *fname) { + int fd = open (fname, O_RDONLY); + if (fd < 0) { + fprintf (stderr, "Error %m\n"); + assert (0); + return 0; + } + long long size = lseek (fd, 0, SEEK_END); + if (size <= 0) { + fprintf (stderr, "size is %lld. Too small.\n", size); + return 0; + } + static struct parse save; + save.text = talloc (size); + lseek (fd, 0, SEEK_SET); + save.len = read (fd, save.text, size); + assert (save.len == size); + save.pos = 0; + save.line = 0; + save.line_pos = 0; + save.lex.ptr = save.text; + save.lex.len = 0; + save.lex.type = lex_none; + return &save; +} + +#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)); +#define PARSE_FAIL load_parse (save); tree_delete (T); return 0; +#define PARSE_OK return T; +#define PARSE_TRY_PES(x) if (!(S = x ())) { PARSE_FAIL; } { tree_add_child (T, S); } +#define PARSE_TRY_OPT(x) if ((S = x ())) { tree_add_child (T, S); PARSE_OK } +#define PARSE_TRY(x) S = x (); +#define PARSE_ADD(_type) S = tree_alloc (); S->type = _type; tree_add_child (T, S); +#define EXPECT(s) if (expect (s) < 0) { PARSE_FAIL; } +#define LEX_CHAR(c) (parse.lex.type == lex_char && *parse.lex.ptr == c) +struct tree *parse_args (void); +struct tree *parse_expr (void); + +struct tree *parse_boxed_type_ident (void) { + PARSE_INIT (type_boxed_type_ident); + if (parse.lex.type != lex_uc_ident) { + parse_error ("Can not parse boxed type"); + PARSE_FAIL; + } else { + T->text = parse.lex.ptr; + T->len = parse.lex.len; + T->flags = parse.lex.flags; + parse_lex (); + PARSE_OK; + } +} + +struct tree *parse_full_combinator_id (void) { + PARSE_INIT (type_full_combinator_id); + if (parse.lex.type == lex_lc_ident || LEX_CHAR('_')) { + T->text = parse.lex.ptr; + T->len = parse.lex.len; + T->flags = parse.lex.flags; + parse_lex (); + PARSE_OK; + } else { + parse_error ("Can not parse full combinator id"); + PARSE_FAIL; + } +} + +struct tree *parse_combinator_id (void) { + PARSE_INIT (type_combinator_id); + if (parse.lex.type == lex_lc_ident && !(parse.lex.flags & 2)) { + T->text = parse.lex.ptr; + T->len = parse.lex.len; + T->flags = parse.lex.flags; + parse_lex (); + PARSE_OK; + } else { + parse_error ("Can not parse combinator id"); + PARSE_FAIL; + } +} + +struct tree *parse_var_ident (void) { + PARSE_INIT (type_var_ident); + if ((parse.lex.type == lex_lc_ident || parse.lex.type == lex_uc_ident) && !(parse.lex.flags & 3)) { + T->text = parse.lex.ptr; + T->len = parse.lex.len; + T->flags = parse.lex.flags; + parse_lex (); + PARSE_OK; + } else { + parse_error ("Can not parse var ident"); + PARSE_FAIL; + } +} + +struct tree *parse_var_ident_opt (void) { + PARSE_INIT (type_var_ident_opt); + if ((parse.lex.type == lex_lc_ident || parse.lex.type == lex_uc_ident)&& !(parse.lex.flags & 3)) { + T->text = parse.lex.ptr; + T->len = parse.lex.len; + T->flags = parse.lex.flags; + parse_lex (); + PARSE_OK; + } else if (LEX_CHAR ('_')) { + T->text = parse.lex.ptr; + T->len = parse.lex.len; + T->flags = parse.lex.flags; + parse_lex (); + PARSE_OK; + } else { + parse_error ("Can not parse var ident opt"); + PARSE_FAIL; + } +} + +struct tree *parse_nat_const (void) { + PARSE_INIT (type_nat_const); + if (parse.lex.type == lex_num) { + T->text = parse.lex.ptr; + T->len = parse.lex.len; + T->flags = parse.lex.flags; + parse_lex (); + PARSE_OK; + } else { + parse_error ("Can not parse nat const"); + PARSE_FAIL; + } +} + +struct tree *parse_type_ident (void) { + PARSE_INIT (type_type_ident); + if (parse.lex.type == lex_uc_ident && !(parse.lex.flags & 2)) { + T->text = parse.lex.ptr; + T->len = parse.lex.len; + T->flags = parse.lex.flags; + parse_lex (); + PARSE_OK; + } else if (parse.lex.type == lex_lc_ident && !(parse.lex.flags & 2)) { + T->text = parse.lex.ptr; + T->len = parse.lex.len; + T->flags = parse.lex.flags; + parse_lex (); + PARSE_OK; + } else if (LEX_CHAR ('#')) { + T->text = parse.lex.ptr; + T->len = parse.lex.len; + T->flags = parse.lex.flags; + parse_lex (); + PARSE_OK; + } else { + parse_error ("Can not parse type ident"); + PARSE_FAIL; + } +} + +struct tree *parse_term (void) { + PARSE_INIT (type_term); + while (LEX_CHAR ('%')) { + EXPECT ("%") + PARSE_ADD (type_percent); + } + if (LEX_CHAR ('(')) { + EXPECT ("("); + PARSE_TRY_PES (parse_expr); + EXPECT (")"); + PARSE_OK; + } + PARSE_TRY (parse_type_ident); + if (S) { + tree_add_child (T, S); + if (LEX_CHAR ('<')) { + EXPECT ("<"); + while (1) { + PARSE_TRY_PES (parse_expr); + if (LEX_CHAR ('>')) { break; } + EXPECT (","); + } + EXPECT (">"); + } + PARSE_OK; + } + PARSE_TRY_OPT (parse_type_ident); + PARSE_TRY_OPT (parse_var_ident); + PARSE_TRY_OPT (parse_nat_const); + PARSE_FAIL; +} + +struct tree *parse_nat_term (void) { + PARSE_INIT (type_nat_term); + PARSE_TRY_PES (parse_term); + PARSE_OK; +} + +struct tree *parse_subexpr (void) { + PARSE_INIT (type_subexpr); + int was_term = 0; + int cc = 0; + + while (1) { + PARSE_TRY (parse_nat_const); + if (S) { + tree_add_child (T, S); + } else if (!was_term) { + was_term = 1; + PARSE_TRY (parse_term); + if (S) { + tree_add_child (T, S); + } else { + break; + } + } + cc ++; + if (!LEX_CHAR ('+')) { + break; + } + EXPECT ("+"); + } + if (!cc) { + PARSE_FAIL; + } else { + PARSE_OK; + } +} + +struct tree *parse_expr (void) { + PARSE_INIT (type_expr); + int cc = 0; + while (1) { + PARSE_TRY (parse_subexpr); + if (S) { + tree_add_child (T, S); + cc ++; + } else { + if (cc < 1) { PARSE_FAIL; } + else { PARSE_OK; } + } + } +} + + + +struct tree *parse_final_empty (void) { + PARSE_INIT (type_final_empty); + EXPECT ("Empty"); + PARSE_TRY_PES (parse_boxed_type_ident); + PARSE_OK; +} + +struct tree *parse_final_new (void) { + PARSE_INIT (type_final_new); + EXPECT ("New"); + PARSE_TRY_PES (parse_boxed_type_ident); + PARSE_OK; +} + +struct tree *parse_final_final (void) { + PARSE_INIT (type_final_final); + EXPECT ("Final"); + PARSE_TRY_PES (parse_boxed_type_ident); + PARSE_OK; +} + +struct tree *parse_partial_comb_app_decl (void) { + PARSE_INIT (type_partial_comb_app_decl); + PARSE_TRY_PES (parse_combinator_id); + while (1) { + PARSE_TRY_PES (parse_subexpr); + if (LEX_CHAR (';')) { break; } + } + PARSE_OK; +} + +struct tree *parse_partial_type_app_decl (void) { + PARSE_INIT (type_partial_type_app_decl); + PARSE_TRY_PES (parse_boxed_type_ident); + if (LEX_CHAR ('<')) { + EXPECT ("<"); + while (1) { + PARSE_TRY_PES (parse_expr); + if (LEX_CHAR ('>')) { break; } + EXPECT (","); + } + EXPECT (">"); + PARSE_OK; + } else { + while (1) { + PARSE_TRY_PES (parse_subexpr); + if (LEX_CHAR (';')) { break; } + } + PARSE_OK; + } +} + + + + +struct tree *parse_multiplicity (void) { + PARSE_INIT (type_multiplicity); + PARSE_TRY_PES (parse_nat_term); + PARSE_OK; +} + + +struct tree *parse_type_term (void) { + PARSE_INIT (type_type_term); + PARSE_TRY_PES (parse_term); + PARSE_OK; +} + +struct tree *parse_optional_arg_def (void) { + PARSE_INIT (type_optional_arg_def); + PARSE_TRY_PES (parse_var_ident); + EXPECT ("."); + PARSE_TRY_PES (parse_nat_const); + EXPECT ("?"); + PARSE_OK; +} + +struct tree *parse_args4 (void) { + PARSE_INIT (type_args4); + struct parse so = save_parse (); + PARSE_TRY (parse_optional_arg_def); + if (S) { + tree_add_child (T, S); + } else { + load_parse (so); + } + if (LEX_CHAR ('!')) { + PARSE_ADD (type_exclam); + EXPECT ("!"); + } + PARSE_TRY_PES (parse_type_term); + PARSE_OK; +} + +struct tree *parse_args3 (void) { + PARSE_INIT (type_args3); + PARSE_TRY_PES (parse_var_ident_opt); + EXPECT (":"); + struct parse so = save_parse (); + PARSE_TRY (parse_optional_arg_def); + if (S) { + tree_add_child (T, S); + } else { + load_parse (so); + } + if (LEX_CHAR ('!')) { + PARSE_ADD (type_exclam); + EXPECT ("!"); + } + PARSE_TRY_PES (parse_type_term); + PARSE_OK; +} + +struct tree *parse_args2 (void) { + PARSE_INIT (type_args2); + PARSE_TRY (parse_var_ident_opt); + if (S && LEX_CHAR (':')) { + tree_add_child (T, S); + EXPECT (":"); + } else { + load_parse (save); + } + struct parse so = save_parse (); + PARSE_TRY (parse_optional_arg_def); + if (S) { + tree_add_child (T, S); + } else { + load_parse (so); + } + struct parse save2 = save_parse (); + PARSE_TRY (parse_multiplicity); + if (S && LEX_CHAR ('*')) { + tree_add_child (T, S); + EXPECT ("*"); + } else { + load_parse (save2); + } + EXPECT ("["); + while (1) { + if (LEX_CHAR (']')) { break; } + PARSE_TRY_PES (parse_args); + } + EXPECT ("]"); + PARSE_OK; +} + +struct tree *parse_args1 (void) { + PARSE_INIT (type_args1); + EXPECT ("("); + while (1) { + PARSE_TRY_PES (parse_var_ident_opt); + if (LEX_CHAR(':')) { break; } + } + EXPECT (":"); + struct parse so = save_parse (); + PARSE_TRY (parse_optional_arg_def); + if (S) { + tree_add_child (T, S); + } else { + load_parse (so); + } + if (LEX_CHAR ('!')) { + PARSE_ADD (type_exclam); + EXPECT ("!"); + } + PARSE_TRY_PES (parse_type_term); + EXPECT (")"); + PARSE_OK; +} + +struct tree *parse_args (void) { + PARSE_INIT (type_args); + PARSE_TRY_OPT (parse_args1); + PARSE_TRY_OPT (parse_args2); + PARSE_TRY_OPT (parse_args3); + PARSE_TRY_OPT (parse_args4); + PARSE_FAIL; +} + +struct tree *parse_opt_args (void) { + PARSE_INIT (type_opt_args); + while (1) { + PARSE_TRY_PES (parse_var_ident); + if (parse.lex.type == lex_char && *parse.lex.ptr == ':') { break;} + } + EXPECT (":"); + PARSE_TRY_PES (parse_type_term); + PARSE_OK; +} + +struct tree *parse_final_decl (void) { + PARSE_INIT (type_final_decl); + PARSE_TRY_OPT (parse_final_new); + PARSE_TRY_OPT (parse_final_final); + PARSE_TRY_OPT (parse_final_empty); + PARSE_FAIL; +} + +struct tree *parse_partial_app_decl (void) { + PARSE_INIT (type_partial_app_decl); + PARSE_TRY_OPT (parse_partial_type_app_decl); + PARSE_TRY_OPT (parse_partial_comb_app_decl); + PARSE_FAIL; +} + +struct tree *parse_result_type (void) { + PARSE_INIT (type_result_type); + PARSE_TRY_PES (parse_boxed_type_ident); + if (LEX_CHAR ('<')) { + EXPECT ("<"); + while (1) { + PARSE_TRY_PES (parse_expr); + if (LEX_CHAR ('>')) { break; } + EXPECT (","); + } + EXPECT (">"); + PARSE_OK; + } else { + while (1) { + if (LEX_CHAR (';')) { PARSE_OK; } + PARSE_TRY_PES (parse_subexpr); + } + } +} + +struct tree *parse_combinator_decl (void) { + PARSE_INIT (type_combinator_decl); + PARSE_TRY_PES (parse_full_combinator_id) + while (1) { + if (LEX_CHAR ('{')) { + parse_lex (); + PARSE_TRY_PES (parse_opt_args); + EXPECT ("}"); + } else { + break; + } + } + while (1) { + if (LEX_CHAR ('=')) { break; } + PARSE_TRY_PES (parse_args); + } + EXPECT ("="); + PARSE_ADD (type_equals); + + PARSE_TRY_PES (parse_result_type); + PARSE_OK; +} + +struct tree *parse_builtin_combinator_decl (void) { + PARSE_INIT (type_builtin_combinator_decl); + PARSE_TRY_PES (parse_full_combinator_id) + EXPECT ("?"); + EXPECT ("="); + PARSE_TRY_PES (parse_boxed_type_ident); + PARSE_OK; +} + +struct tree *parse_declaration (void) { + PARSE_INIT (type_declaration); + PARSE_TRY_OPT (parse_combinator_decl); + PARSE_TRY_OPT (parse_partial_app_decl); + PARSE_TRY_OPT (parse_final_decl); + PARSE_TRY_OPT (parse_builtin_combinator_decl); + PARSE_FAIL; +} + +struct tree *parse_constr_declarations (void) { + PARSE_INIT (type_constr_declarations); + if (parse.lex.type == lex_triple_minus || parse.lex.type == lex_eof) { PARSE_OK; } + while (1) { + PARSE_TRY_PES (parse_declaration); + EXPECT (";"); + if (parse.lex.type == lex_eof || parse.lex.type == lex_triple_minus) { PARSE_OK; } + } +} + +struct tree *parse_fun_declarations (void) { + PARSE_INIT (type_fun_declarations); + if (parse.lex.type == lex_triple_minus || parse.lex.type == lex_eof) { PARSE_OK; } + while (1) { + PARSE_TRY_PES (parse_declaration); + EXPECT (";"); + if (parse.lex.type == lex_eof || parse.lex.type == lex_triple_minus) { PARSE_OK; } + } +} + +struct tree *parse_program (void) { + PARSE_INIT (type_tl_program); + while (1) { + PARSE_TRY_PES (parse_constr_declarations); + if (parse.lex.type == lex_eof) { PARSE_OK; } + if (parse.lex.type == lex_error || expect ("---") < 0 || expect ("functions") < 0 || expect ("---") < 0) { PARSE_FAIL; } + + PARSE_TRY_PES (parse_fun_declarations); + if (parse.lex.type == lex_eof) { PARSE_OK; } + if (parse.lex.type == lex_error || expect ("---") < 0 || expect ("types") < 0 || expect ("---") < 0) { PARSE_FAIL; } + } +} + +struct tree *tl_parse_lex (struct parse *_parse) { + assert (_parse); + load_parse (*_parse); + if (parse.lex.type == lex_none) { + parse_lex (); + } + if (parse.lex.type == lex_error) { + return 0; + } + return parse_program (); +} + +int mystrcmp2 (const char *b, int len, const char *a) { + int c = strncmp (b, a, len); + return c ? a[len] ? -1 : 0 : c; +} + +char *mystrdup (const char *a, int len) { + char *z = talloc (len + 1); + memcpy (z, a, len); + z[len] = 0; + return z; +} + +struct tl_program *tl_program_cur; +#define TL_TRY_PES(x) if (!(x)) { return 0; } + +#define tl_type_cmp(a,b) (strcmp (a->id, b->id)) +DEFINE_TREE (tl_type,struct tl_type *,tl_type_cmp,0) +struct tree_tl_type *tl_type_tree; + +DEFINE_TREE (tl_constructor,struct tl_constructor *,tl_type_cmp,0) +struct tree_tl_constructor *tl_constructor_tree; +struct tree_tl_constructor *tl_function_tree; + +DEFINE_TREE (tl_var,struct tl_var *,tl_type_cmp,0) + +struct tl_var_value { + struct tl_combinator_tree *ptr; + struct tl_combinator_tree *val; + int num_val; +}; + +#define tl_var_value_cmp(a,b) (((char *)a.ptr) - ((char *)b.ptr)) +struct tl_var_value empty; +DEFINE_TREE (var_value, struct tl_var_value, tl_var_value_cmp, empty) +//tree_tl_var_t *tl_var_tree; + +DEFINE_TREE (tl_field,char *,strcmp, 0) +//tree_tl_field_t *tl_field_tree; +#define TL_FAIL return 0; +#define TL_INIT(x) struct tl_combinator_tree *x = 0; +#define TL_TRY(f,x) { struct tl_combinator_tree *_t = f; if (!_t) { TL_FAIL;} x = tl_union (x, _t); if (!x) { TL_FAIL; }} +#define TL_ERROR(...) fprintf (stderr, __VA_ARGS__); +#define TL_WARNING(...) fprintf (stderr, __VA_ARGS__); + +void tl_set_var_value (struct tree_var_value **T, struct tl_combinator_tree *var, struct tl_combinator_tree *value) { + struct tl_var_value t = {.ptr = var, .val = value, .num_val = 0}; + if (tree_lookup_var_value (*T, t).ptr) { + *T = tree_delete_var_value (*T, t); + } + *T = tree_insert_var_value (*T, t, lrand48 ()); +} + +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) { + struct tl_var_value t = {.ptr = var, .val = value, .num_val = num_value}; + if (tree_lookup_var_value (*T, t).ptr) { + *T = tree_delete_var_value (*T, t); + } + *T = tree_insert_var_value (*T, t, lrand48 ()); +} + +struct tl_combinator_tree *tl_get_var_value (struct tree_var_value **T, struct tl_combinator_tree *var) { + struct tl_var_value t = {.ptr = var, .val = 0, .num_val = 0}; + struct tl_var_value r = tree_lookup_var_value (*T, t); + return r.ptr ? r.val : 0; +} + +int tl_get_var_value_num (struct tree_var_value **T, struct tl_combinator_tree *var) { + struct tl_var_value t = {.ptr = var, .val = 0}; + struct tl_var_value r = tree_lookup_var_value (*T, t); + return r.ptr ? r.num_val : 0; +} + +int namespace_level; + +struct tree_tl_var *vars[10]; +struct tree_tl_field *fields[10]; +struct tl_var *last_num_var[10]; + +int tl_is_type_name (const char *id, int len) { + if (len == 1 && *id == '#') { return 1;} + int ok = id[0] >= 'A' && id[0] <= 'Z'; + int i; + for (i = 0; i < len - 1; i++) if (id[i] == '.') { + ok = id[i + 1] >= 'A' && id[i + 1] <= 'Z'; + } + return ok; +} + +int tl_add_field (char *id) { + assert (namespace_level < 10); + assert (namespace_level >= 0); + if (tree_lookup_tl_field (fields[namespace_level], id)) { + return 0; + } + fields[namespace_level] = tree_insert_tl_field (fields[namespace_level], id, lrand48 ()); + return 1; +} + +void tl_clear_fields (void) { +// tree_act_tl_field (fields[namespace_level], (void *)free); + fields[namespace_level] = tree_clear_tl_field (fields[namespace_level]); +} + +struct tl_var *tl_add_var (char *id, struct tl_combinator_tree *ptr, int type) { + struct tl_var *v = talloc (sizeof (*v)); + v->id = tstrdup (id); + v->type = type; + v->ptr = ptr; + v->flags = 0; + if (tree_lookup_tl_var (vars[namespace_level], v)) { + return 0; + } + vars[namespace_level] = tree_insert_tl_var (vars[namespace_level], v, lrand48 ()); + if (type) { + last_num_var[namespace_level] = v; + } + return v; +} + +void tl_del_var (struct tl_var *v) { +// free (v->id); + tfree (v, sizeof (*v)); +} + +void tl_clear_vars (void) { + tree_act_tl_var (vars[namespace_level], tl_del_var); + vars[namespace_level] = tree_clear_tl_var (vars[namespace_level]); + last_num_var[namespace_level] = 0; +} + +struct tl_var *tl_get_last_num_var (void) { + return last_num_var[namespace_level]; +} + +struct tl_var *tl_get_var (char *_id, int len) { + char *id = mystrdup (_id, len); + struct tl_var v = {.id = id}; + int i; + for (i = namespace_level; i >= 0; i--) { + struct tl_var *w = tree_lookup_tl_var (vars[i], &v); + if (w) { + tfree (id, len + 1); + return w; + } + } + tfree (id, len + 1); + return 0; +} + +void namespace_push (void) { + namespace_level ++; + assert (namespace_level < 10); + tl_clear_vars (); + tl_clear_fields (); +} + +void namespace_pop (void) { + namespace_level --; + assert (namespace_level >= 0); +} + +struct tl_type *tl_get_type (const char *_id, int len) { + char *id = mystrdup (_id, len); + struct tl_type _t = {.id = id}; + struct tl_type *r = tree_lookup_tl_type (tl_type_tree, &_t); + tfree (id, len + 1); + return r; +} + +struct tl_type *tl_add_type (const char *_id, int len, int params_num, long long params_types) { + char *id = talloc (len + 1); + memcpy (id, _id, len); + id[len] = 0; + struct tl_type _t = {.id = id}; + struct tl_type *_r = 0; + if ((_r = tree_lookup_tl_type (tl_type_tree, &_t))) { + tfree (id, len + 1); + if (params_num >= 0 && (_r->params_num != params_num || _r->params_types != params_types)) { + TL_ERROR ("Wrong params_num or types for type %s\n", _r->id); + return 0; + } + return _r; + } + struct tl_type *t = talloc (sizeof (*t)); + t->id = id; + t->print_id = tstrdup (t->id); + int i; + for (i = 0; i < len; i++) if (t->print_id[i] == '.' || t->print_id[i] == '#' || t->print_id[i] == ' ') { + t->print_id[i] = '$'; + } + t->name = 0; + t->constructors_num = 0; + t->constructors = 0; + t->flags = 0; + t->real_id = 0; + if (params_num >= 0) { + assert (params_num <= 64); + t->params_num = params_num; + t->params_types = params_types; + } else { + t->flags |= 4; + t->params_num = -1; + } + tl_type_tree = tree_insert_tl_type (tl_type_tree, t, lrand48 ()); + total_types_num ++; + return t; +} + +void tl_add_type_param (struct tl_type *t, int x) { + assert (t->flags & 4); + assert (t->params_num <= 64); + if (x) { + t->params_types |= (1ull << (t->params_num ++)); + } else { + t->params_num ++; + } +} + +int tl_type_set_params (struct tl_type *t, int x, long long y) { + if (t->flags & 4) { + t->params_num = x; + t->params_types = y; + t->flags &= ~4; + } else { + if (t->params_num != x || t->params_types != y) { + fprintf (stderr, "Wrong num of params (type %s)\n", t->id); + return 0; + } + } + return 1; +} + +void tl_type_finalize (struct tl_type *t) { + t->flags &= ~4; +} + +struct tl_constructor *tl_get_constructor (const char *_id, int len) { + char *id = mystrdup (_id, len); + struct tl_constructor _t = {.id = id}; + struct tl_constructor *r = tree_lookup_tl_constructor (tl_constructor_tree, &_t); + tfree (id, len + 1); + return r; +} + +struct tl_constructor *tl_add_constructor (struct tl_type *a, const char *_id, int len, int force_magic) { + assert (a); + if (a->flags & 1) { + TL_ERROR ("New constructor for type `%s` after final statement\n", a->id); + return 0; + } + int x = 0; + while (x < len && (_id[x] != '#' || force_magic)) { x++; } + char *id = talloc (x + 1); + memcpy (id, _id, x); + id[x] = 0; + + unsigned magic = 0; + if (x < len) { + assert (len - x >= 6 && len - x <= 9); + int i; + for (i = 1; i < len - x; i++) { + magic = (magic << 4) + (_id[x + i] <= '9' ? _id[x + i] - '0' : _id[x + i] - 'a' + 10); + } + assert (magic && magic != (unsigned)-1); + } + + len = x; + if (*id != '_') { + struct tl_constructor _t = {.id = id}; + if (tree_lookup_tl_constructor (tl_constructor_tree, &_t)) { + TL_ERROR ("Duplicate constructor id `%s`\n", id); + tfree (id, len + 1); + return 0; + } + } else { + assert (len == 1); + } + + struct tl_constructor *t = talloc (sizeof (*t)); + t->type = a; + t->name = magic; + t->id = id; + t->print_id = tstrdup (id); + t->real_id = 0; + + int i; + for (i = 0; i < len; i++) if (t->print_id[i] == '.' || t->print_id[i] == '#' || t->print_id[i] == ' ') { + t->print_id[i] = '$'; + } + + t->left = t->right = 0; + a->constructors = realloc (a->constructors, sizeof (void *) * (a->constructors_num + 1)); + assert (a->constructors); + a->constructors[a->constructors_num ++] = t; + if (*id != '_') { + tl_constructor_tree = tree_insert_tl_constructor (tl_constructor_tree, t, lrand48 ()); + } else { + a->flags |= FLAG_DEFAULT_CONSTRUCTOR; + } + total_constructors_num ++; + return t; +} + +struct tl_constructor *tl_get_function (const char *_id, int len) { + char *id = mystrdup (_id, len); + struct tl_constructor _t = {.id = id}; + struct tl_constructor *r = tree_lookup_tl_constructor (tl_function_tree, &_t); + tfree (id, len + 1); + return r; +} + +struct tl_constructor *tl_add_function (struct tl_type *a, const char *_id, int len, int force_magic) { +// assert (a); + int x = 0; + while (x < len && ((_id[x] != '#') || force_magic)) { x++; } + char *id = talloc (x + 1); + memcpy (id, _id, x); + id[x] = 0; + + unsigned magic = 0; + if (x < len) { + assert (len - x >= 6 && len - x <= 9); + int i; + for (i = 1; i < len - x; i++) { + magic = (magic << 4) + (_id[x + i] <= '9' ? _id[x + i] - '0' : _id[x + i] - 'a' + 10); + } + assert (magic && magic != (unsigned)-1); + } + + len = x; + + struct tl_constructor _t = {.id = id}; + if (tree_lookup_tl_constructor (tl_function_tree, &_t)) { + TL_ERROR ("Duplicate function id `%s`\n", id); + tfree (id, len + 1); + return 0; + } + + struct tl_constructor *t = talloc (sizeof (*t)); + t->type = a; + t->name = magic; + t->id = id; + t->print_id = tstrdup (id); + t->real_id = 0; + + int i; + for (i = 0; i < len; i++) if (t->print_id[i] == '.' || t->print_id[i] == '#' || t->print_id[i] == ' ') { + t->print_id[i] = '$'; + } + + t->left = t->right = 0; + tl_function_tree = tree_insert_tl_constructor (tl_function_tree, t, lrand48 ()); + total_functions_num ++; + return t; +} + +static char buf[(1 << 20)]; +int buf_pos; + +struct tl_combinator_tree *alloc_ctree_node (void) { + struct tl_combinator_tree *T = talloc (sizeof (*T)); + assert (T); + memset (T, 0, sizeof (*T)); + return T; +} + +struct tl_combinator_tree *tl_tree_dup (struct tl_combinator_tree *T) { + if (!T) { return 0; } + struct tl_combinator_tree *S = talloc (sizeof (*S)); + memcpy (S, T, sizeof (*S)); + S->left = tl_tree_dup (T->left); + S->right = tl_tree_dup (T->right); + return S; +} + +struct tl_type *tl_tree_get_type (struct tl_combinator_tree *T) { + assert (T->type == type_type); + if (T->act == act_array) { return 0;} + while (T->left) { + T = T->left; + if (T->act == act_array) { return 0;} + assert (T->type == type_type); + } + assert (T->act == act_type || T->act == act_var || T->act == act_array); + return T->act == act_type ? T->data : 0; +} + +void tl_tree_set_len (struct tl_combinator_tree *T) { + TL_INIT (H); + H = T; + while (H->left) { + H->left->type_len = H->type_len + 1; + H = H->left; + } + assert (H->type == type_type); + struct tl_type *t = H->data; + assert (t); + assert (H->type_len == t->params_num); +} + +void tl_buf_reset (void) { + buf_pos = 0; +} + +void tl_buf_add_string (char *s, int len) { + if (len < 0) { len = strlen (s); } + buf[buf_pos ++] = ' '; + memcpy (buf + buf_pos, s, len); buf_pos += len; + buf[buf_pos] = 0; +} + +void tl_buf_add_string_nospace (char *s, int len) { + if (len < 0) { len = strlen (s); } +// if (buf_pos) { buf[buf_pos ++] = ' '; } + memcpy (buf + buf_pos, s, len); buf_pos += len; + buf[buf_pos] = 0; +} + +void tl_buf_add_string_q (char *s, int len, int x) { + if (x) { + tl_buf_add_string (s, len); + } else { + tl_buf_add_string_nospace (s, len); + } +} + + +void tl_buf_add_tree (struct tl_combinator_tree *T, int x) { + if (!T) { return; } + assert (T != (void *)-1l && T != (void *)-2l); + switch (T->act) { + case act_question_mark: + tl_buf_add_string_q ("?", -1, x); + return; + case act_type: + if ((T->flags & 1) && !(T->flags & 4)) { + tl_buf_add_string_q ("%", -1, x); + x = 0; + } + if (T->flags & 2) { + tl_buf_add_string_q ((char *)T->data, -1, x); + } else { + struct tl_type *t = T->data; + if (T->flags & 4) { + assert (t->constructors_num == 1); + tl_buf_add_string_q (t->constructors[0]->real_id ? t->constructors[0]->real_id : t->constructors[0]->id, -1, x); + } else { + tl_buf_add_string_q (t->real_id ? t->real_id : t->id, -1, x); + } + } + return; + case act_field: + if (T->data) { + tl_buf_add_string_q ((char *)T->data, -1, x); + x = 0; + tl_buf_add_string_q (":", -1, 0); + } + tl_buf_add_tree (T->left, x); + tl_buf_add_tree (T->right, 1); + return; + case act_union: + tl_buf_add_tree (T->left, x); + tl_buf_add_tree (T->right, 1); + return; + case act_var: + { + if (T->data == (void *)-1l) { return; } + struct tl_combinator_tree *v = T->data; + tl_buf_add_string_q ((char *)v->data, -1, x); + if (T->type == type_num && T->type_flags) { + static char _buf[30]; + sprintf (_buf, "+%lld", T->type_flags); + tl_buf_add_string_q (_buf, -1, 0); + } + } + return; + case act_arg: + tl_buf_add_tree (T->left, x); + tl_buf_add_tree (T->right, 1); + return; + case act_array: + if (T->left && !(T->left->flags & 128)) { + tl_buf_add_tree (T->left, x); + x = 0; + tl_buf_add_string_q ("*", -1, x); + } + tl_buf_add_string_q ("[", -1, x); + tl_buf_add_tree (T->right, 1); + tl_buf_add_string_q ("]", -1, 1); + return; + case act_plus: + tl_buf_add_tree (T->left, x); + tl_buf_add_string_q ("+", -1, 0); + tl_buf_add_tree (T->right, 0); + return; + case act_nat_const: + { + static char _buf[30]; + snprintf (_buf, 29, "%lld", T->type_flags); + tl_buf_add_string_q (_buf, -1, x); + return; + } + case act_opt_field: + { + struct tl_combinator_tree *v = T->left->data; + tl_buf_add_string_q ((char *)v->data, -1, x); + tl_buf_add_string_q (".", -1, 0); + static char _buf[30]; + sprintf (_buf, "%lld", T->left->type_flags); + tl_buf_add_string_q (_buf, -1, 0); + tl_buf_add_string_q ("?", -1, 0); + tl_buf_add_tree (T->right, 0); + return; + } + + default: + fprintf (stderr, "%s %s\n", TL_ACT (T->act), TL_TYPE (T->type)); + assert (0); + return; + } +} + +int tl_count_combinator_name (struct tl_constructor *c) { + assert (c); + tl_buf_reset (); + tl_buf_add_string_nospace (c->real_id ? c->real_id : c->id, -1); + tl_buf_add_tree (c->left, 1); + tl_buf_add_string ("=", -1); + tl_buf_add_tree (c->right, 1); + //fprintf (stderr, "%.*s\n", buf_pos, buf); + if (!c->name) { + c->name = crc32 (CRC32_INITIAL, (void *) buf, buf_pos); + } + return c->name; +} + +int tl_print_combinator (struct tl_constructor *c) { + tl_buf_reset (); + tl_buf_add_string_nospace (c->real_id ? c->real_id : c->id, -1); + static char _buf[10]; + sprintf (_buf, "#%08x", c->name); + tl_buf_add_string_nospace (_buf, -1); + tl_buf_add_tree (c->left, 1); + tl_buf_add_string ("=", -1); + tl_buf_add_tree (c->right, 1); + if (output_expressions >= 1) { + fprintf (stderr, "%.*s\n", buf_pos, buf); + } +/* if (!c->name) { + c->name = crc32 (CRC32_INITIAL, (void *) bbuf, buf_pos); + }*/ + return c->name; +} + +int _tl_finish_subtree (struct tl_combinator_tree *R, int x, long long y) { + assert (R->type == type_type); + assert (R->type_len < 0); + assert (R->act == act_arg || R->act == act_type); + R->type_len = x; + R->type_flags = y; + if (R->act == act_type) { + struct tl_type *t = R->data; + assert (t); + return tl_type_set_params (t, x, y); + } + assert ((R->right->type == type_type && R->right->type_len == 0) || R->right->type == type_num || R->right->type == type_num_value); + return _tl_finish_subtree (R->left, x + 1, y * 2 + (R->right->type == type_num || R->right->type == type_num_value)); +} + +int tl_finish_subtree (struct tl_combinator_tree *R) { + assert (R); + if (R->type != type_type) { + return 1; + } + if (R->type_len >= 0) { + if (R->type_len > 0) { + TL_ERROR ("Not enough params\n"); + return 0; + } + return 1; + } + return _tl_finish_subtree (R, 0, 0); +} + +struct tl_combinator_tree *tl_union (struct tl_combinator_tree *L, struct tl_combinator_tree *R) { + if (!L) { return R; } + if (!R) { return L; } + TL_INIT (v); + v = alloc_ctree_node (); + v->left = L; + v->right = R; + switch (L->type) { + case type_num: + if (R->type != type_num_value) { + TL_ERROR ("Union: type mistmatch\n"); + return 0; + } + tfree (v, sizeof (*v)); + L->type_flags += R->type_flags; + return L; + case type_num_value: + if (R->type != type_num_value && R->type != type_num) { + TL_ERROR ("Union: type mistmatch\n"); + return 0; + } + tfree (v, sizeof (*v)); + R->type_flags += L->type_flags; + return R; + case type_list_item: + case type_list: + if (R->type != type_list_item) { + TL_ERROR ("Union: type mistmatch\n"); + return 0; + } + v->type = type_list; + v->act = act_union; + return v; + case type_type: + if (L->type_len == 0) { + TL_ERROR ("Arguments number exceeds type arity\n"); + return 0; + } + if (R->type != type_num && R->type != type_type && R->type != type_num_value) { + TL_ERROR ("Union: type mistmatch\n"); + return 0; + } + if (R->type_len < 0) { + if (!tl_finish_subtree (R)) { + return 0; + } + } + if (R->type_len > 0) { + TL_ERROR ("Argument type must have full number of arguments\n"); + return 0; + } + if (L->type_len > 0 && ((L->type_flags & 1) != (R->type == type_num || R->type == type_num_value))) { + TL_ERROR ("Argument types mistmatch: L->type_flags = %lld, R->type = %s\n", L->flags, TL_TYPE (R->type)); + return 0; + } + v->type = type_type; + v->act = act_arg; + v->type_len = L->type_len > 0 ? L->type_len - 1 : -1; + v->type_flags = L->type_flags >> 1; + return v; + default: + assert (0); + return 0; + } +} + +struct tl_combinator_tree *tl_parse_any_term (struct tree *T, int s); +struct tl_combinator_tree *tl_parse_term (struct tree *T, int s) { + assert (T->type == type_term); + int i = 0; + while (i < T->nc && T->c[i]->type == type_percent) { i ++; s ++; } + assert (i < T->nc); + TL_INIT (L); + while (i < T->nc) { + TL_TRY (tl_parse_any_term (T->c[i], s), L); + s = 0; + i ++; + } + return L; +} + + +struct tl_combinator_tree *tl_parse_type_term (struct tree *T, int s) { + assert (T->type == type_type_term); + assert (T->nc == 1); + struct tl_combinator_tree *Z = tl_parse_term (T->c[0], s); + if (!Z || Z->type != type_type) { if (Z) { TL_ERROR ("type_term: found type %s\n", TL_TYPE (Z->type)); } TL_FAIL; } + return Z; +} + +struct tl_combinator_tree *tl_parse_nat_term (struct tree *T, int s) { + assert (T->type == type_nat_term); + assert (T->nc == 1); + struct tl_combinator_tree *Z = tl_parse_term (T->c[0], s); + 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; } + return Z; +} + +struct tl_combinator_tree *tl_parse_subexpr (struct tree *T, int s) { + assert (T->type == type_subexpr); + assert (T->nc >= 1); + int i; + TL_INIT (L); + for (i = 0; i < T->nc; i++) { + TL_TRY (tl_parse_any_term (T->c[i], s), L); + s = 0; + } + return L; +} + +struct tl_combinator_tree *tl_parse_expr (struct tree *T, int s) { + assert (T->type == type_expr); + assert (T->nc >= 1); + int i; + TL_INIT (L); + for (i = 0; i < T->nc; i++) { + TL_TRY (tl_parse_subexpr (T->c[i], s), L); + s = 0; + } + return L; +} + +struct tl_combinator_tree *tl_parse_nat_const (struct tree *T, int s) { + assert (T->type == type_nat_const); + assert (!T->nc); + if (s > 0) { + TL_ERROR ("Nat const can not precede with %%\n"); + TL_FAIL; + } + assert (T->type == type_nat_const); + assert (!T->nc); + TL_INIT (L); + L = alloc_ctree_node (); + L->act = act_nat_const; + L->type = type_num_value; + int i; + long long x = 0; + for (i = 0; i < T->len; i++) { + x = x * 10 + T->text[i] - '0'; + } + L->type_flags = x; + return L; +} + +struct tl_combinator_tree *tl_parse_ident (struct tree *T, int s) { + assert (T->type == type_type_ident || T->type == type_var_ident || T->type == type_boxed_type_ident); + assert (!T->nc); + struct tl_var *v = tl_get_var (T->text, T->len); + TL_INIT (L); + if (v) { + L = alloc_ctree_node (); + L->act = act_var; + L->type = v->type ? type_num : type_type; + if (L->type == type_num && s) { + TL_ERROR ("Nat var can not precede with %%\n"); + TL_FAIL; + } else { + if (s) { + L->flags |= 1; + } + } + L->type_len = 0; + L->type_flags = 0; + L->data = v->ptr; + return L; + } + +/* if (!mystrcmp2 (T->text, T->len, "#") || !mystrcmp2 (T->text, T->len, "Type")) { + L = alloc_ctree_node (); + L->act = act_type; + L->flags |= 2; + L->data = tl_get_type (T->text, T->len); + assert (L->data); + L->type = type_type; + L->type_len = 0; + L->type_flags = 0; + return L; + }*/ + + struct tl_constructor *c = tl_get_constructor (T->text, T->len); + if (c) { + assert (c->type); + if (c->type->constructors_num != 1) { + TL_ERROR ("Constructor can be used only if it is the only constructor of the type\n"); + return 0; + } + c->type->flags |= 1; + L = alloc_ctree_node (); + L->act = act_type; + L->flags |= 5; + L->data = c->type; + L->type = type_type; + L->type_len = c->type->params_num; + L->type_flags = c->type->params_types; + return L; + } + int x = tl_is_type_name (T->text, T->len); + if (x) { + struct tl_type *t = tl_add_type (T->text, T->len, -1, 0); + L = alloc_ctree_node (); + if (s) { + L->flags |= 1; + t->flags |= 8; + } + L->act = act_type; + L->data = t; + L->type = type_type; + L->type_len = t->params_num; + L->type_flags = t->params_types; + return L; + } else { + TL_ERROR ("Not a type/var ident `%.*s`\n", T->len, T->text); + return 0; + } +} + +struct tl_combinator_tree *tl_parse_any_term (struct tree *T, int s) { + switch (T->type) { + case type_type_term: + return tl_parse_type_term (T, s); + case type_nat_term: + return tl_parse_nat_term (T, s); + case type_term: + return tl_parse_term (T, s); + case type_expr: + return tl_parse_expr (T, s); + case type_subexpr: + return tl_parse_subexpr (T, s); + case type_nat_const: + return tl_parse_nat_const (T, s); + case type_type_ident: + case type_var_ident: + return tl_parse_ident (T, s); + default: + fprintf (stderr, "type = %d\n", T->type); + assert (0); + return 0; + } +} + +struct tl_combinator_tree *tl_parse_multiplicity (struct tree *T) { + assert (T->type == type_multiplicity); + assert (T->nc == 1); + return tl_parse_nat_term (T->c[0], 0); +} + +struct tl_combinator_tree *tl_parse_opt_args (struct tree *T) { + assert (T); + assert (T->type == type_opt_args); + assert (T->nc >= 2); + TL_INIT (R); + TL_TRY (tl_parse_type_term (T->c[T->nc - 1], 0), R); + assert (R->type == type_type && !R->type_len); + assert (tl_finish_subtree (R)); + struct tl_type *t = tl_tree_get_type (R); + //assert (t); + int tt = -1; + if (t && !strcmp (t->id, "#")) { + tt = 1; + } else if (t && !strcmp (t->id, "Type")) { + tt = 0; + } + if (tt < 0) { + TL_ERROR ("Optargs can be only of type # or Type\n"); + TL_FAIL; + } + + int i; + for (i = 0; i < T->nc - 1; i++) { + if (T->c[i]->type != type_var_ident) { + TL_ERROR ("Variable name expected\n"); + TL_FAIL; + } + if (T->c[i]->len == 1 && *T->c[i]->text == '_') { + TL_ERROR ("Variables can not be unnamed\n"); + TL_FAIL; + } + } + TL_INIT (H); +// for (i = T->nc - 2; i >= (T->nc >= 2 ? 0 : -1); i--) { + for (i = 0; i <= T->nc - 2; i++) { + TL_INIT (S); S = alloc_ctree_node (); + S->left = (i == T->nc - 2) ? R : tl_tree_dup (R) ; S->right = 0; + S->type = type_list_item; + S->type_len = 0; + S->act = act_field; + S->data = i >= 0 ? mystrdup (T->c[i]->text, T->c[i]->len) : 0; + if (tt >= 0) { + assert (S->data); + tl_add_var (S->data, S, tt); + } + S->flags = 33; + H = tl_union (H, S); + } + return H; +} + +struct tl_combinator_tree *tl_parse_args (struct tree *T); +struct tl_combinator_tree *tl_parse_args2 (struct tree *T) { + assert (T); + assert (T->type == type_args2); + assert (T->nc >= 1); + TL_INIT (R); + TL_INIT (L); + int x = 0; + char *field_name = 0; + if (T->c[x]->type == type_var_ident_opt || T->c[x]->type == type_var_ident) { + field_name = mystrdup (T->c[x]->text, T->c[x]->len); + if (!tl_add_field (field_name)) { + TL_ERROR ("Duplicate field name %s\n", field_name); + TL_FAIL; + } + x ++; + } + //fprintf (stderr, "%d %d\n", x, T->nc); + if (T->c[x]->type == type_multiplicity) { + L = tl_parse_multiplicity (T->c[x]); + if (!L) { TL_FAIL;} + x ++; + } else { + struct tl_var *v = tl_get_last_num_var (); + if (!v) { + TL_ERROR ("Expected multiplicity or nat var\n"); + TL_FAIL; + } + L = alloc_ctree_node (); + L->act = act_var; + L->type = type_num; + L->flags |= 128; + L->type_len = 0; + L->type_flags = 0; + L->data = v->ptr; + ((struct tl_combinator_tree *)(v->ptr))->flags |= 256; + } + namespace_push (); + while (x < T->nc) { + TL_TRY (tl_parse_args (T->c[x]), R); + x ++; + } + namespace_pop (); + struct tl_combinator_tree *S = alloc_ctree_node (); + S->type = type_type; + S->type_len = 0; + S->act = act_array; + S->left = L; + S->right = R; + //S->data = field_name; + + struct tl_combinator_tree *H = alloc_ctree_node (); + H->type = type_list_item; + H->act = act_field; + H->left = S; + H->right = 0; + H->data = field_name; + H->type_len = 0; + + return H; +} + +void tl_mark_vars (struct tl_combinator_tree *T); +struct tl_combinator_tree *tl_parse_args134 (struct tree *T) { + assert (T); + assert (T->type == type_args1 || T->type == type_args3 || T->type == type_args4); + assert (T->nc >= 1); + TL_INIT (R); + TL_TRY (tl_parse_type_term (T->c[T->nc - 1], 0), R); + assert (tl_finish_subtree (R)); + assert (R->type == type_type && !R->type_len); + struct tl_type *t = tl_tree_get_type (R); + //assert (t); + int tt = -1; + if (t && !strcmp (t->id, "#")) { + tt = 1; + } else if (t && !strcmp (t->id, "Type")) { + tt = 0; + } + +/* if (tt >= 0 && T->nc == 1) { + TL_ERROR ("Variables can not be unnamed (type %d)\n", tt); + }*/ + int last = T->nc - 2; + int excl = 0; + if (last >= 0 && T->c[last]->type == type_exclam) { + excl ++; + tl_mark_vars (R); + last --; + } + if (last >= 0 && T->c[last]->type == type_optional_arg_def) { + assert (T->c[last]->nc == 2); + TL_INIT (E); E = alloc_ctree_node (); + E->type = type_type; + E->act = act_opt_field; + E->left = tl_parse_ident (T->c[last]->c[0], 0); + int i; + long long x = 0; + for (i = 0; i < T->c[last]->c[1]->len; i++) { + x = x * 10 + T->c[last]->c[1]->text[i] - '0'; + } + E->left->type_flags = x; + E->type_flags = R->type_flags; + E->type_len = R->type_len; + E->right = R; + R = E; + last --; + } + int i; + for (i = 0; i < last; i++) { + if (T->c[i]->type != type_var_ident && T->c[i]->type != type_var_ident_opt) { + TL_ERROR ("Variable name expected\n"); + TL_FAIL; + } +/* if (tt >= 0 && (T->nc == 1 || (T->c[i]->len == 1 && *T->c[i]->text == '_'))) { + TL_ERROR ("Variables can not be unnamed\n"); + TL_FAIL; + }*/ + } + TL_INIT (H); +// for (i = T->nc - 2; i >= (T->nc >= 2 ? 0 : -1); i--) { + for (i = (last >= 0 ? 0 : -1); i <= last; i++) { + TL_INIT (S); S = alloc_ctree_node (); + S->left = (i == last) ? R : tl_tree_dup (R) ; S->right = 0; + S->type = type_list_item; + S->type_len = 0; + S->act = act_field; + S->data = i >= 0 ? mystrdup (T->c[i]->text, T->c[i]->len) : 0; + if (excl) { + S->flags |= FLAG_EXCL; + } + if (S->data && (T->c[i]->len >= 2 || *T->c[i]->text != '_')) { + if (!tl_add_field (S->data)) { + TL_ERROR ("Duplicate field name %s\n", (char *)S->data); + TL_FAIL; + } + } + if (tt >= 0) { + char *name = S->data; + static char s[21]; + if (!name) { + sprintf (s, "%lld", lrand48 () * (1ll << 32) + lrand48 ()); + name = s; // will be strdup'd, so reference-to-stack is fine. + } + struct tl_var *v = tl_add_var (name, S, tt); + if (!v) {TL_FAIL;} + v->flags |= 2; + } + + H = tl_union (H, S); + } + return H; +} + + +struct tl_combinator_tree *tl_parse_args (struct tree *T) { + assert (T->type == type_args); + assert (T->nc == 1); + switch (T->c[0]->type) { + case type_args1: + return tl_parse_args134 (T->c[0]); + case type_args2: + return tl_parse_args2 (T->c[0]); + case type_args3: + return tl_parse_args134 (T->c[0]); + case type_args4: + return tl_parse_args134 (T->c[0]); + default: + assert (0); + return 0; + } +} + +void tl_mark_vars (struct tl_combinator_tree *T) { + if (!T) { return; } + if (T->act == act_var) { + char *id = ((struct tl_combinator_tree *)(T->data))->data; + struct tl_var *v = tl_get_var (id, strlen (id)); + assert (v); + v->flags |= 1; + } + tl_mark_vars (T->left); + tl_mark_vars (T->right); +} + +struct tl_combinator_tree *tl_parse_result_type (struct tree *T) { + assert (T->type == type_result_type); + assert (T->nc >= 1); + assert (T->nc <= 64); + + TL_INIT (L); + + if (tl_get_var (T->c[0]->text, T->c[0]->len)) { + if (T->nc != 1) { + TL_ERROR ("Variable can not take params\n"); + TL_FAIL; + } + L = alloc_ctree_node (); + L->act = act_var; + L->type = type_type; + struct tl_var *v = tl_get_var (T->c[0]->text, T->c[0]->len); + if (v->type) { + TL_ERROR ("Type mistmatch\n"); + TL_FAIL; + } + L->data = v->ptr; +// assert (v->ptr); + } else { + L = alloc_ctree_node (); + L->act = act_type; + L->type = type_type; + struct tl_type *t = tl_add_type (T->c[0]->text, T->c[0]->len, -1, 0); + assert (t); + L->type_len = t->params_num; + L->type_flags = t->params_types; + L->data = t; + + int i; + for (i = 1; i < T->nc; i++) { + TL_TRY (tl_parse_any_term (T->c[i], 0), L); + assert (L->right); + assert (L->right->type == type_num || L->right->type == type_num_value || (L->right->type == type_type && L->right->type_len == 0)); + } + } + + if (!tl_finish_subtree (L)) { + TL_FAIL; + } + + tl_mark_vars (L); + return L; +} + +int __ok; +void tl_var_check_used (struct tl_var *v) { + __ok = __ok && (v->flags & 3); +} + +int tl_parse_combinator_decl (struct tree *T, int fun) { + assert (T->type == type_combinator_decl); + assert (T->nc >= 3); + namespace_level = 0; + tl_clear_vars (); + tl_clear_fields (); + TL_INIT (L); + TL_INIT (R); + + int i = 1; + while (i < T->nc - 2 && T->c[i]->type == type_opt_args) { + TL_TRY (tl_parse_opt_args (T->c[i]), L); + i++; + } + while (i < T->nc - 2 && T->c[i]->type == type_args) { + TL_TRY (tl_parse_args (T->c[i]), L); + i++; + } + assert (i == T->nc - 2 && T->c[i]->type == type_equals); + i ++; + + R = tl_parse_result_type (T->c[i]); + if (!R) { TL_FAIL; } + + struct tl_type *t = tl_tree_get_type (R); + if (!fun && !t) { + TL_ERROR ("Only functions can return variables\n"); + } + assert (t || fun); + + assert (namespace_level == 0); + __ok = 1; + tree_act_tl_var (vars[0], tl_var_check_used); + if (!__ok) { + TL_ERROR ("Not all variables are used in right side\n"); + TL_FAIL; + } + + if (tl_get_constructor (T->c[0]->text, T->c[0]->len) || tl_get_function (T->c[0]->text, T->c[0]->len)) { + TL_ERROR ("Duplicate combinator id %.*s\n", T->c[0]->len, T->c[0]->text); + return 0; + } + 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); + if (!c) { TL_FAIL; } + c->left = L; + c->right = R; + + if (!c->name) { + tl_count_combinator_name (c); + } + tl_print_combinator (c); + + return 1; +} + +void change_var_ptrs (struct tl_combinator_tree *O, struct tl_combinator_tree *D, struct tree_var_value **V) { + if (!O || !D) { + assert (!O && !D); + return; + } + if (O->act == act_field) { + struct tl_type *t = tl_tree_get_type (O->left); + if (t && (!strcmp (t->id, "#") || !strcmp (t->id, "Type"))) { + tl_set_var_value (V, O, D); + } + } + if (O->act == act_var) { + assert (D->data == O->data); + D->data = tl_get_var_value (V, O->data); + assert (D->data); + } + change_var_ptrs (O->left, D->left, V); + change_var_ptrs (O->right, D->right, V); +} + +struct tl_combinator_tree *change_first_var (struct tl_combinator_tree *O, struct tl_combinator_tree **X, struct tl_combinator_tree *Y) { + if (!O) { return (void *)-2l; }; + if (O->act == act_field && !*X) { + struct tl_type *t = tl_tree_get_type (O->left); + if (t && !strcmp (t->id, "#")) { + if (Y->type != type_num && Y->type != type_num_value) { + TL_ERROR ("change_var: Type mistmatch\n"); + return 0; + } else { + *X = O; + return (void *)-1l; + } + } + if (t && !strcmp (t->id, "Type")) { + if (Y->type != type_type || Y->type_len != 0) { + TL_ERROR ("change_var: Type mistmatch\n"); + return 0; + } else { + *X = O; + return (void *)-1l; + } + } + } + if (O->act == act_var) { + if (O->data == *X) { + struct tl_combinator_tree *R = tl_tree_dup (Y); + if (O->type == type_num || O->type == type_num_value) { R->type_flags += O->type_flags; } + return R; + } + } + struct tl_combinator_tree *t; + t = change_first_var (O->left, X, Y); + if (!t) { return 0;} + if (t == (void *)-1l) { + t = change_first_var (O->right, X, Y); + if (!t) { return 0;} + if (t == (void *)-1l) { return (void *)-1l; } + if (t != (void *)-2l) { return t;} + return (void *)-1l; + } + if (t != (void *)-2l) { + O->left = t; + } + t = change_first_var (O->right, X, Y); + if (!t) { return 0;} + if (t == (void *)-1l) { + return O->left; + } + if (t != (void *)-2l) { + O->right = t; + } + return O; +} + + +int uniformize (struct tl_combinator_tree *L, struct tl_combinator_tree *R, struct tree_var_value **T); +struct tree_var_value **_T; +int __tok; +void check_nat_val (struct tl_var_value v) { + if (!__tok) { return; } + long long x = v.num_val; + struct tl_combinator_tree *L = v.val; + if (L->type == type_type) { return;} + while (1) { + if (L->type == type_num_value) { + if (x + L->type_flags < 0) { + __tok = 0; + return; + } else { + return; + } + } + assert (L->type == type_num); + x += L->type_flags; + x += tl_get_var_value_num (_T, L->data); + L = tl_get_var_value (_T, L->data); + if (!L) { return;} + } +} + +int check_constructors_equal (struct tl_combinator_tree *L, struct tl_combinator_tree *R, struct tree_var_value **T) { + if (!uniformize (L, R, T)) { return 0; } + __tok = 1; + _T = T; + tree_act_var_value (*T, check_nat_val); + return __tok; +} + +struct tl_combinator_tree *reduce_type (struct tl_combinator_tree *A, struct tl_type *t) { + assert (A); + if (A->type_len == t->params_num) { + assert (A->type_flags == t->params_types); + A->act = act_type; + A->type = type_type; + A->left = A->right = 0; + A->data = t; + return A; + } + A->left = reduce_type (A->left, t); + return A; +} + +struct tl_combinator_tree *change_value_var (struct tl_combinator_tree *O, struct tree_var_value **X) { + if (!O) { return (void *)-2l; }; + while (O->act == act_var) { + assert (O->data); + if (!tl_get_var_value (X, O->data)) { + break; + } + if (O->type == type_type) { + O = tl_tree_dup (tl_get_var_value (X, O->data)); + } else { + long long n = tl_get_var_value_num (X, O->data); + struct tl_combinator_tree *T = tl_get_var_value (X, O->data); + O->data = T->data; + O->type = T->type; + O->act = T->act; + O->type_flags = O->type_flags + n + T->type_flags; + } + } + if (O->act == act_field) { + if (tl_get_var_value (X, O)) { return (void *)-1l; } + } + struct tl_combinator_tree *t; + t = change_value_var (O->left, X); + if (!t) { return 0;} + if (t == (void *)-1l) { + t = change_value_var (O->right, X); + if (!t) { return 0;} + if (t == (void *)-1l) { return (void *)-1l; } + if (t != (void *)-2l) { return t;} + return (void *)-1l; + } + if (t != (void *)-2l) { + O->left = t; + } + t = change_value_var (O->right, X); + if (!t) { return 0;} + if (t == (void *)-1l) { + return O->left; + } + if (t != (void *)-2l) { + O->right = t; + } + return O; +} + +int tl_parse_partial_type_app_decl (struct tree *T) { + assert (T->type == type_partial_type_app_decl); + assert (T->nc >= 1); + + assert (T->c[0]->type == type_boxed_type_ident); + struct tl_type *t = tl_get_type (T->c[0]->text, T->c[0]->len); + if (!t) { + TL_ERROR ("Can not make partial app for unknown type\n"); + return 0; + } + + tl_type_finalize (t); + + struct tl_combinator_tree *L = tl_parse_ident (T->c[0], 0); + assert (L); + int i; + tl_buf_reset (); + int cc = T->nc - 1; + for (i = 1; i < T->nc; i++) { + TL_TRY (tl_parse_any_term (T->c[i], 0), L); + tl_buf_add_tree (L->right, 1); + } + + while (L->type_len) { + struct tl_combinator_tree *C = alloc_ctree_node (); + C->act = act_var; + C->type = (L->type_flags & 1) ? type_num : type_type; + C->type_len = 0; + C->type_flags = 0; + C->data = (void *)-1l; + L = tl_union (L, C); + if (!L) { return 0; } + } + + + static char _buf[100000]; + snprintf (_buf, 100000, "%s%.*s", t->id, buf_pos, buf); + struct tl_type *nt = tl_add_type (_buf, strlen (_buf), t->params_num - cc, t->params_types >> cc); + assert (nt); + //snprintf (_buf, 100000, "%s #", t->id); + //nt->real_id = strdup (_buf); + + for (i = 0; i < t->constructors_num; i++) { + struct tl_constructor *c = t->constructors[i]; + struct tree_var_value *V = 0; + TL_INIT (A); + TL_INIT (B); + A = tl_tree_dup (c->left); + B = tl_tree_dup (c->right); + + struct tree_var_value *W = 0; + change_var_ptrs (c->left, A, &W); + change_var_ptrs (c->right, B, &W); + + + if (!check_constructors_equal (B, L, &V)) { continue; } + B = reduce_type (B, nt); + A = change_value_var (A, &V); + if (A == (void *)-1l) { A = 0;} + B = change_value_var (B, &V); + assert (B != (void *)-1l); + snprintf (_buf, 100000, "%s%.*s", c->id, buf_pos, buf); + + struct tl_constructor *r = tl_add_constructor (nt, _buf, strlen (_buf), 1); + snprintf (_buf, 100000, "%s", c->id); + r->real_id = tstrdup (_buf); + + r->left = A; + r->right = B; + if (!r->name) { + tl_count_combinator_name (r); + } + tl_print_combinator (r); + } + + return 1; +} + +int tl_parse_partial_comb_app_decl (struct tree *T, int fun) { + assert (T->type == type_partial_comb_app_decl); + + 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); + if (!c) { + TL_ERROR ("Can not make partial app for undefined combinator\n"); + return 0; + } + + //TL_INIT (K); + //static char buf[1000]; + //int x = sprintf (buf, "%s", c->id); + TL_INIT (L); + TL_INIT (R); + L = tl_tree_dup (c->left); + R = tl_tree_dup (c->right); + + + struct tree_var_value *V = 0; + change_var_ptrs (c->left, L, &V); + change_var_ptrs (c->right, R, &V); + V = tree_clear_var_value (V); + + int i; + tl_buf_reset (); + for (i = 1; i < T->nc; i++) { + TL_INIT (X); + TL_INIT (Z); + X = tl_parse_any_term (T->c[i], 0); + struct tl_combinator_tree *K = 0; + if (!(Z = change_first_var (L, &K, X))) { + TL_FAIL; + } + L = Z; + if (!K) { + TL_ERROR ("Partial app: not enougth variables (i = %d)\n", i); + TL_FAIL; + } + if (!(Z = change_first_var (R, &K, X))) { + TL_FAIL; + } + assert (Z == R); + tl_buf_add_tree (X, 1); + } + + static char _buf[100000]; + snprintf (_buf, 100000, "%s%.*s", c->id, buf_pos, buf); +// fprintf (stderr, "Local id: %s\n", _buf); + + struct tl_constructor *r = !fun ? tl_add_constructor (c->type, _buf, strlen (_buf), 1) : tl_add_function (c->type, _buf, strlen (_buf), 1); + r->left = L; + r->right = R; + snprintf (_buf, 100000, "%s", c->id); + r->real_id = tstrdup (_buf); + if (!r->name) { + tl_count_combinator_name (r); + } + tl_print_combinator (r); + return 1; +} + + +int tl_parse_partial_app_decl (struct tree *T, int fun) { + assert (T->type == type_partial_app_decl); + assert (T->nc == 1); + if (T->c[0]->type == type_partial_comb_app_decl) { + return tl_parse_partial_comb_app_decl (T->c[0], fun); + } else { + if (fun) { + TL_ERROR ("Partial type app in functions block\n"); + TL_FAIL; + } + return tl_parse_partial_type_app_decl (T->c[0]); + } +} + +int tl_parse_final_final (struct tree *T) { + assert (T->type == type_final_final); + assert (T->nc == 1); + struct tl_type *R; + if ((R = tl_get_type (T->c[0]->text, T->c[0]->len))) { + R->flags |= 1; + return 1; + } else { + TL_ERROR ("Final statement for type `%.*s` before declaration\n", T->c[0]->len, T->c[0]->text); + TL_FAIL; + } +} + +int tl_parse_final_new (struct tree *T) { + assert (T->type == type_final_new); + assert (T->nc == 1); + if (tl_get_type (T->c[0]->text, T->c[0]->len)) { + TL_ERROR ("New statement: type `%.*s` already declared\n", T->c[0]->len, T->c[0]->text); + TL_FAIL; + } else { + return 1; + } +} + +int tl_parse_final_empty (struct tree *T) { + assert (T->type == type_final_empty); + assert (T->nc == 1); + if (tl_get_type (T->c[0]->text, T->c[0]->len)) { + TL_ERROR ("New statement: type `%.*s` already declared\n", T->c[0]->len, T->c[0]->text); + TL_FAIL; + } + struct tl_type *t = tl_add_type (T->c[0]->text, T->c[0]->len, 0, 0); + assert (t); + t->flags |= 1 | FLAG_EMPTY; + return 1; +} + +int tl_parse_final_decl (struct tree *T, int fun) { + assert (T->type == type_final_decl); + assert (!fun); + assert (T->nc == 1); + switch (T->c[0]->type) { + case type_final_new: + return tl_parse_final_new (T->c[0]); + case type_final_final: + return tl_parse_final_final (T->c[0]); + case type_final_empty: + return tl_parse_final_empty (T->c[0]); + default: + assert (0); + return 0; + } +} + +int tl_parse_builtin_combinator_decl (struct tree *T, int fun) { + if (fun) { + TL_ERROR ("Builtin type can not be described in function block\n"); + return -1; + } + assert (T->type == type_builtin_combinator_decl); + assert (T->nc == 2); + assert (T->c[0]->type == type_full_combinator_id); + assert (T->c[1]->type == type_boxed_type_ident); + + + if ((!mystrcmp2 (T->c[0]->text, T->c[0]->len, "int") && !mystrcmp2 (T->c[1]->text, T->c[1]->len, "Int")) || + (!mystrcmp2 (T->c[0]->text, T->c[0]->len, "long") && !mystrcmp2 (T->c[1]->text, T->c[1]->len, "Long")) || + (!mystrcmp2 (T->c[0]->text, T->c[0]->len, "double") && !mystrcmp2 (T->c[1]->text, T->c[1]->len, "Double")) || + (!mystrcmp2 (T->c[0]->text, T->c[0]->len, "string") && !mystrcmp2 (T->c[1]->text, T->c[1]->len, "String"))) { + struct tl_type *t = tl_add_type (T->c[1]->text, T->c[1]->len, 0, 0); + if (!t) { + return 0; + } + struct tl_constructor *c = tl_add_constructor (t, T->c[0]->text, T->c[0]->len, 0); + if (!c) { + return 0; + } + + c->left = alloc_ctree_node (); + c->left->act = act_question_mark; + c->left->type = type_list_item; + + c->right = alloc_ctree_node (); + c->right->act = act_type; + c->right->data = t; + c->right->type = type_type; + + if (!c->name) { + tl_count_combinator_name (c); + } + tl_print_combinator (c); + } else { + TL_ERROR ("Unknown builting type `%.*s`\n", T->c[0]->len, T->c[0]->text); + return 0; + } + + return 1; +} + +int tl_parse_declaration (struct tree *T, int fun) { + assert (T->type == type_declaration); + assert (T->nc == 1); + switch (T->c[0]->type) { + case type_combinator_decl: + return tl_parse_combinator_decl (T->c[0], fun); + case type_partial_app_decl: + return tl_parse_partial_app_decl (T->c[0], fun); + case type_final_decl: + return tl_parse_final_decl (T->c[0], fun); + case type_builtin_combinator_decl: + return tl_parse_builtin_combinator_decl (T->c[0], fun); + default: + assert (0); + return 0; + } +} + +int tl_parse_constr_declarations (struct tree *T) { + assert (T->type == type_constr_declarations); + int i; + for (i = 0; i < T->nc; i++) { + TL_TRY_PES (tl_parse_declaration (T->c[i], 0)); + } + return 1; +} + +int tl_parse_fun_declarations (struct tree *T) { + assert (T->type == type_fun_declarations); + int i; + for (i = 0; i < T->nc; i++) { + TL_TRY_PES (tl_parse_declaration (T->c[i], 1)); + } + return 1; +} + +int tl_tree_lookup_value (struct tl_combinator_tree *L, void *var, struct tree_var_value **T) { + if (!L) { + return -1; + } + if (L->act == act_var && L->data == var) { + return 0; + } + if (L->act == act_var) { + struct tl_combinator_tree *E = tl_get_var_value (T, L->data); + if (!E) { return -1;} + else { return tl_tree_lookup_value (E, var, T); } + } + if (tl_tree_lookup_value (L->left, var, T) >= 0) { return 1; } + if (tl_tree_lookup_value (L->right, var, T) >= 0) { return 1; } + return -1; +} + +int tl_tree_lookup_value_nat (struct tl_combinator_tree *L, void *var, long long x, struct tree_var_value **T) { + assert (L); + if (L->type == type_num_value) { return -1; } + assert (L->type == type_num); + assert (L->act == act_var); + if (L->data == var) { + return x == L->type_flags ? 0 : 1; + } else { + if (!tl_get_var_value (T, L->data)) { + return -1; + } + return tl_tree_lookup_value_nat (tl_get_var_value (T, L->data), var, x + tl_get_var_value_num (T, L->data), T); + } + +} + +int uniformize (struct tl_combinator_tree *L, struct tl_combinator_tree *R, struct tree_var_value **T) { + if (!L || !R) { + assert (!L && !R); + return 1; + } + if (R->act == act_var) { + struct tl_combinator_tree *_ = R; R = L; L = _; + } + + if (L->type == type_type) { + if (R->type != type_type || L->type_len != R->type_len || L->type_flags != R->type_flags) { + return 0; + } + if (R->data == (void *)-1l || L->data == (void *)-1l) { return 1;} + if (L->act == act_var) { + int x = tl_tree_lookup_value (R, L->data, T); + if (x > 0) { +// if (tl_tree_lookup_value (R, L->data, T) > 0) { + return 0; + } + if (x == 0) { + return 1; + } + struct tl_combinator_tree *E = tl_get_var_value (T, L->data); + if (!E) { + tl_set_var_value (T, L->data, R); + return 1; + } else { + return uniformize (E, R, T); + } + } else { + if (L->act != R->act || L->data != R->data) { + return 0; + } + return uniformize (L->left, R->left, T) && uniformize (L->right, R->right, T); + } + } else { + assert (L->type == type_num || L->type == type_num_value); + if (R->type != type_num && R->type != type_num_value) { + return 0; + } + assert (R->type == type_num || R->type == type_num_value); + if (R->data == (void *)-1l || L->data == (void *)-1l) { return 1;} + long long x = 0; + struct tl_combinator_tree *K = L; + while (1) { + x += K->type_flags; + if (K->type == type_num_value) { + break; + } + if (!tl_get_var_value (T, K->data)) { + int s = tl_tree_lookup_value_nat (R, K->data, K->type_flags, T); + if (s > 0) { + return 0; + } + if (s == 0) { + return 1; + } + /*tl_set_var_value_num (T, K->data, R, -x); + return 1;*/ + break; + } + x += tl_get_var_value_num (T, K->data); + K = tl_get_var_value (T, K->data); + } + long long y = 0; + struct tl_combinator_tree *M = R; + while (1) { + y += M->type_flags; + if (M->type == type_num_value) { + break; + } + if (!tl_get_var_value (T, M->data)) { + int s = tl_tree_lookup_value_nat (L, M->data, M->type_flags, T); + if (s > 0) { + return 0; + } + if (s == 0) { + return 1; + } + /*tl_set_var_value_num (T, M->data, L, -y); + return 1;*/ + break; + } + y += tl_get_var_value_num (T, M->data); + M = tl_get_var_value (T, M->data); + } + if (K->type == type_num_value && M->type == type_num_value) { + return x == y; + } + if (M->type == type_num_value) { + tl_set_var_value_num (T, K->data, M, -(x - y + M->type_flags)); + return 1; + } else if (K->type == type_num_value) { + tl_set_var_value_num (T, M->data, K, -(y - x + K->type_flags)); + return 1; + } else { + if (x >= y) { + tl_set_var_value_num (T, K->data, M, -(x - y + M->type_flags)); + } else { + tl_set_var_value_num (T, M->data, K, -(y - x + K->type_flags)); + } + return 1; + } + } + return 0; +} + + +void tl_type_check (struct tl_type *t) { + if (!__ok) return; + if (!strcmp (t->id, "#")) { t->name = 0x70659eff; return; } + if (!strcmp (t->id, "Type")) { t->name = 0x2cecf817; return; } + if (t->constructors_num <= 0 && !(t->flags & FLAG_EMPTY)) { + TL_ERROR ("Type %s has no constructors\n", t->id); + __ok = 0; + return; + } + int i, j; + t->name = 0; + for (i = 0; i < t->constructors_num; i++) { + t->name ^= t->constructors[i]->name; + } + for (i = 0; i < t->constructors_num; i++) { + for (j = i + 1; j < t->constructors_num; j++) { + struct tree_var_value *v = 0; + if (check_constructors_equal (t->constructors[i]->right, t->constructors[j]->right, &v)) { + t->flags |= 16; + } + } + } + if ((t->flags & 24) == 24) { + TL_WARNING ("Warning: Type %s has overlapping costructors, but it is used with `%%`\n", t->id); + } + int z = 0; + int sid = 0; + for (i = 0; i < t->constructors_num; i++) if (*t->constructors[i]->id == '_') { + z ++; + sid = i; + } + if (z > 1) { + TL_ERROR ("Type %s has %d default constructors\n", t->id, z); + __ok = 0; + return; + } + if (z == 1 && (t->flags & 8)) { + TL_ERROR ("Type %s has default constructors and used bare\n", t->id); + __ok = 0; + return; + } + if (z) { + struct tl_constructor *c; + c = t->constructors[sid]; + t->constructors[sid] = t->constructors[t->constructors_num - 1]; + t->constructors[t->constructors_num - 1] = c; + } +} + +struct tl_program *tl_parse (struct tree *T) { + assert (T); + assert (T->type == type_tl_program); + int i; + tl_program_cur = talloc (sizeof (*tl_program_cur)); + tl_add_type ("#", 1, 0, 0); + tl_add_type ("Type", 4, 0, 0); + for (i = 0; i < T->nc; i++) { + if (T->c[i]->type == type_constr_declarations) { TL_TRY_PES (tl_parse_constr_declarations (T->c[i])); } + else { TL_TRY_PES (tl_parse_fun_declarations (T->c[i])) } + } + __ok = 1; + tree_act_tl_type (tl_type_tree, tl_type_check); + if (!__ok) { + return 0; + } + return tl_program_cur; +} + +int __f; +int num = 0; + +void wint (int a) { +// printf ("%d ", a); + a = htole32 (a); + assert (write (__f, &a, 4) == 4); +} + +void wdata (const void *x, int len) { + assert (write (__f, x, len) == len); +} + +void wstr (const char *s) { + if (s) { +// printf ("\"%s\" ", s); + int x = strlen (s); + if (x <= 254) { + unsigned char x_c = (unsigned char)x; + assert (write (__f, &x_c, 1) == 1); + } else { + fprintf (stderr, "String is too big...\n"); + assert (0); + } + wdata (s, x); + x ++; // The header, containing the length, which is 1 byte + int t = 0; + if (x & 3) { + // Let's hope it's truly zero on every platform + wdata (&t, 4 - (x & 3)); + } + } else { +// printf ("<none> "); + wint (0); + } +} + +void wll (long long a) { +// printf ("%lld ", a); + a = htole64 (a); + assert (write (__f, &a, 8) == 8); +} + +int count_list_size (struct tl_combinator_tree *T) { + assert (T->type == type_list || T->type == type_list_item); + if (T->type == type_list_item) { + return 1; + } else { + return count_list_size (T->left) + count_list_size (T->right); + } +} + +void write_type_flags (long long flags) { + int new_flags = 0; + if (flags & 1) { + new_flags |= FLAG_BARE; + } + if (flags & FLAG_DEFAULT_CONSTRUCTOR) { + new_flags |= FLAG_DEFAULT_CONSTRUCTOR; + } + wint (new_flags); +} + +void write_field_flags (long long flags) { + int new_flags = 0; + //fprintf (stderr, "%lld\n", flags); + if (flags & 1) { + new_flags |= FLAG_BARE; + } + if (flags & 32) { + new_flags |= FLAG_OPT_VAR; + } + if (flags & FLAG_EXCL) { + new_flags |= FLAG_EXCL; + } + if (flags & FLAG_OPT_FIELD) { + // new_flags |= FLAG_OPT_FIELD; + new_flags |= 2; + } + if (flags & (1 << 21)) { + new_flags |= 4; + } + wint (new_flags); +} + +void write_var_type_flags (long long flags) { + int new_flags = 0; + if (flags & 1) { + new_flags |= FLAG_BARE; + } + if (new_flags & FLAG_BARE) { + TL_ERROR ("Sorry, bare vars are not (yet ?) supported.\n"); + assert (!(new_flags & FLAG_BARE)); + } + wint (new_flags); +} + +void write_tree (struct tl_combinator_tree *T, int extra, struct tree_var_value **v, int *last_var); +void write_args (struct tl_combinator_tree *T, struct tree_var_value **v, int *last_var) { + assert (T->type == type_list || T->type == type_list_item); + if (T->type == type_list) { + assert (T->act == act_union); + assert (T->left); + assert (T->right); + write_args (T->left, v, last_var); + write_args (T->right, v, last_var); + return; + } + wint (TLS_ARG_V2); + assert (T->act == act_field); + assert (T->left); + wstr (T->data && strcmp (T->data, "_") ? T->data : 0); + long long f = T->flags; + if (T->left->act == act_opt_field) { + f |= (1 << 20); + } + 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"))) { + write_field_flags (f | (1 << 21)); + wint (*last_var); + *last_var = (*last_var) + 1; + tl_set_var_value_num (v, T, 0, (*last_var) - 1); + } else { + write_field_flags (f); + } + write_tree (T->left, 0, v, last_var); +} + +void write_array (struct tl_combinator_tree *T, struct tree_var_value **v, int *last_var) { + wint (TLS_ARRAY); + write_tree (T->left, 0, v, last_var); + write_tree (T->right, 0, v, last_var); +} + +void write_type_rec (struct tl_combinator_tree *T, int cc, struct tree_var_value **v, int *last_var) { + if (T->act == act_arg) { + write_type_rec (T->left, cc + 1, v, last_var); + if (T->right->type == type_num_value || T->right->type == type_num) { + wint (TLS_EXPR_NAT); + } else { + wint (TLS_EXPR_TYPE); + } + write_tree (T->right, 0, v, last_var); + } else { + assert (T->act == act_var || T->act == act_type); + if (T->act == act_var) { + assert (!cc); + wint (TLS_TYPE_VAR); + wint (tl_get_var_value_num (v, T->data)); + write_var_type_flags (T->flags); + //wint (T->flags); + } else { + wint (TLS_TYPE_EXPR); + struct tl_type *t = T->data; + wint (t->name); + write_type_flags (T->flags); +// wint (T->flags); + wint (cc); +// fprintf (stderr, "cc = %d\n", cc); + } + } +} + +void write_opt_type (struct tl_combinator_tree *T, struct tree_var_value **v, int *last_var) { + wint (tl_get_var_value_num (v, T->left->data)); + wint (T->left->type_flags); +// write_tree (T->right, 0, v, last_var); + assert (T); + T = T->right; + switch (T->type) { + case type_type: + if (T->act == act_array) { + write_array (T, v, last_var); + } else if (T->act == act_type || T->act == act_var || T->act == act_arg) { + write_type_rec (T, 0, v, last_var); + } else { + assert (0); + } + break; + default: + assert (0); + } +} + +void write_tree (struct tl_combinator_tree *T, int extra, struct tree_var_value **v, int *last_var) { + assert (T); + switch (T->type) { + case type_list_item: + case type_list: + if (extra) { + wint (TLS_COMBINATOR_RIGHT_V2); + } + wint (count_list_size (T)); + write_args (T, v, last_var); + break; + case type_num_value: + wint ((int)TLS_NAT_CONST); + wint (T->type_flags); + break; + case type_num: + wint ((int)TLS_NAT_VAR); + wint (T->type_flags); + wint (tl_get_var_value_num (v, T->data)); + break; + case type_type: + if (T->act == act_array) { + write_array (T, v, last_var); + } else if (T->act == act_type || T->act == act_var || T->act == act_arg) { + write_type_rec (T, 0, v, last_var); + } else { + assert (T->act == act_opt_field); + write_opt_type (T, v, last_var); + } + break; + default: + assert (0); + } +} + +void write_type (struct tl_type *t) { + wint (TLS_TYPE); + wint (t->name); + wstr (t->id); + wint (t->constructors_num); + wint (t->flags); + wint (t->params_num); + wll (t->params_types); +} + +int is_builtin_type (const char *id) { + return !strcmp (id, "int") || !strcmp (id, "long") || !strcmp (id, "double") || !strcmp (id, "string"); +} + +void write_combinator (struct tl_constructor *c) { + wint (c->name); + wstr (c->id); + wint (c->type ? c->type->name : 0); + struct tree_var_value *T = 0; + int x = 0; + assert (c->right); + if (c->left) { + if (is_builtin_type (c->id)) { + wint (TLS_COMBINATOR_LEFT_BUILTIN); + } else { + wint (TLS_COMBINATOR_LEFT); + // FIXME: What is that? +// wint (count_list_size (c->left)); + write_tree (c->left, 0, &T, &x); + } + } else { + wint (TLS_COMBINATOR_LEFT); + wint (0); + } + wint (TLS_COMBINATOR_RIGHT_V2); + write_tree (c->right, 1, &T, &x); +} + +void write_constructor (struct tl_constructor *c) { + wint (TLS_COMBINATOR); + write_combinator (c); +} + +void write_function (struct tl_constructor *c) { + wint (TLS_COMBINATOR); + write_combinator (c); +} + +void write_type_constructors (struct tl_type *t) { + int i; + for (i = 0; i < t->constructors_num; i++) { + write_constructor (t->constructors[i]); + } +} + +void write_types (int f) { + __f = f; + wint (TLS_SCHEMA_V2); + wint (0); +#ifdef TL_PARSER_NEED_TIME + wint (time (0)); +#else + /* Make the tlo reproducible by default. Rationale: https://wiki.debian.org/ReproducibleBuilds/Howto#Introduction */ + wint (0); +#endif + num = 0; + wint (total_types_num); + tree_act_tl_type (tl_type_tree, write_type); + wint (total_constructors_num); + tree_act_tl_type (tl_type_tree, write_type_constructors); + wint (total_functions_num); + tree_act_tl_constructor (tl_function_tree, write_function); +} |