newer version with bug fixes

lang/m2/comp/Makefile

@@ -1,16 +1,16 @@
 # make modula-2 "compiler"
 # $Header$
-EMDIR =		/usr/em
+EMDIR =		/usr/ceriel/em
 MHDIR =		$(EMDIR)/modules/h
 PKGDIR =	$(EMDIR)/modules/pkg
 LIBDIR =	$(EMDIR)/modules/lib
-LLGEN =		$(EMDIR)/util/LLgen/src/LLgen
+LLGEN =		$(EMDIR)/bin/LLgen
 
 INCLUDES = -I$(MHDIR) -I$(EMDIR)/h -I$(PKGDIR)
 
 LSRC =	tokenfile.g program.g declar.g expression.g statement.g
 CC =	cc
-LLGENOPTIONS = -d
+LLGENOPTIONS =
 PROFILE = 
 CFLAGS = $(PROFILE) $(INCLUDES) -DSTATIC=
 LINTFLAGS = -DSTATIC= -DNORCSID
@@ -23,7 +23,7 @@ COBJ =	LLlex.o LLmessage.o char.o error.o main.o \
 	code.o tmpvar.o lookup.o
 OBJ =	$(COBJ) $(LOBJ) Lpars.o
 
-# Keep the next three entries up to date!
+# Keep the next entries up to date!
 GENCFILES=	tokenfile.c \
 	program.c declar.c expression.c statement.c \
 	symbol2str.c char.c Lpars.c casestat.c tmpvar.c scope.c
@@ -32,12 +32,42 @@ GENHFILES=	errout.h\
 	idfsize.h numsize.h strsize.h target_sizes.h debug.h\
 	inputtype.h maxset.h ndir.h density.h\
 	def.h type.h Lpars.h node.h
+HFILES=		LLlex.h\
+	chk_expr.h class.h const.h desig.h f_info.h idf.h\
+	input.h main.h misc.h scope.h standards.h tokenname.h\
+	walk.h $(GENHFILES)
 #
 GENFILES = $(GENGFILES) $(GENCFILES) $(GENHFILES)
-all:
+
-	make hfiles
+all:	Cfiles
-	make LLfiles
+	sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make main ; else sh Resolve main ; fi'
-	make main
+	@rm -f nmclash.o a.out
+
+clean:
+	rm -f $(OBJ) $(GENFILES) LLfiles hfiles Cfiles tab cclash.o cid.o cclash cid
+	(cd .. ; rm -rf Xsrc)
+
+lint:	Cfiles
+	sh -c `if $(CC) nmclash.c > /dev/null 2>&1 ; then make Xlint ; else sh Resolve Xlint ; fi'
+	@rm -f nmclash.o a.out
+
+mkdep:	mkdep.o
+	$(CC) -o mkdep mkdep.o
+
+cclash:	cclash.o
+	$(CC) -o cclash cclash.o
+
+cid:	cid.o
+	$(CC) -o cid cid.o
+
+# entry points not to be used directly
+
+Xlint:
+	lint $(INCLUDES) $(LINTFLAGS) `./sources $(OBJ)`
+
+Cfiles:	hfiles LLfiles $(GENHFILES) $(GENCFILES)
+	./sources $(OBJ) > Cfiles
+	sh -c 'for i in $(HFILES) ; do echo $$i ; done >> Cfiles'
 
 LLfiles:	$(LSRC)
 	$(LLGEN) $(LLGENOPTIONS) $(LSRC)
@@ -47,47 +77,48 @@ hfiles:	Parameters make.hfiles
 	make.hfiles Parameters
 	touch hfiles
 
-main:	$(OBJ) Makefile
+main:	$(OBJ) ../src/Makefile
-	$(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libem_mes.a $(LIBDIR)/libeme.a $(LIBDIR)/input.a $(LIBDIR)/assert.a $(LIBDIR)/alloc.a $(LIBDIR)/malloc.o $(LIBDIR)/libprint.a $(LIBDIR)/libstr.a $(LIBDIR)/libsystem.a -o main
+	$(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libem_mes.a $(LIBDIR)/libemk.a $(LIBDIR)/input.a $(LIBDIR)/assert.a $(LIBDIR)/alloc.a $(LIBDIR)/malloc.o $(LIBDIR)/libprint.a $(LIBDIR)/libstr.a $(LIBDIR)/libsystem.a -o ../src/main
-	size main
+	size ../src/main
-
-clean:
-	rm -f $(OBJ) $(GENFILES) LLfiles hfiles
-
-lint:	LLfiles hfiles
-	lint $(INCLUDES) $(LINTFLAGS) `sources $(OBJ)`
 
 tokenfile.g:	tokenname.c make.tokfile
 	make.tokfile <tokenname.c >tokenfile.g
 
-symbol2str.c:	tokenname.c make.tokcase
+symbol2str.c:	../src/tokenname.c ../src/make.tokcase
-	make.tokcase <tokenname.c >symbol2str.c
+	../src/make.tokcase <../src/tokenname.c >symbol2str.c
 
-def.h:		def.H make.allocd
+def.h:		../src/def.H ../src/make.allocd
-type.h:		type.H make.allocd
+		../src/make.allocd < ../src/def.H > def.h
-node.h:		node.H make.allocd
-scope.c:	scope.C make.allocd
-tmpvar.c:	tmpvar.C make.allocd
-casestat.c:	casestat.C make.allocd
 
-char.c: char.tab tab
+type.h:		../src/type.H ../src/make.allocd
-	./tab -fchar.tab >char.c
+		../src/make.allocd < ../src/type.H > type.h
 
-tab: 
+node.h:		../src/node.H ../src/make.allocd
-	$(CC) tab.c -o tab
+		../src/make.allocd < ../src/node.H > node.h
 
-depend:
+scope.c:	../src/scope.C ../src/make.allocd
+		../src/make.allocd < ../src/scope.C > scope.c
+
+tmpvar.c:	../src/tmpvar.C ../src/make.allocd
+		../src/make.allocd < ../src/tmpvar.C > tmpvar.c
+
+casestat.c:	../src/casestat.C ../src/make.allocd
+		../src/make.allocd < ../src/casestat.C > casestat.c
+
+char.c: ../src/char.tab ../src/tab
+	../src/tab -fchar.tab >char.c
+
+../src/tab: 
+	$(CC) ../src/tab.c -o ../src/tab
+
+depend:	mkdep
 	sed '/^#AUTOAUTO/,$$d' Makefile > Makefile.new
 	echo '#AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO' >> Makefile.new
-	/user1/erikb/bin/mkdep `sources $(OBJ)` |\
+	./mkdep `./sources $(OBJ)` |\
 		sed 's/\.c:/\.o:/' >> Makefile.new
 	mv Makefile Makefile.old
 	mv Makefile.new Makefile
 
-.SUFFIXES:	.H .h .C
-.H.h .C.c :
-	make.allocd < $< > $@
-
 #AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO
 LLlex.o: LLlex.h Lpars.h class.h const.h debug.h f_info.h idf.h idfsize.h input.h inputtype.h numsize.h strsize.h type.h
 LLmessage.o: LLlex.h Lpars.h idf.h
@@ -116,7 +147,7 @@ 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 main.h scope.h type.h
 lookup.o: LLlex.h debug.h def.h idf.h node.h scope.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
+program.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h main.h node.h scope.h type.h
 declar.o: LLlex.h Lpars.h chk_expr.h debug.h def.h idf.h main.h misc.h node.h scope.h type.h
 expression.o: LLlex.h Lpars.h chk_expr.h const.h debug.h def.h idf.h node.h type.h
 statement.o: LLlex.h Lpars.h def.h idf.h node.h scope.h type.h

lang/m2/comp/Parameters

@@ -5,7 +5,7 @@
 
 
 !File: idfsize.h
-#define	IDFSIZE	30	/* maximum significant length of an identifier	*/
+#define	IDFSIZE	128	/* maximum significant length of an identifier	*/
 
 
 !File: numsize.h

lang/m2/comp/chk_expr.c

@@ -132,6 +132,8 @@ ChkLinkOrName(expp)
 {
 	register struct def *df;
 
+	expp->nd_type = error_type;
+
 	if (expp->nd_class == Name) {
 		expp->nd_def = lookfor(expp, CurrVis, 1);
 		expp->nd_class = Def;
@@ -183,7 +185,7 @@ df->df_idf->id_text);
 	assert(expp->nd_class == Def);
 
 	df = expp->nd_def;
-	if (df == ill_df) return 0;
+	if (df->df_kind == D_ERROR) return 0;
 
 	if (df->df_kind & (D_ENUM | D_CONST)) {
 		if (df->df_kind == D_ENUM) {
@@ -855,7 +857,7 @@ ChkStandard(expp, left)
 	case S_MIN:
 		if (!(left = getname(&arg, D_ISTYPE))) return 0;
 		if (!(left->nd_type->tp_fund & (T_DISCRETE))) {
-			node_error(left, "illegal type in MIN or MAX");
+node_error(left, "illegal type in %s", std == S_MAX ? "MAX" : "MIN");
 			return 0;
 		}
 		expp->nd_type = left->nd_type;
@@ -961,7 +963,7 @@ ChkStandard(expp, left)
 		expp->nd_type = 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");
+node_error(left,"illegal type in argument of %s",std == S_INC ? "INC" : "DEC");
 			return 0;
 		}
 		if (arg->nd_right) {
@@ -982,7 +984,7 @@ node_error(left, "illegal type in argument of INC or DEC");
 		if (!(left = getvariable(&arg))) return 0;
 		tp = left->nd_type;
 		if (tp->tp_fund != T_SET) {
-node_error(arg, "EXCL and INCL expect a SET parameter");
+node_error(arg, "%s expects a SET parameter", std == S_EXCL ? "EXCL" : "INCL");
 			return 0;
 		}
 		if (!(left = getarg(&arg, T_DISCRETE, 0))) return 0;

lang/m2/comp/code.c

@@ -201,7 +201,6 @@ 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) {
@@ -232,11 +231,13 @@ CodeCoercion(t1, t2)
 	case T_CHAR:
 	case T_ENUMERATION:
 	case T_CARDINAL:
+	case T_INTORCARD:
 		switch(fund2) {
 		case T_ENUMERATION:
 		case T_CHAR:
 		case T_CARDINAL:
 		case T_POINTER:
+		case T_INTORCARD:
 			if (t2->tp_size > word_size) {
 				C_loc(word_size);
 				C_loc(t2->tp_size);
@@ -313,16 +314,25 @@ CodeCall(nd)
 		CodeParameters(ParamList(left->nd_type), nd->nd_right);
 	}
 
-	if (left->nd_class == Def && left->nd_def->df_kind == D_PROCEDURE) {
+	switch(left->nd_class) {
-		if (left->nd_def->df_scope->sc_level > 0) {
+	case Def: {
-			C_lxl((arith) proclevel - left->nd_def->df_scope->sc_level);
+		register struct def *df = left->nd_def;
+
+		if (df->df_kind == D_PROCEDURE) {
+			arith level = df->df_scope->sc_level;
+
+			if (level > 0) {
+				C_lxl((arith) proclevel - level);
 			}
-		C_cal(NameOfProc(left->nd_def));
+			C_cal(NameOfProc(df));
+			break;
 		}
-	else if (left->nd_class == Def && left->nd_def->df_kind == D_PROCHEAD) {
+		else if (df->df_kind == D_PROCHEAD) {
-		C_cal(left->nd_def->for_name);
+			C_cal(df->for_name);
-	}
+			break;
-	else {
+		}}
+		/* Fall through */
+	default:
 		CodePExpr(left);
 		C_cai();
 	}
@@ -342,6 +352,7 @@ CodeParameters(param, arg)
 {
 	register struct type *tp;
 	register struct node *left;
+	register struct type *left_type;
 	
 	assert(param != 0 && arg != 0);
 
@@ -351,25 +362,31 @@ CodeParameters(param, arg)
 
 	tp = TypeOfParam(param);
 	left = arg->nd_left;
+	left_type = left->nd_type;
 	if (IsConformantArray(tp)) {
 		C_loc(tp->arr_elsize);
-		if (IsConformantArray(left->nd_type)) {
+		if (IsConformantArray(left_type)) {
 			DoHIGH(left);
-			if (tp->arr_elem->tp_size != left->nd_type->arr_elem->tp_size) {
+			if (tp->arr_elem->tp_size !=
+			    left_type->arr_elem->tp_size) {
 				/* This can only happen if the formal type is
 				   ARRAY OF WORD
 				*/
-				/* ??? */
+				assert(tp->arr_elem == word_type);
+				C_loc(left_type->arr_elem->tp_size);
+				C_cal("_wa");
+				C_asp(dword_size);
+				C_lfr(word_size);
 			}
 		}
 		else if (left->nd_symb == STRING) {
 			C_loc(left->nd_SLE);
 		}
 		else if (tp->arr_elem == word_type) {
-			C_loc(left->nd_type->tp_size / word_size - 1);
+			C_loc((left_type->tp_size+word_size-1) / word_size - 1);
 		}
 		else {
-			tp = IndexType(left->nd_type);
+			tp = IndexType(left_type);
 			if (tp->tp_fund == T_SUBRANGE) {
 				C_loc(tp->sub_ub - tp->sub_lb);
 			}
@@ -385,11 +402,11 @@ CodeParameters(param, arg)
 		CodeDAddress(left);
 	}
 	else {
-		if (left->nd_type->tp_fund == T_STRING) {
+		if (left_type->tp_fund == T_STRING) {
 			CodePadString(left, tp->tp_size);
 		}
 		else CodePExpr(left);
-		CheckAssign(left->nd_type, tp);
+		CheckAssign(left_type, tp);
 	}
 }
 
@@ -422,6 +439,7 @@ CodeStd(nd)
 			}
 			else	C_cal("_absd");
 		}
+		C_asp(tp->tp_size);
 		C_lfr(tp->tp_size);
 		break;
 
@@ -447,6 +465,7 @@ CodeStd(nd)
 		break;
 
 	case S_ODD:
+		CodePExpr(left);
 		if (tp->tp_size == word_size) {
 			C_loc((arith) 1);
 			C_and(word_size);
@@ -584,45 +603,39 @@ CheckAssign(tpl, tpr)
 	}
 }
 
-Operands(leftop, rightop)
+Operands(leftop, rightop, tp)
 	register struct node *leftop, *rightop;
+	struct type *tp;
 {
 
 	CodePExpr(leftop);
-
+	CodeCoercion(leftop->nd_type, tp);
-	if (rightop->nd_type->tp_fund == T_POINTER && 
-	    leftop->nd_type->tp_size != pointer_size) {
-		CodeCoercion(leftop->nd_type, rightop->nd_type);
-		leftop->nd_type = rightop->nd_type;
-	}
-
 	CodePExpr(rightop);
+	CodeCoercion(rightop->nd_type, tp);
 }
 
 CodeOper(expr, true_label, false_label)
-	struct node *expr;	/* the expression tree itself		*/
+	register struct node *expr;	/* the expression tree itself	*/
 	label true_label;
 	label false_label;	/* labels to jump to in logical expr's	*/
 {
-	register int oper = expr->nd_symb;
 	register struct node *leftop = expr->nd_left;
 	register struct node *rightop = expr->nd_right;
 	register struct type *tp = expr->nd_type;
 
-	switch (oper)	{
+	switch (expr->nd_symb)	{
 	case '+':
-		Operands(leftop, rightop);
+		Operands(leftop, rightop, tp);
 		switch (tp->tp_fund)	{
 		case T_INTEGER:
 			C_adi(tp->tp_size);
 			break;
-		case T_POINTER:
-			C_ads(rightop->nd_type->tp_size);
-			break;
 		case T_REAL:
 			C_adf(tp->tp_size);
 			break;
+		case T_POINTER:
 		case T_CARDINAL:
+		case T_INTORCARD:
 			C_adu(tp->tp_size);
 			break;
 		case T_SET:
@@ -633,24 +646,17 @@ CodeOper(expr, true_label, false_label)
 		}
 		break;
 	case '-':
-		Operands(leftop, rightop);
+		Operands(leftop, rightop, tp);
 		switch (tp->tp_fund)	{
 		case T_INTEGER:
 			C_sbi(tp->tp_size);
 			break;
-		case T_POINTER:
-			if (rightop->nd_type->tp_fund == T_POINTER) {
-				C_sbs(pointer_size);
-			}
-			else	{
-				C_ngi(rightop->nd_type->tp_size);
-				C_ads(rightop->nd_type->tp_size);
-			}
-			break;
 		case T_REAL:
 			C_sbf(tp->tp_size);
 			break;
+		case T_POINTER:
 		case T_CARDINAL:
+		case T_INTORCARD:
 			C_sbu(tp->tp_size);
 			break;
 		case T_SET:
@@ -662,15 +668,14 @@ CodeOper(expr, true_label, false_label)
 		}
 		break;
 	case '*':
-		Operands(leftop, rightop);
+		Operands(leftop, rightop, tp);
 		switch (tp->tp_fund)	{
 		case T_INTEGER:
 			C_mli(tp->tp_size);
 			break;
 		case T_POINTER:
-			CodeCoercion(rightop->nd_type, tp);
-			/* Fall through */
 		case T_CARDINAL:
+		case T_INTORCARD:
 			C_mlu(tp->tp_size);
 			break;
 		case T_REAL:
@@ -684,7 +689,7 @@ CodeOper(expr, true_label, false_label)
 		}
 		break;
 	case '/':
-		Operands(leftop, rightop);
+		Operands(leftop, rightop, tp);
 		switch (tp->tp_fund)	{
 		case T_REAL:
 			C_dvf(tp->tp_size);
@@ -697,15 +702,14 @@ CodeOper(expr, true_label, false_label)
 		}
 		break;
 	case DIV:
-		Operands(leftop, rightop);
+		Operands(leftop, rightop, tp);
 		switch(tp->tp_fund)	{
 		case T_INTEGER:
 			C_dvi(tp->tp_size);
 			break;
 		case T_POINTER:
-			CodeCoercion(rightop->nd_type, tp);
-			/* Fall through */
 		case T_CARDINAL:
+		case T_INTORCARD:
 			C_dvu(tp->tp_size);
 			break;
 		default:
@@ -713,15 +717,14 @@ CodeOper(expr, true_label, false_label)
 		}
 		break;
 	case MOD:
-		Operands(leftop, rightop);
+		Operands(leftop, rightop, tp);
 		switch(tp->tp_fund)	{
 		case T_INTEGER:
 			C_rmi(tp->tp_size);
 			break;
 		case T_POINTER:
-			CodeCoercion(rightop->nd_type, tp);
-			/* Fall through */
 		case T_CARDINAL:
+		case T_INTORCARD:
 			C_rmu(tp->tp_size);
 			break;
 		default:
@@ -734,18 +737,17 @@ CodeOper(expr, true_label, false_label)
 	case GREATEREQUAL:
 	case '=':
 	case '#':
-		Operands(leftop, rightop);
+		tp = BaseType(leftop->nd_type);
-		CodeCoercion(rightop->nd_type, leftop->nd_type);
+		if (tp == intorcard_type) tp = BaseType(rightop->nd_type);
-		tp = BaseType(leftop->nd_type);	/* Not the result type! */
+		Operands(leftop, rightop, tp);
 		switch (tp->tp_fund)	{
 		case T_INTEGER:
 			C_cmi(tp->tp_size);
 			break;
 		case T_HIDDEN:
 		case T_POINTER:
-			C_cmp();
-			break;
 		case T_CARDINAL:
+		case T_INTORCARD:
 			C_cmu(tp->tp_size);
 			break;
 		case T_ENUMERATION:
@@ -756,19 +758,18 @@ CodeOper(expr, true_label, false_label)
 			C_cmf(tp->tp_size);
 			break;
 		case T_SET:
-			if (oper == GREATEREQUAL) {
+			if (expr->nd_symb == 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);
+				C_ior(tp->tp_size);
 			}
-			else if (oper == LESSEQUAL) {
+			else if (expr->nd_symb == 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_zer(tp->tp_size);
 			}
 			C_cms(tp->tp_size);
@@ -777,11 +778,11 @@ CodeOper(expr, true_label, false_label)
 			crash("bad type COMPARE");
 		}
 		if (true_label != 0)	{
-			compare(oper, true_label);
+			compare(expr->nd_symb, true_label);
 			C_bra(false_label);
 		}
 		else	{
-			truthvalue(oper);
+			truthvalue(expr->nd_symb);
 		}
 		break;
 	case IN:
@@ -789,7 +790,8 @@ CodeOper(expr, true_label, false_label)
 		   INN instruction expects the bit number on top of the
 		   stack
 		*/
-		Operands(rightop, leftop);
+		CodePExpr(rightop);
+		CodePExpr(leftop);
 		CodeCoercion(leftop->nd_type, word_type);
 		C_inn(rightop->nd_type->tp_size);
 		if (true_label != 0) {
@@ -798,19 +800,26 @@ CodeOper(expr, true_label, false_label)
 		}
 		break;
 	case AND:
-	case '&':
+	case '&': {
-		if (true_label == 0)	{
+		label l_true, l_false, l_maybe = ++text_label, l_end;
-			label l_true = ++text_label;
-			label l_false = ++text_label;
-			label l_maybe = ++text_label;
-			label l_end = ++text_label;
 		struct desig Des;
 
+		if (true_label == 0)	{
+			l_true = ++text_label;
+			l_false = ++text_label;
+			l_end = ++text_label;
+		}
+		else {
+			l_true = true_label;
+			l_false = false_label;
+		}
+
 		Des = InitDesig;
 		CodeExpr(leftop, &Des, l_maybe, l_false);
 		C_df_ilb(l_maybe);
 		Des = InitDesig;
 		CodeExpr(rightop, &Des, l_true, l_false);
+		if (true_label == 0) {
 			C_df_ilb(l_true);
 			C_loc((arith)1);
 			C_bra(l_end);
@@ -818,30 +827,27 @@ CodeOper(expr, true_label, false_label)
 			C_loc((arith)0);
 			C_df_ilb(l_end);
 		}
-		else	{
-			label l_maybe = ++text_label;
-			struct desig Des;
-
-			Des = InitDesig;
-			CodeExpr(leftop, &Des, l_maybe, false_label);
-			Des = InitDesig;
-			C_df_ilb(l_maybe);
-			CodeExpr(rightop, &Des, true_label, false_label);
-		}
 		break;
-	case OR:
+		}
-		if (true_label == 0)	{
+	case OR: {
-			label l_true = ++text_label;
+		label l_true, l_false, l_maybe = ++text_label, l_end;
-			label l_false = ++text_label;
-			label l_maybe = ++text_label;
-			label l_end = ++text_label;
 		struct desig Des;
 
+		if (true_label == 0)	{
+			l_true = ++text_label;
+			l_false = ++text_label;
+			l_end = ++text_label;
+		}
+		else {
+			l_true = true_label;
+			l_false = false_label;
+		}
 		Des = InitDesig;
 		CodeExpr(leftop, &Des, l_true, l_maybe);
 		C_df_ilb(l_maybe);
 		Des = InitDesig;
 		CodeExpr(rightop, &Des, l_true, l_false);
+		if (true_label == 0) {
 			C_df_ilb(l_false);
 			C_loc((arith)0);
 			C_bra(l_end);
@@ -849,19 +855,10 @@ CodeOper(expr, true_label, false_label)
 			C_loc((arith)1);
 			C_df_ilb(l_end);
 		}
-		else	{
-			label l_maybe = ++text_label;
-			struct desig Des;
-
-			Des = InitDesig;
-			CodeExpr(leftop, &Des, true_label, l_maybe);
-			C_df_ilb(l_maybe);
-			Des = InitDesig;
-			CodeExpr(rightop, &Des, true_label, false_label);
-		}
 		break;
+		}
 	default:
-		crash("(CodeOper) Bad operator %s\n", symbol2str(oper));
+		crash("(CodeOper) Bad operator %s\n",symbol2str(expr->nd_symb));
 	}
 }
 
@@ -936,6 +933,7 @@ CodeUoper(nd)
 	case '-':
 		switch(tp->tp_fund) {
 		case T_INTEGER:
+		case T_INTORCARD:
 			C_ngi(tp->tp_size);
 			break;
 		case T_REAL:
@@ -977,7 +975,7 @@ CodeEl(nd, tp)
 			C_loc(eltype->sub_ub);
 		}
 		else	C_loc((arith) (eltype->enm_ncst - 1));
-		Operands(nd->nd_left, nd->nd_right);
+		Operands(nd->nd_left, nd->nd_right, word_type);
 		C_cal("_LtoUset");	/* library routine to fill set */
 		C_asp(4 * word_size);
 	}
@@ -1032,13 +1030,20 @@ CodeDStore(nd)
 DoHIGH(nd)
 	struct node *nd;
 {
+	/*	Get the high index of a conformant array, indicated by "nd".
+		The high index is the second field in the descriptor of
+		the array, so it is easily found.
+	*/
 	register struct def *df = nd->nd_def;
 	register arith highoff;
 
 	assert(nd->nd_class == Def);
 	assert(df->df_kind == D_VARIABLE);
+	assert(IsConformantArray(df->df_type));
 
-	highoff = df->var_off + pointer_size + word_size;
+	highoff = df->var_off		/* base address and descriptor */
+		  + pointer_size	/* skip base address */
+		  + word_size;		/* skip first field of descriptor */
 	if (df->df_scope->sc_level < proclevel) {
 		C_lxa((arith) (proclevel - df->df_scope->sc_level));
 		C_lof(highoff);

lang/m2/comp/cstoper.c

@@ -248,6 +248,7 @@ cstset(expp)
 		assert(expp->nd_left->nd_class == Value);
 
 		i = expp->nd_left->nd_INT;
+		expp->nd_class = Value;
 		expp->nd_INT = (i >= 0 && set2 != 0 &&
 		    i < setsize * wrd_bits &&
 		    (set2[i / wrd_bits] & (1 << (i % wrd_bits))));

lang/m2/comp/declar.g

@@ -108,9 +108,7 @@ declaration:
 FormalParameters(struct paramlist **pr;
 		 struct type **ptp;
 		 arith *parmaddr;)
-{
+:	
-	struct def *df;
-} :
 	'('
 	[
 		FPSection(pr, parmaddr)
@@ -128,74 +126,38 @@ FPSection(struct paramlist **ppr; arith *parmaddr;)
 	struct node *FPList;
 	struct type *tp;
 	int VARp;
-	struct paramlist *p = 0;
 } :
-	var(&VARp) IdentList(&FPList) ':' FormalType(&p, 0)
+	var(&VARp) IdentList(&FPList) ':' FormalType(&tp)
-			{ EnterParamList(ppr, FPList, p->par_def->df_type,
+			{ EnterParamList(ppr, FPList, tp, VARp, parmaddr); }
-					 VARp, parmaddr);
-			  free_def(p->par_def);
-			  free_paramlist(p);
-			}
 ;
 
-FormalType(struct paramlist **ppr; int VARp;)
+FormalType(struct type **ptp;)
 {
-	register struct def *df;
-	int ARRAYflag;
 	register struct type *tp;
-	struct type *tp1;
-	register struct paramlist *p = new_paramlist();
 	extern arith ArrayElSize();
 } :
-	[ ARRAY OF	{ ARRAYflag = 1; }
+	ARRAY OF qualtype(ptp)
-	|		{ ARRAYflag = 0; }
+		{ tp = construct_type(T_ARRAY, NULLTYPE);
-	]
+		  tp->arr_elem = *ptp; *ptp = tp;
-	qualtype(&tp1)
+		  tp->arr_elsize = ArrayElSize(tp->arr_elem);
-		{ if (ARRAYflag) {
-			tp = construct_type(T_ARRAY, NULLTYPE);
-			tp->arr_elem = tp1;
-			tp->arr_elsize = ArrayElSize(tp1);
 		  tp->tp_align = lcm(word_align, pointer_align);
 		}
-		  else	tp = tp1;
+|
-		  p->next = *ppr;
+	 qualtype(ptp)
-		  *ppr = p;
-		  p->par_def = df = new_def();
-		  df->df_type = tp;
-		  df->df_flags = VARp;
-		}
 ;
 
 TypeDeclaration
 {
-	register struct def *df;
+	struct def *df;
 	struct type *tp;
 }:
 	IDENT		{ df = define(dot.TOK_IDF,CurrentScope,D_TYPE); }
 	'=' type(&tp)
-			{ if (df->df_type && df->df_type->tp_fund == T_HIDDEN) {
+			{ DeclareType(df, tp); }
-			  	if (tp->tp_fund != T_POINTER) {
-error("opaque type \"%s\" is not a pointer type", df->df_idf->id_text);
-				}
-				/* Careful now ... we might have declarations
-				   referring to the hidden type.
-				*/
-				*(df->df_type) = *tp;
-				if (! tp->next) {
-					/* It also contains a forward
-					   reference, so update the forward-
-					   list
-					*/
-					ChForward(tp, df->df_type);
-				}
-				free_type(tp);
-			  }
-			  else	df->df_type = tp;
-			}
 ;
 
 type(struct type **ptp;):
-	SimpleType(ptp)
+	%default SimpleType(ptp)
 |
 	ArrayType(ptp)
 |
@@ -247,7 +209,7 @@ IdentList(struct node **p;)
 	register struct node *q;
 } :
 	IDENT		{ *p = q = MkLeaf(Value, &dot); }
-	[
+	[ %persistent
 		',' IDENT
 			{ q->next = MkLeaf(Value, &dot);
 			  q = q->next;
@@ -460,11 +422,12 @@ PointerType(struct type **ptp;)
 		*/
 		qualtype(&((*ptp)->next))
 	| %if ( nd = new_node(), nd->nd_token = dot,
-		df = lookfor(nd, CurrVis, 0), free_node(nd),
+		df = lookfor(nd, CurrVis, 0),
 	        df->df_kind == D_MODULE)
 		type(&((*ptp)->next)) 
+			{ free_node(nd); }
 	|
-		IDENT	{ Forward(&dot, (*ptp)); }
+		IDENT	{ Forward(nd, (*ptp)); }
 	]
 ;
 
@@ -486,24 +449,28 @@ ProcedureType(struct type **ptp;)
 {
 	struct paramlist *pr = 0;
 	register struct type *tp;
+	arith nbytes = 0;
 } :
 			{ *ptp = 0; }
-	PROCEDURE FormalTypeList(&pr, ptp)?
+	PROCEDURE FormalTypeList(&pr, ptp, &nbytes)?
 			{ *ptp = tp = construct_type(T_PROCEDURE, *ptp);
 			  tp->prc_params = pr;
+			  tp->prc_nbpar = nbytes;
 			}
 ;
 
-FormalTypeList(struct paramlist **ppr; struct type **ptp;)
+FormalTypeList(struct paramlist **ppr; struct type **ptp; arith *parmaddr;)
 {
-	struct def *df;
 	int VARp;
+	struct type *tp;
 } :
 	'('		{ *ppr = 0; }
 	[
-		var(&VARp) FormalType(ppr, VARp)
+		var(&VARp) FormalType(&tp)
+			{ EnterParamList(ppr,NULLNODE,tp,VARp,parmaddr); }
 		[
-			',' var(&VARp) FormalType(ppr, VARp)
+			',' var(&VARp) FormalType(&tp)
+			{ EnterParamList(ppr,NULLNODE,tp,VARp,parmaddr); }
 		]*
 	]?
 	')'
@@ -535,7 +502,7 @@ VariableDeclaration
 } :
 	IdentAddr(&VarList)
 			{ nd = VarList; }
-	[
+	[ %persistent
 		',' IdentAddr(&(nd->nd_right))
 			{ nd = nd->nd_right; }
 	]*

lang/m2/comp/def.c

@@ -290,7 +290,6 @@ DefineLocalModule(id)
 		a name to be used for code generation.
 	*/
 	register struct def *df = define(id, CurrentScope, D_MODULE);
-	register struct type *tp;
 	register struct scope *sc;
 	static int modulecount = 0;
 	char buf[256];
@@ -316,8 +315,8 @@ DefineLocalModule(id)
 
 	/* Create a type for it
 	*/
-	df->df_type = tp = standard_type(T_RECORD, 0, (arith) 0);
+	df->df_type = standard_type(T_RECORD, 0, (arith) 0);
-	tp->rec_scope = sc;
+	df->df_type->rec_scope = sc;
 
 	/* Generate code that indicates that the initialization procedure
 	   for this module is local.

lang/m2/comp/defmodule.c

@@ -74,7 +74,7 @@ GetDefinitionModule(id)
 		}
 		df = lookup(id, GlobalScope);
 	}
-	assert(df != 0 && df->df_kind == D_MODULE);
+	assert(df && df->df_kind == D_MODULE);
 	level--;
 	return df;
 }

lang/m2/comp/enter.c

@@ -168,8 +168,12 @@ EnterParamList(ppr, Idlist, type, VARp, off)
 	register struct paramlist *pr;
 	register struct def *df;
 	register struct node *idlist = Idlist;
+	struct node *dummy = 0;
 	static struct paramlist *last;
 
+	if (! idlist) {
+		dummy = Idlist = idlist = MkLeaf(Name, &dot);
+	}
 	for ( ; idlist; idlist = idlist->next) {
 		pr = new_paramlist();
 		pr->next = 0;
@@ -178,11 +182,17 @@ EnterParamList(ppr, Idlist, type, VARp, off)
 		}
 		else	last->next = pr;
 		last = pr;
+		if (idlist != dummy) {
 			df = define(idlist->nd_IDF, CurrentScope, D_VARIABLE);
+			df->var_off = *off;
+		}
+		else {
+			df = new_def();
+		}
 		pr->par_def = df;
 		df->df_type = type;
-		df->var_off = *off;
 		df->df_flags = VARp;
+
 		if (IsConformantArray(type)) {
 			/* we need room for the base address and a descriptor
 			*/
@@ -347,49 +357,38 @@ node_error(idlist, "opaque type \"%s\" is not a pointer type", df->df_idf->id_te
 	FreeNode(Idlist);
 }
 
-EnterFromImportList(Idlist, Fromid, local)
+EnterFromImportList(Idlist, FromDef)
 	struct node *Idlist;
-	register struct node *Fromid;
+	register struct def *FromDef;
 {
-	/*	Import the list Idlist from the module indicated by Fromid.
+	/*	Import the list Idlist from the module indicated by Fromdef.
-		An exception must be made for imports of the Compilation Unit,
-		because in this case the definition module for Fromid must
-		be read.
-		This case is indicated by  the value 0 of the flag "local".
 	*/
 	register struct node *idlist = Idlist;
+	register struct scopelist *vis;
 	register struct def *df;
-	struct scopelist *vis = enclosing(CurrVis);
 	int forwflag = 0;
-	extern struct def *GetDefinitionModule();
 
-	if (local) {
+	switch(FromDef->df_kind) {
-		df = lookfor(Fromid, vis, 0);
-		switch(df->df_kind) {
 	case D_ERROR:
 		/* The module from which the import was done
 		   is not yet declared. I'm not sure if I must
 		   accept this, but for the time being I will.
 		   ???
 		*/
-			vis = ForwModule(df, Fromid);
+		vis = ForwModule(FromDef, FromDef->df_idf);
 		forwflag = 1;
 		break;
 	case D_FORWMODULE:
-			vis = df->for_vis;
+		vis = FromDef->for_vis;
 		break;
 	case D_MODULE:
-			vis = df->mod_vis;
+		vis = FromDef->mod_vis;
 		break;
 	default:
-node_error(Fromid, "identifier \"%s\" does not represent a module",
+error("identifier \"%s\" does not represent a module",
-Fromid->nd_IDF->id_text);
+FromDef->df_idf->id_text);
 		break;
 	}
-	}
-	else	vis = GetDefinitionModule(Fromid->nd_IDF)->mod_vis;
-
-	FreeNode(Fromid);
 
 	for (; idlist; idlist = idlist->next) {
 		if (forwflag) {

lang/m2/comp/program.g

@@ -18,6 +18,7 @@ static  char *RcsId = "$Header$";
 #include	"def.h"
 #include	"type.h"
 #include	"node.h"
+#include	"f_info.h"
 
 }
 /*
@@ -91,12 +92,22 @@ export(int *QUALflag; struct node **ExportList;)
 import(int local;)
 {
 	struct node *ImportList;
-	register struct node *id;
+	register struct def *df;
+	int fromid;
+	extern struct def *GetDefinitionModule();
 } :
 	[ FROM
-	  IDENT		{ id = MkLeaf(Value, &dot); }
+	  IDENT		{ fromid = 1;
+			  if (local) {
+				struct node *nd = MkLeaf(Name, &dot);
+
+				df = lookfor(nd,enclosing(CurrVis),0);
+				FreeNode(nd);
+			  }
+			  else	df = GetDefinitionModule(dot.TOK_IDF);
+			}
 	|
-			{ id = 0; }
+			{ fromid = 0; }
 	]
 	IMPORT IdentList(&ImportList) ';'
 	/*
@@ -105,7 +116,7 @@ import(int local;)
 	   If the FROM clause is present, the identifier in it is a module
 	   name, otherwise the names in the import list are module names.
 	*/
-			{ if (id) EnterFromImportList(ImportList, id, local);
+			{ if (fromid) EnterFromImportList(ImportList, df);
 			  else EnterImportList(ImportList, local);
 			}
 ;

lang/m2/comp/scope.C

@@ -67,14 +67,14 @@ InitScope()
 
 struct forwards {
 	struct forwards *next;
-	struct node fo_tok;
+	struct node *fo_tok;
 	struct type *fo_ptyp;
 };
 
 /* STATICALLOCDEF "forwards" */
 
 Forward(tk, ptp)
-	struct token *tk;
+	struct node *tk;
 	struct type *ptp;
 {
 	/*	Enter a forward reference into a list belonging to the
@@ -84,7 +84,7 @@ Forward(tk, ptp)
 	*/
 	register struct forwards *f = new_forwards();
 
-	f->fo_tok.nd_token = *tk;
+	f->fo_tok = tk;
 	f->fo_ptyp = ptp;
 	f->next = CurrentScope->sc_forw;
 	CurrentScope->sc_forw = f;
@@ -168,23 +168,24 @@ node_error((*pdf)->for_node, "identifier \"%s\" has not been declared",
 
 STATIC
 rem_forwards(fo)
-	struct forwards *fo;
+	register struct forwards *fo;
 {
 	/*	When closing a scope, all forward references must be resolved
 	*/
-	register struct forwards *f;
 	register struct def *df;
 
-	while (f = fo) {
+	if (fo->next) rem_forwards(fo->next);
-		df = lookfor(&(f->fo_tok), CurrVis, 1);
+	df = lookfor(fo->fo_tok, CurrVis, 0);
-		if (!(df->df_kind & (D_TYPE|D_ERROR))) {
+	if (df->df_kind == D_ERROR) {
-			node_error(&(f->fo_tok), "identifier \"%s\" not a type",
+		node_error(fo->fo_tok, "identifier \"%s\" not declared",
 			df->df_idf->id_text);
 	}
-		f->fo_ptyp->next = df->df_type;
+	else if (df->df_kind != D_TYPE) {
-		fo = f->next;
+		node_error(fo->fo_tok, "identifier \"%s\" not a type",
-		free_forwards(f);
+			     df->df_idf->id_text);
 	}
+	fo->fo_ptyp->next = df->df_type;
+	free_forwards(fo);
 }
 
 Reverse(pdf)

lang/m2/comp/type.c

@@ -104,10 +104,11 @@ construct_type(fund, tp)
 		break;
 
 	case T_ARRAY:
-		dtp->tp_align = tp->tp_align;
+		if (tp) dtp->tp_align = tp->tp_align;
 		break;
 
 	case T_SUBRANGE:
+		assert(tp != 0);
 		dtp->tp_align = tp->tp_align;
 		dtp->tp_size = tp->tp_size;
 		break;
@@ -386,7 +387,7 @@ ArrayElSize(tp)
 
 	if (tp->tp_fund == T_ARRAY) ArraySizes(tp);
 	algn = align(tp->tp_size, tp->tp_align);
-	if (word_size % algn != 0) {
+	if (algn && word_size % algn != 0) {
 		/* algn is not a dividor of the word size, so make sure it
 		   is a multiple
 		*/
@@ -449,6 +450,36 @@ FreeType(tp)
 	free_type(tp);
 }
 
+DeclareType(df, tp)
+	register struct def *df;
+	register struct type *tp;
+{
+	/*	A type with type-description "tp" is declared and must
+		be bound to definition "df".
+		This routine also handles the case that the type-field of
+		"df" is already bound. In that case, it is either an opaque
+		type, or an error message was given when "df" was created.
+	*/
+
+	if (df->df_type && df->df_type->tp_fund == T_HIDDEN) {
+	  	if (tp->tp_fund != T_POINTER) {
+error("opaque type \"%s\" is not a pointer type", df->df_idf->id_text);
+		}
+		/* Careful now ... we might have declarations
+		   referring to the hidden type.
+		*/
+		*(df->df_type) = *tp;
+		if (! tp->next) {
+			/* It also contains a forward reference,
+			   so update the forwardlist
+			*/
+			ChForward(tp, df->df_type);
+		}
+		free_type(tp);
+	}
+	else	df->df_type = tp;
+}
+
 int
 gcd(m, n)
 	register int m, n;

lang/m2/comp/typequiv.c

@@ -81,6 +81,9 @@ TstProcEquiv(tp1, tp2)
 		p2 = p2->next;
 	}
 
+	/* Here, at least one of the parameterlists is exhausted.
+	   Check that they are both.
+	*/
 	return p1 == p2;
 }
 
@@ -101,18 +104,17 @@ TstCompat(tp1, tp2)
 	    ||
 		(  tp1 == intorcard_type
 		&&
-		   (tp2 == int_type || tp2 == card_type)
+		   (tp2 == int_type || tp2 == card_type || tp2 == address_type)
 		)
 	    ||
 		(  tp2 == intorcard_type
 		&&
-		   (tp1 == int_type || tp1 == card_type)
+		   (tp1 == int_type || tp1 == card_type || tp1 == address_type)
 		)
 	    ||
 		(  tp1 == address_type
 		&& 
 	          (  tp2 == card_type
-		  || tp2 == intorcard_type
 		  || tp2->tp_fund == T_POINTER
 		  )
 		)
@@ -120,7 +122,6 @@ TstCompat(tp1, tp2)
 		(  tp2 == address_type
 		&& 
 	          (  tp1 == card_type
-		  || tp1 == intorcard_type
 		  || tp1->tp_fund == T_POINTER
 		  )
 		)
@@ -173,7 +174,7 @@ TstAssCompat(tp1, tp2)
 
 int
 TstParCompat(formaltype, actualtype, VARflag, nd)
-	struct type *formaltype, *actualtype;
+	register struct type *formaltype, *actualtype;
 	struct node *nd;
 {
 	/*	Check type compatibility for a parameter in a procedure call.
@@ -218,19 +219,12 @@ TstParCompat(formaltype, actualtype, VARflag, nd)
 		   )
 		)
 	    ||
-		( VARflag && OldCompat(formaltype, actualtype, nd))
+		(  VARflag
+		&& (  TstCompat(formaltype, actualtype)
+		   &&
+(node_warning(nd, "oldfashioned! types of formal and actual must be identical"),
+		      1)
+		   )
+		)
 	;
 }
-
-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

@@ -132,6 +132,8 @@ WalkProcedure(procedure)
 	register struct type *tp;
 	register struct paramlist *param;
 	label func_res_label = 0;
+	arith tmpvar1 = 0;
+	arith retsav = 0;
 
 	proclevel++;
 	CurrVis = procedure->prc_vis;
@@ -147,6 +149,14 @@ WalkProcedure(procedure)
 	DoProfil();
 	TmpOpen(sc);
 
+	func_type = tp = ResultType(procedure->df_type);
+
+	if (tp && IsConstructed(tp)) {
+		func_res_label = ++data_label;
+		C_df_dlb(func_res_label);
+		C_bss_cst(tp->tp_size, (arith) 0, 0);
+	}
+
 	/* Generate calls to initialization routines of modules defined within
 	   this procedure
 	*/
@@ -154,6 +164,7 @@ WalkProcedure(procedure)
 
 	/* Make sure that arguments of size < word_size are on a
 	   fixed place.
+	   Also make copies of conformant arrays when neccessary.
 	*/
 	for (param = ParamList(procedure->df_type);
 	     param;
@@ -161,37 +172,114 @@ WalkProcedure(procedure)
 		if (! IsVarParam(param)) {
 			tp = TypeOfParam(param);
 
-			if (!IsConformantArray(tp) && tp->tp_size < word_size) {
+			if (! IsConformantArray(tp)) {
+				if (tp->tp_size < word_size) {
 					C_lol(param->par_def->var_off);
 					C_lal(param->par_def->var_off);
 					C_sti(tp->tp_size);
 				}
 			}
+			else {
+				/* Here, we have to make a copy of the
+				   array. We must also remember how much
+				   room is reserved for copies, because
+				   we have to adjust the stack pointer before
+				   a RET is done. This is even more complicated
+				   when the procedure returns a value.
+				   Then, the value must be saved (in retval),
+				   the stack adjusted, the return value pushed
+				   again, and then RET
+				*/
+				arith tmpvar = NewInt();
+
+				if (! tmpvar1) {
+					if (tp && !func_res_label) {
+						/* Some local space, only
+						   needed if the value itself
+						   is returned
+						*/
+						sc->sc_off -= WA(tp->tp_size);
+						retsav = sc->sc_off;
+					}
+					tmpvar1 = NewInt();
+					C_loc((arith) 0);
+					C_stl(tmpvar1);
+				}
+				/* First compute the size */
+				C_lol(param->par_def->var_off +
+				      pointer_size + word_size);
+				C_inc();	/* gives number of elements */
+				C_loc(tp->arr_elem->tp_size);
+				C_cal("_wa");
+				C_asp(dword_size);
+				C_lfr(word_size);
+						/* size in words */
+				C_loc(word_size);
+				C_mli(word_size);
+						/* size in bytes */
+				C_stl(tmpvar);
+				C_lol(tmpvar);
+				C_dup(word_size);
+				C_lol(tmpvar1);
+				C_adi(word_size);
+				C_stl(tmpvar1);	/* remember all stack adjustments */
+				C_ngi(word_size);
+				C_ass(word_size);
+						/* adjusted stack pointer */
+				C_lor((arith) 1);
+						/* destination address */
+				C_lal(param->par_def->var_off);
+				C_loi(pointer_size);
+						/* push source address */
+				C_exg(pointer_size);
+						/* exchange them */
+				C_lol(tmpvar);	/* push size */
+				C_bls(word_size);
+						/* copy */
+				C_lor((arith) 1);	
+						/* push new address of array */
+				C_lal(param->par_def->var_off);
+				C_sti(pointer_size);
+				FreeInt(tmpvar);
+			}
+		}
 	}
 
 	text_label = 1;
-	func_type = tp = ResultType(procedure->df_type);
-
-	if (IsConstructed(tp)) {
-		func_res_label = ++data_label;
-		C_df_dlb(func_res_label);
-		C_bss_cst(tp->tp_size, (arith) 0, 0);
-	}
 
 	DO_DEBUG(options['X'], PrNode(procedure->prc_body, 0));
 	WalkNode(procedure->prc_body, (label) 0);
-	C_ret((arith) 0);
-	if (tp) {
 	C_df_ilb((label) 1);
+	tp = func_type;
 	if (func_res_label) {
 		C_lae_dlb(func_res_label, (arith) 0);
 		C_sti(tp->tp_size);
+		if (tmpvar1) {
+			C_lol(tmpvar1);
+			C_ass(word_size);
+		}
 		C_lae_dlb(func_res_label, (arith) 0);
 		C_ret(pointer_size);
 	}
-		else	C_ret(WA(tp->tp_size));
+	else if (tp) {
+		if (tmpvar1) {
+			C_lal(retsav);
+			C_sti(WA(tp->tp_size));
+			C_lol(tmpvar1);
+			C_ass(word_size);
+			C_lal(retsav);
+			C_loi(WA(tp->tp_size));
 		}
-
+		C_ret(WA(tp->tp_size));
+	}
+	else	{
+		if (tmpvar1) {
+			C_lol(tmpvar1);
+			C_ass(word_size);
+		}
+		C_ret((arith) 0);
+	}
+	if (tmpvar1) FreeInt(tmpvar1);
 	if (! options['n']) RegisterMessages(sc->sc_def);
 	C_end(-sc->sc_off);
 	TmpClose();
@@ -394,7 +482,7 @@ WalkStat(nd, lab)
 			struct desig ds;
 			arith tmp = 0;
 
-			WalkDesignator(left, &ds);
+			if (! WalkDesignator(left, &ds)) break;
 			if (left->nd_type->tp_fund != T_RECORD) {
 				node_error(left, "record variable expected");
 				break;
@@ -432,7 +520,7 @@ WalkStat(nd, lab)
 
 	case RETURN:
 		if (right) {
-			WalkExpr(right);
+			if (! WalkExpr(right)) break;
 			/* The type of the return-expression must be
 			   assignment compatible with the result type of the
 			   function procedure (See Rep. 9.11).
@@ -440,9 +528,8 @@ WalkStat(nd, lab)
 			if (!TstAssCompat(func_type, right->nd_type)) {
 node_error(right, "type incompatibility in RETURN statement");
 			}
-			C_bra((label) 1);
 		}
-		else	C_ret((arith) 0);
+		C_bra((label) 1);
 		break;
 
 	default:
@@ -487,17 +574,20 @@ ExpectBool(nd, true_label, false_label)
 	CodeExpr(nd, &ds,  true_label, false_label);
 }
 
+int
 WalkExpr(nd)
 	struct node *nd;
 {
 	/*	Check an expression and generate code for it
 	*/
 
-	if (! ChkExpression(nd)) return;
+	if (! ChkExpression(nd)) return 0;
 
 	CodePExpr(nd);
+	return 1;
 }
 
+int
 WalkDesignator(nd, ds)
 	struct node *nd;
 	struct desig *ds;
@@ -505,10 +595,11 @@ WalkDesignator(nd, ds)
 	/*	Check designator and generate code for it
 	*/
 
-	if (! ChkVariable(nd)) return;
+	if (! ChkVariable(nd)) return 0;
 
 	*ds = InitDesig;
 	CodeDesig(nd, ds);
+	return 1;
 }
 
 DoForInit(nd, left)