Исправлена конверсия строки единичного размера в символ в сравнениях

diff --git a/Test.obn b/Test.obn
index d232953a80d3259d11c1a1987e2bd14d3a4c415c..67a35e4ef616fb5f76e91b2f1cf9a5b60eb0ffbc 100644 (file)
--- a/Test.obn
+++ b/Test.obn
@@ -1,14 +1,14 @@
 MODULE Test;
 
-IMPORT SYSTEM, Out;
-
-TYPE
-  R = RECORD END;
-
-VAR
-  i : INTEGER;
-  l : LONGINT;
+IMPORT Out;
 
 BEGIN
-  i := SYSTEM.VAL(INTEGER, l);
+  Out.String("A");
+  Out.Char("A");
+  Out.Ln;
+  ASSERT("A" = 041X);
+  ASSERT(041X = "A");
+  ASSERT(ORD("A") = 041H);
+  ASSERT(041H = ORD("A"));
+  ASSERT("A" = "A");
 END Test.

diff --git a/Test20.obn b/Test20.obn
new file mode 100644 (file)
index 0000000..0eea39b
--- /dev/null
+++ b/Test20.obn
@@ -0,0 +1,20 @@
+MODULE Test20;
+
+IMPORT Out;
+
+VAR
+  ch : CHAR;
+
+BEGIN
+  ch := "A";
+  Out.String("A");
+  Out.Char("A");
+  Out.Ln;
+  ASSERT("A" = 041X);
+  ASSERT(041X = "A");
+  ASSERT(ORD("A") = 041H);
+  ASSERT(041H = ORD("A"));
+  ASSERT("A" = "A");
+END Test20.
+
+Тест конверсии строки единичного размера в символ.

diff --git a/notes b/notes
index ad35ef7a9565f946f208f572960e3626a52318b7..6c6cf6fbcef722eca42b59fd1c6f8e00f3024715 100644 (file)
--- a/notes
+++ b/notes
@@ -1,16 +1,21 @@
-- Перепроверить конверсию строк единичного размера в символ.
-- Не полная реализация модуля SYSTEM
-    * Процедуры GETREG PUTREG впринципе вписываются в jvm
-      и могут быть полезны при реализции рефлекции
 - Нет процедур привязанных к типм (10.2)
 - Не полная реализация модуля Files 
     * Не реализована запись в файл
 
+- Нужна опция для задания списка директорий для поиска модулей.
+
 - Не полная реализация модуля Strings 
     * Реализованы только процедуры Length и Cap
 - Сделать проверку повторов в CASE.
 - Сделать нормальную проверку наличия RETURN.
 
+- Нет счёта строк / столбцов (хрен с ними - у меня есть утилита tail!)
+- Нужны средства создания биндингов. (oakwood 3.5)
+- Любая ошибка фатальна
+
+- Примеры -5 DIV 3 и -5 MOD 3 работают не так как в (8.2.2)
+    Нужен другой тип округления?
+
 - Неплохо бы иметь оператор ** (oakwood 3.7)
 - Неплохо бы иметь параметры только для чтения (oakwood 5.13)
 - Надо что-то делать с ситуацией описанной в (okawood 2.4)
@@ -20,16 +25,13 @@
 - Запретить доступ к битам SET которые не входят в пределы 0..MAX(SET) (oakwood 2.3.5)
 - Запретить каст через SHORT если значение не в пределах результата (в рантайме чтоли?) (oakwood 2.3.6)
 - Нет проверки переполнений (oakwood 2.3.8)
-
-- Примеры -5 DIV 3 и -5 MOD 3 работают не так как в (8.2.2)
-    Нужен другой тип округления?
-
-- Нет счёта строк / столбцов (хрен с ними - у меня есть утилита tail!)
-- Нужны средства создания биндингов. (oakwood 3.5)
-- Любая ошибка фатальна
 - Нет проверок переполнения в компилтайме.
     Возможно можно заюзать это:
       https://gcc.gnu.org/onlinedocs/gcc/Integer-Overflow-Builtins.html
 
+- Не полная реализация модуля SYSTEM
+    * Процедуры GETREG PUTREG впринципе вписываются в jvm
+      и могут быть полезны при реализции рефлекции
+    * Остальное не имеет смысла в jvm
 - JVM: Не достаточно средств для реализации рефлексии на уровне локальных процедур.
     Как минимум нужно каждой функции добавлять фрейм к параметрам (динамическая связь?)

diff --git a/obn-run-tests.sh b/obn-run-tests.sh
index 7011dc59ada134164831c80e12cf2bb077d5bdc9..fa1d728f373bbc133344fd14886982b2cdb21fe1 100755 (executable)
--- a/obn-run-tests.sh
+++ b/obn-run-tests.sh
@@ -92,3 +92,4 @@ makefail Test18B
 makefail Test18C
 
 maketest Test19
+maketest Test20

diff --git a/src/oberon-type-compat.c b/src/oberon-type-compat.c
index 4291f6c5f402d97b9e5c859056dd107099b31895..3da62edc2bb5b059b7ee20b90f20c238400de495 100644 (file)
--- a/src/oberon-type-compat.c
+++ b/src/oberon-type-compat.c
@@ -281,6 +281,12 @@ 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_string_of_one(oberon_expr_t * e)
+{
+       return oberon_is_const_string(e) && strlen(e -> item.string) == 1;
+}
+
 bool
 oberon_is_assignment_compatible_expressions(oberon_expr_t * e, oberon_type_t * Tv)
 {
@@ -308,7 +314,7 @@ oberon_is_assignment_compatible_expressions(oberon_expr_t * e, oberon_type_t * T
                || ((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_char_type(Tv) && oberon_is_string_of_one(e))
                || (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));
 }
@@ -344,6 +350,27 @@ oberon_check_compatible_arrays(oberon_context_t * ctx, oberon_object_t * f, ober
        }
 }
 
+bool
+oberon_is_compatible_bin_expr(int token, oberon_expr_t * a, oberon_expr_t * b)
+{
+       if(token == EQUAL || token == NEQ || token == LESS || token == LEQ || token == GREAT || token == GEQ)
+       {
+               if((oberon_is_char_type(a -> result) || oberon_is_string_of_one(a))
+                       && (oberon_is_char_type(b -> result) || oberon_is_string_of_one(b)))
+               {
+                       return true;
+               }
+               else
+               {
+                       return oberon_is_compatible_bin_expr_types(token, a -> result, b -> result);
+               }
+       }
+       else
+       {
+               return oberon_is_compatible_bin_expr_types(token, a -> result, b -> result);
+       }
+}
+
 bool
 oberon_is_compatible_bin_expr_types(int token, oberon_type_t * a, oberon_type_t * b)
 {
@@ -473,9 +500,9 @@ 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)
+oberon_check_compatible_bin_expr(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_expr_t * b)
 {
-       if(!oberon_is_compatible_bin_expr_types(token, a, b))
+       if(!oberon_is_compatible_bin_expr(token, a, b))
        {
                oberon_error(ctx, "incompatibe expression types");
        }

diff --git a/src/oberon-type-compat.h b/src/oberon-type-compat.h
index 92b67503c78ffe37cfffa3b85c0adf543b648b18..ccb1e2444d8915134c8dc408745ffb0c2cc9b10f 100644 (file)
--- a/src/oberon-type-compat.h
+++ b/src/oberon-type-compat.h
@@ -46,6 +46,9 @@ oberon_is_array_of_char_type(oberon_type_t * t);
 bool
 oberon_is_type_expr(oberon_expr_t * e);
 
+bool
+oberon_is_string_of_one(oberon_expr_t * e);
+
 
 
 bool
@@ -72,6 +75,9 @@ oberon_is_assignment_compatible_expressions(oberon_expr_t * e, oberon_type_t * T
 bool
 oberon_is_compatible_arrays(oberon_object_t * f, oberon_expr_t * a);
 
+bool
+oberon_is_comatible_bin_expr(int token, oberon_expr_t * a, oberon_expr_t * b);
+
 bool
 oberon_is_compatible_bin_expr_types(int token, oberon_type_t * a, oberon_type_t * b);
 
@@ -81,7 +87,7 @@ 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);
+oberon_check_compatible_bin_expr(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_expr_t * b);
 
 void
 oberon_check_compatible_arrays(oberon_context_t * ctx, oberon_object_t * f, oberon_expr_t * a);

diff --git a/src/oberon.c b/src/oberon.c
index c1e86d229c340de3f475029119b6335ea08f4aba..04d4c6d75a736a8e1d1f57e909ba6d509775fcf4 100644 (file)
--- a/src/oberon.c
+++ b/src/oberon.c
@@ -171,6 +171,17 @@ oberon_make_char(oberon_context_t * ctx, int64_t 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)
 {
@@ -1666,9 +1677,7 @@ oberon_factor(oberon_context_t * ctx)
                        oberon_assert_token(ctx, CHAR);
                        break;
                case STRING:
-                       result = ctx -> string_type;
-                       expr = oberon_new_item(MODE_STRING, result, true);
-                       expr -> item.string = ctx -> string;
+                       expr = oberon_make_string(ctx, ctx -> string);
                        oberon_assert_token(ctx, STRING);
                        break;
                case REAL:
@@ -1705,7 +1714,7 @@ oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_
        oberon_expr_t * expr;
        oberon_type_t * result;
 
-       oberon_check_compatible_bin_expr_types(ctx, token, a -> result, b -> result);
+       oberon_check_compatible_bin_expr(ctx, token, a, b);
        oberon_check_src(ctx, a);
        if(token != IS)
        {
@@ -1730,7 +1739,22 @@ oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_
        }
        else if((token >= EQUAL && token <= GEQ) || token == OR || token == AND)
        {
-               result = oberon_get_longer_type(ctx, a -> result, b -> result);
+               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)))
@@ -4398,7 +4422,7 @@ oberon_make_ord_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_
        arg = list_args;
        oberon_check_src(ctx, arg);
 
-       if(!oberon_is_char_type(arg -> result))
+       if(!oberon_is_char_type(arg -> result) && !oberon_is_string_of_one(arg))
        {
                oberon_error(ctx, "expected char");
        }