version with better overflow checking

lang/m2/comp/LLlex.c

@@ -461,7 +461,9 @@ again:
 				base = 8;
 				/* Fall through */
 				
-			case End:
+			case End: {
+				int sgnswtch = 0;
+
 				*np = '\0';
 				if (np >= &buf[NUMSIZE]) {
 					tk->TOK_INT = 1;
@@ -470,27 +472,38 @@ again:
 				else {
 					np = &buf[1];
 					while (*np == '0') np++;
-					tk->TOK_INT = str2long(np, base);
-					if (strlen(np) > 14 /* ??? */ ||
-				    	    tk->TOK_INT < 0) {
-lexwarning(W_ORDINARY, "overflow in constant");
+					tk->TOK_INT = 0;
+					while (*np) {
+						arith old = tk->TOK_INT;
+
+						tk->TOK_INT = tk->TOK_INT*base
+							+ (*np++ - '0');
+						sgnswtch += (old < 0) ^
+							    (tk->TOK_INT < 0);
 					}
 				}
-				if (ch == 'C' && base == 8) {
+				toktype = card_type;
+				if (sgnswtch >= 2) {
+lexwarning(W_ORDINARY, "overflow in constant");
+				}
+				else if (ch == 'C' && base == 8) {
 					toktype = char_type;
-					if (tk->TOK_INT<0 || tk->TOK_INT>255) {
+					if (sgnswtch != 0 || tk->TOK_INT>255) {
 lexwarning(W_ORDINARY, "character constant out of range");
 					}
 				}
 				else if (ch == 'D' && base == 10) {
+					if (sgnswtch != 0) {
+lexwarning(W_ORDINARY, "overflow in constant");
+					}
 					toktype = longint_type;
 				}
-				else if (tk->TOK_INT>=0 &&
-					 tk->TOK_INT<=max_int) {
+				else if (sgnswtch == 0 &&
+					 tk->TOK_INT<=max_int[(int)word_size]) {
 					toktype = intorcard_type;
 				}
-				else	toktype = card_type;
 				return tk->tk_symb = INTEGER;
+				}
 
 			case OptReal:
 				/*	The '.' could be the first of the '..'

lang/m2/comp/chk_expr.c

@@ -103,7 +103,7 @@ MkCoercion(pnd, tp)
 			}
 			break;
 		case T_INTEGER:  {
-			long i = ~int_mask[(int)(tp->tp_size)];
+			long i = ~max_int[(int)(tp->tp_size)];
 			long j = nd->nd_INT & i;
 
 			if ((nd_tp->tp_fund == T_INTEGER &&
@@ -896,7 +896,10 @@ ChkBinOper(expp)
 	}
 	else if ( tpl->tp_fund != T_REAL &&
 		  left->nd_class == Value && right->nd_class == Value) {
-		cstbin(expp);
+		if (expp->nd_left->nd_type->tp_fund == T_INTEGER) {
+			cstibin(expp);
+		}
+		else	cstubin(expp);
 	}
 
 	return 1;

lang/m2/comp/code.c

@@ -474,6 +474,28 @@ CodePString(nd, tp)
 	C_loi(szarg);
 }
 
+static
+subu(sz)
+	arith sz;
+{
+	if (options['R']) C_sbu(sz);
+	else {
+		C_cal(sz == word_size ? "subu" : "subul");
+		C_asp(sz);
+	}
+}
+
+static
+addu(sz)
+	arith sz;
+{
+	if (options['R']) C_adu(sz);
+	else {
+		C_cal(sz == word_size ? "addu" : "addul");
+		C_asp(sz);
+	}
+}
+
 CodeStd(nd)
 	t_node *nd;
 {
@@ -559,11 +581,11 @@ CodeStd(nd)
 		}
 		if (std == S_DEC) {
 			if (tp->tp_fund == T_INTEGER) C_sbi(size);
-			else	C_sbu(size);
+			else	subu(size);
 		}
 		else {
 			if (tp->tp_fund == T_INTEGER) C_adi(size);
-			else	C_adu(size);
+			else	addu(size);
 		}
 		if (size == word_size) {
 			RangeCheck(left->nd_type, tp->tp_fund == T_INTEGER ?
@@ -673,7 +695,7 @@ CodeOper(expr, true_label, false_label)
 		case T_EQUAL:
 		case T_CARDINAL:
 		case T_INTORCARD:
-			C_adu(tp->tp_size);
+			addu(tp->tp_size);
 			break;
 		case T_SET:
 			C_ior(tp->tp_size);
@@ -695,7 +717,7 @@ CodeOper(expr, true_label, false_label)
 		case T_EQUAL:
 		case T_CARDINAL:
 		case T_INTORCARD:
-			C_sbu(tp->tp_size);
+			subu(tp->tp_size);
 			break;
 		case T_SET:
 			C_com(tp->tp_size);
@@ -715,7 +737,15 @@ CodeOper(expr, true_label, false_label)
 		case T_EQUAL:
 		case T_CARDINAL:
 		case T_INTORCARD:
-			C_mlu(tp->tp_size);
+			if (options['R']) {
+				C_mlu(tp->tp_size);
+			}
+			else {
+				C_cal(tp->tp_size <= word_size ?
+					"mulu" :
+					"mulul");
+				C_asp(tp->tp_size);
+			}
 			break;
 		case T_REAL:
 			C_mlf(tp->tp_size);

lang/m2/comp/const.h

@@ -13,7 +13,5 @@ extern long
 	mach_long_sign;	/* sign bit of the machine long */
 extern int
 	mach_long_size;	/* size of long on this machine == sizeof(long) */
-extern arith
-	max_int;	/* maximum integer on target machine	*/
 extern unsigned int
 	wrd_bits;	/* Number of bits in a word */

lang/m2/comp/cstoper.c

@@ -27,13 +27,27 @@
 long mach_long_sign;	/* sign bit of the machine long */
 int mach_long_size;	/* size of long on this machine == sizeof(long) */
 long full_mask[MAXSIZE];/* full_mask[1] == 0xFF, full_mask[2] == 0xFFFF, .. */
-long int_mask[MAXSIZE];	/* int_mask[1] == 0x7F, int_mask[2] == 0x7FFF, .. */
-arith max_int;		/* maximum integer on target machine	*/
+long max_int[MAXSIZE];	/* max_int[1] == 0x7F, max_int[2] == 0x7FFF, .. */
+long min_int[MAXSIZE];	/* min_int[1] == 0xFFFFFF80, min_int[2] = 0xFFFF8000,
+			   ...
+			*/
 unsigned int wrd_bits;	/* number of bits in a word */
 
 extern char options[];
 
-static char ovflow[] = "overflow in constant expression";
+overflow(expp)
+	t_node *expp;
+{
+	node_warning(expp, W_ORDINARY, "overflow in constant expression");
+}
+	
+arith
+ar_abs(i)
+	arith i;
+{
+
+	return i < 0 ? -i : i;
+}
 
 cstunary(expp)
 	register t_node *expp;
@@ -50,8 +64,8 @@ cstunary(expp)
 	*/
 
 	case '-':
-		if (right->nd_INT < -int_mask[(int)(right->nd_type->tp_size)])
-			node_warning(expp, W_ORDINARY, ovflow);
+		if (right->nd_INT == min_int[(int)(right->nd_type->tp_size)])
+			overflow(expp);
 		
 		expp->nd_INT = -right->nd_INT;
 		break;
@@ -73,71 +87,65 @@ cstunary(expp)
 }
 
 STATIC
-divide(pdiv, prem, uns)
+divide(pdiv, prem)
 	arith *pdiv, *prem;
 {
-	/*	Divide *pdiv by *prem, and store result in *pdiv,
+	/*	Unsigned divide *pdiv by *prem, and store result in *pdiv,
 		remainder in *prem
 	*/
 	register arith o1 = *pdiv;
 	register arith o2 = *prem;
 
-	if (uns)	{
-		/*	this is more of a problem than you might
-			think on C compilers which do not have
-			unsigned long.
-		*/
-		if (o2 & mach_long_sign)	{/* o2 > max_long */
-			if (! (o1 >= 0 || o1 < o2)) {
-				/*	this is the unsigned test
-					o1 < o2 for o2 > max_long
-				*/
-				*prem = o2 - o1;
-				*pdiv = 1;
-			}
-			else {
-				*pdiv = 0;
-			}
-		}
-		else	{		/* o2 <= max_long */
-			long half, bit, hdiv, hrem, rem;
-
-			half = (o1 >> 1) & ~mach_long_sign;
-			bit = o1 & 01;
-			/*	now o1 == 2 * half + bit
-				and half <= max_long
-				and bit <= max_long
+	/*	this is more of a problem than you might
+		think on C compilers which do not have
+		unsigned long.
+	*/
+	if (o2 & mach_long_sign)	{/* o2 > max_long */
+		if (! (o1 >= 0 || o1 < o2)) {
+			/*	this is the unsigned test
+				o1 < o2 for o2 > max_long
 			*/
-			hdiv = half / o2;
-			hrem = half % o2;
-			rem = 2 * hrem + bit;
-			*pdiv = 2*hdiv;
-			*prem = rem;
-			if (rem < 0 || rem >= o2) {
-				/*	that is the unsigned compare
-					rem >= o2 for o2 <= max_long
-				*/
-				*pdiv += 1;
-				*prem -= o2;
-			}
+			*prem = o2 - o1;
+			*pdiv = 1;
+		}
+		else {
+			*pdiv = 0;
 		}
 	}
-	else {
-		*pdiv = o1 / o2;		/* ??? */
-		*prem = o1 - *pdiv * o2;
+	else	{		/* o2 <= max_long */
+		long half, bit, hdiv, hrem, rem;
+
+		half = (o1 >> 1) & ~mach_long_sign;
+		bit = o1 & 01;
+		/*	now o1 == 2 * half + bit
+			and half <= max_long
+			and bit <= max_long
+		*/
+		hdiv = half / o2;
+		hrem = half % o2;
+		rem = 2 * hrem + bit;
+		*pdiv = 2*hdiv;
+		*prem = rem;
+		if (rem < 0 || rem >= o2) {
+			/*	that is the unsigned compare
+				rem >= o2 for o2 <= max_long
+			*/
+			*pdiv += 1;
+			*prem -= o2;
+		}
 	}
 }
 
-cstbin(expp)
+cstibin(expp)
 	register t_node *expp;
 {
 	/*	The binary operation in "expp" is performed on the constant
-		expressions below it, and the result restored in
-		expp.
+		expressions below it, and the result restored in expp.
+		This version is for INTEGER expressions.
 	*/
 	arith o1 = expp->nd_left->nd_INT;
 	arith o2 = expp->nd_right->nd_INT;
-	register int uns = expp->nd_left->nd_type != int_type;
+	register int sz = expp->nd_type->tp_size;
 
 	assert(expp->nd_class == Oper);
 	assert(expp->nd_left->nd_class == Value);
@@ -145,6 +153,19 @@ cstbin(expp)
 
 	switch (expp->nd_symb)	{
 	case '*':
+		if (o1 == 0 || o2 == 0) {
+			o1 = 0;
+			break;
+		}
+		if ((o1 > 0 && o2 > 0) || (o1 < 0 && o2 < 0)) {
+			if (o1 == min_int[sz] ||
+			    o2 == min_int[sz] ||
+			    max_int[sz] / ar_abs(o1) < ar_abs(o2)) overflow(expp);
+		}
+		else if (o1 > 0) {
+			if (min_int[sz] / o1 > o2) overflow(expp);
+		}
+		else if (min_int[sz] / o2 > o1) overflow(expp);
 		o1 *= o2;
 		break;
 
@@ -153,7 +174,7 @@ cstbin(expp)
 			node_error(expp, "division by 0");
 			return;
 		}
-		divide(&o1, &o2, uns);
+		o1 /= o2;	/* ??? */
 		break;
 
 	case MOD:
@@ -161,19 +182,27 @@ cstbin(expp)
 			node_error(expp, "modulo by 0");
 			return;
 		}
-		divide(&o1, &o2, uns);
-		o1 = o2;
+		o1 %= o2;	/* ??? */
 		break;
 
 	case '+':
+		if (o1 > 0 && o2 > 0) {
+			if (max_int[sz] - o1 < o2) overflow(expp);
+		}
+		else if (o1 < 0 && o2 < 0) {
+			if (min_int[sz] - o1 > o2) overflow(expp);
+		}
 		o1 += o2;
 		break;
 
 	case '-':
-		o1 -= o2;
-		if (expp->nd_type->tp_fund == T_INTORCARD) {
-			if (o1 < 0) expp->nd_type = int_type;
+		if (o1 >= 0 && o2 < 0) {
+			if (max_int[sz] + o2 < o1) overflow(expp);
 		}
+		else if (o1 < 0 && o2 >= 0) {
+			if (min_int[sz] + o2 > o1) overflow(expp);
+		}
+		o1 -= o2;
 		break;
 
 	case '<':
@@ -185,14 +214,7 @@ cstbin(expp)
 		/* Fall through */
 
 	case '>':
-		if (uns)	{
-			o1 = (o1 & mach_long_sign ?
-				(o2 & mach_long_sign ? o1 > o2 : 1) :
-				(o2 & mach_long_sign ? 0 : o1 > o2)
-			);
-		}
-		else
-			o1 = (o1 > o2);
+		o1 = (o1 > o2);
 		break;
 
 	case LESSEQUAL:
@@ -204,7 +226,118 @@ cstbin(expp)
 		/* Fall through */
 
 	case GREATEREQUAL:
-		o1 = chk_bounds(o2, o1, uns ? T_CARDINAL : T_INTEGER);
+		o1 = chk_bounds(o2, o1, T_INTEGER);
+		break;
+
+	case '=':
+		o1 = (o1 == o2);
+		break;
+
+	case '#':
+		o1 = (o1 != o2);
+		break;
+
+	default:
+		crash("(cstibin)");
+	}
+
+	expp->nd_class = Value;
+	expp->nd_token = expp->nd_right->nd_token;
+	expp->nd_INT = o1;
+	CutSize(expp);
+	FreeNode(expp->nd_left);
+	FreeNode(expp->nd_right);
+	expp->nd_left = expp->nd_right = 0;
+}
+
+cstubin(expp)
+	register t_node *expp;
+{
+	/*	The binary operation in "expp" is performed on the constant
+		expressions below it, and the result restored in
+		expp.
+	*/
+	arith o1 = expp->nd_left->nd_INT;
+	arith o2 = expp->nd_right->nd_INT;
+	register int sz = expp->nd_type->tp_size;
+	arith tmp1, tmp2;
+
+	assert(expp->nd_class == Oper);
+	assert(expp->nd_left->nd_class == Value);
+	assert(expp->nd_right->nd_class == Value);
+
+	switch (expp->nd_symb)	{
+	case '*':
+		if (o1 == 0 || o2 == 0) {
+			o1 = 0;
+			break;
+		}
+		tmp1 = full_mask[sz];
+		tmp2 = o2;
+		divide(&tmp1, &tmp2);
+		if (! chk_bounds(o1, tmp1, T_CARDINAL)) overflow(expp);
+		o1 *= o2;
+		break;
+
+	case DIV:
+		if (o2 == 0)	{
+			node_error(expp, "division by 0");
+			return;
+		}
+		divide(&o1, &o2);
+		break;
+
+	case MOD:
+		if (o2 == 0)	{
+			node_error(expp, "modulo by 0");
+			return;
+		}
+		divide(&o1, &o2);
+		o1 = o2;
+		break;
+
+	case '+':
+		if (! chk_bounds(o2, full_mask[sz] - o1, T_CARDINAL)) {
+			overflow(expp);
+		}
+		o1 += o2;
+		break;
+
+	case '-':
+		if (! chk_bounds(o2, o1, T_CARDINAL)) {
+			if (expp->nd_type->tp_fund == T_INTORCARD) {
+				expp->nd_type = int_type;
+				if (! chk_bounds(min_int[sz], o1 - o2, T_CARDINAL)) {
+					overflow();
+				}
+			}
+			else	overflow();
+		}
+		o1 -= o2;
+		break;
+
+	case '<':
+		{	arith tmp = o1;
+			
+			o1 = o2;
+			o2 = tmp;
+		}
+		/* Fall through */
+
+	case '>':
+		o1 = ! chk_bounds(o1, o2, T_CARDINAL);
+		break;
+
+	case LESSEQUAL:
+		{	arith tmp = o1;
+			
+			o1 = o2;
+			o2 = tmp;
+		}
+		/* Fall through */
+
+	case GREATEREQUAL:
+		o1 = chk_bounds(o2, o1, T_CARDINAL);
 		break;
 
 	case '=':
@@ -225,7 +358,7 @@ cstbin(expp)
 		break;
 
 	default:
-		crash("(cstbin)");
+		crash("(cstubin)");
 	}
 
 	expp->nd_class = Value;
@@ -361,7 +494,12 @@ cstcall(expp, call)
 	expp->nd_symb = INTEGER;
 	switch(call) {
 	case S_ABS:
-		if (expr->nd_INT < 0) expp->nd_INT = - expr->nd_INT;
+		if (expr->nd_INT < 0) {
+			if (expr->nd_INT <= min_int[(int)(tp->tp_size)]) {
+				overflow(expr);
+			}
+			expp->nd_INT = - expr->nd_INT;
+		}
 		else expp->nd_INT = expr->nd_INT;
 		CutSize(expp);
 		break;
@@ -375,7 +513,7 @@ cstcall(expp, call)
 
 	case S_MAX:
 		if (tp->tp_fund == T_INTEGER) {
-			expp->nd_INT = int_mask[(int)(tp->tp_size)];
+			expp->nd_INT = max_int[(int)(tp->tp_size)];
 		}
 		else if (tp == card_type) {
 			expp->nd_INT = full_mask[(int)(int_size)];
@@ -388,8 +526,7 @@ cstcall(expp, call)
 
 	case S_MIN:
 		if (tp->tp_fund == T_INTEGER) {
-			expp->nd_INT = -int_mask[(int)(tp->tp_size)];
-			if (! options['s']) expp->nd_INT--;
+			expp->nd_INT = min_int[(int)(tp->tp_size)];
 		}
 		else if (tp->tp_fund == T_SUBRANGE) {
 			expp->nd_INT = tp->sub_lb;
@@ -419,30 +556,18 @@ CutSize(expr)
 	/*	The constant value of the expression expr is made to
 		conform to the size of the type of the expression.
 	*/
-	register arith o1 = expr->nd_INT;
 	register t_type *tp = BaseType(expr->nd_type);
-	int uns;
-	int size = tp->tp_size;
 
 	assert(expr->nd_class == Value);
-	uns = (tp->tp_fund & (T_CARDINAL|T_CHAR));
-	if (uns) {
-		if (o1 & ~full_mask[size]) {
-			node_warning(expr, W_ORDINARY, ovflow);
-			o1 &= full_mask[size];
-		}
+	if (tp->tp_fund != T_INTEGER) {
+		expr->nd_INT &= full_mask[tp->tp_size];
 	}
 	else {
-		int nbits = (int) (mach_long_size - size) * 8;
-		long remainder = o1 & ~int_mask[size];
+		int nbits = (int) (mach_long_size - tp->tp_size) * 8;
 
-		if (remainder != 0 && remainder != ~int_mask[size]) {
-			node_warning(expr, W_ORDINARY, ovflow);
-			o1 <<= nbits;
-			o1 >>= nbits;
-		}
+		expr->nd_INT <<= nbits;
+		expr->nd_INT >>= nbits;
 	}
-	expr->nd_INT = o1;
 }
 
 InitCst()
@@ -455,7 +580,9 @@ InitCst()
 		if (i == MAXSIZE)
 			fatal("array full_mask too small for this machine");
 		full_mask[i] = bt;
-		int_mask[i] = bt & ~(1L << ((i << 3) - 1));
+		max_int[i] = bt & ~(1L << ((i << 3) - 1));
+		min_int[i] = - max_int[i];
+		if (! options['s']) min_int[i]--;
 	}
 	mach_long_size = i;
 	mach_long_sign = 1L << (mach_long_size * 8 - 1);
@@ -463,6 +590,5 @@ InitCst()
 		fatal("sizeof (long) insufficient on this machine");
 	}
 
-	max_int = int_mask[(int)int_size];
 	wrd_bits = 8 * (unsigned) word_size;
 }

lang/m2/comp/declar.g

@@ -404,7 +404,8 @@ CaseLabels(t_type **ptp; register t_node **pnd;)
 				ChkCompat(pnd, *ptp, "case label");
 			  }
 			  nd = *pnd;
-			  if (! (nd->nd_type->tp_fund & T_DISCRETE)) {
+			  if (! (nd->nd_type->tp_fund & T_DISCRETE) ||
+			      nd->nd_type->tp_size > word_size) {
 				node_error(nd, "illegal type in case label");
 			  }
 			}

lang/m2/comp/type.H

@@ -212,7 +212,8 @@ extern t_type
 #define	IsConstructed(tpx)	((tpx)->tp_fund & T_CONSTRUCTED)
 
 extern long full_mask[];
-extern long int_mask[];
+extern long max_int[];
+extern long min_int[];
 
 #define fit(n, i)	(((n) + ((arith)0x80<<(((i)-1)*8)) & ~full_mask[(i)]) == 0)
 #define ufit(n, i)	(((n) & ~full_mask[(i)]) == 0)

lang/m2/comp/type.c

@@ -305,7 +305,7 @@ chk_basesubrange(tp, base)
 		error("illegal base for a subrange");
 	}
 	else if (base == int_type && tp->tp_next == card_type &&
-		 (tp->sub_ub > max_int || tp->sub_ub < 0)) {
+		 (tp->sub_ub > max_int[(int) word_size] || tp->sub_ub < 0)) {
 		error("upperbound to large for type INTEGER");
 	}
 	else if (base != tp->tp_next && base != int_type) {

lang/m2/libm2/ChkCards.e

@@ -2,13 +2,22 @@
 
  mes 2,EM_WSIZE,EM_PSIZE
 
+ exp $addu
+ exp $subu
+ exp $mulu
+#if EM_WSIZE < EM_LSIZE
+ exp $addul
+ exp $subul
+ exp $mulul
+#endif
+
  pro $addu,0
  loc -1
  lol 0
  sbu EM_WSIZE
  lol EM_WSIZE
  cmu EM_WSIZE
- zle *1
+ zge *1
  loc M2_UOVFL
  trp
 1
@@ -19,6 +28,25 @@
  ret 0
  end 0
 
+#if EM_WSIZE < EM_LSIZE
+ pro $addul,0
+ ldc -1
+ ldl 0
+ sbu EM_LSIZE
+ ldl EM_LSIZE
+ cmu EM_LSIZE
+ zge *1
+ loc M2_UOVFL
+ trp
+1
+ ldl 0
+ ldl EM_LSIZE
+ adu EM_LSIZE
+ sdl EM_LSIZE
+ ret 0
+ end 0
+#endif
+
  pro $mulu,0
  lol 0
  zeq *1
@@ -37,3 +65,58 @@
  stl EM_WSIZE
  ret 0
  end 0
+
+#if EM_WSIZE < EM_LSIZE
+ pro $mulul,0
+ ldl 0
+ ldc 0
+ cmu EM_LSIZE
+ zeq *1
+ ldc -1
+ ldl 0
+ dvu EM_LSIZE
+ ldl EM_LSIZE
+ cmu EM_LSIZE
+ zle *1
+ loc M2_UOVFL
+ trp
+1
+ ldl 0
+ ldl EM_LSIZE
+ mlu EM_LSIZE
+ sdl EM_LSIZE
+ ret 0
+ end 0
+#endif
+
+ pro $subu,0
+ lol EM_WSIZE
+ lol 0
+ cmu EM_WSIZE
+ zge *1
+ loc M2_UOVFL
+ trp
+1
+ lol EM_WSIZE
+ lol 0
+ sbu EM_WSIZE
+ stl EM_WSIZE
+ ret 0
+ end 0
+
+#if EM_WSIZE < EM_LSIZE
+ pro $subul,0
+ ldl EM_LSIZE
+ ldl 0
+ cmu EM_LSIZE
+ zge *1
+ loc M2_UOVFL
+ trp
+1
+ ldl EM_LSIZE
+ ldl 0
+ sbu EM_LSIZE
+ sdl EM_LSIZE
+ ret 0
+ end 0
+#endif