X-Git-Url: http://deadsoftware.ru/gitweb?a=blobdiff_plain;f=oberon.c;h=2b4e09f5e8a3ca7e95e4923a6d4773fa9e5202bf;hb=42da6ba15843521d2b18994d863f2ec3d2672a97;hp=e411c6c2fdaa455bf15fddcd54c7b94a37f3c8c3;hpb=b752043cfbb49243ca3727dbfc9be5b614a8c9c2;p=dsw-obn.git diff --git a/oberon.c b/oberon.c index e411c6c..2b4e09f 100644 --- a/oberon.c +++ b/oberon.c @@ -3,7 +3,10 @@ #include #include #include +#include + #include "oberon.h" +#include "generator.h" enum { EOF_ = 0, @@ -16,26 +19,43 @@ enum { COLON, BEGIN, ASSIGN, - INTEGER -}; - -enum { - MODE_VAR, - MODE_INTEGER, + INTEGER, + TRUE, + FALSE, + LPAREN, + RPAREN, + EQUAL, + NEQ, + LESS, + LEQ, + GREAT, + GEQ, + PLUS, + MINUS, + OR, + STAR, + SLASH, + DIV, + MOD, + AND, + NOT, + PROCEDURE, + COMMA, + RETURN, + CONST, + TYPE, + ARRAY, + OF, + LBRACE, + RBRACE, + RECORD }; -typedef struct -{ - int mode; - int integer; - oberon_var_t * var; -} oberon_item_t; - // ======================================================================= // UTILS // ======================================================================= -static void +void oberon_error(oberon_context_t * ctx, const char * fmt, ...) { va_list ptr; @@ -50,85 +70,215 @@ oberon_error(oberon_context_t * ctx, const char * fmt, ...) exit(1); } -static int -oberon_item_to_type_class(oberon_context_t * ctx, oberon_item_t * item) +static oberon_type_t * +oberon_new_type_ptr(int class) { - int class; + oberon_type_t * x = malloc(sizeof *x); + memset(x, 0, sizeof *x); + x -> class = class; + return x; +} - if(item -> mode == MODE_INTEGER) - { - class = OBERON_TYPE_INTEGER; - } - else if(item -> mode == MODE_VAR) - { - class = item -> var -> type -> class; - } - else - { - oberon_error(ctx, "oberon_item_to_type_class: wat"); - } +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; +} - return class; +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_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_type_t * x = ctx -> types; + 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; + if(result == NULL) + { + oberon_error(scope -> ctx, "undefined ident %s", name); + } - x -> next = newvar; + return result; } -// ======================================================================= -// GENERATOR -// ======================================================================= +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; + } -static void -oberon_generate_assign(oberon_context_t * ctx, void * src, void * dst, int size) + 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) { - printf("G: %p := %p (%i);\n", dst, src, size); + 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; } // ======================================================================= @@ -164,9 +314,9 @@ oberon_read_ident(oberon_context_t * ctx) c = ctx -> code[i]; } - char * ident = malloc(len + 2); + char * ident = malloc(len + 1); memcpy(ident, &ctx->code[ctx->code_index], len); - ident[len + 1] = 0; + ident[len] = 0; ctx -> code_index = i; ctx -> c = ctx -> code[i]; @@ -189,6 +339,54 @@ oberon_read_ident(oberon_context_t * ctx) { ctx -> token = BEGIN; } + else if(strcmp(ident, "TRUE") == 0) + { + ctx -> token = TRUE; + } + else if(strcmp(ident, "FALSE") == 0) + { + ctx -> token = FALSE; + } + else if(strcmp(ident, "OR") == 0) + { + ctx -> token = OR; + } + else if(strcmp(ident, "DIV") == 0) + { + ctx -> token = DIV; + } + else if(strcmp(ident, "MOD") == 0) + { + ctx -> token = MOD; + } + else if(strcmp(ident, "PROCEDURE") == 0) + { + 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 @@ -225,6 +423,108 @@ oberon_skip_space(oberon_context_t * ctx) } } +static void +oberon_read_symbol(oberon_context_t * ctx) +{ + int c = ctx -> c; + switch(c) + { + case 0: + ctx -> token = EOF_; + break; + case ';': + ctx -> token = SEMICOLON; + oberon_get_char(ctx); + break; + case ':': + ctx -> token = COLON; + oberon_get_char(ctx); + if(ctx -> c == '=') + { + ctx -> token = ASSIGN; + oberon_get_char(ctx); + } + break; + case '.': + ctx -> token = DOT; + oberon_get_char(ctx); + break; + case '(': + ctx -> token = LPAREN; + oberon_get_char(ctx); + break; + case ')': + ctx -> token = RPAREN; + oberon_get_char(ctx); + break; + case '=': + ctx -> token = EQUAL; + oberon_get_char(ctx); + break; + case '#': + ctx -> token = NEQ; + oberon_get_char(ctx); + break; + case '<': + ctx -> token = LESS; + oberon_get_char(ctx); + if(ctx -> c == '=') + { + ctx -> token = LEQ; + oberon_get_char(ctx); + } + break; + case '>': + ctx -> token = GREAT; + oberon_get_char(ctx); + if(ctx -> c == '=') + { + ctx -> token = GEQ; + oberon_get_char(ctx); + } + break; + case '+': + ctx -> token = PLUS; + oberon_get_char(ctx); + break; + case '-': + ctx -> token = MINUS; + oberon_get_char(ctx); + break; + case '*': + ctx -> token = STAR; + oberon_get_char(ctx); + break; + case '/': + ctx -> token = SLASH; + oberon_get_char(ctx); + break; + case '&': + ctx -> token = AND; + oberon_get_char(ctx); + break; + case '~': + 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; + } +} + static void oberon_read_token(oberon_context_t * ctx) { @@ -241,249 +541,1148 @@ oberon_read_token(oberon_context_t * ctx) } else { - switch(c) - { - case 0: ctx -> token = EOF_; break; - case ';': ctx -> token = SEMICOLON; oberon_get_char(ctx); break; - case ':': - /****************************************************/ - ctx -> token = COLON; oberon_get_char(ctx); - if(ctx -> c == '=') - { - ctx -> token = ASSIGN; - oberon_get_char(ctx); - } - break; - /****************************************************/ - case '.': ctx -> token = DOT; oberon_get_char(ctx); break; - default: oberon_error(ctx, "invalid char"); - } + oberon_read_symbol(ctx); } } // ======================================================================= -// PARSER +// EXPRESSION // ======================================================================= -static void -oberon_expect_token(oberon_context_t * ctx, int token) -{ - if(ctx -> token != token) - { - oberon_error(ctx, "unexpected token %i (%i)", ctx -> token, token); - } -} +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 void -oberon_assert_token(oberon_context_t * ctx, int token) +static oberon_expr_t * +oberon_new_operator(int op, oberon_type_t * result, oberon_expr_t * left, oberon_expr_t * right) { - oberon_expect_token(ctx, token); - oberon_read_token(ctx); -} + oberon_oper_t * operator; + operator = malloc(sizeof *operator); + memset(operator, 0, sizeof *operator); -static char * -oberon_assert_ident(oberon_context_t * ctx) -{ - char * ident; - oberon_expect_token(ctx, IDENT); - ident = ctx -> string; - oberon_read_token(ctx); - return ident; + operator -> is_item = 0; + operator -> result = result; + operator -> op = op; + operator -> left = left; + operator -> right = right; + + return (oberon_expr_t *) operator; } -static oberon_type_t * -oberon_type(oberon_context_t * ctx) +static oberon_expr_t * +oberon_new_item(int mode, oberon_type_t * result) { - char * name = oberon_assert_ident(ctx); - oberon_type_t * type = oberon_find_type(ctx, name); + oberon_item_t * item; + item = malloc(sizeof *item); + memset(item, 0, sizeof *item); - if(type == NULL) - { - oberon_error(ctx, "undefined type"); - } + item -> is_item = 1; + item -> result = result; + item -> mode = mode; - return type; + return (oberon_expr_t *)item; } -static void -oberon_var_decl(oberon_context_t * ctx) +static oberon_expr_t * +oberon_make_unary_op(oberon_context_t * ctx, int token, oberon_expr_t * a) { - 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_expr_t * expr; + oberon_type_t * result; -static void -oberon_decl_seq(oberon_context_t * ctx) -{ - if(ctx -> token == VAR) + result = a -> result; + + if(token == MINUS) { - oberon_assert_token(ctx, VAR); - while(ctx -> token == IDENT) + if(result -> class != OBERON_TYPE_INTEGER) { - oberon_var_decl(ctx); - oberon_assert_token(ctx, SEMICOLON); + oberon_error(ctx, "incompatible operator type"); } - } -} - -static oberon_item_t * -oberon_expr(oberon_context_t * ctx) -{ - oberon_item_t * item = malloc(sizeof *item); - memset(item, 0, sizeof *item); - if(ctx -> token == IDENT) + expr = oberon_new_operator(OP_UNARY_MINUS, result, a, NULL); + } + else if(token == NOT) { - char * name = oberon_assert_ident(ctx); - oberon_var_t * var = oberon_find_var(ctx, name); - if(var == NULL) + if(result -> class != OBERON_TYPE_BOOLEAN) { - oberon_error(ctx, "undefined variable"); + oberon_error(ctx, "incompatible operator type"); } - item -> mode = MODE_VAR; - item -> var = var; - } - else if(ctx -> token == INTEGER) - { - item -> mode = MODE_INTEGER; - item -> integer = ctx -> integer; - oberon_assert_token(ctx, INTEGER); + + expr = oberon_new_operator(OP_LOGIC_NOT, result, a, NULL); } else { - oberon_error(ctx, "invalid expression"); + oberon_error(ctx, "oberon_make_unary_op: wat"); } - return item; + return expr; } static void -oberon_assign(oberon_context_t * ctx, oberon_item_t * src, oberon_item_t * dst) +oberon_expr_list(oberon_context_t * ctx, int * num_expr, oberon_expr_t ** first) { - if(dst -> mode == MODE_INTEGER) - { - oberon_error(ctx, "invalid assignment"); - } - - int src_class = oberon_item_to_type_class(ctx, src); - int dst_class = oberon_item_to_type_class(ctx, dst); + oberon_expr_t * last; - if(src_class != dst_class) + *num_expr = 1; + *first = last = oberon_expr(ctx); + while(ctx -> token == COMMA) { - oberon_error(ctx, "types not matched"); + oberon_assert_token(ctx, COMMA); + oberon_expr_t * current; + current = oberon_expr(ctx); + last -> next = current; + last = current; + *num_expr += 1; } - - // TODO: code generation - oberon_generate_assign(ctx, 0, 0, 4); } -static void -oberon_statement(oberon_context_t * ctx) +static oberon_expr_t * +oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref) { - oberon_item_t * item1; - oberon_item_t * item2; + if(pref -> class != expr -> result -> class) + { + oberon_error(ctx, "incompatible types"); + } - if(ctx -> token == IDENT) + + if(pref -> class == OBERON_TYPE_INTEGER) { - item1 = oberon_expr(ctx); - oberon_assert_token(ctx, ASSIGN); - item2 = oberon_expr(ctx); - oberon_assign(ctx, item2, item1); + if(expr -> result -> class > pref -> class) + { + oberon_error(ctx, "incompatible size"); + } } + + // TODO cast + + return expr; } static void -oberon_statement_seq(oberon_context_t * ctx) +oberon_autocast_call(oberon_context_t * ctx, oberon_expr_t * desig) { - oberon_statement(ctx); - while(ctx -> token == SEMICOLON) + if(desig -> is_item == 0) { - oberon_assert_token(ctx, SEMICOLON); - oberon_statement(ctx); + oberon_error(ctx, "expected item"); } -} -static void -oberon_parse_it(oberon_context_t * ctx) -{ - char *name1, *name2; - oberon_read_token(ctx); + if(desig -> item.mode != MODE_CALL) + { + oberon_error(ctx, "expected mode CALL"); + } - oberon_assert_token(ctx, MODULE); - name1 = oberon_assert_ident(ctx); - oberon_assert_token(ctx, SEMICOLON); - ctx -> mod -> name = name1; + if(desig -> item.var -> class != OBERON_CLASS_PROC) + { + oberon_error(ctx, "only procedures can be called"); + } - oberon_decl_seq(ctx); + oberon_type_t * fn = desig -> item.var -> type; + int num_args = desig -> item.num_args; + int num_decl = fn -> num_decl; - if(ctx -> token == BEGIN) + if(num_args < num_decl) { - oberon_assert_token(ctx, BEGIN); - oberon_statement_seq(ctx); + oberon_error(ctx, "too few arguments"); + } + else if(num_args > num_decl) + { + oberon_error(ctx, "too many arguments"); } - oberon_assert_token(ctx, END); - name2 = oberon_assert_ident(ctx); - oberon_assert_token(ctx, DOT); - - if(strcmp(name1, name2) != 0) + oberon_expr_t * arg = desig -> item.args; + oberon_object_t * param = fn -> decl; + for(int i = 0; i < num_args; i++) { - oberon_error(ctx, "module name not matched"); + oberon_autocast_to(ctx, arg, param -> type); + arg = arg -> next; + param = param -> next; } } -// ======================================================================= -// LIBRARY -// ======================================================================= - -oberon_context_t * -oberon_create_context() +#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) { - oberon_context_t * ctx = malloc(sizeof *ctx); - memset(ctx, 0, sizeof *ctx); - - oberon_type_t * types = malloc(sizeof *types); - memset(types, 0, sizeof *types); + assert(desig -> is_item == 1); - ctx -> types = types; - return ctx; -} - -oberon_module_t * -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; + if(desig -> item.mode != MODE_VAR) + { + oberon_error(ctx, "not MODE_VAR"); + } - oberon_init_scaner(ctx, code); - oberon_parse_it(ctx); - return mod; -} + 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; + } -void -oberon_register_global_type(oberon_context_t * ctx, oberon_type_t * type) -{ - oberon_type_t * x = ctx -> types; - while(x -> next && strcmp(x -> next -> name, type -> name) != 0) + oberon_type_t * type = desig -> item.var -> type; + if(type -> class != OBERON_TYPE_ARRAY) { - x = x -> next; + oberon_error(ctx, "not array"); } - if(x -> next) + int dim = desig -> item.var -> type -> dim; + if(num_indexes != dim) { - oberon_error(ctx, "already defined"); + oberon_error(ctx, "dimesions not matched"); } - // TODO: copy type name (not a pointer) - oberon_type_t * newtype = malloc(sizeof *newtype); - memcpy(newtype, type, sizeof *newtype); - newtype -> next = NULL; + oberon_type_t * base = desig -> item.var -> type -> base; - x -> next = newtype; + 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_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: + expr = oberon_designator(ctx); + expr = oberon_opt_proc_parens(ctx, expr); + break; + case INTEGER: + expr = oberon_new_item(MODE_INTEGER, ctx -> int_type); + expr -> item.integer = ctx -> integer; + oberon_assert_token(ctx, INTEGER); + break; + case TRUE: + expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type); + expr -> item.boolean = 1; + oberon_assert_token(ctx, TRUE); + break; + case FALSE: + expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type); + expr -> item.boolean = 0; + oberon_assert_token(ctx, FALSE); + break; + case LPAREN: + oberon_assert_token(ctx, LPAREN); + expr = oberon_expr(ctx); + oberon_assert_token(ctx, RPAREN); + break; + case NOT: + oberon_assert_token(ctx, NOT); + expr = oberon_factor(ctx); + expr = oberon_make_unary_op(ctx, NOT, expr); + break; + default: + oberon_error(ctx, "invalid expression"); + } + + return expr; +} + +/* + * oberon_autocast_binary_op автоматически переобразовывеат тип по след. правилам: + * 1. Классы обоих типов должны быть одинаковы + * 2. В качестве результата должен быть выбран больший тип. + * 3. Если размер результат не должен быть меньше чем базовый int + */ + +static void +oberon_autocast_binary_op(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b, oberon_type_t ** result) +{ + if((a -> class) != (b -> class)) + { + oberon_error(ctx, "incompatible types"); + } + + if((a -> size) > (b -> size)) + { + *result = a; + } + else + { + *result = b; + } + + if(((*result) -> class) == OBERON_TYPE_INTEGER) + { + if(((*result) -> size) < (ctx -> int_type -> size)) + { + *result = ctx -> int_type; + } + } + + /* TODO: cast types */ +} + +#define ITMAKESBOOLEAN(x) \ + (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND)) + +#define ITUSEONLYINTEGER(x) \ + ((x) >= LESS && (x) <= GEQ) + +#define ITUSEONLYBOOLEAN(x) \ + (((x) == OR) || ((x) == AND)) + +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; + + if(ITMAKESBOOLEAN(token)) + { + if(ITUSEONLYINTEGER(token)) + { + if(a -> result -> class != OBERON_TYPE_INTEGER + || b -> result -> class != OBERON_TYPE_INTEGER) + { + oberon_error(ctx, "used only with integer types"); + } + } + else if(ITUSEONLYBOOLEAN(token)) + { + if(a -> 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); + } + else if(token == NEQ) + { + expr = oberon_new_operator(OP_NEQ, result, a, b); + } + else if(token == LESS) + { + expr = oberon_new_operator(OP_LSS, result, a, b); + } + else if(token == LEQ) + { + expr = oberon_new_operator(OP_LEQ, result, a, b); + } + else if(token == GREAT) + { + expr = oberon_new_operator(OP_GRT, result, a, b); + } + else if(token == GEQ) + { + expr = oberon_new_operator(OP_GEQ, result, a, b); + } + else if(token == OR) + { + expr = oberon_new_operator(OP_LOGIC_OR, result, a, b); + } + else if(token == AND) + { + expr = oberon_new_operator(OP_LOGIC_AND, result, a, b); + } + else + { + oberon_error(ctx, "oberon_make_bin_op: bool wat"); + } + } + else + { + oberon_autocast_binary_op(ctx, a -> result, b -> result, &result); + + if(token == PLUS) + { + expr = oberon_new_operator(OP_ADD, result, a, b); + } + else if(token == MINUS) + { + expr = oberon_new_operator(OP_SUB, result, a, b); + } + else if(token == STAR) + { + expr = oberon_new_operator(OP_MUL, result, a, b); + } + else if(token == SLASH) + { + expr = oberon_new_operator(OP_DIV, result, a, b); + } + else if(token == DIV) + { + expr = oberon_new_operator(OP_DIV, result, a, b); + } + else if(token == MOD) + { + expr = oberon_new_operator(OP_MOD, result, a, b); + } + else + { + oberon_error(ctx, "oberon_make_bin_op: bin wat"); + } + } + + return expr; +} + +#define ISMULOP(x) \ + ((x) >= STAR && (x) <= AND) + +static oberon_expr_t * +oberon_term_expr(oberon_context_t * ctx) +{ + oberon_expr_t * expr; + + expr = oberon_factor(ctx); + while(ISMULOP(ctx -> token)) + { + int token = ctx -> token; + oberon_read_token(ctx); + + oberon_expr_t * inter = oberon_factor(ctx); + expr = oberon_make_bin_op(ctx, token, expr, inter); + } + + return expr; +} + +#define ISADDOP(x) \ + ((x) >= PLUS && (x) <= OR) + +static oberon_expr_t * +oberon_simple_expr(oberon_context_t * ctx) +{ + oberon_expr_t * expr; + + int minus = 0; + if(ctx -> token == PLUS) + { + minus = 0; + oberon_assert_token(ctx, PLUS); + } + else if(ctx -> token == MINUS) + { + minus = 1; + oberon_assert_token(ctx, MINUS); + } + + expr = oberon_term_expr(ctx); + while(ISADDOP(ctx -> token)) + { + int token = ctx -> token; + oberon_read_token(ctx); + + oberon_expr_t * inter = oberon_term_expr(ctx); + expr = oberon_make_bin_op(ctx, token, expr, inter); + } + + if(minus) + { + expr = oberon_make_unary_op(ctx, MINUS, expr); + } + + return expr; +} + +#define ISRELATION(x) \ + ((x) >= EQUAL && (x) <= GEQ) + +static oberon_expr_t * +oberon_expr(oberon_context_t * ctx) +{ + oberon_expr_t * expr; + + expr = oberon_simple_expr(ctx); + while(ISRELATION(ctx -> token)) + { + int token = ctx -> token; + oberon_read_token(ctx); + + oberon_expr_t * inter = oberon_simple_expr(ctx); + expr = oberon_make_bin_op(ctx, token, expr, inter); + } + + 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 +// ======================================================================= + +static void oberon_statement_seq(oberon_context_t * ctx); + +static void +oberon_expect_token(oberon_context_t * ctx, int token) +{ + if(ctx -> token != token) + { + oberon_error(ctx, "unexpected token %i (%i)", ctx -> token, token); + } +} + +static void +oberon_assert_token(oberon_context_t * ctx, int token) +{ + oberon_expect_token(ctx, token); + oberon_read_token(ctx); +} + +static char * +oberon_assert_ident(oberon_context_t * ctx) +{ + oberon_expect_token(ctx, IDENT); + char * ident = ctx -> string; + oberon_read_token(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) +{ + 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); + + type -> decl = type -> decl -> next; + oberon_generator_init_type(ctx, type); + } + else if(ctx -> token == PROCEDURE) + { + oberon_assert_token(ctx, PROCEDURE); + type = oberon_opt_formal_pars(ctx, OBERON_TYPE_PROCEDURE); + } + else + { + oberon_error(ctx, "invalid type declaration"); + } + + return type; +} + +static void +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 -> decl, OBERON_CLASS_VAR, name, type); +} + +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_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 +oberon_proc_decl(oberon_context_t * ctx) +{ + 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_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_generate_begin_proc(ctx, proc); + + // TODO declarations + + if(ctx -> token == BEGIN) + { + oberon_assert_token(ctx, BEGIN); + oberon_statement_seq(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); + while(ctx -> token == IDENT) + { + oberon_var_decl(ctx); + oberon_assert_token(ctx, SEMICOLON); + } + } + + while(ctx -> token == PROCEDURE) + { + oberon_proc_decl(ctx); + oberon_assert_token(ctx, SEMICOLON); + } +} + +static void +oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst) +{ + 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) +{ + oberon_expr_t * item1; + oberon_expr_t * item2; + + if(ctx -> token == IDENT) + { + 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); + } + } +} + +static void +oberon_statement_seq(oberon_context_t * ctx) +{ + oberon_statement(ctx); + while(ctx -> token == SEMICOLON) + { + oberon_assert_token(ctx, SEMICOLON); + oberon_statement(ctx); + } +} + +static void +oberon_parse_module(oberon_context_t * ctx) +{ + char *name1, *name2; + oberon_read_token(ctx); + + oberon_assert_token(ctx, MODULE); + name1 = oberon_assert_ident(ctx); + oberon_assert_token(ctx, SEMICOLON); + ctx -> mod -> name = name1; + + oberon_decl_seq(ctx); + + if(ctx -> token == BEGIN) + { + oberon_assert_token(ctx, BEGIN); + oberon_generate_begin_module(ctx); + oberon_statement_seq(ctx); + oberon_generate_end_module(ctx); + } + + oberon_assert_token(ctx, END); + name2 = oberon_assert_ident(ctx); + oberon_assert_token(ctx, DOT); + + if(strcmp(name1, name2) != 0) + { + oberon_error(ctx, "module name not matched"); + } +} + +// ======================================================================= +// LIBRARY +// ======================================================================= + +static void +register_default_types(oberon_context_t * ctx) +{ + ctx -> void_type = oberon_new_type_ptr(OBERON_TYPE_VOID); + oberon_generator_init_type(ctx, ctx -> void_type); + + ctx -> int_type = oberon_new_type_integer(sizeof(int)); + oberon_define_type(ctx -> world_scope, "INTEGER", ctx -> int_type); + + ctx -> bool_type = oberon_new_type_boolean(sizeof(int)); + oberon_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type); +} + +oberon_context_t * +oberon_create_context() +{ + oberon_context_t * ctx = malloc(sizeof *ctx); + memset(ctx, 0, sizeof *ctx); + + oberon_scope_t * world_scope; + world_scope = oberon_open_scope(ctx); + ctx -> world_scope = world_scope; + + oberon_generator_init_context(ctx); + + register_default_types(ctx); + + return ctx; +} + +void +oberon_destroy_context(oberon_context_t * ctx) +{ + oberon_generator_destroy_context(ctx); + free(ctx); +} + +oberon_module_t * +oberon_compile_module(oberon_context_t * ctx, const char * code) +{ + oberon_module_t * mod = malloc(sizeof *mod); + memset(mod, 0, sizeof *mod); + ctx -> mod = mod; + + 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; }