From: ceriel <none@none>
Date: Wed, 6 Apr 1988 18:14:50 +0000 (+0000)
Subject: some minor changes and a fix in pointer arithmetic
X-Git-Tag: release-5-5~3503
X-Git-Url: https://git.ndcode.org/public/gitweb.cgi?a=commitdiff_plain;h=c8a728969de2ddb797eebaed5c21a68c5ebdf958;p=ack.git

some minor changes and a fix in pointer arithmetic
---

diff --git a/lang/m2/comp/chk_expr.c b/lang/m2/comp/chk_expr.c
index 88c1a7f19..47928a678 100644
--- a/lang/m2/comp/chk_expr.c
+++ b/lang/m2/comp/chk_expr.c
@@ -1021,7 +1021,6 @@ ChkStandard(expp)
 	t_node *arg = expp;
 	register t_node *left = expp->nd_left;
 	register t_def *edf = left->nd_def;
-	t_type *basetype;
 	int free_it = 0;
 
 	assert(left->nd_class == Def);
@@ -1030,17 +1029,19 @@ ChkStandard(expp)
 	switch(edf->df_value.df_stdname) {
 	case S_ABS:
 		if (!(left = getarg(&arg, T_NUMERIC, 0, edf))) return 0;
-		basetype = BaseType(left->nd_type);
-		MkCoercion(&(arg->nd_left), basetype);
-		left = arg->nd_left;
-		expp->nd_type = left->nd_type;
-		if (left->nd_class == Value &&
-		    expp->nd_type->tp_fund != T_REAL) {
-			cstcall(expp, S_ABS);
-		}
-		else if (basetype->tp_fund != T_INTEGER &&
-			 basetype->tp_fund != T_REAL) {
+		expp->nd_type = BaseType(left->nd_type);
+		MkCoercion(&(arg->nd_left), expp->nd_type);
+		switch(expp->nd_type->tp_fund) {
+		case T_REAL:
+			break;
+		case T_INTEGER:
+			if (arg->nd_left->nd_class == Value) {
+				cstcall(expp,S_ABS);
+			}
+			break;
+		default:
 			free_it = 1;
+			break;
 		}
 		break;
 
@@ -1050,13 +1051,6 @@ ChkStandard(expp)
 		if (left->nd_class == Value) cstcall(expp, S_CAP);
 		break;
 
-	case S_CHR:
-		expp->nd_type = char_type;
-		if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0;
-		MkCoercion(&(arg->nd_left), char_type);
-		free_it = 1;
-		break;
-
 	case S_FLOATD:
 	case S_FLOAT:
 		if (! getarg(&arg, T_INTORCARD, 0, edf)) return 0;
@@ -1152,9 +1146,13 @@ ChkStandard(expp)
 		break;
 
 	case S_ORD:
-		if (! getarg(&arg, T_DISCRETE, 0, edf)) return 0;
-		MkCoercion(&(arg->nd_left), card_type);
-		free_it = 1;
+		if (! (left = getarg(&arg, T_NOSUB, 0, edf))) return 0;
+		MkCoercion(&(arg->nd_left), BaseType(left->nd_type));
+		expp->nd_type = card_type;
+		if (arg->nd_left->nd_class == Value) {
+			arg->nd_left->nd_type = card_type;
+			free_it = 1;
+		}
 		break;
 
 #ifndef STRICT_3RD_ED
@@ -1220,17 +1218,15 @@ ChkStandard(expp)
 
 	case S_TRUNCD:
 	case S_TRUNC:
-		expp->nd_type = card_type;
-		if (edf->df_value.df_stdname == S_TRUNCD) {
-			expp->nd_type = longint_type;
-		}
 		if (! getarg(&arg, T_REAL, 0, edf)) return 0;
-		MkCoercion(&(arg->nd_left), expp->nd_type);
+		MkCoercion(&(arg->nd_left),
+			   edf->df_value.df_stdname == S_TRUNCD ?
+				longint_type : card_type);
 		free_it = 1;
 		break;
 
 	case S_VAL:
-		if (!(left = getname(&arg, D_ISTYPE, T_DISCRETE, edf))) {
+		if (!(left = getname(&arg, D_ISTYPE, T_NOSUB, edf))) {
 			return 0;
 		}
 		expp->nd_type = left->nd_def->df_type;
@@ -1238,9 +1234,16 @@ ChkStandard(expp)
 		arg->nd_right = 0;
 		FreeNode(arg);
 		arg = expp;
-		if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0;
-		MkCoercion(&(arg->nd_left), expp->nd_type);
-		free_it = 1;
+		/* fall through */
+	case S_CHR:
+		if (! getarg(&arg, T_CARDINAL, 0, edf)) return 0;
+		if (edf->df_value.df_stdname == S_CHR) {
+			expp->nd_type = char_type;
+		}
+		if (expp->nd_type != int_type) {
+			MkCoercion(&(arg->nd_left), expp->nd_type);
+			free_it = 1;
+		}
 		break;
 
 	case S_ADR:
@@ -1344,10 +1347,16 @@ ChkCast(expp)
 		  df);
 	}
 
+	expp->nd_right->nd_left = 0;
+	FreeLR(expp);
 	if (arg->nd_class == Value) {
-		expp->nd_right->nd_left = 0;
-		FreeLR(expp);
 		*expp = *arg;
+		free_node(arg);
+	}
+	else {
+		expp->nd_symb = CAST;
+		expp->nd_class = Uoper;
+		expp->nd_right = arg;
 	}
 	expp->nd_type = lefttype;
 
diff --git a/lang/m2/comp/code.c b/lang/m2/comp/code.c
index 15f521122..e9d2167eb 100644
--- a/lang/m2/comp/code.c
+++ b/lang/m2/comp/code.c
@@ -319,15 +319,6 @@ CodeCall(nd)
 		return;
 	}	
 
-	if (IsCast(left)) {
-		/* it was just a cast. Simply ignore it
-		*/
-		CodePExpr(right->nd_left);
-		*nd = *(right->nd_left);
-		nd->nd_type = left->nd_def->df_type;
-		return;
-	}
-
 	assert(IsProcCall(left));
 
 	if (right) {
@@ -501,6 +492,11 @@ CodeStd(nd)
 	}
 
 	switch(std) {
+	case S_ORD:
+	case S_VAL:
+		CodePExpr(left);
+		break;
+
 	case S_ABS:
 		CodePExpr(left);
 		if (tp->tp_fund == T_INTEGER) {
@@ -517,8 +513,7 @@ CodeStd(nd)
 
 	case S_CAP:
 		CodePExpr(left);
-		c_loc(0137);	/* ASCII assumed */
-		C_and(word_size);
+		C_cal("cap");
 		break;
 
 	case S_HIGH:
@@ -706,15 +701,17 @@ CodeOper(expr, true_label, false_label)
 		case T_REAL:
 			C_sbf(tp->tp_size);
 			break;
-		case T_CARDINAL:
+		case T_POINTER:
+		case T_EQUAL:
 			if (rightop->nd_type == address_type) {
-				C_sbs(pointer_size);
+				C_sbs(tp->tp_size);
 				break;
 			}
-			/* fall through */
-		case T_POINTER:
-		case T_EQUAL:
+			C_ngi(rightop->nd_type->tp_size);
+			C_ads(rightop->nd_type->tp_size);
+			break;
 		case T_INTORCARD:
+		case T_CARDINAL:
 			subu(tp->tp_size);
 			break;
 		case T_SET:
@@ -994,6 +991,8 @@ CodeUoper(nd)
 		CodeCoercion(nd->nd_right->nd_type, tp);
 		RangeCheck(tp, nd->nd_right->nd_type);
 		break;
+	case CAST:
+		break;
 	default:
 		crash("Bad unary operator");
 	}
diff --git a/lang/m2/comp/tokenname.c b/lang/m2/comp/tokenname.c
index 779076701..f1a0d1c46 100644
--- a/lang/m2/comp/tokenname.c
+++ b/lang/m2/comp/tokenname.c
@@ -86,6 +86,7 @@ struct tokenname tkidf[] =	{	/* names of the identifier tokens */
 struct tokenname tkinternal[] = {	/* internal keywords	*/
 	{PROGRAM, ""},
 	{COERCION, ""},
+	{CAST, ""},
 	{0, "0"}
 };
 
diff --git a/lang/m2/comp/type.H b/lang/m2/comp/type.H
index 4ff1930d3..fc626a7bd 100644
--- a/lang/m2/comp/type.H
+++ b/lang/m2/comp/type.H
@@ -95,6 +95,7 @@ struct type	{
 #define T_ARRAY		0x2000
 #define T_STRING	0x4000
 #define T_INTORCARD	(T_INTEGER|T_CARDINAL)
+#define T_NOSUB		(T_INTORCARD|T_ENUMERATION|T_CHAR)
 #define T_NUMERIC	(T_INTORCARD|T_REAL)
 #define T_INDEX		(T_ENUMERATION|T_CHAR|T_SUBRANGE)
 #define T_DISCRETE	(T_INDEX|T_INTORCARD)