From: DeaDDooMER <deaddoomer@deadsoftware.ru>
Date: Thu, 10 Aug 2017 10:47:21 +0000 (+0300)
Subject: Проверка ораны типа теперь как описано в стандарте
X-Git-Url: http://deadsoftware.ru/gitweb?a=commitdiff_plain;h=49ad3c76fc9656759aab23d9034ebc33f8d8bd9d;p=dsw-obn.git

Проверка ораны типа теперь как описано в стандарте
---

diff --git a/Test.obn b/Test.obn
index 363783e..b80d7a1 100644
--- a/Test.obn
+++ b/Test.obn
@@ -2,16 +2,21 @@ MODULE Test;
 
 TYPE
   R1 = RECORD END;
-(*  R2 = RECORD (R1) END; *)
+  R2 = RECORD (R1) END;
   R3 = RECORD END;
 
+  P1 = POINTER TO R1;
+  P2 = POINTER TO R2;
+
 VAR
-(*
   a : R1;
   b : R2;
-*)
   c : R3;
+  p1 : P1;
+  p2 : P2;
 
 BEGIN
-(*  a := b; *)
+  a := b;
+  p2 := p1(P2);
+  p1 := p2(P2);
 END Test.
diff --git a/Test5.obn b/Test5.obn
new file mode 100644
index 0000000..248d688
--- /dev/null
+++ b/Test5.obn
@@ -0,0 +1,22 @@
+MODULE Test5;
+
+TYPE
+  R1 = RECORD END;
+  R2 = RECORD (R1) END;
+  R3 = RECORD END;
+
+  P1 = POINTER TO R1;
+  P2 = POINTER TO R2;
+
+VAR
+  a : R1;
+  b : R2;
+  c : R3;
+  p1 : P1;
+  p2 : P2;
+
+BEGIN
+  a := b;
+  p2 := p1(P2);
+  p1 := p2(P2);
+END Test5.
diff --git a/obn-run-tests.sh b/obn-run-tests.sh
index c665472..2c7dbec 100755
--- a/obn-run-tests.sh
+++ b/obn-run-tests.sh
@@ -31,3 +31,4 @@ maketest Test1
 maketest Test2
 maketest Test3
 maketest Test4
+maketest Test5
diff --git a/src/oberon.c b/src/oberon.c
index 349015d..ece881f 100644
--- a/src/oberon.c
+++ b/src/oberon.c
@@ -1573,11 +1573,46 @@ oberon_qualident_expr(oberon_context_t * ctx)
 	return expr;
 }
 
+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;
+
+	/* Охрана типа применима, если */
+	/*   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)
+	{
+		// accept
+	}
+	else
+	{
+		oberon_error(ctx, "guard type used only with var-param or pointers");
+	}
+
+	oberon_check_record_compatibility(ctx, type, expr -> result);
+	return oberno_make_record_cast(ctx, expr, objtype -> type);
+}
+
 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);
 
@@ -1609,13 +1644,9 @@ oberon_designator(oberon_context_t * ctx)
 				break;
 			case LPAREN:
 				oberon_assert_token(ctx, LPAREN);
-				oberon_object_t * objtype = oberon_qualident(ctx, NULL, 1);
-				if(objtype -> class != OBERON_CLASS_TYPE)
-				{
-					oberon_error(ctx, "must be type");
-				}
+				objtype = oberon_qualident(ctx, NULL, true);
 				oberon_assert_token(ctx, RPAREN);
-				expr = oberno_make_record_cast(ctx, expr, objtype -> type);
+				expr = oberon_make_type_guard(ctx, expr, objtype);
 				break;
 			default:
 				oberon_error(ctx, "oberon_designator: wat");