From: ceriel <none@none>
Date: Wed, 14 Aug 1996 07:42:40 +0000 (+0000)
Subject: Added LONGCARD as a local extension
X-Git-Tag: release-5-5~44
X-Git-Url: https://git.ndcode.org/public/gitweb.cgi?a=commitdiff_plain;h=efacd02ffdab639361b28f2aaa8d5a747eb6a5b0;p=ack.git

Added LONGCARD as a local extension
---

diff --git a/lang/m2/comp/LLlex.c b/lang/m2/comp/LLlex.c
index 15fd0f383..14506180d 100644
--- a/lang/m2/comp/LLlex.c
+++ b/lang/m2/comp/LLlex.c
@@ -529,12 +529,30 @@ lexwarning(W_ORDINARY, "character constant out of range");
 					return tk->tk_symb = INTEGER;
 				}
 				if (ch == 'D' && base == 10) {
+				    if (options['l']) {
+					/* Local extension: LONGCARD exists,
+					   so internally also longintorcard_type
+					   exists.
+					*/
+					toktype = longcard_type;
+					if (ovfl == 0 && tk->TOK_INT >= 0 &&
+					    tk->TOK_INT<=max_int[(int)long_size]) {
+					    toktype = longintorcard_type;
+				        }
+				        else if (! chk_bounds(tk->TOK_INT,
+						      full_mask[(int)long_size],
+						      T_CARDINAL)) {
+					    ovfl = 1;
+				        }
+				    }
+				    else {
 					if (ovfl != 0 ||
 					    tk->TOK_INT > max_int[(int)long_size] ||
 					    tk->TOK_INT < 0) {
 						ovfl = 1;
 					}
 					toktype = longint_type;
+				    }
 				}
 				else if (ovfl == 0 && tk->TOK_INT >= 0 &&
 					 tk->TOK_INT<=max_int[(int)int_size]) {
@@ -543,7 +561,7 @@ lexwarning(W_ORDINARY, "character constant out of range");
 				else if (! chk_bounds(tk->TOK_INT,
 						      full_mask[(int)int_size],
 						      T_CARDINAL)) {
-							ovfl = 1;
+					ovfl = 1;
 				}
 				if (ovfl)
 lexwarning(W_ORDINARY, "overflow in constant");
diff --git a/lang/m2/comp/chk_expr.c b/lang/m2/comp/chk_expr.c
index 0dd7f11fc..25f0f2d5c 100644
--- a/lang/m2/comp/chk_expr.c
+++ b/lang/m2/comp/chk_expr.c
@@ -921,10 +921,10 @@ ChkBinOper(expp)
 	tpr = BaseType(exp->nd_RIGHT->nd_type);
 
 	if (intorcard(tpl, tpr) != 0) {
-		if (tpl == intorcard_type) {
+		if (tpl->tp_fund == T_INTORCARD) {
 			 exp->nd_LEFT->nd_type = tpl = tpr;
 		}
-		if (tpr == intorcard_type) {
+		if (tpr->tp_fund == T_INTORCARD) {
 			exp->nd_RIGHT->nd_type = tpr = tpl;
 		}
 	}
@@ -1052,6 +1052,9 @@ ChkUnOper(expp)
 			if (tpr == intorcard_type) {
 				exp->nd_type = int_type;
 			}
+			else if (tpr == longintorcard_type) {
+				exp->nd_type = longint_type;
+			}
 			if (right->nd_class == Value) {
 				cstunary(expp);
 			}
@@ -1166,7 +1169,7 @@ ChkStandard(expp)
 	case S_SHORT:
 	case S_LONG: {
 		t_type *tp;
-		t_type *s1, *s2, *d1, *d2;
+		t_type *s1, *s2, *s3, *d1, *d2, *d3;
 
 		if (!(arg = getarg(&arglink, 0, 0, edf))) {
 			return 0;
@@ -1178,12 +1181,16 @@ ChkStandard(expp)
 			d1 = int_type;
 			s2 = longreal_type;
 			d2 = real_type;
+			s3 = longcard_type;
+			d3 = card_type;
 		}
 		else {
 			d1 = longint_type;
 			s1 = int_type;
 			d2 = longreal_type;
 			s2 = real_type;
+			d3 = longcard_type;
+			s3 = card_type;
 		}
 
 		if (tp == s1) {
@@ -1192,6 +1199,9 @@ ChkStandard(expp)
 		else if (tp == s2) {
 			MkCoercion(&(arglink->nd_LEFT), d2);
 		}
+		else if (options['l'] && tp == s3) {
+			MkCoercion(&(arglink->nd_LEFT), d3);
+		}
 		else {
 			df_error(arg, "unexpected parameter type", edf);
 			break;
@@ -1330,7 +1340,8 @@ ChkStandard(expp)
 		if (! getarg(&arglink, T_REAL, 0, edf)) return 0;
 		MkCoercion(&(arglink->nd_LEFT),
 			   edf->df_value.df_stdname == S_TRUNCD ?
-				longint_type : card_type);
+				options['l'] ? longcard_type : longint_type
+					: card_type);
 		free_it = 1;
 		break;
 
diff --git a/lang/m2/comp/code.c b/lang/m2/comp/code.c
index 2bc8f75c5..4916f127e 100644
--- a/lang/m2/comp/code.c
+++ b/lang/m2/comp/code.c
@@ -687,8 +687,8 @@ RangeCheck(tpl, tpr)
 		return;
 	}
 	tpr = BaseType(tpr);
-	if ((tpl->tp_fund == T_INTEGER && tpr == card_type) ||
-	     (tpr->tp_fund == T_INTEGER && tpl == card_type)) {
+	if ((tpl->tp_fund == T_INTEGER && tpr->tp_fund == T_CARDINAL) ||
+	     (tpr->tp_fund == T_INTEGER && tpl->tp_fund == T_CARDINAL)) {
 		label lb = ++text_label;
 
 		C_dup(tpr->tp_size);
@@ -865,7 +865,7 @@ CodeOper(expr, true_label, false_label)
 
 		Operands(expr);
 		tp = BaseType(leftop->nd_type);
-		if (tp == intorcard_type) tp = BaseType(rightop->nd_type);
+		if (tp->tp_fund == T_INTORCARD) tp = BaseType(rightop->nd_type);
 		size = tp->tp_size;
 		switch (tp->tp_fund)	{
 		case T_INTEGER:
diff --git a/lang/m2/comp/cstoper.c b/lang/m2/comp/cstoper.c
index 2ee060b4c..fafb560f2 100644
--- a/lang/m2/comp/cstoper.c
+++ b/lang/m2/comp/cstoper.c
@@ -615,8 +615,8 @@ cstcall(expp, call)
 		if (tp->tp_fund == T_INTEGER) {
 			expr->nd_INT = max_int[(int)(tp->tp_size)];
 		}
-		else if (tp == card_type) {
-			expr->nd_INT = full_mask[(int)(int_size)];
+		else if (tp->tp_fund == T_CARDINAL) {
+			expr->nd_INT = full_mask[(int)(tp->tp_size)];
 		}
 		else if (tp->tp_fund == T_SUBRANGE) {
 			expr->nd_INT = tp->sub_ub;
diff --git a/lang/m2/comp/em_m2.6 b/lang/m2/comp/em_m2.6
index 29e2eeb53..a122a4a30 100644
--- a/lang/m2/comp/em_m2.6
+++ b/lang/m2/comp/em_m2.6
@@ -65,8 +65,8 @@ make all procedure names global, so that \fIadb\fR(1) understands them.
 .IP \fB\-g\fR
 produce a DBX-style symbol table.
 .IP \fB\-l\fR
-enable local extensions. Currently, the only local extension consists of
-procedure constants.
+enable local extensions. Currently, there are two local extensions:
+procedure constants, and the type LONGCARD.
 .IP \fB\-s\fR
 make INTEGER ranges symmetric, t.i., MIN(INTEGER) = - MAX(INTEGER).
 This is useful for interpreters that use the "real" MIN(INTEGER) to
diff --git a/lang/m2/comp/main.c b/lang/m2/comp/main.c
index 47aa5354c..4b181eb83 100644
--- a/lang/m2/comp/main.c
+++ b/lang/m2/comp/main.c
@@ -221,6 +221,10 @@ AddStandards()
 	EnterType("REAL", real_type);
 	EnterType("LONGREAL", longreal_type);
 	EnterType("CARDINAL", card_type);
+	if (options['l']) {
+		/* local extension: LONGCARD. */
+		EnterType("LONGCARD", longcard_type);
+	}
 	EnterType("(void)", void_type);
 	df = Enter("NIL", D_CONST, address_type, 0);
 	df->con_const = nilconst;
diff --git a/lang/m2/comp/type.H b/lang/m2/comp/type.H
index c05137440..b677fa516 100644
--- a/lang/m2/comp/type.H
+++ b/lang/m2/comp/type.H
@@ -136,6 +136,7 @@ extern t_type
 	*byte_type,
 	*address_type,
 	*intorcard_type,
+	*longintorcard_type,
 	*bitset_type,
 	*void_type,
 	*std_type,
diff --git a/lang/m2/comp/type.c b/lang/m2/comp/type.c
index 38a7e904b..fa0283d73 100644
--- a/lang/m2/comp/type.c
+++ b/lang/m2/comp/type.c
@@ -70,6 +70,7 @@ t_type
 	*byte_type,
 	*address_type,
 	*intorcard_type,
+	*longintorcard_type,
 	*bitset_type,
 	*void_type,
 	*std_type,
@@ -187,6 +188,7 @@ InitTypes()
 	longcard_type = standard_type(T_CARDINAL, long_align, long_size);
 	card_type = standard_type(T_CARDINAL, int_align, int_size);
 	intorcard_type = standard_type(T_INTORCARD, int_align, int_size);
+	longintorcard_type = standard_type(T_INTORCARD, long_align, long_size);
 
 	/* floating types
 	*/
@@ -844,13 +846,13 @@ t_type *
 intorcard(left, right)
 	register t_type *left, *right;
 {
-	if (left == intorcard_type) {
+	if (left->tp_fund == T_INTORCARD) {
 		t_type *tmp = left;
 		left = right;
 		right = tmp;
 	}
-	if (right == intorcard_type) {
-		if (left == int_type || left == card_type) {
+	if (right->tp_fund == T_INTORCARD) {
+		if (left->tp_fund == T_INTEGER || left->tp_fund == T_CARDINAL) {
 			return left;
 		}
 	}
diff --git a/lang/m2/comp/typequiv.c b/lang/m2/comp/typequiv.c
index 1cec5ee22..2a3efbb7c 100644
--- a/lang/m2/comp/typequiv.c
+++ b/lang/m2/comp/typequiv.c
@@ -111,8 +111,8 @@ TstCompat(tp1, tp2)
 
 	tp1 = BaseType(tp1);
 	tp2 = BaseType(tp2);
-	if (tp2 != intorcard_type &&
-	    (tp1 == intorcard_type || tp1 == address_type)) {
+	if (tp2->tp_fund != T_INTORCARD &&
+	    (tp1->tp_fund == T_INTORCARD || tp1 == address_type)) {
 		t_type *tmp = tp2;
 		
 		tp2 = tp1;
@@ -125,10 +125,15 @@ TstCompat(tp1, tp2)
 		&&
 		   (tp1 == int_type || tp1 == card_type || tp1 == address_type)
 		)
+	    ||
+		(  tp2 == longintorcard_type
+		&&
+		   (tp1 == longint_type || tp1 == longcard_type || tp1 == address_type)
+		)
 	    ||
 		(  tp2 == address_type
 		&& 
-	          ( tp1 == card_type || tp1->tp_fund == T_POINTER)
+	          ( tp1->tp_fund == T_CARDINAL || tp1->tp_fund == T_POINTER)
 		)
 	;
 }