From: DeaDDooMER <deaddoomer@deadsoftware.ru>
Date: Fri, 18 Aug 2017 15:30:30 +0000 (+0300)
Subject: Исправлена конверсия строки единичного размера в символ в сравнениях
X-Git-Url: http://deadsoftware.ru/gitweb?p=dsw-obn.git;a=commitdiff_plain;h=ba1a55241f3841d1254317d76d45322c85fb687b

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

diff --git a/Test.obn b/Test.obn
index d232953..67a35e4 100644
--- 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
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 ad35ef7..6c6cf6f 100644
--- 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 7011dc5..fa1d728 100755
--- 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 4291f6c..3da62ed 100644
--- 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 92b6750..ccb1e24 100644
--- 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 c1e86d2..04d4c6d 100644
--- 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");
 	}