diff --git a/src/oberon.c b/src/oberon.c
index b428ecf73f6bda15c85365a8d49a5dd6aafb45ad..a2a567036598a90f005bcc1780531e18e6d54701 100644 (file)
--- a/src/oberon.c
+++ b/src/oberon.c
#include <string.h>
#include <assert.h>
#include <stdbool.h>
+#include <math.h>
#include "../include/oberon.h"
IF,
THEN,
ELSE,
- ELSIF
+ ELSIF,
+ WHILE,
+ DO,
+ REPEAT,
+ UNTIL,
+ FOR,
+ BY,
+ LOOP,
+ EXIT
};
// =======================================================================
scope -> local = scope -> up -> local;
scope -> parent = scope -> up -> parent;
scope -> parent_type = scope -> up -> parent_type;
+ scope -> exit_label = scope -> up -> exit_label;
}
ctx -> decl = scope;
return result;
}
+static oberon_object_t *
+oberon_create_object(oberon_scope_t * scope, char * name, int class, bool export, bool read_only)
+{
+ oberon_object_t * newvar = malloc(sizeof *newvar);
+ memset(newvar, 0, sizeof *newvar);
+ newvar -> name = name;
+ newvar -> class = class;
+ newvar -> export = export;
+ newvar -> read_only = read_only;
+ newvar -> local = scope -> local;
+ newvar -> parent = scope -> parent;
+ newvar -> parent_type = scope -> parent_type;
+ newvar -> module = scope -> ctx -> mod;
+ return newvar;
+}
+
static oberon_object_t *
oberon_define_object(oberon_scope_t * scope, char * name, int class, bool export, bool read_only, bool check_upscope)
{
@@ -225,17 +251,8 @@ oberon_define_object(oberon_scope_t * scope, char * name, int class, bool export
oberon_error(scope -> ctx, "already defined");
}
- oberon_object_t * newvar = malloc(sizeof *newvar);
- memset(newvar, 0, sizeof *newvar);
- newvar -> name = name;
- newvar -> class = class;
- newvar -> export = export;
- newvar -> read_only = read_only;
- newvar -> local = scope -> local;
- newvar -> parent = scope -> parent;
- newvar -> parent_type = scope -> parent_type;
- newvar -> module = scope -> ctx -> mod;
-
+ oberon_object_t * newvar;
+ newvar = oberon_create_object(scope, name, class, export, read_only);
x -> next = newvar;
return newvar;
{
ctx -> token = ELSIF;
}
+ else if(strcmp(ident, "WHILE") == 0)
+ {
+ ctx -> token = WHILE;
+ }
+ else if(strcmp(ident, "DO") == 0)
+ {
+ ctx -> token = DO;
+ }
+ else if(strcmp(ident, "REPEAT") == 0)
+ {
+ ctx -> token = REPEAT;
+ }
+ else if(strcmp(ident, "UNTIL") == 0)
+ {
+ ctx -> token = UNTIL;
+ }
+ else if(strcmp(ident, "FOR") == 0)
+ {
+ ctx -> token = FOR;
+ }
+ else if(strcmp(ident, "BY") == 0)
+ {
+ ctx -> token = BY;
+ }
+ else if(strcmp(ident, "LOOP") == 0)
+ {
+ ctx -> token = LOOP;
+ }
+ else if(strcmp(ident, "EXIT") == 0)
+ {
+ ctx -> token = EXIT;
+ }
}
static void
@@ -963,6 +1012,42 @@ oberon_check_record_compatibility(oberon_context_t * ctx, oberon_type_t * from,
}
}
+static void
+oberon_check_dst(oberon_context_t * ctx, oberon_expr_t * dst)
+{
+ if(dst -> is_item == false)
+ {
+ oberon_error(ctx, "not variable");
+ }
+
+ switch(dst -> item.mode)
+ {
+ case MODE_VAR:
+ case MODE_CALL:
+ case MODE_INDEX:
+ case MODE_FIELD:
+ case MODE_DEREF:
+ case MODE_NEW:
+ /* accept */
+ break;
+ default:
+ oberon_error(ctx, "not variable");
+ break;
+ }
+}
+
+static void
+oberon_check_src(oberon_context_t * ctx, oberon_expr_t * src)
+{
+ if(src -> is_item)
+ {
+ if(src -> item.mode == MODE_TYPE)
+ {
+ oberon_error(ctx, "not variable");
+ }
+ }
+}
+
static oberon_expr_t *
oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref)
{
@@ -971,6 +1056,8 @@ oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t *
// Если INTEGER переводится в REAL
// Есди STRING переводится в ARRAY OF CHAR
+ oberon_check_src(ctx, expr);
+
bool error = false;
if(pref -> class != expr -> result -> class)
{
@@ -1180,58 +1267,6 @@ oberon_make_call_proc(oberon_context_t * ctx, oberon_item_t * item, int num_args
}
}
-/*
-static void
-oberon_make_call_proc(oberon_context_t * ctx, oberon_object_t * proc, int num_args, oberon_expr_t * list_args)
-{
- switch(proc -> class)
- {
- case OBERON_CLASS_PROC:
- if(proc -> class != OBERON_CLASS_PROC)
- {
- oberon_error(ctx, "not a procedure");
- }
- break;
- case OBERON_CLASS_VAR:
- case OBERON_CLASS_VAR_PARAM:
- case OBERON_CLASS_PARAM:
- if(proc -> type -> class != OBERON_TYPE_PROCEDURE)
- {
- oberon_error(ctx, "not a procedure");
- }
- break;
- default:
- oberon_error(ctx, "not a procedure");
- break;
- }
-
- if(proc -> sysproc)
- {
- if(proc -> genproc == NULL)
- {
- oberon_error(ctx, "requres non-typed procedure");
- }
-
- proc -> genproc(ctx, num_args, list_args);
- }
- else
- {
- if(proc -> type -> base -> class != OBERON_TYPE_VOID)
- {
- oberon_error(ctx, "attempt to call function as non-typed procedure");
- }
-
- oberon_expr_t * call;
- call = oberon_new_item(MODE_CALL, proc -> type -> base, 1);
- call -> item.var = proc;
- call -> item.num_args = num_args;
- call -> item.args = list_args;
- oberon_autocast_call(ctx, call);
- oberon_generate_call_proc(ctx, call);
- }
-}
-*/
-
#define ISEXPR(x) \
(((x) == PLUS) \
|| ((x) == MINUS) \
return x;
}
+static oberon_expr_t *
+oberon_ident_item(oberon_context_t * ctx, char * name)
+{
+ bool read_only;
+ oberon_object_t * x;
+ oberon_expr_t * expr;
+
+ x = oberon_find_object(ctx -> decl, name, true);
+
+ read_only = false;
+ if(x -> class == OBERON_CLASS_CONST || x -> class == OBERON_CLASS_PROC)
+ {
+ read_only = true;
+ }
+
+ expr = oberon_new_item(MODE_VAR, x -> type, read_only);
+ expr -> item.var = x;
+ return expr;
+}
+
static oberon_expr_t *
oberon_designator(oberon_context_t * ctx)
{
// TODO copy value
expr = (oberon_expr_t *) var -> value;
break;
+ case OBERON_CLASS_TYPE:
+ expr = oberon_new_item(MODE_TYPE, var -> type, read_only);
+ break;
case OBERON_CLASS_VAR:
case OBERON_CLASS_VAR_PARAM:
case OBERON_CLASS_PARAM:
expr = oberon_new_item(MODE_VAR, var -> type, read_only);
break;
case OBERON_CLASS_PROC:
- expr = oberon_new_item(MODE_VAR, var -> type, 1);
+ expr = oberon_new_item(MODE_VAR, var -> type, true);
break;
default:
oberon_error(ctx, "invalid designator");
}
}
+static oberon_expr_t *
+oberon_integer_item(oberon_context_t * ctx, int64_t i)
+{
+ oberon_expr_t * expr;
+ oberon_type_t * result;
+ result = oberon_get_type_of_int_value(ctx, i);
+ expr = oberon_new_item(MODE_INTEGER, result, true);
+ expr -> item.integer = i;
+ return expr;
+}
+
static oberon_expr_t *
oberon_factor(oberon_context_t * ctx)
{
expr = oberon_opt_func_parens(ctx, expr);
break;
case INTEGER:
- result = oberon_get_type_of_int_value(ctx, ctx -> integer);
- expr = oberon_new_item(MODE_INTEGER, result, true);
- expr -> item.integer = ctx -> integer;
+ expr = oberon_integer_item(ctx, ctx -> integer);
oberon_assert_token(ctx, INTEGER);
break;
case CHAR:
oberon_error(ctx, "const expression are required");
}
+ switch(expr -> item.mode)
+ {
+ case MODE_INTEGER:
+ case MODE_BOOLEAN:
+ case MODE_NIL:
+ case MODE_REAL:
+ case MODE_CHAR:
+ case MODE_STRING:
+ case MODE_TYPE:
+ /* accept */
+ break;
+ default:
+ oberon_error(ctx, "const expression are required");
+ break;
+ }
+
return (oberon_item_t *) expr;
}
oberon_prevent_undeclarated_procedures(ctx);
}
+static oberon_expr_t *
+oberon_make_temp_var_item(oberon_context_t * ctx, oberon_type_t * type)
+{
+ oberon_object_t * x;
+ oberon_expr_t * expr;
+
+ x = oberon_create_object(ctx -> decl, "TEMP", OBERON_CLASS_VAR, false, false);
+ x -> local = true;
+ x -> type = type;
+ oberon_generator_init_temp_var(ctx, x);
+
+ expr = oberon_new_item(MODE_VAR, type, false);
+ expr -> item.var = x;
+ return expr;
+}
+
static void
oberon_statement_seq(oberon_context_t * ctx);
@@ -2880,6 +2979,7 @@ oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst)
oberon_error(ctx, "read-only destination");
}
+ oberon_check_dst(ctx, dst);
src = oberon_autocast_to(ctx, src, dst -> result);
oberon_generate_assign(ctx, src, dst);
}
oberon_generate_label(ctx, end);
oberon_assert_token(ctx, END);
}
+ else if(ctx -> token == WHILE)
+ {
+ gen_label_t * begin;
+ gen_label_t * end;
+ oberon_expr_t * cond;
+
+ begin = oberon_generator_reserve_label(ctx);
+ end = oberon_generator_reserve_label(ctx);
+
+ oberon_assert_token(ctx, WHILE);
+ oberon_generate_label(ctx, begin);
+ cond = oberon_expr(ctx);
+ if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
+ {
+ oberon_error(ctx, "condition must be boolean");
+ }
+ oberon_generate_branch(ctx, cond, false, end);
+
+ oberon_assert_token(ctx, DO);
+ oberon_statement_seq(ctx);
+ oberon_generate_goto(ctx, begin);
+
+ oberon_assert_token(ctx, END);
+ oberon_generate_label(ctx, end);
+ }
+ else if(ctx -> token == REPEAT)
+ {
+ gen_label_t * begin;
+ oberon_expr_t * cond;
+
+ begin = oberon_generator_reserve_label(ctx);
+ oberon_generate_label(ctx, begin);
+ oberon_assert_token(ctx, REPEAT);
+
+ oberon_statement_seq(ctx);
+
+ oberon_assert_token(ctx, UNTIL);
+
+ cond = oberon_expr(ctx);
+ if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
+ {
+ oberon_error(ctx, "condition must be boolean");
+ }
+
+ oberon_generate_branch(ctx, cond, true, begin);
+ }
+ else if(ctx -> token == FOR)
+ {
+ oberon_expr_t * from;
+ oberon_expr_t * index;
+ oberon_expr_t * to;
+ oberon_expr_t * bound;
+ oberon_expr_t * by;
+ oberon_expr_t * cond;
+ oberon_expr_t * count;
+ gen_label_t * begin;
+ gen_label_t * end;
+ char * iname;
+ int op;
+
+ begin = oberon_generator_reserve_label(ctx);
+ end = oberon_generator_reserve_label(ctx);
+
+ oberon_assert_token(ctx, FOR);
+ iname = oberon_assert_ident(ctx);
+ index = oberon_ident_item(ctx, iname);
+ oberon_assert_token(ctx, ASSIGN);
+ from = oberon_expr(ctx);
+ oberon_assign(ctx, from, index);
+ oberon_assert_token(ctx, TO);
+ bound = oberon_make_temp_var_item(ctx, index -> result);
+ to = oberon_expr(ctx);
+ oberon_assign(ctx, to, bound);
+ if(ctx -> token == BY)
+ {
+ oberon_assert_token(ctx, BY);
+ by = (oberon_expr_t *) oberon_const_expr(ctx);
+ }
+ else
+ {
+ by = oberon_integer_item(ctx, 1);
+ }
+
+ if(by -> result -> class != OBERON_TYPE_INTEGER)
+ {
+ oberon_error(ctx, "must be integer");
+ }
+
+ if(by -> item.integer > 0)
+ {
+ op = LEQ;
+ }
+ else if(by -> item.integer < 0)
+ {
+ op = GEQ;
+ }
+ else
+ {
+ oberon_error(ctx, "zero step not allowed");
+ }
+
+ oberon_assert_token(ctx, DO);
+ oberon_generate_label(ctx, begin);
+ cond = oberon_make_bin_op(ctx, op, index, bound);
+ oberon_generate_branch(ctx, cond, false, end);
+ oberon_statement_seq(ctx);
+ count = oberon_make_bin_op(ctx, PLUS, index, by);
+ oberon_assign(ctx, count, index);
+ oberon_generate_goto(ctx, begin);
+ oberon_generate_label(ctx, end);
+ oberon_assert_token(ctx, END);
+ }
+ else if(ctx -> token == LOOP)
+ {
+ gen_label_t * begin;
+ gen_label_t * end;
+
+ begin = oberon_generator_reserve_label(ctx);
+ end = oberon_generator_reserve_label(ctx);
+
+ oberon_open_scope(ctx);
+ oberon_assert_token(ctx, LOOP);
+ oberon_generate_label(ctx, begin);
+ ctx -> decl -> exit_label = end;
+ oberon_statement_seq(ctx);
+ oberon_generate_goto(ctx, begin);
+ oberon_generate_label(ctx, end);
+ oberon_assert_token(ctx, END);
+ oberon_close_scope(ctx -> decl);
+ }
+ else if(ctx -> token == EXIT)
+ {
+ oberon_assert_token(ctx, EXIT);
+ if(ctx -> decl -> exit_label == NULL)
+ {
+ oberon_error(ctx, "not in LOOP-END");
+ }
+ oberon_generate_goto(ctx, ctx -> decl -> exit_label);
+ }
else if(ctx -> token == RETURN)
{
oberon_assert_token(ctx, RETURN);
@@ -3135,6 +3374,118 @@ oberon_new_intrinsic(oberon_context_t * ctx, char * name, GenerateFuncCallback f
proc -> type -> genproc = p;
}
+static oberon_expr_t *
+oberon_make_min_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;
+
+ if(!arg -> is_item || arg -> item.mode != MODE_TYPE)
+ {
+ oberon_error(ctx, "MIN accept only type");
+ }
+
+ oberon_expr_t * expr;
+ int bits = arg -> result -> size * 8;
+ switch(arg -> result -> class)
+ {
+ case OBERON_TYPE_INTEGER:
+ expr = oberon_integer_item(ctx, -powl(2, bits - 1));
+ break;
+ default:
+ oberon_error(ctx, "allowed only basic types");
+ break;
+ }
+
+ return expr;
+}
+
+static oberon_expr_t *
+oberon_make_max_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;
+
+ if(!arg -> is_item || arg -> item.mode != MODE_TYPE)
+ {
+ oberon_error(ctx, "MAX accept only type");
+ }
+
+ oberon_expr_t * expr;
+ int bits = arg -> result -> size * 8;
+ switch(arg -> result -> class)
+ {
+ case OBERON_TYPE_INTEGER:
+ expr = oberon_integer_item(ctx, powl(2, bits - 1) - 1);
+ break;
+ default:
+ oberon_error(ctx, "allowed only basic types");
+ break;
+ }
+
+ return expr;
+}
+
+static oberon_expr_t *
+oberon_make_size_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;
+
+ if(!arg -> is_item || arg -> item.mode != MODE_TYPE)
+ {
+ oberon_error(ctx, "SIZE accept only type");
+ }
+
+ int size;
+ oberon_expr_t * expr;
+ oberon_type_t * type = arg -> result;
+ switch(type -> class)
+ {
+ case OBERON_TYPE_INTEGER:
+ case OBERON_TYPE_BOOLEAN:
+ case OBERON_TYPE_REAL:
+ size = type -> size;
+ break;
+ default:
+ oberon_error(ctx, "TODO SIZE");
+ break;
+ }
+
+ expr = oberon_integer_item(ctx, size);
+ return expr;
+}
+
static oberon_expr_t *
oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
{
@@ -3159,7 +3510,6 @@ oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_
oberon_error(ctx, "ABS accepts only integers");
}
-
oberon_expr_t * expr;
expr = oberon_new_operator(OP_ABS, result_type, arg, NULL);
return expr;
oberon_generator_init_context(ctx);
register_default_types(ctx);
+
+ /* Functions */
oberon_new_intrinsic(ctx, "ABS", oberon_make_abs_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, "SIZE", oberon_make_size_call, NULL);
+
+ /* Procedures */
oberon_new_intrinsic(ctx, "NEW", NULL, oberon_make_new_call);
return ctx;