many changes; some cosmetic; coercions now explicit in tree

lang/m2/comp/LLlex.c

@@ -19,6 +19,7 @@
 #include	<em_label.h>
 #include	<assert.h>
 
+#include	"LLlex.h"
 #include	"input.h"
 #include	"f_info.h"
 #include	"Lpars.h"
@@ -26,7 +27,6 @@
 #include	"idf.h"
 #include	"def.h"
 #include	"type.h"
-#include	"LLlex.h"
 #include	"const.h"
 #include	"warning.h"
 
@@ -278,6 +278,8 @@ again:
 			else if (nch == EOI) eofseen = 1;
 			else PushBack();
 		}
+		if (ch == '&') return tk->tk_symb = AND;
+		if (ch == '~') return tk->tk_symb = NOT;
 		return tk->tk_symb = ch;
 
 	case STCOMP:
@@ -301,7 +303,6 @@ again:
 				return tk->tk_symb = LESSEQUAL;
 			}
 			if (nch == '>') {
-				lexwarning(W_STRICT, "'<>' is old-fashioned; use '#'");
 				return tk->tk_symb = '#';
 			}
 			break;

lang/m2/comp/Makefile

@@ -40,14 +40,14 @@ OBJ =	$(COBJ) $(LOBJ) Lpars.o
 GENH=	errout.h\
 	idfsize.h numsize.h strsize.h target_sizes.h \
 	inputtype.h maxset.h density.h\
-	def.h debugcst.h type.h Lpars.h node.h
+	def.h debugcst.h type.h Lpars.h node.h desig.h
 HFILES=		LLlex.h\
-	chk_expr.h class.h const.h debug.h desig.h f_info.h idf.h\
+	chk_expr.h class.h const.h debug.h f_info.h idf.h\
 	input.h main.h misc.h scope.h standards.h tokenname.h\
 	walk.h warning.h SYSTEM.h $(GENH)
 #
 GENFILES = $(GENGFILES) $(GENC) $(GENH)
-NEXTFILES = def.H type.H node.H scope.C tmpvar.C casestat.C
+NEXTFILES = def.H type.H node.H desig.H scope.C tmpvar.C casestat.C
 
 #EXCLEXCLEXCLEXCL
 
@@ -113,6 +113,7 @@ symbol2str.c:	tokenname.c make.tokcase
 def.h:		make.allocd
 type.h:		make.allocd
 node.h:		make.allocd
+desig.h:	make.allocd
 scope.c:	make.allocd
 tmpvar.c:	make.allocd
 casestat.c:	make.allocd

lang/m2/comp/casestat.C

@@ -30,6 +30,7 @@
 #include	"node.h"
 #include	"desig.h"
 #include	"walk.h"
+#include	"chk_expr.h"
 
 #include	"density.h"
 
@@ -81,14 +82,16 @@ CaseCode(nd, exitlabel)
 
 	assert(pnode->nd_class == Stat && pnode->nd_symb == CASE);
 
-	WalkExpr(pnode->nd_left);	/* evaluate case expression */
+	if (ChkExpression(pnode->nd_left)) {
+		MkCoercion(&(pnode->nd_left),BaseType(pnode->nd_left->nd_type));
+		CodePExpr(pnode->nd_left);
+	}
 	sh->sh_type = pnode->nd_left->nd_type;
 	sh->sh_break = ++text_label;
 
 	/* Now, create case label list
 	*/
-	while (pnode->nd_right) {
+	while (pnode = pnode->nd_right) {
-		pnode = pnode->nd_right;
 		if (pnode->nd_class == Link && pnode->nd_symb == '|') {
 			if (pnode->nd_left) {
 				/* non-empty case
@@ -168,8 +171,7 @@ CaseCode(nd, exitlabel)
 	/* Now generate code for the cases
 	*/
 	pnode = nd;
-	while (pnode->nd_right) {
+	while (pnode = pnode->nd_right) {
-		pnode = pnode->nd_right;
 		if (pnode->nd_class == Link && pnode->nd_symb == '|') {
 			if (pnode->nd_left) {
 				C_df_ilb(pnode->nd_lab);
@@ -252,8 +254,7 @@ AddOneCase(sh, node, lbl)
 
 	ce->ce_label = lbl;
 	ce->ce_value = node->nd_INT;
-	if (! TstCompat(sh->sh_type, node->nd_type)) {
+	if (! ChkCompat(&node, sh->sh_type, "case")) {
-		node_error(node, "type incompatibility in case");
 		free_case_entry(ce);
 		return 0;
 	}

lang/m2/comp/chk_expr.c

@@ -22,8 +22,8 @@
 #include	"Lpars.h"
 #include	"idf.h"
 #include	"type.h"
-#include	"def.h"
 #include	"LLlex.h"
+#include	"def.h"
 #include	"node.h"
 #include	"scope.h"
 #include	"const.h"
@@ -35,7 +35,7 @@
 extern char *symbol2str();
 extern char *sprint();
 
-STATIC
+STATIC int
 Xerror(nd, mess, edf)
 	struct node *nd;
 	char *mess;
@@ -45,9 +45,86 @@ Xerror(nd, mess, edf)
 		if (edf->df_kind != D_ERROR)  {
 			node_error(nd,"\"%s\": %s", edf->df_idf->id_text, mess);
 		}
-		return;
 	}
-	node_error(nd, "%s", mess);
+	else node_error(nd, "%s", mess);
+	return 0;
+}
+
+MkCoercion(pnd, tp)
+	struct node **pnd;
+	register struct type *tp;
+{
+	register struct node *nd = *pnd;
+	register struct type *nd_tp = nd->nd_type;
+	extern int pass_1;
+	int w = 0;
+
+	if (nd_tp == tp) return;
+	if (nd_tp->tp_fund == T_STRING) return;
+	nd_tp = BaseType(nd_tp);
+	if (nd->nd_class == Value) {
+		switch(tp->tp_fund) {
+		case T_REAL:
+			if (nd_tp->tp_fund == T_REAL) {
+				break;
+			}
+			goto Out;
+		case T_SUBRANGE:
+			if (! chk_bounds(tp->sub_lb, nd->nd_INT, 
+				BaseType(tp)->tp_fund) ||
+			    ! chk_bounds(nd->nd_INT, tp->sub_ub,
+				BaseType(tp)->tp_fund)) {
+				node_warning(nd,
+					     W_ORDINARY,
+					     "might cause range bound error");
+				w = 1;
+			}
+			break;
+		case T_ENUMERATION:
+		case T_CHAR:
+			if (nd->nd_INT < 0 || nd->nd_INT >= tp->enm_ncst) {
+				node_warning(nd,
+					     W_ORDINARY,
+					     "might cause range bound error");
+				w = 1;
+			}
+			break;
+		case T_INTORCARD:
+		case T_CARDINAL:
+		case T_POINTER:
+			if ((nd_tp->tp_fund == T_INTEGER &&
+			     nd->nd_INT < 0) ||
+			    (nd->nd_INT & ~full_mask[(int)(tp->tp_size)])) {
+				node_warning(nd,
+					     W_ORDINARY,
+					     "might cause conversion error");
+				w = 1;
+			}
+			break;
+		case T_INTEGER:  {
+			long i = ~int_mask[(int)(tp->tp_size)];
+			long j = nd->nd_INT & i;
+
+			if ((nd_tp->tp_fund == T_INTEGER &&
+			     j != i && j != 0) ||
+			    (nd_tp->tp_fund != T_INTEGER && j)) {
+				node_warning(nd,
+					     W_ORDINARY,
+					     "might cause conversion error");
+				w = 1;
+			}
+			}
+			break;
+		}
+		if (!w || pass_1) {
+			nd->nd_type = tp;
+			return;
+		}
+	}
+Out:
+	*pnd = nd = MkNode(Uoper, NULLNODE, nd, &(nd->nd_token));
+	nd->nd_symb = COERCION;
+	nd->nd_type = tp;
 }
 
 int
@@ -58,15 +135,10 @@ ChkVariable(expp)
 		assigned to.
 	*/
 
-	if (! ChkDesignator(expp)) return 0;
+	return ChkDesignator(expp) &&
-
+		( expp->nd_class != Def ||
-	if ((expp->nd_class == Def || expp->nd_class == LinkDef) &&
+	    	  ( expp->nd_def->df_kind & (D_FIELD|D_VARIABLE)) ||
-	     !(expp->nd_def->df_kind & (D_FIELD|D_VARIABLE))) {
+		  Xerror(expp, "variable expected", expp->nd_def));
-		Xerror(expp, "variable expected", expp->nd_def);
-		return 0;
-	}
-
-	return 1;
 }
 
 STATIC int
@@ -106,37 +178,33 @@ ChkArr(expp)
 		assignment compatible with the array-index.
 	*/
 
-	register struct type *tpl, *tpr;
+	register struct type *tpl;
-	int retval;
 
 	assert(expp->nd_class == Arrsel);
 	assert(expp->nd_symb == '[');
 
 	expp->nd_type = error_type;
 
-	retval = ChkVariable(expp->nd_left) & ChkExpression(expp->nd_right);
+	if (! (ChkVariable(expp->nd_left) & ChkExpression(expp->nd_right))) {
+		return 0;
+	}
 
 	tpl = expp->nd_left->nd_type;
-	tpr = expp->nd_right->nd_type;
-	if (tpl == error_type || tpr == error_type) return 0;
 
 	if (tpl->tp_fund != T_ARRAY) {
 		node_error(expp, "not indexing an ARRAY type");
 		return 0;
 	}
+	expp->nd_type = RemoveEqual(tpl->arr_elem);
 
 	/* Type of the index must be assignment compatible with
 	   the index type of the array (Def 8.1).
 	   However, the index type of a conformant array is not specified.
 	   In our implementation it is CARDINAL.
 	*/
-	if (!TstAssCompat(IndexType(tpl), tpr)) {
+	return ChkAssCompat(&(expp->nd_right),
-		node_error(expp, "incompatible index type");
+			    BaseType(IndexType(tpl)),
-		return 0;
+			    "index type");
-	}
-
-	expp->nd_type = RemoveEqual(tpl->arr_elem);
-	return retval;
 }
 
 #ifdef DEBUG
@@ -183,13 +251,12 @@ ChkLinkOrName(expp)
 
 		if (! ChkDesignator(left)) return 0;
 
-		if ((left->nd_class==Def || left->nd_class==LinkDef) &&
+		if (left->nd_class==Def &&
 		    (left->nd_type->tp_fund != T_RECORD ||
 		    !(left->nd_def->df_kind & (D_MODULE|D_VARIABLE|D_FIELD))
 		    )
 		   ) {
-			Xerror(left, "illegal selection", left->nd_def);
+			return Xerror(left, "illegal selection", left->nd_def);
-			return 0;
 		}
 		if (left->nd_type->tp_fund != T_RECORD) {
 			node_error(left, "illegal selection");
@@ -200,25 +267,22 @@ ChkLinkOrName(expp)
 			id_not_declared(expp);
 			return 0;
 		}
-		else {
+		expp->nd_def = df;
-			expp->nd_def = df;
+		expp->nd_type = RemoveEqual(df->df_type);
-			expp->nd_type = RemoveEqual(df->df_type);
+		expp->nd_class = Def;
-			expp->nd_class = LinkDef;
+		if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
-			if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
+			/* Fields of a record are always D_QEXPORTED,
-				/* Fields of a record are always D_QEXPORTED,
+			   so ...
-				   so ...
+			*/
-				*/
 Xerror(expp, "not exported from qualifying module", df);
-			}
 		}
 
-		if ((left->nd_class == Def || left->nd_class == LinkDef) &&
+		if (!(left->nd_class == Def &&
-		     left->nd_def->df_kind == D_MODULE) {
+		      left->nd_def->df_kind == D_MODULE)) {
-			expp->nd_class = Def;
+			return 1;
-			FreeNode(left);
-			expp->nd_left = 0;
 		}
-		else	return 1;
+		FreeNode(left);
+		expp->nd_left = 0;
 	}
 
 	assert(expp->nd_class == Def);
@@ -242,8 +306,11 @@ ChkExLinkOrName(expp)
 	if (df->df_kind & (D_ENUM | D_CONST)) {
 		/* Replace an enum-literal or a CONST identifier by its value.
 		*/
+		if (df->df_type->tp_fund == T_SET) {
+			expp->nd_class = Set;
+		}
+		else	expp->nd_class = Value;
 		if (df->df_kind == D_ENUM) {
-			expp->nd_class = Value;
 			expp->nd_INT = df->enm_val;
 			expp->nd_symb = INTEGER;
 		}
@@ -251,7 +318,7 @@ ChkExLinkOrName(expp)
 			unsigned int ln = expp->nd_lineno;
 
 			assert(df->df_kind == D_CONST);
-			*expp = *(df->con_const);
+			expp->nd_token = df->con_const;
 			expp->nd_lineno = ln;
 		}
 	}
@@ -278,32 +345,24 @@ node_error(expp, "standard or local procedures may not be assigned");
 
 STATIC int
 ChkEl(expr, tp)
-	register struct node *expr;
+	register struct node **expr;
 	struct type *tp;
 {
-	if (!ChkExpression(expr)) return 0;
 
-	if (!TstCompat(tp, expr->nd_type)) {
+	return ChkExpression(*expr) && ChkCompat(expr, tp, "set element");
-		node_error(expr, "set element has incompatible type");
-		return 0;
-	}
-
-	return 1;
 }
 
 STATIC int
 ChkElement(expp, tp, set)
 	struct node **expp;
 	struct type *tp;
-	arith **set;
+	arith *set;
 {
 	/*	Check elements of a set. This routine may call itself
 		recursively.
 		Also try to compute the set!
 	*/
 	register struct node *expr = *expp;
-	register struct node *left = expr->nd_left;
-	register struct node *right = expr->nd_right;
 	register unsigned int i;
 	arith lo, hi, low, high;
 
@@ -311,22 +370,25 @@ ChkElement(expp, tp, set)
 		/* { ... , expr1 .. expr2,  ... }
 		   First check expr1 and expr2, and try to compute them.
 		*/
-		if (! (ChkEl(left, tp) & ChkEl(right, tp))) {
+		if (! (ChkEl(&(expr->nd_left), tp) & 
+		       ChkEl(&(expr->nd_right), tp))) {
 			return 0;
 		}
 
-		if (!(left->nd_class == Value && right->nd_class == Value)) {
+		if (!(expr->nd_left->nd_class == Value &&
+		      expr->nd_right->nd_class == Value)) {
 			return 1;
 		}
 		/* We have a constant range. Put all elements in the
 		  set
 		*/
 
-		low = left->nd_INT;
+		low = expr->nd_left->nd_INT;
-		high = right->nd_INT;
+		high = expr->nd_right->nd_INT;
 	}
 	else {
-		if (! ChkEl(expr, tp)) return 0;
+		if (! ChkEl(expp, tp)) return 0;
+		expr = *expp;
 		if (expr->nd_class != Value) {
 			return 1;
 		}
@@ -344,7 +406,7 @@ ChkElement(expp, tp, set)
 	}
 
 	for (i=(unsigned)low; i<= (unsigned)high; i++) {
-		(*set)[i/wrd_bits] |= (1<<(i%wrd_bits));
+		set[i/wrd_bits] |= (1<<(i%wrd_bits));
 	}
 	FreeNode(expr);
 	*expp = 0;
@@ -374,7 +436,7 @@ ChkSet(expp)
 		/* A type was given. Check it out
 		*/
 		if (! ChkDesignator(nd)) return 0;
-		assert(nd->nd_class == Def || nd->nd_class == LinkDef);
+		assert(nd->nd_class == Def);
 		df = nd->nd_def;
 
 		if (!is_type(df) ||
@@ -406,7 +468,7 @@ ChkSet(expp)
 		assert(nd->nd_class == Link && nd->nd_symb == ',');
 
 		if (!ChkElement(&(nd->nd_left), ElementType(tp),
-						&(expp->nd_set))) {
+						expp->nd_set)) {
 			retval = 0;
 		}
 		if (nd->nd_left) expp->nd_class = Xset;
@@ -420,6 +482,21 @@ ChkSet(expp)
 	return retval;
 }
 
+STATIC struct node *
+nextarg(argp, edf)
+	struct node **argp;
+	struct def *edf;
+{
+	register struct node *arg = (*argp)->nd_right;
+
+	if (! arg) {
+		return (struct node *)Xerror(*argp, "too few arguments supplied", edf);
+	}
+
+	*argp = arg;
+	return arg->nd_left;
+}
+
 STATIC struct node *
 getarg(argp, bases, designator, edf)
 	struct node **argp;
@@ -433,29 +510,23 @@ getarg(argp, bases, designator, edf)
 		that it must be a designator and may not be a register
 		variable.
 	*/
-	register struct node *arg = (*argp)->nd_right;
+	register struct node *left = nextarg(argp, edf);
-	register struct node *left;
 
-	if (! arg) {
+	if (!left || (designator ? !ChkVariable(left) : !ChkExpression(left))) {
-		Xerror(*argp, "too few arguments supplied", edf);
 		return 0;
 	}
 
-	left = arg->nd_left;
+	if (designator && left->nd_class==Def) {
-	*argp = arg;
-
-	if (designator ? !ChkVariable(left) : !ChkExpression(left)) {
-		return 0;
-	}
-
-	if (designator && (left->nd_class==Def || left->nd_class==LinkDef)) {
 		left->nd_def->df_flags |= D_NOREG;
 	}
 
 	if (bases) {
-		if (!(BaseType(left->nd_type)->tp_fund & bases)) {
+		struct type *tp = BaseType(left->nd_type);
-			Xerror(arg, "unexpected parameter type", edf);
+
-			return 0;
+		MkCoercion(&((*argp)->nd_left), tp);
+		left = (*argp)->nd_left;
+		if (!(tp->tp_fund & bases)) {
+			return (struct node *)Xerror(left, "unexpected parameter type", edf);
 		}
 	}
 
@@ -471,35 +542,17 @@ getname(argp, kinds, bases, edf)
 		The argument must indicate a definition, and the
 		definition kind must be one of "kinds".
 	*/
-	register struct node *arg = *argp;
+	register struct node *left = nextarg(argp, edf);
-	register struct node *left;
 
-	*argp = arg->nd_right;
+	if (!left || ! ChkDesignator(left)) return 0;
 
-	if (!arg->nd_right) {
+	if (left->nd_class != Def) {
-		Xerror(arg, "too few arguments supplied", edf);
+		return (struct node *)Xerror(left, "identifier expected", edf);
-		return 0;
 	}
 
-	arg = arg->nd_right;
+	if (!(left->nd_def->df_kind & kinds) ||
-	left = arg->nd_left;
+	    (bases && !(left->nd_type->tp_fund & bases))) {
-	if (! ChkDesignator(left)) return 0;
+		return (struct node *)Xerror(left, "unexpected parameter type", edf);
-
-	if (left->nd_class != Def && left->nd_class != LinkDef) {
-		Xerror(arg, "identifier expected", edf);
-		return 0;
-	}
-
-	if (!(left->nd_def->df_kind & kinds)) {
-		Xerror(arg, "unexpected parameter type", edf);
-		return 0;
-	}
-
-	if (bases) {
-		if (!(left->nd_type->tp_fund & bases)) {
-			Xerror(arg, "unexpected parameter type", edf);
-			return 0;
-		}
 	}
 
 	return left;
@@ -514,12 +567,11 @@ ChkProcCall(expp)
 	register struct node *left;
 	struct def *edf = 0;
 	register struct paramlist *param;
-	char ebuf[256];
 	int retval = 1;
 	int cnt = 0;
 
 	left = expp->nd_left;
-	if (left->nd_class == Def || left->nd_class == LinkDef) {
+	if (left->nd_class == Def) {
 		edf = left->nd_def;
 	}
 	if (left->nd_type == error_type) {
@@ -544,13 +596,11 @@ ChkProcCall(expp)
 		if (left->nd_symb == STRING) {
 			TryToString(left, TypeOfParam(param));
 		}
-		if (! TstParCompat(RemoveEqual(TypeOfParam(param)),
+		if (! TstParCompat(cnt,
-				   left->nd_type,
+				   RemoveEqual(TypeOfParam(param)),
 				   IsVarParam(param),
-				   left)) {
+				   &(expp->nd_left),
-			sprint(ebuf, "type incompatibility in parameter %d",
+				   edf)) {
-					cnt);
-			Xerror(left, ebuf, edf);
 			retval = 0;
 		}
 	}
@@ -591,19 +641,18 @@ ChkCall(expp)
 		Of course this does not have to be a call at all,
 		it may also be a cast or a standard procedure call.
 	*/
-	register struct node *left;
+	register struct node *left = expp->nd_left;
 	STATIC int ChkStandard();
 	STATIC int ChkCast();
 
 	/* First, get the name of the function or procedure
 	*/
 	expp->nd_type = error_type;
-	left = expp->nd_left;
 	if (ChkDesignator(left)) {
 		if (IsCast(left)) {
 			/* It was a type cast.
 			*/
-			return ChkCast(expp, left);
+			return ChkCast(expp);
 		}
 
 		if (IsProcCall(left) || left->nd_type == error_type) {
@@ -613,7 +662,7 @@ ChkCall(expp)
 			if (left->nd_type == std_type) {
 				/* A standard procedure
 				*/
-				return ChkStandard(expp, left);
+				return ChkStandard(expp);
 			}
 			/* Here, we have found a real procedure call. 
 			   The left hand side may also represent a procedure
@@ -650,7 +699,7 @@ ResultOfOperation(operator, tp)
 STATIC int
 Boolean(operator)
 {
-	return operator == OR || operator == AND || operator == '&';
+	return operator == OR || operator == AND;
 }
 
 STATIC int
@@ -672,7 +721,6 @@ AllowedTypes(operator)
 		return T_INTORCARD;
 	case OR:
 	case AND:
-	case '&':
 		return T_ENUMERATION;
 	case '=':
 	case '#':
@@ -756,15 +804,16 @@ ChkBinOper(expp)
 			node_error(expp, "\"IN\": right operand must be a set");
 			return 0;
 		}
-		if (!TstAssCompat(tpl, ElementType(tpr))) {
+		if (!TstAssCompat(ElementType(tpr), tpl)) {
 			/* Assignment compatible ???
 			   I don't know! Should we be allowed to check
 			   if a INTEGER is a member of a BITSET???
 			*/
-
+			node_error(left, "type incompatibility in IN");
-			node_error(expp, "\"IN\": incompatible types");
 			return 0;
 		}
+		MkCoercion(&(expp->nd_left), word_type);
+		left = expp->nd_left;
 		if (left->nd_class == Value && right->nd_class == Set) {
 			cstset(expp);
 		}
@@ -795,11 +844,15 @@ ChkBinOper(expp)
 
 	/* Operands must be compatible (distilled from Def 8.2)
 	*/
-	if (!TstCompat(tpl, tpr)) {
+	if (!TstCompat(tpr, tpl)) {
-		node_error(expp, "\"%s\": incompatible types", symbol2str(expp->nd_symb));
+		node_error(expp,"\"%s\": incompatible types",
+			   symbol2str(expp->nd_symb));
 		return 0;
 	}
 
+	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);
@@ -823,8 +876,10 @@ ChkUnOper(expp)
 	register struct type *tpr;
 
 	if (! ChkExpression(right)) return 0;
-
 	expp->nd_type = tpr = BaseType(right->nd_type);
+	MkCoercion(&(expp->nd_right), tpr);
+	right = expp->nd_right;
+
 	if (tpr == address_type) tpr = card_type;
 
 	switch(expp->nd_symb) {
@@ -862,7 +917,6 @@ ChkUnOper(expp)
 		break;
 
 	case NOT:
-	case '~':
 		if (tpr == bool_type) {
 			if (right->nd_class == Value) {
 				cstunary(expp);
@@ -886,38 +940,31 @@ getvariable(argp, edf)
 	/*	Get the next argument from argument list "argp".
 		It must obey the rules of "ChkVariable".
 	*/
-	register struct node *arg = *argp;
+	register struct node *left = nextarg(argp, edf);
 
-	arg = arg->nd_right;
+	if (!left || !ChkVariable(left)) return 0;
-	if (!arg) {
-		Xerror(arg, "too few parameters supplied", edf);
-		return 0;
-	}
 
-	*argp = arg;
+	return left;
-	arg = arg->nd_left;
-	if (! ChkVariable(arg)) return 0;
-
-	return arg;
 }
 
 STATIC int
-ChkStandard(expp, left)
+ChkStandard(expp)
-	register struct node *expp, *left;
+	register struct node *expp;
 {
 	/*	Check a call of a standard procedure or function
 	*/
 	struct node *arg = expp;
-	register struct def *edf;
+	register struct node *left = expp->nd_left;
-	int std;
+	register struct def *edf = left->nd_def;
+	int free_it = 0;
 
-	assert(left->nd_class == Def || left->nd_class == LinkDef);
+	assert(left->nd_class == Def);
-	edf = left->nd_def;
-	std = edf->df_value.df_stdname;
 
-	switch(std) {
+	switch(edf->df_value.df_stdname) {
 	case S_ABS:
 		if (!(left = getarg(&arg, T_NUMERIC, 0, edf))) return 0;
+		MkCoercion(&(arg->nd_left), BaseType(left->nd_type));
+		left = arg->nd_left;
 		expp->nd_type = left->nd_type;
 		if (left->nd_class == Value &&
 		    expp->nd_type->tp_fund != T_REAL) {
@@ -934,47 +981,57 @@ ChkStandard(expp, left)
 	case S_CHR:
 		expp->nd_type = char_type;
 		if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0;
-		if (left->nd_class == Value) cstcall(expp, S_CHR);
+		MkCoercion(&(arg->nd_left), char_type);
+		free_it = 1;
 		break;
 
 	case S_FLOATD:
 	case S_FLOAT:
-		expp->nd_type = real_type;
+		if (! getarg(&arg, T_INTORCARD, 0, edf)) return 0;
-		if (std == S_FLOATD) expp->nd_type = longreal_type;
+		if (edf->df_value.df_stdname == S_FLOAT) {
-		if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0;
+			MkCoercion(&(arg->nd_left), card_type);
+		}
+		MkCoercion(&(arg->nd_left),
+			   edf->df_value.df_stdname == S_FLOATD ?
+				longreal_type :
+				real_type);
+		free_it = 1;
 		break;
 
+	case S_SHORT:
 	case S_LONG: {
 		struct type *tp;
+		struct type *s1, *s2, *d1, *d2;
+
+		if (edf->df_value.df_stdname == S_SHORT) {
+			s1 = longint_type;
+			d1 = int_type;
+			s2 = longreal_type;
+			d2 = real_type;
+		}
+		else {
+			d1 = longint_type;
+			s1 = int_type;
+			d2 = longreal_type;
+			s2 = real_type;
+		}
 
 		if (!(left = getarg(&arg, 0, 0, edf))) {
 			return 0;
 		}
 		tp = BaseType(left->nd_type);
-		if (tp == int_type) expp->nd_type = longint_type;
+		if (tp == s1) {
-		else if (tp == real_type) expp->nd_type = longreal_type;
+			MkCoercion(&(arg->nd_left), d1);
+		}
+		else if (tp == s2) {
+			MkCoercion(&(arg->nd_left), d2);
+		}
 		else {
 			expp->nd_type = error_type;
 			Xerror(left, "unexpected parameter type", edf);
+			break;
 		}
-		if (left->nd_class == Value) cstcall(expp, S_LONG);
+		free_it = 1;
-		break;
-		}
-
-	case S_SHORT: {
-		struct type *tp;
-
-		if (!(left = getarg(&arg, 0, 0, edf))) {
-			return 0;
-		}
-		tp = BaseType(left->nd_type);
-		if (tp == longint_type) expp->nd_type = int_type;
-		else if (tp == longreal_type) expp->nd_type = real_type;
-		else {
-			expp->nd_type = error_type;
-			Xerror(left, "unexpected parameter type", edf);
-		}
-		if (left->nd_class == Value) cstcall(expp, S_SHORT);
 		break;
 		}
 
@@ -990,8 +1047,7 @@ ChkStandard(expp, left)
 			break;
 		}
 		if (left->nd_symb != STRING) {
-			Xerror(left,"array parameter expected", edf);
+			return Xerror(left,"array parameter expected", edf);
-			return 0;
 		}
 		expp->nd_type = card_type;
 		expp->nd_class = Value;
@@ -1011,19 +1067,20 @@ ChkStandard(expp, left)
 			return 0;
 		}
 		expp->nd_type = left->nd_type;
-		cstcall(expp,std);
+		cstcall(expp,edf->df_value.df_stdname);
 		break;
 
 	case S_ODD:
-		if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0;
+		if (! (left = getarg(&arg, T_INTORCARD, 0, edf))) return 0;
+		MkCoercion(&(arg->nd_left), BaseType(left->nd_type));
 		expp->nd_type = bool_type;
-		if (left->nd_class == Value) cstcall(expp, S_ODD);
+		if (arg->nd_left->nd_class == Value) cstcall(expp, S_ODD);
 		break;
 
 	case S_ORD:
-		if (!(left = getarg(&arg, T_DISCRETE, 0, edf))) return 0;
+		if (! getarg(&arg, T_DISCRETE, 0, edf)) return 0;
-		expp->nd_type = card_type;
+		MkCoercion(&(arg->nd_left), card_type);
-		if (left->nd_class == Value) cstcall(expp, S_ORD);
+		free_it = 1;
 		break;
 
 	case S_NEW:
@@ -1038,8 +1095,7 @@ ChkStandard(expp, left)
 		}
 		if (! (left = getvariable(&arg, edf))) return 0;
 		if (! (left->nd_type->tp_fund == T_POINTER)) {
-			Xerror(left, "pointer variable expected", edf);
+			return Xerror(left, "pointer variable expected", edf);
-			return 0;
 		}
 		/* Now, make it look like a call to ALLOCATE or DEALLOCATE */
 		{
@@ -1058,7 +1114,7 @@ ChkStandard(expp, left)
 			FreeNode(expp->nd_left);
 			dt.tk_symb = IDENT;
 			dt.tk_lineno = expp->nd_left->nd_lineno;
-			dt.TOK_IDF = str2idf(std == S_NEW ?
+			dt.TOK_IDF = str2idf(edf->df_value.df_stdname==S_NEW ?
 						"ALLOCATE" : "DEALLOCATE", 0);
 			expp->nd_left = MkLeaf(Name, &dt);
 		}
@@ -1080,8 +1136,12 @@ ChkStandard(expp, left)
 	case S_TRUNCD:
 	case S_TRUNC:
 		expp->nd_type = card_type;
-		if (std == S_TRUNCD) expp->nd_type = longint_type;
+		if (edf->df_value.df_stdname == S_TRUNCD) {
-		if (!(left = getarg(&arg, T_REAL, 0, edf))) return 0;
+			expp->nd_type = longint_type;
+		}
+		if (! getarg(&arg, T_REAL, 0, edf)) return 0;
+		MkCoercion(&(arg->nd_left), expp->nd_type);
+		free_it = 1;
 		break;
 
 	case S_VAL:
@@ -1094,12 +1154,13 @@ ChkStandard(expp, left)
 		FreeNode(arg);
 		arg = expp;
 		if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0;
-		if (left->nd_class == Value) cstcall(expp, S_VAL);
+		MkCoercion(&(arg->nd_left), expp->nd_type);
+		free_it = 1;
 		break;
 
 	case S_ADR:
 		expp->nd_type = address_type;
-		if (!(left = getarg(&arg, 0, 1, edf))) return 0;
+		if (! getarg(&arg, 0, 1, edf)) return 0;
 		break;
 
 	case S_DEC:
@@ -1107,8 +1168,7 @@ ChkStandard(expp, left)
 		expp->nd_type = 0;
 		if (! (left = getvariable(&arg, edf))) return 0;
 		if (! (left->nd_type->tp_fund & T_DISCRETE)) {
-			Xerror(left,"illegal parameter type", edf);
+			return Xerror(left,"illegal parameter type", edf);
-			return 0;
 		}
 		if (arg->nd_right) {
 			if (! getarg(&arg, T_INTORCARD, 0, edf)) return 0;
@@ -1122,23 +1182,26 @@ ChkStandard(expp, left)
 	case S_EXCL:
 	case S_INCL:
 		{
-		struct type *tp;
+		register struct type *tp;
+		struct node *dummy;
 
 		expp->nd_type = 0;
 		if (!(left = getvariable(&arg, edf))) return 0;
 		tp = left->nd_type;
 		if (tp->tp_fund != T_SET) {
-			Xerror(arg, "SET parameter expected", edf);
+			return Xerror(arg, "SET parameter expected", edf);
-			return 0;
 		}
-		if (!(left = getarg(&arg, T_DISCRETE, 0, edf))) return 0;
+		if (!(dummy = getarg(&arg, 0, 0, edf))) return 0;
-		if (!TstAssCompat(ElementType(tp), left->nd_type)) {
+		if (!ChkAssCompat(&dummy, ElementType(tp), "EXCL/INCL")) {
 			/* What type of compatibility do we want here?
 			   apparently assignment compatibility! ??? ???
+			   But we don't want the coercion in the tree, because
+			   we don't want a range check here. We want a SET
+			   error.
 			*/
-			Xerror(arg, "unexpected parameter type", edf);
 			return 0;
 		}
+		MkCoercion(&(arg->nd_left), word_type);
 		break;
 		}
 
@@ -1147,16 +1210,22 @@ ChkStandard(expp, left)
 	}
 
 	if (arg->nd_right) {
-		Xerror(arg->nd_right, "too many parameters supplied", edf);
+		return Xerror(arg->nd_right, "too many parameters supplied", edf);
-		return 0;
+	}
+
+	if (free_it) {
+		FreeNode(expp->nd_left);
+		*expp = *(arg->nd_left);
+		arg->nd_left = 0;
+		FreeNode(arg);
 	}
 
 	return 1;
 }
 
 STATIC int
-ChkCast(expp, left)
+ChkCast(expp)
-	register struct node *expp, *left;
+	register struct node *expp;
 {
 	/*	Check a cast and perform it if the argument is constant.
 		If the sizes don't match, only complain if at least one of them
@@ -1165,17 +1234,19 @@ ChkCast(expp, left)
 		is no problem as such values take a word on the EM stack
 		anyway.
 	*/
-	register struct type *lefttype = left->nd_type;
+	register struct node *left = expp->nd_left;
 	register struct node *arg = expp->nd_right;
+	register struct type *lefttype = left->nd_type;
 
 	if ((! arg) || arg->nd_right) {
-		Xerror(expp, "too many parameters in type cast", left->nd_def);
+		return Xerror(expp, "type cast must have 1 parameter", left->nd_def);
-		return 0;
 	}
 
-	arg = arg->nd_left;
+	if (! ChkExpression(arg->nd_left)) return 0;
-	if (! ChkExpression(arg)) return 0;
 
+	MkCoercion(&(arg->nd_left), BaseType(arg->nd_left->nd_type));
+
+	arg = arg->nd_left;
 	if (arg->nd_type->tp_size != lefttype->tp_size &&
 	    (arg->nd_type->tp_size > word_size ||
 	     lefttype->tp_size > word_size)) {
@@ -1186,11 +1257,9 @@ ChkCast(expp, left)
 		FreeNode(left);
 		expp->nd_right->nd_left = 0;
 		FreeNode(expp->nd_right);
-		expp->nd_left = expp->nd_right = 0;
 		*expp = *arg;
-		expp->nd_type = lefttype;
 	}
-	else expp->nd_type = lefttype;
+	expp->nd_type = lefttype;
 
 	return 1;
 }
@@ -1201,17 +1270,16 @@ TryToString(nd, tp)
 {
 	/*	Try a coercion from character constant to string.
 	*/
+	static char buf[2];
 
 	assert(nd->nd_symb == STRING);
 
 	if (tp->tp_fund == T_ARRAY && nd->nd_type == char_type) {
-		int ch = nd->nd_INT;
+		buf[0] = nd->nd_INT;
-
 		nd->nd_type = standard_type(T_STRING, 1, (arith) 2);
 		nd->nd_token.tk_data.tk_str = 
 			(struct string *) Malloc(sizeof(struct string));
-		nd->nd_STR = Salloc("X", 2);
+		nd->nd_STR = Salloc(buf, 2);
-		*(nd->nd_STR) = ch;
 		nd->nd_SLE = 1;
 	}
 }

lang/m2/comp/code.c

@@ -19,12 +19,13 @@
 #include	<em_code.h>
 #include	<em_abs.h>
 #include	<assert.h>
+#include	<alloc.h>
 
 #include	"type.h"
+#include	"LLlex.h"
 #include	"def.h"
 #include	"scope.h"
 #include	"desig.h"
-#include	"LLlex.h"
 #include	"node.h"
 #include	"Lpars.h"
 #include	"standards.h"
@@ -90,7 +91,6 @@ CodeExpr(nd, ds, true_label, false_label)
 		/* Fall through */
 
 	case Link:
-	case LinkDef:
 	case Arrsel:
 	case Arrow:
 		CodeDesig(nd, ds);
@@ -263,10 +263,21 @@ CodeCoercion(t1, t2)
 			C_cfi();
 			break;
 		case T_CARDINAL:
+		{
+			label lb = ++text_label;
+
+			C_dup(t1->tp_size);
+			C_zrf(t1->tp_size);
+			C_cmf(t1->tp_size);
+			C_zge(lb);
+			C_loc((arith) ECONV);
+			C_trp();
+			C_df_ilb(lb);
 			C_loc(t1->tp_size);
 			C_loc(t2->tp_size);
 			C_cfu();
 			break;
+		}
 		default:
 			crash("Funny REAL conversion");
 		}
@@ -400,7 +411,6 @@ CodeParameters(param, arg)
 		case Arrsel:
 		case Arrow:
 		case Def:
-		case LinkDef:
 			CodeDAddress(left);
 			break;
 		default:{
@@ -425,14 +435,6 @@ CodeParameters(param, arg)
 		return;
 	}
 	CodePExpr(left);
-	CodeCheckExpr(left_type, tp);
-}
-
-CodeCheckExpr(tp1, tp2)
-	struct type *tp1, *tp2;
-{
-	CodeCoercion(tp1, tp2);
-	RangeCheck(tp2, tp1);
 }
 
 CodePString(nd, tp)
@@ -486,11 +488,6 @@ CodeStd(nd)
 		C_and(word_size);
 		break;
 
-	case S_CHR:
-		CodePExpr(left);
-		RangeCheck(char_type, tp);
-		break;
-
 	case S_HIGH:
 		assert(IsConformantArray(tp));
 		DoHIGH(left->nd_def);
@@ -519,52 +516,15 @@ CodeStd(nd)
 		}
 		break;
 
-	case S_ORD:
-		CodePExpr(left);
-		break;
-
-	case S_FLOAT:
-		CodePExpr(left);
-		RangeCheck(card_type, left->nd_type);
-		CodeCoercion(tp, nd->nd_type);
-		break;
-
-	case S_TRUNC: {
-		label lb = ++text_label;
-
-		CodePExpr(left);
-		C_dup(tp->tp_size);
-		C_zrf(tp->tp_size);
-		C_cmf(tp->tp_size);
-		C_zge(lb);
-		C_loc((arith) ECONV);
-		C_trp();
-		C_df_ilb(lb);
-		CodeCoercion(tp, nd->nd_type);
-		}
-		break;
-
-	case S_TRUNCD:
-	case S_FLOATD:
-	case S_LONG:
-	case S_SHORT:
-		CodePExpr(left);
-		CodeCoercion(tp, nd->nd_type);
-		break;
-
-	case S_VAL:
-		CodePExpr(left);
-		RangeCheck(nd->nd_type, tp);
-		break;
-
 	case S_ADR:
 		CodeDAddress(left);
 		break;
 
 	case S_DEC:
 	case S_INC: {
-		register arith size = tp->tp_size;
+		register arith size;
 
+		size = left->nd_type->tp_size;
 		if (size < word_size) size = word_size;
 		CodePExpr(left);
 		if (arg) {
@@ -584,7 +544,7 @@ CodeStd(nd)
 			else	C_adu(size);
 		}
 		if (size == word_size) {
-			RangeCheck(tp, tp->tp_fund == T_INTEGER ?
+			RangeCheck(left->nd_type, tp->tp_fund == T_INTEGER ?
 						int_type : card_type);
 		}
 		CodeDStore(left);
@@ -628,24 +588,24 @@ RangeCheck(tpl, tpr)
 		if (!bounded(tpr)) {
 			/* yes, we need one */
 			genrck(tpl);
+			return;
 		}
-		else {
+		/* both types are restricted. check the bounds
-			/* both types are restricted. check the bounds
+		   to see wether we need a range check.
-			   to see wether we need a range check.
+		   We don't need one if the range of values of the
-			   We don't need one if the range of values of the
+		   right hand side is a subset of the range of values
-			   right hand side is a subset of the range of values
+		   of the left hand side.
-			   of the left hand side.
+		*/
-			*/
+		getbounds(tpl, &llo, &lhi);
-			getbounds(tpl, &llo, &lhi);
+		getbounds(tpr, &rlo, &rhi);
-			getbounds(tpr, &rlo, &rhi);
+		if (llo > rlo || lhi < rhi) {
-			if (llo > rlo || lhi < rhi) {
+			genrck(tpl);
-				genrck(tpl);
-			}
 		}
+		return;
 	}
-	else if (tpl->tp_size <= tpr->tp_size &&
+	if (tpl->tp_size <= tpr->tp_size &&
-		 ((tpl->tp_fund == T_INTEGER && tpr == card_type) ||
+	    ((tpl->tp_fund == T_INTEGER && tpr == card_type) ||
-		  (tpr->tp_fund == T_INTEGER && tpl == card_type))) {
+	     (tpr->tp_fund == T_INTEGER && tpl == card_type))) {
 		label lb = ++text_label;
 
 		C_dup(word_size);
@@ -654,18 +614,14 @@ RangeCheck(tpl, tpr)
 		C_trp();
 		C_df_ilb(lb);
 	}
-
 }
 
-Operands(leftop, rightop, tp)
+Operands(leftop, rightop)
 	register struct node *leftop, *rightop;
-	struct type *tp;
 {
 
 	CodePExpr(leftop);
-	CodeCoercion(leftop->nd_type, tp);
 	CodePExpr(rightop);
-	CodeCoercion(rightop->nd_type, tp);
 }
 
 CodeOper(expr, true_label, false_label)
@@ -679,7 +635,7 @@ CodeOper(expr, true_label, false_label)
 
 	switch (expr->nd_symb)	{
 	case '+':
-		Operands(leftop, rightop, tp);
+		Operands(leftop, rightop);
 		switch (tp->tp_fund)	{
 		case T_INTEGER:
 			C_adi(tp->tp_size);
@@ -701,7 +657,7 @@ CodeOper(expr, true_label, false_label)
 		}
 		break;
 	case '-':
-		Operands(leftop, rightop, tp);
+		Operands(leftop, rightop);
 		switch (tp->tp_fund)	{
 		case T_INTEGER:
 			C_sbi(tp->tp_size);
@@ -724,7 +680,7 @@ CodeOper(expr, true_label, false_label)
 		}
 		break;
 	case '*':
-		Operands(leftop, rightop, tp);
+		Operands(leftop, rightop);
 		switch (tp->tp_fund)	{
 		case T_INTEGER:
 			C_mli(tp->tp_size);
@@ -746,7 +702,7 @@ CodeOper(expr, true_label, false_label)
 		}
 		break;
 	case '/':
-		Operands(leftop, rightop, tp);
+		Operands(leftop, rightop);
 		switch (tp->tp_fund)	{
 		case T_REAL:
 			C_dvf(tp->tp_size);
@@ -759,7 +715,7 @@ CodeOper(expr, true_label, false_label)
 		}
 		break;
 	case DIV:
-		Operands(leftop, rightop, tp);
+		Operands(leftop, rightop);
 		switch(tp->tp_fund)	{
 		case T_INTEGER:
 			C_dvi(tp->tp_size);
@@ -775,7 +731,7 @@ CodeOper(expr, true_label, false_label)
 		}
 		break;
 	case MOD:
-		Operands(leftop, rightop, tp);
+		Operands(leftop, rightop);
 		switch(tp->tp_fund)	{
 		case T_INTEGER:
 			C_rmi(tp->tp_size);
@@ -796,9 +752,9 @@ CodeOper(expr, true_label, false_label)
 	case GREATEREQUAL:
 	case '=':
 	case '#':
+		Operands(leftop, rightop);
 		tp = BaseType(leftop->nd_type);
 		if (tp == intorcard_type) tp = BaseType(rightop->nd_type);
-		Operands(leftop, rightop, tp);
 		switch (tp->tp_fund)	{
 		case T_INTEGER:
 			C_cmi(tp->tp_size);
@@ -854,7 +810,6 @@ CodeOper(expr, true_label, false_label)
 		*/
 		CodePExpr(rightop);
 		CodePExpr(leftop);
-		CodeCoercion(leftop->nd_type, word_type);
 		C_inn(rightop->nd_type->tp_size);
 		if (true_label != NO_LABEL) {
 			C_zne(true_label);
@@ -862,10 +817,9 @@ CodeOper(expr, true_label, false_label)
 		}
 		break;
 	case OR:
-	case AND:
+	case AND: {
-	case '&': {
 		label  l_maybe = ++text_label, l_end;
-		struct desig Des;
+		struct desig *Des = new_desig();
 		int genlabels = 0;
 
 		if (true_label == NO_LABEL)	{
@@ -875,14 +829,14 @@ CodeOper(expr, true_label, false_label)
 			l_end = ++text_label;
 		}
 
-		Des = InitDesig;
 		if (expr->nd_symb == OR) {
-			CodeExpr(leftop, &Des, true_label, l_maybe);
+			CodeExpr(leftop, Des, true_label, l_maybe);
 		}
-		else	CodeExpr(leftop, &Des, l_maybe, false_label);
+		else	CodeExpr(leftop, Des, l_maybe, false_label);
 		C_df_ilb(l_maybe);
-		Des = InitDesig;
+		free_desig(Des);
-		CodeExpr(rightop, &Des, true_label, false_label);
+		Des = new_desig();
+		CodeExpr(rightop, Des, true_label, false_label);
 		if (genlabels) {
 			C_df_ilb(true_label);
 			C_loc((arith)1);
@@ -891,6 +845,7 @@ CodeOper(expr, true_label, false_label)
 			C_loc((arith)0);
 			C_df_ilb(l_end);
 		}
+		free_desig(Des);
 		break;
 		}
 	default:
@@ -962,7 +917,6 @@ CodeUoper(nd)
 
 	CodePExpr(nd->nd_right);
 	switch(nd->nd_symb) {
-	case '~':
 	case NOT:
 		C_teq();
 		break;
@@ -979,6 +933,10 @@ CodeUoper(nd)
 			crash("Bad operand to unary -");
 		}
 		break;
+	case COERCION:
+		CodeCoercion(nd->nd_right->nd_type, tp);
+		RangeCheck(tp, nd->nd_right->nd_type);
+		break;
 	default:
 		crash("Bad unary operator");
 	}
@@ -1010,7 +968,7 @@ CodeEl(nd, tp)
 			C_loc(eltype->sub_ub);
 		}
 		else	C_loc((arith) (eltype->enm_ncst - 1));
-		Operands(nd->nd_left, nd->nd_right, word_type);
+		Operands(nd->nd_left, nd->nd_right);
 		C_cal("_LtoUset");	/* library routine to fill set */
 		C_asp(4 * word_size);
 	}
@@ -1027,11 +985,11 @@ CodePExpr(nd)
 	/*	Generate code to push the value of the expression "nd"
 		on the stack.
 	*/
-	struct desig designator;
+	register struct desig *designator = new_desig();
 
-	designator = InitDesig;
+	CodeExpr(nd, designator, NO_LABEL, NO_LABEL);
-	CodeExpr(nd, &designator, NO_LABEL, NO_LABEL);
+	CodeValue(designator, nd->nd_type);
-	CodeValue(&designator, nd->nd_type);
+	free_desig(designator);
 }
 
 CodeDAddress(nd)
@@ -1041,11 +999,11 @@ CodeDAddress(nd)
 		on the stack.
 	*/
 
-	struct desig designator;
+	register struct desig *designator = new_desig();
 
-	designator = InitDesig;
+	CodeDesig(nd, designator);
-	CodeDesig(nd, &designator);
+	CodeAddress(designator);
-	CodeAddress(&designator);
+	free_desig(designator);
 }
 
 CodeDStore(nd)
@@ -1055,11 +1013,11 @@ CodeDStore(nd)
 		designator "nd".
 	*/
 
-	struct desig designator;
+	register struct desig *designator = new_desig();
 
-	designator = InitDesig;
+	CodeDesig(nd, designator);
-	CodeDesig(nd, &designator);
+	CodeStore(designator, nd->nd_type);
-	CodeStore(&designator, nd->nd_type);
+	free_desig(designator);
 }
 
 DoHIGH(df)

lang/m2/comp/cstoper.c

@@ -27,6 +27,7 @@
 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	*/
 arith max_unsigned;	/* maximum unsigned on target machine	*/
 arith max_longint;	/* maximum longint on target machine	*/
@@ -200,14 +201,7 @@ cstbin(expp)
 		/* Fall through */
 
 	case GREATEREQUAL:
-		if (uns)	{
+		o1 = chk_bounds(o2, o1, uns ? T_CARDINAL : T_INTEGER);
-			o1 = (o1 & mach_long_sign ?
-				(o2 & mach_long_sign ? o1 >= o2 : 1) :
-				(o2 & mach_long_sign ? 0 : o1 >= o2)
-			);
-		}
-		else
-			o1 = (o1 >= o2);
 		break;
 
 	case '=':
@@ -251,6 +245,7 @@ cstset(expp)
 
 	assert(expp->nd_right->nd_class == Set);
 	assert(expp->nd_symb == IN || expp->nd_left->nd_class == Set);
+
 	set2 = expp->nd_right->nd_set;
 	setsize = (unsigned) expp->nd_right->nd_type->tp_size / (unsigned) word_size;
 
@@ -390,22 +385,11 @@ cstcall(expp, call)
 		CutSize(expp);
 		break;
 
-	case S_LONG:
-	case S_SHORT: {
-		struct type *tp = expp->nd_type;
-
-		*expp = *expr;
-		expp->nd_type = tp;
-		break;
-		}
 	case S_CAP:
 		if (expr->nd_INT >= 'a' && expr->nd_INT <= 'z') {
 			expr->nd_INT = expr->nd_INT + ('A' - 'a');
 		}
-		/* fall through */
-	case S_CHR:
 		expp->nd_INT = expr->nd_INT;
-		CutSize(expp);
 		break;
 
 	case S_MAX:
@@ -443,35 +427,10 @@ cstcall(expp, call)
 		expp->nd_INT = (expr->nd_INT & 1);
 		break;
 
-	case S_ORD:
-		expp->nd_INT = expr->nd_INT;
-		CutSize(expp);
-		break;
-
 	case S_SIZE:
 		expp->nd_INT = expr->nd_type->tp_size;
 		break;
 
-	case S_VAL:
-		expp->nd_INT = expr->nd_INT;
-		if ( /* Check overflow of subranges or enumerations */
-		    ( expp->nd_type->tp_fund == T_SUBRANGE
-		    &&
-		      (  expp->nd_INT < expp->nd_type->sub_lb
-		      || expp->nd_INT > expp->nd_type->sub_ub
-		      )
-		    )
-		   ||
-		    ( expp->nd_type->tp_fund == T_ENUMERATION
-		    &&
-		      (  expp->nd_INT < 0
-		      || expp->nd_INT >= expp->nd_type->enm_ncst
-		      )
-		    )
-		   )	node_warning(expp, W_ORDINARY, ovflow);
-		else CutSize(expp);
-		break;
-
 	default:
 		crash("(cstcall)");
 	}
@@ -501,9 +460,9 @@ CutSize(expr)
 	}
 	else {
 		int nbits = (int) (mach_long_size - size) * 8;
-		long remainder = o1 & ~full_mask[size];
+		long remainder = o1 & ~int_mask[size];
 
-		if (remainder != 0 && remainder != ~full_mask[size]) {
+		if (remainder != 0 && remainder != ~int_mask[size]) {
 			node_warning(expr, W_ORDINARY, ovflow);
 			o1 <<= nbits;
 			o1 >>= nbits;
@@ -522,6 +481,7 @@ 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));
 	}
 	mach_long_size = i;
 	mach_long_sign = 1L << (mach_long_size * 8 - 1);
@@ -529,8 +489,8 @@ InitCst()
 		fatal("sizeof (long) insufficient on this machine");
 	}
 
-	max_int = full_mask[int_size] & ~(1L << (int_size * 8 - 1));
+	max_int = int_mask[int_size];
 	max_unsigned = full_mask[int_size];
-	max_longint = full_mask[long_size] & ~(1L << (long_size * 8 - 1));
+	max_longint = int_mask[long_size];
 	wrd_bits = 8 * (unsigned) word_size;
 }

lang/m2/comp/declar.g

@@ -387,22 +387,22 @@ CaseLabels(struct type **ptp; register struct node **pnd;)
 	register struct node *nd;
 }:
 	ConstExpression(pnd)
-			{ nd = *pnd; }
+			{ 
+			  if (*ptp != 0) {
+				ChkCompat(pnd, *ptp, "case label");
+			  }
+			  nd = *pnd;
+			}
 	[
 		UPTO	{ *pnd = MkNode(Link,nd,NULLNODE,&dot); }
 		ConstExpression(&(*pnd)->nd_right)
-			{ if (!TstCompat(nd->nd_type,
+			{ if (!ChkCompat(&((*pnd)->nd_right), nd->nd_type,
-					 (*pnd)->nd_right->nd_type)) {
+					 "case label")) {
-				node_error((*pnd)->nd_right,
-					  "type incompatibility in case label");
 			  	nd->nd_type = error_type;
 			  }
 			}
 	]?
-			{ if (*ptp != 0 && !TstCompat(*ptp, nd->nd_type)) {
+			{
-				node_error(nd,
-					  "type incompatibility in case label");
-			  }
 			  *ptp = nd->nd_type;
 			}
 ;
@@ -486,10 +486,15 @@ ConstantDeclaration
 {
 	struct idf *id;
 	struct node *nd;
+	register struct def *df;
 }:
 	IDENT		{ id = dot.TOK_IDF; }
 	'=' ConstExpression(&nd)
-			{ define(id,CurrentScope,D_CONST)->con_const = nd; }
+			{ df = define(id,CurrentScope,D_CONST);
+			  df->con_const = nd->nd_token;
+			  df->df_type = nd->nd_type;
+			  FreeNode(nd);
+			}
 ;
 
 VariableDeclaration
@@ -508,10 +513,14 @@ VariableDeclaration
 			{ EnterVarList(VarList, tp, proclevel > 0); }
 ;
 
-IdentAddr(register struct node **pnd;) :
+IdentAddr(struct node **pnd;) 
-	IDENT		{ *pnd = MkLeaf(Name, &dot); }
+{
+	register struct node *nd;
+} :
+	IDENT		{ nd = MkLeaf(Name, &dot); }
 	[	'['
-		ConstExpression(&((*pnd)->nd_left))
+		ConstExpression(&(nd->nd_left))
 		']'
 	]?
+			{ *pnd = nd; }
 ;

lang/m2/comp/def.H

@@ -26,7 +26,7 @@ struct variable {
 };
 
 struct constant {
-	struct node *co_const;	/* result of a constant expression */
+	struct token co_const;	/* result of a constant expression */
 #define con_const	df_value.df_constant.co_const
 };
 

lang/m2/comp/def.c

@@ -16,17 +16,15 @@
 #include	<em_label.h>
 #include	<assert.h>
 
+#include	"LLlex.h"
 #include	"main.h"
 #include	"def.h"
 #include	"type.h"
 #include	"idf.h"
 #include	"scope.h"
-#include	"LLlex.h"
 #include	"node.h"
 #include	"Lpars.h"
 
-extern int	(*c_inp)();
-
 STATIC
 DefInFront(df)
 	register struct def *df;
@@ -272,7 +270,10 @@ DeclProc(type, id)
 			df = define(id, CurrentScope, type);
 			sprint(buf,"_%d_%s",++nmcount,id->id_text);
 			name = Salloc(buf, (unsigned)(strlen(buf)+1));
-			(*c_inp)(buf);
+			if (options['x']) {
+				C_exp(buf);
+			}
+			else	C_inp(buf);
 		}
 		open_scope(OPENSCOPE);
 		scope = CurrentScope;
@@ -342,7 +343,10 @@ DefineLocalModule(id)
 	/* Generate code that indicates that the initialization procedure
 	   for this module is local.
 	*/
-	(*c_inp)(buf);
+	if (options['x']) {
+		C_exp(buf);
+	}
+	else	C_inp(buf);
 
 	return df;
 }

lang/m2/comp/defmodule.c

@@ -19,8 +19,8 @@
 #include	"idf.h"
 #include	"input.h"
 #include	"scope.h"
-#include	"def.h"
 #include	"LLlex.h"
+#include	"def.h"
 #include	"Lpars.h"
 #include	"f_info.h"
 #include	"main.h"

lang/m2/comp/desig.H

@@ -0,0 +1,66 @@
+/*
+ * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ * See the copyright notice in the ACK home directory, in the file "Copyright".
+ *
+ * Author: Ceriel J.H. Jacobs
+ */
+
+/* D E S I G N A T O R   D E S C R I P T I O N S */
+
+/* $Header$ */
+
+/* Generating code for designators is not particularly easy, especially if
+   you don't know wether you want the address or the value.
+   The next structure is used to generate code for designators.
+   It contains information on how to find the designator, after generation
+   of the code that is common to both address and value computations.
+*/
+
+struct desig {
+	int	dsg_kind;
+#define DSG_INIT	0	/* don't know anything yet */
+#define DSG_LOADED	1	/* designator loaded  on top of the stack */
+#define DSG_PLOADED	2	/* designator accessible through pointer on
+				   stack, possibly with an offset
+				*/
+#define DSG_FIXED	3	/* designator directly accessible */
+#define DSG_PFIXED	4	/* designator accessible through directly
+				   accessible pointer
+				*/
+#define DSG_INDEXED	5	/* designator accessible through array
+				   operation. Address of array descriptor on
+				   top of the stack, index beneath that, and
+				   base address beneath that
+				*/
+	arith	dsg_offset;	/* contains an offset for PLOADED,
+				   or for FIXED or PFIXED it contains an
+				   offset from dsg_name, if it exists,
+				   or from the current Local Base
+				*/
+	char	*dsg_name;	/* name of global variable, used for
+				   FIXED and PFIXED
+				*/
+	struct def *dsg_def;	/* def structure associated with this
+				   designator, or 0
+				*/
+};
+
+/* ALLOCDEF "desig" 5 */
+
+/* The next structure describes the designator in a with-statement.
+   We have a linked list of them, as with-statements may be nested.
+*/
+
+struct withdesig {
+	struct withdesig *w_next;
+	struct scope *w_scope;	/* scope in which fields of this record
+				   reside
+				*/
+	struct desig w_desig;	/* a desig structure for this particular
+				   designator
+				*/
+};
+
+extern struct withdesig	*WithDesigs;
+
+#define NO_LABEL	((label) 0)

lang/m2/comp/desig.c

@@ -22,16 +22,16 @@
 #include	<em_label.h>
 #include	<em_code.h>
 #include	<assert.h>
+#include	<alloc.h>
 
 #include	"type.h"
+#include	"LLlex.h"
 #include	"def.h"
 #include	"scope.h"
 #include	"desig.h"
-#include	"LLlex.h"
 #include	"node.h"
 
 extern int	proclevel;
-struct desig	InitDesig = {DSG_INIT, 0, 0, 0};
 
 int
 WordOrDouble(ds, size)
@@ -86,9 +86,9 @@ DoStore(ds, size)
 }
 
 STATIC int
-properly(ds, size, al)
+properly(ds, tp)
 	register struct desig *ds;
-	arith size;
+	register struct type *tp;
 {
 	/*	Check if it is allowed to load or store the value indicated
 		by "ds" with LOI/STI.
@@ -100,16 +100,17 @@ properly(ds, size, al)
 		  with DSG_FIXED.
 	*/
 
-	int szmodword = (int) size % (int) word_size;	/* 0 if multiple of wordsize */
+	int szmodword = (int) (tp->tp_size) % (int) word_size;
-	int wordmodsz = word_size % size;	/* 0 if dividor of wordsize */
+						/* 0 if multiple of wordsize */
+	int wordmodsz = word_size % tp->tp_size;/* 0 if dividor of wordsize */
 
 	if (szmodword && wordmodsz) return 0;
-	if (al >= word_align) return 1;
+	if (tp->tp_align >= word_align) return 1;
-	if (szmodword && al >= szmodword) return 1;
+	if (szmodword && tp->tp_align >= szmodword) return 1;
 
 	return ds->dsg_kind == DSG_FIXED &&
 	       ((! szmodword && (int) (ds->dsg_offset) % word_align == 0) ||
-		(! wordmodsz && ds->dsg_offset % size == 0));
+		(! wordmodsz && ds->dsg_offset % tp->tp_size == 0));
 }
 
 CodeValue(ds, tp)
@@ -131,7 +132,7 @@ CodeValue(ds, tp)
 	case DSG_PLOADED:
 	case DSG_PFIXED:
 		sz = WA(tp->tp_size);
-		if (properly(ds, tp->tp_size, tp->tp_align)) {
+		if (properly(ds, tp)) {
 			CodeAddress(ds);
 			C_loi(tp->tp_size);
 			break;
@@ -162,9 +163,6 @@ CodeValue(ds, tp)
 	}
 
 	ds->dsg_kind = DSG_LOADED;
-	if (tp->tp_fund == T_SUBRANGE) {
-		CodeCoercion(tp, BaseType(tp));
-	}
 }
 
 CodeStore(ds, tp)
@@ -184,7 +182,7 @@ CodeStore(ds, tp)
 	case DSG_PLOADED:
 	case DSG_PFIXED:
 		CodeAddress(&save);
-		if (properly(ds, tp->tp_size, tp->tp_align)) {
+		if (properly(ds, tp)) {
 			C_sti(tp->tp_size);
 			break;
 		}
@@ -225,13 +223,10 @@ CodeMove(rhs, left, rtp)
 	register struct node *left;
 	struct type *rtp;
 {
-	struct desig dsl;
+	register struct desig *lhs = new_desig();
-	register struct desig *lhs = &dsl;
 	register struct type *tp = left->nd_type;
 	int	loadedflag = 0;
 
-	dsl = InitDesig;
-
 	/*	Generate code for an assignment. Testing of type
 		compatibility and the like is already done.
 		Go through some (considerable) trouble to see if a BLM can be
@@ -247,10 +242,10 @@ CodeMove(rhs, left, rtp)
 			C_loc(tp->tp_size);
 			C_cal("_StringAssign");
 			C_asp(word_size << 2);
-			return;
+			break;
 		}
 		CodeStore(lhs, tp);
-		return;
+		break;
 	case DSG_PLOADED:
 	case DSG_PFIXED:
 		CodeAddress(rhs);
@@ -259,11 +254,11 @@ CodeMove(rhs, left, rtp)
 			CodeDesig(left, lhs);
 			CodeAddress(lhs);
 			C_blm(tp->tp_size);
-			return;
+			break;
 		}
 		CodeValue(rhs, tp);
 		CodeDStore(left);
-		return;
+		break;
 	case DSG_FIXED:
 		CodeDesig(left, lhs);
 		if (lhs->dsg_kind == DSG_FIXED &&
@@ -313,7 +308,7 @@ CodeMove(rhs, left, rtp)
 					CodeCopy(lhs, rhs, (arith) sz, &size);
 				}
 			}
-			return;
+			break;
 		}
 		if (lhs->dsg_kind == DSG_PLOADED ||
 		    lhs->dsg_kind == DSG_INDEXED) {
@@ -326,7 +321,7 @@ CodeMove(rhs, left, rtp)
 			if (loadedflag) C_exg(pointer_size);
 			else CodeAddress(lhs);
 			C_blm(tp->tp_size);
-			return;
+			break;
 		}
 		{
 			arith tmp;
@@ -343,11 +338,12 @@ CodeMove(rhs, left, rtp)
 			CodeValue(rhs, tp);
 			CodeStore(lhs, tp);
 			if (loadedflag) FreePtr(tmp);
-			return;
+			break;
 		}
 	default:
 		crash("CodeMove");
 	}
+	free_desig(lhs);
 }
 
 CodeAddress(ds)
@@ -529,6 +525,7 @@ CodeDesig(nd, ds)
 	switch(nd->nd_class) {	/* Divide */
 	case Def:
 		df = nd->nd_def;
+		if (nd->nd_left) CodeDesig(nd->nd_left, ds);
 
 		switch(df->df_kind) {
 		case D_FIELD:
@@ -544,22 +541,12 @@ CodeDesig(nd, ds)
 		}
 		break;
 
-	case LinkDef:
-		assert(nd->nd_symb == '.');
-
-		CodeDesig(nd->nd_left, ds);
-		CodeFieldDesig(nd->nd_def, ds);
-		break;
-
 	case Arrsel:
 		assert(nd->nd_symb == '[');
 
 		CodeDesig(nd->nd_left, ds);
 		CodeAddress(ds);
 		CodePExpr(nd->nd_right);
-		if (nd->nd_right->nd_type->tp_size > word_size) {
-			CodeCoercion(nd->nd_right->nd_type, int_type);
-		}
 
 		/* Now load address of descriptor
 		*/

lang/m2/comp/enter.c

@@ -18,10 +18,10 @@
 #include	<assert.h>
 
 #include	"idf.h"
+#include	"LLlex.h"
 #include	"def.h"
 #include	"type.h"
 #include	"scope.h"
-#include	"LLlex.h"
 #include	"node.h"
 #include	"main.h"
 #include	"misc.h"

lang/m2/comp/expression.g

@@ -146,19 +146,21 @@ AddOperator:
 
 term(struct node **pnd;)
 {
+	register struct node *nd;
 }:
-	factor(pnd)
+	factor(pnd)	{ nd = *pnd; }
 	[
 		/* MulOperator */
-		[ '*' | '/' | DIV | MOD | AND | '&' ]
+		[ '*' | '/' | DIV | MOD | AND ]
-			{ *pnd = MkNode(Oper, *pnd, NULLNODE, &dot); }
+			{ nd = MkNode(Oper, nd, NULLNODE, &dot); }
-		factor(&((*pnd)->nd_right))
+		factor(&(nd->nd_right))
 	]*
+			{ *pnd = nd; }
 ;
 
 /* inline in "term"
 MulOperator:
-	'*' | '/' | DIV | MOD | AND | '&'
+	'*' | '/' | DIV | MOD | AND
 ;
 */
 

lang/m2/comp/input.c

@@ -12,11 +12,6 @@
 #include	"f_info.h"
 struct f_info	file_info;
 #include	"input.h"
-#include	<em_arith.h>
-#include	<em_label.h>
-#include	"def.h"
-#include	"idf.h"
-#include	"scope.h"
 #include	<inp_pkg.body>
 
 

lang/m2/comp/lookup.c

@@ -15,10 +15,10 @@
 #include	<em_label.h>
 #include	<assert.h>
 
+#include	"LLlex.h"
 #include	"def.h"
 #include	"idf.h"
 #include	"scope.h"
-#include	"LLlex.h"
 #include	"node.h"
 #include	"type.h"
 #include	"misc.h"
@@ -52,9 +52,11 @@ lookup(id, scope, import)
 			df->df_next = id->id_def;
 			id->id_def = df;
 		}
-		if (import && df->df_kind == D_IMPORT) {
+		if (import) {
-			assert(df->imp_def != 0);
+			while (df->df_kind == D_IMPORT) {
-			return df->imp_def;
+				assert(df->imp_def != 0);
+				df = df->imp_def;
+			}
 		}
 	}
 	return df;

lang/m2/comp/main.c

@@ -36,13 +36,11 @@ int		DefinitionModule;
 char		*ProgName;
 char		**DEFPATH;
 int		nDEF, mDEF;
+int		pass_1;
 struct def 	*Defined;
 extern int 	err_occurred;
 extern int	fp_used;		/* set if floating point used */
 
-extern		C_inp(), C_exp();
-int		(*c_inp)() = C_inp;
-
 main(argc, argv)
 	register char **argv;
 {
@@ -66,7 +64,6 @@ main(argc, argv)
 		fprint(STDERR, "%s: Use a file argument\n", ProgName);
 		exit(1);
 	}
-	if (options['x']) c_inp = C_exp;
 	exit(!Compile(Nargv[1], Nargv[2]));
 }
 
@@ -103,9 +100,11 @@ Compile(src, dst)
 	C_magic();
 	C_ms_emx(word_size, pointer_size);
 	CheckForLineDirective();
+	pass_1 = 1;
 	CompUnit();
 	C_ms_src((int)LineNumber - 1, FileName);
 	if (!err_occurred) {
+		pass_1 = 0;
 		C_exp(Defined->mod_vis->sc_scope->sc_name);
 		WalkModule(Defined);
 		if (fp_used) C_ms_flt();
@@ -186,7 +185,7 @@ AddStandards()
 {
 	register struct def *df;
 	register struct stdproc *p;
-	static struct node nilnode = { 0, 0, Value, 0, { INTEGER, 0}};
+	static struct token nilconst = { INTEGER, 0};
 
 	for (p = stdproc; p->st_nam != 0; p++) {
 		Enter(p->st_nam, D_PROCEDURE, std_type, p->st_con);
@@ -200,9 +199,7 @@ AddStandards()
 	EnterType("BOOLEAN", bool_type);
 	EnterType("CARDINAL", card_type);
 	df = Enter("NIL", D_CONST, address_type, 0);
-	df->con_const = &nilnode;
+	df->con_const = nilconst;
-	nilnode.nd_INT = 0;
-	nilnode.nd_type = address_type;
 
 	EnterType("PROC", construct_type(T_PROCEDURE, NULLTYPE));
 	EnterType("BITSET", bitset_type);

lang/m2/comp/node.c

@@ -16,9 +16,9 @@
 #include	<alloc.h>
 #include	<system.h>
 
+#include	"LLlex.h"
 #include	"def.h"
 #include	"type.h"
-#include	"LLlex.h"
 #include	"node.h"
 
 struct node *

lang/m2/comp/tmpvar.C

@@ -24,6 +24,7 @@
 #include	<alloc.h>
 #include	<assert.h>
 
+#include	"LLlex.h"
 #include	"def.h"
 #include	"type.h"
 #include	"scope.h"

lang/m2/comp/tokenname.c

@@ -85,6 +85,7 @@ struct tokenname tkidf[] =	{	/* names of the identifier tokens */
 #ifdef ___XXX___
 struct tokenname tkinternal[] = {	/* internal keywords	*/
 	{PROGRAM, ""},
+	{COERCION, ""},
 	{0, "0"}
 };
 

lang/m2/comp/type.H

@@ -179,6 +179,7 @@ struct type
 #define	IsConstructed(tpx)	((tpx)->tp_fund & T_CONSTRUCTED)
 
 extern long full_mask[];
+extern long int_mask[];
 
 #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

@@ -19,10 +19,10 @@
 #include	<em_label.h>
 #include	<em_code.h>
 
+#include	"LLlex.h"
 #include	"def.h"
 #include	"type.h"
 #include	"idf.h"
-#include	"LLlex.h"
 #include	"node.h"
 #include	"const.h"
 #include	"scope.h"
@@ -287,7 +287,10 @@ chk_basesubrange(tp, base)
 		/* Check that the bounds of "tp" fall within the range
 		   of "base".
 		*/
-		if (base->sub_lb > tp->sub_lb || base->sub_ub < tp->sub_ub) {
+		int fund = base->tp_next->tp_fund;
+
+		if (! chk_bounds(base->sub_lb, tp->sub_lb, fund) || 
+		    ! chk_bounds(base->sub_ub, tp->sub_ub, fund)) {
 			error("base type has insufficient range");
 		}
 		base = base->tp_next;
@@ -314,6 +317,21 @@ chk_basesubrange(tp, base)
 	tp->tp_align = base->tp_align;
 }
 
+int
+chk_bounds(l1, l2, fund)
+	arith l1, l2;
+{
+	/*	compare to arith's, but be careful. They might be unsigned
+	*/
+	if (fund == T_INTEGER) {
+		return l2 >= l1;
+	}
+	return (l2 & mach_long_sign ?
+		(l1 & mach_long_sign ? l2 >= l1 : 1) :
+		(l1 & mach_long_sign ? 0 : l2 >= l1)
+	       );
+}
+
 struct type *
 subr_type(lb, ub)
 	register struct node *lb;
@@ -326,11 +344,6 @@ subr_type(lb, ub)
 	register struct type *tp = BaseType(lb->nd_type);
 	register struct type *res;
 
-	if (!TstCompat(lb->nd_type, ub->nd_type)) {
-		node_error(lb, "types of subrange bounds not equal");
-		return error_type;
-	}
-
 	if (tp == intorcard_type) {
 		/* Lower bound >= 0; in this case, the base type is CARDINAL,
 		   according to the language definition, par. 6.3
@@ -339,6 +352,10 @@ subr_type(lb, ub)
 		tp = card_type;
 	}
 
+	if (!ChkCompat(&ub, tp, "subrange bounds")) {
+		return error_type;
+	}
+
 	/* Check base type
 	*/
 	if (! (tp->tp_fund & T_DISCRETE)) {
@@ -348,7 +365,7 @@ subr_type(lb, ub)
 
 	/* Check bounds
 	*/
-	if (lb->nd_INT > ub->nd_INT) {
+	if (! chk_bounds(lb->nd_INT, ub->nd_INT, tp->tp_fund)) {
 		node_error(lb, "lower bound exceeds upper bound");
 	}
 
@@ -490,7 +507,7 @@ ArraySizes(tp)
 	*/
 	register struct type *index_type = IndexType(tp);
 	register struct type *elem_type = tp->arr_elem;
-	arith lo, hi;
+	arith lo, hi, diff;
 
 	tp->arr_elsize = ArrayElSize(elem_type);
 	tp->tp_align = elem_type->tp_align;
@@ -504,20 +521,21 @@ ArraySizes(tp)
 	}
 
 	getbounds(index_type, &lo, &hi);
+	diff = hi - lo;
 
-	tp->tp_size = (hi - lo + 1) * tp->arr_elsize;
+	tp->tp_size = (diff + 1) * tp->arr_elsize;
 
 	/* generate descriptor and remember label.
 	*/
 	tp->arr_descr = ++data_label;
 	C_df_dlb(tp->arr_descr);
 	C_rom_cst(lo);
-	C_rom_cst(hi - lo);
+	C_rom_cst(diff);
 	C_rom_cst(tp->arr_elsize);
 }
 
 FreeType(tp)
-	struct type *tp;
+	register struct type *tp;
 {
 	/*	Release type structures indicated by "tp".
 		This procedure is only called for types, constructed with
@@ -549,19 +567,20 @@ DeclareType(nd, df, tp)
 		"df" is already bound. In that case, it is either an opaque
 		type, or an error message was given when "df" was created.
 	*/
+	register struct type *df_tp = df->df_type;
 
-	if (df->df_type && df->df_type->tp_fund == T_HIDDEN) {
+	if (df_tp && df_tp->tp_fund == T_HIDDEN) {
 	  	if (! (tp->tp_fund & (T_POINTER|T_HIDDEN|T_EQUAL))) {
 			node_error(nd,
 				   "opaque type \"%s\" is not a pointer type",
 				   df->df_idf->id_text);
 		}
-		df->df_type->tp_next = tp;
+		df_tp->tp_next = tp;
-		df->df_type->tp_fund = T_EQUAL;
+		df_tp->tp_fund = T_EQUAL;
-		while (tp != df->df_type && tp->tp_fund == T_EQUAL) {
+		while (tp != df_tp && tp->tp_fund == T_EQUAL) {
 			tp = tp->tp_next;
 		}
-		if (tp == df->df_type) {
+		if (tp == df_tp) {
 			/* Circular definition! */
 			node_error(nd,
 				 "opaque type \"%s\" has a circular definition",
@@ -588,7 +607,7 @@ type_or_forward(ptp)
 		in "dot". This routine handles the different cases.
 	*/
 	register struct node *nd;
-	register struct def *df1;
+	register struct def *df, *df1;
 
 	if ((df1 = lookup(dot.TOK_IDF, CurrentScope, 1))) {
 		/* Either a Module or a Type, but in both cases defined
@@ -622,21 +641,17 @@ type_or_forward(ptp)
 		may have forward references that must howewer be declared in the
 		same scope.
 	*/
-	{
+	df = define(nd->nd_IDF, CurrentScope, D_FORWTYPE);
-		register struct def *df =
-			define(nd->nd_IDF, CurrentScope, D_FORWTYPE);
 
-		if (df->df_kind == D_TYPE) {
+	if (df->df_kind == D_TYPE) {
-			(*ptp)->tp_next = df->df_type;
+		(*ptp)->tp_next = df->df_type;
-			free_node(nd);
+		free_node(nd);
-		}
+		return 0;
-		else {
+	}
-			nd->nd_type = *ptp;
+	nd->nd_type = *ptp;
-			df->df_forw_node = nd;
+	df->df_forw_node = nd;
-			if (df1->df_kind == D_TYPE) {
+	if (df1->df_kind == D_TYPE) {
-				df->df_type = df1->df_type;
+		df->df_type = df1->df_type;
-			}
-		}
 	}
 	return 0;
 }

lang/m2/comp/typequiv.c

@@ -19,8 +19,9 @@
 #include	<assert.h>
 
 #include	"type.h"
-#include	"def.h"
 #include	"LLlex.h"
+#include	"idf.h"
+#include	"def.h"
 #include	"node.h"
 #include	"warning.h"
 
@@ -175,9 +176,10 @@ TstAssCompat(tp1, tp2)
 }
 
 int
-TstParCompat(formaltype, actualtype, VARflag, nd)
+TstParCompat(parno, formaltype, VARflag, nd, edf)
-	register struct type *formaltype, *actualtype;
+	register struct type *formaltype;
-	struct node *nd;
+	struct node **nd;
+	struct def *edf;
 {
 	/*	Check type compatibility for a parameter in a procedure call.
 		Assignment compatibility may do if the parameter is
@@ -186,11 +188,19 @@ TstParCompat(formaltype, actualtype, VARflag, nd)
 		may do too.
 		Or: a WORD may do.
 	*/
+	register struct type *actualtype = (*nd)->nd_type;
+	char ebuf[256];
+	char ebuf1[256];
 
-	return
+	if (edf) {
+		sprintf(ebuf, "\"%s\", parameter %d: %%s", edf->df_idf->id_text, parno);
+	}
+	else sprint(ebuf, "parameter %d: %%s", parno);
+
+	if (
 		TstTypeEquiv(formaltype, actualtype)
 	    ||
-		( !VARflag && TstAssCompat(formaltype, actualtype))
+		( !VARflag && ChkAssCompat(nd, formaltype, (char *) 0))
 	    ||
 		(  formaltype == address_type 
 		&& actualtype->tp_fund == T_POINTER
@@ -225,13 +235,62 @@ TstParCompat(formaltype, actualtype, VARflag, nd)
 		      )
 		   )
 		)
-	    ||
+	)
-		(  VARflag
+		return 1;
-		&& (  TstCompat(formaltype, actualtype)
+	if (VARflag && TstCompat(formaltype, actualtype)) {
-		   &&
+		if (formaltype->tp_size == actualtype->tp_size) {
-(node_warning(nd, W_OLDFASHIONED, "types of formal and actual must be identical"),
+			sprint(ebuf1, ebuf, "identical types required");
-		      1)
+			node_warning(*nd,
-		   )
+				     W_OLDFASHIONED,
-		)
+				     ebuf1);
-	;
+			return 1;
+		}
+		sprint(ebuf1, ebuf, "equal sized types required");
+		node_error(*nd, ebuf1);
+		return 0;
+	}
+				
+	sprint(ebuf1, ebuf, "type incompatibility");
+	node_error(*nd, ebuf1);
+	return 0;
+}
+
+CompatCheck(nd, tp, message, fc)
+	struct node **nd;
+	struct type *tp;
+	char *message;
+	int (*fc)();
+{
+	if (! (*fc)(tp, (*nd)->nd_type)) {
+		if (message) {
+			node_error(*nd, "type incompatibility in %s", message);
+		}
+		return 0;
+	}
+	MkCoercion(nd, tp);
+	return 1;
+}
+
+ChkAssCompat(nd, tp, message)
+	struct node **nd;
+	struct type *tp;
+	char *message;
+{
+	/*	Check assignment compatibility of node "nd" with type "tp".
+		Give an error message when it fails
+	*/
+
+	return CompatCheck(nd, tp, message, TstAssCompat);
+}
+
+ChkCompat(nd, tp, message)
+	struct node **nd;
+	struct type *tp;
+	char *message;
+{
+	/*	Check compatibility of node "nd" with type "tp".
+		Give an error message when it fails
+	*/
+
+	return CompatCheck(nd, tp, message, TstCompat);
 }

lang/m2/comp/walk.c

@@ -21,12 +21,13 @@
 #include	<em_code.h>
 #include	<m2_traps.h>
 #include	<assert.h>
+#include	<alloc.h>
 
+#include	"LLlex.h"
 #include	"def.h"
 #include	"type.h"
 #include	"scope.h"
 #include	"main.h"
-#include	"LLlex.h"
 #include	"node.h"
 #include	"Lpars.h"
 #include	"desig.h"
@@ -40,7 +41,7 @@ extern arith	NewPtr();
 extern arith	NewInt();
 extern int	proclevel;
 label		text_label;
-label		data_label;
+label		data_label = 1;
 static struct type *func_type;
 struct withdesig *WithDesigs;
 struct node	*Modules;
@@ -55,8 +56,11 @@ DoPriority()
 	/*	For the time being (???), handle priorities by calls to
 		the runtime system
 	*/
-	if (priority) {
+
-		C_loc(priority->nd_INT);
+	register struct node *p;
+
+	if (p = priority) {
+		C_loc(p->nd_INT);
 		C_cal("_stackprio");
 		C_asp(word_size);
 	}
@@ -77,13 +81,13 @@ DoProfil()
 
 	if (! options['L']) {
 
-		if (!filename_label) {
+		if (! filename_label) {
-			filename_label = ++data_label;
+			filename_label = 1;
-			C_df_dlb(filename_label);
+			C_df_dlb((label) 1);
 			C_rom_scon(FileName, (arith) (strlen(FileName) + 1));
 		}
 
-		C_fil_dlb(filename_label, (arith) 0);
+		C_fil_dlb((label) 1, (arith) 0);
 	}
 }
 
@@ -215,14 +219,14 @@ WalkProcedure(procedure)
 	     param;
 	     param = param->par_next) {
 		if (! IsVarParam(param)) {
-			register struct type *TpParam = TypeOfParam(param);
+			tp = TypeOfParam(param);
 
-			if (! IsConformantArray(TpParam)) {
+			if (! IsConformantArray(tp)) {
-				if (TpParam->tp_size < word_size &&
+				if (tp->tp_size < word_size &&
-				    (int) word_size % (int) TpParam->tp_size == 0) {
+				    (int) word_size % (int) tp->tp_size == 0) {
 					C_lol(param->par_def->var_off);
 					C_lal(param->par_def->var_off);
-					C_sti(TpParam->tp_size);
+					C_sti(tp->tp_size);
 				}
 			}
 			else {
@@ -239,7 +243,7 @@ WalkProcedure(procedure)
 				if (! StackAdjustment) {
 					/* First time we get here
 					*/
-					if (tp && !func_res_label) {
+					if (func_type && !func_res_label) {
 						/* Some local space, only
 						   needed if the value itself
 						   is returned
@@ -290,21 +294,20 @@ WalkProcedure(procedure)
 			C_str((arith) 1);
 		}
 		C_lae_dlb(func_res_label, (arith) 0);
-		EndPriority();
+		func_res_size = pointer_size;
-		C_ret(pointer_size);
 	}
 	else if (StackAdjustment) {
 		/* First save the function result in a safe place.
 		   Then remove copies of conformant arrays,
 		   and put function result back on the stack
 		*/
-		if (tp) {
+		if (func_type) {
 			C_lal(retsav);
 			C_sti(func_res_size);
 		}
 		C_lol(StackAdjustment);
 		C_str((arith) 1);
-		if (tp) {
+		if (func_type) {
 			C_lal(retsav);
 			C_loi(func_res_size);
 		}
@@ -410,7 +413,7 @@ WalkStat(nd, exit_label)
 		break;
 
 	case BECOMES:
-		DoAssign(nd, left, right);
+		DoAssign(left, right);
 		break;
 
 	case IF:
@@ -478,43 +481,47 @@ WalkStat(nd, exit_label)
 			int good_forvar;
 			label l1 = ++text_label;
 			label l2 = ++text_label;
+			int uns = 0;
 
 			good_forvar = DoForInit(nd, left);
-#ifdef DEBUG
-			nd->nd_left = left;
-			nd->nd_right = right;
-#endif
 			fnd = left->nd_right;
-			if (fnd->nd_class != Value) {
-				/* Upperbound not constant.
-				   The expression may only be evaluated once,
-				   so generate a temporary for it
-				*/
-				CodePExpr(fnd);
-				tmp = NewInt();
-				C_stl(tmp);
-			}
-			C_df_ilb(l1);
-			C_dup(int_size);
-			if (tmp) C_lol(tmp); else C_loc(fnd->nd_INT);
-			if (left->nd_INT > 0) {
-				C_bgt(l2);
-			}
-			else	C_blt(l2);
 			if (good_forvar) {
-				RangeCheck(nd->nd_type, int_type);
+				uns = BaseType(nd->nd_type)->tp_fund != T_INTEGER;
+				if (fnd->nd_class != Value) {
+					/* Upperbound not constant.
+					   The expression may only be evaluated
+					   once, so generate a temporary for it
+					*/
+					CodePExpr(fnd);
+					tmp = NewInt();
+					C_stl(tmp);
+				}
+				C_df_ilb(l1);
+				C_dup(int_size);
+				if (tmp) C_lol(tmp); else C_loc(fnd->nd_INT);
+				if (uns) C_cmu(int_size);
+				else C_cmi(int_size);
+				if (left->nd_INT > 0) {
+					C_zgt(l2);
+				}
+				else	C_zlt(l2);
 				CodeDStore(nd);
 			}
 			WalkNode(right, exit_label);
 			if (good_forvar) {	
 				CodePExpr(nd);
 				C_loc(left->nd_INT);
-				C_adi(int_size);
+				if (uns) C_adu(int_size);
+				else C_adi(int_size);
 				C_bra(l1);
 				C_df_ilb(l2);
 				C_asp(int_size);
 			}
 			if (tmp) FreeInt(tmp);
+#ifdef DEBUG
+			nd->nd_left = left;
+			nd->nd_right = right;
+#endif
 		}
 		break;
 
@@ -566,15 +573,14 @@ WalkStat(nd, exit_label)
 			   assignment compatible with the result type of the
 			   function procedure (See Rep. 9.11).
 			*/
-			if (!TstAssCompat(func_type, right->nd_type)) {
+			if (!ChkAssCompat(&(nd->nd_right), func_type, "RETURN")) {
-node_error(right, "type incompatibility in RETURN statement");
 				break;
 			}
+			right = nd->nd_right;
 			if (right->nd_type->tp_fund == T_STRING) {
 				CodePString(right, func_type);
 			}
 			else	CodePExpr(right);
-			RangeCheck(func_type, right->nd_type);
 		}
 		C_bra(RETURN_LABEL);
 		break;
@@ -609,29 +615,16 @@ ExpectBool(nd, true_label, false_label)
 	/*	"nd" must indicate a boolean expression. Check this and
 		generate code to evaluate the expression.
 	*/
-	struct desig ds;
+	register struct desig *ds = new_desig();
 
-	if (!ChkExpression(nd)) return;
+	if (ChkExpression(nd)) {
+		if (nd->nd_type != bool_type && nd->nd_type != error_type) {
+			node_error(nd, "boolean expression expected");
+		}
 
-	if (nd->nd_type != bool_type && nd->nd_type != error_type) {
+		CodeExpr(nd, ds,  true_label, false_label);
-		node_error(nd, "boolean expression expected");
 	}
-
+	free_desig(ds);
-	ds = InitDesig;
-	CodeExpr(nd, &ds,  true_label, false_label);
-}
-
-int
-WalkExpr(nd)
-	register struct node *nd;
-{
-	/*	Check an expression and generate code for it
-	*/
-
-	if (! ChkExpression(nd)) return 0;
-
-	CodePExpr(nd);
-	return 1;
 }
 
 int
@@ -644,7 +637,7 @@ WalkDesignator(nd, ds)
 
 	if (! ChkVariable(nd)) return 0;
 
-	*ds = InitDesig;
+	clear((char *) ds, sizeof(struct desig));
 	CodeDesig(nd, ds);
 	return 1;
 }
@@ -653,13 +646,14 @@ DoForInit(nd, left)
 	register struct node *nd, *left;
 {
 	register struct def *df;
+	struct type *tpl, *tpr;
 
 	nd->nd_left = nd->nd_right = 0;
 	nd->nd_class = Name;
 	nd->nd_symb = IDENT;
 
 	if (!( ChkVariable(nd) &
-	       WalkExpr(left->nd_left) &
+	       ChkExpression(left->nd_left) &
 	       ChkExpression(left->nd_right))) return 0;
 
 	df = nd->nd_def;
@@ -694,21 +688,22 @@ DoForInit(nd, left)
 		return 1;
 	}
 
-	if (!TstCompat(df->df_type, left->nd_left->nd_type) ||
+	tpl = left->nd_left->nd_type;
-	    !TstCompat(df->df_type, left->nd_right->nd_type)) {
+	tpr = left->nd_right->nd_type;
-		if (!TstAssCompat(df->df_type, left->nd_left->nd_type) ||
+	if (!ChkAssCompat(&(left->nd_left), df->df_type, "FOR statement") ||
-		    !TstAssCompat(df->df_type, left->nd_right->nd_type)) {
+	    !ChkAssCompat(&(left->nd_right), df->df_type,"FOR statement")) {
-			node_error(nd, "type incompatibility in FOR statement");
+		return 1;
-			return 1;
+	}
-		}
+	if (!TstCompat(df->df_type, tpl) ||
+	    !TstCompat(df->df_type, tpr)) {
 node_warning(nd, W_OLDFASHIONED, "compatibility required in FOR statement");
 	}
 
+	CodePExpr(left->nd_left);
 	return 1;
 }
 
-DoAssign(nd, left, right)
+DoAssign(left, right)
-	struct node *nd;
 	register struct node *left, *right;
 {
 	/* May we do it in this order (expression first) ???
@@ -716,32 +711,32 @@ DoAssign(nd, left, right)
 	   it sais that the left hand side is evaluated first.
 	   DAMN THE BOOK!
 	*/
-	struct desig dsr;
+	register struct desig *dsr;
 	register struct type *rtp, *ltp;
+	struct node *rht = right;
 
 	if (! (ChkExpression(right) & ChkVariable(left))) return;
 	rtp = right->nd_type;
 	ltp = left->nd_type;
 
 	if (right->nd_symb == STRING) TryToString(right, ltp);
-	dsr = InitDesig;
 
-	if (! TstAssCompat(ltp, rtp)) {
+	if (! ChkAssCompat(&rht, ltp, "assignment")) {
-		node_error(nd, "type incompatibility in assignment");
 		return;
 	}
+	dsr = new_desig();
 
 #define StackNeededFor(ds)	((ds)->dsg_kind == DSG_PLOADED \
 				  || (ds)->dsg_kind == DSG_INDEXED)
-	CodeExpr(right, &dsr, NO_LABEL, NO_LABEL);
+	CodeExpr(rht, dsr, NO_LABEL, NO_LABEL);
 	if (complex(rtp)) {
-		if (StackNeededFor(&dsr)) CodeAddress(&dsr);
+		if (StackNeededFor(dsr)) CodeAddress(dsr);
 	}
 	else {
-		CodeValue(&dsr, rtp);
+		CodeValue(dsr, rtp);
-		CodeCheckExpr(rtp, ltp);
 	}
-	CodeMove(&dsr, left, rtp);
+	CodeMove(dsr, left, rtp);
+	free_desig(dsr);
 }
 
 RegisterMessages(df)

lang/m2/comp/walk.h

@@ -14,7 +14,7 @@
 
 extern int (*WalkTable[])();
 
-#define	WalkNode(xnd, xlab)	((xnd) && (*WalkTable[(xnd)->nd_class])((xnd), (xlab)))
+#define	WalkNode(xnd, xlab)	if (! xnd) ; else (*WalkTable[(xnd)->nd_class])((xnd), (xlab))
 
 extern label	text_label;
 extern label	data_label;