From: DeaDDooMER <deaddoomer@deadsoftware.ru>
Date: Fri, 18 Aug 2017 13:54:18 +0000 (+0300)
Subject: Добавлены функции SYSTEM.CC и SYSTEM.VAL
X-Git-Url: http://deadsoftware.ru/gitweb?a=commitdiff_plain;h=9aa6ede8ebe1b901501ad3cb49d79d6811a79dc9;p=dsw-obn.git

Добавлены функции SYSTEM.CC и SYSTEM.VAL
---

diff --git a/Test.obn b/Test.obn
index 3c869ea..d232953 100644
--- a/Test.obn
+++ b/Test.obn
@@ -2,18 +2,13 @@ MODULE Test;
 
 IMPORT SYSTEM, Out;
 
+TYPE
+  R = RECORD END;
+
 VAR
-  i, j : INTEGER;
+  i : INTEGER;
+  l : LONGINT;
 
 BEGIN
-  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));
+  i := SYSTEM.VAL(INTEGER, l);
 END Test.
diff --git a/notes b/notes
index 5ac3bbd..ad35ef7 100644
--- a/notes
+++ b/notes
@@ -1,6 +1,5 @@
 - Перепроверить конверсию строк единичного размера в символ.
 - Не полная реализация модуля SYSTEM
-    * Нет функций CC VAL
     * Процедуры GETREG PUTREG впринципе вписываются в jvm
       и могут быть полезны при реализции рефлекции
 - Нет процедур привязанных к типм (10.2)
diff --git a/src/backends/jvm/generator-jvm.c b/src/backends/jvm/generator-jvm.c
index c063e2f..1281c19 100644
--- a/src/backends/jvm/generator-jvm.c
+++ b/src/backends/jvm/generator-jvm.c
@@ -1207,6 +1207,30 @@ jvm_generate_cast_type(gen_proc_t * p, oberon_type_t * from, oberon_type_t * to)
 	}
 }
 
+static void
+jvm_generate_hard_cast_type(gen_proc_t * p, oberon_type_t * from, oberon_type_t * to)
+{
+	if(from -> class == OBERON_TYPE_REAL
+		&& (to -> class == OBERON_TYPE_INTEGER || to -> class == OBERON_TYPE_SYSTEM_BYTE))
+	{
+		char postfix = jvm_get_postfix(to);
+		if(from -> size <= 4)
+		{
+			jvm_generate(p, 1, 1, "invokestatic java/lang/Float/floatToIntBits(F)I");
+			jvm_generate_cast_prefix(p, 'I', postfix);
+		}
+		else
+		{
+			jvm_generate(p, 2, 2, "invokestatic java/lang/Double/floatToIntBits(D)J");
+			jvm_generate_cast_prefix(p, 'J', postfix);
+		}
+	}
+	else
+	{
+		jvm_generate_cast_type(p, from, to);
+	}
+}
+
 static void
 push_item(gen_proc_t * p, oberon_item_t * item)
 {
@@ -1624,6 +1648,10 @@ push_operator(gen_proc_t * p, oberon_oper_t * oper)
 			push_expr(p, oper -> left);
 			jvm_generate_cast_type(p, oper -> left -> result, oper -> result);
 			break;
+		case OP_HARDCAST:
+			push_expr(p, oper -> left);
+			jvm_generate_hard_cast_type(p, oper -> left -> result, oper -> result);
+			break;
 		case OP_COMPLEMENTATION:
 		case OP_UNARY_MINUS:
 		case OP_LOGIC_NOT:
diff --git a/src/oberon-internals.h b/src/oberon-internals.h
index 528842b..ad2ecc6 100644
--- a/src/oberon-internals.h
+++ b/src/oberon-internals.h
@@ -218,6 +218,7 @@ enum oberon_operator_kind
 	OP_GEQ,
 
 	OP_CAST,
+	OP_HARDCAST,
 	OP_IS,
 
 	OP_RANGE,
diff --git a/src/oberon.c b/src/oberon.c
index 9080fb1..c1e86d2 100644
--- a/src/oberon.c
+++ b/src/oberon.c
@@ -1056,6 +1056,12 @@ oberon_cast_expr(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * p
 	return cast;
 }
 
+static oberon_expr_t *
+oberon_hard_cast_expr(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref)
+{
+	return oberon_new_operator(OP_HARDCAST, pref, expr, NULL);
+}
+
 static void
 oberon_check_dst(oberon_context_t * ctx, oberon_expr_t * dst)
 {
@@ -4471,6 +4477,38 @@ oberon_make_odd_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_
 	return expr;
 }
 
+static oberon_expr_t *
+oberon_make_cc_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);
+	oberon_check_const(ctx, arg);
+
+	if(!oberon_is_integer_type(arg -> result))
+	{
+		oberon_error(ctx, "expected integer");
+	}
+
+	/* n >= 0 && n <= 15 */
+
+	oberon_expr_t * cond1;
+	oberon_expr_t * cond2;
+	cond1 = oberon_make_bin_op(ctx, GEQ, arg, oberon_make_integer(ctx, 0));
+	cond2 = oberon_make_bin_op(ctx, LEQ, arg, oberon_make_integer(ctx, 15));
+	return oberon_make_bin_op(ctx, AND, cond1, cond2);
+}
+
 static oberon_expr_t *
 oberon_make_short_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
 {
@@ -4525,6 +4563,35 @@ oberon_make_long_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list
 	return expr;
 }
 
+static oberon_expr_t *
+oberon_make_val_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 * typ;
+	typ = list_args;
+	if(!oberon_is_type_expr(typ))
+	{
+		oberon_error(ctx, "requires type");
+	}
+
+	oberon_expr_t * arg;
+	arg = list_args -> next;
+	oberon_check_src(ctx, arg);
+
+	oberon_expr_t * expr;
+	expr = oberon_hard_cast_expr(ctx, arg, typ -> result);
+	return expr;
+}
+
 static oberon_expr_t *
 oberon_make_len_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
 {
@@ -4770,8 +4837,10 @@ oberon_create_context(ModuleImportCallback import_module)
 		oberon_new_intrinsic_type(ctx, "PTR", ctx -> system_ptr_type);
 
 		/* Functions */
+		oberon_new_intrinsic(ctx, "CC", oberon_make_cc_call, NULL);
 		oberon_new_intrinsic(ctx, "LSH", oberon_make_lsh_call, NULL);
 		oberon_new_intrinsic(ctx, "ROT", oberon_make_rot_call, NULL);
+		oberon_new_intrinsic(ctx, "VAL", oberon_make_val_call, NULL);
 
 	oberon_end_intrinsic_module(ctx, ctx -> system_module);