X-Git-Url: http://deadsoftware.ru/gitweb?p=dsw-obn.git;a=blobdiff_plain;f=src%2Foberon.c;h=0fff8d7ba4c791846d662f1a6e728c6b2fbfe883;hp=08543355c92b9e421854e751081df3e6827c8d17;hb=023ef0d8349acdfe751bba1b50749361682f72ff;hpb=95acec6c3ae8d3c324c84b001a680aa49320790b diff --git a/src/oberon.c b/src/oberon.c index 0854335..0fff8d7 100644 --- a/src/oberon.c +++ b/src/oberon.c @@ -8,6 +8,8 @@ #include #include +#include + #include "../include/oberon.h" #include "oberon-internals.h" @@ -25,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; @@ -88,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; @@ -105,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; @@ -197,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) { @@ -214,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; @@ -274,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; @@ -362,7 +377,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; @@ -621,7 +636,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; @@ -731,8 +746,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; @@ -1238,7 +1254,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; @@ -1569,7 +1585,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)) { @@ -1948,11 +1964,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; @@ -1962,6 +1973,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; } @@ -2930,9 +2946,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); } @@ -3614,57 +3631,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) { @@ -3845,6 +3811,132 @@ oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ 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) { @@ -4111,6 +4203,108 @@ oberon_make_cap_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ 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) { @@ -4139,6 +4333,120 @@ oberon_make_odd_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ 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) { @@ -4148,10 +4456,82 @@ oberon_new_const(oberon_context_t * ctx, char * name, oberon_expr_t * 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_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); + + + + 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; +} + oberon_context_t * oberon_create_context(ModuleImportCallback import_module) { - oberon_context_t * ctx = calloc(1, sizeof *ctx); + oberon_context_t * ctx = GC_MALLOC(sizeof *ctx); + memset(ctx, 0, sizeof *ctx); oberon_scope_t * world_scope; world_scope = oberon_open_scope(ctx); @@ -4171,16 +4551,26 @@ oberon_create_context(ModuleImportCallback import_module) 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, "MIN", oberon_make_min_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); return ctx; } @@ -4189,7 +4579,6 @@ void oberon_destroy_context(oberon_context_t * ctx) { oberon_generator_destroy_context(ctx); - free(ctx); } oberon_module_t * @@ -4210,7 +4599,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;