X-Git-Url: http://deadsoftware.ru/gitweb?a=blobdiff_plain;f=oberon.c;h=2b4e09f5e8a3ca7e95e4923a6d4773fa9e5202bf;hb=42da6ba15843521d2b18994d863f2ec3d2672a97;hp=440364361e45956f86091d3022fd50b3099f1026;hpb=7f3e5aeb0348e6c0af28869bad6acc13fe483177;p=dsw-obn.git diff --git a/oberon.c b/oberon.c index 4403643..2b4e09f 100644 --- a/oberon.c +++ b/oberon.c @@ -3,6 +3,7 @@ #include #include #include +#include #include "oberon.h" #include "generator.h" @@ -38,7 +39,16 @@ enum { MOD, AND, NOT, - PROCEDURE + PROCEDURE, + COMMA, + RETURN, + CONST, + TYPE, + ARRAY, + OF, + LBRACE, + RBRACE, + RECORD }; // ======================================================================= @@ -60,55 +70,215 @@ oberon_error(oberon_context_t * ctx, const char * fmt, ...) exit(1); } +static oberon_type_t * +oberon_new_type_ptr(int class) +{ + oberon_type_t * x = malloc(sizeof *x); + memset(x, 0, sizeof *x); + x -> class = class; + return x; +} + +static oberon_type_t * +oberon_new_type_integer(int size) +{ + oberon_type_t * x; + x = oberon_new_type_ptr(OBERON_TYPE_INTEGER); + x -> size = size; + return x; +} + +static oberon_type_t * +oberon_new_type_boolean(int size) +{ + oberon_type_t * x; + x = oberon_new_type_ptr(OBERON_TYPE_BOOLEAN); + x -> size = size; + return x; +} + // ======================================================================= // TABLE // ======================================================================= -static oberon_type_t * -oberon_find_type(oberon_context_t * ctx, char * name) +static oberon_scope_t * +oberon_open_scope(oberon_context_t * ctx) { - oberon_type_t * x = ctx -> types; + oberon_scope_t * scope = malloc(sizeof *scope); + memset(scope, 0, sizeof *scope); + + oberon_object_t * list = malloc(sizeof *list); + memset(list, 0, sizeof *list); + + scope -> ctx = ctx; + scope -> list = list; + scope -> up = ctx -> decl; + + ctx -> decl = scope; + return scope; +} + +static void +oberon_close_scope(oberon_scope_t * scope) +{ + oberon_context_t * ctx = scope -> ctx; + ctx -> decl = scope -> up; +} + +static oberon_object_t * +oberon_define_object(oberon_scope_t * scope, char * name, int class) +{ + oberon_object_t * x = scope -> list; while(x -> next && strcmp(x -> next -> name, name) != 0) { x = x -> next; } - return x -> next; + if(x -> next) + { + oberon_error(scope -> ctx, "already defined"); + } + + oberon_object_t * newvar = malloc(sizeof *newvar); + memset(newvar, 0, sizeof *newvar); + newvar -> name = name; + newvar -> class = class; + + x -> next = newvar; + + return newvar; } -static oberon_var_t * -oberon_find_var(oberon_context_t * ctx, char * name) +static void +oberon_define_field(oberon_context_t * ctx, oberon_type_t * rec, char * name, oberon_type_t * type) { - oberon_var_t * x = ctx -> mod -> vars; + oberon_object_t * x = rec -> decl; while(x -> next && strcmp(x -> next -> name, name) != 0) { x = x -> next; } - return x -> next; + if(x -> next) + { + oberon_error(ctx, "multiple definition"); + } + + oberon_object_t * field = malloc(sizeof *field); + memset(field, 0, sizeof *field); + field -> name = name; + field -> class = OBERON_CLASS_FIELD; + field -> type = type; + + rec -> num_decl += 1; + oberon_generator_init_var(ctx, field); + + x -> next = field; } -static void -oberon_define_var(oberon_context_t * ctx, char * name, oberon_type_t * type) +static oberon_object_t * +oberon_find_object_in_list(oberon_object_t * list, char * name) { - oberon_var_t * x = ctx -> mod -> vars; + oberon_object_t * x = list; while(x -> next && strcmp(x -> next -> name, name) != 0) { x = x -> next; } + return x -> next; +} - if(x -> next) +static oberon_object_t * +oberon_find_object(oberon_scope_t * scope, char * name) +{ + oberon_object_t * result = NULL; + + oberon_scope_t * s = scope; + while(result == NULL && s != NULL) { - oberon_error(ctx, "already defined"); + result = oberon_find_object_in_list(s -> list, name); + s = s -> up; } - oberon_var_t * newvar = malloc(sizeof *newvar); - memset(newvar, 0, sizeof *newvar); - newvar -> name = name; - newvar -> type = type; - oberon_generator_init_var(ctx, newvar); + if(result == NULL) + { + oberon_error(scope -> ctx, "undefined ident %s", name); + } - x -> next = newvar; + return result; +} + +static oberon_object_t * +oberon_find_field(oberon_context_t * ctx, oberon_type_t * rec, char * name) +{ + oberon_object_t * x = rec -> decl; + for(int i = 0; i < rec -> num_decl; i++) + { + if(strcmp(x -> name, name) == 0) + { + return x; + } + x = x -> next; + } + + oberon_error(ctx, "field not defined"); + + return NULL; +} + +static oberon_object_t * +oberon_define_type(oberon_scope_t * scope, char * name, oberon_type_t * type) +{ + oberon_object_t * id; + id = oberon_define_object(scope, name, OBERON_CLASS_TYPE); + id -> type = type; + oberon_generator_init_type(scope -> ctx, type); + return id; +} + +static oberon_type_t * +oberon_find_type(oberon_scope_t * scope, char * name) +{ + oberon_object_t * x = oberon_find_object(scope, name); + if(x -> class != OBERON_CLASS_TYPE) + { + oberon_error(scope -> ctx, "%s not a type", name); + } + + return x -> type; +} + +static oberon_object_t * +oberon_define_var(oberon_scope_t * scope, int class, char * name, oberon_type_t * type) +{ + oberon_object_t * var; + var = oberon_define_object(scope, name, class); + var -> type = type; + oberon_generator_init_var(scope -> ctx, var); + return var; +} + +/* +static oberon_object_t * +oberon_find_var(oberon_scope_t * scope, char * name) +{ + oberon_object_t * x = oberon_find_object(scope, name); + + if(x -> class != OBERON_CLASS_VAR) + { + oberon_error(scope -> ctx, "%s not a var", name); + } + + return x; +} +*/ + +static oberon_object_t * +oberon_define_proc(oberon_scope_t * scope, char * name, oberon_type_t * signature) +{ + oberon_object_t * proc; + proc = oberon_define_object(scope, name, OBERON_CLASS_PROC); + proc -> type = signature; + oberon_generator_init_proc(scope -> ctx, proc); + return proc; } // ======================================================================= @@ -193,6 +363,30 @@ oberon_read_ident(oberon_context_t * ctx) { ctx -> token = PROCEDURE; } + else if(strcmp(ident, "RETURN") == 0) + { + ctx -> token = RETURN; + } + else if(strcmp(ident, "CONST") == 0) + { + ctx -> token = CONST; + } + else if(strcmp(ident, "TYPE") == 0) + { + ctx -> token = TYPE; + } + else if(strcmp(ident, "ARRAY") == 0) + { + ctx -> token = ARRAY; + } + else if(strcmp(ident, "OF") == 0) + { + ctx -> token = OF; + } + else if(strcmp(ident, "RECORD") == 0) + { + ctx -> token = RECORD; + } } static void @@ -313,6 +507,18 @@ oberon_read_symbol(oberon_context_t * ctx) ctx -> token = NOT; oberon_get_char(ctx); break; + case ',': + ctx -> token = COMMA; + oberon_get_char(ctx); + break; + case '[': + ctx -> token = LBRACE; + oberon_get_char(ctx); + break; + case ']': + ctx -> token = RBRACE; + oberon_get_char(ctx); + break; default: oberon_error(ctx, "invalid char"); break; @@ -347,6 +553,7 @@ static void oberon_expect_token(oberon_context_t * ctx, int token); 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 oberon_type_t * oberon_type(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) @@ -412,24 +619,269 @@ oberon_make_unary_op(oberon_context_t * ctx, int token, oberon_expr_t * a) return expr; } +static void +oberon_expr_list(oberon_context_t * ctx, int * num_expr, oberon_expr_t ** first) +{ + oberon_expr_t * last; + + *num_expr = 1; + *first = last = oberon_expr(ctx); + while(ctx -> token == COMMA) + { + oberon_assert_token(ctx, COMMA); + oberon_expr_t * current; + current = oberon_expr(ctx); + last -> next = current; + last = current; + *num_expr += 1; + } +} + static oberon_expr_t * -oberon_factor(oberon_context_t * ctx) +oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref) +{ + if(pref -> class != expr -> result -> class) + { + oberon_error(ctx, "incompatible types"); + } + + + if(pref -> class == OBERON_TYPE_INTEGER) + { + if(expr -> result -> class > pref -> class) + { + oberon_error(ctx, "incompatible size"); + } + } + + // TODO cast + + return expr; +} + +static void +oberon_autocast_call(oberon_context_t * ctx, oberon_expr_t * desig) +{ + if(desig -> is_item == 0) + { + oberon_error(ctx, "expected item"); + } + + if(desig -> item.mode != MODE_CALL) + { + oberon_error(ctx, "expected mode CALL"); + } + + if(desig -> item.var -> class != OBERON_CLASS_PROC) + { + oberon_error(ctx, "only procedures can be called"); + } + + oberon_type_t * fn = desig -> item.var -> type; + int num_args = desig -> item.num_args; + int num_decl = fn -> num_decl; + + if(num_args < num_decl) + { + oberon_error(ctx, "too few arguments"); + } + else if(num_args > num_decl) + { + oberon_error(ctx, "too many arguments"); + } + + oberon_expr_t * arg = desig -> item.args; + oberon_object_t * param = fn -> decl; + for(int i = 0; i < num_args; i++) + { + oberon_autocast_to(ctx, arg, param -> type); + arg = arg -> next; + param = param -> next; + } +} + +#define ISEXPR(x) \ + (((x) == PLUS) \ + || ((x) == MINUS) \ + || ((x) == IDENT) \ + || ((x) == INTEGER) \ + || ((x) == LPAREN) \ + || ((x) == NOT) \ + || ((x) == TRUE) \ + || ((x) == FALSE)) + +#define ISSELECTOR(x) \ + (((x) == LBRACE) \ + || ((x) == DOT)) + +static oberon_expr_t * +oberon_make_array_selector(oberon_context_t * ctx, oberon_expr_t * desig, int num_indexes, oberon_expr_t * indexes) +{ + assert(desig -> is_item == 1); + + if(desig -> item.mode != MODE_VAR) + { + oberon_error(ctx, "not MODE_VAR"); + } + + int class = desig -> item.var -> class; + switch(class) + { + case OBERON_CLASS_VAR: + case OBERON_CLASS_VAR_PARAM: + case OBERON_CLASS_PARAM: + break; + default: + oberon_error(ctx, "not variable"); + break; + } + + oberon_type_t * type = desig -> item.var -> type; + if(type -> class != OBERON_TYPE_ARRAY) + { + oberon_error(ctx, "not array"); + } + + int dim = desig -> item.var -> type -> dim; + if(num_indexes != dim) + { + oberon_error(ctx, "dimesions not matched"); + } + + oberon_type_t * base = desig -> item.var -> type -> base; + + 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; + + return selector; +} + +static oberon_expr_t * +oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char * name) +{ + assert(expr -> is_item == 1); + + int class = expr -> result -> class; + if(class != OBERON_TYPE_RECORD) + { + oberon_error(ctx, "not record"); + } + + oberon_type_t * rec = expr -> result; + + oberon_object_t * field; + field = oberon_find_field(ctx, rec, name); + + oberon_expr_t * selector; + selector = oberon_new_item(MODE_FIELD, field -> type); + selector -> item.var = field; + selector -> item.parent = (oberon_item_t *) expr; + + return selector; +} + +static oberon_expr_t * +oberon_designator(oberon_context_t * ctx) { char * name; - oberon_var_t * var; + oberon_object_t * var; + oberon_expr_t * expr; + + name = oberon_assert_ident(ctx); + var = oberon_find_object(ctx -> decl, name); + + switch(var -> class) + { + case OBERON_CLASS_CONST: + // TODO copy value + expr = (oberon_expr_t *) var -> value; + break; + 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); + break; + default: + oberon_error(ctx, "invalid designator"); + break; + } + expr -> item.var = var; + + while(ISSELECTOR(ctx -> token)) + { + switch(ctx -> token) + { + case DOT: + oberon_assert_token(ctx, DOT); + name = oberon_assert_ident(ctx); + expr = oberon_make_record_selector(ctx, expr, name); + break; + case LBRACE: + oberon_assert_token(ctx, LBRACE); + int num_indexes = 0; + oberon_expr_t * indexes = NULL; + oberon_expr_list(ctx, &num_indexes, &indexes); + oberon_assert_token(ctx, RBRACE); + expr = oberon_make_array_selector(ctx, expr, num_indexes, indexes); + break; + default: + oberon_error(ctx, "oberon_designator: wat"); + break; + } + } + return expr; +} + +static oberon_expr_t * +oberon_opt_proc_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; + oberon_expr_t * arguments = NULL; + + if(ISEXPR(ctx -> token)) + { + oberon_expr_list(ctx, &num_args, &arguments); + } + + 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_autocast_call(ctx, expr); + } + + return expr; +} + +static oberon_expr_t * +oberon_factor(oberon_context_t * ctx) +{ oberon_expr_t * expr; switch(ctx -> token) { case IDENT: - name = oberon_assert_ident(ctx); - var = oberon_find_var(ctx, name); - if(var == NULL) - { - oberon_error(ctx, "undefined variable %s", name); - } - expr = oberon_new_item(MODE_VAR, var -> type); - expr -> item.var = var; + expr = oberon_designator(ctx); + expr = oberon_opt_proc_parens(ctx, expr); break; case INTEGER: expr = oberon_new_item(MODE_INTEGER, ctx -> int_type); @@ -513,14 +965,12 @@ oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_ oberon_expr_t * expr; oberon_type_t * result; - oberon_autocast_binary_op(ctx, a -> result, b -> result, &result); - if(ITMAKESBOOLEAN(token)) { if(ITUSEONLYINTEGER(token)) { if(a -> result -> class != OBERON_TYPE_INTEGER - && b -> result -> class != OBERON_TYPE_INTEGER) + || b -> result -> class != OBERON_TYPE_INTEGER) { oberon_error(ctx, "used only with integer types"); } @@ -528,12 +978,14 @@ oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_ else if(ITUSEONLYBOOLEAN(token)) { if(a -> result -> class != OBERON_TYPE_BOOLEAN - && b -> result -> class != OBERON_TYPE_BOOLEAN) + || b -> result -> class != OBERON_TYPE_BOOLEAN) { oberon_error(ctx, "used only with boolean type"); } } + result = ctx -> bool_type; + if(token == EQUAL) { expr = oberon_new_operator(OP_EQ, result, a, b); @@ -573,6 +1025,8 @@ oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_ } else { + oberon_autocast_binary_op(ctx, a -> result, b -> result, &result); + if(token == PLUS) { expr = oberon_new_operator(OP_ADD, result, a, b); @@ -686,6 +1140,20 @@ oberon_expr(oberon_context_t * ctx) return expr; } +static oberon_item_t * +oberon_const_expr(oberon_context_t * ctx) +{ + oberon_expr_t * expr; + expr = oberon_expr(ctx); + + if(expr -> is_item == 0) + { + oberon_error(ctx, "const expression are required"); + } + + return (oberon_item_t *) expr; +} + // ======================================================================= // PARSER // ======================================================================= @@ -717,15 +1185,89 @@ oberon_assert_ident(oberon_context_t * ctx) return ident; } +static oberon_type_t * +oberon_make_array_type(oberon_context_t * ctx, int dim, oberon_item_t * size, oberon_type_t * base) +{ + assert(dim == 1); + oberon_type_t * newtype; + + if(size -> mode != MODE_INTEGER) + { + oberon_error(ctx, "requires integer constant"); + } + + newtype = oberon_new_type_ptr(OBERON_TYPE_ARRAY); + newtype -> dim = dim; + newtype -> size = size -> integer; + newtype -> base = base; + oberon_generator_init_type(ctx, newtype); + + return newtype; +} + +static void +oberon_field_list(oberon_context_t * ctx, oberon_type_t * rec) +{ + if(ctx -> token == IDENT) + { + char * name; + oberon_type_t * type; + name = oberon_assert_ident(ctx); + oberon_assert_token(ctx, COLON); + type = oberon_type(ctx); + oberon_define_field(ctx, rec, name, type); + } +} + +static oberon_type_t * oberon_opt_formal_pars(oberon_context_t * ctx, int class); + static oberon_type_t * oberon_type(oberon_context_t * ctx) { - char * name = oberon_assert_ident(ctx); - oberon_type_t * type = oberon_find_type(ctx, name); + oberon_type_t * type; + + if(ctx -> token == IDENT) + { + char * name = oberon_assert_ident(ctx); + type = oberon_find_type(ctx -> decl, name); + } + else if(ctx -> token == ARRAY) + { + oberon_assert_token(ctx, ARRAY); + oberon_item_t * size = oberon_const_expr(ctx); + oberon_assert_token(ctx, OF); + oberon_type_t * base = oberon_type(ctx); + type = oberon_make_array_type(ctx, 1, size, base); + } + else if(ctx -> token == RECORD) + { + type = oberon_new_type_ptr(OBERON_TYPE_RECORD); + oberon_object_t * list = malloc(sizeof *list); + memset(list, 0, sizeof *list); + type -> num_decl = 0; + type -> base = NULL; + type -> decl = list; + + oberon_assert_token(ctx, RECORD); + oberon_field_list(ctx, type); + while(ctx -> token == SEMICOLON) + { + oberon_assert_token(ctx, SEMICOLON); + oberon_field_list(ctx, type); + } + oberon_assert_token(ctx, END); - if(type == NULL) + type -> decl = type -> decl -> next; + oberon_generator_init_type(ctx, type); + } + else if(ctx -> token == PROCEDURE) { - oberon_error(ctx, "undefined type"); + oberon_assert_token(ctx, PROCEDURE); + type = oberon_opt_formal_pars(ctx, OBERON_TYPE_PROCEDURE); + } + else + { + oberon_error(ctx, "invalid type declaration"); } return type; @@ -737,19 +1279,134 @@ oberon_var_decl(oberon_context_t * ctx) char * name = oberon_assert_ident(ctx); oberon_assert_token(ctx, COLON); oberon_type_t * type = oberon_type(ctx); - oberon_define_var(ctx, name, type); + oberon_define_var(ctx -> decl, OBERON_CLASS_VAR, name, type); } -static void -oberon_make_procedure_begin(oberon_context_t * ctx, char * name) +static oberon_object_t * +oberon_make_param(oberon_context_t * ctx, int token, char * name, oberon_type_t * type) { - + oberon_object_t * param; + + if(token == VAR) + { + param = oberon_define_var(ctx -> decl, OBERON_CLASS_VAR_PARAM, name, type); + } + else if(token == IDENT) + { + param = oberon_define_var(ctx -> decl, OBERON_CLASS_PARAM, name, type); + } + else + { + oberon_error(ctx, "oberon_make_param: wat"); + } + + return param; +} + +static oberon_object_t * +oberon_fp_section(oberon_context_t * ctx, int * num_decl) +{ + int modifer_token = ctx -> token; + if(ctx -> token == VAR) + { + oberon_read_token(ctx); + } + + char * name; + name = oberon_assert_ident(ctx); + + oberon_assert_token(ctx, COLON); + + oberon_type_t * type; + type = oberon_type(ctx); + + oberon_object_t * first; + first = oberon_make_param(ctx, modifer_token, name, type); + + *num_decl += 1; + return first; +} + +#define ISFPSECTION \ + ((ctx -> token == VAR) || (ctx -> token == IDENT)) + +static oberon_type_t * +oberon_formal_pars(oberon_context_t * ctx) +{ + oberon_type_t * tp; + tp = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE); + tp -> num_decl = 0; + tp -> base = ctx -> void_type; + tp -> decl = NULL; + + oberon_assert_token(ctx, LPAREN); + + if(ISFPSECTION) + { + tp -> decl = oberon_fp_section(ctx, &tp -> num_decl); + while(ctx -> token == SEMICOLON) + { + oberon_assert_token(ctx, SEMICOLON); + oberon_fp_section(ctx, &tp -> num_decl); + } + } + + oberon_assert_token(ctx, RPAREN); + + if(ctx -> token == COLON) + { + oberon_assert_token(ctx, COLON); + tp -> base = oberon_type(ctx); + } + + oberon_generator_init_type(ctx, tp); + return tp; +} + +static oberon_type_t * +oberon_opt_formal_pars(oberon_context_t * ctx, int class) +{ + oberon_type_t * signature; + + if(ctx -> token == LPAREN) + { + signature = oberon_formal_pars(ctx); + } + else + { + signature = oberon_new_type_ptr(class); + signature -> num_decl = 0; + signature -> base = ctx -> void_type; + signature -> decl = NULL; + oberon_generator_init_type(ctx, signature); + } + + return signature; } static void -oberon_make_procedure_end(oberon_context_t * ctx) +oberon_make_return(oberon_context_t * ctx, oberon_expr_t * expr) { + if(ctx -> result_type -> class == OBERON_TYPE_VOID) + { + if(expr != NULL) + { + oberon_error(ctx, "procedure has no result type"); + } + } + else + { + if(expr == NULL) + { + oberon_error(ctx, "procedure requires expression on result"); + } + oberon_autocast_to(ctx, expr, ctx -> result_type); + } + + ctx -> has_return = 1; + + oberon_generate_return(ctx, expr); } static void @@ -760,28 +1417,105 @@ oberon_proc_decl(oberon_context_t * ctx) 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_opt_formal_pars(ctx, OBERON_TYPE_PROCEDURE); + + oberon_object_t * proc; + proc = oberon_define_proc(this_proc_def_scope, name, signature); + + ctx -> result_type = signature -> base; + ctx -> has_return = 0; + oberon_assert_token(ctx, SEMICOLON); - oberon_make_procedure_begin(ctx, name); + oberon_generate_begin_proc(ctx, proc); + + // TODO declarations + if(ctx -> token == BEGIN) { oberon_assert_token(ctx, BEGIN); oberon_statement_seq(ctx); } - oberon_make_procedure_end(ctx); oberon_assert_token(ctx, END); char * name2 = oberon_assert_ident(ctx); - if(strcmp(name2, name) != 0) { oberon_error(ctx, "procedure name not matched"); } + + if(signature -> base -> class == OBERON_TYPE_VOID) + { + oberon_make_return(ctx, NULL); + } + + if(ctx -> 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_const_decl(oberon_context_t * ctx) +{ + char * name; + oberon_item_t * value; + oberon_object_t * constant; + + name = oberon_assert_ident(ctx); + oberon_assert_token(ctx, EQUAL); + value = oberon_const_expr(ctx); + + constant = oberon_define_object(ctx -> decl, name, OBERON_CLASS_CONST); + constant -> value = value; +} + +static void +oberon_type_decl(oberon_context_t * ctx) +{ + char * name; + oberon_object_t * newtype; + oberon_type_t * type; + + name = oberon_assert_ident(ctx); + oberon_assert_token(ctx, EQUAL); + type = oberon_type(ctx); + + newtype = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE); + newtype -> type = type; } static void oberon_decl_seq(oberon_context_t * ctx) { + if(ctx -> token == CONST) + { + oberon_assert_token(ctx, CONST); + while(ctx -> token == IDENT) + { + oberon_const_decl(ctx); + oberon_assert_token(ctx, SEMICOLON); + } + } + + if(ctx -> token == TYPE) + { + oberon_assert_token(ctx, TYPE); + while(ctx -> token == IDENT) + { + oberon_type_decl(ctx); + oberon_assert_token(ctx, SEMICOLON); + } + } + if(ctx -> token == VAR) { oberon_assert_token(ctx, VAR); @@ -792,7 +1526,7 @@ oberon_decl_seq(oberon_context_t * ctx) } } - if(ctx -> token == PROCEDURE) + while(ctx -> token == PROCEDURE) { oberon_proc_decl(ctx); oberon_assert_token(ctx, SEMICOLON); @@ -802,22 +1536,17 @@ oberon_decl_seq(oberon_context_t * ctx) static void oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst) { - if(src -> result -> class != dst -> result -> class) - { - oberon_error(ctx, "incompatible assignment types"); - } - - if(dst -> result -> class == OBERON_TYPE_INTEGER) - { - if((dst -> result -> size) < (src -> result -> size)) - { - oberon_error(ctx, "incompatible assignment type size"); - } - } - + oberon_autocast_to(ctx, src, dst -> result); 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) { @@ -826,10 +1555,32 @@ oberon_statement(oberon_context_t * ctx) if(ctx -> token == IDENT) { - item1 = oberon_expr(ctx); - oberon_assert_token(ctx, ASSIGN); - item2 = oberon_expr(ctx); - oberon_assign(ctx, item2, item1); + item1 = oberon_designator(ctx); + if(ctx -> token == ASSIGN) + { + oberon_assert_token(ctx, ASSIGN); + item2 = oberon_expr(ctx); + oberon_assign(ctx, item2, item1); + } + else + { + item1 = oberon_opt_proc_parens(ctx, item1); + oberon_make_call(ctx, item1); + } + } + 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); + } } } @@ -879,44 +1630,17 @@ oberon_parse_module(oberon_context_t * ctx) // LIBRARY // ======================================================================= -static oberon_type_t * -oberon_register_global_type_ret(oberon_context_t * ctx, oberon_type_t * type) -{ - oberon_type_t * x = ctx -> types; - while(x -> next && strcmp(x -> next -> name, type -> name) != 0) - { - x = x -> next; - } - - if(x -> next) - { - oberon_error(ctx, "already defined"); - } - - // TODO: copy type name (not a pointer) - oberon_type_t * newtype = malloc(sizeof *newtype); - memcpy(newtype, type, sizeof *newtype); - newtype -> next = NULL; - oberon_generator_init_type(ctx, newtype); - - x -> next = newtype; - return newtype; -} - static void register_default_types(oberon_context_t * ctx) { - static oberon_type_t integer = { "INTEGER", OBERON_TYPE_INTEGER, sizeof(int) }; - static oberon_type_t boolean = { "BOOLEAN", OBERON_TYPE_BOOLEAN, sizeof(int) }; + ctx -> void_type = oberon_new_type_ptr(OBERON_TYPE_VOID); + oberon_generator_init_type(ctx, ctx -> void_type); - ctx -> int_type = oberon_register_global_type_ret(ctx, &integer); - ctx -> bool_type = oberon_register_global_type_ret(ctx, &boolean); -} + ctx -> int_type = oberon_new_type_integer(sizeof(int)); + oberon_define_type(ctx -> world_scope, "INTEGER", ctx -> int_type); -void -oberon_register_global_type(oberon_context_t * ctx, oberon_type_t * type) -{ - oberon_register_global_type_ret(ctx, type); + ctx -> bool_type = oberon_new_type_boolean(sizeof(int)); + oberon_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type); } oberon_context_t * @@ -925,9 +1649,9 @@ oberon_create_context() oberon_context_t * ctx = malloc(sizeof *ctx); memset(ctx, 0, sizeof *ctx); - oberon_type_t * types = malloc(sizeof *types); - memset(types, 0, sizeof *types); - ctx -> types = types; + oberon_scope_t * world_scope; + world_scope = oberon_open_scope(ctx); + ctx -> world_scope = world_scope; oberon_generator_init_context(ctx); @@ -948,15 +1672,17 @@ oberon_compile_module(oberon_context_t * ctx, const char * code) { oberon_module_t * mod = malloc(sizeof *mod); memset(mod, 0, sizeof *mod); - oberon_var_t * vars = malloc(sizeof *vars); - memset(vars, 0, sizeof *vars); ctx -> mod = mod; - ctx -> mod -> vars = vars; + + oberon_scope_t * module_scope; + module_scope = oberon_open_scope(ctx); + mod -> decl = module_scope; oberon_init_scaner(ctx, code); oberon_parse_module(ctx); oberon_generate_code(ctx); + + ctx -> mod = NULL; return mod; } -