From b09b4829b70cf34a470003286ea100663d7fe442 Mon Sep 17 00:00:00 2001
From: DeaDDooMER <deaddoomer@deadsoftware.ru>
Date: Sun, 13 Aug 2017 13:08:21 +0300
Subject: [PATCH] =?utf8?q?=D0=94=D0=BE=D0=B1=D0=B0=D0=B2=D0=BB=D0=B5=D0=BD?=
 =?utf8?q?=D1=8B=20=D1=84=D1=83=D0=BD=D0=BA=D1=86=D0=B8=D0=B8=20CHR=20ENTI?=
 =?utf8?q?ER=20LEN=20ORD?=
MIME-Version: 1.0
Content-Type: text/plain; charset=utf8
Content-Transfer-Encoding: 8bit

---
 Test.obn                         |   9 +-
 Test14.obn                       |  21 ++++
 Test15.obn                       |  14 +++
 notes                            |   2 +-
 obn-run-tests.sh                 |   2 +
 src/backends/jvm/generator-jvm.c |  45 +++++++--
 src/oberon-internals.h           |   4 +-
 src/oberon.c                     | 166 +++++++++++++++++++++++++++++++
 8 files changed, 249 insertions(+), 14 deletions(-)
 create mode 100644 Test14.obn
 create mode 100644 Test15.obn

diff --git a/Test.obn b/Test.obn
index babecff..03df037 100644
--- a/Test.obn
+++ b/Test.obn
@@ -1,5 +1,12 @@
 MODULE Test;
 
+VAR
+  x : ARRAY 10 OF INTEGER;
+  p : POINTER TO ARRAY OF ARRAY OF INTEGER;
+
 BEGIN
-  ASSERT(ODD(5));
+  NEW(p, 20, 30);
+  ASSERT(LEN(x, 0) = 10);
+  ASSERT(LEN(p^, 0) = 20);
+  ASSERT(LEN(p^, 1) = 30);
 END Test.
diff --git a/Test14.obn b/Test14.obn
new file mode 100644
index 0000000..2baa8db
--- /dev/null
+++ b/Test14.obn
@@ -0,0 +1,21 @@
+MODULE Test14;
+
+VAR
+  x : REAL;
+
+BEGIN
+  x := 3.6;
+  ASSERT(ENTIER(x) = 3);
+  ASSERT(ENTIER(3.6) = 3);
+  x := 3.5;
+  ASSERT(ENTIER(x) = 3);
+  ASSERT(ENTIER(3.5) = 3);
+  x := -3.6;
+  ASSERT(ENTIER(x) = -4);
+  ASSERT(ENTIER(-3.6) = -4);
+  x := -3.5;
+  ASSERT(ENTIER(x) = -4);
+  ASSERT(ENTIER(-3.5) = -4);
+END Test14.
+
+Тест правильности ENTIER.
diff --git a/Test15.obn b/Test15.obn
new file mode 100644
index 0000000..59be01b
--- /dev/null
+++ b/Test15.obn
@@ -0,0 +1,14 @@
+MODULE Test15;
+
+VAR
+  x : ARRAY 10 OF INTEGER;
+  p : POINTER TO ARRAY OF ARRAY OF INTEGER;
+
+BEGIN
+  NEW(p, 20, 30);
+  ASSERT(LEN(x, 0) = 10);
+  ASSERT(LEN(p^, 0) = 20);
+  ASSERT(LEN(p^, 1) = 30);
+END Test15.
+
+Тест LEN.
diff --git a/notes b/notes
index a6270d0..09e3bd0 100644
--- a/notes
+++ b/notes
@@ -1,7 +1,7 @@
 - Сделать проверку повторов в CASE.
 - Сделать нормальную проверку наличия RETURN.
 
-- Нет функций CHR ENTIER LEN LONG ORD SHORT
+- Нет функций LONG SHORT
 - Нет процедур DEC EXCL INC INCL
 - Нет счёта строк / столбцов
 - Нет процедур привязанных к типм
diff --git a/obn-run-tests.sh b/obn-run-tests.sh
index 0c0e092..f36da1f 100755
--- a/obn-run-tests.sh
+++ b/obn-run-tests.sh
@@ -42,3 +42,5 @@ maketest Test10
 maketest Test11
 maketest Test12
 maketest Test13
+maketest Test14
+maketest Test15
diff --git a/src/backends/jvm/generator-jvm.c b/src/backends/jvm/generator-jvm.c
index c2fd9ab..5b45cc1 100644
--- a/src/backends/jvm/generator-jvm.c
+++ b/src/backends/jvm/generator-jvm.c
@@ -1136,6 +1136,19 @@ jvm_generate_expr_new_pointer(gen_proc_t * p, oberon_type_t * type, int num, obe
 	jvm_generate_new(p, type -> base, num);
 }
 
+static void
+jvm_generate_cast_prefix(gen_proc_t * p, char prefix, char postfix)
+{
+	if(prefix == postfix)
+	{
+		return;
+	}
+
+	int from_cell_size = jvm_cell_size_for_postfix(prefix);
+	int to_cell_size = jvm_cell_size_for_postfix(postfix);
+	jvm_generate(p, from_cell_size, to_cell_size, "%c2%c", prefix, postfix);
+}
+
 static void
 jvm_generate_cast_type(gen_proc_t * p, oberon_type_t * from, oberon_type_t * to)
 {
@@ -1151,17 +1164,7 @@ jvm_generate_cast_type(gen_proc_t * p, oberon_type_t * from, oberon_type_t * to)
 	{
 		char prefix = jvm_get_prefix(from);
 		char postfix = jvm_get_postfix(to);
-		int from_cell_size = jvm_cell_size_for_type(from);
-		int to_cell_size = jvm_cell_size_for_type(to);
-
-		jvm_generate_comment(p, "cast type class from %i(%i) to %i(%i)", from -> class, from -> size, to -> class, to -> size);
-
-		if(prefix == postfix)
-		{
-			return;
-		}
-
-		jvm_generate(p, from_cell_size, to_cell_size, "%c2%c", prefix, postfix);
+		jvm_generate_cast_prefix(p, prefix, postfix);
 	}
 }
 
@@ -1217,6 +1220,11 @@ push_item(gen_proc_t * p, oberon_item_t * item)
 		case MODE_STRING:
 			jvm_generate_push_string(p, item -> string, item -> result -> size);
 			break;
+		case MODE_LEN:
+			push_item(p, item -> parent);
+			jvm_generate_array_len(p, item -> integer);
+			jvm_generate_cast_prefix(p, 'i', jvm_get_postfix(item -> result));
+			break;
 		default:
 			gen_error("push_item: unk mode %i", item -> mode);
 			break;
@@ -1555,6 +1563,18 @@ jvm_generate_ash(gen_proc_t * p, oberon_expr_t * a, oberon_expr_t * b)
 	jvm_generate_label(p, label_end);
 }
 
+static void
+jvm_generate_entier(gen_proc_t * p, oberon_expr_t * x, oberon_type_t * res)
+{
+	char prefix = jvm_get_prefix(x -> result);
+	char postfix = jvm_get_postfix(res);
+
+	push_expr(p, x);
+	jvm_generate_cast_prefix(p, prefix, 'd');
+	jvm_generate(p, 2, 2, "invokestatic java/lang/Math/floor(D)D");
+	jvm_generate_cast_prefix(p, 'd', postfix);
+}
+
 static void
 push_operator(gen_proc_t * p, oberon_oper_t * oper)
 {
@@ -1574,6 +1594,9 @@ push_operator(gen_proc_t * p, oberon_oper_t * oper)
 			push_expr(p, oper -> left);
 			jvm_generate_operator(p, preq, op);
 			break;
+		case OP_ENTIER:
+			jvm_generate_entier(p, oper -> left, oper -> result);
+			break;
 
 		case OP_ADD:
 		case OP_SUB:
diff --git a/src/oberon-internals.h b/src/oberon-internals.h
index 7536540..31c8054 100644
--- a/src/oberon-internals.h
+++ b/src/oberon-internals.h
@@ -180,7 +180,8 @@ enum oberon_mode_kind
 	MODE_CHAR,
 	MODE_STRING,
 	MODE_TYPE,
-	MODE_SET
+	MODE_SET,
+	MODE_LEN
 };
 
 enum oberon_operator_kind
@@ -189,6 +190,7 @@ enum oberon_operator_kind
 	OP_LOGIC_NOT,
 	OP_ABS,
 	OP_CAP,
+	OP_ENTIER,
 
 	OP_ADD,
 	OP_SUB,
diff --git a/src/oberon.c b/src/oberon.c
index 0854335..53dd33e 100644
--- a/src/oberon.c
+++ b/src/oberon.c
@@ -4111,6 +4111,108 @@ oberon_make_cap_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_
 	return expr;
 }
 
+static oberon_expr_t *
+oberon_make_chr_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;
+	if(oberon_is_const(arg))
+	{
+		expr = oberon_make_char(ctx, arg -> item.integer);
+	}
+	else
+	{
+		expr = oberon_cast_expr(ctx, arg, ctx -> char_type);
+	}
+	return expr;
+}
+
+static oberon_expr_t *
+oberon_make_ord_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_integer(ctx, arg -> item.integer);
+	}
+	else
+	{
+		expr = oberon_cast_expr(ctx, arg, ctx -> int_type);
+	}
+	return expr;
+}
+
+static oberon_expr_t *
+oberon_make_entier_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_real_type(arg -> result))
+	{
+		oberon_error(ctx, "expected real");
+	}
+
+	oberon_expr_t * expr;
+	if(oberon_is_const(arg))
+	{
+		expr = oberon_make_integer(ctx, floor(arg -> item.real));
+	}
+	else
+	{
+		expr = oberon_new_operator(OP_ENTIER, ctx -> int_type, arg, NULL);
+	}
+	return expr;
+}
+
 static oberon_expr_t *
 oberon_make_odd_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
 {
@@ -4139,6 +4241,66 @@ oberon_make_odd_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_
 	return expr;
 }
 
+static oberon_expr_t *
+oberon_make_len_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 > 2)
+	{
+		oberon_error(ctx, "too mach arguments");
+	}
+
+	oberon_expr_t * v;
+	v = list_args;
+	oberon_check_src(ctx, v);
+
+	if(!oberon_is_array_type(v -> result))
+	{
+		oberon_error(ctx, "expected array");
+	}
+
+	int n = 0;
+	if(num_args == 2)
+	{
+		oberon_expr_t * num;
+		num = list_args -> next;
+		oberon_check_src(ctx, num);
+
+		if(!oberon_is_integer_type(num -> result))
+		{
+			oberon_error(ctx, "expected integer");
+		}
+		oberon_check_const(ctx, num);
+
+		n = num -> item.integer;
+	}
+
+	int dim = 0;
+	oberon_type_t * arr = v -> result;
+	while(arr -> class == OBERON_TYPE_ARRAY)
+	{
+		dim += 1;
+		arr = arr -> base;
+	}
+
+	if(n < 0 || n > dim)
+	{
+		oberon_error(ctx, "not in range 0..%i", dim - 1);
+	}
+
+	assert(v -> is_item);
+
+	oberon_expr_t * expr;
+	expr = oberon_new_item(MODE_LEN, ctx -> int_type, true);
+	expr -> item.parent = (oberon_item_t *) v;
+	expr -> item.integer = n;
+	return expr;	
+}
+
 static void
 oberon_new_const(oberon_context_t * ctx, char * name, oberon_expr_t * expr)
 {
@@ -4171,9 +4333,13 @@ oberon_create_context(ModuleImportCallback import_module)
 	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, "CHR", oberon_make_chr_call, NULL);
+	oberon_new_intrinsic(ctx, "ENTIER", oberon_make_entier_call, NULL);
+	oberon_new_intrinsic(ctx, "LEN", oberon_make_len_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, "ORD", oberon_make_ord_call, NULL);
 	oberon_new_intrinsic(ctx, "SIZE", oberon_make_size_call, NULL);
 
 	/* Procedures */
-- 
2.29.2