diff --git a/src/oberon.c b/src/oberon.c
index 9080fb144eadec7fad4d923d0c328491bb5f7334..29c40cb974b5a822bb89c18cfe567a2d464aa966 100644 (file)
--- a/src/oberon.c
+++ b/src/oberon.c
return expr;
}
+static oberon_expr_t *
+oberon_make_string(oberon_context_t * ctx, char * str)
+{
+ oberon_expr_t * expr;
+ expr = oberon_new_item(MODE_STRING, ctx -> string_type, true);
+ expr -> item.integer = str[0];
+ expr -> item.real = str[0];
+ expr -> item.string = str;
+ return expr;
+}
+
static oberon_expr_t *
oberon_make_real_typed(oberon_context_t * ctx, double r, oberon_type_t * result)
{
@@ -1056,6 +1067,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)
{
oberon_assert_token(ctx, CHAR);
break;
case STRING:
- result = ctx -> string_type;
- expr = oberon_new_item(MODE_STRING, result, true);
- expr -> item.string = ctx -> string;
+ expr = oberon_make_string(ctx, ctx -> string);
oberon_assert_token(ctx, STRING);
break;
case REAL:
@@ -1699,7 +1714,7 @@ oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_
oberon_expr_t * expr;
oberon_type_t * result;
- oberon_check_compatible_bin_expr_types(ctx, token, a -> result, b -> result);
+ oberon_check_compatible_bin_expr(ctx, token, a, b);
oberon_check_src(ctx, a);
if(token != IS)
{
@@ -1724,7 +1739,22 @@ oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_
}
else if((token >= EQUAL && token <= GEQ) || token == OR || token == AND)
{
- result = oberon_get_longer_type(ctx, a -> result, b -> result);
+ if(oberon_is_string_of_one(a) && oberon_is_char_type(b -> result))
+ {
+ result = b -> result;
+ }
+ else if(oberon_is_string_of_one(b) && oberon_is_char_type(a -> result))
+ {
+ result = a -> result;
+ }
+ else if(oberon_is_string_of_one(a) && oberon_is_string_of_one(b))
+ {
+ result = ctx -> char_type;
+ }
+ else
+ {
+ result = oberon_get_longer_type(ctx, a -> result, b -> result);
+ }
if(oberon_is_const(a) && oberon_is_const(b)
&& (oberon_is_real_type(result) || oberon_is_integer_type(result)))
oberon_expr_t * cond2;
e1 = (oberon_expr_t *) oberon_const_expr(ctx);
-
+
e2 = NULL;
if(ctx -> token == DOTDOT)
{
@@ -4392,7 +4422,7 @@ oberon_make_ord_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_
arg = list_args;
oberon_check_src(ctx, arg);
- if(!oberon_is_char_type(arg -> result))
+ if(!oberon_is_char_type(arg -> result) && !oberon_is_string_of_one(arg))
{
oberon_error(ctx, "expected char");
}
@@ -4471,6 +4501,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 +4587,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, "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);