Добавлена функция SYSTEM.ROT

diff --git a/Test.obn b/Test.obn
index f5f060074bc991c58ed398d78be0dd3e5c5ed6be..3c869eab01977277c2f1c68f2cbc88b4f80319ea 100644 (file)
--- a/Test.obn
+++ b/Test.obn
@@ -3,10 +3,17 @@ MODULE Test;
 IMPORT SYSTEM, Out;
 
 VAR
-  i : INTEGER;
+  i, j : INTEGER;
 
 BEGIN
-  i := -32;
-  Out.Int(SYSTEM.LSH(i, -5), 0); Out.Char(" "); Out.Int(SYSTEM.LSH(-32, -5), 0); Out.Ln;
-  ASSERT(SYSTEM.LSH(i, -5) = SYSTEM.LSH(-32, -5));
+  i := 1;
+  j := -32;
+  Out.Int(SYSTEM.ROT(i, -1), 0); Out.String(" = "); Out.Int(SYSTEM.ROT(1, -1), 0); Out.Ln;
+  Out.Int(SYSTEM.ROT(i, 1), 0); Out.String(" = "); Out.Int(SYSTEM.ROT(1, 1), 0); Out.Ln;
+  Out.Int(SYSTEM.ROT(j, -1), 0); Out.String(" = "); Out.Int(SYSTEM.ROT(-32, -1), 0); Out.Ln;
+  Out.Int(SYSTEM.ROT(j, 1), 0); Out.String(" = "); Out.Int(SYSTEM.ROT(-32, 1), 0); Out.Ln;
+
+  ASSERT(SYSTEM.ROT(i, -1) = SYSTEM.ROT(1, -1));
+
+  ASSERT(SYSTEM.ROT(i,  1) = SYSTEM.ROT(1,  1));
 END Test.

diff --git a/Test12.obn b/Test12.obn
index 05273a2d7d519c39122ecf1d524a6f6a58a9d5bb..74562f62e4c09611d36ce1cc2e39a3e6894e877a 100644 (file)
--- a/Test12.obn
+++ b/Test12.obn
@@ -1,31 +1,40 @@
 MODULE Test12;
 
-IMPORT SYSTEM;
+IMPORT SYSTEM, Out;
 
 CONST
-  con  = -32;
-  comp = 32;
+  xConI = -33;
+  xConJ = 33;
+  nConK = -5;
+  nConL = 5;
 
 VAR
-  i, j : INTEGER;
+  i, j : HUGEINT;
 
+PROCEDURE Chk(a, b : HUGEINT);
 BEGIN
-  i := con;
-  j := comp;
-
-  ASSERT(ASH(i, -5) = ASH(con, -5));
-  ASSERT(ASH(i,  5) = ASH(con,  5));
-  ASSERT(ASH(j, -5) = ASH(comp, -5));
-  ASSERT(ASH(j,  5) = ASH(comp,  5));
-
-(*
-  (* Константы вычисляются с максимальной точностью, поэтому всегда провал  *)
-  ASSERT(SYSTEM.LSH(i, -5) = SYSTEM.LSH(con, -5));
-*)
-
-  ASSERT(SYSTEM.LSH(i,  5) = SYSTEM.LSH(con,  5));
-  ASSERT(SYSTEM.LSH(j, -5) = SYSTEM.LSH(comp, -5));
-  ASSERT(SYSTEM.LSH(j,  5) = SYSTEM.LSH(comp,  5));
+  Out.Int(a, 0); Out.String(" = "); Out.Int(b, 0); Out.Ln;
+  ASSERT(a = b);
+END Chk;
+
+BEGIN
+  i := xConI;
+  j := xConJ;
+
+  Chk(ASH(i, nConK), ASH(xConI, nConK));
+  Chk(ASH(i, nConL), ASH(xConI, nConL));
+  Chk(ASH(j, nConK), ASH(xConJ, nConK));
+  Chk(ASH(j, nConL), ASH(xConJ, nConL));
+
+  Chk(SYSTEM.LSH(i, nConK), SYSTEM.LSH(xConI, nConK));
+  Chk(SYSTEM.LSH(i, nConL), SYSTEM.LSH(xConI, nConL));
+  Chk(SYSTEM.LSH(j, nConK), SYSTEM.LSH(xConJ, nConK));
+  Chk(SYSTEM.LSH(j, nConL), SYSTEM.LSH(xConJ, nConL));
+
+  Chk(SYSTEM.ROT(i, nConK), SYSTEM.ROT(xConI, nConK));
+  Chk(SYSTEM.ROT(i, nConL), SYSTEM.ROT(xConI, nConL));
+  Chk(SYSTEM.ROT(j, nConK), SYSTEM.ROT(xConJ, nConK));
+  Chk(SYSTEM.ROT(j, nConL), SYSTEM.ROT(xConJ, nConL));
 END Test12.
 
 Проверка сдвигов.

diff --git a/notes b/notes
index fa7705dfa001aa13adc046c33670a855dec92312..5ac3bbdd1f7aea525fd9393459deb0cea6fe6238 100644 (file)
--- a/notes
+++ b/notes
@@ -1,6 +1,6 @@
 - Перепроверить конверсию строк единичного размера в символ.
 - Не полная реализация модуля SYSTEM
-    * Нет функций CC ROT VAL
+    * Нет функций CC VAL
     * Процедуры GETREG PUTREG впринципе вписываются в jvm
       и могут быть полезны при реализции рефлекции
 - Нет процедур привязанных к типм (10.2)
@@ -17,7 +17,6 @@
 - Надо что-то делать с ситуацией описанной в (okawood 2.4)
 - Нет модулей Math and MathL (oakwood 1.2.7)
 
-- Не совсем корректное значение при логическом сдвиге отрицательного числа (см. Test12)
 - Запретить проверку типа и приведене типа если указатель имеет значение NIL (oakwood 2.3.3)
 - Запретить доступ к битам SET которые не входят в пределы 0..MAX(SET) (oakwood 2.3.5)
 - Запретить каст через SHORT если значение не в пределах результата (в рантайме чтоли?) (oakwood 2.3.6)

diff --git a/rtl/SYSTEM.java b/rtl/SYSTEM.java
index ce1b50621e447042154ad9d70dc11136278673ff..20cbe60f2115f1167d1076d32f81b2f7a3040386 100644 (file)
--- a/rtl/SYSTEM.java
+++ b/rtl/SYSTEM.java
@@ -81,4 +81,50 @@ public class SYSTEM
                        throw new RuntimeException("TRAP CODE " + n);
                }
        }
+
+       public static int ASH(int x, int n)
+       {
+               return (n > 0) ? (x << n) : (x >> Math.abs(n));
+       }
+
+       public static long ASH(long x, long n)
+       {
+               return (n > 0) ? (x << n) : (x >> Math.abs(n));
+       }
+
+       public static int LSH(int x, int n)
+       {
+               return (n > 0) ? (x << n) : (x >>> Math.abs(n));
+       }
+
+       public static long LSH(long x, long n)
+       {
+               return (n > 0) ? (x << n) : (x >>> Math.abs(n));
+       }
+
+       public static int ROT(int x, int n)
+       {
+               if(n > 0)
+               {
+                       return (x << n) | (x >>> (Integer.SIZE - n));
+               }
+               else
+               {
+                       n = Math.abs(n);
+                       return (x >>> n) | (x << (Integer.SIZE - n));
+               }
+       }
+
+       public static long ROT(long x, long n)
+       {
+               if(n > 0)
+               {
+                       return (x << n) | (x >>> (Long.SIZE - n));
+               }
+               else
+               {
+                       n = Math.abs(n);
+                       return (x >>> n) | (x << (Long.SIZE - n));
+               }
+       }
 }

diff --git a/src/backends/jvm/generator-jvm.c b/src/backends/jvm/generator-jvm.c
index c131f7f750080b2ce9f3ace65639063f0617d548..c063e2fc7fcc03ddd8c2150e03cca24c2220a96a 100644 (file)
--- a/src/backends/jvm/generator-jvm.c
+++ b/src/backends/jvm/generator-jvm.c
@@ -1570,43 +1570,35 @@ jvm_generate_in(gen_proc_t * p, oberon_expr_t * a, oberon_expr_t * b)
 }
 
 static void
-jvm_generate_ash(gen_proc_t * p, oberon_expr_t * a, oberon_expr_t * b, bool logical)
+jvm_generate_shift(gen_proc_t * p, int op, 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 */
+       char dt = jvm_get_type_of_prefix(prefix);
 
        push_expr(p, a);
+       jvm_generate_cast_type(p, a -> result, t);
        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_cast_type(p, b -> result, t);
 
-       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);
-       if(logical)
-       {
-               jvm_generate(p, 2 * cell_size, cell_size, "%cushr", prefix);
-       }
-       else
+       char * opname;
+       switch(op)
        {
-               jvm_generate(p, 2 * cell_size, cell_size, "%cshr", prefix);
+               case OP_ASH:
+                       opname = "ASH";
+                       break;
+               case OP_LSH:
+                       opname = "LSH";
+                       break;
+               case OP_ROT:
+                       opname = "ROT";
+                       break;
+               default:
+                       gen_error("jvm_generate_shift: invalid op %i", op);
        }
-       jvm_generate_label(p, label_end);
+
+       jvm_generate(p, 2 * cell_size, cell_size, "invokestatic SYSTEM/%s(%c%c)%c", opname, dt, dt, dt);
 }
 
 static void
@@ -1687,10 +1679,9 @@ push_operator(gen_proc_t * p, oberon_oper_t * oper)
                        break;
 
                case OP_ASH:
-                       jvm_generate_ash(p, oper -> left, oper -> right, false);
-                       break;
                case OP_LSH:
-                       jvm_generate_ash(p, oper -> left, oper -> right, true);
+               case OP_ROT:
+                       jvm_generate_shift(p, op, oper -> left, oper -> right);
                        break;
                default:
                        gen_error("push_oper: unk op %i", op);

diff --git a/src/oberon-internals.h b/src/oberon-internals.h
index b81eb95fea111b6b1d9231ca92f176ba90069f7a..528842bb6c8b24f0503c85b1b45ca3d0ed9ae551 100644 (file)
--- a/src/oberon-internals.h
+++ b/src/oberon-internals.h
@@ -229,7 +229,8 @@ enum oberon_operator_kind
        OP_IN,
 
        OP_ASH,
-       OP_LSH
+       OP_LSH,
+       OP_ROT
 };
 
 struct oberon_item_t

diff --git a/src/oberon.c b/src/oberon.c
index 2b114eee9cfd9aa01cf08e2e1d05691c2aa036dd..9080fb144eadec7fad4d923d0c328491bb5f7334 100644 (file)
--- a/src/oberon.c
+++ b/src/oberon.c
@@ -4161,7 +4161,7 @@ oberon_make_ash_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_
        {
                int64_t x = arg1 -> item.integer;
                int64_t y = arg2 -> item.integer;
-               int64_t v = x * powl(2, y);
+               int64_t v = (y > 0) ? (x << y) : (x >> labs(y));
                expr = oberon_make_integer(ctx, v);
        }
        else
@@ -4211,6 +4211,7 @@ oberon_make_lsh_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_
                uint64_t x = arg1 -> item.integer;
                int64_t y = arg2 -> item.integer;
                uint64_t v = (y > 0) ? (x << y) : (x >> labs(y));
+
                if(oberon_is_integer_type(t))
                {
                        expr = oberon_make_integer(ctx, v);
@@ -4233,6 +4234,78 @@ oberon_make_lsh_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_
        return expr;
 }
 
+static oberon_expr_t *
+oberon_make_rot_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);
+
+       oberon_type_t * t = arg1 -> result;
+       if(!oberon_is_integer_type(t)
+               && !oberon_is_char_type(t) 
+               && !oberon_is_system_byte_type(t))
+       {
+               oberon_error(ctx, "expected integer, char, or SYSTEM.BYTE");
+       }
+
+       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))
+       {
+               uint64_t x = arg1 -> item.integer;
+               int64_t y = arg2 -> item.integer;
+
+               uint64_t v = 0;
+               if(y > 0)
+               {
+                       v = (x << y) | (x >> (64 - y));
+               }
+               else
+               {
+                       y = labs(y);
+                       v = (x >> y) | (x << (64 - y));
+               }
+
+               if(oberon_is_integer_type(t))
+               {
+                       expr = oberon_make_integer(ctx, v);
+               }
+               else if(oberon_is_char_type(t))
+               {
+                       expr = oberon_make_char(ctx, v);
+               }
+               else
+               {
+                       expr = oberon_make_system_byte(ctx, v);
+               }
+       }
+       else
+       {
+               expr = oberon_new_operator(OP_ROT, arg1 -> result, arg1, arg2);
+               expr = oberon_cast_expr(ctx, expr, t);
+       }
+
+       return expr;
+}
+
 static oberon_expr_t *
 oberon_make_cap_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
 {
@@ -4698,6 +4771,7 @@ oberon_create_context(ModuleImportCallback import_module)
 
                /* Functions */
                oberon_new_intrinsic(ctx, "LSH", oberon_make_lsh_call, NULL);
+               oberon_new_intrinsic(ctx, "ROT", oberon_make_rot_call, NULL);
 
        oberon_end_intrinsic_module(ctx, ctx -> system_module);