X-Git-Url: http://deadsoftware.ru/gitweb?p=dsw-obn.git;a=blobdiff_plain;f=src%2Foberon.c;h=0fff8d7ba4c791846d662f1a6e728c6b2fbfe883;hp=349015dc163318316d7ccbc8c40e964b9c78839f;hb=023ef0d8349acdfe751bba1b50749361682f72ff;hpb=9e17ac5ff506785891f06e3beeba66185fc7f867 diff --git a/src/oberon.c b/src/oberon.c index 349015d..0fff8d7 100644 --- a/src/oberon.c +++ b/src/oberon.c @@ -6,104 +6,28 @@ #include #include #include +#include + +#include #include "../include/oberon.h" #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, - LPAREN, - RPAREN, - EQUAL, - NEQ, - LESS, - LEQ, - GREAT, - GEQ, - IN, - IS, - PLUS, - MINUS, - OR, - STAR, - SLASH, - DIV, - MOD, - AND, - NOT, - PROCEDURE, - COMMA, - RETURN, - CONST, - TYPE, - ARRAY, - OF, - LBRACK, - RBRACK, - RECORD, - POINTER, - TO, - UPARROW, - NIL, - IMPORT, - REAL, - CHAR, - STRING, - IF, - THEN, - ELSE, - ELSIF, - WHILE, - DO, - REPEAT, - UNTIL, - FOR, - BY, - LOOP, - EXIT, - LBRACE, - RBRACE, - DOTDOT, - CASE, - BAR, - WITH -}; - // ======================================================================= // 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; @@ -162,6 +86,139 @@ oberon_new_type_set(int 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_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_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 // ======================================================================= @@ -169,8 +226,11 @@ oberon_new_type_set(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; @@ -229,7 +289,7 @@ oberon_find_object(oberon_scope_t * scope, char * name, bool check_it) static oberon_object_t * oberon_create_object(oberon_scope_t * scope, char * name, int class, bool export, bool read_only) { - oberon_object_t * newvar = malloc(sizeof *newvar); + oberon_object_t * newvar = GC_MALLOC(sizeof *newvar); memset(newvar, 0, sizeof *newvar); newvar -> name = name; newvar -> class = class; @@ -317,7 +377,7 @@ oberon_read_ident(oberon_context_t * ctx) c = ctx -> code[i]; } - char * ident = malloc(len + 1); + char * ident = GC_MALLOC(len + 1); memcpy(ident, &ctx->code[ctx->code_index], len); ident[len] = 0; @@ -576,7 +636,7 @@ oberon_read_number(oberon_context_t * ctx) } int len = end_i - start_i; - ident = malloc(len + 1); + ident = GC_MALLOC(len + 1); memcpy(ident, &ctx -> code[start_i], len); ident[len] = 0; @@ -603,6 +663,7 @@ oberon_read_number(oberon_context_t * ctx) case 2: case 3: sscanf(ident, "%lf", &real); + integer = real; ctx -> token = REAL; break; case 4: @@ -685,11 +746,13 @@ static void oberon_read_string(oberon_context_t * ctx) oberon_get_char(ctx); - char * string = calloc(1, end - start + 1); + char * string = GC_MALLOC(end - start + 1); strncpy(string, &ctx -> code[start], end - start); + string[end] = 0; ctx -> token = STRING; ctx -> string = string; + ctx -> integer = string[0]; } static void oberon_read_token(oberon_context_t * ctx); @@ -865,38 +928,7 @@ 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 * oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr); - -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 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) @@ -910,11 +942,36 @@ oberon_make_unary_op(oberon_context_t * ctx, int token, oberon_expr_t * a) { if(result -> class == OBERON_TYPE_SET) { - expr = oberon_new_operator(OP_COMPLEMENTATION, result, a, NULL); + 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) { - expr = oberon_new_operator(OP_UNARY_MINUS, result, a, NULL); + 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 { @@ -928,7 +985,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 { @@ -975,86 +1039,30 @@ oberon_expr_list(oberon_context_t * ctx, int * num_expr, oberon_expr_t ** first, static oberon_expr_t * oberon_cast_expr(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref) { - return oberon_new_operator(OP_CAST, pref, expr, NULL); -} - -static oberon_expr_t * -oberno_make_record_cast(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * rec) -{ - oberon_type_t * from = expr -> result; - oberon_type_t * to = rec; - - if(from -> class == OBERON_TYPE_POINTER && to -> class == OBERON_TYPE_POINTER) - { - from = from -> base; - to = to -> base; - } - - if(from -> class != OBERON_TYPE_RECORD || to -> class != OBERON_TYPE_RECORD) - { - oberon_error(ctx, "must be record type"); - } - - return oberon_cast_expr(ctx, expr, rec); -} + oberon_expr_t * 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) - { - result = b; - } - else if(a -> class != b -> class) + if((oberon_is_char_type(pref) && oberon_is_const_string(expr) && strlen(expr -> item.string) == 1)) { - oberon_error(ctx, "oberon_get_equal_expr_type: incompatible types"); - } - else if(a -> size > b -> size) - { - result = a; + /* Автоматически преобразуем строку единичного размера в символ */ + cast = oberon_new_item(MODE_CHAR, ctx -> char_type, true); + cast -> item.integer = expr -> item.string[0]; } else { - result = b; + cast = oberon_new_operator(OP_CAST, pref, expr, NULL); } - return result; + return cast; } static void -oberon_check_record_compatibility(oberon_context_t * ctx, oberon_type_t * from, oberon_type_t * to) +oberon_check_dst(oberon_context_t * ctx, oberon_expr_t * dst) { - if(from -> class == OBERON_TYPE_POINTER && to -> class == OBERON_TYPE_POINTER) - { - from = from -> base; - to = to -> base; - } - - if(from -> class != OBERON_TYPE_RECORD || to -> class != OBERON_TYPE_RECORD) - { - oberon_error(ctx, "not a record"); - } - - oberon_type_t * t = from; - while(t != NULL && t != to) - { - t = t -> base; - } - - if(t == NULL) + if(dst -> read_only) { - oberon_error(ctx, "incompatible record types"); + oberon_error(ctx, "read-only destination"); } -} -static void -oberon_check_dst(oberon_context_t * ctx, oberon_expr_t * dst) -{ if(dst -> is_item == false) { oberon_error(ctx, "not variable"); @@ -1088,185 +1096,61 @@ oberon_check_src(oberon_context_t * ctx, oberon_expr_t * src) } } -static oberon_expr_t * -oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref) +static void +oberon_autocast_call(oberon_context_t * ctx, oberon_item_t * desig) { - // Допускается: - // Если классы типов равны - // Если INTEGER переводится в REAL - // Если STRING переводится в CHAR - // Если STRING переводится в ARRAY OF CHAR - // Если NIL переводится в POINTER - // Если NIL переводится в PROCEDURE + if(desig -> mode != MODE_CALL) + { + oberon_error(ctx, "expected mode CALL"); + } - oberon_check_src(ctx, expr); + oberon_type_t * fn = desig -> parent -> result; + int num_args = desig -> num_args; + int num_decl = fn -> num_decl; - bool error = false; - if(pref -> class != expr -> result -> class) + if(num_args < num_decl) { - if(expr -> result -> class == OBERON_TYPE_NIL) - { - if(pref -> class != OBERON_TYPE_POINTER - && pref -> class != OBERON_TYPE_PROCEDURE) - { - error = true; - } - } - else if(expr -> result -> class == OBERON_TYPE_STRING) + oberon_error(ctx, "too few arguments"); + } + else if(num_args > num_decl) + { + oberon_error(ctx, "too many arguments"); + } + + /* Делаем проверку на запись и делаем автокаст */ + oberon_expr_t * casted[num_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(pref -> class == OBERON_TYPE_CHAR) - { - if(expr -> is_item && expr -> item.mode == MODE_STRING) - { - if(strlen(expr -> item.string) != 1) - { - error = true; - } - } - else - { - error = true; - } - } - else if(pref -> class == OBERON_TYPE_ARRAY) - { - if(pref -> base -> class != OBERON_TYPE_CHAR) - { - error = true; - } - } - else + oberon_check_dst(ctx, arg); + if(!oberon_is_compatible_arrays(param, arg)) { - error = true; + oberon_check_compatible_var_param(ctx, param -> type, arg -> result); } + casted[i] = oberon_cast_expr(ctx, arg, param -> type); } - else if(expr -> result -> class == OBERON_TYPE_INTEGER) + else { - if(pref -> class != OBERON_TYPE_REAL) + oberon_check_src(ctx, arg); + if(!oberon_is_compatible_arrays(param, arg)) { - error = true; + oberon_check_assignment_compatible(ctx, arg, param -> type); } + casted[i] = oberon_cast_expr(ctx, arg, param -> type); } - else - { - error = true; - } - } - if(error) - { - oberon_error(ctx, "oberon_autocast_to: incompatible types"); + arg = arg -> next; + param = param -> next; } - if(pref -> class == OBERON_TYPE_CHAR) + /* Создаём новый список выражений */ + if(num_args > 0) { - if(expr -> result -> class == OBERON_TYPE_STRING) - { - int c = expr -> item.string[0]; - expr = oberon_new_item(MODE_CHAR, ctx -> char_type, true); - expr -> item.integer = c; - } - } - else if(pref -> class == OBERON_TYPE_INTEGER || pref -> class == OBERON_TYPE_REAL) - { - if(expr -> result -> size > pref -> size) - { - oberon_error(ctx, "incompatible size"); - } - else - { - expr = oberon_cast_expr(ctx, expr, pref); - } - } - else if(pref -> class == OBERON_TYPE_RECORD) - { - oberon_check_record_compatibility(ctx, expr -> result, pref); - expr = oberno_make_record_cast(ctx, expr, pref); - } - else if(pref -> class == OBERON_TYPE_POINTER) - { - assert(pref -> base); - if(expr -> result -> class == OBERON_TYPE_NIL) - { - // do nothing - } - else if(expr -> result -> base -> class == OBERON_TYPE_RECORD) - { - oberon_check_record_compatibility(ctx, expr -> result, pref); - expr = oberno_make_record_cast(ctx, expr, pref); - } - else if(expr -> result -> base != pref -> base) - { - oberon_error(ctx, "incompatible pointer types"); - } - } - - return expr; -} - -static void -oberon_autocast_binary_op(oberon_context_t * ctx, oberon_expr_t ** ea, oberon_expr_t ** eb) -{ - 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); -} - -static void -oberon_autocast_call(oberon_context_t * ctx, oberon_item_t * desig) -{ - if(desig -> mode != MODE_CALL) - { - oberon_error(ctx, "expected mode CALL"); - } - - oberon_type_t * fn = desig -> parent -> result; - int num_args = desig -> num_args; - int num_decl = fn -> num_decl; - - if(num_args < num_decl) - { - oberon_error(ctx, "too few arguments"); - } - else if(num_args > num_decl) - { - oberon_error(ctx, "too many arguments"); - } - - /* Делаем проверку на запись и делаем автокаст */ - oberon_expr_t * casted[num_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 -> result != param -> type) - { - oberon_error(ctx, "incompatible type"); - } - if(arg -> read_only) - { - oberon_error(ctx, "assign to read-only var"); - } - casted[i] = arg; - } - else - { - casted[i] = oberon_autocast_to(ctx, arg, param -> type); - } - - arg = arg -> next; - param = param -> next; - } - - /* Создаём новый список выражений */ - if(num_args > 0) - { - arg = casted[0]; - for(int i = 0; i < num_args - 1; i++) + arg = casted[0]; + for(int i = 0; i < num_args - 1; i++) { casted[i] -> next = casted[i + 1]; } @@ -1370,7 +1254,7 @@ 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 = oberon_new_item(MODE_DEREF, expr -> result -> base, false); selector -> item.parent = (oberon_item_t *) expr; return selector; @@ -1578,6 +1462,7 @@ oberon_designator(oberon_context_t * ctx) { char * name; oberon_expr_t * expr; + oberon_object_t * objtype; expr = oberon_qualident_expr(ctx); @@ -1609,13 +1494,10 @@ oberon_designator(oberon_context_t * ctx) break; case LPAREN: oberon_assert_token(ctx, LPAREN); - oberon_object_t * objtype = oberon_qualident(ctx, NULL, 1); - if(objtype -> class != OBERON_CLASS_TYPE) - { - oberon_error(ctx, "must be type"); - } + objtype = oberon_qualident(ctx, NULL, true); oberon_assert_token(ctx, RPAREN); - expr = oberno_make_record_cast(ctx, expr, objtype -> type); + 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"); @@ -1675,38 +1557,6 @@ oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr) 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) -{ - 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_integer_item(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; - return expr; -} - static oberon_expr_t * oberon_element(oberon_context_t * ctx) { @@ -1714,6 +1564,7 @@ oberon_element(oberon_context_t * ctx) oberon_expr_t * e2; e1 = oberon_expr(ctx); + oberon_check_src(ctx, e1); if(e1 -> result -> class != OBERON_TYPE_INTEGER) { oberon_error(ctx, "expected integer"); @@ -1724,6 +1575,7 @@ oberon_element(oberon_context_t * ctx) { 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"); @@ -1731,28 +1583,51 @@ oberon_element(oberon_context_t * ctx) } oberon_expr_t * set; - set = oberon_new_operator(OP_RANGE, ctx -> set_type, e1, e2); + if(e2 == NULL && oberon_is_const(e1)) + { + 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 + { + 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_new_item(MODE_SET, ctx -> set_type, true); - set -> item.integer = 0; + set = oberon_make_set(ctx, 0); oberon_assert_token(ctx, LBRACE); if(ISEXPR(ctx -> token)) { elements = oberon_element(ctx); - set = oberon_new_operator(OP_UNION, ctx -> set_type, set, elements); + set = oberon_make_set_union(ctx, set, elements); while(ctx -> token == COMMA) { oberon_assert_token(ctx, COMMA); elements = oberon_element(ctx); - set = oberon_new_operator(OP_UNION, ctx -> set_type, set, elements); + set = oberon_make_set_union(ctx, set, elements); } } oberon_assert_token(ctx, RBRACE); @@ -1760,15 +1635,6 @@ oberon_set(oberon_context_t * ctx) return set; } -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; - return expr; -} - static oberon_expr_t * oberon_factor(oberon_context_t * ctx) { @@ -1782,7 +1648,7 @@ oberon_factor(oberon_context_t * ctx) expr = oberon_opt_func_parens(ctx, expr); break; case INTEGER: - expr = oberon_integer_item(ctx, ctx -> integer); + expr = oberon_make_integer(ctx, ctx -> integer); oberon_assert_token(ctx, INTEGER); break; case CHAR: @@ -1798,9 +1664,7 @@ oberon_factor(oberon_context_t * ctx) 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 LBRACE: @@ -1827,245 +1691,233 @@ 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; - bool error = false; + oberon_check_compatible_bin_expr_types(ctx, token, a -> result, b -> result); + oberon_check_src(ctx, a); + if(token != IS) + { + oberon_check_src(ctx, b); + } + if(token == IN) { - if(a -> result -> class != OBERON_TYPE_INTEGER) + if(oberon_is_const(a) && oberon_is_const(b)) { - oberon_error(ctx, "must be integer"); + expr = oberon_make_boolean(ctx, (1 << a -> item.integer) & b -> item.integer); } - - if(b -> result -> class != OBERON_TYPE_SET) + else { - oberon_error(ctx, "must be set"); + expr = oberon_new_operator(OP_IN, ctx -> bool_type, a, b); } - - result = ctx -> bool_type; - expr = oberon_new_operator(OP_IN, result, a, b); } else if(token == IS) { - oberon_type_t * v = a -> result; - if(v -> class == OBERON_TYPE_POINTER) - { - v = v -> base; - if(v -> class != OBERON_TYPE_RECORD) - { - oberon_error(ctx, "must be record"); - } - } - else if(v -> class != OBERON_TYPE_RECORD) - { - oberon_error(ctx, "must be record"); - } - - if(b -> is_item == false || b -> item.mode != MODE_TYPE) - { - oberon_error(ctx, "requires type"); - } + 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) + { + result = oberon_get_longer_type(ctx, a -> result, b -> result); - oberon_type_t * t = b -> result; - if(t -> class == OBERON_TYPE_POINTER) + if(oberon_is_const(a) && oberon_is_const(b) + && (oberon_is_real_type(result) || oberon_is_integer_type(result))) { - t = t -> base; - if(t -> class != OBERON_TYPE_RECORD) + if(oberon_is_real_type(result)) { - oberon_error(ctx, "must be record"); + 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(t -> class != OBERON_TYPE_RECORD) - { - oberon_error(ctx, "must be record"); - } - - result = ctx -> bool_type; - expr = oberon_new_operator(OP_IS, result, a, b); - } - else if(ITMAKESBOOLEAN(token)) - { - 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) + else if(oberon_is_integer_type(result)) { - // accept + 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 { - oberon_error(ctx, "used only with numeric types"); + assert(0); } } - else if(ITUSEONLYBOOLEAN(token)) + else { - if(a -> result -> class != OBERON_TYPE_BOOLEAN - || b -> result -> class != OBERON_TYPE_BOOLEAN) + a = oberon_cast_expr(ctx, a, result); + b = oberon_cast_expr(ctx, b, result); + result = ctx -> bool_type; + switch(token) { - oberon_error(ctx, "used only with boolean type"); + 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; } } - - oberon_autocast_binary_op(ctx, &a, &b); - result = ctx -> bool_type; - - if(token == EQUAL) - { - expr = oberon_new_operator(OP_EQ, result, a, b); - } - else if(token == NEQ) - { - expr = oberon_new_operator(OP_NEQ, result, a, b); - } - else if(token == LESS) - { - expr = oberon_new_operator(OP_LSS, result, a, b); - } - else if(token == LEQ) - { - expr = oberon_new_operator(OP_LEQ, result, a, b); - } - else if(token == GREAT) - { - expr = oberon_new_operator(OP_GRT, result, a, b); - } - else if(token == GEQ) - { - expr = oberon_new_operator(OP_GEQ, result, a, b); - } - else if(token == OR) - { - expr = oberon_new_operator(OP_LOGIC_OR, result, a, b); - } - else if(token == AND) - { - expr = oberon_new_operator(OP_LOGIC_AND, result, a, b); - } - else - { - oberon_error(ctx, "oberon_make_bin_op: bool wat"); - } } else if(token == SLASH) { - if(a -> result -> class == OBERON_TYPE_SET - || b -> result -> class == OBERON_TYPE_SET) + if(oberon_is_set_type(a -> result) && oberon_is_set_type(b -> result)) { - oberon_autocast_binary_op(ctx, &a, &b); - result = a -> result; - expr = oberon_new_operator(OP_SYM_DIFFERENCE, result, a, b); + 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_autocast_to_real(ctx, &a); - oberon_autocast_to_real(ctx, &b); - oberon_autocast_binary_op(ctx, &a, &b); - result = a -> result; - expr = oberon_new_operator(OP_DIV, result, a, b); - } - } - else if(token == DIV) - { - if(a -> result -> class != OBERON_TYPE_INTEGER - || b -> result -> class != OBERON_TYPE_INTEGER) - { - 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 = a -> result; - if(result -> class == OBERON_TYPE_SET) + result = oberon_get_longer_type(ctx, a -> result, b -> result); + + if(oberon_is_const(a) && oberon_is_const(b)) { - switch(token) + if(oberon_is_set_type(result)) { - 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: - error = true; - break; + 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; + } } - } - else if(result -> class == OBERON_TYPE_INTEGER - || result -> class == OBERON_TYPE_REAL) - { - switch(token) + 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 { - 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 MOD: - expr = oberon_new_operator(OP_MOD, result, a, b); - break; - default: - error = true; - break; + assert(0); } } else { - error = true; + 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_number_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: + assert(0); + break; + } + } + else + { + assert(0); + } } } - if(error) - { - oberon_error(ctx, "invalid operation"); - } - return expr; } @@ -2112,11 +1964,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; @@ -2126,6 +1973,11 @@ 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; } @@ -2150,12 +2002,12 @@ oberon_expr(oberon_context_t * ctx) return expr; } -static void -oberon_check_const(oberon_context_t * ctx, oberon_expr_t * expr) +static bool +oberon_is_const(oberon_expr_t * expr) { - if(expr -> is_item == 0) + if(expr -> is_item == false) { - oberon_error(ctx, "const expression are required"); + return false; } switch(expr -> item.mode) @@ -2166,13 +2018,25 @@ oberon_check_const(oberon_context_t * ctx, oberon_expr_t * expr) case MODE_REAL: case MODE_CHAR: case MODE_STRING: + case MODE_SET: case MODE_TYPE: - /* accept */ + return true; break; default: - oberon_error(ctx, "const expression are required"); + return false; break; } + + return false; +} + +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 * @@ -2348,6 +2212,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; } } @@ -2416,7 +2285,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; @@ -3075,9 +2946,10 @@ oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type) oberon_object_t * field = type -> decl; for(int i = 0; i < num_fields; i++) { - oberon_initialize_object(ctx, field); + //oberon_initialize_object(ctx, field); + oberon_initialize_type(ctx, field -> type); field = field -> next; - } + } oberon_generator_init_type(ctx, type); } @@ -3226,14 +3098,20 @@ 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); } - - oberon_check_dst(ctx, dst); - src = oberon_autocast_to(ctx, src, dst -> result); - oberon_generate_assign(ctx, src, dst); } static oberon_expr_t * @@ -3245,14 +3123,12 @@ oberon_case_labels(oberon_context_t * ctx, oberon_expr_t * val) oberon_expr_t * cond2; e1 = (oberon_expr_t *) oberon_const_expr(ctx); - oberon_autocast_to(ctx, e1, val -> result); e2 = NULL; if(ctx -> token == DOTDOT) { oberon_assert_token(ctx, DOTDOT); e2 = (oberon_expr_t *) oberon_const_expr(ctx); - oberon_autocast_to(ctx, e2, val -> result); } if(e2 == NULL) @@ -3326,6 +3202,10 @@ oberon_case_statement(oberon_context_t * ctx) 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); @@ -3355,7 +3235,8 @@ oberon_with_guard_do(oberon_context_t * ctx, gen_label_t * end) /* Сохраняем ссылку во временной переменной */ val = oberon_make_temp_var_item(ctx, type -> result); - cast = oberno_make_record_cast(ctx, var, type -> result); + //cast = oberno_make_record_cast(ctx, var, type -> result); + cast = oberon_cast_expr(ctx, var, type -> result); oberon_assign(ctx, cast, val); /* Подменяем тип у оригинальной переменной */ old_type = var -> item.var -> type; @@ -3392,6 +3273,10 @@ oberon_with_statement(oberon_context_t * ctx) oberon_assert_token(ctx, ELSE); oberon_statement_seq(ctx); } + else + { + oberon_generate_trap(ctx, -2); + } oberon_generate_label(ctx, end); oberon_assert_token(ctx, END); @@ -3532,11 +3417,11 @@ oberon_statement(oberon_context_t * ctx) index = oberon_ident_item(ctx, iname); oberon_assert_token(ctx, ASSIGN); from = oberon_expr(ctx); - oberon_assign(ctx, from, index); oberon_assert_token(ctx, TO); bound = oberon_make_temp_var_item(ctx, index -> result); to = oberon_expr(ctx); - oberon_assign(ctx, to, bound); + oberon_assign(ctx, to, bound); // сначала temp + oberon_assign(ctx, from, index); // потом i if(ctx -> token == BY) { oberon_assert_token(ctx, BY); @@ -3544,7 +3429,7 @@ oberon_statement(oberon_context_t * ctx) } else { - by = oberon_integer_item(ctx, 1); + by = oberon_make_integer(ctx, 1); } if(by -> result -> class != OBERON_TYPE_INTEGER) @@ -3746,57 +3631,6 @@ oberon_parse_module(oberon_context_t * ctx) // LIBRARY // ======================================================================= -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_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type, 1); - - ctx -> char_type = oberon_new_type_char(1); - oberon_define_type(ctx -> world_scope, "CHAR", ctx -> char_type, 1); - - ctx -> byte_type = oberon_new_type_integer(1); - oberon_define_type(ctx -> world_scope, "SHORTINT", ctx -> byte_type, 1); - - ctx -> shortint_type = oberon_new_type_integer(2); - oberon_define_type(ctx -> world_scope, "INTEGER", ctx -> shortint_type, 1); - - ctx -> int_type = oberon_new_type_integer(4); - oberon_define_type(ctx -> world_scope, "LONGINT", ctx -> int_type, 1); - - ctx -> longint_type = oberon_new_type_integer(8); - oberon_define_type(ctx -> world_scope, "HUGEINT", ctx -> longint_type, 1); - - ctx -> real_type = oberon_new_type_real(4); - oberon_define_type(ctx -> world_scope, "REAL", ctx -> real_type, 1); - - ctx -> longreal_type = oberon_new_type_real(8); - oberon_define_type(ctx -> world_scope, "LONGREAL", ctx -> longreal_type, 1); - - ctx -> set_type = oberon_new_type_set(4); - oberon_define_type(ctx -> world_scope, "SET", ctx -> set_type, 1); -} - -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 oberon_expr_t * oberon_make_min_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) { @@ -3813,7 +3647,7 @@ oberon_make_min_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ oberon_expr_t * arg; arg = list_args; - if(!arg -> is_item || arg -> item.mode != MODE_TYPE) + if(!oberon_is_type_expr(arg)) { oberon_error(ctx, "MIN accept only type"); } @@ -3823,10 +3657,19 @@ oberon_make_min_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ switch(arg -> result -> class) { case OBERON_TYPE_INTEGER: - expr = oberon_integer_item(ctx, -powl(2, bits - 1)); + 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_integer_item(ctx, 0); + expr = oberon_make_integer(ctx, 0); break; default: oberon_error(ctx, "allowed only basic types"); @@ -3852,7 +3695,7 @@ oberon_make_max_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ oberon_expr_t * arg; arg = list_args; - if(!arg -> is_item || arg -> item.mode != MODE_TYPE) + if(!oberon_is_type_expr(arg)) { oberon_error(ctx, "MAX accept only type"); } @@ -3862,10 +3705,19 @@ oberon_make_max_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ switch(arg -> result -> class) { case OBERON_TYPE_INTEGER: - expr = oberon_integer_item(ctx, powl(2, bits - 1) - 1); + 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_integer_item(ctx, bits); + expr = oberon_make_integer(ctx, bits); break; default: oberon_error(ctx, "allowed only basic types"); @@ -3890,8 +3742,7 @@ oberon_make_size_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list oberon_expr_t * arg; arg = list_args; - - if(!arg -> is_item || arg -> item.mode != MODE_TYPE) + if(!oberon_is_type_expr(arg)) { oberon_error(ctx, "SIZE accept only type"); } @@ -3913,7 +3764,7 @@ oberon_make_size_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list break; } - expr = oberon_integer_item(ctx, size); + expr = oberon_make_integer(ctx, size); return expr; } @@ -3934,27 +3785,165 @@ oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ arg = list_args; oberon_check_src(ctx, arg); - oberon_type_t * result_type; - result_type = arg -> result; - - if(result_type -> class != OBERON_TYPE_INTEGER) + if(oberon_is_number_type(arg -> result)) { - oberon_error(ctx, "ABS accepts only integers"); + oberon_error(ctx, "ABS accepts only numbers"); } oberon_expr_t * expr; - expr = oberon_new_operator(OP_ABS, result_type, arg, NULL); + 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_new_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +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 > 1) + { + 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 * expr; + expr = oberon_make_bin_op(ctx, PLUS, dst, oberon_make_integer(ctx, 1)); + 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 > 1) + { + 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 * expr; + expr = oberon_make_bin_op(ctx, MINUS, dst, oberon_make_integer(ctx, 1)); + 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; @@ -4032,40 +4021,555 @@ oberon_make_new_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ } static void -oberon_new_const(oberon_context_t * ctx, char * name, oberon_expr_t * expr) +oberon_make_copy_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) { - 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; + if(num_args < 2) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 2) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * src; + src = list_args; + oberon_check_src(ctx, src); + + oberon_expr_t * dst; + dst = list_args -> next; + oberon_check_dst(ctx, dst); + + 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); } -oberon_context_t * -oberon_create_context(ModuleImportCallback import_module) +static void +oberon_make_assert_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) { - oberon_context_t * ctx = calloc(1, sizeof *ctx); + if(num_args < 1) + { + 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 * cond; + cond = list_args; + oberon_check_src(ctx, cond); - oberon_generator_init_context(ctx); + if(!oberon_is_boolean_type(cond -> result)) + { + oberon_error(ctx, "expected boolean"); + } - register_default_types(ctx); + if(num_args == 1) + { + oberon_generate_assert(ctx, cond); + } + else + { + oberon_expr_t * num; + num = list_args -> next; + oberon_check_src(ctx, num); - /* Constants */ - oberon_new_const(ctx, "TRUE", oberon_make_boolean(ctx, true)); - oberon_new_const(ctx, "FALSE", oberon_make_boolean(ctx, false)); + if(!oberon_is_integer_type(num -> result)) + { + oberon_error(ctx, "expected integer"); + } - /* Functions */ - oberon_new_intrinsic(ctx, "ABS", oberon_make_abs_call, NULL); - oberon_new_intrinsic(ctx, "MIN", oberon_make_min_call, NULL); + 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; + expr = oberon_make_integer(ctx, x * powl(2, y)); + } + else + { + expr = oberon_new_operator(OP_ASH, arg1 -> result, arg1, arg2); + } + + 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_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 -> int_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_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_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_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type, 1); + + ctx -> char_type = oberon_new_type_char(1); + oberon_define_type(ctx -> world_scope, "CHAR", ctx -> char_type, 1); + + ctx -> byte_type = oberon_new_type_integer(1); + oberon_define_type(ctx -> world_scope, "SHORTINT", ctx -> byte_type, 1); + + ctx -> shortint_type = oberon_new_type_integer(2); + oberon_define_type(ctx -> world_scope, "INTEGER", ctx -> shortint_type, 1); + + ctx -> int_type = oberon_new_type_integer(4); + oberon_define_type(ctx -> world_scope, "LONGINT", ctx -> int_type, 1); + + ctx -> longint_type = oberon_new_type_integer(8); + oberon_define_type(ctx -> world_scope, "HUGEINT", ctx -> longint_type, 1); + + ctx -> real_type = oberon_new_type_real(4); + oberon_define_type(ctx -> world_scope, "REAL", ctx -> real_type, 1); + + ctx -> longreal_type = oberon_new_type_real(8); + oberon_define_type(ctx -> world_scope, "LONGREAL", ctx -> longreal_type, 1); + + ctx -> set_type = oberon_new_type_set(4); + oberon_define_type(ctx -> world_scope, "SET", ctx -> set_type, 1); + + + + 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; +} + +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); + + 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)); + + /* 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); return ctx; @@ -4075,7 +4579,6 @@ void oberon_destroy_context(oberon_context_t * ctx) { oberon_generator_destroy_context(ctx); - free(ctx); } oberon_module_t * @@ -4096,7 +4599,8 @@ 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;