Добавлена функция SYSTEM.LSH

[dsw-obn.git] / src / oberon-type-compat.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 "../include/oberon.h"

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

bool
oberon_is_array_type(oberon_type_t * t)
{
        return t -> class == OBERON_TYPE_ARRAY;
}

bool
oberon_is_open_array(oberon_type_t * t)
{
        /* Открытые массивы всегда размером 0 */

        return oberon_is_array_type(t) && (t -> size == 0);
}

bool
oberon_is_real_type(oberon_type_t * t)
{
        return t -> class == OBERON_TYPE_REAL;
}

bool
oberon_is_integer_type(oberon_type_t * t)
{
        return t -> class == OBERON_TYPE_INTEGER;
}

bool
oberon_is_system_byte_type(oberon_type_t * t)
{
        return t -> class == OBERON_TYPE_SYSTEM_BYTE;
}

bool
oberon_is_system_ptr_type(oberon_type_t * t)
{
        return t -> class == OBERON_TYPE_SYSTEM_PTR;
}

bool
oberon_is_byte_type(oberon_type_t * t)
{
        return oberon_is_integer_type(t) && t -> size == 1;
}

bool
oberon_is_number_type(oberon_type_t * t)
{
        return oberon_is_integer_type(t)
                || oberon_is_real_type(t);
}

bool
oberon_is_char_type(oberon_type_t * t)
{
        return t -> class == OBERON_TYPE_CHAR;
}

bool
oberon_is_set_type(oberon_type_t * t)
{
        return t -> class == OBERON_TYPE_SET;
}

bool
oberon_is_string_type(oberon_type_t * t)
{
        return t -> class == OBERON_TYPE_STRING;
}

bool
oberon_is_procedure_type(oberon_type_t * t)
{
        return t -> class == OBERON_TYPE_PROCEDURE;
}

bool
oberon_is_record_type(oberon_type_t * t)
{
        return t -> class == OBERON_TYPE_RECORD;
}

bool
oberon_is_pointer_type(oberon_type_t * t)
{
        return t -> class == OBERON_TYPE_POINTER;
}

bool
oberon_is_pointer_to_record(oberon_type_t * t)
{
        return oberon_is_pointer_type(t) && oberon_is_record_type(t -> base);
}

bool
oberon_is_boolean_type(oberon_type_t * t)
{
        return t -> class == OBERON_TYPE_BOOLEAN;
}

bool
oberon_is_array_of_char_type(oberon_type_t * t)
{
        return oberon_is_array_type(t) && oberon_is_char_type(t -> base);
}

bool
oberon_is_array_of_system_byte_type(oberon_type_t * t)
{
        return oberon_is_array_type(t) && oberon_is_system_byte_type(t -> base);
}

bool
oberon_is_nil_type(oberon_type_t * t)
{
        return t -> class == OBERON_TYPE_NIL;
}

bool
oberon_is_type_expr(oberon_expr_t * e)
{
        return (e -> is_item) && (e -> item.mode == MODE_TYPE);
}



bool
oberon_is_some_types(oberon_type_t * a, oberon_type_t * b)
{
        /* Две переменные a и b с типами Ta и Tb имеют одинаковый тип, если */
        /*   1. Ta и Tb оба обозначены одним и тем же идентификатором типа, или */
        /*   2. Ta объявлен равным Tb в объявлении типа вида Ta = Tb, или  */
        /*   3. a и b появляются в одном и том же списке идентификаторов переменных, полей записи */
        /*        или объявлении формальных параметров и не являются открытыми массивами. */

        return (a == b) && !oberon_is_open_array(a) && !oberon_is_open_array(b);
}

bool
oberon_is_some_procedure_signatures(oberon_type_t * a, oberon_type_t * b)
{
        /* Два списка формальных параметров совпадают если */
        /*  1. они имеют одинаковое количество параметров, и */
        /*  2. они имеют или одинаковый тип результата функции или не имеют никакого, и */
        /*  3. параметры в соответствующих позициях имеют равные типы, и */
        /*  4. параметры в соответствующих позициях - оба или параметры-значения */
        /*       или параметры-переменные. */

        if(a -> num_decl != b -> num_decl)
        {
                return false;
        }

        if(!oberon_is_some_types(a -> base, b -> base))
        {
                return false;
        }

        int num = a -> num_decl;
        oberon_object_t * va = a -> decl;
        oberon_object_t * vb = b -> decl;
        for(int i = 0; i < num; i++)
        {
                if(!oberon_is_equal_types(va -> type, vb -> type))
                {
                        return false;
                }

                if(va -> class != vb -> class)
                {
                        return false;
                }

                va = va -> next;
                vb = vb -> next;
        }

        return true;
}

bool
oberon_is_equal_types(oberon_type_t * a, oberon_type_t * b)
{
        /* Два типа Ta, и Tb равны, если */
        /*  1. Ta и Tb - одинаковые типы, или */
        /*  2. Ta и Tb - типы открытый массив с равными типами элементов, или */
        /*  3. Ta и Tb - процедурные типы, чьи списки формальных параметров совпадают. */

        return oberon_is_some_types(a, b)
                || (oberon_is_open_array(a) && oberon_is_open_array(b) && oberon_is_some_types(a -> base, b -> base))
                || (oberon_is_procedure_type(a) && oberon_is_procedure_type(b) && oberon_is_some_procedure_signatures(a, b));
}

bool
oberon_incluses_type(oberon_type_t * a, oberon_type_t * b)
{
        /* a поглощает b */
        /* LONGREAL >= REAL >= LONGINT >= INTEGER >= SHORTINT  */

/*
        printf("oberon_incluses_type: a %i %i\n", a -> class, a -> size);
        printf("oberon_incluses_type: b %i %i\n", b -> class, b -> size);
*/

        if(a -> class == OBERON_TYPE_REAL)
        {
                if(b -> class == OBERON_TYPE_INTEGER)
                {
                        return true;
                }
                else if(b -> class == OBERON_TYPE_REAL)
                {
                        return (a -> size >= b -> size);
                }
        }
        else if(a -> class == OBERON_TYPE_INTEGER)
        {
                if(b -> class == OBERON_TYPE_INTEGER)
                {
                        return (a -> size >= b -> size);
                }
        }

        return false;
}

bool
oberon_extension_of(oberon_type_t * ext, oberon_type_t * rec)
{
        /* Тип Tb есть расширение типа Ta (Ta есть базовый тип Tb) если */
        /*  1. Ta и Tb - одинаковые типы, или */
        /*  2. Tb - непосредственное расширение типа, являющегося расширением Ta */
        /*  Если Pa = POINTER TO Ta и Pb = POINTER TO Tb, то Pb есть расширение Pa */
        /*    (Pa есть базовый тип Pb), если Tb есть расширение Ta. */

        if(ext -> class == OBERON_TYPE_POINTER && rec -> class == OBERON_TYPE_POINTER)
        {
                ext = ext -> base;
                rec = rec -> base;
        }

        if(ext -> class != OBERON_TYPE_RECORD || rec -> class != OBERON_TYPE_RECORD)
        {
                return false;
        }

        if(oberon_is_some_types(ext, rec))
        {
                return true;
        }

        while(rec -> base)
        {
                if(oberon_is_some_types(ext, rec -> base))
                {
                        return true;
                }               
                rec = rec -> base;
        }

        return false;
}

bool
oberon_is_const_string(oberon_expr_t * e)
{
        return e -> result -> class == OBERON_TYPE_STRING && e -> is_item && e -> item.mode == MODE_STRING;
}

bool
oberon_is_assignment_compatible_expressions(oberon_expr_t * e, oberon_type_t * Tv)
{
        /* Выражение e типа Te совместимо по присваиванию с переменной v типа Tv, */
        /* если выполнено одно из следующих условий: */
        /*   1. Te и Tv - одинаковые типы; */
        /*   2. Te и Tv - числовые типы и Tv поглощает Te; */
        /*   3. Te и Tv - типы запись, Te есть расширение Tv, а v имеет динамический тип Tv; */
        /*   4. Te и Tv - типы указатель и Te - расширение Tv; */
        /*   5. Tv - тип указатель или процедурный тип, а e - NIL; */
        /*   6. Tv - ARRAY n OF CHAR, e - строковая константа из m символов и m < n; */
        /*   7. Tv - процедурный тип, а e - имя процедуры, чьи формальные параметры */
        /*      совпадают с параметрами Tv. */
        /* Доп: Tv - символ, е - строковая константа из одного символа */

        /* SYSTEM: переменным типа BYTE можно присваивать значения переменных типа CHAR или SHORTINT. */
        /* SYSTEM: Переменным типа PTR могут быть присвоены значения переменных-указателей любого типа. */

        oberon_type_t * Te = e -> result;

        return oberon_is_some_types(Te, Tv)
                || (oberon_is_number_type(Te) && oberon_is_number_type(Tv) && oberon_incluses_type(Tv, Te))
                || (oberon_is_record_type(Te) && oberon_is_record_type(Tv) && oberon_extension_of(Tv, Te))
                || (oberon_is_pointer_type(Te) && oberon_is_pointer_type(Tv) && oberon_extension_of(Tv, Te))
                || ((oberon_is_pointer_type(Tv) || oberon_is_procedure_type(Tv)) && oberon_is_nil_type(Te))
                || (oberon_is_array_of_char_type(Tv) && !oberon_is_open_array(Tv) && oberon_is_const_string(e) && (strlen(e -> item.string) < Tv -> size))
                || (oberon_is_procedure_type(Tv) && e -> is_item && e -> item.var -> class == OBERON_CLASS_PROC && oberon_is_some_procedure_signatures(Tv, e -> result))
                || (oberon_is_char_type(Tv) && oberon_is_const_string(e) && strlen(e -> item.string) == 1)
                || (oberon_is_system_byte_type(Tv) && (oberon_is_char_type(Te) || oberon_is_byte_type(Te)))
                || (oberon_is_system_ptr_type(Tv) && oberon_is_pointer_type(Te));
}

static bool
oberon_is_compatible_arrays_types(oberon_type_t * Tf, oberon_type_t * Ta)
{
        /* Фактический параметр a типа Ta является совместимым массивом для формального параметра f типа Tf если */
        /*   1. Tf и Ta - одинаковые типы или */
        /*   2. Tf - открытый массив, Ta - любой массив, а типы их элементов - совместимые массивы или */
        /*   3. f - параметр-значение типа ARRAY OF CHAR, а фактический параметр a - строка. */

        return oberon_is_some_types(Tf, Ta)
                || (oberon_is_open_array(Tf) && oberon_is_array_type(Ta) && oberon_is_compatible_arrays_types(Tf -> base, Ta -> base));
}

bool
oberon_is_compatible_arrays(oberon_object_t * f, oberon_expr_t * a)
{
        oberon_type_t * Tf = f -> type;
        oberon_type_t * Ta = a -> result;

        return oberon_is_compatible_arrays_types(Tf, Ta)
                || (oberon_is_array_of_char_type(Tf) && oberon_is_const_string(a));
}

void
oberon_check_compatible_arrays(oberon_context_t * ctx, oberon_object_t * f, oberon_expr_t * a)
{
        if(!oberon_is_compatible_arrays(f, a))
        {
                oberon_error(ctx, "incompatible types");
        }
}

bool
oberon_is_compatible_bin_expr_types(int token, oberon_type_t * a, oberon_type_t * b)
{
        if(token == PLUS || token == MINUS || token == STAR || token == SLASH)
        {
                if(oberon_is_number_type(a) && oberon_is_number_type(b))
                {
                        return true;
                }
                else if(oberon_is_set_type(a) && oberon_is_set_type(b))
                {
                        return true;
                }
        }
        else if(token == DIV || token == MOD)
        {
                if(oberon_is_integer_type(a) && oberon_is_integer_type(b))
                {
                        return true;
                }
        }
        else if(token == OR || token == AND)
        {
                if(oberon_is_boolean_type(a) && oberon_is_boolean_type(b))
                {
                        return true;
                }
        }
        else if(token == EQUAL || token == NEQ)
        {
                if(oberon_is_number_type(a) && oberon_is_number_type(b))
                {
                        return true;
                }
                else if(oberon_is_char_type(a) && oberon_is_char_type(b))
                {
                        return true;
                }
                else if((oberon_is_array_of_char_type(a) || oberon_is_string_type(a))
                        && (oberon_is_array_of_char_type(b) || oberon_is_string_type(b)))
                {
                        return true;
                }
                else if(oberon_is_boolean_type(a) && oberon_is_boolean_type(b))
                {
                        return true;
                }
                else if(oberon_is_set_type(a) && oberon_is_set_type(b))
                {
                        return true;
                }
                else if((oberon_is_nil_type(a) || oberon_is_pointer_to_record(a) || oberon_is_procedure_type(a))
                        && (oberon_is_nil_type(b) || oberon_is_pointer_to_record(b) || oberon_is_procedure_type(b)))
                {
                        return true;
                }
        }
        else if(token == LESS || token == LEQ || token == GREAT || token == GEQ)
        {
                if(oberon_is_number_type(a) && oberon_is_number_type(b))
                {
                        return true;
                }
                else if(oberon_is_char_type(a) && oberon_is_char_type(b))
                {
                        return true;
                }
                else if((oberon_is_array_of_char_type(a) || oberon_is_string_type(a))
                        && (oberon_is_array_of_char_type(b) || oberon_is_string_type(b)))
                {
                        return true;
                }
        }
        else if(token == IN)
        {
                if(oberon_is_integer_type(a) && oberon_is_set_type(b))
                {
                        return true;
                }
        }
        else if(token == IS)
        {
                if(oberon_extension_of(a, b))
                {
                        return true;
                }
        }

        return false;
}

bool
oberon_is_compatible_var_param(oberon_type_t * Tf, oberon_type_t * Ta)
{
        /* Пусть Tf - тип формального параметра f (не открытого массива) */
        /* и Ta - тип соответствующего фактического параметра a. */
        /* Для параметров-переменных Ta и Tf должны быть одинаковыми типами */
        /* или Tf должен быть типом запись, а Ta - расширением Tf. */

        /* SYSTEM: Если формальный параметр-переменная имеет тип ARRAY OF BYTE, */
        /* то соответствующий фактический параметр может иметь любой тип. */
        /* SYSTEM: Если формальный параметр-переменная имеет тип PTR, */
        /* фактический параметр может быть указателем любого типа. */

        return oberon_is_some_types(Tf, Ta)
                || (oberon_is_record_type(Tf) && oberon_extension_of(Ta, Tf))
                || (oberon_is_array_of_system_byte_type(Tf))
                || (oberon_is_system_ptr_type(Tf));
}

void
oberon_check_compatible_var_param(oberon_context_t * ctx, oberon_type_t * Tf, oberon_type_t * Ta)
{
        if(!oberon_is_compatible_var_param(Tf, Ta))
        {
                oberon_error(ctx, "incompatible types");
        }
}

void
oberon_check_type_expr(oberon_context_t * ctx, oberon_expr_t * e)
{
        if(!oberon_is_type_expr(e))
        {
                oberon_error(ctx, "expected type");
        }
}

void
oberon_check_compatible_bin_expr_types(oberon_context_t * ctx, int token, oberon_type_t * a, oberon_type_t * b)
{
        if(!oberon_is_compatible_bin_expr_types(token, a, b))
        {
                oberon_error(ctx, "incompatibe expression types");
        }
}

void
oberon_check_assignment_compatible(oberon_context_t * ctx, oberon_expr_t * e, oberon_type_t * Tv)
{
        if(!oberon_is_assignment_compatible_expressions(e, Tv))
        {
                oberon_error(ctx, "incompatible types");
        }
}

void
oberon_check_extension_of(oberon_context_t * ctx, oberon_type_t * ext, oberon_type_t * rec)
{
        if(!oberon_extension_of(ext, rec))
        {
                oberon_error(ctx, "not extension");
        }
}

oberon_type_t *
oberon_get_longer_type(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b)
{
        if(oberon_incluses_type(a, b))
        {
                return a;
        }
        else
        {
                return b;
        }
}

oberon_type_t *
oberon_get_longer_real_type(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b)
{
        oberon_type_t * result = oberon_get_longer_type(ctx, a, b);
        if(oberon_is_integer_type(result))
        {
                return ctx -> real_type;
        }
        else
        {
                return result;
        }
}