X-Git-Url: http://deadsoftware.ru/gitweb?a=blobdiff_plain;f=oberon.c;h=b0bb6aa6fa3ba13a60fe7f956fc8dc820d683501;hb=d3438ae51da4c98b47441911495f10e686191abd;hp=e411c6c2fdaa455bf15fddcd54c7b94a37f3c8c3;hpb=b752043cfbb49243ca3727dbfc9be5b614a8c9c2;p=dsw-obn.git diff --git a/oberon.c b/oberon.c index e411c6c..b0bb6aa 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,47 @@ 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, + POINTER, + TO, + UPARROW, + NIL }; -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,86 +74,228 @@ 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) +{ + 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_scope_t * +oberon_open_scope(oberon_context_t * ctx) { - int class; + oberon_scope_t * scope = malloc(sizeof *scope); + memset(scope, 0, sizeof *scope); - if(item -> mode == MODE_INTEGER) + oberon_object_t * list = malloc(sizeof *list); + memset(list, 0, sizeof *list); + + scope -> ctx = ctx; + scope -> list = list; + scope -> up = ctx -> decl; + + if(scope -> up) { - class = OBERON_TYPE_INTEGER; + scope -> parent = scope -> up -> parent; + scope -> local = scope -> up -> local; } - else if(item -> mode == MODE_VAR) + + 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) { - class = item -> var -> type -> class; + x = x -> next; } - else + + if(x -> next) { - oberon_error(ctx, "oberon_item_to_type_class: wat"); + oberon_error(scope -> ctx, "already defined"); } - return class; -} + oberon_object_t * newvar = malloc(sizeof *newvar); + memset(newvar, 0, sizeof *newvar); + newvar -> name = name; + newvar -> class = class; + newvar -> local = scope -> local; + newvar -> parent = scope -> parent; -// ======================================================================= -// TABLE -// ======================================================================= + x -> next = newvar; -static oberon_type_t * -oberon_find_type(oberon_context_t * ctx, char * name) + return newvar; +} + +static void +oberon_define_field(oberon_context_t * ctx, oberon_type_t * rec, char * name, oberon_type_t * type) { - oberon_type_t * x = ctx -> types; + // TODO check base fields + + 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; + field -> local = 1; + field -> parent = NULL; + + rec -> num_decl += 1; + x -> next = field; } -static oberon_var_t * -oberon_find_var(oberon_context_t * ctx, char * name) +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; } -static void -oberon_define_var(oberon_context_t * ctx, char * name, oberon_type_t * type) +static oberon_object_t * +oberon_find_object(oberon_scope_t * scope, char * name, int check_it) { - oberon_var_t * x = ctx -> mod -> vars; - while(x -> next && strcmp(x -> next -> name, name) != 0) + oberon_object_t * result = NULL; + + oberon_scope_t * s = scope; + while(result == NULL && s != NULL) + { + result = oberon_find_object_in_list(s -> list, name); + s = s -> up; + } + + if(check_it && result == NULL) { + oberon_error(scope -> ctx, "undefined ident %s", name); + } + + 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; } - if(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(ctx, "already defined"); + oberon_error(scope -> ctx, "%s not a type", name); } - oberon_var_t * newvar = malloc(sizeof *newvar); - memset(newvar, 0, sizeof *newvar); - newvar -> name = name; - newvar -> type = type; + return x -> type; +} +*/ - x -> next = newvar; +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; + return var; } -// ======================================================================= -// GENERATOR -// ======================================================================= +/* +static oberon_object_t * +oberon_find_var(oberon_scope_t * scope, char * name) +{ + oberon_object_t * x = oberon_find_object(scope, name); -static void -oberon_generate_assign(oberon_context_t * ctx, void * src, void * dst, int size) + 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; + return proc; } +*/ // ======================================================================= // SCANER @@ -164,9 +330,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 +355,66 @@ 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; + } + else if(strcmp(ident, "POINTER") == 0) + { + ctx -> token = POINTER; + } + else if(strcmp(ident, "TO") == 0) + { + ctx -> token = TO; + } + else if(strcmp(ident, "NIL") == 0) + { + ctx -> token = NIL; + } } static void @@ -225,6 +451,112 @@ 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; + case '^': + ctx -> token = UPARROW; + oberon_get_char(ctx); + break; + default: + oberon_error(ctx, "invalid char"); + break; + } +} + static void oberon_read_token(oberon_context_t * ctx) { @@ -241,202 +573,1817 @@ 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 void oberon_type(oberon_context_t * ctx, oberon_type_t ** type); +static oberon_item_t * oberon_const_expr(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); + + operator -> is_item = 0; + operator -> result = result; + operator -> op = op; + operator -> left = left; + operator -> right = right; + + return (oberon_expr_t *) operator; } -static char * -oberon_assert_ident(oberon_context_t * ctx) +static oberon_expr_t * +oberon_new_item(int mode, oberon_type_t * result) { - char * ident; - oberon_expect_token(ctx, IDENT); - ident = ctx -> string; - oberon_read_token(ctx); - return ident; + oberon_item_t * item; + item = malloc(sizeof *item); + memset(item, 0, sizeof *item); + + item -> is_item = 1; + item -> result = result; + item -> mode = mode; + + return (oberon_expr_t *)item; } -static oberon_type_t * -oberon_type(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_type_t * type = oberon_find_type(ctx, name); + oberon_expr_t * expr; + oberon_type_t * result; + + result = a -> result; - if(type == NULL) + if(token == MINUS) { - oberon_error(ctx, "undefined type"); + if(result -> class != OBERON_TYPE_INTEGER) + { + oberon_error(ctx, "incompatible operator type"); + } + + expr = oberon_new_operator(OP_UNARY_MINUS, result, a, NULL); } + else if(token == NOT) + { + if(result -> class != OBERON_TYPE_BOOLEAN) + { + oberon_error(ctx, "incompatible operator type"); + } - return type; -} + expr = oberon_new_operator(OP_LOGIC_NOT, result, a, NULL); + } + else + { + oberon_error(ctx, "oberon_make_unary_op: wat"); + } -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, name, type); + return expr; } static void -oberon_decl_seq(oberon_context_t * ctx) +oberon_expr_list(oberon_context_t * ctx, int * num_expr, oberon_expr_t ** first, int const_expr) { - if(ctx -> token == VAR) + oberon_expr_t * last; + + *num_expr = 1; + *first = last = oberon_expr(ctx); + while(ctx -> token == COMMA) { - oberon_assert_token(ctx, VAR); - while(ctx -> token == IDENT) + oberon_assert_token(ctx, COMMA); + oberon_expr_t * current; + + if(const_expr) { - oberon_var_decl(ctx); - oberon_assert_token(ctx, SEMICOLON); + current = (oberon_expr_t *) oberon_const_expr(ctx); } + else + { + current = oberon_expr(ctx); + } + + last -> next = current; + last = current; + *num_expr += 1; } } -static oberon_item_t * -oberon_expr(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 * item = malloc(sizeof *item); - memset(item, 0, sizeof *item); + if(pref -> class != expr -> result -> class) + { + oberon_error(ctx, "incompatible types"); + } - if(ctx -> token == IDENT) + if(pref -> class == OBERON_TYPE_INTEGER) { - char * name = oberon_assert_ident(ctx); - oberon_var_t * var = oberon_find_var(ctx, name); - if(var == NULL) + if(expr -> result -> class > pref -> class) { - oberon_error(ctx, "undefined variable"); + oberon_error(ctx, "incompatible size"); } - item -> mode = MODE_VAR; - item -> var = var; } - else if(ctx -> token == INTEGER) + else if(pref -> class == OBERON_TYPE_RECORD) { - item -> mode = MODE_INTEGER; - item -> integer = ctx -> integer; - oberon_assert_token(ctx, INTEGER); + if(expr -> result != pref) + { + printf("oberon_autocast_to: rec %p != %p\n", expr -> result, pref); + oberon_error(ctx, "incompatible record types"); + } } - else + else if(pref -> class == OBERON_TYPE_POINTER) { - oberon_error(ctx, "invalid expression"); + if(expr -> result -> base != pref -> base) + { + if(expr -> result -> base -> class != OBERON_TYPE_VOID) + { + oberon_error(ctx, "incompatible pointer types"); + } + } } - return item; + // TODO cast + + return expr; } static void -oberon_assign(oberon_context_t * ctx, oberon_item_t * src, oberon_item_t * dst) +oberon_autocast_call(oberon_context_t * ctx, oberon_expr_t * desig) { - if(dst -> mode == MODE_INTEGER) + if(desig -> is_item == 0) { - oberon_error(ctx, "invalid assignment"); + oberon_error(ctx, "expected item"); } - int src_class = oberon_item_to_type_class(ctx, src); - int dst_class = oberon_item_to_type_class(ctx, dst); - - if(src_class != dst_class) + if(desig -> item.mode != MODE_CALL) { - oberon_error(ctx, "types not matched"); + oberon_error(ctx, "expected mode CALL"); } - // TODO: code generation - oberon_generate_assign(ctx, 0, 0, 4); -} + if(desig -> item.var -> type -> class != OBERON_TYPE_PROCEDURE) + { + oberon_error(ctx, "only procedures can be called"); + } -static void -oberon_statement(oberon_context_t * ctx) -{ - oberon_item_t * item1; - oberon_item_t * item2; + oberon_type_t * fn = desig -> item.var -> type; + int num_args = desig -> item.num_args; + int num_decl = fn -> num_decl; - if(ctx -> token == IDENT) + if(num_args < num_decl) { - item1 = oberon_expr(ctx); - oberon_assert_token(ctx, ASSIGN); - item2 = oberon_expr(ctx); - oberon_assign(ctx, item2, item1); + oberon_error(ctx, "too few arguments"); + } + else if(num_args > num_decl) + { + oberon_error(ctx, "too many arguments"); } -} -static void -oberon_statement_seq(oberon_context_t * ctx) -{ - oberon_statement(ctx); - while(ctx -> token == SEMICOLON) + oberon_expr_t * arg = desig -> item.args; + oberon_object_t * param = fn -> decl; + for(int i = 0; i < num_args; i++) { - oberon_assert_token(ctx, SEMICOLON); - oberon_statement(ctx); + 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 void -oberon_parse_it(oberon_context_t * ctx) +static oberon_expr_t * +oberon_make_call_func(oberon_context_t * ctx, oberon_object_t * proc, int num_args, oberon_expr_t * list_args) { - char *name1, *name2; - oberon_read_token(ctx); + 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_assert_token(ctx, MODULE); - name1 = oberon_assert_ident(ctx); - oberon_assert_token(ctx, SEMICOLON); - ctx -> mod -> name = name1; + oberon_expr_t * call; - oberon_decl_seq(ctx); + if(proc -> sysproc) + { + if(proc -> genfunc == NULL) + { + oberon_error(ctx, "not a function-procedure"); + } - if(ctx -> token == BEGIN) + call = proc -> genfunc(ctx, num_args, list_args); + } + else { - oberon_assert_token(ctx, BEGIN); - oberon_statement_seq(ctx); + 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); } - oberon_assert_token(ctx, END); - name2 = oberon_assert_ident(ctx); - oberon_assert_token(ctx, DOT); + return call; +} - if(strcmp(name1, name2) != 0) +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) { - oberon_error(ctx, "module name not matched"); + 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) \ + || ((x) == IDENT) \ + || ((x) == INTEGER) \ + || ((x) == LPAREN) \ + || ((x) == NOT) \ + || ((x) == TRUE) \ + || ((x) == FALSE)) + +static oberon_expr_t * +oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr) +{ + if(expr -> result -> class != OBERON_TYPE_POINTER) + { + oberon_error(ctx, "not a pointer"); + } + + assert(expr -> is_item); + + oberon_expr_t * selector; + selector = oberon_new_item(MODE_DEREF, expr -> result -> base); + selector -> item.parent = (oberon_item_t *) expr; + + return selector; +} + +static oberon_expr_t * +oberon_make_array_selector(oberon_context_t * ctx, oberon_expr_t * desig, oberon_expr_t * index) +{ + if(desig -> result -> class == OBERON_TYPE_POINTER) + { + desig = oberno_make_dereferencing(ctx, desig); + } + + assert(desig -> is_item); + + if(desig -> result -> class != OBERON_TYPE_ARRAY) + { + oberon_error(ctx, "not array"); + } + + oberon_type_t * base; + base = desig -> result -> base; + + 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 = 1; + selector -> item.args = index; + + return selector; +} + +static oberon_expr_t * +oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char * name) +{ + if(expr -> result -> class == OBERON_TYPE_POINTER) + { + expr = oberno_make_dereferencing(ctx, expr); + } + + assert(expr -> is_item == 1); + + if(expr -> result -> 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; +} + +#define ISSELECTOR(x) \ + (((x) == LBRACE) \ + || ((x) == DOT) \ + || ((x) == UPARROW)) + +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, 1); + + 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: + case OBERON_CLASS_PROC: + expr = oberon_new_item(MODE_VAR, 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, 0); + oberon_assert_token(ctx, RBRACE); + + 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); + expr = oberno_make_dereferencing(ctx, expr); + break; + default: + oberon_error(ctx, "oberon_designator: wat"); + break; + } + } + return expr; +} + +static oberon_expr_t * +oberon_opt_func_parens(oberon_context_t * ctx, oberon_expr_t * expr) +{ + assert(expr -> is_item == 1); + + /* Если есть скобки - значит вызов. Если нет, то передаём указатель. */ + if(ctx -> token == LPAREN) + { + oberon_assert_token(ctx, LPAREN); + + int num_args = 0; + oberon_expr_t * arguments = NULL; + + if(ISEXPR(ctx -> token)) + { + oberon_expr_list(ctx, &num_args, &arguments, 0); + } + + expr = oberon_make_call_func(ctx, expr -> item.var, num_args, arguments); + + oberon_assert_token(ctx, RPAREN); + } + + return expr; +} + +static void +oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr) +{ + assert(expr -> is_item == 1); + + 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) +{ + oberon_expr_t * expr; + + switch(ctx -> token) + { + case IDENT: + expr = oberon_designator(ctx); + expr = oberon_opt_func_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; + case NIL: + oberon_assert_token(ctx, NIL); + expr = oberon_new_item(MODE_NIL, ctx -> void_ptr_type); + 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_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) +{ + 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 void +oberon_var_decl(oberon_context_t * ctx) +{ + char * name; + oberon_type_t * type; + type = oberon_new_type_ptr(OBERON_TYPE_VOID); + + name = oberon_assert_ident(ctx); + oberon_assert_token(ctx, COLON); + oberon_type(ctx, &type); + 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_new_type_ptr(OBERON_TYPE_VOID); + oberon_type(ctx, &type); + + 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 void +oberon_formal_pars(oberon_context_t * ctx, oberon_type_t * signature) +{ + oberon_assert_token(ctx, LPAREN); + + if(ISFPSECTION) + { + signature -> decl = oberon_fp_section(ctx, &signature -> num_decl); + while(ctx -> token == SEMICOLON) + { + oberon_assert_token(ctx, SEMICOLON); + oberon_fp_section(ctx, &signature -> num_decl); + } + } + + oberon_assert_token(ctx, RPAREN); + + if(ctx -> token == COLON) + { + oberon_assert_token(ctx, COLON); + // TODO get by qualident + oberon_type(ctx, &signature -> base); + } +} + +static void +oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type) +{ + oberon_type_t * signature; + signature = *type; + signature -> class = OBERON_TYPE_PROCEDURE; + signature -> num_decl = 0; + signature -> base = ctx -> void_type; + signature -> decl = NULL; + + if(ctx -> token == LPAREN) + { + oberon_formal_pars(ctx, signature); + } +} + +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) +{ + 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) + { + 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, result_type); + } + + proc -> has_return = 1; + + oberon_generate_return(ctx, expr); +} + +static void +oberon_proc_decl_body(oberon_context_t * ctx, oberon_object_t * proc) +{ + oberon_assert_token(ctx, SEMICOLON); + + ctx -> decl = proc -> scope; + + oberon_decl_seq(ctx); + + oberon_generate_begin_proc(ctx, proc); + + if(ctx -> token == BEGIN) + { + oberon_assert_token(ctx, BEGIN); + oberon_statement_seq(ctx); + } + + oberon_assert_token(ctx, END); + char * name = oberon_assert_ident(ctx); + if(strcmp(name, proc -> name) != 0) + { + oberon_error(ctx, "procedure name not matched"); + } + + if(proc -> type -> base -> class == OBERON_TYPE_VOID + && proc -> has_return == 0) + { + oberon_make_return(ctx, NULL); + } + + if(proc -> has_return == 0) + { + oberon_error(ctx, "procedure requires return"); + } + + 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) +{ + 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_make_array_type(oberon_context_t * ctx, oberon_expr_t * size, oberon_type_t * base, oberon_type_t ** type) +{ + if(size -> is_item == 0) + { + oberon_error(ctx, "requires constant"); + } + + if(size -> item.mode != MODE_INTEGER) + { + oberon_error(ctx, "requires integer constant"); + } + + oberon_type_t * arr; + arr = *type; + arr -> class = OBERON_TYPE_ARRAY; + arr -> size = size -> item.integer; + arr -> base = base; +} + +static void +oberon_field_list(oberon_context_t * ctx, oberon_type_t * rec) +{ + if(ctx -> token == IDENT) + { + char * name; + oberon_type_t * type; + type = oberon_new_type_ptr(OBERON_TYPE_VOID); + + name = oberon_assert_ident(ctx); + oberon_assert_token(ctx, COLON); + oberon_type(ctx, &type); + oberon_define_field(ctx, rec, name, type); + } +} + +static void +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); + + if(to != NULL) + { + if(to -> class != OBERON_CLASS_TYPE) + { + oberon_error(ctx, "not a type"); + } + } + else + { + to = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE); + to -> type = oberon_new_type_ptr(OBERON_TYPE_VOID); + } + + *type = to -> type; +} + +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) +{ + if(ctx -> token == IDENT) + { + oberon_qualident_type(ctx, type); + } + else if(ctx -> token == ARRAY) + { + oberon_assert_token(ctx, ARRAY); + + int num_sizes = 0; + oberon_expr_t * sizes; + oberon_expr_list(ctx, &num_sizes, &sizes, 1); + + oberon_assert_token(ctx, OF); + + oberon_type_t * base; + base = oberon_new_type_ptr(OBERON_TYPE_VOID); + oberon_type(ctx, &base); + + oberon_make_multiarray(ctx, sizes, base, type); + } + else if(ctx -> token == RECORD) + { + oberon_type_t * rec; + rec = *type; + rec -> class = OBERON_TYPE_RECORD; + oberon_object_t * list = malloc(sizeof *list); + memset(list, 0, sizeof *list); + rec -> num_decl = 0; + rec -> base = NULL; + rec -> decl = list; + + oberon_assert_token(ctx, RECORD); + oberon_field_list(ctx, rec); + while(ctx -> token == SEMICOLON) + { + oberon_assert_token(ctx, SEMICOLON); + oberon_field_list(ctx, rec); + } + oberon_assert_token(ctx, END); + + rec -> decl = rec -> decl -> next; + *type = rec; + } + else if(ctx -> token == POINTER) + { + oberon_assert_token(ctx, POINTER); + oberon_assert_token(ctx, TO); + + oberon_type_t * base; + base = oberon_new_type_ptr(OBERON_TYPE_VOID); + oberon_type(ctx, &base); + + oberon_type_t * ptr; + ptr = *type; + ptr -> class = OBERON_TYPE_POINTER; + ptr -> base = base; + } + else if(ctx -> token == PROCEDURE) + { + oberon_open_scope(ctx); + oberon_assert_token(ctx, PROCEDURE); + oberon_opt_formal_pars(ctx, type); + oberon_close_scope(ctx -> decl); + } + else + { + oberon_error(ctx, "invalid type declaration"); + } +} + +static void +oberon_type_decl(oberon_context_t * ctx) +{ + char * name; + oberon_object_t * newtype; + oberon_type_t * type; + + name = oberon_assert_ident(ctx); + + newtype = oberon_find_object(ctx -> decl, name, 0); + if(newtype == NULL) + { + newtype = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE); + newtype -> type = oberon_new_type_ptr(OBERON_TYPE_VOID); + assert(newtype -> type); + } + else + { + if(newtype -> class != OBERON_CLASS_TYPE) + { + oberon_error(ctx, "mult definition"); + } + + if(newtype -> linked) + { + oberon_error(ctx, "mult definition - already linked"); + } + } + + oberon_assert_token(ctx, EQUAL); + + type = newtype -> type; + oberon_type(ctx, &type); + + if(type -> class == OBERON_TYPE_VOID) + { + oberon_error(ctx, "recursive alias declaration"); + } + + newtype -> type = type; + newtype -> linked = 1; +} + +static void oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x); +static void oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type); + +static void +oberon_prevent_recursive_pointer(oberon_context_t * ctx, oberon_type_t * type) +{ + if(type -> class != OBERON_TYPE_POINTER + && type -> class != OBERON_TYPE_ARRAY) + { + return; + } + + if(type -> recursive) + { + oberon_error(ctx, "recursive pointer declaration"); + } + + if(type -> base -> class == OBERON_TYPE_POINTER) + { + oberon_error(ctx, "attempt to make pointer to pointer"); + } + + type -> recursive = 1; + + oberon_prevent_recursive_pointer(ctx, type -> base); + + type -> recursive = 0; +} + +static void +oberon_prevent_recursive_record(oberon_context_t * ctx, oberon_type_t * type) +{ + if(type -> class != OBERON_TYPE_RECORD) + { + return; + } + + if(type -> recursive) + { + oberon_error(ctx, "recursive record declaration"); + } + + type -> recursive = 1; + + int num_fields = type -> num_decl; + oberon_object_t * field = type -> decl; + for(int i = 0; i < num_fields; i++) + { + oberon_prevent_recursive_object(ctx, field); + field = field -> next; + } + + type -> recursive = 0; +} +static void +oberon_prevent_recursive_procedure(oberon_context_t * ctx, oberon_type_t * type) +{ + if(type -> class != OBERON_TYPE_PROCEDURE) + { + return; + } + + if(type -> recursive) + { + oberon_error(ctx, "recursive procedure declaration"); + } + + type -> recursive = 1; + + int num_fields = type -> num_decl; + oberon_object_t * field = type -> decl; + for(int i = 0; i < num_fields; i++) + { + oberon_prevent_recursive_object(ctx, field); + field = field -> next; + } + + type -> recursive = 0; +} + +static void +oberon_prevent_recursive_array(oberon_context_t * ctx, oberon_type_t * type) +{ + if(type -> class != OBERON_TYPE_ARRAY) + { + return; + } + + if(type -> recursive) + { + oberon_error(ctx, "recursive array declaration"); + } + + type -> recursive = 1; + + oberon_prevent_recursive_type(ctx, type -> base); + + type -> recursive = 0; +} + +static void +oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type) +{ + if(type -> class == OBERON_TYPE_POINTER) + { + oberon_prevent_recursive_pointer(ctx, type); + } + else if(type -> class == OBERON_TYPE_RECORD) + { + oberon_prevent_recursive_record(ctx, type); + } + else if(type -> class == OBERON_TYPE_ARRAY) + { + oberon_prevent_recursive_array(ctx, type); + } + else if(type -> class == OBERON_TYPE_PROCEDURE) + { + oberon_prevent_recursive_procedure(ctx, type); + } +} + +static void +oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x) +{ + switch(x -> class) + { + case OBERON_CLASS_VAR: + case OBERON_CLASS_TYPE: + case OBERON_CLASS_PARAM: + case OBERON_CLASS_VAR_PARAM: + case OBERON_CLASS_FIELD: + oberon_prevent_recursive_type(ctx, x -> type); + break; + case OBERON_CLASS_CONST: + case OBERON_CLASS_PROC: + break; + default: + oberon_error(ctx, "oberon_prevent_recursive_object: wat"); + break; + } +} + +static void +oberon_prevent_recursive_decl(oberon_context_t * ctx) +{ + oberon_object_t * x = ctx -> decl -> list -> next; + + while(x) + { + oberon_prevent_recursive_object(ctx, x); + x = x -> next; + } +} + +static void oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x); +static void oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type); + +static void +oberon_initialize_record_fields(oberon_context_t * ctx, oberon_type_t * type) +{ + if(type -> class != OBERON_TYPE_RECORD) + { + return; + } + + int num_fields = type -> num_decl; + oberon_object_t * field = type -> decl; + for(int i = 0; i < num_fields; i++) + { + if(field -> type -> class == OBERON_TYPE_POINTER) + { + oberon_initialize_type(ctx, field -> type); + } + + oberon_initialize_object(ctx, field); + field = field -> next; + } + + oberon_generator_init_record(ctx, type); +} + +static void +oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type) +{ + if(type -> class == OBERON_TYPE_VOID) + { + oberon_error(ctx, "undeclarated type"); + } + + if(type -> initialized) + { + return; + } + + type -> initialized = 1; + + if(type -> class == OBERON_TYPE_POINTER) + { + oberon_initialize_type(ctx, type -> base); + oberon_generator_init_type(ctx, type); + } + else if(type -> class == OBERON_TYPE_ARRAY) + { + oberon_initialize_type(ctx, type -> base); + oberon_generator_init_type(ctx, type); + } + else if(type -> class == OBERON_TYPE_RECORD) + { + oberon_generator_init_type(ctx, type); + oberon_initialize_record_fields(ctx, type); + } + else if(type -> class == OBERON_TYPE_PROCEDURE) + { + int num_fields = type -> num_decl; + oberon_object_t * field = type -> decl; + for(int i = 0; i < num_fields; i++) + { + oberon_initialize_object(ctx, field); + field = field -> next; + } + + oberon_generator_init_type(ctx, type); + } + else + { + oberon_generator_init_type(ctx, type); + } +} + +static void +oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x) +{ + if(x -> initialized) + { + return; + } + + x -> initialized = 1; + + switch(x -> class) + { + case OBERON_CLASS_TYPE: + oberon_initialize_type(ctx, x -> type); + break; + case OBERON_CLASS_VAR: + case OBERON_CLASS_PARAM: + case OBERON_CLASS_VAR_PARAM: + case OBERON_CLASS_FIELD: + oberon_initialize_type(ctx, x -> type); + oberon_generator_init_var(ctx, x); + break; + case OBERON_CLASS_CONST: + case OBERON_CLASS_PROC: + break; + default: + oberon_error(ctx, "oberon_prevent_recursive_object: wat"); + break; + } +} + +static void +oberon_initialize_decl(oberon_context_t * ctx) +{ + oberon_object_t * x = ctx -> decl -> list; + + while(x -> next) + { + oberon_initialize_object(ctx, x -> next); + x = x -> next; + } +} + +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) +{ + 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); + } + } + + oberon_prevent_recursive_decl(ctx); + oberon_initialize_decl(ctx); + + while(ctx -> token == PROCEDURE) + { + oberon_proc_decl(ctx); + oberon_assert_token(ctx, SEMICOLON); + } + + oberon_prevent_undeclarated_procedures(ctx); +} + +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_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 + { + oberon_opt_proc_parens(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 // ======================================================================= -// 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 -> void_ptr_type = oberon_new_type_ptr(OBERON_TYPE_POINTER); + ctx -> void_ptr_type -> base = ctx -> void_type; + oberon_generator_init_type(ctx, ctx -> void_ptr_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); +} + +static void +oberon_new_intrinsic_function(oberon_context_t * ctx, char * name, GenerateFuncCallback generate) +{ + oberon_object_t * proc; + proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC); + proc -> sysproc = 1; + proc -> genfunc = generate; + proc -> type = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE); +} + +/* +static void +oberon_new_intrinsic_procedure(oberon_context_t * ctx, char * name, GenerateProcCallback generate) +{ + oberon_object_t * proc; + proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC); + proc -> sysproc = 1; + proc -> genproc = generate; + proc -> type = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE); +} +*/ + +static oberon_expr_t * +oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 1) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 1) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * arg; + arg = list_args; + + oberon_type_t * result_type; + result_type = arg -> result; + + if(result_type -> class != OBERON_TYPE_INTEGER) + { + oberon_error(ctx, "ABS accepts only integers"); + } + + + oberon_expr_t * expr; + expr = oberon_new_operator(OP_ABS, result_type, arg, NULL); + return expr; +} oberon_context_t * oberon_create_context() @@ -444,46 +2391,41 @@ 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); + 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); + oberon_new_intrinsic_function(ctx, "ABS", oberon_make_abs_call); - ctx -> types = types; 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); - oberon_var_t * vars = malloc(sizeof *vars); - memset(vars, 0, sizeof *vars); ctx -> mod = mod; - ctx -> mod -> vars = vars; - - oberon_init_scaner(ctx, code); - oberon_parse_it(ctx); - return mod; -} -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) - { - x = x -> next; - } + oberon_scope_t * module_scope; + module_scope = oberon_open_scope(ctx); + mod -> decl = module_scope; - if(x -> next) - { - oberon_error(ctx, "already defined"); - } + oberon_init_scaner(ctx, code); + oberon_parse_module(ctx); - // TODO: copy type name (not a pointer) - oberon_type_t * newtype = malloc(sizeof *newtype); - memcpy(newtype, type, sizeof *newtype); - newtype -> next = NULL; + oberon_generate_code(ctx); - x -> next = newtype; + ctx -> mod = NULL; + return mod; }