From 2985d77f3ee4af98761b28b4ce1e57582d8c8619 Mon Sep 17 00:00:00 2001 From: DeaDDooMER Date: Sun, 13 Aug 2017 14:17:02 +0300 Subject: [PATCH] =?utf8?q?=D0=94=D0=BE=D0=B1=D0=B0=D0=B2=D0=BB=D0=B5=D0=BD?= =?utf8?q?=D1=8B=20=D1=84=D1=83=D0=BD=D0=BA=D1=86=D0=B8=D0=B8=20LONG=20?= =?utf8?q?=D0=B8=20SHORT?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- Test.obn | 14 +--- notes | 1 - src/oberon-internals.h | 2 + src/oberon.c | 180 +++++++++++++++++++++++++++++------------ 4 files changed, 131 insertions(+), 66 deletions(-) diff --git a/Test.obn b/Test.obn index da1f545..82fbedb 100644 --- a/Test.obn +++ b/Test.obn @@ -1,19 +1,9 @@ MODULE Test; VAR - i : INTEGER; + i : SHORTINT; s : SET; BEGIN - INC(i); - ASSERT(i = 1); - DEC(i); - ASSERT(i = 0); - - INCL(s, 3); - ASSERT(3 IN s); - EXCL(s, 3); - ASSERT(~(3 IN s)); + i := SHORT(12345); END Test. - -Проверка встроенных процедур. diff --git a/notes b/notes index 21447a4..45bb85f 100644 --- a/notes +++ b/notes @@ -1,7 +1,6 @@ - Сделать проверку повторов в CASE. - Сделать нормальную проверку наличия RETURN. -- Нет функций LONG SHORT - Нет счёта строк / столбцов - Нет процедур привязанных к типм diff --git a/src/oberon-internals.h b/src/oberon-internals.h index 31c8054..703ba6c 100644 --- a/src/oberon-internals.h +++ b/src/oberon-internals.h @@ -57,6 +57,8 @@ struct oberon_type_t { enum oberon_type_kind class; int size; + oberon_type_t * shorter; + oberon_type_t * longer; int num_decl; oberon_type_t * base; diff --git a/src/oberon.c b/src/oberon.c index 1d00f22..8b94271 100644 --- a/src/oberon.c +++ b/src/oberon.c @@ -3624,57 +3624,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) { @@ -4377,6 +4326,60 @@ 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) { @@ -4446,6 +4449,77 @@ 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) { @@ -4472,12 +4546,12 @@ oberon_create_context(ModuleImportCallback import_module) 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, "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, "SHORT", oberon_make_short_call, NULL); oberon_new_intrinsic(ctx, "SIZE", oberon_make_size_call, NULL); /* Procedures */ -- 2.29.2