From: DeaDDooMER <deaddoomer@deadsoftware.ru>
Date: Wed, 2 Aug 2017 07:13:12 +0000 (+0300)
Subject: Поправлен каст и использование указателей на записи
X-Git-Url: http://deadsoftware.ru/gitweb?p=dsw-obn.git;a=commitdiff_plain;h=e6a70a3b694efa5600cfcd0d8110f8d9e8866342

Поправлен каст и использование указателей на записи
---

diff --git a/src/backends/jvm/generator-jvm-basic.c b/src/backends/jvm/generator-jvm-basic.c
index 865ffdd..2b9b548 100644
--- a/src/backends/jvm/generator-jvm-basic.c
+++ b/src/backends/jvm/generator-jvm-basic.c
@@ -234,6 +234,9 @@ jvm_get_class_full_name(oberon_type_t * type)
 
 	switch(type -> class)
 	{
+		case OBERON_TYPE_POINTER:
+			name = jvm_get_class_full_name(type -> base);
+			break;
 		case OBERON_TYPE_PROCEDURE:
 			name = new_string("SYSTEM$PROCEDURE");
 
diff --git a/src/oberon.c b/src/oberon.c
index 570db39..e755b6c 100644
--- a/src/oberon.c
+++ b/src/oberon.c
@@ -673,6 +673,7 @@ static void oberon_assert_token(oberon_context_t * ctx, int token);
 static char * oberon_assert_ident(oberon_context_t * ctx);
 static void oberon_type(oberon_context_t * ctx, oberon_type_t ** type);
 static oberon_item_t * oberon_const_expr(oberon_context_t * ctx);
+static oberon_expr_t * oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr);
 
 static oberon_expr_t *
 oberon_new_operator(int op, oberon_type_t * result, oberon_expr_t * left, oberon_expr_t * right)
@@ -776,8 +777,19 @@ oberon_cast_expr(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * p
 static oberon_expr_t *
 oberno_make_record_cast(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * rec)
 {
-	if(expr -> result -> class != OBERON_TYPE_RECORD
-		|| rec -> class != OBERON_TYPE_RECORD)
+	oberon_type_t * from = expr -> result;
+	oberon_type_t * to = rec;
+
+	printf("oberno_make_record_cast: from class %i to class %i\n", from -> class, to -> class);
+
+	if(from -> class == OBERON_TYPE_POINTER && to -> class == OBERON_TYPE_POINTER)
+	{
+		printf("oberno_make_record_cast: pointers\n");
+		from = from -> base;
+		to = to -> base;
+	}
+
+	if(from -> class != OBERON_TYPE_RECORD || to -> class != OBERON_TYPE_RECORD)
 	{
 		oberon_error(ctx, "must be record type");
 	}
@@ -813,39 +825,60 @@ oberon_get_equal_expr_type(oberon_context_t * ctx, oberon_type_t * a, oberon_typ
 	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");
+	}
+}
+
 static oberon_expr_t *
 oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref)
 {
+	// Допускается:
+	//  Если классы типов равны
+	//  Если INTEGER переводится в REAL
+
+	bool error = false;
 	if(pref -> class != expr -> result -> class)
 	{
-		if(pref -> class == OBERON_TYPE_POINTER)
-		{
-			if(expr -> result -> class == OBERON_TYPE_POINTER)
-			{
-				// accept
-			}
-			else
-			{
-				oberon_error(ctx, "incompatible types");
-			}
-		}
-		else if(pref -> class == OBERON_TYPE_REAL)
+		if(expr -> result -> class == OBERON_TYPE_INTEGER)
 		{
-			if(expr -> result -> class == OBERON_TYPE_INTEGER)
-			{
-				// accept
-			}
-			else
+			if(pref -> class != OBERON_TYPE_REAL)
 			{
-				oberon_error(ctx, "incompatible types");
+				error = true;
 			}
 		}
 		else
 		{
-			oberon_error(ctx, "incompatible types");
+			error = true;
 		}
 	}
 
+	if(error)
+	{
+		oberon_error(ctx, "incompatible types");
+	}
+
 	if(pref -> class == OBERON_TYPE_INTEGER || pref -> class == OBERON_TYPE_REAL)
 	{
 		if(expr -> result -> size > pref -> size)
@@ -859,24 +892,17 @@ oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t *
 	}
 	else if(pref -> class == OBERON_TYPE_RECORD)
 	{
-		oberon_type_t * t = expr -> result;
-		while(t != NULL && t != pref)
-		{
-			t = t -> base;
-		}
-		if(t == NULL)
-		{
-			printf("oberon_autocast_to: rec %p != %p\n", expr -> result, pref);
-			oberon_error(ctx, "incompatible record types");
-		}
-		if(expr -> result != pref)
-		{
-			expr = oberno_make_record_cast(ctx, expr, pref);
-		}
+		oberon_check_record_compatibility(ctx, expr -> result, pref);
 	}
 	else if(pref -> class == OBERON_TYPE_POINTER)
 	{
-		if(expr -> result -> base != pref -> base)
+		assert(pref -> base);
+		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)
 		{
 			if(expr -> result -> base -> class != OBERON_TYPE_VOID)
 			{
@@ -1088,6 +1114,7 @@ oberon_make_call_proc(oberon_context_t * ctx, oberon_object_t * proc, int num_ar
 static oberon_expr_t *
 oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr)
 {
+	printf("oberno_make_dereferencing\n");
 	if(expr -> result -> class != OBERON_TYPE_POINTER)
 	{
 		oberon_error(ctx, "not a pointer");
@@ -1273,8 +1300,7 @@ oberon_designator(oberon_context_t * ctx)
 	}
 	expr -> item.var = var;
 
-	bool brk = false;
-	while(brk == false && ISSELECTOR(ctx -> token))
+	while(expr -> result -> class != OBERON_TYPE_PROCEDURE && ISSELECTOR(ctx -> token))
 	{
 		switch(ctx -> token)
 		{
@@ -1301,11 +1327,6 @@ oberon_designator(oberon_context_t * ctx)
 				expr = oberno_make_dereferencing(ctx, expr);
 				break;
 			case LPAREN:
-				if(expr -> result -> class == OBERON_TYPE_PROCEDURE)
-				{
-					brk = true;
-					break;
-				}
 				oberon_assert_token(ctx, LPAREN);
 				oberon_object_t * objtype = oberon_qualident(ctx, NULL, 1);
 				if(objtype -> class != OBERON_CLASS_TYPE)
@@ -1320,14 +1341,13 @@ oberon_designator(oberon_context_t * ctx)
 				break;
 		}
 	}
+
 	return expr;
 }
 
 static oberon_expr_t *
 oberon_opt_func_parens(oberon_context_t * ctx, oberon_expr_t * expr)
 {
-	assert(expr -> is_item == 1);
-
 	/* Если есть скобки - значит вызов. Если нет, то передаём указатель. */
 	if(ctx -> token == LPAREN)
 	{
@@ -1341,6 +1361,7 @@ oberon_opt_func_parens(oberon_context_t * ctx, oberon_expr_t * expr)
 			oberon_expr_list(ctx, &num_args, &arguments, 0);
 		}
 
+		assert(expr -> is_item == 1);
 		expr = oberon_make_call_func(ctx, (oberon_item_t *) expr, num_args, arguments);
 
 		oberon_assert_token(ctx, RPAREN);
@@ -2176,13 +2197,19 @@ oberon_type_record_body(oberon_context_t * ctx, oberon_type_t * rec)
 			oberon_error(ctx, "base must be type");
 		}
 
-		if(typeobj -> type -> class != OBERON_TYPE_RECORD)
+		oberon_type_t * base = typeobj -> type;
+		if(base -> class == OBERON_TYPE_POINTER)
+		{
+			base = base -> base;
+		}
+
+		if(base -> class != OBERON_TYPE_RECORD)
 		{
 			oberon_error(ctx, "base must be record type");
 		}
 
-		rec -> base = typeobj -> type;
-		ctx -> decl = rec -> base -> scope;
+		rec -> base = base;
+		ctx -> decl = base -> scope;
 
 		oberon_assert_token(ctx, RPAREN);
 	}
diff --git a/src/test.c b/src/test.c
index 3305807..125c5df 100644
--- a/src/test.c
+++ b/src/test.c
@@ -9,38 +9,22 @@ static char source_test[] =
 	"MODULE Test;"
 	"IMPORT Out;"
 	"TYPE"
-	"  Callback = PROCEDURE;"
-	"  Callfront = PROCEDURE(x : LONGINT) : LONGINT;"
-	"  RecDesc = RECORD"
-	"    cb : Callback;"
-	"    cf : Callfront;"
-	"  END;"
+	"  RecA = POINTER TO RecADesc;"
+	"  RecADesc = RECORD END;"
 	""
-	"VAR"
-	"  r : RecDesc;"
-	"  i : LONGINT;"
-	""
-	"PROCEDURE Stuff;"
-	"BEGIN"
-	"  Out.Int(0123456789, 0); Out.Ln;"
-	"END Stuff;"
+	"  RecB = POINTER TO RecBDesc;"
+	"  RecBDesc = RECORD (RecADesc) END;"
 	""
-	"PROCEDURE Ffuts (x : LONGINT) : LONGINT;"
-	"BEGIN"
-	"  RETURN 9876543210 + x;"
-	"END Ffuts;"
+	"VAR"
+	"  pra : RecA;"
+	"  prb : RecB;"
+	"  ra  : RecADesc;"
+	"  rb  : RecBDesc;"
 	""
 	"BEGIN"
-	"  Out.Open;"
-	"  Out.Int(1, 0); Out.Ln;"
-	"  r.cb := Stuff;"
-	"  Out.Int(2, 0); Out.Ln;"
-	"  r.cb();"
-	"  Out.Int(3, 0); Out.Ln;"
-	"  r.cf := Ffuts;"
-	"  Out.Int(4, 0); Out.Ln;"
-	"  i := r.cf(0123456789);"
-	"  Out.Int(i, 0); Out.Ln;"
+	"  pra := prb;"
+	"  prb := pra(RecB);"
+	"  ra := prb^;"
 	"END Test."
 ;