From 95acec6c3ae8d3c324c84b001a680aa49320790b Mon Sep 17 00:00:00 2001 From: DeaDDooMER Date: Sun, 13 Aug 2017 10:40:37 +0300 Subject: [PATCH] =?utf8?q?=D0=94=D0=BE=D0=B1=D0=B0=D0=B2=D0=BB=D0=B5=D0=BD?= =?utf8?q?=D1=8B=20=D1=84=D1=83=D0=BD=D0=BA=D1=86=D0=B8=D0=B8=20ASH=20?= =?utf8?q?=D0=B8=20ODD,=20=D0=BA=20=D0=B4=D1=80=D1=83=D0=B3=D0=B8=D0=BC=20?= =?utf8?q?=D0=B4=D0=BE=D0=B1=D0=B0=D0=B2=D0=BB=D0=B5=D0=BD=D0=B0=20=D1=81?= =?utf8?q?=D0=B2=D1=91=D1=80=D1=82=D0=BA=D0=B0=20=D0=BA=D0=BE=D0=BD=D1=81?= =?utf8?q?=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