X-Git-Url: https://deadsoftware.ru/gitweb?a=blobdiff_plain;f=src%2Foberon.c;h=0bbeec188b3d5b4e7fafe506285a9d096cb809b7;hb=1233fb1d5d8f67a8f5e970386c1c4cbb6691ec04;hp=30f10ec49af929465b3dfa31885ae7bb3b150fbb;hpb=3d4021b9a2dd52aaf4b97859a8a58b74903ebac9;p=dsw-obn.git diff --git a/src/oberon.c b/src/oberon.c index 30f10ec..0bbeec1 100644 --- a/src/oberon.c +++ b/src/oberon.c @@ -6,6 +6,9 @@ #include #include #include +#include + +#include #include "../include/oberon.h" @@ -24,7 +27,7 @@ oberon_make_copy_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list static oberon_type_t * oberon_new_type_ptr(int class) { - oberon_type_t * x = malloc(sizeof *x); + oberon_type_t * x = GC_MALLOC(sizeof *x); memset(x, 0, sizeof *x); x -> class = class; return x; @@ -87,7 +90,7 @@ static oberon_expr_t * oberon_new_operator(int op, oberon_type_t * result, oberon_expr_t * left, oberon_expr_t * right) { oberon_oper_t * operator; - operator = malloc(sizeof *operator); + operator = GC_MALLOC(sizeof *operator); memset(operator, 0, sizeof *operator); operator -> is_item = 0; @@ -104,7 +107,7 @@ static oberon_expr_t * oberon_new_item(int mode, oberon_type_t * result, int read_only) { oberon_item_t * item; - item = malloc(sizeof *item); + item = GC_MALLOC(sizeof *item); memset(item, 0, sizeof *item); item -> is_item = 1; @@ -148,6 +151,16 @@ oberon_make_integer(oberon_context_t * ctx, int64_t i) return expr; } +static oberon_expr_t * +oberon_make_char(oberon_context_t * ctx, int64_t i) +{ + oberon_expr_t * expr; + expr = oberon_new_item(MODE_CHAR, ctx -> char_type, true); + expr -> item.integer = i; + expr -> item.real = i; + return expr; +} + static oberon_expr_t * oberon_make_real_typed(oberon_context_t * ctx, double r, oberon_type_t * result) { @@ -186,6 +199,16 @@ oberon_make_set(oberon_context_t * ctx, int64_t i) return expr; } +static oberon_expr_t * +oberon_make_set_index(oberon_context_t * ctx, int64_t i) +{ + oberon_expr_t * expr; + expr = oberon_new_item(MODE_SET, ctx -> set_type, true); + expr -> item.integer = 1 << i; + expr -> item.real = 1 << i; + return expr; +} + static oberon_expr_t * oberon_make_set_range(oberon_context_t * ctx, int64_t x, int64_t y) { @@ -203,8 +226,11 @@ oberon_make_set_range(oberon_context_t * ctx, int64_t x, int64_t y) static oberon_scope_t * oberon_open_scope(oberon_context_t * ctx) { - oberon_scope_t * scope = calloc(1, sizeof *scope); - oberon_object_t * list = calloc(1, sizeof *list); + oberon_scope_t * scope = GC_MALLOC(sizeof *scope); + memset(scope, 0, sizeof *scope); + + oberon_object_t * list = GC_MALLOC(sizeof *list); + memset(list, 0, sizeof *list); scope -> ctx = ctx; scope -> list = list; @@ -263,7 +289,7 @@ oberon_find_object(oberon_scope_t * scope, char * name, bool check_it) 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); + oberon_object_t * newvar = GC_MALLOC(sizeof *newvar); memset(newvar, 0, sizeof *newvar); newvar -> name = name; newvar -> class = class; @@ -305,16 +331,6 @@ oberon_define_object(oberon_scope_t * scope, char * name, int class, bool export return newvar; } -static oberon_object_t * -oberon_define_type(oberon_scope_t * scope, char * name, oberon_type_t * type, int export) -{ - oberon_object_t * id; - id = oberon_define_object(scope, name, OBERON_CLASS_TYPE, export, false, false); - id -> type = type; - oberon_generator_init_type(scope -> ctx, type); - return id; -} - // ======================================================================= // SCANER // ======================================================================= @@ -351,7 +367,7 @@ oberon_read_ident(oberon_context_t * ctx) c = ctx -> code[i]; } - char * ident = malloc(len + 1); + char * ident = GC_MALLOC(len + 1); memcpy(ident, &ctx->code[ctx->code_index], len); ident[len] = 0; @@ -610,7 +626,7 @@ oberon_read_number(oberon_context_t * ctx) } int len = end_i - start_i; - ident = malloc(len + 1); + ident = GC_MALLOC(len + 1); memcpy(ident, &ctx -> code[start_i], len); ident[len] = 0; @@ -720,8 +736,9 @@ static void oberon_read_string(oberon_context_t * ctx) oberon_get_char(ctx); - char * string = calloc(1, end - start + 1); + char * string = GC_MALLOC(end - start + 1); strncpy(string, &ctx -> code[start], end - start); + string[end] = 0; ctx -> token = STRING; ctx -> string = string; @@ -1020,10 +1037,14 @@ oberon_cast_expr(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * p cast = oberon_new_item(MODE_CHAR, ctx -> char_type, true); cast -> item.integer = expr -> item.string[0]; } - else + else if(!oberon_is_some_types(expr -> result, pref)) { cast = oberon_new_operator(OP_CAST, pref, expr, NULL); } + else + { + cast = expr; + } return cast; } @@ -1103,7 +1124,8 @@ oberon_autocast_call(oberon_context_t * ctx, oberon_item_t * desig) { oberon_check_compatible_var_param(ctx, param -> type, arg -> result); } - casted[i] = oberon_cast_expr(ctx, arg, param -> type); + casted[i] = arg; + //casted[i] = oberon_cast_expr(ctx, arg, param -> type); } else { @@ -1227,7 +1249,7 @@ oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr) assert(expr -> is_item); oberon_expr_t * selector; - selector = oberon_new_item(MODE_DEREF, expr -> result -> base, expr -> read_only); + selector = oberon_new_item(MODE_DEREF, expr -> result -> base, false); selector -> item.parent = (oberon_item_t *) expr; return selector; @@ -1558,7 +1580,7 @@ oberon_element(oberon_context_t * ctx) oberon_expr_t * set; if(e2 == NULL && oberon_is_const(e1)) { - set = oberon_make_set(ctx, e1 -> item.integer); + set = oberon_make_set_index(ctx, e1 -> item.integer); } else if(e2 != NULL && oberon_is_const(e1) && oberon_is_const(e2)) { @@ -1937,11 +1959,6 @@ oberon_simple_expr(oberon_context_t * ctx) expr = oberon_term_expr(ctx); - if(minus) - { - expr = oberon_make_unary_op(ctx, MINUS, expr); - } - while(ISADDOP(ctx -> token)) { int token = ctx -> token; @@ -1951,6 +1968,11 @@ oberon_simple_expr(oberon_context_t * ctx) expr = oberon_make_bin_op(ctx, token, expr, inter); } + if(minus) + { + expr = oberon_make_unary_op(ctx, MINUS, expr); + } + return expr; } @@ -2919,9 +2941,10 @@ oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type) oberon_object_t * field = type -> decl; for(int i = 0; i < num_fields; i++) { - oberon_initialize_object(ctx, field); + //oberon_initialize_object(ctx, field); + oberon_initialize_type(ctx, field -> type); field = field -> next; - } + } oberon_generator_init_type(ctx, type); } @@ -3073,7 +3096,8 @@ oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst) oberon_check_dst(ctx, dst); oberon_check_assignment_compatible(ctx, src, dst -> result); - if(oberon_is_string_type(src -> result)) + if(oberon_is_array_of_char_type(dst -> result) + && oberon_is_string_type(src -> result)) { src -> next = dst; oberon_make_copy_call(ctx, 2, src); @@ -3602,57 +3626,6 @@ oberon_parse_module(oberon_context_t * ctx) // LIBRARY // ======================================================================= -static void -register_default_types(oberon_context_t * ctx) -{ - ctx -> notype_type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE); - oberon_generator_init_type(ctx, ctx -> notype_type); - - ctx -> nil_type = oberon_new_type_ptr(OBERON_TYPE_NIL); - oberon_generator_init_type(ctx, ctx -> nil_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); - - ctx -> char_type = oberon_new_type_char(1); - oberon_define_type(ctx -> world_scope, "CHAR", ctx -> char_type, 1); - - ctx -> byte_type = oberon_new_type_integer(1); - oberon_define_type(ctx -> world_scope, "SHORTINT", ctx -> byte_type, 1); - - ctx -> shortint_type = oberon_new_type_integer(2); - oberon_define_type(ctx -> world_scope, "INTEGER", ctx -> shortint_type, 1); - - ctx -> int_type = oberon_new_type_integer(4); - oberon_define_type(ctx -> world_scope, "LONGINT", ctx -> int_type, 1); - - ctx -> longint_type = oberon_new_type_integer(8); - oberon_define_type(ctx -> world_scope, "HUGEINT", ctx -> longint_type, 1); - - ctx -> real_type = oberon_new_type_real(4); - oberon_define_type(ctx -> world_scope, "REAL", ctx -> real_type, 1); - - ctx -> longreal_type = oberon_new_type_real(8); - oberon_define_type(ctx -> world_scope, "LONGREAL", ctx -> longreal_type, 1); - - ctx -> set_type = oberon_new_type_set(4); - oberon_define_type(ctx -> world_scope, "SET", ctx -> set_type, 1); -} - -static void -oberon_new_intrinsic(oberon_context_t * ctx, char * name, GenerateFuncCallback f, GenerateProcCallback p) -{ - oberon_object_t * proc; - proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, true, false, false); - 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 * oberon_make_min_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) { @@ -3669,7 +3642,7 @@ oberon_make_min_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ oberon_expr_t * arg; arg = list_args; - if(!arg -> is_item || arg -> item.mode != MODE_TYPE) + if(!oberon_is_type_expr(arg)) { oberon_error(ctx, "MIN accept only type"); } @@ -3681,6 +3654,15 @@ oberon_make_min_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ case OBERON_TYPE_INTEGER: expr = oberon_make_integer(ctx, -powl(2, bits - 1)); break; + case OBERON_TYPE_BOOLEAN: + expr = oberon_make_boolean(ctx, false); + break; + case OBERON_TYPE_CHAR: + expr = oberon_make_char(ctx, 0); + break; + case OBERON_TYPE_REAL: + expr = oberon_make_real_typed(ctx, (bits <= 32) ? (-FLT_MAX) : (-DBL_MAX), arg -> result); + break; case OBERON_TYPE_SET: expr = oberon_make_integer(ctx, 0); break; @@ -3708,7 +3690,7 @@ oberon_make_max_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ oberon_expr_t * arg; arg = list_args; - if(!arg -> is_item || arg -> item.mode != MODE_TYPE) + if(!oberon_is_type_expr(arg)) { oberon_error(ctx, "MAX accept only type"); } @@ -3720,6 +3702,15 @@ oberon_make_max_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ case OBERON_TYPE_INTEGER: expr = oberon_make_integer(ctx, powl(2, bits - 1) - 1); break; + case OBERON_TYPE_BOOLEAN: + expr = oberon_make_boolean(ctx, true); + break; + case OBERON_TYPE_CHAR: + expr = oberon_make_char(ctx, powl(2, bits) - 1); + break; + case OBERON_TYPE_REAL: + expr = oberon_make_real_typed(ctx, (bits <= 32) ? (FLT_MAX) : (DBL_MAX), arg -> result); + break; case OBERON_TYPE_SET: expr = oberon_make_integer(ctx, bits); break; @@ -3746,8 +3737,7 @@ oberon_make_size_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list oberon_expr_t * arg; arg = list_args; - - if(!arg -> is_item || arg -> item.mode != MODE_TYPE) + if(!oberon_is_type_expr(arg)) { oberon_error(ctx, "SIZE accept only type"); } @@ -3790,19 +3780,158 @@ oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ arg = list_args; oberon_check_src(ctx, arg); - oberon_type_t * result_type; - result_type = arg -> result; - - if(result_type -> class != OBERON_TYPE_INTEGER) + if(oberon_is_number_type(arg -> result)) { - oberon_error(ctx, "ABS accepts only integers"); + oberon_error(ctx, "ABS accepts only numbers"); } oberon_expr_t * expr; - expr = oberon_new_operator(OP_ABS, result_type, arg, NULL); + if(oberon_is_const(arg)) + { + if(oberon_is_real_type(arg -> result)) + { + double x = arg -> item.real; + expr = oberon_make_real(ctx, fabsl(x), arg -> result); + } + else + { + int64_t x = arg -> item.integer; + expr = oberon_make_integer(ctx, llabs(x)); + } + } + else + { + expr = oberon_new_operator(OP_ABS, arg -> result, arg, NULL); + } return expr; } +static void +oberon_make_inc_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 * dst; + dst = list_args; + oberon_check_dst(ctx, dst); + + if(!oberon_is_integer_type(dst -> result)) + { + oberon_error(ctx, "expect integer"); + } + + oberon_expr_t * expr; + expr = oberon_make_bin_op(ctx, PLUS, dst, oberon_make_integer(ctx, 1)); + oberon_assign(ctx, expr, dst); +} + +static void +oberon_make_incl_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 2) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 2) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * dst; + dst = list_args; + oberon_check_dst(ctx, dst); + + if(!oberon_is_set_type(dst -> result)) + { + oberon_error(ctx, "expect integer"); + } + + oberon_expr_t * x; + x = list_args -> next; + oberon_check_src(ctx, x); + + if(!oberon_is_integer_type(x -> result)) + { + oberon_error(ctx, "expect integer"); + } + + oberon_expr_t * expr; + expr = oberon_make_bin_op(ctx, PLUS, dst, oberon_new_operator(OP_RANGE, dst -> result, x, NULL)); + oberon_assign(ctx, expr, dst); +} + +static void +oberon_make_excl_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) +{ + if(num_args < 2) + { + oberon_error(ctx, "too few arguments"); + } + + if(num_args > 2) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * dst; + dst = list_args; + oberon_check_dst(ctx, dst); + + if(!oberon_is_set_type(dst -> result)) + { + oberon_error(ctx, "expect integer"); + } + + oberon_expr_t * x; + x = list_args -> next; + oberon_check_src(ctx, x); + + if(!oberon_is_integer_type(x -> result)) + { + oberon_error(ctx, "expect integer"); + } + + oberon_expr_t * expr; + expr = oberon_make_bin_op(ctx, MINUS, dst, oberon_new_operator(OP_RANGE, dst -> result, x, NULL)); + oberon_assign(ctx, expr, dst); +} + +static void +oberon_make_dec_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 * dst; + dst = list_args; + oberon_check_dst(ctx, dst); + + if(!oberon_is_integer_type(dst -> result)) + { + oberon_error(ctx, "expect integer"); + } + + oberon_expr_t * expr; + expr = oberon_make_bin_op(ctx, MINUS, dst, oberon_make_integer(ctx, 1)); + oberon_assign(ctx, expr, dst); +} + static void oberon_make_new_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) { @@ -3937,7 +4066,7 @@ oberon_make_assert_call(oberon_context_t * ctx, int num_args, oberon_expr_t * li cond = list_args; oberon_check_src(ctx, cond); - if(cond -> result -> class != OBERON_TYPE_BOOLEAN) + if(!oberon_is_boolean_type(cond -> result)) { oberon_error(ctx, "expected boolean"); } @@ -3952,7 +4081,7 @@ oberon_make_assert_call(oberon_context_t * ctx, int num_args, oberon_expr_t * li num = list_args -> next; oberon_check_src(ctx, num); - if(num -> result -> class != OBERON_TYPE_INTEGER) + if(!oberon_is_integer_type(num -> result)) { oberon_error(ctx, "expected integer"); } @@ -3990,45 +4119,510 @@ oberon_make_halt_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list oberon_generate_halt(ctx, num -> item.integer); } -static void -oberon_new_const(oberon_context_t * ctx, char * name, oberon_expr_t * expr) -{ - oberon_object_t * constant; - constant = oberon_define_object(ctx -> decl, name, OBERON_CLASS_CONST, true, false, false); - oberon_check_const(ctx, expr); - constant -> value = (oberon_item_t *) expr; -} - -oberon_context_t * -oberon_create_context(ModuleImportCallback import_module) +static oberon_expr_t * +oberon_make_ash_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args) { - oberon_context_t * ctx = calloc(1, sizeof *ctx); + if(num_args < 2) + { + oberon_error(ctx, "too few arguments"); + } - oberon_scope_t * world_scope; - world_scope = oberon_open_scope(ctx); - ctx -> world_scope = world_scope; + if(num_args > 2) + { + oberon_error(ctx, "too mach arguments"); + } - ctx -> import_module = import_module; + oberon_expr_t * arg1; + arg1 = list_args; + oberon_check_src(ctx, arg1); + if(arg1 -> result -> class != OBERON_TYPE_INTEGER) + { + oberon_error(ctx, "expected integer"); + } - oberon_generator_init_context(ctx); + oberon_expr_t * arg2; + arg2 = list_args -> next; + oberon_check_src(ctx, arg2); + if(arg2 -> result -> class != OBERON_TYPE_INTEGER) + { + oberon_error(ctx, "expected integer"); + } - register_default_types(ctx); + oberon_expr_t * expr; + if(oberon_is_const(arg1) && oberon_is_const(arg2)) + { + int64_t x = arg1 -> item.integer; + int64_t y = arg2 -> item.integer; + expr = oberon_make_integer(ctx, x * powl(2, y)); + } + else + { + expr = oberon_new_operator(OP_ASH, arg1 -> result, arg1, arg2); + } - /* Constants */ - oberon_new_const(ctx, "TRUE", oberon_make_boolean(ctx, true)); - oberon_new_const(ctx, "FALSE", oberon_make_boolean(ctx, false)); + return expr; +} - /* Functions */ - oberon_new_intrinsic(ctx, "ABS", oberon_make_abs_call, NULL); - oberon_new_intrinsic(ctx, "MIN", oberon_make_min_call, NULL); - oberon_new_intrinsic(ctx, "MAX", oberon_make_max_call, NULL); - oberon_new_intrinsic(ctx, "SIZE", oberon_make_size_call, NULL); +static oberon_expr_t * +oberon_make_cap_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_check_src(ctx, arg); + + if(!oberon_is_char_type(arg -> result)) + { + oberon_error(ctx, "expected char"); + } + + oberon_expr_t * expr; + if(oberon_is_const(arg)) + { + expr = oberon_make_char(ctx, toupper(arg -> item.integer)); + } + else + { + expr = oberon_new_operator(OP_CAP, arg -> result, arg, NULL); + } + + return expr; +} + +static oberon_expr_t * +oberon_make_chr_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_check_src(ctx, arg); + + if(!oberon_is_integer_type(arg -> result)) + { + oberon_error(ctx, "expected integer"); + } + + oberon_expr_t * expr; + if(oberon_is_const(arg)) + { + expr = oberon_make_char(ctx, arg -> item.integer); + } + else + { + expr = oberon_cast_expr(ctx, arg, ctx -> char_type); + } + return expr; +} + +static oberon_expr_t * +oberon_make_ord_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_check_src(ctx, arg); + + if(!oberon_is_char_type(arg -> result)) + { + oberon_error(ctx, "expected char"); + } + + oberon_expr_t * expr; + if(oberon_is_const(arg)) + { + expr = oberon_make_integer(ctx, arg -> item.integer); + } + else + { + expr = oberon_cast_expr(ctx, arg, ctx -> int_type); + } + return expr; +} + +static oberon_expr_t * +oberon_make_entier_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_check_src(ctx, arg); + + if(!oberon_is_real_type(arg -> result)) + { + oberon_error(ctx, "expected real"); + } + + oberon_expr_t * expr; + if(oberon_is_const(arg)) + { + expr = oberon_make_integer(ctx, floor(arg -> item.real)); + } + else + { + expr = oberon_new_operator(OP_ENTIER, ctx -> int_type, arg, NULL); + } + return expr; +} + +static oberon_expr_t * +oberon_make_odd_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_check_src(ctx, arg); + + if(!oberon_is_integer_type(arg -> result)) + { + oberon_error(ctx, "expected integer"); + } + + oberon_expr_t * expr; + expr = oberon_make_bin_op(ctx, MOD, arg, oberon_make_integer(ctx, 2)); + expr = oberon_make_bin_op(ctx, EQUAL, expr, oberon_make_integer(ctx, 1)); + return expr; +} + +static oberon_expr_t * +oberon_make_short_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_check_src(ctx, arg); + + if(arg -> result -> shorter == NULL) + { + oberon_error(ctx, "already shorter"); + } + + oberon_expr_t * expr; + expr = oberon_cast_expr(ctx, arg, arg -> result -> shorter); + return expr; +} + +static oberon_expr_t * +oberon_make_long_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_check_src(ctx, arg); + + if(arg -> result -> longer == NULL) + { + oberon_error(ctx, "already longer"); + } + + oberon_expr_t * expr; + expr = oberon_cast_expr(ctx, arg, arg -> result -> longer); + return expr; +} + +static oberon_expr_t * +oberon_make_len_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 > 2) + { + oberon_error(ctx, "too mach arguments"); + } + + oberon_expr_t * v; + v = list_args; + oberon_check_src(ctx, v); + + if(!oberon_is_array_type(v -> result)) + { + oberon_error(ctx, "expected array"); + } + + int n = 0; + if(num_args == 2) + { + oberon_expr_t * num; + num = list_args -> next; + oberon_check_src(ctx, num); + + if(!oberon_is_integer_type(num -> result)) + { + oberon_error(ctx, "expected integer"); + } + oberon_check_const(ctx, num); + + n = num -> item.integer; + } + + int dim = 0; + oberon_type_t * arr = v -> result; + while(arr -> class == OBERON_TYPE_ARRAY) + { + dim += 1; + arr = arr -> base; + } + + if(n < 0 || n > dim) + { + oberon_error(ctx, "not in range 0..%i", dim - 1); + } + + assert(v -> is_item); + + oberon_expr_t * expr; + expr = oberon_new_item(MODE_LEN, ctx -> int_type, true); + expr -> item.parent = (oberon_item_t *) v; + expr -> item.integer = n; + return expr; +} + +static void +oberon_new_const(oberon_context_t * ctx, char * name, oberon_expr_t * expr) +{ + oberon_object_t * constant; + constant = oberon_define_object(ctx -> decl, name, OBERON_CLASS_CONST, true, false, false); + oberon_check_const(ctx, expr); + constant -> value = (oberon_item_t *) expr; +} + +static void +register_default_types(oberon_context_t * ctx) +{ + ctx -> notype_type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE); + oberon_generator_init_type(ctx, ctx -> notype_type); + + ctx -> nil_type = oberon_new_type_ptr(OBERON_TYPE_NIL); + oberon_generator_init_type(ctx, ctx -> nil_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_generator_init_type(ctx, ctx -> bool_type); + + ctx -> char_type = oberon_new_type_char(1); + oberon_generator_init_type(ctx, ctx -> char_type); + + ctx -> byte_type = oberon_new_type_integer(1); + oberon_generator_init_type(ctx, ctx -> byte_type); + + ctx -> shortint_type = oberon_new_type_integer(2); + oberon_generator_init_type(ctx, ctx -> shortint_type); + + ctx -> int_type = oberon_new_type_integer(4); + oberon_generator_init_type(ctx, ctx -> int_type); + + ctx -> longint_type = oberon_new_type_integer(8); + oberon_generator_init_type(ctx, ctx -> longint_type); + + ctx -> real_type = oberon_new_type_real(4); + oberon_generator_init_type(ctx, ctx -> real_type); + + ctx -> longreal_type = oberon_new_type_real(8); + oberon_generator_init_type(ctx, ctx -> longreal_type); + + ctx -> set_type = oberon_new_type_set(4); + oberon_generator_init_type(ctx, ctx -> set_type); + + ctx -> system_byte_type = oberon_new_type_ptr(OBERON_TYPE_SYSTEM_BYTE); + oberon_generator_init_type(ctx, ctx -> system_byte_type); + + /* LONG / SHORT support */ + ctx -> byte_type -> shorter = NULL; + ctx -> byte_type -> longer = ctx -> shortint_type; + + ctx -> shortint_type -> shorter = ctx -> byte_type; + ctx -> shortint_type -> longer = ctx -> int_type; + + ctx -> int_type -> shorter = ctx -> shortint_type; + ctx -> int_type -> longer = ctx -> longint_type; + + ctx -> longint_type -> shorter = ctx -> int_type; + ctx -> longint_type -> longer = NULL; + + ctx -> real_type -> shorter = NULL; + ctx -> real_type -> longer = ctx -> longreal_type; + + ctx -> longreal_type -> shorter = ctx -> real_type; + ctx -> longreal_type -> longer = NULL; +} + +static void +oberon_new_intrinsic(oberon_context_t * ctx, char * name, GenerateFuncCallback f, GenerateProcCallback p) +{ + oberon_object_t * proc; + proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, true, false, false); + proc -> type = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE); + proc -> type -> sysproc = true; + proc -> type -> genfunc = f; + proc -> type -> genproc = p; +} + +static void oberon_new_intrinsic_type(oberon_context_t * ctx, char * name, oberon_type_t * type) +{ + oberon_object_t * id; + id = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, true, false, false); + id -> type = type; +} + +static void +oberon_begin_intrinsic_module(oberon_context_t * ctx, char * name, oberon_module_t ** m) +{ + oberon_scope_t * module_scope; + module_scope = oberon_open_scope(ctx); + + oberon_module_t * module; + module = GC_MALLOC(sizeof *module); + memset(module, 0, sizeof *module); + module -> name = name; + module -> intrinsic = true; + module -> decl = module_scope; + module -> next = ctx -> module_list; + + ctx -> mod = module; + ctx -> module_list = module; + + *m = module; +} + +static void +oberon_end_intrinsic_module(oberon_context_t * ctx, oberon_module_t * m) +{ + oberon_close_scope(m -> decl); + m -> ready = true; + ctx -> mod = NULL; +} + +oberon_context_t * +oberon_create_context(ModuleImportCallback import_module) +{ + oberon_context_t * ctx = GC_MALLOC(sizeof *ctx); + memset(ctx, 0, sizeof *ctx); + + oberon_scope_t * world_scope; + world_scope = oberon_open_scope(ctx); + ctx -> world_scope = world_scope; + + ctx -> import_module = import_module; + + oberon_generator_init_context(ctx); + + /* Types */ + register_default_types(ctx); + + /* Constants */ + oberon_new_const(ctx, "TRUE", oberon_make_boolean(ctx, true)); + oberon_new_const(ctx, "FALSE", oberon_make_boolean(ctx, false)); + + /* Types */ + oberon_new_intrinsic_type(ctx, "BOOLEAN", ctx -> bool_type); + oberon_new_intrinsic_type(ctx, "CHAR", ctx -> char_type); + oberon_new_intrinsic_type(ctx, "SHORTINT", ctx -> byte_type); + oberon_new_intrinsic_type(ctx, "INTEGER", ctx -> shortint_type); + oberon_new_intrinsic_type(ctx, "LONGINT", ctx -> int_type); + oberon_new_intrinsic_type(ctx, "HUGEINT", ctx -> longint_type); + oberon_new_intrinsic_type(ctx, "REAL", ctx -> real_type); + oberon_new_intrinsic_type(ctx, "LONGREAL", ctx -> longreal_type); + oberon_new_intrinsic_type(ctx, "SET", ctx -> set_type); + + /* Functions */ + oberon_new_intrinsic(ctx, "ABS", oberon_make_abs_call, NULL); + oberon_new_intrinsic(ctx, "ASH", oberon_make_ash_call, NULL); + oberon_new_intrinsic(ctx, "CAP", oberon_make_cap_call, NULL); + oberon_new_intrinsic(ctx, "CHR", oberon_make_chr_call, NULL); + oberon_new_intrinsic(ctx, "ENTIER", oberon_make_entier_call, NULL); + oberon_new_intrinsic(ctx, "LEN", oberon_make_len_call, NULL); + oberon_new_intrinsic(ctx, "LONG", oberon_make_long_call, NULL); + oberon_new_intrinsic(ctx, "MAX", oberon_make_max_call, NULL); + oberon_new_intrinsic(ctx, "MIN", oberon_make_min_call, NULL); + oberon_new_intrinsic(ctx, "ODD", oberon_make_odd_call, NULL); + oberon_new_intrinsic(ctx, "ORD", oberon_make_ord_call, NULL); + oberon_new_intrinsic(ctx, "SHORT", oberon_make_short_call, NULL); + oberon_new_intrinsic(ctx, "SIZE", oberon_make_size_call, NULL); /* Procedures */ - oberon_new_intrinsic(ctx, "NEW", NULL, oberon_make_new_call); - oberon_new_intrinsic(ctx, "COPY", NULL, oberon_make_copy_call); oberon_new_intrinsic(ctx, "ASSERT", NULL, oberon_make_assert_call); + oberon_new_intrinsic(ctx, "COPY", NULL, oberon_make_copy_call); + oberon_new_intrinsic(ctx, "DEC", NULL, oberon_make_dec_call); + oberon_new_intrinsic(ctx, "EXCL", NULL, oberon_make_excl_call); oberon_new_intrinsic(ctx, "HALT", NULL, oberon_make_halt_call); + oberon_new_intrinsic(ctx, "INC", NULL, oberon_make_inc_call); + oberon_new_intrinsic(ctx, "INCL", NULL, oberon_make_incl_call); + oberon_new_intrinsic(ctx, "NEW", NULL, oberon_make_new_call); + + /* MODULE SYSTEM */ + oberon_begin_intrinsic_module(ctx, "SYSTEM", &ctx -> system_module); + + /* Types */ + oberon_new_intrinsic_type(ctx, "BYTE", ctx -> system_byte_type); + + oberon_end_intrinsic_module(ctx, ctx -> system_module); return ctx; } @@ -4037,7 +4631,6 @@ void oberon_destroy_context(oberon_context_t * ctx) { oberon_generator_destroy_context(ctx); - free(ctx); } oberon_module_t * @@ -4058,7 +4651,8 @@ oberon_compile_module(oberon_context_t * ctx, const char * newcode) module_scope = oberon_open_scope(ctx); oberon_module_t * module; - module = calloc(1, sizeof *module); + module = GC_MALLOC(sizeof *module); + memset(module, 0, sizeof *module); module -> decl = module_scope; module -> next = ctx -> module_list;