Добавлены функции CHR ENTIER LEN ORD

diff --git a/Test.obn b/Test.obn
index babecff95eba9648125ff9e686de586d643d366e..03df037492a62bec8642dbd45bd9a5ec5f2cc689 100644 (file)
--- 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 (file)
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 (file)
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 a6270d01e235a696b420c02896614ec5f4fb0548..09e3bd0b3f1032a06ff27b4cf3d87c3b24560b47 100644 (file)
--- 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 0c0e0922d08a99eb1658597b4a2b17c0bcf62093..f36da1f47fac90c4c7c2a5a26acc3186b2aedc53 100755 (executable)
--- 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 c2fd9abd4662bef894b32ae159650e7cdcb4baa2..5b45cc166bca184d32d0640a24f9f90a016617ef 100644 (file)
--- 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 7536540a6574ebc901d79e8870ad935ac6f2170b..31c8054c6f2cab8f088c5de904e443aa73f67105 100644 (file)
--- 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 08543355c92b9e421854e751081df3e6827c8d17..53dd33eec2a711792adf5f3a0e9ed9b982fa5c74 100644 (file)
--- 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 */