From 9f8036eb00032fa7f756113365cb42e05ab262df Mon Sep 17 00:00:00 2001
From: DeaDDooMER <deaddoomer@deadsoftware.ru>
Date: Fri, 11 Aug 2017 14:27:56 +0300
Subject: [PATCH] =?utf8?q?=D0=9F=D0=B5=D1=80=D0=B5=D0=B4=D0=B5=D0=BB=D0=B0?=
 =?utf8?q?=D0=BD=D0=BE=20=D0=BF=D1=80=D0=B8=D1=81=D0=B2=D0=B0=D0=B8=D0=B2?=
 =?utf8?q?=D0=B0=D0=BD=D0=B8=D0=B5=20=D1=81=D1=82=D1=80=D0=BE=D0=BA=20?=
 =?utf8?q?=D0=B8=20=D0=B4=D0=BE=D0=B1=D0=B0=D0=B2=D0=BB=D0=B5=D0=BD=D1=8B?=
 =?utf8?q?=20=D0=BF=D1=80=D0=BE=D1=86=D0=B5=D0=B4=D1=83=D1=80=D1=8B=20COPY?=
 =?utf8?q?,=20ASSERT=20=D0=B8=20HALT?=
MIME-Version: 1.0
Content-Type: text/plain; charset=utf8
Content-Transfer-Encoding: 8bit

---
 System.obn                           |   6 --
 Test.obn                             |  16 +--
 Test6.obn                            |  20 ++++
 notes                                |   4 +-
 obn-run-tests.sh                     |   1 +
 obn-run.sh                           |   2 +-
 rtl/SYSTEM.java                      |  47 +++++++++
 rtl/System.java                      |   7 --
 src/backends/jvm/generator-jvm-abi.c |   5 +-
 src/backends/jvm/generator-jvm.c     |  59 +++++++++++
 src/generator.h                      |   4 +
 src/oberon.c                         | 144 +++++++++++++++++++++++++--
 12 files changed, 285 insertions(+), 30 deletions(-)
 delete mode 100644 System.obn
 create mode 100644 Test6.obn
 create mode 100644 rtl/SYSTEM.java
 delete mode 100644 rtl/System.java

diff --git a/System.obn b/System.obn
deleted file mode 100644
index 54db52e..0000000
--- a/System.obn
+++ /dev/null
@@ -1,6 +0,0 @@
-MODULE System;
-
-PROCEDURE Halt*(n : INTEGER);
-END Halt;
-
-END System.
diff --git a/Test.obn b/Test.obn
index 4f53910..8c3a8d1 100644
--- a/Test.obn
+++ b/Test.obn
@@ -3,12 +3,16 @@ MODULE Test;
 IMPORT Out;
 
 VAR
-  f : BOOLEAN;
-  r, e : POINTER TO RECORD END;
+  msg : ARRAY 20 OF CHAR;
 
 BEGIN
-  f := r = e;
-  IF f THEN
-    Out.String('Yes'); Out.Ln;
-  END;
+  Out.Open;
+  COPY("Hello World!", msg);
+  Out.String(msg); Out.Ln;
+  COPY("Hell!", msg);
+  Out.String(msg); Out.Ln;
+  COPY("The quick brown fox jumps over the lazy dog", msg);
+  Out.String(msg); Out.Ln;
+  msg := "Hello World!";
+  Out.String(msg); Out.Ln;
 END Test.
diff --git a/Test6.obn b/Test6.obn
new file mode 100644
index 0000000..db6cede
--- /dev/null
+++ b/Test6.obn
@@ -0,0 +1,20 @@
+MODULE Test6;
+
+IMPORT Out;
+
+VAR
+  msg : ARRAY 20 OF CHAR;
+
+BEGIN
+  Out.Open;
+  COPY("Hello World!", msg);
+  Out.String(msg); Out.Ln;
+  COPY("Hell!", msg);
+  Out.String(msg); Out.Ln;
+  COPY("The quick brown fox jumps over the lazy dog", msg);
+  Out.String(msg); Out.Ln;
+  msg := "Hello World!";
+  Out.String(msg); Out.Ln;
+END Test6.
+
+Проверка строк. COPY должен обрезать строки если не лезет.
diff --git a/notes b/notes
index 072a37d..ce31365 100644
--- a/notes
+++ b/notes
@@ -1,4 +1,3 @@
-- Переделать присваивание строк.
 - Сделать проверку повторов в CASE и выполнять прирывание при отсутствии ELSE.
 - В FOR сначала должна вычисляться переменная temp.
 - Сделать выполнение прерывания при отсутствии ELSE в операторе WITH.
@@ -9,7 +8,7 @@
 
 - Нет модуля SYSTEM
 - Нет функций ASH CAP CHR ENTIER LEN LONG ODD ORD SHORT
-- Нет процедур ASSERT COPY DEC EXCL HALT INC INCL
+- Нет процедур DEC EXCL INC INCL
 - Нет счёта строк / столбцов
 - Нет процедур привязанных к типм
 - Не реализована свёртка констант
@@ -24,6 +23,7 @@
 - Уточнить как должна работать проверка импорта на чтение. (8.1)
 - Уточнить результат оператора "/" (8.2.2)
 - Примеры -5 DIV 3 и -5 MOD 3 работают не так как в (8.2.2)
+    Нужен другой тип округления?
 
 - Нужны средства создания биндингов. На данный момент реализуемо как заглушки для модулей.
 - Любая ошибка фатальна
diff --git a/obn-run-tests.sh b/obn-run-tests.sh
index 2c7dbec..d809c75 100755
--- a/obn-run-tests.sh
+++ b/obn-run-tests.sh
@@ -32,3 +32,4 @@ maketest Test2
 maketest Test3
 maketest Test4
 maketest Test5
+maketest Test6
diff --git a/obn-run.sh b/obn-run.sh
index ef0185c..9514a22 100755
--- a/obn-run.sh
+++ b/obn-run.sh
@@ -2,4 +2,4 @@
 
 set -e
 
-java -cp classes Launcher $1
+java -ea -cp classes Launcher $1
diff --git a/rtl/SYSTEM.java b/rtl/SYSTEM.java
new file mode 100644
index 0000000..f98236b
--- /dev/null
+++ b/rtl/SYSTEM.java
@@ -0,0 +1,47 @@
+public class SYSTEM
+{
+	/* Каркас для фреймов процедур */
+	public static abstract class FRAME
+	{
+		public FRAME up;
+	}
+
+	/* Длинна строки LEN(s$) */
+	public static int LEN(byte[] x)
+	{
+		int i = 0;
+		while(x[i] != 0)
+		{
+			i += 1;
+		}
+		return i;
+	}
+
+	/* Встроенная процедура COPY(x, v) */
+	public static void COPY(byte[] x, byte[] v)
+	{
+		int len_x = LEN(x);
+		int len_v = v.length - 1;
+		int len = (len_x < len_v) ? (len_x) : (len_v);
+		for(int i = 0; i < len; i++)
+		{
+			v[i] = x[i];
+		}
+		v[len] = 0;
+	}
+
+	public static void HALT(long n)
+	{
+		System.exit((int) n);
+	}
+
+	public static void ASSERT(boolean x)
+	{
+		assert x;
+	}
+
+	public static void ASSERT(boolean x, long n)
+	{
+		assert x : n;
+	}
+}
diff --git a/rtl/System.java b/rtl/System.java
deleted file mode 100644
index d2ccf9b..0000000
--- a/rtl/System.java
+++ /dev/null
@@ -1,7 +0,0 @@
-public class System
-{
-	public static void Halt(short n)
-	{
-		java.lang.System.exit(n);
-	}
-}
diff --git a/src/backends/jvm/generator-jvm-abi.c b/src/backends/jvm/generator-jvm-abi.c
index d0dabd2..b404fca 100644
--- a/src/backends/jvm/generator-jvm-abi.c
+++ b/src/backends/jvm/generator-jvm-abi.c
@@ -358,6 +358,7 @@ jvm_generate_var_initialization(gen_proc_t * p, gen_var_t * v)
 	}
 }
 
+/*
 static void
 jvm_generate_abstract_frame_class()
 {
@@ -383,6 +384,7 @@ jvm_generate_abstract_frame_class()
 
 	jvm_destroy_class(class);
 }
+*/
 
 static struct gen_class *
 jvm_generate_frame_class(oberon_object_t * proc)
@@ -478,7 +480,8 @@ jvm_generate_procedure_frame(oberon_object_t * proc)
 
 	p = proc -> gen_proc;
 
-	jvm_generate_abstract_frame_class();
+//	jvm_generate_abstract_frame_class();
+
 	class = jvm_generate_frame_class(proc);
 
 	t = GC_MALLOC(sizeof *t);
diff --git a/src/backends/jvm/generator-jvm.c b/src/backends/jvm/generator-jvm.c
index 5e74d18..4011965 100644
--- a/src/backends/jvm/generator-jvm.c
+++ b/src/backends/jvm/generator-jvm.c
@@ -1641,3 +1641,62 @@ oberon_generate_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_
 
 	store_expr(p, dst, src);
 }
+
+void
+oberon_generate_copy(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst)
+{
+	gen_module_t * m;
+	gen_proc_t * p;
+	char * desc;
+
+	m = ctx -> mod -> gen_mod;
+	p = m -> class -> p;
+
+	push_expr(p, src);
+	push_expr(p, dst);
+
+	desc = jvm_get_descriptor(dst -> result);
+
+	jvm_generate(p, 2, 0, "invokestatic SYSTEM/COPY(%s%s)V", desc, desc);
+}
+
+void
+oberon_generate_assert(oberon_context_t * ctx, oberon_expr_t * cond)
+{
+	gen_module_t * m;
+	gen_proc_t * p;
+
+	m = ctx -> mod -> gen_mod;
+	p = m -> class -> p;
+
+	push_expr(p, cond);
+	jvm_generate(p, 1, 0, "invokestatic SYSTEM/ASSERT(Z)V");
+}
+
+void
+oberon_generate_assert_n(oberon_context_t * ctx, oberon_expr_t * cond, int64_t n)
+{
+	gen_module_t * m;
+	gen_proc_t * p;
+
+	m = ctx -> mod -> gen_mod;
+	p = m -> class -> p;
+
+	push_expr(p, cond);
+	jvm_generate_push_int_size(p, n, 8);
+	jvm_generate(p, 1 + 2, 0, "invokestatic SYSTEM/ASSERT(ZJ)V");
+}
+
+void
+oberon_generate_halt(oberon_context_t * ctx, int64_t n)
+{
+	gen_module_t * m;
+	gen_proc_t * p;
+
+	m = ctx -> mod -> gen_mod;
+	p = m -> class -> p;
+
+	jvm_generate_push_int_size(p, n, 8);
+	jvm_generate(p, 2, 0, "invokestatic SYSTEM/HALT(J)V");
+}
+
diff --git a/src/generator.h b/src/generator.h
index a940dab..bc502cc 100644
--- a/src/generator.h
+++ b/src/generator.h
@@ -38,4 +38,8 @@ void oberon_generate_goto(oberon_context_t * ctx, gen_label_t * l);
  */
 
 void oberon_generate_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst);
+void oberon_generate_copy(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst);
+void oberon_generate_assert_n(oberon_context_t * ctx, oberon_expr_t * cond, int64_t n);
+void oberon_generate_assert(oberon_context_t * ctx, oberon_expr_t * cond);
+void oberon_generate_halt(oberon_context_t * ctx, int64_t n);
 void oberon_generate_return(oberon_context_t * ctx, oberon_expr_t * expr);
diff --git a/src/oberon.c b/src/oberon.c
index 9738056..1f33a03 100644
--- a/src/oberon.c
+++ b/src/oberon.c
@@ -85,6 +85,9 @@ enum {
 //   UTILS
 // ======================================================================= 
 
+static void
+oberon_make_copy_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args);
+
 static void
 oberon_error(oberon_context_t * ctx, const char * fmt, ...)
 {
@@ -1055,6 +1058,11 @@ oberon_check_record_compatibility(oberon_context_t * ctx, oberon_type_t * from,
 static void
 oberon_check_dst(oberon_context_t * ctx, oberon_expr_t * dst)
 {
+	if(dst -> read_only)
+	{
+		oberon_error(ctx, "read-only destination");
+	}
+
 	if(dst -> is_item == false)
 	{
 		oberon_error(ctx, "not variable");
@@ -3314,14 +3322,30 @@ oberon_statement_seq(oberon_context_t * ctx);
 static void
 oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst)
 {
-	if(dst -> read_only)
+	if(src -> is_item
+		&& src -> item.mode == MODE_STRING
+		&& src -> result -> class == OBERON_TYPE_STRING
+		&& dst -> result -> class == OBERON_TYPE_ARRAY
+		&& dst -> result -> base -> class == OBERON_TYPE_CHAR
+		&& dst -> result -> size > 0)
 	{
-		oberon_error(ctx, "read-only destination");
-	}
 
-	oberon_check_dst(ctx, dst);
-	src = oberon_autocast_to(ctx, src, dst -> result);
-	oberon_generate_assign(ctx, src, dst);
+		if(strlen(src -> item.string) < dst -> result -> size)
+		{
+			src -> next = dst;
+			oberon_make_copy_call(ctx, 2, src);
+		}
+		else
+		{
+			oberon_error(ctx, "string too long for destination");
+		}
+	}
+	else
+	{
+		oberon_check_dst(ctx, dst);
+		src = oberon_autocast_to(ctx, src, dst -> result);
+		oberon_generate_assign(ctx, src, dst);
+	}
 }
 
 static oberon_expr_t *
@@ -4043,7 +4067,6 @@ oberon_make_new_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_
 		oberon_error(ctx, "too few arguments");
 	}
 
-
 	oberon_expr_t * dst;
 	dst = list_args;
 	oberon_check_dst(ctx, dst);
@@ -4119,6 +4142,110 @@ oberon_make_new_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_
 	oberon_assign(ctx, src, dst);
 }
 
+static void
+oberon_make_copy_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 * src;
+	src = list_args;
+	oberon_check_src(ctx, src);
+
+	oberon_expr_t * dst;
+	dst = list_args -> next;
+	oberon_check_dst(ctx, dst);
+
+	if(!oberon_is_string_type(src -> result))
+	{
+		oberon_error(ctx, "source must be string or array of char");
+	}
+
+	if(!oberon_is_string_type(dst -> result))
+	{
+		oberon_error(ctx, "dst must be array of char");
+	}
+
+	oberon_generate_copy(ctx, src, dst);
+}
+
+static void
+oberon_make_assert_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 * cond;
+	cond = list_args;
+	oberon_check_src(ctx, cond);
+
+	if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
+	{
+		oberon_error(ctx, "expected boolean");
+	}
+
+	if(num_args == 1)
+	{
+		oberon_generate_assert(ctx, cond);
+	}
+	else
+	{
+		oberon_expr_t * num;
+		num = list_args -> next;
+		oberon_check_src(ctx, num);
+
+		if(num -> result -> class != OBERON_TYPE_INTEGER)
+		{
+			oberon_error(ctx, "expected integer");
+		}
+
+		oberon_check_const(ctx, num);
+
+		oberon_generate_assert_n(ctx, cond, num -> item.integer);
+	}
+}
+
+static void
+oberon_make_halt_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 * num;
+	num = list_args;
+	oberon_check_src(ctx, num);
+
+	if(num -> result -> class != OBERON_TYPE_INTEGER)
+	{
+		oberon_error(ctx, "expected integer");
+	}
+
+	oberon_check_const(ctx, num);
+
+	oberon_generate_halt(ctx, num -> item.integer);
+}
+
 static void
 oberon_new_const(oberon_context_t * ctx, char * name, oberon_expr_t * expr)
 {
@@ -4155,6 +4282,9 @@ oberon_create_context(ModuleImportCallback import_module)
 
 	/* Procedures */
 	oberon_new_intrinsic(ctx, "NEW", NULL, oberon_make_new_call);
+	oberon_new_intrinsic(ctx, "COPY", NULL, oberon_make_copy_call);
+	oberon_new_intrinsic(ctx, "ASSERT", NULL, oberon_make_assert_call);
+	oberon_new_intrinsic(ctx, "HALT", NULL, oberon_make_halt_call);
 
 	return ctx;
 }
-- 
2.29.2