X-Git-Url: http://deadsoftware.ru/gitweb?a=blobdiff_plain;f=src%2Foberon.c;h=e95a9bef396271f68b2dff5a6af06147cc530c09;hb=5b29102a5440d6511087356b9d9579b7501ca1ec;hp=0118ff9bfceded3989c464ed1a6f9fb59645a6be;hpb=90882596d1b4b9ef59880c878118e4f9da49eede;p=dsw-obn.git diff --git a/src/oberon.c b/src/oberon.c index 0118ff9..e95a9be 100644 --- a/src/oberon.c +++ b/src/oberon.c @@ -33,6 +33,8 @@ enum { LEQ, GREAT, GEQ, + IN, + IS, PLUS, MINUS, OR, @@ -57,7 +59,21 @@ enum { UPARROW, NIL, IMPORT, - REAL + REAL, + CHAR, + STRING, + IF, + THEN, + ELSE, + ELSIF, + WHILE, + DO, + REPEAT, + UNTIL, + FOR, + BY, + LOOP, + EXIT }; // ======================================================================= @@ -114,6 +130,24 @@ oberon_new_type_real(int size) return x; } +static oberon_type_t * +oberon_new_type_char(int size) +{ + oberon_type_t * x; + x = oberon_new_type_ptr(OBERON_TYPE_CHAR); + x -> size = size; + return x; +} + +static oberon_type_t * +oberon_new_type_string(int size) +{ + oberon_type_t * x; + x = oberon_new_type_ptr(OBERON_TYPE_STRING); + x -> size = size; + return x; +} + // ======================================================================= // TABLE // ======================================================================= @@ -133,6 +167,7 @@ oberon_open_scope(oberon_context_t * ctx) scope -> local = scope -> up -> local; scope -> parent = scope -> up -> parent; scope -> parent_type = scope -> up -> parent_type; + scope -> exit_label = scope -> up -> exit_label; } ctx -> decl = scope; @@ -177,6 +212,22 @@ oberon_find_object(oberon_scope_t * scope, char * name, bool check_it) return result; } +static oberon_object_t * +oberon_create_object(oberon_scope_t * scope, char * name, int class, bool export, bool read_only) +{ + oberon_object_t * newvar = malloc(sizeof *newvar); + memset(newvar, 0, sizeof *newvar); + newvar -> name = name; + newvar -> class = class; + newvar -> export = export; + newvar -> read_only = read_only; + newvar -> local = scope -> local; + newvar -> parent = scope -> parent; + newvar -> parent_type = scope -> parent_type; + newvar -> module = scope -> ctx -> mod; + return newvar; +} + static oberon_object_t * oberon_define_object(oberon_scope_t * scope, char * name, int class, bool export, bool read_only, bool check_upscope) { @@ -199,17 +250,8 @@ oberon_define_object(oberon_scope_t * scope, char * name, int class, bool export oberon_error(scope -> ctx, "already defined"); } - oberon_object_t * newvar = malloc(sizeof *newvar); - memset(newvar, 0, sizeof *newvar); - newvar -> name = name; - newvar -> class = class; - newvar -> export = export; - newvar -> read_only = read_only; - newvar -> local = scope -> local; - newvar -> parent = scope -> parent; - newvar -> parent_type = scope -> parent_type; - newvar -> module = scope -> ctx -> mod; - + oberon_object_t * newvar; + newvar = oberon_create_object(scope, name, class, export, read_only); x -> next = newvar; return newvar; @@ -350,6 +392,62 @@ oberon_read_ident(oberon_context_t * ctx) { ctx -> token = IMPORT; } + else if(strcmp(ident, "IN") == 0) + { + ctx -> token = IN; + } + else if(strcmp(ident, "IS") == 0) + { + ctx -> token = IS; + } + else if(strcmp(ident, "IF") == 0) + { + ctx -> token = IF; + } + else if(strcmp(ident, "THEN") == 0) + { + ctx -> token = THEN; + } + else if(strcmp(ident, "ELSE") == 0) + { + ctx -> token = ELSE; + } + else if(strcmp(ident, "ELSIF") == 0) + { + ctx -> token = ELSIF; + } + else if(strcmp(ident, "WHILE") == 0) + { + ctx -> token = WHILE; + } + else if(strcmp(ident, "DO") == 0) + { + ctx -> token = DO; + } + else if(strcmp(ident, "REPEAT") == 0) + { + ctx -> token = REPEAT; + } + else if(strcmp(ident, "UNTIL") == 0) + { + ctx -> token = UNTIL; + } + else if(strcmp(ident, "FOR") == 0) + { + ctx -> token = FOR; + } + else if(strcmp(ident, "BY") == 0) + { + ctx -> token = BY; + } + else if(strcmp(ident, "LOOP") == 0) + { + ctx -> token = LOOP; + } + else if(strcmp(ident, "EXIT") == 0) + { + ctx -> token = EXIT; + } } static void @@ -367,6 +465,7 @@ oberon_read_number(oberon_context_t * ctx) * mode = 1 == HEX * mode = 2 == REAL * mode = 3 == LONGREAL + * mode = 4 == CHAR */ int mode = 0; start_i = ctx -> code_index; @@ -388,11 +487,20 @@ oberon_read_number(oberon_context_t * ctx) end_i = ctx -> code_index; - if(ctx -> c != 'H') + if(ctx -> c == 'H') + { + mode = 1; + oberon_get_char(ctx); + } + else if(ctx -> c == 'X') + { + mode = 4; + oberon_get_char(ctx); + } + else { oberon_error(ctx, "invalid hex number"); } - oberon_get_char(ctx); } else if(ctx -> c == '.') { @@ -430,6 +538,20 @@ oberon_read_number(oberon_context_t * ctx) end_i = ctx -> code_index; } + if(mode == 0) + { + if(ctx -> c == 'H') + { + mode = 1; + oberon_get_char(ctx); + } + else if(ctx -> c == 'X') + { + mode = 4; + oberon_get_char(ctx); + } + } + int len = end_i - start_i; ident = malloc(len + 1); memcpy(ident, &ctx -> code[start_i], len); @@ -460,6 +582,11 @@ oberon_read_number(oberon_context_t * ctx) sscanf(ident, "%lf", &real); ctx -> token = REAL; break; + case 4: + sscanf(ident, "%lx", &integer); + real = integer; + ctx -> token = CHAR; + break; default: oberon_error(ctx, "oberon_read_number: wat"); break; @@ -514,6 +641,36 @@ oberon_read_comment(oberon_context_t * ctx) } } +static void oberon_read_string(oberon_context_t * ctx) +{ + int c = ctx -> c; + oberon_get_char(ctx); + + int start = ctx -> code_index; + + while(ctx -> c != 0 && ctx -> c != c) + { + oberon_get_char(ctx); + } + + if(ctx -> c == 0) + { + oberon_error(ctx, "unterminated string"); + } + + int end = ctx -> code_index; + + oberon_get_char(ctx); + + char * string = calloc(1, end - start + 1); + strncpy(string, &ctx -> code[start], end - start); + + ctx -> token = STRING; + ctx -> string = string; + + printf("oberon_read_string: string ((%s))\n", string); +} + static void oberon_read_token(oberon_context_t * ctx); static void @@ -627,6 +784,12 @@ oberon_read_symbol(oberon_context_t * ctx) ctx -> token = UPARROW; oberon_get_char(ctx); break; + case '"': + oberon_read_string(ctx); + break; + case '\'': + oberon_read_string(ctx); + break; default: oberon_error(ctx, "invalid char %c", ctx -> c); break; @@ -663,6 +826,7 @@ static void oberon_assert_token(oberon_context_t * ctx, int token); static char * oberon_assert_ident(oberon_context_t * ctx); static void oberon_type(oberon_context_t * ctx, oberon_type_t ** type); static oberon_item_t * oberon_const_expr(oberon_context_t * ctx); +static oberon_expr_t * oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr); static oberon_expr_t * oberon_new_operator(int op, oberon_type_t * result, oberon_expr_t * left, oberon_expr_t * right) @@ -736,7 +900,14 @@ oberon_expr_list(oberon_context_t * ctx, int * num_expr, oberon_expr_t ** first, oberon_expr_t * last; *num_expr = 1; - *first = last = oberon_expr(ctx); + if(const_expr) + { + *first = last = (oberon_expr_t *) oberon_const_expr(ctx); + } + else + { + *first = last = oberon_expr(ctx); + } while(ctx -> token == COMMA) { oberon_assert_token(ctx, COMMA); @@ -760,11 +931,30 @@ oberon_expr_list(oberon_context_t * ctx, int * num_expr, oberon_expr_t ** first, static oberon_expr_t * oberon_cast_expr(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref) { - oberon_expr_t * cast; - cast = oberon_new_item(MODE_CAST, pref, expr -> read_only); - cast -> item.parent = expr; - cast -> next = expr -> next; - return cast; + return oberon_new_operator(OP_CAST, pref, expr, NULL); +} + +static oberon_expr_t * +oberno_make_record_cast(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * rec) +{ + oberon_type_t * from = expr -> result; + oberon_type_t * to = rec; + + printf("oberno_make_record_cast: from class %i to class %i\n", from -> class, to -> class); + + if(from -> class == OBERON_TYPE_POINTER && to -> class == OBERON_TYPE_POINTER) + { + printf("oberno_make_record_cast: pointers\n"); + from = from -> base; + to = to -> base; + } + + if(from -> class != OBERON_TYPE_RECORD || to -> class != OBERON_TYPE_RECORD) + { + oberon_error(ctx, "must be record type"); + } + + return oberon_cast_expr(ctx, expr, rec); } static oberon_type_t * @@ -795,39 +985,78 @@ oberon_get_equal_expr_type(oberon_context_t * ctx, oberon_type_t * a, oberon_typ return result; } +static void +oberon_check_record_compatibility(oberon_context_t * ctx, oberon_type_t * from, oberon_type_t * to) +{ + if(from -> class == OBERON_TYPE_POINTER && to -> class == OBERON_TYPE_POINTER) + { + from = from -> base; + to = to -> base; + } + + if(from -> class != OBERON_TYPE_RECORD || to -> class != OBERON_TYPE_RECORD) + { + oberon_error(ctx, "not a record"); + } + + oberon_type_t * t = from; + while(t != NULL && t != to) + { + t = t -> base; + } + + if(t == NULL) + { + oberon_error(ctx, "incompatible record types"); + } +} + static oberon_expr_t * oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref) { + // Допускается: + // Если классы типов равны + // Если INTEGER переводится в REAL + // Есди STRING переводится в ARRAY OF CHAR + + bool error = false; if(pref -> class != expr -> result -> class) { - if(pref -> class == OBERON_TYPE_POINTER) + printf("expr class %i\n", expr -> result -> class); + printf("pref class %i\n", pref -> class); + + if(expr -> result -> class == OBERON_TYPE_STRING) { - if(expr -> result -> class == OBERON_TYPE_POINTER) + if(pref -> class == OBERON_TYPE_ARRAY) { - // accept + if(pref -> base -> class != OBERON_TYPE_CHAR) + { + error = true; + } } else { - oberon_error(ctx, "incompatible types"); + error = true; } } - else if(pref -> class == OBERON_TYPE_REAL) + else if(expr -> result -> class == OBERON_TYPE_INTEGER) { - if(expr -> result -> class == OBERON_TYPE_INTEGER) + if(pref -> class != OBERON_TYPE_REAL) { - // accept - } - else - { - oberon_error(ctx, "incompatible types"); + error = true; } } else { - oberon_error(ctx, "incompatible types"); + error = true; } } + if(error) + { + oberon_error(ctx, "oberon_autocast_to: incompatible types"); + } + if(pref -> class == OBERON_TYPE_INTEGER || pref -> class == OBERON_TYPE_REAL) { if(expr -> result -> size > pref -> size) @@ -841,15 +1070,18 @@ oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * } else if(pref -> class == OBERON_TYPE_RECORD) { - if(expr -> result != pref) - { - printf("oberon_autocast_to: rec %p != %p\n", expr -> result, pref); - oberon_error(ctx, "incompatible record types"); - } + oberon_check_record_compatibility(ctx, expr -> result, pref); + expr = oberno_make_record_cast(ctx, expr, pref); } else if(pref -> class == OBERON_TYPE_POINTER) { - if(expr -> result -> base != pref -> base) + assert(pref -> base); + if(expr -> result -> base -> class == OBERON_TYPE_RECORD) + { + oberon_check_record_compatibility(ctx, expr -> result, pref); + expr = oberno_make_record_cast(ctx, expr, pref); + } + else if(expr -> result -> base != pref -> base) { if(expr -> result -> base -> class != OBERON_TYPE_VOID) { @@ -872,25 +1104,15 @@ oberon_autocast_binary_op(oberon_context_t * ctx, oberon_expr_t ** ea, oberon_ex } static void -oberon_autocast_call(oberon_context_t * ctx, oberon_expr_t * desig) +oberon_autocast_call(oberon_context_t * ctx, oberon_item_t * desig) { - if(desig -> is_item == 0) - { - oberon_error(ctx, "expected item"); - } - - if(desig -> item.mode != MODE_CALL) + if(desig -> mode != MODE_CALL) { oberon_error(ctx, "expected mode CALL"); } - if(desig -> item.var -> type -> class != OBERON_TYPE_PROCEDURE) - { - oberon_error(ctx, "only procedures can be called"); - } - - oberon_type_t * fn = desig -> item.var -> type; - int num_args = desig -> item.num_args; + oberon_type_t * fn = desig -> parent -> result; + int num_args = desig -> num_args; int num_decl = fn -> num_decl; if(num_args < num_decl) @@ -904,7 +1126,7 @@ oberon_autocast_call(oberon_context_t * ctx, oberon_expr_t * desig) /* Делаем проверку на запись и делаем автокаст */ oberon_expr_t * casted[num_args]; - oberon_expr_t * arg = desig -> item.args; + oberon_expr_t * arg = desig -> args; oberon_object_t * param = fn -> decl; for(int i = 0; i < num_args; i++) { @@ -929,62 +1151,84 @@ oberon_autocast_call(oberon_context_t * ctx, oberon_expr_t * desig) { casted[i] -> next = casted[i + 1]; } - desig -> item.args = arg; + desig -> args = arg; } } static oberon_expr_t * -oberon_make_call_func(oberon_context_t * ctx, oberon_object_t * proc, int num_args, oberon_expr_t * list_args) +oberon_make_call_func(oberon_context_t * ctx, oberon_item_t * item, int num_args, oberon_expr_t * list_args) { - switch(proc -> class) + oberon_type_t * signature = item -> result; + if(signature -> class != OBERON_TYPE_PROCEDURE) { - 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_error(ctx, "not a procedure"); } oberon_expr_t * call; - if(proc -> sysproc) + if(signature -> sysproc) { - if(proc -> genfunc == NULL) + if(signature -> genfunc == NULL) { oberon_error(ctx, "not a function-procedure"); } - call = proc -> genfunc(ctx, num_args, list_args); + call = signature -> genfunc(ctx, num_args, list_args); } else { - if(proc -> type -> base -> class == OBERON_TYPE_VOID) + if(signature -> base -> class == OBERON_TYPE_VOID) { oberon_error(ctx, "attempt to call procedure in expression"); } - call = oberon_new_item(MODE_CALL, proc -> type -> base, 1); - call -> item.var = proc; + call = oberon_new_item(MODE_CALL, signature -> base, true); + call -> item.parent = item; call -> item.num_args = num_args; call -> item.args = list_args; - oberon_autocast_call(ctx, call); + oberon_autocast_call(ctx, (oberon_item_t *) call); } return call; } +static void +oberon_make_call_proc(oberon_context_t * ctx, oberon_item_t * item, int num_args, oberon_expr_t * list_args) +{ + oberon_type_t * signature = item -> result; + if(signature -> class != OBERON_TYPE_PROCEDURE) + { + oberon_error(ctx, "not a procedure"); + } + + oberon_expr_t * call; + + if(signature -> sysproc) + { + if(signature -> genproc == NULL) + { + oberon_error(ctx, "not a procedure"); + } + + signature -> genproc(ctx, num_args, list_args); + } + else + { + if(signature -> base -> class != OBERON_TYPE_VOID) + { + oberon_error(ctx, "attempt to call function as non-typed procedure"); + } + + call = oberon_new_item(MODE_CALL, signature -> base, true); + call -> item.parent = item; + call -> item.num_args = num_args; + call -> item.args = list_args; + oberon_autocast_call(ctx, (oberon_item_t *) call); + oberon_generate_call_proc(ctx, call); + } +} + +/* static void oberon_make_call_proc(oberon_context_t * ctx, oberon_object_t * proc, int num_args, oberon_expr_t * list_args) { @@ -1034,20 +1278,26 @@ oberon_make_call_proc(oberon_context_t * ctx, oberon_object_t * proc, int num_ar oberon_generate_call_proc(ctx, call); } } +*/ #define ISEXPR(x) \ (((x) == PLUS) \ || ((x) == MINUS) \ || ((x) == IDENT) \ || ((x) == INTEGER) \ + || ((x) == REAL) \ + || ((x) == CHAR) \ + || ((x) == STRING) \ + || ((x) == NIL) \ || ((x) == LPAREN) \ || ((x) == NOT) \ || ((x) == TRUE) \ - || ((x) == FALSE)) + || ((x) == FALSE)) static oberon_expr_t * oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr) { + printf("oberno_make_dereferencing\n"); if(expr -> result -> class != OBERON_TYPE_POINTER) { oberon_error(ctx, "not a pointer"); @@ -1057,7 +1307,7 @@ oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr) oberon_expr_t * selector; selector = oberon_new_item(MODE_DEREF, expr -> result -> base, expr -> read_only); - selector -> item.parent = expr; + selector -> item.parent = (oberon_item_t *) expr; return selector; } @@ -1104,7 +1354,7 @@ oberon_make_array_selector(oberon_context_t * ctx, oberon_expr_t * desig, oberon oberon_expr_t * selector; selector = oberon_new_item(MODE_INDEX, base, desig -> read_only); - selector -> item.parent = desig; + selector -> item.parent = (oberon_item_t *) desig; selector -> item.num_args = 1; selector -> item.args = index; @@ -1119,7 +1369,7 @@ oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char * expr = oberno_make_dereferencing(ctx, expr); } - assert(expr -> is_item == 1); + assert(expr -> is_item); if(expr -> result -> class != OBERON_TYPE_RECORD) { @@ -1151,7 +1401,7 @@ oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char * oberon_expr_t * selector; selector = oberon_new_item(MODE_FIELD, field -> type, read_only); selector -> item.var = field; - selector -> item.parent = expr; + selector -> item.parent = (oberon_item_t *) expr; return selector; } @@ -1159,7 +1409,8 @@ oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char * #define ISSELECTOR(x) \ (((x) == LBRACE) \ || ((x) == DOT) \ - || ((x) == UPARROW)) + || ((x) == UPARROW) \ + || ((x) == LPAREN)) static oberon_object_t * oberon_qualident(oberon_context_t * ctx, char ** xname, int check) @@ -1194,6 +1445,26 @@ oberon_qualident(oberon_context_t * ctx, char ** xname, int check) return x; } +static oberon_expr_t * +oberon_ident_item(oberon_context_t * ctx, char * name) +{ + bool read_only; + oberon_object_t * x; + oberon_expr_t * expr; + + x = oberon_find_object(ctx -> decl, name, true); + + read_only = false; + if(x -> class == OBERON_CLASS_CONST || x -> class == OBERON_CLASS_PROC) + { + read_only = true; + } + + expr = oberon_new_item(MODE_VAR, x -> type, read_only); + expr -> item.var = x; + return expr; +} + static oberon_expr_t * oberon_designator(oberon_context_t * ctx) { @@ -1224,7 +1495,7 @@ oberon_designator(oberon_context_t * ctx) expr = oberon_new_item(MODE_VAR, var -> type, read_only); break; case OBERON_CLASS_PROC: - expr = oberon_new_item(MODE_VAR, var -> type, 1); + expr = oberon_new_item(MODE_VAR, var -> type, true); break; default: oberon_error(ctx, "invalid designator"); @@ -1232,7 +1503,7 @@ oberon_designator(oberon_context_t * ctx) } expr -> item.var = var; - while(ISSELECTOR(ctx -> token)) + while(expr -> result -> class != OBERON_TYPE_PROCEDURE && ISSELECTOR(ctx -> token)) { switch(ctx -> token) { @@ -1258,19 +1529,28 @@ oberon_designator(oberon_context_t * ctx) oberon_assert_token(ctx, UPARROW); expr = oberno_make_dereferencing(ctx, expr); break; + case LPAREN: + oberon_assert_token(ctx, LPAREN); + oberon_object_t * objtype = oberon_qualident(ctx, NULL, 1); + if(objtype -> class != OBERON_CLASS_TYPE) + { + oberon_error(ctx, "must be type"); + } + oberon_assert_token(ctx, RPAREN); + expr = oberno_make_record_cast(ctx, expr, objtype -> type); + 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) { @@ -1284,7 +1564,8 @@ oberon_opt_func_parens(oberon_context_t * ctx, oberon_expr_t * expr) oberon_expr_list(ctx, &num_args, &arguments, 0); } - expr = oberon_make_call_func(ctx, expr -> item.var, num_args, arguments); + assert(expr -> is_item == 1); + expr = oberon_make_call_func(ctx, (oberon_item_t *) expr, num_args, arguments); oberon_assert_token(ctx, RPAREN); } @@ -1295,7 +1576,7 @@ oberon_opt_func_parens(oberon_context_t * ctx, oberon_expr_t * expr) static void oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr) { - assert(expr -> is_item == 1); + assert(expr -> is_item); int num_args = 0; oberon_expr_t * arguments = NULL; @@ -1313,7 +1594,7 @@ oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr) } /* Вызов происходит даже без скобок */ - oberon_make_call_proc(ctx, expr -> item.var, num_args, arguments); + oberon_make_call_proc(ctx, (oberon_item_t *) expr, num_args, arguments); } static oberon_type_t * @@ -1337,6 +1618,17 @@ oberon_get_type_of_int_value(oberon_context_t * ctx, int64_t i) } } +static oberon_expr_t * +oberon_integer_item(oberon_context_t * ctx, int64_t i) +{ + oberon_expr_t * expr; + oberon_type_t * result; + result = oberon_get_type_of_int_value(ctx, i); + expr = oberon_new_item(MODE_INTEGER, result, true); + expr -> item.integer = i; + return expr; +} + static oberon_expr_t * oberon_factor(oberon_context_t * ctx) { @@ -1350,11 +1642,21 @@ oberon_factor(oberon_context_t * ctx) expr = oberon_opt_func_parens(ctx, expr); break; case INTEGER: - result = oberon_get_type_of_int_value(ctx, ctx -> integer); - expr = oberon_new_item(MODE_INTEGER, result, 1); - expr -> item.integer = ctx -> integer; + expr = oberon_integer_item(ctx, ctx -> integer); oberon_assert_token(ctx, INTEGER); break; + case CHAR: + result = ctx -> char_type; + expr = oberon_new_item(MODE_CHAR, result, true); + expr -> item.integer = ctx -> integer; + oberon_assert_token(ctx, CHAR); + break; + case STRING: + result = ctx -> string_type; + expr = oberon_new_item(MODE_STRING, result, true); + expr -> item.string = ctx -> string; + oberon_assert_token(ctx, STRING); + break; case REAL: result = (ctx -> longmode) ? (ctx -> longreal_type) : (ctx -> real_type); expr = oberon_new_item(MODE_REAL, result, 1); @@ -1362,12 +1664,12 @@ oberon_factor(oberon_context_t * ctx) oberon_assert_token(ctx, REAL); break; case TRUE: - expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, 1); + expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, true); expr -> item.boolean = true; oberon_assert_token(ctx, TRUE); break; case FALSE: - expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, 1); + expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, true); expr -> item.boolean = false; oberon_assert_token(ctx, FALSE); break; @@ -1383,7 +1685,7 @@ oberon_factor(oberon_context_t * ctx) break; case NIL: oberon_assert_token(ctx, NIL); - expr = oberon_new_item(MODE_NIL, ctx -> void_ptr_type, 1); + expr = oberon_new_item(MODE_NIL, ctx -> void_ptr_type, true); break; default: oberon_error(ctx, "invalid expression"); @@ -1436,6 +1738,10 @@ oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_ || b -> result -> class == OBERON_TYPE_INTEGER || a -> result -> class == OBERON_TYPE_REAL || b -> result -> class == OBERON_TYPE_REAL) + { + // accept + } + else { oberon_error(ctx, "used only with numeric types"); } @@ -1597,7 +1903,7 @@ oberon_simple_expr(oberon_context_t * ctx) } #define ISRELATION(x) \ - ((x) >= EQUAL && (x) <= GEQ) + ((x) >= EQUAL && (x) <= IS) static oberon_expr_t * oberon_expr(oberon_context_t * ctx) @@ -1628,6 +1934,21 @@ oberon_const_expr(oberon_context_t * ctx) oberon_error(ctx, "const expression are required"); } + switch(expr -> item.mode) + { + case MODE_INTEGER: + case MODE_BOOLEAN: + case MODE_NIL: + case MODE_REAL: + case MODE_CHAR: + case MODE_STRING: + /* accept */ + break; + default: + oberon_error(ctx, "const expression are required"); + break; + } + return (oberon_item_t *) expr; } @@ -2119,13 +2440,19 @@ oberon_type_record_body(oberon_context_t * ctx, oberon_type_t * rec) oberon_error(ctx, "base must be type"); } - if(typeobj -> type -> class != OBERON_TYPE_RECORD) + oberon_type_t * base = typeobj -> type; + if(base -> class == OBERON_TYPE_POINTER) + { + base = base -> base; + } + + if(base -> class != OBERON_TYPE_RECORD) { oberon_error(ctx, "base must be record type"); } - rec -> base = typeobj -> type; - ctx -> decl = rec -> base -> scope; + rec -> base = base; + ctx -> decl = base -> scope; oberon_assert_token(ctx, RPAREN); } @@ -2634,6 +2961,25 @@ oberon_decl_seq(oberon_context_t * ctx) oberon_prevent_undeclarated_procedures(ctx); } +static oberon_expr_t * +oberon_make_temp_var_item(oberon_context_t * ctx, oberon_type_t * type) +{ + oberon_object_t * x; + oberon_expr_t * expr; + + x = oberon_create_object(ctx -> decl, "TEMP", OBERON_CLASS_VAR, false, false); + x -> local = true; + x -> type = type; + oberon_generator_init_temp_var(ctx, x); + + expr = oberon_new_item(MODE_VAR, type, false); + expr -> item.var = x; + return expr; +} + +static void +oberon_statement_seq(oberon_context_t * ctx); + static void oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst) { @@ -2666,6 +3012,192 @@ oberon_statement(oberon_context_t * ctx) oberon_opt_proc_parens(ctx, item1); } } + else if(ctx -> token == IF) + { + gen_label_t * end; + gen_label_t * els; + oberon_expr_t * cond; + + els = oberon_generator_reserve_label(ctx); + end = oberon_generator_reserve_label(ctx); + + oberon_assert_token(ctx, IF); + cond = oberon_expr(ctx); + if(cond -> result -> class != OBERON_TYPE_BOOLEAN) + { + oberon_error(ctx, "condition must be boolean"); + } + oberon_assert_token(ctx, THEN); + oberon_generate_branch(ctx, cond, false, els); + oberon_statement_seq(ctx); + oberon_generate_goto(ctx, end); + oberon_generate_label(ctx, els); + + while(ctx -> token == ELSIF) + { + els = oberon_generator_reserve_label(ctx); + + oberon_assert_token(ctx, ELSIF); + cond = oberon_expr(ctx); + if(cond -> result -> class != OBERON_TYPE_BOOLEAN) + { + oberon_error(ctx, "condition must be boolean"); + } + oberon_assert_token(ctx, THEN); + oberon_generate_branch(ctx, cond, false, els); + oberon_statement_seq(ctx); + oberon_generate_goto(ctx, end); + oberon_generate_label(ctx, els); + } + + if(ctx -> token == ELSE) + { + oberon_assert_token(ctx, ELSE); + oberon_statement_seq(ctx); + } + + oberon_generate_label(ctx, end); + oberon_assert_token(ctx, END); + } + else if(ctx -> token == WHILE) + { + gen_label_t * begin; + gen_label_t * end; + oberon_expr_t * cond; + + begin = oberon_generator_reserve_label(ctx); + end = oberon_generator_reserve_label(ctx); + + oberon_assert_token(ctx, WHILE); + oberon_generate_label(ctx, begin); + cond = oberon_expr(ctx); + if(cond -> result -> class != OBERON_TYPE_BOOLEAN) + { + oberon_error(ctx, "condition must be boolean"); + } + oberon_generate_branch(ctx, cond, false, end); + + oberon_assert_token(ctx, DO); + oberon_statement_seq(ctx); + oberon_generate_goto(ctx, begin); + + oberon_assert_token(ctx, END); + oberon_generate_label(ctx, end); + } + else if(ctx -> token == REPEAT) + { + gen_label_t * begin; + oberon_expr_t * cond; + + begin = oberon_generator_reserve_label(ctx); + oberon_generate_label(ctx, begin); + oberon_assert_token(ctx, REPEAT); + + oberon_statement_seq(ctx); + + oberon_assert_token(ctx, UNTIL); + + cond = oberon_expr(ctx); + if(cond -> result -> class != OBERON_TYPE_BOOLEAN) + { + oberon_error(ctx, "condition must be boolean"); + } + + oberon_generate_branch(ctx, cond, true, begin); + } + else if(ctx -> token == FOR) + { + oberon_expr_t * from; + oberon_expr_t * index; + oberon_expr_t * to; + oberon_expr_t * bound; + oberon_expr_t * by; + oberon_expr_t * cond; + oberon_expr_t * count; + gen_label_t * begin; + gen_label_t * end; + char * iname; + int op; + + begin = oberon_generator_reserve_label(ctx); + end = oberon_generator_reserve_label(ctx); + + oberon_assert_token(ctx, FOR); + iname = oberon_assert_ident(ctx); + index = oberon_ident_item(ctx, iname); + oberon_assert_token(ctx, ASSIGN); + from = oberon_expr(ctx); + oberon_assign(ctx, from, index); + oberon_assert_token(ctx, TO); + bound = oberon_make_temp_var_item(ctx, index -> result); + to = oberon_expr(ctx); + oberon_assign(ctx, to, bound); + if(ctx -> token == BY) + { + oberon_assert_token(ctx, BY); + by = (oberon_expr_t *) oberon_const_expr(ctx); + } + else + { + by = oberon_integer_item(ctx, 1); + } + + if(by -> result -> class != OBERON_TYPE_INTEGER) + { + oberon_error(ctx, "must be integer"); + } + + if(by -> item.integer > 0) + { + op = LEQ; + } + else if(by -> item.integer < 0) + { + op = GEQ; + } + else + { + oberon_error(ctx, "zero step not allowed"); + } + + oberon_assert_token(ctx, DO); + oberon_generate_label(ctx, begin); + cond = oberon_make_bin_op(ctx, op, index, bound); + oberon_generate_branch(ctx, cond, false, end); + oberon_statement_seq(ctx); + count = oberon_make_bin_op(ctx, PLUS, index, by); + oberon_assign(ctx, count, index); + oberon_generate_goto(ctx, begin); + oberon_generate_label(ctx, end); + oberon_assert_token(ctx, END); + } + else if(ctx -> token == LOOP) + { + gen_label_t * begin; + gen_label_t * end; + + begin = oberon_generator_reserve_label(ctx); + end = oberon_generator_reserve_label(ctx); + + oberon_open_scope(ctx); + oberon_assert_token(ctx, LOOP); + oberon_generate_label(ctx, begin); + ctx -> decl -> exit_label = end; + oberon_statement_seq(ctx); + oberon_generate_goto(ctx, begin); + oberon_generate_label(ctx, end); + oberon_assert_token(ctx, END); + oberon_close_scope(ctx -> decl); + } + else if(ctx -> token == EXIT) + { + oberon_assert_token(ctx, EXIT); + if(ctx -> decl -> exit_label == NULL) + { + oberon_error(ctx, "not in LOOP-END"); + } + oberon_generate_goto(ctx, ctx -> decl -> exit_label); + } else if(ctx -> token == RETURN) { oberon_assert_token(ctx, RETURN); @@ -2811,6 +3343,9 @@ register_default_types(oberon_context_t * ctx) ctx -> void_ptr_type -> base = ctx -> void_type; oberon_generator_init_type(ctx, ctx -> void_ptr_type); + ctx -> string_type = oberon_new_type_string(1); + oberon_generator_init_type(ctx, ctx -> string_type); + ctx -> bool_type = oberon_new_type_boolean(); oberon_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type, 1); @@ -2831,6 +3366,9 @@ register_default_types(oberon_context_t * ctx) ctx -> longreal_type = oberon_new_type_real(8); oberon_define_type(ctx -> world_scope, "LONGREAL", ctx -> longreal_type, 1); + + ctx -> char_type = oberon_new_type_char(1); + oberon_define_type(ctx -> world_scope, "CHAR", ctx -> char_type, 1); } static void @@ -2838,10 +3376,10 @@ oberon_new_intrinsic(oberon_context_t * ctx, char * name, GenerateFuncCallback f { oberon_object_t * proc; proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, true, false, false); - proc -> sysproc = 1; - proc -> genfunc = f; - proc -> genproc = p; proc -> type = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE); + proc -> type -> sysproc = true; + proc -> type -> genfunc = f; + proc -> type -> genproc = p; } static oberon_expr_t *