X-Git-Url: https://deadsoftware.ru/gitweb?a=blobdiff_plain;f=oberon.c;h=6dd84f16b6b9c3108973c087636865c661735bc3;hb=1bf625553dc35ac4a5c1afceb6950fd44776a424;hp=b7ffd0ea73ab2b9cd366a04d96a2b1e16a80a94d;hpb=060a955ff58efde6cb51ab18eaed8f479e2550f3;p=dsw-obn.git diff --git a/oberon.c b/oberon.c index b7ffd0e..6dd84f1 100644 --- a/oberon.c +++ b/oberon.c @@ -118,6 +118,12 @@ oberon_open_scope(oberon_context_t * ctx) scope -> list = list; scope -> up = ctx -> decl; + if(scope -> up) + { + scope -> parent = scope -> up -> parent; + scope -> local = scope -> up -> local; + } + ctx -> decl = scope; return scope; } @@ -147,6 +153,8 @@ oberon_define_object(oberon_scope_t * scope, char * name, int class) memset(newvar, 0, sizeof *newvar); newvar -> name = name; newvar -> class = class; + newvar -> local = scope -> local; + newvar -> parent = scope -> parent; x -> next = newvar; @@ -156,6 +164,8 @@ oberon_define_object(oberon_scope_t * scope, char * name, int class) static void oberon_define_field(oberon_context_t * ctx, oberon_type_t * rec, char * name, oberon_type_t * type) { + // TODO check base fields + oberon_object_t * x = rec -> decl; while(x -> next && strcmp(x -> next -> name, name) != 0) { @@ -172,6 +182,8 @@ oberon_define_field(oberon_context_t * ctx, oberon_type_t * rec, char * name, o field -> name = name; field -> class = OBERON_CLASS_FIELD; field -> type = type; + field -> local = 1; + field -> parent = NULL; rec -> num_decl += 1; x -> next = field; @@ -274,6 +286,7 @@ oberon_find_var(oberon_scope_t * scope, char * name) } */ +/* static oberon_object_t * oberon_define_proc(oberon_scope_t * scope, char * name, oberon_type_t * signature) { @@ -282,6 +295,7 @@ oberon_define_proc(oberon_scope_t * scope, char * name, oberon_type_t * signatur proc -> type = signature; return proc; } +*/ // ======================================================================= // SCANER @@ -739,12 +753,100 @@ oberon_autocast_call(oberon_context_t * ctx, oberon_expr_t * desig) oberon_object_t * param = fn -> decl; for(int i = 0; i < num_args; i++) { + if(param -> class == OBERON_CLASS_VAR_PARAM) + { + if(arg -> is_item) + { + switch(arg -> item.mode) + { + case MODE_VAR: + case MODE_INDEX: + case MODE_FIELD: + // Допустимо разыменование? + //case MODE_DEREF: + break; + default: + oberon_error(ctx, "var-parameter accept only variables"); + break; + } + } + } oberon_autocast_to(ctx, arg, param -> type); arg = arg -> next; param = param -> next; } } +static oberon_expr_t * +oberon_make_call_func(oberon_context_t * ctx, oberon_object_t * proc, int num_args, oberon_expr_t * list_args) +{ + if(proc -> class != OBERON_CLASS_PROC) + { + oberon_error(ctx, "not a procedure"); + } + + oberon_expr_t * call; + + if(proc -> sysproc) + { + if(proc -> genfunc == NULL) + { + oberon_error(ctx, "not a function-procedure"); + } + + call = proc -> genfunc(ctx, num_args, list_args); + } + else + { + if(proc -> type -> base -> class == OBERON_TYPE_VOID) + { + oberon_error(ctx, "attempt to call procedure in expression"); + } + + call = oberon_new_item(MODE_CALL, proc -> type -> base); + call -> item.var = proc; + call -> item.num_args = num_args; + call -> item.args = list_args; + oberon_autocast_call(ctx, call); + } + + return call; +} + +static void +oberon_make_call_proc(oberon_context_t * ctx, oberon_object_t * proc, int num_args, oberon_expr_t * list_args) +{ + if(proc -> class != OBERON_CLASS_PROC) + { + oberon_error(ctx, "not a procedure"); + } + + 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); + 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) \ @@ -790,14 +892,12 @@ oberon_make_array_selector(oberon_context_t * ctx, oberon_expr_t * desig, oberon oberon_type_t * base; base = desig -> result -> base; - // TODO check ranges - - printf("oberon_make_array_selector: index class %i\n", index -> result -> class); if(index -> result -> class != OBERON_TYPE_INTEGER) { oberon_error(ctx, "index must be integer"); } + // Статическая проверка границ массива if(index -> is_item) { if(index -> item.mode == MODE_INTEGER) @@ -875,6 +975,7 @@ oberon_designator(oberon_context_t * ctx) expr = oberon_new_item(MODE_VAR, var -> type); break; case OBERON_CLASS_PROC: + //expr = oberon_make_call_expr(var, 0, NULL); expr = oberon_new_item(MODE_CALL, var -> type); break; default: @@ -918,17 +1019,37 @@ oberon_designator(oberon_context_t * ctx) } static oberon_expr_t * -oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr) +oberon_opt_func_parens(oberon_context_t * ctx, oberon_expr_t * expr) { assert(expr -> is_item == 1); if(ctx -> token == LPAREN) { - if(expr -> result -> class != OBERON_TYPE_PROCEDURE) + oberon_assert_token(ctx, LPAREN); + + int num_args = 0; + oberon_expr_t * arguments = NULL; + + if(ISEXPR(ctx -> token)) { - oberon_error(ctx, "not a procedure"); + oberon_expr_list(ctx, &num_args, &arguments, 0); } + expr = oberon_make_call_func(ctx, expr -> item.var, num_args, arguments); + + oberon_assert_token(ctx, RPAREN); + } + + return expr; +} + +static void +oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr) +{ + assert(expr -> is_item == 1); + + if(ctx -> token == LPAREN) + { oberon_assert_token(ctx, LPAREN); int num_args = 0; @@ -939,16 +1060,10 @@ oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr) oberon_expr_list(ctx, &num_args, &arguments, 0); } - expr -> result = expr -> item.var -> type -> base; - expr -> item.mode = MODE_CALL; - expr -> item.num_args = num_args; - expr -> item.args = arguments; - oberon_assert_token(ctx, RPAREN); + oberon_make_call_proc(ctx, expr -> item.var, num_args, arguments); - oberon_autocast_call(ctx, expr); + oberon_assert_token(ctx, RPAREN); } - - return expr; } static oberon_expr_t * @@ -960,7 +1075,7 @@ oberon_factor(oberon_context_t * ctx) { case IDENT: expr = oberon_designator(ctx); - expr = oberon_opt_proc_parens(ctx, expr); + expr = oberon_opt_func_parens(ctx, expr); break; case INTEGER: expr = oberon_new_item(MODE_INTEGER, ctx -> int_type); @@ -1241,7 +1356,9 @@ oberon_const_expr(oberon_context_t * ctx) // PARSER // ======================================================================= +static void oberon_decl_seq(oberon_context_t * ctx); static void oberon_statement_seq(oberon_context_t * ctx); +static void oberon_initialize_decl(oberon_context_t * ctx); static void oberon_expect_token(oberon_context_t * ctx, int token) @@ -1350,6 +1467,7 @@ oberon_formal_pars(oberon_context_t * ctx, oberon_type_t * signature) if(ctx -> token == COLON) { oberon_assert_token(ctx, COLON); + // TODO get by qualident oberon_type(ctx, &signature -> base); } } @@ -1370,10 +1488,41 @@ oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type) } } +static void +oberon_compare_signatures(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b) +{ + if(a -> num_decl != b -> num_decl) + { + oberon_error(ctx, "number parameters not matched"); + } + + int num_param = a -> num_decl; + oberon_object_t * param_a = a -> decl; + oberon_object_t * param_b = b -> decl; + for(int i = 0; i < num_param; i++) + { + if(strcmp(param_a -> name, param_b -> name) != 0) + { + oberon_error(ctx, "param %i name not matched", i + 1); + } + + if(param_a -> type != param_b -> type) + { + oberon_error(ctx, "param %i type not matched", i + 1); + } + + param_a = param_a -> next; + param_b = param_b -> next; + } +} + static void oberon_make_return(oberon_context_t * ctx, oberon_expr_t * expr) { - if(ctx -> result_type -> class == OBERON_TYPE_VOID) + oberon_object_t * proc = ctx -> decl -> parent; + oberon_type_t * result_type = proc -> type -> base; + + if(result_type -> class == OBERON_TYPE_VOID) { if(expr != NULL) { @@ -1387,41 +1536,25 @@ oberon_make_return(oberon_context_t * ctx, oberon_expr_t * expr) oberon_error(ctx, "procedure requires expression on result"); } - oberon_autocast_to(ctx, expr, ctx -> result_type); + oberon_autocast_to(ctx, expr, result_type); } - ctx -> has_return = 1; + proc -> has_return = 1; oberon_generate_return(ctx, expr); } static void -oberon_proc_decl(oberon_context_t * ctx) +oberon_proc_decl_body(oberon_context_t * ctx, oberon_object_t * proc) { - oberon_assert_token(ctx, PROCEDURE); - - char * name; - name = oberon_assert_ident(ctx); - - oberon_scope_t * this_proc_def_scope = ctx -> decl; - oberon_open_scope(ctx); - - oberon_type_t * signature; - signature = oberon_new_type_ptr(OBERON_TYPE_VOID); - oberon_opt_formal_pars(ctx, &signature); - - oberon_object_t * proc; - proc = oberon_define_proc(this_proc_def_scope, name, signature); + oberon_assert_token(ctx, SEMICOLON); - ctx -> result_type = signature -> base; - ctx -> has_return = 0; + ctx -> decl = proc -> scope; - oberon_assert_token(ctx, SEMICOLON); + oberon_decl_seq(ctx); oberon_generate_begin_proc(ctx, proc); - // TODO declarations - if(ctx -> token == BEGIN) { oberon_assert_token(ctx, BEGIN); @@ -1429,27 +1562,90 @@ oberon_proc_decl(oberon_context_t * ctx) } oberon_assert_token(ctx, END); - char * name2 = oberon_assert_ident(ctx); - if(strcmp(name2, name) != 0) + char * name = oberon_assert_ident(ctx); + if(strcmp(name, proc -> name) != 0) { oberon_error(ctx, "procedure name not matched"); } - if(signature -> base -> class == OBERON_TYPE_VOID) + if(proc -> type -> base -> class == OBERON_TYPE_VOID + && proc -> has_return == 0) { oberon_make_return(ctx, NULL); } - if(ctx -> has_return == 0) + if(proc -> has_return == 0) { oberon_error(ctx, "procedure requires return"); } - ctx -> result_type = NULL; oberon_generate_end_proc(ctx); oberon_close_scope(ctx -> decl); } +static void +oberon_proc_decl(oberon_context_t * ctx) +{ + oberon_assert_token(ctx, PROCEDURE); + + int forward = 0; + if(ctx -> token == UPARROW) + { + oberon_assert_token(ctx, UPARROW); + forward = 1; + } + + char * name; + name = oberon_assert_ident(ctx); + + oberon_scope_t * proc_scope; + proc_scope = oberon_open_scope(ctx); + ctx -> decl -> local = 1; + + oberon_type_t * signature; + signature = oberon_new_type_ptr(OBERON_TYPE_VOID); + oberon_opt_formal_pars(ctx, &signature); + + 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 -> class != OBERON_CLASS_PROC) + { + oberon_error(ctx, "mult definition"); + } + + if(forward == 0) + { + if(proc -> linked) + { + oberon_error(ctx, "mult procedure definition"); + } + } + + oberon_compare_signatures(ctx, proc -> type, signature); + } + else + { + proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC); + proc -> type = signature; + proc -> scope = proc_scope; + oberon_generator_init_proc(ctx, proc); + } + + proc -> scope -> parent = proc; + + if(forward == 0) + { + proc -> linked = 1; + oberon_proc_decl_body(ctx, proc); + } +} + static void oberon_const_decl(oberon_context_t * ctx) { @@ -1897,7 +2093,13 @@ oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type) static void oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x) { - printf("oberon_initialize_object: name %s class %i\n", x -> name, x -> class); + if(x -> initialized) + { + return; + } + + x -> initialized = 1; + switch(x -> class) { case OBERON_CLASS_TYPE: @@ -1931,6 +2133,24 @@ oberon_initialize_decl(oberon_context_t * ctx) } } +static void +oberon_prevent_undeclarated_procedures(oberon_context_t * ctx) +{ + oberon_object_t * x = ctx -> decl -> list; + + while(x -> next) + { + if(x -> next -> class == OBERON_CLASS_PROC) + { + if(x -> next -> linked == 0) + { + oberon_error(ctx, "unresolved forward declaration"); + } + } + x = x -> next; + } +} + static void oberon_decl_seq(oberon_context_t * ctx) { @@ -1972,6 +2192,8 @@ oberon_decl_seq(oberon_context_t * ctx) oberon_proc_decl(ctx); oberon_assert_token(ctx, SEMICOLON); } + + oberon_prevent_undeclarated_procedures(ctx); } static void @@ -1981,13 +2203,6 @@ oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst) oberon_generate_assign(ctx, src, dst); } -static void -oberon_make_call(oberon_context_t * ctx, oberon_expr_t * desig) -{ - oberon_autocast_call(ctx, desig); - oberon_generate_call_proc(ctx, desig); -} - static void oberon_statement(oberon_context_t * ctx) { @@ -2005,8 +2220,7 @@ oberon_statement(oberon_context_t * ctx) } else { - item1 = oberon_opt_proc_parens(ctx, item1); - oberon_make_call(ctx, item1); + oberon_opt_proc_parens(ctx, item1); } } else if(ctx -> token == RETURN) @@ -2088,6 +2302,58 @@ register_default_types(oberon_context_t * ctx) oberon_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type); } +static void +oberon_new_intrinsic_function(oberon_context_t * ctx, char * name, GenerateFuncCallback generate) +{ + oberon_object_t * proc; + proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC); + proc -> sysproc = 1; + proc -> genfunc = generate; + proc -> type = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE); +} + +/* +static void +oberon_new_intrinsic_procedure(oberon_context_t * ctx, char * name, GenerateProcCallback generate) +{ + oberon_object_t * proc; + proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC); + proc -> sysproc = 1; + proc -> genproc = generate; + proc -> type = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE); +} +*/ + +static oberon_expr_t * +oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 1) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 1) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * arg; + arg = list_args; + + oberon_type_t * result_type; + result_type = arg -> result; + + if(result_type -> class != OBERON_TYPE_INTEGER) + { + oberon_error(ctx, "ABS accepts only integers"); + } + + + oberon_expr_t * expr; + expr = oberon_new_operator(OP_ABS, result_type, arg, NULL); + return expr; +} + oberon_context_t * oberon_create_context() { @@ -2100,7 +2366,8 @@ oberon_create_context() oberon_generator_init_context(ctx); - register_default_types(ctx); + register_default_types(ctx); + oberon_new_intrinsic_function(ctx, "ABS", oberon_make_abs_call); return ctx; }