From: DeaDDooMER <deaddoomer@deadsoftware.ru>
Date: Mon, 24 Jul 2017 19:42:56 +0000 (+0300)
Subject: Добавлены встроенные процедуры
X-Git-Url: http://deadsoftware.ru/gitweb?a=commitdiff_plain;h=1bf625553dc35ac4a5c1afceb6950fd44776a424;p=dsw-obn.git

Добавлены встроенные процедуры
---

diff --git a/generator.c b/generator.c
index b17a8cd..709e5a6 100644
--- a/generator.c
+++ b/generator.c
@@ -519,14 +519,19 @@ struct {
 		enum gcc_jit_comparison comp_op;
 	};
 } op_table[] = {
-	{ 0, .unary_op = GCC_JIT_UNARY_OP_LOGICAL_NEGATE },
 	{ 0, .unary_op = GCC_JIT_UNARY_OP_MINUS },
+	{ 0, .unary_op = GCC_JIT_UNARY_OP_BITWISE_NEGATE },
+	{ 0, .unary_op = GCC_JIT_UNARY_OP_LOGICAL_NEGATE },
+	{ 0, .unary_op = GCC_JIT_UNARY_OP_ABS },
 
 	{ 1, .binary_op = GCC_JIT_BINARY_OP_PLUS },
 	{ 1, .binary_op = GCC_JIT_BINARY_OP_MINUS },
 	{ 1, .binary_op = GCC_JIT_BINARY_OP_MULT },
 	{ 1, .binary_op = GCC_JIT_BINARY_OP_DIVIDE },
 	{ 1, .binary_op = GCC_JIT_BINARY_OP_MODULO },
+	{ 1, .binary_op = GCC_JIT_BINARY_OP_BITWISE_AND },
+	{ 1, .binary_op = GCC_JIT_BINARY_OP_BITWISE_XOR },
+	{ 1, .binary_op = GCC_JIT_BINARY_OP_BITWISE_OR },
 	{ 1, .binary_op = GCC_JIT_BINARY_OP_LOGICAL_AND },
 	{ 1, .binary_op = GCC_JIT_BINARY_OP_LOGICAL_OR },
 
diff --git a/notes b/notes
index ec0a69c..3c1b0db 100644
--- a/notes
+++ b/notes
@@ -1,4 +1,4 @@
-- нужно сделать объявление встроенных процедур
+- нету тестовых процедур для ввода-вывода
 - нету процедуры NEW
 - нету открытых массивов
 
@@ -10,7 +10,7 @@
 - не реализована свёртка констант
 - не протестированы типы разнных размеров
 
-- не реализовано расширение типа record
+- не реализовано расширение типа record (libgccjit не умеет в классы)
 - не работает присваивание к переменным-процедурам.
 - не реализован автокаст (libgccjit сам разруливает)
 - libgccjit не умеет в локальные функции (опять пилить костыли как в jvm)
diff --git a/oberon.c b/oberon.c
index c3a6f86..6dd84f1 100644
--- a/oberon.c
+++ b/oberon.c
@@ -777,6 +777,76 @@ oberon_autocast_call(oberon_context_t * ctx, oberon_expr_t * desig)
 	}
 }
 
+static oberon_expr_t *
+oberon_make_call_func(oberon_context_t * ctx, oberon_object_t * proc, int num_args, oberon_expr_t * list_args)
+{
+	if(proc -> class != OBERON_CLASS_PROC)
+	{
+		oberon_error(ctx, "not a procedure");
+	}
+
+	oberon_expr_t * call;
+
+	if(proc -> sysproc)
+	{
+		if(proc -> genfunc == NULL)
+		{
+			oberon_error(ctx, "not a function-procedure");
+		}
+
+		call = proc -> genfunc(ctx, num_args, list_args);
+	}
+	else
+	{
+		if(proc -> type -> base -> class == OBERON_TYPE_VOID)
+		{
+			oberon_error(ctx, "attempt to call procedure in expression");
+		}
+
+		call = oberon_new_item(MODE_CALL, proc -> type -> base);
+		call -> item.var = proc;
+		call -> item.num_args = num_args;
+		call -> item.args = list_args;
+		oberon_autocast_call(ctx, call);
+	}
+
+	return call;
+}
+
+static void
+oberon_make_call_proc(oberon_context_t * ctx, oberon_object_t * proc, int num_args, oberon_expr_t * list_args)
+{
+	if(proc -> class != OBERON_CLASS_PROC)
+	{
+		oberon_error(ctx, "not a procedure");
+	}
+
+	if(proc -> sysproc)
+	{
+		if(proc -> genproc == NULL)
+		{
+			oberon_error(ctx, "requres non-typed procedure");
+		}
+
+		proc -> genproc(ctx, num_args, list_args);
+	}
+	else
+	{
+		if(proc -> type -> base -> class != OBERON_TYPE_VOID)
+		{
+			oberon_error(ctx, "attempt to call function as non-typed procedure");
+		}
+
+		oberon_expr_t * call;
+		call = oberon_new_item(MODE_CALL, proc -> type -> base);
+		call -> item.var = proc;
+		call -> item.num_args = num_args;
+		call -> item.args = list_args;
+		oberon_autocast_call(ctx, call);
+		oberon_generate_call_proc(ctx, call);
+	}
+}
+
 #define ISEXPR(x) \
 	(((x) == PLUS) \
 	|| ((x) == MINUS) \
@@ -905,6 +975,7 @@ oberon_designator(oberon_context_t * ctx)
 			expr = oberon_new_item(MODE_VAR, var -> type);
 			break;
 		case OBERON_CLASS_PROC:
+			//expr = oberon_make_call_expr(var, 0, NULL);
 			expr = oberon_new_item(MODE_CALL, var -> type);
 			break;
 		default:
@@ -948,17 +1019,37 @@ oberon_designator(oberon_context_t * ctx)
 }
 
 static oberon_expr_t *
-oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr)
+oberon_opt_func_parens(oberon_context_t * ctx, oberon_expr_t * expr)
 {
 	assert(expr -> is_item == 1);
 
 	if(ctx -> token == LPAREN)
 	{
-		if(expr -> result -> class != OBERON_TYPE_PROCEDURE)
+		oberon_assert_token(ctx, LPAREN);
+
+		int num_args = 0;
+		oberon_expr_t * arguments = NULL;
+
+		if(ISEXPR(ctx -> token))
 		{
-			oberon_error(ctx, "not a procedure");
+			oberon_expr_list(ctx, &num_args, &arguments, 0);
 		}
 
+		expr = oberon_make_call_func(ctx, expr -> item.var, num_args, arguments);
+
+		oberon_assert_token(ctx, RPAREN);
+	}
+
+	return expr;
+}
+
+static void
+oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr)
+{
+	assert(expr -> is_item == 1);
+
+	if(ctx -> token == LPAREN)
+	{
 		oberon_assert_token(ctx, LPAREN);
 
 		int num_args = 0;
@@ -969,16 +1060,10 @@ oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr)
 			oberon_expr_list(ctx, &num_args, &arguments, 0);
 		}
 
-		expr -> result = expr -> item.var -> type -> base;
-		expr -> item.mode = MODE_CALL;
-		expr -> item.num_args = num_args;
-		expr -> item.args = arguments;
-		oberon_assert_token(ctx, RPAREN);
+		oberon_make_call_proc(ctx, expr -> item.var, num_args, arguments);
 
-		oberon_autocast_call(ctx, expr);
+		oberon_assert_token(ctx, RPAREN);
 	}
-
-	return expr;
 }
 
 static oberon_expr_t *
@@ -990,7 +1075,7 @@ oberon_factor(oberon_context_t * ctx)
 	{
 		case IDENT:
 			expr = oberon_designator(ctx);
-			expr = oberon_opt_proc_parens(ctx, expr);
+			expr = oberon_opt_func_parens(ctx, expr);
 			break;
 		case INTEGER:
 			expr = oberon_new_item(MODE_INTEGER, ctx -> int_type);
@@ -2118,21 +2203,6 @@ oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst)
 	oberon_generate_assign(ctx, src, dst);
 }
 
-static void
-oberon_make_call(oberon_context_t * ctx, oberon_expr_t * desig)
-{
-	if(desig -> result -> class != OBERON_TYPE_VOID)
-	{
-		if(desig -> result -> class != OBERON_TYPE_PROCEDURE)
-		{
-			oberon_error(ctx, "procedure with result");
-		}
-	}
-
-	oberon_autocast_call(ctx, desig);
-	oberon_generate_call_proc(ctx, desig);
-}
-
 static void
 oberon_statement(oberon_context_t * ctx)
 {
@@ -2150,8 +2220,7 @@ oberon_statement(oberon_context_t * ctx)
 		}
 		else
 		{
-			item1 = oberon_opt_proc_parens(ctx, item1);
-			oberon_make_call(ctx, item1);
+			oberon_opt_proc_parens(ctx, item1);
 		}
 	}
 	else if(ctx -> token == RETURN)
@@ -2233,6 +2302,58 @@ register_default_types(oberon_context_t * ctx)
 	oberon_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type);
 }
 
+static void
+oberon_new_intrinsic_function(oberon_context_t * ctx, char * name, GenerateFuncCallback generate)
+{
+	oberon_object_t * proc;
+	proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC);
+	proc -> sysproc = 1;
+	proc -> genfunc = generate;
+	proc -> type = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE);
+}
+
+/*
+static void
+oberon_new_intrinsic_procedure(oberon_context_t * ctx, char * name, GenerateProcCallback generate)
+{
+	oberon_object_t * proc;
+	proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC);
+	proc -> sysproc = 1;
+	proc -> genproc = generate;
+	proc -> type = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE);
+}
+*/
+
+static oberon_expr_t *
+oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
+{
+	if(num_args < 1)
+	{
+		oberon_error(ctx, "too few arguments");
+	}
+
+	if(num_args > 1)
+	{
+		oberon_error(ctx, "too mach arguments");
+	}
+
+	oberon_expr_t * arg;
+	arg = list_args;
+
+	oberon_type_t * result_type;
+	result_type = arg -> result;
+	
+	if(result_type -> class != OBERON_TYPE_INTEGER)
+	{
+		oberon_error(ctx, "ABS accepts only integers");
+	}
+
+
+	oberon_expr_t * expr;
+	expr = oberon_new_operator(OP_ABS, result_type, arg, NULL);
+	return expr;
+}
+
 oberon_context_t *
 oberon_create_context()
 {
@@ -2245,7 +2366,8 @@ oberon_create_context()
 
 	oberon_generator_init_context(ctx);
 
-	register_default_types(ctx);	
+	register_default_types(ctx);
+	oberon_new_intrinsic_function(ctx, "ABS", oberon_make_abs_call);
 
 	return ctx;
 }
diff --git a/oberon.h b/oberon.h
index 30c4cbe..09a24c9 100644
--- a/oberon.h
+++ b/oberon.h
@@ -139,6 +139,11 @@ enum
 	OBERON_CLASS_FIELD
 };
 
+enum
+{
+	OBERON_SYSPROC_ABS
+};
+
 /*
  * Структура oberon_object_s (oberon_object_t) описывает все
  * объявления которые могут иметь имя. От констант, до процедур.
@@ -149,6 +154,9 @@ enum
  *   next -- ссылка на следующий объект в списке.
  */
 
+typedef oberon_expr_t * (*GenerateFuncCallback)(oberon_context_t *, int, oberon_expr_t *);
+typedef void (*GenerateProcCallback)(oberon_context_t *, int, oberon_expr_t *);
+
 struct oberon_object_s
 {
 	char * name;
@@ -159,9 +167,12 @@ struct oberon_object_s
 	int initialized;
 
 	oberon_object_t * parent;
+
 	oberon_scope_t * scope; // for proc
 	int has_return; // for proc
-
+	int sysproc;
+	GenerateFuncCallback genfunc;
+	GenerateProcCallback genproc;
 
 	oberon_type_t * type;
 	oberon_item_t * value;
@@ -241,15 +252,22 @@ enum
 
 enum
 {
-	OP_LOGIC_NOT,
 	OP_UNARY_MINUS,
+	OP_BITWISE_NOT,
+	OP_LOGIC_NOT,
+	OP_ABS,
+
 	OP_ADD,
 	OP_SUB,
 	OP_MUL,
 	OP_DIV,
 	OP_MOD,
+	OP_BITWISE_AND,
+	OP_BITWISE_XOR,
+	OP_BITWISE_OP,
 	OP_LOGIC_AND,
 	OP_LOGIC_OR,
+
 	OP_EQ,
 	OP_NEQ,
 	OP_LSS,
diff --git a/test.c b/test.c
index b07a08d..914764e 100644
--- a/test.c
+++ b/test.c
@@ -21,8 +21,9 @@ static const char source[] =
 	"PROCEDURE ^ Tier(x : INTEGER);"
 	""
 	"BEGIN;"
-	"	i := 666;"
-	"	Tier(1);"
+	"	i := ABS(-666);"
+	"	Tier(i);"
+	"	ABS(1);"
 	"END Test."
 ;