newer version

lang/m2/comp/LLlex.c

@@ -182,6 +182,10 @@ again:
 			if (nch == '=')	{
 				return tk->tk_symb = LESSEQUAL;
 			}
+			if (nch == '>') {
+				lexwarning("'<>' is old-fashioned; use '#'");
+				return tk->tk_symb = '#';
+			}
 			PushBack(nch);
 			return tk->tk_symb = ch;
 

lang/m2/comp/Makefile

@@ -54,7 +54,6 @@ tokenfile.g:	tokenname.c make.tokfile
 symbol2str.c:	tokenname.c make.tokcase
 	make.tokcase <tokenname.c >symbol2str.c
 
-misc.h:		misc.H make.allocd
 def.h:		def.H make.allocd
 type.h:		type.H make.allocd
 node.h:		node.H make.allocd
@@ -90,13 +89,13 @@ symbol2str.o: Lpars.h
 tokenname.o: Lpars.h idf.h tokenname.h
 idf.o: idf.h
 input.o: f_info.h input.h inputtype.h
-type.o: LLlex.h const.h debug.h def.h idf.h maxset.h node.h target_sizes.h type.h
+type.o: LLlex.h const.h debug.h def.h idf.h maxset.h node.h scope.h target_sizes.h type.h
 def.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.h type.h
 scope.o: LLlex.h debug.h def.h idf.h node.h scope.h type.h
 misc.o: LLlex.h f_info.h idf.h misc.h node.h
 enter.o: LLlex.h debug.h def.h idf.h main.h node.h scope.h type.h
 defmodule.o: LLlex.h debug.h def.h f_info.h idf.h input.h inputtype.h main.h scope.h
-typequiv.o: def.h type.h
+typequiv.o: LLlex.h def.h node.h type.h
 node.o: LLlex.h debug.h def.h node.h type.h
 cstoper.o: LLlex.h Lpars.h debug.h idf.h node.h standards.h target_sizes.h type.h
 chk_expr.o: LLlex.h Lpars.h const.h debug.h def.h idf.h node.h scope.h standards.h type.h
@@ -104,7 +103,7 @@ options.o: idfsize.h main.h ndir.h type.h
 walk.o: LLlex.h Lpars.h debug.h def.h desig.h f_info.h idf.h main.h node.h scope.h type.h
 casestat.o: LLlex.h Lpars.h debug.h density.h desig.h node.h type.h
 desig.o: LLlex.h debug.h def.h desig.h node.h scope.h type.h
-code.o: LLlex.h Lpars.h debug.h def.h desig.h node.h scope.h type.h
+code.o: LLlex.h Lpars.h debug.h def.h desig.h node.h scope.h standards.h type.h
 tmpvar.o: debug.h def.h scope.h type.h
 tokenfile.o: Lpars.h
 program.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.h type.h

lang/m2/comp/chk_expr.c

@@ -254,47 +254,53 @@ rem_set(set)
 
 struct node *
 getarg(argp, bases, designator)
-	struct node *argp;
+	struct node **argp;
 {
 	struct type *tp;
+	register struct node *arg = *argp;
 
-	if (!argp->nd_right) {
+	if (!arg->nd_right) {
-		node_error(argp, "too few arguments supplied");
+		node_error(arg, "too few arguments supplied");
 		return 0;
 	}
-	argp = argp->nd_right;
+	arg = arg->nd_right;
-	if ((!designator && !chk_expr(argp->nd_left)) ||
+	if ((!designator && !chk_expr(arg->nd_left)) ||
-	    (designator && !chk_designator(argp->nd_left, DESIGNATOR, D_REFERRED))) {
+	    (designator && !chk_designator(arg->nd_left, DESIGNATOR, D_REFERRED))) {
 		return 0;
 	}
-	tp = argp->nd_left->nd_type;
+	tp = arg->nd_left->nd_type;
 	if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
 	if (bases && !(tp->tp_fund & bases)) {
-		node_error(argp, "unexpected type");
+		node_error(arg, "unexpected type");
 		return 0;
 	}
-	return argp;
+
+	*argp = arg;
+	return arg->nd_left;
 }
 
 struct node *
 getname(argp, kinds)
-	struct node *argp;
+	struct node **argp;
 {
-	if (!argp->nd_right) {
+	register struct node *arg = *argp;
-		node_error(argp, "too few arguments supplied");
+
+	if (!arg->nd_right) {
+		node_error(arg, "too few arguments supplied");
 		return 0;
 	}
-	argp = argp->nd_right;
+	arg = arg->nd_right;
-	if (! chk_designator(argp->nd_left, 0, D_REFERRED)) return 0;
+	if (! chk_designator(arg->nd_left, 0, D_REFERRED)) return 0;
 
-	assert(argp->nd_left->nd_class == Def);
+	assert(arg->nd_left->nd_class == Def);
 
-	if (!(argp->nd_left->nd_def->df_kind & kinds)) {
+	if (!(arg->nd_left->nd_def->df_kind & kinds)) {
-		node_error(argp, "unexpected type");
+		node_error(arg, "unexpected type");
 		return 0;
 	}
 
-	return argp;
+	*argp = arg;
+	return arg->nd_left;
 }
 
 int
@@ -314,44 +320,20 @@ chk_call(expp)
 	left = expp->nd_left;
 	if (! chk_designator(left, 0, D_USED)) return 0;
 
-	if (left->nd_class == Def && is_type(left->nd_def)) {
+	if (IsCast(left)) {
 		/* It was a type cast. This is of course not portable.
 		*/
-		arg = expp->nd_right;
+		return chk_cast(expp, left);
-		if ((! arg) || arg->nd_right) {
-node_error(expp, "only one parameter expected in type cast");
-			return 0;
-		}
-		arg = arg->nd_left;
-		if (! chk_expr(arg)) return 0;
-		if (arg->nd_type->tp_size != left->nd_type->tp_size) {
-node_error(expp, "unequal sizes in type cast");
-		}
-		if (arg->nd_class == Value) {
-			struct type *tp = left->nd_type;
-
-			FreeNode(expp->nd_left);
-			expp->nd_right->nd_left = 0;
-			FreeNode(expp->nd_right);
-			expp->nd_left = expp->nd_right = 0;
-			*expp = *arg;
-			expp->nd_type = tp;
-		}
-		else expp->nd_type = left->nd_type;
-
-		return 1;
 	}
 
-	if ((left->nd_class == Def && left->nd_def->df_kind == D_PROCEDURE) ||
+	if (IsProcCall(left)) {
-	    left->nd_type->tp_fund == T_PROCEDURE) {
 		/* A procedure call. it may also be a call to a
 		   standard procedure
 		*/
-		arg = expp;
 		if (left->nd_type == std_type) {
 			/* A standard procedure
 			*/
-			return chk_std(expp, left, arg);
+			return chk_std(expp, left);
 		}
 		/* Here, we have found a real procedure call. The left hand
 		   side may also represent a procedure variable.
@@ -363,12 +345,12 @@ node_error(expp, "unequal sizes in type cast");
 }
 
 chk_proccall(expp)
-	struct node *expp;
+	register struct node *expp;
 {
 	/*	Check a procedure call
 	*/
 	register struct node *left;
-	register struct node *arg;
+	struct node *arg;
 	register struct paramlist *param;
 
 	left = 0;
@@ -383,20 +365,21 @@ chk_proccall(expp)
 
 	left = expp->nd_left;
 	arg = expp;
-	arg->nd_type = left->nd_type->next;
+	expp->nd_type = left->nd_type->next;
 	param = left->nd_type->prc_params;
 
 	while (param) {
-		if (!(arg = getarg(arg, 0, param->par_var))) return 0;
+		if (!(left = getarg(&arg, 0, IsVarParam(param)))) return 0;
 
-		if (! TstParCompat(param->par_type,
+		if (! TstParCompat(TypeOfParam(param),
-				   arg->nd_left->nd_type,
+				   left->nd_type,
-				   param->par_var)) {
+				   IsVarParam(param),
-node_error(arg->nd_left, "type incompatibility in parameter");
+				   left)) {
+node_error(left, "type incompatibility in parameter");
 			return 0;
 		}
-		if (param->par_var && arg->nd_left->nd_class == Def) {
+		if (IsVarParam(param) && left->nd_class == Def) {
-			arg->nd_left->nd_def->df_flags |= D_NOREG;
+			left->nd_def->df_flags |= D_NOREG;
 		}
 
 		param = param->next;
@@ -475,7 +458,6 @@ chk_designator(expp, flag, dflags)
 
 	if (expp->nd_class == Link) {
 		assert(expp->nd_symb == '.');
-		assert(expp->nd_right->nd_class == Name);
 
 		if (! chk_designator(expp->nd_left,
 				     flag|HASSELECTORS,
@@ -485,19 +467,17 @@ chk_designator(expp, flag, dflags)
 
 		assert(tp->tp_fund == T_RECORD);
 
-		df = lookup(expp->nd_right->nd_IDF, tp->rec_scope);
+		df = lookup(expp->nd_IDF, tp->rec_scope);
 
 		if (!df) {
-			id_not_declared(expp->nd_right);
+			id_not_declared(expp);
 			return 0;
 		}
 		else {
-			expp->nd_right->nd_class = Def;
+			expp->nd_def = df;
-			expp->nd_right->nd_def = df;
 			expp->nd_type = df->df_type;
 			if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
-node_error(expp->nd_right,
+node_error(expp, "identifier \"%s\" not exported from qualifying module",
-"identifier \"%s\" not exported from qualifying module",
 df->df_idf->id_text);
 				return 0;
 			}
@@ -508,11 +488,10 @@ df->df_idf->id_text);
 			expp->nd_class = Def;
 			expp->nd_def = df;
 			FreeNode(expp->nd_left);
-			FreeNode(expp->nd_right);
+			expp->nd_left = 0;
-			expp->nd_left = expp->nd_right = 0;
 		}
 		else {
-			return FlagCheck(expp->nd_right, df, flag);
+			return FlagCheck(expp, df, flag);
 		}
 	}
 
@@ -869,10 +848,11 @@ chk_uoper(expp)
 }
 
 struct node *
-getvariable(arg)
+getvariable(argp)
-	register struct node *arg;
+	struct node **argp;
 {
-	struct def *df;
+	register struct node *arg = *argp;
+	register struct def *df;
 	register struct node *left;
 
 	arg = arg->nd_right;
@@ -885,62 +865,65 @@ getvariable(arg)
 
 	if (! chk_designator(left, DESIGNATOR, D_REFERRED)) return 0;
 	if (left->nd_class == Oper || left->nd_class == Uoper) {
-		return arg;
+		*argp = arg;
+		return left;
 	}
 
 	df = 0;
-	if (left->nd_class == Link) df = left->nd_right->nd_def;
+	if (left->nd_class == Link || left->nd_class == Def) {
-	else if (left->nd_class == Def) df = left->nd_def;
+		df = left->nd_def;
+	}
 
 	if (!df || !(df->df_kind & (D_VARIABLE|D_FIELD))) {
 		node_error(arg, "variable expected");
 		return 0;
 	}
 
-	return arg;
+	*argp = arg;
+	return left;
 }
 
 int
-chk_std(expp, left, arg)
+chk_std(expp, left)
-	register struct node *expp, *left, *arg;
+	register struct node *expp, *left;
 {
 	/*	Check a call of a standard procedure or function
 	*/
+	struct node *arg = expp;
+	int std;
 
 	assert(left->nd_class == Def);
-DO_DEBUG(3, debug("standard name \"%s\", %d", 
+	std = left->nd_def->df_value.df_stdname;
-left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
 
-	switch(left->nd_def->df_value.df_stdname) {
+DO_DEBUG(3,debug("standard name \"%s\", %d",left->nd_def->df_idf->id_text,std));
+
+	switch(std) {
 	case S_ABS:
-		if (!(arg = getarg(arg, T_NUMERIC, 0))) return 0;
+		if (!(left = getarg(&arg, T_NUMERIC, 0))) return 0;
-		left = arg->nd_left;
 		expp->nd_type = left->nd_type;
 		if (left->nd_class == Value) cstcall(expp, S_ABS);
 		break;
 
 	case S_CAP:
 		expp->nd_type = char_type;
-		if (!(arg = getarg(arg, T_CHAR, 0))) return 0;
+		if (!(left = getarg(&arg, T_CHAR, 0))) return 0;
-		left = arg->nd_left;
 		if (left->nd_class == Value) cstcall(expp, S_CAP);
 		break;
 
 	case S_CHR:
 		expp->nd_type = char_type;
-		if (!(arg = getarg(arg, T_INTORCARD, 0))) return 0;
+		if (!(left = getarg(&arg, T_INTORCARD, 0))) return 0;
-		left = arg->nd_left;
 		if (left->nd_class == Value) cstcall(expp, S_CHR);
 		break;
 
 	case S_FLOAT:
 		expp->nd_type = real_type;
-		if (!(arg = getarg(arg, T_INTORCARD, 0))) return 0;
+		if (!(left = getarg(&arg, T_INTORCARD, 0))) return 0;
 		break;
 
 	case S_HIGH:
-		if (!(arg = getarg(arg, T_ARRAY, 0))) return 0;
+		if (!(left = getarg(&arg, T_ARRAY, 0))) return 0;
-		expp->nd_type = arg->nd_left->nd_type->next;
+		expp->nd_type = left->nd_type->next;
 		if (!expp->nd_type) {
 			/* A dynamic array has no explicit index type
 			*/
@@ -951,68 +934,75 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
 
 	case S_MAX:
 	case S_MIN:
-		if (!(arg = getarg(arg, T_DISCRETE, 0))) return 0;
+		if (!(left = getarg(&arg, T_DISCRETE, 0))) return 0;
-		expp->nd_type = arg->nd_left->nd_type;
+		expp->nd_type = left->nd_type;
-		cstcall(expp,left->nd_def->df_value.df_stdname);
+		cstcall(expp,std);
 		break;
 
 	case S_ODD:
-		if (!(arg = getarg(arg, T_INTORCARD, 0))) return 0;
+		if (!(left = getarg(&arg, T_INTORCARD, 0))) return 0;
 		expp->nd_type = bool_type;
-		if (arg->nd_left->nd_class == Value) cstcall(expp, S_ODD);
+		if (left->nd_class == Value) cstcall(expp, S_ODD);
 		break;
 
 	case S_ORD:
-		if (!(arg = getarg(arg, T_DISCRETE, 0))) return 0;
+		if (!(left = getarg(&arg, T_DISCRETE, 0))) return 0;
+		if (left->nd_type->tp_size > word_size) {
+			node_error(left, "illegal type in argument of ORD");
+			return 0;
+		}
 		expp->nd_type = card_type;
-		if (arg->nd_left->nd_class == Value) cstcall(expp, S_ORD);
+		if (left->nd_class == Value) cstcall(expp, S_ORD);
 		break;
 
 	case S_TSIZE:	/* ??? */
 	case S_SIZE:
 		expp->nd_type = intorcard_type;
-		arg = getname(arg, D_FIELD|D_VARIABLE|D_ISTYPE);
+		if (! getname(&arg, D_FIELD|D_VARIABLE|D_ISTYPE)) return 0;
-		if (!arg) return 0;
 		cstcall(expp, S_SIZE);
 		break;
 
 	case S_TRUNC:
 		expp->nd_type = card_type;
-		if (!(arg = getarg(arg, T_REAL, 0))) return 0;
+		if (!(left = getarg(&arg, T_REAL, 0))) return 0;
 		break;
 
 	case S_VAL:
 		{
 		struct type *tp;
 
-		if (!(arg = getname(arg, D_ISTYPE))) return 0;
+		if (!(left = getname(&arg, D_ISTYPE))) return 0;
-		tp = arg->nd_left->nd_def->df_type;
+		tp = left->nd_def->df_type;
 		if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
 		if (!(tp->tp_fund & T_DISCRETE)) {
 			node_error(arg, "unexpected type");
 			return 0;
 		}
-		expp->nd_type = arg->nd_left->nd_def->df_type;
+		expp->nd_type = left->nd_def->df_type;
 		expp->nd_right = arg->nd_right;
 		arg->nd_right = 0;
 		FreeNode(arg);
-		arg = getarg(expp, T_INTORCARD, 0);
+		arg = expp;
-		if (!arg) return 0;
+		if (!(left = getarg(&arg, T_INTORCARD, 0))) return 0;
-		if (arg->nd_left->nd_class == Value) cstcall(expp, S_VAL);
+		if (left->nd_class == Value) cstcall(expp, S_VAL);
 		break;
 		}
 
 	case S_ADR:
 		expp->nd_type = address_type;
-		if (!(arg = getarg(arg, 0, 1))) return 0;
+		if (!(left = getarg(&arg, 0, 1))) return 0;
 		break;
 
 	case S_DEC:
 	case S_INC:
 		expp->nd_type = 0;
-		if (!(arg = getvariable(arg))) return 0;
+		if (! (left = getvariable(&arg))) return 0;
+		if (! (left->nd_type->tp_fund & T_DISCRETE)) {
+node_error(left, "illegal type in argument of INC or DEC");
+			return 0;
+		}
 		if (arg->nd_right) {
-			if (!(arg = getarg(arg, T_INTORCARD, 0))) return 0;
+			if (! getarg(&arg, T_INTORCARD, 0)) return 0;
 		}
 		break;
 
@@ -1026,14 +1016,14 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
 		struct type *tp;
 
 		expp->nd_type = 0;
-		if (!(arg = getvariable(arg))) return 0;
+		if (!(left = getvariable(&arg))) return 0;
-		tp = arg->nd_left->nd_type;
+		tp = left->nd_type;
 		if (tp->tp_fund != T_SET) {
 node_error(arg, "EXCL and INCL expect a SET parameter");
 			return 0;
 		}
-		if (!(arg = getarg(arg, T_DISCRETE, 0))) return 0;
+		if (!(left = getarg(&arg, T_DISCRETE, 0))) return 0;
-		if (!TstAssCompat(tp->next, arg->nd_left->nd_type)) {
+		if (!TstAssCompat(tp->next, left->nd_type)) {
 			/* What type of compatibility do we want here?
 			   apparently assignment compatibility! ??? ???
 			*/
@@ -1044,7 +1034,7 @@ node_error(arg, "EXCL and INCL expect a SET parameter");
 		}
 
 	default:
-		assert(0);
+		crash("(chk_std)");
 	}
 
 	if (arg->nd_right) {
@@ -1054,3 +1044,44 @@ node_error(arg, "EXCL and INCL expect a SET parameter");
 
 	return 1;
 }
+
+chk_cast(expp, left)
+	register struct node *expp, *left;
+{
+	/*	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
+		has a size larger than the word size.
+		If both sizes are equal to or smaller than the word size, there
+		is no problem as such values take a word on the EM stack
+		anyway.
+	*/
+	register struct node *arg = expp->nd_right;
+
+	if ((! arg) || arg->nd_right) {
+node_error(expp, "only one parameter expected in type cast");
+		return 0;
+	}
+
+	arg = arg->nd_left;
+	if (! chk_expr(arg)) return 0;
+
+	if (arg->nd_type->tp_size != left->nd_type->tp_size &&
+	    (arg->nd_type->tp_size > word_size ||
+	     left->nd_type->tp_size > word_size)) {
+		node_error(expp, "unequal sizes in type cast");
+	}
+
+	if (arg->nd_class == Value) {
+		struct type *tp = left->nd_type;
+
+		FreeNode(left);
+		expp->nd_right->nd_left = 0;
+		FreeNode(expp->nd_right);
+		expp->nd_left = expp->nd_right = 0;
+		*expp = *arg;
+		expp->nd_type = tp;
+	}
+	else expp->nd_type = left->nd_type;
+
+	return 1;
+}

lang/m2/comp/code.c

@@ -20,6 +20,7 @@ static char *RcsId = "$Header$";
 #include	"LLlex.h"
 #include	"node.h"
 #include	"Lpars.h"
+#include	"standards.h"
 
 extern label	data_label();
 extern label	text_label();
@@ -81,6 +82,11 @@ CodeExpr(nd, ds, true_label, false_label)
 
 	switch(nd->nd_class) {
 	case Def:
+		if (nd->nd_def->df_kind == D_PROCEDURE) {
+			C_lpi(nd->nd_def->prc_vis->sc_scope->sc_name);
+			ds->dsg_kind = DSG_LOADED;
+			break;
+		}
 		CodeDesig(nd, ds);
 		break;
 
@@ -102,8 +108,7 @@ CodeExpr(nd, ds, true_label, false_label)
 			CodeDesig(nd, ds);
 			break;
 		}
-		CodeExpr(nd->nd_right, ds, NO_LABEL, NO_LABEL);
+		CodePExpr(nd->nd_right);
-		CodeValue(ds, nd->nd_right->nd_type->tp_size);
 		CodeUoper(nd);
 		ds->dsg_kind = DSG_LOADED;
 		break;
@@ -181,6 +186,7 @@ CodeCoercion(t1, t2)
 	if ((fund2 = t2->tp_fund) == T_WORD) fund2 = T_INTEGER;
 	switch(fund1) {
 	case T_INTEGER:
+	case T_INTORCARD:
 		switch(fund2) {
 		case T_INTEGER:
 			if (t2->tp_size != t1->tp_size) {
@@ -274,7 +280,6 @@ CodeCall(nd)
 	register struct paramlist *param;
 	struct type *tp;
 	arith pushed = 0;
-	struct desig Des;
 
 	if (left->nd_type == std_type) {
 		CodeStd(nd);
@@ -282,32 +287,27 @@ CodeCall(nd)
 	}	
 	tp = left->nd_type;
 
-	if (left->nd_class == Def && is_type(left->nd_def)) {
+	if (IsCast(left)) {
 		/* it was just a cast. Simply ignore it
 		*/
-		Des = InitDesig;
+		CodePExpr(nd->nd_right->nd_left);
-		CodeExpr(nd->nd_right->nd_left, &Des, NO_LABEL, NO_LABEL);
-		CodeValue(&Des, tp->tp_size);
 		*nd = *(nd->nd_right->nd_left);
 		nd->nd_type = left->nd_def->df_type;
 		return;
 	}
 
-	assert(tp->tp_fund == T_PROCEDURE);
+	assert(IsProcCall(left));
 
 	for (param = left->nd_type->prc_params; param; param = param->next) {
-		Des = InitDesig;
 		arg = arg->nd_right;
 		assert(arg != 0);
-		if (param->par_var) {
+		if (IsVarParam(param)) {
-			CodeDesig(arg->nd_left, &Des);
+			CodeDAddress(arg->nd_left);
-			CodeAddress(&Des);
 			pushed += pointer_size;
 		}
 		else {
-			CodeExpr(arg->nd_left, &Des, NO_LABEL, NO_LABEL);
+			CodePExpr(arg->nd_left);
-			CodeValue(&Des, arg->nd_left->nd_type->tp_size);
+			CheckAssign(arg->nd_left->nd_type, TypeOfParam(param));
-			CheckAssign(arg->nd_left->nd_type, param->par_type);
 			pushed += align(arg->nd_left->nd_type->tp_size, word_align);
 		}
 		/* ??? Conformant arrays */
@@ -324,9 +324,7 @@ CodeCall(nd)
 		C_cal(left->nd_def->for_name);
 	}
 	else {
-		Des = InitDesig;
+		CodePExpr(left);
-		CodeDesig(left, &Des);
-		CodeAddress(&Des);
 		C_cai();
 	}
 	C_asp(pushed);
@@ -338,7 +336,141 @@ CodeCall(nd)
 CodeStd(nd)
 	struct node *nd;
 {
+	register struct node *arg = nd->nd_right;
+	register struct node *left = 0;
+	register struct type *tp = 0;
+	int std;
+
+	if (arg) {
+		left = arg->nd_left;
+		tp = left->nd_type;
+		if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
+		arg = arg->nd_right;
+	}
+	Desig = InitDesig;
+
+	switch(std = nd->nd_left->nd_def->df_value.df_stdname) {
+	case S_ABS:
+		CodePExpr(left);
+		if (tp->tp_fund == T_INTEGER) {
+			if (tp->tp_size == int_size) {
+				C_cal("_absi");
+			}
+			else	C_cal("_absl");
+		}
+		else if (tp->tp_fund == T_REAL) {
+			if (tp->tp_size == float_size) {
+				C_cal("_absf");
+			}
+			else	C_cal("_absd");
+		}
+		C_lfr(tp->tp_size);
+		break;
+
+	case S_CAP:
+		CodePExpr(left);
+		C_loc((arith) 0137);
+		C_and(word_size);
+		break;
+
+	case S_CHR:
+		CodePExpr(left);
+		CheckAssign(char_type, tp);
+		break;
+
+	case S_FLOAT:
+		CodePExpr(left);
+		CodeCoercion(tp, real_type);
+		break;
+
+	case S_HIGH:
+		assert(IsConformantArray(tp));
 		/* ??? */
+		break;
+
+	case S_ODD:
+		if (tp->tp_size == word_size) {
+			C_loc((arith) 1);
+			C_and(word_size);
+		}
+		else {
+			assert(tp->tp_size == dword_size);
+			C_ldc((arith) 1);
+			C_and(dword_size);
+			C_ior(word_size);
+		}
+		break;
+
+	case S_ORD:
+		CodePExpr(left);
+		break;
+
+	case S_TRUNC:
+		CodePExpr(left);
+		CodeCoercion(tp, card_type);
+		break;
+
+	case S_VAL:
+		CodePExpr(left);
+		CheckAssign(nd->nd_type, tp);
+		break;
+
+	case S_ADR:
+		CodeDAddress(left);
+		break;
+
+	case S_DEC:
+	case S_INC:
+		CodePExpr(left);
+		if (arg) CodePExpr(arg->nd_left);
+		else	C_loc((arith) 1);
+		if (tp->tp_size <= word_size) {
+			if (std == S_DEC) {
+				if (tp->tp_fund == T_INTEGER) C_sbi(word_size);
+				else	C_sbu(word_size);
+			}
+			else {
+				if (tp->tp_fund == T_INTEGER) C_adi(word_size);
+				else	C_adu(word_size);
+			}
+			CheckAssign(tp, int_type);
+		}
+		else {
+			CodeCoercion(int_type, tp);
+			if (std == S_DEC) {
+				if (tp->tp_fund==T_INTEGER) C_sbi(tp->tp_size);
+				else	C_sbu(tp->tp_size);
+			}
+			else {
+				if (tp->tp_fund==T_INTEGER) C_adi(tp->tp_size);
+				else	C_adu(tp->tp_size);
+			}
+		}
+		CodeDStore(left);
+		break;
+
+	case S_HALT:
+		C_cal("_halt");
+		break;
+
+	case S_INCL:
+	case S_EXCL:
+		CodePExpr(left);
+		CodePExpr(arg->nd_left);
+		C_set(tp->tp_size);
+		if (std == S_INCL) {
+			C_ior(tp->tp_size);
+		}
+		else {
+			C_com(tp->tp_size);
+			C_and(tp->tp_size);
+		}
+		CodeDStore(left);
+		break;
+
+	default:
+		crash("(CodeStd)");
+	}
 }
 
 CodeAssign(nd, dss, dst)
@@ -353,6 +485,7 @@ CodeAssign(nd, dss, dst)
 		CodeStore(dst, nd->nd_left->nd_type->tp_size);
 	}
 	else {
+		CodeAddress(dss);
 		CodeAddress(dst);
 		C_blm(nd->nd_left->nd_type->tp_size);
 	}
@@ -395,12 +528,8 @@ CheckAssign(tpl, tpr)
 Operands(leftop, rightop)
 	register struct node *leftop, *rightop;
 {
-	struct desig Des;
 
-	Des = InitDesig;
+	CodePExpr(leftop);
-	CodeExpr(leftop, &Des, NO_LABEL, NO_LABEL);
-	CodeValue(&Des, leftop->nd_type->tp_size);
-	Des = InitDesig;
 
 	if (rightop->nd_type->tp_fund == T_POINTER && 
 	    leftop->nd_type->tp_size != pointer_size) {
@@ -408,8 +537,7 @@ Operands(leftop, rightop)
 		leftop->nd_type = rightop->nd_type;
 	}
 
-	CodeExpr(rightop, &Des, NO_LABEL, NO_LABEL);
+	CodePExpr(rightop);
-	CodeValue(&Des, rightop->nd_type->tp_size);
 }
 
 CodeOper(expr, true_label, false_label)
@@ -787,11 +915,48 @@ CodeEl(nd, tp)
 		C_asp(2 * word_size + pointer_size);
 	}
 	else {
-		struct desig Des;
+		CodePExpr(nd);
-
-		Des = InitDesig;
-		CodeExpr(nd, &Des, NO_LABEL, NO_LABEL);
-		CodeValue(&Des, word_size);
 		C_set(tp->tp_size);
 	}
 }
+
+CodePExpr(nd)
+	struct node *nd;
+{
+	/*	Generate code to push the value of the expression "nd"
+		on the stack.
+	*/
+	struct desig designator;
+
+	designator = InitDesig;
+	CodeExpr(nd, &designator, NO_LABEL, NO_LABEL);
+	CodeValue(&designator, nd->nd_type->tp_size);
+}
+
+CodeDAddress(nd)
+	struct node *nd;
+{
+	/*	Generate code to push the address of the designator "nd"
+		on the stack.
+	*/
+
+	struct desig designator;
+
+	designator = InitDesig;
+	CodeDesig(nd, &designator);
+	CodeAddress(&designator);
+}
+
+CodeDStore(nd)
+	register struct node *nd;
+{
+	/*	Generate code to store the expression on the stack into the
+		designator "nd".
+	*/
+
+	struct desig designator;
+
+	designator = InitDesig;
+	CodeDesig(nd, &designator);
+	CodeStore(&designator, nd->nd_type->tp_size);
+}

lang/m2/comp/declar.g

@@ -23,25 +23,23 @@ static char *RcsId = "$Header$";
 
 int		proclevel = 0;	/* nesting level of procedures */
 extern char	*sprint();
-extern struct def *currentdef;
 }
 
 ProcedureDeclaration
 {
 	struct def *df;
-	struct def *savecurr = currentdef;
 } :
+			{ proclevel++; }
 	ProcedureHeading(&df, D_PROCEDURE)
 			{
-			  currentdef = df;
+			  CurrentScope->sc_definedby = df;
+			  df->prc_vis = CurrVis;
 			}
 	';' block(&(df->prc_body)) IDENT
 			{
 			  match_id(dot.TOK_IDF, df->df_idf);
-			  df->prc_vis = CurrVis;
 			  close_scope(SC_CHKFORW|SC_REVERSE);
 			  proclevel--;
-			  currentdef = savecurr;
 			}
 ;
 
@@ -54,17 +52,16 @@ ProcedureHeading(struct def **pdf; int type;)
 } :
 	PROCEDURE IDENT
 		{
-		  if (type == D_PROCEDURE) proclevel++;
 		  df = DeclProc(type);
 		  tp = construct_type(T_PROCEDURE, tp);
-		  if (proclevel > 1) {
+		  if (proclevel) {
 			/* Room for static link
 			*/
 			tp->prc_nbpar = pointer_size;
 		  }
 		  else	tp->prc_nbpar = 0;
 		}
-	FormalParameters(type == D_PROCEDURE, &params, &(tp->next), &(tp->prc_nbpar))?
+	FormalParameters(&params, &(tp->next), &(tp->prc_nbpar))?
 		{
 		  tp->prc_params = params;
 		  if (df->df_type) {
@@ -79,6 +76,8 @@ error("inconsistent procedure declaration for \"%s\"", df->df_idf->id_text);
 		  df->df_type = tp;
 		  *pdf = df;
 
+		  if (type == D_PROCHEAD) close_scope(0);
+
 		  DO_DEBUG(1, type == D_PROCEDURE && 
 				(print("proc %s:", df->df_idf->id_text),
 				 DumpType(tp), print("\n")));
@@ -110,20 +109,17 @@ declaration:
 	ModuleDeclaration ';'
 ;
 
-FormalParameters(int doparams;
+FormalParameters(struct paramlist **pr;
-		 struct paramlist **pr;
 		 struct type **tp;
 		 arith *parmaddr;)
 {
 	struct def *df;
-	register struct paramlist *pr1;
 } :
 	'('
 	[
-		FPSection(doparams, pr, parmaddr)	
+		FPSection(pr, parmaddr)
 		[
-			{ for (pr1 = *pr; pr1->next; pr1 = pr1->next) ; }
+			';' FPSection(pr, parmaddr)
-			';' FPSection(doparams, &(pr1->next), parmaddr)
 		]*
 	]?
 	')'
@@ -134,16 +130,9 @@ FormalParameters(int doparams;
 	]?
 ;
 
-/*	In the next nonterminal, "doparams" is a flag indicating whether
+FPSection(struct paramlist **ppr; arith *parmaddr;)
-	the identifiers representing the parameters must be added to the
-	symbol table. We must not do so when reading a Definition Module,
-	because in this case we only read the header. The Implementation
-	might contain different identifiers representing the same paramters.
-*/
-FPSection(int doparams; struct paramlist **ppr; arith *addr;)
 {
 	struct node *FPList;
-	struct paramlist *ParamList();
 	struct type *tp;
 	int VARp = 0;
 } :
@@ -152,11 +141,7 @@ FPSection(int doparams; struct paramlist **ppr; arith *addr;)
 	]?
 	IdentList(&FPList) ':' FormalType(&tp)
 		{
-		  if (doparams) {
+		  ParamList(ppr, FPList, tp, VARp, parmaddr);
-			EnterIdList(FPList, D_VARIABLE, VARp,
-				    tp, CurrentScope, addr);
-		  }
-		  *ppr = ParamList(FPList, tp, VARp);
 		  FreeNode(FPList);
 		}
 ;
@@ -530,27 +515,29 @@ FormalTypeList(struct paramlist **ppr; struct type **ptp;)
 } :
 	'('		{ *ppr = 0; }
 	[
-		[ VAR	{ VARp = 1; }
+		[ VAR	{ VARp = D_VARPAR; }
-		|	{ VARp = 0; }
+		|	{ VARp = D_VALPAR; }
 		]
 		FormalType(&tp)
 			{ *ppr = p = new_paramlist();
-			  p->par_type = tp;
+			  p->next = 0;
-			  p->par_var = VARp;
+			  p->par_def = df = new_def();
+			  df->df_type = tp;
+			  df->df_flags = VARp;
 			}
 		[
 			','
-			[ VAR	{VARp = 1; }
+			[ VAR	{VARp = D_VARPAR; }
-			|	{VARp = 0; }
+			|	{VARp = D_VALPAR; }
 			] 
 			FormalType(&tp)
-				{ p->next = new_paramlist();
+				{ p = new_paramlist();
-				  p = p->next;
+				  p->next = *ppr; *ppr = p;
-				  p->par_type = tp;
+			  	  p->par_def = df = new_def();
-				  p->par_var = VARp;
+			  	  df->df_type = tp;
+			  	  df->df_flags = VARp;
 				}
 		]*
-				{ p->next = 0; }
 	]?
 	')'
 	[ ':' qualident(D_TYPE, &df, "type", (struct node **) 0)

lang/m2/comp/def.c

@@ -20,7 +20,10 @@ static char *RcsId = "$Header$";
 #include	"node.h"
 #include	"Lpars.h"
 
-struct def *h_def;		/* Pointer to free list of def structures */
+struct def *h_def;		/* pointer to free list of def structures */
+#ifdef DEBUG
+int	cnt_def;		/* count number of allocated ones */
+#endif
 
 struct def *ill_df;
 
@@ -455,6 +458,7 @@ DeclProc(type)
 		df->for_name = Malloc((unsigned) (strlen(buf)+1));
 		strcpy(df->for_name, buf);
 		C_exp(df->for_name);
+		open_scope(OPENSCOPE);
 	}
 	else {
 		df = lookup(dot.TOK_IDF, CurrentScope);

lang/m2/comp/desig.c

@@ -326,10 +326,9 @@ CodeDesig(nd, ds)
 
 	case Link:
 		assert(nd->nd_symb == '.');
-		assert(nd->nd_right->nd_class == Def);
 
 		CodeDesig(nd->nd_left, ds);
-		CodeFieldDesig(nd->nd_right->nd_def, ds);
+		CodeFieldDesig(nd->nd_def, ds);
 		break;
 
 	case Oper:

lang/m2/comp/enter.c

@@ -73,15 +73,6 @@ EnterIdList(idlist, kind, flags, type, scope, addr)
 			}
 
 			if (*addr >= 0) {
-				if (scope->sc_level && kind != D_FIELD) {
-					/* alignment of parameters is on
-					   word boundaries. We cannot do any
-					   better, because we don't know the
-					   alignment of the stack pointer when
-					   starting to push parameters
-					*/
-					xalign = word_align;
-				}
 				off = align(*addr, xalign);
 				*addr = off + type->tp_size;
 			}

lang/m2/comp/expression.g

@@ -72,7 +72,7 @@ node_error(nd,"identifier \"%s\" is not a %s", df->df_idf->id_text, str);
 
 selector(struct node **pnd;):
 	'.'	{ *pnd = MkNode(Link,*pnd,NULLNODE,&dot); }
-	IDENT	{ (*pnd)->nd_right = MkNode(Name,NULLNODE,NULLNODE,&dot); }
+	IDENT	{ (*pnd)->nd_IDF = dot.TOK_IDF; }
 ;
 
 ExpList(struct node **pnd;)

lang/m2/comp/main.c

@@ -101,6 +101,9 @@ Compile(src, dst)
 	}
 	WalkModule(Defined);
 	C_close();
+#ifdef DEBUG
+	if (options['m']) MemUse();
+#endif
 	if (err_occurred) return 0;
 	return 1;
 }
@@ -217,3 +220,19 @@ AtEoIT()
 	*/
 	return 1;
 }
+
+#ifdef DEBUG
+MemUse()
+{
+	extern int cnt_def, cnt_node, cnt_paramlist, cnt_type,
+		   cnt_switch_hdr, cnt_case_entry, 
+		   cnt_scope, cnt_scopelist, cnt_forwards, cnt_tmpvar;
+
+	print("\
+%6d def\n%6d node\n%6d paramlist\n%6d type\n%6d switch_hdr\n\
+%6d case_entry\n%6d scope\n%6d scopelist\n%6d forwards\n%6d tmpvar\n",
+cnt_def, cnt_node, cnt_paramlist, cnt_type,
+cnt_switch_hdr, cnt_case_entry, 
+cnt_scope, cnt_scopelist, cnt_forwards, cnt_tmpvar);
+}
+#endif

lang/m2/comp/make.allocd

@@ -3,15 +3,23 @@ s:^.*[ 	]ALLOCDEF[ 	].*"\(.*\)".*$:\
 /* allocation definitions of struct \1 */\
 extern char *st_alloc();\
 extern struct \1 *h_\1;\
-#define	new_\1() ((struct \1 *) \\\
+#ifdef DEBUG\
-		st_alloc((char **)\&h_\1, sizeof(struct \1)))\
+extern int cnt_\1;\
+#define	new_\1() ((struct \1 *) std_alloc((char **)\&h_\1, sizeof(struct \1), \&cnt_\1))\
+#else\
+#define	new_\1() ((struct \1 *) st_alloc((char **)\&h_\1, sizeof(struct \1)))\
+#endif\
 #define	free_\1(p) st_free(p, h_\1, sizeof(struct \1))\
 :' -e '
 s:^.*[ 	]STATICALLOCDEF[ 	].*"\(.*\)".*$:\
 /* allocation definitions of struct \1 */\
 extern char *st_alloc();\
-static struct \1 *h_\1;\
+struct \1 *h_\1;\
-#define	new_\1() ((struct \1 *) \\\
+#ifdef DEBUG\
-		st_alloc((char **)\&h_\1, sizeof(struct \1)))\
+int cnt_\1;\
+#define	new_\1() ((struct \1 *) std_alloc((char **)\&h_\1, sizeof(struct \1), \&cnt_\1))\
+#else\
+#define	new_\1() ((struct \1 *) st_alloc((char **)\&h_\1, sizeof(struct \1)))\
+#endif\
 #define	free_\1(p) st_free(p, h_\1, sizeof(struct \1))\
 :'

lang/m2/comp/misc.h

@@ -0,0 +1,8 @@
+/* M I S C E L L A N E O U S */
+
+/* $Header$ */
+
+#define is_anon_idf(x)	((x)->id_text[0] == '#')
+
+extern struct idf
+	*gen_anon_idf();

lang/m2/comp/node.H

@@ -41,3 +41,6 @@ extern struct node *MkNode();
 #define HASSELECTORS 2
 #define VARIABLE 4
 #define VALUE 8
+
+#define	IsCast(lnd)	((lnd)->nd_class == Def && is_type((lnd)->nd_def))
+#define	IsProcCall(lnd)	((lnd)->nd_type->tp_fund == T_PROCEDURE)

lang/m2/comp/node.c

@@ -17,6 +17,9 @@ static char *RcsId = "$Header$";
 #include	"node.h"
 
 struct node *h_node;		/* header of free list */
+#ifdef DEBUG
+int	cnt_node;		/* count number of allocated ones */
+#endif
 
 struct node *
 MkNode(class, left, right, token)

lang/m2/comp/options.c

@@ -25,8 +25,8 @@ DoOption(text)
 		options[text[-1]] = 1;	/* flags, debug options etc.	*/
 		break;
 
-	case 'L' :
+	case 'L' :	/* don't generate fil/lin */
-		warning("-L: default no EM profiling; use -p for EM profiling");
+		options['L'] = 1;
 		break;
 
 	case 'M':	/* maximum identifier length */
@@ -37,7 +37,7 @@ DoOption(text)
 			fatal("maximum identifier length is %d", IDFSIZE);
 		break;
 
-	case 'p' :	/* generate profiling code (fil/lin) */
+	case 'p' :	/* generate profiling code procentry/procexit ???? */
 		options['p'] = 1;
 		break;
 

lang/m2/comp/program.g

@@ -24,7 +24,6 @@ static int DEFofIMPL = 0;	/* Flag indicating that we are currently
 				   implementation module currently being
 				   compiled
 				*/
-struct def *currentdef;		/* current definition of module or procedure */
 }
 /*
 	The grammar as given by Wirth is already almost LL(1); the
@@ -49,7 +48,6 @@ ModuleDeclaration
 {
 	struct idf *id;
 	register struct def *df;
-	struct def *savecurr = currentdef;
 	extern int proclevel;
 	static int modulecount = 0;
 	char buf[256];
@@ -61,7 +59,6 @@ ModuleDeclaration
 	MODULE IDENT	{
 			  id = dot.TOK_IDF;
 			  df = define(id, CurrentScope, D_MODULE);
-			  currentdef = df;
 
 			  if (!df->mod_vis) {	
 			  	open_scope(CLOSEDSCOPE);
@@ -71,6 +68,7 @@ ModuleDeclaration
 				CurrVis = df->mod_vis;
 				CurrentScope->sc_level = proclevel;
 			  }
+			  CurrentScope->sc_definedby = df;
 
 			  df->df_type = standard_type(T_RECORD, 0, (arith) 0);
 			  df->df_type->rec_scope = df->mod_vis->sc_scope;
@@ -93,7 +91,6 @@ ModuleDeclaration
 			  }
 			  close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
 			  match_id(id, dot.TOK_IDF);
-			  currentdef = savecurr;
 			}
 ;
 
@@ -244,7 +241,6 @@ ProgramModule
 		  if (state == IMPLEMENTATION) {
 			DEFofIMPL = 1;
 			df = GetDefinitionModule(id);
-			currentdef = df;
 			CurrVis = df->mod_vis;
 			CurrentScope = CurrVis->sc_scope;
 			DEFofIMPL = 0;
@@ -256,6 +252,7 @@ ProgramModule
 			df->mod_vis = CurrVis;
 			CurrentScope->sc_name = id->id_text;
 		  }
+		  CurrentScope->sc_definedby = df;
 		}
 	priority(&(df->mod_priority))?
 	';' import(0)*

lang/m2/comp/scope.C

@@ -35,11 +35,10 @@ open_scope(scopetype)
 	register struct scopelist *ls = new_scopelist();
 	
 	assert(scopetype == OPENSCOPE || scopetype == CLOSEDSCOPE);
+
+	clear((char *) sc, sizeof (*sc));
 	sc->sc_scopeclosed = scopetype == CLOSEDSCOPE;
 	sc->sc_level = proclevel;
-	sc->sc_forw = 0;
-	sc->sc_def = 0;
-	sc->sc_off = 0;
 	if (scopetype == OPENSCOPE) {
 		ls->next = CurrVis;
 	}

lang/m2/comp/scope.h

@@ -23,6 +23,7 @@ struct scope {
 	arith sc_off;		/* offsets of variables in this scope */
 	char sc_scopeclosed;	/* flag indicating closed or open scope */
 	int sc_level;		/* level of this scope */
+	struct def *sc_definedby; /* The def structure defining this scope */
 };
 
 struct scopelist {

lang/m2/comp/statement.g

@@ -16,7 +16,6 @@ static char *RcsId = "$Header$";
 #include	"node.h"
 
 static int	loopcount = 0;	/* Count nested loops */
-extern struct def *currentdef;
 }
 
 statement(struct node **pnd;)
@@ -61,28 +60,11 @@ statement(struct node **pnd;)
 	WithStatement(pnd)
 |
 	EXIT
-			{ if (!loopcount) {
+			{ if (!loopcount) error("EXIT not in a LOOP");
-error("EXIT not in a LOOP");
-			  }
 			  *pnd = MkNode(Stat, NULLNODE, NULLNODE, &dot);
 			}
 |
-	RETURN		{ *pnd = nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
+	ReturnStatement(pnd)
-	[
-		expression(&(nd->nd_right))
-			{ if (scopeclosed(CurrentScope)) {
-error("a module body has no result value");
-			  }
-			  else if (! currentdef->df_type->next) {
-error("procedure \"%s\" has no result value", currentdef->df_idf->id_text);
-			  }
-			}
-	|
-			{ if (currentdef->df_type->next) {
-error("procedure \"%s\" must return a value", currentdef->df_idf->id_text);
-			  }
-			}
-	]
 ]?
 ;
 
@@ -193,18 +175,28 @@ RepeatStatement(struct node **pnd;)
 ForStatement(struct node **pnd;)
 {
 	register struct node *nd;
+	struct node *dummy;
 }:
 	FOR		{ *pnd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
-	IDENT		{ nd = MkNode(Name, NULLNODE, NULLNODE, &dot); }
+	IDENT		{ (*pnd)->nd_IDF = dot.TOK_IDF; }
-	BECOMES		{ nd = MkNode(BECOMES, nd, NULLNODE, &dot); }
+	BECOMES		{ nd = MkNode(Stat, NULLNODE, NULLNODE, &dot);
-	expression(&(nd->nd_right))
+			  (*pnd)->nd_left = nd;
-	TO		{ (*pnd)->nd_left=nd=MkNode(Link,nd,NULLNODE,&dot); }
+			}
+	expression(&(nd->nd_left))
+	TO
 	expression(&(nd->nd_right))
 	[
-		BY	{ nd->nd_right=MkNode(Link,NULLNODE,nd->nd_right,&dot);
+		BY
+		ConstExpression(&dummy)
+			{
+			  if (!(dummy->nd_type->tp_fund & T_INTORCARD)) {
+				error("illegal type in BY clause");
+			  }
+			  nd->nd_INT = dummy->nd_INT;
+			  FreeNode(dummy);
 			}
-		ConstExpression(&(nd->nd_right->nd_left))
 	|
+			{ nd->nd_INT = 1; }
 	]
 	DO
 	StatementSequence(&((*pnd)->nd_right))
@@ -227,3 +219,27 @@ WithStatement(struct node **pnd;)
 	StatementSequence(&(nd->nd_right))
 	END
 ;
+
+ReturnStatement(struct node **pnd;)
+{
+	register struct def *df = CurrentScope->sc_definedby;
+	register struct node *nd;
+} :
+
+	RETURN		{ *pnd = nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
+	[
+		expression(&(nd->nd_right))
+			{ if (scopeclosed(CurrentScope)) {
+error("a module body has no result value");
+			  }
+			  else if (! df->df_type->next) {
+error("procedure \"%s\" has no result value", df->df_idf->id_text);
+			  }
+			}
+	|
+			{ if (df->df_type->next) {
+error("procedure \"%s\" must return a value", df->df_idf->id_text);
+			  }
+			}
+	]
+;

lang/m2/comp/type.H

@@ -4,8 +4,9 @@
 
 struct paramlist {		/* structure for parameterlist of a PROCEDURE */
 	struct paramlist *next;
-	struct type *par_type;	/* Parameter type */
+	struct def *par_def;	/* "df" of parameter */
-	int par_var;		/* flag, set if VAR parameter */
+#define	IsVarParam(xpar)	((xpar)->par_def->df_flags & D_VARPAR)
+#define TypeOfParam(xpar)	((xpar)->par_def->df_type)
 };
 
 /* ALLOCDEF "paramlist" */

lang/m2/comp/type.c

@@ -19,6 +19,7 @@ static char *RcsId = "$Header$";
 #include	"LLlex.h"
 #include	"node.h"
 #include	"const.h"
+#include	"scope.h"
 
 /*	To be created dynamically in main() from defaults or from command
 	line parameters.
@@ -58,8 +59,14 @@ struct type
 	*error_type;
 
 struct paramlist *h_paramlist;
+#ifdef DEBUG
+int	cnt_paramlist;
+#endif
 
 struct type *h_type;
+#ifdef DEBUG
+int	cnt_type;
+#endif
 
 extern label	data_label();
 
@@ -215,31 +222,33 @@ init_types()
 	error_type = standard_type(T_CHAR, 1, (arith) 1);
 }
 
-/*	Create a parameterlist of a procedure and return a pointer to it.
+ParamList(ppr, ids, tp, VARp, off)
+	register struct node *ids;
+	struct paramlist **ppr;
+	struct type *tp;
+	arith *off;
+{
+	/*	Create (part of) a parameterlist of a procedure.
 		"ids" indicates the list of identifiers, "tp" their type, and
 		"VARp" is set when the parameters are VAR-parameters.
-	Actually, "ids" is only used because it tells us how many parameters
-	there were with this type.
 */
-struct paramlist *
-ParamList(ids, tp, VARp)
-	register struct node *ids;
-	struct type *tp;
-{
 	register struct paramlist *pr;
+	register struct def *df;
 	struct paramlist *pstart;
 
-	pstart = pr = new_paramlist();
+	while (ids) {
-	pr->par_type = tp;
+		pr = new_paramlist();
-	pr->par_var = VARp;
+		pr->next = *ppr;
-	for (ids = ids->next; ids; ids = ids->next) {
+		*ppr = pr;
-		pr->next = new_paramlist();
+		df = define(ids->nd_IDF, CurrentScope, D_VARIABLE);
-		pr = pr->next;
+		pr->par_def = df;
-		pr->par_type = tp;
+		df->df_type = tp;
-		pr->par_var = VARp;
+		if (VARp) df->df_flags = D_VARPAR;
+		else	df->df_flags = D_VALPAR;
+		df->var_off = align(*off, word_align);
+		*off = df->var_off + tp->tp_size;
+		ids = ids->next;
 	}
-	pr->next = 0;
-	return pstart;
 }
 
 chk_basesubrange(tp, base)
@@ -551,8 +560,8 @@ DumpType(tp)
 		if (par) {
 			print("; p:");
 			while(par) {
-				if (par->par_var) print("VAR ");
+				if (IsVarParam(par)) print("VAR ");
-				DumpType(par->par_type);
+				DumpType(TypeOfParam(par));
 				par = par->next;
 			}
 		}

lang/m2/comp/typequiv.c

@@ -12,6 +12,8 @@ static char *RcsId = "$Header$";
 
 #include	"type.h"
 #include	"def.h"
+#include	"LLlex.h"
+#include	"node.h"
 
 int
 TstTypeEquiv(tp1, tp2)
@@ -70,8 +72,8 @@ TstProcEquiv(tp1, tp2)
 	/* Now check the parameters
 	*/
 	while (p1 && p2) {
-		if (p1->par_var != p2->par_var ||
+		if (IsVarParam(p1) != IsVarParam(p2) ||
-		    !TstParEquiv(p1->par_type, p2->par_type)) return 0;
+		    !TstParEquiv(TypeOfParam(p1), TypeOfParam(p2))) return 0;
 		p1 = p1->next;
 		p2 = p2->next;
 	}
@@ -172,11 +174,11 @@ TstAssCompat(tp1, tp2)
 }
 
 int
-TstParCompat(formaltype, actualtype, VARflag)
+TstParCompat(formaltype, actualtype, VARflag, nd)
 	struct type *formaltype, *actualtype;
+	struct node *nd;
 {
-	/*	Check type compatibility for a parameter in a procedure
+	/*	Check type compatibility for a parameter in a procedure call.
-		call. Ordinary type compatibility is sufficient in any case.
 		Assignment compatibility may do if the parameter is
 		a value parameter.
 		Otherwise, a conformant array may do, or an ARRAY OF WORD
@@ -185,11 +187,20 @@ TstParCompat(formaltype, actualtype, VARflag)
 	*/
 
 	return
-		TstCompat(formaltype, actualtype)
+		TstTypeEquiv(formaltype, actualtype)
 	    ||
 		( !VARflag && TstAssCompat(formaltype, actualtype))
 	    ||
-		(  formaltype == word_type && actualtype->tp_size == word_size)
+		(  formaltype == word_type
+		&& 
+		   (  actualtype->tp_size == word_size
+		   ||
+		      (  !VARflag
+		      &&
+			 actualtype->tp_size <= word_size
+		      )
+		   )
+		)
 	    ||
 		(  IsConformantArray(formaltype)
 		&&
@@ -203,5 +214,21 @@ TstParCompat(formaltype, actualtype, VARflag)
 		      && TstTypeEquiv(formaltype->arr_elem, char_type)
 		      )
 		   )
-		);
+		)
+	    ||
+		( VARflag && OldCompat(formaltype, actualtype, nd))
+	;
+}
+
+int
+OldCompat(ft, at, nd)
+	struct type *ft, *at;
+	struct node *nd;
+{
+	if (TstCompat(ft, at)) {
+node_warning(nd, "oldfashioned! types of formal and actual must be identical");
+		return 1;
+	}
+
+	return 0;
 }

lang/m2/comp/walk.c

@@ -54,7 +54,7 @@ DoProfil()
 {
 	static label	filename_label = 0;
 
-	if (options['p']) {
+	if (! options['L']) {
 		if (!filename_label) {
 			filename_label = data_label();
 			C_df_dlb(filename_label);
@@ -278,10 +278,16 @@ WalkStat(nd, lab)
 		return;
 	}
 
-	if (options['p']) C_lin((arith) nd->nd_lineno);
+	if (options['L']) C_lin((arith) nd->nd_lineno);
 
 	if (nd->nd_class == Call) {
-		if (chk_call(nd)) CodeCall(nd);
+		if (chk_call(nd)) {
+			if (nd->nd_type != 0) {
+				node_error(nd, "procedure call expected");
+				return;
+			}
+			CodeCall(nd);
+		}
 		return;
 	}
 
@@ -289,7 +295,7 @@ WalkStat(nd, lab)
 
 	switch(nd->nd_symb) {
 	case BECOMES:
-		DoAssign(nd, left, right, 0);
+		DoAssign(nd, left, right);
 		break;
 
 	case IF:
@@ -362,51 +368,27 @@ WalkStat(nd, lab)
 			struct node *fnd;
 			label l1 = instructionlabel++;
 			label l2 = instructionlabel++;
-			arith incr = 1;
 			arith size;
 
-			assert(left->nd_symb == TO);
+			if (! DoForInit(nd, left)) break;
-			assert(left->nd_left->nd_symb == BECOMES);
-
-			DoAssign(left->nd_left,
-				 left->nd_left->nd_left,
-				 left->nd_left->nd_right, 1);
 			fnd = left->nd_right;
-			if (fnd->nd_symb == BY) {
-				incr = fnd->nd_left->nd_INT;
-				fnd = fnd->nd_right;
-			}
-			if (! chk_expr(fnd)) return;
 			size = fnd->nd_type->tp_size;
 			if (fnd->nd_class != Value) {
-				*pds = InitDesig;
+				CodePExpr(fnd);
-				CodeExpr(fnd, pds, NO_LABEL, NO_LABEL);
-				CodeValue(pds, size);
 				tmp = NewInt();
 				C_stl(tmp);
 			}
-			if (!TstCompat(left->nd_left->nd_left->nd_type,
-				       fnd->nd_type)) {
-node_error(fnd, "type incompatibility in limit of FOR loop");
-				break;
-			}
 			C_bra(l1);
 			C_df_ilb(l2);
 			WalkNode(right, lab);
-			*pds = InitDesig;
+			C_loc(left->nd_INT);
-			C_loc(incr);
+			CodePExpr(nd);
-			CodeDesig(left->nd_left->nd_left, pds);
-			CodeValue(pds, size);
 			C_adi(int_size);
-			*pds = InitDesig;
+			CodeDStore(nd);
-			CodeDesig(left->nd_left->nd_left, pds);
-			CodeStore(pds, size);
 			C_df_ilb(l1);
-			*pds = InitDesig;
+			CodePExpr(nd);
-			CodeDesig(left->nd_left->nd_left, pds);
-			CodeValue(pds, size);
 			if (tmp) C_lol(tmp); else C_loc(fnd->nd_INT);
-			if (incr > 0) {
+			if (left->nd_INT > 0) {
 				C_ble(l2);
 			}
 			else	C_bge(l2);
@@ -461,8 +443,7 @@ node_error(fnd, "type incompatibility in limit of FOR loop");
 	case RETURN:
 		if (right) {
 			WalkExpr(right, NO_LABEL, NO_LABEL);
-			/* What kind of compatibility do we need here ???
+			/* Assignment compatibility? Yes, see Rep. 9.11
-			   assignment compatibility?
 			*/
 			if (!TstAssCompat(func_type, right->nd_type)) {
 node_error(right, "type incompatibility in RETURN statement");
@@ -519,10 +500,41 @@ WalkDesignator(nd)
 
 	Desig = InitDesig;
 	CodeDesig(nd, &Desig);
-
 }
 
-DoAssign(nd, left, right, forloopass)
+DoForInit(nd, left)
+	register struct node *nd, *left;
+{
+
+	nd->nd_left = nd->nd_right = 0;
+	nd->nd_class = Name;
+	nd->nd_symb = IDENT;
+
+	if (! chk_designator(nd, VARIABLE, D_DEFINED) ||
+	    ! chk_expr(left->nd_left) ||
+	    ! chk_expr(left->nd_right)) return;
+
+	if (nd->nd_type->tp_size > word_size ||
+	    !(nd->nd_type->tp_fund & T_DISCRETE)) {
+		node_error(nd, "illegal type of FOR loop variable");
+		return 0;
+	}
+
+	if (!TstCompat(nd->nd_type, left->nd_left->nd_type) ||
+	    !TstCompat(nd->nd_type, left->nd_right->nd_type)) {
+		if (!TstAssCompat(nd->nd_type, left->nd_left->nd_type) ||
+		    !TstAssCompat(nd->nd_type, left->nd_right->nd_type)) {
+			node_error(nd, "type incompatibility in FOR statement");
+			return 0;
+		}
+node_warning(nd, "old-fashioned! compatibility required in FOR statement");
+	}
+
+	CodePExpr(left->nd_left);
+	CodeDStore(nd);
+}
+
+DoAssign(nd, left, right)
 	struct node *nd;
 	register struct node *left, *right;
 {
@@ -532,14 +544,7 @@ DoAssign(nd, left, right, forloopass)
 	WalkExpr(right, NO_LABEL, NO_LABEL);
 	if (! chk_designator(left, DESIGNATOR|VARIABLE, D_DEFINED)) return;
 
-	if (forloopass) {
+	if (! TstAssCompat(left->nd_type, right->nd_type)) {
-		if (! TstCompat(left->nd_type, right->nd_type)) {
-			node_error(nd, "type incompatibility in FOR loop");
-			return;
-		}
-		/* Test if the left hand side may be a for loop variable ??? */
-	}
-	else if (! TstAssCompat(left->nd_type, right->nd_type)) {
 		node_error(nd, "type incompatibility in assignment");
 		return;
 	}