X-Git-Url: http://deadsoftware.ru/gitweb?p=dsw-obn.git;a=blobdiff_plain;f=src%2Foberon.c;h=437e7694205489c681c5da3757bdc7e58a42ad39;hp=07c83c28643623df555292ca429fa5eba776ae9d;hb=35e75d29be18a7355aaaea9e146f3fda1d91857f;hpb=0570527a2279ee6bd14b4c08e653b6d68369475a diff --git a/src/oberon.c b/src/oberon.c index 07c83c2..437e769 100644 --- a/src/oberon.c +++ b/src/oberon.c @@ -10,8 +10,6 @@ #include -#include "../include/oberon.h" - #include "oberon-internals.h" #include "oberon-type-compat.h" #include "oberon-common.h" @@ -151,6 +149,16 @@ oberon_make_integer(oberon_context_t * ctx, int64_t i) return expr; } +static oberon_expr_t * +oberon_make_system_byte(oberon_context_t * ctx, int64_t i) +{ + oberon_expr_t * expr; + expr = oberon_new_item(MODE_SYSBYTE, ctx -> system_byte_type, true); + expr -> item.integer = i; + expr -> item.real = i; + return expr; +} + static oberon_expr_t * oberon_make_char(oberon_context_t * ctx, int64_t i) { @@ -161,6 +169,17 @@ oberon_make_char(oberon_context_t * ctx, int64_t i) return expr; } +static oberon_expr_t * +oberon_make_string(oberon_context_t * ctx, char * str) +{ + oberon_expr_t * expr; + expr = oberon_new_item(MODE_STRING, ctx -> string_type, true); + expr -> item.integer = str[0]; + expr -> item.real = str[0]; + expr -> item.string = str; + return expr; +} + static oberon_expr_t * oberon_make_real_typed(oberon_context_t * ctx, double r, oberon_type_t * result) { @@ -341,15 +360,20 @@ oberon_get_char(oberon_context_t * ctx) if(ctx -> code[ctx -> code_index]) { ctx -> code_index += 1; + ctx -> xloc.col += 1; ctx -> c = ctx -> code[ctx -> code_index]; } } static void -oberon_init_scaner(oberon_context_t * ctx, const char * code) +oberon_init_scaner(oberon_context_t * ctx, oberon_scanner_t * s) { - ctx -> code = code; + ctx -> code = s -> code; ctx -> code_index = 0; + ctx -> xloc.source = s -> source; + ctx -> xloc.line = 1; + ctx -> xloc.col = 1; + ctx -> loc = ctx -> xloc; ctx -> c = ctx -> code[ctx -> code_index]; } @@ -668,12 +692,40 @@ oberon_read_number(oberon_context_t * ctx) ctx -> real = real; } +static void +oberon_get_lined_char(oberon_context_t * ctx) +{ + do + { + if(ctx -> c == 0xD) + { + oberon_get_char(ctx); + if(ctx -> c == 0xA) + { + oberon_get_char(ctx); + } + ctx -> xloc.line += 1; + ctx -> xloc.col = 1; + } + else if(ctx -> c == 0xA) + { + oberon_get_char(ctx); + ctx -> xloc.line += 1; + ctx -> xloc.col = 1; + } + else + { + oberon_get_char(ctx); + } + } while(ctx -> c == 0xD || ctx -> c == 0xA); +} + static void oberon_skip_space(oberon_context_t * ctx) { while(isspace(ctx -> c)) { - oberon_get_char(ctx); + oberon_get_lined_char(ctx); } } @@ -685,19 +737,19 @@ oberon_read_comment(oberon_context_t * ctx) { if(ctx -> c == '(') { - oberon_get_char(ctx); + oberon_get_lined_char(ctx); if(ctx -> c == '*') { - oberon_get_char(ctx); + oberon_get_lined_char(ctx); nesting += 1; } } else if(ctx -> c == '*') { - oberon_get_char(ctx); + oberon_get_lined_char(ctx); if(ctx -> c == ')') { - oberon_get_char(ctx); + oberon_get_lined_char(ctx); nesting -= 1; } } @@ -707,7 +759,7 @@ oberon_read_comment(oberon_context_t * ctx) } else { - oberon_get_char(ctx); + oberon_get_lined_char(ctx); } } } @@ -889,6 +941,8 @@ oberon_read_token(oberon_context_t * ctx) { oberon_skip_space(ctx); + ctx -> loc = ctx -> xloc; + int c = ctx -> c; if(isalpha(c) || c == '_') { @@ -1046,6 +1100,12 @@ oberon_cast_expr(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * p return cast; } +static oberon_expr_t * +oberon_hard_cast_expr(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref) +{ + return oberon_new_operator(OP_HARDCAST, pref, expr, NULL); +} + static void oberon_check_dst(oberon_context_t * ctx, oberon_expr_t * dst) { @@ -1232,6 +1292,7 @@ oberon_make_call_proc(oberon_context_t * ctx, oberon_item_t * item, int num_args || ((x) == CHAR) \ || ((x) == STRING) \ || ((x) == NIL) \ + || ((x) == LBRACE) \ || ((x) == LPAREN) \ || ((x) == NOT)) @@ -1650,9 +1711,7 @@ oberon_factor(oberon_context_t * ctx) oberon_assert_token(ctx, CHAR); break; case STRING: - result = ctx -> string_type; - expr = oberon_new_item(MODE_STRING, result, true); - expr -> item.string = ctx -> string; + expr = oberon_make_string(ctx, ctx -> string); oberon_assert_token(ctx, STRING); break; case REAL: @@ -1689,7 +1748,7 @@ oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_ oberon_expr_t * expr; oberon_type_t * result; - oberon_check_compatible_bin_expr_types(ctx, token, a -> result, b -> result); + oberon_check_compatible_bin_expr(ctx, token, a, b); oberon_check_src(ctx, a); if(token != IS) { @@ -1714,7 +1773,22 @@ oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_ } else if((token >= EQUAL && token <= GEQ) || token == OR || token == AND) { - result = oberon_get_longer_type(ctx, a -> result, b -> result); + if(oberon_is_string_of_one(a) && oberon_is_char_type(b -> result)) + { + result = b -> result; + } + else if(oberon_is_string_of_one(b) && oberon_is_char_type(a -> result)) + { + result = a -> result; + } + else if(oberon_is_string_of_one(a) && oberon_is_string_of_one(b)) + { + result = ctx -> char_type; + } + else + { + result = oberon_get_longer_type(ctx, a -> result, b -> result); + } if(oberon_is_const(a) && oberon_is_const(b) && (oberon_is_real_type(result) || oberon_is_integer_type(result))) @@ -1885,7 +1959,26 @@ oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_ break; } } - else if(oberon_is_number_type(result)) + else if(oberon_is_real_type(result)) + { + switch(token) + { + case PLUS: + expr = oberon_new_operator(OP_ADD, result, a, b); + break; + case MINUS: + expr = oberon_new_operator(OP_SUB, result, a, b); + break; + case STAR: + expr = oberon_new_operator(OP_MUL, result, a, b); + break; + default: + printf("token %i line %i\n", token, ctx -> loc.line); + assert(0); + break; + } + } + else if(oberon_is_integer_type(result)) { switch(token) { @@ -1898,7 +1991,14 @@ oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_ case STAR: expr = oberon_new_operator(OP_MUL, result, a, b); break; + case DIV: + expr = oberon_new_operator(OP_DIV, result, a, b); + break; + case MOD: + expr = oberon_new_operator(OP_DIV, result, a, b); + break; default: + printf("token %i line %i\n", token, ctx -> loc.line); assert(0); break; } @@ -2012,6 +2112,7 @@ oberon_is_const(oberon_expr_t * expr) case MODE_STRING: case MODE_SET: case MODE_TYPE: + case MODE_SYSBYTE: return true; break; default: @@ -2311,8 +2412,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_NOTYPE - && proc -> has_return == 0) + if(proc -> type -> base -> class == OBERON_TYPE_NOTYPE) { oberon_make_return(ctx, NULL); } @@ -2717,7 +2817,14 @@ oberon_prevent_recursive_pointer(oberon_context_t * ctx, oberon_type_t * type) if(type -> recursive) { - oberon_error(ctx, "recursive pointer declaration"); + if(type -> class == OBERON_TYPE_POINTER) + { + oberon_error(ctx, "recursive pointer declaration"); + } + else + { + oberon_error(ctx, "recursive array declaration (pointer)"); + } } if(type -> class == OBERON_TYPE_POINTER @@ -2870,20 +2977,12 @@ static void oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type) static void oberon_initialize_record_fields(oberon_context_t * ctx, oberon_type_t * type) { - if(type -> class != OBERON_TYPE_RECORD) - { - return; - } + assert(type -> class == OBERON_TYPE_RECORD); int num_fields = type -> num_decl; oberon_object_t * field = type -> decl; for(int i = 0; i < num_fields; i++) { - if(field -> type -> class == OBERON_TYPE_POINTER) - { - oberon_initialize_type(ctx, field -> type); - } - oberon_initialize_object(ctx, field); field = field -> next; } @@ -2906,39 +3005,50 @@ oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type) type -> initialized = 1; - if(type -> class == OBERON_TYPE_POINTER) + if(type -> class == OBERON_TYPE_POINTER || type -> class == OBERON_TYPE_ARRAY) { - oberon_initialize_type(ctx, type -> base); - oberon_generator_init_type(ctx, type); - } - else if(type -> class == OBERON_TYPE_ARRAY) - { - if(type -> size != 0) + if(type -> class == OBERON_TYPE_ARRAY + && type -> size != 0 + && type -> base -> class == OBERON_TYPE_ARRAY + && type -> base -> size == 0) { - if(type -> base -> class == OBERON_TYPE_ARRAY) - { - if(type -> base -> size == 0) - { - oberon_error(ctx, "open array not allowed as array element"); - } - } + oberon_error(ctx, "open array not allowed as array element"); } - oberon_initialize_type(ctx, type -> base); - oberon_generator_init_type(ctx, type); + oberon_type_t * rec = type -> base; + while(rec -> class == OBERON_TYPE_ARRAY || rec -> class == OBERON_TYPE_POINTER) + { + rec = rec -> base; + } + + if(rec -> class == OBERON_TYPE_RECORD + && rec -> initialized == 0) + { + rec -> initialized = 1; + oberon_generator_init_type(ctx, rec); + oberon_initialize_type(ctx, type -> base); + oberon_generator_init_type(ctx, type); + oberon_initialize_record_fields(ctx, rec); + } + else + { + oberon_initialize_type(ctx, type -> base); + oberon_generator_init_type(ctx, type); + } } else if(type -> class == OBERON_TYPE_RECORD) { + printf("Init type: RECORD\n"); oberon_generator_init_type(ctx, type); oberon_initialize_record_fields(ctx, type); } else if(type -> class == OBERON_TYPE_PROCEDURE) { + printf("Init type: PROCEDURE\n"); int num_fields = type -> num_decl; oberon_object_t * field = type -> decl; for(int i = 0; i < num_fields; i++) { - //oberon_initialize_object(ctx, field); oberon_initialize_type(ctx, field -> type); field = field -> next; } @@ -3115,7 +3225,7 @@ oberon_case_labels(oberon_context_t * ctx, oberon_expr_t * val) oberon_expr_t * cond2; e1 = (oberon_expr_t *) oberon_const_expr(ctx); - + e2 = NULL; if(ctx -> token == DOTDOT) { @@ -3526,14 +3636,14 @@ oberon_import_module(oberon_context_t * ctx, char * alias, char * name) if(m == NULL) { - const char * code; - code = ctx -> import_module(name); - if(code == NULL) + oberon_scanner_t * s; + s = ctx -> import_module(name); + if(s == NULL) { - oberon_error(ctx, "no such module"); + oberon_error(ctx, "no such module %s", name); } - m = oberon_compile_module(ctx, code); + m = oberon_compile_module(ctx, s); assert(m); } @@ -3777,7 +3887,7 @@ oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ arg = list_args; oberon_check_src(ctx, arg); - if(oberon_is_number_type(arg -> result)) + if(!oberon_is_number_type(arg -> result)) { oberon_error(ctx, "ABS accepts only numbers"); } @@ -3811,7 +3921,7 @@ oberon_make_inc_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ oberon_error(ctx, "too few arguments"); } - if(num_args > 1) + if(num_args > 2) { oberon_error(ctx, "too mach arguments"); } @@ -3825,8 +3935,24 @@ oberon_make_inc_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ oberon_error(ctx, "expect integer"); } + oberon_expr_t * step; + if(num_args == 2) + { + step = list_args -> next; + oberon_check_src(ctx, step); + oberon_check_const(ctx, step); + if(!oberon_is_integer_type(step -> result)) + { + oberon_error(ctx, "expect integer"); + } + } + else + { + step = oberon_make_integer(ctx, 1); + } + oberon_expr_t * expr; - expr = oberon_make_bin_op(ctx, PLUS, dst, oberon_make_integer(ctx, 1)); + expr = oberon_make_bin_op(ctx, PLUS, dst, step); oberon_assign(ctx, expr, dst); } @@ -3910,7 +4036,7 @@ oberon_make_dec_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ oberon_error(ctx, "too few arguments"); } - if(num_args > 1) + if(num_args > 2) { oberon_error(ctx, "too mach arguments"); } @@ -3924,8 +4050,24 @@ oberon_make_dec_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ oberon_error(ctx, "expect integer"); } + oberon_expr_t * step; + if(num_args == 2) + { + step = list_args -> next; + oberon_check_src(ctx, step); + oberon_check_const(ctx, step); + if(!oberon_is_integer_type(step -> result)) + { + oberon_error(ctx, "expect integer"); + } + } + else + { + step = oberon_make_integer(ctx, 1); + } + oberon_expr_t * expr; - expr = oberon_make_bin_op(ctx, MINUS, dst, oberon_make_integer(ctx, 1)); + expr = oberon_make_bin_op(ctx, MINUS, dst, step); oberon_assign(ctx, expr, dst); } @@ -4150,7 +4292,8 @@ oberon_make_ash_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ { int64_t x = arg1 -> item.integer; int64_t y = arg2 -> item.integer; - expr = oberon_make_integer(ctx, x * powl(2, y)); + int64_t v = (y > 0) ? (x << y) : (x >> labs(y)); + expr = oberon_make_integer(ctx, v); } else { @@ -4160,6 +4303,140 @@ oberon_make_ash_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ return expr; } +static oberon_expr_t * +oberon_make_lsh_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 2) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 2) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * arg1; + arg1 = list_args; + oberon_check_src(ctx, arg1); + + oberon_type_t * t = arg1 -> result; + if(!oberon_is_integer_type(t) + && !oberon_is_char_type(t) + && !oberon_is_system_byte_type(t)) + { + oberon_error(ctx, "expected integer, char, or SYSTEM.BYTE"); + } + + oberon_expr_t * arg2; + arg2 = list_args -> next; + oberon_check_src(ctx, arg2); + if(arg2 -> result -> class != OBERON_TYPE_INTEGER) + { + oberon_error(ctx, "expected integer"); + } + + oberon_expr_t * expr; + if(oberon_is_const(arg1) && oberon_is_const(arg2)) + { + uint64_t x = arg1 -> item.integer; + int64_t y = arg2 -> item.integer; + uint64_t v = (y > 0) ? (x << y) : (x >> labs(y)); + + if(oberon_is_integer_type(t)) + { + expr = oberon_make_integer(ctx, v); + } + else if(oberon_is_char_type(t)) + { + expr = oberon_make_char(ctx, v); + } + else + { + expr = oberon_make_system_byte(ctx, v); + } + } + else + { + expr = oberon_new_operator(OP_LSH, arg1 -> result, arg1, arg2); + expr = oberon_cast_expr(ctx, expr, t); + } + + return expr; +} + +static oberon_expr_t * +oberon_make_rot_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 2) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 2) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * arg1; + arg1 = list_args; + oberon_check_src(ctx, arg1); + + oberon_type_t * t = arg1 -> result; + if(!oberon_is_integer_type(t) + && !oberon_is_char_type(t) + && !oberon_is_system_byte_type(t)) + { + oberon_error(ctx, "expected integer, char, or SYSTEM.BYTE"); + } + + oberon_expr_t * arg2; + arg2 = list_args -> next; + oberon_check_src(ctx, arg2); + if(arg2 -> result -> class != OBERON_TYPE_INTEGER) + { + oberon_error(ctx, "expected integer"); + } + + oberon_expr_t * expr; + if(oberon_is_const(arg1) && oberon_is_const(arg2)) + { + uint64_t x = arg1 -> item.integer; + int64_t y = arg2 -> item.integer; + + uint64_t v = 0; + if(y > 0) + { + v = (x << y) | (x >> (64 - y)); + } + else + { + y = labs(y); + v = (x >> y) | (x << (64 - y)); + } + + if(oberon_is_integer_type(t)) + { + expr = oberon_make_integer(ctx, v); + } + else if(oberon_is_char_type(t)) + { + expr = oberon_make_char(ctx, v); + } + else + { + expr = oberon_make_system_byte(ctx, v); + } + } + else + { + expr = oberon_new_operator(OP_ROT, arg1 -> result, arg1, arg2); + expr = oberon_cast_expr(ctx, expr, t); + } + + return expr; +} + static oberon_expr_t * oberon_make_cap_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) { @@ -4246,7 +4523,7 @@ oberon_make_ord_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ arg = list_args; oberon_check_src(ctx, arg); - if(!oberon_is_char_type(arg -> result)) + if(!oberon_is_char_type(arg -> result) && !oberon_is_string_of_one(arg)) { oberon_error(ctx, "expected char"); } @@ -4325,6 +4602,38 @@ oberon_make_odd_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ return expr; } +static oberon_expr_t * +oberon_make_cc_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 1) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 1) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * arg; + arg = list_args; + oberon_check_src(ctx, arg); + oberon_check_const(ctx, arg); + + if(!oberon_is_integer_type(arg -> result)) + { + oberon_error(ctx, "expected integer"); + } + + /* n >= 0 && n <= 15 */ + + oberon_expr_t * cond1; + oberon_expr_t * cond2; + cond1 = oberon_make_bin_op(ctx, GEQ, arg, oberon_make_integer(ctx, 0)); + cond2 = oberon_make_bin_op(ctx, LEQ, arg, oberon_make_integer(ctx, 15)); + return oberon_make_bin_op(ctx, AND, cond1, cond2); +} + static oberon_expr_t * oberon_make_short_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) { @@ -4379,6 +4688,35 @@ oberon_make_long_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list return expr; } +static oberon_expr_t * +oberon_make_val_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 2) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 2) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * typ; + typ = list_args; + if(!oberon_is_type_expr(typ)) + { + oberon_error(ctx, "requires type"); + } + + oberon_expr_t * arg; + arg = list_args -> next; + oberon_check_src(ctx, arg); + + oberon_expr_t * expr; + expr = oberon_hard_cast_expr(ctx, arg, typ -> result); + return expr; +} + static oberon_expr_t * oberon_make_len_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) { @@ -4622,6 +4960,14 @@ oberon_create_context(ModuleImportCallback import_module) /* Types */ oberon_new_intrinsic_type(ctx, "BYTE", ctx -> system_byte_type); oberon_new_intrinsic_type(ctx, "PTR", ctx -> system_ptr_type); + oberon_new_intrinsic_type(ctx, "INT32", ctx -> int_type); + oberon_new_intrinsic_type(ctx, "SET32", ctx -> set_type); + + /* Functions */ + oberon_new_intrinsic(ctx, "CC", oberon_make_cc_call, NULL); + oberon_new_intrinsic(ctx, "LSH", oberon_make_lsh_call, NULL); + oberon_new_intrinsic(ctx, "ROT", oberon_make_rot_call, NULL); + oberon_new_intrinsic(ctx, "VAL", oberon_make_val_call, NULL); oberon_end_intrinsic_module(ctx, ctx -> system_module); @@ -4635,10 +4981,12 @@ oberon_destroy_context(oberon_context_t * ctx) } oberon_module_t * -oberon_compile_module(oberon_context_t * ctx, const char * newcode) +oberon_compile_module(oberon_context_t * ctx, oberon_scanner_t * s) { const char * code = ctx -> code; int code_index = ctx -> code_index; + oberon_location_t loc = ctx -> loc; + oberon_location_t xloc = ctx -> xloc; char c = ctx -> c; int token = ctx -> token; char * string = ctx -> string; @@ -4660,13 +5008,15 @@ oberon_compile_module(oberon_context_t * ctx, const char * newcode) ctx -> mod = module; ctx -> module_list = module; - oberon_init_scaner(ctx, newcode); + oberon_init_scaner(ctx, s); oberon_parse_module(ctx); module -> ready = 1; ctx -> code = code; ctx -> code_index = code_index; + ctx -> loc = loc; + ctx -> xloc = xloc; ctx -> c = c; ctx -> token = token; ctx -> string = string;