newer version

lang/m2/comp/LLlex.c

@@ -182,10 +182,6 @@ again:
 			if (nch == '=')	{
 				return tk->tk_symb = LESSEQUAL;
 			}
-			else
-			if (nch == '>') {
-				return tk->tk_symb = '#';
-			}
 			PushBack(nch);
 			return tk->tk_symb = ch;
 

lang/m2/comp/LLmessage.c

@@ -4,6 +4,12 @@
 static char *RcsId = "$Header$";
 #endif
 
+/*	Defines the LLmessage routine. LLgen-generated parsers require the
+	existence of a routine of that name.
+	The routine must do syntax-error reporting and must be able to
+	insert tokens in the token stream.
+*/
+
 #include	<alloc.h>
 #include	<em_arith.h>
 #include	<em_label.h>
@@ -12,15 +18,18 @@ static char *RcsId = "$Header$";
 #include	"LLlex.h"
 #include	"Lpars.h"
 
-extern char *symbol2str();
+extern char		*symbol2str();
-extern struct idf *gen_anon_idf();
+extern struct idf	*gen_anon_idf();
-int err_occurred = 0;
+int			 err_occurred = 0;
 
 LLmessage(tk)
 	int tk;
 {
 	++err_occurred;
 	if (tk)	{
+		/* if (tk != 0), it represents the token to be inserted.
+		   otherwize, the current token is deleted
+		*/
 		error("%s missing", symbol2str(tk));
 		insert_token(tk);
 	}

lang/m2/comp/Makefile

@@ -11,7 +11,7 @@ LSRC =	tokenfile.g program.g declar.g expression.g statement.g
 CC =	cc
 GEN =	LLgen
 GENOPTIONS =
-PROFILE =
+PROFILE = 
 CFLAGS = $(PROFILE) $(INCLUDES)
 LFLAGS = $(PROFILE)
 LOBJ =	tokenfile.o program.o declar.o expression.o statement.o
@@ -91,7 +91,7 @@ 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
-def.o: LLlex.h debug.h def.h idf.h main.h node.h scope.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
@@ -101,10 +101,11 @@ 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
 options.o: idfsize.h main.h ndir.h type.h
-walk.o: LLlex.h Lpars.h debug.h def.h desig.h main.h node.h scope.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
+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
 declar.o: LLlex.h Lpars.h debug.h def.h idf.h main.h misc.h node.h scope.h type.h

lang/m2/comp/casestat.C

@@ -63,15 +63,12 @@ CaseCode(nd, exitlabel)
 	register arith val;
 	label tablabel;
 
-	assert(nd->nd_class == Stat && nd->nd_symb == CASE);
+	assert(pnode->nd_class == Stat && pnode->nd_symb == CASE);
 
-	WalkExpr(nd->nd_left, NO_LABEL, NO_LABEL);
+	clear((char *) sh, sizeof(*sh));
-	sh->sh_type = nd->nd_left->nd_type;
+	WalkExpr(pnode->nd_left, NO_LABEL, NO_LABEL);
+	sh->sh_type = pnode->nd_left->nd_type;
 	sh->sh_break = text_label();
-	sh->sh_default = 0;
-	sh->sh_nrofentries = 0;
-	sh->sh_lowerbd = sh->sh_upperbd = (arith)0;	/* immaterial ??? */
-	sh->sh_entries = (struct case_entry *) 0; /* case-entry list	*/
 
 	/* Now, create case label list
 	*/
@@ -189,6 +186,7 @@ AddCases(sh, node, lbl)
 		if (node->nd_symb == UPTO) {
 			assert(node->nd_left->nd_class == Value);
 			assert(node->nd_right->nd_class == Value);
+
 			v2 = node->nd_right->nd_INT;
 			node->nd_type = node->nd_left->nd_type;
 			for (v1 = node->nd_left->nd_INT; v1 <= v2; v1++) {
@@ -233,9 +231,12 @@ AddOneCase(sh, node, lbl)
 		/* second etc. case entry		*/
 		/* find the proper place to put ce into the list	*/
 		
-		if (ce->ce_value < sh->sh_lowerbd) sh->sh_lowerbd = ce->ce_value;
+		if (ce->ce_value < sh->sh_lowerbd) {
-		else
+			sh->sh_lowerbd = ce->ce_value;
-		if (ce->ce_value > sh->sh_upperbd) sh->sh_upperbd = ce->ce_value;
+		}
+		else if (ce->ce_value > sh->sh_upperbd) {
+			sh->sh_upperbd = ce->ce_value;
+		}
 		while (c1 && c1->ce_value < ce->ce_value)	{
 			c2 = c1;
 			c1 = c1->next;

lang/m2/comp/chk_expr.c

@@ -38,7 +38,7 @@ chk_expr(expp)
 	switch(expp->nd_class) {
 	case Oper:
 		if (expp->nd_symb == '[') {
-			return chk_designator(expp, DESIGNATOR|VARIABLE);
+			return chk_designator(expp, DESIGNATOR|VARIABLE, D_NOREG|D_USED);
 		}
 
 		return	chk_expr(expp->nd_left) &&
@@ -47,7 +47,7 @@ chk_expr(expp)
 
 	case Uoper:
 		if (expp->nd_symb == '^') {
-			return chk_designator(expp, DESIGNATOR|VARIABLE);
+			return chk_designator(expp, DESIGNATOR|VARIABLE, D_USED);
 		}
 
 		return	chk_expr(expp->nd_right) &&
@@ -69,13 +69,13 @@ chk_expr(expp)
 		return chk_set(expp);
 
 	case Name:
-		return chk_designator(expp, VALUE);
+		return chk_designator(expp, VALUE, D_USED);
 
 	case Call:
 		return chk_call(expp);
 
 	case Link:
-		return chk_designator(expp, DESIGNATOR|VALUE);
+		return chk_designator(expp, DESIGNATOR|VALUE, D_USED|D_NOREG);
 
 	default:
 		assert(0);
@@ -94,6 +94,7 @@ chk_set(expp)
 	struct def *df;
 	register struct node *nd;
 	arith *set;
+	unsigned size;
 
 	assert(expp->nd_symb == SET);
 
@@ -102,7 +103,7 @@ chk_set(expp)
 	if (nd = expp->nd_left) {
 		/* A type was given. Check it out
 		*/
-		if (! chk_designator(nd, 0)) return 0;
+		if (! chk_designator(nd, 0, D_USED)) return 0;
 
 		assert(nd->nd_class == Def);
 		df = nd->nd_def;
@@ -117,16 +118,26 @@ chk_set(expp)
 		expp->nd_left = 0;
 	}
 	else	tp = bitset_type;
+	expp->nd_type = tp;
+
+	nd = expp->nd_right;
 
 	/* Now check the elements given, and try to compute a constant set.
-	   First allocate room for the set
+	   First allocate room for the set, but only if it is'nt empty.
 	*/
-	set = (arith *)
+	if (! nd) {
-		Malloc((unsigned) (tp->tp_size * sizeof(arith) / word_size));
+		/* The resulting set IS empty, so we just return
+		*/
+		expp->nd_class = Set;
+		expp->nd_set = 0;
+		return 1;
+	}
+	size = tp->tp_size * (sizeof(arith) / word_size);
+	set = (arith *) Malloc(size);
+	clear((char *) set, size);
 
 	/* Now check the elements, one by one
 	*/
-	nd = expp->nd_right;
 	while (nd) {
 		assert(nd->nd_class == Link && nd->nd_symb == ',');
 
@@ -134,8 +145,6 @@ chk_set(expp)
 		nd = nd->nd_right;
 	}
 
-	expp->nd_type = tp;
-
 	if (set) {
 		/* Yes, it was a constant set, and we managed to compute it!
 		   Notice that at the moment there is no such thing as
@@ -255,7 +264,7 @@ getarg(argp, bases, designator)
 	}
 	argp = argp->nd_right;
 	if ((!designator && !chk_expr(argp->nd_left)) ||
-	    (designator && !chk_designator(argp->nd_left, DESIGNATOR))) {
+	    (designator && !chk_designator(argp->nd_left, DESIGNATOR, D_REFERRED))) {
 		return 0;
 	}
 	tp = argp->nd_left->nd_type;
@@ -276,7 +285,7 @@ getname(argp, kinds)
 		return 0;
 	}
 	argp = argp->nd_right;
-	if (! chk_designator(argp->nd_left, 0)) return 0;
+	if (! chk_designator(argp->nd_left, 0, D_REFERRED)) return 0;
 
 	assert(argp->nd_left->nd_class == Def);
 
@@ -303,10 +312,9 @@ chk_call(expp)
 	*/
 	expp->nd_type = error_type;
 	left = expp->nd_left;
-	if (! chk_designator(left, 0)) return 0;
+	if (! chk_designator(left, 0, D_USED)) return 0;
 
-	if (left->nd_class == Def &&
+	if (left->nd_class == Def && is_type(left->nd_def)) {
-	    (left->nd_def->df_kind & (D_HTYPE|D_TYPE|D_HIDDEN))) {
 		/* It was a type cast. This is of course not portable.
 		*/
 		arg = expp->nd_right;
@@ -359,10 +367,21 @@ chk_proccall(expp)
 {
 	/*	Check a procedure call
 	*/
-	register struct node *left = expp->nd_left;
+	register struct node *left;
 	register struct node *arg;
 	register struct paramlist *param;
 
+	left = 0;
+	arg = expp->nd_right;
+	/* First, reverse the order in the argument list */
+	while (arg) {
+		expp->nd_right = arg;
+		arg = arg->nd_right;
+		expp->nd_right->nd_right = left;
+		left = expp->nd_right;
+	}
+
+	left = expp->nd_left;
 	arg = expp;
 	arg->nd_type = left->nd_type->next;
 	param = left->nd_type->prc_params;
@@ -376,6 +395,9 @@ chk_proccall(expp)
 node_error(arg->nd_left, "type incompatibility in parameter");
 			return 0;
 		}
+		if (param->par_var && arg->nd_left->nd_class == Def) {
+			arg->nd_left->nd_def->df_flags |= D_NOREG;
+		}
 
 		param = param->next;
 	}
@@ -422,7 +444,7 @@ FlagCheck(expp, df, flag)
 }
 
 int
-chk_designator(expp, flag)
+chk_designator(expp, flag, dflags)
 	register struct node *expp;
 {
 	/*	Find the name indicated by "expp", starting from the current
@@ -435,6 +457,8 @@ chk_designator(expp, flag)
 		and '^' are allowed for this designator.
 		Also contained may be the flag HASSELECTORS, indicating that
 		the result must have selectors.
+		"dflags" contains some flags that must be set at the definition
+		found.
 	*/
 	register struct def *df;
 	register struct type *tp;
@@ -454,7 +478,8 @@ chk_designator(expp, flag)
 		assert(expp->nd_right->nd_class == Name);
 
 		if (! chk_designator(expp->nd_left,
-				     (flag|HASSELECTORS))) return 0;
+				     flag|HASSELECTORS,
+				     dflags|D_NOREG)) return 0;
 
 		tp = expp->nd_left->nd_type;
 
@@ -512,6 +537,8 @@ df->df_idf->id_text);
 			}
 		}
 
+		df->df_flags |= dflags;
+
 		return 1;
 	}
 
@@ -526,7 +553,7 @@ df->df_idf->id_text);
 		assert(expp->nd_symb == '[');
 
 		if ( 
-		    	!chk_designator(expp->nd_left, DESIGNATOR|VARIABLE)
+		    	!chk_designator(expp->nd_left, DESIGNATOR|VARIABLE, dflags|D_NOREG)
 		   ||
 		    	!chk_expr(expp->nd_right)
 		   ||
@@ -558,7 +585,7 @@ df->df_idf->id_text);
 	if (expp->nd_class == Uoper) {
 		assert(expp->nd_symb == '^');
 
-		if (! chk_designator(expp->nd_right, DESIGNATOR|VARIABLE)) {
+		if (! chk_designator(expp->nd_right, DESIGNATOR|VARIABLE, dflags)) {
 			return 0;
 		}
 
@@ -703,7 +730,6 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
 
 	case '=':
 	case '#':
-	case UNEQUAL:
 	case GREATEREQUAL:
 	case LESSEQUAL:
 	case '<':
@@ -732,7 +758,6 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
 		case T_POINTER:
 			if (chk_address(tpl, tpr) ||
 			    expp->nd_symb == '=' ||
-			    expp->nd_symb == UNEQUAL ||
 			    expp->nd_symb == '#') return 1;
 			break;
 
@@ -790,6 +815,7 @@ chk_uoper(expp)
 	case '+':
 		if (tpr->tp_fund & T_NUMERIC) {
 			expp->nd_token = right->nd_token;
+			expp->nd_class = right->nd_class;
 			FreeNode(right);
 			expp->nd_right = 0;
 			return 1;
@@ -809,10 +835,14 @@ chk_uoper(expp)
 		else if (tpr->tp_fund == T_REAL) {
 			if (right->nd_class == Value) {
 				expp->nd_token = right->nd_token;
+				expp->nd_class = Value;
 				if (*(expp->nd_REL) == '-') {
 					expp->nd_REL++;
 				}
-				else	expp->nd_REL--;
+				else {
+					expp->nd_REL--;
+					*(expp->nd_REL) = '-';
+				}
 				FreeNode(right);
 				expp->nd_right = 0;
 			}
@@ -853,7 +883,7 @@ getvariable(arg)
 
 	left = arg->nd_left;
 
-	if (! chk_designator(left, DESIGNATOR)) return 0;
+	if (! chk_designator(left, DESIGNATOR, D_REFERRED)) return 0;
 	if (left->nd_class == Oper || left->nd_class == Uoper) {
 		return arg;
 	}
@@ -941,7 +971,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
 	case S_TSIZE:	/* ??? */
 	case S_SIZE:
 		expp->nd_type = intorcard_type;
-		arg = getname(arg, D_FIELD|D_VARIABLE|D_TYPE|D_HIDDEN|D_HTYPE);
+		arg = getname(arg, D_FIELD|D_VARIABLE|D_ISTYPE);
 		if (!arg) return 0;
 		cstcall(expp, S_SIZE);
 		break;
@@ -955,7 +985,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
 		{
 		struct type *tp;
 
-		if (!(arg = getname(arg, D_HIDDEN|D_HTYPE|D_TYPE))) return 0;
+		if (!(arg = getname(arg, D_ISTYPE))) return 0;
 		tp = arg->nd_left->nd_def->df_type;
 		if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
 		if (!(tp->tp_fund & T_DISCRETE)) {

lang/m2/comp/code.c

@@ -52,14 +52,14 @@ CodeString(nd)
 	struct node *nd;
 {
 	label lab;
-	
+
 	if (nd->nd_type == charc_type) {
 		C_loc(nd->nd_INT);
 		return;
 	}
 	C_df_dlb(lab = data_label());
 	C_rom_scon(nd->nd_STR, nd->nd_SLE);
-	C_lae_dlb(lab);
+	C_lae_dlb(lab, (arith) 0);
 }
 
 CodeReal(nd)
@@ -69,7 +69,7 @@ CodeReal(nd)
 	
 	C_df_dlb(lab = data_label());
 	C_rom_fcon(nd->nd_REL, nd->nd_type->tp_size);
-	C_lae_dlb(lab);
+	C_lae_dlb(lab, (arith) 0);
 	C_loi(nd->nd_type->tp_size);
 }
 
@@ -139,12 +139,16 @@ CodeExpr(nd, ds, true_label, false_label)
 		int i;
 
 		st = nd->nd_set;
-		for (i = nd->nd_type->tp_size / word_size, st = nd->nd_set + i;
+		ds->dsg_kind = DSG_LOADED;
+		if (!st) {
+			C_zer(nd->nd_type->tp_size);
+			break;
+		}
+		for (i = nd->nd_type->tp_size / word_size, st += i;
 		     i > 0;
 		     i--) { 
 			C_loc(*--st);
 		}
-		ds->dsg_kind = DSG_LOADED;
 		}
 		break;
 
@@ -166,9 +170,97 @@ CodeExpr(nd, ds, true_label, false_label)
 }
 
 CodeCoercion(t1, t2)
-	struct type *t1, *t2;
+	register struct type *t1, *t2;
 {
-	/* ??? */
+	int fund1, fund2;
+
+	if (t1 == t2) return;
+	if (t1->tp_fund == T_SUBRANGE) t1 = t1->next;
+	if (t2->tp_fund == T_SUBRANGE) t2 = t2->next;
+	if ((fund1 = t1->tp_fund) == T_WORD) fund1 = T_INTEGER;
+	if ((fund2 = t2->tp_fund) == T_WORD) fund2 = T_INTEGER;
+	switch(fund1) {
+	case T_INTEGER:
+		switch(fund2) {
+		case T_INTEGER:
+			if (t2->tp_size != t1->tp_size) {
+				C_loc(t1->tp_size);
+				C_loc(t2->tp_size);
+				C_cii();
+			}
+			break;
+		case T_ENUMERATION:
+		case T_CHAR:
+		case T_CARDINAL:
+			if (t1->tp_size != word_size) {
+				C_loc(t1->tp_size);
+				C_loc(word_size);
+				C_ciu();
+			}
+			break;
+		case T_REAL:
+			C_loc(t1->tp_size);
+			C_loc(t2->tp_size);
+			C_cif();
+			break;
+		default:
+			crash("Funny integer conversion");
+		}
+		break;
+
+	case T_CHAR:
+	case T_ENUMERATION:
+	case T_CARDINAL:
+		switch(fund2) {
+		case T_ENUMERATION:
+		case T_CHAR:
+		case T_CARDINAL:
+		case T_POINTER:
+			if (t2->tp_size > word_size) {
+				C_loc(word_size);
+				C_loc(t2->tp_size);
+				C_cuu();
+			}
+			break;
+		case T_INTEGER:
+			C_loc(t1->tp_size);
+			C_loc(t2->tp_size);
+			C_cui();
+			break;
+		case T_REAL:
+			C_loc(t1->tp_size);
+			C_loc(t2->tp_size);
+			C_cuf();
+			break;
+		default:
+			crash("Funny cardinal conversion");
+		}
+		break;
+
+	case T_REAL:
+		switch(fund2) {
+		case T_REAL:
+			if (t2->tp_size != t1->tp_size) {
+				C_loc(t1->tp_size);
+				C_loc(t2->tp_size);
+				C_cff();
+			}
+			break;
+		case T_INTEGER:
+			C_loc(t1->tp_size);
+			C_loc(t2->tp_size);
+			C_cfi();
+			break;
+		case T_CARDINAL:
+			C_loc(t1->tp_size);
+			C_loc(t2->tp_size);
+			C_cfu();
+			break;
+		default:
+			crash("Funny REAL conversion");
+		}
+		break;
+	}
 }
 
 CodeCall(nd)
@@ -190,13 +282,12 @@ CodeCall(nd)
 	}	
 	tp = left->nd_type;
 
-	if (left->nd_class == Def &&
+	if (left->nd_class == Def && is_type(left->nd_def)) {
-	    (left->nd_def->df_kind & (D_TYPE|D_HTYPE|D_HIDDEN))) {
 		/* it was just a cast. Simply ignore it
 		*/
 		Des = InitDesig;
 		CodeExpr(nd->nd_right->nd_left, &Des, NO_LABEL, NO_LABEL);
-		CodeValue(&Des);
+		CodeValue(&Des, tp->tp_size);
 		*nd = *(nd->nd_right->nd_left);
 		nd->nd_type = left->nd_def->df_type;
 		return;
@@ -216,6 +307,7 @@ CodeCall(nd)
 		else {
 			CodeExpr(arg->nd_left, &Des, NO_LABEL, NO_LABEL);
 			CodeValue(&Des, arg->nd_left->nd_type->tp_size);
+			CheckAssign(arg->nd_left->nd_type, param->par_type);
 			pushed += align(arg->nd_left->nd_type->tp_size, word_align);
 		}
 		/* ??? Conformant arrays */
@@ -249,16 +341,55 @@ CodeStd(nd)
 	/* ??? */
 }
 
-CodeAssign(nd, dst, dss)
+CodeAssign(nd, dss, dst)
 	struct node *nd;
 	struct desig *dst, *dss;
 {
 	/*	Generate code for an assignment. Testing of type
 		compatibility and the like is already done.
 	*/
-	
+
-	CodeCoercion(nd->nd_right->nd_type, nd->nd_left->nd_type);
+	if (dss->dsg_kind == DSG_LOADED) {
-	/* ??? */
+		CodeStore(dst, nd->nd_left->nd_type->tp_size);
+	}
+	else {
+		CodeAddress(dst);
+		C_blm(nd->nd_left->nd_type->tp_size);
+	}
+}
+
+CheckAssign(tpl, tpr)
+	register struct type *tpl, *tpr;
+{
+	/*	Generate a range check if neccessary
+	*/
+
+	arith llo, lhi, rlo, rhi;
+	label l = 0;
+	extern label getrck();
+
+	if (bounded(tpl)) {
+		/* in this case we might need a range check */
+		if (!bounded(tpr)) {
+			/* yes, we need one */
+			l = getrck(tpl);
+		}
+		else {
+			/* both types are restricted. check the bounds
+			   to see wether we need a range check
+			*/
+			getbounds(tpl, &llo, &lhi);
+			getbounds(tpr, &rlo, &rhi);
+			if (llo > rlo || lhi < rhi) {
+				l = getrck(tpl);
+			}
+		}
+
+		if (l) {
+			C_lae_dlb(l, (arith) 0);
+			C_rck(word_size);
+		}
+	}
 }
 
 Operands(leftop, rightop)
@@ -415,29 +546,44 @@ CodeOper(expr, true_label, false_label)
 	case '>':
 	case GREATEREQUAL:
 	case '=':
-	case UNEQUAL:
 	case '#':
 		Operands(leftop, rightop);
 		CodeCoercion(rightop->nd_type, leftop->nd_type);
+		tp = leftop->nd_type;	/* Not the result type! */
+		if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
 		switch (tp->tp_fund)	{
 		case T_INTEGER:
-			C_cmi(leftop->nd_type->tp_size);
+			C_cmi(tp->tp_size);
 			break;
 		case T_POINTER:
 			C_cmp();
 			break;
 		case T_CARDINAL:
-			C_cmu(leftop->nd_type->tp_size);
+			C_cmu(tp->tp_size);
 			break;
 		case T_ENUMERATION:
 		case T_CHAR:
 			C_cmu(word_size);
 			break;
 		case T_REAL:
-			C_cmf(leftop->nd_type->tp_size);
+			C_cmf(tp->tp_size);
 			break;
 		case T_SET:
-			C_cms(leftop->nd_type->tp_size);
+			if (oper == GREATEREQUAL) {
+				/* A >= B is the same as A equals A + B
+				*/
+				C_dup(2*tp->tp_size);
+				C_asp(tp->tp_size);
+				C_zer(tp->tp_size);
+			}
+			else if (oper == LESSEQUAL) {
+				/* A <= B is the same as A - B = {}
+				*/
+				C_com(tp->tp_size);
+				C_and(tp->tp_size);
+				C_ior(tp->tp_size);
+			}
+			C_cms(tp->tp_size);
 			break;
 		default:
 			crash("bad type COMPARE");
@@ -451,9 +597,13 @@ CodeOper(expr, true_label, false_label)
 		}
 		break;
 	case IN:
-		Operands(leftop, rightop);
+		/* In this case, evaluate right hand side first! The
-		CodeCoercion(rightop->nd_type, word_type);
+		   INN instruction expects the bit number on top of the
-		C_inn(leftop->nd_type->tp_size);
+		   stack
+		*/
+		Operands(rightop, leftop);
+		CodeCoercion(leftop->nd_type, word_type);
+		C_inn(rightop->nd_type->tp_size);
 		break;
 	case AND:
 	case '&':
@@ -544,7 +694,6 @@ compare(relop, lbl)
 	case '=':
 		C_zeq(lbl);
 		break;
-	case UNEQUAL:
 	case '#':
 		C_zne(lbl);
 		break;
@@ -573,7 +722,6 @@ truthvalue(relop)
 	case '=':
 		C_teq();
 		break;
-	case UNEQUAL:
 	case '#':
 		C_tne();
 		break;
@@ -643,7 +791,7 @@ CodeEl(nd, tp)
 
 		Des = InitDesig;
 		CodeExpr(nd, &Des, NO_LABEL, NO_LABEL);
-		CodeValue(nd, word_size);
+		CodeValue(&Des, word_size);
 		C_set(tp->tp_size);
 	}
 }

lang/m2/comp/cstoper.c

@@ -45,7 +45,7 @@ cstunary(expp)
 		o1 = !o1;
 		break;
 	default:
-		assert(0);
+		crash("(cstunary)");
 	}
 	expp->nd_class = Value;
 	expp->nd_token = expp->nd_right->nd_token;
@@ -159,7 +159,7 @@ cstbin(expp)
 			);
 		}
 		else
-			o1 = o1 < o2;
+			o1 = (o1 < o2);
 		break;
 
 	case '>':
@@ -170,7 +170,7 @@ cstbin(expp)
 			);
 		}
 		else
-			o1 = o1 > o2;
+			o1 = (o1 > o2);
 		break;
 	case LESSEQUAL:
 		if (uns)	{
@@ -180,7 +180,7 @@ cstbin(expp)
 			);
 		}
 		else
-			o1 = o1 <= o2;
+			o1 = (o1 <= o2);
 		break;
 	case GREATEREQUAL:
 		if (uns)	{
@@ -190,27 +190,27 @@ cstbin(expp)
 			);
 		}
 		else
-			o1 = o1 >= o2;
+			o1 = (o1 >= o2);
 		break;
 	case '=':
-		o1 = o1 == o2;
+		o1 = (o1 == o2);
 		break;
 	case '#':
-	case UNEQUAL:
+		o1 = (o1 != o2);
-		o1 = o1 != o2;
 		break;
 	case AND:
 	case '&':
-		o1 = o1 && o2;
+		o1 = (o1 && o2);
 		break;
 	case OR:
-		o1 = o1 || o2;
+		o1 = (o1 || o2);
 		break;
 	default:
-		assert(0);
+		crash("(cstbin)");
 	}
 	expp->nd_class = Value;
 	expp->nd_token = expp->nd_right->nd_token;
+	if (expp->nd_type == bool_type) expp->nd_symb = INTEGER;
 	expp->nd_INT = o1;
 	CutSize(expp);
 	FreeNode(expp->nd_left);
@@ -222,6 +222,7 @@ cstset(expp)
 	register struct node *expp;
 {
 	register arith *set1 = 0, *set2;
+	arith *resultset = 0;
 	register int setsize, j;
 
 	assert(expp->nd_right->nd_class == Set);
@@ -233,32 +234,59 @@ cstset(expp)
 		arith i;
 
 		assert(expp->nd_left->nd_class == Value);
+
 		i = expp->nd_left->nd_INT;
-		expp->nd_INT = (i >= 0 &&
+		expp->nd_INT = (i >= 0 && set2 != 0 &&
 		    i < setsize * wrd_bits &&
 		    (set2[i / wrd_bits] & (1 << (i % wrd_bits))));
-		    free((char *) set2);
+		if (set2) free((char *) set2);
 	}
 	else {
 		set1 = expp->nd_left->nd_set;
+		resultset = set1;
+		expp->nd_left->nd_set = 0;
 		switch(expp->nd_symb) {
 		case '+':
-			for (j = 0; j < setsize; j++) {
+			if (!set1) {
+				resultset = set2;
+				expp->nd_right->nd_set = 0;
+				break;
+			}
+			if (set2) for (j = 0; j < setsize; j++) {
 				*set1++ |= *set2++;
 			}
 			break;
 		case '-':
+			if (!set1 || !set2) {
+				/* The set from which something is substracted
+				   is already empty, or the set that is
+				   substracted is empty
+				*/
+				break;
+			}
 			for (j = 0; j < setsize; j++) {
 				*set1++ &= ~*set2++;
 			}
 			break;
 		case '*':
+			if (!set1) break;
+			if (!set2) {
+				resultset = set2;
+				expp->nd_right->nd_set = 0;
+				break;
+			}
+
 			for (j = 0; j < setsize; j++) {
 				*set1++ &= *set2++;
 			}
 			break;
 		case '/':
-			for (j = 0; j < setsize; j++) {
+			if (!set1) {
+				resultset = set2;
+				expp->nd_right->nd_set = 0;
+				break;
+			}
+			if (set2) for (j = 0; j < setsize; j++) {
 				*set1++ ^= *set2++;
 			}
 			break;
@@ -266,42 +294,62 @@ cstset(expp)
 		case LESSEQUAL:
 		case '=':
 		case '#':
-		case UNEQUAL:
 			/* Clumsy, but who cares? Nobody writes these things! */
+			expp->nd_left->nd_set = set1;
 			for (j = 0; j < setsize; j++) {
 				switch(expp->nd_symb) {
 				case GREATEREQUAL:
+					if (!set2) {j = setsize; break; }
+					if (!set1) break;
 					if ((*set1 | *set2++) != *set1) break;
 					set1++;
 					continue;
 				case LESSEQUAL:
+					if (!set1) {j = setsize; break; }
+					if (!set2) break;
 					if ((*set2 | *set1++) != *set2) break;
 					set2++;
 					continue;
 				case '=':
 				case '#':
-				case UNEQUAL:
+					if (!set1 && !set2) {
+						j = setsize; break;
+					}
+					if (!set1 || !set2) break;
 					if (*set1++ != *set2++) break;
 					continue;
 				}
-				expp->nd_INT = expp->nd_symb != '=';
+				if (j < setsize) {
+					expp->nd_INT = expp->nd_symb == '#';
+				}
+				else {
+			 		expp->nd_INT = expp->nd_symb != '#';
+				}
 				break;
 			}
-			if (j == setsize) expp->nd_INT = expp->nd_symb == '=';
 			expp->nd_class = Value;
 			expp->nd_symb = INTEGER;
-			free((char *) expp->nd_left->nd_set);
+			if (expp->nd_left->nd_set) {
-			free((char *) expp->nd_right->nd_set);
+				free((char *) expp->nd_left->nd_set);
+			}
+			if (expp->nd_right->nd_set) {
+				free((char *) expp->nd_right->nd_set);
+			}
 			FreeNode(expp->nd_left);
 			FreeNode(expp->nd_right);
 			expp->nd_left = expp->nd_right = 0;
 			return;
 		default:
-			assert(0);
+			crash("(cstset)");
+		}
+		if (expp->nd_right->nd_set) {
+			free((char *) expp->nd_right->nd_set);
+		}
+		if (expp->nd_left->nd_set) {
+			free((char *) expp->nd_left->nd_set);
 		}
-		free((char *) expp->nd_right->nd_set);
 		expp->nd_class = Set;
-		expp->nd_set = expp->nd_left->nd_set;
+		expp->nd_set = resultset;
 	}
 	FreeNode(expp->nd_left);
 	FreeNode(expp->nd_right);
@@ -405,7 +453,7 @@ cstcall(expp, call)
 		else CutSize(expp);
 		break;
 	default:
-		assert(0);
+		crash("(cstcall)");
 	}
 	FreeNode(expr);
 	FreeNode(expp->nd_left);

lang/m2/comp/declar.g

@@ -128,8 +128,7 @@ FormalParameters(int doparams;
 	]?
 	')'
 			{ *tp = 0; }
-	[	':' qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type",
+	[	':' qualident(D_ISTYPE, &df, "type", (struct node **) 0)
-							(struct node **) 0)
 			{ *tp = df->df_type;
 			}
 	]?
@@ -169,7 +168,7 @@ FormalType(struct type **tp;)
 } :
 	[ ARRAY OF	{ ARRAYflag = 1; }
 	]?
-	qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type", (struct node **) 0)
+	qualident(D_ISTYPE, &df, "type", (struct node **) 0)
 		{ if (ARRAYflag) {
 			*tp = construct_type(T_ARRAY, NULLTYPE);
 			(*tp)->arr_elem = df->df_type;
@@ -186,14 +185,19 @@ TypeDeclaration
 	struct def *df;
 	struct type *tp;
 }:
-	IDENT		{ df = define(dot.TOK_IDF, CurrentScope, D_TYPE); }
+	IDENT		{ df = lookup(dot.TOK_IDF, CurrentScope);
+			  if (!df) df = define( dot.TOK_IDF,
+						CurrentScope,
+						D_TYPE);
+			}
 	'=' type(&tp)
-			{ if (df->df_type) free_type(df->df_type);
+			{ if (df->df_type) free_type(df->df_type); /* ??? */
 			  df->df_type = tp;
-			  if (df->df_kind == D_HTYPE &&
+			  if (df->df_kind == D_HIDDEN &&
 			      tp->tp_fund != T_POINTER) {
 error("opaque type \"%s\" is not a pointer type", df->df_idf->id_text);
 			  }
+			  df->df_kind = D_TYPE;
 			}
 ;
 
@@ -215,7 +219,7 @@ SimpleType(struct type **ptp;)
 {
 	struct def *df;
 } :
-	qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type", (struct node **) 0)
+	qualident(D_ISTYPE, &df, "type", (struct node **) 0)
 	[
 		/* nothing */
 			{ *ptp = df->df_type; }
@@ -237,22 +241,16 @@ SimpleType(struct type **ptp;)
 enumeration(struct type **ptp;)
 {
 	struct node *EnumList;
+	register struct type *tp;
 } :
 	'(' IdentList(&EnumList) ')'
 		{
-		  *ptp = standard_type(T_ENUMERATION, 1, (arith) 1);
+		  *ptp = tp = standard_type(T_ENUMERATION, 1, (arith) 1);
-		  EnterIdList(EnumList, D_ENUM, 0, *ptp,
+		  EnterIdList(EnumList, D_ENUM, 0, tp,
 				 CurrentScope, (arith *) 0);
 		  FreeNode(EnumList);
-		  if ((*ptp)->enm_ncst > 256) {
+		  if (tp->enm_ncst > 256) {
-			if (word_size == 1) {
+			error("Too many enumeration literals");
-				error("Too many enumeration literals");
-			}
-			else {
-				/* ??? This is crummy */
-				(*ptp)->tp_size = word_size;
-				(*ptp)->tp_align = word_align;
-			}
 		  }
 		}
 ;
@@ -284,7 +282,8 @@ SubrangeType(struct type **ptp;)
 	'[' ConstExpression(&nd1)
 	UPTO ConstExpression(&nd2)
 	']'
-			{ *ptp = subr_type(nd1, nd2); }
+			{ *ptp = subr_type(nd1, nd2);
+			}
 ;
 
 ArrayType(struct type **ptp;)
@@ -298,8 +297,8 @@ ArrayType(struct type **ptp;)
 			}
 	[
 		',' SimpleType(&tp)
-			{ tp2 = tp2->arr_elem = 
+			{ tp2->arr_elem = construct_type(T_ARRAY, tp);
-				construct_type(T_ARRAY, tp);
+			  tp2 = tp2->arr_elem;
 			}
 	]* OF type(&tp)
 			{ tp2->arr_elem = tp;
@@ -365,8 +364,7 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
 			  }
 			  else	id = nd->nd_IDF;
 			}
-		':' qualident(D_TYPE|D_HTYPE|D_HIDDEN,
+		':' qualident(D_ISTYPE, &df, "type", (struct node **) 0)
-			      &df, "type", (struct node **) 0)
 		|
 			/* Old fashioned! the first qualident now represents
 			   the type
@@ -374,10 +372,10 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
 				{ warning("Old fashioned Modula-2 syntax!");
 				  id = gen_anon_idf();
 				  df = ill_df;
-				  if (chk_designator(nd, 0) &&
+				  if (chk_designator(nd, 0, D_REFERRED) &&
 				      (nd->nd_class != Def ||
 				       !(nd->nd_def->df_kind &
-					 (D_ERROR|D_TYPE|D_HTYPE|D_HIDDEN)))) {
+					 (D_ERROR|D_ISTYPE)))) {
 					node_error(nd, "type expected");
 				  }
 				  else df = nd->nd_def;
@@ -386,7 +384,7 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
 		]
 	|
 		/* Aha, third edition? */
-		':' qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type", (struct node **) 0)
+		':' qualident(D_ISTYPE, &df, "type", (struct node **) 0)
 				{ id = gen_anon_idf(); }
 	]
 				{ tp = df->df_type;
@@ -489,7 +487,7 @@ PointerType(struct type **ptp;)
 		/* Either a Module or a Type, but in both cases defined
 		   in this scope, so this is the correct identification
 		*/
-		qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type", (struct node **) 0)
+		qualident(D_ISTYPE, &df, "type", (struct node **) 0)
 				{
 				  if (!df->df_type) {
 					error("type \"%s\" not declared",
@@ -555,7 +553,7 @@ FormalTypeList(struct paramlist **ppr; struct type **ptp;)
 				{ p->next = 0; }
 	]?
 	')'
-	[ ':' qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type", (struct node **) 0)
+	[ ':' qualident(D_TYPE, &df, "type", (struct node **) 0)
 				{ *ptp = df->df_type; }
 	]?
 ;

lang/m2/comp/def.H

@@ -81,19 +81,21 @@ struct def	{		/* list of definitions for a name */
 #define D_IMPORT	0x0080	/* an imported definition */
 #define D_PROCHEAD	0x0100	/* a procedure heading in a definition module */
 #define D_HIDDEN	0x0200	/* a hidden type */
-#define D_HTYPE		0x0400	/* definition of a hidden type seen */
 #define D_FORWARD	0x0800	/* not yet defined */
 #define D_UNDEF_IMPORT	0x1000	/* imported from an undefined name */
 #define D_FORWMODULE	0x2000	/* module must be declared later */
 #define D_ERROR		0x4000	/* a compiler generated definition for an
 				   undefined variable
 				*/
+#define D_ISTYPE	(D_HIDDEN|D_TYPE)
+#define is_type(dfx)	((dfx)->df_kind & D_ISTYPE)
 	char df_flags;
-#define D_ADDRESS	0x01	/* set if address was taken */
+#define D_NOREG		0x01	/* set if it may not reside in a register */
 #define D_USED		0x02	/* set if used */
 #define D_DEFINED	0x04	/* set if it is assigned a value */
-#define D_VARPAR	0x08	/* set if it is a VAR parameter */
+#define D_REFERRED	0x08	/* set if it is referred to */
-#define D_VALPAR	0x10	/* set if it is a value parameter */
+#define D_VARPAR	0x10	/* set if it is a VAR parameter */
+#define D_VALPAR	0x20	/* set if it is a value parameter */
 #define D_EXPORTED	0x40	/* set if exported */
 #define D_QEXPORTED	0x80	/* set if qualified exported */
 	struct type *df_type;

lang/m2/comp/def.c

@@ -18,6 +18,7 @@ static char *RcsId = "$Header$";
 #include	"scope.h"
 #include	"LLlex.h"
 #include	"node.h"
+#include	"Lpars.h"
 
 struct def *h_def;		/* Pointer to free list of def structures */
 
@@ -80,7 +81,7 @@ define(id, scope, kind)
 		switch(df->df_kind) {
 		case D_HIDDEN:
 			if (kind == D_TYPE && !DefinitionModule) {
-				df->df_kind = D_HTYPE;
+				df->df_kind = D_TYPE;
 				return df;
 			}
 			break;
@@ -94,6 +95,7 @@ define(id, scope, kind)
 				FreeNode(df->for_node);
 				df->mod_vis = df->for_vis;
 				df->df_kind = kind;
+				DefInFront(df);
 				return df;
 			}
 			break;
@@ -241,9 +243,9 @@ df->df_idf->id_text);
 			else if (df1 && df1->df_kind == D_HIDDEN) {
 				if (df->df_kind == D_TYPE) {
 					if (df->df_type->tp_fund != T_POINTER) {
-error("Opaque type \"%s\" is not a pointer type", df->df_idf->id_text);
+error("opaque type \"%s\" is not a pointer type", df->df_idf->id_text);
 					}
-					df->df_kind = D_HTYPE;
+					df->df_kind = D_TYPE;
 					df1->df_kind = D_IMPORT;
 					df1->imp_def = df;
 					continue;
@@ -436,8 +438,10 @@ DeclProc(type)
 		module. Create a def structure for it (if neccessary)
 	*/
 	register struct def *df;
-	extern char *sprint(), *Malloc(), *strcpy();
 	static int nmcount = 0;
+	extern char *Malloc();
+	extern char *strcpy();
+	extern char *sprint();
 	char buf[256];
 
 	assert(type & (D_PROCEDURE | D_PROCHEAD));
@@ -462,6 +466,7 @@ DeclProc(type)
 			open_scope(OPENSCOPE);
 			CurrentScope->sc_name = df->for_name;
 			df->prc_vis = CurrVis;
+			DefInFront(df);
 		}
 		else {
 			df = define(dot.TOK_IDF, CurrentScope, type);
@@ -492,6 +497,46 @@ InitProc(nd, df)
 	/* Keep it this way, or really create a procedure out of it??? */
 }
 
+AddModule(id)
+	struct idf *id;
+{
+	/*	Add the name of a module to the Module list. This list is
+		maintained to create the initialization routine of the
+		program/implementation module currently defined.
+	*/
+	static struct node *nd_end;	/* to remember end of list */
+	register struct node *n;
+	extern struct node *Modules;
+
+	n = MkNode(Name, NULLNODE, NULLNODE, &dot);
+	n->nd_IDF = id;
+	n->nd_symb = IDENT;
+	if (nd_end) nd_end->next = n;
+	nd_end = n;
+	if (!Modules) Modules = n;
+}
+
+DefInFront(df)
+	register struct def *df;
+{
+	/*	Put definition "df" in front of the list of definitions
+		in its scope.
+		This is neccessary because in some cases the order in this
+		list is important.
+	*/
+	register struct def *df1;
+
+	if (df->df_scope->sc_def != df) {
+		df1 = df->df_scope->sc_def;
+		while (df1 && df1->df_nextinscope != df) {
+			df1 = df1->df_nextinscope;
+		}
+		if (df1) df1->df_nextinscope = df->df_nextinscope;
+		df->df_nextinscope = df->df_scope->sc_def;
+		df->df_scope->sc_def = df;
+	}
+}
+
 #ifdef DEBUG
 PrDef(df)
 	register struct def *df;

lang/m2/comp/defmodule.c

@@ -52,7 +52,9 @@ GetDefinitionModule(id)
 		We may have to read the definition module itself.
 	*/
 	struct def *df;
+	static int level;
 
+	level++;
 	df = lookup(id, GlobalScope);
 	if (!df) {
 		/* Read definition module. Make an exception for SYSTEM.
@@ -63,10 +65,19 @@ GetDefinitionModule(id)
 		else {
 			GetFile(id->id_text);
 			DefModule();
+			if (level == 1) {
+				/* The module is directly imported by the
+				   currently defined module, so we have to
+				   remember its name because we have to call
+				   its initialization routine
+				*/
+				AddModule(id);
+			}
 		}
 		df = lookup(id, GlobalScope);
 	}
 	assert(df != 0 && df->df_kind == D_MODULE);
+	level--;
 	return df;
 }
 

lang/m2/comp/desig.c

@@ -232,6 +232,7 @@ CodeVarDesig(df, ds)
 		CodeConst(df->var_off, pointer_size);
 		ds->dsg_kind = DSG_PLOADED;
 		ds->dsg_offset = 0;
+		df->df_flags |= D_NOREG;
 		return;
 	}
 
@@ -242,6 +243,7 @@ CodeVarDesig(df, ds)
 		ds->dsg_name = df->var_name;
 		ds->dsg_offset = 0;
 		ds->dsg_kind = DSG_FIXED;
+		df->df_flags |= D_NOREG;
 		return;
 	}
 	
@@ -254,6 +256,7 @@ CodeVarDesig(df, ds)
 		ds->dsg_name = &(sc->sc_name[1]);
 		ds->dsg_offset = df->var_off;
 		ds->dsg_kind = DSG_FIXED;
+		df->df_flags |= D_NOREG;
 		return;
 	}
 
@@ -278,6 +281,7 @@ CodeVarDesig(df, ds)
 		else	C_lxl((arith) (proclevel - sc->sc_level));
 		ds->dsg_kind = DSG_PLOADED;
 		ds->dsg_offset = df->var_off;
+		df->df_flags |= D_NOREG;
 		return;
 	}
 
@@ -304,6 +308,7 @@ CodeDesig(nd, ds)
 	case Def: {
 		register struct def *df = nd->nd_def;
 
+		df->df_flags |= D_USED;
 		switch(df->df_kind) {
 		case D_FIELD:
 			CodeFieldDesig(df, ds);
@@ -335,14 +340,16 @@ CodeDesig(nd, ds)
 		*ds = InitDesig;
 		CodeExpr(nd->nd_right, ds, NO_LABEL, NO_LABEL);
 		CodeValue(ds, nd->nd_right->nd_type->tp_size);
-		CodeCoercion(nd->nd_right->nd_type, int_type);
+		if (nd->nd_right->nd_type->tp_size > word_size) {
+			CodeCoercion(nd->nd_right->nd_type, int_type);
+		}
 		if (IsConformantArray(nd->nd_left->nd_type)) {
 			/* ??? */
 		}
 		else	{
 			/* load address of descriptor
 			*/
-			/* ??? */
+			C_lae_dlb(nd->nd_left->nd_type->arr_descr, (arith) 0);
 		}
 		ds->dsg_kind = DSG_INDEXED;
 		break;

lang/m2/comp/enter.c

@@ -67,27 +67,23 @@ EnterIdList(idlist, kind, flags, type, scope, addr)
 			int xalign = type->tp_align;
 
 			if (xalign < word_align && kind != D_FIELD) {
+				/* variables are at least word aligned
+				*/
 				xalign = word_align;
 			}
 
 			if (*addr >= 0) {
-				if (scope->sc_level) {
+				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
 					*/
-					off = *addr;
+					xalign = word_align;
-					*addr = align(off, word_align);
-				}
-				else {
-					/* for global variables we can honour
-					   the alignment requirements totally.
-					*/
-					off = align(*addr, xalign);
-					*addr = off + type->tp_size;
 				}
+				off = align(*addr, xalign);
+				*addr = off + type->tp_size;
 			}
 			else {
 				off = -align(-*addr-type->tp_size, xalign);

lang/m2/comp/expression.g

@@ -25,6 +25,7 @@ number(struct node **p;)
 	struct type *tp;
 } :
 [
+	%default
 	INTEGER		{ tp = numtype; }
 |
 	REAL		{ tp = real_type; }
@@ -46,7 +47,7 @@ qualident(int types; struct def **pdf; char *str; struct node **p;)
 			{ if (types) {
 				df = ill_df;
 
-				if (chk_designator(nd, 0)) {
+				if (chk_designator(nd, 0, D_REFERRED)) {
 				    if (nd->nd_class != Def) {
 					node_error(nd, "%s expected", str);
 				    }
@@ -113,9 +114,7 @@ expression(struct node **pnd;)
 	SimpleExpression(pnd)
 	[
 		/* relation */
-		[ '=' | '#' | UNEQUAL | '<' | LESSEQUAL | '>' |
+		[ '=' | '#' | '<' | LESSEQUAL | '>' | GREATEREQUAL | IN ]
-		  GREATEREQUAL | IN
-		]
 			{ *pnd = MkNode(Oper, *pnd, NULLNODE, &dot); }
 		SimpleExpression(&((*pnd)->nd_right))
 	]?
@@ -123,7 +122,7 @@ expression(struct node **pnd;)
 
 /* Inline in expression
 relation:
-	'=' | '#' | UNEQUAL | '<' | LESSEQUAL | '>' | GREATEREQUAL | IN
+	'=' | '#' | '<' | LESSEQUAL | '>' | GREATEREQUAL | IN
 ;
 */
 
@@ -184,9 +183,7 @@ factor(struct node **p;)
 		]?
 	|
 		bare_set(&nd)
-			{ nd->nd_left = *p;
+			{ nd->nd_left = *p; *p = nd; }
-			  *p = nd;
-			}
 	]
 |
 	bare_set(p)
@@ -200,9 +197,9 @@ factor(struct node **p;)
 
 			tp = charc_type;
 			i = *(dot.TOK_STR) & 0377;
-			free((char *) dot.tk_data.tk_str);
 			free(dot.TOK_STR);
-			dot.TOK_INT = i;
+			free((char *) dot.tk_data.tk_str);
+			(*p)->nd_INT = i;
 		  }
 		  else	tp = standard_type(T_STRING, 1, dot.TOK_SLE);
 		  (*p)->nd_type = tp;

lang/m2/comp/main.c

@@ -23,13 +23,14 @@ static char *RcsId = "$Header$";
 #include	"tokenname.h"
 #include	"node.h"
 
+int	state;			/* either IMPLEMENTATION or PROGRAM */
 char	options[128];
 int	DefinitionModule; 
 int	SYSTEMModule = 0;
 char	*ProgName;
-extern int err_occurred;
 char	*DEFPATH[NDIRS+1];
 struct def *Defined;
+extern int err_occurred;
 
 main(argc, argv)
 	char *argv[];
@@ -93,6 +94,7 @@ Compile(src, dst)
 	C_magic();
 	C_ms_emx(word_size, pointer_size);
 	CompUnit();
+	close_scope(SC_REVERSE);
 	if (err_occurred) {
 		C_close();
 		return 0;

lang/m2/comp/main.h

@@ -17,3 +17,4 @@ extern struct def *Defined;
 			   compilation
 			*/
 extern char *DEFPATH[];	/* search path for DEFINITION MODULE's */
+extern int state;	/* either IMPLEMENTATION or PROGRAM */

lang/m2/comp/node.c

@@ -31,7 +31,7 @@ MkNode(class, left, right, token)
 	nd->nd_right = right;
 	nd->nd_token = *token;
 	nd->nd_class = class;
-	nd->nd_type = NULLTYPE;
+	nd->nd_type = error_type;
 	DO_DEBUG(4,(debug("Create node:"), PrNode(nd)));
 	return nd;
 }

lang/m2/comp/program.g

@@ -231,7 +231,7 @@ Semicolon:
 			{ warning("; expected"); }
 ;
 
-ProgramModule(int state;)
+ProgramModule
 {
 	struct idf *id;
 	struct def *GetDefinitionModule();
@@ -267,16 +267,15 @@ ProgramModule(int state;)
 	'.'
 ;
 
-Module
+Module:
-{
-	int state = PROGRAM;
-} :
 	DefinitionModule
 |
 	[
 		IMPLEMENTATION	{ state = IMPLEMENTATION; }
-	]?
+	|
-	ProgramModule(state)
+				{ state = PROGRAM; }
+	]
+	ProgramModule
 ;
 
 CompilationUnit:

lang/m2/comp/scope.C

@@ -166,7 +166,7 @@ rem_forwards(fo)
 
 	while (f = fo) {
 		df = lookfor(&(f->fo_tok), CurrVis, 1);
-		if (!(df->df_kind & (D_TYPE|D_HTYPE|D_ERROR))) {
+		if (!(df->df_kind & (D_TYPE|D_ERROR))) {
 			node_error(&(f->fo_tok), "identifier \"%s\" not a type",
 			      df->df_idf->id_text);
 		}

lang/m2/comp/tokenname.c

@@ -24,7 +24,6 @@ struct tokenname tkspec[] =	{	/* the names of the special tokens */
 };
 
 struct tokenname tkcomp[] =	{	/* names of the composite tokens */
-	{UNEQUAL, "<>"},
 	{LESSEQUAL, "<="},
 	{GREATEREQUAL, ">="},
 	{UPTO, ".."},

lang/m2/comp/type.H

@@ -16,7 +16,7 @@ struct enume {
 	label en_rck;		/* Label of range check descriptor */
 #define enm_enums	tp_value.tp_enum.en_enums
 #define enm_ncst	tp_value.tp_enum.en_ncst
-#define enm_rck		tp_value.tp_enum.enm_rck
+#define enm_rck		tp_value.tp_enum.en_rck
 };
 
 struct subrange {
@@ -68,9 +68,10 @@ struct type	{
 #define T_ARRAY		0x2000
 #define T_STRING	0x4000
 #define T_INTORCARD	(T_INTEGER|T_CARDINAL)
-#define T_DISCRETE	(T_ENUMERATION|T_INTORCARD|T_CHAR)
 #define T_NUMERIC	(T_INTORCARD|T_REAL)
 #define T_INDEX		(T_ENUMERATION|T_CHAR|T_SUBRANGE)
+#define T_DISCRETE	(T_INDEX|T_INTORCARD)
+#define T_PRCRESULT	(T_DISCRETE|T_REAL|T_POINTER|T_WORD)
 	int tp_align;		/* alignment requirement of this type */
 	arith tp_size;		/* size of this type */
 	union {
@@ -131,3 +132,7 @@ struct type
 #define NULLTYPE ((struct type *) 0)
 
 #define IsConformantArray(tpx)	((tpx)->tp_fund == T_ARRAY && (tpx)->next == 0)
+#define bounded(tpx)	((tpx)->tp_fund & T_INDEX)
+#define complex(tpx)	((tpx)->tp_fund & (T_RECORD|T_ARRAY))
+#define returntype(tpx)	(((tpx)->tp_fund & T_PRCRESULT) ||\
+		((tpx)->tp_fund == T_SET && (tpx)->tp_size <= dword_size))

lang/m2/comp/type.c

@@ -61,6 +61,8 @@ struct paramlist *h_paramlist;
 
 struct type *h_type;
 
+extern label	data_label();
+
 struct type *
 create_type(fund)
 	register int fund;
@@ -117,7 +119,7 @@ construct_type(fund, tp)
 		break;
 
 	default:
-		assert(0);
+		crash("funny type constructor");
 	}
 
 	return dtp;
@@ -325,6 +327,52 @@ subr_type(lb, ub)
 	return res;
 }
 
+label
+getrck(tp)
+	register struct type *tp;
+{
+	/*	generate a range check descriptor for type "tp" when
+		neccessary. Return its label
+	*/
+
+	assert(bounded(tp));
+
+	if (tp->tp_fund == T_SUBRANGE) {
+		if (tp->sub_rck == (label) 0) {
+			tp->sub_rck = data_label();
+			C_df_dlb(tp->sub_rck);
+			C_rom_cst(tp->sub_lb);
+			C_rom_cst(tp->sub_ub);
+		}
+		return tp->sub_rck;
+	}
+	if (tp->enm_rck == (label) 0) {
+		tp->enm_rck = data_label();
+		C_df_dlb(tp->enm_rck);
+		C_rom_cst((arith) 0);
+		C_rom_cst((arith) (tp->enm_ncst - 1));
+	}
+	return tp->enm_rck;
+}
+
+getbounds(tp, plo, phi)
+	register struct type *tp;
+	arith *plo, *phi;
+{
+	/*	Get the bounds of a bounded type
+	*/
+
+	assert(bounded(tp));
+
+	if (tp->tp_fund == T_SUBRANGE) {
+		*plo = tp->sub_lb;
+		*phi = tp->sub_ub;
+	}
+	else {
+		*plo = 0;
+		*phi = tp->enm_ncst - 1;
+	}
+}
 struct type *
 set_type(tp)
 	struct type *tp;
@@ -385,18 +433,30 @@ ArraySizes(tp)
 
 	/* find out HIGH, LOW and size of ARRAY
 	*/
+	tp->arr_descr = data_label();
+	C_df_dlb(tp->arr_descr);
+
 	switch(index_type->tp_fund) {
 	case T_SUBRANGE:
 		tp->tp_size = elem_size *
 			(index_type->sub_ub - index_type->sub_lb + 1);
+		C_rom_cst(index_type->sub_lb);
+		C_rom_cst(index_type->sub_ub - index_type->sub_lb);
 		break;
+
 	case T_CHAR:
 	case T_ENUMERATION:
 		tp->tp_size = elem_size * index_type->enm_ncst;
+		C_rom_cst((arith) 0);
+		C_rom_cst((arith) (index_type->enm_ncst - 1));
 		break;
+
 	default:
-		assert(0);
+		crash("Funny index type");
 	}
+	
+	C_rom_cst(elem_size);
+
 	/* ??? overflow checking ???
 	*/
 }

lang/m2/comp/walk.c

@@ -23,14 +23,17 @@ static char *RcsId = "$Header$";
 #include	"Lpars.h"
 #include	"desig.h"
 #include	"f_info.h"
+#include	"idf.h"
 
 extern arith	align();
 extern arith	NewPtr();
+extern arith	NewInt();
 extern int	proclevel;
 static label	instructionlabel;
 static char	return_expr_occurred;
 static struct type *func_type;
 struct withdesig *WithDesigs;
+struct node	*Modules;
 
 label
 text_label()
@@ -88,7 +91,9 @@ WalkModule(module)
 		/* WHY ??? because we generated an INA for it ??? */
 
 		C_df_dnam(&(sc->sc_name[1]));
+		size = align(size, word_align);
 		C_bss_cst(size, (arith) 0, 0);
+		C_exp(sc->sc_name);
 	}
 	else if (CurrVis == Defined->mod_vis) {
 		/* This module is the module currently being compiled.
@@ -98,10 +103,14 @@ WalkModule(module)
 		while (df) {
 			if (df->df_kind == D_VARIABLE) {
 				C_df_dnam(df->var_name);
-				C_bss_cst(df->df_type->tp_size, (arith) 0, 0);
+				C_bss_cst(
+					align(df->df_type->tp_size, word_align),
+					(arith) 0, 0);
 			}
 			df = df->df_nextinscope;
 		}
+		if (state == PROGRAM) C_exp("main");
+		else C_exp(sc->sc_name);
 	}
 
 	/* Now, walk through it's local definitions
@@ -115,26 +124,55 @@ WalkModule(module)
 	sc->sc_off = 0;
 	instructionlabel = 2;
 	func_type = 0;
-	C_pro_narg(sc->sc_name);
+	C_pro_narg(state == PROGRAM ? "main" : sc->sc_name);
 	DoProfil();
+	if (CurrVis == Defined->mod_vis) {
+		/* Body of implementation or program module.
+		   Call initialization routines of imported modules.
+		   Also prevent recursive calls of this one.
+		*/
+		label l1 = data_label(), l2 = text_label();
+		struct node *nd;
+
+		/* we don't actually prevent recursive calls, but do nothing
+		   if called recursively
+		*/
+		C_df_dlb(l1);
+		C_bss_cst(word_size, (arith) 0, 1);
+		C_loe_dlb(l1, (arith) 0);
+		C_zeq(l2);
+		C_ret((arith) 0);
+		C_df_ilb(l2);
+		C_loc((arith) 1);
+		C_ste_dlb(l1, (arith) 0);
+
+		nd = Modules;
+		while (nd) {
+			C_cal(nd->nd_IDF->id_text);
+			nd = nd->next;
+		}
+	}
 	MkCalls(sc->sc_def);
+	proclevel++;
 	WalkNode(module->mod_body, (label) 0);
 	C_df_ilb((label) 1);
-	C_ret(0);
+	C_ret((arith) 0);
 	C_end(-sc->sc_off);
+	proclevel--;
 	TmpClose();
 
 	CurrVis = vis;
 }
 
 WalkProcedure(procedure)
-	struct def *procedure;
+	register struct def *procedure;
 {
 	/*	Walk through the definition of a procedure and all its
 		local definitions
 	*/
 	struct scopelist *vis = CurrVis;
 	register struct scope *sc;
+	register struct type *res_type;
 
 	proclevel++;
 	CurrVis = procedure->prc_vis;
@@ -152,16 +190,19 @@ WalkProcedure(procedure)
 	MkCalls(sc->sc_def);
 	return_expr_occurred = 0;
 	instructionlabel = 2;
-	func_type = procedure->df_type->next;
+	func_type = res_type = procedure->df_type->next;
+	if (! returntype(res_type)) {
+		node_error(procedure->prc_body, "illegal result type");
+	}
 	WalkNode(procedure->prc_body, (label) 0);
 	C_df_ilb((label) 1);
-	if (func_type) {
+	if (res_type) {
 		if (! return_expr_occurred) {
 node_error(procedure->prc_body,"function procedure does not return a value");
 		}
-		C_ret((int) align(func_type->tp_size, word_align));
+		C_ret(align(res_type->tp_size, word_align));
 	}
-	else	C_ret(0);
+	else	C_ret((arith) 0);
 	C_end(-sc->sc_off);
 	TmpClose();
 	CurrVis = vis;
@@ -195,6 +236,7 @@ MkCalls(df)
 		if (df->df_kind == D_MODULE) {
 			C_lxl((arith) 0);
 			C_cal(df->mod_vis->sc_scope->sc_name);
+			C_asp(pointer_size);
 		}
 		df = df->df_nextinscope;
 	}
@@ -246,20 +288,8 @@ WalkStat(nd, lab)
 	assert(nd->nd_class == Stat);
 
 	switch(nd->nd_symb) {
-	case BECOMES: {
+	case BECOMES:
-		struct desig ds;
+		DoAssign(nd, left, right, 0);
-
-		WalkExpr(right, NO_LABEL, NO_LABEL);
-		ds = Desig;
-		WalkDesignator(left);	/* May we do it in this order??? */
-
-		if (! TstAssCompat(left->nd_type, right->nd_type)) {
-			node_error(nd, "type incompatibility in assignment");
-			break;
-		}
-
-		CodeAssign(nd, &ds, pds);
-		}
 		break;
 
 	case IF:
@@ -327,8 +357,61 @@ WalkStat(nd, lab)
 		}
 
 	case FOR:
-		/* ??? */
+		{
-		WalkNode(right, lab);
+			arith tmp = 0;
+			struct node *fnd;
+			label l1 = instructionlabel++;
+			label l2 = instructionlabel++;
+			arith incr = 1;
+			arith size;
+
+			assert(left->nd_symb == TO);
+			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;
+				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(incr);
+			CodeDesig(left->nd_left->nd_left, pds);
+			CodeValue(pds, size);
+			C_adi(int_size);
+			*pds = InitDesig;
+			CodeDesig(left->nd_left->nd_left, pds);
+			CodeStore(pds, size);
+			C_df_ilb(l1);
+			*pds = InitDesig;
+			CodeDesig(left->nd_left->nd_left, pds);
+			CodeValue(pds, size);
+			if (tmp) C_lol(tmp); else C_loc(fnd->nd_INT);
+			if (incr > 0) {
+				C_ble(l2);
+			}
+			else	C_bge(l2);
+			if (tmp) FreeInt(tmp);
+		}
 		break;
 
 	case WITH:
@@ -358,7 +441,7 @@ WalkStat(nd, lab)
 				pds->dsg_kind = DSG_PFIXED;
 				/* the record is indirectly available */
 			}
-			wds.w_desig = Desig;
+			wds.w_desig = *pds;
 			link.sc_scope = wds.w_scope;
 			link.next = CurrVis;
 			CurrVis = &link;
@@ -432,10 +515,47 @@ WalkDesignator(nd)
 
 	DO_DEBUG(1, (DumpTree(nd), print("\n")));
 
-	if (! chk_designator(nd, DESIGNATOR|VARIABLE)) return;
+	if (! chk_designator(nd, DESIGNATOR|VARIABLE, D_DEFINED)) return;
 
 	Desig = InitDesig;
 	CodeDesig(nd, &Desig);
+
+}
+
+DoAssign(nd, left, right, forloopass)
+	struct node *nd;
+	register struct node *left, *right;
+{
+		/* May we do it in this order (expression first) ??? */
+	struct desig ds;
+
+	WalkExpr(right, NO_LABEL, NO_LABEL);
+	if (! chk_designator(left, DESIGNATOR|VARIABLE, D_DEFINED)) return;
+
+	if (forloopass) {
+		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;
+	}
+
+	if (complex(right->nd_type)) {
+		CodeAddress(&Desig);
+	}
+	else {
+		CodeValue(&Desig, right->nd_type->tp_size);
+		CheckAssign(left->nd_type, right->nd_type);
+	}
+	ds = Desig;
+	Desig = InitDesig;
+	CodeDesig(left, &Desig);
+
+	CodeAssign(nd, &ds, &Desig);
 }
 
 #ifdef DEBUG