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

diff --git a/Test.obn b/Test.obn
index 0bad0ad763fe3b298b127518a3af3fbc2e878678..f5f060074bc991c58ed398d78be0dd3e5c5ed6be 100644 (file)
--- a/Test.obn
+++ b/Test.obn
@@ -1,12 +1,12 @@
 MODULE Test;
 
-IMPORT SYSTEM;
+IMPORT SYSTEM, Out;
 
 VAR
-  ptr : SYSTEM.PTR;
-  arr : POINTER TO ARRAY OF INTEGER;
+  i : INTEGER;
 
 BEGIN
-  NEW(arr, 20);
-  ptr := arr;
+  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));
 END Test.

diff --git a/Test12.obn b/Test12.obn
index 4eecfb167cdeaba601260dce51f77302351da055..05273a2d7d519c39122ecf1d524a6f6a58a9d5bb 100644 (file)
--- a/Test12.obn
+++ b/Test12.obn
@@ -1,19 +1,31 @@
 MODULE Test12;
 
+IMPORT SYSTEM;
+
 CONST
-  icon = 32;
-  ash1 = ASH(icon, -5);
-  ash2 = ASH(icon, 5);
+  con  = -32;
+  comp = 32;
 
 VAR
-  i : INTEGER;
+  i, j : INTEGER;
 
 BEGIN
-  i := icon;
-  ASSERT(ash1 = 1);
-  ASSERT(ash2 = 1024);
-  ASSERT(ASH(i, -5) = 1);
-  ASSERT(ASH(i, 5) = 1024);
+  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));
 END Test12.
 
-Проверка правильности вычисления ASH.
+Проверка сдвигов.

diff --git a/notes b/notes
index 14f5f21b1640e4c46947a0e1c7d93d897ea23051..fa7705dfa001aa13adc046c33670a855dec92312 100644 (file)
--- a/notes
+++ b/notes
@@ -1,6 +1,6 @@
 - Перепроверить конверсию строк единичного размера в символ.
 - Не полная реализация модуля SYSTEM
-    * Нет процедур CC LSH ROT VAL
+    * Нет функций CC ROT VAL
     * Процедуры GETREG PUTREG впринципе вписываются в jvm
       и могут быть полезны при реализции рефлекции
 - Нет процедур привязанных к типм (10.2)
@@ -17,6 +17,7 @@
 - Надо что-то делать с ситуацией описанной в (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/src/backends/jvm/generator-jvm.c b/src/backends/jvm/generator-jvm.c
index feace6fe30e44ea9568b6c9f39ef7846a5286cde..c131f7f750080b2ce9f3ace65639063f0617d548 100644 (file)
--- a/src/backends/jvm/generator-jvm.c
+++ b/src/backends/jvm/generator-jvm.c
@@ -1570,7 +1570,7 @@ 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)
+jvm_generate_ash(gen_proc_t * p, oberon_expr_t * a, oberon_expr_t * b, bool logical)
 {
        oberon_type_t * t = a -> result;
        int cell_size = jvm_cell_size_for_type(t);
@@ -1597,8 +1597,15 @@ jvm_generate_ash(gen_proc_t * p, oberon_expr_t * a, oberon_expr_t * b)
        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_abs(p, prefix);
+       if(logical)
+       {
+               jvm_generate(p, 2 * cell_size, cell_size, "%cushr", prefix);
+       }
+       else
+       {
+               jvm_generate(p, 2 * cell_size, cell_size, "%cshr", prefix);
+       }
        jvm_generate_label(p, label_end);
 }
 
@@ -1680,7 +1687,10 @@ push_operator(gen_proc_t * p, oberon_oper_t * oper)
                        break;
 
                case OP_ASH:
-                       jvm_generate_ash(p, oper -> left, oper -> right);
+                       jvm_generate_ash(p, oper -> left, oper -> right, false);
+                       break;
+               case OP_LSH:
+                       jvm_generate_ash(p, oper -> left, oper -> right, true);
                        break;
                default:
                        gen_error("push_oper: unk op %i", op);

diff --git a/src/oberon-internals.h b/src/oberon-internals.h
index 0a97386fda71b126636f70500fe0643fa3597862..b81eb95fea111b6b1d9231ca92f176ba90069f7a 100644 (file)
--- a/src/oberon-internals.h
+++ b/src/oberon-internals.h
@@ -190,7 +190,8 @@ enum oberon_mode_kind
        MODE_STRING,
        MODE_TYPE,
        MODE_SET,
-       MODE_LEN
+       MODE_LEN,
+       MODE_SYSBYTE
 };
 
 enum oberon_operator_kind
@@ -227,7 +228,8 @@ enum oberon_operator_kind
        OP_COMPLEMENTATION,
        OP_IN,
 
-       OP_ASH
+       OP_ASH,
+       OP_LSH
 };
 
 struct oberon_item_t

diff --git a/src/oberon.c b/src/oberon.c
index 07c83c28643623df555292ca429fa5eba776ae9d..2b114eee9cfd9aa01cf08e2e1d05691c2aa036dd 100644 (file)
--- a/src/oberon.c
+++ b/src/oberon.c
@@ -151,6 +151,16 @@ oberon_make_integer(oberon_context_t * ctx, int64_t i)
        return expr;
 }
 
+static oberon_expr_t *
+oberon_make_system_byte(oberon_context_t * ctx, int64_t i)
+{
+       oberon_expr_t * expr;
+       expr = oberon_new_item(MODE_SYSBYTE, ctx -> system_byte_type, true);
+       expr -> item.integer = i;
+       expr -> item.real = i;
+       return expr;
+}
+
 static oberon_expr_t *
 oberon_make_char(oberon_context_t * ctx, int64_t i)
 {
@@ -2012,6 +2022,7 @@ oberon_is_const(oberon_expr_t * expr)
                case MODE_STRING:
                case MODE_SET:
                case MODE_TYPE:
+               case MODE_SYSBYTE:
                        return true;
                        break;
                default:
@@ -4150,7 +4161,8 @@ 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;
-               expr = oberon_make_integer(ctx, x * powl(2, y));
+               int64_t v = x * powl(2, y);
+               expr = oberon_make_integer(ctx, v);
        }
        else
        {
@@ -4160,6 +4172,67 @@ oberon_make_ash_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_
        return expr;
 }
 
+static oberon_expr_t *
+oberon_make_lsh_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 = (y > 0) ? (x << y) : (x >> labs(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_LSH, 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)
 {
@@ -4623,6 +4696,9 @@ oberon_create_context(ModuleImportCallback import_module)
                oberon_new_intrinsic_type(ctx, "BYTE", ctx -> system_byte_type);
                oberon_new_intrinsic_type(ctx, "PTR", ctx -> system_ptr_type);
 
+               /* Functions */
+               oberon_new_intrinsic(ctx, "LSH", oberon_make_lsh_call, NULL);
+
        oberon_end_intrinsic_module(ctx, ctx -> system_module);
 
        return ctx;