newer version

lang/m2/comp/Makefile

@@ -1,16 +1,16 @@
 # make modula-2 "compiler"
 # $Header$
+EMDIR =		/usr/em
+MHDIR =		$(EMDIR)/modules/h
+PKGDIR =	$(EMDIR)/modules/pkg
+LIBDIR =	$(EMDIR)/modules/lib
+LLGEN =		$(EMDIR)/util/LLgen/src/LLgen
 
-HDIR =	../../em/h
+INCLUDES = -I$(MHDIR) -I$(EMDIR)/h -I$(PKGDIR)
-PKGDIR =	../../em/pkg
-LIBDIR =	../../em/lib
-
-INCLUDES = -I$(HDIR) -I/usr/em/h -I$(PKGDIR) -I/user1/erikb/em/h
 
 LSRC =	tokenfile.g program.g declar.g expression.g statement.g
 CC =	cc
-GEN =	/usr/em/util/LLgen/src/LLgen
+LLGENOPTIONS = -d
-GENOPTIONS = -d
 PROFILE = 
 CFLAGS = $(PROFILE) $(INCLUDES) -DSTATIC=
 LINTFLAGS = -DSTATIC= -DNORCSID
@@ -30,7 +30,8 @@ GENCFILES=	tokenfile.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
+	inputtype.h maxset.h ndir.h density.h\
+	def.h type.h Lpars.h node.h
 #
 GENFILES = $(GENGFILES) $(GENCFILES) $(GENHFILES)
 all:
@@ -39,7 +40,7 @@ all:
 	make main
 
 LLfiles:	$(LSRC)
-	$(GEN) $(GENOPTIONS) $(LSRC)
+	$(LLGEN) $(LLGENOPTIONS) $(LSRC)
 	@touch LLfiles
 
 hfiles:	Parameters make.hfiles
@@ -47,7 +48,7 @@ hfiles:	Parameters make.hfiles
 	touch hfiles
 
 main:	$(OBJ) Makefile
-	$(CC) $(LFLAGS) $(OBJ) /user1/erikb/em/lib/libem_mes.a /user1/erikb/em/lib/libeme.a $(LIBDIR)/libcomp.a $(LIBDIR)/malloc.o /user1/erikb/em/lib/libprint.a /user1/erikb/em/lib/libstr.a /user1/erikb/em/lib/libsystem.a -o main
+	$(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
 	size main
 
 clean:

lang/m2/comp/casestat.C

@@ -8,6 +8,7 @@ static char *RcsId = "$Header$";
 
 #include	<em_label.h>
 #include	<em_arith.h>
+#include	<em_code.h>
 #include	<alloc.h>
 #include	<assert.h>
 

lang/m2/comp/code.c

@@ -11,6 +11,7 @@ static char *RcsId = "$Header$";
 
 #include	<em_arith.h>
 #include	<em_label.h>
+#include	<em_code.h>
 #include	<assert.h>
 
 #include	"type.h"

lang/m2/comp/cstoper.c

@@ -32,24 +32,28 @@ cstunary(expp)
 	/*	The unary operation in "expp" is performed on the constant
 		expression below it, and the result restored in expp.
 	*/
-	arith o1 = expp->nd_right->nd_INT;
+	register arith o1 = expp->nd_right->nd_INT;
 
 	switch(expp->nd_symb) {
 	case '+':
 		break;
+
 	case '-':
 		o1 = -o1;
 		if (expp->nd_type->tp_fund == T_INTORCARD) {
 			expp->nd_type = int_type;
 		}
 		break;
+
 	case NOT:
 	case '~':
 		o1 = !o1;
 		break;
+
 	default:
 		crash("(cstunary)");
 	}
+
 	expp->nd_class = Value;
 	expp->nd_token = expp->nd_right->nd_token;
 	expp->nd_INT = o1;
@@ -65,8 +69,8 @@ cstbin(expp)
 		expressions below it, and the result restored in
 		expp.
 	*/
-	arith o1 = expp->nd_left->nd_INT;
+	register arith o1 = expp->nd_left->nd_INT;
-	arith o2 = expp->nd_right->nd_INT;
+	register arith o2 = expp->nd_right->nd_INT;
 	int uns = expp->nd_type != int_type;
 
 	assert(expp->nd_class == Oper);
@@ -158,15 +162,12 @@ cstbin(expp)
 		break;
 
 	case '<':
-		if (uns)	{
+		{	arith tmp = o1;
-			o1 = (o1 & mach_long_sign ?
+			
-				(o2 & mach_long_sign ? o1 < o2 : 0) :
+			o1 = o2;
-				(o2 & mach_long_sign ? 1 : o1 < o2)
+			o2 = tmp;
-			);
 		}
-		else
+		/* Fall through */
-			o1 = (o1 < o2);
-		break;
 
 	case '>':
 		if (uns)	{
@@ -178,16 +179,15 @@ cstbin(expp)
 		else
 			o1 = (o1 > o2);
 		break;
+
 	case LESSEQUAL:
-		if (uns)	{
+		{	arith tmp = o1;
-			o1 = (o1 & mach_long_sign ?
+			
-				(o2 & mach_long_sign ? o1 <= o2 : 0) :
+			o1 = o2;
-				(o2 & mach_long_sign ? 1 : o1 <= o2)
+			o2 = tmp;
-			);
 		}
-		else
+		/* Fall through */
-			o1 = (o1 <= o2);
+
-		break;
 	case GREATEREQUAL:
 		if (uns)	{
 			o1 = (o1 & mach_long_sign ?
@@ -198,22 +198,28 @@ cstbin(expp)
 		else
 			o1 = (o1 >= o2);
 		break;
+
 	case '=':
 		o1 = (o1 == o2);
 		break;
+
 	case '#':
 		o1 = (o1 != o2);
 		break;
+
 	case AND:
 	case '&':
 		o1 = (o1 && o2);
 		break;
+
 	case OR:
 		o1 = (o1 || o2);
 		break;
+
 	default:
 		crash("(cstbin)");
 	}
+
 	expp->nd_class = Value;
 	expp->nd_token = expp->nd_right->nd_token;
 	if (expp->nd_type == bool_type) expp->nd_symb = INTEGER;
@@ -227,7 +233,7 @@ cstbin(expp)
 cstset(expp)
 	register struct node *expp;
 {
-	register arith *set1 = 0, *set2;
+	register arith *set1, *set2;
 	arith *resultset = 0;
 	register int setsize, j;
 
@@ -253,6 +259,8 @@ cstset(expp)
 		expp->nd_left->nd_set = 0;
 		switch(expp->nd_symb) {
 		case '+':
+			/* Set union
+			*/
 			if (!set1) {
 				resultset = set2;
 				expp->nd_right->nd_set = 0;
@@ -262,11 +270,15 @@ cstset(expp)
 				*set1++ |= *set2++;
 			}
 			break;
+
 		case '-':
+			/* Set difference
+			*/
 			if (!set1 || !set2) {
 				/* The set from which something is substracted
 				   is already empty, or the set that is
-				   substracted is empty
+				   substracted is empty. In either case, the
+				   result set is set1.
 				*/
 				break;
 			}
@@ -274,34 +286,50 @@ cstset(expp)
 				*set1++ &= ~*set2++;
 			}
 			break;
+
 		case '*':
-			if (!set1) break;
+			/* Set intersection
+			*/
+			if (!set1) {
+				/* set1 is empty, and so is the result set
+				*/
+				break;
+			}
 			if (!set2) {
+				/* set 2 is empty, so the result set must be
+				   empty too.
+				*/
 				resultset = set2;
 				expp->nd_right->nd_set = 0;
 				break;
 			}
-
 			for (j = 0; j < setsize; j++) {
 				*set1++ &= *set2++;
 			}
 			break;
+
 		case '/':
+			/* Symmetric set difference
+			*/
 			if (!set1) {
 				resultset = set2;
 				expp->nd_right->nd_set = 0;
 				break;
 			}
-			if (set2) for (j = 0; j < setsize; j++) {
+			if (set2) {
+				for (j = 0; j < setsize; j++) {
 					*set1++ ^= *set2++;
 				}
+			}
 			break;
+
 		case GREATEREQUAL:
 		case LESSEQUAL:
 		case '=':
 		case '#':
-			/* Clumsy, but who cares? Nobody writes these things! */
+			/* Constant set comparisons
-			expp->nd_left->nd_set = set1;
+			*/
+			expp->nd_left->nd_set = set1;	/* may be disposed of */
 			for (j = 0; j < setsize; j++) {
 				switch(expp->nd_symb) {
 				case GREATEREQUAL:
@@ -371,11 +399,13 @@ cstcall(expp, call)
 	register struct node *expr = 0;
 
 	assert(expp->nd_class == Call);
+
 	if (expp->nd_right) {
 		expr = expp->nd_right->nd_left;
 		expp->nd_right->nd_left = 0;
 		FreeNode(expp->nd_right);
 	}
+
 	expp->nd_class = Value;
 	expp->nd_symb = INTEGER;
 	switch(call) {
@@ -384,6 +414,7 @@ cstcall(expp, call)
 		else expp->nd_INT = expr->nd_INT;
 		CutSize(expp);
 		break;
+
 	case S_CAP:
 		if (expr->nd_INT >= 'a' && expr->nd_INT <= 'z') {
 			expp->nd_INT = expr->nd_INT + ('A' - 'a');
@@ -391,10 +422,12 @@ cstcall(expp, call)
 		else	expp->nd_INT = expr->nd_INT;
 		CutSize(expp);
 		break;
+
 	case S_CHR:
 		expp->nd_INT = expr->nd_INT;
 		CutSize(expp);
 		break;
+
 	case S_MAX:
 		if (expp->nd_type == int_type) {
 			expp->nd_INT = max_int;
@@ -410,6 +443,7 @@ cstcall(expp, call)
 		}
 		else	expp->nd_INT = expp->nd_type->enm_ncst - 1;
 		break;
+
 	case S_MIN:
 		if (expp->nd_type == int_type) {
 			expp->nd_INT = (-max_int) - 1;
@@ -422,16 +456,20 @@ cstcall(expp, call)
 		}
 		else	expp->nd_INT = 0;
 		break;
+
 	case S_ODD:
 		expp->nd_INT = (expr->nd_INT & 1);
 		break;
+
 	case S_ORD:
 		expp->nd_INT = expr->nd_INT;
 		CutSize(expp);
 		break;
+
 	case S_SIZE:
 		expp->nd_INT = WA(expr->nd_type->tp_size) / word_size;
 		break;
+
 	case S_VAL:
 		expp->nd_INT = expr->nd_INT;
 		if ( /* Check overflow of subranges or enumerations */
@@ -451,6 +489,7 @@ cstcall(expp, call)
 		   )	node_warning(expp,"overflow in constant expression");
 		else CutSize(expp);
 		break;
+
 	default:
 		crash("(cstcall)");
 	}
@@ -465,8 +504,8 @@ CutSize(expr)
 	/*	The constant value of the expression expr is made to
 		conform to the size of the type of the expression.
 	*/
-	arith o1 = expr->nd_INT;
+	register arith o1 = expr->nd_INT;
-	struct type *tp = BaseType(expr->nd_type);
+	register struct type *tp = BaseType(expr->nd_type);
 	int uns;
 	int size = tp->tp_size;
 
@@ -476,26 +515,26 @@ CutSize(expr)
 		if (o1 & ~full_mask[size]) {
 			node_warning(expr,
 				"overflow in constant expression");
-		}
 			o1 &= full_mask[size];
 		}
+	}
 	else {
 		int nbits = (int) (mach_long_size - size) * 8;
 		long remainder = o1 & ~full_mask[size];
 
 		if (remainder != 0 && remainder != ~full_mask[size]) {
 			node_warning(expr, "overflow in constant expression");
-		}
 			o1 <<= nbits;
 			o1 >>= nbits;
 		}
+	}
 	expr->nd_INT = o1;
 }
 
 InitCst()
 {
-	int i = 0;
+	register int i = 0;
-	arith bt = (arith)0;
+	register arith bt = (arith)0;
 
 	while (!(bt < 0))	{
 		bt = (bt << 8) + 0377, i++;

lang/m2/comp/declar.g

@@ -33,21 +33,20 @@ ProcedureDeclaration
 	register struct def *df;
 	struct def *df1;
 } :
-			{ proclevel++; }
+			{ ++proclevel;
-	ProcedureHeading(&df1, D_PROCEDURE)
-			{
-			  CurrentScope->sc_definedby = df = df1;
-			  df->prc_vis = CurrVis;
 			  return_occurred = 0;
 			}
+	ProcedureHeading(&df1, D_PROCEDURE)
+			{ CurrentScope->sc_definedby = df = df1;
+			  df->prc_vis = CurrVis;
+			}
 	';' block(&(df->prc_body)) IDENT
-			{
+			{ match_id(dot.TOK_IDF, df->df_idf);
-			  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);
+error("function procedure %s does not return a value", df->df_idf->id_text);
 			  }
-			  proclevel--;
+			  --proclevel;
 			}
 ;
 
@@ -56,22 +55,17 @@ ProcedureHeading(struct def **pdf; int type;)
 	struct paramlist *params = 0;
 	struct type *tp = 0;
 	register struct def *df;
-	struct def *DeclProc();
 	arith NBytesParams;
 } :
 	PROCEDURE IDENT
-		{
+		{ df = DeclProc(type);
-		  df = DeclProc(type);
+		  if (proclevel > 1) {	/* need room for static link */
-		  if (proclevel > 1) {
-			/* Room for static link
-			*/
 			NBytesParams = pointer_size;
 		  }
 		  else	NBytesParams = 0;
 		}
 	FormalParameters(&params, &tp, &NBytesParams)?
-		{
+		{ tp = construct_type(T_PROCEDURE, tp);
-		  tp = construct_type(T_PROCEDURE, tp);
 		  tp->prc_params = params;
 		  tp->prc_nbpar = NBytesParams;
 		  if (df->df_type) {
@@ -85,9 +79,6 @@ error("inconsistent procedure declaration for \"%s\"", df->df_idf->id_text);
 		  }
 		  df->df_type = tp;
 		  *pdf = df;
-
-		  if (type == D_PROCHEAD) close_scope(0);
-
 		}
 ;
 
@@ -115,7 +106,7 @@ declaration:
 ;
 
 FormalParameters(struct paramlist **pr;
-		 struct type **tp;
+		 struct type **ptp;
 		 arith *parmaddr;)
 {
 	struct def *df;
@@ -128,9 +119,7 @@ FormalParameters(struct paramlist **pr;
 		]*
 	]?
 	')'
-	[	':' qualident(D_ISTYPE, &df, "type", (struct node **) 0)
+	[	':' qualtype(ptp)
-			{ *tp = df->df_type;
-			}
 	]?
 ;
 
@@ -138,13 +127,10 @@ FPSection(struct paramlist **ppr; arith *parmaddr;)
 {
 	struct node *FPList;
 	struct type *tp;
-	int VARp = D_VALPAR;
+	int VARp;
 	struct paramlist *p = 0;
 } :
-	[
+	var(&VARp) IdentList(&FPList) ':' FormalType(&p, 0)
-		VAR	{ VARp = D_VARPAR; }
-	]?
-	IdentList(&FPList) ':' FormalType(&p, 0)
 			{ EnterParamList(ppr, FPList, p->par_def->df_type,
 					 VARp, parmaddr);
 			  free_def(p->par_def);
@@ -154,25 +140,24 @@ FPSection(struct paramlist **ppr; arith *parmaddr;)
 
 FormalType(struct paramlist **ppr; int VARp;)
 {
-	struct def *df1;
 	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; }
 	|		{ ARRAYflag = 0; }
 	]
-	qualident(D_ISTYPE, &df1, "type", (struct node **) 0)
+	qualtype(&tp1)
-		{ df = df1;
+		{ if (ARRAYflag) {
-		  if (ARRAYflag) {
 			tp = construct_type(T_ARRAY, NULLTYPE);
-			tp->arr_elem = df->df_type;
+			tp->arr_elem = tp1;
-			tp->arr_elsize = ArrayElSize(df->df_type);
+			tp->arr_elsize = ArrayElSize(tp1);
 			tp->tp_align = lcm(word_align, pointer_align);
 		  }
-		  else	tp = df->df_type;
+		  else	tp = tp1;
 		  p->next = *ppr;
 		  *ppr = p;
 		  p->par_def = df = new_def();
@@ -186,23 +171,19 @@ TypeDeclaration
 	register struct def *df;
 	struct type *tp;
 }:
-	IDENT		{ df = lookup(dot.TOK_IDF, CurrentScope);
+	IDENT		{ df = define(dot.TOK_IDF,CurrentScope,D_TYPE); }
-			  if (!df) df = define(dot.TOK_IDF,CurrentScope,D_TYPE);
-			}
 	'=' type(&tp)
-			{ 
+			{ if (df->df_type && df->df_type->tp_fund == T_HIDDEN) {
-			  if (df->df_kind == D_HIDDEN) {
 			  	if (tp->tp_fund != T_POINTER) {
 error("opaque type \"%s\" is not a pointer type", df->df_idf->id_text);
 				}
-				df->df_kind = D_TYPE;
+				/* Careful now ... we might have declarations
+				   referring to the hidden type.
+				*/
 				*(df->df_type) = *tp;
 				free_type(tp);
 			  }
-			  else {	
+			  else	df->df_type = tp;
-			  	df->df_type = tp;
-			  	df->df_kind = D_TYPE;
-			  }
 			}
 ;
 
@@ -222,20 +203,17 @@ type(struct type **ptp;):
 
 SimpleType(struct type **ptp;)
 {
-	struct def *df;
+	struct type *tp;
 } :
-	qualident(D_ISTYPE, &df, "type", (struct node **) 0)
+	qualtype(ptp)
 	[
 		/* nothing */
-			{ *ptp = df->df_type; }
 	|
-		SubrangeType(ptp)
+		SubrangeType(&tp)
 		/* The subrange type is given a base type by the
 		   qualident (this is new modula-2).
 		*/
-			{
+			{ chk_basesubrange(tp, *ptp); }
-			  chk_basesubrange(*ptp, df->df_type);
-			}
 	]
 |
 	enumeration(ptp)
@@ -249,8 +227,7 @@ enumeration(struct type **ptp;)
 	register struct type *tp;
 } :
 	'(' IdentList(&EnumList) ')'
-		{
+		{ *ptp = tp = standard_type(T_ENUMERATION, 1, (arith) 1);
-		  *ptp = tp = standard_type(T_ENUMERATION, 1, (arith) 1);
 		  EnterEnumList(EnumList, tp);
 		  if (tp->enm_ncst > 256) { /* ??? is this reasonable ??? */
 			error("Too many enumeration literals");
@@ -262,9 +239,7 @@ IdentList(struct node **p;)
 {
 	register struct node *q;
 } :
-	IDENT		{ q = MkLeaf(Value, &dot);
+	IDENT		{ *p = q = MkLeaf(Value, &dot); }
-			  *p = q;
-			}
 	[
 		',' IDENT
 			{ q->next = MkLeaf(Value, &dot);
@@ -285,8 +260,7 @@ SubrangeType(struct type **ptp;)
 	'[' ConstExpression(&nd1)
 	UPTO ConstExpression(&nd2)
 	']'
-			{ *ptp = subr_type(nd1, nd2);
+			{ *ptp = subr_type(nd1, nd2); }
-			}
 ;
 
 ArrayType(struct type **ptp;)
@@ -295,9 +269,7 @@ ArrayType(struct type **ptp;)
 	register struct type *tp2;
 } :
 	ARRAY SimpleType(&tp)
-			{
+			{ *ptp = tp2 = construct_type(T_ARRAY, tp); }
-			  *ptp = tp2 = construct_type(T_ARRAY, tp);
-			}
 	[
 		',' SimpleType(&tp)
 			{ tp2->arr_elem = construct_type(T_ARRAY, tp);
@@ -311,7 +283,7 @@ ArrayType(struct type **ptp;)
 
 RecordType(struct type **ptp;)
 {
-	struct scope *scope;
+	register struct scope *scope;
 	arith count;
 	int xalign = struct_align;
 }
@@ -323,8 +295,7 @@ RecordType(struct type **ptp;)
 		  count = 0;
 		}
 	FieldListSequence(scope, &count, &xalign)
-		{
+		{ *ptp = standard_type(T_RECORD, xalign, WA(count));
-		  *ptp = standard_type(T_RECORD, xalign, WA(count));
 		  (*ptp)->rec_scope = scope;
 		}
 	END
@@ -340,8 +311,8 @@ FieldListSequence(struct scope *scope; arith *cnt; int *palign;):
 FieldList(struct scope *scope; arith *cnt; int *palign;)
 {
 	struct node *FldList;
-	struct idf *id;
+	register struct idf *id = gen_anon_idf();
-	struct def *df;
+	register struct def *df;
 	struct type *tp;
 	struct node *nd;
 	arith tcnt, max;
@@ -355,41 +326,37 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
 	CASE
 	/* Also accept old fashioned Modula-2 syntax, but give a warning
 	*/
-	[	qualident(0, &df, (char *) 0, &nd)
+	[	qualident(0, (struct def **) 0, (char *) 0, &nd)
-		[	/* This is good, in both kinds of Modula-2, if
+		[	':' qualtype(&tp)
+			/* This is correct, in both kinds of Modula-2, if
 			   the first qualident is a single identifier.
 			*/
 				{ if (nd->nd_class != Name) {
 					error("illegal variant tag");
-				id = gen_anon_idf();
 			  	  }
 			  	  else	id = nd->nd_IDF;
 				}
-		':' qualident(D_ISTYPE, &df, "type", (struct node **) 0)
 		|
 			/* Old fashioned! the first qualident now represents
 			   the type
 			*/
 				{ warning("Old fashioned Modula-2 syntax!");
-				  id = gen_anon_idf();
-				  df = ill_df;
 				  if (chk_designator(nd) &&
 				      (nd->nd_class != Def ||
-				       !(nd->nd_def->df_kind &
+				       !(nd->nd_def->df_kind&(D_ERROR|D_ISTYPE)) ||
-					 (D_ERROR|D_ISTYPE)))) {
+				       !nd->nd_def->df_type)) {
 					node_error(nd, "type expected");
+					tp = error_type;
 				  }
-				  else df = nd->nd_def;
+				  else tp = nd->nd_def->df_type;
 				  FreeNode(nd);
 				}
 		]
 	|
-		/* Aha, third edition? */
+		/* Aha, third edition. Well done! */
-		':' qualident(D_ISTYPE, &df, "type", (struct node **) 0)
+		':' qualtype(&tp)
-				{ id = gen_anon_idf(); }
 	]
-				{ tp = df->df_type;
+				{ if (!(tp->tp_fund & T_DISCRETE)) {
-				  if (!(tp->tp_fund & T_DISCRETE)) {
 					error("Illegal type in variant");
 				  }
 				  df = define(id, scope, D_FIELD);
@@ -464,12 +431,9 @@ node_error(nd1,"type incompatibility in case label");
 
 SetType(struct type **ptp;)
 {
-	struct type *tp;
 } :
-	SET OF SimpleType(&tp)
+	SET OF SimpleType(ptp)
-			{ 
+			{ *ptp = set_type(*ptp); }
-			  *ptp = set_type(tp);
-			}
 ;
 
 /*	In a pointer type definition, the type pointed at does not
@@ -478,46 +442,48 @@ SetType(struct type **ptp;)
 */
 PointerType(struct type **ptp;)
 {
-	struct type *tp;
+	register struct def *df;
-	struct def *df;
+	register struct node *nd;
-	struct node *nd;
 } :
 	POINTER TO
-	[ %if ( (df = lookup(dot.TOK_IDF, CurrentScope)))
+			{ *ptp = construct_type(T_POINTER, NULLTYPE); }
+	[ %if ( lookup(dot.TOK_IDF, CurrentScope))
 		/* Either a Module or a Type, but in both cases defined
 		   in this scope, so this is the correct identification
 		*/
-		qualident(D_ISTYPE, &df, "type", (struct node **) 0)
+		qualtype(&((*ptp)->next))
-				{
-				  if (!df->df_type) {
-					error("type \"%s\" not declared",
-						df->df_idf->id_text);
-					tp = error_type;
-				  }
-				  else	tp = df->df_type;
-				}
 	| %if ( nd = new_node(), nd->nd_token = dot,
 		df = lookfor(nd, CurrVis, 0), free_node(nd),
 	        df->df_kind == D_MODULE)
-		type(&tp)
+		type(&((*ptp)->next))
 	|
-		IDENT
+		IDENT	{ Forward(&dot, &((*ptp)->next)); }
-				{ tp = NULLTYPE; }
 	]
-				{
+;
-				  *ptp = construct_type(T_POINTER, tp);
+
-				  if (!tp) Forward(&dot, &((*ptp)->next));
+qualtype(struct type **ptp;)
+{
+	struct def *df;
+} :
+	qualident(D_ISTYPE, &df, "type", (struct node **) 0)
+		{ if (!df->df_type) {
+			error("type \"%s\" not declared", df->df_idf->id_text);
+			*ptp = error_type;
+		  }
+		  else	*ptp = df->df_type;
 		}
 ;
 
+
 ProcedureType(struct type **ptp;)
 {
 	struct paramlist *pr = 0;
-	struct type *tp = 0;
+	register struct type *tp;
 } :
-	PROCEDURE FormalTypeList(&pr, &tp)?
+			{ *ptp = 0; }
-			{ *ptp = construct_type(T_PROCEDURE, tp);
+	PROCEDURE FormalTypeList(&pr, ptp)?
-			  (*ptp)->prc_params = pr;
+			{ *ptp = tp = construct_type(T_PROCEDURE, *ptp);
+			  tp->prc_params = pr;
 			}
 ;
 
@@ -528,34 +494,30 @@ FormalTypeList(struct paramlist **ppr; struct type **ptp;)
 } :
 	'('		{ *ppr = 0; }
 	[
-		[ VAR	{ VARp = D_VARPAR; }
+		var(&VARp) FormalType(ppr, VARp)
-		|	{ VARp = D_VALPAR; }
-		]
-		FormalType(ppr, VARp)
 		[
-			','
+			',' var(&VARp) FormalType(ppr, VARp)
-			[ VAR	{VARp = D_VARPAR; }
-			|	{VARp = D_VALPAR; }
-			] 
-			FormalType(ppr, VARp)
 		]*
 	]?
 	')'
-	[ ':' qualident(D_TYPE, &df, "type", (struct node **) 0)
+	[ ':' qualtype(ptp)
-				{ *ptp = df->df_type; }
 	]?
 ;
 
+var(int *VARp;):
+	VAR		{ *VARp = D_VARPAR; }
+|
+	/* empty */	{ *VARp = D_VALPAR; }
+;
+
 ConstantDeclaration
 {
-	struct def *df;
 	struct idf *id;
 	struct node *nd;
 }:
 	IDENT		{ id = dot.TOK_IDF; }
-	'=' ConstExpression(&nd){ df = define(id, CurrentScope, D_CONST);
+	'=' ConstExpression(&nd)
-				  df->con_const = nd;
+			{ define(id,CurrentScope,D_CONST)->con_const = nd; }
-				}
 ;
 
 VariableDeclaration

lang/m2/comp/def.H

@@ -119,6 +119,7 @@ extern struct def
 	*define(),
 	*DefineLocalModule(),
 	*MkDef(),
+	*DeclProc(),
 	*ill_df;
 
 extern struct def

lang/m2/comp/def.c

@@ -232,16 +232,6 @@ DeclProc(type)
 	return df;
 }
 
-InitProc(nd, df)
-	struct node *nd;
-	struct def *df;
-{
-	/*	Create an initialization procedure for a module.
-	*/
-	df->mod_body = nd;
-	/* Keep it this way, or really create a procedure out of it??? */
-}
-
 AddModule(id)
 	struct idf *id;
 {

lang/m2/comp/desig.c

@@ -15,6 +15,7 @@ static char *RcsId = "$Header$";
 
 #include	<em_arith.h>
 #include	<em_label.h>
+#include	<em_code.h>
 #include	<assert.h>
 
 #include	"type.h"

lang/m2/comp/enter.c

@@ -9,6 +9,7 @@ static char *RcsId = "$Header$";
 #include	<alloc.h>
 #include	<em_arith.h>
 #include	<em_label.h>
+#include	<em_code.h>
 #include	<assert.h>
 
 #include	"idf.h"

lang/m2/comp/expression.g

@@ -78,17 +78,16 @@ selector(struct node **pnd;):
 
 ExpList(struct node **pnd;)
 {
-	struct node **nd;
+	register struct node *nd;
 } :
-	expression(pnd)		{ *pnd = MkNode(Link, *pnd, NULLNODE, &dot);
+	expression(pnd)		{ *pnd = nd = MkNode(Link,*pnd,NULLNODE,&dot);
 				  (*pnd)->nd_symb = ',';
-				  nd = &((*pnd)->nd_right);
 				}
 	[
-		','		{ *nd = MkLeaf(Link, &dot);
+		','		{ nd->nd_right = MkLeaf(Link, &dot);
+				  nd = nd->nd_right;
 				}
-		expression(&(*nd)->nd_left)
+		expression(&(nd->nd_left))
-				{ nd = &((*nd)->nd_right); }
 	]*
 ;
 
@@ -169,7 +168,7 @@ MulOperator:
 ;
 */
 
-factor(struct node **p;)
+factor(register struct node **p;)
 {
 	struct def *df;
 	struct node *nd;
@@ -190,8 +189,7 @@ factor(struct node **p;)
 | %default
 	number(p)
 |
-	STRING	{
+	STRING	{ *p = MkLeaf(Value, &dot);
-		  *p = MkLeaf(Value, &dot);
 		  (*p)->nd_type = toktype;
 		}
 |
@@ -205,8 +203,7 @@ bare_set(struct node **pnd;)
 {
 	register struct node *nd;
 } :
-	'{'		{
+	'{'		{ dot.tk_symb = SET;
-			  dot.tk_symb = SET;
 			  *pnd = nd = MkLeaf(Xset, &dot);
 			  nd->nd_type = bitset_type;
 			}
@@ -255,7 +252,7 @@ designator_tail(struct node **pnd;):
 	]*
 ;
 
-visible_designator_tail(struct node **pnd;):
+visible_designator_tail(register struct node **pnd;):
 	'['		{ *pnd = MkNode(Arrsel, *pnd, NULLNODE, &dot); }
 		expression(&((*pnd)->nd_right))
 		[

lang/m2/comp/main.c

@@ -26,7 +26,7 @@ static char *RcsId = "$Header$";
 int		state;			/* either IMPLEMENTATION or PROGRAM */
 char		options[128];
 int		DefinitionModule; 
-int		SYSTEMModule = 0;
+int		SYSTEMModule;
 char		*ProgName;
 char		*DEFPATH[NDIRS+1];
 struct def 	*Defined;
@@ -34,7 +34,7 @@ extern int 	err_occurred;
 extern int	fp_used;		/* set if floating point used */
 
 main(argc, argv)
-	char *argv[];
+	register char **argv;
 {
 	register int Nargc = 1;
 	register char **Nargv = &argv[0];
@@ -84,9 +84,7 @@ Compile(src, dst)
 	open_scope(CLOSEDSCOPE);
 	GlobalScope = CurrentScope;
 	C_init(word_size, pointer_size);
-	if (! C_open(dst)) {
+	if (! C_open(dst)) fatal("Could not open output file");
-		fatal("Could not open output file");
-	}
 	C_magic();
 	C_ms_emx(word_size, pointer_size);
 	CompUnit();
@@ -95,9 +93,7 @@ Compile(src, dst)
 	if (!err_occurred) {
 		C_exp(Defined->mod_vis->sc_scope->sc_name);
 		WalkModule(Defined);
-		if (fp_used) {
+		if (fp_used) C_ms_flt();
-			C_ms_flt();
-		}
 	}
 	C_close();
 #ifdef DEBUG

lang/m2/comp/program.g

@@ -41,9 +41,8 @@ static  char *RcsId = "$Header$";
 
 ModuleDeclaration
 {
-	struct idf *id;
+	struct idf *id;			/* save module identifier */
-	struct def *df;
+	register struct def *df;
-	struct node *nd;
 	struct node *exportlist = 0;
 	int qualified;
 } :
@@ -54,9 +53,8 @@ ModuleDeclaration
 	';'
 	import(1)*
 	export(&qualified, &exportlist)?
-	block(&nd)
+	block(&(df->mod_body))
-	IDENT		{ InitProc(nd, df);
+	IDENT		{ if (exportlist) {
-			  if (exportlist) {
 				EnterExportList(exportlist, qualified);
 			  }
 			  close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
@@ -93,11 +91,13 @@ export(int *QUALflag; struct node **ExportList;)
 import(int local;)
 {
 	struct node *ImportList;
-	struct node *id = 0;
+	register struct node *id;
 } :
 	[ FROM
 	  IDENT		{ id = MkLeaf(Value, &dot); }
-	]?
+	|
+			{ id = 0; }
+	]
 	IMPORT IdentList(&ImportList) ';'
 	/*
 	   When parsing a global module, this is the place where we must
@@ -113,8 +113,8 @@ import(int local;)
 DefinitionModule
 {
 	register struct def *df;
-	struct idf *id;
+	struct idf *id;			/* save module identifier */
-	struct node *exportlist = 0;
+	struct node *exportlist;
 	int dummy;
 } :
 	DEFINITION
@@ -130,19 +130,20 @@ DefinitionModule
 			}
 	';'
 	import(0)* 
-	export(&dummy, &exportlist)?
+	[
-	/*	New Modula-2 does not have export lists in definition modules.
+		export(&dummy, &exportlist)
-		For the time being, we ignore export lists here, and a
+		/*	New Modula-2 does not have export lists in definition
-		warning is issued.
+			modules. Issue a warning.
 		*/
-			{ if (exportlist) {
+			{ 
 node_warning(exportlist, "export list in definition module ignored");
 				FreeNode(exportlist);
 			}
-			}
+	|
+		/* empty */
+	]
 	definition* END IDENT
-			{
+			{ df = CurrentScope->sc_def;
-			  df = CurrentScope->sc_def;
 			  while (df) {
 				/* Make all definitions "QUALIFIED EXPORT" */
 				df->df_flags |= D_QEXPORTED;
@@ -157,7 +158,8 @@ node_warning(exportlist, "export list in definition module ignored");
 
 definition
 {
-	struct def *df;
+	register struct def *df;
+	struct def *dummy;
 } :
 	CONST [ ConstantDeclaration Semicolon ]*
 |
@@ -179,13 +181,17 @@ definition
 |
 	VAR [ VariableDeclaration Semicolon ]*
 |
-	ProcedureHeading(&df, D_PROCHEAD) Semicolon
+	ProcedureHeading(&dummy, D_PROCHEAD)
+			{ close_scope(0); }
+	Semicolon
 ;
 
+/*	The next nonterminal is used to relax the grammar a little.
+*/
 Semicolon:
 	';'
 |
-			{ warning("; expected"); }
+	/* empty */	{ warning("; expected"); }
 ;
 
 ProgramModule
@@ -193,30 +199,26 @@ ProgramModule
 	struct idf *id;
 	struct def *GetDefinitionModule();
 	register struct def *df;
-	struct node *nd;
 } :
 	MODULE
 	IDENT	{ id = dot.TOK_IDF;
 		  if (state == IMPLEMENTATION) {
 			df = GetDefinitionModule(id);
 			CurrVis = df->mod_vis;
-			CurrentScope = CurrVis->sc_scope;
 			RemoveImports(&(CurrentScope->sc_def));
 		  }
 		  else {
-			df = define(id, CurrentScope, D_MODULE);
+			Defined = df = define(id, CurrentScope, D_MODULE);
 			open_scope(CLOSEDSCOPE);
 			df->mod_vis = CurrVis;
 			CurrentScope->sc_name = "_M2M";
 		  }
-		  Defined = df;
 		  CurrentScope->sc_definedby = df;
 		}
 	priority(&(df->mod_priority))?
 	';' import(0)*
-	block(&nd) IDENT
+	block(&(df->mod_body)) IDENT
-		{ InitProc(nd, df);
+		{ close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
-		  close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
 		  match_id(id, dot.TOK_IDF);
 		}
 	'.'
@@ -228,7 +230,7 @@ Module:
 	[
 		IMPLEMENTATION	{ state = IMPLEMENTATION; }
 	|
-				{ state = PROGRAM; }
+		/* empty */	{ state = PROGRAM; }
 	]
 	ProgramModule
 ;

lang/m2/comp/statement.g

@@ -23,7 +23,6 @@ statement(register struct node **pnd;)
 {
 	register struct node *nd;
 } :
-[
 	/*
 	 * This part is not in the reference grammar. The reference grammar
 	 * states : assignment | ProcedureCall | ...
@@ -67,7 +66,6 @@ statement(register struct node **pnd;)
 	ReturnStatement(pnd)
 |
 	/* empty */	{ *pnd = 0; }
-]
 ;
 
 /*
@@ -194,8 +192,7 @@ ForStatement(struct node **pnd;)
 	[
 		BY
 		ConstExpression(&dummy)
-			{
+			{ if (!(dummy->nd_type->tp_fund & T_INTORCARD)) {
-			  if (!(dummy->nd_type->tp_fund & T_INTORCARD)) {
 				error("illegal type in BY clause");
 			  }
 			  nd->nd_INT = dummy->nd_INT;

lang/m2/comp/tmpvar.C

@@ -33,10 +33,17 @@ struct tmpvar {
 
 static struct tmpvar	*TmpInts,	/* for integer temporaries */
 			*TmpPtrs;	/* for pointer temporaries */
-extern struct scope	*ProcScope;	/* scope of procedure in which the
+static struct scope	*ProcScope;	/* scope of procedure in which the
 					   temporaries are allocated
 					*/
 
+TmpOpen(sc) struct scope *sc;
+{
+	/*	Initialize for temporaries in scope "sc".
+	*/
+	ProcScope = sc;
+}
+
 arith
 NewInt()
 {

lang/m2/comp/type.c

@@ -12,6 +12,7 @@ static char *RcsId = "$Header$";
 #include	<alloc.h>
 #include	<em_arith.h>
 #include	<em_label.h>
+#include	<em_code.h>
 
 #include	"def.h"
 #include	"type.h"

lang/m2/comp/walk.c

@@ -13,6 +13,7 @@ static char *RcsId = "$Header$";
 #include	<em_arith.h>
 #include	<em_label.h>
 #include	<em_reg.h>
+#include	<em_code.h>
 #include	<assert.h>
 
 #include	"def.h"
@@ -36,7 +37,6 @@ label		data_label;
 static struct type *func_type;
 struct withdesig *WithDesigs;
 struct node	*Modules;
-struct scope	*ProcScope;
 
 STATIC
 DoProfil()
@@ -74,9 +74,9 @@ WalkModule(module)
 	   First call initialization routines for modules defined within
 	   this module.
 	*/
-	sc->sc_off = 0;
+	sc->sc_off = 0;		/* no locals (yet) */
 	text_label = 1;
-	ProcScope = sc;	
+	TmpOpen(sc);		/* Initialize for temporaries */
 	C_pro_narg(sc->sc_name);
 	DoProfil();
 	if (module == Defined) {
@@ -130,7 +130,7 @@ WalkProcedure(procedure)
 
 	proclevel++;
 	CurrVis = procedure->prc_vis;
-	ProcScope = sc = CurrentScope;
+	sc = CurrentScope;
 
 	/* Generate code for all local modules and procedures
 	*/
@@ -140,6 +140,7 @@ WalkProcedure(procedure)
 	*/
 	C_pro_narg(sc->sc_name);
 	DoProfil();
+	TmpOpen(sc);
 
 	/* Generate calls to initialization routines of modules defined within
 	   this procedure
@@ -397,9 +398,6 @@ WalkStat(nd, lab)
 			wds.w_next = WithDesigs;
 			WithDesigs = &wds;
 			wds.w_scope = left->nd_type->rec_scope;
-			if (ds.dsg_kind != DSG_PFIXED) {
-				/* In this case, we use a temporary variable
-				*/
 			CodeAddress(&ds);
 			ds.dsg_kind = DSG_FIXED;
 			/* Create a designator structure for the
@@ -410,7 +408,6 @@ WalkStat(nd, lab)
 			CodeStore(&ds, pointer_size);
 			ds.dsg_kind = DSG_PFIXED;
 			/* the record is indirectly available */
-			}
 			wds.w_desig = ds;
 			link.sc_scope = wds.w_scope;
 			link.next = CurrVis;
@@ -418,7 +415,7 @@ WalkStat(nd, lab)
 			WalkNode(right, lab);
 			CurrVis = link.next;
 			WithDesigs = wds.w_next;
-			if (tmp) FreePtr(tmp);
+			FreePtr(tmp);
 			break;
 		}