jvm_generate_new(p, type -> base, num);
}
+static void
+jvm_generate_cast_prefix(gen_proc_t * p, char prefix, char postfix)
+{
+ if(prefix == postfix)
+ {
+ return;
+ }
+
+ int from_cell_size = jvm_cell_size_for_postfix(prefix);
+ int to_cell_size = jvm_cell_size_for_postfix(postfix);
+ jvm_generate(p, from_cell_size, to_cell_size, "%c2%c", prefix, postfix);
+}
+
static void
jvm_generate_cast_type(gen_proc_t * p, oberon_type_t * from, oberon_type_t * to)
{
{
char prefix = jvm_get_prefix(from);
char postfix = jvm_get_postfix(to);
- int from_cell_size = jvm_cell_size_for_type(from);
- int to_cell_size = jvm_cell_size_for_type(to);
-
- jvm_generate_comment(p, "cast type class from %i(%i) to %i(%i)", from -> class, from -> size, to -> class, to -> size);
-
- if(prefix == postfix)
- {
- return;
- }
-
- jvm_generate(p, from_cell_size, to_cell_size, "%c2%c", prefix, postfix);
+ jvm_generate_cast_prefix(p, prefix, postfix);
}
}
case MODE_STRING:
jvm_generate_push_string(p, item -> string, item -> result -> size);
break;
+ case MODE_LEN:
+ push_item(p, item -> parent);
+ jvm_generate_array_len(p, item -> integer);
+ jvm_generate_cast_prefix(p, 'i', jvm_get_postfix(item -> result));
+ break;
default:
gen_error("push_item: unk mode %i", item -> mode);
break;
jvm_generate_label(p, label_end);
}
+static void
+jvm_generate_entier(gen_proc_t * p, oberon_expr_t * x, oberon_type_t * res)
+{
+ char prefix = jvm_get_prefix(x -> result);
+ char postfix = jvm_get_postfix(res);
+
+ push_expr(p, x);
+ jvm_generate_cast_prefix(p, prefix, 'd');
+ jvm_generate(p, 2, 2, "invokestatic java/lang/Math/floor(D)D");
+ jvm_generate_cast_prefix(p, 'd', postfix);
+}
+
static void
push_operator(gen_proc_t * p, oberon_oper_t * oper)
{
push_expr(p, oper -> left);
jvm_generate_operator(p, preq, op);
break;
+ case OP_ENTIER:
+ jvm_generate_entier(p, oper -> left, oper -> result);
+ break;
case OP_ADD:
case OP_SUB:
return expr;
}
+static oberon_expr_t *
+oberon_make_chr_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);
+
+ if(!oberon_is_integer_type(arg -> result))
+ {
+ oberon_error(ctx, "expected integer");
+ }
+
+ oberon_expr_t * expr;
+ if(oberon_is_const(arg))
+ {
+ expr = oberon_make_char(ctx, arg -> item.integer);
+ }
+ else
+ {
+ expr = oberon_cast_expr(ctx, arg, ctx -> char_type);
+ }
+ return expr;
+}
+
+static oberon_expr_t *
+oberon_make_ord_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);
+
+ if(!oberon_is_char_type(arg -> result))
+ {
+ oberon_error(ctx, "expected char");
+ }
+
+ oberon_expr_t * expr;
+ if(oberon_is_const(arg))
+ {
+ expr = oberon_make_integer(ctx, arg -> item.integer);
+ }
+ else
+ {
+ expr = oberon_cast_expr(ctx, arg, ctx -> int_type);
+ }
+ return expr;
+}
+
+static oberon_expr_t *
+oberon_make_entier_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);
+
+ if(!oberon_is_real_type(arg -> result))
+ {
+ oberon_error(ctx, "expected real");
+ }
+
+ oberon_expr_t * expr;
+ if(oberon_is_const(arg))
+ {
+ expr = oberon_make_integer(ctx, floor(arg -> item.real));
+ }
+ else
+ {
+ expr = oberon_new_operator(OP_ENTIER, ctx -> int_type, arg, NULL);
+ }
+ return expr;
+}
+
static oberon_expr_t *
oberon_make_odd_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
{
return expr;
}
+static oberon_expr_t *
+oberon_make_len_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 > 2)
+ {
+ oberon_error(ctx, "too mach arguments");
+ }
+
+ oberon_expr_t * v;
+ v = list_args;
+ oberon_check_src(ctx, v);
+
+ if(!oberon_is_array_type(v -> result))
+ {
+ oberon_error(ctx, "expected array");
+ }
+
+ int n = 0;
+ if(num_args == 2)
+ {
+ oberon_expr_t * num;
+ num = list_args -> next;
+ oberon_check_src(ctx, num);
+
+ if(!oberon_is_integer_type(num -> result))
+ {
+ oberon_error(ctx, "expected integer");
+ }
+ oberon_check_const(ctx, num);
+
+ n = num -> item.integer;
+ }
+
+ int dim = 0;
+ oberon_type_t * arr = v -> result;
+ while(arr -> class == OBERON_TYPE_ARRAY)
+ {
+ dim += 1;
+ arr = arr -> base;
+ }
+
+ if(n < 0 || n > dim)
+ {
+ oberon_error(ctx, "not in range 0..%i", dim - 1);
+ }
+
+ assert(v -> is_item);
+
+ oberon_expr_t * expr;
+ expr = oberon_new_item(MODE_LEN, ctx -> int_type, true);
+ expr -> item.parent = (oberon_item_t *) v;
+ expr -> item.integer = n;
+ return expr;
+}
+
static void
oberon_new_const(oberon_context_t * ctx, char * name, oberon_expr_t * expr)
{
oberon_new_intrinsic(ctx, "ABS", oberon_make_abs_call, NULL);
oberon_new_intrinsic(ctx, "ASH", oberon_make_ash_call, NULL);
oberon_new_intrinsic(ctx, "CAP", oberon_make_cap_call, NULL);
+ oberon_new_intrinsic(ctx, "CHR", oberon_make_chr_call, NULL);
+ oberon_new_intrinsic(ctx, "ENTIER", oberon_make_entier_call, NULL);
+ oberon_new_intrinsic(ctx, "LEN", oberon_make_len_call, NULL);
oberon_new_intrinsic(ctx, "MIN", oberon_make_min_call, NULL);
oberon_new_intrinsic(ctx, "MAX", oberon_make_max_call, NULL);
oberon_new_intrinsic(ctx, "ODD", oberon_make_odd_call, NULL);
+ oberon_new_intrinsic(ctx, "ORD", oberon_make_ord_call, NULL);
oberon_new_intrinsic(ctx, "SIZE", oberon_make_size_call, NULL);
/* Procedures */
