X-Git-Url: http://deadsoftware.ru/gitweb?p=dsw-obn.git;a=blobdiff_plain;f=src%2Foberon.c;h=1f33a03c9d82bc084e3ffb1b38777b6750bc9c2f;hp=9738056b94124b347e771b1bb541364e83859ae6;hb=9f8036eb00032fa7f756113365cb42e05ab262df;hpb=e637b466c2a4e0b0feb0f264ad4342ecfe9efd21

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;
 }