tg/tl-parser.c

/*
    This file is part of tgl-libary/tlc

    Tgl-library/tlc 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.

    Tgl-library/tlc 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 tgl-library/tlc.  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 <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"
#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;
}*/

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;
      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 ());
  }
  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 >= 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 = 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);
}