X-Git-Url: http://deadsoftware.ru/gitweb?p=dsw-obn.git;a=blobdiff_plain;f=src%2Foberon.c;h=931a30724697a03476cff779779b3385bad5f2b4;hp=0118ff9bfceded3989c464ed1a6f9fb59645a6be;hb=HEAD;hpb=90882596d1b4b9ef59880c878118e4f9da49eede diff --git a/src/oberon.c b/src/oberon.c index 0118ff9..931a307 100644 --- a/src/oberon.c +++ b/src/oberon.c @@ -5,84 +5,27 @@ #include #include #include +#include +#include -#include "../include/oberon.h" +#include #include "oberon-internals.h" +#include "oberon-type-compat.h" +#include "oberon-common.h" #include "generator.h" -enum { - EOF_ = 0, - IDENT, - MODULE, - SEMICOLON, - END, - DOT, - VAR, - COLON, - BEGIN, - ASSIGN, - INTEGER, - TRUE, - FALSE, - LPAREN, - RPAREN, - EQUAL, - NEQ, - LESS, - LEQ, - GREAT, - GEQ, - PLUS, - MINUS, - OR, - STAR, - SLASH, - DIV, - MOD, - AND, - NOT, - PROCEDURE, - COMMA, - RETURN, - CONST, - TYPE, - ARRAY, - OF, - LBRACE, - RBRACE, - RECORD, - POINTER, - TO, - UPARROW, - NIL, - IMPORT, - REAL -}; - // ======================================================================= // UTILS // ======================================================================= static void -oberon_error(oberon_context_t * ctx, const char * fmt, ...) -{ - va_list ptr; - va_start(ptr, fmt); - fprintf(stderr, "error: "); - vfprintf(stderr, fmt, ptr); - fprintf(stderr, "\n"); - fprintf(stderr, " code_index = %i\n", ctx -> code_index); - fprintf(stderr, " c = %c\n", ctx -> c); - fprintf(stderr, " token = %i\n", ctx -> token); - va_end(ptr); - exit(1); -} +oberon_make_copy_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args); static oberon_type_t * oberon_new_type_ptr(int class) { - oberon_type_t * x = malloc(sizeof *x); + oberon_type_t * x = GC_MALLOC(sizeof *x); memset(x, 0, sizeof *x); x -> class = class; return x; @@ -114,6 +57,187 @@ oberon_new_type_real(int size) return x; } +static oberon_type_t * +oberon_new_type_char(int size) +{ + oberon_type_t * x; + x = oberon_new_type_ptr(OBERON_TYPE_CHAR); + x -> size = size; + return x; +} + +static oberon_type_t * +oberon_new_type_string(int size) +{ + oberon_type_t * x; + x = oberon_new_type_ptr(OBERON_TYPE_STRING); + x -> size = size; + return x; +} + +static oberon_type_t * +oberon_new_type_set(int size) +{ + oberon_type_t * x; + x = oberon_new_type_ptr(OBERON_TYPE_SET); + x -> size = size; + return x; +} + +static oberon_expr_t * +oberon_new_operator(int op, oberon_type_t * result, oberon_expr_t * left, oberon_expr_t * right) +{ + oberon_oper_t * operator; + operator = GC_MALLOC(sizeof *operator); + memset(operator, 0, sizeof *operator); + + operator -> is_item = 0; + operator -> result = result; + operator -> read_only = 1; + operator -> op = op; + operator -> left = left; + operator -> right = right; + + return (oberon_expr_t *) operator; +} + +static oberon_expr_t * +oberon_new_item(int mode, oberon_type_t * result, int read_only) +{ + oberon_item_t * item; + item = GC_MALLOC(sizeof *item); + memset(item, 0, sizeof *item); + + item -> is_item = 1; + item -> result = result; + item -> read_only = read_only; + item -> mode = mode; + + return (oberon_expr_t *)item; +} + +static oberon_type_t * +oberon_get_type_of_int_value(oberon_context_t * ctx, int64_t i) +{ + if(i >= -128 && i <= 127) + { + return ctx -> byte_type; + } + else if(i >= -32768 && i <= 32767) + { + return ctx -> shortint_type; + } + else if(i >= -2147483648 && i <= 2147483647) + { + return ctx -> int_type; + } + else + { + return ctx -> longint_type; + } +} + +static oberon_expr_t * +oberon_make_integer(oberon_context_t * ctx, int64_t i) +{ + oberon_expr_t * expr; + oberon_type_t * result; + result = oberon_get_type_of_int_value(ctx, i); + expr = oberon_new_item(MODE_INTEGER, result, true); + expr -> item.integer = i; + expr -> item.real = i; + return expr; +} + +static oberon_expr_t * +oberon_make_system_byte(oberon_context_t * ctx, int64_t i) +{ + oberon_expr_t * expr; + expr = oberon_new_item(MODE_SYSBYTE, ctx -> system_byte_type, true); + expr -> item.integer = i; + expr -> item.real = i; + return expr; +} + +static oberon_expr_t * +oberon_make_char(oberon_context_t * ctx, int64_t i) +{ + oberon_expr_t * expr; + expr = oberon_new_item(MODE_CHAR, ctx -> char_type, true); + expr -> item.integer = i; + expr -> item.real = i; + return expr; +} + +static oberon_expr_t * +oberon_make_string(oberon_context_t * ctx, char * str) +{ + oberon_expr_t * expr; + expr = oberon_new_item(MODE_STRING, ctx -> string_type, true); + expr -> item.integer = str[0]; + expr -> item.real = str[0]; + expr -> item.string = str; + return expr; +} + +static oberon_expr_t * +oberon_make_real_typed(oberon_context_t * ctx, double r, oberon_type_t * result) +{ + oberon_expr_t * expr; + expr = oberon_new_item(MODE_REAL, result, true); + expr -> item.integer = r; + expr -> item.real = r; + return expr; +} + +static oberon_expr_t * +oberon_make_real(oberon_context_t * ctx, double r, bool longmode) +{ + oberon_type_t * result; + result = (longmode) ? (ctx -> longreal_type) : (ctx -> real_type); + return oberon_make_real_typed(ctx, r, result); +} + +static oberon_expr_t * +oberon_make_boolean(oberon_context_t * ctx, bool cond) +{ + oberon_expr_t * expr; + expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, true); + expr -> item.integer = cond; + expr -> item.real = cond; + return expr; +} + +static oberon_expr_t * +oberon_make_set(oberon_context_t * ctx, int64_t i) +{ + oberon_expr_t * expr; + expr = oberon_new_item(MODE_SET, ctx -> set_type, true); + expr -> item.integer = i; + expr -> item.real = i; + return expr; +} + +static oberon_expr_t * +oberon_make_set_index(oberon_context_t * ctx, int64_t i) +{ + oberon_expr_t * expr; + expr = oberon_new_item(MODE_SET, ctx -> set_type, true); + expr -> item.integer = 1 << i; + expr -> item.real = 1 << i; + return expr; +} + +static oberon_expr_t * +oberon_make_set_range(oberon_context_t * ctx, int64_t x, int64_t y) +{ + oberon_expr_t * expr; + expr = oberon_new_item(MODE_SET, ctx -> set_type, true); + expr -> item.integer = (x <= y) ? ((2 << y) - (1 << x)) : (0); + expr -> item.real = expr -> item.integer; + return expr; +} + // ======================================================================= // TABLE // ======================================================================= @@ -121,8 +245,11 @@ oberon_new_type_real(int size) static oberon_scope_t * oberon_open_scope(oberon_context_t * ctx) { - oberon_scope_t * scope = calloc(1, sizeof *scope); - oberon_object_t * list = calloc(1, sizeof *list); + oberon_scope_t * scope = GC_MALLOC(sizeof *scope); + memset(scope, 0, sizeof *scope); + + oberon_object_t * list = GC_MALLOC(sizeof *list); + memset(list, 0, sizeof *list); scope -> ctx = ctx; scope -> list = list; @@ -133,6 +260,7 @@ oberon_open_scope(oberon_context_t * ctx) scope -> local = scope -> up -> local; scope -> parent = scope -> up -> parent; scope -> parent_type = scope -> up -> parent_type; + scope -> exit_label = scope -> up -> exit_label; } ctx -> decl = scope; @@ -177,6 +305,37 @@ oberon_find_object(oberon_scope_t * scope, char * name, bool check_it) return result; } +static oberon_object_t * +oberon_find_object_in_scope(oberon_scope_t * scope, char * name, bool check_it) +{ + oberon_object_t * result = NULL; + + result = oberon_find_object_in_list(scope -> list, name); + + if(check_it && result == NULL) + { + oberon_error(scope -> ctx, "undefined ident %s", name); + } + + return result; +} + +static oberon_object_t * +oberon_create_object(oberon_scope_t * scope, char * name, int class, bool export, bool read_only) +{ + oberon_object_t * newvar = GC_MALLOC(sizeof *newvar); + memset(newvar, 0, sizeof *newvar); + newvar -> name = name; + newvar -> class = class; + newvar -> export = export; + newvar -> read_only = read_only; + newvar -> local = scope -> local; + newvar -> parent = scope -> parent; + newvar -> parent_type = scope -> parent_type; + newvar -> module = scope -> ctx -> mod; + return newvar; +} + static oberon_object_t * oberon_define_object(oberon_scope_t * scope, char * name, int class, bool export, bool read_only, bool check_upscope) { @@ -199,32 +358,13 @@ oberon_define_object(oberon_scope_t * scope, char * name, int class, bool export oberon_error(scope -> ctx, "already defined"); } - oberon_object_t * newvar = malloc(sizeof *newvar); - memset(newvar, 0, sizeof *newvar); - newvar -> name = name; - newvar -> class = class; - newvar -> export = export; - newvar -> read_only = read_only; - newvar -> local = scope -> local; - newvar -> parent = scope -> parent; - newvar -> parent_type = scope -> parent_type; - newvar -> module = scope -> ctx -> mod; - + oberon_object_t * newvar; + newvar = oberon_create_object(scope, name, class, export, read_only); x -> next = newvar; return newvar; } -static oberon_object_t * -oberon_define_type(oberon_scope_t * scope, char * name, oberon_type_t * type, int export) -{ - oberon_object_t * id; - id = oberon_define_object(scope, name, OBERON_CLASS_TYPE, export, false, false); - id -> type = type; - oberon_generator_init_type(scope -> ctx, type); - return id; -} - // ======================================================================= // SCANER // ======================================================================= @@ -235,38 +375,41 @@ oberon_get_char(oberon_context_t * ctx) if(ctx -> code[ctx -> code_index]) { ctx -> code_index += 1; + ctx -> xloc.col += 1; ctx -> c = ctx -> code[ctx -> code_index]; } } static void -oberon_init_scaner(oberon_context_t * ctx, const char * code) +oberon_init_scaner(oberon_context_t * ctx, oberon_scanner_t * s) { - ctx -> code = code; + ctx -> code = s -> code; ctx -> code_index = 0; + ctx -> xloc.source = s -> source; + ctx -> xloc.line = 1; + ctx -> xloc.col = 1; + ctx -> loc = ctx -> xloc; ctx -> c = ctx -> code[ctx -> code_index]; + oberon_set_line(ctx, 1); } static void oberon_read_ident(oberon_context_t * ctx) { - int len = 0; - int i = ctx -> code_index; + int start = ctx -> code_index; - int c = ctx -> code[i]; - while(isalnum(c)) + oberon_get_char(ctx); + while(isalnum(ctx -> c) || ctx -> c == '_') { - i += 1; - len += 1; - c = ctx -> code[i]; + oberon_get_char(ctx); } - char * ident = malloc(len + 1); - memcpy(ident, &ctx->code[ctx->code_index], len); - ident[len] = 0; + int end = ctx -> code_index; + + char * ident = GC_MALLOC(end - start + 1); + memcpy(ident, &ctx -> code[start], end - start); + ident[end - start] = 0; - ctx -> code_index = i; - ctx -> c = ctx -> code[i]; ctx -> string = ident; ctx -> token = IDENT; @@ -286,14 +429,6 @@ oberon_read_ident(oberon_context_t * ctx) { ctx -> token = BEGIN; } - else if(strcmp(ident, "TRUE") == 0) - { - ctx -> token = TRUE; - } - else if(strcmp(ident, "FALSE") == 0) - { - ctx -> token = FALSE; - } else if(strcmp(ident, "OR") == 0) { ctx -> token = OR; @@ -350,8 +485,75 @@ oberon_read_ident(oberon_context_t * ctx) { ctx -> token = IMPORT; } + else if(strcmp(ident, "IN") == 0) + { + ctx -> token = IN; + } + else if(strcmp(ident, "IS") == 0) + { + ctx -> token = IS; + } + else if(strcmp(ident, "IF") == 0) + { + ctx -> token = IF; + } + else if(strcmp(ident, "THEN") == 0) + { + ctx -> token = THEN; + } + else if(strcmp(ident, "ELSE") == 0) + { + ctx -> token = ELSE; + } + else if(strcmp(ident, "ELSIF") == 0) + { + ctx -> token = ELSIF; + } + else if(strcmp(ident, "WHILE") == 0) + { + ctx -> token = WHILE; + } + else if(strcmp(ident, "DO") == 0) + { + ctx -> token = DO; + } + else if(strcmp(ident, "REPEAT") == 0) + { + ctx -> token = REPEAT; + } + else if(strcmp(ident, "UNTIL") == 0) + { + ctx -> token = UNTIL; + } + else if(strcmp(ident, "FOR") == 0) + { + ctx -> token = FOR; + } + else if(strcmp(ident, "BY") == 0) + { + ctx -> token = BY; + } + else if(strcmp(ident, "LOOP") == 0) + { + ctx -> token = LOOP; + } + else if(strcmp(ident, "EXIT") == 0) + { + ctx -> token = EXIT; + } + else if(strcmp(ident, "CASE") == 0) + { + ctx -> token = CASE; + } + else if(strcmp(ident, "WITH") == 0) + { + ctx -> token = WITH; + } } +#define ISHEXDIGIT(x) \ + (((x) >= '0' && (x) <= '9') || ((x) >= 'A' && (x) <= 'F')) + static void oberon_read_number(oberon_context_t * ctx) { @@ -367,6 +569,7 @@ oberon_read_number(oberon_context_t * ctx) * mode = 1 == HEX * mode = 2 == REAL * mode = 3 == LONGREAL + * mode = 4 == CHAR */ int mode = 0; start_i = ctx -> code_index; @@ -378,65 +581,94 @@ oberon_read_number(oberon_context_t * ctx) end_i = ctx -> code_index; - if(isxdigit(ctx -> c)) + if(ISHEXDIGIT(ctx -> c)) { mode = 1; - while(isxdigit(ctx -> c)) + while(ISHEXDIGIT(ctx -> c)) { oberon_get_char(ctx); } end_i = ctx -> code_index; - if(ctx -> c != 'H') + if(ctx -> c == 'H') + { + mode = 1; + oberon_get_char(ctx); + } + else if(ctx -> c == 'X') + { + mode = 4; + oberon_get_char(ctx); + } + else { oberon_error(ctx, "invalid hex number"); } - oberon_get_char(ctx); } else if(ctx -> c == '.') { - mode = 2; oberon_get_char(ctx); - - while(isdigit(ctx -> c)) + if(ctx -> c == '.') { - oberon_get_char(ctx); + /* Чит: избегаем конфликта с DOTDOT */ + ctx -> code_index -= 1; } - - if(ctx -> c == 'E' || ctx -> c == 'D') + else { - exp_i = ctx -> code_index; + mode = 2; - if(ctx -> c == 'D') - { - mode = 3; - } - - oberon_get_char(ctx); - - if(ctx -> c == '+' || ctx -> c == '-') + while(isdigit(ctx -> c)) { oberon_get_char(ctx); } - while(isdigit(ctx -> c)) + if(ctx -> c == 'E' || ctx -> c == 'D') { + exp_i = ctx -> code_index; + + if(ctx -> c == 'D') + { + mode = 3; + } + oberon_get_char(ctx); - } - } + if(ctx -> c == '+' || ctx -> c == '-') + { + oberon_get_char(ctx); + } + while(isdigit(ctx -> c)) + { + oberon_get_char(ctx); + } + } + } end_i = ctx -> code_index; } - int len = end_i - start_i; - ident = malloc(len + 1); - memcpy(ident, &ctx -> code[start_i], len); - ident[len] = 0; - - ctx -> longmode = false; - if(mode == 3) + if(mode == 0) + { + if(ctx -> c == 'H') + { + mode = 1; + oberon_get_char(ctx); + } + else if(ctx -> c == 'X') + { + mode = 4; + oberon_get_char(ctx); + } + } + + int len = end_i - start_i; + ident = GC_MALLOC(len + 1); + memcpy(ident, &ctx -> code[start_i], len); + ident[len] = 0; + + ctx -> longmode = false; + if(mode == 3) { int i = exp_i - start_i; ident[i] = 'E'; @@ -458,8 +690,14 @@ oberon_read_number(oberon_context_t * ctx) case 2: case 3: sscanf(ident, "%lf", &real); + integer = real; ctx -> token = REAL; break; + case 4: + sscanf(ident, "%lx", &integer); + real = integer; + ctx -> token = CHAR; + break; default: oberon_error(ctx, "oberon_read_number: wat"); break; @@ -470,12 +708,42 @@ oberon_read_number(oberon_context_t * ctx) ctx -> real = real; } +static void +oberon_get_lined_char(oberon_context_t * ctx) +{ + do + { + if(ctx -> c == 0xD) + { + oberon_get_char(ctx); + if(ctx -> c == 0xA) + { + oberon_get_char(ctx); + } + ctx -> xloc.line += 1; + ctx -> xloc.col = 1; + oberon_set_line(ctx, ctx -> xloc.line); + } + else if(ctx -> c == 0xA) + { + oberon_get_char(ctx); + ctx -> xloc.line += 1; + ctx -> xloc.col = 1; + oberon_set_line(ctx, ctx -> xloc.line); + } + else + { + oberon_get_char(ctx); + } + } while(ctx -> c == 0xD || ctx -> c == 0xA); +} + static void oberon_skip_space(oberon_context_t * ctx) { while(isspace(ctx -> c)) { - oberon_get_char(ctx); + oberon_get_lined_char(ctx); } } @@ -487,19 +755,19 @@ oberon_read_comment(oberon_context_t * ctx) { if(ctx -> c == '(') { - oberon_get_char(ctx); + oberon_get_lined_char(ctx); if(ctx -> c == '*') { - oberon_get_char(ctx); + oberon_get_lined_char(ctx); nesting += 1; } } else if(ctx -> c == '*') { - oberon_get_char(ctx); + oberon_get_lined_char(ctx); if(ctx -> c == ')') { - oberon_get_char(ctx); + oberon_get_lined_char(ctx); nesting -= 1; } } @@ -509,11 +777,41 @@ oberon_read_comment(oberon_context_t * ctx) } else { - oberon_get_char(ctx); + oberon_get_lined_char(ctx); } } } +static void oberon_read_string(oberon_context_t * ctx) +{ + int c = ctx -> c; + oberon_get_char(ctx); + + int start = ctx -> code_index; + + while(ctx -> c != 0 && ctx -> c != c) + { + oberon_get_char(ctx); + } + + if(ctx -> c == 0) + { + oberon_error(ctx, "unterminated string"); + } + + int end = ctx -> code_index; + + oberon_get_char(ctx); + + char * string = GC_MALLOC(end - start + 1); + strncpy(string, &ctx -> code[start], end - start); + string[end - start] = 0; + + ctx -> token = STRING; + ctx -> string = string; + ctx -> integer = string[0]; +} + static void oberon_read_token(oberon_context_t * ctx); static void @@ -541,6 +839,11 @@ oberon_read_symbol(oberon_context_t * ctx) case '.': ctx -> token = DOT; oberon_get_char(ctx); + if(ctx -> c == '.') + { + ctx -> token = DOTDOT; + oberon_get_char(ctx); + } break; case '(': ctx -> token = LPAREN; @@ -616,17 +919,35 @@ oberon_read_symbol(oberon_context_t * ctx) oberon_get_char(ctx); break; case '[': - ctx -> token = LBRACE; + ctx -> token = LBRACK; oberon_get_char(ctx); break; case ']': - ctx -> token = RBRACE; + ctx -> token = RBRACK; oberon_get_char(ctx); break; case '^': ctx -> token = UPARROW; oberon_get_char(ctx); break; + case '"': + oberon_read_string(ctx); + break; + case '\'': + oberon_read_string(ctx); + break; + case '{': + ctx -> token = LBRACE; + oberon_get_char(ctx); + break; + case '}': + ctx -> token = RBRACE; + oberon_get_char(ctx); + break; + case '|': + ctx -> token = BAR; + oberon_get_char(ctx); + break; default: oberon_error(ctx, "invalid char %c", ctx -> c); break; @@ -638,8 +959,10 @@ oberon_read_token(oberon_context_t * ctx) { oberon_skip_space(ctx); + ctx -> loc = ctx -> xloc; + int c = ctx -> c; - if(isalpha(c)) + if(isalpha(c) || c == '_') { oberon_read_ident(ctx); } @@ -663,38 +986,8 @@ static void oberon_assert_token(oberon_context_t * ctx, int token); static char * oberon_assert_ident(oberon_context_t * ctx); static void oberon_type(oberon_context_t * ctx, oberon_type_t ** type); static oberon_item_t * oberon_const_expr(oberon_context_t * ctx); - -static oberon_expr_t * -oberon_new_operator(int op, oberon_type_t * result, oberon_expr_t * left, oberon_expr_t * right) -{ - oberon_oper_t * operator; - operator = malloc(sizeof *operator); - memset(operator, 0, sizeof *operator); - - operator -> is_item = 0; - operator -> result = result; - operator -> read_only = 1; - operator -> op = op; - operator -> left = left; - operator -> right = right; - - return (oberon_expr_t *) operator; -} - -static oberon_expr_t * -oberon_new_item(int mode, oberon_type_t * result, int read_only) -{ - oberon_item_t * item; - item = malloc(sizeof *item); - memset(item, 0, sizeof *item); - - item -> is_item = 1; - item -> result = result; - item -> read_only = read_only; - item -> mode = mode; - - return (oberon_expr_t *)item; -} +static oberon_expr_t * oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr); +static bool oberon_is_const(oberon_expr_t * expr); static oberon_expr_t * oberon_make_unary_op(oberon_context_t * ctx, int token, oberon_expr_t * a) @@ -706,12 +999,43 @@ oberon_make_unary_op(oberon_context_t * ctx, int token, oberon_expr_t * a) if(token == MINUS) { - if(result -> class != OBERON_TYPE_INTEGER) + if(result -> class == OBERON_TYPE_SET) + { + if(oberon_is_const(a)) + { + expr = oberon_make_set(ctx, ~(a -> item.integer)); + } + else + { + expr = oberon_new_operator(OP_COMPLEMENTATION, result, a, NULL); + } + } + else if(result -> class == OBERON_TYPE_INTEGER) + { + if(oberon_is_const(a)) + { + expr = oberon_make_integer(ctx, -(a -> item.integer)); + } + else + { + expr = oberon_new_operator(OP_UNARY_MINUS, result, a, NULL); + } + } + else if(result -> class == OBERON_TYPE_REAL) + { + if(oberon_is_const(a)) + { + expr = oberon_make_real_typed(ctx, -(a -> item.real), result); + } + else + { + expr = oberon_new_operator(OP_UNARY_MINUS, result, a, NULL); + } + } + else { oberon_error(ctx, "incompatible operator type"); } - - expr = oberon_new_operator(OP_UNARY_MINUS, result, a, NULL); } else if(token == NOT) { @@ -720,7 +1044,14 @@ oberon_make_unary_op(oberon_context_t * ctx, int token, oberon_expr_t * a) oberon_error(ctx, "incompatible operator type"); } - expr = oberon_new_operator(OP_LOGIC_NOT, result, a, NULL); + if(oberon_is_const(a)) + { + expr = oberon_make_boolean(ctx, !(a -> item.integer)); + } + else + { + expr = oberon_new_operator(OP_LOGIC_NOT, result, a, NULL); + } } else { @@ -736,7 +1067,14 @@ oberon_expr_list(oberon_context_t * ctx, int * num_expr, oberon_expr_t ** first, oberon_expr_t * last; *num_expr = 1; - *first = last = oberon_expr(ctx); + if(const_expr) + { + *first = last = (oberon_expr_t *) oberon_const_expr(ctx); + } + else + { + *first = last = oberon_expr(ctx); + } while(ctx -> token == COMMA) { oberon_assert_token(ctx, COMMA); @@ -761,136 +1099,88 @@ static oberon_expr_t * oberon_cast_expr(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref) { oberon_expr_t * cast; - cast = oberon_new_item(MODE_CAST, pref, expr -> read_only); - cast -> item.parent = expr; - cast -> next = expr -> next; - return cast; -} -static oberon_type_t * -oberon_get_equal_expr_type(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b) -{ - oberon_type_t * result; - if(a -> class == OBERON_TYPE_REAL && b -> class == OBERON_TYPE_INTEGER) - { - result = a; - } - else if(b -> class == OBERON_TYPE_REAL && a -> class == OBERON_TYPE_INTEGER) + if((oberon_is_char_type(pref) && oberon_is_const_string(expr) && strlen(expr -> item.string) == 1)) { - result = b; + /* Автоматически преобразуем строку единичного размера в символ */ + cast = oberon_new_item(MODE_CHAR, ctx -> char_type, true); + cast -> item.integer = expr -> item.string[0]; } - else if(a -> class != b -> class) + else if(oberon_is_record_type(pref) || oberon_is_pointer_to_record(pref)) { - oberon_error(ctx, "oberon_get_equal_expr_type: incompatible types"); + assert(expr -> is_item); + cast = oberon_new_item(MODE_AS, pref, expr -> read_only); + cast -> item.parent = (oberon_item_t *) expr; } - else if(a -> size > b -> size) + else if(!oberon_is_some_types(expr -> result, pref)) { - result = a; + cast = oberon_new_operator(OP_CAST, pref, expr, NULL); } else { - result = b; + cast = expr; } - return result; + return cast; } static oberon_expr_t * -oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref) +oberon_hard_cast_expr(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref) { - if(pref -> class != expr -> result -> class) - { - if(pref -> class == OBERON_TYPE_POINTER) - { - if(expr -> result -> class == OBERON_TYPE_POINTER) - { - // accept - } - else - { - oberon_error(ctx, "incompatible types"); - } - } - else if(pref -> class == OBERON_TYPE_REAL) - { - if(expr -> result -> class == OBERON_TYPE_INTEGER) - { - // accept - } - else - { - oberon_error(ctx, "incompatible types"); - } - } - else - { - oberon_error(ctx, "incompatible types"); - } - } + return oberon_new_operator(OP_HARDCAST, pref, expr, NULL); +} - if(pref -> class == OBERON_TYPE_INTEGER || pref -> class == OBERON_TYPE_REAL) +static void +oberon_check_dst(oberon_context_t * ctx, oberon_expr_t * dst) +{ + if(dst -> read_only) { - if(expr -> result -> size > pref -> size) - { - oberon_error(ctx, "incompatible size"); - } - else - { - expr = oberon_cast_expr(ctx, expr, pref); - } + oberon_error(ctx, "read-only destination"); } - else if(pref -> class == OBERON_TYPE_RECORD) + + if(dst -> is_item == false) { - if(expr -> result != pref) - { - printf("oberon_autocast_to: rec %p != %p\n", expr -> result, pref); - oberon_error(ctx, "incompatible record types"); - } + oberon_error(ctx, "not variable"); } - else if(pref -> class == OBERON_TYPE_POINTER) + + switch(dst -> item.mode) { - if(expr -> result -> base != pref -> base) - { - if(expr -> result -> base -> class != OBERON_TYPE_VOID) - { - oberon_error(ctx, "incompatible pointer types"); - } - } + case MODE_VAR: + case MODE_CALL: + case MODE_INDEX: + case MODE_FIELD: + case MODE_DEREF: + case MODE_NEW: + /* accept */ + break; + default: + oberon_error(ctx, "not variable"); + break; } - - return expr; } static void -oberon_autocast_binary_op(oberon_context_t * ctx, oberon_expr_t ** ea, oberon_expr_t ** eb) +oberon_check_src(oberon_context_t * ctx, oberon_expr_t * src) { - oberon_type_t * a = (*ea) -> result; - oberon_type_t * b = (*eb) -> result; - oberon_type_t * preq = oberon_get_equal_expr_type(ctx, a, b); - *ea = oberon_autocast_to(ctx, *ea, preq); - *eb = oberon_autocast_to(ctx, *eb, preq); + if(src -> is_item) + { + if(src -> item.mode == MODE_TYPE) + { + oberon_error(ctx, "not variable"); + } + } } static void -oberon_autocast_call(oberon_context_t * ctx, oberon_expr_t * desig) +oberon_autocast_call(oberon_context_t * ctx, oberon_item_t * desig) { - if(desig -> is_item == 0) - { - oberon_error(ctx, "expected item"); - } - - if(desig -> item.mode != MODE_CALL) + if(desig -> mode != MODE_CALL) { oberon_error(ctx, "expected mode CALL"); } - if(desig -> item.var -> type -> class != OBERON_TYPE_PROCEDURE) - { - oberon_error(ctx, "only procedures can be called"); - } - - oberon_type_t * fn = desig -> item.var -> type; - int num_args = desig -> item.num_args; + oberon_type_t * fn = desig -> parent -> result; + int num_args = desig -> num_args; int num_decl = fn -> num_decl; if(num_args < num_decl) @@ -904,19 +1194,30 @@ oberon_autocast_call(oberon_context_t * ctx, oberon_expr_t * desig) /* Делаем проверку на запись и делаем автокаст */ oberon_expr_t * casted[num_args]; - oberon_expr_t * arg = desig -> item.args; + oberon_expr_t * arg = desig -> args; oberon_object_t * param = fn -> decl; for(int i = 0; i < num_args; i++) { if(param -> class == OBERON_CLASS_VAR_PARAM) { - if(arg -> read_only) + oberon_check_dst(ctx, arg); + if(!oberon_is_compatible_arrays(param, arg)) + { + oberon_check_compatible_var_param(ctx, param -> type, arg -> result); + } + casted[i] = arg; + //casted[i] = oberon_cast_expr(ctx, arg, param -> type); + } + else + { + oberon_check_src(ctx, arg); + if(!oberon_is_compatible_arrays(param, arg)) { - oberon_error(ctx, "assign to read-only var"); + oberon_check_assignment_compatible(ctx, arg, param -> type); } + casted[i] = oberon_cast_expr(ctx, arg, param -> type); } - casted[i] = oberon_autocast_to(ctx, arg, param -> type); arg = arg -> next; param = param -> next; } @@ -929,108 +1230,79 @@ oberon_autocast_call(oberon_context_t * ctx, oberon_expr_t * desig) { casted[i] -> next = casted[i + 1]; } - desig -> item.args = arg; + desig -> args = arg; } } static oberon_expr_t * -oberon_make_call_func(oberon_context_t * ctx, oberon_object_t * proc, int num_args, oberon_expr_t * list_args) +oberon_make_call_func(oberon_context_t * ctx, oberon_item_t * item, int num_args, oberon_expr_t * list_args) { - switch(proc -> class) + oberon_type_t * signature = item -> result; + if(signature -> class != OBERON_TYPE_PROCEDURE) { - case OBERON_CLASS_PROC: - if(proc -> class != OBERON_CLASS_PROC) - { - oberon_error(ctx, "not a procedure"); - } - break; - case OBERON_CLASS_VAR: - case OBERON_CLASS_VAR_PARAM: - case OBERON_CLASS_PARAM: - if(proc -> type -> class != OBERON_TYPE_PROCEDURE) - { - oberon_error(ctx, "not a procedure"); - } - break; - default: - oberon_error(ctx, "not a procedure"); - break; + oberon_error(ctx, "not a procedure"); } oberon_expr_t * call; - if(proc -> sysproc) + if(signature -> sysproc) { - if(proc -> genfunc == NULL) + if(signature -> genfunc == NULL) { oberon_error(ctx, "not a function-procedure"); } - call = proc -> genfunc(ctx, num_args, list_args); + call = signature -> genfunc(ctx, num_args, list_args); } else { - if(proc -> type -> base -> class == OBERON_TYPE_VOID) + if(signature -> base -> class == OBERON_TYPE_NOTYPE) { oberon_error(ctx, "attempt to call procedure in expression"); } - call = oberon_new_item(MODE_CALL, proc -> type -> base, 1); - call -> item.var = proc; + call = oberon_new_item(MODE_CALL, signature -> base, true); + call -> item.parent = item; call -> item.num_args = num_args; call -> item.args = list_args; - oberon_autocast_call(ctx, call); + oberon_autocast_call(ctx, (oberon_item_t *) call); } return call; } static void -oberon_make_call_proc(oberon_context_t * ctx, oberon_object_t * proc, int num_args, oberon_expr_t * list_args) +oberon_make_call_proc(oberon_context_t * ctx, oberon_item_t * item, int num_args, oberon_expr_t * list_args) { - switch(proc -> class) + oberon_type_t * signature = item -> result; + if(signature -> class != OBERON_TYPE_PROCEDURE) { - case OBERON_CLASS_PROC: - if(proc -> class != OBERON_CLASS_PROC) - { - oberon_error(ctx, "not a procedure"); - } - break; - case OBERON_CLASS_VAR: - case OBERON_CLASS_VAR_PARAM: - case OBERON_CLASS_PARAM: - if(proc -> type -> class != OBERON_TYPE_PROCEDURE) - { - oberon_error(ctx, "not a procedure"); - } - break; - default: - oberon_error(ctx, "not a procedure"); - break; + oberon_error(ctx, "not a procedure"); } - if(proc -> sysproc) + oberon_expr_t * call; + + if(signature -> sysproc) { - if(proc -> genproc == NULL) + if(signature -> genproc == NULL) { - oberon_error(ctx, "requres non-typed procedure"); + oberon_error(ctx, "not a procedure"); } - proc -> genproc(ctx, num_args, list_args); + signature -> genproc(ctx, num_args, list_args); } else { - if(proc -> type -> base -> class != OBERON_TYPE_VOID) + if(signature -> base -> class != OBERON_TYPE_NOTYPE) { oberon_error(ctx, "attempt to call function as non-typed procedure"); } - oberon_expr_t * call; - call = oberon_new_item(MODE_CALL, proc -> type -> base, 1); - call -> item.var = proc; + call = oberon_new_item(MODE_CALL, signature -> base, true); + call -> item.parent = item; call -> item.num_args = num_args; call -> item.args = list_args; - oberon_autocast_call(ctx, call); + oberon_autocast_call(ctx, (oberon_item_t *) call); oberon_generate_call_proc(ctx, call); } } @@ -1040,10 +1312,13 @@ oberon_make_call_proc(oberon_context_t * ctx, oberon_object_t * proc, int num_ar || ((x) == MINUS) \ || ((x) == IDENT) \ || ((x) == INTEGER) \ + || ((x) == REAL) \ + || ((x) == CHAR) \ + || ((x) == STRING) \ + || ((x) == NIL) \ + || ((x) == LBRACE) \ || ((x) == LPAREN) \ - || ((x) == NOT) \ - || ((x) == TRUE) \ - || ((x) == FALSE)) + || ((x) == NOT)) static oberon_expr_t * oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr) @@ -1056,8 +1331,8 @@ oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr) assert(expr -> is_item); oberon_expr_t * selector; - selector = oberon_new_item(MODE_DEREF, expr -> result -> base, expr -> read_only); - selector -> item.parent = expr; + selector = oberon_new_item(MODE_DEREF, expr -> result -> base, false); + selector -> item.parent = (oberon_item_t *) expr; return selector; } @@ -1104,7 +1379,7 @@ oberon_make_array_selector(oberon_context_t * ctx, oberon_expr_t * desig, oberon oberon_expr_t * selector; selector = oberon_new_item(MODE_INDEX, base, desig -> read_only); - selector -> item.parent = desig; + selector -> item.parent = (oberon_item_t *) desig; selector -> item.num_args = 1; selector -> item.args = index; @@ -1119,7 +1394,7 @@ oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char * expr = oberno_make_dereferencing(ctx, expr); } - assert(expr -> is_item == 1); + assert(expr -> is_item); if(expr -> result -> class != OBERON_TYPE_RECORD) { @@ -1139,7 +1414,7 @@ oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char * } } - int read_only = 0; + int read_only = expr -> read_only; if(field -> read_only) { if(field -> module != ctx -> mod) @@ -1151,15 +1426,16 @@ oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char * oberon_expr_t * selector; selector = oberon_new_item(MODE_FIELD, field -> type, read_only); selector -> item.var = field; - selector -> item.parent = expr; + selector -> item.parent = (oberon_item_t *) expr; return selector; } #define ISSELECTOR(x) \ - (((x) == LBRACE) \ + (((x) == LBRACK) \ || ((x) == DOT) \ - || ((x) == UPARROW)) + || ((x) == UPARROW) \ + || ((x) == LPAREN)) static oberon_object_t * oberon_qualident(oberon_context_t * ctx, char ** xname, int check) @@ -1195,9 +1471,28 @@ oberon_qualident(oberon_context_t * ctx, char ** xname, int check) } static oberon_expr_t * -oberon_designator(oberon_context_t * ctx) +oberon_ident_item(oberon_context_t * ctx, char * name) +{ + bool read_only; + oberon_object_t * x; + oberon_expr_t * expr; + + x = oberon_find_object(ctx -> decl, name, true); + + read_only = false; + if(x -> class == OBERON_CLASS_CONST || x -> class == OBERON_CLASS_PROC) + { + read_only = true; + } + + expr = oberon_new_item(MODE_VAR, x -> type, read_only); + expr -> item.var = x; + return expr; +} + +static oberon_expr_t * +oberon_qualident_expr(oberon_context_t * ctx) { - char * name; oberon_object_t * var; oberon_expr_t * expr; @@ -1218,35 +1513,51 @@ oberon_designator(oberon_context_t * ctx) // TODO copy value expr = (oberon_expr_t *) var -> value; break; + case OBERON_CLASS_TYPE: + expr = oberon_new_item(MODE_TYPE, var -> type, read_only); + break; case OBERON_CLASS_VAR: case OBERON_CLASS_VAR_PARAM: case OBERON_CLASS_PARAM: expr = oberon_new_item(MODE_VAR, var -> type, read_only); break; case OBERON_CLASS_PROC: - expr = oberon_new_item(MODE_VAR, var -> type, 1); + expr = oberon_new_item(MODE_VAR, var -> type, true); break; default: oberon_error(ctx, "invalid designator"); break; } + expr -> item.var = var; - while(ISSELECTOR(ctx -> token)) - { - switch(ctx -> token) - { - case DOT: - oberon_assert_token(ctx, DOT); + return expr; +} + +static oberon_expr_t * +oberon_designator(oberon_context_t * ctx) +{ + char * name; + oberon_expr_t * expr; + oberon_object_t * objtype; + + expr = oberon_qualident_expr(ctx); + + while(expr -> result -> class != OBERON_TYPE_PROCEDURE && ISSELECTOR(ctx -> token)) + { + switch(ctx -> token) + { + case DOT: + oberon_assert_token(ctx, DOT); name = oberon_assert_ident(ctx); expr = oberon_make_record_selector(ctx, expr, name); break; - case LBRACE: - oberon_assert_token(ctx, LBRACE); + case LBRACK: + oberon_assert_token(ctx, LBRACK); int num_indexes = 0; oberon_expr_t * indexes = NULL; oberon_expr_list(ctx, &num_indexes, &indexes, 0); - oberon_assert_token(ctx, RBRACE); + oberon_assert_token(ctx, RBRACK); for(int i = 0; i < num_indexes; i++) { @@ -1258,19 +1569,25 @@ oberon_designator(oberon_context_t * ctx) oberon_assert_token(ctx, UPARROW); expr = oberno_make_dereferencing(ctx, expr); break; + case LPAREN: + oberon_assert_token(ctx, LPAREN); + objtype = oberon_qualident(ctx, NULL, true); + oberon_assert_token(ctx, RPAREN); + oberon_check_extension_of(ctx, expr -> result, objtype -> type); + expr = oberon_cast_expr(ctx, expr, objtype -> type); + break; default: oberon_error(ctx, "oberon_designator: wat"); break; } } + return expr; } static oberon_expr_t * oberon_opt_func_parens(oberon_context_t * ctx, oberon_expr_t * expr) { - assert(expr -> is_item == 1); - /* Если есть скобки - значит вызов. Если нет, то передаём указатель. */ if(ctx -> token == LPAREN) { @@ -1284,7 +1601,8 @@ oberon_opt_func_parens(oberon_context_t * ctx, oberon_expr_t * expr) oberon_expr_list(ctx, &num_args, &arguments, 0); } - expr = oberon_make_call_func(ctx, expr -> item.var, num_args, arguments); + assert(expr -> is_item == 1); + expr = oberon_make_call_func(ctx, (oberon_item_t *) expr, num_args, arguments); oberon_assert_token(ctx, RPAREN); } @@ -1295,7 +1613,7 @@ oberon_opt_func_parens(oberon_context_t * ctx, oberon_expr_t * expr) static void oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr) { - assert(expr -> is_item == 1); + assert(expr -> is_item); int num_args = 0; oberon_expr_t * arguments = NULL; @@ -1313,28 +1631,85 @@ oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr) } /* Вызов происходит даже без скобок */ - oberon_make_call_proc(ctx, expr -> item.var, num_args, arguments); + oberon_make_call_proc(ctx, (oberon_item_t *) expr, num_args, arguments); } -static oberon_type_t * -oberon_get_type_of_int_value(oberon_context_t * ctx, int64_t i) +static oberon_expr_t * +oberon_element(oberon_context_t * ctx) { - if(i >= -128 && i <= 127) + oberon_expr_t * e1; + oberon_expr_t * e2; + + e1 = oberon_expr(ctx); + oberon_check_src(ctx, e1); + if(e1 -> result -> class != OBERON_TYPE_INTEGER) { - return ctx -> byte_type; + oberon_error(ctx, "expected integer"); } - else if(i >= -32768 && i <= 32767) + + e2 = NULL; + if(ctx -> token == DOTDOT) { - return ctx -> shortint_type; + oberon_assert_token(ctx, DOTDOT); + e2 = oberon_expr(ctx); + oberon_check_src(ctx, e2); + if(e2 -> result -> class != OBERON_TYPE_INTEGER) + { + oberon_error(ctx, "expected integer"); + } } - else if(i >= -2147483648 && i <= 2147483647) + + oberon_expr_t * set; + if(e2 == NULL && oberon_is_const(e1)) { - return ctx -> int_type; + set = oberon_make_set_index(ctx, e1 -> item.integer); + } + else if(e2 != NULL && oberon_is_const(e1) && oberon_is_const(e2)) + { + set = oberon_make_set_range(ctx, e1 -> item.integer, e2 -> item.integer); } else { - return ctx -> longint_type; + set = oberon_new_operator(OP_RANGE, ctx -> set_type, e1, e2); + } + return set; +} + +static oberon_expr_t * +oberon_make_set_union(oberon_context_t * ctx, oberon_expr_t * a, oberon_expr_t * b) +{ + if(oberon_is_const(a) && oberon_is_const(b)) + { + return oberon_make_set(ctx, (a -> item.integer | b -> item.integer)); + } + else + { + return oberon_new_operator(OP_UNION, ctx -> set_type, a, b); + } +} + +static oberon_expr_t * +oberon_set(oberon_context_t * ctx) +{ + oberon_expr_t * set; + oberon_expr_t * elements; + set = oberon_make_set(ctx, 0); + + oberon_assert_token(ctx, LBRACE); + if(ISEXPR(ctx -> token)) + { + elements = oberon_element(ctx); + set = oberon_make_set_union(ctx, set, elements); + while(ctx -> token == COMMA) + { + oberon_assert_token(ctx, COMMA); + elements = oberon_element(ctx); + set = oberon_make_set_union(ctx, set, elements); + } } + oberon_assert_token(ctx, RBRACE); + + return set; } static oberon_expr_t * @@ -1350,26 +1725,25 @@ oberon_factor(oberon_context_t * ctx) expr = oberon_opt_func_parens(ctx, expr); break; case INTEGER: - result = oberon_get_type_of_int_value(ctx, ctx -> integer); - expr = oberon_new_item(MODE_INTEGER, result, 1); - expr -> item.integer = ctx -> integer; + expr = oberon_make_integer(ctx, ctx -> integer); oberon_assert_token(ctx, INTEGER); break; + case CHAR: + result = ctx -> char_type; + expr = oberon_new_item(MODE_CHAR, result, true); + expr -> item.integer = ctx -> integer; + oberon_assert_token(ctx, CHAR); + break; + case STRING: + expr = oberon_make_string(ctx, ctx -> string); + oberon_assert_token(ctx, STRING); + break; case REAL: - result = (ctx -> longmode) ? (ctx -> longreal_type) : (ctx -> real_type); - expr = oberon_new_item(MODE_REAL, result, 1); - expr -> item.real = ctx -> real; + expr = oberon_make_real(ctx, ctx -> real, ctx -> longmode); oberon_assert_token(ctx, REAL); break; - case TRUE: - expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, 1); - expr -> item.boolean = true; - oberon_assert_token(ctx, TRUE); - break; - case FALSE: - expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, 1); - expr -> item.boolean = false; - oberon_assert_token(ctx, FALSE); + case LBRACE: + expr = oberon_set(ctx); break; case LPAREN: oberon_assert_token(ctx, LPAREN); @@ -1383,7 +1757,7 @@ oberon_factor(oberon_context_t * ctx) break; case NIL: oberon_assert_token(ctx, NIL); - expr = oberon_new_item(MODE_NIL, ctx -> void_ptr_type, 1); + expr = oberon_new_item(MODE_NIL, ctx -> nil_type, true); break; default: oberon_error(ctx, "invalid expression"); @@ -1392,144 +1766,271 @@ oberon_factor(oberon_context_t * ctx) return expr; } -#define ITMAKESBOOLEAN(x) \ - (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND)) - -#define ITUSEONLYINTEGER(x) \ - ((x) >= LESS && (x) <= GEQ) - -#define ITUSEONLYBOOLEAN(x) \ - (((x) == OR) || ((x) == AND)) - -static void -oberon_autocast_to_real(oberon_context_t * ctx, oberon_expr_t ** e) -{ - oberon_expr_t * expr = *e; - if(expr -> result -> class == OBERON_TYPE_INTEGER) - { - if(expr -> result -> size <= ctx -> real_type -> size) - { - *e = oberon_cast_expr(ctx, expr, ctx -> real_type); - } - else - { - *e = oberon_cast_expr(ctx, expr, ctx -> longreal_type); - } - } - else if(expr -> result -> class != OBERON_TYPE_REAL) - { - oberon_error(ctx, "required numeric type"); - } -} - static oberon_expr_t * oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_expr_t * b) { oberon_expr_t * expr; oberon_type_t * result; - if(ITMAKESBOOLEAN(token)) + oberon_check_compatible_bin_expr(ctx, token, a, b); + oberon_check_src(ctx, a); + if(token != IS) { - if(ITUSEONLYINTEGER(token)) - { - if(a -> result -> class == OBERON_TYPE_INTEGER - || b -> result -> class == OBERON_TYPE_INTEGER - || a -> result -> class == OBERON_TYPE_REAL - || b -> result -> class == OBERON_TYPE_REAL) - { - oberon_error(ctx, "used only with numeric types"); - } - } - else if(ITUSEONLYBOOLEAN(token)) - { - if(a -> result -> class != OBERON_TYPE_BOOLEAN - || b -> result -> class != OBERON_TYPE_BOOLEAN) - { - oberon_error(ctx, "used only with boolean type"); - } - } - - oberon_autocast_binary_op(ctx, &a, &b); - result = ctx -> bool_type; + oberon_check_src(ctx, b); + } - if(token == EQUAL) - { - expr = oberon_new_operator(OP_EQ, result, a, b); - } - else if(token == NEQ) + if(token == IN) + { + if(oberon_is_const(a) && oberon_is_const(b)) { - expr = oberon_new_operator(OP_NEQ, result, a, b); + expr = oberon_make_boolean(ctx, (1 << a -> item.integer) & b -> item.integer); } - else if(token == LESS) + else { - expr = oberon_new_operator(OP_LSS, result, a, b); + expr = oberon_new_operator(OP_IN, ctx -> bool_type, a, b); } - else if(token == LEQ) + } + else if(token == IS) + { + oberon_check_type_expr(ctx, b); + expr = oberon_new_operator(OP_IS, ctx -> bool_type, a, b); + } + else if((token >= EQUAL && token <= GEQ) || token == OR || token == AND) + { + if(oberon_is_string_of_one(a) && oberon_is_char_type(b -> result)) { - expr = oberon_new_operator(OP_LEQ, result, a, b); + result = b -> result; } - else if(token == GREAT) + else if(oberon_is_string_of_one(b) && oberon_is_char_type(a -> result)) { - expr = oberon_new_operator(OP_GRT, result, a, b); + result = a -> result; } - else if(token == GEQ) + else if(oberon_is_string_of_one(a) && oberon_is_string_of_one(b)) { - expr = oberon_new_operator(OP_GEQ, result, a, b); + result = ctx -> char_type; } - else if(token == OR) + else { - expr = oberon_new_operator(OP_LOGIC_OR, result, a, b); + result = oberon_get_longer_type(ctx, a -> result, b -> result); } - else if(token == AND) + + if(oberon_is_const(a) && oberon_is_const(b) + && (oberon_is_real_type(result) || oberon_is_integer_type(result))) { - expr = oberon_new_operator(OP_LOGIC_AND, result, a, b); + if(oberon_is_real_type(result)) + { + double x = a -> item.real; + double y = b -> item.real; + switch(token) + { + case EQUAL: expr = oberon_make_boolean(ctx, x == y); break; + case NEQ: expr = oberon_make_boolean(ctx, x != y); break; + case LESS: expr = oberon_make_boolean(ctx, x < y); break; + case LEQ: expr = oberon_make_boolean(ctx, x <= y); break; + case GREAT: expr = oberon_make_boolean(ctx, x > y); break; + case GEQ: expr = oberon_make_boolean(ctx, x >= y); break; + case OR: expr = oberon_make_boolean(ctx, x || y); break; + case AND: expr = oberon_make_boolean(ctx, x && y); break; + default: assert(0); break; + } + } + else if(oberon_is_integer_type(result)) + { + int64_t x = a -> item.integer; + int64_t y = b -> item.integer; + switch(token) + { + case EQUAL: expr = oberon_make_boolean(ctx, x == y); break; + case NEQ: expr = oberon_make_boolean(ctx, x != y); break; + case LESS: expr = oberon_make_boolean(ctx, x < y); break; + case LEQ: expr = oberon_make_boolean(ctx, x <= y); break; + case GREAT: expr = oberon_make_boolean(ctx, x > y); break; + case GEQ: expr = oberon_make_boolean(ctx, x >= y); break; + case OR: expr = oberon_make_boolean(ctx, x || y); break; + case AND: expr = oberon_make_boolean(ctx, x && y); break; + default: assert(0); break; + } + } + else + { + assert(0); + } } else { - oberon_error(ctx, "oberon_make_bin_op: bool wat"); + a = oberon_cast_expr(ctx, a, result); + b = oberon_cast_expr(ctx, b, result); + result = ctx -> bool_type; + switch(token) + { + case EQUAL: expr = oberon_new_operator(OP_EQ, result, a, b); break; + case NEQ: expr = oberon_new_operator(OP_NEQ, result, a, b); break; + case LESS: expr = oberon_new_operator(OP_LSS, result, a, b); break; + case LEQ: expr = oberon_new_operator(OP_LEQ, result, a, b); break; + case GREAT: expr = oberon_new_operator(OP_GRT, result, a, b); break; + case GEQ: expr = oberon_new_operator(OP_GEQ, result, a, b); break; + case OR: expr = oberon_new_operator(OP_LOGIC_OR, result, a, b); break; + case AND: expr = oberon_new_operator(OP_LOGIC_AND, result, a, b); break; + default: assert(0); break; + } } } else if(token == SLASH) { - oberon_autocast_to_real(ctx, &a); - oberon_autocast_to_real(ctx, &b); - oberon_autocast_binary_op(ctx, &a, &b); - expr = oberon_new_operator(OP_DIV, a -> result, a, b); - } - else if(token == DIV) - { - if(a -> result -> class != OBERON_TYPE_INTEGER - || b -> result -> class != OBERON_TYPE_INTEGER) + if(oberon_is_set_type(a -> result) && oberon_is_set_type(b -> result)) + { + if(oberon_is_const(a) && oberon_is_const(b)) + { + int64_t x = a -> item.integer; + int64_t y = b -> item.integer; + expr = oberon_make_set(ctx, x ^ y); + } + else + { + result = oberon_get_longer_type(ctx, a -> result, b -> result); + a = oberon_cast_expr(ctx, a, result); + b = oberon_cast_expr(ctx, b, result); + expr = oberon_new_operator(OP_SYM_DIFFERENCE, result, a, b); + } + } + else { - oberon_error(ctx, "operator DIV requires integer type"); + result = oberon_get_longer_real_type(ctx, a -> result, b -> result); + if(oberon_is_const(a) && oberon_is_const(b)) + { + double x = a -> item.real; + double y = b -> item.real; + expr = oberon_make_real_typed(ctx, x / y, result); + } + else + { + a = oberon_cast_expr(ctx, a, result); + b = oberon_cast_expr(ctx, b, result); + expr = oberon_new_operator(OP_DIV, result, a, b); + } } - - oberon_autocast_binary_op(ctx, &a, &b); - expr = oberon_new_operator(OP_DIV, a -> result, a, b); } else { - oberon_autocast_binary_op(ctx, &a, &b); + result = oberon_get_longer_type(ctx, a -> result, b -> result); - if(token == PLUS) - { - expr = oberon_new_operator(OP_ADD, a -> result, a, b); - } - else if(token == MINUS) - { - expr = oberon_new_operator(OP_SUB, a -> result, a, b); - } - else if(token == STAR) - { - expr = oberon_new_operator(OP_MUL, a -> result, a, b); - } - else if(token == MOD) + if(oberon_is_const(a) && oberon_is_const(b)) { - expr = oberon_new_operator(OP_MOD, a -> result, a, b); + if(oberon_is_set_type(result)) + { + int64_t x = a -> item.integer; + int64_t y = b -> item.integer; + switch(token) + { + case PLUS: expr = oberon_make_set(ctx, x | y); break; + case MINUS: expr = oberon_make_set(ctx, x & ~y); break; + case STAR: expr = oberon_make_set(ctx, x & y); break; + default: assert(0); break; + } + } + if(oberon_is_real_type(result)) + { + double x = a -> item.real; + double y = b -> item.real; + switch(token) + { + case PLUS: expr = oberon_make_real_typed(ctx, x + y, result); break; + case MINUS: expr = oberon_make_real_typed(ctx, x - y, result); break; + case STAR: expr = oberon_make_real_typed(ctx, x * y, result); break; + default: assert(0); break; + } + } + else if(oberon_is_integer_type(result)) + { + int64_t x = a -> item.integer; + int64_t y = b -> item.integer; + switch(token) + { + case PLUS: expr = oberon_make_integer(ctx, x + y); break; + case MINUS: expr = oberon_make_integer(ctx, x - y); break; + case STAR: expr = oberon_make_integer(ctx, x * y); break; + case DIV: expr = oberon_make_integer(ctx, x / y); break; + case MOD: expr = oberon_make_integer(ctx, x % y); break; + default: assert(0); break; + } + } + else + { + assert(0); + } } else { - oberon_error(ctx, "oberon_make_bin_op: bin wat"); + a = oberon_cast_expr(ctx, a, result); + b = oberon_cast_expr(ctx, b, result); + + + if(oberon_is_set_type(result)) + { + switch(token) + { + case PLUS: + expr = oberon_new_operator(OP_UNION, result, a, b); + break; + case MINUS: + expr = oberon_new_operator(OP_DIFFERENCE, result, a, b); + break; + case STAR: + expr = oberon_new_operator(OP_INTERSECTION, result, a, b); + break; + default: + assert(0); + break; + } + } + else if(oberon_is_real_type(result)) + { + switch(token) + { + case PLUS: + expr = oberon_new_operator(OP_ADD, result, a, b); + break; + case MINUS: + expr = oberon_new_operator(OP_SUB, result, a, b); + break; + case STAR: + expr = oberon_new_operator(OP_MUL, result, a, b); + break; + default: + printf("token %i line %i\n", token, ctx -> loc.line); + assert(0); + break; + } + } + else if(oberon_is_integer_type(result)) + { + switch(token) + { + case PLUS: + expr = oberon_new_operator(OP_ADD, result, a, b); + break; + case MINUS: + expr = oberon_new_operator(OP_SUB, result, a, b); + break; + case STAR: + expr = oberon_new_operator(OP_MUL, result, a, b); + break; + case DIV: + expr = oberon_new_operator(OP_DIV, result, a, b); + break; + case MOD: + expr = oberon_new_operator(OP_MOD, result, a, b); + break; + default: + printf("token %i line %i\n", token, ctx -> loc.line); + assert(0); + break; + } + } + else + { + assert(0); + } } } @@ -1579,11 +2080,6 @@ oberon_simple_expr(oberon_context_t * ctx) expr = oberon_term_expr(ctx); - if(minus) - { - expr = oberon_make_unary_op(ctx, MINUS, expr); - } - while(ISADDOP(ctx -> token)) { int token = ctx -> token; @@ -1593,11 +2089,16 @@ oberon_simple_expr(oberon_context_t * ctx) expr = oberon_make_bin_op(ctx, token, expr, inter); } + if(minus) + { + expr = oberon_make_unary_op(ctx, MINUS, expr); + } + return expr; } #define ISRELATION(x) \ - ((x) >= EQUAL && (x) <= GEQ) + ((x) >= EQUAL && (x) <= IS) static oberon_expr_t * oberon_expr(oberon_context_t * ctx) @@ -1617,17 +2118,50 @@ oberon_expr(oberon_context_t * ctx) return expr; } -static oberon_item_t * -oberon_const_expr(oberon_context_t * ctx) +static bool +oberon_is_const(oberon_expr_t * expr) { - oberon_expr_t * expr; - expr = oberon_expr(ctx); + if(expr -> is_item == false) + { + return false; + } + + switch(expr -> item.mode) + { + case MODE_INTEGER: + case MODE_BOOLEAN: + case MODE_NIL: + case MODE_REAL: + case MODE_CHAR: + case MODE_STRING: + case MODE_SET: + case MODE_TYPE: + case MODE_SYSBYTE: + return true; + break; + default: + return false; + break; + } + + return false; +} - if(expr -> is_item == 0) +static void +oberon_check_const(oberon_context_t * ctx, oberon_expr_t * expr) +{ + if(!oberon_is_const(expr)) { oberon_error(ctx, "const expression are required"); } +} +static oberon_item_t * +oberon_const_expr(oberon_context_t * ctx) +{ + oberon_expr_t * expr; + expr = oberon_expr(ctx); + oberon_check_const(ctx, expr); return (oberon_item_t *) expr; } @@ -1720,7 +2254,7 @@ oberon_var_decl(oberon_context_t * ctx) int num; oberon_object_t * list; oberon_type_t * type; - type = oberon_new_type_ptr(OBERON_TYPE_VOID); + type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE); oberon_ident_list(ctx, OBERON_CLASS_VAR, false, &num, &list); oberon_assert_token(ctx, COLON); @@ -1751,7 +2285,7 @@ oberon_fp_section(oberon_context_t * ctx, int * num_decl) oberon_assert_token(ctx, COLON); oberon_type_t * type; - type = oberon_new_type_ptr(OBERON_TYPE_VOID); + type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE); oberon_type(ctx, &type); oberon_object_t * param = list; @@ -1795,6 +2329,11 @@ oberon_formal_pars(oberon_context_t * ctx, oberon_type_t * signature) { oberon_error(ctx, "function result is not type"); } + if(typeobj -> type -> class == OBERON_TYPE_RECORD + || typeobj -> type -> class == OBERON_TYPE_ARRAY) + { + oberon_error(ctx, "records or arrays could not be result of function"); + } signature -> base = typeobj -> type; } } @@ -1806,7 +2345,7 @@ oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type) signature = *type; signature -> class = OBERON_TYPE_PROCEDURE; signature -> num_decl = 0; - signature -> base = ctx -> void_type; + signature -> base = ctx -> notype_type; signature -> decl = NULL; if(ctx -> token == LPAREN) @@ -1849,7 +2388,7 @@ oberon_make_return(oberon_context_t * ctx, oberon_expr_t * expr) oberon_object_t * proc = ctx -> decl -> parent; oberon_type_t * result_type = proc -> type -> base; - if(result_type -> class == OBERON_TYPE_VOID) + if(result_type -> class == OBERON_TYPE_NOTYPE) { if(expr != NULL) { @@ -1863,7 +2402,9 @@ oberon_make_return(oberon_context_t * ctx, oberon_expr_t * expr) oberon_error(ctx, "procedure requires expression on result"); } - expr = oberon_autocast_to(ctx, expr, result_type); + oberon_check_src(ctx, expr); + oberon_check_assignment_compatible(ctx, expr, result_type); + expr = oberon_cast_expr(ctx, expr, result_type); } proc -> has_return = 1; @@ -1895,8 +2436,7 @@ oberon_proc_decl_body(oberon_context_t * ctx, oberon_object_t * proc) oberon_error(ctx, "procedure name not matched"); } - if(proc -> type -> base -> class == OBERON_TYPE_VOID - && proc -> has_return == 0) + if(proc -> type -> base -> class == OBERON_TYPE_NOTYPE) { oberon_make_return(ctx, NULL); } @@ -1925,6 +2465,12 @@ oberon_proc_decl(oberon_context_t * ctx) char * name; int export; int read_only; + + if(ctx -> token == STAR) + { + oberon_assert_token(ctx, STAR); + } + name = oberon_assert_ident(ctx); oberon_def(ctx, &export, &read_only); @@ -1933,16 +2479,23 @@ oberon_proc_decl(oberon_context_t * ctx) ctx -> decl -> local = 1; oberon_type_t * signature; - signature = oberon_new_type_ptr(OBERON_TYPE_VOID); + signature = oberon_new_type_ptr(OBERON_TYPE_NOTYPE); oberon_opt_formal_pars(ctx, &signature); - oberon_initialize_decl(ctx); + //oberon_initialize_decl(ctx); oberon_generator_init_type(ctx, signature); oberon_close_scope(ctx -> decl); oberon_object_t * proc; - proc = oberon_find_object(ctx -> decl, name, 0); - if(proc != NULL) + proc = oberon_find_object_in_scope(ctx -> decl, name, 0); + if(proc == NULL) + { + proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, export, read_only, false); + proc -> type = signature; + proc -> scope = proc_scope; + oberon_generator_init_proc(ctx, proc); + } + else { if(proc -> class != OBERON_CLASS_PROC) { @@ -1964,16 +2517,15 @@ oberon_proc_decl(oberon_context_t * ctx) oberon_compare_signatures(ctx, proc -> type, signature); } - else + + proc_scope -> parent = proc; + oberon_object_t * param = proc_scope -> list -> next; + while(param) { - proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, export, read_only, false); - proc -> type = signature; - proc -> scope = proc_scope; - oberon_generator_init_proc(ctx, proc); + param -> parent = proc; + param = param -> next; } - proc -> scope -> parent = proc; - if(forward == 0) { proc -> linked = 1; @@ -2034,7 +2586,7 @@ oberon_qualident_type(oberon_context_t * ctx, oberon_type_t ** type) else { to = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, false, false, false); - to -> type = oberon_new_type_ptr(OBERON_TYPE_VOID); + to -> type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE); } *type = to -> type; @@ -2056,7 +2608,7 @@ oberon_make_multiarray(oberon_context_t * ctx, oberon_expr_t * sizes, oberon_typ } oberon_type_t * dim; - dim = oberon_new_type_ptr(OBERON_TYPE_VOID); + dim = oberon_new_type_ptr(OBERON_TYPE_NOTYPE); oberon_make_multiarray(ctx, sizes -> next, base, &dim); @@ -2079,7 +2631,7 @@ oberon_field_list(oberon_context_t * ctx, oberon_type_t * rec, oberon_scope_t * int num; oberon_object_t * list; oberon_type_t * type; - type = oberon_new_type_ptr(OBERON_TYPE_VOID); + type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE); oberon_ident_list(ctx, OBERON_CLASS_FIELD, true, &num, &list); oberon_assert_token(ctx, COLON); @@ -2103,9 +2655,8 @@ oberon_field_list(oberon_context_t * ctx, oberon_type_t * rec, oberon_scope_t * static void oberon_type_record_body(oberon_context_t * ctx, oberon_type_t * rec) { - oberon_scope_t * modscope = ctx -> mod -> decl; oberon_scope_t * oldscope = ctx -> decl; - ctx -> decl = modscope; + ctx -> decl = oldscope; if(ctx -> token == LPAREN) { @@ -2119,13 +2670,19 @@ oberon_type_record_body(oberon_context_t * ctx, oberon_type_t * rec) oberon_error(ctx, "base must be type"); } - if(typeobj -> type -> class != OBERON_TYPE_RECORD) + oberon_type_t * base = typeobj -> type; + if(base -> class == OBERON_TYPE_POINTER) + { + base = base -> base; + } + + if(base -> class != OBERON_TYPE_RECORD) { oberon_error(ctx, "base must be record type"); } - rec -> base = typeobj -> type; - ctx -> decl = rec -> base -> scope; + rec -> base = base; + ctx -> decl = base -> scope; oberon_assert_token(ctx, RPAREN); } @@ -2140,11 +2697,11 @@ oberon_type_record_body(oberon_context_t * ctx, oberon_type_t * rec) this_scope -> parent = NULL; this_scope -> parent_type = rec; - oberon_field_list(ctx, rec, modscope); + oberon_field_list(ctx, rec, oldscope); while(ctx -> token == SEMICOLON) { oberon_assert_token(ctx, SEMICOLON); - oberon_field_list(ctx, rec, modscope); + oberon_field_list(ctx, rec, oldscope); } rec -> scope = this_scope; @@ -2174,7 +2731,7 @@ oberon_type(oberon_context_t * ctx, oberon_type_t ** type) oberon_assert_token(ctx, OF); oberon_type_t * base; - base = oberon_new_type_ptr(OBERON_TYPE_VOID); + base = oberon_new_type_ptr(OBERON_TYPE_NOTYPE); oberon_type(ctx, &base); if(num_sizes == 0) @@ -2205,7 +2762,7 @@ oberon_type(oberon_context_t * ctx, oberon_type_t ** type) oberon_assert_token(ctx, TO); oberon_type_t * base; - base = oberon_new_type_ptr(OBERON_TYPE_VOID); + base = oberon_new_type_ptr(OBERON_TYPE_NOTYPE); oberon_type(ctx, &base); oberon_type_t * ptr; @@ -2242,7 +2799,7 @@ oberon_type_decl(oberon_context_t * ctx) if(newtype == NULL) { newtype = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, export, read_only, false); - newtype -> type = oberon_new_type_ptr(OBERON_TYPE_VOID); + newtype -> type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE); assert(newtype -> type); } else @@ -2266,7 +2823,7 @@ oberon_type_decl(oberon_context_t * ctx) type = newtype -> type; oberon_type(ctx, &type); - if(type -> class == OBERON_TYPE_VOID) + if(type -> class == OBERON_TYPE_NOTYPE) { oberon_error(ctx, "recursive alias declaration"); } @@ -2289,7 +2846,14 @@ oberon_prevent_recursive_pointer(oberon_context_t * ctx, oberon_type_t * type) if(type -> recursive) { - oberon_error(ctx, "recursive pointer declaration"); + if(type -> class == OBERON_TYPE_POINTER) + { + oberon_error(ctx, "recursive pointer declaration"); + } + else + { + oberon_error(ctx, "recursive array declaration (pointer)"); + } } if(type -> class == OBERON_TYPE_POINTER @@ -2320,6 +2884,11 @@ oberon_prevent_recursive_record(oberon_context_t * ctx, oberon_type_t * type) type -> recursive = 1; + if(type -> base) + { + oberon_prevent_recursive_record(ctx, type -> base); + } + int num_fields = type -> num_decl; oberon_object_t * field = type -> decl; for(int i = 0; i < num_fields; i++) @@ -2437,20 +3006,12 @@ static void oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type) static void oberon_initialize_record_fields(oberon_context_t * ctx, oberon_type_t * type) { - if(type -> class != OBERON_TYPE_RECORD) - { - return; - } + assert(type -> class == OBERON_TYPE_RECORD); int num_fields = type -> num_decl; oberon_object_t * field = type -> decl; for(int i = 0; i < num_fields; i++) { - if(field -> type -> class == OBERON_TYPE_POINTER) - { - oberon_initialize_type(ctx, field -> type); - } - oberon_initialize_object(ctx, field); field = field -> next; } @@ -2461,7 +3022,7 @@ oberon_initialize_record_fields(oberon_context_t * ctx, oberon_type_t * type) static void oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type) { - if(type -> class == OBERON_TYPE_VOID) + if(type -> class == OBERON_TYPE_NOTYPE) { oberon_error(ctx, "undeclarated type"); } @@ -2473,41 +3034,53 @@ oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type) type -> initialized = 1; - if(type -> class == OBERON_TYPE_POINTER) - { - oberon_initialize_type(ctx, type -> base); - oberon_generator_init_type(ctx, type); - } - else if(type -> class == OBERON_TYPE_ARRAY) + if(type -> class == OBERON_TYPE_POINTER || type -> class == OBERON_TYPE_ARRAY) { - if(type -> size != 0) + if(type -> class == OBERON_TYPE_ARRAY + && type -> size != 0 + && type -> base -> class == OBERON_TYPE_ARRAY + && type -> base -> size == 0) { - if(type -> base -> class == OBERON_TYPE_ARRAY) - { - if(type -> base -> size == 0) - { - oberon_error(ctx, "open array not allowed as array element"); - } - } + oberon_error(ctx, "open array not allowed as array element"); } - oberon_initialize_type(ctx, type -> base); - oberon_generator_init_type(ctx, type); + oberon_type_t * rec = type -> base; + while(rec -> class == OBERON_TYPE_ARRAY || rec -> class == OBERON_TYPE_POINTER) + { + rec = rec -> base; + } + + if(rec -> class == OBERON_TYPE_RECORD + && rec -> initialized == 0) + { + rec -> initialized = 1; + oberon_generator_init_type(ctx, rec); + oberon_initialize_type(ctx, type -> base); + oberon_generator_init_type(ctx, type); + oberon_initialize_record_fields(ctx, rec); + } + else + { + oberon_initialize_type(ctx, type -> base); + oberon_generator_init_type(ctx, type); + } } else if(type -> class == OBERON_TYPE_RECORD) { + printf("Init type: RECORD\n"); oberon_generator_init_type(ctx, type); oberon_initialize_record_fields(ctx, type); } else if(type -> class == OBERON_TYPE_PROCEDURE) { + printf("Init type: PROCEDURE\n"); int num_fields = type -> num_decl; oberon_object_t * field = type -> decl; for(int i = 0; i < num_fields; i++) { - oberon_initialize_object(ctx, field); + oberon_initialize_type(ctx, field -> type); field = field -> next; - } + } oberon_generator_init_type(ctx, type); } @@ -2592,33 +3165,34 @@ oberon_prevent_undeclarated_procedures(oberon_context_t * ctx) static void oberon_decl_seq(oberon_context_t * ctx) { - if(ctx -> token == CONST) + while(ctx -> token >= CONST && ctx -> token <= VAR) { - oberon_assert_token(ctx, CONST); - while(ctx -> token == IDENT) + if(ctx -> token == CONST) { - oberon_const_decl(ctx); - oberon_assert_token(ctx, SEMICOLON); + oberon_assert_token(ctx, CONST); + while(ctx -> token == IDENT) + { + oberon_const_decl(ctx); + oberon_assert_token(ctx, SEMICOLON); + } } - } - - if(ctx -> token == TYPE) - { - oberon_assert_token(ctx, TYPE); - while(ctx -> token == IDENT) + else if(ctx -> token == TYPE) { - oberon_type_decl(ctx); - oberon_assert_token(ctx, SEMICOLON); + oberon_assert_token(ctx, TYPE); + while(ctx -> token == IDENT) + { + oberon_type_decl(ctx); + oberon_assert_token(ctx, SEMICOLON); + } } - } - - if(ctx -> token == VAR) - { - oberon_assert_token(ctx, VAR); - while(ctx -> token == IDENT) + else if(ctx -> token == VAR) { - oberon_var_decl(ctx); - oberon_assert_token(ctx, SEMICOLON); + oberon_assert_token(ctx, VAR); + while(ctx -> token == IDENT) + { + oberon_var_decl(ctx); + oberon_assert_token(ctx, SEMICOLON); + } } } @@ -2634,16 +3208,204 @@ oberon_decl_seq(oberon_context_t * ctx) oberon_prevent_undeclarated_procedures(ctx); } +static oberon_expr_t * +oberon_make_temp_var_item(oberon_context_t * ctx, oberon_type_t * type) +{ + oberon_object_t * x; + oberon_expr_t * expr; + + x = oberon_create_object(ctx -> decl, "TEMP", OBERON_CLASS_VAR, false, false); + x -> local = true; + x -> type = type; + oberon_generator_init_temp_var(ctx, x); + + expr = oberon_new_item(MODE_VAR, type, false); + expr -> item.var = x; + return expr; +} + +static void +oberon_statement_seq(oberon_context_t * ctx); + static void oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst) { - if(dst -> read_only) + oberon_check_dst(ctx, dst); + oberon_check_assignment_compatible(ctx, src, dst -> result); + + if(oberon_is_array_of_char_type(dst -> result) + && oberon_is_string_type(src -> result)) { - oberon_error(ctx, "read-only destination"); + src -> next = dst; + oberon_make_copy_call(ctx, 2, src); + } + else + { + src = oberon_cast_expr(ctx, src, dst -> result); + oberon_generate_assign(ctx, src, dst); + } +} + +static oberon_expr_t * +oberon_case_labels(oberon_context_t * ctx, oberon_expr_t * val) +{ + oberon_expr_t * e1; + oberon_expr_t * e2; + oberon_expr_t * cond; + oberon_expr_t * cond2; + + e1 = (oberon_expr_t *) oberon_const_expr(ctx); + + e2 = NULL; + if(ctx -> token == DOTDOT) + { + oberon_assert_token(ctx, DOTDOT); + e2 = (oberon_expr_t *) oberon_const_expr(ctx); + } + + if(e2 == NULL) + { + /* val == e1 */ + cond = oberon_make_bin_op(ctx, EQUAL, val, e1); + } + else + { + /* val >= e1 && val <= e2 */ + cond = oberon_make_bin_op(ctx, GEQ, val, e1); + cond2 = oberon_make_bin_op(ctx, LEQ, val, e2); + cond = oberon_make_bin_op(ctx, AND, cond, cond2); + } + + return cond; +} + +static void +oberon_case(oberon_context_t * ctx, oberon_expr_t * val, gen_label_t * end) +{ + oberon_expr_t * cond; + oberon_expr_t * cond2; + gen_label_t * this_end; + + if(ISEXPR(ctx -> token)) + { + this_end = oberon_generator_reserve_label(ctx); + + cond = oberon_case_labels(ctx, val); + while(ctx -> token == COMMA) + { + oberon_assert_token(ctx, COMMA); + /* cond || cond2 */ + cond2 = oberon_case_labels(ctx, val); + cond = oberon_make_bin_op(ctx, OR, cond, cond2); + } + oberon_assert_token(ctx, COLON); + + oberon_generate_branch(ctx, cond, false, this_end); + oberon_statement_seq(ctx); + oberon_generate_goto(ctx, end); + + oberon_generate_label(ctx, this_end); + } +} + +static void +oberon_case_statement(oberon_context_t * ctx) +{ + oberon_expr_t * val; + oberon_expr_t * expr; + gen_label_t * end; + + end = oberon_generator_reserve_label(ctx); + + oberon_assert_token(ctx, CASE); + expr = oberon_expr(ctx); + val = oberon_make_temp_var_item(ctx, expr -> result); + oberon_assign(ctx, expr, val); + oberon_assert_token(ctx, OF); + oberon_case(ctx, val, end); + while(ctx -> token == BAR) + { + oberon_assert_token(ctx, BAR); + oberon_case(ctx, val, end); + } + + if(ctx -> token == ELSE) + { + oberon_assert_token(ctx, ELSE); + oberon_statement_seq(ctx); + } + else + { + oberon_generate_trap(ctx, -1); + } + + oberon_generate_label(ctx, end); + oberon_assert_token(ctx, END); +} + +static void +oberon_with_guard_do(oberon_context_t * ctx, gen_label_t * end) +{ + oberon_object_t * var; + oberon_expr_t * var_expr; + oberon_expr_t * type_expr; + oberon_expr_t * cond; + oberon_type_t * type; + oberon_type_t * old_type; + gen_label_t * this_end; + + this_end = oberon_generator_reserve_label(ctx); + + var_expr = oberon_qualident_expr(ctx); + oberon_assert_token(ctx, COLON); + type_expr = oberon_qualident_expr(ctx); + cond = oberon_make_bin_op(ctx, IS, var_expr, type_expr); + + var = var_expr -> item.var; + type = type_expr -> result; + old_type = var -> type; + + oberon_assert_token(ctx, DO); + oberon_generate_branch(ctx, cond, false, this_end); + + var -> type = type; + oberon_set_typecheck(var, true); + + oberon_statement_seq(ctx); + + var -> type = old_type; + oberon_set_typecheck(var, false); + + oberon_generate_goto(ctx, end); + oberon_generate_label(ctx, this_end); +} + +static void +oberon_with_statement(oberon_context_t * ctx) +{ + gen_label_t * end; + end = oberon_generator_reserve_label(ctx); + + oberon_assert_token(ctx, WITH); + oberon_with_guard_do(ctx, end); + while(ctx -> token == BAR) + { + oberon_assert_token(ctx, BAR); + oberon_with_guard_do(ctx, end); + } + + if(ctx -> token == ELSE) + { + oberon_assert_token(ctx, ELSE); + oberon_statement_seq(ctx); + } + else + { + oberon_generate_trap(ctx, -2); } - src = oberon_autocast_to(ctx, src, dst -> result); - oberon_generate_assign(ctx, src, dst); + oberon_generate_label(ctx, end); + oberon_assert_token(ctx, END); } static void @@ -2666,6 +3428,200 @@ oberon_statement(oberon_context_t * ctx) oberon_opt_proc_parens(ctx, item1); } } + else if(ctx -> token == IF) + { + gen_label_t * end; + gen_label_t * els; + oberon_expr_t * cond; + + els = oberon_generator_reserve_label(ctx); + end = oberon_generator_reserve_label(ctx); + + oberon_assert_token(ctx, IF); + cond = oberon_expr(ctx); + if(cond -> result -> class != OBERON_TYPE_BOOLEAN) + { + oberon_error(ctx, "condition must be boolean"); + } + oberon_assert_token(ctx, THEN); + oberon_generate_branch(ctx, cond, false, els); + oberon_statement_seq(ctx); + oberon_generate_goto(ctx, end); + oberon_generate_label(ctx, els); + + while(ctx -> token == ELSIF) + { + els = oberon_generator_reserve_label(ctx); + + oberon_assert_token(ctx, ELSIF); + cond = oberon_expr(ctx); + if(cond -> result -> class != OBERON_TYPE_BOOLEAN) + { + oberon_error(ctx, "condition must be boolean"); + } + oberon_assert_token(ctx, THEN); + oberon_generate_branch(ctx, cond, false, els); + oberon_statement_seq(ctx); + oberon_generate_goto(ctx, end); + oberon_generate_label(ctx, els); + } + + if(ctx -> token == ELSE) + { + oberon_assert_token(ctx, ELSE); + oberon_statement_seq(ctx); + } + + oberon_generate_label(ctx, end); + oberon_assert_token(ctx, END); + } + else if(ctx -> token == WHILE) + { + gen_label_t * begin; + gen_label_t * end; + oberon_expr_t * cond; + + begin = oberon_generator_reserve_label(ctx); + end = oberon_generator_reserve_label(ctx); + + oberon_assert_token(ctx, WHILE); + oberon_generate_label(ctx, begin); + cond = oberon_expr(ctx); + if(cond -> result -> class != OBERON_TYPE_BOOLEAN) + { + oberon_error(ctx, "condition must be boolean"); + } + oberon_generate_branch(ctx, cond, false, end); + + oberon_assert_token(ctx, DO); + oberon_statement_seq(ctx); + oberon_generate_goto(ctx, begin); + + oberon_assert_token(ctx, END); + oberon_generate_label(ctx, end); + } + else if(ctx -> token == REPEAT) + { + gen_label_t * begin; + oberon_expr_t * cond; + + begin = oberon_generator_reserve_label(ctx); + oberon_generate_label(ctx, begin); + oberon_assert_token(ctx, REPEAT); + + oberon_statement_seq(ctx); + + oberon_assert_token(ctx, UNTIL); + + cond = oberon_expr(ctx); + if(cond -> result -> class != OBERON_TYPE_BOOLEAN) + { + oberon_error(ctx, "condition must be boolean"); + } + + oberon_generate_branch(ctx, cond, false, begin); + } + else if(ctx -> token == FOR) + { + oberon_expr_t * from; + oberon_expr_t * index; + oberon_expr_t * to; + oberon_expr_t * bound; + oberon_expr_t * by; + oberon_expr_t * cond; + oberon_expr_t * count; + gen_label_t * begin; + gen_label_t * end; + char * iname; + int op; + + begin = oberon_generator_reserve_label(ctx); + end = oberon_generator_reserve_label(ctx); + + oberon_assert_token(ctx, FOR); + iname = oberon_assert_ident(ctx); + index = oberon_ident_item(ctx, iname); + oberon_assert_token(ctx, ASSIGN); + from = oberon_expr(ctx); + oberon_assert_token(ctx, TO); + bound = oberon_make_temp_var_item(ctx, index -> result); + to = oberon_expr(ctx); + oberon_assign(ctx, to, bound); // сначала temp + oberon_assign(ctx, from, index); // потом i + if(ctx -> token == BY) + { + oberon_assert_token(ctx, BY); + by = (oberon_expr_t *) oberon_const_expr(ctx); + } + else + { + by = oberon_make_integer(ctx, 1); + } + + if(by -> result -> class != OBERON_TYPE_INTEGER) + { + oberon_error(ctx, "must be integer"); + } + + if(by -> item.integer > 0) + { + op = LEQ; + } + else if(by -> item.integer < 0) + { + op = GEQ; + } + else + { + oberon_error(ctx, "zero step not allowed"); + } + + oberon_assert_token(ctx, DO); + oberon_generate_label(ctx, begin); + cond = oberon_make_bin_op(ctx, op, index, bound); + oberon_generate_branch(ctx, cond, false, end); + oberon_statement_seq(ctx); + count = oberon_make_bin_op(ctx, PLUS, index, by); + oberon_assign(ctx, count, index); + oberon_generate_goto(ctx, begin); + oberon_generate_label(ctx, end); + oberon_assert_token(ctx, END); + } + else if(ctx -> token == LOOP) + { + gen_label_t * begin; + gen_label_t * end; + + begin = oberon_generator_reserve_label(ctx); + end = oberon_generator_reserve_label(ctx); + + oberon_open_scope(ctx); + oberon_assert_token(ctx, LOOP); + oberon_generate_label(ctx, begin); + ctx -> decl -> exit_label = end; + oberon_statement_seq(ctx); + oberon_generate_goto(ctx, begin); + oberon_generate_label(ctx, end); + oberon_assert_token(ctx, END); + oberon_close_scope(ctx -> decl); + } + else if(ctx -> token == EXIT) + { + oberon_assert_token(ctx, EXIT); + if(ctx -> decl -> exit_label == NULL) + { + oberon_error(ctx, "not in LOOP-END"); + } + oberon_generate_goto(ctx, ctx -> decl -> exit_label); + } + else if(ctx -> token == CASE) + { + oberon_case_statement(ctx); + } + else if(ctx -> token == WITH) + { + oberon_with_statement(ctx); + } else if(ctx -> token == RETURN) { oberon_assert_token(ctx, RETURN); @@ -2704,14 +3660,14 @@ oberon_import_module(oberon_context_t * ctx, char * alias, char * name) if(m == NULL) { - const char * code; - code = ctx -> import_module(name); - if(code == NULL) + oberon_scanner_t * s; + s = ctx -> import_module(name); + if(s == NULL) { - oberon_error(ctx, "no such module"); + oberon_error(ctx, "no such module %s", name); } - m = oberon_compile_module(ctx, code); + m = oberon_compile_module(ctx, s); assert(m); } @@ -2787,7 +3743,7 @@ oberon_parse_module(oberon_context_t * ctx) oberon_assert_token(ctx, END); name2 = oberon_assert_ident(ctx); - oberon_assert_token(ctx, DOT); + oberon_expect_token(ctx, DOT); if(strcmp(name1, name2) != 0) { @@ -2801,51 +3757,56 @@ oberon_parse_module(oberon_context_t * ctx) // LIBRARY // ======================================================================= -static void -register_default_types(oberon_context_t * ctx) +static oberon_expr_t * +oberon_make_min_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) { - ctx -> void_type = oberon_new_type_ptr(OBERON_TYPE_VOID); - oberon_generator_init_type(ctx, ctx -> void_type); - - ctx -> void_ptr_type = oberon_new_type_ptr(OBERON_TYPE_POINTER); - ctx -> void_ptr_type -> base = ctx -> void_type; - oberon_generator_init_type(ctx, ctx -> void_ptr_type); - - ctx -> bool_type = oberon_new_type_boolean(); - oberon_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type, 1); - - ctx -> byte_type = oberon_new_type_integer(1); - oberon_define_type(ctx -> world_scope, "BYTE", ctx -> byte_type, 1); - - ctx -> shortint_type = oberon_new_type_integer(2); - oberon_define_type(ctx -> world_scope, "SHORTINT", ctx -> shortint_type, 1); + if(num_args < 1) + { + oberon_error(ctx, "too few arguments"); + } - ctx -> int_type = oberon_new_type_integer(4); - oberon_define_type(ctx -> world_scope, "INTEGER", ctx -> int_type, 1); + if(num_args > 1) + { + oberon_error(ctx, "too mach arguments"); + } - ctx -> longint_type = oberon_new_type_integer(8); - oberon_define_type(ctx -> world_scope, "LONGINT", ctx -> longint_type, 1); + oberon_expr_t * arg; + arg = list_args; - ctx -> real_type = oberon_new_type_real(4); - oberon_define_type(ctx -> world_scope, "REAL", ctx -> real_type, 1); + if(!oberon_is_type_expr(arg)) + { + oberon_error(ctx, "MIN accept only type"); + } - ctx -> longreal_type = oberon_new_type_real(8); - oberon_define_type(ctx -> world_scope, "LONGREAL", ctx -> longreal_type, 1); -} + oberon_expr_t * expr; + int bits = arg -> result -> size * 8; + switch(arg -> result -> class) + { + case OBERON_TYPE_INTEGER: + expr = oberon_make_integer(ctx, -powl(2, bits - 1)); + break; + case OBERON_TYPE_BOOLEAN: + expr = oberon_make_boolean(ctx, false); + break; + case OBERON_TYPE_CHAR: + expr = oberon_make_char(ctx, 0); + break; + case OBERON_TYPE_REAL: + expr = oberon_make_real_typed(ctx, (bits <= 32) ? (-FLT_MAX) : (-DBL_MAX), arg -> result); + break; + case OBERON_TYPE_SET: + expr = oberon_make_integer(ctx, 0); + break; + default: + oberon_error(ctx, "allowed only basic types"); + break; + } -static void -oberon_new_intrinsic(oberon_context_t * ctx, char * name, GenerateFuncCallback f, GenerateProcCallback p) -{ - oberon_object_t * proc; - proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, true, false, false); - proc -> sysproc = 1; - proc -> genfunc = f; - proc -> genproc = p; - proc -> type = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE); + return expr; } static oberon_expr_t * -oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +oberon_make_max_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) { if(num_args < 1) { @@ -2860,35 +3821,294 @@ oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ oberon_expr_t * arg; arg = list_args; - oberon_type_t * result_type; - result_type = arg -> result; - - if(result_type -> class != OBERON_TYPE_INTEGER) + if(!oberon_is_type_expr(arg)) { - oberon_error(ctx, "ABS accepts only integers"); + oberon_error(ctx, "MAX accept only type"); } - oberon_expr_t * expr; - expr = oberon_new_operator(OP_ABS, result_type, arg, NULL); + int bits = arg -> result -> size * 8; + switch(arg -> result -> class) + { + case OBERON_TYPE_INTEGER: + expr = oberon_make_integer(ctx, powl(2, bits - 1) - 1); + break; + case OBERON_TYPE_BOOLEAN: + expr = oberon_make_boolean(ctx, true); + break; + case OBERON_TYPE_CHAR: + expr = oberon_make_char(ctx, powl(2, bits) - 1); + break; + case OBERON_TYPE_REAL: + expr = oberon_make_real_typed(ctx, (bits <= 32) ? (FLT_MAX) : (DBL_MAX), arg -> result); + break; + case OBERON_TYPE_SET: + expr = oberon_make_integer(ctx, bits); + break; + default: + oberon_error(ctx, "allowed only basic types"); + break; + } + return expr; } -static void -oberon_make_new_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +static oberon_expr_t * +oberon_make_size_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) { if(num_args < 1) { oberon_error(ctx, "too few arguments"); } - oberon_expr_t * dst; - dst = list_args; - - oberon_type_t * type; - type = dst -> result; - - if(type -> class != OBERON_TYPE_POINTER) + if(num_args > 1) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * arg; + arg = list_args; + if(!oberon_is_type_expr(arg)) + { + oberon_error(ctx, "SIZE accept only type"); + } + + int size; + oberon_expr_t * expr; + oberon_type_t * type = arg -> result; + switch(type -> class) + { + case OBERON_TYPE_INTEGER: + case OBERON_TYPE_BOOLEAN: + case OBERON_TYPE_REAL: + case OBERON_TYPE_CHAR: + case OBERON_TYPE_SET: + size = type -> size; + break; + default: + oberon_error(ctx, "TODO SIZE"); + break; + } + + expr = oberon_make_integer(ctx, size); + return expr; +} + +static oberon_expr_t * +oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 1) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 1) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * arg; + arg = list_args; + oberon_check_src(ctx, arg); + + if(!oberon_is_number_type(arg -> result)) + { + oberon_error(ctx, "ABS accepts only numbers"); + } + + oberon_expr_t * expr; + if(oberon_is_const(arg)) + { + if(oberon_is_real_type(arg -> result)) + { + double x = arg -> item.real; + expr = oberon_make_real(ctx, fabsl(x), arg -> result); + } + else + { + int64_t x = arg -> item.integer; + expr = oberon_make_integer(ctx, llabs(x)); + } + } + else + { + expr = oberon_new_operator(OP_ABS, arg -> result, arg, NULL); + } + return expr; +} + +static void +oberon_make_inc_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 1) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 2) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * dst; + dst = list_args; + oberon_check_dst(ctx, dst); + + if(!oberon_is_integer_type(dst -> result)) + { + oberon_error(ctx, "expect integer"); + } + + oberon_expr_t * step; + if(num_args == 2) + { + step = list_args -> next; + oberon_check_src(ctx, step); + if(!oberon_is_integer_type(step -> result)) + { + oberon_error(ctx, "expect integer"); + } + } + else + { + step = oberon_make_integer(ctx, 1); + } + + oberon_expr_t * expr; + expr = oberon_make_bin_op(ctx, PLUS, dst, step); + oberon_assign(ctx, expr, dst); +} + +static void +oberon_make_incl_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 2) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 2) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * dst; + dst = list_args; + oberon_check_dst(ctx, dst); + + if(!oberon_is_set_type(dst -> result)) + { + oberon_error(ctx, "expect integer"); + } + + oberon_expr_t * x; + x = list_args -> next; + oberon_check_src(ctx, x); + + if(!oberon_is_integer_type(x -> result)) + { + oberon_error(ctx, "expect integer"); + } + + oberon_expr_t * expr; + expr = oberon_make_bin_op(ctx, PLUS, dst, oberon_new_operator(OP_RANGE, dst -> result, x, NULL)); + oberon_assign(ctx, expr, dst); +} + +static void +oberon_make_excl_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 2) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 2) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * dst; + dst = list_args; + oberon_check_dst(ctx, dst); + + if(!oberon_is_set_type(dst -> result)) + { + oberon_error(ctx, "expect integer"); + } + + oberon_expr_t * x; + x = list_args -> next; + oberon_check_src(ctx, x); + + if(!oberon_is_integer_type(x -> result)) + { + oberon_error(ctx, "expect integer"); + } + + oberon_expr_t * expr; + expr = oberon_make_bin_op(ctx, MINUS, dst, oberon_new_operator(OP_RANGE, dst -> result, x, NULL)); + oberon_assign(ctx, expr, dst); +} + +static void +oberon_make_dec_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 1) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 2) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * dst; + dst = list_args; + oberon_check_dst(ctx, dst); + + if(!oberon_is_integer_type(dst -> result)) + { + oberon_error(ctx, "expect integer"); + } + + oberon_expr_t * step; + if(num_args == 2) + { + step = list_args -> next; + oberon_check_src(ctx, step); + if(!oberon_is_integer_type(step -> result)) + { + oberon_error(ctx, "expect integer"); + } + } + else + { + step = oberon_make_integer(ctx, 1); + } + + oberon_expr_t * expr; + expr = oberon_make_bin_op(ctx, MINUS, dst, step); + oberon_assign(ctx, expr, dst); +} + +static void +oberon_make_new_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 1) + { + oberon_error(ctx, "too few arguments"); + } + + oberon_expr_t * dst; + dst = list_args; + oberon_check_dst(ctx, dst); + + oberon_type_t * type; + type = dst -> result; + + if(type -> class != OBERON_TYPE_POINTER) { oberon_error(ctx, "not a pointer"); } @@ -2932,6 +4152,7 @@ oberon_make_new_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ oberon_expr_t * arg = size_list; for(int i = 0; i < max_args - 1; i++) { + oberon_check_src(ctx, arg); if(arg -> result -> class != OBERON_TYPE_INTEGER) { oberon_error(ctx, "size must be integer"); @@ -2955,22 +4176,825 @@ oberon_make_new_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ oberon_assign(ctx, src, dst); } -oberon_context_t * -oberon_create_context(ModuleImportCallback import_module) +static void +oberon_make_copy_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) { - oberon_context_t * ctx = calloc(1, sizeof *ctx); + if(num_args < 2) + { + oberon_error(ctx, "too few arguments"); + } - oberon_scope_t * world_scope; - world_scope = oberon_open_scope(ctx); - ctx -> world_scope = world_scope; + if(num_args > 2) + { + oberon_error(ctx, "too mach arguments"); + } - ctx -> import_module = import_module; + oberon_expr_t * src; + src = list_args; + oberon_check_src(ctx, src); - oberon_generator_init_context(ctx); + oberon_expr_t * dst; + dst = list_args -> next; + oberon_check_dst(ctx, dst); - register_default_types(ctx); - oberon_new_intrinsic(ctx, "ABS", oberon_make_abs_call, NULL); - oberon_new_intrinsic(ctx, "NEW", NULL, oberon_make_new_call); + if(!oberon_is_string_type(src -> result) && !oberon_is_array_of_char_type(src -> result)) + { + oberon_error(ctx, "source must be string or array of char"); + } + + if(!oberon_is_array_of_char_type(dst -> result)) + { + oberon_error(ctx, "dst must be array of char"); + } + + oberon_generate_copy(ctx, src, dst); +} + +static void +oberon_make_assert_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 1) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 2) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * cond; + cond = list_args; + oberon_check_src(ctx, cond); + + if(!oberon_is_boolean_type(cond -> result)) + { + oberon_error(ctx, "expected boolean"); + } + + if(num_args == 1) + { + oberon_generate_assert(ctx, cond); + } + else + { + oberon_expr_t * num; + num = list_args -> next; + oberon_check_src(ctx, num); + + if(!oberon_is_integer_type(num -> result)) + { + oberon_error(ctx, "expected integer"); + } + + oberon_check_const(ctx, num); + + oberon_generate_assert_n(ctx, cond, num -> item.integer); + } +} + +static void +oberon_make_halt_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 1) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 1) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * num; + num = list_args; + oberon_check_src(ctx, num); + + if(num -> result -> class != OBERON_TYPE_INTEGER) + { + oberon_error(ctx, "expected integer"); + } + + oberon_check_const(ctx, num); + + oberon_generate_halt(ctx, num -> item.integer); +} + +static oberon_expr_t * +oberon_make_ash_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 2) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 2) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * arg1; + arg1 = list_args; + oberon_check_src(ctx, arg1); + if(arg1 -> result -> class != OBERON_TYPE_INTEGER) + { + oberon_error(ctx, "expected integer"); + } + + oberon_expr_t * arg2; + arg2 = list_args -> next; + oberon_check_src(ctx, arg2); + if(arg2 -> result -> class != OBERON_TYPE_INTEGER) + { + oberon_error(ctx, "expected integer"); + } + + oberon_expr_t * expr; + if(oberon_is_const(arg1) && oberon_is_const(arg2)) + { + int64_t x = arg1 -> item.integer; + int64_t y = arg2 -> item.integer; + int64_t v = (y > 0) ? (x << y) : (x >> labs(y)); + expr = oberon_make_integer(ctx, v); + } + else + { + expr = oberon_new_operator(OP_ASH, arg1 -> result, arg1, arg2); + } + + return expr; +} + +static oberon_expr_t * +oberon_make_lsh_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 2) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 2) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * arg1; + arg1 = list_args; + oberon_check_src(ctx, arg1); + + oberon_type_t * t = arg1 -> result; + if(!oberon_is_integer_type(t) + && !oberon_is_char_type(t) + && !oberon_is_system_byte_type(t)) + { + oberon_error(ctx, "expected integer, char, or SYSTEM.BYTE"); + } + + oberon_expr_t * arg2; + arg2 = list_args -> next; + oberon_check_src(ctx, arg2); + if(arg2 -> result -> class != OBERON_TYPE_INTEGER) + { + oberon_error(ctx, "expected integer"); + } + + oberon_expr_t * expr; + if(oberon_is_const(arg1) && oberon_is_const(arg2)) + { + uint64_t x = arg1 -> item.integer; + int64_t y = arg2 -> item.integer; + uint64_t v = (y > 0) ? (x << y) : (x >> labs(y)); + + if(oberon_is_integer_type(t)) + { + expr = oberon_make_integer(ctx, v); + } + else if(oberon_is_char_type(t)) + { + expr = oberon_make_char(ctx, v); + } + else + { + expr = oberon_make_system_byte(ctx, v); + } + } + else + { + expr = oberon_new_operator(OP_LSH, arg1 -> result, arg1, arg2); + expr = oberon_cast_expr(ctx, expr, t); + } + + return expr; +} + +static oberon_expr_t * +oberon_make_rot_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 2) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 2) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * arg1; + arg1 = list_args; + oberon_check_src(ctx, arg1); + + oberon_type_t * t = arg1 -> result; + if(!oberon_is_integer_type(t) + && !oberon_is_char_type(t) + && !oberon_is_system_byte_type(t)) + { + oberon_error(ctx, "expected integer, char, or SYSTEM.BYTE"); + } + + oberon_expr_t * arg2; + arg2 = list_args -> next; + oberon_check_src(ctx, arg2); + if(arg2 -> result -> class != OBERON_TYPE_INTEGER) + { + oberon_error(ctx, "expected integer"); + } + + oberon_expr_t * expr; + if(oberon_is_const(arg1) && oberon_is_const(arg2)) + { + uint64_t x = arg1 -> item.integer; + int64_t y = arg2 -> item.integer; + + uint64_t v = 0; + if(y > 0) + { + v = (x << y) | (x >> (64 - y)); + } + else + { + y = labs(y); + v = (x >> y) | (x << (64 - y)); + } + + if(oberon_is_integer_type(t)) + { + expr = oberon_make_integer(ctx, v); + } + else if(oberon_is_char_type(t)) + { + expr = oberon_make_char(ctx, v); + } + else + { + expr = oberon_make_system_byte(ctx, v); + } + } + else + { + expr = oberon_new_operator(OP_ROT, arg1 -> result, arg1, arg2); + expr = oberon_cast_expr(ctx, expr, t); + } + + return expr; +} + +static oberon_expr_t * +oberon_make_cap_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 1) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 1) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * arg; + arg = list_args; + oberon_check_src(ctx, arg); + + if(!oberon_is_char_type(arg -> result)) + { + oberon_error(ctx, "expected char"); + } + + oberon_expr_t * expr; + if(oberon_is_const(arg)) + { + expr = oberon_make_char(ctx, toupper(arg -> item.integer)); + } + else + { + expr = oberon_new_operator(OP_CAP, arg -> result, arg, NULL); + } + + return expr; +} + +static oberon_expr_t * +oberon_make_chr_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 1) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 1) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * arg; + arg = list_args; + oberon_check_src(ctx, arg); + + if(!oberon_is_integer_type(arg -> result)) + { + oberon_error(ctx, "expected integer"); + } + + oberon_expr_t * expr; + if(oberon_is_const(arg)) + { + expr = oberon_make_char(ctx, arg -> item.integer); + } + else + { + expr = oberon_cast_expr(ctx, arg, ctx -> char_type); + } + return expr; +} + +static oberon_expr_t * +oberon_make_ord_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 1) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 1) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * arg; + arg = list_args; + oberon_check_src(ctx, arg); + + if(!oberon_is_char_type(arg -> result) && !oberon_is_string_of_one(arg)) + { + oberon_error(ctx, "expected char"); + } + + oberon_expr_t * expr; + if(oberon_is_const(arg)) + { + expr = oberon_make_integer(ctx, arg -> item.integer); + } + else + { + expr = oberon_cast_expr(ctx, arg, ctx -> shortint_type); + } + return expr; +} + +static oberon_expr_t * +oberon_make_entier_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 1) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 1) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * arg; + arg = list_args; + oberon_check_src(ctx, arg); + + if(!oberon_is_real_type(arg -> result)) + { + oberon_error(ctx, "expected real"); + } + + oberon_expr_t * expr; + if(oberon_is_const(arg)) + { + expr = oberon_make_integer(ctx, floor(arg -> item.real)); + } + else + { + expr = oberon_new_operator(OP_ENTIER, ctx -> int_type, arg, NULL); + } + return expr; +} + +static oberon_expr_t * +oberon_make_odd_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 1) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 1) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * arg; + arg = list_args; + oberon_check_src(ctx, arg); + + if(!oberon_is_integer_type(arg -> result)) + { + oberon_error(ctx, "expected integer"); + } + + oberon_expr_t * expr; + expr = oberon_make_bin_op(ctx, MOD, arg, oberon_make_integer(ctx, 2)); + expr = oberon_make_bin_op(ctx, EQUAL, expr, oberon_make_integer(ctx, 1)); + return expr; +} + +static oberon_expr_t * +oberon_make_cc_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 1) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 1) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * arg; + arg = list_args; + oberon_check_src(ctx, arg); + oberon_check_const(ctx, arg); + + if(!oberon_is_integer_type(arg -> result)) + { + oberon_error(ctx, "expected integer"); + } + + /* n >= 0 && n <= 15 */ + + oberon_expr_t * cond1; + oberon_expr_t * cond2; + cond1 = oberon_make_bin_op(ctx, GEQ, arg, oberon_make_integer(ctx, 0)); + cond2 = oberon_make_bin_op(ctx, LEQ, arg, oberon_make_integer(ctx, 15)); + return oberon_make_bin_op(ctx, AND, cond1, cond2); +} + +static oberon_expr_t * +oberon_make_short_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 1) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 1) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * arg; + arg = list_args; + oberon_check_src(ctx, arg); + + if(arg -> result -> shorter == NULL) + { + oberon_error(ctx, "already shorter"); + } + + oberon_expr_t * expr; + expr = oberon_cast_expr(ctx, arg, arg -> result -> shorter); + return expr; +} + +static oberon_expr_t * +oberon_make_long_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 1) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 1) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * arg; + arg = list_args; + oberon_check_src(ctx, arg); + + if(arg -> result -> longer == NULL) + { + oberon_error(ctx, "already longer"); + } + + oberon_expr_t * expr; + expr = oberon_cast_expr(ctx, arg, arg -> result -> longer); + return expr; +} + +static oberon_expr_t * +oberon_make_val_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 2) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 2) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * typ; + typ = list_args; + if(!oberon_is_type_expr(typ)) + { + oberon_error(ctx, "requires type"); + } + + oberon_expr_t * arg; + arg = list_args -> next; + oberon_check_src(ctx, arg); + + oberon_expr_t * expr; + expr = oberon_hard_cast_expr(ctx, arg, typ -> result); + return expr; +} + +static oberon_expr_t * +oberon_make_len_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 1) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 2) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * v; + v = list_args; + oberon_check_src(ctx, v); + + if(!oberon_is_array_type(v -> result)) + { + oberon_error(ctx, "expected array"); + } + + int n = 0; + if(num_args == 2) + { + oberon_expr_t * num; + num = list_args -> next; + oberon_check_src(ctx, num); + + if(!oberon_is_integer_type(num -> result)) + { + oberon_error(ctx, "expected integer"); + } + oberon_check_const(ctx, num); + + n = num -> item.integer; + } + + int dim = 0; + oberon_type_t * arr = v -> result; + while(arr -> class == OBERON_TYPE_ARRAY) + { + dim += 1; + arr = arr -> base; + } + + if(n < 0 || n > dim) + { + oberon_error(ctx, "not in range 0..%i", dim - 1); + } + + assert(v -> is_item); + + oberon_expr_t * expr; + expr = oberon_new_item(MODE_LEN, ctx -> int_type, true); + expr -> item.parent = (oberon_item_t *) v; + expr -> item.integer = n; + return expr; +} + +static void +oberon_new_const(oberon_context_t * ctx, char * name, oberon_expr_t * expr) +{ + oberon_object_t * constant; + constant = oberon_define_object(ctx -> decl, name, OBERON_CLASS_CONST, true, false, false); + oberon_check_const(ctx, expr); + constant -> value = (oberon_item_t *) expr; +} + +static void +register_default_types(oberon_context_t * ctx) +{ + ctx -> notype_type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE); + oberon_generator_init_type(ctx, ctx -> notype_type); + + ctx -> nil_type = oberon_new_type_ptr(OBERON_TYPE_NIL); + oberon_generator_init_type(ctx, ctx -> nil_type); + + ctx -> string_type = oberon_new_type_string(1); + oberon_generator_init_type(ctx, ctx -> string_type); + + ctx -> bool_type = oberon_new_type_boolean(); + oberon_generator_init_type(ctx, ctx -> bool_type); + + ctx -> char_type = oberon_new_type_char(1); + oberon_generator_init_type(ctx, ctx -> char_type); + + ctx -> byte_type = oberon_new_type_integer(1); + oberon_generator_init_type(ctx, ctx -> byte_type); + + ctx -> shortint_type = oberon_new_type_integer(2); + oberon_generator_init_type(ctx, ctx -> shortint_type); + + ctx -> int_type = oberon_new_type_integer(4); + oberon_generator_init_type(ctx, ctx -> int_type); + + ctx -> longint_type = oberon_new_type_integer(8); + oberon_generator_init_type(ctx, ctx -> longint_type); + + ctx -> real_type = oberon_new_type_real(4); + oberon_generator_init_type(ctx, ctx -> real_type); + + ctx -> longreal_type = oberon_new_type_real(8); + oberon_generator_init_type(ctx, ctx -> longreal_type); + + ctx -> set_type = oberon_new_type_set(4); + oberon_generator_init_type(ctx, ctx -> set_type); + + ctx -> system_byte_type = oberon_new_type_ptr(OBERON_TYPE_SYSTEM_BYTE); + oberon_generator_init_type(ctx, ctx -> system_byte_type); + + ctx -> system_ptr_type = oberon_new_type_ptr(OBERON_TYPE_SYSTEM_PTR); + oberon_generator_init_type(ctx, ctx -> system_ptr_type); + + /* LONG / SHORT support */ + ctx -> byte_type -> shorter = NULL; + ctx -> byte_type -> longer = ctx -> shortint_type; + + ctx -> shortint_type -> shorter = ctx -> byte_type; + ctx -> shortint_type -> longer = ctx -> int_type; + + ctx -> int_type -> shorter = ctx -> shortint_type; + ctx -> int_type -> longer = ctx -> longint_type; + + ctx -> longint_type -> shorter = ctx -> int_type; + ctx -> longint_type -> longer = NULL; + + ctx -> real_type -> shorter = NULL; + ctx -> real_type -> longer = ctx -> longreal_type; + + ctx -> longreal_type -> shorter = ctx -> real_type; + ctx -> longreal_type -> longer = NULL; +} + +static void +oberon_new_intrinsic(oberon_context_t * ctx, char * name, GenerateFuncCallback f, GenerateProcCallback p) +{ + oberon_object_t * proc; + proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, true, false, false); + proc -> type = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE); + proc -> type -> sysproc = true; + proc -> type -> genfunc = f; + proc -> type -> genproc = p; +} + +static void oberon_new_intrinsic_type(oberon_context_t * ctx, char * name, oberon_type_t * type) +{ + oberon_object_t * id; + id = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, true, false, false); + id -> type = type; +} + +static void +oberon_begin_intrinsic_module(oberon_context_t * ctx, char * name, oberon_module_t ** m) +{ + oberon_scope_t * module_scope; + module_scope = oberon_open_scope(ctx); + + oberon_module_t * module; + module = GC_MALLOC(sizeof *module); + memset(module, 0, sizeof *module); + module -> name = name; + module -> intrinsic = true; + module -> decl = module_scope; + module -> next = ctx -> module_list; + + ctx -> mod = module; + ctx -> module_list = module; + + *m = module; +} + +static void +oberon_end_intrinsic_module(oberon_context_t * ctx, oberon_module_t * m) +{ + oberon_close_scope(m -> decl); + m -> ready = true; + ctx -> mod = NULL; +} + +oberon_context_t * +oberon_create_context(ModuleImportCallback import_module) +{ + oberon_context_t * ctx = GC_MALLOC(sizeof *ctx); + memset(ctx, 0, sizeof *ctx); + + oberon_scope_t * world_scope; + world_scope = oberon_open_scope(ctx); + ctx -> world_scope = world_scope; + + ctx -> import_module = import_module; + + oberon_generator_init_context(ctx); + + /* Types */ + register_default_types(ctx); + + /* Constants */ + oberon_new_const(ctx, "TRUE", oberon_make_boolean(ctx, true)); + oberon_new_const(ctx, "FALSE", oberon_make_boolean(ctx, false)); + + /* Types */ + oberon_new_intrinsic_type(ctx, "BOOLEAN", ctx -> bool_type); + oberon_new_intrinsic_type(ctx, "CHAR", ctx -> char_type); + oberon_new_intrinsic_type(ctx, "SHORTINT", ctx -> byte_type); + oberon_new_intrinsic_type(ctx, "INTEGER", ctx -> shortint_type); + oberon_new_intrinsic_type(ctx, "LONGINT", ctx -> int_type); + oberon_new_intrinsic_type(ctx, "HUGEINT", ctx -> longint_type); + oberon_new_intrinsic_type(ctx, "REAL", ctx -> real_type); + oberon_new_intrinsic_type(ctx, "LONGREAL", ctx -> longreal_type); + oberon_new_intrinsic_type(ctx, "SET", ctx -> set_type); + + /* Functions */ + oberon_new_intrinsic(ctx, "ABS", oberon_make_abs_call, NULL); + oberon_new_intrinsic(ctx, "ASH", oberon_make_ash_call, NULL); + oberon_new_intrinsic(ctx, "CAP", oberon_make_cap_call, NULL); + oberon_new_intrinsic(ctx, "CHR", oberon_make_chr_call, NULL); + oberon_new_intrinsic(ctx, "ENTIER", oberon_make_entier_call, NULL); + oberon_new_intrinsic(ctx, "LEN", oberon_make_len_call, NULL); + oberon_new_intrinsic(ctx, "LONG", oberon_make_long_call, NULL); + oberon_new_intrinsic(ctx, "MAX", oberon_make_max_call, NULL); + oberon_new_intrinsic(ctx, "MIN", oberon_make_min_call, NULL); + oberon_new_intrinsic(ctx, "ODD", oberon_make_odd_call, NULL); + oberon_new_intrinsic(ctx, "ORD", oberon_make_ord_call, NULL); + oberon_new_intrinsic(ctx, "SHORT", oberon_make_short_call, NULL); + oberon_new_intrinsic(ctx, "SIZE", oberon_make_size_call, NULL); + + /* Procedures */ + oberon_new_intrinsic(ctx, "ASSERT", NULL, oberon_make_assert_call); + oberon_new_intrinsic(ctx, "COPY", NULL, oberon_make_copy_call); + oberon_new_intrinsic(ctx, "DEC", NULL, oberon_make_dec_call); + oberon_new_intrinsic(ctx, "EXCL", NULL, oberon_make_excl_call); + oberon_new_intrinsic(ctx, "HALT", NULL, oberon_make_halt_call); + oberon_new_intrinsic(ctx, "INC", NULL, oberon_make_inc_call); + oberon_new_intrinsic(ctx, "INCL", NULL, oberon_make_incl_call); + oberon_new_intrinsic(ctx, "NEW", NULL, oberon_make_new_call); + + /* MODULE SYSTEM */ + oberon_begin_intrinsic_module(ctx, "SYSTEM", &ctx -> system_module); + + /* Types */ + oberon_new_intrinsic_type(ctx, "BYTE", ctx -> system_byte_type); + oberon_new_intrinsic_type(ctx, "PTR", ctx -> system_ptr_type); + oberon_new_intrinsic_type(ctx, "INT8", ctx -> byte_type); + oberon_new_intrinsic_type(ctx, "INT16", ctx -> shortint_type); + oberon_new_intrinsic_type(ctx, "INT32", ctx -> int_type); + oberon_new_intrinsic_type(ctx, "INT64", ctx -> longint_type); + oberon_new_intrinsic_type(ctx, "SET32", ctx -> set_type); + + /* Functions */ + oberon_new_intrinsic(ctx, "CC", oberon_make_cc_call, NULL); + oberon_new_intrinsic(ctx, "LSH", oberon_make_lsh_call, NULL); + oberon_new_intrinsic(ctx, "ROT", oberon_make_rot_call, NULL); + oberon_new_intrinsic(ctx, "VAL", oberon_make_val_call, NULL); + + oberon_end_intrinsic_module(ctx, ctx -> system_module); return ctx; } @@ -2979,14 +5003,15 @@ void oberon_destroy_context(oberon_context_t * ctx) { oberon_generator_destroy_context(ctx); - free(ctx); } oberon_module_t * -oberon_compile_module(oberon_context_t * ctx, const char * newcode) +oberon_compile_module(oberon_context_t * ctx, oberon_scanner_t * s) { const char * code = ctx -> code; int code_index = ctx -> code_index; + oberon_location_t loc = ctx -> loc; + oberon_location_t xloc = ctx -> xloc; char c = ctx -> c; int token = ctx -> token; char * string = ctx -> string; @@ -3000,20 +5025,23 @@ oberon_compile_module(oberon_context_t * ctx, const char * newcode) module_scope = oberon_open_scope(ctx); oberon_module_t * module; - module = calloc(1, sizeof *module); + module = GC_MALLOC(sizeof *module); + memset(module, 0, sizeof *module); module -> decl = module_scope; module -> next = ctx -> module_list; ctx -> mod = module; ctx -> module_list = module; - oberon_init_scaner(ctx, newcode); + oberon_init_scaner(ctx, s); oberon_parse_module(ctx); module -> ready = 1; ctx -> code = code; ctx -> code_index = code_index; + ctx -> loc = loc; + ctx -> xloc = xloc; ctx -> c = c; ctx -> token = token; ctx -> string = string;