From: DeaDDooMER <deaddoomer@deadsoftware.ru>
Date: Fri, 18 Aug 2017 12:59:08 +0000 (+0300)
Subject: Добавлена функция SYSTEM.ROT
X-Git-Url: http://deadsoftware.ru/gitweb?a=commitdiff_plain;h=789adb9354da345b13aa284f3f4f8f1046cadbc4;p=dsw-obn.git

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

diff --git a/Test.obn b/Test.obn
index f5f0600..3c869ea 100644
--- 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 05273a2..74562f6 100644
--- 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 fa7705d..5ac3bbd 100644
--- 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 ce1b506..20cbe60 100644
--- 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 c131f7f..c063e2f 100644
--- 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 b81eb95..528842b 100644
--- 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 2b114ee..9080fb1 100644
--- 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);