MODULE Test;
-IMPORT SYSTEM;
+IMPORT SYSTEM, Out;
VAR
- ptr : SYSTEM.PTR;
- arr : POINTER TO ARRAY OF INTEGER;
+ i : INTEGER;
BEGIN
- NEW(arr, 20);
- ptr := arr;
+ i := -32;
+ Out.Int(SYSTEM.LSH(i, -5), 0); Out.Char(" "); Out.Int(SYSTEM.LSH(-32, -5), 0); Out.Ln;
+ ASSERT(SYSTEM.LSH(i, -5) = SYSTEM.LSH(-32, -5));
END Test.
MODULE Test12;
+IMPORT SYSTEM;
+
CONST
- icon = 32;
- ash1 = ASH(icon, -5);
- ash2 = ASH(icon, 5);
+ con = -32;
+ comp = 32;
VAR
- i : INTEGER;
+ i, j : INTEGER;
BEGIN
- i := icon;
- ASSERT(ash1 = 1);
- ASSERT(ash2 = 1024);
- ASSERT(ASH(i, -5) = 1);
- ASSERT(ASH(i, 5) = 1024);
+ i := con;
+ j := comp;
+
+ ASSERT(ASH(i, -5) = ASH(con, -5));
+ ASSERT(ASH(i, 5) = ASH(con, 5));
+ ASSERT(ASH(j, -5) = ASH(comp, -5));
+ ASSERT(ASH(j, 5) = ASH(comp, 5));
+
+(*
+ (* Константы вычисляются с максимальной точностью, поэтому всегда провал *)
+ ASSERT(SYSTEM.LSH(i, -5) = SYSTEM.LSH(con, -5));
+*)
+
+ ASSERT(SYSTEM.LSH(i, 5) = SYSTEM.LSH(con, 5));
+ ASSERT(SYSTEM.LSH(j, -5) = SYSTEM.LSH(comp, -5));
+ ASSERT(SYSTEM.LSH(j, 5) = SYSTEM.LSH(comp, 5));
END Test12.
-Проверка правильности вычисления ASH.
+Проверка сдвигов.
- Перепроверить конверсию строк единичного размера в символ.
- Не полная реализация модуля SYSTEM
- * Нет процедур CC LSH ROT VAL
+ * Нет функций CC ROT VAL
* Процедуры GETREG PUTREG впринципе вписываются в jvm
и могут быть полезны при реализции рефлекции
- Нет процедур привязанных к типм (10.2)
- Надо что-то делать с ситуацией описанной в (okawood 2.4)
- Нет модулей Math and MathL (oakwood 1.2.7)
+- Не совсем корректное значение при логическом сдвиге отрицательного числа (см. Test12)
- Запретить проверку типа и приведене типа если указатель имеет значение NIL (oakwood 2.3.3)
- Запретить доступ к битам SET которые не входят в пределы 0..MAX(SET) (oakwood 2.3.5)
- Запретить каст через SHORT если значение не в пределах результата (в рантайме чтоли?) (oakwood 2.3.6)
}
static void
-jvm_generate_ash(gen_proc_t * p, oberon_expr_t * a, oberon_expr_t * b)
+jvm_generate_ash(gen_proc_t * p, oberon_expr_t * a, oberon_expr_t * b, bool logical)
{
oberon_type_t * t = a -> result;
int cell_size = jvm_cell_size_for_type(t);
jvm_generate(p, 2 * cell_size, cell_size, "%cshl", prefix);
jvm_generate(p, 0, 0, "goto L%i", label_end);
jvm_generate_label(p, label_else);
- jvm_generate_abs(p, prefix);
- jvm_generate(p, 2 * cell_size, cell_size, "%cshr", prefix);
+ jvm_generate_abs(p, prefix);
+ if(logical)
+ {
+ jvm_generate(p, 2 * cell_size, cell_size, "%cushr", prefix);
+ }
+ else
+ {
+ jvm_generate(p, 2 * cell_size, cell_size, "%cshr", prefix);
+ }
jvm_generate_label(p, label_end);
}
break;
case OP_ASH:
- jvm_generate_ash(p, oper -> left, oper -> right);
+ jvm_generate_ash(p, oper -> left, oper -> right, false);
+ break;
+ case OP_LSH:
+ jvm_generate_ash(p, oper -> left, oper -> right, true);
break;
default:
gen_error("push_oper: unk op %i", op);
MODE_STRING,
MODE_TYPE,
MODE_SET,
- MODE_LEN
+ MODE_LEN,
+ MODE_SYSBYTE
};
enum oberon_operator_kind
OP_COMPLEMENTATION,
OP_IN,
- OP_ASH
+ OP_ASH,
+ OP_LSH
};
struct oberon_item_t
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)
{
case MODE_STRING:
case MODE_SET:
case MODE_TYPE:
+ case MODE_SYSBYTE:
return true;
break;
default:
{
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
{
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)
{
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;
