Переделано присваивание строк и добавлены процедуры COPY, ASSERT и HALT

[dsw-obn.git] / src / oberon.c

diff --git a/src/oberon.c b/src/oberon.c
index 9738056b94124b347e771b1bb541364e83859ae6..1f33a03c9d82bc084e3ffb1b38777b6750bc9c2f 100644 (file)
--- 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;
 }