Исправлено чтение и запсь в Files, Texts портирован из voc, добавлены типы SYSTEM...

[dsw-obn.git] / src / oberon.c

#include <stdio.h>
#include <stdlib.h>
#include <stdarg.h>
#include <ctype.h>
#include <string.h>
#include <assert.h>
#include <stdbool.h>
#include <math.h>
#include <float.h>

#include <gc.h>

#include "oberon-internals.h"
#include "oberon-type-compat.h"
#include "oberon-common.h"
#include "generator.h"

// =======================================================================
//   UTILS
// ======================================================================= 

static void
oberon_make_copy_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args);

static oberon_type_t *
oberon_new_type_ptr(int class)
{
        oberon_type_t * x = GC_MALLOC(sizeof *x);
        memset(x, 0, sizeof *x);
        x -> class = class;
        return x;
}

static oberon_type_t *
oberon_new_type_integer(int size)
{
        oberon_type_t * x;
        x = oberon_new_type_ptr(OBERON_TYPE_INTEGER);
        x -> size = size;
        return x;
}

static oberon_type_t *
oberon_new_type_boolean()
{
        oberon_type_t * x;
        x = oberon_new_type_ptr(OBERON_TYPE_BOOLEAN);
        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;
}

static oberon_type_t *
oberon_new_type_char(int size)
{
        oberon_type_t * x;
        x = oberon_new_type_ptr(OBERON_TYPE_CHAR);
        x -> size = size;
        return x;
}

static oberon_type_t *
oberon_new_type_string(int size)
{
        oberon_type_t * x;
        x = oberon_new_type_ptr(OBERON_TYPE_STRING);
        x -> size = size;
        return x;
}

static oberon_type_t *
oberon_new_type_set(int size)
{
        oberon_type_t * x;
        x = oberon_new_type_ptr(OBERON_TYPE_SET);
        x -> size = size;
        return x;
}

static oberon_expr_t *
oberon_new_operator(int op, oberon_type_t * result, oberon_expr_t * left, oberon_expr_t * right)
{
        oberon_oper_t * operator;
        operator = GC_MALLOC(sizeof *operator);
        memset(operator, 0, sizeof *operator);

        operator -> is_item = 0;
        operator -> result = result;
        operator -> read_only = 1;
        operator -> op = op;
        operator -> left = left;
        operator -> right = right;

        return (oberon_expr_t *) operator;
}

static oberon_expr_t *
oberon_new_item(int mode, oberon_type_t * result, int read_only)
{
        oberon_item_t * item;
        item = GC_MALLOC(sizeof *item);
        memset(item, 0, sizeof *item);

        item -> is_item = 1;
        item -> result = result;
        item -> read_only = read_only;
        item -> mode = mode;

        return (oberon_expr_t *)item;
}

static oberon_type_t *
oberon_get_type_of_int_value(oberon_context_t * ctx, int64_t i)
{
        if(i >= -128 && i <= 127)
        {
                return ctx -> byte_type;
        }
        else if(i >= -32768 && i <= 32767)
        {
                return ctx -> shortint_type;
        }
        else if(i >= -2147483648 && i <= 2147483647)
        {
                 return ctx -> int_type;
        }
        else
        {
                return ctx -> longint_type;
        }
}

static oberon_expr_t *
oberon_make_integer(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;
        expr -> item.real = i;
        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)
{
        oberon_expr_t * expr;
        expr = oberon_new_item(MODE_CHAR, ctx -> char_type, true);
        expr -> item.integer = i;
        expr -> item.real = i;
        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)
{
        oberon_expr_t * expr;
        expr = oberon_new_item(MODE_REAL, result, true);
        expr -> item.integer = r;
        expr -> item.real = r;
        return expr;
}

static oberon_expr_t *
oberon_make_real(oberon_context_t * ctx, double r, bool longmode)
{
        oberon_type_t * result;
        result = (longmode) ? (ctx -> longreal_type) : (ctx -> real_type);
        return oberon_make_real_typed(ctx, r, result);
}

static oberon_expr_t *
oberon_make_boolean(oberon_context_t * ctx, bool cond)
{
        oberon_expr_t * expr;
        expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, true);
        expr -> item.integer = cond;
        expr -> item.real = cond;
        return expr;
}

static oberon_expr_t *
oberon_make_set(oberon_context_t * ctx, int64_t i)
{
        oberon_expr_t * expr;
        expr = oberon_new_item(MODE_SET, ctx -> set_type, true);
        expr -> item.integer = i;
        expr -> item.real = i;
        return expr;
}

static oberon_expr_t *
oberon_make_set_index(oberon_context_t * ctx, int64_t i)
{
        oberon_expr_t * expr;
        expr = oberon_new_item(MODE_SET, ctx -> set_type, true);
        expr -> item.integer = 1 << i;
        expr -> item.real = 1 << i;
        return expr;
}

static oberon_expr_t *
oberon_make_set_range(oberon_context_t * ctx, int64_t x, int64_t y)
{
        oberon_expr_t * expr;
        expr = oberon_new_item(MODE_SET, ctx -> set_type, true);
        expr -> item.integer = (x <= y) ? ((2 << y) - (1 << x)) : (0);
        expr -> item.real = expr -> item.integer;
        return expr;
}

// =======================================================================
//   TABLE
// ======================================================================= 

static oberon_scope_t *
oberon_open_scope(oberon_context_t * ctx)
{
        oberon_scope_t * scope = GC_MALLOC(sizeof *scope);
        memset(scope, 0, sizeof *scope);

        oberon_object_t * list = GC_MALLOC(sizeof *list);
        memset(list, 0, sizeof *list);

        scope -> ctx = ctx;
        scope -> list = list;
        scope -> up = ctx -> decl;

        if(scope -> up)
        {
                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 scope;
}

static void
oberon_close_scope(oberon_scope_t * scope)
{
        oberon_context_t * ctx = scope -> ctx;
        ctx -> decl = scope -> up;
}

static oberon_object_t *
oberon_find_object_in_list(oberon_object_t * list, char * name)
{
        oberon_object_t * x = list;
        while(x -> next && strcmp(x -> next -> name, name) != 0)
        {
                x = x -> next;
        }
        return x -> next;
}

static oberon_object_t *
oberon_find_object(oberon_scope_t * scope, char * name, bool check_it)
{
        oberon_object_t * result = NULL;

        oberon_scope_t * s = scope;
        while(result == NULL && s != NULL)
        {
                result = oberon_find_object_in_list(s -> list, name);
                s = s -> up;
        }

        if(check_it && result == NULL)
        {
                oberon_error(scope -> ctx, "undefined ident %s", name);
        }

        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 = GC_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)
{
        if(check_upscope)
        {
                if(oberon_find_object(scope -> up, name, false))
                {
                        oberon_error(scope -> ctx, "already defined");
                }
        }

        oberon_object_t * x = scope -> list;
        while(x -> next && strcmp(x -> next -> name, name) != 0)
        {
                x = x -> next;
        }

        if(x -> next)
        {
                oberon_error(scope -> ctx, "already defined");
        }

        oberon_object_t * newvar;
        newvar = oberon_create_object(scope, name, class, export, read_only);
        x -> next = newvar;

        return newvar;
}

// =======================================================================
//   SCANER
// ======================================================================= 

static void
oberon_get_char(oberon_context_t * ctx)
{
        if(ctx -> code[ctx -> code_index])
        {
                ctx -> code_index += 1;
                ctx -> xloc.col += 1;
                ctx -> c = ctx -> code[ctx -> code_index];
        }
}

static void
oberon_init_scaner(oberon_context_t * ctx, oberon_scanner_t * s)
{
        ctx -> code = s -> code;
        ctx -> code_index = 0;
        ctx -> xloc.source = s -> source;
        ctx -> xloc.line = 1;
        ctx -> xloc.col = 1;
        ctx -> loc = ctx -> xloc;
        ctx -> c = ctx -> code[ctx -> code_index];
}

static void
oberon_read_ident(oberon_context_t * ctx)
{
        int start = ctx -> code_index;

        oberon_get_char(ctx);
        while(isalnum(ctx -> c) || ctx -> c == '_')
        {
                oberon_get_char(ctx);
        }

        int end = ctx -> code_index;

        char * ident = GC_MALLOC(end - start + 1);
        memcpy(ident, &ctx -> code[start], end - start);
        ident[end - start] = 0;

        ctx -> string = ident;
        ctx -> token = IDENT;

        if(strcmp(ident, "MODULE") == 0)
        {
                ctx -> token = MODULE;
        }
        else if(strcmp(ident, "END") == 0)
        {
                ctx -> token = END;
        }
        else if(strcmp(ident, "VAR") == 0)
        {
                ctx -> token = VAR;
        }
        else if(strcmp(ident, "BEGIN") == 0)
        {
                ctx -> token = BEGIN;
        }
        else if(strcmp(ident, "OR") == 0)
        {
                ctx -> token = OR;
        }
        else if(strcmp(ident, "DIV") == 0)
        {
                ctx -> token = DIV;
        }
        else if(strcmp(ident, "MOD") == 0)
        {
                ctx -> token = MOD;
        }
        else if(strcmp(ident, "PROCEDURE") == 0)
        {
                ctx -> token = PROCEDURE;
        }
        else if(strcmp(ident, "RETURN") == 0)
        {
                ctx -> token = RETURN;
        }
        else if(strcmp(ident, "CONST") == 0)
        {
                ctx -> token = CONST;
        }
        else if(strcmp(ident, "TYPE") == 0)
        {
                ctx -> token = TYPE;
        }
        else if(strcmp(ident, "ARRAY") == 0)
        {
                ctx -> token = ARRAY;
        }
        else if(strcmp(ident, "OF") == 0)
        {
                ctx -> token = OF;
        }
        else if(strcmp(ident, "RECORD") == 0)
        {
                ctx -> token = RECORD;
        }
        else if(strcmp(ident, "POINTER") == 0)
        {
                ctx -> token = POINTER;
        }
        else if(strcmp(ident, "TO") == 0)
        {
                ctx -> token = TO;
        }
        else if(strcmp(ident, "NIL") == 0)
        {
                ctx -> token = NIL;
        }
        else if(strcmp(ident, "IMPORT") == 0)
        {
                ctx -> token = IMPORT;
        }
        else if(strcmp(ident, "IN") == 0)
        {
                ctx -> token = IN;
        }
        else if(strcmp(ident, "IS") == 0)
        {
                ctx -> token = IS;
        }
        else if(strcmp(ident, "IF") == 0)
        {
                ctx -> token = IF;
        }
        else if(strcmp(ident, "THEN") == 0)
        {
                ctx -> token = THEN;
        }
        else if(strcmp(ident, "ELSE") == 0)
        {
                ctx -> token = ELSE;
        }
        else if(strcmp(ident, "ELSIF") == 0)
        {
                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;
        }
        else if(strcmp(ident, "CASE") == 0)
        {
                ctx -> token = CASE;
        }
        else if(strcmp(ident, "WITH") == 0)
        {
                ctx -> token = WITH;
        }
}

#define ISHEXDIGIT(x) \
        (((x) >= '0' && (x) <= '9') || ((x) >= 'A' && (x) <= 'F'))

static void
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
         * mode = 4 == CHAR
         */
        int mode = 0;
        start_i = ctx -> code_index;

        while(isdigit(ctx -> c))
        {
                oberon_get_char(ctx);
        }

        end_i = ctx -> code_index;

        if(ISHEXDIGIT(ctx -> c))
        {
                mode = 1;
                while(ISHEXDIGIT(ctx -> c))
                {
                        oberon_get_char(ctx);
                }

                end_i = ctx -> code_index;

                if(ctx -> c == 'H')
                {
                        mode = 1;
                        oberon_get_char(ctx);
                }
                else if(ctx -> c == 'X')
                {
                        mode = 4;
                        oberon_get_char(ctx);
                }
                else
                {
                        oberon_error(ctx, "invalid hex number");
                }
        }
        else if(ctx -> c == '.')
        {
                oberon_get_char(ctx);
                if(ctx -> c == '.')
                {
                        /* Чит: избегаем конфликта с DOTDOT */
                        ctx -> code_index -= 1;
                }
                else
                {
                        mode = 2;

                        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;
        }

        if(mode == 0)
        {
                if(ctx -> c == 'H')
                {
                        mode = 1;
                        oberon_get_char(ctx);
                }
                else if(ctx -> c == 'X')
                {
                        mode = 4;
                        oberon_get_char(ctx);
                }
        }

        int len = end_i - start_i;
        ident = GC_MALLOC(len + 1);
        memcpy(ident, &ctx -> code[start_i], len);
        ident[len] = 0;

        ctx -> longmode = false;
        if(mode == 3)
        {
                int i = exp_i - start_i;
                ident[i] = 'E';
                ctx -> longmode = true;
        }

        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);
                        integer = real;
                        ctx -> token = REAL;
                        break;
                case 4:
                        sscanf(ident, "%lx", &integer);
                        real = integer;
                        ctx -> token = CHAR;
                        break;
                default:
                        oberon_error(ctx, "oberon_read_number: wat");
                        break;
        }

        ctx -> string = ident;
        ctx -> integer = integer;
        ctx -> real = real;
}

static void
oberon_get_lined_char(oberon_context_t * ctx)
{
        do
        {
                if(ctx -> c == 0xD)
                {
                        oberon_get_char(ctx);
                        if(ctx -> c == 0xA)
                        {
                                oberon_get_char(ctx);
                        }
                        ctx -> xloc.line += 1;
                        ctx -> xloc.col = 1;
                }
                else if(ctx -> c == 0xA)
                {
                        oberon_get_char(ctx);
                        ctx -> xloc.line += 1;
                        ctx -> xloc.col = 1;
                }
                else
                {
                        oberon_get_char(ctx);
                }
        } while(ctx -> c == 0xD || ctx -> c == 0xA);
}

static void
oberon_skip_space(oberon_context_t * ctx)
{
        while(isspace(ctx -> c))
        {
                oberon_get_lined_char(ctx);
        }
}

static void
oberon_read_comment(oberon_context_t * ctx)
{
        int nesting = 1;
        while(nesting >= 1)
        {
                if(ctx -> c == '(')
                {
                        oberon_get_lined_char(ctx);
                        if(ctx -> c == '*')
                        {
                                oberon_get_lined_char(ctx);
                                nesting += 1;
                        }
                }
                else if(ctx -> c == '*')
                {
                        oberon_get_lined_char(ctx);
                        if(ctx -> c == ')')
                        {
                                oberon_get_lined_char(ctx);
                                nesting -= 1;
                        }
                }
                else if(ctx -> c == 0)
                {
                        oberon_error(ctx, "unterminated comment");
                }
                else
                {
                        oberon_get_lined_char(ctx);
                }
        }
}

static void oberon_read_string(oberon_context_t * ctx)
{
        int c = ctx -> c;
        oberon_get_char(ctx);

        int start = ctx -> code_index;

        while(ctx -> c != 0 && ctx -> c != c)
        {
                oberon_get_char(ctx);
        }

        if(ctx -> c == 0)
        {
                oberon_error(ctx, "unterminated string");
        }

        int end = ctx -> code_index;

        oberon_get_char(ctx);

        char * string = GC_MALLOC(end - start + 1);
        strncpy(string, &ctx -> code[start], end - start);
        string[end - start] = 0;

        ctx -> token = STRING;
        ctx -> string = string;
        ctx -> integer = string[0];
}

static void oberon_read_token(oberon_context_t * ctx);

static void
oberon_read_symbol(oberon_context_t * ctx)
{
        int c = ctx -> c;
        switch(c)
        {
                case 0:
                        ctx -> token = EOF_;
                        break;
                case ';':
                        ctx -> token = SEMICOLON;
                        oberon_get_char(ctx);
                        break;
                case ':':
                        ctx -> token = COLON;
                        oberon_get_char(ctx);
                        if(ctx -> c == '=')
                        {
                                ctx -> token = ASSIGN;
                                oberon_get_char(ctx);
                        }
                        break;
                case '.':
                        ctx -> token = DOT;
                        oberon_get_char(ctx);
                        if(ctx -> c == '.')
                        {
                                ctx -> token = DOTDOT;
                                oberon_get_char(ctx);
                        }
                        break;
                case '(':
                        ctx -> token = LPAREN;
                        oberon_get_char(ctx);
                        if(ctx -> c == '*')
                        {
                                oberon_get_char(ctx);
                                oberon_read_comment(ctx);
                                oberon_read_token(ctx);
                        }
                        break;
                case ')':
                        ctx -> token = RPAREN;
                        oberon_get_char(ctx);
                        break;
                case '=':
                        ctx -> token = EQUAL;
                        oberon_get_char(ctx);
                        break;
                case '#':
                        ctx -> token = NEQ;
                        oberon_get_char(ctx);
                        break;
                case '<':
                        ctx -> token = LESS;
                        oberon_get_char(ctx);
                        if(ctx -> c == '=')
                        {
                                ctx -> token = LEQ;
                                oberon_get_char(ctx);
                        }
                        break;
                case '>':
                        ctx -> token = GREAT;
                        oberon_get_char(ctx);
                        if(ctx -> c == '=')
                        {
                                ctx -> token = GEQ;
                                oberon_get_char(ctx);
                        }
                        break;
                case '+':
                        ctx -> token = PLUS;
                        oberon_get_char(ctx);
                        break;
                case '-':
                        ctx -> token = MINUS;
                        oberon_get_char(ctx);
                        break;
                case '*':
                        ctx -> token = STAR;
                        oberon_get_char(ctx);
                        if(ctx -> c == ')')
                        {
                                oberon_get_char(ctx);
                                oberon_error(ctx, "unstarted comment");
                        }
                        break;
                case '/':
                        ctx -> token = SLASH;
                        oberon_get_char(ctx);
                        break;
                case '&':
                        ctx -> token = AND;
                        oberon_get_char(ctx);
                        break;
                case '~':
                        ctx -> token = NOT;
                        oberon_get_char(ctx);
                        break;
                case ',':
                        ctx -> token = COMMA;
                        oberon_get_char(ctx);
                        break;
                case '[':
                        ctx -> token = LBRACK;
                        oberon_get_char(ctx);
                        break;
                case ']':
                        ctx -> token = RBRACK;
                        oberon_get_char(ctx);
                        break;
                case '^':
                        ctx -> token = UPARROW;
                        oberon_get_char(ctx);
                        break;
                case '"':
                        oberon_read_string(ctx);
                        break;
                case '\'':
                        oberon_read_string(ctx);
                        break;                  
                case '{':
                        ctx -> token = LBRACE;
                        oberon_get_char(ctx);
                        break;
                case '}':
                        ctx -> token = RBRACE;
                        oberon_get_char(ctx);
                        break;
                case '|':
                        ctx -> token = BAR;
                        oberon_get_char(ctx);
                        break;
                default:
                        oberon_error(ctx, "invalid char %c", ctx -> c);
                        break;
        }
}

static void
oberon_read_token(oberon_context_t * ctx)
{
        oberon_skip_space(ctx);

        ctx -> loc = ctx -> xloc;

        int c = ctx -> c;
        if(isalpha(c) || c == '_')
        {
                oberon_read_ident(ctx);
        }
        else if(isdigit(c))
        {
                oberon_read_number(ctx);
        }
        else
        {
                oberon_read_symbol(ctx);
        }
}

// =======================================================================
//   EXPRESSION
// =======================================================================

static void oberon_expect_token(oberon_context_t * ctx, int token);
static oberon_expr_t * oberon_expr(oberon_context_t * ctx);
static void oberon_assert_token(oberon_context_t * ctx, int token);
static char * oberon_assert_ident(oberon_context_t * ctx);
static void oberon_type(oberon_context_t * ctx, oberon_type_t ** type);
static oberon_item_t * oberon_const_expr(oberon_context_t * ctx);
static oberon_expr_t * oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr);
static bool oberon_is_const(oberon_expr_t * expr);

static oberon_expr_t *
oberon_make_unary_op(oberon_context_t * ctx, int token, oberon_expr_t * a)
{
        oberon_expr_t * expr;
        oberon_type_t * result;

        result = a -> result;

        if(token == MINUS)
        {
                if(result -> class == OBERON_TYPE_SET)
                {
                        if(oberon_is_const(a))
                        {
                                expr = oberon_make_set(ctx, ~(a -> item.integer));
                        }
                        else
                        {
                                expr = oberon_new_operator(OP_COMPLEMENTATION, result, a, NULL);
                        }
                }
                else if(result -> class == OBERON_TYPE_INTEGER)
                {
                        if(oberon_is_const(a))
                        {
                                expr = oberon_make_integer(ctx, -(a -> item.integer));
                        }
                        else
                        {
                                expr = oberon_new_operator(OP_UNARY_MINUS, result, a, NULL);
                        }
                }
                else if(result -> class == OBERON_TYPE_REAL)
                {
                        if(oberon_is_const(a))
                        {
                                expr = oberon_make_real_typed(ctx, -(a -> item.real), result);
                        }
                        else
                        {
                                expr = oberon_new_operator(OP_UNARY_MINUS, result, a, NULL);
                        }
                }
                else
                {
                        oberon_error(ctx, "incompatible operator type");
                }
        }
        else if(token == NOT)
        {
                if(result -> class != OBERON_TYPE_BOOLEAN)
                {
                        oberon_error(ctx, "incompatible operator type");
                }

                        if(oberon_is_const(a))
                        {
                                expr = oberon_make_boolean(ctx, !(a -> item.integer));
                        }
                        else
                        {
                                expr = oberon_new_operator(OP_LOGIC_NOT, result, a, NULL);
                        }
        }
        else
        {
                oberon_error(ctx, "oberon_make_unary_op: wat");
        }

        return expr;
}

static void
oberon_expr_list(oberon_context_t * ctx, int * num_expr, oberon_expr_t ** first, int const_expr)
{
        oberon_expr_t * last;

        *num_expr = 1;
        if(const_expr)
        {
                *first = last = (oberon_expr_t *) oberon_const_expr(ctx);
        }
        else
        {
                *first = last = oberon_expr(ctx);
        }
        while(ctx -> token == COMMA)
        {
                oberon_assert_token(ctx, COMMA);
                oberon_expr_t * current;

                if(const_expr)
                {
                        current = (oberon_expr_t *) oberon_const_expr(ctx);
                }
                else
                {
                        current = oberon_expr(ctx);
                }

                last -> next = current;
                last = current;
                *num_expr += 1;
        }
}

static oberon_expr_t *
oberon_cast_expr(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref)
{
        oberon_expr_t * cast;

        if((oberon_is_char_type(pref) && oberon_is_const_string(expr) && strlen(expr -> item.string) == 1))
        {
                /* Автоматически преобразуем строку единичного размера в символ */
                cast = oberon_new_item(MODE_CHAR, ctx -> char_type, true);
                cast -> item.integer = expr -> item.string[0];
        }
        else if(oberon_is_record_type(pref) || oberon_is_pointer_to_record(pref))
        {
                assert(expr -> is_item);
                cast = oberon_new_item(MODE_AS, pref, expr -> read_only);
                cast -> item.parent = (oberon_item_t *) expr;
        }
        else if(!oberon_is_some_types(expr -> result, pref))
        {
                cast = oberon_new_operator(OP_CAST, pref, expr, NULL);
        }
        else
        {
                cast = expr;
        }

        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)
{
        if(dst -> read_only)
        {
                oberon_error(ctx, "read-only destination");
        }

        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 void
oberon_autocast_call(oberon_context_t * ctx, oberon_item_t * desig)
{
        if(desig -> mode != MODE_CALL)
        {
                oberon_error(ctx, "expected mode CALL");
        }

        oberon_type_t * fn = desig -> parent -> result;
        int num_args = desig -> num_args;
        int num_decl = fn -> num_decl;

        if(num_args < num_decl)
        {
                oberon_error(ctx, "too few arguments");
        }
        else if(num_args > num_decl)
        {
                oberon_error(ctx, "too many arguments");
        }

        /* Делаем проверку на запись и делаем автокаст */
        oberon_expr_t * casted[num_args];
        oberon_expr_t * arg = desig -> args;
        oberon_object_t * param = fn -> decl;
        for(int i = 0; i < num_args; i++)
        {
                if(param -> class == OBERON_CLASS_VAR_PARAM)
                {
                        oberon_check_dst(ctx, arg);
                        if(!oberon_is_compatible_arrays(param, arg))
                        {
                                oberon_check_compatible_var_param(ctx, param -> type, arg -> result);
                        }
                        casted[i] = arg;
                        //casted[i] = oberon_cast_expr(ctx, arg, param -> type);
                }
                else
                {
                        oberon_check_src(ctx, arg);
                        if(!oberon_is_compatible_arrays(param, arg))
                        {
                                oberon_check_assignment_compatible(ctx, arg, param -> type);
                        }
                        casted[i] = oberon_cast_expr(ctx, arg, param -> type);
                }

                arg = arg -> next;
                param = param -> next;
        }

        /* Создаём новый список выражений */
        if(num_args > 0)
        {
                arg = casted[0];
                for(int i = 0; i < num_args - 1; i++)
                {
                        casted[i] -> next = casted[i + 1];
                }
                desig -> args = arg;
        }
}

static oberon_expr_t *
oberon_make_call_func(oberon_context_t * ctx, oberon_item_t * item, int num_args, oberon_expr_t * list_args)
{
        oberon_type_t * signature = item -> result;
        if(signature -> class != OBERON_TYPE_PROCEDURE)
        {
                oberon_error(ctx, "not a procedure");
        }

        oberon_expr_t * call;

        if(signature -> sysproc)
        {
                if(signature -> genfunc == NULL)
                {
                        oberon_error(ctx, "not a function-procedure");
                }

                call = signature -> genfunc(ctx, num_args, list_args);
        }
        else
        {
                if(signature -> base -> class == OBERON_TYPE_NOTYPE)
                {
                        oberon_error(ctx, "attempt to call procedure in expression");
                }

                call = oberon_new_item(MODE_CALL, signature -> base, true);
                call -> item.parent = item;
                call -> item.num_args = num_args;
                call -> item.args = list_args;
                oberon_autocast_call(ctx, (oberon_item_t *) call);
        }

        return call;
}

static void
oberon_make_call_proc(oberon_context_t * ctx, oberon_item_t * item, int num_args, oberon_expr_t * list_args)
{
        oberon_type_t * signature = item -> result;
        if(signature -> class != OBERON_TYPE_PROCEDURE)
        {
                oberon_error(ctx, "not a procedure");
        }

        oberon_expr_t * call;

        if(signature -> sysproc)
        {
                if(signature -> genproc == NULL)
                {
                        oberon_error(ctx, "not a procedure");
                }

                signature -> genproc(ctx, num_args, list_args);
        }
        else
        {
                if(signature -> base -> class != OBERON_TYPE_NOTYPE)
                {
                        oberon_error(ctx, "attempt to call function as non-typed procedure");
                }

                call = oberon_new_item(MODE_CALL, signature -> base, true);
                call -> item.parent = item;
                call -> item.num_args = num_args;
                call -> item.args = list_args;
                oberon_autocast_call(ctx, (oberon_item_t *) call);
                oberon_generate_call_proc(ctx, call);
        }
}

#define ISEXPR(x) \
        (((x) == PLUS) \
        || ((x) == MINUS) \
        || ((x) == IDENT) \
        || ((x) == INTEGER) \
        || ((x) == REAL) \
        || ((x) == CHAR) \
        || ((x) == STRING) \
        || ((x) == NIL) \
        || ((x) == LBRACE) \
        || ((x) == LPAREN) \
        || ((x) == NOT))

static oberon_expr_t *
oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr)
{
        if(expr -> result -> class != OBERON_TYPE_POINTER)
        {
                oberon_error(ctx, "not a pointer");
        }

        assert(expr -> is_item);

        oberon_expr_t * selector;
        selector = oberon_new_item(MODE_DEREF, expr -> result -> base, false);
        selector -> item.parent = (oberon_item_t *) expr;

        return selector;
}

static oberon_expr_t *
oberon_make_array_selector(oberon_context_t * ctx, oberon_expr_t * desig, oberon_expr_t * index)
{
        if(desig -> result -> class == OBERON_TYPE_POINTER)
        {
                desig = oberno_make_dereferencing(ctx, desig);
        }

        assert(desig -> is_item);

        if(desig -> result -> class != OBERON_TYPE_ARRAY)
        {
                oberon_error(ctx, "not array");
        }

        oberon_type_t * base;
        base = desig -> result -> base;

        if(index -> result -> class != OBERON_TYPE_INTEGER)
        {
                oberon_error(ctx, "index must be integer");
        }

        // Статическая проверка границ массива
        if(desig -> result -> size != 0)
        {
                if(index -> is_item)
                {
                        if(index -> item.mode == MODE_INTEGER)
                        {
                                int arr_size = desig -> result -> size;
                                int index_int = index -> item.integer;
                                if(index_int < 0 || index_int > arr_size - 1)
                                {
                                        oberon_error(ctx, "not in range (dimension size 0..%i)", arr_size - 1);
                                }
                        }
                }
        }

        oberon_expr_t * selector;
        selector = oberon_new_item(MODE_INDEX, base, desig -> read_only);
        selector -> item.parent = (oberon_item_t *) desig;
        selector -> item.num_args = 1;
        selector -> item.args = index;

        return selector;
}

static oberon_expr_t *
oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char * name)
{
        if(expr -> result -> class == OBERON_TYPE_POINTER)
        {
                expr = oberno_make_dereferencing(ctx, expr);
        }

        assert(expr -> is_item);

        if(expr -> result -> class != OBERON_TYPE_RECORD)
        {
                oberon_error(ctx, "not record");
        }

        oberon_type_t * rec = expr -> result;

        oberon_object_t * field;
        field = oberon_find_object(rec -> scope, name, true);

        if(field -> export == 0)
        {
                if(field -> module != ctx -> mod)
                {
                        oberon_error(ctx, "field not exported");
                }
        }

        int read_only = expr -> read_only;
        if(field -> read_only)
        {
                if(field -> module != ctx -> mod)
                {
                        read_only = 1;
                }
        }

        oberon_expr_t * selector;
        selector = oberon_new_item(MODE_FIELD, field -> type, read_only);
        selector -> item.var = field;
        selector -> item.parent = (oberon_item_t *) expr;

        return selector;
}

#define ISSELECTOR(x) \
        (((x) == LBRACK) \
        || ((x) == DOT) \
        || ((x) == UPARROW) \
        || ((x) == LPAREN))

static oberon_object_t *
oberon_qualident(oberon_context_t * ctx, char ** xname, int check)
{
        char * name;
        oberon_object_t * x;

        name = oberon_assert_ident(ctx);
        x = oberon_find_object(ctx -> decl, name, check);

        if(x != NULL)
        {
                if(x -> class == OBERON_CLASS_MODULE)
                {
                        oberon_assert_token(ctx, DOT);
                        name = oberon_assert_ident(ctx);
                        /* Наличие объектов в левых модулях всегда проверяется */
                        x = oberon_find_object(x -> module -> decl, name, 1);

                        if(x -> export == 0)
                        {
                                oberon_error(ctx, "not exported");
                        }
                }
        }

        if(xname)
        {
                *xname = name;
        }

        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_qualident_expr(oberon_context_t * ctx)
{
        oberon_object_t * var;
        oberon_expr_t * expr;

        var = oberon_qualident(ctx, NULL, 1);

        int read_only = 0;
        if(var -> read_only)
        {
                if(var -> module != ctx -> mod)
                {
                        read_only = 1;
                }
        }

        switch(var -> class)
        {
                case OBERON_CLASS_CONST:
                        // 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, true);
                        break;
                default:
                        oberon_error(ctx, "invalid designator");
                        break;
        }

        expr -> item.var = var;

        return expr;
}

static oberon_expr_t *
oberon_designator(oberon_context_t * ctx)
{
        char * name;
        oberon_expr_t * expr;
        oberon_object_t * objtype;

        expr = oberon_qualident_expr(ctx);

        while(expr -> result -> class != OBERON_TYPE_PROCEDURE && ISSELECTOR(ctx -> token))
        {
                switch(ctx -> token)
                {
                        case DOT:
                                oberon_assert_token(ctx, DOT);
                                name = oberon_assert_ident(ctx);
                                expr = oberon_make_record_selector(ctx, expr, name);
                                break;
                        case LBRACK:
                                oberon_assert_token(ctx, LBRACK);
                                int num_indexes = 0;
                                oberon_expr_t * indexes = NULL;
                                oberon_expr_list(ctx, &num_indexes, &indexes, 0);
                                oberon_assert_token(ctx, RBRACK);

                                for(int i = 0; i < num_indexes; i++)
                                {
                                        expr = oberon_make_array_selector(ctx, expr, indexes);
                                        indexes = indexes -> next;
                                }
                                break;
                        case UPARROW:
                                oberon_assert_token(ctx, UPARROW);
                                expr = oberno_make_dereferencing(ctx, expr);
                                break;
                        case LPAREN:
                                oberon_assert_token(ctx, LPAREN);
                                objtype = oberon_qualident(ctx, NULL, true);
                                oberon_assert_token(ctx, RPAREN);
                                oberon_check_extension_of(ctx, expr -> result, objtype -> type);
                                expr = oberon_cast_expr(ctx, expr, objtype -> type);
                                break;
                        default:
                                oberon_error(ctx, "oberon_designator: wat");
                                break;
                }
        }

        return expr;
}

static oberon_expr_t *
oberon_opt_func_parens(oberon_context_t * ctx, oberon_expr_t * expr)
{
        /* Если есть скобки - значит вызов. Если нет, то передаём указатель. */
        if(ctx -> token == LPAREN)
        {
                oberon_assert_token(ctx, LPAREN);

                int num_args = 0;
                oberon_expr_t * arguments = NULL;

                if(ISEXPR(ctx -> token))
                {
                        oberon_expr_list(ctx, &num_args, &arguments, 0);
                }

                assert(expr -> is_item == 1);
                expr = oberon_make_call_func(ctx, (oberon_item_t *) expr, num_args, arguments);

                oberon_assert_token(ctx, RPAREN);
        }

        return expr;
}

static void
oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr)
{
        assert(expr -> is_item);

        int num_args = 0;
        oberon_expr_t * arguments = NULL;

        if(ctx -> token == LPAREN)
        {
                oberon_assert_token(ctx, LPAREN);

                if(ISEXPR(ctx -> token))
                {
                        oberon_expr_list(ctx, &num_args, &arguments, 0);
                }

                oberon_assert_token(ctx, RPAREN);
        }

        /* Вызов происходит даже без скобок */
        oberon_make_call_proc(ctx, (oberon_item_t *) expr, num_args, arguments);
}

static oberon_expr_t *
oberon_element(oberon_context_t * ctx)
{
        oberon_expr_t * e1;
        oberon_expr_t * e2;

        e1 = oberon_expr(ctx);
        oberon_check_src(ctx, e1);
        if(e1 -> result -> class != OBERON_TYPE_INTEGER)
        {
                oberon_error(ctx, "expected integer");
        }

        e2 = NULL;
        if(ctx -> token == DOTDOT)
        {
                oberon_assert_token(ctx, DOTDOT);
                e2 = oberon_expr(ctx);
                oberon_check_src(ctx, e2);
                if(e2 -> result -> class != OBERON_TYPE_INTEGER)
                {
                        oberon_error(ctx, "expected integer");
                }
        }

        oberon_expr_t * set;
        if(e2 == NULL && oberon_is_const(e1))
        {
                set = oberon_make_set_index(ctx, e1 -> item.integer);
        }
        else if(e2 != NULL && oberon_is_const(e1) && oberon_is_const(e2))
        {
                set = oberon_make_set_range(ctx, e1 -> item.integer, e2 -> item.integer);
        }
        else
        {
                set = oberon_new_operator(OP_RANGE, ctx -> set_type, e1, e2);
        }
        return set;
}

static oberon_expr_t *
oberon_make_set_union(oberon_context_t * ctx, oberon_expr_t * a, oberon_expr_t * b)
{
        if(oberon_is_const(a) && oberon_is_const(b))
        {
                return oberon_make_set(ctx, (a -> item.integer | b -> item.integer));
        }
        else
        {
                return oberon_new_operator(OP_UNION, ctx -> set_type, a, b);
        }       
}

static oberon_expr_t *
oberon_set(oberon_context_t * ctx)
{
        oberon_expr_t * set;
        oberon_expr_t * elements;
        set = oberon_make_set(ctx, 0);

        oberon_assert_token(ctx, LBRACE);
        if(ISEXPR(ctx -> token))
        {
                elements = oberon_element(ctx);
                set = oberon_make_set_union(ctx, set, elements);
                while(ctx -> token == COMMA)
                {
                        oberon_assert_token(ctx, COMMA);
                        elements = oberon_element(ctx);
                        set = oberon_make_set_union(ctx, set, elements);
                }
        }
        oberon_assert_token(ctx, RBRACE);

        return set;
}

static oberon_expr_t *
oberon_factor(oberon_context_t * ctx)
{
        oberon_expr_t * expr;
        oberon_type_t * result;

        switch(ctx -> token)
        {
                case IDENT:
                        expr = oberon_designator(ctx);
                        expr = oberon_opt_func_parens(ctx, expr);
                        break;
                case INTEGER:
                        expr = oberon_make_integer(ctx, ctx -> integer);
                        oberon_assert_token(ctx, INTEGER);
                        break;
                case CHAR:
                        result = ctx -> char_type;
                        expr = oberon_new_item(MODE_CHAR, result, true);
                        expr -> item.integer = ctx -> integer;
                        oberon_assert_token(ctx, CHAR);
                        break;
                case STRING:
                        expr = oberon_make_string(ctx, ctx -> string);
                        oberon_assert_token(ctx, STRING);
                        break;
                case REAL:
                        expr = oberon_make_real(ctx, ctx -> real, ctx -> longmode);
                        oberon_assert_token(ctx, REAL);
                        break;
                case LBRACE:
                        expr = oberon_set(ctx);
                        break;
                case LPAREN:
                        oberon_assert_token(ctx, LPAREN);
                        expr = oberon_expr(ctx);
                        oberon_assert_token(ctx, RPAREN);
                        break;
                case NOT:
                        oberon_assert_token(ctx, NOT);
                        expr = oberon_factor(ctx);
                        expr = oberon_make_unary_op(ctx, NOT, expr);
                        break;
                case NIL:
                        oberon_assert_token(ctx, NIL);
                        expr = oberon_new_item(MODE_NIL, ctx -> nil_type, true);
                        break;
                default:
                        oberon_error(ctx, "invalid expression");
        }

        return expr;
}

static oberon_expr_t *
oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_expr_t * b)
{
        oberon_expr_t * expr;
        oberon_type_t * result;

        oberon_check_compatible_bin_expr(ctx, token, a, b);
        oberon_check_src(ctx, a);
        if(token != IS)
        {
                oberon_check_src(ctx, b);
        }

        if(token == IN)
        {
                if(oberon_is_const(a) && oberon_is_const(b))
                {
                        expr = oberon_make_boolean(ctx, (1 << a -> item.integer) & b -> item.integer);
                }
                else
                {
                        expr = oberon_new_operator(OP_IN, ctx -> bool_type, a, b);
                }
        }
        else if(token == IS)
        {
                oberon_check_type_expr(ctx, b);
                expr = oberon_new_operator(OP_IS, ctx -> bool_type, a, b);
        }
        else if((token >= EQUAL && token <= GEQ) || token == OR || token == AND)
        {
                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)))
                {
                        if(oberon_is_real_type(result))
                        {
                                double x = a -> item.real;
                                double y = b -> item.real;
                                switch(token)
                                {
                                        case EQUAL: expr = oberon_make_boolean(ctx, x == y); break;
                                        case NEQ:   expr = oberon_make_boolean(ctx, x != y); break;
                                        case LESS:  expr = oberon_make_boolean(ctx, x < y); break;
                                        case LEQ:   expr = oberon_make_boolean(ctx, x <= y); break;
                                        case GREAT: expr = oberon_make_boolean(ctx, x > y); break;
                                        case GEQ:   expr = oberon_make_boolean(ctx, x >= y); break;
                                        case OR:    expr = oberon_make_boolean(ctx, x || y); break;
                                        case AND:   expr = oberon_make_boolean(ctx, x && y); break;
                                        default: assert(0); break;
                                }
                        }
                        else if(oberon_is_integer_type(result))
                        {
                                int64_t x = a -> item.integer;
                                int64_t y = b -> item.integer;
                                switch(token)
                                {
                                        case EQUAL: expr = oberon_make_boolean(ctx, x == y); break;
                                        case NEQ:   expr = oberon_make_boolean(ctx, x != y); break;
                                        case LESS:  expr = oberon_make_boolean(ctx, x < y); break;
                                        case LEQ:   expr = oberon_make_boolean(ctx, x <= y); break;
                                        case GREAT: expr = oberon_make_boolean(ctx, x > y); break;
                                        case GEQ:   expr = oberon_make_boolean(ctx, x >= y); break;
                                        case OR:    expr = oberon_make_boolean(ctx, x || y); break;
                                        case AND:   expr = oberon_make_boolean(ctx, x && y); break;
                                        default: assert(0); break;
                                }
                        }
                        else
                        {
                                assert(0);
                        }
                }
                else
                {
                        a = oberon_cast_expr(ctx, a, result);
                        b = oberon_cast_expr(ctx, b, result);
                        result = ctx -> bool_type;
                        switch(token)
                        {
                                case EQUAL: expr = oberon_new_operator(OP_EQ, result, a, b); break;
                                case NEQ:   expr = oberon_new_operator(OP_NEQ, result, a, b); break;
                                case LESS:  expr = oberon_new_operator(OP_LSS, result, a, b); break;
                                case LEQ:   expr = oberon_new_operator(OP_LEQ, result, a, b); break;
                                case GREAT: expr = oberon_new_operator(OP_GRT, result, a, b); break;
                                case GEQ:   expr = oberon_new_operator(OP_GEQ, result, a, b); break;
                                case OR:    expr = oberon_new_operator(OP_LOGIC_OR, result, a, b); break;
                                case AND:   expr = oberon_new_operator(OP_LOGIC_AND, result, a, b); break;
                                default: assert(0); break;
                        }
                }
        }
        else if(token == SLASH)
        {
                if(oberon_is_set_type(a -> result) && oberon_is_set_type(b -> result))
                {
                        if(oberon_is_const(a) && oberon_is_const(b))
                        {
                                int64_t x = a -> item.integer;
                                int64_t y = b -> item.integer;
                                expr = oberon_make_set(ctx, x ^ y);
                        }
                        else
                        {
                                result = oberon_get_longer_type(ctx, a -> result, b -> result);
                                a = oberon_cast_expr(ctx, a, result);
                                b = oberon_cast_expr(ctx, b, result);
                                expr = oberon_new_operator(OP_SYM_DIFFERENCE, result, a, b);
                        }
                }
                else
                {
                        result = oberon_get_longer_real_type(ctx, a -> result, b -> result);
                        if(oberon_is_const(a) && oberon_is_const(b))
                        {
                                double x = a -> item.real;
                                double y = b -> item.real;
                                expr = oberon_make_real_typed(ctx, x / y, result);
                        }
                        else
                        {
                                a = oberon_cast_expr(ctx, a, result);
                                b = oberon_cast_expr(ctx, b, result);
                                expr = oberon_new_operator(OP_DIV, result, a, b);
                        }
                }
        }
        else
        {
                result = oberon_get_longer_type(ctx, a -> result, b -> result);

                if(oberon_is_const(a) && oberon_is_const(b))
                {
                        if(oberon_is_set_type(result))
                        {
                                int64_t x = a -> item.integer;
                                int64_t y = b -> item.integer;
                                switch(token)
                                {
                                        case PLUS:  expr = oberon_make_set(ctx, x | y); break;
                                        case MINUS: expr = oberon_make_set(ctx, x & ~y); break;
                                        case STAR:  expr = oberon_make_set(ctx, x & y); break;
                                        default: assert(0); break;
                                }
                        }
                        if(oberon_is_real_type(result))
                        {
                                double x = a -> item.real;
                                double y = b -> item.real;
                                switch(token)
                                {
                                        case PLUS:  expr = oberon_make_real_typed(ctx, x + y, result); break;
                                        case MINUS: expr = oberon_make_real_typed(ctx, x - y, result); break;
                                        case STAR:  expr = oberon_make_real_typed(ctx, x * y, result); break;
                                        default: assert(0); break;
                                }
                        }
                        else if(oberon_is_integer_type(result))
                        {
                                int64_t x = a -> item.integer;
                                int64_t y = b -> item.integer;
                                switch(token)
                                {
                                        case PLUS:  expr = oberon_make_integer(ctx, x + y); break;
                                        case MINUS: expr = oberon_make_integer(ctx, x - y); break;
                                        case STAR:  expr = oberon_make_integer(ctx, x * y); break;
                                        case DIV:   expr = oberon_make_integer(ctx, x / y); break;
                                        case MOD:   expr = oberon_make_integer(ctx, x % y); break;
                                        default: assert(0); break;
                                }
                        }
                        else
                        {
                                assert(0);
                        }
                }
                else
                {
                        a = oberon_cast_expr(ctx, a, result);
                        b = oberon_cast_expr(ctx, b, result);
                        
                        
                        if(oberon_is_set_type(result))
                        {
                                switch(token)
                                {
                                        case PLUS:
                                                expr = oberon_new_operator(OP_UNION, result, a, b);
                                                break;
                                        case MINUS:
                                                expr = oberon_new_operator(OP_DIFFERENCE, result, a, b);
                                                break;
                                        case STAR:
                                                expr = oberon_new_operator(OP_INTERSECTION, result, a, b);
                                                break;
                                        default:
                                                assert(0);
                                                break;
                                }
                        }
                        else if(oberon_is_real_type(result))
                        {
                                switch(token)
                                {
                                        case PLUS:
                                                expr = oberon_new_operator(OP_ADD, result, a, b);
                                                break;
                                        case MINUS:
                                                expr = oberon_new_operator(OP_SUB, result, a, b);
                                                break;
                                        case STAR:
                                                expr = oberon_new_operator(OP_MUL, result, a, b);
                                                break;
                                        default:
                                                printf("token %i line %i\n", token, ctx -> loc.line);
                                                assert(0);
                                                break;
                                }
                        }
                        else if(oberon_is_integer_type(result))
                        {
                                switch(token)
                                {
                                        case PLUS:
                                                expr = oberon_new_operator(OP_ADD, result, a, b);
                                                break;
                                        case MINUS:
                                                expr = oberon_new_operator(OP_SUB, result, a, b);
                                                break;
                                        case STAR:
                                                expr = oberon_new_operator(OP_MUL, result, a, b);
                                                break;
                                        case DIV:
                                                expr = oberon_new_operator(OP_DIV, result, a, b);
                                                break;
                                        case MOD:
                                                expr = oberon_new_operator(OP_MOD, result, a, b);
                                                break;
                                        default:
                                                printf("token %i line %i\n", token, ctx -> loc.line);
                                                assert(0);
                                                break;
                                }
                        }
                        else
                        {
                                assert(0);
                        }
                }
        }

        return expr;
}

#define ISMULOP(x) \
        ((x) >= STAR && (x) <= AND)

static oberon_expr_t *
oberon_term_expr(oberon_context_t * ctx)
{
        oberon_expr_t * expr;

        expr = oberon_factor(ctx);
        while(ISMULOP(ctx -> token))
        {
                int token = ctx -> token;
                oberon_read_token(ctx);

                oberon_expr_t * inter = oberon_factor(ctx);
                expr = oberon_make_bin_op(ctx, token, expr, inter);
        }

        return expr;
}

#define ISADDOP(x) \
        ((x) >= PLUS && (x) <= OR)

static oberon_expr_t *
oberon_simple_expr(oberon_context_t * ctx)
{
        oberon_expr_t * expr;

        int minus = 0;
        if(ctx -> token == PLUS)
        {
                minus = 0;
                oberon_assert_token(ctx, PLUS);
        }
        else if(ctx -> token == MINUS)
        {
                minus = 1;
                oberon_assert_token(ctx, MINUS);
        }

        expr = oberon_term_expr(ctx);

        while(ISADDOP(ctx -> token))
        {
                int token = ctx -> token;
                oberon_read_token(ctx);

                oberon_expr_t * inter = oberon_term_expr(ctx);
                expr = oberon_make_bin_op(ctx, token, expr, inter);
        }

        if(minus)
        {
                expr = oberon_make_unary_op(ctx, MINUS, expr);
        }

        return expr;
}

#define ISRELATION(x) \
        ((x) >= EQUAL && (x) <= IS)

static oberon_expr_t *
oberon_expr(oberon_context_t * ctx)
{
        oberon_expr_t * expr;

        expr = oberon_simple_expr(ctx);
        while(ISRELATION(ctx -> token))
        {
                int token = ctx -> token;
                oberon_read_token(ctx);

                oberon_expr_t * inter = oberon_simple_expr(ctx);
                expr = oberon_make_bin_op(ctx, token, expr, inter);
        }

        return expr;
}

static bool
oberon_is_const(oberon_expr_t * expr)
{
        if(expr -> is_item == false)
        {
                return false;
        }

        switch(expr -> item.mode)
        {
                case MODE_INTEGER:
                case MODE_BOOLEAN:
                case MODE_NIL:
                case MODE_REAL:
                case MODE_CHAR:
                case MODE_STRING:
                case MODE_SET:
                case MODE_TYPE:
                case MODE_SYSBYTE:
                        return true;
                        break;
                default:
                        return false;
                        break;
        }

        return false;
}

static void
oberon_check_const(oberon_context_t * ctx, oberon_expr_t * expr)
{
        if(!oberon_is_const(expr))
        {
                oberon_error(ctx, "const expression are required");
        }
}

static oberon_item_t *
oberon_const_expr(oberon_context_t * ctx)
{
        oberon_expr_t * expr;
        expr = oberon_expr(ctx);
        oberon_check_const(ctx, expr);
        return (oberon_item_t *) expr;
}

// =======================================================================
//   PARSER
// =======================================================================

static void oberon_decl_seq(oberon_context_t * ctx);
static void oberon_statement_seq(oberon_context_t * ctx);
static void oberon_initialize_decl(oberon_context_t * ctx);

static void
oberon_expect_token(oberon_context_t * ctx, int token)
{
        if(ctx -> token != token)
        {
                oberon_error(ctx, "unexpected token %i (%i)", ctx -> token, token);
        }
}

static void
oberon_assert_token(oberon_context_t * ctx, int token)
{
        oberon_expect_token(ctx, token);
        oberon_read_token(ctx);
}

static char *
oberon_assert_ident(oberon_context_t * ctx)
{
        oberon_expect_token(ctx, IDENT);
        char * ident = ctx -> string;
        oberon_read_token(ctx);
        return ident;
}

static void
oberon_def(oberon_context_t * ctx, int * export, int * read_only)
{
        switch(ctx -> token)
        {
                case STAR:
                        oberon_assert_token(ctx, STAR);
                        *export = 1;
                        *read_only = 0;
                        break;
                case MINUS:
                        oberon_assert_token(ctx, MINUS);
                        *export = 1;
                        *read_only = 1;
                        break;
                default:
                        *export = 0;
                        *read_only = 0;
                        break;
        }
}

static oberon_object_t *
oberon_ident_def(oberon_context_t * ctx, int class, bool check_upscope)
{
        char * name;
        int export;
        int read_only;
        oberon_object_t * x;

        name = oberon_assert_ident(ctx);
        oberon_def(ctx, &export, &read_only);

        x = oberon_define_object(ctx -> decl, name, class, export, read_only, check_upscope);
        return x;
}

static void
oberon_ident_list(oberon_context_t * ctx, int class, bool check_upscope, int * num, oberon_object_t ** list)
{
        *num = 1;
        *list = oberon_ident_def(ctx, class, check_upscope);
        while(ctx -> token == COMMA)
        {
                oberon_assert_token(ctx, COMMA);
                oberon_ident_def(ctx, class, check_upscope);
                *num += 1;
        }
}

static void
oberon_var_decl(oberon_context_t * ctx)
{
        int num;
        oberon_object_t * list;
        oberon_type_t * type;
        type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);

        oberon_ident_list(ctx, OBERON_CLASS_VAR, false, &num, &list);
        oberon_assert_token(ctx, COLON);
        oberon_type(ctx, &type);

        oberon_object_t * var = list;
        for(int i = 0; i < num; i++)
        {
                var -> type = type;
                var = var -> next;
        }
}

static oberon_object_t *
oberon_fp_section(oberon_context_t * ctx, int * num_decl)
{
        int class = OBERON_CLASS_PARAM;
        if(ctx -> token == VAR)
        {
                oberon_read_token(ctx);
                class = OBERON_CLASS_VAR_PARAM;
        }

        int num;
        oberon_object_t * list;
        oberon_ident_list(ctx, class, false, &num, &list);

        oberon_assert_token(ctx, COLON);

        oberon_type_t * type;
        type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);
        oberon_type(ctx, &type);

        oberon_object_t * param = list;
        for(int i = 0; i < num; i++)
        {
                param -> type = type;
                param = param -> next;
        }

        *num_decl += num;
        return list;
}

#define ISFPSECTION \
        ((ctx -> token == VAR) || (ctx -> token == IDENT))

static void
oberon_formal_pars(oberon_context_t * ctx, oberon_type_t * signature)
{
        oberon_assert_token(ctx, LPAREN);

        if(ISFPSECTION)
        {
                signature -> decl = oberon_fp_section(ctx, &signature -> num_decl);
                while(ctx -> token == SEMICOLON)
                {
                        oberon_assert_token(ctx, SEMICOLON);
                        oberon_fp_section(ctx, &signature -> num_decl);
                }
        }

        oberon_assert_token(ctx, RPAREN);

        if(ctx -> token == COLON)
        {
                oberon_assert_token(ctx, COLON);

                oberon_object_t * typeobj;
                typeobj = oberon_qualident(ctx, NULL, 1);
                if(typeobj -> class != OBERON_CLASS_TYPE)
                {
                        oberon_error(ctx, "function result is not type");
                }
                if(typeobj -> type -> class == OBERON_TYPE_RECORD
                        || typeobj -> type -> class == OBERON_TYPE_ARRAY)
                {
                        oberon_error(ctx, "records or arrays could not be result of function");
                }
                signature -> base = typeobj -> type;
        }
}

static void
oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type)
{
        oberon_type_t * signature;
        signature = *type;
        signature -> class = OBERON_TYPE_PROCEDURE;
        signature -> num_decl = 0;
        signature -> base = ctx -> notype_type;
        signature -> decl = NULL;

        if(ctx -> token == LPAREN)
        {
                oberon_formal_pars(ctx, signature);
        }
}

static void
oberon_compare_signatures(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b)
{
        if(a -> num_decl != b -> num_decl)
        {
                oberon_error(ctx, "number parameters not matched");
        }

        int num_param = a -> num_decl;
        oberon_object_t * param_a = a -> decl;
        oberon_object_t * param_b = b -> decl;
        for(int i = 0; i < num_param; i++)
        {
                if(strcmp(param_a -> name, param_b -> name) != 0)
                {
                        oberon_error(ctx, "param %i name not matched", i + 1);
                }

                if(param_a -> type != param_b -> type)
                {
                        oberon_error(ctx, "param %i type not matched", i + 1);
                }

                param_a = param_a -> next;
                param_b = param_b -> next;
        }
}

static void
oberon_make_return(oberon_context_t * ctx, oberon_expr_t * expr)
{
        oberon_object_t * proc = ctx -> decl -> parent;
        oberon_type_t * result_type = proc -> type -> base;

        if(result_type -> class == OBERON_TYPE_NOTYPE)
        {
                if(expr != NULL)
                {
                        oberon_error(ctx, "procedure has no result type");
                }
        }
        else
        {
                if(expr == NULL)
                {
                        oberon_error(ctx, "procedure requires expression on result");
                }

                oberon_check_src(ctx, expr);
                oberon_check_assignment_compatible(ctx, expr, result_type);
                expr = oberon_cast_expr(ctx, expr, result_type);
        }

        proc -> has_return = 1;

        oberon_generate_return(ctx, expr);
}

static void
oberon_proc_decl_body(oberon_context_t * ctx, oberon_object_t * proc)
{
        oberon_assert_token(ctx, SEMICOLON);

        ctx -> decl = proc -> scope;

        oberon_decl_seq(ctx);

        oberon_generate_begin_proc(ctx, proc);

        if(ctx -> token == BEGIN)
        {
                oberon_assert_token(ctx, BEGIN);
                oberon_statement_seq(ctx);
        }

        oberon_assert_token(ctx, END);
        char * name = oberon_assert_ident(ctx);
        if(strcmp(name, proc -> name) != 0)
        {
                oberon_error(ctx, "procedure name not matched");
        }

        if(proc -> type -> base -> class == OBERON_TYPE_NOTYPE)
        {
                oberon_make_return(ctx, NULL);
        }

        if(proc -> has_return == 0)
        {
                oberon_error(ctx, "procedure requires return");
        }

        oberon_generate_end_proc(ctx);
        oberon_close_scope(ctx -> decl);
}

static void
oberon_proc_decl(oberon_context_t * ctx)
{
        oberon_assert_token(ctx, PROCEDURE);

        int forward = 0;
        if(ctx -> token == UPARROW)
        {
                oberon_assert_token(ctx, UPARROW);
                forward = 1;
        }

        char * name;
        int export;
        int read_only;
        name = oberon_assert_ident(ctx);
        oberon_def(ctx, &export, &read_only);

        oberon_scope_t * proc_scope;
        proc_scope = oberon_open_scope(ctx);
        ctx -> decl -> local = 1;

        oberon_type_t * signature;
        signature = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);
        oberon_opt_formal_pars(ctx, &signature);        

        //oberon_initialize_decl(ctx);
        oberon_generator_init_type(ctx, signature);
        oberon_close_scope(ctx -> decl);

        oberon_object_t * proc;
        proc = oberon_find_object(ctx -> decl, name, 0);
        if(proc == NULL)
        {
                proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, export, read_only, false);
                proc -> type = signature;
                proc -> scope = proc_scope;
                oberon_generator_init_proc(ctx, proc);
        }
        else
        {
                if(proc -> class != OBERON_CLASS_PROC)
                {
                        oberon_error(ctx, "mult definition");
                }

                if(forward == 0)
                {
                        if(proc -> linked)
                        {
                                oberon_error(ctx, "mult procedure definition");
                        }
                }

                if(proc -> export != export || proc -> read_only != read_only)
                {
                        oberon_error(ctx, "export type not matched");
                }

                oberon_compare_signatures(ctx, proc -> type, signature);
        }

        proc_scope -> parent = proc;
        oberon_object_t * param = proc_scope -> list -> next;
        while(param)
        {
                param -> parent = proc;
                param = param -> next;
        }

        if(forward == 0)
        {
                proc -> linked = 1;
                oberon_proc_decl_body(ctx, proc);
        }
}

static void
oberon_const_decl(oberon_context_t * ctx)
{
        oberon_item_t * value;
        oberon_object_t * constant;

        constant = oberon_ident_def(ctx, OBERON_CLASS_CONST, false);
        oberon_assert_token(ctx, EQUAL);
        value = oberon_const_expr(ctx);
        constant -> value = value;
}

static void
oberon_make_array_type(oberon_context_t * ctx, oberon_expr_t * size, oberon_type_t * base, oberon_type_t ** type)
{
        if(size -> is_item == 0)
        {
                oberon_error(ctx, "requires constant");
        }

        if(size -> item.mode != MODE_INTEGER)
        {
                oberon_error(ctx, "requires integer constant");
        }

        oberon_type_t * arr;
        arr = *type;
        arr -> class = OBERON_TYPE_ARRAY;
        arr -> size = size -> item.integer;
        arr -> base = base;
}

static void
oberon_qualident_type(oberon_context_t * ctx, oberon_type_t ** type)
{
        char * name;
        oberon_object_t * to;

        to = oberon_qualident(ctx, &name, 0);

        //name = oberon_assert_ident(ctx);
        //to = oberon_find_object(ctx -> decl, name, 0);

        if(to != NULL)
        {
                if(to -> class != OBERON_CLASS_TYPE)
                {
                        oberon_error(ctx, "not a type");
                }
        }
        else
        {
                to = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, false, false, false);
                to -> type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);
        }

        *type = to -> type;
}

static void oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type);

/*
 * Правило граматики "type". Указатель type должен указывать на существующий объект!
 */

static void
oberon_make_multiarray(oberon_context_t * ctx, oberon_expr_t * sizes, oberon_type_t * base, oberon_type_t ** type)
{
        if(sizes == NULL)
        {
                *type = base;
                return;
        }

        oberon_type_t * dim;
        dim = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);

        oberon_make_multiarray(ctx, sizes -> next, base, &dim);

        oberon_make_array_type(ctx, sizes, dim, type);
}

static void
oberon_make_open_array(oberon_context_t * ctx, oberon_type_t * base, oberon_type_t * type)
{
        type -> class = OBERON_TYPE_ARRAY;
        type -> size = 0;
        type -> base = base;
}

static void
oberon_field_list(oberon_context_t * ctx, oberon_type_t * rec, oberon_scope_t * modscope)
{
        if(ctx -> token == IDENT)
        {
                int num;
                oberon_object_t * list;
                oberon_type_t * type;
                type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);

                oberon_ident_list(ctx, OBERON_CLASS_FIELD, true, &num, &list);
                oberon_assert_token(ctx, COLON);

                oberon_scope_t * current = ctx -> decl;
                ctx -> decl = modscope;
                oberon_type(ctx, &type);
                ctx -> decl = current;

                oberon_object_t * field = list;
                for(int i = 0; i < num; i++)
                {
                        field -> type = type;
                        field = field -> next;
                }

                rec -> num_decl += num;
        }
}

static void
oberon_type_record_body(oberon_context_t * ctx, oberon_type_t * rec)
{
        oberon_scope_t * oldscope = ctx -> decl;
        ctx -> decl = oldscope;

        if(ctx -> token == LPAREN)
        {
                oberon_assert_token(ctx, LPAREN);

                oberon_object_t * typeobj;
                typeobj = oberon_qualident(ctx, NULL, true);

                if(typeobj -> class != OBERON_CLASS_TYPE)
                {
                        oberon_error(ctx, "base must be type");
                }

                oberon_type_t * base = typeobj -> type;
                if(base -> class == OBERON_TYPE_POINTER)
                {
                        base = base -> base;
                }

                if(base -> class != OBERON_TYPE_RECORD)
                {
                        oberon_error(ctx, "base must be record type");
                }

                rec -> base = base;
                ctx -> decl = base -> scope;

                oberon_assert_token(ctx, RPAREN);
        }
        else
        {
                ctx -> decl = NULL;
        }

        oberon_scope_t * this_scope;
        this_scope = oberon_open_scope(ctx);
        this_scope -> local = true;
        this_scope -> parent = NULL;
        this_scope -> parent_type = rec;

        oberon_field_list(ctx, rec, oldscope);
        while(ctx -> token == SEMICOLON)
        {
                oberon_assert_token(ctx, SEMICOLON);
                oberon_field_list(ctx, rec, oldscope);
        }

        rec -> scope = this_scope;
        rec -> decl = this_scope -> list -> next;
        ctx -> decl = oldscope;
}

static void
oberon_type(oberon_context_t * ctx, oberon_type_t ** type)
{
        if(ctx -> token == IDENT)
        {
                oberon_qualident_type(ctx, type);
        }
        else if(ctx -> token == ARRAY)
        {
                oberon_assert_token(ctx, ARRAY);

                int num_sizes = 0;
                oberon_expr_t * sizes;

                if(ISEXPR(ctx -> token))
                {
                        oberon_expr_list(ctx, &num_sizes, &sizes, 1);
                }

                oberon_assert_token(ctx, OF);

                oberon_type_t * base;
                base = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);
                oberon_type(ctx, &base);

                if(num_sizes == 0)
                {
                        oberon_make_open_array(ctx, base, *type);
                }
                else
                {
                        oberon_make_multiarray(ctx, sizes, base, type);
                }
        }
        else if(ctx -> token == RECORD)
        {
                oberon_type_t * rec;
                rec = *type;
                rec -> class = OBERON_TYPE_RECORD;
                rec -> module = ctx -> mod;

                oberon_assert_token(ctx, RECORD);
                oberon_type_record_body(ctx, rec);
                oberon_assert_token(ctx, END);

                *type = rec;
        }
        else if(ctx -> token == POINTER)
        {
                oberon_assert_token(ctx, POINTER);
                oberon_assert_token(ctx, TO);

                oberon_type_t * base;
                base = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);
                oberon_type(ctx, &base);

                oberon_type_t * ptr;
                ptr = *type;
                ptr -> class = OBERON_TYPE_POINTER;
                ptr -> base = base;
        }
        else if(ctx -> token == PROCEDURE)
        {
                oberon_open_scope(ctx);
                oberon_assert_token(ctx, PROCEDURE);
                oberon_opt_formal_pars(ctx, type);
                oberon_close_scope(ctx -> decl);
        }
        else
        {
                oberon_error(ctx, "invalid type declaration");
        }
}

static void
oberon_type_decl(oberon_context_t * ctx)
{
        char * name;
        oberon_object_t * newtype;
        oberon_type_t * type;
        int export;
        int read_only;

        name = oberon_assert_ident(ctx);
        oberon_def(ctx, &export, &read_only);

        newtype = oberon_find_object(ctx -> decl, name, 0);
        if(newtype == NULL)
        {
                newtype = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, export, read_only, false);
                newtype -> type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);
                assert(newtype -> type);
        }
        else
        {
                if(newtype -> class != OBERON_CLASS_TYPE)
                {
                        oberon_error(ctx, "mult definition");
                }

                if(newtype -> linked)
                {
                        oberon_error(ctx, "mult definition - already linked");
                }

                newtype -> export = export;
                newtype -> read_only = read_only;
        }

        oberon_assert_token(ctx, EQUAL);

        type = newtype -> type;
        oberon_type(ctx, &type);

        if(type -> class == OBERON_TYPE_NOTYPE)
        {
                oberon_error(ctx, "recursive alias declaration");
        }

        newtype -> type = type;
        newtype -> linked = 1;
}

static void oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x);
static void oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type);

static void
oberon_prevent_recursive_pointer(oberon_context_t * ctx, oberon_type_t * type)
{
        if(type -> class != OBERON_TYPE_POINTER
                && type -> class != OBERON_TYPE_ARRAY)
        {
                return;
        }

        if(type -> recursive)
        {
                if(type -> class == OBERON_TYPE_POINTER)
                {
                        oberon_error(ctx, "recursive pointer declaration");
                }
                else
                {
                        oberon_error(ctx, "recursive array declaration (pointer)");
                }
        }

        if(type -> class == OBERON_TYPE_POINTER
                && type -> base -> class == OBERON_TYPE_POINTER)
        {
                oberon_error(ctx, "attempt to make pointer to pointer");
        }

        type -> recursive = 1;

        oberon_prevent_recursive_pointer(ctx, type -> base);

        type -> recursive = 0;
}

static void
oberon_prevent_recursive_record(oberon_context_t * ctx, oberon_type_t * type)
{
        if(type -> class != OBERON_TYPE_RECORD)
        {
                return;
        }

        if(type -> recursive)
        {
                oberon_error(ctx, "recursive record declaration");
        }

        type -> recursive = 1;

        if(type -> base)
        {
                oberon_prevent_recursive_record(ctx, type -> base);
        }

        int num_fields = type -> num_decl;
        oberon_object_t * field = type -> decl;
        for(int i = 0; i < num_fields; i++)
        {
                oberon_prevent_recursive_object(ctx, field);
                field = field -> next;
        }

        type -> recursive = 0;  
}
static void
oberon_prevent_recursive_procedure(oberon_context_t * ctx, oberon_type_t * type)
{
        if(type -> class != OBERON_TYPE_PROCEDURE)
        {
                return;
        }

        if(type -> recursive)
        {
                oberon_error(ctx, "recursive procedure declaration");
        }

        type -> recursive = 1;

        int num_fields = type -> num_decl;
        oberon_object_t * field = type -> decl;
        for(int i = 0; i < num_fields; i++)
        {
                oberon_prevent_recursive_object(ctx, field);
                field = field -> next;
        }

        type -> recursive = 0;  
}

static void
oberon_prevent_recursive_array(oberon_context_t * ctx, oberon_type_t * type)
{
        if(type -> class != OBERON_TYPE_ARRAY)
        {
                return;
        }

        if(type -> recursive)
        {
                oberon_error(ctx, "recursive array declaration");
        }

        type -> recursive = 1;

        oberon_prevent_recursive_type(ctx, type -> base);

        type -> recursive = 0;
}

static void
oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type)
{
        if(type -> class == OBERON_TYPE_POINTER)
        {
                oberon_prevent_recursive_pointer(ctx, type);
        }
        else if(type -> class == OBERON_TYPE_RECORD)
        {
                oberon_prevent_recursive_record(ctx, type);
        }
        else if(type -> class == OBERON_TYPE_ARRAY)
        {
                oberon_prevent_recursive_array(ctx, type);
        }
        else if(type -> class == OBERON_TYPE_PROCEDURE)
        {
                oberon_prevent_recursive_procedure(ctx, type);
        }
}

static void
oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x)
{
        switch(x -> class)
        {
                case OBERON_CLASS_VAR:
                case OBERON_CLASS_TYPE:
                case OBERON_CLASS_PARAM:
                case OBERON_CLASS_VAR_PARAM:
                case OBERON_CLASS_FIELD:
                        oberon_prevent_recursive_type(ctx, x -> type);
                        break;
                case OBERON_CLASS_CONST:
                case OBERON_CLASS_PROC:
                case OBERON_CLASS_MODULE:
                        break;
                default:
                        oberon_error(ctx, "oberon_prevent_recursive_object: wat");
                        break;
        }
}

static void
oberon_prevent_recursive_decl(oberon_context_t * ctx)
{
        oberon_object_t * x = ctx -> decl -> list -> next;

        while(x)
        {
                oberon_prevent_recursive_object(ctx, x);
                x = x -> next;
        }
}

static void oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x);
static void oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type);

static void
oberon_initialize_record_fields(oberon_context_t * ctx, oberon_type_t * type)
{
        assert(type -> class == OBERON_TYPE_RECORD);

        int num_fields = type -> num_decl;
        oberon_object_t * field = type -> decl;
        for(int i = 0; i < num_fields; i++)
        {
                oberon_initialize_object(ctx, field);
                field = field -> next;
        }

        oberon_generator_init_record(ctx, type);
}

static void
oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type)
{
        if(type -> class == OBERON_TYPE_NOTYPE)
        {
                oberon_error(ctx, "undeclarated type");
        }

        if(type -> initialized)
        {
                return;
        }

        type -> initialized = 1;

        if(type -> class == OBERON_TYPE_POINTER || type -> class == OBERON_TYPE_ARRAY)
        {
                if(type -> class == OBERON_TYPE_ARRAY
                        && type -> size != 0
                        && type -> base -> class == OBERON_TYPE_ARRAY
                        && type -> base -> size == 0)
                {
                        oberon_error(ctx, "open array not allowed as array element");
                }

                oberon_type_t * rec = type -> base;
                while(rec -> class == OBERON_TYPE_ARRAY || rec -> class == OBERON_TYPE_POINTER)
                {
                        rec = rec -> base;
                }

                if(rec -> class == OBERON_TYPE_RECORD
                        && rec -> initialized == 0)
                {
                        rec -> initialized = 1;
                        oberon_generator_init_type(ctx, rec);
                        oberon_initialize_type(ctx, type -> base);
                        oberon_generator_init_type(ctx, type);
                        oberon_initialize_record_fields(ctx, rec);
                }
                else
                {
                        oberon_initialize_type(ctx, type -> base);
                        oberon_generator_init_type(ctx, type);
                }
        }
        else if(type -> class == OBERON_TYPE_RECORD)
        {
                printf("Init type: RECORD\n");
                oberon_generator_init_type(ctx, type);
                oberon_initialize_record_fields(ctx, type);
        }
        else if(type -> class == OBERON_TYPE_PROCEDURE)
        {
                printf("Init type: PROCEDURE\n");
                int num_fields = type -> num_decl;
                oberon_object_t * field = type -> decl;
                for(int i = 0; i < num_fields; i++)
                {
                        oberon_initialize_type(ctx, field -> type);
                        field = field -> next;
                }

                oberon_generator_init_type(ctx, type);
        }
        else
        {
                oberon_generator_init_type(ctx, type);
        }
}

static void
oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x)
{
        if(x -> initialized)
        {
                return;
        }

        x -> initialized = 1;

        switch(x -> class)
        {
                case OBERON_CLASS_TYPE:
                        oberon_initialize_type(ctx, x -> type);
                        break;
                case OBERON_CLASS_VAR:
                case OBERON_CLASS_FIELD:
                        if(x -> type -> class == OBERON_TYPE_ARRAY)
                        {
                                if(x -> type -> size == 0)
                                {
                                        oberon_error(ctx, "open array not allowed as variable or field");
                                }
                        }
                        oberon_initialize_type(ctx, x -> type);
                        oberon_generator_init_var(ctx, x);
                        break;
                case OBERON_CLASS_PARAM:
                case OBERON_CLASS_VAR_PARAM:
                        oberon_initialize_type(ctx, x -> type);
                        oberon_generator_init_var(ctx, x);
                        break;
                case OBERON_CLASS_CONST:
                case OBERON_CLASS_PROC:
                case OBERON_CLASS_MODULE:
                        break;
                default:
                        oberon_error(ctx, "oberon_initialize_object: wat");
                        break;
        }
}

static void
oberon_initialize_decl(oberon_context_t * ctx)
{
        oberon_object_t * x = ctx -> decl -> list;

        while(x -> next)
        {
                oberon_initialize_object(ctx, x -> next);
                x = x -> next;
        }       
}

static void
oberon_prevent_undeclarated_procedures(oberon_context_t * ctx)
{
        oberon_object_t * x = ctx -> decl -> list;

        while(x -> next)
        {
                if(x -> next -> class == OBERON_CLASS_PROC)
                {
                        if(x -> next -> linked == 0)
                        {
                                oberon_error(ctx, "unresolved forward declaration");
                        }
                }
                x = x -> next;
        }       
}

static void
oberon_decl_seq(oberon_context_t * ctx)
{
        while(ctx -> token >= CONST && ctx -> token <= VAR)
        {
                if(ctx -> token == CONST)
                {
                        oberon_assert_token(ctx, CONST);
                        while(ctx -> token == IDENT)
                        {
                                oberon_const_decl(ctx);
                                oberon_assert_token(ctx, SEMICOLON);
                        }
                }
                else if(ctx -> token == TYPE)
                {
                        oberon_assert_token(ctx, TYPE);
                        while(ctx -> token == IDENT)
                        {
                                oberon_type_decl(ctx);
                                oberon_assert_token(ctx, SEMICOLON);
                        }
                }
                else if(ctx -> token == VAR)
                {
                        oberon_assert_token(ctx, VAR);
                        while(ctx -> token == IDENT)
                        {
                                oberon_var_decl(ctx);
                                oberon_assert_token(ctx, SEMICOLON);
                        }
                }
        }

        oberon_prevent_recursive_decl(ctx);
        oberon_initialize_decl(ctx);

        while(ctx -> token == PROCEDURE)
        {
                oberon_proc_decl(ctx);
                oberon_assert_token(ctx, SEMICOLON);
        }

        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);

static void
oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst)
{
        oberon_check_dst(ctx, dst);
        oberon_check_assignment_compatible(ctx, src, dst -> result);

        if(oberon_is_array_of_char_type(dst -> result)
                && oberon_is_string_type(src -> result))
        {
                src -> next = dst;
                oberon_make_copy_call(ctx, 2, src);
        }
        else
        {
                src = oberon_cast_expr(ctx, src, dst -> result);
                oberon_generate_assign(ctx, src, dst);
        }
}

static oberon_expr_t *
oberon_case_labels(oberon_context_t * ctx, oberon_expr_t * val)
{
        oberon_expr_t * e1;
        oberon_expr_t * e2;
        oberon_expr_t * cond;
        oberon_expr_t * cond2;

        e1 = (oberon_expr_t *) oberon_const_expr(ctx);

        e2 = NULL;
        if(ctx -> token == DOTDOT)
        {
                oberon_assert_token(ctx, DOTDOT);
                e2 = (oberon_expr_t *) oberon_const_expr(ctx);
        }

        if(e2 == NULL)
        {
                /* val == e1 */
                cond = oberon_make_bin_op(ctx, EQUAL, val, e1);
        }
        else
        {
                /* val >= e1 && val <= e2 */
                cond = oberon_make_bin_op(ctx, GEQ, val, e1);
                cond2 = oberon_make_bin_op(ctx, LEQ, val, e2);
                cond = oberon_make_bin_op(ctx, AND, cond, cond2);
        }

        return cond;
}

static void
oberon_case(oberon_context_t * ctx, oberon_expr_t * val, gen_label_t * end)
{
        oberon_expr_t * cond;
        oberon_expr_t * cond2;
        gen_label_t * this_end;

        if(ISEXPR(ctx -> token))
        {
                this_end = oberon_generator_reserve_label(ctx);

                cond = oberon_case_labels(ctx, val);
                while(ctx -> token == COMMA)
                {
                        oberon_assert_token(ctx, COMMA);
                        /* cond || cond2 */
                        cond2 = oberon_case_labels(ctx, val);
                        cond = oberon_make_bin_op(ctx, OR, cond, cond2);
                }
                oberon_assert_token(ctx, COLON);

                oberon_generate_branch(ctx, cond, false, this_end);
                oberon_statement_seq(ctx);
                oberon_generate_goto(ctx, end);

                oberon_generate_label(ctx, this_end);
        }
}

static void
oberon_case_statement(oberon_context_t * ctx)
{
        oberon_expr_t * val;
        oberon_expr_t * expr;
        gen_label_t * end;

        end = oberon_generator_reserve_label(ctx);

        oberon_assert_token(ctx, CASE);
        expr = oberon_expr(ctx);
        val = oberon_make_temp_var_item(ctx, expr -> result);
        oberon_assign(ctx, expr, val);
        oberon_assert_token(ctx, OF);
        oberon_case(ctx, val, end);
        while(ctx -> token == BAR)
        {
                oberon_assert_token(ctx, BAR);
                oberon_case(ctx, val, end);
        }

        if(ctx -> token == ELSE)
        {
                oberon_assert_token(ctx, ELSE);
                oberon_statement_seq(ctx);
        }
        else
        {
                oberon_generate_trap(ctx, -1);
        }

        oberon_generate_label(ctx, end);
        oberon_assert_token(ctx, END);
}

static void
oberon_with_guard_do(oberon_context_t * ctx, gen_label_t * end)
{
        oberon_object_t * var;
        oberon_expr_t * var_expr;
        oberon_expr_t * type_expr;
        oberon_expr_t * cond;
        oberon_type_t * type;
        oberon_type_t * old_type;
        gen_label_t * this_end;

        this_end = oberon_generator_reserve_label(ctx);

        var_expr = oberon_qualident_expr(ctx);
        oberon_assert_token(ctx, COLON);
        type_expr = oberon_qualident_expr(ctx);
        cond = oberon_make_bin_op(ctx, IS, var_expr, type_expr);

        var = var_expr -> item.var;
        type = type_expr -> result;
        old_type = var -> type;

        oberon_assert_token(ctx, DO);
        oberon_generate_branch(ctx, cond, false, this_end);

        var -> type = type;
        oberon_set_typecheck(var, true);

        oberon_statement_seq(ctx);

        var -> type = old_type;
        oberon_set_typecheck(var, false);

        oberon_generate_goto(ctx, end);
        oberon_generate_label(ctx, this_end);
}

static void
oberon_with_statement(oberon_context_t * ctx)
{
        gen_label_t * end;
        end = oberon_generator_reserve_label(ctx);

        oberon_assert_token(ctx, WITH);
        oberon_with_guard_do(ctx, end);
        while(ctx -> token == BAR)
        {
                oberon_assert_token(ctx, BAR);
                oberon_with_guard_do(ctx, end);
        }

        if(ctx -> token == ELSE)
        {
                oberon_assert_token(ctx, ELSE);
                oberon_statement_seq(ctx);
        }
        else
        {
                oberon_generate_trap(ctx, -2);
        }

        oberon_generate_label(ctx, end);
        oberon_assert_token(ctx, END);
}

static void
oberon_statement(oberon_context_t * ctx)
{
        oberon_expr_t * item1;
        oberon_expr_t * item2;

        if(ctx -> token == IDENT)
        {
                item1 = oberon_designator(ctx);
                if(ctx -> token == ASSIGN)
                {
                        oberon_assert_token(ctx, ASSIGN);
                        item2 = oberon_expr(ctx);
                        oberon_assign(ctx, item2, item1);
                }
                else
                {
                        oberon_opt_proc_parens(ctx, item1);
                }
        }
        else if(ctx -> token == IF)
        {
                gen_label_t * end;
                gen_label_t * els;
                oberon_expr_t * cond;

                els = oberon_generator_reserve_label(ctx);
                end = oberon_generator_reserve_label(ctx);

                oberon_assert_token(ctx, IF);
                cond = oberon_expr(ctx);
                if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
                {
                        oberon_error(ctx, "condition must be boolean");
                }
                oberon_assert_token(ctx, THEN);
                oberon_generate_branch(ctx, cond, false, els);
                oberon_statement_seq(ctx);
                oberon_generate_goto(ctx, end);
                oberon_generate_label(ctx, els);

                while(ctx -> token == ELSIF)
                {
                        els = oberon_generator_reserve_label(ctx);

                        oberon_assert_token(ctx, ELSIF);
                        cond = oberon_expr(ctx);
                        if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
                        {
                                oberon_error(ctx, "condition must be boolean");
                        }
                        oberon_assert_token(ctx, THEN);
                        oberon_generate_branch(ctx, cond, false, els);
                        oberon_statement_seq(ctx);
                        oberon_generate_goto(ctx, end);
                        oberon_generate_label(ctx, els);
                }

                if(ctx -> token == ELSE)
                {
                        oberon_assert_token(ctx, ELSE);
                        oberon_statement_seq(ctx);
                }

                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, false, 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_assert_token(ctx, TO);
                bound = oberon_make_temp_var_item(ctx, index -> result);
                to = oberon_expr(ctx);
                oberon_assign(ctx, to, bound); // сначала temp
                oberon_assign(ctx, from, index); // потом i
                if(ctx -> token == BY)
                {
                        oberon_assert_token(ctx, BY);
                        by = (oberon_expr_t *) oberon_const_expr(ctx);
                }
                else
                {
                        by = oberon_make_integer(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 == CASE)
        {
                oberon_case_statement(ctx);
        }
        else if(ctx -> token == WITH)
        {
                oberon_with_statement(ctx);
        }
        else if(ctx -> token == RETURN)
        {
                oberon_assert_token(ctx, RETURN);
                if(ISEXPR(ctx -> token))
                {
                        oberon_expr_t * expr;
                        expr = oberon_expr(ctx);
                        oberon_make_return(ctx, expr);
                }
                else
                {
                        oberon_make_return(ctx, NULL);
                }
        }
}

static void
oberon_statement_seq(oberon_context_t * ctx)
{
        oberon_statement(ctx);
        while(ctx -> token == SEMICOLON)
        {
                oberon_assert_token(ctx, SEMICOLON);
                oberon_statement(ctx);
        }
}

static void
oberon_import_module(oberon_context_t * ctx, char * alias, char * name)
{
        oberon_module_t * m = ctx -> module_list;
        while(m && strcmp(m -> name, name) != 0)
        {
                m = m -> next;
        }

        if(m == NULL)
        {
                oberon_scanner_t * s;
                s = ctx -> import_module(name);
                if(s == NULL)
                {
                        oberon_error(ctx, "no such module %s", name);
                }

                m = oberon_compile_module(ctx, s);
                assert(m);
        }

        if(m -> ready == 0)
        {
                oberon_error(ctx, "cyclic module import");
        }

        oberon_object_t * ident;
        ident = oberon_define_object(ctx -> decl, alias, OBERON_CLASS_MODULE, false, false, false);
        ident -> module = m;
}

static void
oberon_import_decl(oberon_context_t * ctx)
{
        char * alias;
        char * name;

        alias = name = oberon_assert_ident(ctx);
        if(ctx -> token == ASSIGN)
        {
                oberon_assert_token(ctx, ASSIGN);
                name = oberon_assert_ident(ctx);
        }

        oberon_import_module(ctx, alias, name);
}

static void
oberon_import_list(oberon_context_t * ctx)
{
        oberon_assert_token(ctx, IMPORT);

        oberon_import_decl(ctx);
        while(ctx -> token == COMMA)
        {
                oberon_assert_token(ctx, COMMA);
                oberon_import_decl(ctx);
        }

        oberon_assert_token(ctx, SEMICOLON);
}

static void
oberon_parse_module(oberon_context_t * ctx)
{
        char * name1;
        char * name2;
        oberon_read_token(ctx);

        oberon_assert_token(ctx, MODULE);
        name1 = oberon_assert_ident(ctx);
        oberon_assert_token(ctx, SEMICOLON);
        ctx -> mod -> name = name1;

        oberon_generator_init_module(ctx, ctx -> mod);

        if(ctx -> token == IMPORT)
        {
                oberon_import_list(ctx);
        }

        oberon_decl_seq(ctx);

        oberon_generate_begin_module(ctx);
        if(ctx -> token == BEGIN)
        {
                oberon_assert_token(ctx, BEGIN);
                oberon_statement_seq(ctx);
        }
        oberon_generate_end_module(ctx);

        oberon_assert_token(ctx, END);
        name2 = oberon_assert_ident(ctx);
        oberon_expect_token(ctx, DOT);

        if(strcmp(name1, name2) != 0)
        {
                oberon_error(ctx, "module name not matched");
        }

        oberon_generator_fini_module(ctx -> mod);
}

// =======================================================================
//   LIBRARY
// =======================================================================

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(!oberon_is_type_expr(arg))
        {
                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_make_integer(ctx, -powl(2, bits - 1));
                        break;
                case OBERON_TYPE_BOOLEAN:
                        expr = oberon_make_boolean(ctx, false);
                        break;
                case OBERON_TYPE_CHAR:
                        expr = oberon_make_char(ctx, 0);
                        break;
                case OBERON_TYPE_REAL:
                        expr = oberon_make_real_typed(ctx, (bits <= 32) ? (-FLT_MAX) : (-DBL_MAX), arg -> result);
                        break;
                case OBERON_TYPE_SET:
                        expr = oberon_make_integer(ctx, 0);
                        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(!oberon_is_type_expr(arg))
        {
                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_make_integer(ctx, powl(2, bits - 1) - 1);
                        break;
                case OBERON_TYPE_BOOLEAN:
                        expr = oberon_make_boolean(ctx, true);
                        break;
                case OBERON_TYPE_CHAR:
                        expr = oberon_make_char(ctx, powl(2, bits) - 1);
                        break;
                case OBERON_TYPE_REAL:
                        expr = oberon_make_real_typed(ctx, (bits <= 32) ? (FLT_MAX) : (DBL_MAX), arg -> result);
                        break;
                case OBERON_TYPE_SET:
                        expr = oberon_make_integer(ctx, bits);
                        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(!oberon_is_type_expr(arg))
        {
                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:
                case OBERON_TYPE_CHAR:
                case OBERON_TYPE_SET:
                        size = type -> size;
                        break;
                default:
                        oberon_error(ctx, "TODO SIZE");
                        break;
        }

        expr = oberon_make_integer(ctx, size);
        return expr;
}

static oberon_expr_t *
oberon_make_abs_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_number_type(arg -> result))
        {
                oberon_error(ctx, "ABS accepts only numbers");
        }

        oberon_expr_t * expr;
        if(oberon_is_const(arg))
        {
                if(oberon_is_real_type(arg -> result))
                {
                        double x = arg -> item.real;
                        expr = oberon_make_real(ctx, fabsl(x), arg -> result);
                }
                else
                {
                        int64_t x = arg -> item.integer;
                        expr = oberon_make_integer(ctx, llabs(x));
                }
        }
        else
        {
                expr = oberon_new_operator(OP_ABS, arg -> result, arg, NULL);
        }
        return expr;
}

static void
oberon_make_inc_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 * dst;
        dst = list_args;
        oberon_check_dst(ctx, dst);

        if(!oberon_is_integer_type(dst -> result))
        {
                oberon_error(ctx, "expect integer");
        }

        oberon_expr_t * step;
        if(num_args == 2)
        {
                step = list_args -> next;
                oberon_check_src(ctx, step);
                if(!oberon_is_integer_type(step -> result))
                {
                        oberon_error(ctx, "expect integer");
                }
        }
        else
        {
                step = oberon_make_integer(ctx, 1);
        }

        oberon_expr_t * expr;
        expr = oberon_make_bin_op(ctx, PLUS, dst, step);
        oberon_assign(ctx, expr, dst);
}

static void
oberon_make_incl_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 * dst;
        dst = list_args;
        oberon_check_dst(ctx, dst);

        if(!oberon_is_set_type(dst -> result))
        {
                oberon_error(ctx, "expect integer");
        }

        oberon_expr_t * x;
        x = list_args -> next;
        oberon_check_src(ctx, x);
        
        if(!oberon_is_integer_type(x -> result))
        {
                oberon_error(ctx, "expect integer");
        }

        oberon_expr_t * expr;
        expr = oberon_make_bin_op(ctx, PLUS, dst, oberon_new_operator(OP_RANGE, dst -> result, x, NULL));
        oberon_assign(ctx, expr, dst);
}

static void
oberon_make_excl_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 * dst;
        dst = list_args;
        oberon_check_dst(ctx, dst);

        if(!oberon_is_set_type(dst -> result))
        {
                oberon_error(ctx, "expect integer");
        }

        oberon_expr_t * x;
        x = list_args -> next;
        oberon_check_src(ctx, x);
        
        if(!oberon_is_integer_type(x -> result))
        {
                oberon_error(ctx, "expect integer");
        }

        oberon_expr_t * expr;
        expr = oberon_make_bin_op(ctx, MINUS, dst, oberon_new_operator(OP_RANGE, dst -> result, x, NULL));
        oberon_assign(ctx, expr, dst);
}

static void
oberon_make_dec_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 * dst;
        dst = list_args;
        oberon_check_dst(ctx, dst);

        if(!oberon_is_integer_type(dst -> result))
        {
                oberon_error(ctx, "expect integer");
        }

        oberon_expr_t * step;
        if(num_args == 2)
        {
                step = list_args -> next;
                oberon_check_src(ctx, step);
                if(!oberon_is_integer_type(step -> result))
                {
                        oberon_error(ctx, "expect integer");
                }
        }
        else
        {
                step = oberon_make_integer(ctx, 1);
        }

        oberon_expr_t * expr;
        expr = oberon_make_bin_op(ctx, MINUS, dst, step);
        oberon_assign(ctx, expr, dst);
}

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");
        }

        oberon_expr_t * dst;
        dst = list_args;
        oberon_check_dst(ctx, dst);

        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;

        int max_args = 1;
        if(type -> class == OBERON_TYPE_ARRAY)
        {
                if(type -> size == 0)
                {
                        oberon_type_t * x = type;
                        while(x -> class == OBERON_TYPE_ARRAY)
                        {
                                if(x -> size == 0)
                                {
                                        max_args += 1;
                                }
                                x = x -> base;
                        }
                }

                if(num_args < max_args)
                {
                        oberon_error(ctx, "too few arguments");
                }

                if(num_args > max_args)
                {
                        oberon_error(ctx, "too mach arguments");
                }

                int num_sizes = max_args - 1;
                oberon_expr_t * size_list = list_args -> next;

                oberon_expr_t * arg = size_list;
                for(int i = 0; i < max_args - 1; i++)
                {
                        oberon_check_src(ctx, arg);
                        if(arg -> result -> class != OBERON_TYPE_INTEGER)
                        {
                                oberon_error(ctx, "size must be integer");
                        }
                        arg = arg -> next;
                }

                src -> item.num_args = num_sizes;
                src -> item.args = size_list;
        }
        else if(type -> class != OBERON_TYPE_RECORD)
        {
                oberon_error(ctx, "oberon_make_new_call: wat");
        }

        if(num_args > max_args)
        {
                oberon_error(ctx, "too mach arguments");
        }

        oberon_assign(ctx, src, dst);
}

static void
oberon_make_copy_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 * src;
        src = list_args;
        oberon_check_src(ctx, src);

        oberon_expr_t * dst;
        dst = list_args -> next;
        oberon_check_dst(ctx, dst);

        if(!oberon_is_string_type(src -> result) && !oberon_is_array_of_char_type(src -> result))
        {
                oberon_error(ctx, "source must be string or array of char");
        }

        if(!oberon_is_array_of_char_type(dst -> result))
        {
                oberon_error(ctx, "dst must be array of char");
        }

        oberon_generate_copy(ctx, src, dst);
}

static void
oberon_make_assert_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 * cond;
        cond = list_args;
        oberon_check_src(ctx, cond);

        if(!oberon_is_boolean_type(cond -> result))
        {
                oberon_error(ctx, "expected boolean");
        }

        if(num_args == 1)
        {
                oberon_generate_assert(ctx, cond);
        }
        else
        {
                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);

                oberon_generate_assert_n(ctx, cond, num -> item.integer);
        }
}

static void
oberon_make_halt_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 * num;
        num = list_args;
        oberon_check_src(ctx, num);

        if(num -> result -> class != OBERON_TYPE_INTEGER)
        {
                oberon_error(ctx, "expected integer");
        }

        oberon_check_const(ctx, num);

        oberon_generate_halt(ctx, num -> item.integer);
}

static oberon_expr_t *
oberon_make_ash_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);
        if(arg1 -> result -> class != OBERON_TYPE_INTEGER)
        {
                oberon_error(ctx, "expected integer");
        }

        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))
        {
                int64_t x = arg1 -> item.integer;
                int64_t y = arg2 -> item.integer;
                int64_t v = (y > 0) ? (x << y) : (x >> labs(y));
                expr = oberon_make_integer(ctx, v);
        }
        else
        {
                expr = oberon_new_operator(OP_ASH, arg1 -> result, arg1, arg2);
        }

        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_rot_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 = 0;
                if(y > 0)
                {
                        v = (x << y) | (x >> (64 - y));
                }
                else
                {
                        y = labs(y);
                        v = (x >> y) | (x << (64 - 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_ROT, 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)
{
        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_char(ctx, toupper(arg -> item.integer));
        }
        else
        {
                expr = oberon_new_operator(OP_CAP, arg -> result, arg, NULL);
        }

        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_is_string_of_one(arg))
        {
                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 -> shortint_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)
{
        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;
        expr = oberon_make_bin_op(ctx, MOD, arg, oberon_make_integer(ctx, 2));
        expr = oberon_make_bin_op(ctx, EQUAL, expr, oberon_make_integer(ctx, 1));
        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)
{
        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(arg -> result -> shorter == NULL)
        {
                oberon_error(ctx, "already shorter");
        }

        oberon_expr_t * expr;
        expr = oberon_cast_expr(ctx, arg, arg -> result -> shorter);
        return expr;
}

static oberon_expr_t *
oberon_make_long_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(arg -> result -> longer == NULL)
        {
                oberon_error(ctx, "already longer");
        }

        oberon_expr_t * expr;
        expr = oberon_cast_expr(ctx, arg, arg -> result -> longer);
        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)
{
        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_object_t * constant;
        constant = oberon_define_object(ctx -> decl, name, OBERON_CLASS_CONST, true, false, false);
        oberon_check_const(ctx, expr);
        constant -> value = (oberon_item_t *) expr;
}

static void
register_default_types(oberon_context_t * ctx)
{
        ctx -> notype_type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);
        oberon_generator_init_type(ctx, ctx -> notype_type);

        ctx -> nil_type = oberon_new_type_ptr(OBERON_TYPE_NIL);
        oberon_generator_init_type(ctx, ctx -> nil_type);

        ctx -> string_type = oberon_new_type_string(1);
        oberon_generator_init_type(ctx, ctx -> string_type);

        ctx -> bool_type = oberon_new_type_boolean();
        oberon_generator_init_type(ctx, ctx -> bool_type);

        ctx -> char_type = oberon_new_type_char(1);
        oberon_generator_init_type(ctx, ctx -> char_type);

        ctx -> byte_type = oberon_new_type_integer(1);
        oberon_generator_init_type(ctx, ctx -> byte_type);

        ctx -> shortint_type = oberon_new_type_integer(2);
        oberon_generator_init_type(ctx, ctx -> shortint_type);

        ctx -> int_type = oberon_new_type_integer(4);
        oberon_generator_init_type(ctx, ctx -> int_type);

        ctx -> longint_type = oberon_new_type_integer(8);
        oberon_generator_init_type(ctx, ctx -> longint_type);

        ctx -> real_type = oberon_new_type_real(4);
        oberon_generator_init_type(ctx, ctx -> real_type);

        ctx -> longreal_type = oberon_new_type_real(8);
        oberon_generator_init_type(ctx, ctx -> longreal_type);

        ctx -> set_type = oberon_new_type_set(4);
        oberon_generator_init_type(ctx, ctx -> set_type);

        ctx -> system_byte_type = oberon_new_type_ptr(OBERON_TYPE_SYSTEM_BYTE);
        oberon_generator_init_type(ctx, ctx -> system_byte_type);

        ctx -> system_ptr_type = oberon_new_type_ptr(OBERON_TYPE_SYSTEM_PTR);
        oberon_generator_init_type(ctx, ctx -> system_ptr_type);

        /* LONG / SHORT support */
        ctx -> byte_type -> shorter = NULL;
        ctx -> byte_type -> longer = ctx -> shortint_type;

        ctx -> shortint_type -> shorter = ctx -> byte_type;
        ctx -> shortint_type -> longer = ctx -> int_type;

        ctx -> int_type -> shorter = ctx -> shortint_type;
        ctx -> int_type -> longer = ctx -> longint_type;

        ctx -> longint_type -> shorter = ctx -> int_type;
        ctx -> longint_type -> longer = NULL;

        ctx -> real_type -> shorter = NULL;
        ctx -> real_type -> longer = ctx -> longreal_type;

        ctx -> longreal_type -> shorter = ctx -> real_type;
        ctx -> longreal_type -> longer = NULL;
}

static void
oberon_new_intrinsic(oberon_context_t * ctx, char * name, GenerateFuncCallback f, GenerateProcCallback p)
{
        oberon_object_t * proc;
        proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, true, false, false);
        proc -> type = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE);
        proc -> type -> sysproc = true;
        proc -> type -> genfunc = f;
        proc -> type -> genproc = p;
}

static void oberon_new_intrinsic_type(oberon_context_t * ctx, char * name, oberon_type_t * type)
{
        oberon_object_t * id;
        id = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, true, false, false);
        id -> type = type;
}

static void
oberon_begin_intrinsic_module(oberon_context_t * ctx, char * name, oberon_module_t ** m)
{
        oberon_scope_t * module_scope;
        module_scope = oberon_open_scope(ctx);

        oberon_module_t * module;
        module = GC_MALLOC(sizeof *module);
        memset(module, 0, sizeof *module);
        module -> name = name;
        module -> intrinsic = true;
        module -> decl = module_scope;
        module -> next = ctx -> module_list;

        ctx -> mod = module;
        ctx -> module_list = module;

        *m = module;
}

static void
oberon_end_intrinsic_module(oberon_context_t * ctx, oberon_module_t * m)
{
        oberon_close_scope(m -> decl);
        m -> ready = true;
        ctx -> mod = NULL;
}

oberon_context_t *
oberon_create_context(ModuleImportCallback import_module)
{
        oberon_context_t * ctx = GC_MALLOC(sizeof *ctx);
        memset(ctx, 0, sizeof *ctx);

        oberon_scope_t * world_scope;
        world_scope = oberon_open_scope(ctx);
        ctx -> world_scope = world_scope;

        ctx -> import_module = import_module;

        oberon_generator_init_context(ctx);

        /* Types */
        register_default_types(ctx);

        /* Constants */
        oberon_new_const(ctx, "TRUE", oberon_make_boolean(ctx, true));
        oberon_new_const(ctx, "FALSE", oberon_make_boolean(ctx, false));

        /* Types */
        oberon_new_intrinsic_type(ctx, "BOOLEAN", ctx -> bool_type);
        oberon_new_intrinsic_type(ctx, "CHAR", ctx -> char_type);
        oberon_new_intrinsic_type(ctx, "SHORTINT", ctx -> byte_type);
        oberon_new_intrinsic_type(ctx, "INTEGER", ctx -> shortint_type);
        oberon_new_intrinsic_type(ctx, "LONGINT", ctx -> int_type);
        oberon_new_intrinsic_type(ctx, "HUGEINT", ctx -> longint_type);
        oberon_new_intrinsic_type(ctx, "REAL", ctx -> real_type);
        oberon_new_intrinsic_type(ctx, "LONGREAL", ctx -> longreal_type);
        oberon_new_intrinsic_type(ctx, "SET", ctx -> set_type);

        /* Functions */
        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, "LONG", oberon_make_long_call, NULL);
        oberon_new_intrinsic(ctx, "MAX", oberon_make_max_call, NULL);
        oberon_new_intrinsic(ctx, "MIN", oberon_make_min_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, "SHORT", oberon_make_short_call, NULL);
        oberon_new_intrinsic(ctx, "SIZE", oberon_make_size_call, NULL);

        /* Procedures */
        oberon_new_intrinsic(ctx, "ASSERT", NULL, oberon_make_assert_call);
        oberon_new_intrinsic(ctx, "COPY", NULL, oberon_make_copy_call);
        oberon_new_intrinsic(ctx, "DEC", NULL, oberon_make_dec_call);
        oberon_new_intrinsic(ctx, "EXCL", NULL, oberon_make_excl_call);
        oberon_new_intrinsic(ctx, "HALT", NULL, oberon_make_halt_call);
        oberon_new_intrinsic(ctx, "INC", NULL, oberon_make_inc_call);
        oberon_new_intrinsic(ctx, "INCL", NULL, oberon_make_incl_call);
        oberon_new_intrinsic(ctx, "NEW", NULL, oberon_make_new_call);

        /* MODULE SYSTEM */
        oberon_begin_intrinsic_module(ctx, "SYSTEM", &ctx -> system_module);

                /* Types */
                oberon_new_intrinsic_type(ctx, "BYTE", ctx -> system_byte_type);
                oberon_new_intrinsic_type(ctx, "PTR", ctx -> system_ptr_type);
                oberon_new_intrinsic_type(ctx, "INT8", ctx -> byte_type);
                oberon_new_intrinsic_type(ctx, "INT16", ctx -> shortint_type);
                oberon_new_intrinsic_type(ctx, "INT32", ctx -> int_type);
                oberon_new_intrinsic_type(ctx, "INT64", ctx -> longint_type);
                oberon_new_intrinsic_type(ctx, "SET32", ctx -> set_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);

        return ctx;
}

void
oberon_destroy_context(oberon_context_t * ctx)
{
        oberon_generator_destroy_context(ctx);
}

oberon_module_t *
oberon_compile_module(oberon_context_t * ctx, oberon_scanner_t * s)
{
        const char * code = ctx -> code;
        int code_index = ctx -> code_index;
        oberon_location_t loc = ctx -> loc;
        oberon_location_t xloc = ctx -> xloc;
        char c = ctx -> c;
        int token = ctx -> token;
        char * string = ctx -> string;
        int integer = ctx -> integer;
        int real = ctx -> real;
        bool longmode = ctx -> longmode;
        oberon_scope_t * decl = ctx -> decl;
        oberon_module_t * mod = ctx -> mod;

        oberon_scope_t * module_scope;
        module_scope = oberon_open_scope(ctx);

        oberon_module_t * module;
        module = GC_MALLOC(sizeof *module);
        memset(module, 0, sizeof *module);
        module -> decl = module_scope;
        module -> next = ctx -> module_list;

        ctx -> mod = module;
        ctx -> module_list = module;

        oberon_init_scaner(ctx, s);
        oberon_parse_module(ctx);

        module -> ready = 1;

        ctx -> code = code;
        ctx -> code_index = code_index;
        ctx -> loc = loc;
        ctx -> xloc = xloc;
        ctx -> c = c;
        ctx -> token = token;
        ctx -> string = string;
        ctx -> integer = integer;
        ctx -> real = real;
        ctx -> longmode = longmode;
        ctx -> decl = decl;
        ctx -> mod = mod;

        return module;
}