X-Git-Url: https://deadsoftware.ru/gitweb?p=dsw-obn.git;a=blobdiff_plain;f=src%2Foberon.c;h=6f9395ca71b81e1f8bf1254f9715a9568bf79610;hp=f67d3927dfdb0d72cbd620aeea0f4f606901376b;hb=d25fb653bfe19a696d3f53abd784d32ba2d3ee03;hpb=f4aa48e4c1e3b81ccbe3da5c33fdaba3a46081dd diff --git a/src/oberon.c b/src/oberon.c index f67d392..6f9395c 100644 --- a/src/oberon.c +++ b/src/oberon.c @@ -10,77 +10,10 @@ #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 // ======================================================================= @@ -88,21 +21,6 @@ enum { 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, ...) -{ - 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); -} - static oberon_type_t * oberon_new_type_ptr(int class) { @@ -693,6 +611,7 @@ static void oberon_read_string(oberon_context_t * ctx) ctx -> token = STRING; ctx -> string = string; + ctx -> integer = string[0]; } static void oberon_read_token(oberon_context_t * ctx); @@ -978,81 +897,20 @@ 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) + if((oberon_is_char_type(pref) && oberon_is_const_string(expr) && strlen(expr -> item.string) == 1)) { - result = b; - } - else if(a -> class != b -> class) - { - 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; -} - -static void -oberon_check_record_compatibility(oberon_context_t * ctx, oberon_type_t * from, oberon_type_t * to) -{ - 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) - { - oberon_error(ctx, "incompatible record types"); - } + return cast; } static void @@ -1096,132 +954,6 @@ 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) -{ - // Допускается: - // Если классы типов равны - // Если INTEGER переводится в REAL - // Если STRING переводится в CHAR - // Если STRING переводится в ARRAY OF CHAR - // Если NIL переводится в POINTER - // Если NIL переводится в PROCEDURE - - oberon_check_src(ctx, expr); - - bool error = false; - if(pref -> class != expr -> result -> class) - { - 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_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 - { - error = true; - } - } - else if(expr -> result -> class == OBERON_TYPE_INTEGER) - { - if(pref -> class != OBERON_TYPE_REAL) - { - error = true; - } - } - else - { - error = true; - } - } - - if(error) - { - oberon_error(ctx, "oberon_autocast_to: incompatible types"); - } - - 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) - { - 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) { @@ -1251,19 +983,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_check_dst(ctx, arg); + if(!oberon_is_compatible_arrays(param, arg)) { - oberon_error(ctx, "assign to read-only var"); + oberon_check_compatible_var_param(ctx, param -> type, arg -> result); } - casted[i] = arg; + casted[i] = oberon_cast_expr(ctx, arg, param -> type); } else { - casted[i] = oberon_autocast_to(ctx, arg, param -> type); + oberon_check_src(ctx, arg); + if(!oberon_is_compatible_arrays(param, arg)) + { + oberon_check_assignment_compatible(ctx, arg, param -> type); + } + casted[i] = oberon_cast_expr(ctx, arg, param -> type); } arg = arg -> next; @@ -1581,47 +1315,6 @@ oberon_qualident_expr(oberon_context_t * ctx) 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) { @@ -1661,7 +1354,8 @@ oberon_designator(oberon_context_t * ctx) oberon_assert_token(ctx, LPAREN); objtype = oberon_qualident(ctx, NULL, true); oberon_assert_token(ctx, RPAREN); - expr = oberon_make_type_guard(ctx, expr, objtype); + 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"); @@ -1760,6 +1454,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"); @@ -1770,6 +1465,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"); @@ -1873,172 +1569,34 @@ oberon_factor(oberon_context_t * ctx) return expr; } -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 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; + 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); + } + 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); + expr = oberon_new_operator(OP_IN, ctx -> bool_type, 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); + oberon_check_type_expr(ctx, b); + expr = oberon_new_operator(OP_IS, ctx -> bool_type, a, b); } else if((token >= EQUAL && token <= GEQ) || token == OR || token == AND) { - if(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(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, "invalid comparation"); - } - } - else if(token == AND || token == OR) - { - if(!oberon_is_boolean_type(a -> result) || !oberon_is_boolean_type(b -> result)) - { - oberon_error(ctx, "invalid comparation"); - } - } - else - { - oberon_error(ctx, "wat"); - } - - oberon_autocast_binary_op(ctx, &a, &b); + result = oberon_get_longer_type(ctx, a -> result, b -> result); + a = oberon_cast_expr(ctx, a, result); + b = oberon_cast_expr(ctx, b, result); result = ctx -> bool_type; if(token == EQUAL) @@ -2080,38 +1638,34 @@ oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_ } 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; + 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; + result = oberon_get_longer_real_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_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"); - } - - oberon_autocast_binary_op(ctx, &a, &b); - expr = oberon_new_operator(OP_DIV, a -> result, a, b); + 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_DIV, 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); + a = oberon_cast_expr(ctx, a, result); + b = oberon_cast_expr(ctx, b, result); + if(oberon_is_set_type(result)) { switch(token) { @@ -2129,8 +1683,7 @@ oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_ break; } } - else if(result -> class == OBERON_TYPE_INTEGER - || result -> class == OBERON_TYPE_REAL) + else if(oberon_is_number_type(result)) { switch(token) { @@ -2517,7 +2070,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; @@ -3327,28 +2882,17 @@ oberon_statement_seq(oberon_context_t * ctx); static void oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst) { - 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_check_dst(ctx, dst); + oberon_check_assignment_compatible(ctx, src, dst -> result); - if(strlen(src -> item.string) < dst -> result -> size) - { - src -> next = dst; - oberon_make_copy_call(ctx, 2, src); - } - else - { - oberon_error(ctx, "string too long for destination"); - } + if(oberon_is_string_type(src -> result)) + { + src -> next = dst; + oberon_make_copy_call(ctx, 2, src); } else { - oberon_check_dst(ctx, dst); - src = oberon_autocast_to(ctx, src, dst -> result); + src = oberon_cast_expr(ctx, src, dst -> result); oberon_generate_assign(ctx, src, dst); } } @@ -3362,14 +2906,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) @@ -3476,7 +3018,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; @@ -4176,12 +3719,12 @@ oberon_make_copy_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list dst = list_args -> next; oberon_check_dst(ctx, dst); - if(!oberon_is_string_type(src -> result)) + 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_string_type(dst -> result)) + if(!oberon_is_array_of_char_type(dst -> result)) { oberon_error(ctx, "dst must be array of char"); }