From: ceriel <none@none>
Date: Mon, 21 Mar 1988 16:36:31 +0000 (+0000)
Subject: too many changes: some cosmetic; some for 2/4; some for added options
X-Git-Tag: release-5-5~3548
X-Git-Url: https://git.ndcode.org/public/gitweb.cgi?a=commitdiff_plain;h=759f4738ca7f16238c4ee9227af9fdfaa30d5f4b;p=ack.git

too many changes: some cosmetic; some for 2/4; some for added options
---

diff --git a/lang/m2/comp/LLlex.c b/lang/m2/comp/LLlex.c
index 4ba46596e..530911433 100644
--- a/lang/m2/comp/LLlex.c
+++ b/lang/m2/comp/LLlex.c
@@ -50,7 +50,7 @@ SkipComment()
 	/*	Skip Modula-2 comments (* ... *).
 		Note that comments may be nested (par. 3.5).
 	*/
-	register int ch;
+	register int ch, c;
 	register int CommentLevel = 0;
 
 	LoadChar(ch);
@@ -66,17 +66,23 @@ SkipComment()
 			*/
 			ForeignFlag = D_FOREIGN;
 			break;
-		case 'R':
-			/* Range checks, on or off */
-			LoadChar(ch);
-			if (ch == '-') {
-				options['R'] = 1;
+		case 'U':
+			inidf['_'] = 1;
+			break;
+		case 'A': /* Extra array bound checks, on or off */
+		case 'R': /* Range checks, on or off */
+		{
+			int on_on_minus = ch == 'R';
+			LoadChar(c);
+			if (c == '-') {
+				options[ch] = on_on_minus;
 				break;
 			}
-			if (ch == '+') {
-				options['R'] = 0;
+			if (c == '+') {
+				options[ch] = !on_on_minus;
 				break;
 			}
+		}
 			/* fall through */
 		default:
 			PushBack();
@@ -365,6 +371,9 @@ again:
 		}
 		else {
 			tk->tk_data.tk_str = str;
+			if (! fit(str->s_length, (int) word_size)) {
+				lexerror("string too long");
+			}
 			toktype = standard_type(T_STRING, 1, str->s_length);
 		}
 		return tk->tk_symb = STRING;
@@ -504,11 +513,11 @@ lexwarning(W_ORDINARY, "overflow in constant");
 					toktype = longint_type;
 				}
 				else if (sgnswtch == 0 &&
-					 tk->TOK_INT<=max_int[(int)word_size]) {
+					 tk->TOK_INT<=max_int[(int)int_size]) {
 					toktype = intorcard_type;
 				}
 				else if (! chk_bounds(tk->TOK_INT,
-						      full_mask[(int)word_size],
+						      full_mask[(int)int_size],
 						      T_CARDINAL)) {
 lexwarning(W_ORDINARY, "overflow in constant");
 				}
diff --git a/lang/m2/comp/Makefile b/lang/m2/comp/Makefile
index b5a8ecf58..938708c6f 100644
--- a/lang/m2/comp/Makefile
+++ b/lang/m2/comp/Makefile
@@ -1,8 +1,9 @@
 # make modula-2 "compiler"
-EMHOME =		../../..
-MHDIR =		$(EMHOME)/modules/h
-PKGDIR =	$(EMHOME)/modules/pkg
-LIBDIR =	$(EMHOME)/modules/lib
+EMHOME =	../../..
+MDIR =		$(EMHOME)/modules
+MHDIR =		$(MDIR)/h
+PKGDIR =	$(MDIR)/pkg
+LIBDIR =	$(MDIR)/lib
 OBJECTCODE =	$(LIBDIR)/libemk.a
 LLGEN =		$(EMHOME)/bin/LLgen
 MKDEP =		$(EMHOME)/bin/mkdep
@@ -325,10 +326,12 @@ chk_expr.o: strict3rd.h
 chk_expr.o: target_sizes.h
 chk_expr.o: type.h
 chk_expr.o: warning.h
+options.o: class.h
 options.o: idfsize.h
 options.o: main.h
 options.o: nocross.h
 options.o: nostrict.h
+options.o: squeeze.h
 options.o: strict3rd.h
 options.o: target_sizes.h
 options.o: type.h
diff --git a/lang/m2/comp/Parameters b/lang/m2/comp/Parameters
index 127248dbd..a05f79a4b 100644
--- a/lang/m2/comp/Parameters
+++ b/lang/m2/comp/Parameters
@@ -23,26 +23,25 @@
 #define MAXSIZE		8	/* the maximum of the SZ_* constants	*/
 
 /* target machine sizes	*/
-#define	SZ_CHAR		(arith)1
-#define	SZ_SHORT	(arith)2
-#define SZ_WORD		(arith)4
-#define	SZ_INT		(arith)4
-#define	SZ_LONG		(arith)4
-#define	SZ_FLOAT	(arith)4
-#define	SZ_DOUBLE	(arith)8
-#define	SZ_POINTER	(arith)4
+#define	SZ_CHAR		((arith)1)
+#define	SZ_SHORT	((arith)2)
+#define SZ_WORD		((arith)4)
+#define	SZ_INT		((arith)4)
+#define	SZ_LONG		((arith)4)
+#define	SZ_FLOAT	((arith)4)
+#define	SZ_DOUBLE	((arith)8)
+#define	SZ_POINTER	((arith)4)
 
 /* target machine alignment requirements	*/
 #define	AL_CHAR		1
-#define	AL_SHORT	(int)SZ_SHORT
-#define AL_WORD		(int)SZ_WORD
-#define	AL_INT		(int)SZ_WORD
-#define	AL_LONG		(int)SZ_WORD
-#define	AL_FLOAT	(int)SZ_WORD
-#define	AL_DOUBLE	(int)SZ_WORD
-#define	AL_POINTER	(int)SZ_WORD
-#define AL_STRUCT	1
-#define AL_UNION	1
+#define	AL_SHORT	((int)SZ_SHORT)
+#define AL_WORD		((int)SZ_WORD)
+#define	AL_INT		((int)SZ_WORD)
+#define	AL_LONG		((int)SZ_WORD)
+#define	AL_FLOAT	((int)SZ_WORD)
+#define	AL_DOUBLE	((int)SZ_WORD)
+#define	AL_POINTER	((int)SZ_WORD)
+#define AL_STRUCT	((int)SZ_WORD)
 
 
 !File: debugcst.h
diff --git a/lang/m2/comp/casestat.C b/lang/m2/comp/casestat.C
index 3e93b6f73..e21c54274 100644
--- a/lang/m2/comp/casestat.C
+++ b/lang/m2/comp/casestat.C
@@ -73,7 +73,8 @@ compact(nr, low, up)
 	*/
 	arith diff = up - low;
 
-	return (nr == 0 || (diff >= 0 && diff / nr <= (DENSITY - 1)));
+	return (nr != 0 && diff >= 0 && fit(diff, (int) word_size) &&
+		diff / nr <= (DENSITY - 1));
 }
 
 CaseCode(nd, exitlabel)
@@ -149,11 +150,10 @@ CaseCode(nd, exitlabel)
 	if (compact(sh->sh_nrofentries, sh->sh_lowerbd, sh->sh_upperbd)) {
 		/* CSA
 		*/
-		C_rom_cst(sh->sh_lowerbd);
-		C_rom_cst(sh->sh_upperbd - sh->sh_lowerbd);
 		ce = sh->sh_entries;
-		if (sh->sh_nrofentries)
-		    for (val = sh->sh_lowerbd; val <= sh->sh_upperbd; val++) {
+		C_rom_cst((arith) 0);
+		C_rom_cst(sh->sh_upperbd - sh->sh_lowerbd);
+		for (val = sh->sh_lowerbd; val <= sh->sh_upperbd; val++) {
 			assert(ce);
 			if (val == ce->ce_value)	{
 				C_rom_ilb(ce->ce_label);
@@ -162,6 +162,8 @@ CaseCode(nd, exitlabel)
 			else if (sh->sh_default) C_rom_ilb(sh->sh_default);
 			else C_rom_ucon("0", pointer_size);
 		}
+		C_loc(sh->sh_lowerbd);
+		C_sbu(word_size);
 		c_lae_dlb(CaseDescrLab);	/* perform the switch */
 		C_csa(word_size);
 	}
diff --git a/lang/m2/comp/chk_expr.c b/lang/m2/comp/chk_expr.c
index 4bf812af3..58de781be 100644
--- a/lang/m2/comp/chk_expr.c
+++ b/lang/m2/comp/chk_expr.c
@@ -282,9 +282,9 @@ ChkLinkOrName(expp, flags)
 			/* Fields of a record are always D_QEXPORTED,
 			   so ...
 			*/
-			df_error(expp,
+			if (df_error(expp,
 			       "not exported from qualifying module",
-			       df);
+			       df)) assert(0);
 		}
 
 		if (!(left->nd_class == Def &&
@@ -617,7 +617,7 @@ ChkProcCall(expp)
 		/* Just check parameters as if they were value parameters
 		*/
 		while (expp->nd_right) {
-			getarg(&expp, 0, 0, edf);
+			if (getarg(&expp, 0, 0, edf)) { }
 		}
 		return 0;
 	}
@@ -646,9 +646,11 @@ ChkProcCall(expp)
 	}
 
 	if (expp->nd_right) {
-		df_error(expp->nd_right, "too many parameters supplied", edf);
+		if (df_error(expp->nd_right,"too many parameters supplied",edf)){
+			assert(0);
+		}
 		while (expp->nd_right) {
-			getarg(&expp, 0, 0, edf);
+			if (getarg(&expp, 0, 0, edf)) { }
 		}
 		return 0;
 	}
@@ -779,20 +781,47 @@ AllowedTypes(operator)
 }
 
 STATIC int
-ChkAddress(tpl, tpr)
+ChkAddressOper(tpl, tpr, expp)
 	register t_type *tpl, *tpr;
+	register t_node *expp;
 {
 	/*	Check that either "tpl" or "tpr" are both of type
 		address_type, or that one of them is, but the other is
-		of type cardinal.
+		of a cardinal type.
+		Also insert proper coercions, making sure that the EM pointer
+		arithmetic instructions can be generated whenever possible
 	*/
+
+	if (tpr == address_type && expp->nd_symb == '+') {
+		/* use the fact that '+' is a commutative operator */
+		t_type *tmptype = tpr;
+		t_node *tmpnode = expp->nd_right;
+
+		tpr = tpl;
+		expp->nd_right = expp->nd_left;
+		tpl = tmptype;
+		expp->nd_left = tmpnode;
+	}
 	
 	if (tpl == address_type) {
-		return tpr == address_type || (tpr->tp_fund & T_CARDINAL);
+		expp->nd_type = address_type;
+		if (tpr == address_type) {
+			return 1;
+		}
+		if (tpr->tp_fund & T_CARDINAL) {
+			MkCoercion(&(expp->nd_right),
+				   expp->nd_symb=='+' || expp->nd_symb=='-' ?
+					tpr :
+				  	address_type);
+			return 1;
+		}
+		return 0;
 	}
 
-	if (tpr == address_type) {
-		return (tpl->tp_fund & T_CARDINAL);
+	if (tpr == address_type && tpl->tp_fund & T_CARDINAL) {
+		expp->nd_type = address_type;
+		MkCoercion(&(expp->nd_left), address_type);
+		return 1;
 	}
 
 	return 0;
@@ -804,13 +833,13 @@ ChkBinOper(expp)
 {
 	/*	Check a binary operation.
 	*/
-	register t_node *left, *right;
+	register t_node *left = expp->nd_left, *right = expp->nd_right;
 	register t_type *tpl, *tpr;
+	t_type *result_type;
 	int allowed;
 	int retval;
 
-	left = expp->nd_left;
-	right = expp->nd_right;
+	/* First, check BOTH operands */
 
 	retval = ChkExpression(left) & ChkExpression(right);
 
@@ -828,7 +857,7 @@ ChkBinOper(expp)
 		}
 	}
 
-	expp->nd_type = ResultOfOperation(expp->nd_symb, tpr);
+	expp->nd_type = result_type = ResultOfOperation(expp->nd_symb, tpr);
 
 	/* Check that the application of the operator is allowed on the type
 	   of the operands.
@@ -866,27 +895,26 @@ ChkBinOper(expp)
 
 	if (!(tpr->tp_fund & allowed) || !(tpl->tp_fund & allowed)) {
 	    	if (!((T_CARDINAL & allowed) &&
-	             ChkAddress(tpl, tpr))) {
+	             ChkAddressOper(tpl, tpr, expp))) {
 			return ex_error(expp, "illegal operand type(s)");
 		}
-		if (expp->nd_type->tp_fund & T_CARDINAL) {
-			expp->nd_type = address_type;
-		}
+		if (result_type == bool_type) expp->nd_type = bool_type;
 	}
+	else {
+		if (Boolean(expp->nd_symb) && tpl != bool_type) {
+			return ex_error(expp, "illegal operand type(s)");
+		}
 
-	if (Boolean(expp->nd_symb) && tpl != bool_type) {
-		return ex_error(expp, "illegal operand type(s)");
-	}
+		/* Operands must be compatible (distilled from Def 8.2)
+		*/
+		if (!TstCompat(tpr, tpl)) {
+			return ex_error(expp, "incompatible operand types");
+		}
 
-	/* Operands must be compatible (distilled from Def 8.2)
-	*/
-	if (!TstCompat(tpr, tpl)) {
-		return ex_error(expp, "incompatible operand types");
+		MkCoercion(&(expp->nd_left), tpl);
+		MkCoercion(&(expp->nd_right), tpr);
 	}
 
-	MkCoercion(&(expp->nd_left), tpl);
-	MkCoercion(&(expp->nd_right), tpr);
-
 	if (tpl->tp_fund == T_SET) {
 	    	if (left->nd_class == Set && right->nd_class == Set) {
 			cstset(expp);
@@ -1071,7 +1099,9 @@ ChkStandard(expp)
 			MkCoercion(&(arg->nd_left), d2);
 		}
 		else {
-			df_error(left, "unexpected parameter type", edf);
+			if (df_error(left, "unexpected parameter type", edf)) {
+				assert(0);
+			}
 			break;
 		}
 		free_it = 1;