X-Git-Url: http://deadsoftware.ru/gitweb?a=blobdiff_plain;f=src%2Foberon.c;h=e755b6cf625c2984edd3ef2dd8655810426fd44e;hb=e6a70a3b694efa5600cfcd0d8110f8d9e8866342;hp=6aa94d602fd9da13bb67174ecf2dc6632f9c2d4a;hpb=5eab721345c3e472bbfbb97645729069b0b6bb40;p=dsw-obn.git

diff --git a/src/oberon.c b/src/oberon.c
index 6aa94d6..e755b6c 100644
--- a/src/oberon.c
+++ b/src/oberon.c
@@ -33,6 +33,8 @@ enum {
 	LEQ,
 	GREAT,
 	GEQ,
+	IN,
+	IS,
 	PLUS,
 	MINUS,
 	OR,
@@ -350,6 +352,14 @@ oberon_read_ident(oberon_context_t * ctx)
 	{
 		ctx -> token = IMPORT;
 	}
+	else if(strcmp(ident, "IN") == 0)
+	{
+		ctx -> token = IN;
+	}
+	else if(strcmp(ident, "IS") == 0)
+	{
+		ctx -> token = IS;
+	}
 }
 
 static void
@@ -663,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)
@@ -760,11 +771,30 @@ 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)
 {
-	oberon_expr_t * cast;
-	cast = oberon_new_item(MODE_CAST, pref, expr -> read_only);
-	cast -> item.parent = expr;
-	cast -> next = expr -> next;
-	return cast;
+	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;
+
+	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");
+	}
+
+	return oberon_cast_expr(ctx, expr, rec);
 }
 
 static oberon_type_t *
@@ -795,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_INTEGER)
 		{
-			if(expr -> result -> class == OBERON_TYPE_POINTER)
+			if(pref -> class != OBERON_TYPE_REAL)
 			{
-				// accept
-			}
-			else
-			{
-				oberon_error(ctx, "incompatible types");
-			}
-		}
-		else if(pref -> class == OBERON_TYPE_REAL)
-		{
-			if(expr -> result -> class == OBERON_TYPE_INTEGER)
-			{
-				// accept
-			}
-			else
-			{
-				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)
@@ -841,15 +892,17 @@ oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t *
 	}
 	else if(pref -> class == OBERON_TYPE_RECORD)
 	{
-		if(expr -> result != pref)
-		{
-			printf("oberon_autocast_to: rec %p != %p\n", expr -> result, pref);
-			oberon_error(ctx, "incompatible record types");
-		}
+		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)
 			{
@@ -872,25 +925,15 @@ oberon_autocast_binary_op(oberon_context_t * ctx, oberon_expr_t ** ea, oberon_ex
 }
 
 static void
-oberon_autocast_call(oberon_context_t * ctx, oberon_expr_t * desig)
+oberon_autocast_call(oberon_context_t * ctx, oberon_item_t * desig)
 {
-	if(desig -> is_item == 0)
-	{
-		oberon_error(ctx, "expected item");
-	}
-
-	if(desig -> item.mode != MODE_CALL)
+	if(desig -> mode != MODE_CALL)
 	{
 		oberon_error(ctx, "expected mode CALL");
 	}
 
-	if(desig -> item.var -> type -> class != OBERON_TYPE_PROCEDURE)
-	{
-		oberon_error(ctx, "only procedures can be called");
-	}
-
-	oberon_type_t * fn = desig -> item.var -> type;
-	int num_args = desig -> item.num_args;
+	oberon_type_t * fn = desig -> parent -> result;
+	int num_args = desig -> num_args;
 	int num_decl = fn -> num_decl;
 
 	if(num_args < num_decl)
@@ -904,7 +947,7 @@ oberon_autocast_call(oberon_context_t * ctx, oberon_expr_t * desig)
 
 	/* Делаем проверку на запись и делаем автокаст */
 	oberon_expr_t * casted[num_args];
-	oberon_expr_t * arg = desig -> item.args;
+	oberon_expr_t * arg = desig -> args;
 	oberon_object_t * param = fn -> decl;
 	for(int i = 0; i < num_args; i++)
 	{
@@ -929,62 +972,84 @@ oberon_autocast_call(oberon_context_t * ctx, oberon_expr_t * desig)
 		{
 			casted[i] -> next = casted[i + 1];
 		}
-		desig -> item.args = arg;
+		desig -> args = arg;
 	}
 }
 
 static oberon_expr_t *
-oberon_make_call_func(oberon_context_t * ctx, oberon_object_t * proc, int num_args, oberon_expr_t * list_args)
+oberon_make_call_func(oberon_context_t * ctx, oberon_item_t * item, int num_args, oberon_expr_t * list_args)
 {
-	switch(proc -> class)
+	oberon_type_t * signature = item -> result;
+	if(signature -> class != OBERON_TYPE_PROCEDURE)
 	{
-		case OBERON_CLASS_PROC:
-			if(proc -> class != OBERON_CLASS_PROC)
-			{
-				oberon_error(ctx, "not a procedure");
-			}
-			break;
-		case OBERON_CLASS_VAR:
-		case OBERON_CLASS_VAR_PARAM:
-		case OBERON_CLASS_PARAM:
-			if(proc -> type -> class != OBERON_TYPE_PROCEDURE)
-			{
-				oberon_error(ctx, "not a procedure");
-			}
-			break;
-		default:
-			oberon_error(ctx, "not a procedure");
-			break;
+		oberon_error(ctx, "not a procedure");
 	}
 
 	oberon_expr_t * call;
 
-	if(proc -> sysproc)
+	if(signature -> sysproc)
 	{
-		if(proc -> genfunc == NULL)
+		if(signature -> genfunc == NULL)
 		{
 			oberon_error(ctx, "not a function-procedure");
 		}
 
-		call = proc -> genfunc(ctx, num_args, list_args);
+		call = signature -> genfunc(ctx, num_args, list_args);
 	}
 	else
 	{
-		if(proc -> type -> base -> class == OBERON_TYPE_VOID)
+		if(signature -> base -> class == OBERON_TYPE_VOID)
 		{
 			oberon_error(ctx, "attempt to call procedure in expression");
 		}
 
-		call = oberon_new_item(MODE_CALL, proc -> type -> base, 1);
-		call -> item.var = proc;
+		call = oberon_new_item(MODE_CALL, signature -> base, true);
+		call -> item.parent = item;
 		call -> item.num_args = num_args;
 		call -> item.args = list_args;
-		oberon_autocast_call(ctx, call);
+		oberon_autocast_call(ctx, (oberon_item_t *) call);
 	}
 
 	return call;
 }
 
+static void
+oberon_make_call_proc(oberon_context_t * ctx, oberon_item_t * item, int num_args, oberon_expr_t * list_args)
+{
+	oberon_type_t * signature = item -> result;
+	if(signature -> class != OBERON_TYPE_PROCEDURE)
+	{
+		oberon_error(ctx, "not a procedure");
+	}
+
+	oberon_expr_t * call;
+
+	if(signature -> sysproc)
+	{
+		if(signature -> genproc == NULL)
+		{
+			oberon_error(ctx, "not a procedure");
+		}
+
+		signature -> genproc(ctx, num_args, list_args);
+	}
+	else
+	{
+		if(signature -> base -> class != OBERON_TYPE_VOID)
+		{
+			oberon_error(ctx, "attempt to call function as non-typed procedure");
+		}
+
+		call = oberon_new_item(MODE_CALL, signature -> base, true);
+		call -> item.parent = item;
+		call -> item.num_args = num_args;
+		call -> item.args = list_args;
+		oberon_autocast_call(ctx, (oberon_item_t *) call);
+		oberon_generate_call_proc(ctx, call);
+	}
+}
+
+/*
 static void
 oberon_make_call_proc(oberon_context_t * ctx, oberon_object_t * proc, int num_args, oberon_expr_t * list_args)
 {
@@ -1034,6 +1099,7 @@ oberon_make_call_proc(oberon_context_t * ctx, oberon_object_t * proc, int num_ar
 		oberon_generate_call_proc(ctx, call);
 	}
 }
+*/
 
 #define ISEXPR(x) \
 	(((x) == PLUS) \
@@ -1048,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");
@@ -1057,7 +1124,7 @@ oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr)
 
 	oberon_expr_t * selector;
 	selector = oberon_new_item(MODE_DEREF, expr -> result -> base, expr -> read_only);
-	selector -> item.parent = expr;
+	selector -> item.parent = (oberon_item_t *) expr;
 
 	return selector;
 }
@@ -1104,7 +1171,7 @@ oberon_make_array_selector(oberon_context_t * ctx, oberon_expr_t * desig, oberon
 
 	oberon_expr_t * selector;
 	selector = oberon_new_item(MODE_INDEX, base, desig -> read_only);
-	selector -> item.parent = desig;
+	selector -> item.parent = (oberon_item_t *) desig;
 	selector -> item.num_args = 1;
 	selector -> item.args = index;
 
@@ -1119,7 +1186,7 @@ oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char *
 		expr = oberno_make_dereferencing(ctx, expr);
 	}
 
-	assert(expr -> is_item == 1);
+	assert(expr -> is_item);
 
 	if(expr -> result -> class != OBERON_TYPE_RECORD)
 	{
@@ -1151,7 +1218,7 @@ oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char *
 	oberon_expr_t * selector;
 	selector = oberon_new_item(MODE_FIELD, field -> type, read_only);
 	selector -> item.var = field;
-	selector -> item.parent = expr;
+	selector -> item.parent = (oberon_item_t *) expr;
 
 	return selector;
 }
@@ -1195,18 +1262,6 @@ oberon_qualident(oberon_context_t * ctx, char ** xname, int check)
 	return x;
 }
 
-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_error(ctx, "must be record type");
-	}
-
-	return oberon_cast_expr(ctx, expr, rec);
-}
-
 static oberon_expr_t *
 oberon_designator(oberon_context_t * ctx)
 {
@@ -1245,7 +1300,7 @@ oberon_designator(oberon_context_t * ctx)
 	}
 	expr -> item.var = var;
 
-	while(ISSELECTOR(ctx -> token))
+	while(expr -> result -> class != OBERON_TYPE_PROCEDURE && ISSELECTOR(ctx -> token))
 	{
 		switch(ctx -> token)
 		{
@@ -1286,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)
 	{
@@ -1307,7 +1361,8 @@ oberon_opt_func_parens(oberon_context_t * ctx, oberon_expr_t * expr)
 			oberon_expr_list(ctx, &num_args, &arguments, 0);
 		}
 
-		expr = oberon_make_call_func(ctx, expr -> item.var, num_args, arguments);
+		assert(expr -> is_item == 1);
+		expr = oberon_make_call_func(ctx, (oberon_item_t *) expr, num_args, arguments);
 
 		oberon_assert_token(ctx, RPAREN);
 	}
@@ -1336,7 +1391,7 @@ oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr)
 	}
 
 	/* Вызов происходит даже без скобок */
-	oberon_make_call_proc(ctx, expr -> item.var, num_args, arguments);
+	oberon_make_call_proc(ctx, (oberon_item_t *) expr, num_args, arguments);
 }
 
 static oberon_type_t *
@@ -1620,7 +1675,7 @@ oberon_simple_expr(oberon_context_t * ctx)
 }
 
 #define ISRELATION(x) \
-	((x) >= EQUAL && (x) <= GEQ)
+	((x) >= EQUAL && (x) <= IS)
 
 static oberon_expr_t *
 oberon_expr(oberon_context_t * ctx)
@@ -2142,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);
 	}
@@ -2861,10 +2922,10 @@ oberon_new_intrinsic(oberon_context_t * ctx, char * name, GenerateFuncCallback f
 {
 	oberon_object_t * proc;
 	proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, true, false, false);
-	proc -> sysproc = 1;
-	proc -> genfunc = f;
-	proc -> genproc = p;
 	proc -> type = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE);
+	proc -> type -> sysproc = true;
+	proc -> type -> genfunc = f;
+	proc -> type -> genproc = p;
 }
 
 static oberon_expr_t *