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

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

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