3065 lines
78 KiB
C
3065 lines
78 KiB
C
/*
|
|
This file is part of VK/KittenPHP-DB-Engine.
|
|
|
|
VK/KittenPHP-DB-Engine 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.
|
|
|
|
VK/KittenPHP-DB-Engine 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 VK/KittenPHP-DB-Engine. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
This program is released under the GPL with the additional exemption
|
|
that compiling, linking, and/or using OpenSSL is allowed.
|
|
You are free to remove this exemption from derived works.
|
|
|
|
Copyright 2012-2013 Vkontakte Ltd
|
|
2012-2013 Vitaliy Valtman
|
|
*/
|
|
|
|
#define _FILE_OFFSET_BITS 64
|
|
#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 "tree.h"
|
|
#include "tl-parser.h"
|
|
#include "crc32.h"
|
|
#include "tl-tl.h"
|
|
#include "tools.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;
|
|
}*/
|
|
|
|
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;
|
|
}
|
|
|
|
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;
|
|
for (i = 0; i < 8; i++) {
|
|
if (!is_hexdigit (nextch())) {
|
|
parse_error ("Hex digit expected");
|
|
parse.lex.type = lex_error;
|
|
return (parse.lex.ptr = (void *)-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;
|
|
}
|
|
}
|
|
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 == 9);
|
|
int i;
|
|
for (i = 1; i <= 8; i++) {
|
|
magic = (magic << 4) + (_id[x + i] <= '9' ? _id[x + i] - '0' : _id[x + i] - 'a' + 10);
|
|
}
|
|
assert (magic && magic != (unsigned)-1);
|
|
}
|
|
|
|
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 ());
|
|
}
|
|
total_constructors_num ++;
|
|
a->flags |= FLAG_DEFAULT_CONSTRUCTOR;
|
|
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 == 9);
|
|
int i;
|
|
for (i = 1; i <= 8; i++) {
|
|
magic = (magic << 4) + (_id[x + i] <= '9' ? _id[x + i] - '0' : _id[x + i] - 'a' + 10);
|
|
}
|
|
assert (magic && magic != (unsigned)-1);
|
|
}
|
|
|
|
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 = compute_crc32 (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 = compute_crc32 (buf, 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 preceed 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 preceed 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) {
|
|
//assert (S->data);
|
|
char *name = S->data;
|
|
if (!name) {
|
|
static char s[20];
|
|
sprintf (s, "%lld", lrand48 () * (1ll << 32) + lrand48 ());
|
|
name = s;
|
|
}
|
|
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);
|
|
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);
|
|
if (schema_version < 1) {
|
|
wint (strlen (s));
|
|
wdata (s, strlen (s));
|
|
} else {
|
|
int x = strlen (s);
|
|
if (x <= 254) {
|
|
assert (write (__f, &x, 1) == 1);
|
|
} else {
|
|
fprintf (stderr, "String is too big...\n");
|
|
assert (0);
|
|
}
|
|
wdata (s, x);
|
|
x ++;
|
|
int t = 0;
|
|
if (x & 3) {
|
|
wdata (&t, 4 - (x & 3));
|
|
}
|
|
}
|
|
} else {
|
|
// printf ("<none> ");
|
|
wint (0);
|
|
}
|
|
}
|
|
|
|
void wll (long long a) {
|
|
// printf ("%lld ", 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;
|
|
}
|
|
if (schema_version == 1) {
|
|
wint (TLS_ARG);
|
|
} if (schema_version == 2) {
|
|
wint (TLS_ARG_V2);
|
|
} else {
|
|
wint (-3);
|
|
}
|
|
if (T->act == act_question_mark) {
|
|
if (schema_version >= 1) {
|
|
assert (0);
|
|
} else {
|
|
wint (-100);
|
|
}
|
|
return;
|
|
}
|
|
if (schema_version >= 1) {
|
|
} else {
|
|
wint (-99);
|
|
}
|
|
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);
|
|
if (schema_version <= 1) {
|
|
wint (-1);
|
|
}
|
|
}
|
|
write_tree (T->left, 0, v, last_var);
|
|
}
|
|
|
|
void write_array (struct tl_combinator_tree *T, struct tree_var_value **v, int *last_var) {
|
|
if (schema_version == 1) {
|
|
wint (TLS_TREE_ARRAY);
|
|
} else if (schema_version == 2) {
|
|
wint (TLS_ARRAY);
|
|
} else {
|
|
wint (-8);
|
|
}
|
|
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 (schema_version >= 2) {
|
|
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);
|
|
if (schema_version == 1) {
|
|
wint (TLS_TREE_TYPE_VAR);
|
|
} else if (schema_version == 2) {
|
|
wint (TLS_TYPE_VAR);
|
|
} else {
|
|
wint (-6);
|
|
}
|
|
wint (tl_get_var_value_num (v, T->data));
|
|
write_var_type_flags (T->flags);
|
|
//wint (T->flags);
|
|
} else {
|
|
if (schema_version == 1) {
|
|
wint (TLS_TREE_TYPE);
|
|
} else if (schema_version == 2) {
|
|
wint (TLS_TYPE_EXPR);
|
|
} else {
|
|
wint (-7);
|
|
}
|
|
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) {
|
|
if (schema_version >= 1) {
|
|
} else {
|
|
wint (-20);
|
|
}
|
|
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 (schema_version >= 1) {
|
|
if (extra) {
|
|
wint (schema_version >= 2 ? TLS_COMBINATOR_RIGHT_V2 : TLS_COMBINATOR_RIGHT);
|
|
}
|
|
} else {
|
|
wint (extra ? -1 : -2);
|
|
}
|
|
wint (count_list_size (T));
|
|
write_args (T, v, last_var);
|
|
break;
|
|
case type_num_value:
|
|
wint (schema_version >= 1 ? schema_version >= 2 ? (int)TLS_NAT_CONST : (int)TLS_TREE_NAT_CONST : -4);
|
|
if (schema_version >= 2) {
|
|
wint (T->type_flags);
|
|
} else {
|
|
wll (T->type_flags);
|
|
}
|
|
break;
|
|
case type_num:
|
|
wint (schema_version >= 1 ? schema_version >= 2 ? (int)TLS_NAT_VAR : (int)TLS_TREE_NAT_VAR : -5);
|
|
if (schema_version >= 2) {
|
|
wint (T->type_flags);
|
|
} else {
|
|
wll (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 (schema_version >= 1 ? TLS_TYPE : 1);
|
|
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 (schema_version >= 1 && is_builtin_type (c->id)) {
|
|
wint (TLS_COMBINATOR_LEFT_BUILTIN);
|
|
} else {
|
|
if (schema_version >= 1) {
|
|
wint (TLS_COMBINATOR_LEFT);
|
|
}
|
|
// wint (count_list_size (c->left));
|
|
write_tree (c->left, 0, &T, &x);
|
|
}
|
|
} else {
|
|
if (schema_version >= 1) {
|
|
wint (TLS_COMBINATOR_LEFT);
|
|
wint (0);
|
|
} else {
|
|
wint (-11);
|
|
}
|
|
}
|
|
if (schema_version >= 1) {
|
|
wint (schema_version >= 2 ? TLS_COMBINATOR_RIGHT_V2 : TLS_COMBINATOR_RIGHT);
|
|
}
|
|
write_tree (c->right, 1, &T, &x);
|
|
}
|
|
|
|
void write_constructor (struct tl_constructor *c) {
|
|
wint (schema_version >= 1 ? TLS_COMBINATOR : 2);
|
|
write_combinator (c);
|
|
}
|
|
|
|
void write_function (struct tl_constructor *c) {
|
|
wint (schema_version >= 1 ? TLS_COMBINATOR : 3);
|
|
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]);
|
|
}
|
|
}
|
|
|
|
int MAGIC = 0x850230aa;
|
|
void write_types (int f) {
|
|
__f = f;
|
|
if (schema_version == 1) {
|
|
wint (TLS_SCHEMA);
|
|
} else if (schema_version == 2) {
|
|
wint (TLS_SCHEMA_V2);
|
|
} else {
|
|
wint (MAGIC);
|
|
}
|
|
if (schema_version >= 1) {
|
|
wint (0);
|
|
wint (time (0));
|
|
}
|
|
num = 0;
|
|
if (schema_version >= 1) {
|
|
wint (total_types_num);
|
|
}
|
|
tree_act_tl_type (tl_type_tree, write_type);
|
|
if (schema_version >= 1) {
|
|
wint (total_constructors_num);
|
|
}
|
|
tree_act_tl_type (tl_type_tree, write_type_constructors);
|
|
if (schema_version >= 1) {
|
|
wint (total_functions_num);
|
|
}
|
|
tree_act_tl_constructor (tl_function_tree, write_function);
|
|
}
|