newer version

lang/m2/comp/Makefile

@@ -11,7 +11,7 @@ LSRC =	tokenfile.g program.g declar.g expression.g statement.g
 CC =	cc
 GEN =	/usr/em/util/LLgen/src/LLgen
 GENOPTIONS = -d
-PROFILE = -p
+PROFILE = 
 CFLAGS = $(PROFILE) $(INCLUDES) -DSTATIC=
 LINTFLAGS = -DSTATIC= -DNORCSID
 LFLAGS = $(PROFILE)
@@ -22,10 +22,17 @@ COBJ =	LLlex.o LLmessage.o char.o error.o main.o \
 	cstoper.o chk_expr.o options.o walk.o casestat.o desig.o \
 	code.o tmpvar.o lookup.o
 OBJ =	$(COBJ) $(LOBJ) Lpars.o
-GENFILES=	tokenfile.c \
-	program.c declar.c expression.c statement.c \
-	tokenfile.g symbol2str.c char.c Lpars.c Lpars.h
 
+# Keep the next three 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
+GENGFILES=	tokenfile.g
+GENHFILES=	errout.h\
+	idfsize.h numsize.h strsize.h target_sizes.h debug.h\
+	inputtype.h maxset.h ndir.h density.h
+#
+GENFILES = $(GENGFILES) $(GENCFILES) $(GENHFILES)
 all:
 	make hfiles
 	make LLfiles
@@ -44,7 +51,7 @@ main:	$(OBJ) Makefile
 	size main
 
 clean:
-	rm -f $(OBJ) $(GENFILES) LLfiles 
+	rm -f $(OBJ) $(GENFILES) LLfiles hfiles
 
 lint:	LLfiles hfiles
 	lint $(INCLUDES) $(LINTFLAGS) `sources $(OBJ)`
@@ -101,7 +108,7 @@ 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 chk_expr.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 chk_expr.h debug.h def.h desig.h f_info.h idf.h main.h node.h scope.h type.h
+walk.o: LLlex.h Lpars.h chk_expr.h debug.h def.h desig.h f_info.h idf.h main.h node.h scope.h type.h walk.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 standards.h type.h

lang/m2/comp/casestat.C

@@ -16,6 +16,7 @@ static char *RcsId = "$Header$";
 #include	"LLlex.h"
 #include	"node.h"
 #include	"desig.h"
+#include	"walk.h"
 
 #include	"density.h"
 
@@ -48,8 +49,6 @@ struct case_entry	{
 */
 #define	compact(nr, low, up)	(nr != 0 && (up - low) / nr <= DENSITY)
 
-extern label text_label(), data_label();
-
 CaseCode(nd, exitlabel)
 	struct node *nd;
 	label exitlabel;
@@ -68,7 +67,7 @@ CaseCode(nd, exitlabel)
 	clear((char *) sh, sizeof(*sh));
 	WalkExpr(pnode->nd_left);
 	sh->sh_type = pnode->nd_left->nd_type;
-	sh->sh_break = text_label();
+	sh->sh_break = ++text_label;
 
 	/* Now, create case label list
 	*/
@@ -76,7 +75,7 @@ CaseCode(nd, exitlabel)
 		pnode = pnode->nd_right;
 		if (pnode->nd_class == Link && pnode->nd_symb == '|') {
 			if (pnode->nd_left) {
-				pnode->nd_lab = text_label();
+				pnode->nd_lab = ++text_label;
 				if (! AddCases(sh,
 					       pnode->nd_left->nd_left,
 					       pnode->nd_lab)) {
@@ -89,17 +88,17 @@ CaseCode(nd, exitlabel)
 			/* Else part
 			*/
 
-			sh->sh_default = text_label();
+			sh->sh_default = ++text_label;
 			pnode = 0;
 		}
 	}
 
 	/* Now generate code for the switch itself
 	*/
-	tablabel = data_label();	/* the rom must have a label	*/
+	tablabel = ++data_label;	/* the rom must have a label	*/
 	C_df_dlb(tablabel);
 	if (sh->sh_default) C_rom_ilb(sh->sh_default);
-	else C_rom_ilb(sh->sh_break);
+	else C_rom_ucon("0", pointer_size);
 	if (compact(sh->sh_nrofentries, sh->sh_lowerbd, sh->sh_upperbd)) {
 		/* CSA */
 
@@ -113,7 +112,7 @@ CaseCode(nd, exitlabel)
 				ce = ce->next;
 			}
 			else if (sh->sh_default) C_rom_ilb(sh->sh_default);
-			else C_rom_ilb(sh->sh_break);
+			else C_rom_ucon("0", pointer_size);
 		}
 		C_lae_dlb(tablabel, (arith)0); /* perform the switch	*/
 		C_csa(word_size);

lang/m2/comp/chk_expr.c

@@ -31,7 +31,7 @@ STATIC int
 chk_arr(expp)
 	struct node *expp;
 {
-	return chk_designator(expp, DESIGNATOR|VARIABLE, D_USED);
+	return chk_designator(expp, VARIABLE, D_USED);
 }
 
 STATIC int
@@ -54,7 +54,7 @@ STATIC int
 chk_linkorname(expp)
 	register struct node *expp;
 {
-	if (chk_designator(expp, VALUE|DESIGNATOR, D_USED)) {
+	if (chk_designator(expp, VALUE, D_USED)) {
 		if (expp->nd_class == Def &&
 		    expp->nd_def->df_kind == D_PROCEDURE) {
 			/* Check that this procedure is one that we
@@ -269,7 +269,7 @@ getarg(argp, bases, designator)
 
 	if ((!designator && !chk_expr(left)) ||
 	    (designator &&
-	     !chk_designator(left, DESIGNATOR|VARIABLE, D_USED|D_NOREG))) {
+	     !chk_designator(left, VARIABLE, D_USED|D_NOREG))) {
 		return 0;
 	}
 
@@ -299,7 +299,10 @@ getname(argp, kinds)
 	arg = arg->nd_right;
 	if (! chk_designator(arg->nd_left, 0, D_REFERRED)) return 0;
 
-	if (arg->nd_left->nd_class != Def);
+	if (arg->nd_left->nd_class != Def && arg->nd_left->nd_class != LinkDef) {
+		node_error(arg, "identifier expected");
+		return 0;
+	}
 
 	if (!(arg->nd_left->nd_def->df_kind & kinds)) {
 		node_error(arg, "unexpected type");
@@ -324,7 +327,7 @@ chk_proccall(expp)
 	arg = expp;
 	expp->nd_type = left->nd_type->next;
 
-	for (param = left->nd_type->prc_params; param; param = param->next) {
+	for (param = ParamList(left->nd_type); param; param = param->next) {
 		if (!(left = getarg(&arg, 0, IsVarParam(param)))) return 0;
 		if (left->nd_symb == STRING) {
 			TryToString(left, TypeOfParam(param));
@@ -430,8 +433,6 @@ chk_designator(expp, flag, dflags)
 		be something that can be assigned to.
 		It may also contain the flag VALUE, indicating that a
 		value is expected. In this case, VARIABLE may not be set.
-		It also contains the flag DESIGNATOR, indicating that '['
-		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
@@ -440,6 +441,11 @@ chk_designator(expp, flag, dflags)
 	register struct def *df;
 	register struct type *tp;
 
+	if (expp->nd_class == Def || expp->nd_class == LinkDef) {
+		expp->nd_def->df_flags |= dflags;
+		return 1;
+	}
+
 	expp->nd_type = error_type;
 
 	if (expp->nd_class == Name) {
@@ -453,7 +459,7 @@ chk_designator(expp, flag, dflags)
 		assert(expp->nd_symb == '.');
 
 		if (! chk_designator(left,
-				     (flag&DESIGNATOR)|HASSELECTORS,
+				     HASSELECTORS,
 				     dflags)) return 0;
 
 		tp = left->nd_type;
@@ -466,6 +472,7 @@ chk_designator(expp, flag, dflags)
 		else {
 			expp->nd_def = df;
 			expp->nd_type = df->df_type;
+			expp->nd_class = LinkDef;
 			if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
 				/* Fields of a record are always D_QEXPORTED,
 				   so ...
@@ -513,18 +520,13 @@ df->df_idf->id_text);
 		return 1;
 	}
 
-	if (! (flag & DESIGNATOR)) {
-		node_error(expp, "identifier expected");
-		return 0;
-	}
-
 	if (expp->nd_class == Arrsel) {
 		struct type *tpl, *tpr;
 
 		assert(expp->nd_symb == '[');
 
 		if ( 
-		     !chk_designator(expp->nd_left, DESIGNATOR|VARIABLE, dflags)
+		     !chk_designator(expp->nd_left, VARIABLE, dflags)
 		   ||
 		     !chk_expr(expp->nd_right)
 		   ||
@@ -556,7 +558,7 @@ df->df_idf->id_text);
 	if (expp->nd_class == Arrow) {
 		assert(expp->nd_symb == '^');
 
-		if (! chk_designator(expp->nd_right, DESIGNATOR|VARIABLE, dflags)) {
+		if (! chk_designator(expp->nd_right, VARIABLE, dflags)) {
 			return 0;
 		}
 
@@ -795,7 +797,7 @@ chk_uoper(expp)
 		break;
 
 	default:
-		assert(0);
+		crash("chk_uoper");
 	}
 	node_error(expp, "illegal operand for unary operator \"%s\"",
 			symbol2str(expp->nd_symb));
@@ -818,14 +820,14 @@ getvariable(argp)
 
 	left = arg->nd_left;
 
-	if (! chk_designator(left, DESIGNATOR, D_REFERRED)) return 0;
+	if (! chk_designator(left, 0, D_REFERRED)) return 0;
 	if (left->nd_class == Arrsel || left->nd_class == Arrow) {
 		*argp = arg;
 		return left;
 	}
 
 	df = 0;
-	if (left->nd_class == Link || left->nd_class == Def) {
+	if (left->nd_class == LinkDef || left->nd_class == Def) {
 		df = left->nd_def;
 	}
 
@@ -917,6 +919,47 @@ DO_DEBUG(3,debug("standard name \"%s\", %d",left->nd_def->df_idf->id_text,std));
 		if (left->nd_class == Value) cstcall(expp, S_ORD);
 		break;
 
+	case S_NEW:
+	case S_DISPOSE:
+		{
+			static int warning_given = 0;
+
+			if (!warning_given) {
+				warning_given = 1;
+				node_warning(expp, "NEW and DISPOSE are old-fashioned");
+			}
+		}
+		if (! (left = getvariable(&arg))) return 0;
+		if (! (left->nd_type->tp_fund == T_POINTER)) {
+			node_error(left, "pointer variable expected");
+			return 0;
+		}
+		if (left->nd_class == Def) {
+			left->nd_def->df_flags |= D_NOREG;
+		}
+		/* Now, make it look like a call to ALLOCATE or DEALLOCATE */
+		{
+			struct token dt;
+			struct node *nd;
+
+			dt.TOK_INT = left->nd_type->next->tp_size;
+			dt.tk_symb = INTEGER;
+			dt.tk_lineno = left->nd_lineno;
+			nd = MkLeaf(Value, &dt);
+			nd->nd_type = card_type;
+			dt.tk_symb = ',';
+			arg->nd_right = MkNode(Link, nd, NULLNODE, &dt);
+			/* Ignore other arguments to NEW and/or DISPOSE ??? */
+
+			FreeNode(expp->nd_left);
+			dt.tk_symb = IDENT;
+			dt.tk_lineno = expp->nd_left->nd_lineno;
+			dt.TOK_IDF = str2idf(std == S_NEW ?
+						"ALLOCATE" : "DEALLOCATE", 0);
+			expp->nd_left = MkLeaf(Name, &dt);
+		}
+		return chk_call(expp);
+
 	case S_TSIZE:	/* ??? */
 	case S_SIZE:
 		expp->nd_type = intorcard_type;
@@ -1080,5 +1123,6 @@ int (*ChkTable[])() = {
 	chk_set,
 	NodeCrash,
 	NodeCrash,
-	chk_linkorname
+	chk_linkorname,
+	NodeCrash
 };

lang/m2/comp/code.c

@@ -21,9 +21,8 @@ static char *RcsId = "$Header$";
 #include	"node.h"
 #include	"Lpars.h"
 #include	"standards.h"
+#include	"walk.h"
 
-extern label	data_label();
-extern label	text_label();
 extern char	*long2str();
 extern char	*symbol2str();
 extern int	proclevel;
@@ -43,7 +42,7 @@ CodeConst(cst, size)
 		C_ldc(cst);
 	}
 	else {
-		C_df_dlb(dlab = data_label());
+		C_df_dlb(dlab = ++data_label);
 		C_rom_icon(long2str((long) cst), size);
 		C_lae_dlb(dlab, (arith) 0);
 		C_loi(size);
@@ -59,7 +58,7 @@ CodeString(nd)
 		C_loc(nd->nd_INT);
 	}
 	else {
-		C_df_dlb(lab = data_label());
+		C_df_dlb(lab = ++data_label);
 		C_rom_scon(nd->nd_STR, WA(nd->nd_SLE + 1));
 		C_lae_dlb(lab, (arith) 0);
 	}
@@ -88,7 +87,7 @@ CodePadString(nd, sz)
 CodeReal(nd)
 	register struct node *nd;
 {
-	label lab = data_label();
+	label lab = ++data_label;
 
 	C_df_dlb(lab);
 	C_rom_fcon(nd->nd_REL, nd->nd_type->tp_size);
@@ -114,6 +113,7 @@ CodeExpr(nd, ds, true_label, false_label)
 		/* Fall through */
 
 	case Link:
+	case LinkDef:
 	case Arrsel:
 	case Arrow:
 		CodeDesig(nd, ds);
@@ -290,6 +290,7 @@ CodeCall(nd)
 		and result is already done.
 	*/
 	register struct node *left = nd->nd_left;
+	register struct type *result_tp;
 
 	if (left->nd_type == std_type) {
 		CodeStd(nd);
@@ -308,7 +309,7 @@ CodeCall(nd)
 	assert(IsProcCall(left));
 
 	if (nd->nd_right) {
-		CodeParameters(left->nd_type->prc_params, nd->nd_right);
+		CodeParameters(ParamList(left->nd_type), nd->nd_right);
 	}
 
 	if (left->nd_class == Def && left->nd_def->df_kind == D_PROCEDURE) {
@@ -325,8 +326,12 @@ CodeCall(nd)
 		C_cai();
 	}
 	if (left->nd_type->prc_nbpar) C_asp(left->nd_type->prc_nbpar);
-	if (left->nd_type->next) {
+	if (result_tp = ResultType(left->nd_type)) {
-		C_lfr(WA(left->nd_type->next->tp_size));
+		if (IsConstructed(result_tp)) {
+			C_lfr(pointer_size);
+			C_loi(result_tp->tp_size);
+		}
+		else	C_lfr(WA(result_tp->tp_size));
 	}
 }
 
@@ -765,6 +770,7 @@ CodeOper(expr, true_label, false_label)
 				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);
 			break;
@@ -795,10 +801,10 @@ CodeOper(expr, true_label, false_label)
 	case AND:
 	case '&':
 		if (true_label == 0)	{
-			label l_true = text_label();
+			label l_true = ++text_label;
-			label l_false = text_label();
+			label l_false = ++text_label;
-			label l_maybe = text_label();
+			label l_maybe = ++text_label;
-			label l_end = text_label();
+			label l_end = ++text_label;
 			struct desig Des;
 
 			Des = InitDesig;
@@ -814,7 +820,7 @@ CodeOper(expr, true_label, false_label)
 			C_df_ilb(l_end);
 		}
 		else	{
-			label l_maybe = text_label();
+			label l_maybe = ++text_label;
 			struct desig Des;
 
 			Des = InitDesig;
@@ -826,10 +832,10 @@ CodeOper(expr, true_label, false_label)
 		break;
 	case OR:
 		if (true_label == 0)	{
-			label l_true = text_label();
+			label l_true = ++text_label;
-			label l_false = text_label();
+			label l_false = ++text_label;
-			label l_maybe = text_label();
+			label l_maybe = ++text_label;
-			label l_end = text_label();
+			label l_end = ++text_label;
 			struct desig Des;
 
 			Des = InitDesig;
@@ -845,7 +851,7 @@ CodeOper(expr, true_label, false_label)
 			C_df_ilb(l_end);
 		}
 		else	{
-			label l_maybe = text_label();
+			label l_maybe = ++text_label;
 			struct desig Des;
 
 			Des = InitDesig;
@@ -1026,13 +1032,10 @@ CodeDStore(nd)
 DoHIGH(nd)
 	struct node *nd;
 {
-	register struct def *df;
+	register struct def *df = nd->nd_def;
-	arith highoff;
+	register arith highoff;
 
 	assert(nd->nd_class == Def);
-
-	df = nd->nd_def;
-
 	assert(df->df_kind == D_VARIABLE);
 
 	highoff = df->var_off + pointer_size + word_size;

lang/m2/comp/declar.g

@@ -21,23 +21,31 @@ static char *RcsId = "$Header$";
 #include	"misc.h"
 #include	"main.h"
 
-int		proclevel = 0;	/* nesting level of procedures */
+int		proclevel = 0;		/* nesting level of procedures */
+int		return_occurred;	/* set if a return occurred in a
+					   procedure or function
+					*/
 }
 
 ProcedureDeclaration
 {
-	struct def *df;
+	register struct def *df;
+	struct def *df1;
 } :
 			{ proclevel++; }
-	ProcedureHeading(&df, D_PROCEDURE)
+	ProcedureHeading(&df1, D_PROCEDURE)
 			{
-			  CurrentScope->sc_definedby = df;
+			  CurrentScope->sc_definedby = df = df1;
 			  df->prc_vis = CurrVis;
+			  return_occurred = 0;
 			}
 	';' block(&(df->prc_body)) IDENT
 			{
 			  match_id(dot.TOK_IDF, df->df_idf);
 			  close_scope(SC_CHKFORW|SC_REVERSE);
+			  if (! return_occurred && ResultType(df->df_type)) {
+error("function procedure does not return a value", df->df_idf->id_text);
+			  }
 			  proclevel--;
 			}
 ;

lang/m2/comp/desig.c

@@ -311,7 +311,7 @@ CodeDesig(nd, ds)
 		}
 		break;
 
-	case Link:
+	case LinkDef:
 		assert(nd->nd_symb == '.');
 
 		CodeDesig(nd->nd_left, ds);

lang/m2/comp/lookup.c

@@ -26,26 +26,31 @@ lookup(id, scope)
 		Return a pointer to its "def" structure if it exists,
 		otherwise return 0.
 	*/
-	register struct def *df;
+	register struct def *df, *df1;
-	struct def *df1;
 
-	for (df = id->id_def, df1 = 0; df; df1 = df, df = df->next) {
+	/* Look in the chain of definitions of this "id" for one with scope
-		if (df->df_scope == scope) {
+	   "scope".
-			if (df1) {
+	*/
-				/* Put the definition in front
+	for (df = id->id_def, df1 = 0;
-				*/
+	     df && df->df_scope != scope;
-				df1->next = df->next;
+	     df1 = df, df = df->next) { /* nothing */ }
-				df->next = id->id_def;
+
-				id->id_def = df;
+	if (df) {
-			}
+		/* Found it
-			if (df->df_kind == D_IMPORT) {
+		*/
-				assert(df->imp_def != 0);
+		if (df1) {
-				return df->imp_def;
+			/* Put the definition in front
-			}
+			*/
-			return df;
+			df1->next = df->next;
+			df->next = id->id_def;
+			id->id_def = df;
+		}
+		if (df->df_kind == D_IMPORT) {
+			assert(df->imp_def != 0);
+			return df->imp_def;
 		}
 	}
-	return 0;
+	return df;
 }
 
 struct def *
@@ -57,7 +62,7 @@ lookfor(id, vis, give_error)
 		If it is not defined create a dummy definition and,
 		if "give_error" is set, give an error message.
 	*/
-	struct def *df;
+	register struct def *df;
 	register struct scopelist *sc = vis;
 
 	while (sc) {

lang/m2/comp/main.c

@@ -159,6 +159,8 @@ AddStandards()
 	(void) Enter("DEC", D_PROCEDURE, std_type, S_DEC);
 	(void) Enter("INC", D_PROCEDURE, std_type, S_INC);
 	(void) Enter("VAL", D_PROCEDURE, std_type, S_VAL);
+	(void) Enter("NEW", D_PROCEDURE, std_type, S_NEW);
+	(void) Enter("DISPOSE", D_PROCEDURE, std_type, S_DISPOSE);
 	(void) Enter("TRUNC", D_PROCEDURE, std_type, S_TRUNC);
 	(void) Enter("SIZE", D_PROCEDURE, std_type, S_SIZE);
 	(void) Enter("ORD", D_PROCEDURE, std_type, S_ORD);

lang/m2/comp/node.H

@@ -19,6 +19,7 @@ struct node {
 #define Def	9		/* an identified name */
 #define Stat	10		/* a statement */
 #define Link	11
+#define LinkDef	12
 				/* do NOT change the order or the numbers!!! */
 	struct type *nd_type;	/* type of this node */
 	struct token nd_token;
@@ -40,10 +41,9 @@ extern struct node *MkNode(), *MkLeaf();
 
 #define NULLNODE ((struct node *) 0)
 
-#define DESIGNATOR 1
+#define HASSELECTORS	002
-#define HASSELECTORS 2
+#define VARIABLE	004
-#define VARIABLE 4
+#define VALUE		010
-#define VALUE 8
 
-#define	IsCast(lnd)	((lnd)->nd_class == Def && is_type((lnd)->nd_def))
+#define	IsCast(lnd)	(((lnd)->nd_class == Def || (lnd)->nd_class == LinkDef)  && is_type((lnd)->nd_def))
 #define	IsProcCall(lnd)	((lnd)->nd_type->tp_fund == T_PROCEDURE)

lang/m2/comp/standards.h

@@ -19,6 +19,8 @@
 #define S_SIZE	15
 #define S_TRUNC	16
 #define S_VAL	17
+#define S_NEW	18
+#define S_DISPOSE 19
 
 /* Standard procedures and functions defined in the SYSTEM module ... */
 

lang/m2/comp/statement.g

@@ -229,9 +229,12 @@ ReturnStatement(struct node **pnd;)
 {
 	register struct def *df = CurrentScope->sc_definedby;
 	register struct node *nd;
+	extern int return_occurred;
 } :
 
-	RETURN		{ *pnd = nd = MkLeaf(Stat, &dot); }
+	RETURN		{ *pnd = nd = MkLeaf(Stat, &dot);
+			  return_occurred = 1;
+			}
 	[
 		expression(&(nd->nd_right))
 			{ if (scopeclosed(CurrentScope)) {

lang/m2/comp/type.H

@@ -74,7 +74,7 @@ struct type	{
 #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)
+#define	T_CONSTRUCTED	(T_ARRAY|T_SET|T_RECORD)
 	int tp_align;		/* alignment requirement of this type */
 	arith tp_size;		/* size of this type */
 	union {
@@ -136,6 +136,8 @@ struct type
 #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))
 #define WA(sz)		(align(sz, (int) word_size))
+#define ResultType(tpx)	(assert((tpx)->tp_fund == T_PROCEDURE), (tpx)->next)
+#define ParamList(tpx)	(assert((tpx)->tp_fund == T_PROCEDURE),\
+					(tpx)->prc_params)
+#define	IsConstructed(tpx)	((tpx)->tp_fund & T_CONSTRUCTED)

lang/m2/comp/type.c

@@ -20,6 +20,7 @@ static char *RcsId = "$Header$";
 #include	"node.h"
 #include	"const.h"
 #include	"scope.h"
+#include	"walk.h"
 
 int
 	word_align = AL_WORD,
@@ -64,8 +65,6 @@ struct type *h_type;
 int	cnt_type;
 #endif
 
-extern label	data_label();
-
 struct type *
 create_type(fund)
 	int fund;
@@ -93,10 +92,6 @@ construct_type(fund, tp)
 
 	switch (fund)	{
 	case T_PROCEDURE:
-		if (tp && !returntype(tp)) {
-			error("illegal procedure result type");
-		}
-		/* Fall through */
 	case T_POINTER:
 	case T_HIDDEN:
 		dtp->tp_align = pointer_align;
@@ -315,11 +310,11 @@ genrck(tp)
 
 	if (tp->tp_fund == T_SUBRANGE) {
 		if (!(ol = tp->sub_rck)) {
-			tp->sub_rck = l = data_label();
+			tp->sub_rck = l = ++data_label;
 		}
 	}
 	else if (!(ol = tp->enm_rck)) {
-		tp->enm_rck = l = data_label();
+		tp->enm_rck = l = ++data_label;
 	}
 	if (!ol) {
 		ol = l;
@@ -423,7 +418,7 @@ ArraySizes(tp)
 
 	/* generate descriptor and remember label.
 	*/
-	tp->arr_descr = data_label();
+	tp->arr_descr = ++data_label;
 	C_df_dlb(tp->arr_descr);
 	C_rom_cst(lo);
 	C_rom_cst(hi - lo);
@@ -441,7 +436,7 @@ FreeType(tp)
 
 	assert(tp->tp_fund == T_PROCEDURE);
 
-	pr = tp->prc_params;
+	pr = ParamList(tp);
 	while (pr) {
 		pr1 = pr;
 		pr = pr->next;
@@ -516,7 +511,7 @@ DumpType(tp)
 		break;
 	case T_PROCEDURE:
 		{
-		register struct paramlist *par = tp->prc_params;
+		register struct paramlist *par = ParamList(tp);
 
 		print("PROCEDURE");
 		if (par) {
@@ -541,7 +536,7 @@ DumpType(tp)
 	case T_INTORCARD:
 		print("INTORCARD"); break;
 	default:
-		assert(0);
+		crash("DumpType");
 	}
 	print(";");
 }

lang/m2/comp/typequiv.c

@@ -7,8 +7,11 @@ static char *RcsId = "$Header$";
 /*	Routines for testing type equivalence, type compatibility, and
 	assignment compatibility
 */
+#include	"debug.h"
+
 #include	<em_arith.h>
 #include	<em_label.h>
+#include	<assert.h>
 
 #include	"type.h"
 #include	"def.h"
@@ -66,8 +69,8 @@ TstProcEquiv(tp1, tp2)
 	*/
 	if (! TstTypeEquiv(tp1->next, tp2->next)) return 0;
 
-	p1 = tp1->prc_params;
+	p1 = ParamList(tp1);
-	p2 = tp2->prc_params;
+	p2 = ParamList(tp2);
 
 	/* Now check the parameters
 	*/
@@ -180,6 +183,10 @@ TstParCompat(formaltype, actualtype, VARflag, nd)
 		TstTypeEquiv(formaltype, actualtype)
 	    ||
 		( !VARflag && TstAssCompat(formaltype, actualtype))
+	    ||
+		(  formaltype == address_type 
+		&& actualtype->tp_fund == T_POINTER
+		)
 	    ||
 		(  formaltype == word_type
 		&& 

lang/m2/comp/walk.c

@@ -26,31 +26,18 @@ static char *RcsId = "$Header$";
 #include	"f_info.h"
 #include	"idf.h"
 #include	"chk_expr.h"
+#include	"walk.h"
 
 extern arith	NewPtr();
 extern arith	NewInt();
 extern int	proclevel;
-static label	instructionlabel;
+label		text_label;
-static char	return_expr_occurred;
+label		data_label;
 static struct type *func_type;
 struct withdesig *WithDesigs;
 struct node	*Modules;
 struct scope	*ProcScope;
 
-label
-text_label()
-{
-	return instructionlabel++;
-}
-
-label
-data_label()
-{
-	static label	datalabel = 0;
-
-	return ++datalabel;
-}
-
 STATIC
 DoProfil()
 {
@@ -58,7 +45,7 @@ DoProfil()
 
 	if (! options['L']) {
 		if (!filename_label) {
-			filename_label = data_label();
+			filename_label = ++data_label;
 			C_df_dlb(filename_label);
 			C_rom_scon(FileName, (arith) (strlen(FileName) + 1));
 		}
@@ -73,7 +60,6 @@ WalkModule(module)
 	/*	Walk through a module, and all its local definitions.
 		Also generate code for its body.
 	*/
-	register struct def *df = module->mod_vis->sc_scope->sc_def;
 	register struct scope *sc;
 	struct scopelist *vis;
 
@@ -81,20 +67,10 @@ WalkModule(module)
 	CurrVis = module->mod_vis;
 	sc = CurrentScope;
 
-	if (!proclevel) {
+	if (!proclevel && module == Defined) {
-		/* This module is a glocal module.
+		/* This module is a global module. Export the name of its
-		   Generate code to allocate storage for its variables.
+		   initialization routine
-		   They all have an explicit name.
 		*/
-		while (df) {
-			if (df->df_kind == D_VARIABLE) {
-				C_df_dnam(df->var_name);
-				C_bss_cst(
-					WA(df->df_type->tp_size),
-					(arith) 0, 0);
-			}
-			df = df->df_nextinscope;
-		}
 		if (state == PROGRAM) C_exp("main");
 		else C_exp(sc->sc_name);
 	}
@@ -108,12 +84,11 @@ WalkModule(module)
 	   this module.
 	*/
 	sc->sc_off = 0;
-	instructionlabel = 2;
+	text_label = 1;
-	func_type = 0;
 	ProcScope = CurrentScope;	
-	C_pro_narg(state == PROGRAM ? "main" : sc->sc_name);
+	C_pro_narg(state==PROGRAM && module==Defined ? "main" : sc->sc_name);
 	DoProfil();
-	if (CurrVis == Defined->mod_vis) {
+	if (module == Defined) {
 		/* Body of implementation or program module.
 		   Call initialization routines of imported modules.
 		   Also prevent recursive calls of this one.
@@ -121,7 +96,7 @@ WalkModule(module)
 		struct node *nd;
 
 		if (state == IMPLEMENTATION) {
-			label l1 = data_label();
+			label l1 = ++data_label;
 			/* we don't actually prevent recursive calls,
 			   but do nothing if called recursively
 			*/
@@ -157,44 +132,73 @@ WalkProcedure(procedure)
 	/*	Walk through the definition of a procedure and all its
 		local definitions
 	*/
-	struct scopelist *vis = CurrVis;
+	struct scopelist *savevis = CurrVis;
 	register struct scope *sc;
 	register struct type *tp;
 	register struct paramlist *param;
+	label func_res_label = 0;
 
 	proclevel++;
 	CurrVis = procedure->prc_vis;
 	ProcScope = sc = CurrentScope;
 	
+	/* Generate code for all local modules and procedures
+	*/
 	WalkDef(sc->sc_def);
 
 	/* Generate code for this procedure
 	*/
 	C_pro_narg(sc->sc_name);
 	DoProfil();
-	/* generate calls to initialization routines of modules defined within
+
+	/* Generate calls to initialization routines of modules defined within
 	   this procedure
 	*/
 	MkCalls(sc->sc_def);
-	return_expr_occurred = 0;
+
-	instructionlabel = 2;
+	/* Make sure that arguments of size < word_size are on a
-	func_type = tp = procedure->df_type->next;
+	   fixed place.
-	if (! returntype(tp)) {
+	*/
-		node_error(procedure->prc_body, "illegal result type");
+	for (param = ParamList(procedure->df_type);
-	}
+	     param;
-	WalkNode(procedure->prc_body, (label) 0);
+	     param = param->next) {
-	C_df_ilb((label) 1);
+		if (! IsVarParam(param)) {
-	if (tp) {
+			tp = TypeOfParam(param);
-		if (! return_expr_occurred) {
+
-node_error(procedure->prc_body,"function procedure does not return a value");
+			if (!IsConformantArray(tp) && tp->tp_size < word_size) {
+				C_lol(param->par_def->var_off);
+				C_lal(param->par_def->var_off);
+				C_sti(tp->tp_size);
+			}
 		}
-		C_ret(WA(tp->tp_size));
 	}
-	else	C_ret((arith) 0);
+
+	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);
+	}
+
+	WalkNode(procedure->prc_body, (label) 0);
+	C_ret((arith) 0);
+	if (tp) {
+		C_df_ilb((label) 1);
+		if (func_res_label) {
+			C_lae_dlb(func_res_label, (arith) 0);
+			C_sti(tp->tp_size);
+			C_lae_dlb(func_res_label, (arith) 0);
+			C_ret(pointer_size);
+		}
+		else	C_ret(WA(tp->tp_size));
+	}
+
 	RegisterMessages(sc->sc_def);
 	C_end(-sc->sc_off);
 	TmpClose();
-	CurrVis = vis;
+	CurrVis = savevis;
 	proclevel--;
 }
 
@@ -211,6 +215,12 @@ WalkDef(df)
 		else if (df->df_kind == D_PROCEDURE) {
 			WalkProcedure(df);
 		}
+		else if (!proclevel && df->df_kind == D_VARIABLE) {
+			C_df_dnam(df->var_name);
+			C_bss_cst(
+				WA(df->df_type->tp_size),
+				(arith) 0, 0);
+		}
 		df = df->df_nextinscope;
 	}
 }
@@ -231,22 +241,36 @@ MkCalls(df)
 	}
 }
 
-WalkNode(nd, lab)
+WalkLink(nd, lab)
 	register struct node *nd;
 	label lab;
 {
-	/*	Node "nd" represents either a statement or a statement list.
+	/*	Walk node "nd", which is a link.
-		Walk through it.
 		"lab" represents the label that must be jumped to on
 		encountering an EXIT statement.
 	*/
 
-	while (nd->nd_class == Link) {	 /* statement list */
+	while (nd && nd->nd_class == Link) {	 /* statement list */
-		WalkStat(nd->nd_left, lab);
+		WalkNode(nd->nd_left, lab);
 		nd = nd->nd_right;
 	}
 
-	WalkStat(nd, lab);
+	WalkNode(nd, lab);
+}
+
+WalkCall(nd)
+	register struct node *nd;
+{
+	assert(nd->nd_class == Call);
+
+	if (! options['L']) C_lin((arith) nd->nd_lineno);
+	if (chk_call(nd)) {
+		if (nd->nd_type != 0) {
+			node_error(nd, "procedure call expected");
+			return;
+		}
+		CodeCall(nd);
+	}
 }
 
 WalkStat(nd, lab)
@@ -260,27 +284,9 @@ WalkStat(nd, lab)
 	register struct node *left = nd->nd_left;
 	register struct node *right = nd->nd_right;
 
-	if (!nd) {
-		/* Empty statement
-		*/
-		return;
-	}
-
-	if (! options['L']) C_lin((arith) nd->nd_lineno);
-
-	if (nd->nd_class == Call) {
-		if (chk_call(nd)) {
-			if (nd->nd_type != 0) {
-				node_error(nd, "procedure call expected");
-				return;
-			}
-			CodeCall(nd);
-		}
-		return;
-	}
-
 	assert(nd->nd_class == Stat);
 
+	if (! options['L']) C_lin((arith) nd->nd_lineno);
 	switch(nd->nd_symb) {
 	case BECOMES:
 		DoAssign(nd, left, right);
@@ -289,9 +295,9 @@ WalkStat(nd, lab)
 	case IF:
 		{	label l1, l2, l3;
 
-			l1 = instructionlabel++;
+			l1 = ++text_label;
-			l2 = instructionlabel++;
+			l2 = ++text_label;
-			l3 = instructionlabel++;
+			l3 = ++text_label;
 			ExpectBool(left, l3, l1);
 			assert(right->nd_symb == THEN);
 			C_df_ilb(l3);
@@ -314,9 +320,9 @@ WalkStat(nd, lab)
 	case WHILE:
 		{	label l1, l2, l3;
 
-			l1 = instructionlabel++;
+			l1 = ++text_label;
-			l2 = instructionlabel++;
+			l2 = ++text_label;
-			l3 = instructionlabel++;
+			l3 = ++text_label;
 			C_df_ilb(l1);
 			ExpectBool(left, l3, l2);
 			C_df_ilb(l3);
@@ -329,8 +335,8 @@ WalkStat(nd, lab)
 	case REPEAT:
 		{	label l1, l2;
 
-			l1 = instructionlabel++;
+			l1 = ++text_label;
-			l2 = instructionlabel++;
+			l2 = ++text_label;
 			C_df_ilb(l1);
 			WalkNode(left, lab);
 			ExpectBool(right, l2, l1);
@@ -341,8 +347,8 @@ WalkStat(nd, lab)
 	case LOOP:
 		{	label l1, l2;
 
-			l1 = instructionlabel++;
+			l1 = ++text_label;
-			l2 = instructionlabel++;
+			l2 = ++text_label;
 			C_df_ilb(l1);
 			WalkNode(right, l2);
 			C_bra(l1);
@@ -354,8 +360,8 @@ WalkStat(nd, lab)
 		{
 			arith tmp = 0;
 			struct node *fnd;
-			label l1 = instructionlabel++;
+			label l1 = ++text_label;
-			label l2 = instructionlabel++;
+			label l2 = ++text_label;
 
 			if (! DoForInit(nd, left)) break;
 			fnd = left->nd_right;
@@ -432,14 +438,16 @@ WalkStat(nd, lab)
 	case RETURN:
 		if (right) {
 			WalkExpr(right);
-			/* Assignment compatibility? Yes, see Rep. 9.11
+			/* The type of the return-expression must be
+			   assignment compatible with the result type of the
+			   function procedure (See Rep. 9.11).
 			*/
 			if (!TstAssCompat(func_type, right->nd_type)) {
 node_error(right, "type incompatibility in RETURN statement");
 			}
-			return_expr_occurred = 1;
+			C_bra((label) 1);
 		}
-		C_bra((label) 1);
+		else	C_ret((arith) 0);
 		break;
 
 	default:
@@ -447,6 +455,24 @@ node_error(right, "type incompatibility in RETURN statement");
 	}
 }
 
+extern int	NodeCrash();
+
+int (*WalkTable[])() = {
+	NodeCrash,
+	NodeCrash,
+	NodeCrash,
+	NodeCrash,
+	NodeCrash,
+	WalkCall,
+	NodeCrash,
+	NodeCrash,
+	NodeCrash,
+	NodeCrash,
+	WalkStat,
+	WalkLink,
+	NodeCrash
+};
+
 ExpectBool(nd, true_label, false_label)
 	register struct node *nd;
 	label true_label, false_label;
@@ -488,7 +514,7 @@ WalkDesignator(nd, ds)
 
 	DO_DEBUG(1, (DumpTree(nd), print("\n")));
 
-	if (! chk_designator(nd, DESIGNATOR|VARIABLE, D_DEFINED)) return;
+	if (! chk_designator(nd, VARIABLE, D_DEFINED)) return;
 
 	*ds = InitDesig;
 	CodeDesig(nd, ds);
@@ -497,6 +523,7 @@ WalkDesignator(nd, ds)
 DoForInit(nd, left)
 	register struct node *nd, *left;
 {
+	register struct def *df;
 
 	nd->nd_left = nd->nd_right = 0;
 	nd->nd_class = Name;
@@ -506,6 +533,30 @@ DoForInit(nd, left)
 	    ! chk_expr(left->nd_left) ||
 	    ! chk_expr(left->nd_right)) return 0;
 
+	df = nd->nd_def;
+	if (df->df_kind == D_FIELD) {
+		node_error(nd, "FOR-loop variable may not be a field of a record");
+		return 0;
+	}
+
+	if (!df->var_name && df->var_off >= 0) {
+		node_error(nd, "FOR-loop variable may not be a parameter");
+		return 0;
+	}
+
+	if (df->df_scope != CurrentScope) {
+		register struct scopelist *sc = CurrVis;
+
+		while (sc && sc->sc_scope != df->df_scope) {
+			sc = nextvisible(sc);
+		}
+
+		if (!sc) {
+			node_error(nd, "FOR-loop variable may not be imported");
+			return 0;
+		}
+	}
+
 	if (nd->nd_type->tp_size > word_size ||
 	    !(nd->nd_type->tp_fund & T_DISCRETE)) {
 		node_error(nd, "illegal type of FOR loop variable");
@@ -536,7 +587,7 @@ DoAssign(nd, left, right)
 	struct desig dsl, dsr;
 
 	if (!chk_expr(right)) return;
-	if (! chk_designator(left, DESIGNATOR|VARIABLE, D_DEFINED)) return;
+	if (! chk_designator(left, VARIABLE, D_DEFINED)) return;
 	TryToString(right, left->nd_type);
 	dsr = InitDesig;
 	CodeExpr(right, &dsr, NO_LABEL, NO_LABEL);

lang/m2/comp/walk.h

@@ -0,0 +1,13 @@
+/* P A R S E   T R E E   W A L K E R */
+
+/* $Header$ */
+
+/*	Definition of WalkNode macro
+*/
+
+extern int (*WalkTable[])();
+
+#define	WalkNode(xnd, xlab)	((xnd) && (*WalkTable[(xnd)->nd_class])((xnd), (xlab)))
+
+extern label	text_label;
+extern label	data_label;