X-Git-Url: http://deadsoftware.ru/gitweb?a=blobdiff_plain;f=oberon.c;h=e12ee36174e9fd9cfd9a870225dea8528d46e8f8;hb=c15b86365824545bdee7d813ce0c796f1bdff592;hp=dfed94a274ad3991d56ab8adf5223fabac446e38;hpb=338eeae16495bbdcbd8c4f3dad4996346e26139b;p=dsw-obn.git diff --git a/oberon.c b/oberon.c index dfed94a..e12ee36 100644 --- a/oberon.c +++ b/oberon.c @@ -52,7 +52,8 @@ enum { POINTER, TO, UPARROW, - NIL + NIL, + IMPORT }; // ======================================================================= @@ -108,16 +109,19 @@ oberon_new_type_boolean(int size) static oberon_scope_t * oberon_open_scope(oberon_context_t * ctx) { - oberon_scope_t * scope = malloc(sizeof *scope); - memset(scope, 0, sizeof *scope); - - oberon_object_t * list = malloc(sizeof *list); - memset(list, 0, sizeof *list); + oberon_scope_t * scope = calloc(1, sizeof *scope); + oberon_object_t * list = calloc(1, sizeof *list); scope -> ctx = 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 +151,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 +162,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 +180,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 +284,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 +293,7 @@ oberon_define_proc(oberon_scope_t * scope, char * name, oberon_type_t * signatur proc -> type = signature; return proc; } +*/ // ======================================================================= // SCANER @@ -401,6 +413,10 @@ oberon_read_ident(oberon_context_t * ctx) { ctx -> token = NIL; } + else if(strcmp(ident, "IMPORT") == 0) + { + ctx -> token = IMPORT; + } } static void @@ -572,6 +588,7 @@ static oberon_expr_t * oberon_expr(oberon_context_t * ctx); static void oberon_assert_token(oberon_context_t * ctx, int token); static char * oberon_assert_ident(oberon_context_t * ctx); static void oberon_type(oberon_context_t * ctx, oberon_type_t ** type); +static oberon_item_t * oberon_const_expr(oberon_context_t * ctx); static oberon_expr_t * oberon_new_operator(int op, oberon_type_t * result, oberon_expr_t * left, oberon_expr_t * right) @@ -638,7 +655,7 @@ oberon_make_unary_op(oberon_context_t * ctx, int token, oberon_expr_t * a) } static void -oberon_expr_list(oberon_context_t * ctx, int * num_expr, oberon_expr_t ** first) +oberon_expr_list(oberon_context_t * ctx, int * num_expr, oberon_expr_t ** first, int const_expr) { oberon_expr_t * last; @@ -648,7 +665,16 @@ oberon_expr_list(oberon_context_t * ctx, int * num_expr, oberon_expr_t ** first) { oberon_assert_token(ctx, COMMA); oberon_expr_t * current; - current = oberon_expr(ctx); + + if(const_expr) + { + current = (oberon_expr_t *) oberon_const_expr(ctx); + } + else + { + current = oberon_expr(ctx); + } + last -> next = current; last = current; *num_expr += 1; @@ -663,7 +689,6 @@ oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * oberon_error(ctx, "incompatible types"); } - if(pref -> class == OBERON_TYPE_INTEGER) { if(expr -> result -> class > pref -> class) @@ -679,6 +704,16 @@ oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * oberon_error(ctx, "incompatible record types"); } } + else if(pref -> class == OBERON_TYPE_POINTER) + { + if(expr -> result -> base != pref -> base) + { + if(expr -> result -> base -> class != OBERON_TYPE_VOID) + { + oberon_error(ctx, "incompatible pointer types"); + } + } + } // TODO cast @@ -698,7 +733,7 @@ oberon_autocast_call(oberon_context_t * ctx, oberon_expr_t * desig) oberon_error(ctx, "expected mode CALL"); } - if(desig -> item.var -> class != OBERON_CLASS_PROC) + if(desig -> item.var -> type -> class != OBERON_TYPE_PROCEDURE) { oberon_error(ctx, "only procedures can be called"); } @@ -720,12 +755,132 @@ 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) +{ + 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; + } + + 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) +{ + 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); + 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) \ @@ -754,7 +909,7 @@ oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr) } static oberon_expr_t * -oberon_make_array_selector(oberon_context_t * ctx, oberon_expr_t * desig, int num_indexes, oberon_expr_t * indexes) +oberon_make_array_selector(oberon_context_t * ctx, oberon_expr_t * desig, oberon_expr_t * index) { if(desig -> result -> class == OBERON_TYPE_POINTER) { @@ -771,13 +926,30 @@ oberon_make_array_selector(oberon_context_t * ctx, oberon_expr_t * desig, int nu oberon_type_t * base; base = desig -> result -> base; - // TODO check ranges + if(index -> result -> class != OBERON_TYPE_INTEGER) + { + oberon_error(ctx, "index must be integer"); + } + + // Статическая проверка границ массива + if(index -> is_item) + { + if(index -> item.mode == MODE_INTEGER) + { + int arr_size = desig -> result -> size; + int index_int = index -> item.integer; + if(index_int < 0 || index_int > arr_size - 1) + { + oberon_error(ctx, "not in range (dimension size 0..%i)", arr_size - 1); + } + } + } oberon_expr_t * selector; selector = oberon_new_item(MODE_INDEX, base); selector -> item.parent = (oberon_item_t *) desig; - selector -> item.num_args = num_indexes; - selector -> item.args = indexes; + selector -> item.num_args = 1; + selector -> item.args = index; return selector; } @@ -815,6 +987,34 @@ oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char * || ((x) == DOT) \ || ((x) == UPARROW)) +static oberon_object_t * +oberon_qualident(oberon_context_t * ctx, char ** xname, int check) +{ + char * name; + oberon_object_t * x; + + name = oberon_assert_ident(ctx); + x = oberon_find_object(ctx -> decl, name, check); + + if(x != NULL) + { + if(x -> class == OBERON_CLASS_MODULE) + { + oberon_assert_token(ctx, DOT); + name = oberon_assert_ident(ctx); + /* Наличие объектов в левых модулях всегда проверяется */ + x = oberon_find_object(x -> module -> decl, name, 1); + } + } + + if(xname) + { + *xname = name; + } + + return x; +} + static oberon_expr_t * oberon_designator(oberon_context_t * ctx) { @@ -822,8 +1022,7 @@ oberon_designator(oberon_context_t * ctx) oberon_object_t * var; oberon_expr_t * expr; - name = oberon_assert_ident(ctx); - var = oberon_find_object(ctx -> decl, name, 1); + var = oberon_qualident(ctx, NULL, 1); switch(var -> class) { @@ -834,10 +1033,8 @@ oberon_designator(oberon_context_t * ctx) case OBERON_CLASS_VAR: case OBERON_CLASS_VAR_PARAM: case OBERON_CLASS_PARAM: - expr = oberon_new_item(MODE_VAR, var -> type); - break; case OBERON_CLASS_PROC: - expr = oberon_new_item(MODE_CALL, var -> type); + expr = oberon_new_item(MODE_VAR, var -> type); break; default: oberon_error(ctx, "invalid designator"); @@ -858,9 +1055,14 @@ oberon_designator(oberon_context_t * ctx) oberon_assert_token(ctx, LBRACE); int num_indexes = 0; oberon_expr_t * indexes = NULL; - oberon_expr_list(ctx, &num_indexes, &indexes); + oberon_expr_list(ctx, &num_indexes, &indexes, 0); oberon_assert_token(ctx, RBRACE); - expr = oberon_make_array_selector(ctx, expr, num_indexes, indexes); + + for(int i = 0; i < num_indexes; i++) + { + expr = oberon_make_array_selector(ctx, expr, indexes); + indexes = indexes -> next; + } break; case UPARROW: oberon_assert_token(ctx, UPARROW); @@ -875,17 +1077,13 @@ 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_error(ctx, "not a procedure"); - } - oberon_assert_token(ctx, LPAREN); int num_args = 0; @@ -893,21 +1091,41 @@ oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr) if(ISEXPR(ctx -> token)) { - oberon_expr_list(ctx, &num_args, &arguments); + 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); + expr = oberon_make_call_func(ctx, expr -> item.var, num_args, arguments); - oberon_autocast_call(ctx, expr); + 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); + + int num_args = 0; + oberon_expr_t * arguments = NULL; + + if(ctx -> token == LPAREN) + { + oberon_assert_token(ctx, LPAREN); + + if(ISEXPR(ctx -> token)) + { + oberon_expr_list(ctx, &num_args, &arguments, 0); + } + + oberon_assert_token(ctx, RPAREN); + } + + /* Вызов происходит даже без скобок */ + oberon_make_call_proc(ctx, expr -> item.var, num_args, arguments); +} + static oberon_expr_t * oberon_factor(oberon_context_t * ctx) { @@ -917,7 +1135,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); @@ -1198,7 +1416,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) @@ -1307,7 +1527,14 @@ oberon_formal_pars(oberon_context_t * ctx, oberon_type_t * signature) if(ctx -> token == COLON) { oberon_assert_token(ctx, COLON); - oberon_type(ctx, &signature -> base); + + oberon_object_t * typeobj; + typeobj = oberon_qualident(ctx, NULL, 1); + if(typeobj -> class != OBERON_CLASS_TYPE) + { + oberon_error(ctx, "function result is not type"); + } + signature -> base = typeobj -> type; } } @@ -1327,10 +1554,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) { @@ -1344,41 +1602,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); @@ -1386,27 +1628,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) { @@ -1423,9 +1728,14 @@ oberon_const_decl(oberon_context_t * ctx) } static void -oberon_make_array_type(oberon_context_t * ctx, oberon_item_t * size, oberon_type_t * base, oberon_type_t ** type) +oberon_make_array_type(oberon_context_t * ctx, oberon_expr_t * size, oberon_type_t * base, oberon_type_t ** type) { - if(size -> mode != MODE_INTEGER) + if(size -> is_item == 0) + { + oberon_error(ctx, "requires constant"); + } + + if(size -> item.mode != MODE_INTEGER) { oberon_error(ctx, "requires integer constant"); } @@ -1433,7 +1743,7 @@ oberon_make_array_type(oberon_context_t * ctx, oberon_item_t * size, oberon_type oberon_type_t * arr; arr = *type; arr -> class = OBERON_TYPE_ARRAY; - arr -> size = size -> integer; + arr -> size = size -> item.integer; arr -> base = base; } @@ -1459,8 +1769,10 @@ oberon_qualident_type(oberon_context_t * ctx, oberon_type_t ** type) char * name; oberon_object_t * to; - name = oberon_assert_ident(ctx); - to = oberon_find_object(ctx -> decl, name, 0); + to = oberon_qualident(ctx, &name, 0); + + //name = oberon_assert_ident(ctx); + //to = oberon_find_object(ctx -> decl, name, 0); if(to != NULL) { @@ -1484,6 +1796,23 @@ static void oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type * Правило граматики "type". Указатель type должен указывать на существующий объект! */ +static void +oberon_make_multiarray(oberon_context_t * ctx, oberon_expr_t * sizes, oberon_type_t * base, oberon_type_t ** type) +{ + if(sizes == NULL) + { + *type = base; + return; + } + + oberon_type_t * dim; + dim = oberon_new_type_ptr(OBERON_TYPE_VOID); + + oberon_make_multiarray(ctx, sizes -> next, base, &dim); + + oberon_make_array_type(ctx, sizes, dim, type); +} + static void oberon_type(oberon_context_t * ctx, oberon_type_t ** type) { @@ -1495,8 +1824,9 @@ oberon_type(oberon_context_t * ctx, oberon_type_t ** type) { oberon_assert_token(ctx, ARRAY); - oberon_item_t * size; - size = oberon_const_expr(ctx); + int num_sizes = 0; + oberon_expr_t * sizes; + oberon_expr_list(ctx, &num_sizes, &sizes, 1); oberon_assert_token(ctx, OF); @@ -1504,7 +1834,7 @@ oberon_type(oberon_context_t * ctx, oberon_type_t ** type) base = oberon_new_type_ptr(OBERON_TYPE_VOID); oberon_type(ctx, &base); - oberon_make_array_type(ctx, size, base, type); + oberon_make_multiarray(ctx, sizes, base, type); } else if(ctx -> token == RECORD) { @@ -1734,6 +2064,7 @@ oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x) break; case OBERON_CLASS_CONST: case OBERON_CLASS_PROC: + case OBERON_CLASS_MODULE: break; default: oberon_error(ctx, "oberon_prevent_recursive_object: wat"); @@ -1831,7 +2162,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: @@ -1846,9 +2183,10 @@ oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x) break; case OBERON_CLASS_CONST: case OBERON_CLASS_PROC: + case OBERON_CLASS_MODULE: break; default: - oberon_error(ctx, "oberon_prevent_recursive_object: wat"); + oberon_error(ctx, "oberon_initialize_object: wat"); break; } } @@ -1865,6 +2203,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) { @@ -1906,6 +2262,8 @@ oberon_decl_seq(oberon_context_t * ctx) oberon_proc_decl(ctx); oberon_assert_token(ctx, SEMICOLON); } + + oberon_prevent_undeclarated_procedures(ctx); } static void @@ -1915,13 +2273,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) { @@ -1939,8 +2290,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) @@ -1970,10 +2320,74 @@ oberon_statement_seq(oberon_context_t * ctx) } } +static void +oberon_import_module(oberon_context_t * ctx, char * alias, char * name) +{ + oberon_module_t * m = ctx -> module_list; + while(m && strcmp(m -> name, name) != 0) + { + m = m -> next; + } + + if(m == NULL) + { + const char * code; + code = ctx -> import_module(name); + if(code == NULL) + { + oberon_error(ctx, "no such module"); + } + + m = oberon_compile_module(ctx, code); + assert(m); + } + + if(m -> ready == 0) + { + oberon_error(ctx, "cyclic module import"); + } + + oberon_object_t * ident; + ident = oberon_define_object(ctx -> decl, alias, OBERON_CLASS_MODULE); + ident -> module = m; +} + +static void +oberon_import_decl(oberon_context_t * ctx) +{ + char * alias; + char * name; + + alias = name = oberon_assert_ident(ctx); + if(ctx -> token == ASSIGN) + { + oberon_assert_token(ctx, ASSIGN); + name = oberon_assert_ident(ctx); + } + + oberon_import_module(ctx, alias, name); +} + +static void +oberon_import_list(oberon_context_t * ctx) +{ + oberon_assert_token(ctx, IMPORT); + + oberon_import_decl(ctx); + while(ctx -> token == COMMA) + { + oberon_assert_token(ctx, COMMA); + oberon_import_decl(ctx); + } + + oberon_assert_token(ctx, SEMICOLON); +} + static void oberon_parse_module(oberon_context_t * ctx) { - char *name1, *name2; + char * name1; + char * name2; oberon_read_token(ctx); oberon_assert_token(ctx, MODULE); @@ -1981,12 +2395,24 @@ oberon_parse_module(oberon_context_t * ctx) oberon_assert_token(ctx, SEMICOLON); ctx -> mod -> name = name1; + oberon_object_t * this_module; + this_module = oberon_define_object(ctx -> decl, name1, OBERON_CLASS_MODULE); + this_module -> module = ctx -> mod; + + if(ctx -> token == IMPORT) + { + oberon_import_list(ctx); + } + + ctx -> decl -> parent = this_module; + oberon_decl_seq(ctx); + oberon_generate_begin_module(ctx); + if(ctx -> token == BEGIN) { oberon_assert_token(ctx, BEGIN); - oberon_generate_begin_module(ctx); oberon_statement_seq(ctx); oberon_generate_end_module(ctx); } @@ -2022,19 +2448,62 @@ register_default_types(oberon_context_t * ctx) oberon_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type); } +static void +oberon_new_intrinsic(oberon_context_t * ctx, char * name, GenerateFuncCallback f, GenerateProcCallback p) +{ + oberon_object_t * proc; + proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC); + proc -> sysproc = 1; + proc -> genfunc = f; + proc -> genproc = p; + 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() +oberon_create_context(ModuleImportCallback import_module) { - oberon_context_t * ctx = malloc(sizeof *ctx); - memset(ctx, 0, sizeof *ctx); + oberon_context_t * ctx = calloc(1, sizeof *ctx); oberon_scope_t * world_scope; world_scope = oberon_open_scope(ctx); ctx -> world_scope = world_scope; + ctx -> import_module = import_module; + oberon_generator_init_context(ctx); - register_default_types(ctx); + register_default_types(ctx); + oberon_new_intrinsic(ctx, "ABS", oberon_make_abs_call, NULL); return ctx; } @@ -2047,21 +2516,41 @@ oberon_destroy_context(oberon_context_t * ctx) } oberon_module_t * -oberon_compile_module(oberon_context_t * ctx, const char * code) +oberon_compile_module(oberon_context_t * ctx, const char * newcode) { - oberon_module_t * mod = malloc(sizeof *mod); - memset(mod, 0, sizeof *mod); - ctx -> mod = mod; + const char * code = ctx -> code; + int code_index = ctx -> code_index; + char c = ctx -> c; + int token = ctx -> token; + char * string = ctx -> string; + int integer = ctx -> integer; + oberon_scope_t * decl = ctx -> decl; + oberon_module_t * mod = ctx -> mod; oberon_scope_t * module_scope; module_scope = oberon_open_scope(ctx); - mod -> decl = module_scope; - oberon_init_scaner(ctx, code); + oberon_module_t * module; + module = calloc(1, sizeof *module); + module -> decl = module_scope; + module -> next = ctx -> module_list; + + ctx -> mod = module; + ctx -> module_list = module; + + oberon_init_scaner(ctx, newcode); oberon_parse_module(ctx); - oberon_generate_code(ctx); + module -> ready = 1; + + ctx -> code = code; + ctx -> code_index = code_index; + ctx -> c = c; + ctx -> token = token; + ctx -> string = string; + ctx -> integer = integer; + ctx -> decl = decl; + ctx -> mod = mod; - ctx -> mod = NULL; - return mod; + return module; }