Добавлена функция SYSTEM.LSH

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

diff --git a/src/oberon.c b/src/oberon.c
index 07c83c28643623df555292ca429fa5eba776ae9d..2b114eee9cfd9aa01cf08e2e1d05691c2aa036dd 100644 (file)
--- a/src/oberon.c
+++ b/src/oberon.c
@@ -151,6 +151,16 @@ oberon_make_integer(oberon_context_t * ctx, int64_t i)
        return expr;
 }
 
+static oberon_expr_t *
+oberon_make_system_byte(oberon_context_t * ctx, int64_t i)
+{
+       oberon_expr_t * expr;
+       expr = oberon_new_item(MODE_SYSBYTE, ctx -> system_byte_type, true);
+       expr -> item.integer = i;
+       expr -> item.real = i;
+       return expr;
+}
+
 static oberon_expr_t *
 oberon_make_char(oberon_context_t * ctx, int64_t i)
 {
@@ -2012,6 +2022,7 @@ oberon_is_const(oberon_expr_t * expr)
                case MODE_STRING:
                case MODE_SET:
                case MODE_TYPE:
+               case MODE_SYSBYTE:
                        return true;
                        break;
                default:
@@ -4150,7 +4161,8 @@ oberon_make_ash_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_
        {
                int64_t x = arg1 -> item.integer;
                int64_t y = arg2 -> item.integer;
-               expr = oberon_make_integer(ctx, x * powl(2, y));
+               int64_t v = x * powl(2, y);
+               expr = oberon_make_integer(ctx, v);
        }
        else
        {
@@ -4160,6 +4172,67 @@ oberon_make_ash_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_
        return expr;
 }
 
+static oberon_expr_t *
+oberon_make_lsh_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 * arg1;
+       arg1 = list_args;
+       oberon_check_src(ctx, arg1);
+
+       oberon_type_t * t = arg1 -> result;
+       if(!oberon_is_integer_type(t)
+               && !oberon_is_char_type(t) 
+               && !oberon_is_system_byte_type(t))
+       {
+               oberon_error(ctx, "expected integer, char, or SYSTEM.BYTE");
+       }
+
+       oberon_expr_t * arg2;
+       arg2 = list_args -> next;
+       oberon_check_src(ctx, arg2);
+       if(arg2 -> result -> class != OBERON_TYPE_INTEGER)
+       {
+               oberon_error(ctx, "expected integer");
+       }
+
+       oberon_expr_t * expr;
+       if(oberon_is_const(arg1) && oberon_is_const(arg2))
+       {
+               uint64_t x = arg1 -> item.integer;
+               int64_t y = arg2 -> item.integer;
+               uint64_t v = (y > 0) ? (x << y) : (x >> labs(y));
+               if(oberon_is_integer_type(t))
+               {
+                       expr = oberon_make_integer(ctx, v);
+               }
+               else if(oberon_is_char_type(t))
+               {
+                       expr = oberon_make_char(ctx, v);
+               }
+               else
+               {
+                       expr = oberon_make_system_byte(ctx, v);
+               }
+       }
+       else
+       {
+               expr = oberon_new_operator(OP_LSH, arg1 -> result, arg1, arg2);
+               expr = oberon_cast_expr(ctx, expr, t);
+       }
+
+       return expr;
+}
+
 static oberon_expr_t *
 oberon_make_cap_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
 {
@@ -4623,6 +4696,9 @@ oberon_create_context(ModuleImportCallback import_module)
                oberon_new_intrinsic_type(ctx, "BYTE", ctx -> system_byte_type);
                oberon_new_intrinsic_type(ctx, "PTR", ctx -> system_ptr_type);
 
+               /* Functions */
+               oberon_new_intrinsic(ctx, "LSH", oberon_make_lsh_call, NULL);
+
        oberon_end_intrinsic_module(ctx, ctx -> system_module);
 
        return ctx;