From d25fb653bfe19a696d3f53abd784d32ba2d3ee03 Mon Sep 17 00:00:00 2001 From: DeaDDooMER Date: Sat, 12 Aug 2017 15:40:26 +0300 Subject: [PATCH] =?utf8?q?=D0=9F=D1=80=D0=B0=D0=B2=D0=B8=D0=BB=D0=B0=20?= =?utf8?q?=D1=81=D0=BE=D0=B2=D0=BC=D0=B5=D1=81=D1=82=D0=B8=D0=BC=D0=BE?= =?utf8?q?=D1=81=D1=82=D0=B8=20=D1=82=D0=B8=D0=BF=D0=BE=D0=B2=20=D0=BF?= =?utf8?q?=D1=80=D0=B8=D0=B2=D0=B5=D0=B4=D0=B5=D0=BD=D1=8B=20=D0=B2=20?= =?utf8?q?=D1=81=D0=BE=D0=BE=D1=82=D0=B2=D0=B5=D1=82=D1=81=D1=82=D0=B2?= =?utf8?q?=D0=B8=D0=B5=20=D1=81=D0=BE=20=D1=81=D1=82=D1=80=D0=B0=D0=BD?= =?utf8?q?=D0=B4=D0=B0=D1=82=D1=80=D0=BE=D0=BC?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- Test.obn | 24 +- Test5.obn | 5 +- Test8.obn | 24 ++ Test9.obn | 18 + notes | 2 +- obn-run-tests.sh | 10 +- src/backends/jvm/generator-jvm.c | 7 +- src/oberon-common.c | 22 ++ src/oberon-common.h | 71 ++++ src/oberon-type-compat.c | 516 +++++++++++++++++++++++++++ src/oberon-type-compat.h | 102 ++++++ src/oberon.c | 591 ++++--------------------------- 12 files changed, 844 insertions(+), 548 deletions(-) create mode 100644 Test8.obn create mode 100644 Test9.obn create mode 100644 src/oberon-common.c create mode 100644 src/oberon-common.h create mode 100644 src/oberon-type-compat.c create mode 100644 src/oberon-type-compat.h diff --git a/Test.obn b/Test.obn index e044594..6713226 100644 --- a/Test.obn +++ b/Test.obn @@ -1,23 +1,13 @@ MODULE Test; -IMPORT Out; - -TYPE - P1 = POINTER TO R1; - P2 = POINTER TO R2; - P3 = POINTER TO R3; - - R1 = RECORD END; - R2 = RECORD (R1) END; - R3 = RECORD (R2) END; - VAR - r : P1; + i : INTEGER; + f : REAL; + d : LONGREAL; BEGIN - NEW(r); - Out.Open; - WITH r : P1 DO - Out.String("R1"); Out.Ln; - END; + i := 5 DIV 3; + f := 5 / 3; + d := 5 / 3.0; + d := 5 / 3.0D0; END Test. diff --git a/Test5.obn b/Test5.obn index 248d688..c92a398 100644 --- a/Test5.obn +++ b/Test5.obn @@ -7,6 +7,7 @@ TYPE P1 = POINTER TO R1; P2 = POINTER TO R2; + P3 = POINTER TO R3; VAR a : R1; @@ -14,9 +15,11 @@ VAR c : R3; p1 : P1; p2 : P2; + p3 : P3; BEGIN a := b; p2 := p1(P2); - p1 := p2(P2); + p1 := p2; + p3 := p3; END Test5. diff --git a/Test8.obn b/Test8.obn new file mode 100644 index 0000000..c81f6fc --- /dev/null +++ b/Test8.obn @@ -0,0 +1,24 @@ +MODULE Test8; + +VAR + s : SHORTINT; + i : INTEGER; + j : LONGINT; + f : REAL; + d : LONGREAL; + +BEGIN + s := 127; + s := s; + i := s; + i := i; + j := i; + j := j; + f := j; + f := f; + d := f; + d := d; +END Test8. + +Проверка поглощения типов. +LONGREAL >= REAL >= LONGINT >= INTEGER >= SHORTINT diff --git a/Test9.obn b/Test9.obn new file mode 100644 index 0000000..2a40b73 --- /dev/null +++ b/Test9.obn @@ -0,0 +1,18 @@ +MODULE Test9; + +VAR + i : INTEGER; + f : REAL; + d : LONGREAL; + x : SET; + +BEGIN + i := i + 1; + i := 5 DIV 3; + f := 5 / 3; + d := 5 / 3.0; + d := 5 / 3.0D0; + x := { 0..4 }; +END Test9. + +Проверка типов в операциях. diff --git a/notes b/notes index 7666610..31c1a4d 100644 --- a/notes +++ b/notes @@ -2,7 +2,6 @@ - Сделать нормальную проверку наличия RETURN. - Нужно проверить правила совместимости типов (Приложение A). -- Нет модуля SYSTEM - Нет функций ASH CAP CHR ENTIER LEN LONG ODD ORD SHORT - Нет процедур DEC EXCL INC INCL - Нет счёта строк / столбцов @@ -19,6 +18,7 @@ - Примеры -5 DIV 3 и -5 MOD 3 работают не так как в (8.2.2) Нужен другой тип округления? +- Нет модуля SYSTEM (на жабе он особо и не нужен) - Нужны средства создания биндингов. На данный момент реализуемо как заглушки для модулей. - Любая ошибка фатальна - Нет проверок переполнения в компилтайме. diff --git a/obn-run-tests.sh b/obn-run-tests.sh index 404c840..da13a65 100755 --- a/obn-run-tests.sh +++ b/obn-run-tests.sh @@ -8,10 +8,12 @@ maketest() if ! ./obn-compile.sh $1; then OK=0; echo "Test fail: $1 compile-time $?" fi - if ! ./obn-run.sh $1; then - OK=0; echo "Test fail: $1 run-time $?" + if [ $OK = 1 ]; then + if ! ./obn-run.sh $1; then + OK=0; echo "Test fail: $1 run-time $?" + fi fi - if [ $OK ]; then + if [ $OK = 1 ]; then echo "Test ok: $1" fi } @@ -34,3 +36,5 @@ maketest Test4 maketest Test5 maketest Test6 maketest Test7 +maketest Test8 +maketest Test9 diff --git a/src/backends/jvm/generator-jvm.c b/src/backends/jvm/generator-jvm.c index bb11231..21ad4db 100644 --- a/src/backends/jvm/generator-jvm.c +++ b/src/backends/jvm/generator-jvm.c @@ -1141,8 +1141,11 @@ jvm_generate_cast_type(gen_proc_t * p, oberon_type_t * from, oberon_type_t * to) { if(to -> class == OBERON_TYPE_RECORD || to -> class == OBERON_TYPE_POINTER) { - char * full_name = jvm_get_class_full_name(to); - jvm_generate(p, 1, 1, "checkcast %s", full_name); + if(to -> class == OBERON_TYPE_POINTER && to -> base -> class == OBERON_TYPE_RECORD) + { + char * full_name = jvm_get_class_full_name(to); + jvm_generate(p, 1, 1, "checkcast %s", full_name); + } } else { diff --git a/src/oberon-common.c b/src/oberon-common.c new file mode 100644 index 0000000..f1b6711 --- /dev/null +++ b/src/oberon-common.c @@ -0,0 +1,22 @@ +#include +#include +#include + +#include "../include/oberon.h" + +#include "oberon-internals.h" + +void +oberon_error(oberon_context_t * ctx, const char * fmt, ...) +{ + va_list ptr; + va_start(ptr, fmt); + fprintf(stderr, "error: "); + vfprintf(stderr, fmt, ptr); + fprintf(stderr, "\n"); + fprintf(stderr, " code_index = %i\n", ctx -> code_index); + fprintf(stderr, " c = %c\n", ctx -> c); + fprintf(stderr, " token = %i\n", ctx -> token); + va_end(ptr); + exit(1); +} diff --git a/src/oberon-common.h b/src/oberon-common.h new file mode 100644 index 0000000..ccbe6e1 --- /dev/null +++ b/src/oberon-common.h @@ -0,0 +1,71 @@ +enum { + EOF_ = 0, + IDENT, + MODULE, + SEMICOLON, + END, + DOT, + VAR, + COLON, + BEGIN, + ASSIGN, + INTEGER, + LPAREN, + RPAREN, + EQUAL, + NEQ, + LESS, + LEQ, + GREAT, + GEQ, + IN, + IS, + PLUS, + MINUS, + OR, + STAR, + SLASH, + DIV, + MOD, + AND, + NOT, + PROCEDURE, + COMMA, + RETURN, + CONST, + TYPE, + ARRAY, + OF, + LBRACK, + RBRACK, + RECORD, + POINTER, + TO, + UPARROW, + NIL, + IMPORT, + REAL, + CHAR, + STRING, + IF, + THEN, + ELSE, + ELSIF, + WHILE, + DO, + REPEAT, + UNTIL, + FOR, + BY, + LOOP, + EXIT, + LBRACE, + RBRACE, + DOTDOT, + CASE, + BAR, + WITH +}; + +void +oberon_error(oberon_context_t * ctx, const char * fmt, ...); diff --git a/src/oberon-type-compat.c b/src/oberon-type-compat.c new file mode 100644 index 0000000..6c3b698 --- /dev/null +++ b/src/oberon-type-compat.c @@ -0,0 +1,516 @@ +#include +#include +#include +#include +#include +#include +#include +#include + +#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_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_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 - символ, е - строковая константа из одного символа */ + + oberon_type_t * Te = e -> result; + +/* + printf("<<< oberon_is_assignment_compatible_expressions ===\n"); + printf(": Te -> class == %i\n", Te -> class); + printf(": Tv -> class == %i\n", Tv -> class); + printf(":: oberon_is_some_types(Te, Tv) == %i\n", oberon_is_some_types(Te, Tv)); + printf("::: oberon_is_number_type(Te) == %i\n", oberon_is_number_type(Te)); + printf("::: oberon_is_number_type(Tv) == %i\n", oberon_is_number_type(Tv)); + printf("::: oberon_incluses_type(Tv, Te) == %i\n", oberon_incluses_type(Tv, Te)); + printf(":::: oberon_is_record_type(Te) == %i\n", oberon_is_record_type(Te)); + printf(":::: oberon_is_record_type(Tv) == %i\n", oberon_is_record_type(Tv)); +// printf(":::: oberon_extension_of(Te, Tv) == %i\n", oberon_extension_of(Te, Tv)); + printf(":::: oberon_extension_of(Tv, Te) == %i\n", oberon_extension_of(Tv, Te)); + printf("=== oberon_is_assignment_compatible_expressions >>>\n"); +*/ + + 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); +} + +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. */ + + return oberon_is_some_types(Tf, Ta) + || (oberon_is_record_type(Tf) && oberon_extension_of(Ta, 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 if(oberon_incluses_type(b, a)) + { + return b; + } + else + { + oberon_error(ctx, "oberon_get_longer_type: error"); + return NULL; + } +} + +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 if(oberon_is_real_type(result)) + { + return result; + } + else + { + oberon_error(ctx, "oberon_get_longer_real_type: error"); + return NULL; + } +} diff --git a/src/oberon-type-compat.h b/src/oberon-type-compat.h new file mode 100644 index 0000000..b09dccc --- /dev/null +++ b/src/oberon-type-compat.h @@ -0,0 +1,102 @@ +bool +oberon_is_array_type(oberon_type_t * t); + +bool +oberon_is_open_array(oberon_type_t * t); + +bool +oberon_is_real_type(oberon_type_t * t); + +bool +oberon_is_integer_type(oberon_type_t * t); + +bool +oberon_is_number_type(oberon_type_t * t); + +bool +oberon_is_char_type(oberon_type_t * t); + +bool +oberon_is_set_type(oberon_type_t * t); + +bool +oberon_is_string_type(oberon_type_t * t); + +bool +oberon_is_procedure_type(oberon_type_t * t); + +bool +oberon_is_record_type(oberon_type_t * t); + +bool +oberon_is_pointer_type(oberon_type_t * t); + +bool +oberon_is_pointer_to_record(oberon_type_t * t); + +bool +oberon_is_boolean_type(oberon_type_t * t); + +bool +oberon_is_array_of_char_type(oberon_type_t * t); + + + +bool +oberon_is_some_types(oberon_type_t * a, oberon_type_t * b); + +bool +oberon_is_some_procedure_signatures(oberon_type_t * a, oberon_type_t * b); + +bool +oberon_is_equal_types(oberon_type_t * a, oberon_type_t * b); + +bool +oberon_incluses_type(oberon_type_t * from, oberon_type_t * to); + +bool +oberon_extension_of(oberon_type_t * ext, oberon_type_t * rec); + +bool +oberon_is_const_string(oberon_expr_t * e); + +bool +oberon_is_assignment_compatible_expressions(oberon_expr_t * e, oberon_type_t * Tv); + +bool +oberon_is_compatible_arrays(oberon_object_t * f, oberon_expr_t * a); + +bool +oberon_is_compatible_bin_expr_types(int token, oberon_type_t * a, oberon_type_t * b); + + + +void +oberon_check_type_expr(oberon_context_t * ctx, oberon_expr_t * e); + +void +oberon_check_compatible_bin_expr_types(oberon_context_t * ctx, int token, oberon_type_t * a, oberon_type_t * b); + +void +oberon_check_compatible_arrays(oberon_context_t * ctx, oberon_object_t * f, oberon_expr_t * a); + +void +oberon_check_assignment_compatible(oberon_context_t * ctx, oberon_expr_t * e, oberon_type_t * Tv); + +void +oberon_check_extension_of(oberon_context_t * ctx, oberon_type_t * ext, oberon_type_t * rec); + + + +oberon_type_t * +oberon_get_longer_type(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b); + +oberon_type_t * +oberon_get_longer_real_type(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b); + + +bool +oberon_is_compatible_var_param(oberon_type_t * Tf, oberon_type_t * Ta); + +void +oberon_check_compatible_var_param(oberon_context_t * ctx, oberon_type_t * Tf, oberon_type_t * Ta); diff --git a/src/oberon.c b/src/oberon.c index f67d392..6f9395c 100644 --- a/src/oberon.c +++ b/src/oberon.c @@ -10,77 +10,10 @@ #include "../include/oberon.h" #include "oberon-internals.h" +#include "oberon-type-compat.h" +#include "oberon-common.h" #include "generator.h" -enum { - EOF_ = 0, - IDENT, - MODULE, - SEMICOLON, - END, - DOT, - VAR, - COLON, - BEGIN, - ASSIGN, - INTEGER, - LPAREN, - RPAREN, - EQUAL, - NEQ, - LESS, - LEQ, - GREAT, - GEQ, - IN, - IS, - PLUS, - MINUS, - OR, - STAR, - SLASH, - DIV, - MOD, - AND, - NOT, - PROCEDURE, - COMMA, - RETURN, - CONST, - TYPE, - ARRAY, - OF, - LBRACK, - RBRACK, - RECORD, - POINTER, - TO, - UPARROW, - NIL, - IMPORT, - REAL, - CHAR, - STRING, - IF, - THEN, - ELSE, - ELSIF, - WHILE, - DO, - REPEAT, - UNTIL, - FOR, - BY, - LOOP, - EXIT, - LBRACE, - RBRACE, - DOTDOT, - CASE, - BAR, - WITH -}; - // ======================================================================= // UTILS // ======================================================================= @@ -88,21 +21,6 @@ enum { static void oberon_make_copy_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args); -static void -oberon_error(oberon_context_t * ctx, const char * fmt, ...) -{ - va_list ptr; - va_start(ptr, fmt); - fprintf(stderr, "error: "); - vfprintf(stderr, fmt, ptr); - fprintf(stderr, "\n"); - fprintf(stderr, " code_index = %i\n", ctx -> code_index); - fprintf(stderr, " c = %c\n", ctx -> c); - fprintf(stderr, " token = %i\n", ctx -> token); - va_end(ptr); - exit(1); -} - static oberon_type_t * oberon_new_type_ptr(int class) { @@ -693,6 +611,7 @@ static void oberon_read_string(oberon_context_t * ctx) ctx -> token = STRING; ctx -> string = string; + ctx -> integer = string[0]; } static void oberon_read_token(oberon_context_t * ctx); @@ -978,81 +897,20 @@ oberon_expr_list(oberon_context_t * ctx, int * num_expr, oberon_expr_t ** first, static oberon_expr_t * oberon_cast_expr(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref) { - return oberon_new_operator(OP_CAST, pref, expr, NULL); -} - -static oberon_expr_t * -oberno_make_record_cast(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * rec) -{ - oberon_type_t * from = expr -> result; - oberon_type_t * to = rec; - - if(from -> class == OBERON_TYPE_POINTER && to -> class == OBERON_TYPE_POINTER) - { - from = from -> base; - to = to -> base; - } - - if(from -> class != OBERON_TYPE_RECORD || to -> class != OBERON_TYPE_RECORD) - { - oberon_error(ctx, "must be record type"); - } - - return oberon_cast_expr(ctx, expr, rec); -} + oberon_expr_t * cast; -static oberon_type_t * -oberon_get_equal_expr_type(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b) -{ - oberon_type_t * result; - if(a -> class == OBERON_TYPE_REAL && b -> class == OBERON_TYPE_INTEGER) - { - result = a; - } - else if(b -> class == OBERON_TYPE_REAL && a -> class == OBERON_TYPE_INTEGER) + if((oberon_is_char_type(pref) && oberon_is_const_string(expr) && strlen(expr -> item.string) == 1)) { - result = b; - } - else if(a -> class != b -> class) - { - oberon_error(ctx, "oberon_get_equal_expr_type: incompatible types"); - } - else if(a -> size > b -> size) - { - result = a; + /* Автоматически преобразуем строку единичного размера в символ */ + cast = oberon_new_item(MODE_CHAR, ctx -> char_type, true); + cast -> item.integer = expr -> item.string[0]; } else { - result = b; + cast = oberon_new_operator(OP_CAST, pref, expr, NULL); } - return result; -} - -static void -oberon_check_record_compatibility(oberon_context_t * ctx, oberon_type_t * from, oberon_type_t * to) -{ - if(from -> class == OBERON_TYPE_POINTER && to -> class == OBERON_TYPE_POINTER) - { - from = from -> base; - to = to -> base; - } - - if(from -> class != OBERON_TYPE_RECORD || to -> class != OBERON_TYPE_RECORD) - { - oberon_error(ctx, "not a record"); - } - - oberon_type_t * t = from; - while(t != NULL && t != to) - { - t = t -> base; - } - - if(t == NULL) - { - oberon_error(ctx, "incompatible record types"); - } + return cast; } static void @@ -1096,132 +954,6 @@ oberon_check_src(oberon_context_t * ctx, oberon_expr_t * src) } } -static oberon_expr_t * -oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref) -{ - // Допускается: - // Если классы типов равны - // Если INTEGER переводится в REAL - // Если STRING переводится в CHAR - // Если STRING переводится в ARRAY OF CHAR - // Если NIL переводится в POINTER - // Если NIL переводится в PROCEDURE - - oberon_check_src(ctx, expr); - - bool error = false; - if(pref -> class != expr -> result -> class) - { - if(expr -> result -> class == OBERON_TYPE_NIL) - { - if(pref -> class != OBERON_TYPE_POINTER - && pref -> class != OBERON_TYPE_PROCEDURE) - { - error = true; - } - } - else if(expr -> result -> class == OBERON_TYPE_STRING) - { - if(pref -> class == OBERON_TYPE_CHAR) - { - if(expr -> is_item && expr -> item.mode == MODE_STRING) - { - if(strlen(expr -> item.string) != 1) - { - error = true; - } - } - else - { - error = true; - } - } - else if(pref -> class == OBERON_TYPE_ARRAY) - { - if(pref -> base -> class != OBERON_TYPE_CHAR) - { - error = true; - } - } - else - { - error = true; - } - } - else if(expr -> result -> class == OBERON_TYPE_INTEGER) - { - if(pref -> class != OBERON_TYPE_REAL) - { - error = true; - } - } - else - { - error = true; - } - } - - if(error) - { - oberon_error(ctx, "oberon_autocast_to: incompatible types"); - } - - if(pref -> class == OBERON_TYPE_CHAR) - { - if(expr -> result -> class == OBERON_TYPE_STRING) - { - int c = expr -> item.string[0]; - expr = oberon_new_item(MODE_CHAR, ctx -> char_type, true); - expr -> item.integer = c; - } - } - else if(pref -> class == OBERON_TYPE_INTEGER || pref -> class == OBERON_TYPE_REAL) - { - if(expr -> result -> size > pref -> size) - { - oberon_error(ctx, "incompatible size"); - } - else - { - expr = oberon_cast_expr(ctx, expr, pref); - } - } - else if(pref -> class == OBERON_TYPE_RECORD) - { - oberon_check_record_compatibility(ctx, expr -> result, pref); - expr = oberno_make_record_cast(ctx, expr, pref); - } - else if(pref -> class == OBERON_TYPE_POINTER) - { - assert(pref -> base); - if(expr -> result -> class == OBERON_TYPE_NIL) - { - // do nothing - } - else if(expr -> result -> base -> class == OBERON_TYPE_RECORD) - { - oberon_check_record_compatibility(ctx, expr -> result, pref); - expr = oberno_make_record_cast(ctx, expr, pref); - } - else if(expr -> result -> base != pref -> base) - { - oberon_error(ctx, "incompatible pointer types"); - } - } - - return expr; -} - -static void -oberon_autocast_binary_op(oberon_context_t * ctx, oberon_expr_t ** ea, oberon_expr_t ** eb) -{ - oberon_type_t * a = (*ea) -> result; - oberon_type_t * b = (*eb) -> result; - oberon_type_t * preq = oberon_get_equal_expr_type(ctx, a, b); - *ea = oberon_autocast_to(ctx, *ea, preq); - *eb = oberon_autocast_to(ctx, *eb, preq); -} - static void oberon_autocast_call(oberon_context_t * ctx, oberon_item_t * desig) { @@ -1251,19 +983,21 @@ oberon_autocast_call(oberon_context_t * ctx, oberon_item_t * desig) { if(param -> class == OBERON_CLASS_VAR_PARAM) { - if(arg -> result != param -> type) - { - oberon_error(ctx, "incompatible type"); - } - if(arg -> read_only) + oberon_check_dst(ctx, arg); + if(!oberon_is_compatible_arrays(param, arg)) { - oberon_error(ctx, "assign to read-only var"); + oberon_check_compatible_var_param(ctx, param -> type, arg -> result); } - casted[i] = arg; + casted[i] = oberon_cast_expr(ctx, arg, param -> type); } else { - casted[i] = oberon_autocast_to(ctx, arg, param -> type); + 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; @@ -1581,47 +1315,6 @@ oberon_qualident_expr(oberon_context_t * ctx) return expr; } -static void -oberon_check_type_guard(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * type) -{ - /* Охрана типа применима, если */ - /* 1. v - параметр-переменная типа запись, или v - указатель, и если */ - /* 2. T - расширение статического типа v */ - - if(expr -> is_item - && expr -> item.mode == MODE_VAR - && expr -> item.var -> class == OBERON_CLASS_VAR_PARAM) - { - // accept - } - else if(expr -> result -> class == OBERON_TYPE_POINTER - || expr -> result -> class == OBERON_TYPE_RECORD) - { - // accept - } - else - { - oberon_error(ctx, "guard type used only with var-param or pointers"); - } - - oberon_check_record_compatibility(ctx, type, expr -> result); -} - -static oberon_expr_t * -oberon_make_type_guard(oberon_context_t * ctx, oberon_expr_t * expr, oberon_object_t * objtype) -{ - oberon_type_t * type; - - if(objtype -> class != OBERON_CLASS_TYPE) - { - oberon_error(ctx, "must be type"); - } - type = objtype -> type; - - oberon_check_type_guard(ctx, expr, type); - return oberno_make_record_cast(ctx, expr, objtype -> type); -} - static oberon_expr_t * oberon_designator(oberon_context_t * ctx) { @@ -1661,7 +1354,8 @@ oberon_designator(oberon_context_t * ctx) oberon_assert_token(ctx, LPAREN); objtype = oberon_qualident(ctx, NULL, true); oberon_assert_token(ctx, RPAREN); - expr = oberon_make_type_guard(ctx, expr, objtype); + 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"); @@ -1760,6 +1454,7 @@ oberon_element(oberon_context_t * ctx) 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"); @@ -1770,6 +1465,7 @@ oberon_element(oberon_context_t * ctx) { 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"); @@ -1873,172 +1569,34 @@ oberon_factor(oberon_context_t * ctx) return expr; } -static void -oberon_autocast_to_real(oberon_context_t * ctx, oberon_expr_t ** e) -{ - oberon_expr_t * expr = *e; - if(expr -> result -> class == OBERON_TYPE_INTEGER) - { - if(expr -> result -> size <= ctx -> real_type -> size) - { - *e = oberon_cast_expr(ctx, expr, ctx -> real_type); - } - else - { - *e = oberon_cast_expr(ctx, expr, ctx -> longreal_type); - } - } - else if(expr -> result -> class != OBERON_TYPE_REAL) - { - oberon_error(ctx, "required numeric type"); - } -} - -static bool -oberon_is_numeric_type(oberon_type_t * t) -{ - return (t -> class == OBERON_TYPE_INTEGER) || (t -> class == OBERON_TYPE_REAL); -} - -static bool -oberon_is_char_type(oberon_type_t * t) -{ - return (t -> class == OBERON_TYPE_CHAR); -} - -static bool -oberon_is_string_type(oberon_type_t * t) -{ - return (t -> class == OBERON_TYPE_STRING) - || (t -> class == OBERON_TYPE_ARRAY && t -> base -> class == OBERON_TYPE_CHAR); -} - -static bool -oberon_is_boolean_type(oberon_type_t * t) -{ - return (t -> class == OBERON_TYPE_BOOLEAN); -} - -static bool -oberon_is_set_type(oberon_type_t * t) -{ - return (t -> class == OBERON_TYPE_SET); -} - -static bool -oberon_is_pointer_type(oberon_type_t * t) -{ - return (t -> class == OBERON_TYPE_POINTER) || (t -> class == OBERON_TYPE_NIL); -} - -static bool -oberon_is_procedure_type(oberon_type_t * t) -{ - return (t -> class == OBERON_TYPE_POINTER) || (t -> class == OBERON_TYPE_NIL); -} - 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_types(ctx, token, a -> result, b -> result); + oberon_check_src(ctx, a); + if(token != IS) + { + oberon_check_src(ctx, b); + } + bool error = false; if(token == IN) { - if(a -> result -> class != OBERON_TYPE_INTEGER) - { - oberon_error(ctx, "must be integer"); - } - - if(b -> result -> class != OBERON_TYPE_SET) - { - oberon_error(ctx, "must be set"); - } - - result = ctx -> bool_type; - expr = oberon_new_operator(OP_IN, result, a, b); + expr = oberon_new_operator(OP_IN, ctx -> bool_type, a, b); } else if(token == IS) { - if(b -> is_item == false || b -> item.mode != MODE_TYPE) - { - oberon_error(ctx, "requires type"); - } - - result = ctx -> bool_type; - oberon_check_type_guard(ctx, a, b -> result); - expr = oberon_new_operator(OP_IS, result, a, b); + 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(token >= LESS && token <= GEQ) - { - if(oberon_is_numeric_type(a -> result) && oberon_is_numeric_type(b -> result)) - { - // accept - } - else if(oberon_is_char_type(a -> result) && oberon_is_char_type(b -> result)) - { - // accept - } - else if(oberon_is_string_type(a -> result) && oberon_is_string_type(b -> result)) - { - // accept - } - else - { - oberon_error(ctx, "invalid comparation"); - } - } - else if(token == EQUAL || token == NEQ) - { - if(oberon_is_numeric_type(a -> result) && oberon_is_numeric_type(b -> result)) - { - // accept - } - else if(oberon_is_char_type(a -> result) && oberon_is_char_type(b -> result)) - { - // accept - } - else if(oberon_is_string_type(a -> result) && oberon_is_string_type(b -> result)) - { - // accept - } - else if(oberon_is_boolean_type(a -> result) && oberon_is_boolean_type(b -> result)) - { - // accept - } - else if(oberon_is_set_type(a -> result) && oberon_is_set_type(b -> result)) - { - // accept - } - else if(oberon_is_pointer_type(a -> result) && oberon_is_pointer_type(b -> result)) - { - // accept - } - else if(oberon_is_procedure_type(a -> result) && oberon_is_procedure_type(b -> result)) - { - // accept - } - else - { - oberon_error(ctx, "invalid comparation"); - } - } - else if(token == AND || token == OR) - { - if(!oberon_is_boolean_type(a -> result) || !oberon_is_boolean_type(b -> result)) - { - oberon_error(ctx, "invalid comparation"); - } - } - else - { - oberon_error(ctx, "wat"); - } - - oberon_autocast_binary_op(ctx, &a, &b); + result = oberon_get_longer_type(ctx, a -> result, b -> result); + a = oberon_cast_expr(ctx, a, result); + b = oberon_cast_expr(ctx, b, result); result = ctx -> bool_type; if(token == EQUAL) @@ -2080,38 +1638,34 @@ oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_ } else if(token == SLASH) { - if(a -> result -> class == OBERON_TYPE_SET - || b -> result -> class == OBERON_TYPE_SET) + if(oberon_is_set_type(a -> result) && oberon_is_set_type(b -> result)) { - oberon_autocast_binary_op(ctx, &a, &b); - result = a -> result; + 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 { - oberon_autocast_to_real(ctx, &a); - oberon_autocast_to_real(ctx, &b); - oberon_autocast_binary_op(ctx, &a, &b); - result = a -> result; + result = oberon_get_longer_real_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_DIV, result, a, b); } } else if(token == DIV) { - if(a -> result -> class != OBERON_TYPE_INTEGER - || b -> result -> class != OBERON_TYPE_INTEGER) - { - oberon_error(ctx, "operator DIV requires integer type"); - } - - oberon_autocast_binary_op(ctx, &a, &b); - expr = oberon_new_operator(OP_DIV, a -> result, a, b); + 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_DIV, result, a, b); } else { - oberon_autocast_binary_op(ctx, &a, &b); - result = a -> result; - if(result -> class == OBERON_TYPE_SET) + result = oberon_get_longer_type(ctx, a -> result, b -> result); + a = oberon_cast_expr(ctx, a, result); + b = oberon_cast_expr(ctx, b, result); + if(oberon_is_set_type(result)) { switch(token) { @@ -2129,8 +1683,7 @@ oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_ break; } } - else if(result -> class == OBERON_TYPE_INTEGER - || result -> class == OBERON_TYPE_REAL) + else if(oberon_is_number_type(result)) { switch(token) { @@ -2517,7 +2070,9 @@ oberon_make_return(oberon_context_t * ctx, oberon_expr_t * expr) oberon_error(ctx, "procedure requires expression on result"); } - expr = oberon_autocast_to(ctx, expr, result_type); + 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; @@ -3327,28 +2882,17 @@ oberon_statement_seq(oberon_context_t * ctx); static void oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst) { - if(src -> is_item - && src -> item.mode == MODE_STRING - && src -> result -> class == OBERON_TYPE_STRING - && dst -> result -> class == OBERON_TYPE_ARRAY - && dst -> result -> base -> class == OBERON_TYPE_CHAR - && dst -> result -> size > 0) - { + oberon_check_dst(ctx, dst); + oberon_check_assignment_compatible(ctx, src, dst -> result); - if(strlen(src -> item.string) < dst -> result -> size) - { - src -> next = dst; - oberon_make_copy_call(ctx, 2, src); - } - else - { - oberon_error(ctx, "string too long for destination"); - } + if(oberon_is_string_type(src -> result)) + { + src -> next = dst; + oberon_make_copy_call(ctx, 2, src); } else { - oberon_check_dst(ctx, dst); - src = oberon_autocast_to(ctx, src, dst -> result); + src = oberon_cast_expr(ctx, src, dst -> result); oberon_generate_assign(ctx, src, dst); } } @@ -3362,14 +2906,12 @@ oberon_case_labels(oberon_context_t * ctx, oberon_expr_t * val) oberon_expr_t * cond2; e1 = (oberon_expr_t *) oberon_const_expr(ctx); - oberon_autocast_to(ctx, e1, val -> result); e2 = NULL; if(ctx -> token == DOTDOT) { oberon_assert_token(ctx, DOTDOT); e2 = (oberon_expr_t *) oberon_const_expr(ctx); - oberon_autocast_to(ctx, e2, val -> result); } if(e2 == NULL) @@ -3476,7 +3018,8 @@ oberon_with_guard_do(oberon_context_t * ctx, gen_label_t * end) /* Сохраняем ссылку во временной переменной */ val = oberon_make_temp_var_item(ctx, type -> result); - cast = oberno_make_record_cast(ctx, var, type -> result); + //cast = oberno_make_record_cast(ctx, var, type -> result); + cast = oberon_cast_expr(ctx, var, type -> result); oberon_assign(ctx, cast, val); /* Подменяем тип у оригинальной переменной */ old_type = var -> item.var -> type; @@ -4176,12 +3719,12 @@ oberon_make_copy_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list dst = list_args -> next; oberon_check_dst(ctx, dst); - if(!oberon_is_string_type(src -> result)) + 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_string_type(dst -> result)) + if(!oberon_is_array_of_char_type(dst -> result)) { oberon_error(ctx, "dst must be array of char"); } -- 2.29.2