X-Git-Url: https://deadsoftware.ru/gitweb?p=dsw-obn.git;a=blobdiff_plain;f=src%2Foberon.c;h=59a5c3d5fa7f6f11dc9e65e6b1974f59fca12770;hp=5816c2b3fb0a96f2076f0e6ff82fbeb2b87058d2;hb=c535b4be889716bfd37a4f0dd888f398534bc306;hpb=51a1ab2543ec5c221d4a3a9ab89968ae7dd39981 diff --git a/src/oberon.c b/src/oberon.c index 5816c2b..59a5c3d 100644 --- a/src/oberon.c +++ b/src/oberon.c @@ -5,6 +5,7 @@ #include #include #include +#include #include "../include/oberon.h" @@ -23,8 +24,6 @@ enum { BEGIN, ASSIGN, INTEGER, - TRUE, - FALSE, LPAREN, RPAREN, EQUAL, @@ -51,8 +50,8 @@ enum { TYPE, ARRAY, OF, - LBRACE, - RBRACE, + LBRACK, + RBRACK, RECORD, POINTER, TO, @@ -64,13 +63,31 @@ enum { STRING, IF, THEN, - ELSE + ELSE, + ELSIF, + WHILE, + DO, + REPEAT, + UNTIL, + FOR, + BY, + LOOP, + EXIT, + LBRACE, + RBRACE, + DOTDOT, + CASE, + BAR, + WITH }; // ======================================================================= // UTILS // ======================================================================= +static void +oberon_make_copy_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args); + static void oberon_error(oberon_context_t * ctx, const char * fmt, ...) { @@ -139,6 +156,15 @@ oberon_new_type_string(int 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; +} + // ======================================================================= // TABLE // ======================================================================= @@ -158,6 +184,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; @@ -202,6 +229,22 @@ oberon_find_object(oberon_scope_t * scope, char * name, bool check_it) 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 = 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) { @@ -224,17 +267,8 @@ 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; @@ -311,14 +345,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; @@ -395,8 +421,55 @@ oberon_read_ident(oberon_context_t * ctx) { 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) { @@ -424,10 +497,10 @@ 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); } @@ -451,37 +524,43 @@ oberon_read_number(oberon_context_t * 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; - - if(ctx -> c == 'D') - { - mode = 3; - } - - oberon_get_char(ctx); + mode = 2; - 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; } @@ -614,8 +693,6 @@ static void oberon_read_string(oberon_context_t * ctx) ctx -> token = STRING; ctx -> string = string; - - printf("oberon_read_string: string ((%s))\n", string); } static void oberon_read_token(oberon_context_t * ctx); @@ -645,6 +722,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; @@ -720,11 +802,11 @@ 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 '^': @@ -737,6 +819,18 @@ oberon_read_symbol(oberon_context_t * ctx) 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; @@ -817,12 +911,18 @@ 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) + { + 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); + } + else { oberon_error(ctx, "incompatible operator type"); } - - expr = oberon_new_operator(OP_UNARY_MINUS, result, a, NULL); } else if(token == NOT) { @@ -887,11 +987,8 @@ oberno_make_record_cast(oberon_context_t * ctx, oberon_expr_t * expr, oberon_typ oberon_type_t * from = expr -> result; oberon_type_t * to = rec; - printf("oberno_make_record_cast: from class %i to class %i\n", from -> class, to -> class); - if(from -> class == OBERON_TYPE_POINTER && to -> class == OBERON_TYPE_POINTER) { - printf("oberno_make_record_cast: pointers\n"); from = from -> base; to = to -> base; } @@ -958,23 +1055,88 @@ oberon_check_record_compatibility(oberon_context_t * ctx, oberon_type_t * from, } } +static void +oberon_check_dst(oberon_context_t * ctx, oberon_expr_t * dst) +{ + if(dst -> read_only) + { + oberon_error(ctx, "read-only destination"); + } + + if(dst -> is_item == false) + { + oberon_error(ctx, "not variable"); + } + + switch(dst -> item.mode) + { + 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; + } +} + +static void +oberon_check_src(oberon_context_t * ctx, oberon_expr_t * src) +{ + if(src -> is_item) + { + if(src -> item.mode == MODE_TYPE) + { + oberon_error(ctx, "not variable"); + } + } +} + static oberon_expr_t * oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref) { // Допускается: // Если классы типов равны // Если INTEGER переводится в REAL - // Есди STRING переводится в ARRAY OF CHAR + // Если STRING переводится в CHAR + // Если STRING переводится в ARRAY OF CHAR + // Если NIL переводится в POINTER + // Если NIL переводится в PROCEDURE + + oberon_check_src(ctx, expr); bool error = false; if(pref -> class != expr -> result -> class) { - printf("expr class %i\n", expr -> result -> class); - printf("pref class %i\n", pref -> class); - - if(expr -> result -> class == OBERON_TYPE_STRING) + 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) { - if(pref -> class == OBERON_TYPE_ARRAY) + 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) { @@ -1004,7 +1166,16 @@ oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * oberon_error(ctx, "oberon_autocast_to: incompatible types"); } - if(pref -> class == OBERON_TYPE_INTEGER || pref -> class == OBERON_TYPE_REAL) + if(pref -> class == OBERON_TYPE_CHAR) + { + 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) { @@ -1023,17 +1194,18 @@ oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * else if(pref -> class == OBERON_TYPE_POINTER) { assert(pref -> base); - if(expr -> result -> base -> class == OBERON_TYPE_RECORD) + 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) { - if(expr -> result -> base -> class != OBERON_TYPE_VOID) - { - oberon_error(ctx, "incompatible pointer types"); - } + oberon_error(ctx, "incompatible pointer types"); } } @@ -1079,13 +1251,21 @@ oberon_autocast_call(oberon_context_t * ctx, oberon_item_t * desig) { 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); } - casted[i] = oberon_autocast_to(ctx, arg, param -> type); arg = arg -> next; param = param -> next; } @@ -1124,7 +1304,7 @@ oberon_make_call_func(oberon_context_t * ctx, oberon_item_t * item, int num_args } else { - if(signature -> base -> class == OBERON_TYPE_VOID) + if(signature -> base -> class == OBERON_TYPE_NOTYPE) { oberon_error(ctx, "attempt to call procedure in expression"); } @@ -1161,7 +1341,7 @@ oberon_make_call_proc(oberon_context_t * ctx, oberon_item_t * item, int num_args } else { - if(signature -> base -> class != OBERON_TYPE_VOID) + if(signature -> base -> class != OBERON_TYPE_NOTYPE) { oberon_error(ctx, "attempt to call function as non-typed procedure"); } @@ -1175,58 +1355,6 @@ oberon_make_call_proc(oberon_context_t * ctx, oberon_item_t * item, int num_args } } -/* -static void -oberon_make_call_proc(oberon_context_t * ctx, oberon_object_t * proc, int num_args, oberon_expr_t * list_args) -{ - switch(proc -> class) - { - 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; - } - - if(proc -> sysproc) - { - if(proc -> genproc == NULL) - { - oberon_error(ctx, "requres non-typed procedure"); - } - - proc -> genproc(ctx, num_args, list_args); - } - else - { - if(proc -> type -> base -> class != OBERON_TYPE_VOID) - { - 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 -> item.num_args = num_args; - call -> item.args = list_args; - oberon_autocast_call(ctx, call); - oberon_generate_call_proc(ctx, call); - } -} -*/ - #define ISEXPR(x) \ (((x) == PLUS) \ || ((x) == MINUS) \ @@ -1237,14 +1365,11 @@ oberon_make_call_proc(oberon_context_t * ctx, oberon_object_t * proc, int num_ar || ((x) == STRING) \ || ((x) == NIL) \ || ((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) { - printf("oberno_make_dereferencing\n"); if(expr -> result -> class != OBERON_TYPE_POINTER) { oberon_error(ctx, "not a pointer"); @@ -1336,7 +1461,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) @@ -1354,7 +1479,7 @@ oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char * } #define ISSELECTOR(x) \ - (((x) == LBRACE) \ + (((x) == LBRACK) \ || ((x) == DOT) \ || ((x) == UPARROW) \ || ((x) == LPAREN)) @@ -1393,9 +1518,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; @@ -1416,20 +1560,77 @@ 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; + return expr; +} + +static void +oberon_check_type_guard(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * type) +{ + /* Охрана типа применима, если */ + /* 1. v - параметр-переменная типа запись, или v - указатель, и если */ + /* 2. T - расширение статического типа v */ + + if(expr -> is_item + && expr -> item.mode == MODE_VAR + && expr -> item.var -> class == OBERON_CLASS_VAR_PARAM) + { + // accept + } + else if(expr -> result -> class == OBERON_TYPE_POINTER + || expr -> result -> class == OBERON_TYPE_RECORD) + { + // accept + } + else + { + oberon_error(ctx, "guard type used only with var-param or pointers"); + } + + oberon_check_record_compatibility(ctx, type, expr -> result); +} + +static oberon_expr_t * +oberon_make_type_guard(oberon_context_t * ctx, oberon_expr_t * expr, oberon_object_t * objtype) +{ + oberon_type_t * type; + + if(objtype -> class != OBERON_CLASS_TYPE) + { + oberon_error(ctx, "must be type"); + } + type = objtype -> type; + + oberon_check_type_guard(ctx, expr, type); + return oberno_make_record_cast(ctx, expr, objtype -> type); +} + +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) @@ -1439,12 +1640,12 @@ oberon_designator(oberon_context_t * ctx) 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++) { @@ -1458,13 +1659,9 @@ 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); + expr = oberon_make_type_guard(ctx, expr, objtype); break; default: oberon_error(ctx, "oberon_designator: wat"); @@ -1546,21 +1743,92 @@ oberon_get_type_of_int_value(oberon_context_t * ctx, int64_t i) } static oberon_expr_t * -oberon_factor(oberon_context_t * ctx) +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; +} - switch(ctx -> token) - { +static oberon_expr_t * +oberon_element(oberon_context_t * ctx) +{ + oberon_expr_t * e1; + oberon_expr_t * e2; + + e1 = oberon_expr(ctx); + if(e1 -> result -> class != OBERON_TYPE_INTEGER) + { + oberon_error(ctx, "expected integer"); + } + + e2 = NULL; + if(ctx -> token == DOTDOT) + { + oberon_assert_token(ctx, DOTDOT); + e2 = oberon_expr(ctx); + if(e2 -> result -> class != OBERON_TYPE_INTEGER) + { + oberon_error(ctx, "expected integer"); + } + } + + oberon_expr_t * set; + set = oberon_new_operator(OP_RANGE, ctx -> set_type, e1, e2); + return set; +} + +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; + + oberon_assert_token(ctx, LBRACE); + if(ISEXPR(ctx -> token)) + { + elements = oberon_element(ctx); + set = oberon_new_operator(OP_UNION, ctx -> set_type, 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); + } + } + oberon_assert_token(ctx, RBRACE); + + 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) +{ + oberon_expr_t * expr; + oberon_type_t * result; + + switch(ctx -> token) + { case IDENT: expr = oberon_designator(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, true); - expr -> item.integer = ctx -> integer; + expr = oberon_integer_item(ctx, ctx -> integer); oberon_assert_token(ctx, INTEGER); break; case CHAR: @@ -1581,15 +1849,8 @@ oberon_factor(oberon_context_t * ctx) expr -> item.real = ctx -> real; oberon_assert_token(ctx, REAL); break; - case TRUE: - expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, true); - expr -> item.boolean = true; - oberon_assert_token(ctx, TRUE); - break; - case FALSE: - expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, true); - expr -> item.boolean = false; - oberon_assert_token(ctx, FALSE); + case LBRACE: + expr = oberon_set(ctx); break; case LPAREN: oberon_assert_token(ctx, LPAREN); @@ -1603,7 +1864,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, true); + expr = oberon_new_item(MODE_NIL, ctx -> nil_type, true); break; default: oberon_error(ctx, "invalid expression"); @@ -1612,15 +1873,6 @@ 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) { @@ -1642,36 +1894,149 @@ oberon_autocast_to_real(oberon_context_t * ctx, oberon_expr_t ** e) } } +static bool +oberon_is_numeric_type(oberon_type_t * t) +{ + return (t -> class == OBERON_TYPE_INTEGER) || (t -> class == OBERON_TYPE_REAL); +} + +static bool +oberon_is_char_type(oberon_type_t * t) +{ + return (t -> class == OBERON_TYPE_CHAR); +} + +static bool +oberon_is_string_type(oberon_type_t * t) +{ + return (t -> class == OBERON_TYPE_STRING) + || (t -> class == OBERON_TYPE_ARRAY && t -> base -> class == OBERON_TYPE_CHAR); +} + +static bool +oberon_is_boolean_type(oberon_type_t * t) +{ + return (t -> class == OBERON_TYPE_BOOLEAN); +} + +static bool +oberon_is_set_type(oberon_type_t * t) +{ + return (t -> class == OBERON_TYPE_SET); +} + +static bool +oberon_is_pointer_type(oberon_type_t * t) +{ + return (t -> class == OBERON_TYPE_POINTER) || (t -> class == OBERON_TYPE_NIL); +} + +static bool +oberon_is_procedure_type(oberon_type_t * t) +{ + return (t -> class == OBERON_TYPE_POINTER) || (t -> class == OBERON_TYPE_NIL); +} + 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)) + bool error = false; + if(token == IN) + { + if(a -> result -> class != OBERON_TYPE_INTEGER) + { + oberon_error(ctx, "must be integer"); + } + + if(b -> result -> class != OBERON_TYPE_SET) + { + oberon_error(ctx, "must be set"); + } + + result = ctx -> bool_type; + expr = oberon_new_operator(OP_IN, result, a, b); + } + else if(token == IS) + { + if(b -> is_item == false || b -> item.mode != MODE_TYPE) + { + oberon_error(ctx, "requires type"); + } + + result = ctx -> bool_type; + oberon_check_type_guard(ctx, a, b -> result); + expr = oberon_new_operator(OP_IS, result, a, b); + } + else if((token >= EQUAL && token <= GEQ) || token == OR || token == AND) { - if(ITUSEONLYINTEGER(token)) + if(token >= LESS && token <= GEQ) + { + if(oberon_is_numeric_type(a -> result) && oberon_is_numeric_type(b -> result)) + { + // accept + } + else if(oberon_is_char_type(a -> result) && oberon_is_char_type(b -> result)) + { + // accept + } + else if(oberon_is_string_type(a -> result) && oberon_is_string_type(b -> result)) + { + // accept + } + else + { + oberon_error(ctx, "invalid comparation"); + } + } + else if(token == EQUAL || token == NEQ) { - 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) + if(oberon_is_numeric_type(a -> result) && oberon_is_numeric_type(b -> result)) + { + // accept + } + else if(oberon_is_char_type(a -> result) && oberon_is_char_type(b -> result)) + { + // accept + } + else if(oberon_is_string_type(a -> result) && oberon_is_string_type(b -> result)) + { + // accept + } + else if(oberon_is_boolean_type(a -> result) && oberon_is_boolean_type(b -> result)) + { + // accept + } + else if(oberon_is_set_type(a -> result) && oberon_is_set_type(b -> result)) + { + // accept + } + else if(oberon_is_pointer_type(a -> result) && oberon_is_pointer_type(b -> result)) + { + // accept + } + else if(oberon_is_procedure_type(a -> result) && oberon_is_procedure_type(b -> result)) { // accept } else { - oberon_error(ctx, "used only with numeric types"); + oberon_error(ctx, "invalid comparation"); } } - else if(ITUSEONLYBOOLEAN(token)) + else if(token == AND || token == OR) { - if(a -> result -> class != OBERON_TYPE_BOOLEAN - || b -> result -> class != OBERON_TYPE_BOOLEAN) + if(!oberon_is_boolean_type(a -> result) || !oberon_is_boolean_type(b -> result)) { - oberon_error(ctx, "used only with boolean type"); + oberon_error(ctx, "invalid comparation"); } } + else + { + oberon_error(ctx, "wat"); + } oberon_autocast_binary_op(ctx, &a, &b); result = ctx -> bool_type; @@ -1715,10 +2080,21 @@ oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_ } 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); + if(a -> result -> class == OBERON_TYPE_SET + || b -> result -> class == OBERON_TYPE_SET) + { + oberon_autocast_binary_op(ctx, &a, &b); + result = a -> 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) { @@ -1734,29 +2110,58 @@ oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_ else { oberon_autocast_binary_op(ctx, &a, &b); - - if(token == PLUS) - { - expr = oberon_new_operator(OP_ADD, a -> result, a, b); - } - else if(token == MINUS) + result = a -> result; + if(result -> class == OBERON_TYPE_SET) { - expr = oberon_new_operator(OP_SUB, a -> result, a, b); - } - else if(token == STAR) - { - expr = oberon_new_operator(OP_MUL, a -> result, a, b); + 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: + error = true; + break; + } } - else if(token == MOD) + else if(result -> class == OBERON_TYPE_INTEGER + || result -> class == OBERON_TYPE_REAL) { - expr = oberon_new_operator(OP_MOD, a -> result, a, b); + 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 MOD: + expr = oberon_new_operator(OP_MOD, result, a, b); + break; + default: + error = true; + break; + } } else { - oberon_error(ctx, "oberon_make_bin_op: bin wat"); + error = true; } } + if(error) + { + oberon_error(ctx, "invalid operation"); + } + return expr; } @@ -1841,17 +2246,37 @@ oberon_expr(oberon_context_t * ctx) return expr; } -static oberon_item_t * -oberon_const_expr(oberon_context_t * ctx) +static void +oberon_check_const(oberon_context_t * ctx, oberon_expr_t * expr) { - oberon_expr_t * expr; - expr = oberon_expr(ctx); - if(expr -> is_item == 0) { oberon_error(ctx, "const expression are required"); } + switch(expr -> item.mode) + { + case MODE_INTEGER: + case MODE_BOOLEAN: + case MODE_NIL: + case MODE_REAL: + case MODE_CHAR: + case MODE_STRING: + case MODE_TYPE: + /* accept */ + break; + default: + oberon_error(ctx, "const expression are required"); + break; + } +} + +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; } @@ -1944,7 +2369,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); @@ -1975,7 +2400,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; @@ -2019,6 +2444,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; } } @@ -2030,7 +2460,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) @@ -2073,7 +2503,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) { @@ -2119,7 +2549,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 + if(proc -> type -> base -> class == OBERON_TYPE_NOTYPE && proc -> has_return == 0) { oberon_make_return(ctx, NULL); @@ -2157,16 +2587,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) + 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) { @@ -2188,16 +2625,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; @@ -2258,7 +2694,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; @@ -2280,7 +2716,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); @@ -2303,7 +2739,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); @@ -2404,7 +2840,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) @@ -2435,7 +2871,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; @@ -2472,7 +2908,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 @@ -2496,7 +2932,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"); } @@ -2550,6 +2986,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++) @@ -2691,7 +3132,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"); } @@ -2864,92 +3305,450 @@ 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) + if(src -> is_item + && src -> item.mode == MODE_STRING + && src -> result -> class == OBERON_TYPE_STRING + && dst -> result -> class == OBERON_TYPE_ARRAY + && dst -> result -> base -> class == OBERON_TYPE_CHAR + && dst -> result -> size > 0) { - oberon_error(ctx, "read-only destination"); - } - - src = oberon_autocast_to(ctx, src, dst -> result); - oberon_generate_assign(ctx, src, dst); -} - -static void -oberon_statement(oberon_context_t * ctx) -{ - oberon_expr_t * item1; - oberon_expr_t * item2; - if(ctx -> token == IDENT) - { - item1 = oberon_designator(ctx); - if(ctx -> token == ASSIGN) + if(strlen(src -> item.string) < dst -> result -> size) { - oberon_assert_token(ctx, ASSIGN); - item2 = oberon_expr(ctx); - oberon_assign(ctx, item2, item1); + src -> next = dst; + oberon_make_copy_call(ctx, 2, src); } else { - oberon_opt_proc_parens(ctx, item1); + oberon_error(ctx, "string too long for destination"); } } - else if(ctx -> token == IF) + else { - 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_check_dst(ctx, dst); + src = oberon_autocast_to(ctx, src, dst -> result); + oberon_generate_assign(ctx, src, dst); + } +} - 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); +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; - if(ctx -> token == ELSE) - { - oberon_generate_label(ctx, els); - oberon_assert_token(ctx, ELSE); - oberon_statement_seq(ctx); - } + 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); + } - oberon_generate_label(ctx, end); - oberon_assert_token(ctx, END); + if(e2 == NULL) + { + /* val == e1 */ + cond = oberon_make_bin_op(ctx, EQUAL, val, e1); } - else if(ctx -> token == RETURN) + else { - oberon_assert_token(ctx, RETURN); - if(ISEXPR(ctx -> token)) - { - oberon_expr_t * expr; - expr = oberon_expr(ctx); - oberon_make_return(ctx, expr); - } - else - { - oberon_make_return(ctx, NULL); - } + /* 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_statement_seq(oberon_context_t * ctx) +oberon_case(oberon_context_t * ctx, oberon_expr_t * val, gen_label_t * end) { - oberon_statement(ctx); - while(ctx -> token == SEMICOLON) + 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); + } + + 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_expr_t * val; + oberon_expr_t * var; + oberon_expr_t * type; + oberon_expr_t * cond; + oberon_expr_t * cast; + oberon_type_t * old_type; + gen_var_t * old_var; + gen_label_t * this_end; + + this_end = oberon_generator_reserve_label(ctx); + + var = oberon_qualident_expr(ctx); + oberon_assert_token(ctx, COLON); + type = oberon_qualident_expr(ctx); + cond = oberon_make_bin_op(ctx, IS, var, type); + + oberon_assert_token(ctx, DO); + oberon_generate_branch(ctx, cond, false, this_end); + + /* Сохраняем ссылку во временной переменной */ + val = oberon_make_temp_var_item(ctx, type -> result); + cast = oberno_make_record_cast(ctx, var, type -> result); + oberon_assign(ctx, cast, val); + /* Подменяем тип у оригинальной переменной */ + old_type = var -> item.var -> type; + var -> item.var -> type = type -> result; + /* Подменяем ссылку на переменную */ + old_var = var -> item.var -> gen_var; + var -> item.var -> gen_var = val -> item.var -> gen_var; + + oberon_statement_seq(ctx); + oberon_generate_goto(ctx, end); + oberon_generate_label(ctx, this_end); + + /* Возвращаем исходное состояние */ + var -> item.var -> gen_var = old_var; + var -> item.var -> type = old_type; +} + +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); + } + + oberon_generate_label(ctx, end); + oberon_assert_token(ctx, END); +} + +static void +oberon_statement(oberon_context_t * ctx) +{ + oberon_expr_t * item1; + oberon_expr_t * item2; + + if(ctx -> token == IDENT) + { + item1 = oberon_designator(ctx); + if(ctx -> token == ASSIGN) + { + oberon_assert_token(ctx, ASSIGN); + item2 = oberon_expr(ctx); + oberon_assign(ctx, item2, item1); + } + else + { + 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, true, 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_integer_item(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); + if(ISEXPR(ctx -> token)) + { + oberon_expr_t * expr; + expr = oberon_expr(ctx); + oberon_make_return(ctx, expr); + } + else + { + oberon_make_return(ctx, NULL); + } + } +} + +static void +oberon_statement_seq(oberon_context_t * ctx) +{ + oberon_statement(ctx); + while(ctx -> token == SEMICOLON) { oberon_assert_token(ctx, SEMICOLON); oberon_statement(ctx); @@ -3050,7 +3849,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) { @@ -3067,12 +3866,11 @@ oberon_parse_module(oberon_context_t * ctx) static void register_default_types(oberon_context_t * ctx) { - ctx -> void_type = oberon_new_type_ptr(OBERON_TYPE_VOID); - oberon_generator_init_type(ctx, ctx -> void_type); + ctx -> notype_type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE); + oberon_generator_init_type(ctx, ctx -> notype_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 -> 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); @@ -3080,17 +3878,20 @@ register_default_types(oberon_context_t * ctx) 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, "BYTE", ctx -> byte_type, 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, "SHORTINT", ctx -> shortint_type, 1); + 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, "INTEGER", ctx -> int_type, 1); + 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, "LONGINT", ctx -> longint_type, 1); + 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); @@ -3098,8 +3899,8 @@ register_default_types(oberon_context_t * ctx) ctx -> longreal_type = oberon_new_type_real(8); oberon_define_type(ctx -> world_scope, "LONGREAL", ctx -> longreal_type, 1); - ctx -> char_type = oberon_new_type_char(1); - oberon_define_type(ctx -> world_scope, "CHAR", ctx -> char_type, 1); + ctx -> set_type = oberon_new_type_set(4); + oberon_define_type(ctx -> world_scope, "SET", ctx -> set_type, 1); } static void @@ -3113,6 +3914,126 @@ oberon_new_intrinsic(oberon_context_t * ctx, char * name, GenerateFuncCallback 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) +{ + 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; + + if(!arg -> is_item || arg -> item.mode != MODE_TYPE) + { + oberon_error(ctx, "MIN accept only type"); + } + + oberon_expr_t * expr; + int bits = arg -> result -> size * 8; + switch(arg -> result -> class) + { + case OBERON_TYPE_INTEGER: + expr = oberon_integer_item(ctx, -powl(2, bits - 1)); + break; + case OBERON_TYPE_SET: + expr = oberon_integer_item(ctx, 0); + break; + default: + oberon_error(ctx, "allowed only basic types"); + break; + } + + return expr; +} + +static oberon_expr_t * +oberon_make_max_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; + + if(!arg -> is_item || arg -> item.mode != MODE_TYPE) + { + oberon_error(ctx, "MAX accept only type"); + } + + oberon_expr_t * expr; + int bits = arg -> result -> size * 8; + switch(arg -> result -> class) + { + case OBERON_TYPE_INTEGER: + expr = oberon_integer_item(ctx, powl(2, bits - 1) - 1); + break; + case OBERON_TYPE_SET: + expr = oberon_integer_item(ctx, bits); + break; + default: + oberon_error(ctx, "allowed only basic types"); + break; + } + + return expr; +} + +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"); + } + + if(num_args > 1) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * arg; + arg = list_args; + + if(!arg -> is_item || arg -> item.mode != MODE_TYPE) + { + 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_integer_item(ctx, size); + return expr; +} + static oberon_expr_t * oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) { @@ -3128,6 +4049,7 @@ oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ oberon_expr_t * arg; arg = list_args; + oberon_check_src(ctx, arg); oberon_type_t * result_type; result_type = arg -> result; @@ -3137,7 +4059,6 @@ oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ oberon_error(ctx, "ABS accepts only integers"); } - oberon_expr_t * expr; expr = oberon_new_operator(OP_ABS, result_type, arg, NULL); return expr; @@ -3153,6 +4074,7 @@ oberon_make_new_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ oberon_expr_t * dst; dst = list_args; + oberon_check_dst(ctx, dst); oberon_type_t * type; type = dst -> result; @@ -3201,6 +4123,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"); @@ -3224,6 +4147,119 @@ oberon_make_new_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ oberon_assign(ctx, src, dst); } +static void +oberon_make_copy_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 * 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_error(ctx, "source must be string or array of char"); + } + + if(!oberon_is_string_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(cond -> result -> class != OBERON_TYPE_BOOLEAN) + { + 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(num -> result -> class != OBERON_TYPE_INTEGER) + { + 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 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; +} + oberon_context_t * oberon_create_context(ModuleImportCallback import_module) { @@ -3238,8 +4274,22 @@ oberon_create_context(ModuleImportCallback 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, "MIN", oberon_make_min_call, NULL); + oberon_new_intrinsic(ctx, "MAX", oberon_make_max_call, NULL); + oberon_new_intrinsic(ctx, "SIZE", oberon_make_size_call, NULL); + + /* Procedures */ oberon_new_intrinsic(ctx, "NEW", NULL, oberon_make_new_call); + oberon_new_intrinsic(ctx, "COPY", NULL, oberon_make_copy_call); + oberon_new_intrinsic(ctx, "ASSERT", NULL, oberon_make_assert_call); + oberon_new_intrinsic(ctx, "HALT", NULL, oberon_make_halt_call); return ctx; }