Добавлены функции SYSTEM.CC и SYSTEM.VAL

diff --git a/Test.obn b/Test.obn
index 3c869eab01977277c2f1c68f2cbc88b4f80319ea..d232953a80d3259d11c1a1987e2bd14d3a4c415c 100644 (file)
--- a/Test.obn
+++ b/Test.obn
@@ -2,18 +2,13 @@ MODULE Test;
 
 IMPORT SYSTEM, Out;
 
+TYPE
+  R = RECORD END;
+
 VAR
-  i, j : INTEGER;
+  i : INTEGER;
+  l : LONGINT;
 
 BEGIN
-  i := 1;
-  j := -32;
-  Out.Int(SYSTEM.ROT(i, -1), 0); Out.String(" = "); Out.Int(SYSTEM.ROT(1, -1), 0); Out.Ln;
-  Out.Int(SYSTEM.ROT(i, 1), 0); Out.String(" = "); Out.Int(SYSTEM.ROT(1, 1), 0); Out.Ln;
-  Out.Int(SYSTEM.ROT(j, -1), 0); Out.String(" = "); Out.Int(SYSTEM.ROT(-32, -1), 0); Out.Ln;
-  Out.Int(SYSTEM.ROT(j, 1), 0); Out.String(" = "); Out.Int(SYSTEM.ROT(-32, 1), 0); Out.Ln;
-
-  ASSERT(SYSTEM.ROT(i, -1) = SYSTEM.ROT(1, -1));
-
-  ASSERT(SYSTEM.ROT(i,  1) = SYSTEM.ROT(1,  1));
+  i := SYSTEM.VAL(INTEGER, l);
 END Test.

diff --git a/notes b/notes
index 5ac3bbdd1f7aea525fd9393459deb0cea6fe6238..ad35ef7a9565f946f208f572960e3626a52318b7 100644 (file)
--- a/notes
+++ b/notes
@@ -1,6 +1,5 @@
 - Перепроверить конверсию строк единичного размера в символ.
 - Не полная реализация модуля SYSTEM
-    * Нет функций CC VAL
     * Процедуры GETREG PUTREG впринципе вписываются в jvm
       и могут быть полезны при реализции рефлекции
 - Нет процедур привязанных к типм (10.2)

diff --git a/src/backends/jvm/generator-jvm.c b/src/backends/jvm/generator-jvm.c
index c063e2fc7fcc03ddd8c2150e03cca24c2220a96a..1281c19426745d43a4982a24e92a26c834445bb7 100644 (file)
--- a/src/backends/jvm/generator-jvm.c
+++ b/src/backends/jvm/generator-jvm.c
@@ -1207,6 +1207,30 @@ jvm_generate_cast_type(gen_proc_t * p, oberon_type_t * from, oberon_type_t * to)
        }
 }
 
+static void
+jvm_generate_hard_cast_type(gen_proc_t * p, oberon_type_t * from, oberon_type_t * to)
+{
+       if(from -> class == OBERON_TYPE_REAL
+               && (to -> class == OBERON_TYPE_INTEGER || to -> class == OBERON_TYPE_SYSTEM_BYTE))
+       {
+               char postfix = jvm_get_postfix(to);
+               if(from -> size <= 4)
+               {
+                       jvm_generate(p, 1, 1, "invokestatic java/lang/Float/floatToIntBits(F)I");
+                       jvm_generate_cast_prefix(p, 'I', postfix);
+               }
+               else
+               {
+                       jvm_generate(p, 2, 2, "invokestatic java/lang/Double/floatToIntBits(D)J");
+                       jvm_generate_cast_prefix(p, 'J', postfix);
+               }
+       }
+       else
+       {
+               jvm_generate_cast_type(p, from, to);
+       }
+}
+
 static void
 push_item(gen_proc_t * p, oberon_item_t * item)
 {
@@ -1624,6 +1648,10 @@ push_operator(gen_proc_t * p, oberon_oper_t * oper)
                        push_expr(p, oper -> left);
                        jvm_generate_cast_type(p, oper -> left -> result, oper -> result);
                        break;
+               case OP_HARDCAST:
+                       push_expr(p, oper -> left);
+                       jvm_generate_hard_cast_type(p, oper -> left -> result, oper -> result);
+                       break;
                case OP_COMPLEMENTATION:
                case OP_UNARY_MINUS:
                case OP_LOGIC_NOT:

diff --git a/src/oberon-internals.h b/src/oberon-internals.h
index 528842bb6c8b24f0503c85b1b45ca3d0ed9ae551..ad2ecc654b1dfc66fd744ddab31a7ef26f05a515 100644 (file)
--- a/src/oberon-internals.h
+++ b/src/oberon-internals.h
@@ -218,6 +218,7 @@ enum oberon_operator_kind
        OP_GEQ,
 
        OP_CAST,
+       OP_HARDCAST,
        OP_IS,
 
        OP_RANGE,

diff --git a/src/oberon.c b/src/oberon.c
index 9080fb144eadec7fad4d923d0c328491bb5f7334..c1e86d229c340de3f475029119b6335ea08f4aba 100644 (file)
--- a/src/oberon.c
+++ b/src/oberon.c
@@ -1056,6 +1056,12 @@ oberon_cast_expr(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * p
        return cast;
 }
 
+static oberon_expr_t *
+oberon_hard_cast_expr(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref)
+{
+       return oberon_new_operator(OP_HARDCAST, pref, expr, NULL);
+}
+
 static void
 oberon_check_dst(oberon_context_t * ctx, oberon_expr_t * dst)
 {
@@ -4471,6 +4477,38 @@ oberon_make_odd_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_
        return expr;
 }
 
+static oberon_expr_t *
+oberon_make_cc_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);
+       oberon_check_const(ctx, arg);
+
+       if(!oberon_is_integer_type(arg -> result))
+       {
+               oberon_error(ctx, "expected integer");
+       }
+
+       /* n >= 0 && n <= 15 */
+
+       oberon_expr_t * cond1;
+       oberon_expr_t * cond2;
+       cond1 = oberon_make_bin_op(ctx, GEQ, arg, oberon_make_integer(ctx, 0));
+       cond2 = oberon_make_bin_op(ctx, LEQ, arg, oberon_make_integer(ctx, 15));
+       return oberon_make_bin_op(ctx, AND, cond1, cond2);
+}
+
 static oberon_expr_t *
 oberon_make_short_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
 {
@@ -4525,6 +4563,35 @@ oberon_make_long_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list
        return expr;
 }
 
+static oberon_expr_t *
+oberon_make_val_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 * typ;
+       typ = list_args;
+       if(!oberon_is_type_expr(typ))
+       {
+               oberon_error(ctx, "requires type");
+       }
+
+       oberon_expr_t * arg;
+       arg = list_args -> next;
+       oberon_check_src(ctx, arg);
+
+       oberon_expr_t * expr;
+       expr = oberon_hard_cast_expr(ctx, arg, typ -> result);
+       return expr;
+}
+
 static oberon_expr_t *
 oberon_make_len_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
 {
@@ -4770,8 +4837,10 @@ oberon_create_context(ModuleImportCallback import_module)
                oberon_new_intrinsic_type(ctx, "PTR", ctx -> system_ptr_type);
 
                /* Functions */
+               oberon_new_intrinsic(ctx, "CC", oberon_make_cc_call, NULL);
                oberon_new_intrinsic(ctx, "LSH", oberon_make_lsh_call, NULL);
                oberon_new_intrinsic(ctx, "ROT", oberon_make_rot_call, NULL);
+               oberon_new_intrinsic(ctx, "VAL", oberon_make_val_call, NULL);
 
        oberon_end_intrinsic_module(ctx, ctx -> system_module);