Добавлены функции ASH и ODD, к другим добавлена свёртка констант

diff --git a/Test.obn b/Test.obn
index 8371d40d26dc72bcfbac718753e7ba1e333de80b..babecff95eba9648125ff9e686de586d643d366e 100644 (file)
--- 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 89dbcfd2f83a2e1d89937f8760d6dcab388e505c..08dd56c3aa1f2e8428324f8ac83322028a0397a5 100644 (file)
--- 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.
 
-Проверка строк.
+Ð\9fÑ\80овеÑ\80ка Ñ\81Ñ\80авнениÑ\8f Ñ\81Ñ\82Ñ\80ок.

diff --git a/Test11.obn b/Test11.obn
index 847fddfb9dcdf2b6a41579d0e2b995af2861f581..aba8cb4bae1d18d664dc202f963784ab443d51d2 100644 (file)
--- 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 (file)
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 (file)
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 7579867ca572312f8f4945516f7d4dbed0d1d0d4..e3613e4e53d70fc7e9db3bbc058b3aada74dbb77 100644 (file)
--- 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 cf12913f25bfb136d5410fa6e51a6dc266fbb4d2..a6270d01e235a696b420c02896614ec5f4fb0548 100644 (file)
--- 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 f483e01a2634ae6574da0e2a8ed8e7f4c00fc374..0c0e0922d08a99eb1658597b4a2b17c0bcf62093 100755 (executable)
--- 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 ee4bc67c17d31f33f25ba5047600658776953755..c2fd9abd4662bef894b32ae159650e7cdcb4baa2 100644 (file)
--- 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 3c6fb853f1a824330eb773fa55a95b7ac0ffd16d..7536540a6574ebc901d79e8870ad935ac6f2170b 100644 (file)
--- 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 b09dccc7c2155e5827c7bec573548568efbb10bf..904a89c4577de0ee9b270281103e3391b0530e0d 100644 (file)
--- 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 30f10ec49af929465b3dfa31885ae7bb3b150fbb..08543355c92b9e421854e751081df3e6827c8d17 100644 (file)
--- a/src/oberon.c
+++ b/src/oberon.c
@@ -6,6 +6,7 @@
 #include <assert.h>
 #include <stdbool.h>
 #include <math.h>
+#include <float.h>
 
 #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 */