diff --git a/oberon.c b/oberon.c
index e857b1d1ec6f93e454b5439cdcf81f96c150d167..4b20dad3d30de42797478959dc92d2cd1e8929b9 100644 (file)
--- a/oberon.c
+++ b/oberon.c
#include <ctype.h>
#include <string.h>
#include <assert.h>
+#include <stdbool.h>
#include "oberon.h"
#include "generator.h"
TO,
UPARROW,
NIL,
- IMPORT
+ IMPORT,
+ REAL
};
// =======================================================================
return x;
}
+static oberon_type_t *
+oberon_new_type_real(int size)
+{
+ oberon_type_t * x;
+ x = oberon_new_type_ptr(OBERON_TYPE_REAL);
+ x -> size = size;
+ return x;
+}
+
// =======================================================================
// TABLE
// =======================================================================
}
static void
-oberon_read_integer(oberon_context_t * ctx)
-{
- int len = 0;
- int i = ctx -> code_index;
+oberon_read_number(oberon_context_t * ctx)
+{
+ long integer;
+ double real;
+ char * ident;
+ int start_i;
+ int exp_i;
+ int end_i;
+
+ /*
+ * mode = 0 == DEC
+ * mode = 1 == HEX
+ * mode = 2 == REAL
+ * mode = 3 == LONGREAL
+ */
+ int mode = 0;
+ start_i = ctx -> code_index;
+
+ while(isdigit(ctx -> c))
+ {
+ oberon_get_char(ctx);
+ }
- int c = ctx -> code[i];
- while(isdigit(c))
+ end_i = ctx -> code_index;
+
+ if(isxdigit(ctx -> c))
{
- i += 1;
- len += 1;
- c = ctx -> code[i];
+ mode = 1;
+ while(isxdigit(ctx -> c))
+ {
+ oberon_get_char(ctx);
+ }
+
+ end_i = ctx -> code_index;
+
+ if(ctx -> c != 'H')
+ {
+ oberon_error(ctx, "invalid hex number");
+ }
+ oberon_get_char(ctx);
}
+ else if(ctx -> c == '.')
+ {
+ mode = 2;
+ oberon_get_char(ctx);
- char * ident = malloc(len + 2);
- memcpy(ident, &ctx->code[ctx->code_index], len);
- ident[len + 1] = 0;
+ while(isdigit(ctx -> c))
+ {
+ oberon_get_char(ctx);
+ }
+
+ if(ctx -> c == 'E' || ctx -> c == 'D')
+ {
+ exp_i = ctx -> code_index;
+
+ if(ctx -> c == 'D')
+ {
+ mode = 3;
+ }
+
+ oberon_get_char(ctx);
+
+ if(ctx -> c == '+' || ctx -> c == '-')
+ {
+ oberon_get_char(ctx);
+ }
+
+ while(isdigit(ctx -> c))
+ {
+ oberon_get_char(ctx);
+ }
+
+ }
+
+ end_i = ctx -> code_index;
+ }
+
+ int len = end_i - start_i;
+ ident = malloc(len + 1);
+ memcpy(ident, &ctx -> code[start_i], len);
+ ident[len] = 0;
+
+ if(mode == 3)
+ {
+ int i = exp_i - start_i;
+ ident[i] = 'E';
+ }
+
+ switch(mode)
+ {
+ case 0:
+ integer = atol(ident);
+ real = integer;
+ ctx -> token = INTEGER;
+ break;
+ case 1:
+ sscanf(ident, "%lx", &integer);
+ real = integer;
+ ctx -> token = INTEGER;
+ break;
+ case 2:
+ case 3:
+ sscanf(ident, "%lf", &real);
+ ctx -> token = REAL;
+ break;
+ default:
+ oberon_error(ctx, "oberon_read_number: wat");
+ break;
+ }
- ctx -> code_index = i;
- ctx -> c = ctx -> code[i];
ctx -> string = ident;
- ctx -> integer = atoi(ident);
- ctx -> token = INTEGER;
+ ctx -> integer = integer;
+ ctx -> real = real;
}
static void
}
else if(isdigit(c))
{
- oberon_read_integer(ctx);
+ oberon_read_number(ctx);
}
else
{
@@ -665,7 +767,13 @@ oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t *
{
if(pref -> class != expr -> result -> class)
{
- oberon_error(ctx, "incompatible types");
+ if(pref -> class != OBERON_TYPE_PROCEDURE)
+ {
+ if(expr -> result -> class != OBERON_TYPE_POINTER)
+ {
+ oberon_error(ctx, "incompatible types");
+ }
+ }
}
if(pref -> class == OBERON_TYPE_INTEGER)
{
if(param -> class == OBERON_CLASS_VAR_PARAM)
{
- if(arg -> is_item)
+ if(arg -> read_only)
{
- switch(arg -> item.mode)
- {
- case MODE_VAR:
- case MODE_INDEX:
- case MODE_FIELD:
- // Допустимо разыменование?
- //case MODE_DEREF:
- break;
- default:
- oberon_error(ctx, "var-parameter accept only variables");
- break;
- }
+ oberon_error(ctx, "assign to read-only var");
}
+
+ //if(arg -> is_item)
+ //{
+ // switch(arg -> item.mode)
+ // {
+ // case MODE_VAR:
+ // case MODE_INDEX:
+ // case MODE_FIELD:
+ // // Допустимо разыменование?
+ // //case MODE_DEREF:
+ // break;
+ // default:
+ // oberon_error(ctx, "var-parameter accept only variables");
+ // break;
+ // }
+ //}
}
oberon_autocast_to(ctx, arg, param -> type);
arg = arg -> next;
expr -> item.integer = ctx -> integer;
oberon_assert_token(ctx, INTEGER);
break;
+ case REAL:
+ expr = oberon_new_item(MODE_REAL, ctx -> real_type, 1);
+ expr -> item.real = ctx -> real;
+ oberon_assert_token(ctx, REAL);
+ break;
case TRUE:
expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, 1);
expr -> item.boolean = 1;
@@ -1293,6 +1411,46 @@ oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_
oberon_error(ctx, "oberon_make_bin_op: bool wat");
}
}
+ else if(token == SLASH)
+ {
+ if(a -> result -> class != OBERON_TYPE_REAL)
+ {
+ if(a -> result -> class == OBERON_TYPE_INTEGER)
+ {
+ oberon_error(ctx, "TODO cast int -> real");
+ }
+ else
+ {
+ oberon_error(ctx, "operator / requires numeric type");
+ }
+ }
+
+ if(b -> result -> class != OBERON_TYPE_REAL)
+ {
+ if(b -> result -> class == OBERON_TYPE_INTEGER)
+ {
+ oberon_error(ctx, "TODO cast int -> real");
+ }
+ else
+ {
+ oberon_error(ctx, "operator / requires numeric type");
+ }
+ }
+
+ oberon_autocast_binary_op(ctx, a -> result, b -> result, &result);
+ expr = oberon_new_operator(OP_DIV, result, a, b);
+ }
+ else if(token == DIV)
+ {
+ if(a -> result -> class != OBERON_TYPE_INTEGER
+ || b -> result -> class != OBERON_TYPE_INTEGER)
+ {
+ oberon_error(ctx, "operator DIV requires integer type");
+ }
+
+ oberon_autocast_binary_op(ctx, a -> result, b -> result, &result);
+ expr = oberon_new_operator(OP_DIV, result, a, b);
+ }
else
{
oberon_autocast_binary_op(ctx, a -> result, b -> result, &result);
@@ -1309,14 +1467,6 @@ oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_
{
expr = oberon_new_operator(OP_MUL, result, a, b);
}
- else if(token == SLASH)
- {
- expr = oberon_new_operator(OP_DIV, result, a, b);
- }
- else if(token == DIV)
- {
- expr = oberon_new_operator(OP_DIV, result, a, b);
- }
else if(token == MOD)
{
expr = oberon_new_operator(OP_MOD, result, a, b);
ctx -> int_type = oberon_new_type_integer(sizeof(int));
oberon_define_type(ctx -> world_scope, "INTEGER", ctx -> int_type, 1);
- ctx -> bool_type = oberon_new_type_boolean(sizeof(int));
+ ctx -> bool_type = oberon_new_type_boolean(sizeof(bool));
oberon_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type, 1);
+
+ ctx -> real_type = oberon_new_type_real(sizeof(float));
+ oberon_define_type(ctx -> world_scope, "REAL", ctx -> real_type, 1);
}
static void
@@ -2564,6 +2717,71 @@ oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_
return expr;
}
+static void
+oberon_make_new_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 * dst;
+ dst = list_args;
+
+ oberon_type_t * type;
+ type = dst -> result;
+
+ if(type -> class != OBERON_TYPE_POINTER)
+ {
+ oberon_error(ctx, "not a pointer");
+ }
+
+ type = type -> base;
+
+ oberon_expr_t * src;
+ src = oberon_new_item(MODE_NEW, dst -> result, 0);
+ src -> item.num_args = 0;
+ src -> item.args = NULL;
+
+ if(type -> class == OBERON_TYPE_ARRAY)
+ {
+ // Пригодится при работе с открытыми массивами
+ /*
+ int dim = 1;
+ oberon_expr_t * sizes = NULL;
+ oberon_expr_t * last_size = NULL;
+ sizes = last_size = oberon_new_item(MODE_INTEGER, ctx -> int_type, 1);
+ sizes -> item.integer = type -> size;
+ oberon_type_t * base = type -> base;
+ while(base -> class == OBERON_TYPE_ARRAY)
+ {
+ oberon_expr_t * size;
+ size = last_size = oberon_new_item(MODE_INTEGER, ctx -> int_type, 1);
+ size -> item.integer = base -> size;
+
+ last_size -> next = size;
+ last_size = size;
+ base = base -> base;
+ dim += 1;
+ }
+ */
+
+ src -> item.num_args = 0;
+ src -> item.args = NULL;
+ }
+ else if(type -> class != OBERON_TYPE_RECORD)
+ {
+ oberon_error(ctx, "oberon_make_new_call: wat");
+ }
+
+ oberon_assign(ctx, src, dst);
+}
+
oberon_context_t *
oberon_create_context(ModuleImportCallback import_module)
{
register_default_types(ctx);
oberon_new_intrinsic(ctx, "ABS", oberon_make_abs_call, NULL);
+ oberon_new_intrinsic(ctx, "NEW", NULL, oberon_make_new_call);
return ctx;
}