From 776edd758b261bd4f7c5c7cd758edef40e8b4f64 Mon Sep 17 00:00:00 2001 From: DeaDDooMER Date: Wed, 9 Aug 2017 21:11:58 +0300 Subject: [PATCH 01/16] =?utf8?q?=D0=98=D0=B7=D0=BC=D0=B5=D0=BD=D0=B5=D0=BD?= =?utf8?q?=D1=8B=20=D1=80=D0=B0=D0=B7=D0=BC=D0=B5=D1=80=D1=8B=20=D0=BF?= =?utf8?q?=D1=80=D0=B8=D0=BC=D0=B8=D1=82=D0=B8=D0=B2=D0=BD=D1=8B=D1=85=20?= =?utf8?q?=D1=82=D0=B8=D0=BF=D0=BE=D0=B2?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- Out.obn | 2 +- rtl/Out.java | 6 +++--- rtl/System.java | 2 +- src/oberon.c | 14 +++++++------- 4 files changed, 12 insertions(+), 12 deletions(-) diff --git a/Out.obn b/Out.obn index dce767c..9a923c2 100644 --- a/Out.obn +++ b/Out.obn @@ -9,7 +9,7 @@ END Char; PROCEDURE String*(str : ARRAY OF CHAR); END String; -PROCEDURE Int*(i, n : LONGINT); +PROCEDURE Int*(i : HUGEINT; n : INTEGER); END Int; PROCEDURE Real*(x : REAL; n : INTEGER); diff --git a/rtl/Out.java b/rtl/Out.java index 429d321..9989977 100644 --- a/rtl/Out.java +++ b/rtl/Out.java @@ -22,17 +22,17 @@ public class Out System.out.write(str, 0, i); } - public static void Int(long i, long n) + public static void Int(long i, short n) { System.out.print(i); } - public static void Real(float x, int n) + public static void Real(float x, short n) { System.out.print(x); } - public static void LongReal(double x, int n) + public static void LongReal(double x, short n) { System.out.print(x); } diff --git a/rtl/System.java b/rtl/System.java index 08411e7..d2ccf9b 100644 --- a/rtl/System.java +++ b/rtl/System.java @@ -1,6 +1,6 @@ public class System { - public static void Halt(int n) + public static void Halt(short n) { java.lang.System.exit(n); } diff --git a/src/oberon.c b/src/oberon.c index cf1a570..bf5dad8 100644 --- a/src/oberon.c +++ b/src/oberon.c @@ -3751,17 +3751,20 @@ register_default_types(oberon_context_t * ctx) 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, "BYTE", ctx -> byte_type, 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, "SHORTINT", ctx -> shortint_type, 1); + 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, "INTEGER", ctx -> int_type, 1); + 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, "LONGINT", ctx -> longint_type, 1); + 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); @@ -3769,9 +3772,6 @@ 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); - ctx -> set_type = oberon_new_type_set(4); oberon_define_type(ctx -> world_scope, "SET", ctx -> set_type, 1); } -- 2.29.2 From a0ff807fe0e69c50469e506836467da32f23f754 Mon Sep 17 00:00:00 2001 From: DeaDDooMER Date: Wed, 9 Aug 2017 21:44:46 +0300 Subject: [PATCH 02/16] =?utf8?q?=D0=98=D1=81=D0=BF=D1=80=D0=B0=D0=B2=D0=BB?= =?utf8?q?=D0=B5=D0=BD=D0=BE=20=D0=BF=D1=80=D0=B8=D1=81=D0=B2=D0=B0=D0=B8?= =?utf8?q?=D0=B2=D0=B0=D0=BD=D0=B8=D0=B5=20NIL?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- Test.obn | 19 +++---- Test4.obn | 12 +++++ obn-run-tests.sh | 1 + src/backends/jvm/generator-jvm-basic.c | 6 ++- src/backends/jvm/generator-jvm.c | 14 ++++-- src/oberon-internals.h | 9 ++-- src/oberon.c | 70 +++++++++++++++----------- 7 files changed, 79 insertions(+), 52 deletions(-) create mode 100644 Test4.obn diff --git a/Test.obn b/Test.obn index f4deacc..98ac0e2 100644 --- a/Test.obn +++ b/Test.obn @@ -1,17 +1,12 @@ MODULE Test; -IMPORT - Out, - System; - -TYPE - RBase = RECORD END; - R = RECORD (RBase) END; +VAR + a : POINTER TO RECORD END; + b : POINTER TO ARRAY OF INTEGER; + c : PROCEDURE; BEGIN - Out.Open; - IF FALSE THEN - Out.String("Hello World!"); Out.Ln; - END; - System.Halt(1); + a := NIL; + b := NIL; + c := NIL; END Test. diff --git a/Test4.obn b/Test4.obn new file mode 100644 index 0000000..132f864 --- /dev/null +++ b/Test4.obn @@ -0,0 +1,12 @@ +MODULE Test4; + +VAR + a : POINTER TO RECORD END; + b : POINTER TO ARRAY OF INTEGER; + c : PROCEDURE; + +BEGIN + a := NIL; + b := NIL; + c := NIL; +END Test4. diff --git a/obn-run-tests.sh b/obn-run-tests.sh index 6017f7e..c665472 100755 --- a/obn-run-tests.sh +++ b/obn-run-tests.sh @@ -30,3 +30,4 @@ compile_false_positive() maketest Test1 maketest Test2 maketest Test3 +maketest Test4 diff --git a/src/backends/jvm/generator-jvm-basic.c b/src/backends/jvm/generator-jvm-basic.c index fac9e0b..9c8b78c 100644 --- a/src/backends/jvm/generator-jvm-basic.c +++ b/src/backends/jvm/generator-jvm-basic.c @@ -53,7 +53,7 @@ jvm_get_descriptor(oberon_type_t * type) switch(type -> class) { - case OBERON_TYPE_VOID: + case OBERON_TYPE_NOTYPE: return new_string("V"); break; case OBERON_TYPE_INTEGER: @@ -194,6 +194,7 @@ jvm_get_prefix(oberon_type_t * type) case OBERON_TYPE_RECORD: case OBERON_TYPE_POINTER: case OBERON_TYPE_STRING: + case OBERON_TYPE_NIL: return 'a'; break; case OBERON_TYPE_REAL: @@ -261,6 +262,7 @@ jvm_get_postfix(oberon_type_t * type) case OBERON_TYPE_RECORD: case OBERON_TYPE_POINTER: case OBERON_TYPE_STRING: + case OBERON_TYPE_NIL: return 'a'; break; case OBERON_TYPE_REAL: @@ -397,7 +399,7 @@ jvm_cell_size_for_type(oberon_type_t * type) return 2; } } - else if(type -> class == OBERON_TYPE_VOID) + else if(type -> class == OBERON_TYPE_NOTYPE) { return 0; } diff --git a/src/backends/jvm/generator-jvm.c b/src/backends/jvm/generator-jvm.c index 9d5e1f4..90b0e88 100644 --- a/src/backends/jvm/generator-jvm.c +++ b/src/backends/jvm/generator-jvm.c @@ -424,7 +424,7 @@ oberon_generate_procedure_pointer_class(oberon_object_t * proc) int cell_size = jvm_cell_size_for_type(proc -> type -> base); jvm_generate(p, use_size, cell_size, "invokestatic %s%s", full_name, signature); - if(proc -> type -> base -> class == OBERON_TYPE_VOID) + if(proc -> type -> base -> class == OBERON_TYPE_NOTYPE) { jvm_generate(p, 0, 0, "return"); } @@ -475,18 +475,23 @@ oberon_generator_init_type(oberon_context_t * ctx, oberon_type_t * type) memset(t, 0, sizeof *t); type -> gen_type = t; - if(type -> class != OBERON_TYPE_VOID) + if(type -> class != OBERON_TYPE_NOTYPE) { t -> wide = jvm_is_wide_type(type); t -> prefix = jvm_get_prefix(type); t -> postfix = jvm_get_postfix(type); } + t -> cell_size = jvm_cell_size_for_type(type); - t -> desc = jvm_get_descriptor(type); + + if(type -> class != OBERON_TYPE_NIL) + { + t -> desc = jvm_get_descriptor(type); + } switch(type -> class) { - case OBERON_TYPE_VOID: + case OBERON_TYPE_NOTYPE: case OBERON_TYPE_INTEGER: case OBERON_TYPE_BOOLEAN: case OBERON_TYPE_ARRAY: @@ -495,6 +500,7 @@ oberon_generator_init_type(oberon_context_t * ctx, oberon_type_t * type) case OBERON_TYPE_CHAR: case OBERON_TYPE_STRING: case OBERON_TYPE_SET: + case OBERON_TYPE_NIL: break; case OBERON_TYPE_RECORD: ; diff --git a/src/oberon-internals.h b/src/oberon-internals.h index fa9b5d5..3c6fb85 100644 --- a/src/oberon-internals.h +++ b/src/oberon-internals.h @@ -36,7 +36,7 @@ struct oberon_scope_t enum oberon_type_kind { - OBERON_TYPE_VOID, + OBERON_TYPE_NOTYPE, OBERON_TYPE_INTEGER, OBERON_TYPE_BOOLEAN, OBERON_TYPE_PROCEDURE, @@ -46,7 +46,8 @@ enum oberon_type_kind OBERON_TYPE_REAL, OBERON_TYPE_CHAR, OBERON_TYPE_STRING, - OBERON_TYPE_SET + OBERON_TYPE_SET, + OBERON_TYPE_NIL }; typedef oberon_expr_t * (*GenerateFuncCallback)(oberon_context_t *, int, oberon_expr_t *); @@ -145,8 +146,8 @@ struct oberon_context_t oberon_module_t * mod; /*** END PARSER DATA ***/ - oberon_type_t * void_type; - oberon_type_t * void_ptr_type; + oberon_type_t * notype_type; + oberon_type_t * nil_type; oberon_type_t * bool_type; oberon_type_t * byte_type; oberon_type_t * shortint_type; diff --git a/src/oberon.c b/src/oberon.c index bf5dad8..5a93489 100644 --- a/src/oberon.c +++ b/src/oberon.c @@ -1094,15 +1094,25 @@ oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * // Допускается: // Если классы типов равны // Если INTEGER переводится в REAL - // Есди STRING переводится в CHAR - // Есди STRING переводится в ARRAY OF CHAR + // Если STRING переводится в CHAR + // Если STRING переводится в ARRAY OF CHAR + // Если NIL переводится в POINTER + // Если NIL переводится в PROCEDURE oberon_check_src(ctx, expr); bool error = false; if(pref -> class != expr -> result -> class) { - if(expr -> result -> class == OBERON_TYPE_STRING) + if(expr -> result -> class == OBERON_TYPE_NIL) + { + if(pref -> class != OBERON_TYPE_POINTER + && pref -> class != OBERON_TYPE_PROCEDURE) + { + error = true; + } + } + else if(expr -> result -> class == OBERON_TYPE_STRING) { if(pref -> class == OBERON_TYPE_CHAR) { @@ -1176,17 +1186,18 @@ oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * else if(pref -> class == OBERON_TYPE_POINTER) { assert(pref -> base); - if(expr -> result -> base -> class == OBERON_TYPE_RECORD) + if(expr -> result -> class == OBERON_TYPE_NIL) + { + // do nothing + } + else 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) - { - oberon_error(ctx, "incompatible pointer types"); - } + oberon_error(ctx, "incompatible pointer types"); } } @@ -1285,7 +1296,7 @@ oberon_make_call_func(oberon_context_t * ctx, oberon_item_t * item, int num_args } else { - if(signature -> base -> class == OBERON_TYPE_VOID) + if(signature -> base -> class == OBERON_TYPE_NOTYPE) { oberon_error(ctx, "attempt to call procedure in expression"); } @@ -1322,7 +1333,7 @@ oberon_make_call_proc(oberon_context_t * ctx, oberon_item_t * item, int num_args } else { - if(signature -> base -> class != OBERON_TYPE_VOID) + if(signature -> base -> class != OBERON_TYPE_NOTYPE) { oberon_error(ctx, "attempt to call function as non-typed procedure"); } @@ -1807,7 +1818,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, true); + expr = oberon_new_item(MODE_NIL, ctx -> nil_type, true); break; default: oberon_error(ctx, "invalid expression"); @@ -2262,7 +2273,7 @@ oberon_var_decl(oberon_context_t * ctx) int num; oberon_object_t * list; oberon_type_t * type; - type = oberon_new_type_ptr(OBERON_TYPE_VOID); + type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE); oberon_ident_list(ctx, OBERON_CLASS_VAR, false, &num, &list); oberon_assert_token(ctx, COLON); @@ -2293,7 +2304,7 @@ oberon_fp_section(oberon_context_t * ctx, int * num_decl) oberon_assert_token(ctx, COLON); oberon_type_t * type; - type = oberon_new_type_ptr(OBERON_TYPE_VOID); + type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE); oberon_type(ctx, &type); oberon_object_t * param = list; @@ -2348,7 +2359,7 @@ oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type) signature = *type; signature -> class = OBERON_TYPE_PROCEDURE; signature -> num_decl = 0; - signature -> base = ctx -> void_type; + signature -> base = ctx -> notype_type; signature -> decl = NULL; if(ctx -> token == LPAREN) @@ -2391,7 +2402,7 @@ 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(result_type -> class == OBERON_TYPE_NOTYPE) { if(expr != NULL) { @@ -2437,7 +2448,7 @@ oberon_proc_decl_body(oberon_context_t * ctx, oberon_object_t * proc) oberon_error(ctx, "procedure name not matched"); } - if(proc -> type -> base -> class == OBERON_TYPE_VOID + if(proc -> type -> base -> class == OBERON_TYPE_NOTYPE && proc -> has_return == 0) { oberon_make_return(ctx, NULL); @@ -2475,7 +2486,7 @@ oberon_proc_decl(oberon_context_t * ctx) ctx -> decl -> local = 1; oberon_type_t * signature; - signature = oberon_new_type_ptr(OBERON_TYPE_VOID); + signature = oberon_new_type_ptr(OBERON_TYPE_NOTYPE); oberon_opt_formal_pars(ctx, &signature); //oberon_initialize_decl(ctx); @@ -2582,7 +2593,7 @@ oberon_qualident_type(oberon_context_t * ctx, oberon_type_t ** type) else { to = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, false, false, false); - to -> type = oberon_new_type_ptr(OBERON_TYPE_VOID); + to -> type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE); } *type = to -> type; @@ -2604,7 +2615,7 @@ oberon_make_multiarray(oberon_context_t * ctx, oberon_expr_t * sizes, oberon_typ } oberon_type_t * dim; - dim = oberon_new_type_ptr(OBERON_TYPE_VOID); + dim = oberon_new_type_ptr(OBERON_TYPE_NOTYPE); oberon_make_multiarray(ctx, sizes -> next, base, &dim); @@ -2627,7 +2638,7 @@ oberon_field_list(oberon_context_t * ctx, oberon_type_t * rec, oberon_scope_t * int num; oberon_object_t * list; oberon_type_t * type; - type = oberon_new_type_ptr(OBERON_TYPE_VOID); + type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE); oberon_ident_list(ctx, OBERON_CLASS_FIELD, true, &num, &list); oberon_assert_token(ctx, COLON); @@ -2728,7 +2739,7 @@ oberon_type(oberon_context_t * ctx, oberon_type_t ** type) oberon_assert_token(ctx, OF); oberon_type_t * base; - base = oberon_new_type_ptr(OBERON_TYPE_VOID); + base = oberon_new_type_ptr(OBERON_TYPE_NOTYPE); oberon_type(ctx, &base); if(num_sizes == 0) @@ -2759,7 +2770,7 @@ oberon_type(oberon_context_t * ctx, oberon_type_t ** type) oberon_assert_token(ctx, TO); oberon_type_t * base; - base = oberon_new_type_ptr(OBERON_TYPE_VOID); + base = oberon_new_type_ptr(OBERON_TYPE_NOTYPE); oberon_type(ctx, &base); oberon_type_t * ptr; @@ -2796,7 +2807,7 @@ oberon_type_decl(oberon_context_t * ctx) if(newtype == NULL) { newtype = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, export, read_only, false); - newtype -> type = oberon_new_type_ptr(OBERON_TYPE_VOID); + newtype -> type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE); assert(newtype -> type); } else @@ -2820,7 +2831,7 @@ oberon_type_decl(oberon_context_t * ctx) type = newtype -> type; oberon_type(ctx, &type); - if(type -> class == OBERON_TYPE_VOID) + if(type -> class == OBERON_TYPE_NOTYPE) { oberon_error(ctx, "recursive alias declaration"); } @@ -3020,7 +3031,7 @@ oberon_initialize_record_fields(oberon_context_t * ctx, oberon_type_t * type) static void oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type) { - if(type -> class == OBERON_TYPE_VOID) + if(type -> class == OBERON_TYPE_NOTYPE) { oberon_error(ctx, "undeclarated type"); } @@ -3738,12 +3749,11 @@ oberon_parse_module(oberon_context_t * ctx) 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 -> notype_type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE); + oberon_generator_init_type(ctx, ctx -> notype_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 -> 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); -- 2.29.2 From 9e17ac5ff506785891f06e3beeba66185fc7f867 Mon Sep 17 00:00:00 2001 From: DeaDDooMER Date: Thu, 10 Aug 2017 13:16:27 +0300 Subject: [PATCH 03/16] =?utf8?q?=D0=98=D1=81=D0=BF=D1=80=D0=B0=D0=B2=D0=BB?= =?utf8?q?=D0=B5=D0=BD=D0=B0=20=D0=B8=D0=BD=D0=B8=D1=86=D0=B8=D0=B0=D0=BB?= =?utf8?q?=D0=B8=D0=B7=D0=B0=D1=86=D0=B8=D1=8F=20=D0=B7=D0=B0=D0=BF=D0=B8?= =?utf8?q?=D1=81=D0=B5=D0=B9?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- Test.obn | 17 +++++++++++------ Test4.obn | 2 ++ notes | 3 +++ obn-dev-test.sh | 1 + src/backends/jvm/generator-jvm.c | 31 +++++++++++++++---------------- src/oberon.c | 2 +- 6 files changed, 33 insertions(+), 23 deletions(-) diff --git a/Test.obn b/Test.obn index 98ac0e2..363783e 100644 --- a/Test.obn +++ b/Test.obn @@ -1,12 +1,17 @@ MODULE Test; +TYPE + R1 = RECORD END; +(* R2 = RECORD (R1) END; *) + R3 = RECORD END; + VAR - a : POINTER TO RECORD END; - b : POINTER TO ARRAY OF INTEGER; - c : PROCEDURE; +(* + a : R1; + b : R2; +*) + c : R3; BEGIN - a := NIL; - b := NIL; - c := NIL; +(* a := b; *) END Test. diff --git a/Test4.obn b/Test4.obn index 132f864..fba34f9 100644 --- a/Test4.obn +++ b/Test4.obn @@ -10,3 +10,5 @@ BEGIN b := NIL; c := NIL; END Test4. + +Проверка присвоения NIL diff --git a/notes b/notes index 1e0a9e5..762ef89 100644 --- a/notes +++ b/notes @@ -1,3 +1,5 @@ +- Уточнить как должна работать проверка импорта на чтение. (8.1) + - Нет модуля SYSTEM - Нет функций ASH CAP CHR ENTIER LEN LONG ODD ORD SHORT - Нет процедур ASSERT COPY DEC EXCL HALT INC INCL @@ -5,6 +7,7 @@ - Не реализована свёртка констант - Нужно пробежаться по стандарту и всё перепроверить. +- JVM: Импортируемые модули не инициализируются - JVM: Не реализовано полное сранение массивов. - JVM: Не реализовано полное сранение записей. - JVM: Не достаточно средств для реализации рефлексии на уровне локальных процедур. diff --git a/obn-dev-test.sh b/obn-dev-test.sh index 89592da..424cf4e 100755 --- a/obn-dev-test.sh +++ b/obn-dev-test.sh @@ -6,6 +6,7 @@ set -e ./obn-compile.sh Test # -a -- for asm as comments +# -noinner jad -o -b -noinner classes/* ./obn-run.sh Test diff --git a/src/backends/jvm/generator-jvm.c b/src/backends/jvm/generator-jvm.c index 90b0e88..5e74d18 100644 --- a/src/backends/jvm/generator-jvm.c +++ b/src/backends/jvm/generator-jvm.c @@ -475,20 +475,7 @@ oberon_generator_init_type(oberon_context_t * ctx, oberon_type_t * type) memset(t, 0, sizeof *t); type -> gen_type = t; - if(type -> class != OBERON_TYPE_NOTYPE) - { - t -> wide = jvm_is_wide_type(type); - t -> prefix = jvm_get_prefix(type); - t -> postfix = jvm_get_postfix(type); - } - - t -> cell_size = jvm_cell_size_for_type(type); - - if(type -> class != OBERON_TYPE_NIL) - { - t -> desc = jvm_get_descriptor(type); - } - + gen_module_t * m; switch(type -> class) { case OBERON_TYPE_NOTYPE: @@ -503,8 +490,6 @@ oberon_generator_init_type(oberon_context_t * ctx, oberon_type_t * type) case OBERON_TYPE_NIL: break; case OBERON_TYPE_RECORD: - ; - gen_module_t * m; m = type -> module -> gen_mod; oberon_generate_record_class(m, type); break; @@ -515,6 +500,20 @@ oberon_generator_init_type(oberon_context_t * ctx, oberon_type_t * type) gen_error("oberon_generator_init_type: unk calss %i", type -> class); break; } + + if(type -> class != OBERON_TYPE_NOTYPE) + { + t -> wide = jvm_is_wide_type(type); + t -> prefix = jvm_get_prefix(type); + t -> postfix = jvm_get_postfix(type); + } + + t -> cell_size = jvm_cell_size_for_type(type); + + if(type -> class != OBERON_TYPE_NIL) + { + t -> desc = jvm_get_descriptor(type); + } } void diff --git a/src/oberon.c b/src/oberon.c index 5a93489..349015d 100644 --- a/src/oberon.c +++ b/src/oberon.c @@ -1453,7 +1453,7 @@ oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char * } } - int read_only = 0; + int read_only = expr -> read_only; if(field -> read_only) { if(field -> module != ctx -> mod) -- 2.29.2 From 49ad3c76fc9656759aab23d9034ebc33f8d8bd9d Mon Sep 17 00:00:00 2001 From: DeaDDooMER Date: Thu, 10 Aug 2017 13:47:21 +0300 Subject: [PATCH 04/16] =?utf8?q?=D0=9F=D1=80=D0=BE=D0=B2=D0=B5=D1=80=D0=BA?= =?utf8?q?=D0=B0=20=D0=BE=D1=80=D0=B0=D0=BD=D1=8B=20=D1=82=D0=B8=D0=BF?= =?utf8?q?=D0=B0=20=D1=82=D0=B5=D0=BF=D0=B5=D1=80=D1=8C=20=D0=BA=D0=B0?= =?utf8?q?=D0=BA=20=D0=BE=D0=BF=D0=B8=D1=81=D0=B0=D0=BD=D0=BE=20=D0=B2=20?= =?utf8?q?=D1=81=D1=82=D0=B0=D0=BD=D0=B4=D0=B0=D1=80=D1=82=D0=B5?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- Test.obn | 13 +++++++++---- Test5.obn | 22 ++++++++++++++++++++++ obn-run-tests.sh | 1 + src/oberon.c | 43 +++++++++++++++++++++++++++++++++++++------ 4 files changed, 69 insertions(+), 10 deletions(-) create mode 100644 Test5.obn diff --git a/Test.obn b/Test.obn index 363783e..b80d7a1 100644 --- a/Test.obn +++ b/Test.obn @@ -2,16 +2,21 @@ MODULE Test; TYPE R1 = RECORD END; -(* R2 = RECORD (R1) END; *) + R2 = RECORD (R1) END; R3 = RECORD END; + P1 = POINTER TO R1; + P2 = POINTER TO R2; + VAR -(* a : R1; b : R2; -*) c : R3; + p1 : P1; + p2 : P2; BEGIN -(* a := b; *) + a := b; + p2 := p1(P2); + p1 := p2(P2); END Test. diff --git a/Test5.obn b/Test5.obn new file mode 100644 index 0000000..248d688 --- /dev/null +++ b/Test5.obn @@ -0,0 +1,22 @@ +MODULE Test5; + +TYPE + R1 = RECORD END; + R2 = RECORD (R1) END; + R3 = RECORD END; + + P1 = POINTER TO R1; + P2 = POINTER TO R2; + +VAR + a : R1; + b : R2; + c : R3; + p1 : P1; + p2 : P2; + +BEGIN + a := b; + p2 := p1(P2); + p1 := p2(P2); +END Test5. diff --git a/obn-run-tests.sh b/obn-run-tests.sh index c665472..2c7dbec 100755 --- a/obn-run-tests.sh +++ b/obn-run-tests.sh @@ -31,3 +31,4 @@ maketest Test1 maketest Test2 maketest Test3 maketest Test4 +maketest Test5 diff --git a/src/oberon.c b/src/oberon.c index 349015d..ece881f 100644 --- a/src/oberon.c +++ b/src/oberon.c @@ -1573,11 +1573,46 @@ oberon_qualident_expr(oberon_context_t * ctx) return expr; } +static oberon_expr_t * +oberon_make_type_guard(oberon_context_t * ctx, oberon_expr_t * expr, oberon_object_t * objtype) +{ + oberon_type_t * type; + + if(objtype -> class != OBERON_CLASS_TYPE) + { + oberon_error(ctx, "must be type"); + } + type = objtype -> type; + + /* Охрана типа применима, если */ + /* 1. v - параметр-переменная типа запись, или v - указатель, и если */ + /* 2. T - расширение статического типа v */ + + if(expr -> is_item + && expr -> item.mode == MODE_VAR + && expr -> item.var -> class == OBERON_CLASS_VAR_PARAM) + { + // accept + } + else if(expr -> result -> class == OBERON_TYPE_POINTER) + { + // accept + } + else + { + oberon_error(ctx, "guard type used only with var-param or pointers"); + } + + oberon_check_record_compatibility(ctx, type, expr -> result); + return oberno_make_record_cast(ctx, expr, objtype -> type); +} + static oberon_expr_t * oberon_designator(oberon_context_t * ctx) { char * name; oberon_expr_t * expr; + oberon_object_t * objtype; expr = oberon_qualident_expr(ctx); @@ -1609,13 +1644,9 @@ oberon_designator(oberon_context_t * ctx) 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"); - } + objtype = oberon_qualident(ctx, NULL, true); oberon_assert_token(ctx, RPAREN); - expr = oberno_make_record_cast(ctx, expr, objtype -> type); + expr = oberon_make_type_guard(ctx, expr, objtype); break; default: oberon_error(ctx, "oberon_designator: wat"); -- 2.29.2 From 496b7b4a5162004e33dfd3328aee7d155342f09f Mon Sep 17 00:00:00 2001 From: DeaDDooMER Date: Thu, 10 Aug 2017 16:12:29 +0300 Subject: [PATCH 05/16] =?utf8?q?=D0=98=D1=81=D0=BF=D1=80=D0=B0=D0=B2=D0=BB?= =?utf8?q?=D0=B5=D0=BD=D0=BE=20=D0=BF=D1=80=D0=B8=D1=81=D0=B2=D0=B0=D0=B8?= =?utf8?q?=D0=B2=D0=B0=D0=BD=D0=B8=D0=B5=20=D0=B8=20=D1=81=D0=B8=D0=BD?= =?utf8?q?=D1=85=D1=80=D0=BE=D0=BD=D0=B8=D0=B7=D0=B0=D1=86=D0=B8=D1=8F=20?= =?utf8?q?=D1=81=D1=80=D0=B0=D0=B2=D0=BD=D0=B5=D0=BD=D0=B8=D0=B9=20=D1=81?= =?utf8?q?=D0=BE=20=D1=81=D1=82=D0=B0=D0=BD=D0=B4=D0=B0=D1=80=D1=82=D0=BE?= =?utf8?q?=D0=BC?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- Test.obn | 22 ++-- notes | 7 +- src/backends/jvm/generator-jvm-abi.c | 9 +- src/oberon.c | 175 ++++++++++++++++++--------- 4 files changed, 133 insertions(+), 80 deletions(-) diff --git a/Test.obn b/Test.obn index b80d7a1..4f53910 100644 --- a/Test.obn +++ b/Test.obn @@ -1,22 +1,14 @@ MODULE Test; -TYPE - R1 = RECORD END; - R2 = RECORD (R1) END; - R3 = RECORD END; - - P1 = POINTER TO R1; - P2 = POINTER TO R2; +IMPORT Out; VAR - a : R1; - b : R2; - c : R3; - p1 : P1; - p2 : P2; + f : BOOLEAN; + r, e : POINTER TO RECORD END; BEGIN - a := b; - p2 := p1(P2); - p1 := p2(P2); + f := r = e; + IF f THEN + Out.String('Yes'); Out.Ln; + END; END Test. diff --git a/notes b/notes index 762ef89..ab857f4 100644 --- a/notes +++ b/notes @@ -1,4 +1,6 @@ - Уточнить как должна работать проверка импорта на чтение. (8.1) +- Уточнить результат оператора "/" (8.2.2) +- Примеры -5 DIV 3 и -5 MOD 3 работают не так как в (8.2.2) - Нет модуля SYSTEM - Нет функций ASH CAP CHR ENTIER LEN LONG ODD ORD SHORT @@ -8,10 +10,9 @@ - Нужно пробежаться по стандарту и всё перепроверить. - JVM: Импортируемые модули не инициализируются -- JVM: Не реализовано полное сранение массивов. -- JVM: Не реализовано полное сранение записей. +- JVM: Не реализовано сравнение строк. - JVM: Не достаточно средств для реализации рефлексии на уровне локальных процедур. - (Как минимум нужно каждой функции добавлять фрейм к параметрам) + Как минимум нужно каждой функции добавлять фрейм к параметрам (динамическая связь?) - Нужны средства создания биндингов. На данный момент реализуемо как заглушки для модулей. - Любая ошибка фатальна diff --git a/src/backends/jvm/generator-jvm-abi.c b/src/backends/jvm/generator-jvm-abi.c index ddaf45f..d0dabd2 100644 --- a/src/backends/jvm/generator-jvm-abi.c +++ b/src/backends/jvm/generator-jvm-abi.c @@ -69,6 +69,7 @@ void jvm_generate_load(gen_proc_t * p, gen_var_t * src) { char prefix = src -> type -> prefix; + char postfix = src -> type -> postfix; int cell_size = src -> type -> cell_size; char * full_name = src -> full_name; char * desc = src -> type -> desc; @@ -94,7 +95,7 @@ jvm_generate_load(gen_proc_t * p, gen_var_t * src) case JVM_STORAGE_FRAME_PARAM_VAR: case JVM_STORAGE_FRAME_PARAM_VARPTR: jvm_generate_ldst_prepare(p, src); - jvm_generate(p, 1 + 1, cell_size, "%caload", prefix); + jvm_generate(p, 1 + 1, cell_size, "%caload", postfix); break; case JVM_STORAGE_FRAME: case JVM_STORAGE_FRAME_PARAM: @@ -111,6 +112,7 @@ void jvm_generate_store(gen_proc_t * p, gen_var_t * dst) { char prefix = dst -> type -> prefix; + char postfix = dst -> type -> postfix; int cell_size = dst -> type -> cell_size; char * full_name = dst -> full_name; char * desc = dst -> type -> desc; @@ -135,7 +137,7 @@ jvm_generate_store(gen_proc_t * p, gen_var_t * dst) case JVM_STORAGE_FRAME_VAR: case JVM_STORAGE_FRAME_PARAM_VAR: case JVM_STORAGE_FRAME_PARAM_VARPTR: - jvm_generate(p, 1 + 1 + cell_size, 0, "%castore", prefix); + jvm_generate(p, 1 + 1 + cell_size, 0, "%castore", postfix); break; case JVM_STORAGE_FRAME: case JVM_STORAGE_FRAME_PARAM: @@ -295,6 +297,7 @@ jvm_generate_param_initialization(gen_proc_t * p, gen_var_t * v) int old_reg = v -> reg; int cell_size = v -> type -> cell_size; char prefix = v -> type -> prefix; + char postfix = v -> type -> postfix; char * name = v -> name; char * desc = v -> type -> desc; @@ -308,7 +311,7 @@ jvm_generate_param_initialization(gen_proc_t * p, gen_var_t * v) jvm_generate(p, 0, 1, "iconst_0"); jvm_generate(p, 0, cell_size, "%cload %i", prefix, old_reg); - jvm_generate(p, 1 + 1 + cell_size, 0, "%castore", prefix); + jvm_generate(p, 1 + 1 + cell_size, 0, "%castore", postfix); } void diff --git a/src/oberon.c b/src/oberon.c index ece881f..9738056 100644 --- a/src/oberon.c +++ b/src/oberon.c @@ -1573,17 +1573,9 @@ oberon_qualident_expr(oberon_context_t * ctx) return expr; } -static oberon_expr_t * -oberon_make_type_guard(oberon_context_t * ctx, oberon_expr_t * expr, oberon_object_t * objtype) +static void +oberon_check_type_guard(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * type) { - oberon_type_t * type; - - if(objtype -> class != OBERON_CLASS_TYPE) - { - oberon_error(ctx, "must be type"); - } - type = objtype -> type; - /* Охрана типа применима, если */ /* 1. v - параметр-переменная типа запись, или v - указатель, и если */ /* 2. T - расширение статического типа v */ @@ -1594,7 +1586,8 @@ oberon_make_type_guard(oberon_context_t * ctx, oberon_expr_t * expr, oberon_obje { // accept } - else if(expr -> result -> class == OBERON_TYPE_POINTER) + else if(expr -> result -> class == OBERON_TYPE_POINTER + || expr -> result -> class == OBERON_TYPE_RECORD) { // accept } @@ -1604,6 +1597,20 @@ oberon_make_type_guard(oberon_context_t * ctx, oberon_expr_t * expr, oberon_obje } oberon_check_record_compatibility(ctx, type, expr -> result); +} + +static oberon_expr_t * +oberon_make_type_guard(oberon_context_t * ctx, oberon_expr_t * expr, oberon_object_t * objtype) +{ + oberon_type_t * type; + + if(objtype -> class != OBERON_CLASS_TYPE) + { + oberon_error(ctx, "must be type"); + } + type = objtype -> type; + + oberon_check_type_guard(ctx, expr, type); return oberno_make_record_cast(ctx, expr, objtype -> type); } @@ -1858,15 +1865,6 @@ oberon_factor(oberon_context_t * ctx) return expr; } -#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 void oberon_autocast_to_real(oberon_context_t * ctx, oberon_expr_t ** e) { @@ -1888,6 +1886,49 @@ oberon_autocast_to_real(oberon_context_t * ctx, oberon_expr_t ** e) } } +static bool +oberon_is_numeric_type(oberon_type_t * t) +{ + return (t -> class == OBERON_TYPE_INTEGER) || (t -> class == OBERON_TYPE_REAL); +} + +static bool +oberon_is_char_type(oberon_type_t * t) +{ + return (t -> class == OBERON_TYPE_CHAR); +} + +static bool +oberon_is_string_type(oberon_type_t * t) +{ + return (t -> class == OBERON_TYPE_STRING) + || (t -> class == OBERON_TYPE_ARRAY && t -> base -> class == OBERON_TYPE_CHAR); +} + +static bool +oberon_is_boolean_type(oberon_type_t * t) +{ + return (t -> class == OBERON_TYPE_BOOLEAN); +} + +static bool +oberon_is_set_type(oberon_type_t * t) +{ + return (t -> class == OBERON_TYPE_SET); +} + +static bool +oberon_is_pointer_type(oberon_type_t * t) +{ + return (t -> class == OBERON_TYPE_POINTER) || (t -> class == OBERON_TYPE_NIL); +} + +static bool +oberon_is_procedure_type(oberon_type_t * t) +{ + return (t -> class == OBERON_TYPE_POINTER) || (t -> class == OBERON_TYPE_NIL); +} + static oberon_expr_t * oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_expr_t * b) { @@ -1912,66 +1953,82 @@ oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_ } else if(token == IS) { - oberon_type_t * v = a -> result; - if(v -> class == OBERON_TYPE_POINTER) - { - v = v -> base; - if(v -> class != OBERON_TYPE_RECORD) - { - oberon_error(ctx, "must be record"); - } - } - else if(v -> class != OBERON_TYPE_RECORD) - { - oberon_error(ctx, "must be record"); - } - if(b -> is_item == false || b -> item.mode != MODE_TYPE) { oberon_error(ctx, "requires type"); } - oberon_type_t * t = b -> result; - if(t -> class == OBERON_TYPE_POINTER) - { - t = t -> base; - if(t -> class != OBERON_TYPE_RECORD) - { - oberon_error(ctx, "must be record"); - } - } - else if(t -> class != OBERON_TYPE_RECORD) - { - oberon_error(ctx, "must be record"); - } - result = ctx -> bool_type; + oberon_check_type_guard(ctx, a, b -> result); expr = oberon_new_operator(OP_IS, result, a, b); } - else if(ITMAKESBOOLEAN(token)) + else if((token >= EQUAL && token <= GEQ) || token == OR || token == AND) { - if(ITUSEONLYINTEGER(token)) + if(token >= LESS && token <= GEQ) + { + if(oberon_is_numeric_type(a -> result) && oberon_is_numeric_type(b -> result)) + { + // accept + } + else if(oberon_is_char_type(a -> result) && oberon_is_char_type(b -> result)) + { + // accept + } + else if(oberon_is_string_type(a -> result) && oberon_is_string_type(b -> result)) + { + // accept + } + else + { + oberon_error(ctx, "invalid comparation"); + } + } + else if(token == EQUAL || token == NEQ) { - if(a -> result -> class == OBERON_TYPE_INTEGER - || b -> result -> class == OBERON_TYPE_INTEGER - || a -> result -> class == OBERON_TYPE_REAL - || b -> result -> class == OBERON_TYPE_REAL) + if(oberon_is_numeric_type(a -> result) && oberon_is_numeric_type(b -> result)) + { + // accept + } + else if(oberon_is_char_type(a -> result) && oberon_is_char_type(b -> result)) + { + // accept + } + else if(oberon_is_string_type(a -> result) && oberon_is_string_type(b -> result)) + { + // accept + } + else if(oberon_is_boolean_type(a -> result) && oberon_is_boolean_type(b -> result)) + { + // accept + } + else if(oberon_is_set_type(a -> result) && oberon_is_set_type(b -> result)) + { + // accept + } + else if(oberon_is_pointer_type(a -> result) && oberon_is_pointer_type(b -> result)) + { + // accept + } + else if(oberon_is_procedure_type(a -> result) && oberon_is_procedure_type(b -> result)) { // accept } else { - oberon_error(ctx, "used only with numeric types"); + oberon_error(ctx, "invalid comparation"); } } - else if(ITUSEONLYBOOLEAN(token)) + else if(token == AND || token == OR) { - if(a -> result -> class != OBERON_TYPE_BOOLEAN - || b -> result -> class != OBERON_TYPE_BOOLEAN) + if(!oberon_is_boolean_type(a -> result) || !oberon_is_boolean_type(b -> result)) { - oberon_error(ctx, "used only with boolean type"); + oberon_error(ctx, "invalid comparation"); } } + else + { + oberon_error(ctx, "wat"); + } oberon_autocast_binary_op(ctx, &a, &b); result = ctx -> bool_type; -- 2.29.2 From e637b466c2a4e0b0feb0f264ad4342ecfe9efd21 Mon Sep 17 00:00:00 2001 From: DeaDDooMER Date: Thu, 10 Aug 2017 18:51:06 +0300 Subject: [PATCH 06/16] =?utf8?q?=D0=9E=D0=B1=D0=BD=D0=BE=D0=B2=D0=BB=D1=91?= =?utf8?q?=D0=BD=20TODO-=D1=81=D0=BF=D0=B8=D1=81=D0=BE=D0=BA?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- notes | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/notes b/notes index ab857f4..072a37d 100644 --- a/notes +++ b/notes @@ -1,19 +1,30 @@ -- Уточнить как должна работать проверка импорта на чтение. (8.1) -- Уточнить результат оператора "/" (8.2.2) -- Примеры -5 DIV 3 и -5 MOD 3 работают не так как в (8.2.2) +- Переделать присваивание строк. +- Сделать проверку повторов в CASE и выполнять прирывание при отсутствии ELSE. +- В FOR сначала должна вычисляться переменная temp. +- Сделать выполнение прерывания при отсутствии ELSE в операторе WITH. +- Сделать нормальную проверку наличия RETURN. +- Запретить массивы и записи как результат процедуры-функции. +- Запретить модулю импорт самого себя. +- Нужно проверить правила совместимости типов (Приложение A). - Нет модуля SYSTEM - Нет функций ASH CAP CHR ENTIER LEN LONG ODD ORD SHORT - Нет процедур ASSERT COPY DEC EXCL HALT INC INCL - Нет счёта строк / столбцов +- Нет процедур привязанных к типм - Не реализована свёртка констант -- Нужно пробежаться по стандарту и всё перепроверить. + +- Нужно просмотреть Дубовые требования. - JVM: Импортируемые модули не инициализируются - JVM: Не реализовано сравнение строк. - JVM: Не достаточно средств для реализации рефлексии на уровне локальных процедур. Как минимум нужно каждой функции добавлять фрейм к параметрам (динамическая связь?) +- Уточнить как должна работать проверка импорта на чтение. (8.1) +- Уточнить результат оператора "/" (8.2.2) +- Примеры -5 DIV 3 и -5 MOD 3 работают не так как в (8.2.2) + - Нужны средства создания биндингов. На данный момент реализуемо как заглушки для модулей. - Любая ошибка фатальна - Нет проверок переполнения в компилтайме. -- 2.29.2 From 9f8036eb00032fa7f756113365cb42e05ab262df Mon Sep 17 00:00:00 2001 From: DeaDDooMER Date: Fri, 11 Aug 2017 14:27:56 +0300 Subject: [PATCH 07/16] =?utf8?q?=D0=9F=D0=B5=D1=80=D0=B5=D0=B4=D0=B5=D0=BB?= =?utf8?q?=D0=B0=D0=BD=D0=BE=20=D0=BF=D1=80=D0=B8=D1=81=D0=B2=D0=B0=D0=B8?= =?utf8?q?=D0=B2=D0=B0=D0=BD=D0=B8=D0=B5=20=D1=81=D1=82=D1=80=D0=BE=D0=BA?= =?utf8?q?=20=D0=B8=20=D0=B4=D0=BE=D0=B1=D0=B0=D0=B2=D0=BB=D0=B5=D0=BD?= =?utf8?q?=D1=8B=20=D0=BF=D1=80=D0=BE=D1=86=D0=B5=D0=B4=D1=83=D1=80=D1=8B?= =?utf8?q?=20COPY,=20ASSERT=20=D0=B8=20HALT?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- System.obn | 6 -- Test.obn | 16 +-- Test6.obn | 20 ++++ notes | 4 +- obn-run-tests.sh | 1 + obn-run.sh | 2 +- rtl/SYSTEM.java | 47 +++++++++ rtl/System.java | 7 -- src/backends/jvm/generator-jvm-abi.c | 5 +- src/backends/jvm/generator-jvm.c | 59 +++++++++++ src/generator.h | 4 + src/oberon.c | 144 +++++++++++++++++++++++++-- 12 files changed, 285 insertions(+), 30 deletions(-) delete mode 100644 System.obn create mode 100644 Test6.obn create mode 100644 rtl/SYSTEM.java delete mode 100644 rtl/System.java diff --git a/System.obn b/System.obn deleted file mode 100644 index 54db52e..0000000 --- a/System.obn +++ /dev/null @@ -1,6 +0,0 @@ -MODULE System; - -PROCEDURE Halt*(n : INTEGER); -END Halt; - -END System. diff --git a/Test.obn b/Test.obn index 4f53910..8c3a8d1 100644 --- a/Test.obn +++ b/Test.obn @@ -3,12 +3,16 @@ MODULE Test; IMPORT Out; VAR - f : BOOLEAN; - r, e : POINTER TO RECORD END; + msg : ARRAY 20 OF CHAR; BEGIN - f := r = e; - IF f THEN - Out.String('Yes'); Out.Ln; - END; + Out.Open; + COPY("Hello World!", msg); + Out.String(msg); Out.Ln; + COPY("Hell!", msg); + Out.String(msg); Out.Ln; + COPY("The quick brown fox jumps over the lazy dog", msg); + Out.String(msg); Out.Ln; + msg := "Hello World!"; + Out.String(msg); Out.Ln; END Test. diff --git a/Test6.obn b/Test6.obn new file mode 100644 index 0000000..db6cede --- /dev/null +++ b/Test6.obn @@ -0,0 +1,20 @@ +MODULE Test6; + +IMPORT Out; + +VAR + msg : ARRAY 20 OF CHAR; + +BEGIN + Out.Open; + COPY("Hello World!", msg); + Out.String(msg); Out.Ln; + COPY("Hell!", msg); + Out.String(msg); Out.Ln; + COPY("The quick brown fox jumps over the lazy dog", msg); + Out.String(msg); Out.Ln; + msg := "Hello World!"; + Out.String(msg); Out.Ln; +END Test6. + +Проверка строк. COPY должен обрезать строки если не лезет. diff --git a/notes b/notes index 072a37d..ce31365 100644 --- a/notes +++ b/notes @@ -1,4 +1,3 @@ -- Переделать присваивание строк. - Сделать проверку повторов в CASE и выполнять прирывание при отсутствии ELSE. - В FOR сначала должна вычисляться переменная temp. - Сделать выполнение прерывания при отсутствии ELSE в операторе WITH. @@ -9,7 +8,7 @@ - Нет модуля SYSTEM - Нет функций ASH CAP CHR ENTIER LEN LONG ODD ORD SHORT -- Нет процедур ASSERT COPY DEC EXCL HALT INC INCL +- Нет процедур DEC EXCL INC INCL - Нет счёта строк / столбцов - Нет процедур привязанных к типм - Не реализована свёртка констант @@ -24,6 +23,7 @@ - Уточнить как должна работать проверка импорта на чтение. (8.1) - Уточнить результат оператора "/" (8.2.2) - Примеры -5 DIV 3 и -5 MOD 3 работают не так как в (8.2.2) + Нужен другой тип округления? - Нужны средства создания биндингов. На данный момент реализуемо как заглушки для модулей. - Любая ошибка фатальна diff --git a/obn-run-tests.sh b/obn-run-tests.sh index 2c7dbec..d809c75 100755 --- a/obn-run-tests.sh +++ b/obn-run-tests.sh @@ -32,3 +32,4 @@ maketest Test2 maketest Test3 maketest Test4 maketest Test5 +maketest Test6 diff --git a/obn-run.sh b/obn-run.sh index ef0185c..9514a22 100755 --- a/obn-run.sh +++ b/obn-run.sh @@ -2,4 +2,4 @@ set -e -java -cp classes Launcher $1 +java -ea -cp classes Launcher $1 diff --git a/rtl/SYSTEM.java b/rtl/SYSTEM.java new file mode 100644 index 0000000..f98236b --- /dev/null +++ b/rtl/SYSTEM.java @@ -0,0 +1,47 @@ +public class SYSTEM +{ + /* Каркас для фреймов процедур */ + public static abstract class FRAME + { + public FRAME up; + } + + /* Длинна строки LEN(s$) */ + public static int LEN(byte[] x) + { + int i = 0; + while(x[i] != 0) + { + i += 1; + } + return i; + } + + /* Встроенная процедура COPY(x, v) */ + public static void COPY(byte[] x, byte[] v) + { + int len_x = LEN(x); + int len_v = v.length - 1; + int len = (len_x < len_v) ? (len_x) : (len_v); + for(int i = 0; i < len; i++) + { + v[i] = x[i]; + } + v[len] = 0; + } + + public static void HALT(long n) + { + System.exit((int) n); + } + + public static void ASSERT(boolean x) + { + assert x; + } + + public static void ASSERT(boolean x, long n) + { + assert x : n; + } +} diff --git a/rtl/System.java b/rtl/System.java deleted file mode 100644 index d2ccf9b..0000000 --- a/rtl/System.java +++ /dev/null @@ -1,7 +0,0 @@ -public class System -{ - public static void Halt(short n) - { - java.lang.System.exit(n); - } -} diff --git a/src/backends/jvm/generator-jvm-abi.c b/src/backends/jvm/generator-jvm-abi.c index d0dabd2..b404fca 100644 --- a/src/backends/jvm/generator-jvm-abi.c +++ b/src/backends/jvm/generator-jvm-abi.c @@ -358,6 +358,7 @@ jvm_generate_var_initialization(gen_proc_t * p, gen_var_t * v) } } +/* static void jvm_generate_abstract_frame_class() { @@ -383,6 +384,7 @@ jvm_generate_abstract_frame_class() jvm_destroy_class(class); } +*/ static struct gen_class * jvm_generate_frame_class(oberon_object_t * proc) @@ -478,7 +480,8 @@ jvm_generate_procedure_frame(oberon_object_t * proc) p = proc -> gen_proc; - jvm_generate_abstract_frame_class(); +// jvm_generate_abstract_frame_class(); + class = jvm_generate_frame_class(proc); t = GC_MALLOC(sizeof *t); diff --git a/src/backends/jvm/generator-jvm.c b/src/backends/jvm/generator-jvm.c index 5e74d18..4011965 100644 --- a/src/backends/jvm/generator-jvm.c +++ b/src/backends/jvm/generator-jvm.c @@ -1641,3 +1641,62 @@ oberon_generate_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_ store_expr(p, dst, src); } + +void +oberon_generate_copy(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst) +{ + gen_module_t * m; + gen_proc_t * p; + char * desc; + + m = ctx -> mod -> gen_mod; + p = m -> class -> p; + + push_expr(p, src); + push_expr(p, dst); + + desc = jvm_get_descriptor(dst -> result); + + jvm_generate(p, 2, 0, "invokestatic SYSTEM/COPY(%s%s)V", desc, desc); +} + +void +oberon_generate_assert(oberon_context_t * ctx, oberon_expr_t * cond) +{ + gen_module_t * m; + gen_proc_t * p; + + m = ctx -> mod -> gen_mod; + p = m -> class -> p; + + push_expr(p, cond); + jvm_generate(p, 1, 0, "invokestatic SYSTEM/ASSERT(Z)V"); +} + +void +oberon_generate_assert_n(oberon_context_t * ctx, oberon_expr_t * cond, int64_t n) +{ + gen_module_t * m; + gen_proc_t * p; + + m = ctx -> mod -> gen_mod; + p = m -> class -> p; + + push_expr(p, cond); + jvm_generate_push_int_size(p, n, 8); + jvm_generate(p, 1 + 2, 0, "invokestatic SYSTEM/ASSERT(ZJ)V"); +} + +void +oberon_generate_halt(oberon_context_t * ctx, int64_t n) +{ + gen_module_t * m; + gen_proc_t * p; + + m = ctx -> mod -> gen_mod; + p = m -> class -> p; + + jvm_generate_push_int_size(p, n, 8); + jvm_generate(p, 2, 0, "invokestatic SYSTEM/HALT(J)V"); +} + diff --git a/src/generator.h b/src/generator.h index a940dab..bc502cc 100644 --- a/src/generator.h +++ b/src/generator.h @@ -38,4 +38,8 @@ void oberon_generate_goto(oberon_context_t * ctx, gen_label_t * l); */ void oberon_generate_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst); +void oberon_generate_copy(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst); +void oberon_generate_assert_n(oberon_context_t * ctx, oberon_expr_t * cond, int64_t n); +void oberon_generate_assert(oberon_context_t * ctx, oberon_expr_t * cond); +void oberon_generate_halt(oberon_context_t * ctx, int64_t n); void oberon_generate_return(oberon_context_t * ctx, oberon_expr_t * expr); diff --git a/src/oberon.c b/src/oberon.c index 9738056..1f33a03 100644 --- a/src/oberon.c +++ b/src/oberon.c @@ -85,6 +85,9 @@ enum { // UTILS // ======================================================================= +static void +oberon_make_copy_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args); + static void oberon_error(oberon_context_t * ctx, const char * fmt, ...) { @@ -1055,6 +1058,11 @@ oberon_check_record_compatibility(oberon_context_t * ctx, oberon_type_t * from, static void oberon_check_dst(oberon_context_t * ctx, oberon_expr_t * dst) { + if(dst -> read_only) + { + oberon_error(ctx, "read-only destination"); + } + if(dst -> is_item == false) { oberon_error(ctx, "not variable"); @@ -3314,14 +3322,30 @@ oberon_statement_seq(oberon_context_t * ctx); static void oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst) { - if(dst -> read_only) + if(src -> is_item + && src -> item.mode == MODE_STRING + && src -> result -> class == OBERON_TYPE_STRING + && dst -> result -> class == OBERON_TYPE_ARRAY + && dst -> result -> base -> class == OBERON_TYPE_CHAR + && dst -> result -> size > 0) { - oberon_error(ctx, "read-only destination"); - } - oberon_check_dst(ctx, dst); - src = oberon_autocast_to(ctx, src, dst -> result); - oberon_generate_assign(ctx, src, dst); + if(strlen(src -> item.string) < dst -> result -> size) + { + src -> next = dst; + oberon_make_copy_call(ctx, 2, src); + } + else + { + oberon_error(ctx, "string too long for destination"); + } + } + else + { + oberon_check_dst(ctx, dst); + src = oberon_autocast_to(ctx, src, dst -> result); + oberon_generate_assign(ctx, src, dst); + } } static oberon_expr_t * @@ -4043,7 +4067,6 @@ oberon_make_new_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ oberon_error(ctx, "too few arguments"); } - oberon_expr_t * dst; dst = list_args; oberon_check_dst(ctx, dst); @@ -4119,6 +4142,110 @@ oberon_make_new_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ oberon_assign(ctx, src, dst); } +static void +oberon_make_copy_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 * src; + src = list_args; + oberon_check_src(ctx, src); + + oberon_expr_t * dst; + dst = list_args -> next; + oberon_check_dst(ctx, dst); + + if(!oberon_is_string_type(src -> result)) + { + oberon_error(ctx, "source must be string or array of char"); + } + + if(!oberon_is_string_type(dst -> result)) + { + oberon_error(ctx, "dst must be array of char"); + } + + oberon_generate_copy(ctx, src, dst); +} + +static void +oberon_make_assert_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 * cond; + cond = list_args; + oberon_check_src(ctx, cond); + + if(cond -> result -> class != OBERON_TYPE_BOOLEAN) + { + oberon_error(ctx, "expected boolean"); + } + + if(num_args == 1) + { + oberon_generate_assert(ctx, cond); + } + else + { + oberon_expr_t * num; + num = list_args -> next; + oberon_check_src(ctx, num); + + if(num -> result -> class != OBERON_TYPE_INTEGER) + { + oberon_error(ctx, "expected integer"); + } + + oberon_check_const(ctx, num); + + oberon_generate_assert_n(ctx, cond, num -> item.integer); + } +} + +static void +oberon_make_halt_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 * num; + num = list_args; + oberon_check_src(ctx, num); + + if(num -> result -> class != OBERON_TYPE_INTEGER) + { + oberon_error(ctx, "expected integer"); + } + + oberon_check_const(ctx, num); + + oberon_generate_halt(ctx, num -> item.integer); +} + static void oberon_new_const(oberon_context_t * ctx, char * name, oberon_expr_t * expr) { @@ -4155,6 +4282,9 @@ oberon_create_context(ModuleImportCallback import_module) /* 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, "HALT", NULL, oberon_make_halt_call); return ctx; } -- 2.29.2 From 6d3cfbfd343c0d069896734e32a8c490f27cb7aa Mon Sep 17 00:00:00 2001 From: DeaDDooMER Date: Fri, 11 Aug 2017 14:50:26 +0300 Subject: [PATCH 08/16] =?utf8?q?=D0=9F=D0=BE=D0=B4=D0=BF=D1=80=D0=B0=D0=BB?= =?utf8?q?=D0=B5=D0=BD=20FOR=20=D0=B4=D0=BB=D1=8F=20=D1=81=D0=BE=D0=BE?= =?utf8?q?=D1=82=D0=B2=D0=B5=D1=82=D1=81=D1=82=D0=B2=D0=B8=D1=8F=20=D1=81?= =?utf8?q?=D1=82=D0=B0=D0=BD=D0=B4=D0=B0=D1=80=D1=82=D1=83?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- Test.obn | 15 ++++++--------- Test7.obn | 19 +++++++++++++++++++ notes | 1 - obn-run-tests.sh | 1 + rtl/SYSTEM.java | 1 - src/oberon.c | 4 ++-- 6 files changed, 28 insertions(+), 13 deletions(-) create mode 100644 Test7.obn diff --git a/Test.obn b/Test.obn index 8c3a8d1..f0552a9 100644 --- a/Test.obn +++ b/Test.obn @@ -3,16 +3,13 @@ MODULE Test; IMPORT Out; VAR - msg : ARRAY 20 OF CHAR; + i : INTEGER; BEGIN Out.Open; - COPY("Hello World!", msg); - Out.String(msg); Out.Ln; - COPY("Hell!", msg); - Out.String(msg); Out.Ln; - COPY("The quick brown fox jumps over the lazy dog", msg); - Out.String(msg); Out.Ln; - msg := "Hello World!"; - Out.String(msg); Out.Ln; + i := 48; + FOR i := 32 TO i DO + Out.Int(i, 0); Out.Char(' '); + END; + Out.Ln; END Test. diff --git a/Test7.obn b/Test7.obn new file mode 100644 index 0000000..739ec97 --- /dev/null +++ b/Test7.obn @@ -0,0 +1,19 @@ +MODULE Test7; + +IMPORT Out; + +VAR + i : INTEGER; + +BEGIN + Out.Open; + i := 48; + FOR i := 32 TO i DO + Out.Int(i, 0); Out.Char(' '); + END; + Out.Ln; +END Test7. + +Проверка корректности FOR. +Сначала должна вычисляться выражение TO и только потом присвоение индекса. +Результат должен быть: 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 diff --git a/notes b/notes index ce31365..7d6b72b 100644 --- a/notes +++ b/notes @@ -1,5 +1,4 @@ - Сделать проверку повторов в CASE и выполнять прирывание при отсутствии ELSE. -- В FOR сначала должна вычисляться переменная temp. - Сделать выполнение прерывания при отсутствии ELSE в операторе WITH. - Сделать нормальную проверку наличия RETURN. - Запретить массивы и записи как результат процедуры-функции. diff --git a/obn-run-tests.sh b/obn-run-tests.sh index d809c75..404c840 100755 --- a/obn-run-tests.sh +++ b/obn-run-tests.sh @@ -33,3 +33,4 @@ maketest Test3 maketest Test4 maketest Test5 maketest Test6 +maketest Test7 diff --git a/rtl/SYSTEM.java b/rtl/SYSTEM.java index f98236b..38f4886 100644 --- a/rtl/SYSTEM.java +++ b/rtl/SYSTEM.java @@ -17,7 +17,6 @@ public class SYSTEM return i; } - /* Встроенная процедура COPY(x, v) */ public static void COPY(byte[] x, byte[] v) { int len_x = LEN(x); diff --git a/src/oberon.c b/src/oberon.c index 1f33a03..36736a4 100644 --- a/src/oberon.c +++ b/src/oberon.c @@ -3644,11 +3644,11 @@ oberon_statement(oberon_context_t * 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); + oberon_assign(ctx, to, bound); // сначала temp + oberon_assign(ctx, from, index); // потом i if(ctx -> token == BY) { oberon_assert_token(ctx, BY); -- 2.29.2 From c535b4be889716bfd37a4f0dd888f398534bc306 Mon Sep 17 00:00:00 2001 From: DeaDDooMER Date: Fri, 11 Aug 2017 15:02:36 +0300 Subject: [PATCH 09/16] =?utf8?q?=D0=97=D0=B0=D0=BF=D1=80=D0=B5=D1=89=D1=91?= =?utf8?q?=D0=BD=20=D0=B2=D0=BE=D0=B7=D0=B2=D1=80=D0=B0=D1=82=20=D0=BC?= =?utf8?q?=D0=B0=D1=81=D1=81=D0=B8=D0=B2=D0=B0=20=D0=B8=D0=BB=D0=B8=20?= =?utf8?q?=D0=B7=D0=B0=D0=BF=D0=B8=D1=81=D0=B8=20=D1=84=D1=83=D0=BD=D0=BA?= =?utf8?q?=D1=86=D0=B8=D0=B5=D0=B9?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- notes | 2 -- src/oberon.c | 5 +++++ 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/notes b/notes index 7d6b72b..c245ba0 100644 --- a/notes +++ b/notes @@ -1,8 +1,6 @@ - Сделать проверку повторов в CASE и выполнять прирывание при отсутствии ELSE. - Сделать выполнение прерывания при отсутствии ELSE в операторе WITH. - Сделать нормальную проверку наличия RETURN. -- Запретить массивы и записи как результат процедуры-функции. -- Запретить модулю импорт самого себя. - Нужно проверить правила совместимости типов (Приложение A). - Нет модуля SYSTEM diff --git a/src/oberon.c b/src/oberon.c index 36736a4..59a5c3d 100644 --- a/src/oberon.c +++ b/src/oberon.c @@ -2444,6 +2444,11 @@ oberon_formal_pars(oberon_context_t * ctx, oberon_type_t * signature) { oberon_error(ctx, "function result is not type"); } + if(typeobj -> type -> class == OBERON_TYPE_RECORD + || typeobj -> type -> class == OBERON_TYPE_ARRAY) + { + oberon_error(ctx, "records or arrays could not be result of function"); + } signature -> base = typeobj -> type; } } -- 2.29.2 From f4aa48e4c1e3b81ccbe3da5c33fdaba3a46081dd Mon Sep 17 00:00:00 2001 From: DeaDDooMER Date: Fri, 11 Aug 2017 16:38:12 +0300 Subject: [PATCH 10/16] =?utf8?q?=D0=9F=D1=80=D0=BE=D0=B3=D1=80=D0=B0=D0=BC?= =?utf8?q?=D0=BC=D0=B0=20=D0=BF=D1=80=D0=B5=D1=80=D1=8B=D0=B2=D0=B0=D0=B5?= =?utf8?q?=D1=82=D1=81=D1=8F=20=D0=B5=D1=81=D0=BB=D0=B8=20=D0=B2=20=D0=BA?= =?utf8?q?=D0=BE=D0=BD=D1=81=D1=82=D1=80=D1=83=D0=BA=D1=86=D0=B8=D1=8F?= =?utf8?q?=D1=85=20CASE=20=D0=B8=20WITH=20=D0=BD=D0=B5=20=D0=B2=D1=8B?= =?utf8?q?=D0=BF=D0=BE=D0=BB=D0=BD=D1=8F=D0=B5=D1=82=D1=81=D1=8F=20=D0=BD?= =?utf8?q?=D0=B8=20=D0=BE=D0=B4=D0=BD=D0=BE=20=D1=83=D1=81=D0=BB=D0=BE?= =?utf8?q?=D0=B2=D0=B8=D0=B5=20=D0=B8=20=D0=BD=D0=B5=D1=82=20=D0=B2=D0=B5?= =?utf8?q?=D1=82=D0=B2=D0=B8=20ELSE?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- Test.obn | 18 +++++++++++++----- notes | 8 ++++---- rtl/SYSTEM.java | 16 ++++++++++++++++ src/backends/jvm/generator-jvm.c | 13 +++++++++++++ src/generator.h | 1 + src/oberon.c | 8 ++++++++ 6 files changed, 55 insertions(+), 9 deletions(-) diff --git a/Test.obn b/Test.obn index f0552a9..e044594 100644 --- a/Test.obn +++ b/Test.obn @@ -2,14 +2,22 @@ MODULE Test; IMPORT Out; +TYPE + P1 = POINTER TO R1; + P2 = POINTER TO R2; + P3 = POINTER TO R3; + + R1 = RECORD END; + R2 = RECORD (R1) END; + R3 = RECORD (R2) END; + VAR - i : INTEGER; + r : P1; BEGIN + NEW(r); Out.Open; - i := 48; - FOR i := 32 TO i DO - Out.Int(i, 0); Out.Char(' '); + WITH r : P1 DO + Out.String("R1"); Out.Ln; END; - Out.Ln; END Test. diff --git a/notes b/notes index c245ba0..7666610 100644 --- a/notes +++ b/notes @@ -1,5 +1,4 @@ -- Сделать проверку повторов в CASE и выполнять прирывание при отсутствии ELSE. -- Сделать выполнение прерывания при отсутствии ELSE в операторе WITH. +- Сделать проверку повторов в CASE. - Сделать нормальную проверку наличия RETURN. - Нужно проверить правила совместимости типов (Приложение A). @@ -14,8 +13,6 @@ - JVM: Импортируемые модули не инициализируются - JVM: Не реализовано сравнение строк. -- JVM: Не достаточно средств для реализации рефлексии на уровне локальных процедур. - Как минимум нужно каждой функции добавлять фрейм к параметрам (динамическая связь?) - Уточнить как должна работать проверка импорта на чтение. (8.1) - Уточнить результат оператора "/" (8.2.2) @@ -27,3 +24,6 @@ - Нет проверок переполнения в компилтайме. Возможно можно заюзать это: https://gcc.gnu.org/onlinedocs/gcc/Integer-Overflow-Builtins.html + +- JVM: Не достаточно средств для реализации рефлексии на уровне локальных процедур. + Как минимум нужно каждой функции добавлять фрейм к параметрам (динамическая связь?) diff --git a/rtl/SYSTEM.java b/rtl/SYSTEM.java index 38f4886..44e1cc3 100644 --- a/rtl/SYSTEM.java +++ b/rtl/SYSTEM.java @@ -43,4 +43,20 @@ public class SYSTEM { assert x : n; } + + public static void TRAP(long n) + { + if(n == -1) + { + throw new RuntimeException("CASE TRAP"); + } + else if(n == -2) + { + throw new RuntimeException("WITH TRAP"); + } + else + { + throw new RuntimeException("TRAP CODE " + n); + } + } } diff --git a/src/backends/jvm/generator-jvm.c b/src/backends/jvm/generator-jvm.c index 4011965..bb11231 100644 --- a/src/backends/jvm/generator-jvm.c +++ b/src/backends/jvm/generator-jvm.c @@ -1687,6 +1687,19 @@ oberon_generate_assert_n(oberon_context_t * ctx, oberon_expr_t * cond, int64_t n jvm_generate(p, 1 + 2, 0, "invokestatic SYSTEM/ASSERT(ZJ)V"); } +void +oberon_generate_trap(oberon_context_t * ctx, int64_t n) +{ + gen_module_t * m; + gen_proc_t * p; + + m = ctx -> mod -> gen_mod; + p = m -> class -> p; + + jvm_generate_push_int_size(p, n, 8); + jvm_generate(p, 2, 0, "invokestatic SYSTEM/TRAP(J)V"); +} + void oberon_generate_halt(oberon_context_t * ctx, int64_t n) { diff --git a/src/generator.h b/src/generator.h index bc502cc..80bab13 100644 --- a/src/generator.h +++ b/src/generator.h @@ -41,5 +41,6 @@ void oberon_generate_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_ void oberon_generate_copy(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst); void oberon_generate_assert_n(oberon_context_t * ctx, oberon_expr_t * cond, int64_t n); void oberon_generate_assert(oberon_context_t * ctx, oberon_expr_t * cond); +void oberon_generate_trap(oberon_context_t * ctx, int64_t n); void oberon_generate_halt(oberon_context_t * ctx, int64_t n); void oberon_generate_return(oberon_context_t * ctx, oberon_expr_t * expr); diff --git a/src/oberon.c b/src/oberon.c index 59a5c3d..f67d392 100644 --- a/src/oberon.c +++ b/src/oberon.c @@ -3443,6 +3443,10 @@ oberon_case_statement(oberon_context_t * ctx) oberon_assert_token(ctx, ELSE); oberon_statement_seq(ctx); } + else + { + oberon_generate_trap(ctx, -1); + } oberon_generate_label(ctx, end); oberon_assert_token(ctx, END); @@ -3509,6 +3513,10 @@ oberon_with_statement(oberon_context_t * ctx) oberon_assert_token(ctx, ELSE); oberon_statement_seq(ctx); } + else + { + oberon_generate_trap(ctx, -2); + } oberon_generate_label(ctx, end); oberon_assert_token(ctx, END); -- 2.29.2 From d25fb653bfe19a696d3f53abd784d32ba2d3ee03 Mon Sep 17 00:00:00 2001 From: DeaDDooMER Date: Sat, 12 Aug 2017 15:40:26 +0300 Subject: [PATCH 11/16] =?utf8?q?=D0=9F=D1=80=D0=B0=D0=B2=D0=B8=D0=BB=D0=B0?= =?utf8?q?=20=D1=81=D0=BE=D0=B2=D0=BC=D0=B5=D1=81=D1=82=D0=B8=D0=BC=D0=BE?= =?utf8?q?=D1=81=D1=82=D0=B8=20=D1=82=D0=B8=D0=BF=D0=BE=D0=B2=20=D0=BF?= =?utf8?q?=D1=80=D0=B8=D0=B2=D0=B5=D0=B4=D0=B5=D0=BD=D1=8B=20=D0=B2=20?= =?utf8?q?=D1=81=D0=BE=D0=BE=D1=82=D0=B2=D0=B5=D1=82=D1=81=D1=82=D0=B2?= =?utf8?q?=D0=B8=D0=B5=20=D1=81=D0=BE=20=D1=81=D1=82=D1=80=D0=B0=D0=BD?= =?utf8?q?=D0=B4=D0=B0=D1=82=D1=80=D0=BE=D0=BC?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- Test.obn | 24 +- Test5.obn | 5 +- Test8.obn | 24 ++ Test9.obn | 18 + notes | 2 +- obn-run-tests.sh | 10 +- src/backends/jvm/generator-jvm.c | 7 +- src/oberon-common.c | 22 ++ src/oberon-common.h | 71 ++++ src/oberon-type-compat.c | 516 +++++++++++++++++++++++++++ src/oberon-type-compat.h | 102 ++++++ src/oberon.c | 591 ++++--------------------------- 12 files changed, 844 insertions(+), 548 deletions(-) create mode 100644 Test8.obn create mode 100644 Test9.obn create mode 100644 src/oberon-common.c create mode 100644 src/oberon-common.h create mode 100644 src/oberon-type-compat.c create mode 100644 src/oberon-type-compat.h diff --git a/Test.obn b/Test.obn index e044594..6713226 100644 --- a/Test.obn +++ b/Test.obn @@ -1,23 +1,13 @@ MODULE Test; -IMPORT Out; - -TYPE - P1 = POINTER TO R1; - P2 = POINTER TO R2; - P3 = POINTER TO R3; - - R1 = RECORD END; - R2 = RECORD (R1) END; - R3 = RECORD (R2) END; - VAR - r : P1; + i : INTEGER; + f : REAL; + d : LONGREAL; BEGIN - NEW(r); - Out.Open; - WITH r : P1 DO - Out.String("R1"); Out.Ln; - END; + i := 5 DIV 3; + f := 5 / 3; + d := 5 / 3.0; + d := 5 / 3.0D0; END Test. diff --git a/Test5.obn b/Test5.obn index 248d688..c92a398 100644 --- a/Test5.obn +++ b/Test5.obn @@ -7,6 +7,7 @@ TYPE P1 = POINTER TO R1; P2 = POINTER TO R2; + P3 = POINTER TO R3; VAR a : R1; @@ -14,9 +15,11 @@ VAR c : R3; p1 : P1; p2 : P2; + p3 : P3; BEGIN a := b; p2 := p1(P2); - p1 := p2(P2); + p1 := p2; + p3 := p3; END Test5. diff --git a/Test8.obn b/Test8.obn new file mode 100644 index 0000000..c81f6fc --- /dev/null +++ b/Test8.obn @@ -0,0 +1,24 @@ +MODULE Test8; + +VAR + s : SHORTINT; + i : INTEGER; + j : LONGINT; + f : REAL; + d : LONGREAL; + +BEGIN + s := 127; + s := s; + i := s; + i := i; + j := i; + j := j; + f := j; + f := f; + d := f; + d := d; +END Test8. + +Проверка поглощения типов. +LONGREAL >= REAL >= LONGINT >= INTEGER >= SHORTINT diff --git a/Test9.obn b/Test9.obn new file mode 100644 index 0000000..2a40b73 --- /dev/null +++ b/Test9.obn @@ -0,0 +1,18 @@ +MODULE Test9; + +VAR + i : INTEGER; + f : REAL; + d : LONGREAL; + x : SET; + +BEGIN + i := i + 1; + i := 5 DIV 3; + f := 5 / 3; + d := 5 / 3.0; + d := 5 / 3.0D0; + x := { 0..4 }; +END Test9. + +Проверка типов в операциях. diff --git a/notes b/notes index 7666610..31c1a4d 100644 --- a/notes +++ b/notes @@ -2,7 +2,6 @@ - Сделать нормальную проверку наличия RETURN. - Нужно проверить правила совместимости типов (Приложение A). -- Нет модуля SYSTEM - Нет функций ASH CAP CHR ENTIER LEN LONG ODD ORD SHORT - Нет процедур DEC EXCL INC INCL - Нет счёта строк / столбцов @@ -19,6 +18,7 @@ - Примеры -5 DIV 3 и -5 MOD 3 работают не так как в (8.2.2) Нужен другой тип округления? +- Нет модуля SYSTEM (на жабе он особо и не нужен) - Нужны средства создания биндингов. На данный момент реализуемо как заглушки для модулей. - Любая ошибка фатальна - Нет проверок переполнения в компилтайме. diff --git a/obn-run-tests.sh b/obn-run-tests.sh index 404c840..da13a65 100755 --- a/obn-run-tests.sh +++ b/obn-run-tests.sh @@ -8,10 +8,12 @@ maketest() if ! ./obn-compile.sh $1; then OK=0; echo "Test fail: $1 compile-time $?" fi - if ! ./obn-run.sh $1; then - OK=0; echo "Test fail: $1 run-time $?" + if [ $OK = 1 ]; then + if ! ./obn-run.sh $1; then + OK=0; echo "Test fail: $1 run-time $?" + fi fi - if [ $OK ]; then + if [ $OK = 1 ]; then echo "Test ok: $1" fi } @@ -34,3 +36,5 @@ maketest Test4 maketest Test5 maketest Test6 maketest Test7 +maketest Test8 +maketest Test9 diff --git a/src/backends/jvm/generator-jvm.c b/src/backends/jvm/generator-jvm.c index bb11231..21ad4db 100644 --- a/src/backends/jvm/generator-jvm.c +++ b/src/backends/jvm/generator-jvm.c @@ -1141,8 +1141,11 @@ jvm_generate_cast_type(gen_proc_t * p, oberon_type_t * from, oberon_type_t * to) { if(to -> class == OBERON_TYPE_RECORD || to -> class == OBERON_TYPE_POINTER) { - char * full_name = jvm_get_class_full_name(to); - jvm_generate(p, 1, 1, "checkcast %s", full_name); + if(to -> class == OBERON_TYPE_POINTER && to -> base -> class == OBERON_TYPE_RECORD) + { + char * full_name = jvm_get_class_full_name(to); + jvm_generate(p, 1, 1, "checkcast %s", full_name); + } } else { diff --git a/src/oberon-common.c b/src/oberon-common.c new file mode 100644 index 0000000..f1b6711 --- /dev/null +++ b/src/oberon-common.c @@ -0,0 +1,22 @@ +#include +#include +#include + +#include "../include/oberon.h" + +#include "oberon-internals.h" + +void +oberon_error(oberon_context_t * ctx, const char * fmt, ...) +{ + va_list ptr; + va_start(ptr, fmt); + fprintf(stderr, "error: "); + vfprintf(stderr, fmt, ptr); + fprintf(stderr, "\n"); + fprintf(stderr, " code_index = %i\n", ctx -> code_index); + fprintf(stderr, " c = %c\n", ctx -> c); + fprintf(stderr, " token = %i\n", ctx -> token); + va_end(ptr); + exit(1); +} diff --git a/src/oberon-common.h b/src/oberon-common.h new file mode 100644 index 0000000..ccbe6e1 --- /dev/null +++ b/src/oberon-common.h @@ -0,0 +1,71 @@ +enum { + EOF_ = 0, + IDENT, + MODULE, + SEMICOLON, + END, + DOT, + VAR, + COLON, + BEGIN, + ASSIGN, + INTEGER, + LPAREN, + RPAREN, + EQUAL, + NEQ, + LESS, + LEQ, + GREAT, + GEQ, + IN, + IS, + PLUS, + MINUS, + OR, + STAR, + SLASH, + DIV, + MOD, + AND, + NOT, + PROCEDURE, + COMMA, + RETURN, + CONST, + TYPE, + ARRAY, + OF, + LBRACK, + RBRACK, + RECORD, + POINTER, + TO, + UPARROW, + NIL, + IMPORT, + REAL, + CHAR, + STRING, + IF, + THEN, + ELSE, + ELSIF, + WHILE, + DO, + REPEAT, + UNTIL, + FOR, + BY, + LOOP, + EXIT, + LBRACE, + RBRACE, + DOTDOT, + CASE, + BAR, + WITH +}; + +void +oberon_error(oberon_context_t * ctx, const char * fmt, ...); diff --git a/src/oberon-type-compat.c b/src/oberon-type-compat.c new file mode 100644 index 0000000..6c3b698 --- /dev/null +++ b/src/oberon-type-compat.c @@ -0,0 +1,516 @@ +#include +#include +#include +#include +#include +#include +#include +#include + +#include "../include/oberon.h" + +#include "oberon-common.h" +#include "oberon-internals.h" +#include "oberon-type-compat.h" + +bool +oberon_is_array_type(oberon_type_t * t) +{ + return t -> class == OBERON_TYPE_ARRAY; +} + +bool +oberon_is_open_array(oberon_type_t * t) +{ + /* Открытые массивы всегда размером 0 */ + + return oberon_is_array_type(t) && (t -> size == 0); +} + +bool +oberon_is_real_type(oberon_type_t * t) +{ + return t -> class == OBERON_TYPE_REAL; +} + +bool +oberon_is_integer_type(oberon_type_t * t) +{ + return t -> class == OBERON_TYPE_INTEGER; +} + +bool +oberon_is_number_type(oberon_type_t * t) +{ + return oberon_is_integer_type(t) + || oberon_is_real_type(t); +} + +bool +oberon_is_char_type(oberon_type_t * t) +{ + return t -> class == OBERON_TYPE_CHAR; +} + +bool +oberon_is_set_type(oberon_type_t * t) +{ + return t -> class == OBERON_TYPE_SET; +} + +bool +oberon_is_string_type(oberon_type_t * t) +{ + return t -> class == OBERON_TYPE_STRING; +} + +bool +oberon_is_procedure_type(oberon_type_t * t) +{ + return t -> class == OBERON_TYPE_PROCEDURE; +} + +bool +oberon_is_record_type(oberon_type_t * t) +{ + return t -> class == OBERON_TYPE_RECORD; +} + +bool +oberon_is_pointer_type(oberon_type_t * t) +{ + return t -> class == OBERON_TYPE_POINTER; +} + +bool +oberon_is_pointer_to_record(oberon_type_t * t) +{ + return oberon_is_pointer_type(t) && oberon_is_record_type(t -> base); +} + +bool +oberon_is_boolean_type(oberon_type_t * t) +{ + return t -> class == OBERON_TYPE_BOOLEAN; +} + +bool +oberon_is_array_of_char_type(oberon_type_t * t) +{ + return oberon_is_array_type(t) && oberon_is_char_type(t -> base); +} + +bool +oberon_is_nil_type(oberon_type_t * t) +{ + return t -> class == OBERON_TYPE_NIL; +} + +bool +oberon_is_type_expr(oberon_expr_t * e) +{ + return (e -> is_item) && (e -> item.mode == MODE_TYPE); +} + + + +bool +oberon_is_some_types(oberon_type_t * a, oberon_type_t * b) +{ + /* Две переменные a и b с типами Ta и Tb имеют одинаковый тип, если */ + /* 1. Ta и Tb оба обозначены одним и тем же идентификатором типа, или */ + /* 2. Ta объявлен равным Tb в объявлении типа вида Ta = Tb, или */ + /* 3. a и b появляются в одном и том же списке идентификаторов переменных, полей записи */ + /* или объявлении формальных параметров и не являются открытыми массивами. */ + + return (a == b) && !oberon_is_open_array(a) && !oberon_is_open_array(b); +} + +bool +oberon_is_some_procedure_signatures(oberon_type_t * a, oberon_type_t * b) +{ + /* Два списка формальных параметров совпадают если */ + /* 1. они имеют одинаковое количество параметров, и */ + /* 2. они имеют или одинаковый тип результата функции или не имеют никакого, и */ + /* 3. параметры в соответствующих позициях имеют равные типы, и */ + /* 4. параметры в соответствующих позициях - оба или параметры-значения */ + /* или параметры-переменные. */ + + if(a -> num_decl != b -> num_decl) + { + return false; + } + + if(!oberon_is_some_types(a -> base, b -> base)) + { + return false; + } + + int num = a -> num_decl; + oberon_object_t * va = a -> decl; + oberon_object_t * vb = b -> decl; + for(int i = 0; i < num; i++) + { + if(!oberon_is_equal_types(va -> type, vb -> type)) + { + return false; + } + + if(va -> class != vb -> class) + { + return false; + } + + va = va -> next; + vb = vb -> next; + } + + return true; +} + +bool +oberon_is_equal_types(oberon_type_t * a, oberon_type_t * b) +{ + /* Два типа Ta, и Tb равны, если */ + /* 1. Ta и Tb - одинаковые типы, или */ + /* 2. Ta и Tb - типы открытый массив с равными типами элементов, или */ + /* 3. Ta и Tb - процедурные типы, чьи списки формальных параметров совпадают. */ + + return oberon_is_some_types(a, b) + || (oberon_is_open_array(a) && oberon_is_open_array(b) && oberon_is_some_types(a -> base, b -> base)) + || (oberon_is_procedure_type(a) && oberon_is_procedure_type(b) && oberon_is_some_procedure_signatures(a, b)); +} + +bool +oberon_incluses_type(oberon_type_t * a, oberon_type_t * b) +{ + /* a поглощает b */ + /* LONGREAL >= REAL >= LONGINT >= INTEGER >= SHORTINT */ + +/* + printf("oberon_incluses_type: a %i %i\n", a -> class, a -> size); + printf("oberon_incluses_type: b %i %i\n", b -> class, b -> size); +*/ + + if(a -> class == OBERON_TYPE_REAL) + { + if(b -> class == OBERON_TYPE_INTEGER) + { + return true; + } + else if(b -> class == OBERON_TYPE_REAL) + { + return (a -> size >= b -> size); + } + } + else if(a -> class == OBERON_TYPE_INTEGER) + { + if(b -> class == OBERON_TYPE_INTEGER) + { + return (a -> size >= b -> size); + } + } + + return false; +} + +bool +oberon_extension_of(oberon_type_t * ext, oberon_type_t * rec) +{ + /* Тип Tb есть расширение типа Ta (Ta есть базовый тип Tb) если */ + /* 1. Ta и Tb - одинаковые типы, или */ + /* 2. Tb - непосредственное расширение типа, являющегося расширением Ta */ + /* Если Pa = POINTER TO Ta и Pb = POINTER TO Tb, то Pb есть расширение Pa */ + /* (Pa есть базовый тип Pb), если Tb есть расширение Ta. */ + + if(ext -> class == OBERON_TYPE_POINTER && rec -> class == OBERON_TYPE_POINTER) + { + ext = ext -> base; + rec = rec -> base; + } + + if(ext -> class != OBERON_TYPE_RECORD || rec -> class != OBERON_TYPE_RECORD) + { + return false; + } + + if(oberon_is_some_types(ext, rec)) + { + return true; + } + + while(rec -> base) + { + if(oberon_is_some_types(ext, rec -> base)) + { + return true; + } + rec = rec -> base; + } + + return false; +} + +bool +oberon_is_const_string(oberon_expr_t * e) +{ + return e -> result -> class == OBERON_TYPE_STRING && e -> is_item && e -> item.mode == MODE_STRING; +} + +bool +oberon_is_assignment_compatible_expressions(oberon_expr_t * e, oberon_type_t * Tv) +{ + /* Выражение e типа Te совместимо по присваиванию с переменной v типа Tv, */ + /* если выполнено одно из следующих условий: */ + /* 1. Te и Tv - одинаковые типы; */ + /* 2. Te и Tv - числовые типы и Tv поглощает Te; */ + /* 3. Te и Tv - типы запись, Te есть расширение Tv, а v имеет динамический тип Tv; */ + /* 4. Te и Tv - типы указатель и Te - расширение Tv; */ + /* 5. Tv - тип указатель или процедурный тип, а e - NIL; */ + /* 6. Tv - ARRAY n OF CHAR, e - строковая константа из m символов и m < n; */ + /* 7. Tv - процедурный тип, а e - имя процедуры, чьи формальные параметры */ + /* совпадают с параметрами Tv. */ + /* Доп: Tv - символ, е - строковая константа из одного символа */ + + oberon_type_t * Te = e -> result; + +/* + printf("<<< oberon_is_assignment_compatible_expressions ===\n"); + printf(": Te -> class == %i\n", Te -> class); + printf(": Tv -> class == %i\n", Tv -> class); + printf(":: oberon_is_some_types(Te, Tv) == %i\n", oberon_is_some_types(Te, Tv)); + printf("::: oberon_is_number_type(Te) == %i\n", oberon_is_number_type(Te)); + printf("::: oberon_is_number_type(Tv) == %i\n", oberon_is_number_type(Tv)); + printf("::: oberon_incluses_type(Tv, Te) == %i\n", oberon_incluses_type(Tv, Te)); + printf(":::: oberon_is_record_type(Te) == %i\n", oberon_is_record_type(Te)); + printf(":::: oberon_is_record_type(Tv) == %i\n", oberon_is_record_type(Tv)); +// printf(":::: oberon_extension_of(Te, Tv) == %i\n", oberon_extension_of(Te, Tv)); + printf(":::: oberon_extension_of(Tv, Te) == %i\n", oberon_extension_of(Tv, Te)); + printf("=== oberon_is_assignment_compatible_expressions >>>\n"); +*/ + + return oberon_is_some_types(Te, Tv) + || (oberon_is_number_type(Te) && oberon_is_number_type(Tv) && oberon_incluses_type(Tv, Te)) + || (oberon_is_record_type(Te) && oberon_is_record_type(Tv) && oberon_extension_of(Tv, Te)) + || (oberon_is_pointer_type(Te) && oberon_is_pointer_type(Tv) && oberon_extension_of(Tv, Te)) + || ((oberon_is_pointer_type(Tv) || oberon_is_procedure_type(Tv)) && oberon_is_nil_type(Te)) + || (oberon_is_array_of_char_type(Tv) && !oberon_is_open_array(Tv) && oberon_is_const_string(e) && (strlen(e -> item.string) < Tv -> size)) + || (oberon_is_procedure_type(Tv) && e -> is_item && e -> item.var -> class == OBERON_CLASS_PROC && oberon_is_some_procedure_signatures(Tv, e -> result)) + || (oberon_is_char_type(Tv) && oberon_is_const_string(e) && strlen(e -> item.string) == 1); +} + +static bool +oberon_is_compatible_arrays_types(oberon_type_t * Tf, oberon_type_t * Ta) +{ + /* Фактический параметр a типа Ta является совместимым массивом для формального параметра f типа Tf если */ + /* 1. Tf и Ta - одинаковые типы или */ + /* 2. Tf - открытый массив, Ta - любой массив, а типы их элементов - совместимые массивы или */ + /* 3. f - параметр-значение типа ARRAY OF CHAR, а фактический параметр a - строка. */ + + return oberon_is_some_types(Tf, Ta) + || (oberon_is_open_array(Tf) && oberon_is_array_type(Ta) && oberon_is_compatible_arrays_types(Tf -> base, Ta -> base)); +} + +bool +oberon_is_compatible_arrays(oberon_object_t * f, oberon_expr_t * a) +{ + oberon_type_t * Tf = f -> type; + oberon_type_t * Ta = a -> result; + + return oberon_is_compatible_arrays_types(Tf, Ta) + || (oberon_is_array_of_char_type(Tf) && oberon_is_const_string(a)); +} + +void +oberon_check_compatible_arrays(oberon_context_t * ctx, oberon_object_t * f, oberon_expr_t * a) +{ + if(!oberon_is_compatible_arrays(f, a)) + { + oberon_error(ctx, "incompatible types"); + } +} + +bool +oberon_is_compatible_bin_expr_types(int token, oberon_type_t * a, oberon_type_t * b) +{ + if(token == PLUS || token == MINUS || token == STAR || token == SLASH) + { + if(oberon_is_number_type(a) && oberon_is_number_type(b)) + { + return true; + } + else if(oberon_is_set_type(a) && oberon_is_set_type(b)) + { + return true; + } + } + else if(token == DIV || token == MOD) + { + if(oberon_is_integer_type(a) && oberon_is_integer_type(b)) + { + return true; + } + } + else if(token == OR || token == AND) + { + if(oberon_is_boolean_type(a) && oberon_is_boolean_type(b)) + { + return true; + } + } + else if(token == EQUAL || token == NEQ) + { + if(oberon_is_number_type(a) && oberon_is_number_type(b)) + { + return true; + } + else if(oberon_is_char_type(a) && oberon_is_char_type(b)) + { + return true; + } + else if((oberon_is_array_of_char_type(a) || oberon_is_string_type(a)) + && (oberon_is_array_of_char_type(b) || oberon_is_string_type(b))) + { + return true; + } + else if(oberon_is_boolean_type(a) && oberon_is_boolean_type(b)) + { + return true; + } + else if(oberon_is_set_type(a) && oberon_is_set_type(b)) + { + return true; + } + else if((oberon_is_nil_type(a) || oberon_is_pointer_to_record(a) || oberon_is_procedure_type(a)) + && (oberon_is_nil_type(b) || oberon_is_pointer_to_record(b) || oberon_is_procedure_type(b))) + { + return true; + } + } + else if(token == LESS || token == LEQ || token == GREAT || token == GEQ) + { + if(oberon_is_number_type(a) && oberon_is_number_type(b)) + { + return true; + } + else if(oberon_is_char_type(a) && oberon_is_char_type(b)) + { + return true; + } + else if((oberon_is_array_of_char_type(a) || oberon_is_string_type(a)) + && (oberon_is_array_of_char_type(b) || oberon_is_string_type(b))) + { + return true; + } + } + else if(token == IN) + { + if(oberon_is_integer_type(a) && oberon_is_set_type(b)) + { + return true; + } + } + else if(token == IS) + { + if(oberon_extension_of(a, b)) + { + return true; + } + } + + return false; +} + +bool +oberon_is_compatible_var_param(oberon_type_t * Tf, oberon_type_t * Ta) +{ + /* Пусть Tf - тип формального параметра f (не открытого массива) */ + /* и Ta - тип соответствующего фактического параметра a. */ + /* Для параметров-переменных Ta и Tf должны быть одинаковыми типами */ + /* или Tf должен быть типом запись, а Ta - расширением Tf. */ + + return oberon_is_some_types(Tf, Ta) + || (oberon_is_record_type(Tf) && oberon_extension_of(Ta, Tf)); +} + +void +oberon_check_compatible_var_param(oberon_context_t * ctx, oberon_type_t * Tf, oberon_type_t * Ta) +{ + if(!oberon_is_compatible_var_param(Tf, Ta)) + { + oberon_error(ctx, "incompatible types"); + } +} + +void +oberon_check_type_expr(oberon_context_t * ctx, oberon_expr_t * e) +{ + if(!oberon_is_type_expr(e)) + { + oberon_error(ctx, "expected type"); + } +} + +void +oberon_check_compatible_bin_expr_types(oberon_context_t * ctx, int token, oberon_type_t * a, oberon_type_t * b) +{ + if(!oberon_is_compatible_bin_expr_types(token, a, b)) + { + oberon_error(ctx, "incompatibe expression types"); + } +} + +void +oberon_check_assignment_compatible(oberon_context_t * ctx, oberon_expr_t * e, oberon_type_t * Tv) +{ + if(!oberon_is_assignment_compatible_expressions(e, Tv)) + { + oberon_error(ctx, "incompatible types"); + } +} + +void +oberon_check_extension_of(oberon_context_t * ctx, oberon_type_t * ext, oberon_type_t * rec) +{ + if(!oberon_extension_of(ext, rec)) + { + oberon_error(ctx, "not extension"); + } +} + +oberon_type_t * +oberon_get_longer_type(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b) +{ + if(oberon_incluses_type(a, b)) + { + return a; + } + else if(oberon_incluses_type(b, a)) + { + return b; + } + else + { + oberon_error(ctx, "oberon_get_longer_type: error"); + return NULL; + } +} + +oberon_type_t * +oberon_get_longer_real_type(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b) +{ + oberon_type_t * result = oberon_get_longer_type(ctx, a, b); + if(oberon_is_integer_type(result)) + { + return ctx -> real_type; + } + else if(oberon_is_real_type(result)) + { + return result; + } + else + { + oberon_error(ctx, "oberon_get_longer_real_type: error"); + return NULL; + } +} diff --git a/src/oberon-type-compat.h b/src/oberon-type-compat.h new file mode 100644 index 0000000..b09dccc --- /dev/null +++ b/src/oberon-type-compat.h @@ -0,0 +1,102 @@ +bool +oberon_is_array_type(oberon_type_t * t); + +bool +oberon_is_open_array(oberon_type_t * t); + +bool +oberon_is_real_type(oberon_type_t * t); + +bool +oberon_is_integer_type(oberon_type_t * t); + +bool +oberon_is_number_type(oberon_type_t * t); + +bool +oberon_is_char_type(oberon_type_t * t); + +bool +oberon_is_set_type(oberon_type_t * t); + +bool +oberon_is_string_type(oberon_type_t * t); + +bool +oberon_is_procedure_type(oberon_type_t * t); + +bool +oberon_is_record_type(oberon_type_t * t); + +bool +oberon_is_pointer_type(oberon_type_t * t); + +bool +oberon_is_pointer_to_record(oberon_type_t * t); + +bool +oberon_is_boolean_type(oberon_type_t * t); + +bool +oberon_is_array_of_char_type(oberon_type_t * t); + + + +bool +oberon_is_some_types(oberon_type_t * a, oberon_type_t * b); + +bool +oberon_is_some_procedure_signatures(oberon_type_t * a, oberon_type_t * b); + +bool +oberon_is_equal_types(oberon_type_t * a, oberon_type_t * b); + +bool +oberon_incluses_type(oberon_type_t * from, oberon_type_t * to); + +bool +oberon_extension_of(oberon_type_t * ext, oberon_type_t * rec); + +bool +oberon_is_const_string(oberon_expr_t * e); + +bool +oberon_is_assignment_compatible_expressions(oberon_expr_t * e, oberon_type_t * Tv); + +bool +oberon_is_compatible_arrays(oberon_object_t * f, oberon_expr_t * a); + +bool +oberon_is_compatible_bin_expr_types(int token, oberon_type_t * a, oberon_type_t * b); + + + +void +oberon_check_type_expr(oberon_context_t * ctx, oberon_expr_t * e); + +void +oberon_check_compatible_bin_expr_types(oberon_context_t * ctx, int token, oberon_type_t * a, oberon_type_t * b); + +void +oberon_check_compatible_arrays(oberon_context_t * ctx, oberon_object_t * f, oberon_expr_t * a); + +void +oberon_check_assignment_compatible(oberon_context_t * ctx, oberon_expr_t * e, oberon_type_t * Tv); + +void +oberon_check_extension_of(oberon_context_t * ctx, oberon_type_t * ext, oberon_type_t * rec); + + + +oberon_type_t * +oberon_get_longer_type(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b); + +oberon_type_t * +oberon_get_longer_real_type(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b); + + +bool +oberon_is_compatible_var_param(oberon_type_t * Tf, oberon_type_t * Ta); + +void +oberon_check_compatible_var_param(oberon_context_t * ctx, oberon_type_t * Tf, oberon_type_t * Ta); diff --git a/src/oberon.c b/src/oberon.c index f67d392..6f9395c 100644 --- a/src/oberon.c +++ b/src/oberon.c @@ -10,77 +10,10 @@ #include "../include/oberon.h" #include "oberon-internals.h" +#include "oberon-type-compat.h" +#include "oberon-common.h" #include "generator.h" -enum { - EOF_ = 0, - IDENT, - MODULE, - SEMICOLON, - END, - DOT, - VAR, - COLON, - BEGIN, - ASSIGN, - INTEGER, - LPAREN, - RPAREN, - EQUAL, - NEQ, - LESS, - LEQ, - GREAT, - GEQ, - IN, - IS, - PLUS, - MINUS, - OR, - STAR, - SLASH, - DIV, - MOD, - AND, - NOT, - PROCEDURE, - COMMA, - RETURN, - CONST, - TYPE, - ARRAY, - OF, - LBRACK, - RBRACK, - RECORD, - POINTER, - TO, - UPARROW, - NIL, - IMPORT, - REAL, - CHAR, - STRING, - IF, - THEN, - ELSE, - ELSIF, - WHILE, - DO, - REPEAT, - UNTIL, - FOR, - BY, - LOOP, - EXIT, - LBRACE, - RBRACE, - DOTDOT, - CASE, - BAR, - WITH -}; - // ======================================================================= // UTILS // ======================================================================= @@ -88,21 +21,6 @@ enum { static void oberon_make_copy_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args); -static void -oberon_error(oberon_context_t * ctx, const char * fmt, ...) -{ - va_list ptr; - va_start(ptr, fmt); - fprintf(stderr, "error: "); - vfprintf(stderr, fmt, ptr); - fprintf(stderr, "\n"); - fprintf(stderr, " code_index = %i\n", ctx -> code_index); - fprintf(stderr, " c = %c\n", ctx -> c); - fprintf(stderr, " token = %i\n", ctx -> token); - va_end(ptr); - exit(1); -} - static oberon_type_t * oberon_new_type_ptr(int class) { @@ -693,6 +611,7 @@ static void oberon_read_string(oberon_context_t * ctx) ctx -> token = STRING; ctx -> string = string; + ctx -> integer = string[0]; } static void oberon_read_token(oberon_context_t * ctx); @@ -978,81 +897,20 @@ 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) { - 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; - - 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, "must be record type"); - } - - return oberon_cast_expr(ctx, expr, rec); -} + oberon_expr_t * cast; -static oberon_type_t * -oberon_get_equal_expr_type(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b) -{ - oberon_type_t * result; - if(a -> class == OBERON_TYPE_REAL && b -> class == OBERON_TYPE_INTEGER) - { - result = a; - } - else if(b -> class == OBERON_TYPE_REAL && a -> class == OBERON_TYPE_INTEGER) + if((oberon_is_char_type(pref) && oberon_is_const_string(expr) && strlen(expr -> item.string) == 1)) { - result = b; - } - else if(a -> class != b -> class) - { - oberon_error(ctx, "oberon_get_equal_expr_type: incompatible types"); - } - else if(a -> size > b -> size) - { - result = a; + /* Автоматически преобразуем строку единичного размера в символ */ + cast = oberon_new_item(MODE_CHAR, ctx -> char_type, true); + cast -> item.integer = expr -> item.string[0]; } else { - result = b; + cast = oberon_new_operator(OP_CAST, pref, expr, NULL); } - 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"); - } + return cast; } static void @@ -1096,132 +954,6 @@ oberon_check_src(oberon_context_t * ctx, oberon_expr_t * src) } } -static oberon_expr_t * -oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref) -{ - // Допускается: - // Если классы типов равны - // Если INTEGER переводится в REAL - // Если STRING переводится в CHAR - // Если STRING переводится в ARRAY OF CHAR - // Если NIL переводится в POINTER - // Если NIL переводится в PROCEDURE - - oberon_check_src(ctx, expr); - - bool error = false; - if(pref -> class != expr -> result -> class) - { - if(expr -> result -> class == OBERON_TYPE_NIL) - { - if(pref -> class != OBERON_TYPE_POINTER - && pref -> class != OBERON_TYPE_PROCEDURE) - { - error = true; - } - } - else if(expr -> result -> class == OBERON_TYPE_STRING) - { - if(pref -> class == OBERON_TYPE_CHAR) - { - if(expr -> is_item && expr -> item.mode == MODE_STRING) - { - if(strlen(expr -> item.string) != 1) - { - error = true; - } - } - else - { - error = true; - } - } - else if(pref -> class == OBERON_TYPE_ARRAY) - { - if(pref -> base -> class != OBERON_TYPE_CHAR) - { - error = true; - } - } - else - { - error = true; - } - } - else if(expr -> result -> class == OBERON_TYPE_INTEGER) - { - if(pref -> class != OBERON_TYPE_REAL) - { - error = true; - } - } - else - { - error = true; - } - } - - if(error) - { - oberon_error(ctx, "oberon_autocast_to: incompatible types"); - } - - if(pref -> class == OBERON_TYPE_CHAR) - { - if(expr -> result -> class == OBERON_TYPE_STRING) - { - int c = expr -> item.string[0]; - expr = oberon_new_item(MODE_CHAR, ctx -> char_type, true); - expr -> item.integer = c; - } - } - else if(pref -> class == OBERON_TYPE_INTEGER || pref -> class == OBERON_TYPE_REAL) - { - if(expr -> result -> size > pref -> size) - { - oberon_error(ctx, "incompatible size"); - } - else - { - expr = oberon_cast_expr(ctx, expr, pref); - } - } - else if(pref -> class == OBERON_TYPE_RECORD) - { - oberon_check_record_compatibility(ctx, expr -> result, pref); - expr = oberno_make_record_cast(ctx, expr, pref); - } - else if(pref -> class == OBERON_TYPE_POINTER) - { - assert(pref -> base); - if(expr -> result -> class == OBERON_TYPE_NIL) - { - // do nothing - } - else 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) - { - oberon_error(ctx, "incompatible pointer types"); - } - } - - return expr; -} - -static void -oberon_autocast_binary_op(oberon_context_t * ctx, oberon_expr_t ** ea, oberon_expr_t ** eb) -{ - oberon_type_t * a = (*ea) -> result; - oberon_type_t * b = (*eb) -> result; - oberon_type_t * preq = oberon_get_equal_expr_type(ctx, a, b); - *ea = oberon_autocast_to(ctx, *ea, preq); - *eb = oberon_autocast_to(ctx, *eb, preq); -} - static void oberon_autocast_call(oberon_context_t * ctx, oberon_item_t * desig) { @@ -1251,19 +983,21 @@ oberon_autocast_call(oberon_context_t * ctx, oberon_item_t * desig) { if(param -> class == OBERON_CLASS_VAR_PARAM) { - if(arg -> result != param -> type) - { - oberon_error(ctx, "incompatible type"); - } - if(arg -> read_only) + oberon_check_dst(ctx, arg); + if(!oberon_is_compatible_arrays(param, arg)) { - oberon_error(ctx, "assign to read-only var"); + oberon_check_compatible_var_param(ctx, param -> type, arg -> result); } - casted[i] = arg; + casted[i] = oberon_cast_expr(ctx, arg, param -> type); } else { - casted[i] = oberon_autocast_to(ctx, arg, param -> type); + oberon_check_src(ctx, arg); + if(!oberon_is_compatible_arrays(param, arg)) + { + oberon_check_assignment_compatible(ctx, arg, param -> type); + } + casted[i] = oberon_cast_expr(ctx, arg, param -> type); } arg = arg -> next; @@ -1581,47 +1315,6 @@ oberon_qualident_expr(oberon_context_t * ctx) return expr; } -static void -oberon_check_type_guard(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * type) -{ - /* Охрана типа применима, если */ - /* 1. v - параметр-переменная типа запись, или v - указатель, и если */ - /* 2. T - расширение статического типа v */ - - if(expr -> is_item - && expr -> item.mode == MODE_VAR - && expr -> item.var -> class == OBERON_CLASS_VAR_PARAM) - { - // accept - } - else if(expr -> result -> class == OBERON_TYPE_POINTER - || expr -> result -> class == OBERON_TYPE_RECORD) - { - // accept - } - else - { - oberon_error(ctx, "guard type used only with var-param or pointers"); - } - - oberon_check_record_compatibility(ctx, type, expr -> result); -} - -static oberon_expr_t * -oberon_make_type_guard(oberon_context_t * ctx, oberon_expr_t * expr, oberon_object_t * objtype) -{ - oberon_type_t * type; - - if(objtype -> class != OBERON_CLASS_TYPE) - { - oberon_error(ctx, "must be type"); - } - type = objtype -> type; - - oberon_check_type_guard(ctx, expr, type); - return oberno_make_record_cast(ctx, expr, objtype -> type); -} - static oberon_expr_t * oberon_designator(oberon_context_t * ctx) { @@ -1661,7 +1354,8 @@ oberon_designator(oberon_context_t * ctx) oberon_assert_token(ctx, LPAREN); objtype = oberon_qualident(ctx, NULL, true); oberon_assert_token(ctx, RPAREN); - expr = oberon_make_type_guard(ctx, expr, objtype); + oberon_check_extension_of(ctx, expr -> result, objtype -> type); + expr = oberon_cast_expr(ctx, expr, objtype -> type); break; default: oberon_error(ctx, "oberon_designator: wat"); @@ -1760,6 +1454,7 @@ oberon_element(oberon_context_t * ctx) oberon_expr_t * e2; e1 = oberon_expr(ctx); + oberon_check_src(ctx, e1); if(e1 -> result -> class != OBERON_TYPE_INTEGER) { oberon_error(ctx, "expected integer"); @@ -1770,6 +1465,7 @@ oberon_element(oberon_context_t * ctx) { oberon_assert_token(ctx, DOTDOT); e2 = oberon_expr(ctx); + oberon_check_src(ctx, e2); if(e2 -> result -> class != OBERON_TYPE_INTEGER) { oberon_error(ctx, "expected integer"); @@ -1873,172 +1569,34 @@ oberon_factor(oberon_context_t * ctx) return expr; } -static void -oberon_autocast_to_real(oberon_context_t * ctx, oberon_expr_t ** e) -{ - oberon_expr_t * expr = *e; - if(expr -> result -> class == OBERON_TYPE_INTEGER) - { - if(expr -> result -> size <= ctx -> real_type -> size) - { - *e = oberon_cast_expr(ctx, expr, ctx -> real_type); - } - else - { - *e = oberon_cast_expr(ctx, expr, ctx -> longreal_type); - } - } - else if(expr -> result -> class != OBERON_TYPE_REAL) - { - oberon_error(ctx, "required numeric type"); - } -} - -static bool -oberon_is_numeric_type(oberon_type_t * t) -{ - return (t -> class == OBERON_TYPE_INTEGER) || (t -> class == OBERON_TYPE_REAL); -} - -static bool -oberon_is_char_type(oberon_type_t * t) -{ - return (t -> class == OBERON_TYPE_CHAR); -} - -static bool -oberon_is_string_type(oberon_type_t * t) -{ - return (t -> class == OBERON_TYPE_STRING) - || (t -> class == OBERON_TYPE_ARRAY && t -> base -> class == OBERON_TYPE_CHAR); -} - -static bool -oberon_is_boolean_type(oberon_type_t * t) -{ - return (t -> class == OBERON_TYPE_BOOLEAN); -} - -static bool -oberon_is_set_type(oberon_type_t * t) -{ - return (t -> class == OBERON_TYPE_SET); -} - -static bool -oberon_is_pointer_type(oberon_type_t * t) -{ - return (t -> class == OBERON_TYPE_POINTER) || (t -> class == OBERON_TYPE_NIL); -} - -static bool -oberon_is_procedure_type(oberon_type_t * t) -{ - return (t -> class == OBERON_TYPE_POINTER) || (t -> class == OBERON_TYPE_NIL); -} - 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; + oberon_check_compatible_bin_expr_types(ctx, token, a -> result, b -> result); + oberon_check_src(ctx, a); + if(token != IS) + { + oberon_check_src(ctx, b); + } + bool error = false; if(token == IN) { - if(a -> result -> class != OBERON_TYPE_INTEGER) - { - oberon_error(ctx, "must be integer"); - } - - if(b -> result -> class != OBERON_TYPE_SET) - { - oberon_error(ctx, "must be set"); - } - - result = ctx -> bool_type; - expr = oberon_new_operator(OP_IN, result, a, b); + expr = oberon_new_operator(OP_IN, ctx -> bool_type, a, b); } else if(token == IS) { - if(b -> is_item == false || b -> item.mode != MODE_TYPE) - { - oberon_error(ctx, "requires type"); - } - - result = ctx -> bool_type; - oberon_check_type_guard(ctx, a, b -> result); - expr = oberon_new_operator(OP_IS, result, a, b); + oberon_check_type_expr(ctx, b); + expr = oberon_new_operator(OP_IS, ctx -> bool_type, a, b); } else if((token >= EQUAL && token <= GEQ) || token == OR || token == AND) { - if(token >= LESS && token <= GEQ) - { - if(oberon_is_numeric_type(a -> result) && oberon_is_numeric_type(b -> result)) - { - // accept - } - else if(oberon_is_char_type(a -> result) && oberon_is_char_type(b -> result)) - { - // accept - } - else if(oberon_is_string_type(a -> result) && oberon_is_string_type(b -> result)) - { - // accept - } - else - { - oberon_error(ctx, "invalid comparation"); - } - } - else if(token == EQUAL || token == NEQ) - { - if(oberon_is_numeric_type(a -> result) && oberon_is_numeric_type(b -> result)) - { - // accept - } - else if(oberon_is_char_type(a -> result) && oberon_is_char_type(b -> result)) - { - // accept - } - else if(oberon_is_string_type(a -> result) && oberon_is_string_type(b -> result)) - { - // accept - } - else if(oberon_is_boolean_type(a -> result) && oberon_is_boolean_type(b -> result)) - { - // accept - } - else if(oberon_is_set_type(a -> result) && oberon_is_set_type(b -> result)) - { - // accept - } - else if(oberon_is_pointer_type(a -> result) && oberon_is_pointer_type(b -> result)) - { - // accept - } - else if(oberon_is_procedure_type(a -> result) && oberon_is_procedure_type(b -> result)) - { - // accept - } - else - { - oberon_error(ctx, "invalid comparation"); - } - } - else if(token == AND || token == OR) - { - if(!oberon_is_boolean_type(a -> result) || !oberon_is_boolean_type(b -> result)) - { - oberon_error(ctx, "invalid comparation"); - } - } - else - { - oberon_error(ctx, "wat"); - } - - oberon_autocast_binary_op(ctx, &a, &b); + result = oberon_get_longer_type(ctx, a -> result, b -> result); + a = oberon_cast_expr(ctx, a, result); + b = oberon_cast_expr(ctx, b, result); result = ctx -> bool_type; if(token == EQUAL) @@ -2080,38 +1638,34 @@ oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_ } else if(token == SLASH) { - if(a -> result -> class == OBERON_TYPE_SET - || b -> result -> class == OBERON_TYPE_SET) + if(oberon_is_set_type(a -> result) && oberon_is_set_type(b -> result)) { - oberon_autocast_binary_op(ctx, &a, &b); - result = a -> result; + result = oberon_get_longer_type(ctx, a -> result, b -> result); + a = oberon_cast_expr(ctx, a, result); + b = oberon_cast_expr(ctx, b, result); expr = oberon_new_operator(OP_SYM_DIFFERENCE, result, a, b); } else { - oberon_autocast_to_real(ctx, &a); - oberon_autocast_to_real(ctx, &b); - oberon_autocast_binary_op(ctx, &a, &b); - result = a -> result; + result = oberon_get_longer_real_type(ctx, a -> result, b -> result); + a = oberon_cast_expr(ctx, a, result); + b = oberon_cast_expr(ctx, b, result); expr = oberon_new_operator(OP_DIV, result, a, b); } } else if(token == DIV) { - if(a -> result -> class != OBERON_TYPE_INTEGER - || b -> result -> class != OBERON_TYPE_INTEGER) - { - oberon_error(ctx, "operator DIV requires integer type"); - } - - oberon_autocast_binary_op(ctx, &a, &b); - expr = oberon_new_operator(OP_DIV, a -> result, a, b); + result = oberon_get_longer_type(ctx, a -> result, b -> result); + a = oberon_cast_expr(ctx, a, result); + b = oberon_cast_expr(ctx, b, result); + expr = oberon_new_operator(OP_DIV, result, a, b); } else { - oberon_autocast_binary_op(ctx, &a, &b); - result = a -> result; - if(result -> class == OBERON_TYPE_SET) + result = oberon_get_longer_type(ctx, a -> result, b -> result); + a = oberon_cast_expr(ctx, a, result); + b = oberon_cast_expr(ctx, b, result); + if(oberon_is_set_type(result)) { switch(token) { @@ -2129,8 +1683,7 @@ oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_ break; } } - else if(result -> class == OBERON_TYPE_INTEGER - || result -> class == OBERON_TYPE_REAL) + else if(oberon_is_number_type(result)) { switch(token) { @@ -2517,7 +2070,9 @@ oberon_make_return(oberon_context_t * ctx, oberon_expr_t * expr) oberon_error(ctx, "procedure requires expression on result"); } - expr = oberon_autocast_to(ctx, expr, result_type); + oberon_check_src(ctx, expr); + oberon_check_assignment_compatible(ctx, expr, result_type); + expr = oberon_cast_expr(ctx, expr, result_type); } proc -> has_return = 1; @@ -3327,28 +2882,17 @@ oberon_statement_seq(oberon_context_t * ctx); static void oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst) { - if(src -> is_item - && src -> item.mode == MODE_STRING - && src -> result -> class == OBERON_TYPE_STRING - && dst -> result -> class == OBERON_TYPE_ARRAY - && dst -> result -> base -> class == OBERON_TYPE_CHAR - && dst -> result -> size > 0) - { + oberon_check_dst(ctx, dst); + oberon_check_assignment_compatible(ctx, src, dst -> result); - if(strlen(src -> item.string) < dst -> result -> size) - { - src -> next = dst; - oberon_make_copy_call(ctx, 2, src); - } - else - { - oberon_error(ctx, "string too long for destination"); - } + if(oberon_is_string_type(src -> result)) + { + src -> next = dst; + oberon_make_copy_call(ctx, 2, src); } else { - oberon_check_dst(ctx, dst); - src = oberon_autocast_to(ctx, src, dst -> result); + src = oberon_cast_expr(ctx, src, dst -> result); oberon_generate_assign(ctx, src, dst); } } @@ -3362,14 +2906,12 @@ oberon_case_labels(oberon_context_t * ctx, oberon_expr_t * val) oberon_expr_t * cond2; e1 = (oberon_expr_t *) oberon_const_expr(ctx); - oberon_autocast_to(ctx, e1, val -> result); e2 = NULL; if(ctx -> token == DOTDOT) { oberon_assert_token(ctx, DOTDOT); e2 = (oberon_expr_t *) oberon_const_expr(ctx); - oberon_autocast_to(ctx, e2, val -> result); } if(e2 == NULL) @@ -3476,7 +3018,8 @@ oberon_with_guard_do(oberon_context_t * ctx, gen_label_t * end) /* Сохраняем ссылку во временной переменной */ val = oberon_make_temp_var_item(ctx, type -> result); - cast = oberno_make_record_cast(ctx, var, type -> result); + //cast = oberno_make_record_cast(ctx, var, type -> result); + cast = oberon_cast_expr(ctx, var, type -> result); oberon_assign(ctx, cast, val); /* Подменяем тип у оригинальной переменной */ old_type = var -> item.var -> type; @@ -4176,12 +3719,12 @@ oberon_make_copy_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list dst = list_args -> next; oberon_check_dst(ctx, dst); - if(!oberon_is_string_type(src -> result)) + if(!oberon_is_string_type(src -> result) && !oberon_is_array_of_char_type(src -> result)) { oberon_error(ctx, "source must be string or array of char"); } - if(!oberon_is_string_type(dst -> result)) + if(!oberon_is_array_of_char_type(dst -> result)) { oberon_error(ctx, "dst must be array of char"); } -- 2.29.2 From 75d0fd92a5342358f37ed9369ccce9355273e51a Mon Sep 17 00:00:00 2001 From: DeaDDooMER Date: Sat, 12 Aug 2017 17:41:39 +0300 Subject: [PATCH 12/16] =?utf8?q?JVM:=20=D0=94=D0=BE=D0=B1=D0=B0=D0=B2?= =?utf8?q?=D0=BB=D0=B5=D0=BD=D0=BE=20=D1=81=D1=80=D0=B0=D0=B2=D0=BD=D0=B5?= =?utf8?q?=D0=BD=D0=B8=D0=B5=20=D1=81=D1=82=D1=80=D0=BE=D0=BA?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- Test.obn | 26 ++++++++++++++++++-------- Test10.obn | 25 +++++++++++++++++++++++++ notes | 5 +---- obn-run-tests.sh | 1 + rtl/SYSTEM.java | 12 ++++++++++++ src/backends/jvm/generator-jvm.c | 13 +++++++++++++ src/oberon-type-compat.c | 14 ++------------ 7 files changed, 72 insertions(+), 24 deletions(-) create mode 100644 Test10.obn diff --git a/Test.obn b/Test.obn index 6713226..4bde081 100644 --- a/Test.obn +++ b/Test.obn @@ -1,13 +1,23 @@ MODULE Test; -VAR - i : INTEGER; - f : REAL; - d : LONGREAL; +IMPORT Out; BEGIN - i := 5 DIV 3; - f := 5 / 3; - d := 5 / 3.0; - d := 5 / 3.0D0; + IF "abc" = "abc" THEN + Out.String("Equal abc = abc"); Out.Ln; + ELSE + Out.String("WAT: MUST BE abc = abc"); Out.Ln; + END; + + IF "cba" > "abc" THEN + Out.String("Great cba > abc"); Out.Ln; + ELSE + Out.String("WAT: MUST BE cba = abc"); Out.Ln; + END; + + IF "abc" < "bc" THEN + Out.String("Less abc < bc"); Out.Ln; + ELSE + Out.String("WAT: MUST BE abc < bc"); Out.Ln; + END; END Test. diff --git a/Test10.obn b/Test10.obn new file mode 100644 index 0000000..7b4b811 --- /dev/null +++ b/Test10.obn @@ -0,0 +1,25 @@ +MODULE Test10; + +IMPORT Out; + +BEGIN + IF "abc" = "abc" THEN + Out.String("Equal abc = abc"); Out.Ln; + ELSE + Out.String("WAT: MUST BE abc = abc"); Out.Ln; + END; + + IF "cba" > "abc" THEN + Out.String("Great cba > abc"); Out.Ln; + ELSE + Out.String("WAT: MUST BE cba = abc"); Out.Ln; + END; + + IF "abc" < "bc" THEN + Out.String("Less abc < bc"); Out.Ln; + ELSE + Out.String("WAT: MUST BE abc < bc"); Out.Ln; + END; +END Test10. + +Проверка строк. diff --git a/notes b/notes index 31c1a4d..8de8906 100644 --- a/notes +++ b/notes @@ -1,20 +1,17 @@ +- Не реализована свёртка констант - Сделать проверку повторов в CASE. - Сделать нормальную проверку наличия RETURN. -- Нужно проверить правила совместимости типов (Приложение A). - Нет функций ASH CAP CHR ENTIER LEN LONG ODD ORD SHORT - Нет процедур DEC EXCL INC INCL - Нет счёта строк / столбцов - Нет процедур привязанных к типм -- Не реализована свёртка констант - Нужно просмотреть Дубовые требования. - JVM: Импортируемые модули не инициализируются -- JVM: Не реализовано сравнение строк. - Уточнить как должна работать проверка импорта на чтение. (8.1) -- Уточнить результат оператора "/" (8.2.2) - Примеры -5 DIV 3 и -5 MOD 3 работают не так как в (8.2.2) Нужен другой тип округления? diff --git a/obn-run-tests.sh b/obn-run-tests.sh index da13a65..f9c6897 100755 --- a/obn-run-tests.sh +++ b/obn-run-tests.sh @@ -38,3 +38,4 @@ maketest Test6 maketest Test7 maketest Test8 maketest Test9 +maketest Test10 diff --git a/rtl/SYSTEM.java b/rtl/SYSTEM.java index 44e1cc3..68f82bd 100644 --- a/rtl/SYSTEM.java +++ b/rtl/SYSTEM.java @@ -21,14 +21,26 @@ public class SYSTEM { int len_x = LEN(x); int len_v = v.length - 1; + int len = (len_x < len_v) ? (len_x) : (len_v); for(int i = 0; i < len; i++) { v[i] = x[i]; } + v[len] = 0; } + public static int STRCMP(byte[] a, byte[] b) + { + int i = 0; + while(a[i] != 0 && a[i] == b[i]) + { + i += 1; + } + return a[i] - b[i]; + } + public static void HALT(long n) { System.exit((int) n); diff --git a/src/backends/jvm/generator-jvm.c b/src/backends/jvm/generator-jvm.c index 21ad4db..189d8d2 100644 --- a/src/backends/jvm/generator-jvm.c +++ b/src/backends/jvm/generator-jvm.c @@ -1304,6 +1304,19 @@ jvm_generate_compare_op(gen_proc_t * p, oberon_type_t * t, int op) jvm_generate(p, 2 * cell_size, 1, "%ccmp%c", prefix, fop); jvm_generate(p, 1, 1, "if%s L%i", cmpop, label_true); } + else if(prefix == 'a') + { + if(t -> class == OBERON_TYPE_STRING + || (t -> class == OBERON_TYPE_POINTER && t -> base -> class == OBERON_TYPE_CHAR)) + { + jvm_generate(p, 2, 1, "invokestatic SYSTEM/STRCMP([B[B)I"); + jvm_generate(p, 1, 0, "if%s L%i", cmpop, label_true); + } + else + { + jvm_generate(p, 1, 0, "if_acmp%s L%i", cmpop, label_true); + } + } else { jvm_generate(p, 2 * cell_size, 0, "if_%ccmp%s L%i", prefix, cmpop, label_true); diff --git a/src/oberon-type-compat.c b/src/oberon-type-compat.c index 6c3b698..60b37c4 100644 --- a/src/oberon-type-compat.c +++ b/src/oberon-type-compat.c @@ -485,14 +485,9 @@ oberon_get_longer_type(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t { return a; } - else if(oberon_incluses_type(b, a)) - { - return b; - } else { - oberon_error(ctx, "oberon_get_longer_type: error"); - return NULL; + return b; } } @@ -504,13 +499,8 @@ oberon_get_longer_real_type(oberon_context_t * ctx, oberon_type_t * a, oberon_ty { return ctx -> real_type; } - else if(oberon_is_real_type(result)) - { - return result; - } else { - oberon_error(ctx, "oberon_get_longer_real_type: error"); - return NULL; + return result; } } -- 2.29.2 From 3d4021b9a2dd52aaf4b97859a8a58b74903ebac9 Mon Sep 17 00:00:00 2001 From: DeaDDooMER Date: Sun, 13 Aug 2017 00:12:12 +0300 Subject: [PATCH 13/16] =?utf8?q?=D0=94=D0=BE=D0=B1=D0=B0=D0=B2=D0=BB=D0=B5?= =?utf8?q?=D0=BD=D0=B0=20=D1=81=D0=B2=D1=91=D1=80=D1=82=D0=BA=D0=B0=20?= =?utf8?q?=D0=BA=D0=BE=D0=BD=D1=81=D1=82=D0=B0=D0=BD=D1=82?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- Test.obn | 31 +- Test10.obn | 3 + Test11.obn | 39 +++ Test7.obn | 6 + obn-run-tests.sh | 1 + rtl/SYSTEM.java | 13 +- src/backends/jvm/generator-jvm.c | 2 + src/oberon.c | 564 ++++++++++++++++++++----------- 8 files changed, 454 insertions(+), 205 deletions(-) create mode 100644 Test11.obn diff --git a/Test.obn b/Test.obn index 4bde081..8371d40 100644 --- a/Test.obn +++ b/Test.obn @@ -2,22 +2,31 @@ MODULE Test; IMPORT Out; +CONST + im1 = -1; + bol = ~FALSE; + set = { 1, 2, 3..6 }; + fm1 = -1.0; + dm1 = -1.0D0; + BEGIN - IF "abc" = "abc" THEN - Out.String("Equal abc = abc"); Out.Ln; - ELSE - Out.String("WAT: MUST BE abc = abc"); Out.Ln; - END; + Out.Open; + + Out.Int(im1, 0); Out.Ln; + Out.Real(fm1, 0); Out.Ln; + Out.LongReal(dm1, 0); Out.Ln; - IF "cba" > "abc" THEN - Out.String("Great cba > abc"); Out.Ln; + IF 5 IN set THEN + Out.String("SET: Ok"); Out.Ln; ELSE - Out.String("WAT: MUST BE cba = abc"); Out.Ln; + Out.String("INVALID SET"); Out.Ln; + HALT(1); END; - IF "abc" < "bc" THEN - Out.String("Less abc < bc"); Out.Ln; + IF bol THEN + Out.String("BOOLEAN: Ok"); Out.Ln; ELSE - Out.String("WAT: MUST BE abc < bc"); Out.Ln; + Out.String("INVALID BOOLEAN"); Out.Ln; + HALT(1); END; END Test. diff --git a/Test10.obn b/Test10.obn index 7b4b811..89dbcfd 100644 --- a/Test10.obn +++ b/Test10.obn @@ -7,18 +7,21 @@ BEGIN Out.String("Equal abc = abc"); Out.Ln; ELSE Out.String("WAT: MUST BE abc = abc"); Out.Ln; + HALT(1); END; IF "cba" > "abc" THEN Out.String("Great cba > abc"); Out.Ln; ELSE Out.String("WAT: MUST BE cba = abc"); Out.Ln; + HALT(1); END; IF "abc" < "bc" THEN Out.String("Less abc < bc"); Out.Ln; ELSE Out.String("WAT: MUST BE abc < bc"); Out.Ln; + HALT(1); END; END Test10. diff --git a/Test11.obn b/Test11.obn new file mode 100644 index 0000000..847fddf --- /dev/null +++ b/Test11.obn @@ -0,0 +1,39 @@ +MODULE Test11; + +IMPORT Out; + +CONST + im1 = -1; + bol = ~FALSE; + set = { 1, 2, 3..6 }; + fm1 = -1.0; + dm1 = -1.0D0; + inf = 4 IN set; + rel = 10 = 100; + pi = 4 / 1 - 4 / 3 + 4 / 5 - 4 / 7 + 4 / 9 - 4 / 11 + 4 / 13 - 4 / 15 + 4 / 17 - 4 / 19 + 4 / 21; + +BEGIN + Out.Open; + + Out.Int(im1, 0); Out.Ln; + Out.Real(fm1, 0); Out.Ln; + Out.LongReal(dm1, 0); Out.Ln; + + Out.Real(pi, 0); Out.Ln; + + IF 5 IN set THEN + Out.String("SET: Ok"); Out.Ln; + ELSE + Out.String("INVALID SET"); Out.Ln; + HALT(1); + END; + + IF bol THEN + Out.String("BOOLEAN: Ok"); Out.Ln; + ELSE + Out.String("INVALID BOOLEAN"); Out.Ln; + HALT(1); + END; +END Test11. + +Проверка свёртки констант. diff --git a/Test7.obn b/Test7.obn index 739ec97..7579867 100644 --- a/Test7.obn +++ b/Test7.obn @@ -4,14 +4,20 @@ IMPORT Out; VAR i : INTEGER; + ok : BOOLEAN; BEGIN Out.Open; i := 48; FOR i := 32 TO i DO Out.Int(i, 0); Out.Char(' '); + ok := TRUE; END; Out.Ln; + + IF ok = FALSE THEN + HALT(1); + END; END Test7. Проверка корректности FOR. diff --git a/obn-run-tests.sh b/obn-run-tests.sh index f9c6897..f483e01 100755 --- a/obn-run-tests.sh +++ b/obn-run-tests.sh @@ -39,3 +39,4 @@ maketest Test7 maketest Test8 maketest Test9 maketest Test10 +maketest Test11 diff --git a/rtl/SYSTEM.java b/rtl/SYSTEM.java index 68f82bd..28d8c46 100644 --- a/rtl/SYSTEM.java +++ b/rtl/SYSTEM.java @@ -19,16 +19,17 @@ public class SYSTEM public static void COPY(byte[] x, byte[] v) { - int len_x = LEN(x); - int len_v = v.length - 1; + int ix = LEN(x); + int iv = v.length - 1; - int len = (len_x < len_v) ? (len_x) : (len_v); - for(int i = 0; i < len; i++) + int i = 0; + int len = (ix < iv) ? (ix) : (iv); + while(i < len) { v[i] = x[i]; + i += 1; } - - v[len] = 0; + v[i] = 0; } public static int STRCMP(byte[] a, byte[] b) diff --git a/src/backends/jvm/generator-jvm.c b/src/backends/jvm/generator-jvm.c index 189d8d2..ee4bc67 100644 --- a/src/backends/jvm/generator-jvm.c +++ b/src/backends/jvm/generator-jvm.c @@ -1372,6 +1372,7 @@ jvm_generate_operator(gen_proc_t * p, oberon_type_t * t, int op) jvm_generate(p, 2 * cell_size, cell_size, "%cand", prefix); break; case OP_DIFFERENCE: + /* (a - b) == a & ~b */ jvm_generate_push_int_size(p, -1, t -> size); jvm_generate(p, 2 * cell_size, cell_size, "%cxor", prefix); jvm_generate(p, 2 * cell_size, cell_size, "%cand", prefix); @@ -1498,6 +1499,7 @@ jvm_generate_in(gen_proc_t * p, oberon_expr_t * a, oberon_expr_t * b) int label_else = jvm_new_label_id(p); int label_end = jvm_new_label_id(p); + /* (a IN b) == (1 << a) & b */ jvm_generate_push_int_size(p, 1, t -> size); push_expr(p, a); jvm_generate(p, 2 * cell_size, cell_size, "%cshl", prefix); diff --git a/src/oberon.c b/src/oberon.c index 6f9395c..30f10ec 100644 --- a/src/oberon.c +++ b/src/oberon.c @@ -83,6 +83,119 @@ oberon_new_type_set(int size) return x; } +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); + memset(operator, 0, sizeof *operator); + + operator -> is_item = 0; + operator -> result = result; + operator -> read_only = 1; + operator -> op = op; + operator -> left = left; + operator -> right = right; + + return (oberon_expr_t *) operator; +} + +static oberon_expr_t * +oberon_new_item(int mode, oberon_type_t * result, int read_only) +{ + oberon_item_t * item; + item = malloc(sizeof *item); + memset(item, 0, sizeof *item); + + item -> is_item = 1; + item -> result = result; + item -> read_only = read_only; + item -> mode = mode; + + return (oberon_expr_t *)item; +} + +static oberon_type_t * +oberon_get_type_of_int_value(oberon_context_t * ctx, int64_t i) +{ + if(i >= -128 && i <= 127) + { + return ctx -> byte_type; + } + else if(i >= -32768 && i <= 32767) + { + return ctx -> shortint_type; + } + else if(i >= -2147483648 && i <= 2147483647) + { + return ctx -> int_type; + } + else + { + return ctx -> longint_type; + } +} + +static oberon_expr_t * +oberon_make_integer(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; + expr -> item.real = i; + return expr; +} + +static oberon_expr_t * +oberon_make_real_typed(oberon_context_t * ctx, double r, oberon_type_t * result) +{ + oberon_expr_t * expr; + expr = oberon_new_item(MODE_REAL, result, true); + expr -> item.integer = r; + expr -> item.real = r; + return expr; +} + +static oberon_expr_t * +oberon_make_real(oberon_context_t * ctx, double r, bool longmode) +{ + oberon_type_t * result; + result = (longmode) ? (ctx -> longreal_type) : (ctx -> real_type); + return oberon_make_real_typed(ctx, r, result); +} + +static oberon_expr_t * +oberon_make_boolean(oberon_context_t * ctx, bool cond) +{ + oberon_expr_t * expr; + expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, true); + expr -> item.integer = cond; + expr -> item.real = cond; + return expr; +} + +static oberon_expr_t * +oberon_make_set(oberon_context_t * ctx, int64_t i) +{ + oberon_expr_t * expr; + expr = oberon_new_item(MODE_SET, ctx -> set_type, true); + expr -> item.integer = i; + expr -> item.real = i; + return expr; +} + +static oberon_expr_t * +oberon_make_set_range(oberon_context_t * ctx, int64_t x, int64_t y) +{ + oberon_expr_t * expr; + expr = oberon_new_item(MODE_SET, ctx -> set_type, true); + expr -> item.integer = (x <= y) ? ((2 << y) - (1 << x)) : (0); + expr -> item.real = expr -> item.integer; + return expr; +} + // ======================================================================= // TABLE // ======================================================================= @@ -524,6 +637,7 @@ oberon_read_number(oberon_context_t * ctx) case 2: case 3: sscanf(ident, "%lf", &real); + integer = real; ctx -> token = REAL; break; case 4: @@ -787,38 +901,7 @@ 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) -{ - oberon_oper_t * operator; - operator = malloc(sizeof *operator); - memset(operator, 0, sizeof *operator); - - operator -> is_item = 0; - operator -> result = result; - operator -> read_only = 1; - operator -> op = op; - operator -> left = left; - operator -> right = right; - - return (oberon_expr_t *) operator; -} - -static oberon_expr_t * -oberon_new_item(int mode, oberon_type_t * result, int read_only) -{ - oberon_item_t * item; - item = malloc(sizeof *item); - memset(item, 0, sizeof *item); - - item -> is_item = 1; - item -> result = result; - item -> read_only = read_only; - item -> mode = mode; - - return (oberon_expr_t *)item; -} +static bool oberon_is_const(oberon_expr_t * expr); static oberon_expr_t * oberon_make_unary_op(oberon_context_t * ctx, int token, oberon_expr_t * a) @@ -832,11 +915,36 @@ oberon_make_unary_op(oberon_context_t * ctx, int token, oberon_expr_t * a) { if(result -> class == OBERON_TYPE_SET) { - expr = oberon_new_operator(OP_COMPLEMENTATION, result, a, NULL); + if(oberon_is_const(a)) + { + expr = oberon_make_set(ctx, ~(a -> item.integer)); + } + else + { + expr = oberon_new_operator(OP_COMPLEMENTATION, result, a, NULL); + } } else if(result -> class == OBERON_TYPE_INTEGER) { - expr = oberon_new_operator(OP_UNARY_MINUS, result, a, NULL); + if(oberon_is_const(a)) + { + expr = oberon_make_integer(ctx, -(a -> item.integer)); + } + else + { + expr = oberon_new_operator(OP_UNARY_MINUS, result, a, NULL); + } + } + else if(result -> class == OBERON_TYPE_REAL) + { + if(oberon_is_const(a)) + { + expr = oberon_make_real_typed(ctx, -(a -> item.real), result); + } + else + { + expr = oberon_new_operator(OP_UNARY_MINUS, result, a, NULL); + } } else { @@ -850,7 +958,14 @@ oberon_make_unary_op(oberon_context_t * ctx, int token, oberon_expr_t * a) oberon_error(ctx, "incompatible operator type"); } - expr = oberon_new_operator(OP_LOGIC_NOT, result, a, NULL); + if(oberon_is_const(a)) + { + expr = oberon_make_boolean(ctx, !(a -> item.integer)); + } + else + { + expr = oberon_new_operator(OP_LOGIC_NOT, result, a, NULL); + } } else { @@ -1415,38 +1530,6 @@ oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr) oberon_make_call_proc(ctx, (oberon_item_t *) expr, num_args, arguments); } -static oberon_type_t * -oberon_get_type_of_int_value(oberon_context_t * ctx, int64_t i) -{ - if(i >= -128 && i <= 127) - { - return ctx -> byte_type; - } - else if(i >= -32768 && i <= 32767) - { - return ctx -> shortint_type; - } - else if(i >= -2147483648 && i <= 2147483647) - { - return ctx -> int_type; - } - else - { - return ctx -> longint_type; - } -} - -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_element(oberon_context_t * ctx) { @@ -1473,28 +1556,51 @@ oberon_element(oberon_context_t * ctx) } oberon_expr_t * set; - set = oberon_new_operator(OP_RANGE, ctx -> set_type, e1, e2); + if(e2 == NULL && oberon_is_const(e1)) + { + set = oberon_make_set(ctx, e1 -> item.integer); + } + else if(e2 != NULL && oberon_is_const(e1) && oberon_is_const(e2)) + { + set = oberon_make_set_range(ctx, e1 -> item.integer, e2 -> item.integer); + } + else + { + set = oberon_new_operator(OP_RANGE, ctx -> set_type, e1, e2); + } return set; } +static oberon_expr_t * +oberon_make_set_union(oberon_context_t * ctx, oberon_expr_t * a, oberon_expr_t * b) +{ + if(oberon_is_const(a) && oberon_is_const(b)) + { + return oberon_make_set(ctx, (a -> item.integer | b -> item.integer)); + } + else + { + return oberon_new_operator(OP_UNION, ctx -> set_type, a, b); + } +} + static oberon_expr_t * oberon_set(oberon_context_t * ctx) { oberon_expr_t * set; oberon_expr_t * elements; - set = oberon_new_item(MODE_SET, ctx -> set_type, true); - set -> item.integer = 0; + set = oberon_make_set(ctx, 0); oberon_assert_token(ctx, LBRACE); if(ISEXPR(ctx -> token)) { elements = oberon_element(ctx); - set = oberon_new_operator(OP_UNION, ctx -> set_type, set, elements); + set = oberon_make_set_union(ctx, set, elements); while(ctx -> token == COMMA) { oberon_assert_token(ctx, COMMA); elements = oberon_element(ctx); - set = oberon_new_operator(OP_UNION, ctx -> set_type, set, elements); + set = oberon_make_set_union(ctx, set, elements); } } oberon_assert_token(ctx, RBRACE); @@ -1502,15 +1608,6 @@ oberon_set(oberon_context_t * ctx) return set; } -static oberon_expr_t * -oberon_make_boolean(oberon_context_t * ctx, bool cond) -{ - oberon_expr_t * expr; - expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, true); - expr -> item.integer = cond; - return expr; -} - static oberon_expr_t * oberon_factor(oberon_context_t * ctx) { @@ -1524,7 +1621,7 @@ oberon_factor(oberon_context_t * ctx) expr = oberon_opt_func_parens(ctx, expr); break; case INTEGER: - expr = oberon_integer_item(ctx, ctx -> integer); + expr = oberon_make_integer(ctx, ctx -> integer); oberon_assert_token(ctx, INTEGER); break; case CHAR: @@ -1540,9 +1637,7 @@ oberon_factor(oberon_context_t * ctx) 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); - expr -> item.real = ctx -> real; + expr = oberon_make_real(ctx, ctx -> real, ctx -> longmode); oberon_assert_token(ctx, REAL); break; case LBRACE: @@ -1582,10 +1677,16 @@ oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_ oberon_check_src(ctx, b); } - bool error = false; if(token == IN) { - expr = oberon_new_operator(OP_IN, ctx -> bool_type, a, b); + if(oberon_is_const(a) && oberon_is_const(b)) + { + expr = oberon_make_boolean(ctx, (1 << a -> item.integer) & b -> item.integer); + } + else + { + expr = oberon_new_operator(OP_IN, ctx -> bool_type, a, b); + } } else if(token == IS) { @@ -1595,126 +1696,201 @@ oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_ else if((token >= EQUAL && token <= GEQ) || token == OR || token == AND) { result = oberon_get_longer_type(ctx, a -> result, b -> result); - a = oberon_cast_expr(ctx, a, result); - b = oberon_cast_expr(ctx, b, result); - 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) + if(oberon_is_const(a) && oberon_is_const(b) + && (oberon_is_real_type(result) || oberon_is_integer_type(result))) { - expr = oberon_new_operator(OP_LOGIC_AND, result, a, b); + if(oberon_is_real_type(result)) + { + double x = a -> item.real; + double y = b -> item.real; + switch(token) + { + case EQUAL: expr = oberon_make_boolean(ctx, x == y); break; + case NEQ: expr = oberon_make_boolean(ctx, x != y); break; + case LESS: expr = oberon_make_boolean(ctx, x < y); break; + case LEQ: expr = oberon_make_boolean(ctx, x <= y); break; + case GREAT: expr = oberon_make_boolean(ctx, x > y); break; + case GEQ: expr = oberon_make_boolean(ctx, x >= y); break; + case OR: expr = oberon_make_boolean(ctx, x || y); break; + case AND: expr = oberon_make_boolean(ctx, x && y); break; + default: assert(0); break; + } + } + else if(oberon_is_integer_type(result)) + { + int64_t x = a -> item.integer; + int64_t y = b -> item.integer; + switch(token) + { + case EQUAL: expr = oberon_make_boolean(ctx, x == y); break; + case NEQ: expr = oberon_make_boolean(ctx, x != y); break; + case LESS: expr = oberon_make_boolean(ctx, x < y); break; + case LEQ: expr = oberon_make_boolean(ctx, x <= y); break; + case GREAT: expr = oberon_make_boolean(ctx, x > y); break; + case GEQ: expr = oberon_make_boolean(ctx, x >= y); break; + case OR: expr = oberon_make_boolean(ctx, x || y); break; + case AND: expr = oberon_make_boolean(ctx, x && y); break; + default: assert(0); break; + } + } + else + { + assert(0); + } } else { - oberon_error(ctx, "oberon_make_bin_op: bool wat"); + a = oberon_cast_expr(ctx, a, result); + b = oberon_cast_expr(ctx, b, result); + result = ctx -> bool_type; + switch(token) + { + case EQUAL: expr = oberon_new_operator(OP_EQ, result, a, b); break; + case NEQ: expr = oberon_new_operator(OP_NEQ, result, a, b); break; + case LESS: expr = oberon_new_operator(OP_LSS, result, a, b); break; + case LEQ: expr = oberon_new_operator(OP_LEQ, result, a, b); break; + case GREAT: expr = oberon_new_operator(OP_GRT, result, a, b); break; + case GEQ: expr = oberon_new_operator(OP_GEQ, result, a, b); break; + case OR: expr = oberon_new_operator(OP_LOGIC_OR, result, a, b); break; + case AND: expr = oberon_new_operator(OP_LOGIC_AND, result, a, b); break; + default: assert(0); break; + } } } else if(token == SLASH) { if(oberon_is_set_type(a -> result) && oberon_is_set_type(b -> result)) { - result = oberon_get_longer_type(ctx, a -> result, b -> result); - a = oberon_cast_expr(ctx, a, result); - b = oberon_cast_expr(ctx, b, result); - expr = oberon_new_operator(OP_SYM_DIFFERENCE, result, a, b); + if(oberon_is_const(a) && oberon_is_const(b)) + { + int64_t x = a -> item.integer; + int64_t y = b -> item.integer; + expr = oberon_make_set(ctx, x ^ y); + } + else + { + result = oberon_get_longer_type(ctx, a -> result, b -> result); + a = oberon_cast_expr(ctx, a, result); + b = oberon_cast_expr(ctx, b, result); + expr = oberon_new_operator(OP_SYM_DIFFERENCE, result, a, b); + } } else { result = oberon_get_longer_real_type(ctx, a -> result, b -> result); - a = oberon_cast_expr(ctx, a, result); - b = oberon_cast_expr(ctx, b, result); - expr = oberon_new_operator(OP_DIV, result, a, b); + if(oberon_is_const(a) && oberon_is_const(b)) + { + double x = a -> item.real; + double y = b -> item.real; + expr = oberon_make_real_typed(ctx, x / y, result); + } + else + { + a = oberon_cast_expr(ctx, a, result); + b = oberon_cast_expr(ctx, b, result); + expr = oberon_new_operator(OP_DIV, result, a, b); + } } } - else if(token == DIV) - { - result = oberon_get_longer_type(ctx, a -> result, b -> result); - a = oberon_cast_expr(ctx, a, result); - b = oberon_cast_expr(ctx, b, result); - expr = oberon_new_operator(OP_DIV, result, a, b); - } else { result = oberon_get_longer_type(ctx, a -> result, b -> result); - a = oberon_cast_expr(ctx, a, result); - b = oberon_cast_expr(ctx, b, result); - if(oberon_is_set_type(result)) + + if(oberon_is_const(a) && oberon_is_const(b)) { - switch(token) + if(oberon_is_set_type(result)) { - case PLUS: - expr = oberon_new_operator(OP_UNION, result, a, b); - break; - case MINUS: - expr = oberon_new_operator(OP_DIFFERENCE, result, a, b); - break; - case STAR: - expr = oberon_new_operator(OP_INTERSECTION, result, a, b); - break; - default: - error = true; - break; + int64_t x = a -> item.integer; + int64_t y = b -> item.integer; + switch(token) + { + case PLUS: expr = oberon_make_set(ctx, x | y); break; + case MINUS: expr = oberon_make_set(ctx, x & ~y); break; + case STAR: expr = oberon_make_set(ctx, x & y); break; + default: assert(0); break; + } } - } - else if(oberon_is_number_type(result)) - { - switch(token) + if(oberon_is_real_type(result)) { - case PLUS: - expr = oberon_new_operator(OP_ADD, result, a, b); - break; - case MINUS: - expr = oberon_new_operator(OP_SUB, result, a, b); - break; - case STAR: - expr = oberon_new_operator(OP_MUL, result, a, b); - break; - case MOD: - expr = oberon_new_operator(OP_MOD, result, a, b); - break; - default: - error = true; - break; + double x = a -> item.real; + double y = b -> item.real; + switch(token) + { + case PLUS: expr = oberon_make_real_typed(ctx, x + y, result); break; + case MINUS: expr = oberon_make_real_typed(ctx, x - y, result); break; + case STAR: expr = oberon_make_real_typed(ctx, x * y, result); break; + default: assert(0); break; + } + } + else if(oberon_is_integer_type(result)) + { + int64_t x = a -> item.integer; + int64_t y = b -> item.integer; + switch(token) + { + case PLUS: expr = oberon_make_integer(ctx, x + y); break; + case MINUS: expr = oberon_make_integer(ctx, x - y); break; + case STAR: expr = oberon_make_integer(ctx, x * y); break; + case DIV: expr = oberon_make_integer(ctx, x / y); break; + case MOD: expr = oberon_make_integer(ctx, x % y); break; + default: assert(0); break; + } + } + else + { + assert(0); } } else { - error = true; + a = oberon_cast_expr(ctx, a, result); + b = oberon_cast_expr(ctx, b, result); + + + if(oberon_is_set_type(result)) + { + switch(token) + { + case PLUS: + expr = oberon_new_operator(OP_UNION, result, a, b); + break; + case MINUS: + expr = oberon_new_operator(OP_DIFFERENCE, result, a, b); + break; + case STAR: + expr = oberon_new_operator(OP_INTERSECTION, result, a, b); + break; + default: + assert(0); + break; + } + } + else if(oberon_is_number_type(result)) + { + switch(token) + { + case PLUS: + expr = oberon_new_operator(OP_ADD, result, a, b); + break; + case MINUS: + expr = oberon_new_operator(OP_SUB, result, a, b); + break; + case STAR: + expr = oberon_new_operator(OP_MUL, result, a, b); + break; + default: + assert(0); + break; + } + } + else + { + assert(0); + } } } - if(error) - { - oberon_error(ctx, "invalid operation"); - } - return expr; } @@ -1799,12 +1975,12 @@ oberon_expr(oberon_context_t * ctx) return expr; } -static void -oberon_check_const(oberon_context_t * ctx, oberon_expr_t * expr) +static bool +oberon_is_const(oberon_expr_t * expr) { - if(expr -> is_item == 0) + if(expr -> is_item == false) { - oberon_error(ctx, "const expression are required"); + return false; } switch(expr -> item.mode) @@ -1815,13 +1991,25 @@ oberon_check_const(oberon_context_t * ctx, oberon_expr_t * expr) case MODE_REAL: case MODE_CHAR: case MODE_STRING: + case MODE_SET: case MODE_TYPE: - /* accept */ + return true; break; default: - oberon_error(ctx, "const expression are required"); + return false; break; } + + return false; +} + +static void +oberon_check_const(oberon_context_t * ctx, oberon_expr_t * expr) +{ + if(!oberon_is_const(expr)) + { + oberon_error(ctx, "const expression are required"); + } } static oberon_item_t * @@ -3212,7 +3400,7 @@ oberon_statement(oberon_context_t * ctx) } else { - by = oberon_integer_item(ctx, 1); + by = oberon_make_integer(ctx, 1); } if(by -> result -> class != OBERON_TYPE_INTEGER) @@ -3491,10 +3679,10 @@ oberon_make_min_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ switch(arg -> result -> class) { case OBERON_TYPE_INTEGER: - expr = oberon_integer_item(ctx, -powl(2, bits - 1)); + expr = oberon_make_integer(ctx, -powl(2, bits - 1)); break; case OBERON_TYPE_SET: - expr = oberon_integer_item(ctx, 0); + expr = oberon_make_integer(ctx, 0); break; default: oberon_error(ctx, "allowed only basic types"); @@ -3530,10 +3718,10 @@ oberon_make_max_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ switch(arg -> result -> class) { case OBERON_TYPE_INTEGER: - expr = oberon_integer_item(ctx, powl(2, bits - 1) - 1); + expr = oberon_make_integer(ctx, powl(2, bits - 1) - 1); break; case OBERON_TYPE_SET: - expr = oberon_integer_item(ctx, bits); + expr = oberon_make_integer(ctx, bits); break; default: oberon_error(ctx, "allowed only basic types"); @@ -3581,7 +3769,7 @@ oberon_make_size_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list break; } - expr = oberon_integer_item(ctx, size); + expr = oberon_make_integer(ctx, size); return expr; } -- 2.29.2 From 19dd8062f04889d5edbc879d5d9daf89de410aee Mon Sep 17 00:00:00 2001 From: DeaDDooMER Date: Sun, 13 Aug 2017 00:33:50 +0300 Subject: [PATCH 14/16] =?utf8?q?=D0=9E=D0=B1=D0=BD=D0=BE=D0=B2=D0=B8=D0=BB?= =?utf8?q?=D0=B5=D0=BD=D0=B8=D0=B5=20notes?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- notes | 1 - 1 file changed, 1 deletion(-) diff --git a/notes b/notes index 8de8906..cf12913 100644 --- a/notes +++ b/notes @@ -1,4 +1,3 @@ -- Не реализована свёртка констант - Сделать проверку повторов в CASE. - Сделать нормальную проверку наличия RETURN. -- 2.29.2 From 95acec6c3ae8d3c324c84b001a680aa49320790b Mon Sep 17 00:00:00 2001 From: DeaDDooMER Date: Sun, 13 Aug 2017 10:40:37 +0300 Subject: [PATCH 15/16] =?utf8?q?=D0=94=D0=BE=D0=B1=D0=B0=D0=B2=D0=BB=D0=B5?= =?utf8?q?=D0=BD=D1=8B=20=D1=84=D1=83=D0=BD=D0=BA=D1=86=D0=B8=D0=B8=20ASH?= =?utf8?q?=20=D0=B8=20ODD,=20=D0=BA=20=D0=B4=D1=80=D1=83=D0=B3=D0=B8=D0=BC?= =?utf8?q?=20=D0=B4=D0=BE=D0=B1=D0=B0=D0=B2=D0=BB=D0=B5=D0=BD=D0=B0=20?= =?utf8?q?=D1=81=D0=B2=D1=91=D1=80=D1=82=D0=BA=D0=B0=20=D0=BA=D0=BE=D0=BD?= =?utf8?q?=D1=81=D1=82=D0=B0=D0=BD=D1=82?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- Test.obn | 29 +---- Test10.obn | 28 +---- Test11.obn | 15 +-- Test12.obn | 19 ++++ Test13.obn | 13 +++ Test7.obn | 4 +- notes | 2 +- obn-run-tests.sh | 2 + src/backends/jvm/generator-jvm.c | 41 +++++++ src/oberon-internals.h | 5 +- src/oberon-type-compat.h | 3 + src/oberon.c | 178 ++++++++++++++++++++++++++++--- 12 files changed, 257 insertions(+), 82 deletions(-) create mode 100644 Test12.obn create mode 100644 Test13.obn diff --git a/Test.obn b/Test.obn index 8371d40..babecff 100644 --- a/Test.obn +++ b/Test.obn @@ -1,32 +1,5 @@ MODULE Test; -IMPORT Out; - -CONST - im1 = -1; - bol = ~FALSE; - set = { 1, 2, 3..6 }; - fm1 = -1.0; - dm1 = -1.0D0; - BEGIN - Out.Open; - - Out.Int(im1, 0); Out.Ln; - Out.Real(fm1, 0); Out.Ln; - Out.LongReal(dm1, 0); Out.Ln; - - IF 5 IN set THEN - Out.String("SET: Ok"); Out.Ln; - ELSE - Out.String("INVALID SET"); Out.Ln; - HALT(1); - END; - - IF bol THEN - Out.String("BOOLEAN: Ok"); Out.Ln; - ELSE - Out.String("INVALID BOOLEAN"); Out.Ln; - HALT(1); - END; + ASSERT(ODD(5)); END Test. diff --git a/Test10.obn b/Test10.obn index 89dbcfd..08dd56c 100644 --- a/Test10.obn +++ b/Test10.obn @@ -1,28 +1,10 @@ MODULE Test10; -IMPORT Out; - BEGIN - IF "abc" = "abc" THEN - Out.String("Equal abc = abc"); Out.Ln; - ELSE - Out.String("WAT: MUST BE abc = abc"); Out.Ln; - HALT(1); - END; - - IF "cba" > "abc" THEN - Out.String("Great cba > abc"); Out.Ln; - ELSE - Out.String("WAT: MUST BE cba = abc"); Out.Ln; - HALT(1); - END; - - IF "abc" < "bc" THEN - Out.String("Less abc < bc"); Out.Ln; - ELSE - Out.String("WAT: MUST BE abc < bc"); Out.Ln; - HALT(1); - END; + ASSERT("abc" = "abc"); + ASSERT("abcz" # "abcd"); + ASSERT("cba" > "abc"); + ASSERT("abc" < "bc"); END Test10. -Проверка строк. +Проверка сравнения строк. diff --git a/Test11.obn b/Test11.obn index 847fddf..aba8cb4 100644 --- a/Test11.obn +++ b/Test11.obn @@ -21,19 +21,8 @@ BEGIN Out.Real(pi, 0); Out.Ln; - IF 5 IN set THEN - Out.String("SET: Ok"); Out.Ln; - ELSE - Out.String("INVALID SET"); Out.Ln; - HALT(1); - END; - - IF bol THEN - Out.String("BOOLEAN: Ok"); Out.Ln; - ELSE - Out.String("INVALID BOOLEAN"); Out.Ln; - HALT(1); - END; + ASSERT(5 IN set); + ASSERT(bol); END Test11. Проверка свёртки констант. diff --git a/Test12.obn b/Test12.obn new file mode 100644 index 0000000..4eecfb1 --- /dev/null +++ b/Test12.obn @@ -0,0 +1,19 @@ +MODULE Test12; + +CONST + icon = 32; + ash1 = ASH(icon, -5); + ash2 = ASH(icon, 5); + +VAR + i : INTEGER; + +BEGIN + i := icon; + ASSERT(ash1 = 1); + ASSERT(ash2 = 1024); + ASSERT(ASH(i, -5) = 1); + ASSERT(ASH(i, 5) = 1024); +END Test12. + +Проверка правильности вычисления ASH. diff --git a/Test13.obn b/Test13.obn new file mode 100644 index 0000000..cec1255 --- /dev/null +++ b/Test13.obn @@ -0,0 +1,13 @@ +MODULE Test13; + +VAR + ch, cap, res : CHAR; + +BEGIN + ch := "a"; + cap := "A"; + res := CAP(ch); + ASSERT(res = cap); +END Test13. + +Проверка функции CAP diff --git a/Test7.obn b/Test7.obn index 7579867..e3613e4 100644 --- a/Test7.obn +++ b/Test7.obn @@ -15,9 +15,7 @@ BEGIN END; Out.Ln; - IF ok = FALSE THEN - HALT(1); - END; + ASSERT(ok); END Test7. Проверка корректности FOR. diff --git a/notes b/notes index cf12913..a6270d0 100644 --- a/notes +++ b/notes @@ -1,7 +1,7 @@ - Сделать проверку повторов в CASE. - Сделать нормальную проверку наличия RETURN. -- Нет функций ASH CAP CHR ENTIER LEN LONG ODD ORD SHORT +- Нет функций CHR ENTIER LEN LONG ORD SHORT - Нет процедур DEC EXCL INC INCL - Нет счёта строк / столбцов - Нет процедур привязанных к типм diff --git a/obn-run-tests.sh b/obn-run-tests.sh index f483e01..0c0e092 100755 --- a/obn-run-tests.sh +++ b/obn-run-tests.sh @@ -40,3 +40,5 @@ maketest Test8 maketest Test9 maketest Test10 maketest Test11 +maketest Test12 +maketest Test13 diff --git a/src/backends/jvm/generator-jvm.c b/src/backends/jvm/generator-jvm.c index ee4bc67..c2fd9ab 100644 --- a/src/backends/jvm/generator-jvm.c +++ b/src/backends/jvm/generator-jvm.c @@ -1349,6 +1349,9 @@ jvm_generate_operator(gen_proc_t * p, oberon_type_t * t, int op) case OP_ABS: jvm_generate_abs(p, prefix); break; + case OP_CAP: + jvm_generate(p, cell_size, cell_size, "invokestatic java/lang/Character/toUpperCase(I)I"); + break; case OP_ADD: jvm_generate(p, 2 * cell_size, cell_size, "%cadd", prefix); @@ -1519,6 +1522,39 @@ jvm_generate_in(gen_proc_t * p, oberon_expr_t * a, oberon_expr_t * b) jvm_generate_label(p, label_end); } +static void +jvm_generate_ash(gen_proc_t * p, oberon_expr_t * a, oberon_expr_t * b) +{ + oberon_type_t * t = a -> result; + int cell_size = jvm_cell_size_for_type(t); + char prefix = jvm_get_prefix(t); + int label_else = jvm_new_label_id(p); + int label_end = jvm_new_label_id(p); + + /* if b < 0 then a << b else a >> b end */ + + push_expr(p, a); + push_expr(p, b); + if(cell_size == 1) + { + jvm_generate(p, cell_size, 2 * cell_size, "dup"); + } + else + { + jvm_generate(p, cell_size, 2 * cell_size, "dup2"); + } + jvm_generate_push_int_size(p, 0, t -> size); + jvm_generate_compare_op(p, t, OP_LSS); + + jvm_generate(p, cell_size, 0, "ifne L%i", label_else); + jvm_generate(p, 2 * cell_size, cell_size, "%cshl", prefix); + jvm_generate(p, 0, 0, "goto L%i", label_end); + jvm_generate_label(p, label_else); + jvm_generate_abs(p, prefix); + jvm_generate(p, 2 * cell_size, cell_size, "%cshr", prefix); + jvm_generate_label(p, label_end); +} + static void push_operator(gen_proc_t * p, oberon_oper_t * oper) { @@ -1534,6 +1570,7 @@ push_operator(gen_proc_t * p, oberon_oper_t * oper) case OP_UNARY_MINUS: case OP_LOGIC_NOT: case OP_ABS: + case OP_CAP: push_expr(p, oper -> left); jvm_generate_operator(p, preq, op); break; @@ -1579,6 +1616,10 @@ push_operator(gen_proc_t * p, oberon_oper_t * oper) case OP_IN: jvm_generate_in(p, oper -> left, oper -> right); break; + + case OP_ASH: + jvm_generate_ash(p, oper -> left, oper -> right); + break; default: gen_error("push_oper: unk op %i", op); break; diff --git a/src/oberon-internals.h b/src/oberon-internals.h index 3c6fb85..7536540 100644 --- a/src/oberon-internals.h +++ b/src/oberon-internals.h @@ -188,6 +188,7 @@ enum oberon_operator_kind OP_UNARY_MINUS, OP_LOGIC_NOT, OP_ABS, + OP_CAP, OP_ADD, OP_SUB, @@ -213,7 +214,9 @@ enum oberon_operator_kind OP_DIFFERENCE, OP_SYM_DIFFERENCE, OP_COMPLEMENTATION, - OP_IN + OP_IN, + + OP_ASH }; struct oberon_item_t diff --git a/src/oberon-type-compat.h b/src/oberon-type-compat.h index b09dccc..904a89c 100644 --- a/src/oberon-type-compat.h +++ b/src/oberon-type-compat.h @@ -40,6 +40,9 @@ oberon_is_boolean_type(oberon_type_t * t); bool oberon_is_array_of_char_type(oberon_type_t * t); +bool +oberon_is_type_expr(oberon_expr_t * e); + bool diff --git a/src/oberon.c b/src/oberon.c index 30f10ec..0854335 100644 --- a/src/oberon.c +++ b/src/oberon.c @@ -6,6 +6,7 @@ #include #include #include +#include #include "../include/oberon.h" @@ -148,6 +149,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) { @@ -3073,7 +3084,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); @@ -3669,7 +3681,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 +3693,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 +3729,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 +3741,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 +3776,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,16 +3819,29 @@ 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; } @@ -3937,7 +3979,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 +3994,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,6 +4032,113 @@ oberon_make_halt_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list oberon_generate_halt(ctx, num -> item.integer); } +static oberon_expr_t * +oberon_make_ash_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 * arg1; + arg1 = list_args; + oberon_check_src(ctx, arg1); + if(arg1 -> result -> class != OBERON_TYPE_INTEGER) + { + oberon_error(ctx, "expected integer"); + } + + 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"); + } + + 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); + } + + return expr; +} + +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_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 void oberon_new_const(oberon_context_t * ctx, char * name, oberon_expr_t * expr) { @@ -4020,8 +4169,11 @@ oberon_create_context(ModuleImportCallback import_module) /* 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, "MIN", oberon_make_min_call, NULL); oberon_new_intrinsic(ctx, "MAX", oberon_make_max_call, NULL); + oberon_new_intrinsic(ctx, "ODD", oberon_make_odd_call, NULL); oberon_new_intrinsic(ctx, "SIZE", oberon_make_size_call, NULL); /* Procedures */ -- 2.29.2 From b09b4829b70cf34a470003286ea100663d7fe442 Mon Sep 17 00:00:00 2001 From: DeaDDooMER Date: Sun, 13 Aug 2017 13:08:21 +0300 Subject: [PATCH 16/16] =?utf8?q?=D0=94=D0=BE=D0=B1=D0=B0=D0=B2=D0=BB=D0=B5?= =?utf8?q?=D0=BD=D1=8B=20=D1=84=D1=83=D0=BD=D0=BA=D1=86=D0=B8=D0=B8=20CHR?= =?utf8?q?=20ENTIER=20LEN=20ORD?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- Test.obn | 9 +- Test14.obn | 21 ++++ Test15.obn | 14 +++ notes | 2 +- obn-run-tests.sh | 2 + src/backends/jvm/generator-jvm.c | 45 +++++++-- src/oberon-internals.h | 4 +- src/oberon.c | 166 +++++++++++++++++++++++++++++++ 8 files changed, 249 insertions(+), 14 deletions(-) create mode 100644 Test14.obn create mode 100644 Test15.obn diff --git a/Test.obn b/Test.obn index babecff..03df037 100644 --- a/Test.obn +++ b/Test.obn @@ -1,5 +1,12 @@ MODULE Test; +VAR + x : ARRAY 10 OF INTEGER; + p : POINTER TO ARRAY OF ARRAY OF INTEGER; + BEGIN - ASSERT(ODD(5)); + NEW(p, 20, 30); + ASSERT(LEN(x, 0) = 10); + ASSERT(LEN(p^, 0) = 20); + ASSERT(LEN(p^, 1) = 30); END Test. diff --git a/Test14.obn b/Test14.obn new file mode 100644 index 0000000..2baa8db --- /dev/null +++ b/Test14.obn @@ -0,0 +1,21 @@ +MODULE Test14; + +VAR + x : REAL; + +BEGIN + x := 3.6; + ASSERT(ENTIER(x) = 3); + ASSERT(ENTIER(3.6) = 3); + x := 3.5; + ASSERT(ENTIER(x) = 3); + ASSERT(ENTIER(3.5) = 3); + x := -3.6; + ASSERT(ENTIER(x) = -4); + ASSERT(ENTIER(-3.6) = -4); + x := -3.5; + ASSERT(ENTIER(x) = -4); + ASSERT(ENTIER(-3.5) = -4); +END Test14. + +Тест правильности ENTIER. diff --git a/Test15.obn b/Test15.obn new file mode 100644 index 0000000..59be01b --- /dev/null +++ b/Test15.obn @@ -0,0 +1,14 @@ +MODULE Test15; + +VAR + x : ARRAY 10 OF INTEGER; + p : POINTER TO ARRAY OF ARRAY OF INTEGER; + +BEGIN + NEW(p, 20, 30); + ASSERT(LEN(x, 0) = 10); + ASSERT(LEN(p^, 0) = 20); + ASSERT(LEN(p^, 1) = 30); +END Test15. + +Тест LEN. diff --git a/notes b/notes index a6270d0..09e3bd0 100644 --- a/notes +++ b/notes @@ -1,7 +1,7 @@ - Сделать проверку повторов в CASE. - Сделать нормальную проверку наличия RETURN. -- Нет функций CHR ENTIER LEN LONG ORD SHORT +- Нет функций LONG SHORT - Нет процедур DEC EXCL INC INCL - Нет счёта строк / столбцов - Нет процедур привязанных к типм diff --git a/obn-run-tests.sh b/obn-run-tests.sh index 0c0e092..f36da1f 100755 --- a/obn-run-tests.sh +++ b/obn-run-tests.sh @@ -42,3 +42,5 @@ maketest Test10 maketest Test11 maketest Test12 maketest Test13 +maketest Test14 +maketest Test15 diff --git a/src/backends/jvm/generator-jvm.c b/src/backends/jvm/generator-jvm.c index c2fd9ab..5b45cc1 100644 --- a/src/backends/jvm/generator-jvm.c +++ b/src/backends/jvm/generator-jvm.c @@ -1136,6 +1136,19 @@ jvm_generate_expr_new_pointer(gen_proc_t * p, oberon_type_t * type, int num, obe jvm_generate_new(p, type -> base, num); } +static void +jvm_generate_cast_prefix(gen_proc_t * p, char prefix, char postfix) +{ + if(prefix == postfix) + { + return; + } + + int from_cell_size = jvm_cell_size_for_postfix(prefix); + int to_cell_size = jvm_cell_size_for_postfix(postfix); + jvm_generate(p, from_cell_size, to_cell_size, "%c2%c", prefix, postfix); +} + static void jvm_generate_cast_type(gen_proc_t * p, oberon_type_t * from, oberon_type_t * to) { @@ -1151,17 +1164,7 @@ jvm_generate_cast_type(gen_proc_t * p, oberon_type_t * from, oberon_type_t * to) { char prefix = jvm_get_prefix(from); char postfix = jvm_get_postfix(to); - int from_cell_size = jvm_cell_size_for_type(from); - int to_cell_size = jvm_cell_size_for_type(to); - - jvm_generate_comment(p, "cast type class from %i(%i) to %i(%i)", from -> class, from -> size, to -> class, to -> size); - - if(prefix == postfix) - { - return; - } - - jvm_generate(p, from_cell_size, to_cell_size, "%c2%c", prefix, postfix); + jvm_generate_cast_prefix(p, prefix, postfix); } } @@ -1217,6 +1220,11 @@ push_item(gen_proc_t * p, oberon_item_t * item) case MODE_STRING: jvm_generate_push_string(p, item -> string, item -> result -> size); break; + case MODE_LEN: + push_item(p, item -> parent); + jvm_generate_array_len(p, item -> integer); + jvm_generate_cast_prefix(p, 'i', jvm_get_postfix(item -> result)); + break; default: gen_error("push_item: unk mode %i", item -> mode); break; @@ -1555,6 +1563,18 @@ jvm_generate_ash(gen_proc_t * p, oberon_expr_t * a, oberon_expr_t * b) jvm_generate_label(p, label_end); } +static void +jvm_generate_entier(gen_proc_t * p, oberon_expr_t * x, oberon_type_t * res) +{ + char prefix = jvm_get_prefix(x -> result); + char postfix = jvm_get_postfix(res); + + push_expr(p, x); + jvm_generate_cast_prefix(p, prefix, 'd'); + jvm_generate(p, 2, 2, "invokestatic java/lang/Math/floor(D)D"); + jvm_generate_cast_prefix(p, 'd', postfix); +} + static void push_operator(gen_proc_t * p, oberon_oper_t * oper) { @@ -1574,6 +1594,9 @@ push_operator(gen_proc_t * p, oberon_oper_t * oper) push_expr(p, oper -> left); jvm_generate_operator(p, preq, op); break; + case OP_ENTIER: + jvm_generate_entier(p, oper -> left, oper -> result); + break; case OP_ADD: case OP_SUB: diff --git a/src/oberon-internals.h b/src/oberon-internals.h index 7536540..31c8054 100644 --- a/src/oberon-internals.h +++ b/src/oberon-internals.h @@ -180,7 +180,8 @@ enum oberon_mode_kind MODE_CHAR, MODE_STRING, MODE_TYPE, - MODE_SET + MODE_SET, + MODE_LEN }; enum oberon_operator_kind @@ -189,6 +190,7 @@ enum oberon_operator_kind OP_LOGIC_NOT, OP_ABS, OP_CAP, + OP_ENTIER, OP_ADD, OP_SUB, diff --git a/src/oberon.c b/src/oberon.c index 0854335..53dd33e 100644 --- a/src/oberon.c +++ b/src/oberon.c @@ -4111,6 +4111,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 +4241,66 @@ oberon_make_odd_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_ 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) { @@ -4171,9 +4333,13 @@ 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, "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, "MIN", oberon_make_min_call, NULL); oberon_new_intrinsic(ctx, "MAX", oberon_make_max_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, "SIZE", oberon_make_size_call, NULL); /* Procedures */ -- 2.29.2