├── README.md ├── .gitignore ├── configure.ac ├── Makefile.in ├── tl-tl.h ├── config.h.in ├── portable_endian.h ├── tlc.c ├── tl-parser.h ├── m4-ax_gcc_builtin.m4 ├── tl-parser-tree.h ├── LICENSE └── tl-parser.c /README.md: -------------------------------------------------------------------------------- 1 | Parse tl scheme to tlo file. Formely part of telegram-cli 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | Makefile 2 | config.h 3 | dep 4 | objs 5 | bin 6 | autom4te.cache 7 | config.log 8 | config.status 9 | -------------------------------------------------------------------------------- /configure.ac: -------------------------------------------------------------------------------- 1 | # -*- Autoconf -*- 2 | # Process this file with autoconf to produce a configure script. 3 | 4 | AC_PREREQ([2.69]) 5 | AC_INIT([tl-parser], [1.0]) 6 | 7 | m4_include([m4-ax_gcc_builtin.m4]) 8 | 9 | AC_CONFIG_HEADERS([config.h]) 10 | 11 | # Checks for programs. 12 | AC_PROG_CC 13 | 14 | # Checks for libraries. 15 | # We only need the symbol 'crc32'. Stay on the safe side by checking a more specific symbol. 16 | AC_CHECK_LIB([z], [crc32_combine]) 17 | 18 | # Checks for header files. 19 | AC_CHECK_HEADERS([fcntl.h mach/mach.h stdlib.h string.h sys/time.h unistd.h]) 20 | 21 | # Checks for typedefs, structures, and compiler characteristics. 22 | AC_C_INLINE 23 | AC_TYPE_SIZE_T 24 | 25 | # Checks for library functions. 26 | AC_FUNC_MALLOC 27 | AC_FUNC_REALLOC 28 | AC_CHECK_FUNCS([clock_gettime memset strdup]) 29 | 30 | AX_GCC_BUILTIN(__builtin_bswap32) 31 | 32 | AC_CONFIG_FILES([Makefile]) 33 | AC_OUTPUT 34 | -------------------------------------------------------------------------------- /Makefile.in: -------------------------------------------------------------------------------- 1 | srcdir=@srcdir@ 2 | 3 | CFLAGS=@CFLAGS@ 4 | LDFLAGS=@LDFLAGS@ 5 | CPPFLAGS=@CPPFLAGS@ 6 | COMPILE_FLAGS=${CFLAGS} ${CPFLAGS} ${CPPFLAGS} ${DEFS} -Wall -Wextra -Werror -Wno-deprecated-declarations -fno-strict-aliasing -fno-omit-frame-pointer -ggdb -Wno-unused-parameter -fPIC 7 | 8 | EXTRA_LIBS=@LIBS@ 9 | LOCAL_LDFLAGS=-rdynamic -ggdb ${EXTRA_LIBS} 10 | LINK_FLAGS=${LDFLAGS} ${LOCAL_LDFLAGS} 11 | 12 | DEP=dep 13 | EXE=bin 14 | OBJ=objs 15 | DIR_LIST=${DEP} ${EXE} ${OBJ} 16 | 17 | EXE_LIST=${EXE}/tl-parser 18 | 19 | OBJECTS=${OBJ}/tl-parser.o ${OBJ}/tlc.o 20 | 21 | DEPENDENCE=$(subst ${OBJ}/,${DEP}/,$(patsubst %.o,%.d,${OBJECTS})) 22 | DEPENDENCE_LIST=${DEPENDENCE} 23 | 24 | INCLUDE=-I. -I${srcdir} 25 | CC=@CC@ 26 | 27 | .SUFFIXES: 28 | 29 | .SUFFIXES: .c .h .o 30 | 31 | all: ${EXE_LIST} ${DIR_LIST} ${LIB_LIST} 32 | create_dirs_and_headers: ${DIR_LIST} 33 | create_dirs: ${DIR_LIST} 34 | 35 | ${DIR_LIST}: 36 | @test -d $@ || mkdir -p $@ 37 | 38 | -include ${DEPENDENCE_LIST} 39 | 40 | ${OBJECTS}: ${OBJ}/%.o: ${srcdir}/%.c | create_dirs_and_headers 41 | ${CC} ${INCLUDE} ${COMPILE_FLAGS} -c -MP -MD -MF ${DEP}/$*.d -MQ ${OBJ}/$*.o -o $@ $< 42 | 43 | ${EXE}/tl-parser: ${OBJECTS} 44 | ${CC} $^ ${LINK_FLAGS} -o $@ 45 | 46 | clean: 47 | rm -rf ${DIR_LIST} config.log config.status > /dev/null || echo "all clean" 48 | 49 | -------------------------------------------------------------------------------- /tl-tl.h: -------------------------------------------------------------------------------- 1 | /* 2 | This file is part of VK/KittenPHP-DB-Engine. 3 | 4 | VK/KittenPHP-DB-Engine is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU General Public License as published by 6 | the Free Software Foundation, either version 2 of the License, or 7 | (at your option) any later version. 8 | 9 | VK/KittenPHP-DB-Engine is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with VK/KittenPHP-DB-Engine. If not, see . 16 | 17 | This program is released under the GPL with the additional exemption 18 | that compiling, linking, and/or using OpenSSL is allowed. 19 | You are free to remove this exemption from derived works. 20 | 21 | Copyright 2012-2013 Vkontakte Ltd 22 | 2012-2013 Vitaliy Valtman 23 | */ 24 | 25 | #ifndef __TL_TL_H__ 26 | #define __TL_TL_H__ 27 | 28 | // Current tl-tl schema is V2 29 | // See https://core.telegram.org/mtproto/TL-tl 30 | 31 | #define TLS_SCHEMA_V2 0x3a2f9be2 32 | #define TLS_TYPE 0x12eb4386 33 | #define TLS_COMBINATOR 0x5c0a1ed5 34 | #define TLS_COMBINATOR_LEFT_BUILTIN 0xcd211f63 35 | #define TLS_COMBINATOR_LEFT 0x4c12c6d9 36 | #define TLS_COMBINATOR_RIGHT_V2 0x2c064372 37 | #define TLS_ARG_V2 0x29dfe61b 38 | 39 | #define TLS_EXPR_TYPE 0xecc9da78 40 | #define TLS_EXPR_NAT 0xdcb49bd8 41 | 42 | #define TLS_NAT_CONST 0xdcb49bd8 43 | #define TLS_NAT_VAR 0x4e8a14f0 44 | #define TLS_TYPE_VAR 0x0142ceae 45 | #define TLS_ARRAY 0xd9fb20de 46 | #define TLS_TYPE_EXPR 0xc1863d08 47 | 48 | /* Deprecated (old versions), read-only */ 49 | #define TLS_TREE_NAT_CONST 0xc09f07d7 50 | #define TLS_TREE_NAT_VAR 0x90ea6f58 51 | #define TLS_TREE_TYPE_VAR 0x1caa237a 52 | #define TLS_TREE_ARRAY 0x80479360 53 | #define TLS_TREE_TYPE 0x10f32190 54 | 55 | #endif 56 | -------------------------------------------------------------------------------- /config.h.in: -------------------------------------------------------------------------------- 1 | /* config.h.in. Generated from configure.ac by autoheader. */ 2 | 3 | /* Define to 1 if you have the `clock_gettime' function. */ 4 | #undef HAVE_CLOCK_GETTIME 5 | 6 | /* Define to 1 if you have the header file. */ 7 | #undef HAVE_FCNTL_H 8 | 9 | /* Define to 1 if you have the header file. */ 10 | #undef HAVE_INTTYPES_H 11 | 12 | /* Define to 1 if you have the `z' library (-lz). */ 13 | #undef HAVE_LIBZ 14 | 15 | /* Define to 1 if you have the header file. */ 16 | #undef HAVE_MACH_MACH_H 17 | 18 | /* Define to 1 if your system has a GNU libc compatible `malloc' function, and 19 | to 0 otherwise. */ 20 | #undef HAVE_MALLOC 21 | 22 | /* Define to 1 if you have the header file. */ 23 | #undef HAVE_MEMORY_H 24 | 25 | /* Define to 1 if you have the `memset' function. */ 26 | #undef HAVE_MEMSET 27 | 28 | /* Define to 1 if your system has a GNU libc compatible `realloc' function, 29 | and to 0 otherwise. */ 30 | #undef HAVE_REALLOC 31 | 32 | /* Define to 1 if you have the header file. */ 33 | #undef HAVE_STDINT_H 34 | 35 | /* Define to 1 if you have the header file. */ 36 | #undef HAVE_STDLIB_H 37 | 38 | /* Define to 1 if you have the `strdup' function. */ 39 | #undef HAVE_STRDUP 40 | 41 | /* Define to 1 if you have the header file. */ 42 | #undef HAVE_STRINGS_H 43 | 44 | /* Define to 1 if you have the header file. */ 45 | #undef HAVE_STRING_H 46 | 47 | /* Define to 1 if you have the header file. */ 48 | #undef HAVE_SYS_STAT_H 49 | 50 | /* Define to 1 if you have the header file. */ 51 | #undef HAVE_SYS_TIME_H 52 | 53 | /* Define to 1 if you have the header file. */ 54 | #undef HAVE_SYS_TYPES_H 55 | 56 | /* Define to 1 if you have the header file. */ 57 | #undef HAVE_UNISTD_H 58 | 59 | /* Define to 1 if the system has the `__builtin_bswap32' built-in function */ 60 | #undef HAVE___BUILTIN_BSWAP32 61 | 62 | /* Define to the address where bug reports for this package should be sent. */ 63 | #undef PACKAGE_BUGREPORT 64 | 65 | /* Define to the full name of this package. */ 66 | #undef PACKAGE_NAME 67 | 68 | /* Define to the full name and version of this package. */ 69 | #undef PACKAGE_STRING 70 | 71 | /* Define to the one symbol short name of this package. */ 72 | #undef PACKAGE_TARNAME 73 | 74 | /* Define to the home page for this package. */ 75 | #undef PACKAGE_URL 76 | 77 | /* Define to the version of this package. */ 78 | #undef PACKAGE_VERSION 79 | 80 | /* Define to 1 if you have the ANSI C header files. */ 81 | #undef STDC_HEADERS 82 | 83 | /* Define to `__inline__' or `__inline' if that's what the C compiler 84 | calls it, or to nothing if 'inline' is not supported under any name. */ 85 | #ifndef __cplusplus 86 | #undef inline 87 | #endif 88 | 89 | /* Define to rpl_malloc if the replacement function should be used. */ 90 | #undef malloc 91 | 92 | /* Define to rpl_realloc if the replacement function should be used. */ 93 | #undef realloc 94 | 95 | /* Define to `unsigned int' if does not define. */ 96 | #undef size_t 97 | -------------------------------------------------------------------------------- /portable_endian.h: -------------------------------------------------------------------------------- 1 | // "License": Public Domain 2 | // I, Mathias Panzenböck, place this file hereby into the public domain. Use it at your own risk for whatever you like. 3 | // In case there are jurisdictions that don't support putting things in the public domain you can also consider it to 4 | // be "dual licensed" under the BSD, MIT and Apache licenses, if you want to. This code is trivial anyway. Consider it 5 | // an example on how to get the endian conversion functions on different platforms. 6 | 7 | /* Originally cloned from https://gist.github.com/PkmX/63dd23f28ba885be53a5 8 | * Commit was: 1eca2ab34f2301b9641aa73d1016b951fff3fc39 9 | * Re-published at https://github.com/BenWiederhake/portable-endian.h to provide a means to submit patches and report issues. */ 10 | 11 | #ifndef PORTABLE_ENDIAN_H__ 12 | #define PORTABLE_ENDIAN_H__ 13 | 14 | #if (defined(_WIN16) || defined(_WIN32) || defined(_WIN64)) && !defined(__WINDOWS__) 15 | 16 | # define __WINDOWS__ 17 | 18 | #endif 19 | 20 | #if defined(__linux__) || defined(__CYGWIN__) 21 | 22 | # include 23 | 24 | #elif defined(__APPLE__) 25 | 26 | # include 27 | 28 | # define htobe16(x) OSSwapHostToBigInt16(x) 29 | # define htole16(x) OSSwapHostToLittleInt16(x) 30 | # define be16toh(x) OSSwapBigToHostInt16(x) 31 | # define le16toh(x) OSSwapLittleToHostInt16(x) 32 | 33 | # define htobe32(x) OSSwapHostToBigInt32(x) 34 | # define htole32(x) OSSwapHostToLittleInt32(x) 35 | # define be32toh(x) OSSwapBigToHostInt32(x) 36 | # define le32toh(x) OSSwapLittleToHostInt32(x) 37 | 38 | # define htobe64(x) OSSwapHostToBigInt64(x) 39 | # define htole64(x) OSSwapHostToLittleInt64(x) 40 | # define be64toh(x) OSSwapBigToHostInt64(x) 41 | # define le64toh(x) OSSwapLittleToHostInt64(x) 42 | 43 | # define __BYTE_ORDER BYTE_ORDER 44 | # define __BIG_ENDIAN BIG_ENDIAN 45 | # define __LITTLE_ENDIAN LITTLE_ENDIAN 46 | # define __PDP_ENDIAN PDP_ENDIAN 47 | 48 | #elif defined(__OpenBSD__) 49 | 50 | # include 51 | 52 | #elif defined(__NetBSD__) || defined(__FreeBSD__) || defined(__DragonFly__) 53 | 54 | # include 55 | 56 | # define be16toh(x) betoh16(x) 57 | # define le16toh(x) letoh16(x) 58 | 59 | # define be32toh(x) betoh32(x) 60 | # define le32toh(x) letoh32(x) 61 | 62 | # define be64toh(x) betoh64(x) 63 | # define le64toh(x) letoh64(x) 64 | 65 | #elif defined(__WINDOWS__) 66 | 67 | # include 68 | # include 69 | 70 | # if BYTE_ORDER == LITTLE_ENDIAN 71 | 72 | # define htobe16(x) htons(x) 73 | # define htole16(x) (x) 74 | # define be16toh(x) ntohs(x) 75 | # define le16toh(x) (x) 76 | 77 | # define htobe32(x) htonl(x) 78 | # define htole32(x) (x) 79 | # define be32toh(x) ntohl(x) 80 | # define le32toh(x) (x) 81 | 82 | # define htobe64(x) htonll(x) 83 | # define htole64(x) (x) 84 | # define be64toh(x) ntohll(x) 85 | # define le64toh(x) (x) 86 | 87 | # elif BYTE_ORDER == BIG_ENDIAN 88 | 89 | /* that would be xbox 360 */ 90 | # define htobe16(x) (x) 91 | # define htole16(x) __builtin_bswap16(x) 92 | # define be16toh(x) (x) 93 | # define le16toh(x) __builtin_bswap16(x) 94 | 95 | # define htobe32(x) (x) 96 | # define htole32(x) __builtin_bswap32(x) 97 | # define be32toh(x) (x) 98 | # define le32toh(x) __builtin_bswap32(x) 99 | 100 | # define htobe64(x) (x) 101 | # define htole64(x) __builtin_bswap64(x) 102 | # define be64toh(x) (x) 103 | # define le64toh(x) __builtin_bswap64(x) 104 | 105 | # else 106 | 107 | # error byte order not supported 108 | 109 | # endif 110 | 111 | # define __BYTE_ORDER BYTE_ORDER 112 | # define __BIG_ENDIAN BIG_ENDIAN 113 | # define __LITTLE_ENDIAN LITTLE_ENDIAN 114 | # define __PDP_ENDIAN PDP_ENDIAN 115 | 116 | #else 117 | 118 | # error platform not supported 119 | 120 | #endif 121 | 122 | #endif 123 | -------------------------------------------------------------------------------- /tlc.c: -------------------------------------------------------------------------------- 1 | /* 2 | This file is part of tl-parser 3 | 4 | tl-parser is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU General Public License as published by 6 | the Free Software Foundation, either version 2 of the License, or 7 | (at your option) any later version. 8 | 9 | tl-parser is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with this tl-parser. If not, see . 16 | 17 | Copyright Vitaly Valtman 2014 18 | 19 | It is derivative work of VK/KittenPHP-DB-Engine (https://github.com/vk-com/kphp-kdb/) 20 | Copyright 2012-2013 Vkontakte Ltd 21 | 2012-2013 Vitaliy Valtman 22 | 23 | */ 24 | 25 | #include "config.h" 26 | 27 | #include 28 | #include 29 | #include 30 | 31 | #include "tl-parser.h" 32 | 33 | #include 34 | #include 35 | #include 36 | #include 37 | 38 | #include 39 | #include "config.h" 40 | 41 | #ifdef HAVE_EXECINFO_H 42 | #include 43 | #endif 44 | #include 45 | 46 | int verbosity; 47 | int output_expressions; 48 | void usage (void) { 49 | printf ("usage: tl-parser [-v] [-h] \n" 50 | "\tTL compiler\n" 51 | "\t-v\toutput statistical and debug information into stderr\n" 52 | "\t-E\twhenever is possible output to stdout expressions\n" 53 | "\t-e \texport serialized schema to file\n" 54 | ); 55 | exit (2); 56 | } 57 | 58 | int vkext_write (const char *filename) { 59 | int f = open (filename, O_CREAT | O_WRONLY | O_TRUNC, 0640); 60 | assert (f >= 0); 61 | write_types (f); 62 | close (f); 63 | return 0; 64 | } 65 | 66 | void logprintf (const char *format, ...) __attribute__ ((format (printf, 1, 2))); 67 | void logprintf (const char *format __attribute__ ((unused)), ...) { 68 | va_list ap; 69 | va_start (ap, format); 70 | vfprintf (stderr, format, ap); 71 | va_end (ap); 72 | } 73 | 74 | void hexdump (int *in_ptr, int *in_end) { 75 | int *ptr = in_ptr; 76 | while (ptr < in_end) { printf (" %08x", *(ptr ++)); } 77 | printf ("\n"); 78 | } 79 | 80 | #ifdef HAVE_EXECINFO_H 81 | void print_backtrace (void) { 82 | void *buffer[255]; 83 | const int calls = backtrace (buffer, sizeof (buffer) / sizeof (void *)); 84 | backtrace_symbols_fd (buffer, calls, 1); 85 | } 86 | #else 87 | void print_backtrace (void) { 88 | if (write (1, "No libexec. Backtrace disabled\n", 32) < 0) { 89 | // Sad thing 90 | } 91 | } 92 | #endif 93 | 94 | void sig_segv_handler (int signum __attribute__ ((unused))) { 95 | if (write (1, "SIGSEGV received\n", 18) < 0) { 96 | // Sad thing 97 | } 98 | print_backtrace (); 99 | exit (EXIT_FAILURE); 100 | } 101 | 102 | void sig_abrt_handler (int signum __attribute__ ((unused))) { 103 | if (write (1, "SIGABRT received\n", 18) < 0) { 104 | // Sad thing 105 | } 106 | print_backtrace (); 107 | exit (EXIT_FAILURE); 108 | } 109 | 110 | int main (int argc, char **argv) { 111 | signal (SIGSEGV, sig_segv_handler); 112 | signal (SIGABRT, sig_abrt_handler); 113 | int i; 114 | char *vkext_file = 0; 115 | while ((i = getopt (argc, argv, "Ehve:w:")) != -1) { 116 | switch (i) { 117 | case 'E': 118 | output_expressions++; 119 | break; 120 | case 'h': 121 | usage (); 122 | return 2; 123 | case 'e': 124 | vkext_file = optarg; 125 | break; 126 | case 'v': 127 | verbosity++; 128 | break; 129 | } 130 | } 131 | 132 | if (argc != optind + 1) { 133 | usage (); 134 | } 135 | 136 | 137 | struct parse *P = tl_init_parse_file (argv[optind]); 138 | if (!P) { 139 | return 0; 140 | } 141 | struct tree *T; 142 | if (!(T = tl_parse_lex (P))) { 143 | fprintf (stderr, "Error in parse:\n"); 144 | tl_print_parse_error (); 145 | return 0; 146 | } else { 147 | if (verbosity) { 148 | fprintf (stderr, "Parse ok\n"); 149 | } 150 | if (!tl_parse (T)) { 151 | if (verbosity) { 152 | fprintf (stderr, "Fail\n"); 153 | } 154 | return 1; 155 | } else { 156 | if (verbosity) { 157 | fprintf (stderr, "Ok\n"); 158 | } 159 | } 160 | } 161 | if (vkext_file) { 162 | vkext_write (vkext_file); 163 | } 164 | return 0; 165 | } 166 | -------------------------------------------------------------------------------- /tl-parser.h: -------------------------------------------------------------------------------- 1 | /* 2 | This file is part of tgl-libary/tlc 3 | 4 | Tgl-library/tlc is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU General Public License as published by 6 | the Free Software Foundation, either version 2 of the License, or 7 | (at your option) any later version. 8 | 9 | Tgl-library/tlc is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with this tgl-library/tlc. If not, see . 16 | 17 | Copyright Vitaly Valtman 2014 18 | 19 | It is derivative work of VK/KittenPHP-DB-Engine (https://github.com/vk-com/kphp-kdb/) 20 | Copyright 2012-2013 Vkontakte Ltd 21 | 2012-2013 Vitaliy Valtman 22 | 23 | */ 24 | 25 | #ifndef __TL_PARSER_NEW_H__ 26 | #define __TL_PARSER_NEW_H__ 27 | enum lex_type { 28 | lex_error, 29 | lex_char, 30 | lex_triple_minus, 31 | lex_uc_ident, 32 | lex_lc_ident, 33 | lex_eof, 34 | lex_final, 35 | lex_new, 36 | lex_none, 37 | lex_num, 38 | lex_empty 39 | }; 40 | 41 | 42 | struct curlex { 43 | char *ptr; 44 | int len; 45 | enum lex_type type; 46 | int flags; 47 | }; 48 | 49 | struct parse { 50 | char *text; 51 | int pos; 52 | int len; 53 | int line; 54 | int line_pos; 55 | struct curlex lex; 56 | }; 57 | 58 | 59 | enum tree_type { 60 | type_tl_program, 61 | type_fun_declarations, 62 | type_constr_declarations, 63 | type_declaration, 64 | type_combinator_decl, 65 | type_equals, 66 | type_partial_app_decl, 67 | type_final_decl, 68 | type_full_combinator_id, 69 | type_opt_args, 70 | type_args, 71 | type_args1, 72 | type_args2, 73 | type_args3, 74 | type_args4, 75 | type_boxed_type_ident, 76 | type_subexpr, 77 | type_partial_comb_app_decl, 78 | type_partial_type_app_decl, 79 | type_final_new, 80 | type_final_final, 81 | type_final_empty, 82 | // type_type, 83 | type_var_ident, 84 | type_var_ident_opt, 85 | type_multiplicity, 86 | type_type_term, 87 | type_term, 88 | type_percent, 89 | type_result_type, 90 | type_expr, 91 | type_nat_term, 92 | type_combinator_id, 93 | type_nat_const, 94 | type_type_ident, 95 | type_builtin_combinator_decl, 96 | type_exclam, 97 | type_optional_arg_def 98 | }; 99 | 100 | struct tree { 101 | char *text; 102 | int len; 103 | enum tree_type type; 104 | int lex_line; 105 | int lex_line_pos; 106 | int flags; 107 | int size; 108 | int nc; 109 | struct tree **c; 110 | }; 111 | 112 | 113 | #define TL_ACT(x) (x == act_var ? "act_var" : x == act_field ? "act_field" : x == act_plus ? "act_plus" : x == act_type ? "act_type" : x == act_nat_const ? "act_nat_const" : x == act_array ? "act_array" : x == act_question_mark ? "act_question_mark" : \ 114 | x == act_union ? "act_union" : x == act_arg ? "act_arg" : x == act_opt_field ? "act_opt_field" : "act_unknown") 115 | 116 | #define TL_TYPE(x) (x == type_num ? "type_num" : x == type_type ? "type_type" : x == type_list_item ? "type_list_item" : x == type_list ? "type_list" : x == type_num_value ? "type_num_value" : "type_unknown") 117 | enum combinator_tree_action { 118 | act_var, 119 | act_field, 120 | act_plus, 121 | act_type, 122 | act_nat_const, 123 | act_array, 124 | act_question_mark, 125 | act_union, 126 | act_arg, 127 | act_opt_field 128 | }; 129 | 130 | enum combinator_tree_type { 131 | type_num, 132 | type_num_value, 133 | type_type, 134 | type_list_item, 135 | type_list 136 | }; 137 | 138 | struct tl_combinator_tree { 139 | enum combinator_tree_action act; 140 | struct tl_combinator_tree *left, *right; 141 | char *name; 142 | void *data; 143 | long long flags; 144 | enum combinator_tree_type type; 145 | int type_len; 146 | long long type_flags; 147 | }; 148 | 149 | 150 | struct tl_program { 151 | int types_num; 152 | int functions_num; 153 | int constructors_num; 154 | struct tl_type **types; 155 | struct tl_function **functions; 156 | // struct tl_constuctor **constructors; 157 | }; 158 | 159 | struct tl_type { 160 | char *id; 161 | char *print_id; 162 | char *real_id; 163 | unsigned name; 164 | int flags; 165 | 166 | int params_num; 167 | long long params_types; 168 | 169 | int constructors_num; 170 | struct tl_constructor **constructors; 171 | }; 172 | 173 | struct tl_constructor { 174 | char *id; 175 | char *print_id; 176 | char *real_id; 177 | unsigned name; 178 | struct tl_type *type; 179 | 180 | struct tl_combinator_tree *left; 181 | struct tl_combinator_tree *right; 182 | }; 183 | 184 | struct tl_var { 185 | char *id; 186 | struct tl_combinator_tree *ptr; 187 | int type; 188 | int flags; 189 | }; 190 | 191 | struct parse *tl_init_parse_file (const char *fname); 192 | struct tree *tl_parse_lex (struct parse *P); 193 | void tl_print_parse_error (void); 194 | struct tl_program *tl_parse (struct tree *T); 195 | 196 | void write_types (int f); 197 | 198 | #define FLAG_BARE 1 199 | #define FLAG_OPT_VAR (1 << 17) 200 | #define FLAG_EXCL (1 << 18) 201 | #define FLAG_OPT_FIELD (1 << 20) 202 | #define FLAG_IS_VAR (1 << 21) 203 | #define FLAG_DEFAULT_CONSTRUCTOR (1 << 25) 204 | #define FLAG_EMPTY (1 << 10) 205 | 206 | #endif 207 | -------------------------------------------------------------------------------- /m4-ax_gcc_builtin.m4: -------------------------------------------------------------------------------- 1 | # =========================================================================== 2 | # http://www.gnu.org/software/autoconf-archive/ax_gcc_builtin.html 3 | # =========================================================================== 4 | # 5 | # SYNOPSIS 6 | # 7 | # AX_GCC_BUILTIN(BUILTIN) 8 | # 9 | # DESCRIPTION 10 | # 11 | # This macro checks if the compiler supports one of GCC's built-in 12 | # functions; many other compilers also provide those same built-ins. 13 | # 14 | # The BUILTIN parameter is the name of the built-in function. 15 | # 16 | # If BUILTIN is supported define HAVE_. Keep in mind that since 17 | # builtins usually start with two underscores they will be copied over 18 | # into the HAVE_ definition (e.g. HAVE___BUILTIN_EXPECT for 19 | # __builtin_expect()). 20 | # 21 | # The macro caches its result in the ax_cv_have_ variable (e.g. 22 | # ax_cv_have___builtin_expect). 23 | # 24 | # The macro currently supports the following built-in functions: 25 | # 26 | # __builtin_assume_aligned 27 | # __builtin_bswap32 28 | # __builtin_bswap64 29 | # __builtin_choose_expr 30 | # __builtin___clear_cache 31 | # __builtin_clrsb 32 | # __builtin_clrsbl 33 | # __builtin_clrsbll 34 | # __builtin_clz 35 | # __builtin_clzl 36 | # __builtin_clzll 37 | # __builtin_complex 38 | # __builtin_constant_p 39 | # __builtin_ctz 40 | # __builtin_ctzl 41 | # __builtin_ctzll 42 | # __builtin_expect 43 | # __builtin_ffs 44 | # __builtin_ffsl 45 | # __builtin_ffsll 46 | # __builtin_fpclassify 47 | # __builtin_huge_val 48 | # __builtin_huge_valf 49 | # __builtin_huge_vall 50 | # __builtin_inf 51 | # __builtin_infd128 52 | # __builtin_infd32 53 | # __builtin_infd64 54 | # __builtin_inff 55 | # __builtin_infl 56 | # __builtin_isinf_sign 57 | # __builtin_nan 58 | # __builtin_nand128 59 | # __builtin_nand32 60 | # __builtin_nand64 61 | # __builtin_nanf 62 | # __builtin_nanl 63 | # __builtin_nans 64 | # __builtin_nansf 65 | # __builtin_nansl 66 | # __builtin_object_size 67 | # __builtin_parity 68 | # __builtin_parityl 69 | # __builtin_parityll 70 | # __builtin_popcount 71 | # __builtin_popcountl 72 | # __builtin_popcountll 73 | # __builtin_powi 74 | # __builtin_powif 75 | # __builtin_powil 76 | # __builtin_prefetch 77 | # __builtin_trap 78 | # __builtin_types_compatible_p 79 | # __builtin_unreachable 80 | # 81 | # Unsuppored built-ins will be tested with an empty parameter set and the 82 | # result of the check might be wrong or meaningless so use with care. 83 | # 84 | # LICENSE 85 | # 86 | # Copyright (c) 2013 Gabriele Svelto 87 | # 88 | # Copying and distribution of this file, with or without modification, are 89 | # permitted in any medium without royalty provided the copyright notice 90 | # and this notice are preserved. This file is offered as-is, without any 91 | # warranty. 92 | 93 | #serial 2 94 | 95 | AC_DEFUN([AX_GCC_BUILTIN], [ 96 | AS_VAR_PUSHDEF([ac_var], [ax_cv_have_$1]) 97 | 98 | AC_CACHE_CHECK([for $1], [ac_var], [ 99 | AC_LINK_IFELSE([AC_LANG_PROGRAM([], [ 100 | m4_case([$1], 101 | [__builtin_assume_aligned], [$1("", 0)], 102 | [__builtin_bswap32], [$1(0)], 103 | [__builtin_bswap64], [$1(0)], 104 | [__builtin_choose_expr], [$1(0, 0, 0)], 105 | [__builtin___clear_cache], [$1("", "")], 106 | [__builtin_clrsb], [$1(0)], 107 | [__builtin_clrsbl], [$1(0)], 108 | [__builtin_clrsbll], [$1(0)], 109 | [__builtin_clz], [$1(0)], 110 | [__builtin_clzl], [$1(0)], 111 | [__builtin_clzll], [$1(0)], 112 | [__builtin_complex], [$1(0.0, 0.0)], 113 | [__builtin_constant_p], [$1(0)], 114 | [__builtin_ctz], [$1(0)], 115 | [__builtin_ctzl], [$1(0)], 116 | [__builtin_ctzll], [$1(0)], 117 | [__builtin_expect], [$1(0, 0)], 118 | [__builtin_ffs], [$1(0)], 119 | [__builtin_ffsl], [$1(0)], 120 | [__builtin_ffsll], [$1(0)], 121 | [__builtin_fpclassify], [$1(0, 1, 2, 3, 4, 0.0)], 122 | [__builtin_huge_val], [$1()], 123 | [__builtin_huge_valf], [$1()], 124 | [__builtin_huge_vall], [$1()], 125 | [__builtin_inf], [$1()], 126 | [__builtin_infd128], [$1()], 127 | [__builtin_infd32], [$1()], 128 | [__builtin_infd64], [$1()], 129 | [__builtin_inff], [$1()], 130 | [__builtin_infl], [$1()], 131 | [__builtin_isinf_sign], [$1(0.0)], 132 | [__builtin_nan], [$1("")], 133 | [__builtin_nand128], [$1("")], 134 | [__builtin_nand32], [$1("")], 135 | [__builtin_nand64], [$1("")], 136 | [__builtin_nanf], [$1("")], 137 | [__builtin_nanl], [$1("")], 138 | [__builtin_nans], [$1("")], 139 | [__builtin_nansf], [$1("")], 140 | [__builtin_nansl], [$1("")], 141 | [__builtin_object_size], [$1("", 0)], 142 | [__builtin_parity], [$1(0)], 143 | [__builtin_parityl], [$1(0)], 144 | [__builtin_parityll], [$1(0)], 145 | [__builtin_popcount], [$1(0)], 146 | [__builtin_popcountl], [$1(0)], 147 | [__builtin_popcountll], [$1(0)], 148 | [__builtin_powi], [$1(0, 0)], 149 | [__builtin_powif], [$1(0, 0)], 150 | [__builtin_powil], [$1(0, 0)], 151 | [__builtin_prefetch], [$1("")], 152 | [__builtin_trap], [$1()], 153 | [__builtin_types_compatible_p], [$1(int, int)], 154 | [__builtin_unreachable], [$1()], 155 | [m4_warn([syntax], [Unsupported built-in $1, the test may fail]) 156 | $1()] 157 | ) 158 | ])], 159 | [AS_VAR_SET([ac_var], [yes])], 160 | [AS_VAR_SET([ac_var], [no])]) 161 | ]) 162 | 163 | AS_IF([test yes = AS_VAR_GET([ac_var])], 164 | [AC_DEFINE_UNQUOTED(AS_TR_CPP(HAVE_$1), 1, 165 | [Define to 1 if the system has the `$1' built-in function])], []) 166 | 167 | AS_VAR_POPDEF([ac_var]) 168 | ]) 169 | -------------------------------------------------------------------------------- /tl-parser-tree.h: -------------------------------------------------------------------------------- 1 | /* 2 | This file is part of tgl-library 3 | 4 | This library is free software; you can redistribute it and/or 5 | modify it under the terms of the GNU Lesser General Public 6 | License as published by the Free Software Foundation; either 7 | version 2.1 of the License, or (at your option) any later version. 8 | 9 | This library is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | Lesser General Public License for more details. 13 | 14 | You should have received a copy of the GNU Lesser General Public 15 | License along with this library; if not, write to the Free Software 16 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 17 | 18 | Copyright Vitaly Valtman 2013-2014 19 | */ 20 | #ifndef __TREE_H__ 21 | #define __TREE_H__ 22 | #include 23 | 24 | #include 25 | #include 26 | 27 | #pragma pack(push,4) 28 | #define DEFINE_TREE(X_NAME, X_TYPE, X_CMP, X_UNSET) \ 29 | struct tree_ ## X_NAME { \ 30 | struct tree_ ## X_NAME *left, *right;\ 31 | X_TYPE x;\ 32 | int y;\ 33 | };\ 34 | \ 35 | static struct tree_ ## X_NAME *new_tree_node_ ## X_NAME (X_TYPE x, int y) {\ 36 | struct tree_ ## X_NAME *T = malloc (sizeof (*T));\ 37 | T->x = x;\ 38 | T->y = y;\ 39 | T->left = T->right = 0;\ 40 | return T;\ 41 | }\ 42 | \ 43 | static void delete_tree_node_ ## X_NAME (struct tree_ ## X_NAME *T) {\ 44 | free (T);\ 45 | }\ 46 | \ 47 | static void tree_split_ ## X_NAME (struct tree_ ## X_NAME *T, X_TYPE x, struct tree_ ## X_NAME **L, struct tree_ ## X_NAME **R) {\ 48 | if (!T) {\ 49 | *L = *R = 0;\ 50 | } else {\ 51 | int c = X_CMP (x, T->x);\ 52 | if (c < 0) {\ 53 | tree_split_ ## X_NAME (T->left, x, L, &T->left);\ 54 | *R = T;\ 55 | } else {\ 56 | tree_split_ ## X_NAME (T->right, x, &T->right, R);\ 57 | *L = T;\ 58 | }\ 59 | }\ 60 | }\ 61 | \ 62 | static struct tree_ ## X_NAME *tree_insert_ ## X_NAME (struct tree_ ## X_NAME *T, X_TYPE x, int y) __attribute__ ((warn_unused_result,unused));\ 63 | static struct tree_ ## X_NAME *tree_insert_ ## X_NAME (struct tree_ ## X_NAME *T, X_TYPE x, int y) {\ 64 | if (!T) {\ 65 | return new_tree_node_ ## X_NAME (x, y);\ 66 | } else {\ 67 | if (y > T->y) {\ 68 | struct tree_ ## X_NAME *N = new_tree_node_ ## X_NAME (x, y);\ 69 | tree_split_ ## X_NAME (T, x, &N->left, &N->right);\ 70 | return N;\ 71 | } else {\ 72 | int c = X_CMP (x, T->x);\ 73 | assert (c);\ 74 | if (c < 0) { \ 75 | T->left = tree_insert_ ## X_NAME (T->left, x, y);\ 76 | } else { \ 77 | T->right = tree_insert_ ## X_NAME (T->right, x, y);\ 78 | } \ 79 | return T; \ 80 | }\ 81 | }\ 82 | }\ 83 | \ 84 | static struct tree_ ## X_NAME *tree_merge_ ## X_NAME (struct tree_ ## X_NAME *L, struct tree_ ## X_NAME *R) {\ 85 | if (!L || !R) {\ 86 | return L ? L : R;\ 87 | } else {\ 88 | if (L->y > R->y) {\ 89 | L->right = tree_merge_ ## X_NAME (L->right, R);\ 90 | return L;\ 91 | } else {\ 92 | R->left = tree_merge_ ## X_NAME (L, R->left);\ 93 | return R;\ 94 | }\ 95 | }\ 96 | }\ 97 | \ 98 | static struct tree_ ## X_NAME *tree_delete_ ## X_NAME (struct tree_ ## X_NAME *T, X_TYPE x) __attribute__ ((warn_unused_result,unused));\ 99 | static struct tree_ ## X_NAME *tree_delete_ ## X_NAME (struct tree_ ## X_NAME *T, X_TYPE x) {\ 100 | assert (T);\ 101 | int c = X_CMP (x, T->x);\ 102 | if (!c) {\ 103 | struct tree_ ## X_NAME *N = tree_merge_ ## X_NAME (T->left, T->right);\ 104 | delete_tree_node_ ## X_NAME (T);\ 105 | return N;\ 106 | } else {\ 107 | if (c < 0) { \ 108 | T->left = tree_delete_ ## X_NAME (T->left, x); \ 109 | } else { \ 110 | T->right = tree_delete_ ## X_NAME (T->right, x); \ 111 | } \ 112 | return T; \ 113 | }\ 114 | }\ 115 | \ 116 | static X_TYPE tree_get_min_ ## X_NAME (struct tree_ ## X_NAME *t) __attribute__ ((unused));\ 117 | static X_TYPE tree_get_min_ ## X_NAME (struct tree_ ## X_NAME *T) {\ 118 | if (!T) { return X_UNSET; } \ 119 | while (T->left) { T = T->left; }\ 120 | return T->x; \ 121 | } \ 122 | \ 123 | static X_TYPE tree_lookup_ ## X_NAME (struct tree_ ## X_NAME *T, X_TYPE x) __attribute__ ((unused));\ 124 | static X_TYPE tree_lookup_ ## X_NAME (struct tree_ ## X_NAME *T, X_TYPE x) {\ 125 | int c;\ 126 | while (T && (c = X_CMP (x, T->x))) {\ 127 | T = (c < 0 ? T->left : T->right);\ 128 | }\ 129 | return T ? T->x : X_UNSET;\ 130 | }\ 131 | \ 132 | static void tree_act_ ## X_NAME (struct tree_ ## X_NAME *T, void (*act)(X_TYPE)) __attribute__ ((unused));\ 133 | static void tree_act_ ## X_NAME (struct tree_ ## X_NAME *T, void (*act)(X_TYPE)) {\ 134 | if (!T) { return; } \ 135 | tree_act_ ## X_NAME (T->left, act); \ 136 | act (T->x); \ 137 | tree_act_ ## X_NAME (T->right, act); \ 138 | }\ 139 | \ 140 | static void tree_act_ex_ ## X_NAME (struct tree_ ## X_NAME *T, void (*act)(X_TYPE, void *), void *extra) __attribute__ ((unused));\ 141 | static void tree_act_ex_ ## X_NAME (struct tree_ ## X_NAME *T, void (*act)(X_TYPE, void *), void *extra) {\ 142 | if (!T) { return; } \ 143 | tree_act_ex_ ## X_NAME (T->left, act, extra); \ 144 | act (T->x, extra); \ 145 | tree_act_ex_ ## X_NAME (T->right, act, extra); \ 146 | }\ 147 | \ 148 | static int tree_count_ ## X_NAME (struct tree_ ## X_NAME *T) __attribute__ ((unused));\ 149 | static int tree_count_ ## X_NAME (struct tree_ ## X_NAME *T) { \ 150 | if (!T) { return 0; }\ 151 | return 1 + tree_count_ ## X_NAME (T->left) + tree_count_ ## X_NAME (T->right); \ 152 | }\ 153 | static void tree_check_ ## X_NAME (struct tree_ ## X_NAME *T) __attribute__ ((unused));\ 154 | static void tree_check_ ## X_NAME (struct tree_ ## X_NAME *T) { \ 155 | if (!T) { return; }\ 156 | if (T->left) { \ 157 | assert (T->left->y <= T->y);\ 158 | assert (X_CMP (T->left->x, T->x) < 0); \ 159 | }\ 160 | if (T->right) { \ 161 | assert (T->right->y <= T->y);\ 162 | assert (X_CMP (T->right->x, T->x) > 0); \ 163 | }\ 164 | tree_check_ ## X_NAME (T->left); \ 165 | tree_check_ ## X_NAME (T->right); \ 166 | }\ 167 | static struct tree_ ## X_NAME *tree_clear_ ## X_NAME (struct tree_ ## X_NAME *T) __attribute__ ((unused));\ 168 | static struct tree_ ## X_NAME *tree_clear_ ## X_NAME (struct tree_ ## X_NAME *T) { \ 169 | if (!T) { return 0; }\ 170 | tree_clear_ ## X_NAME (T->left); \ 171 | tree_clear_ ## X_NAME (T->right); \ 172 | delete_tree_node_ ## X_NAME (T); \ 173 | return 0; \ 174 | } \ 175 | 176 | #define int_cmp(a,b) ((a) - (b)) 177 | #pragma pack(pop) 178 | #endif 179 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 2, June 1991 3 | 4 | Copyright (C) 1989, 1991 Free Software Foundation, Inc., 5 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 6 | Everyone is permitted to copy and distribute verbatim copies 7 | of this license document, but changing it is not allowed. 8 | 9 | Preamble 10 | 11 | The licenses for most software are designed to take away your 12 | freedom to share and change it. By contrast, the GNU General Public 13 | License is intended to guarantee your freedom to share and change free 14 | software--to make sure the software is free for all its users. This 15 | General Public License applies to most of the Free Software 16 | Foundation's software and to any other program whose authors commit to 17 | using it. (Some other Free Software Foundation software is covered by 18 | the GNU Lesser General Public License instead.) You can apply it to 19 | your programs, too. 20 | 21 | When we speak of free software, we are referring to freedom, not 22 | price. Our General Public Licenses are designed to make sure that you 23 | have the freedom to distribute copies of free software (and charge for 24 | this service if you wish), that you receive source code or can get it 25 | if you want it, that you can change the software or use pieces of it 26 | in new free programs; and that you know you can do these things. 27 | 28 | To protect your rights, we need to make restrictions that forbid 29 | anyone to deny you these rights or to ask you to surrender the rights. 30 | These restrictions translate to certain responsibilities for you if you 31 | distribute copies of the software, or if you modify it. 32 | 33 | For example, if you distribute copies of such a program, whether 34 | gratis or for a fee, you must give the recipients all the rights that 35 | you have. You must make sure that they, too, receive or can get the 36 | source code. And you must show them these terms so they know their 37 | rights. 38 | 39 | We protect your rights with two steps: (1) copyright the software, and 40 | (2) offer you this license which gives you legal permission to copy, 41 | distribute and/or modify the software. 42 | 43 | Also, for each author's protection and ours, we want to make certain 44 | that everyone understands that there is no warranty for this free 45 | software. If the software is modified by someone else and passed on, we 46 | want its recipients to know that what they have is not the original, so 47 | that any problems introduced by others will not reflect on the original 48 | authors' reputations. 49 | 50 | Finally, any free program is threatened constantly by software 51 | patents. We wish to avoid the danger that redistributors of a free 52 | program will individually obtain patent licenses, in effect making the 53 | program proprietary. To prevent this, we have made it clear that any 54 | patent must be licensed for everyone's free use or not licensed at all. 55 | 56 | The precise terms and conditions for copying, distribution and 57 | modification follow. 58 | 59 | GNU GENERAL PUBLIC LICENSE 60 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 61 | 62 | 0. This License applies to any program or other work which contains 63 | a notice placed by the copyright holder saying it may be distributed 64 | under the terms of this General Public License. The "Program", below, 65 | refers to any such program or work, and a "work based on the Program" 66 | means either the Program or any derivative work under copyright law: 67 | that is to say, a work containing the Program or a portion of it, 68 | either verbatim or with modifications and/or translated into another 69 | language. (Hereinafter, translation is included without limitation in 70 | the term "modification".) Each licensee is addressed as "you". 71 | 72 | Activities other than copying, distribution and modification are not 73 | covered by this License; they are outside its scope. The act of 74 | running the Program is not restricted, and the output from the Program 75 | is covered only if its contents constitute a work based on the 76 | Program (independent of having been made by running the Program). 77 | Whether that is true depends on what the Program does. 78 | 79 | 1. You may copy and distribute verbatim copies of the Program's 80 | source code as you receive it, in any medium, provided that you 81 | conspicuously and appropriately publish on each copy an appropriate 82 | copyright notice and disclaimer of warranty; keep intact all the 83 | notices that refer to this License and to the absence of any warranty; 84 | and give any other recipients of the Program a copy of this License 85 | along with the Program. 86 | 87 | You may charge a fee for the physical act of transferring a copy, and 88 | you may at your option offer warranty protection in exchange for a fee. 89 | 90 | 2. You may modify your copy or copies of the Program or any portion 91 | of it, thus forming a work based on the Program, and copy and 92 | distribute such modifications or work under the terms of Section 1 93 | above, provided that you also meet all of these conditions: 94 | 95 | a) You must cause the modified files to carry prominent notices 96 | stating that you changed the files and the date of any change. 97 | 98 | b) You must cause any work that you distribute or publish, that in 99 | whole or in part contains or is derived from the Program or any 100 | part thereof, to be licensed as a whole at no charge to all third 101 | parties under the terms of this License. 102 | 103 | c) If the modified program normally reads commands interactively 104 | when run, you must cause it, when started running for such 105 | interactive use in the most ordinary way, to print or display an 106 | announcement including an appropriate copyright notice and a 107 | notice that there is no warranty (or else, saying that you provide 108 | a warranty) and that users may redistribute the program under 109 | these conditions, and telling the user how to view a copy of this 110 | License. (Exception: if the Program itself is interactive but 111 | does not normally print such an announcement, your work based on 112 | the Program is not required to print an announcement.) 113 | 114 | These requirements apply to the modified work as a whole. If 115 | identifiable sections of that work are not derived from the Program, 116 | and can be reasonably considered independent and separate works in 117 | themselves, then this License, and its terms, do not apply to those 118 | sections when you distribute them as separate works. But when you 119 | distribute the same sections as part of a whole which is a work based 120 | on the Program, the distribution of the whole must be on the terms of 121 | this License, whose permissions for other licensees extend to the 122 | entire whole, and thus to each and every part regardless of who wrote it. 123 | 124 | Thus, it is not the intent of this section to claim rights or contest 125 | your rights to work written entirely by you; rather, the intent is to 126 | exercise the right to control the distribution of derivative or 127 | collective works based on the Program. 128 | 129 | In addition, mere aggregation of another work not based on the Program 130 | with the Program (or with a work based on the Program) on a volume of 131 | a storage or distribution medium does not bring the other work under 132 | the scope of this License. 133 | 134 | 3. You may copy and distribute the Program (or a work based on it, 135 | under Section 2) in object code or executable form under the terms of 136 | Sections 1 and 2 above provided that you also do one of the following: 137 | 138 | a) Accompany it with the complete corresponding machine-readable 139 | source code, which must be distributed under the terms of Sections 140 | 1 and 2 above on a medium customarily used for software interchange; or, 141 | 142 | b) Accompany it with a written offer, valid for at least three 143 | years, to give any third party, for a charge no more than your 144 | cost of physically performing source distribution, a complete 145 | machine-readable copy of the corresponding source code, to be 146 | distributed under the terms of Sections 1 and 2 above on a medium 147 | customarily used for software interchange; or, 148 | 149 | c) Accompany it with the information you received as to the offer 150 | to distribute corresponding source code. (This alternative is 151 | allowed only for noncommercial distribution and only if you 152 | received the program in object code or executable form with such 153 | an offer, in accord with Subsection b above.) 154 | 155 | The source code for a work means the preferred form of the work for 156 | making modifications to it. For an executable work, complete source 157 | code means all the source code for all modules it contains, plus any 158 | associated interface definition files, plus the scripts used to 159 | control compilation and installation of the executable. However, as a 160 | special exception, the source code distributed need not include 161 | anything that is normally distributed (in either source or binary 162 | form) with the major components (compiler, kernel, and so on) of the 163 | operating system on which the executable runs, unless that component 164 | itself accompanies the executable. 165 | 166 | If distribution of executable or object code is made by offering 167 | access to copy from a designated place, then offering equivalent 168 | access to copy the source code from the same place counts as 169 | distribution of the source code, even though third parties are not 170 | compelled to copy the source along with the object code. 171 | 172 | 4. You may not copy, modify, sublicense, or distribute the Program 173 | except as expressly provided under this License. Any attempt 174 | otherwise to copy, modify, sublicense or distribute the Program is 175 | void, and will automatically terminate your rights under this License. 176 | However, parties who have received copies, or rights, from you under 177 | this License will not have their licenses terminated so long as such 178 | parties remain in full compliance. 179 | 180 | 5. You are not required to accept this License, since you have not 181 | signed it. However, nothing else grants you permission to modify or 182 | distribute the Program or its derivative works. These actions are 183 | prohibited by law if you do not accept this License. Therefore, by 184 | modifying or distributing the Program (or any work based on the 185 | Program), you indicate your acceptance of this License to do so, and 186 | all its terms and conditions for copying, distributing or modifying 187 | the Program or works based on it. 188 | 189 | 6. Each time you redistribute the Program (or any work based on the 190 | Program), the recipient automatically receives a license from the 191 | original licensor to copy, distribute or modify the Program subject to 192 | these terms and conditions. You may not impose any further 193 | restrictions on the recipients' exercise of the rights granted herein. 194 | You are not responsible for enforcing compliance by third parties to 195 | this License. 196 | 197 | 7. If, as a consequence of a court judgment or allegation of patent 198 | infringement or for any other reason (not limited to patent issues), 199 | conditions are imposed on you (whether by court order, agreement or 200 | otherwise) that contradict the conditions of this License, they do not 201 | excuse you from the conditions of this License. If you cannot 202 | distribute so as to satisfy simultaneously your obligations under this 203 | License and any other pertinent obligations, then as a consequence you 204 | may not distribute the Program at all. For example, if a patent 205 | license would not permit royalty-free redistribution of the Program by 206 | all those who receive copies directly or indirectly through you, then 207 | the only way you could satisfy both it and this License would be to 208 | refrain entirely from distribution of the Program. 209 | 210 | If any portion of this section is held invalid or unenforceable under 211 | any particular circumstance, the balance of the section is intended to 212 | apply and the section as a whole is intended to apply in other 213 | circumstances. 214 | 215 | It is not the purpose of this section to induce you to infringe any 216 | patents or other property right claims or to contest validity of any 217 | such claims; this section has the sole purpose of protecting the 218 | integrity of the free software distribution system, which is 219 | implemented by public license practices. Many people have made 220 | generous contributions to the wide range of software distributed 221 | through that system in reliance on consistent application of that 222 | system; it is up to the author/donor to decide if he or she is willing 223 | to distribute software through any other system and a licensee cannot 224 | impose that choice. 225 | 226 | This section is intended to make thoroughly clear what is believed to 227 | be a consequence of the rest of this License. 228 | 229 | 8. If the distribution and/or use of the Program is restricted in 230 | certain countries either by patents or by copyrighted interfaces, the 231 | original copyright holder who places the Program under this License 232 | may add an explicit geographical distribution limitation excluding 233 | those countries, so that distribution is permitted only in or among 234 | countries not thus excluded. In such case, this License incorporates 235 | the limitation as if written in the body of this License. 236 | 237 | 9. The Free Software Foundation may publish revised and/or new versions 238 | of the General Public License from time to time. Such new versions will 239 | be similar in spirit to the present version, but may differ in detail to 240 | address new problems or concerns. 241 | 242 | Each version is given a distinguishing version number. If the Program 243 | specifies a version number of this License which applies to it and "any 244 | later version", you have the option of following the terms and conditions 245 | either of that version or of any later version published by the Free 246 | Software Foundation. If the Program does not specify a version number of 247 | this License, you may choose any version ever published by the Free Software 248 | Foundation. 249 | 250 | 10. If you wish to incorporate parts of the Program into other free 251 | programs whose distribution conditions are different, write to the author 252 | to ask for permission. For software which is copyrighted by the Free 253 | Software Foundation, write to the Free Software Foundation; we sometimes 254 | make exceptions for this. Our decision will be guided by the two goals 255 | of preserving the free status of all derivatives of our free software and 256 | of promoting the sharing and reuse of software generally. 257 | 258 | NO WARRANTY 259 | 260 | 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY 261 | FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN 262 | OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES 263 | PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED 264 | OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 265 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS 266 | TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE 267 | PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, 268 | REPAIR OR CORRECTION. 269 | 270 | 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 271 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR 272 | REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, 273 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING 274 | OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED 275 | TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY 276 | YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER 277 | PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE 278 | POSSIBILITY OF SUCH DAMAGES. 279 | 280 | END OF TERMS AND CONDITIONS 281 | 282 | How to Apply These Terms to Your New Programs 283 | 284 | If you develop a new program, and you want it to be of the greatest 285 | possible use to the public, the best way to achieve this is to make it 286 | free software which everyone can redistribute and change under these terms. 287 | 288 | To do so, attach the following notices to the program. It is safest 289 | to attach them to the start of each source file to most effectively 290 | convey the exclusion of warranty; and each file should have at least 291 | the "copyright" line and a pointer to where the full notice is found. 292 | 293 | 294 | Copyright (C) 295 | 296 | This program is free software; you can redistribute it and/or modify 297 | it under the terms of the GNU General Public License as published by 298 | the Free Software Foundation; either version 2 of the License, or 299 | (at your option) any later version. 300 | 301 | This program is distributed in the hope that it will be useful, 302 | but WITHOUT ANY WARRANTY; without even the implied warranty of 303 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 304 | GNU General Public License for more details. 305 | 306 | You should have received a copy of the GNU General Public License along 307 | with this program; if not, write to the Free Software Foundation, Inc., 308 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 309 | 310 | Also add information on how to contact you by electronic and paper mail. 311 | 312 | If the program is interactive, make it output a short notice like this 313 | when it starts in an interactive mode: 314 | 315 | Gnomovision version 69, Copyright (C) year name of author 316 | Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 317 | This is free software, and you are welcome to redistribute it 318 | under certain conditions; type `show c' for details. 319 | 320 | The hypothetical commands `show w' and `show c' should show the appropriate 321 | parts of the General Public License. Of course, the commands you use may 322 | be called something other than `show w' and `show c'; they could even be 323 | mouse-clicks or menu items--whatever suits your program. 324 | 325 | You should also get your employer (if you work as a programmer) or your 326 | school, if any, to sign a "copyright disclaimer" for the program, if 327 | necessary. Here is a sample; alter the names: 328 | 329 | Yoyodyne, Inc., hereby disclaims all copyright interest in the program 330 | `Gnomovision' (which makes passes at compilers) written by James Hacker. 331 | 332 | , 1 April 1989 333 | Ty Coon, President of Vice 334 | 335 | This General Public License does not permit incorporating your program into 336 | proprietary programs. If your program is a subroutine library, you may 337 | consider it more useful to permit linking proprietary applications with the 338 | library. If this is what you want to do, use the GNU Lesser General 339 | Public License instead of this License. 340 | -------------------------------------------------------------------------------- /tl-parser.c: -------------------------------------------------------------------------------- 1 | /* 2 | This file is part of tl-parser 3 | 4 | tl-parser is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU General Public License as published by 6 | the Free Software Foundation, either version 2 of the License, or 7 | (at your option) any later version. 8 | 9 | tl-parser is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with this tl-parser. If not, see . 16 | 17 | Copyright Vitaly Valtman 2014 18 | 19 | It is derivative work of VK/KittenPHP-DB-Engine (https://github.com/vk-com/kphp-kdb/) 20 | Copyright 2012-2013 Vkontakte Ltd 21 | 2012-2013 Vitaliy Valtman 22 | 23 | */ 24 | 25 | #define _FILE_OFFSET_BITS 64 26 | #include "config.h" 27 | 28 | #include 29 | #include 30 | #include 31 | #include 32 | #include 33 | #include 34 | #include 35 | #include 36 | #include 37 | #include 38 | #include "portable_endian.h" 39 | #include "tl-parser-tree.h" 40 | #include "tl-parser.h" 41 | #include "tl-tl.h" 42 | #include "config.h" 43 | 44 | extern int verbosity; 45 | extern int schema_version; 46 | extern int output_expressions; 47 | 48 | 49 | int total_types_num; 50 | int total_constructors_num; 51 | int total_functions_num; 52 | 53 | 54 | /*char *tstrdup (const char *s) { 55 | assert (s); 56 | char *r = talloc (strlen (s) + 1); 57 | memcpy (r, s, strlen (s) + 1); 58 | return r; 59 | }*/ 60 | 61 | #define talloc(a) malloc(a) 62 | #define tfree(a,b) free (a) 63 | #define talloc0(a) calloc(a,1) 64 | #define tstrdup(a) strdup(a) 65 | 66 | typedef char error_int_must_be_4_byte[(sizeof (int) == 4) ? 1 : -1]; 67 | typedef char error_long_long_must_be_8_byte[(sizeof (long long) == 8) ? 1 : -1]; 68 | 69 | char curch; 70 | struct parse parse; 71 | 72 | struct tree *tree; 73 | 74 | struct tree *tree_alloc (void) { 75 | struct tree *T = talloc (sizeof (*T)); 76 | assert (T); 77 | memset (T, 0, sizeof (*T)); 78 | return T; 79 | } 80 | 81 | #define CRC32_INITIAL crc32 (0, 0, 0) 82 | 83 | void tree_add_child (struct tree *P, struct tree *C) { 84 | if (P->nc == P->size) { 85 | void **t = talloc (sizeof (void *) * (++P->size)); 86 | memcpy (t, P->c, sizeof (void *) * (P->size - 1)); 87 | if (P->c) { 88 | tfree (P->c, sizeof (void *) * (P->size - 1)); 89 | } 90 | P->c = (void *)t; 91 | assert (P->c); 92 | } 93 | P->c[P->nc ++] = C; 94 | } 95 | 96 | void tree_delete (struct tree *T) { 97 | assert (T); 98 | int i; 99 | for (i = 0; i < T->nc; i++) { 100 | assert (T->c[i]); 101 | tree_delete (T->c[i]); 102 | } 103 | if (T->c) { 104 | tfree (T->c, sizeof (void *) * T->nc); 105 | } 106 | tfree (T, sizeof (*T)); 107 | } 108 | 109 | void tree_del_child (struct tree *P) { 110 | assert (P->nc); 111 | tree_delete (P->c[--P->nc]); 112 | } 113 | 114 | 115 | char nextch (void) { 116 | if (parse.pos < parse.len - 1) { 117 | curch = parse.text[++parse.pos]; 118 | } else { 119 | curch = 0; 120 | } 121 | if (curch == 10) { 122 | parse.line ++; 123 | parse.line_pos = 0; 124 | } else { 125 | if (curch) { 126 | parse.line_pos ++; 127 | } 128 | } 129 | return curch; 130 | } 131 | 132 | 133 | struct parse save_parse (void) { 134 | return parse; 135 | } 136 | 137 | void load_parse (struct parse _parse) { 138 | parse = _parse; 139 | curch = parse.pos > parse.len ? 0: parse.text[parse.pos] ; 140 | } 141 | 142 | int is_whitespace (char c) { 143 | return (c <= 32); 144 | } 145 | 146 | int is_uletter (char c) { 147 | return (c >= 'A' && c <= 'Z'); 148 | } 149 | 150 | int is_lletter (char c) { 151 | return (c >= 'a' && c <= 'z'); 152 | } 153 | 154 | int is_letter (char c) { 155 | return is_uletter (c) || is_lletter (c); 156 | } 157 | 158 | int is_digit (char c) { 159 | return (c >= '0' && c <= '9'); 160 | } 161 | 162 | int is_hexdigit (char c) { 163 | return is_digit (c) || (c >= 'a' && c <= 'f'); 164 | } 165 | 166 | int is_ident_char (char c) { 167 | return is_digit (c) || is_letter (c) || c == '_'; 168 | } 169 | 170 | int last_error_pos; 171 | int last_error_line; 172 | int last_error_line_pos; 173 | char *last_error; 174 | 175 | void parse_error (const char *e) { 176 | if (parse.pos > last_error_pos) { 177 | last_error_pos = parse.pos; 178 | last_error_line = parse.line; 179 | last_error_line_pos = parse.line_pos; 180 | if (last_error) { 181 | tfree (last_error, strlen (last_error) + 1); 182 | } 183 | last_error = tstrdup (e); 184 | } 185 | } 186 | 187 | void tl_print_parse_error (void) { 188 | fprintf (stderr, "Error near line %d pos %d: `%s`\n", last_error_line + 1, last_error_line_pos + 1, last_error); 189 | } 190 | 191 | char *parse_lex (void) { 192 | while (1) { 193 | while (curch && is_whitespace (curch)) { nextch (); } 194 | if (curch == '/' && nextch () == '/') { 195 | while (nextch () != 10); 196 | nextch (); 197 | } else { 198 | break; 199 | } 200 | } 201 | if (!curch) { 202 | parse.lex.len = 0; 203 | parse.lex.type = lex_eof; 204 | return (parse.lex.ptr = 0); 205 | } 206 | char *p = parse.text + parse.pos; 207 | parse.lex.flags = 0; 208 | switch (curch) { 209 | case '-': 210 | if (nextch () != '-' || nextch () != '-') { 211 | parse_error ("Can not parse triple minus"); 212 | parse.lex.type = lex_error; 213 | return (parse.lex.ptr = (void *)-1); 214 | } else { 215 | parse.lex.len = 3; 216 | parse.lex.type = lex_triple_minus; 217 | nextch (); 218 | return (parse.lex.ptr = p); 219 | } 220 | case ':': 221 | case ';': 222 | case '(': 223 | case ')': 224 | case '[': 225 | case ']': 226 | case '{': 227 | case '}': 228 | case '=': 229 | case '#': 230 | case '?': 231 | case '%': 232 | case '<': 233 | case '>': 234 | case '+': 235 | case ',': 236 | case '*': 237 | case '_': 238 | case '!': 239 | case '.': 240 | nextch (); 241 | parse.lex.len = 1; 242 | parse.lex.type = lex_char; 243 | return (parse.lex.ptr = p); 244 | case 'a'...'z': 245 | case 'A'...'Z': 246 | parse.lex.flags = 0; 247 | if (is_uletter (curch)) { 248 | while (is_ident_char (nextch ())); 249 | parse.lex.len = parse.text + parse.pos - p; 250 | parse.lex.ptr = p; 251 | if (parse.lex.len == 5 && !memcmp (parse.lex.ptr, "Final", 5)) { 252 | parse.lex.type = lex_final; 253 | } else if (parse.lex.len == 3 && !memcmp (parse.lex.ptr, "New", 3)) { 254 | parse.lex.type = lex_new; 255 | } else if (parse.lex.len == 5 && !memcmp (parse.lex.ptr, "Empty", 5)) { 256 | parse.lex.type = lex_empty; 257 | } else { 258 | parse.lex.type = lex_uc_ident; 259 | } 260 | return (parse.lex.ptr = p); 261 | } 262 | while (is_ident_char (nextch ())); 263 | if (curch == '.' && !is_letter (parse.text[parse.pos + 1])) { 264 | parse.lex.len = parse.text + parse.pos - p; 265 | parse.lex.type = lex_lc_ident; 266 | return (parse.lex.ptr = p); 267 | } 268 | if (curch == '.') { 269 | parse.lex.flags |= 1; 270 | nextch (); 271 | if (is_uletter (curch)) { 272 | while (is_ident_char (nextch ())); 273 | parse.lex.len = parse.text + parse.pos - p; 274 | parse.lex.type = lex_uc_ident; 275 | return (parse.lex.ptr = p); 276 | } 277 | if (is_lletter (curch)) { 278 | while (is_ident_char (nextch ())); 279 | } else { 280 | parse_error ("Expected letter"); 281 | parse.lex.type = lex_error; 282 | return (parse.lex.ptr = (void *)-1); 283 | } 284 | } 285 | if (curch == '#') { 286 | parse.lex.flags |= 2; 287 | int i; 288 | int ok = 1; 289 | for (i = 0; i < 8; i++) { 290 | if (!is_hexdigit (nextch())) { 291 | if (curch == ' ' && i >= 5) { 292 | ok = 2; 293 | break; 294 | } else { 295 | parse_error ("Hex digit expected"); 296 | parse.lex.type = lex_error; 297 | return (parse.lex.ptr = (void *)-1); 298 | } 299 | } 300 | } 301 | if (ok == 1) { 302 | nextch (); 303 | } 304 | } 305 | parse.lex.len = parse.text + parse.pos - p; 306 | parse.lex.type = lex_lc_ident; 307 | return (parse.lex.ptr = p); 308 | case '0'...'9': 309 | while (is_digit (nextch ())); 310 | parse.lex.len = parse.text + parse.pos - p; 311 | parse.lex.type = lex_num; 312 | return (parse.lex.ptr = p); 313 | default: 314 | parse_error ("Unknown lexem"); 315 | parse.lex.type = lex_error; 316 | return (parse.lex.ptr = (void *)-1); 317 | } 318 | 319 | } 320 | 321 | int expect (char *s) { 322 | 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)) { 323 | static char buf[1000]; 324 | sprintf (buf, "Expected %s", s); 325 | parse_error (buf); 326 | return -1; 327 | } else { 328 | parse_lex (); 329 | } 330 | return 1; 331 | } 332 | 333 | struct parse *tl_init_parse_file (const char *fname) { 334 | int fd = open (fname, O_RDONLY); 335 | if (fd < 0) { 336 | fprintf (stderr, "Error %m\n"); 337 | assert (0); 338 | return 0; 339 | } 340 | long long size = lseek (fd, 0, SEEK_END); 341 | if (size <= 0) { 342 | fprintf (stderr, "size is %lld. Too small.\n", size); 343 | return 0; 344 | } 345 | static struct parse save; 346 | save.text = talloc (size); 347 | lseek (fd, 0, SEEK_SET); 348 | save.len = read (fd, save.text, size); 349 | assert (save.len == size); 350 | save.pos = 0; 351 | save.line = 0; 352 | save.line_pos = 0; 353 | save.lex.ptr = save.text; 354 | save.lex.len = 0; 355 | save.lex.type = lex_none; 356 | return &save; 357 | } 358 | 359 | #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)); 360 | #define PARSE_FAIL load_parse (save); tree_delete (T); return 0; 361 | #define PARSE_OK return T; 362 | #define PARSE_TRY_PES(x) if (!(S = x ())) { PARSE_FAIL; } { tree_add_child (T, S); } 363 | #define PARSE_TRY_OPT(x) if ((S = x ())) { tree_add_child (T, S); PARSE_OK } 364 | #define PARSE_TRY(x) S = x (); 365 | #define PARSE_ADD(_type) S = tree_alloc (); S->type = _type; tree_add_child (T, S); 366 | #define EXPECT(s) if (expect (s) < 0) { PARSE_FAIL; } 367 | #define LEX_CHAR(c) (parse.lex.type == lex_char && *parse.lex.ptr == c) 368 | struct tree *parse_args (void); 369 | struct tree *parse_expr (void); 370 | 371 | struct tree *parse_boxed_type_ident (void) { 372 | PARSE_INIT (type_boxed_type_ident); 373 | if (parse.lex.type != lex_uc_ident) { 374 | parse_error ("Can not parse boxed type"); 375 | PARSE_FAIL; 376 | } else { 377 | T->text = parse.lex.ptr; 378 | T->len = parse.lex.len; 379 | T->flags = parse.lex.flags; 380 | parse_lex (); 381 | PARSE_OK; 382 | } 383 | } 384 | 385 | struct tree *parse_full_combinator_id (void) { 386 | PARSE_INIT (type_full_combinator_id); 387 | if (parse.lex.type == lex_lc_ident || LEX_CHAR('_')) { 388 | T->text = parse.lex.ptr; 389 | T->len = parse.lex.len; 390 | T->flags = parse.lex.flags; 391 | parse_lex (); 392 | PARSE_OK; 393 | } else { 394 | parse_error ("Can not parse full combinator id"); 395 | PARSE_FAIL; 396 | } 397 | } 398 | 399 | struct tree *parse_combinator_id (void) { 400 | PARSE_INIT (type_combinator_id); 401 | if (parse.lex.type == lex_lc_ident && !(parse.lex.flags & 2)) { 402 | T->text = parse.lex.ptr; 403 | T->len = parse.lex.len; 404 | T->flags = parse.lex.flags; 405 | parse_lex (); 406 | PARSE_OK; 407 | } else { 408 | parse_error ("Can not parse combinator id"); 409 | PARSE_FAIL; 410 | } 411 | } 412 | 413 | struct tree *parse_var_ident (void) { 414 | PARSE_INIT (type_var_ident); 415 | if ((parse.lex.type == lex_lc_ident || parse.lex.type == lex_uc_ident) && !(parse.lex.flags & 3)) { 416 | T->text = parse.lex.ptr; 417 | T->len = parse.lex.len; 418 | T->flags = parse.lex.flags; 419 | parse_lex (); 420 | PARSE_OK; 421 | } else { 422 | parse_error ("Can not parse var ident"); 423 | PARSE_FAIL; 424 | } 425 | } 426 | 427 | struct tree *parse_var_ident_opt (void) { 428 | PARSE_INIT (type_var_ident_opt); 429 | if ((parse.lex.type == lex_lc_ident || parse.lex.type == lex_uc_ident)&& !(parse.lex.flags & 3)) { 430 | T->text = parse.lex.ptr; 431 | T->len = parse.lex.len; 432 | T->flags = parse.lex.flags; 433 | parse_lex (); 434 | PARSE_OK; 435 | } else if (LEX_CHAR ('_')) { 436 | T->text = parse.lex.ptr; 437 | T->len = parse.lex.len; 438 | T->flags = parse.lex.flags; 439 | parse_lex (); 440 | PARSE_OK; 441 | } else { 442 | parse_error ("Can not parse var ident opt"); 443 | PARSE_FAIL; 444 | } 445 | } 446 | 447 | struct tree *parse_nat_const (void) { 448 | PARSE_INIT (type_nat_const); 449 | if (parse.lex.type == lex_num) { 450 | T->text = parse.lex.ptr; 451 | T->len = parse.lex.len; 452 | T->flags = parse.lex.flags; 453 | parse_lex (); 454 | PARSE_OK; 455 | } else { 456 | parse_error ("Can not parse nat const"); 457 | PARSE_FAIL; 458 | } 459 | } 460 | 461 | struct tree *parse_type_ident (void) { 462 | PARSE_INIT (type_type_ident); 463 | if (parse.lex.type == lex_uc_ident && !(parse.lex.flags & 2)) { 464 | T->text = parse.lex.ptr; 465 | T->len = parse.lex.len; 466 | T->flags = parse.lex.flags; 467 | parse_lex (); 468 | PARSE_OK; 469 | } else if (parse.lex.type == lex_lc_ident && !(parse.lex.flags & 2)) { 470 | T->text = parse.lex.ptr; 471 | T->len = parse.lex.len; 472 | T->flags = parse.lex.flags; 473 | parse_lex (); 474 | PARSE_OK; 475 | } else if (LEX_CHAR ('#')) { 476 | T->text = parse.lex.ptr; 477 | T->len = parse.lex.len; 478 | T->flags = parse.lex.flags; 479 | parse_lex (); 480 | PARSE_OK; 481 | } else { 482 | parse_error ("Can not parse type ident"); 483 | PARSE_FAIL; 484 | } 485 | } 486 | 487 | struct tree *parse_term (void) { 488 | PARSE_INIT (type_term); 489 | while (LEX_CHAR ('%')) { 490 | EXPECT ("%") 491 | PARSE_ADD (type_percent); 492 | } 493 | if (LEX_CHAR ('(')) { 494 | EXPECT ("("); 495 | PARSE_TRY_PES (parse_expr); 496 | EXPECT (")"); 497 | PARSE_OK; 498 | } 499 | PARSE_TRY (parse_type_ident); 500 | if (S) { 501 | tree_add_child (T, S); 502 | if (LEX_CHAR ('<')) { 503 | EXPECT ("<"); 504 | while (1) { 505 | PARSE_TRY_PES (parse_expr); 506 | if (LEX_CHAR ('>')) { break; } 507 | EXPECT (","); 508 | } 509 | EXPECT (">"); 510 | } 511 | PARSE_OK; 512 | } 513 | PARSE_TRY_OPT (parse_type_ident); 514 | PARSE_TRY_OPT (parse_var_ident); 515 | PARSE_TRY_OPT (parse_nat_const); 516 | PARSE_FAIL; 517 | } 518 | 519 | struct tree *parse_nat_term (void) { 520 | PARSE_INIT (type_nat_term); 521 | PARSE_TRY_PES (parse_term); 522 | PARSE_OK; 523 | } 524 | 525 | struct tree *parse_subexpr (void) { 526 | PARSE_INIT (type_subexpr); 527 | int was_term = 0; 528 | int cc = 0; 529 | 530 | while (1) { 531 | PARSE_TRY (parse_nat_const); 532 | if (S) { 533 | tree_add_child (T, S); 534 | } else if (!was_term) { 535 | was_term = 1; 536 | PARSE_TRY (parse_term); 537 | if (S) { 538 | tree_add_child (T, S); 539 | } else { 540 | break; 541 | } 542 | } 543 | cc ++; 544 | if (!LEX_CHAR ('+')) { 545 | break; 546 | } 547 | EXPECT ("+"); 548 | } 549 | if (!cc) { 550 | PARSE_FAIL; 551 | } else { 552 | PARSE_OK; 553 | } 554 | } 555 | 556 | struct tree *parse_expr (void) { 557 | PARSE_INIT (type_expr); 558 | int cc = 0; 559 | while (1) { 560 | PARSE_TRY (parse_subexpr); 561 | if (S) { 562 | tree_add_child (T, S); 563 | cc ++; 564 | } else { 565 | if (cc < 1) { PARSE_FAIL; } 566 | else { PARSE_OK; } 567 | } 568 | } 569 | } 570 | 571 | 572 | 573 | struct tree *parse_final_empty (void) { 574 | PARSE_INIT (type_final_empty); 575 | EXPECT ("Empty"); 576 | PARSE_TRY_PES (parse_boxed_type_ident); 577 | PARSE_OK; 578 | } 579 | 580 | struct tree *parse_final_new (void) { 581 | PARSE_INIT (type_final_new); 582 | EXPECT ("New"); 583 | PARSE_TRY_PES (parse_boxed_type_ident); 584 | PARSE_OK; 585 | } 586 | 587 | struct tree *parse_final_final (void) { 588 | PARSE_INIT (type_final_final); 589 | EXPECT ("Final"); 590 | PARSE_TRY_PES (parse_boxed_type_ident); 591 | PARSE_OK; 592 | } 593 | 594 | struct tree *parse_partial_comb_app_decl (void) { 595 | PARSE_INIT (type_partial_comb_app_decl); 596 | PARSE_TRY_PES (parse_combinator_id); 597 | while (1) { 598 | PARSE_TRY_PES (parse_subexpr); 599 | if (LEX_CHAR (';')) { break; } 600 | } 601 | PARSE_OK; 602 | } 603 | 604 | struct tree *parse_partial_type_app_decl (void) { 605 | PARSE_INIT (type_partial_type_app_decl); 606 | PARSE_TRY_PES (parse_boxed_type_ident); 607 | if (LEX_CHAR ('<')) { 608 | EXPECT ("<"); 609 | while (1) { 610 | PARSE_TRY_PES (parse_expr); 611 | if (LEX_CHAR ('>')) { break; } 612 | EXPECT (","); 613 | } 614 | EXPECT (">"); 615 | PARSE_OK; 616 | } else { 617 | while (1) { 618 | PARSE_TRY_PES (parse_subexpr); 619 | if (LEX_CHAR (';')) { break; } 620 | } 621 | PARSE_OK; 622 | } 623 | } 624 | 625 | 626 | 627 | 628 | struct tree *parse_multiplicity (void) { 629 | PARSE_INIT (type_multiplicity); 630 | PARSE_TRY_PES (parse_nat_term); 631 | PARSE_OK; 632 | } 633 | 634 | 635 | struct tree *parse_type_term (void) { 636 | PARSE_INIT (type_type_term); 637 | PARSE_TRY_PES (parse_term); 638 | PARSE_OK; 639 | } 640 | 641 | struct tree *parse_optional_arg_def (void) { 642 | PARSE_INIT (type_optional_arg_def); 643 | PARSE_TRY_PES (parse_var_ident); 644 | EXPECT ("."); 645 | PARSE_TRY_PES (parse_nat_const); 646 | EXPECT ("?"); 647 | PARSE_OK; 648 | } 649 | 650 | struct tree *parse_args4 (void) { 651 | PARSE_INIT (type_args4); 652 | struct parse so = save_parse (); 653 | PARSE_TRY (parse_optional_arg_def); 654 | if (S) { 655 | tree_add_child (T, S); 656 | } else { 657 | load_parse (so); 658 | } 659 | if (LEX_CHAR ('!')) { 660 | PARSE_ADD (type_exclam); 661 | EXPECT ("!"); 662 | } 663 | PARSE_TRY_PES (parse_type_term); 664 | PARSE_OK; 665 | } 666 | 667 | struct tree *parse_args3 (void) { 668 | PARSE_INIT (type_args3); 669 | PARSE_TRY_PES (parse_var_ident_opt); 670 | EXPECT (":"); 671 | struct parse so = save_parse (); 672 | PARSE_TRY (parse_optional_arg_def); 673 | if (S) { 674 | tree_add_child (T, S); 675 | } else { 676 | load_parse (so); 677 | } 678 | if (LEX_CHAR ('!')) { 679 | PARSE_ADD (type_exclam); 680 | EXPECT ("!"); 681 | } 682 | PARSE_TRY_PES (parse_type_term); 683 | PARSE_OK; 684 | } 685 | 686 | struct tree *parse_args2 (void) { 687 | PARSE_INIT (type_args2); 688 | PARSE_TRY (parse_var_ident_opt); 689 | if (S && LEX_CHAR (':')) { 690 | tree_add_child (T, S); 691 | EXPECT (":"); 692 | } else { 693 | load_parse (save); 694 | } 695 | struct parse so = save_parse (); 696 | PARSE_TRY (parse_optional_arg_def); 697 | if (S) { 698 | tree_add_child (T, S); 699 | } else { 700 | load_parse (so); 701 | } 702 | struct parse save2 = save_parse (); 703 | PARSE_TRY (parse_multiplicity); 704 | if (S && LEX_CHAR ('*')) { 705 | tree_add_child (T, S); 706 | EXPECT ("*"); 707 | } else { 708 | load_parse (save2); 709 | } 710 | EXPECT ("["); 711 | while (1) { 712 | if (LEX_CHAR (']')) { break; } 713 | PARSE_TRY_PES (parse_args); 714 | } 715 | EXPECT ("]"); 716 | PARSE_OK; 717 | } 718 | 719 | struct tree *parse_args1 (void) { 720 | PARSE_INIT (type_args1); 721 | EXPECT ("("); 722 | while (1) { 723 | PARSE_TRY_PES (parse_var_ident_opt); 724 | if (LEX_CHAR(':')) { break; } 725 | } 726 | EXPECT (":"); 727 | struct parse so = save_parse (); 728 | PARSE_TRY (parse_optional_arg_def); 729 | if (S) { 730 | tree_add_child (T, S); 731 | } else { 732 | load_parse (so); 733 | } 734 | if (LEX_CHAR ('!')) { 735 | PARSE_ADD (type_exclam); 736 | EXPECT ("!"); 737 | } 738 | PARSE_TRY_PES (parse_type_term); 739 | EXPECT (")"); 740 | PARSE_OK; 741 | } 742 | 743 | struct tree *parse_args (void) { 744 | PARSE_INIT (type_args); 745 | PARSE_TRY_OPT (parse_args1); 746 | PARSE_TRY_OPT (parse_args2); 747 | PARSE_TRY_OPT (parse_args3); 748 | PARSE_TRY_OPT (parse_args4); 749 | PARSE_FAIL; 750 | } 751 | 752 | struct tree *parse_opt_args (void) { 753 | PARSE_INIT (type_opt_args); 754 | while (1) { 755 | PARSE_TRY_PES (parse_var_ident); 756 | if (parse.lex.type == lex_char && *parse.lex.ptr == ':') { break;} 757 | } 758 | EXPECT (":"); 759 | PARSE_TRY_PES (parse_type_term); 760 | PARSE_OK; 761 | } 762 | 763 | struct tree *parse_final_decl (void) { 764 | PARSE_INIT (type_final_decl); 765 | PARSE_TRY_OPT (parse_final_new); 766 | PARSE_TRY_OPT (parse_final_final); 767 | PARSE_TRY_OPT (parse_final_empty); 768 | PARSE_FAIL; 769 | } 770 | 771 | struct tree *parse_partial_app_decl (void) { 772 | PARSE_INIT (type_partial_app_decl); 773 | PARSE_TRY_OPT (parse_partial_type_app_decl); 774 | PARSE_TRY_OPT (parse_partial_comb_app_decl); 775 | PARSE_FAIL; 776 | } 777 | 778 | struct tree *parse_result_type (void) { 779 | PARSE_INIT (type_result_type); 780 | PARSE_TRY_PES (parse_boxed_type_ident); 781 | if (LEX_CHAR ('<')) { 782 | EXPECT ("<"); 783 | while (1) { 784 | PARSE_TRY_PES (parse_expr); 785 | if (LEX_CHAR ('>')) { break; } 786 | EXPECT (","); 787 | } 788 | EXPECT (">"); 789 | PARSE_OK; 790 | } else { 791 | while (1) { 792 | if (LEX_CHAR (';')) { PARSE_OK; } 793 | PARSE_TRY_PES (parse_subexpr); 794 | } 795 | } 796 | } 797 | 798 | struct tree *parse_combinator_decl (void) { 799 | PARSE_INIT (type_combinator_decl); 800 | PARSE_TRY_PES (parse_full_combinator_id) 801 | while (1) { 802 | if (LEX_CHAR ('{')) { 803 | parse_lex (); 804 | PARSE_TRY_PES (parse_opt_args); 805 | EXPECT ("}"); 806 | } else { 807 | break; 808 | } 809 | } 810 | while (1) { 811 | if (LEX_CHAR ('=')) { break; } 812 | PARSE_TRY_PES (parse_args); 813 | } 814 | EXPECT ("="); 815 | PARSE_ADD (type_equals); 816 | 817 | PARSE_TRY_PES (parse_result_type); 818 | PARSE_OK; 819 | } 820 | 821 | struct tree *parse_builtin_combinator_decl (void) { 822 | PARSE_INIT (type_builtin_combinator_decl); 823 | PARSE_TRY_PES (parse_full_combinator_id) 824 | EXPECT ("?"); 825 | EXPECT ("="); 826 | PARSE_TRY_PES (parse_boxed_type_ident); 827 | PARSE_OK; 828 | } 829 | 830 | struct tree *parse_declaration (void) { 831 | PARSE_INIT (type_declaration); 832 | PARSE_TRY_OPT (parse_combinator_decl); 833 | PARSE_TRY_OPT (parse_partial_app_decl); 834 | PARSE_TRY_OPT (parse_final_decl); 835 | PARSE_TRY_OPT (parse_builtin_combinator_decl); 836 | PARSE_FAIL; 837 | } 838 | 839 | struct tree *parse_constr_declarations (void) { 840 | PARSE_INIT (type_constr_declarations); 841 | if (parse.lex.type == lex_triple_minus || parse.lex.type == lex_eof) { PARSE_OK; } 842 | while (1) { 843 | PARSE_TRY_PES (parse_declaration); 844 | EXPECT (";"); 845 | if (parse.lex.type == lex_eof || parse.lex.type == lex_triple_minus) { PARSE_OK; } 846 | } 847 | } 848 | 849 | struct tree *parse_fun_declarations (void) { 850 | PARSE_INIT (type_fun_declarations); 851 | if (parse.lex.type == lex_triple_minus || parse.lex.type == lex_eof) { PARSE_OK; } 852 | while (1) { 853 | PARSE_TRY_PES (parse_declaration); 854 | EXPECT (";"); 855 | if (parse.lex.type == lex_eof || parse.lex.type == lex_triple_minus) { PARSE_OK; } 856 | } 857 | } 858 | 859 | struct tree *parse_program (void) { 860 | PARSE_INIT (type_tl_program); 861 | while (1) { 862 | PARSE_TRY_PES (parse_constr_declarations); 863 | if (parse.lex.type == lex_eof) { PARSE_OK; } 864 | if (parse.lex.type == lex_error || expect ("---") < 0 || expect ("functions") < 0 || expect ("---") < 0) { PARSE_FAIL; } 865 | 866 | PARSE_TRY_PES (parse_fun_declarations); 867 | if (parse.lex.type == lex_eof) { PARSE_OK; } 868 | if (parse.lex.type == lex_error || expect ("---") < 0 || expect ("types") < 0 || expect ("---") < 0) { PARSE_FAIL; } 869 | } 870 | } 871 | 872 | struct tree *tl_parse_lex (struct parse *_parse) { 873 | assert (_parse); 874 | load_parse (*_parse); 875 | if (parse.lex.type == lex_none) { 876 | parse_lex (); 877 | } 878 | if (parse.lex.type == lex_error) { 879 | return 0; 880 | } 881 | return parse_program (); 882 | } 883 | 884 | int mystrcmp2 (const char *b, int len, const char *a) { 885 | int c = strncmp (b, a, len); 886 | return c ? a[len] ? -1 : 0 : c; 887 | } 888 | 889 | char *mystrdup (const char *a, int len) { 890 | char *z = talloc (len + 1); 891 | memcpy (z, a, len); 892 | z[len] = 0; 893 | return z; 894 | } 895 | 896 | struct tl_program *tl_program_cur; 897 | #define TL_TRY_PES(x) if (!(x)) { return 0; } 898 | 899 | #define tl_type_cmp(a,b) (strcmp (a->id, b->id)) 900 | DEFINE_TREE (tl_type,struct tl_type *,tl_type_cmp,0) 901 | struct tree_tl_type *tl_type_tree; 902 | 903 | DEFINE_TREE (tl_constructor,struct tl_constructor *,tl_type_cmp,0) 904 | struct tree_tl_constructor *tl_constructor_tree; 905 | struct tree_tl_constructor *tl_function_tree; 906 | 907 | DEFINE_TREE (tl_var,struct tl_var *,tl_type_cmp,0) 908 | 909 | struct tl_var_value { 910 | struct tl_combinator_tree *ptr; 911 | struct tl_combinator_tree *val; 912 | int num_val; 913 | }; 914 | 915 | #define tl_var_value_cmp(a,b) (((char *)a.ptr) - ((char *)b.ptr)) 916 | struct tl_var_value empty; 917 | DEFINE_TREE (var_value, struct tl_var_value, tl_var_value_cmp, empty) 918 | //tree_tl_var_t *tl_var_tree; 919 | 920 | DEFINE_TREE (tl_field,char *,strcmp, 0) 921 | //tree_tl_field_t *tl_field_tree; 922 | #define TL_FAIL return 0; 923 | #define TL_INIT(x) struct tl_combinator_tree *x = 0; 924 | #define TL_TRY(f,x) { struct tl_combinator_tree *_t = f; if (!_t) { TL_FAIL;} x = tl_union (x, _t); if (!x) { TL_FAIL; }} 925 | #define TL_ERROR(...) fprintf (stderr, __VA_ARGS__); 926 | #define TL_WARNING(...) fprintf (stderr, __VA_ARGS__); 927 | 928 | void tl_set_var_value (struct tree_var_value **T, struct tl_combinator_tree *var, struct tl_combinator_tree *value) { 929 | struct tl_var_value t = {.ptr = var, .val = value, .num_val = 0}; 930 | if (tree_lookup_var_value (*T, t).ptr) { 931 | *T = tree_delete_var_value (*T, t); 932 | } 933 | *T = tree_insert_var_value (*T, t, lrand48 ()); 934 | } 935 | 936 | 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) { 937 | struct tl_var_value t = {.ptr = var, .val = value, .num_val = num_value}; 938 | if (tree_lookup_var_value (*T, t).ptr) { 939 | *T = tree_delete_var_value (*T, t); 940 | } 941 | *T = tree_insert_var_value (*T, t, lrand48 ()); 942 | } 943 | 944 | struct tl_combinator_tree *tl_get_var_value (struct tree_var_value **T, struct tl_combinator_tree *var) { 945 | struct tl_var_value t = {.ptr = var, .val = 0, .num_val = 0}; 946 | struct tl_var_value r = tree_lookup_var_value (*T, t); 947 | return r.ptr ? r.val : 0; 948 | } 949 | 950 | int tl_get_var_value_num (struct tree_var_value **T, struct tl_combinator_tree *var) { 951 | struct tl_var_value t = {.ptr = var, .val = 0}; 952 | struct tl_var_value r = tree_lookup_var_value (*T, t); 953 | return r.ptr ? r.num_val : 0; 954 | } 955 | 956 | int namespace_level; 957 | 958 | struct tree_tl_var *vars[10]; 959 | struct tree_tl_field *fields[10]; 960 | struct tl_var *last_num_var[10]; 961 | 962 | int tl_is_type_name (const char *id, int len) { 963 | if (len == 1 && *id == '#') { return 1;} 964 | int ok = id[0] >= 'A' && id[0] <= 'Z'; 965 | int i; 966 | for (i = 0; i < len - 1; i++) if (id[i] == '.') { 967 | ok = id[i + 1] >= 'A' && id[i + 1] <= 'Z'; 968 | } 969 | return ok; 970 | } 971 | 972 | int tl_add_field (char *id) { 973 | assert (namespace_level < 10); 974 | assert (namespace_level >= 0); 975 | if (tree_lookup_tl_field (fields[namespace_level], id)) { 976 | return 0; 977 | } 978 | fields[namespace_level] = tree_insert_tl_field (fields[namespace_level], id, lrand48 ()); 979 | return 1; 980 | } 981 | 982 | void tl_clear_fields (void) { 983 | // tree_act_tl_field (fields[namespace_level], (void *)free); 984 | fields[namespace_level] = tree_clear_tl_field (fields[namespace_level]); 985 | } 986 | 987 | struct tl_var *tl_add_var (char *id, struct tl_combinator_tree *ptr, int type) { 988 | struct tl_var *v = talloc (sizeof (*v)); 989 | v->id = tstrdup (id); 990 | v->type = type; 991 | v->ptr = ptr; 992 | v->flags = 0; 993 | if (tree_lookup_tl_var (vars[namespace_level], v)) { 994 | return 0; 995 | } 996 | vars[namespace_level] = tree_insert_tl_var (vars[namespace_level], v, lrand48 ()); 997 | if (type) { 998 | last_num_var[namespace_level] = v; 999 | } 1000 | return v; 1001 | } 1002 | 1003 | void tl_del_var (struct tl_var *v) { 1004 | // free (v->id); 1005 | tfree (v, sizeof (*v)); 1006 | } 1007 | 1008 | void tl_clear_vars (void) { 1009 | tree_act_tl_var (vars[namespace_level], tl_del_var); 1010 | vars[namespace_level] = tree_clear_tl_var (vars[namespace_level]); 1011 | last_num_var[namespace_level] = 0; 1012 | } 1013 | 1014 | struct tl_var *tl_get_last_num_var (void) { 1015 | return last_num_var[namespace_level]; 1016 | } 1017 | 1018 | struct tl_var *tl_get_var (char *_id, int len) { 1019 | char *id = mystrdup (_id, len); 1020 | struct tl_var v = {.id = id}; 1021 | int i; 1022 | for (i = namespace_level; i >= 0; i--) { 1023 | struct tl_var *w = tree_lookup_tl_var (vars[i], &v); 1024 | if (w) { 1025 | tfree (id, len + 1); 1026 | return w; 1027 | } 1028 | } 1029 | tfree (id, len + 1); 1030 | return 0; 1031 | } 1032 | 1033 | void namespace_push (void) { 1034 | namespace_level ++; 1035 | assert (namespace_level < 10); 1036 | tl_clear_vars (); 1037 | tl_clear_fields (); 1038 | } 1039 | 1040 | void namespace_pop (void) { 1041 | namespace_level --; 1042 | assert (namespace_level >= 0); 1043 | } 1044 | 1045 | struct tl_type *tl_get_type (const char *_id, int len) { 1046 | char *id = mystrdup (_id, len); 1047 | struct tl_type _t = {.id = id}; 1048 | struct tl_type *r = tree_lookup_tl_type (tl_type_tree, &_t); 1049 | tfree (id, len + 1); 1050 | return r; 1051 | } 1052 | 1053 | struct tl_type *tl_add_type (const char *_id, int len, int params_num, long long params_types) { 1054 | char *id = talloc (len + 1); 1055 | memcpy (id, _id, len); 1056 | id[len] = 0; 1057 | struct tl_type _t = {.id = id}; 1058 | struct tl_type *_r = 0; 1059 | if ((_r = tree_lookup_tl_type (tl_type_tree, &_t))) { 1060 | tfree (id, len + 1); 1061 | if (params_num >= 0 && (_r->params_num != params_num || _r->params_types != params_types)) { 1062 | TL_ERROR ("Wrong params_num or types for type %s\n", _r->id); 1063 | return 0; 1064 | } 1065 | return _r; 1066 | } 1067 | struct tl_type *t = talloc (sizeof (*t)); 1068 | t->id = id; 1069 | t->print_id = tstrdup (t->id); 1070 | int i; 1071 | for (i = 0; i < len; i++) if (t->print_id[i] == '.' || t->print_id[i] == '#' || t->print_id[i] == ' ') { 1072 | t->print_id[i] = '$'; 1073 | } 1074 | t->name = 0; 1075 | t->constructors_num = 0; 1076 | t->constructors = 0; 1077 | t->flags = 0; 1078 | t->real_id = 0; 1079 | if (params_num >= 0) { 1080 | assert (params_num <= 64); 1081 | t->params_num = params_num; 1082 | t->params_types = params_types; 1083 | } else { 1084 | t->flags |= 4; 1085 | t->params_num = -1; 1086 | } 1087 | tl_type_tree = tree_insert_tl_type (tl_type_tree, t, lrand48 ()); 1088 | total_types_num ++; 1089 | return t; 1090 | } 1091 | 1092 | void tl_add_type_param (struct tl_type *t, int x) { 1093 | assert (t->flags & 4); 1094 | assert (t->params_num <= 64); 1095 | if (x) { 1096 | t->params_types |= (1ull << (t->params_num ++)); 1097 | } else { 1098 | t->params_num ++; 1099 | } 1100 | } 1101 | 1102 | int tl_type_set_params (struct tl_type *t, int x, long long y) { 1103 | if (t->flags & 4) { 1104 | t->params_num = x; 1105 | t->params_types = y; 1106 | t->flags &= ~4; 1107 | } else { 1108 | if (t->params_num != x || t->params_types != y) { 1109 | fprintf (stderr, "Wrong num of params (type %s)\n", t->id); 1110 | return 0; 1111 | } 1112 | } 1113 | return 1; 1114 | } 1115 | 1116 | void tl_type_finalize (struct tl_type *t) { 1117 | t->flags &= ~4; 1118 | } 1119 | 1120 | struct tl_constructor *tl_get_constructor (const char *_id, int len) { 1121 | char *id = mystrdup (_id, len); 1122 | struct tl_constructor _t = {.id = id}; 1123 | struct tl_constructor *r = tree_lookup_tl_constructor (tl_constructor_tree, &_t); 1124 | tfree (id, len + 1); 1125 | return r; 1126 | } 1127 | 1128 | struct tl_constructor *tl_add_constructor (struct tl_type *a, const char *_id, int len, int force_magic) { 1129 | assert (a); 1130 | if (a->flags & 1) { 1131 | TL_ERROR ("New constructor for type `%s` after final statement\n", a->id); 1132 | return 0; 1133 | } 1134 | int x = 0; 1135 | while (x < len && (_id[x] != '#' || force_magic)) { x++; } 1136 | char *id = talloc (x + 1); 1137 | memcpy (id, _id, x); 1138 | id[x] = 0; 1139 | 1140 | unsigned magic = 0; 1141 | if (x < len) { 1142 | assert (len - x >= 6 && len - x <= 9); 1143 | int i; 1144 | for (i = 1; i < len - x; i++) { 1145 | magic = (magic << 4) + (_id[x + i] <= '9' ? _id[x + i] - '0' : _id[x + i] - 'a' + 10); 1146 | } 1147 | assert (magic && magic != (unsigned)-1); 1148 | } 1149 | 1150 | len = x; 1151 | if (*id != '_') { 1152 | struct tl_constructor _t = {.id = id}; 1153 | if (tree_lookup_tl_constructor (tl_constructor_tree, &_t)) { 1154 | TL_ERROR ("Duplicate constructor id `%s`\n", id); 1155 | tfree (id, len + 1); 1156 | return 0; 1157 | } 1158 | } else { 1159 | assert (len == 1); 1160 | } 1161 | 1162 | struct tl_constructor *t = talloc (sizeof (*t)); 1163 | t->type = a; 1164 | t->name = magic; 1165 | t->id = id; 1166 | t->print_id = tstrdup (id); 1167 | t->real_id = 0; 1168 | 1169 | int i; 1170 | for (i = 0; i < len; i++) if (t->print_id[i] == '.' || t->print_id[i] == '#' || t->print_id[i] == ' ') { 1171 | t->print_id[i] = '$'; 1172 | } 1173 | 1174 | t->left = t->right = 0; 1175 | a->constructors = realloc (a->constructors, sizeof (void *) * (a->constructors_num + 1)); 1176 | assert (a->constructors); 1177 | a->constructors[a->constructors_num ++] = t; 1178 | if (*id != '_') { 1179 | tl_constructor_tree = tree_insert_tl_constructor (tl_constructor_tree, t, lrand48 ()); 1180 | } else { 1181 | a->flags |= FLAG_DEFAULT_CONSTRUCTOR; 1182 | } 1183 | total_constructors_num ++; 1184 | return t; 1185 | } 1186 | 1187 | struct tl_constructor *tl_get_function (const char *_id, int len) { 1188 | char *id = mystrdup (_id, len); 1189 | struct tl_constructor _t = {.id = id}; 1190 | struct tl_constructor *r = tree_lookup_tl_constructor (tl_function_tree, &_t); 1191 | tfree (id, len + 1); 1192 | return r; 1193 | } 1194 | 1195 | struct tl_constructor *tl_add_function (struct tl_type *a, const char *_id, int len, int force_magic) { 1196 | // assert (a); 1197 | int x = 0; 1198 | while (x < len && ((_id[x] != '#') || force_magic)) { x++; } 1199 | char *id = talloc (x + 1); 1200 | memcpy (id, _id, x); 1201 | id[x] = 0; 1202 | 1203 | unsigned magic = 0; 1204 | if (x < len) { 1205 | assert (len - x >= 6 && len - x <= 9); 1206 | int i; 1207 | for (i = 1; i < len - x; i++) { 1208 | magic = (magic << 4) + (_id[x + i] <= '9' ? _id[x + i] - '0' : _id[x + i] - 'a' + 10); 1209 | } 1210 | assert (magic && magic != (unsigned)-1); 1211 | } 1212 | 1213 | len = x; 1214 | 1215 | struct tl_constructor _t = {.id = id}; 1216 | if (tree_lookup_tl_constructor (tl_function_tree, &_t)) { 1217 | TL_ERROR ("Duplicate function id `%s`\n", id); 1218 | tfree (id, len + 1); 1219 | return 0; 1220 | } 1221 | 1222 | struct tl_constructor *t = talloc (sizeof (*t)); 1223 | t->type = a; 1224 | t->name = magic; 1225 | t->id = id; 1226 | t->print_id = tstrdup (id); 1227 | t->real_id = 0; 1228 | 1229 | int i; 1230 | for (i = 0; i < len; i++) if (t->print_id[i] == '.' || t->print_id[i] == '#' || t->print_id[i] == ' ') { 1231 | t->print_id[i] = '$'; 1232 | } 1233 | 1234 | t->left = t->right = 0; 1235 | tl_function_tree = tree_insert_tl_constructor (tl_function_tree, t, lrand48 ()); 1236 | total_functions_num ++; 1237 | return t; 1238 | } 1239 | 1240 | static char buf[(1 << 20)]; 1241 | int buf_pos; 1242 | 1243 | struct tl_combinator_tree *alloc_ctree_node (void) { 1244 | struct tl_combinator_tree *T = talloc (sizeof (*T)); 1245 | assert (T); 1246 | memset (T, 0, sizeof (*T)); 1247 | return T; 1248 | } 1249 | 1250 | struct tl_combinator_tree *tl_tree_dup (struct tl_combinator_tree *T) { 1251 | if (!T) { return 0; } 1252 | struct tl_combinator_tree *S = talloc (sizeof (*S)); 1253 | memcpy (S, T, sizeof (*S)); 1254 | S->left = tl_tree_dup (T->left); 1255 | S->right = tl_tree_dup (T->right); 1256 | return S; 1257 | } 1258 | 1259 | struct tl_type *tl_tree_get_type (struct tl_combinator_tree *T) { 1260 | assert (T->type == type_type); 1261 | if (T->act == act_array) { return 0;} 1262 | while (T->left) { 1263 | T = T->left; 1264 | if (T->act == act_array) { return 0;} 1265 | assert (T->type == type_type); 1266 | } 1267 | assert (T->act == act_type || T->act == act_var || T->act == act_array); 1268 | return T->act == act_type ? T->data : 0; 1269 | } 1270 | 1271 | void tl_tree_set_len (struct tl_combinator_tree *T) { 1272 | TL_INIT (H); 1273 | H = T; 1274 | while (H->left) { 1275 | H->left->type_len = H->type_len + 1; 1276 | H = H->left; 1277 | } 1278 | assert (H->type == type_type); 1279 | struct tl_type *t = H->data; 1280 | assert (t); 1281 | assert (H->type_len == t->params_num); 1282 | } 1283 | 1284 | void tl_buf_reset (void) { 1285 | buf_pos = 0; 1286 | } 1287 | 1288 | void tl_buf_add_string (char *s, int len) { 1289 | if (len < 0) { len = strlen (s); } 1290 | buf[buf_pos ++] = ' '; 1291 | memcpy (buf + buf_pos, s, len); buf_pos += len; 1292 | buf[buf_pos] = 0; 1293 | } 1294 | 1295 | void tl_buf_add_string_nospace (char *s, int len) { 1296 | if (len < 0) { len = strlen (s); } 1297 | // if (buf_pos) { buf[buf_pos ++] = ' '; } 1298 | memcpy (buf + buf_pos, s, len); buf_pos += len; 1299 | buf[buf_pos] = 0; 1300 | } 1301 | 1302 | void tl_buf_add_string_q (char *s, int len, int x) { 1303 | if (x) { 1304 | tl_buf_add_string (s, len); 1305 | } else { 1306 | tl_buf_add_string_nospace (s, len); 1307 | } 1308 | } 1309 | 1310 | 1311 | void tl_buf_add_tree (struct tl_combinator_tree *T, int x) { 1312 | if (!T) { return; } 1313 | assert (T != (void *)-1l && T != (void *)-2l); 1314 | switch (T->act) { 1315 | case act_question_mark: 1316 | tl_buf_add_string_q ("?", -1, x); 1317 | return; 1318 | case act_type: 1319 | if ((T->flags & 1) && !(T->flags & 4)) { 1320 | tl_buf_add_string_q ("%", -1, x); 1321 | x = 0; 1322 | } 1323 | if (T->flags & 2) { 1324 | tl_buf_add_string_q ((char *)T->data, -1, x); 1325 | } else { 1326 | struct tl_type *t = T->data; 1327 | if (T->flags & 4) { 1328 | assert (t->constructors_num == 1); 1329 | tl_buf_add_string_q (t->constructors[0]->real_id ? t->constructors[0]->real_id : t->constructors[0]->id, -1, x); 1330 | } else { 1331 | tl_buf_add_string_q (t->real_id ? t->real_id : t->id, -1, x); 1332 | } 1333 | } 1334 | return; 1335 | case act_field: 1336 | if (T->data) { 1337 | tl_buf_add_string_q ((char *)T->data, -1, x); 1338 | x = 0; 1339 | tl_buf_add_string_q (":", -1, 0); 1340 | } 1341 | tl_buf_add_tree (T->left, x); 1342 | tl_buf_add_tree (T->right, 1); 1343 | return; 1344 | case act_union: 1345 | tl_buf_add_tree (T->left, x); 1346 | tl_buf_add_tree (T->right, 1); 1347 | return; 1348 | case act_var: 1349 | { 1350 | if (T->data == (void *)-1l) { return; } 1351 | struct tl_combinator_tree *v = T->data; 1352 | tl_buf_add_string_q ((char *)v->data, -1, x); 1353 | if (T->type == type_num && T->type_flags) { 1354 | static char _buf[30]; 1355 | sprintf (_buf, "+%lld", T->type_flags); 1356 | tl_buf_add_string_q (_buf, -1, 0); 1357 | } 1358 | } 1359 | return; 1360 | case act_arg: 1361 | tl_buf_add_tree (T->left, x); 1362 | tl_buf_add_tree (T->right, 1); 1363 | return; 1364 | case act_array: 1365 | if (T->left && !(T->left->flags & 128)) { 1366 | tl_buf_add_tree (T->left, x); 1367 | x = 0; 1368 | tl_buf_add_string_q ("*", -1, x); 1369 | } 1370 | tl_buf_add_string_q ("[", -1, x); 1371 | tl_buf_add_tree (T->right, 1); 1372 | tl_buf_add_string_q ("]", -1, 1); 1373 | return; 1374 | case act_plus: 1375 | tl_buf_add_tree (T->left, x); 1376 | tl_buf_add_string_q ("+", -1, 0); 1377 | tl_buf_add_tree (T->right, 0); 1378 | return; 1379 | case act_nat_const: 1380 | { 1381 | static char _buf[30]; 1382 | snprintf (_buf, 29, "%lld", T->type_flags); 1383 | tl_buf_add_string_q (_buf, -1, x); 1384 | return; 1385 | } 1386 | case act_opt_field: 1387 | { 1388 | struct tl_combinator_tree *v = T->left->data; 1389 | tl_buf_add_string_q ((char *)v->data, -1, x); 1390 | tl_buf_add_string_q (".", -1, 0); 1391 | static char _buf[30]; 1392 | sprintf (_buf, "%lld", T->left->type_flags); 1393 | tl_buf_add_string_q (_buf, -1, 0); 1394 | tl_buf_add_string_q ("?", -1, 0); 1395 | tl_buf_add_tree (T->right, 0); 1396 | return; 1397 | } 1398 | 1399 | default: 1400 | fprintf (stderr, "%s %s\n", TL_ACT (T->act), TL_TYPE (T->type)); 1401 | assert (0); 1402 | return; 1403 | } 1404 | } 1405 | 1406 | int tl_count_combinator_name (struct tl_constructor *c) { 1407 | assert (c); 1408 | tl_buf_reset (); 1409 | tl_buf_add_string_nospace (c->real_id ? c->real_id : c->id, -1); 1410 | tl_buf_add_tree (c->left, 1); 1411 | tl_buf_add_string ("=", -1); 1412 | tl_buf_add_tree (c->right, 1); 1413 | //fprintf (stderr, "%.*s\n", buf_pos, buf); 1414 | if (!c->name) { 1415 | c->name = crc32 (CRC32_INITIAL, (void *) buf, buf_pos); 1416 | } 1417 | return c->name; 1418 | } 1419 | 1420 | int tl_print_combinator (struct tl_constructor *c) { 1421 | tl_buf_reset (); 1422 | tl_buf_add_string_nospace (c->real_id ? c->real_id : c->id, -1); 1423 | static char _buf[10]; 1424 | sprintf (_buf, "#%08x", c->name); 1425 | tl_buf_add_string_nospace (_buf, -1); 1426 | tl_buf_add_tree (c->left, 1); 1427 | tl_buf_add_string ("=", -1); 1428 | tl_buf_add_tree (c->right, 1); 1429 | if (output_expressions >= 1) { 1430 | fprintf (stderr, "%.*s\n", buf_pos, buf); 1431 | } 1432 | /* if (!c->name) { 1433 | c->name = crc32 (CRC32_INITIAL, (void *) bbuf, buf_pos); 1434 | }*/ 1435 | return c->name; 1436 | } 1437 | 1438 | int _tl_finish_subtree (struct tl_combinator_tree *R, int x, long long y) { 1439 | assert (R->type == type_type); 1440 | assert (R->type_len < 0); 1441 | assert (R->act == act_arg || R->act == act_type); 1442 | R->type_len = x; 1443 | R->type_flags = y; 1444 | if (R->act == act_type) { 1445 | struct tl_type *t = R->data; 1446 | assert (t); 1447 | return tl_type_set_params (t, x, y); 1448 | } 1449 | assert ((R->right->type == type_type && R->right->type_len == 0) || R->right->type == type_num || R->right->type == type_num_value); 1450 | return _tl_finish_subtree (R->left, x + 1, y * 2 + (R->right->type == type_num || R->right->type == type_num_value)); 1451 | } 1452 | 1453 | int tl_finish_subtree (struct tl_combinator_tree *R) { 1454 | assert (R); 1455 | if (R->type != type_type) { 1456 | return 1; 1457 | } 1458 | if (R->type_len >= 0) { 1459 | if (R->type_len > 0) { 1460 | TL_ERROR ("Not enough params\n"); 1461 | return 0; 1462 | } 1463 | return 1; 1464 | } 1465 | return _tl_finish_subtree (R, 0, 0); 1466 | } 1467 | 1468 | struct tl_combinator_tree *tl_union (struct tl_combinator_tree *L, struct tl_combinator_tree *R) { 1469 | if (!L) { return R; } 1470 | if (!R) { return L; } 1471 | TL_INIT (v); 1472 | v = alloc_ctree_node (); 1473 | v->left = L; 1474 | v->right = R; 1475 | switch (L->type) { 1476 | case type_num: 1477 | if (R->type != type_num_value) { 1478 | TL_ERROR ("Union: type mistmatch\n"); 1479 | return 0; 1480 | } 1481 | tfree (v, sizeof (*v)); 1482 | L->type_flags += R->type_flags; 1483 | return L; 1484 | case type_num_value: 1485 | if (R->type != type_num_value && R->type != type_num) { 1486 | TL_ERROR ("Union: type mistmatch\n"); 1487 | return 0; 1488 | } 1489 | tfree (v, sizeof (*v)); 1490 | R->type_flags += L->type_flags; 1491 | return R; 1492 | case type_list_item: 1493 | case type_list: 1494 | if (R->type != type_list_item) { 1495 | TL_ERROR ("Union: type mistmatch\n"); 1496 | return 0; 1497 | } 1498 | v->type = type_list; 1499 | v->act = act_union; 1500 | return v; 1501 | case type_type: 1502 | if (L->type_len == 0) { 1503 | TL_ERROR ("Arguments number exceeds type arity\n"); 1504 | return 0; 1505 | } 1506 | if (R->type != type_num && R->type != type_type && R->type != type_num_value) { 1507 | TL_ERROR ("Union: type mistmatch\n"); 1508 | return 0; 1509 | } 1510 | if (R->type_len < 0) { 1511 | if (!tl_finish_subtree (R)) { 1512 | return 0; 1513 | } 1514 | } 1515 | if (R->type_len > 0) { 1516 | TL_ERROR ("Argument type must have full number of arguments\n"); 1517 | return 0; 1518 | } 1519 | if (L->type_len > 0 && ((L->type_flags & 1) != (R->type == type_num || R->type == type_num_value))) { 1520 | TL_ERROR ("Argument types mistmatch: L->type_flags = %lld, R->type = %s\n", L->flags, TL_TYPE (R->type)); 1521 | return 0; 1522 | } 1523 | v->type = type_type; 1524 | v->act = act_arg; 1525 | v->type_len = L->type_len > 0 ? L->type_len - 1 : -1; 1526 | v->type_flags = L->type_flags >> 1; 1527 | return v; 1528 | default: 1529 | assert (0); 1530 | return 0; 1531 | } 1532 | } 1533 | 1534 | struct tl_combinator_tree *tl_parse_any_term (struct tree *T, int s); 1535 | struct tl_combinator_tree *tl_parse_term (struct tree *T, int s) { 1536 | assert (T->type == type_term); 1537 | int i = 0; 1538 | while (i < T->nc && T->c[i]->type == type_percent) { i ++; s ++; } 1539 | assert (i < T->nc); 1540 | TL_INIT (L); 1541 | while (i < T->nc) { 1542 | TL_TRY (tl_parse_any_term (T->c[i], s), L); 1543 | s = 0; 1544 | i ++; 1545 | } 1546 | return L; 1547 | } 1548 | 1549 | 1550 | struct tl_combinator_tree *tl_parse_type_term (struct tree *T, int s) { 1551 | assert (T->type == type_type_term); 1552 | assert (T->nc == 1); 1553 | struct tl_combinator_tree *Z = tl_parse_term (T->c[0], s); 1554 | if (!Z || Z->type != type_type) { if (Z) { TL_ERROR ("type_term: found type %s\n", TL_TYPE (Z->type)); } TL_FAIL; } 1555 | return Z; 1556 | } 1557 | 1558 | struct tl_combinator_tree *tl_parse_nat_term (struct tree *T, int s) { 1559 | assert (T->type == type_nat_term); 1560 | assert (T->nc == 1); 1561 | struct tl_combinator_tree *Z = tl_parse_term (T->c[0], s); 1562 | 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; } 1563 | return Z; 1564 | } 1565 | 1566 | struct tl_combinator_tree *tl_parse_subexpr (struct tree *T, int s) { 1567 | assert (T->type == type_subexpr); 1568 | assert (T->nc >= 1); 1569 | int i; 1570 | TL_INIT (L); 1571 | for (i = 0; i < T->nc; i++) { 1572 | TL_TRY (tl_parse_any_term (T->c[i], s), L); 1573 | s = 0; 1574 | } 1575 | return L; 1576 | } 1577 | 1578 | struct tl_combinator_tree *tl_parse_expr (struct tree *T, int s) { 1579 | assert (T->type == type_expr); 1580 | assert (T->nc >= 1); 1581 | int i; 1582 | TL_INIT (L); 1583 | for (i = 0; i < T->nc; i++) { 1584 | TL_TRY (tl_parse_subexpr (T->c[i], s), L); 1585 | s = 0; 1586 | } 1587 | return L; 1588 | } 1589 | 1590 | struct tl_combinator_tree *tl_parse_nat_const (struct tree *T, int s) { 1591 | assert (T->type == type_nat_const); 1592 | assert (!T->nc); 1593 | if (s > 0) { 1594 | TL_ERROR ("Nat const can not preceed with %%\n"); 1595 | TL_FAIL; 1596 | } 1597 | assert (T->type == type_nat_const); 1598 | assert (!T->nc); 1599 | TL_INIT (L); 1600 | L = alloc_ctree_node (); 1601 | L->act = act_nat_const; 1602 | L->type = type_num_value; 1603 | int i; 1604 | long long x = 0; 1605 | for (i = 0; i < T->len; i++) { 1606 | x = x * 10 + T->text[i] - '0'; 1607 | } 1608 | L->type_flags = x; 1609 | return L; 1610 | } 1611 | 1612 | struct tl_combinator_tree *tl_parse_ident (struct tree *T, int s) { 1613 | assert (T->type == type_type_ident || T->type == type_var_ident || T->type == type_boxed_type_ident); 1614 | assert (!T->nc); 1615 | struct tl_var *v = tl_get_var (T->text, T->len); 1616 | TL_INIT (L); 1617 | if (v) { 1618 | L = alloc_ctree_node (); 1619 | L->act = act_var; 1620 | L->type = v->type ? type_num : type_type; 1621 | if (L->type == type_num && s) { 1622 | TL_ERROR ("Nat var can not preceed with %%\n"); 1623 | TL_FAIL; 1624 | } else { 1625 | if (s) { 1626 | L->flags |= 1; 1627 | } 1628 | } 1629 | L->type_len = 0; 1630 | L->type_flags = 0; 1631 | L->data = v->ptr; 1632 | return L; 1633 | } 1634 | 1635 | /* if (!mystrcmp2 (T->text, T->len, "#") || !mystrcmp2 (T->text, T->len, "Type")) { 1636 | L = alloc_ctree_node (); 1637 | L->act = act_type; 1638 | L->flags |= 2; 1639 | L->data = tl_get_type (T->text, T->len); 1640 | assert (L->data); 1641 | L->type = type_type; 1642 | L->type_len = 0; 1643 | L->type_flags = 0; 1644 | return L; 1645 | }*/ 1646 | 1647 | struct tl_constructor *c = tl_get_constructor (T->text, T->len); 1648 | if (c) { 1649 | assert (c->type); 1650 | if (c->type->constructors_num != 1) { 1651 | TL_ERROR ("Constructor can be used only if it is the only constructor of the type\n"); 1652 | return 0; 1653 | } 1654 | c->type->flags |= 1; 1655 | L = alloc_ctree_node (); 1656 | L->act = act_type; 1657 | L->flags |= 5; 1658 | L->data = c->type; 1659 | L->type = type_type; 1660 | L->type_len = c->type->params_num; 1661 | L->type_flags = c->type->params_types; 1662 | return L; 1663 | } 1664 | int x = tl_is_type_name (T->text, T->len); 1665 | if (x) { 1666 | struct tl_type *t = tl_add_type (T->text, T->len, -1, 0); 1667 | L = alloc_ctree_node (); 1668 | if (s) { 1669 | L->flags |= 1; 1670 | t->flags |= 8; 1671 | } 1672 | L->act = act_type; 1673 | L->data = t; 1674 | L->type = type_type; 1675 | L->type_len = t->params_num; 1676 | L->type_flags = t->params_types; 1677 | return L; 1678 | } else { 1679 | TL_ERROR ("Not a type/var ident `%.*s`\n", T->len, T->text); 1680 | return 0; 1681 | } 1682 | } 1683 | 1684 | struct tl_combinator_tree *tl_parse_any_term (struct tree *T, int s) { 1685 | switch (T->type) { 1686 | case type_type_term: 1687 | return tl_parse_type_term (T, s); 1688 | case type_nat_term: 1689 | return tl_parse_nat_term (T, s); 1690 | case type_term: 1691 | return tl_parse_term (T, s); 1692 | case type_expr: 1693 | return tl_parse_expr (T, s); 1694 | case type_subexpr: 1695 | return tl_parse_subexpr (T, s); 1696 | case type_nat_const: 1697 | return tl_parse_nat_const (T, s); 1698 | case type_type_ident: 1699 | case type_var_ident: 1700 | return tl_parse_ident (T, s); 1701 | default: 1702 | fprintf (stderr, "type = %d\n", T->type); 1703 | assert (0); 1704 | return 0; 1705 | } 1706 | } 1707 | 1708 | struct tl_combinator_tree *tl_parse_multiplicity (struct tree *T) { 1709 | assert (T->type == type_multiplicity); 1710 | assert (T->nc == 1); 1711 | return tl_parse_nat_term (T->c[0], 0); 1712 | } 1713 | 1714 | struct tl_combinator_tree *tl_parse_opt_args (struct tree *T) { 1715 | assert (T); 1716 | assert (T->type == type_opt_args); 1717 | assert (T->nc >= 2); 1718 | TL_INIT (R); 1719 | TL_TRY (tl_parse_type_term (T->c[T->nc - 1], 0), R); 1720 | assert (R->type == type_type && !R->type_len); 1721 | assert (tl_finish_subtree (R)); 1722 | struct tl_type *t = tl_tree_get_type (R); 1723 | //assert (t); 1724 | int tt = -1; 1725 | if (t && !strcmp (t->id, "#")) { 1726 | tt = 1; 1727 | } else if (t && !strcmp (t->id, "Type")) { 1728 | tt = 0; 1729 | } 1730 | if (tt < 0) { 1731 | TL_ERROR ("Optargs can be only of type # or Type\n"); 1732 | TL_FAIL; 1733 | } 1734 | 1735 | int i; 1736 | for (i = 0; i < T->nc - 1; i++) { 1737 | if (T->c[i]->type != type_var_ident) { 1738 | TL_ERROR ("Variable name expected\n"); 1739 | TL_FAIL; 1740 | } 1741 | if (T->c[i]->len == 1 && *T->c[i]->text == '_') { 1742 | TL_ERROR ("Variables can not be unnamed\n"); 1743 | TL_FAIL; 1744 | } 1745 | } 1746 | TL_INIT (H); 1747 | // for (i = T->nc - 2; i >= (T->nc >= 2 ? 0 : -1); i--) { 1748 | for (i = 0; i <= T->nc - 2; i++) { 1749 | TL_INIT (S); S = alloc_ctree_node (); 1750 | S->left = (i == T->nc - 2) ? R : tl_tree_dup (R) ; S->right = 0; 1751 | S->type = type_list_item; 1752 | S->type_len = 0; 1753 | S->act = act_field; 1754 | S->data = i >= 0 ? mystrdup (T->c[i]->text, T->c[i]->len) : 0; 1755 | if (tt >= 0) { 1756 | assert (S->data); 1757 | tl_add_var (S->data, S, tt); 1758 | } 1759 | S->flags = 33; 1760 | H = tl_union (H, S); 1761 | } 1762 | return H; 1763 | } 1764 | 1765 | struct tl_combinator_tree *tl_parse_args (struct tree *T); 1766 | struct tl_combinator_tree *tl_parse_args2 (struct tree *T) { 1767 | assert (T); 1768 | assert (T->type == type_args2); 1769 | assert (T->nc >= 1); 1770 | TL_INIT (R); 1771 | TL_INIT (L); 1772 | int x = 0; 1773 | char *field_name = 0; 1774 | if (T->c[x]->type == type_var_ident_opt || T->c[x]->type == type_var_ident) { 1775 | field_name = mystrdup (T->c[x]->text, T->c[x]->len); 1776 | if (!tl_add_field (field_name)) { 1777 | TL_ERROR ("Duplicate field name %s\n", field_name); 1778 | TL_FAIL; 1779 | } 1780 | x ++; 1781 | } 1782 | //fprintf (stderr, "%d %d\n", x, T->nc); 1783 | if (T->c[x]->type == type_multiplicity) { 1784 | L = tl_parse_multiplicity (T->c[x]); 1785 | if (!L) { TL_FAIL;} 1786 | x ++; 1787 | } else { 1788 | struct tl_var *v = tl_get_last_num_var (); 1789 | if (!v) { 1790 | TL_ERROR ("Expected multiplicity or nat var\n"); 1791 | TL_FAIL; 1792 | } 1793 | L = alloc_ctree_node (); 1794 | L->act = act_var; 1795 | L->type = type_num; 1796 | L->flags |= 128; 1797 | L->type_len = 0; 1798 | L->type_flags = 0; 1799 | L->data = v->ptr; 1800 | ((struct tl_combinator_tree *)(v->ptr))->flags |= 256; 1801 | } 1802 | namespace_push (); 1803 | while (x < T->nc) { 1804 | TL_TRY (tl_parse_args (T->c[x]), R); 1805 | x ++; 1806 | } 1807 | namespace_pop (); 1808 | struct tl_combinator_tree *S = alloc_ctree_node (); 1809 | S->type = type_type; 1810 | S->type_len = 0; 1811 | S->act = act_array; 1812 | S->left = L; 1813 | S->right = R; 1814 | //S->data = field_name; 1815 | 1816 | struct tl_combinator_tree *H = alloc_ctree_node (); 1817 | H->type = type_list_item; 1818 | H->act = act_field; 1819 | H->left = S; 1820 | H->right = 0; 1821 | H->data = field_name; 1822 | H->type_len = 0; 1823 | 1824 | return H; 1825 | } 1826 | 1827 | void tl_mark_vars (struct tl_combinator_tree *T); 1828 | struct tl_combinator_tree *tl_parse_args134 (struct tree *T) { 1829 | assert (T); 1830 | assert (T->type == type_args1 || T->type == type_args3 || T->type == type_args4); 1831 | assert (T->nc >= 1); 1832 | TL_INIT (R); 1833 | TL_TRY (tl_parse_type_term (T->c[T->nc - 1], 0), R); 1834 | assert (tl_finish_subtree (R)); 1835 | assert (R->type == type_type && !R->type_len); 1836 | struct tl_type *t = tl_tree_get_type (R); 1837 | //assert (t); 1838 | int tt = -1; 1839 | if (t && !strcmp (t->id, "#")) { 1840 | tt = 1; 1841 | } else if (t && !strcmp (t->id, "Type")) { 1842 | tt = 0; 1843 | } 1844 | 1845 | /* if (tt >= 0 && T->nc == 1) { 1846 | TL_ERROR ("Variables can not be unnamed (type %d)\n", tt); 1847 | }*/ 1848 | int last = T->nc - 2; 1849 | int excl = 0; 1850 | if (last >= 0 && T->c[last]->type == type_exclam) { 1851 | excl ++; 1852 | tl_mark_vars (R); 1853 | last --; 1854 | } 1855 | if (last >= 0 && T->c[last]->type == type_optional_arg_def) { 1856 | assert (T->c[last]->nc == 2); 1857 | TL_INIT (E); E = alloc_ctree_node (); 1858 | E->type = type_type; 1859 | E->act = act_opt_field; 1860 | E->left = tl_parse_ident (T->c[last]->c[0], 0); 1861 | int i; 1862 | long long x = 0; 1863 | for (i = 0; i < T->c[last]->c[1]->len; i++) { 1864 | x = x * 10 + T->c[last]->c[1]->text[i] - '0'; 1865 | } 1866 | E->left->type_flags = x; 1867 | E->type_flags = R->type_flags; 1868 | E->type_len = R->type_len; 1869 | E->right = R; 1870 | R = E; 1871 | last --; 1872 | } 1873 | int i; 1874 | for (i = 0; i < last; i++) { 1875 | if (T->c[i]->type != type_var_ident && T->c[i]->type != type_var_ident_opt) { 1876 | TL_ERROR ("Variable name expected\n"); 1877 | TL_FAIL; 1878 | } 1879 | /* if (tt >= 0 && (T->nc == 1 || (T->c[i]->len == 1 && *T->c[i]->text == '_'))) { 1880 | TL_ERROR ("Variables can not be unnamed\n"); 1881 | TL_FAIL; 1882 | }*/ 1883 | } 1884 | TL_INIT (H); 1885 | // for (i = T->nc - 2; i >= (T->nc >= 2 ? 0 : -1); i--) { 1886 | for (i = (last >= 0 ? 0 : -1); i <= last; i++) { 1887 | TL_INIT (S); S = alloc_ctree_node (); 1888 | S->left = (i == last) ? R : tl_tree_dup (R) ; S->right = 0; 1889 | S->type = type_list_item; 1890 | S->type_len = 0; 1891 | S->act = act_field; 1892 | S->data = i >= 0 ? mystrdup (T->c[i]->text, T->c[i]->len) : 0; 1893 | if (excl) { 1894 | S->flags |= FLAG_EXCL; 1895 | } 1896 | if (S->data && (T->c[i]->len >= 2 || *T->c[i]->text != '_')) { 1897 | if (!tl_add_field (S->data)) { 1898 | TL_ERROR ("Duplicate field name %s\n", (char *)S->data); 1899 | TL_FAIL; 1900 | } 1901 | } 1902 | if (tt >= 0) { 1903 | //assert (S->data); 1904 | char *name = S->data; 1905 | if (!name) { 1906 | static char s[20]; 1907 | sprintf (s, "%lld", lrand48 () * (1ll << 32) + lrand48 ()); 1908 | name = s; 1909 | } 1910 | struct tl_var *v = tl_add_var (name, S, tt); 1911 | if (!v) {TL_FAIL;} 1912 | v->flags |= 2; 1913 | } 1914 | 1915 | H = tl_union (H, S); 1916 | } 1917 | return H; 1918 | } 1919 | 1920 | 1921 | struct tl_combinator_tree *tl_parse_args (struct tree *T) { 1922 | assert (T->type == type_args); 1923 | assert (T->nc == 1); 1924 | switch (T->c[0]->type) { 1925 | case type_args1: 1926 | return tl_parse_args134 (T->c[0]); 1927 | case type_args2: 1928 | return tl_parse_args2 (T->c[0]); 1929 | case type_args3: 1930 | return tl_parse_args134 (T->c[0]); 1931 | case type_args4: 1932 | return tl_parse_args134 (T->c[0]); 1933 | default: 1934 | assert (0); 1935 | return 0; 1936 | } 1937 | } 1938 | 1939 | void tl_mark_vars (struct tl_combinator_tree *T) { 1940 | if (!T) { return; } 1941 | if (T->act == act_var) { 1942 | char *id = ((struct tl_combinator_tree *)(T->data))->data; 1943 | struct tl_var *v = tl_get_var (id, strlen (id)); 1944 | assert (v); 1945 | v->flags |= 1; 1946 | } 1947 | tl_mark_vars (T->left); 1948 | tl_mark_vars (T->right); 1949 | } 1950 | 1951 | struct tl_combinator_tree *tl_parse_result_type (struct tree *T) { 1952 | assert (T->type == type_result_type); 1953 | assert (T->nc >= 1); 1954 | assert (T->nc <= 64); 1955 | 1956 | TL_INIT (L); 1957 | 1958 | if (tl_get_var (T->c[0]->text, T->c[0]->len)) { 1959 | if (T->nc != 1) { 1960 | TL_ERROR ("Variable can not take params\n"); 1961 | TL_FAIL; 1962 | } 1963 | L = alloc_ctree_node (); 1964 | L->act = act_var; 1965 | L->type = type_type; 1966 | struct tl_var *v = tl_get_var (T->c[0]->text, T->c[0]->len); 1967 | if (v->type) { 1968 | TL_ERROR ("Type mistmatch\n"); 1969 | TL_FAIL; 1970 | } 1971 | L->data = v->ptr; 1972 | // assert (v->ptr); 1973 | } else { 1974 | L = alloc_ctree_node (); 1975 | L->act = act_type; 1976 | L->type = type_type; 1977 | struct tl_type *t = tl_add_type (T->c[0]->text, T->c[0]->len, -1, 0); 1978 | assert (t); 1979 | L->type_len = t->params_num; 1980 | L->type_flags = t->params_types; 1981 | L->data = t; 1982 | 1983 | int i; 1984 | for (i = 1; i < T->nc; i++) { 1985 | TL_TRY (tl_parse_any_term (T->c[i], 0), L); 1986 | assert (L->right); 1987 | assert (L->right->type == type_num || L->right->type == type_num_value || (L->right->type == type_type && L->right->type_len == 0)); 1988 | } 1989 | } 1990 | 1991 | if (!tl_finish_subtree (L)) { 1992 | TL_FAIL; 1993 | } 1994 | 1995 | tl_mark_vars (L); 1996 | return L; 1997 | } 1998 | 1999 | int __ok; 2000 | void tl_var_check_used (struct tl_var *v) { 2001 | __ok = __ok && (v->flags & 3); 2002 | } 2003 | 2004 | int tl_parse_combinator_decl (struct tree *T, int fun) { 2005 | assert (T->type == type_combinator_decl); 2006 | assert (T->nc >= 3); 2007 | namespace_level = 0; 2008 | tl_clear_vars (); 2009 | tl_clear_fields (); 2010 | TL_INIT (L); 2011 | TL_INIT (R); 2012 | 2013 | int i = 1; 2014 | while (i < T->nc - 2 && T->c[i]->type == type_opt_args) { 2015 | TL_TRY (tl_parse_opt_args (T->c[i]), L); 2016 | i++; 2017 | } 2018 | while (i < T->nc - 2 && T->c[i]->type == type_args) { 2019 | TL_TRY (tl_parse_args (T->c[i]), L); 2020 | i++; 2021 | } 2022 | assert (i == T->nc - 2 && T->c[i]->type == type_equals); 2023 | i ++; 2024 | 2025 | R = tl_parse_result_type (T->c[i]); 2026 | if (!R) { TL_FAIL; } 2027 | 2028 | struct tl_type *t = tl_tree_get_type (R); 2029 | if (!fun && !t) { 2030 | TL_ERROR ("Only functions can return variables\n"); 2031 | } 2032 | assert (t || fun); 2033 | 2034 | assert (namespace_level == 0); 2035 | __ok = 1; 2036 | tree_act_tl_var (vars[0], tl_var_check_used); 2037 | if (!__ok) { 2038 | TL_ERROR ("Not all variables are used in right side\n"); 2039 | TL_FAIL; 2040 | } 2041 | 2042 | if (tl_get_constructor (T->c[0]->text, T->c[0]->len) || tl_get_function (T->c[0]->text, T->c[0]->len)) { 2043 | TL_ERROR ("Duplicate combinator id %.*s\n", T->c[0]->len, T->c[0]->text); 2044 | return 0; 2045 | } 2046 | 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); 2047 | if (!c) { TL_FAIL; } 2048 | c->left = L; 2049 | c->right = R; 2050 | 2051 | if (!c->name) { 2052 | tl_count_combinator_name (c); 2053 | } 2054 | tl_print_combinator (c); 2055 | 2056 | return 1; 2057 | } 2058 | 2059 | void change_var_ptrs (struct tl_combinator_tree *O, struct tl_combinator_tree *D, struct tree_var_value **V) { 2060 | if (!O || !D) { 2061 | assert (!O && !D); 2062 | return; 2063 | } 2064 | if (O->act == act_field) { 2065 | struct tl_type *t = tl_tree_get_type (O->left); 2066 | if (t && (!strcmp (t->id, "#") || !strcmp (t->id, "Type"))) { 2067 | tl_set_var_value (V, O, D); 2068 | } 2069 | } 2070 | if (O->act == act_var) { 2071 | assert (D->data == O->data); 2072 | D->data = tl_get_var_value (V, O->data); 2073 | assert (D->data); 2074 | } 2075 | change_var_ptrs (O->left, D->left, V); 2076 | change_var_ptrs (O->right, D->right, V); 2077 | } 2078 | 2079 | struct tl_combinator_tree *change_first_var (struct tl_combinator_tree *O, struct tl_combinator_tree **X, struct tl_combinator_tree *Y) { 2080 | if (!O) { return (void *)-2l; }; 2081 | if (O->act == act_field && !*X) { 2082 | struct tl_type *t = tl_tree_get_type (O->left); 2083 | if (t && !strcmp (t->id, "#")) { 2084 | if (Y->type != type_num && Y->type != type_num_value) { 2085 | TL_ERROR ("change_var: Type mistmatch\n"); 2086 | return 0; 2087 | } else { 2088 | *X = O; 2089 | return (void *)-1l; 2090 | } 2091 | } 2092 | if (t && !strcmp (t->id, "Type")) { 2093 | if (Y->type != type_type || Y->type_len != 0) { 2094 | TL_ERROR ("change_var: Type mistmatch\n"); 2095 | return 0; 2096 | } else { 2097 | *X = O; 2098 | return (void *)-1l; 2099 | } 2100 | } 2101 | } 2102 | if (O->act == act_var) { 2103 | if (O->data == *X) { 2104 | struct tl_combinator_tree *R = tl_tree_dup (Y); 2105 | if (O->type == type_num || O->type == type_num_value) { R->type_flags += O->type_flags; } 2106 | return R; 2107 | } 2108 | } 2109 | struct tl_combinator_tree *t; 2110 | t = change_first_var (O->left, X, Y); 2111 | if (!t) { return 0;} 2112 | if (t == (void *)-1l) { 2113 | t = change_first_var (O->right, X, Y); 2114 | if (!t) { return 0;} 2115 | if (t == (void *)-1l) { return (void *)-1l; } 2116 | if (t != (void *)-2l) { return t;} 2117 | return (void *)-1l; 2118 | } 2119 | if (t != (void *)-2l) { 2120 | O->left = t; 2121 | } 2122 | t = change_first_var (O->right, X, Y); 2123 | if (!t) { return 0;} 2124 | if (t == (void *)-1l) { 2125 | return O->left; 2126 | } 2127 | if (t != (void *)-2l) { 2128 | O->right = t; 2129 | } 2130 | return O; 2131 | } 2132 | 2133 | 2134 | int uniformize (struct tl_combinator_tree *L, struct tl_combinator_tree *R, struct tree_var_value **T); 2135 | struct tree_var_value **_T; 2136 | int __tok; 2137 | void check_nat_val (struct tl_var_value v) { 2138 | if (!__tok) { return; } 2139 | long long x = v.num_val; 2140 | struct tl_combinator_tree *L = v.val; 2141 | if (L->type == type_type) { return;} 2142 | while (1) { 2143 | if (L->type == type_num_value) { 2144 | if (x + L->type_flags < 0) { 2145 | __tok = 0; 2146 | return; 2147 | } else { 2148 | return; 2149 | } 2150 | } 2151 | assert (L->type == type_num); 2152 | x += L->type_flags; 2153 | x += tl_get_var_value_num (_T, L->data); 2154 | L = tl_get_var_value (_T, L->data); 2155 | if (!L) { return;} 2156 | } 2157 | } 2158 | 2159 | int check_constructors_equal (struct tl_combinator_tree *L, struct tl_combinator_tree *R, struct tree_var_value **T) { 2160 | if (!uniformize (L, R, T)) { return 0; } 2161 | __tok = 1; 2162 | _T = T; 2163 | tree_act_var_value (*T, check_nat_val); 2164 | return __tok; 2165 | } 2166 | 2167 | struct tl_combinator_tree *reduce_type (struct tl_combinator_tree *A, struct tl_type *t) { 2168 | assert (A); 2169 | if (A->type_len == t->params_num) { 2170 | assert (A->type_flags == t->params_types); 2171 | A->act = act_type; 2172 | A->type = type_type; 2173 | A->left = A->right = 0; 2174 | A->data = t; 2175 | return A; 2176 | } 2177 | A->left = reduce_type (A->left, t); 2178 | return A; 2179 | } 2180 | 2181 | struct tl_combinator_tree *change_value_var (struct tl_combinator_tree *O, struct tree_var_value **X) { 2182 | if (!O) { return (void *)-2l; }; 2183 | while (O->act == act_var) { 2184 | assert (O->data); 2185 | if (!tl_get_var_value (X, O->data)) { 2186 | break; 2187 | } 2188 | if (O->type == type_type) { 2189 | O = tl_tree_dup (tl_get_var_value (X, O->data)); 2190 | } else { 2191 | long long n = tl_get_var_value_num (X, O->data); 2192 | struct tl_combinator_tree *T = tl_get_var_value (X, O->data); 2193 | O->data = T->data; 2194 | O->type = T->type; 2195 | O->act = T->act; 2196 | O->type_flags = O->type_flags + n + T->type_flags; 2197 | } 2198 | } 2199 | if (O->act == act_field) { 2200 | if (tl_get_var_value (X, O)) { return (void *)-1l; } 2201 | } 2202 | struct tl_combinator_tree *t; 2203 | t = change_value_var (O->left, X); 2204 | if (!t) { return 0;} 2205 | if (t == (void *)-1l) { 2206 | t = change_value_var (O->right, X); 2207 | if (!t) { return 0;} 2208 | if (t == (void *)-1l) { return (void *)-1l; } 2209 | if (t != (void *)-2l) { return t;} 2210 | return (void *)-1l; 2211 | } 2212 | if (t != (void *)-2l) { 2213 | O->left = t; 2214 | } 2215 | t = change_value_var (O->right, X); 2216 | if (!t) { return 0;} 2217 | if (t == (void *)-1l) { 2218 | return O->left; 2219 | } 2220 | if (t != (void *)-2l) { 2221 | O->right = t; 2222 | } 2223 | return O; 2224 | } 2225 | 2226 | int tl_parse_partial_type_app_decl (struct tree *T) { 2227 | assert (T->type == type_partial_type_app_decl); 2228 | assert (T->nc >= 1); 2229 | 2230 | assert (T->c[0]->type == type_boxed_type_ident); 2231 | struct tl_type *t = tl_get_type (T->c[0]->text, T->c[0]->len); 2232 | if (!t) { 2233 | TL_ERROR ("Can not make partial app for unknown type\n"); 2234 | return 0; 2235 | } 2236 | 2237 | tl_type_finalize (t); 2238 | 2239 | struct tl_combinator_tree *L = tl_parse_ident (T->c[0], 0); 2240 | assert (L); 2241 | int i; 2242 | tl_buf_reset (); 2243 | int cc = T->nc - 1; 2244 | for (i = 1; i < T->nc; i++) { 2245 | TL_TRY (tl_parse_any_term (T->c[i], 0), L); 2246 | tl_buf_add_tree (L->right, 1); 2247 | } 2248 | 2249 | while (L->type_len) { 2250 | struct tl_combinator_tree *C = alloc_ctree_node (); 2251 | C->act = act_var; 2252 | C->type = (L->type_flags & 1) ? type_num : type_type; 2253 | C->type_len = 0; 2254 | C->type_flags = 0; 2255 | C->data = (void *)-1l; 2256 | L = tl_union (L, C); 2257 | if (!L) { return 0; } 2258 | } 2259 | 2260 | 2261 | static char _buf[100000]; 2262 | snprintf (_buf, 100000, "%s%.*s", t->id, buf_pos, buf); 2263 | struct tl_type *nt = tl_add_type (_buf, strlen (_buf), t->params_num - cc, t->params_types >> cc); 2264 | assert (nt); 2265 | //snprintf (_buf, 100000, "%s #", t->id); 2266 | //nt->real_id = strdup (_buf); 2267 | 2268 | for (i = 0; i < t->constructors_num; i++) { 2269 | struct tl_constructor *c = t->constructors[i]; 2270 | struct tree_var_value *V = 0; 2271 | TL_INIT (A); 2272 | TL_INIT (B); 2273 | A = tl_tree_dup (c->left); 2274 | B = tl_tree_dup (c->right); 2275 | 2276 | struct tree_var_value *W = 0; 2277 | change_var_ptrs (c->left, A, &W); 2278 | change_var_ptrs (c->right, B, &W); 2279 | 2280 | 2281 | if (!check_constructors_equal (B, L, &V)) { continue; } 2282 | B = reduce_type (B, nt); 2283 | A = change_value_var (A, &V); 2284 | if (A == (void *)-1l) { A = 0;} 2285 | B = change_value_var (B, &V); 2286 | assert (B != (void *)-1l); 2287 | snprintf (_buf, 100000, "%s%.*s", c->id, buf_pos, buf); 2288 | 2289 | struct tl_constructor *r = tl_add_constructor (nt, _buf, strlen (_buf), 1); 2290 | snprintf (_buf, 100000, "%s", c->id); 2291 | r->real_id = tstrdup (_buf); 2292 | 2293 | r->left = A; 2294 | r->right = B; 2295 | if (!r->name) { 2296 | tl_count_combinator_name (r); 2297 | } 2298 | tl_print_combinator (r); 2299 | } 2300 | 2301 | return 1; 2302 | } 2303 | 2304 | int tl_parse_partial_comb_app_decl (struct tree *T, int fun) { 2305 | assert (T->type == type_partial_comb_app_decl); 2306 | 2307 | 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); 2308 | if (!c) { 2309 | TL_ERROR ("Can not make partial app for undefined combinator\n"); 2310 | return 0; 2311 | } 2312 | 2313 | //TL_INIT (K); 2314 | //static char buf[1000]; 2315 | //int x = sprintf (buf, "%s", c->id); 2316 | TL_INIT (L); 2317 | TL_INIT (R); 2318 | L = tl_tree_dup (c->left); 2319 | R = tl_tree_dup (c->right); 2320 | 2321 | 2322 | struct tree_var_value *V = 0; 2323 | change_var_ptrs (c->left, L, &V); 2324 | change_var_ptrs (c->right, R, &V); 2325 | V = tree_clear_var_value (V); 2326 | 2327 | int i; 2328 | tl_buf_reset (); 2329 | for (i = 1; i < T->nc; i++) { 2330 | TL_INIT (X); 2331 | TL_INIT (Z); 2332 | X = tl_parse_any_term (T->c[i], 0); 2333 | struct tl_combinator_tree *K = 0; 2334 | if (!(Z = change_first_var (L, &K, X))) { 2335 | TL_FAIL; 2336 | } 2337 | L = Z; 2338 | if (!K) { 2339 | TL_ERROR ("Partial app: not enougth variables (i = %d)\n", i); 2340 | TL_FAIL; 2341 | } 2342 | if (!(Z = change_first_var (R, &K, X))) { 2343 | TL_FAIL; 2344 | } 2345 | assert (Z == R); 2346 | tl_buf_add_tree (X, 1); 2347 | } 2348 | 2349 | static char _buf[100000]; 2350 | snprintf (_buf, 100000, "%s%.*s", c->id, buf_pos, buf); 2351 | // fprintf (stderr, "Local id: %s\n", _buf); 2352 | 2353 | struct tl_constructor *r = !fun ? tl_add_constructor (c->type, _buf, strlen (_buf), 1) : tl_add_function (c->type, _buf, strlen (_buf), 1); 2354 | r->left = L; 2355 | r->right = R; 2356 | snprintf (_buf, 100000, "%s", c->id); 2357 | r->real_id = tstrdup (_buf); 2358 | if (!r->name) { 2359 | tl_count_combinator_name (r); 2360 | } 2361 | tl_print_combinator (r); 2362 | return 1; 2363 | } 2364 | 2365 | 2366 | int tl_parse_partial_app_decl (struct tree *T, int fun) { 2367 | assert (T->type == type_partial_app_decl); 2368 | assert (T->nc == 1); 2369 | if (T->c[0]->type == type_partial_comb_app_decl) { 2370 | return tl_parse_partial_comb_app_decl (T->c[0], fun); 2371 | } else { 2372 | if (fun) { 2373 | TL_ERROR ("Partial type app in functions block\n"); 2374 | TL_FAIL; 2375 | } 2376 | return tl_parse_partial_type_app_decl (T->c[0]); 2377 | } 2378 | } 2379 | 2380 | int tl_parse_final_final (struct tree *T) { 2381 | assert (T->type == type_final_final); 2382 | assert (T->nc == 1); 2383 | struct tl_type *R; 2384 | if ((R = tl_get_type (T->c[0]->text, T->c[0]->len))) { 2385 | R->flags |= 1; 2386 | return 1; 2387 | } else { 2388 | TL_ERROR ("Final statement for type `%.*s` before declaration\n", T->c[0]->len, T->c[0]->text); 2389 | TL_FAIL; 2390 | } 2391 | } 2392 | 2393 | int tl_parse_final_new (struct tree *T) { 2394 | assert (T->type == type_final_new); 2395 | assert (T->nc == 1); 2396 | if (tl_get_type (T->c[0]->text, T->c[0]->len)) { 2397 | TL_ERROR ("New statement: type `%.*s` already declared\n", T->c[0]->len, T->c[0]->text); 2398 | TL_FAIL; 2399 | } else { 2400 | return 1; 2401 | } 2402 | } 2403 | 2404 | int tl_parse_final_empty (struct tree *T) { 2405 | assert (T->type == type_final_empty); 2406 | assert (T->nc == 1); 2407 | if (tl_get_type (T->c[0]->text, T->c[0]->len)) { 2408 | TL_ERROR ("New statement: type `%.*s` already declared\n", T->c[0]->len, T->c[0]->text); 2409 | TL_FAIL; 2410 | } 2411 | struct tl_type *t = tl_add_type (T->c[0]->text, T->c[0]->len, 0, 0); 2412 | assert (t); 2413 | t->flags |= 1 | FLAG_EMPTY; 2414 | return 1; 2415 | } 2416 | 2417 | int tl_parse_final_decl (struct tree *T, int fun) { 2418 | assert (T->type == type_final_decl); 2419 | assert (!fun); 2420 | assert (T->nc == 1); 2421 | switch (T->c[0]->type) { 2422 | case type_final_new: 2423 | return tl_parse_final_new (T->c[0]); 2424 | case type_final_final: 2425 | return tl_parse_final_final (T->c[0]); 2426 | case type_final_empty: 2427 | return tl_parse_final_empty (T->c[0]); 2428 | default: 2429 | assert (0); 2430 | return 0; 2431 | } 2432 | } 2433 | 2434 | int tl_parse_builtin_combinator_decl (struct tree *T, int fun) { 2435 | if (fun) { 2436 | TL_ERROR ("Builtin type can not be described in function block\n"); 2437 | return -1; 2438 | } 2439 | assert (T->type == type_builtin_combinator_decl); 2440 | assert (T->nc == 2); 2441 | assert (T->c[0]->type == type_full_combinator_id); 2442 | assert (T->c[1]->type == type_boxed_type_ident); 2443 | 2444 | 2445 | if ((!mystrcmp2 (T->c[0]->text, T->c[0]->len, "int") && !mystrcmp2 (T->c[1]->text, T->c[1]->len, "Int")) || 2446 | (!mystrcmp2 (T->c[0]->text, T->c[0]->len, "long") && !mystrcmp2 (T->c[1]->text, T->c[1]->len, "Long")) || 2447 | (!mystrcmp2 (T->c[0]->text, T->c[0]->len, "double") && !mystrcmp2 (T->c[1]->text, T->c[1]->len, "Double")) || 2448 | (!mystrcmp2 (T->c[0]->text, T->c[0]->len, "string") && !mystrcmp2 (T->c[1]->text, T->c[1]->len, "String"))) { 2449 | struct tl_type *t = tl_add_type (T->c[1]->text, T->c[1]->len, 0, 0); 2450 | if (!t) { 2451 | return 0; 2452 | } 2453 | struct tl_constructor *c = tl_add_constructor (t, T->c[0]->text, T->c[0]->len, 0); 2454 | if (!c) { 2455 | return 0; 2456 | } 2457 | 2458 | c->left = alloc_ctree_node (); 2459 | c->left->act = act_question_mark; 2460 | c->left->type = type_list_item; 2461 | 2462 | c->right = alloc_ctree_node (); 2463 | c->right->act = act_type; 2464 | c->right->data = t; 2465 | c->right->type = type_type; 2466 | 2467 | if (!c->name) { 2468 | tl_count_combinator_name (c); 2469 | } 2470 | tl_print_combinator (c); 2471 | } else { 2472 | TL_ERROR ("Unknown builting type `%.*s`\n", T->c[0]->len, T->c[0]->text); 2473 | return 0; 2474 | } 2475 | 2476 | return 1; 2477 | } 2478 | 2479 | int tl_parse_declaration (struct tree *T, int fun) { 2480 | assert (T->type == type_declaration); 2481 | assert (T->nc == 1); 2482 | switch (T->c[0]->type) { 2483 | case type_combinator_decl: 2484 | return tl_parse_combinator_decl (T->c[0], fun); 2485 | case type_partial_app_decl: 2486 | return tl_parse_partial_app_decl (T->c[0], fun); 2487 | case type_final_decl: 2488 | return tl_parse_final_decl (T->c[0], fun); 2489 | case type_builtin_combinator_decl: 2490 | return tl_parse_builtin_combinator_decl (T->c[0], fun); 2491 | default: 2492 | assert (0); 2493 | return 0; 2494 | } 2495 | } 2496 | 2497 | int tl_parse_constr_declarations (struct tree *T) { 2498 | assert (T->type == type_constr_declarations); 2499 | int i; 2500 | for (i = 0; i < T->nc; i++) { 2501 | TL_TRY_PES (tl_parse_declaration (T->c[i], 0)); 2502 | } 2503 | return 1; 2504 | } 2505 | 2506 | int tl_parse_fun_declarations (struct tree *T) { 2507 | assert (T->type == type_fun_declarations); 2508 | int i; 2509 | for (i = 0; i < T->nc; i++) { 2510 | TL_TRY_PES (tl_parse_declaration (T->c[i], 1)); 2511 | } 2512 | return 1; 2513 | } 2514 | 2515 | int tl_tree_lookup_value (struct tl_combinator_tree *L, void *var, struct tree_var_value **T) { 2516 | if (!L) { 2517 | return -1; 2518 | } 2519 | if (L->act == act_var && L->data == var) { 2520 | return 0; 2521 | } 2522 | if (L->act == act_var) { 2523 | struct tl_combinator_tree *E = tl_get_var_value (T, L->data); 2524 | if (!E) { return -1;} 2525 | else { return tl_tree_lookup_value (E, var, T); } 2526 | } 2527 | if (tl_tree_lookup_value (L->left, var, T) >= 0) { return 1; } 2528 | if (tl_tree_lookup_value (L->right, var, T) >= 0) { return 1; } 2529 | return -1; 2530 | } 2531 | 2532 | int tl_tree_lookup_value_nat (struct tl_combinator_tree *L, void *var, long long x, struct tree_var_value **T) { 2533 | assert (L); 2534 | if (L->type == type_num_value) { return -1; } 2535 | assert (L->type == type_num); 2536 | assert (L->act == act_var); 2537 | if (L->data == var) { 2538 | return x == L->type_flags ? 0 : 1; 2539 | } else { 2540 | if (!tl_get_var_value (T, L->data)) { 2541 | return -1; 2542 | } 2543 | return tl_tree_lookup_value_nat (tl_get_var_value (T, L->data), var, x + tl_get_var_value_num (T, L->data), T); 2544 | } 2545 | 2546 | } 2547 | 2548 | int uniformize (struct tl_combinator_tree *L, struct tl_combinator_tree *R, struct tree_var_value **T) { 2549 | if (!L || !R) { 2550 | assert (!L && !R); 2551 | return 1; 2552 | } 2553 | if (R->act == act_var) { 2554 | struct tl_combinator_tree *_ = R; R = L; L = _; 2555 | } 2556 | 2557 | if (L->type == type_type) { 2558 | if (R->type != type_type || L->type_len != R->type_len || L->type_flags != R->type_flags) { 2559 | return 0; 2560 | } 2561 | if (R->data == (void *)-1l || L->data == (void *)-1l) { return 1;} 2562 | if (L->act == act_var) { 2563 | int x = tl_tree_lookup_value (R, L->data, T); 2564 | if (x > 0) { 2565 | // if (tl_tree_lookup_value (R, L->data, T) > 0) { 2566 | return 0; 2567 | } 2568 | if (x == 0) { 2569 | return 1; 2570 | } 2571 | struct tl_combinator_tree *E = tl_get_var_value (T, L->data); 2572 | if (!E) { 2573 | tl_set_var_value (T, L->data, R); 2574 | return 1; 2575 | } else { 2576 | return uniformize (E, R, T); 2577 | } 2578 | } else { 2579 | if (L->act != R->act || L->data != R->data) { 2580 | return 0; 2581 | } 2582 | return uniformize (L->left, R->left, T) && uniformize (L->right, R->right, T); 2583 | } 2584 | } else { 2585 | assert (L->type == type_num || L->type == type_num_value); 2586 | if (R->type != type_num && R->type != type_num_value) { 2587 | return 0; 2588 | } 2589 | assert (R->type == type_num || R->type == type_num_value); 2590 | if (R->data == (void *)-1l || L->data == (void *)-1l) { return 1;} 2591 | long long x = 0; 2592 | struct tl_combinator_tree *K = L; 2593 | while (1) { 2594 | x += K->type_flags; 2595 | if (K->type == type_num_value) { 2596 | break; 2597 | } 2598 | if (!tl_get_var_value (T, K->data)) { 2599 | int s = tl_tree_lookup_value_nat (R, K->data, K->type_flags, T); 2600 | if (s > 0) { 2601 | return 0; 2602 | } 2603 | if (s == 0) { 2604 | return 1; 2605 | } 2606 | /*tl_set_var_value_num (T, K->data, R, -x); 2607 | return 1;*/ 2608 | break; 2609 | } 2610 | x += tl_get_var_value_num (T, K->data); 2611 | K = tl_get_var_value (T, K->data); 2612 | } 2613 | long long y = 0; 2614 | struct tl_combinator_tree *M = R; 2615 | while (1) { 2616 | y += M->type_flags; 2617 | if (M->type == type_num_value) { 2618 | break; 2619 | } 2620 | if (!tl_get_var_value (T, M->data)) { 2621 | int s = tl_tree_lookup_value_nat (L, M->data, M->type_flags, T); 2622 | if (s > 0) { 2623 | return 0; 2624 | } 2625 | if (s == 0) { 2626 | return 1; 2627 | } 2628 | /*tl_set_var_value_num (T, M->data, L, -y); 2629 | return 1;*/ 2630 | break; 2631 | } 2632 | y += tl_get_var_value_num (T, M->data); 2633 | M = tl_get_var_value (T, M->data); 2634 | } 2635 | if (K->type == type_num_value && M->type == type_num_value) { 2636 | return x == y; 2637 | } 2638 | if (M->type == type_num_value) { 2639 | tl_set_var_value_num (T, K->data, M, -(x - y + M->type_flags)); 2640 | return 1; 2641 | } else if (K->type == type_num_value) { 2642 | tl_set_var_value_num (T, M->data, K, -(y - x + K->type_flags)); 2643 | return 1; 2644 | } else { 2645 | if (x >= y) { 2646 | tl_set_var_value_num (T, K->data, M, -(x - y + M->type_flags)); 2647 | } else { 2648 | tl_set_var_value_num (T, M->data, K, -(y - x + K->type_flags)); 2649 | } 2650 | return 1; 2651 | } 2652 | } 2653 | return 0; 2654 | } 2655 | 2656 | 2657 | void tl_type_check (struct tl_type *t) { 2658 | if (!__ok) return; 2659 | if (!strcmp (t->id, "#")) { t->name = 0x70659eff; return; } 2660 | if (!strcmp (t->id, "Type")) { t->name = 0x2cecf817; return; } 2661 | if (t->constructors_num <= 0 && !(t->flags & FLAG_EMPTY)) { 2662 | TL_ERROR ("Type %s has no constructors\n", t->id); 2663 | __ok = 0; 2664 | return; 2665 | } 2666 | int i, j; 2667 | t->name = 0; 2668 | for (i = 0; i < t->constructors_num; i++) { 2669 | t->name ^= t->constructors[i]->name; 2670 | } 2671 | for (i = 0; i < t->constructors_num; i++) { 2672 | for (j = i + 1; j < t->constructors_num; j++) { 2673 | struct tree_var_value *v = 0; 2674 | if (check_constructors_equal (t->constructors[i]->right, t->constructors[j]->right, &v)) { 2675 | t->flags |= 16; 2676 | } 2677 | } 2678 | } 2679 | if ((t->flags & 24) == 24) { 2680 | TL_WARNING ("Warning: Type %s has overlapping costructors, but it is used with `%%`\n", t->id); 2681 | } 2682 | int z = 0; 2683 | int sid = 0; 2684 | for (i = 0; i < t->constructors_num; i++) if (*t->constructors[i]->id == '_') { 2685 | z ++; 2686 | sid = i; 2687 | } 2688 | if (z > 1) { 2689 | TL_ERROR ("Type %s has %d default constructors\n", t->id, z); 2690 | __ok = 0; 2691 | return; 2692 | } 2693 | if (z == 1 && (t->flags & 8)) { 2694 | TL_ERROR ("Type %s has default constructors and used bare\n", t->id); 2695 | __ok = 0; 2696 | return; 2697 | } 2698 | if (z) { 2699 | struct tl_constructor *c; 2700 | c = t->constructors[sid]; 2701 | t->constructors[sid] = t->constructors[t->constructors_num - 1]; 2702 | t->constructors[t->constructors_num - 1] = c; 2703 | } 2704 | } 2705 | 2706 | struct tl_program *tl_parse (struct tree *T) { 2707 | assert (T); 2708 | assert (T->type == type_tl_program); 2709 | int i; 2710 | tl_program_cur = talloc (sizeof (*tl_program_cur)); 2711 | tl_add_type ("#", 1, 0, 0); 2712 | tl_add_type ("Type", 4, 0, 0); 2713 | for (i = 0; i < T->nc; i++) { 2714 | if (T->c[i]->type == type_constr_declarations) { TL_TRY_PES (tl_parse_constr_declarations (T->c[i])); } 2715 | else { TL_TRY_PES (tl_parse_fun_declarations (T->c[i])) } 2716 | } 2717 | __ok = 1; 2718 | tree_act_tl_type (tl_type_tree, tl_type_check); 2719 | if (!__ok) { 2720 | return 0; 2721 | } 2722 | return tl_program_cur; 2723 | } 2724 | 2725 | int __f; 2726 | int num = 0; 2727 | 2728 | void wint (int a) { 2729 | // printf ("%d ", a); 2730 | a = htole32 (a); 2731 | assert (write (__f, &a, 4) == 4); 2732 | } 2733 | 2734 | void wdata (const void *x, int len) { 2735 | assert (write (__f, x, len) == len); 2736 | } 2737 | 2738 | void wstr (const char *s) { 2739 | if (s) { 2740 | // printf ("\"%s\" ", s); 2741 | int x = strlen (s); 2742 | if (x <= 254) { 2743 | unsigned char x_c = (unsigned char)x; 2744 | assert (write (__f, &x_c, 1) == 1); 2745 | } else { 2746 | fprintf (stderr, "String is too big...\n"); 2747 | assert (0); 2748 | } 2749 | wdata (s, x); 2750 | x ++; // The header, containing the length, which is 1 byte 2751 | int t = 0; 2752 | if (x & 3) { 2753 | // Let's hope it's truly zero on every platform 2754 | wdata (&t, 4 - (x & 3)); 2755 | } 2756 | } else { 2757 | // printf (" "); 2758 | wint (0); 2759 | } 2760 | } 2761 | 2762 | void wll (long long a) { 2763 | // printf ("%lld ", a); 2764 | a = htole64 (a); 2765 | assert (write (__f, &a, 8) == 8); 2766 | } 2767 | 2768 | int count_list_size (struct tl_combinator_tree *T) { 2769 | assert (T->type == type_list || T->type == type_list_item); 2770 | if (T->type == type_list_item) { 2771 | return 1; 2772 | } else { 2773 | return count_list_size (T->left) + count_list_size (T->right); 2774 | } 2775 | } 2776 | 2777 | void write_type_flags (long long flags) { 2778 | int new_flags = 0; 2779 | if (flags & 1) { 2780 | new_flags |= FLAG_BARE; 2781 | } 2782 | if (flags & FLAG_DEFAULT_CONSTRUCTOR) { 2783 | new_flags |= FLAG_DEFAULT_CONSTRUCTOR; 2784 | } 2785 | wint (new_flags); 2786 | } 2787 | 2788 | void write_field_flags (long long flags) { 2789 | int new_flags = 0; 2790 | //fprintf (stderr, "%lld\n", flags); 2791 | if (flags & 1) { 2792 | new_flags |= FLAG_BARE; 2793 | } 2794 | if (flags & 32) { 2795 | new_flags |= FLAG_OPT_VAR; 2796 | } 2797 | if (flags & FLAG_EXCL) { 2798 | new_flags |= FLAG_EXCL; 2799 | } 2800 | if (flags & FLAG_OPT_FIELD) { 2801 | // new_flags |= FLAG_OPT_FIELD; 2802 | new_flags |= 2; 2803 | } 2804 | if (flags & (1 << 21)) { 2805 | new_flags |= 4; 2806 | } 2807 | wint (new_flags); 2808 | } 2809 | 2810 | void write_var_type_flags (long long flags) { 2811 | int new_flags = 0; 2812 | if (flags & 1) { 2813 | new_flags |= FLAG_BARE; 2814 | } 2815 | if (new_flags & FLAG_BARE) { 2816 | TL_ERROR ("Sorry, bare vars are not (yet ?) supported.\n"); 2817 | assert (!(new_flags & FLAG_BARE)); 2818 | } 2819 | wint (new_flags); 2820 | } 2821 | 2822 | void write_tree (struct tl_combinator_tree *T, int extra, struct tree_var_value **v, int *last_var); 2823 | void write_args (struct tl_combinator_tree *T, struct tree_var_value **v, int *last_var) { 2824 | assert (T->type == type_list || T->type == type_list_item); 2825 | if (T->type == type_list) { 2826 | assert (T->act == act_union); 2827 | assert (T->left); 2828 | assert (T->right); 2829 | write_args (T->left, v, last_var); 2830 | write_args (T->right, v, last_var); 2831 | return; 2832 | } 2833 | wint (TLS_ARG_V2); 2834 | assert (T->act == act_field); 2835 | assert (T->left); 2836 | wstr (T->data && strcmp (T->data, "_") ? T->data : 0); 2837 | long long f = T->flags; 2838 | if (T->left->act == act_opt_field) { 2839 | f |= (1 << 20); 2840 | } 2841 | 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"))) { 2842 | write_field_flags (f | (1 << 21)); 2843 | wint (*last_var); 2844 | *last_var = (*last_var) + 1; 2845 | tl_set_var_value_num (v, T, 0, (*last_var) - 1); 2846 | } else { 2847 | write_field_flags (f); 2848 | } 2849 | write_tree (T->left, 0, v, last_var); 2850 | } 2851 | 2852 | void write_array (struct tl_combinator_tree *T, struct tree_var_value **v, int *last_var) { 2853 | wint (TLS_ARRAY); 2854 | write_tree (T->left, 0, v, last_var); 2855 | write_tree (T->right, 0, v, last_var); 2856 | } 2857 | 2858 | void write_type_rec (struct tl_combinator_tree *T, int cc, struct tree_var_value **v, int *last_var) { 2859 | if (T->act == act_arg) { 2860 | write_type_rec (T->left, cc + 1, v, last_var); 2861 | if (T->right->type == type_num_value || T->right->type == type_num) { 2862 | wint (TLS_EXPR_NAT); 2863 | } else { 2864 | wint (TLS_EXPR_TYPE); 2865 | } 2866 | write_tree (T->right, 0, v, last_var); 2867 | } else { 2868 | assert (T->act == act_var || T->act == act_type); 2869 | if (T->act == act_var) { 2870 | assert (!cc); 2871 | wint (TLS_TYPE_VAR); 2872 | wint (tl_get_var_value_num (v, T->data)); 2873 | write_var_type_flags (T->flags); 2874 | //wint (T->flags); 2875 | } else { 2876 | wint (TLS_TYPE_EXPR); 2877 | struct tl_type *t = T->data; 2878 | wint (t->name); 2879 | write_type_flags (T->flags); 2880 | // wint (T->flags); 2881 | wint (cc); 2882 | // fprintf (stderr, "cc = %d\n", cc); 2883 | } 2884 | } 2885 | } 2886 | 2887 | void write_opt_type (struct tl_combinator_tree *T, struct tree_var_value **v, int *last_var) { 2888 | wint (tl_get_var_value_num (v, T->left->data)); 2889 | wint (T->left->type_flags); 2890 | // write_tree (T->right, 0, v, last_var); 2891 | assert (T); 2892 | T = T->right; 2893 | switch (T->type) { 2894 | case type_type: 2895 | if (T->act == act_array) { 2896 | write_array (T, v, last_var); 2897 | } else if (T->act == act_type || T->act == act_var || T->act == act_arg) { 2898 | write_type_rec (T, 0, v, last_var); 2899 | } else { 2900 | assert (0); 2901 | } 2902 | break; 2903 | default: 2904 | assert (0); 2905 | } 2906 | } 2907 | 2908 | void write_tree (struct tl_combinator_tree *T, int extra, struct tree_var_value **v, int *last_var) { 2909 | assert (T); 2910 | switch (T->type) { 2911 | case type_list_item: 2912 | case type_list: 2913 | if (extra) { 2914 | wint (TLS_COMBINATOR_RIGHT_V2); 2915 | } 2916 | wint (count_list_size (T)); 2917 | write_args (T, v, last_var); 2918 | break; 2919 | case type_num_value: 2920 | wint ((int)TLS_NAT_CONST); 2921 | wint (T->type_flags); 2922 | break; 2923 | case type_num: 2924 | wint ((int)TLS_NAT_VAR); 2925 | wint (T->type_flags); 2926 | wint (tl_get_var_value_num (v, T->data)); 2927 | break; 2928 | case type_type: 2929 | if (T->act == act_array) { 2930 | write_array (T, v, last_var); 2931 | } else if (T->act == act_type || T->act == act_var || T->act == act_arg) { 2932 | write_type_rec (T, 0, v, last_var); 2933 | } else { 2934 | assert (T->act == act_opt_field); 2935 | write_opt_type (T, v, last_var); 2936 | } 2937 | break; 2938 | default: 2939 | assert (0); 2940 | } 2941 | } 2942 | 2943 | void write_type (struct tl_type *t) { 2944 | wint (TLS_TYPE); 2945 | wint (t->name); 2946 | wstr (t->id); 2947 | wint (t->constructors_num); 2948 | wint (t->flags); 2949 | wint (t->params_num); 2950 | wll (t->params_types); 2951 | } 2952 | 2953 | int is_builtin_type (const char *id) { 2954 | return !strcmp (id, "int") || !strcmp (id, "long") || !strcmp (id, "double") || !strcmp (id, "string"); 2955 | } 2956 | 2957 | void write_combinator (struct tl_constructor *c) { 2958 | wint (c->name); 2959 | wstr (c->id); 2960 | wint (c->type ? c->type->name : 0); 2961 | struct tree_var_value *T = 0; 2962 | int x = 0; 2963 | assert (c->right); 2964 | if (c->left) { 2965 | if (is_builtin_type (c->id)) { 2966 | wint (TLS_COMBINATOR_LEFT_BUILTIN); 2967 | } else { 2968 | wint (TLS_COMBINATOR_LEFT); 2969 | // FIXME: What is that? 2970 | // wint (count_list_size (c->left)); 2971 | write_tree (c->left, 0, &T, &x); 2972 | } 2973 | } else { 2974 | wint (TLS_COMBINATOR_LEFT); 2975 | wint (0); 2976 | } 2977 | wint (TLS_COMBINATOR_RIGHT_V2); 2978 | write_tree (c->right, 1, &T, &x); 2979 | } 2980 | 2981 | void write_constructor (struct tl_constructor *c) { 2982 | wint (TLS_COMBINATOR); 2983 | write_combinator (c); 2984 | } 2985 | 2986 | void write_function (struct tl_constructor *c) { 2987 | wint (TLS_COMBINATOR); 2988 | write_combinator (c); 2989 | } 2990 | 2991 | void write_type_constructors (struct tl_type *t) { 2992 | int i; 2993 | for (i = 0; i < t->constructors_num; i++) { 2994 | write_constructor (t->constructors[i]); 2995 | } 2996 | } 2997 | 2998 | void write_types (int f) { 2999 | __f = f; 3000 | wint (TLS_SCHEMA_V2); 3001 | wint (0); 3002 | #ifdef TL_PARSER_NEED_TIME 3003 | wint (time (0)); 3004 | #else 3005 | /* Make the tlo reproducible by default. Rationale: https://wiki.debian.org/ReproducibleBuilds/Howto#Introduction */ 3006 | wint (0); 3007 | #endif 3008 | num = 0; 3009 | wint (total_types_num); 3010 | tree_act_tl_type (tl_type_tree, write_type); 3011 | wint (total_constructors_num); 3012 | tree_act_tl_type (tl_type_tree, write_type_constructors); 3013 | wint (total_functions_num); 3014 | tree_act_tl_constructor (tl_function_tree, write_function); 3015 | } 3016 | --------------------------------------------------------------------------------