X-Git-Url: https://deadsoftware.ru/gitweb?p=dsw-obn.git;a=blobdiff_plain;f=src%2Foberon.c;h=08543355c92b9e421854e751081df3e6827c8d17;hp=30f10ec49af929465b3dfa31885ae7bb3b150fbb;hb=95acec6c3ae8d3c324c84b001a680aa49320790b;hpb=19dd8062f04889d5edbc879d5d9daf89de410aee

diff --git a/src/oberon.c b/src/oberon.c
index 30f10ec..0854335 100644
--- a/src/oberon.c
+++ b/src/oberon.c
@@ -6,6 +6,7 @@
 #include <assert.h>
 #include <stdbool.h>
 #include <math.h>
+#include <float.h>
 
 #include "../include/oberon.h"
 
@@ -148,6 +149,16 @@ oberon_make_integer(oberon_context_t * ctx, int64_t i)
 	return expr;
 }
 
+static oberon_expr_t *
+oberon_make_char(oberon_context_t * ctx, int64_t i)
+{
+	oberon_expr_t * expr;
+	expr = oberon_new_item(MODE_CHAR, ctx -> char_type, true);
+	expr -> item.integer = i;
+	expr -> item.real = i;
+	return expr;
+}
+
 static oberon_expr_t *
 oberon_make_real_typed(oberon_context_t * ctx, double r, oberon_type_t * result)
 {
@@ -3073,7 +3084,8 @@ oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst)
 	oberon_check_dst(ctx, dst);
 	oberon_check_assignment_compatible(ctx, src, dst -> result);
 
-	if(oberon_is_string_type(src -> result))
+	if(oberon_is_array_of_char_type(dst -> result)
+		&& oberon_is_string_type(src -> result))
 	{
 		src -> next = dst;
 		oberon_make_copy_call(ctx, 2, src);
@@ -3669,7 +3681,7 @@ oberon_make_min_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_
 	oberon_expr_t * arg;
 	arg = list_args;
 
-	if(!arg -> is_item || arg -> item.mode != MODE_TYPE)
+	if(!oberon_is_type_expr(arg))
 	{
 		oberon_error(ctx, "MIN accept only type");
 	}
@@ -3681,6 +3693,15 @@ oberon_make_min_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_
 		case OBERON_TYPE_INTEGER:
 			expr = oberon_make_integer(ctx, -powl(2, bits - 1));
 			break;
+		case OBERON_TYPE_BOOLEAN:
+			expr = oberon_make_boolean(ctx, false);
+			break;
+		case OBERON_TYPE_CHAR:
+			expr = oberon_make_char(ctx, 0);
+			break;
+		case OBERON_TYPE_REAL:
+			expr = oberon_make_real_typed(ctx, (bits <= 32) ? (-FLT_MAX) : (-DBL_MAX), arg -> result);
+			break;
 		case OBERON_TYPE_SET:
 			expr = oberon_make_integer(ctx, 0);
 			break;
@@ -3708,7 +3729,7 @@ oberon_make_max_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_
 	oberon_expr_t * arg;
 	arg = list_args;
 
-	if(!arg -> is_item || arg -> item.mode != MODE_TYPE)
+	if(!oberon_is_type_expr(arg))
 	{
 		oberon_error(ctx, "MAX accept only type");
 	}
@@ -3720,6 +3741,15 @@ oberon_make_max_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_
 		case OBERON_TYPE_INTEGER:
 			expr = oberon_make_integer(ctx, powl(2, bits - 1) - 1);
 			break;
+		case OBERON_TYPE_BOOLEAN:
+			expr = oberon_make_boolean(ctx, true);
+			break;
+		case OBERON_TYPE_CHAR:
+			expr = oberon_make_char(ctx, powl(2, bits) - 1);
+			break;
+		case OBERON_TYPE_REAL:
+			expr = oberon_make_real_typed(ctx, (bits <= 32) ? (FLT_MAX) : (DBL_MAX), arg -> result);
+			break;
 		case OBERON_TYPE_SET:
 			expr = oberon_make_integer(ctx, bits);
 			break;
@@ -3746,8 +3776,7 @@ oberon_make_size_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list
 
 	oberon_expr_t * arg;
 	arg = list_args;
-
-	if(!arg -> is_item || arg -> item.mode != MODE_TYPE)
+	if(!oberon_is_type_expr(arg))
 	{
 		oberon_error(ctx, "SIZE accept only type");
 	}
@@ -3790,16 +3819,29 @@ oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_
 	arg = list_args;
 	oberon_check_src(ctx, arg);
 
-	oberon_type_t * result_type;
-	result_type = arg -> result;
-	
-	if(result_type -> class != OBERON_TYPE_INTEGER)
+	if(oberon_is_number_type(arg -> result))
 	{
-		oberon_error(ctx, "ABS accepts only integers");
+		oberon_error(ctx, "ABS accepts only numbers");
 	}
 
 	oberon_expr_t * expr;
-	expr = oberon_new_operator(OP_ABS, result_type, arg, NULL);
+	if(oberon_is_const(arg))
+	{
+		if(oberon_is_real_type(arg -> result))
+		{
+			double x = arg -> item.real;
+			expr = oberon_make_real(ctx, fabsl(x), arg -> result);
+		}
+		else
+		{
+			int64_t x = arg -> item.integer;
+			expr = oberon_make_integer(ctx, llabs(x));
+		}
+	}
+	else
+	{
+		expr = oberon_new_operator(OP_ABS, arg -> result, arg, NULL);
+	}
 	return expr;
 }
 
@@ -3937,7 +3979,7 @@ oberon_make_assert_call(oberon_context_t * ctx, int num_args, oberon_expr_t * li
 	cond = list_args;
 	oberon_check_src(ctx, cond);
 
-	if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
+	if(!oberon_is_boolean_type(cond -> result))
 	{
 		oberon_error(ctx, "expected boolean");
 	}
@@ -3952,7 +3994,7 @@ oberon_make_assert_call(oberon_context_t * ctx, int num_args, oberon_expr_t * li
 		num = list_args -> next;
 		oberon_check_src(ctx, num);
 
-		if(num -> result -> class != OBERON_TYPE_INTEGER)
+		if(!oberon_is_integer_type(num -> result))
 		{
 			oberon_error(ctx, "expected integer");
 		}
@@ -3990,6 +4032,113 @@ oberon_make_halt_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list
 	oberon_generate_halt(ctx, num -> item.integer);
 }
 
+static oberon_expr_t *
+oberon_make_ash_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
+{
+	if(num_args < 2)
+	{
+		oberon_error(ctx, "too few arguments");
+	}
+
+	if(num_args > 2)
+	{
+		oberon_error(ctx, "too mach arguments");
+	}
+
+	oberon_expr_t * arg1;
+	arg1 = list_args;
+	oberon_check_src(ctx, arg1);
+	if(arg1 -> result -> class != OBERON_TYPE_INTEGER)
+	{
+		oberon_error(ctx, "expected integer");
+	}
+
+	oberon_expr_t * arg2;
+	arg2 = list_args -> next;
+	oberon_check_src(ctx, arg2);
+	if(arg2 -> result -> class != OBERON_TYPE_INTEGER)
+	{
+		oberon_error(ctx, "expected integer");
+	}
+
+	oberon_expr_t * expr;
+	if(oberon_is_const(arg1) && oberon_is_const(arg2))
+	{
+		int64_t x = arg1 -> item.integer;
+		int64_t y = arg2 -> item.integer;
+		expr = oberon_make_integer(ctx, x * powl(2, y));
+	}
+	else
+	{
+		expr = oberon_new_operator(OP_ASH, arg1 -> result, arg1, arg2);
+	}
+
+	return expr;
+}
+
+static oberon_expr_t *
+oberon_make_cap_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_check_src(ctx, arg);
+
+	if(!oberon_is_char_type(arg -> result))
+	{
+		oberon_error(ctx, "expected char");
+	}
+
+	oberon_expr_t * expr;
+	if(oberon_is_const(arg))
+	{
+		expr = oberon_make_char(ctx, toupper(arg -> item.integer));
+	}
+	else
+	{
+		expr = oberon_new_operator(OP_CAP, arg -> result, arg, NULL);
+	}
+
+	return expr;
+}
+
+static oberon_expr_t *
+oberon_make_odd_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_check_src(ctx, arg);
+
+	if(!oberon_is_integer_type(arg -> result))
+	{
+		oberon_error(ctx, "expected integer");
+	}
+
+	oberon_expr_t * expr;
+	expr = oberon_make_bin_op(ctx, MOD, arg, oberon_make_integer(ctx, 2));
+	expr = oberon_make_bin_op(ctx, EQUAL, expr, oberon_make_integer(ctx, 1));
+	return expr;
+}
+
 static void
 oberon_new_const(oberon_context_t * ctx, char * name, oberon_expr_t * expr)
 {
@@ -4020,8 +4169,11 @@ oberon_create_context(ModuleImportCallback import_module)
 
 	/* Functions */
 	oberon_new_intrinsic(ctx, "ABS", oberon_make_abs_call, NULL);
+	oberon_new_intrinsic(ctx, "ASH", oberon_make_ash_call, NULL);
+	oberon_new_intrinsic(ctx, "CAP", oberon_make_cap_call, NULL);
 	oberon_new_intrinsic(ctx, "MIN", oberon_make_min_call, NULL);
 	oberon_new_intrinsic(ctx, "MAX", oberon_make_max_call, NULL);
+	oberon_new_intrinsic(ctx, "ODD", oberon_make_odd_call, NULL);
 	oberon_new_intrinsic(ctx, "SIZE", oberon_make_size_call, NULL);
 
 	/* Procedures */