diff --git a/src/oberon.c b/src/oberon.c
index 07c83c28643623df555292ca429fa5eba776ae9d..c1e86d229c340de3f475029119b6335ea08f4aba 100644 (file)
--- a/src/oberon.c
+++ b/src/oberon.c
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)
{
@@ -1046,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)
{
case MODE_STRING:
case MODE_SET:
case MODE_TYPE:
+ case MODE_SYSBYTE:
return true;
break;
default:
@@ -4150,7 +4167,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 = (y > 0) ? (x << y) : (x >> labs(y));
+ expr = oberon_make_integer(ctx, v);
}
else
{
@@ -4160,6 +4178,140 @@ 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_rot_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 = 0;
+ if(y > 0)
+ {
+ v = (x << y) | (x >> (64 - y));
+ }
+ else
+ {
+ y = labs(y);
+ v = (x >> y) | (x << (64 - 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_ROT, 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)
{
@@ -4325,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)
{
@@ -4379,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)
{
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, "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);
return ctx;