newer version

lang/m2/comp/LLlex.c

@@ -1,9 +1,5 @@
 /* L E X I C A L   A N A L Y S E R   F O R   M O D U L A - 2 */
 
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
 #include	"debug.h"
 #include	"idfsize.h"
 #include	"numsize.h"
@@ -40,9 +36,10 @@ SkipComment()
 		Note that comments may be nested (par. 3.5).
 	*/
 	register int ch;
+	register int CommentLevel = 0;
 
+	LoadChar(ch);
 	for (;;) {
-		LoadChar(ch);
 		if (class(ch) == STNL) {
 			LineNumber++;
 #ifdef DEBUG
@@ -51,12 +48,22 @@ SkipComment()
 		}
 		else if (ch == '(') {
 			LoadChar(ch);
-			if (ch == '*') SkipComment();
+			if (ch == '*') CommentLevel++;
+			else continue;
 		}
 		else if (ch == '*') {
 			LoadChar(ch);
-			if (ch == ')') break;
+			if (ch == ')') {
+				CommentLevel--;
+				if (CommentLevel < 0) break;
+			}
+			else continue;
 		}
+		else if (ch == EOI) {
+			lexerror("unterminated comment");
+			break;
+		}
+		LoadChar(ch);
 	}
 }
 
@@ -69,7 +76,8 @@ GetString(upto)
 	register struct string *str = (struct string *) Malloc(sizeof(struct string));
 	register char *p;
 	
-	str->s_str = p = Malloc((unsigned int) (str->s_length = ISTRSIZE));
+	str->s_length = ISTRSIZE;
+	str->s_str = p = Malloc((unsigned int) ISTRSIZE);
 	while (LoadChar(ch), ch != upto)	{
 		if (class(ch) == STNL)	{
 			lexerror("newline in string");
@@ -394,6 +402,7 @@ lexwarning("Character constant out of range");
 	case STCHAR:
 	default:
 		crash("(LLlex) Impossible character class");
+		/*NOTREACHED*/
 	}
 	/*NOTREACHED*/
 }

lang/m2/comp/LLlex.h

@@ -1,7 +1,5 @@
 /* T O K E N   D E S C R I P T O R   D E F I N I T I O N */
 
-/* $Header$ */
-
 /* Structure to store a string constant
 */
 struct string {

lang/m2/comp/LLmessage.c

@@ -1,9 +1,5 @@
 /* S Y N T A X   E R R O R   R E P O R T I N G */
 
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
 /*	Defines the LLmessage routine. LLgen-generated parsers require the
 	existence of a routine of that name.
 	The routine must do syntax-error reporting and must be able to
@@ -39,24 +35,28 @@ LLmessage(tk)
 insert_token(tk)
 	int tk;
 {
-	aside = dot;
+	register struct token *dotp = ˙
 
-	dot.tk_symb = tk;
+	aside = *dotp;
+
+	dotp->tk_symb = tk;
 
 	switch (tk)	{
 	/* The operands need some body */
 	case IDENT:
-		dot.TOK_IDF = gen_anon_idf();
+		dotp->TOK_IDF = gen_anon_idf();
 		break;
 	case STRING:
-		dot.TOK_SLE = 1;
+		dotp->tk_data.tk_str = (struct string *)
-		dot.TOK_STR = Salloc("", 1);
+					Malloc(sizeof (struct string));
+		dotp->TOK_SLE = 1;
+		dotp->TOK_STR = Salloc("", 1);
 		break;
 	case INTEGER:
-		dot.TOK_INT = 1;
+		dotp->TOK_INT = 1;
 		break;
 	case REAL:
-		dot.TOK_REL = Salloc("0.0", 4);
+		dotp->TOK_REL = Salloc("0.0", 4);
 		break;
 	}
 }

lang/m2/comp/Makefile

@@ -1,5 +1,4 @@
 # make modula-2 "compiler"
-# $Header$
 EMDIR =		/usr/ceriel/em
 MHDIR =		$(EMDIR)/modules/h
 PKGDIR =	$(EMDIR)/modules/pkg
@@ -8,19 +7,26 @@ LLGEN =		$(EMDIR)/bin/LLgen
 
 INCLUDES = -I$(MHDIR) -I$(EMDIR)/h -I$(PKGDIR)
 
-LSRC =	tokenfile.g program.g declar.g expression.g statement.g
+GFILES =	tokenfile.g program.g declar.g expression.g statement.g
 CC =	cc
 LLGENOPTIONS =
 PROFILE =
 CFLAGS = $(PROFILE) $(INCLUDES) -DSTATIC=
 LINTFLAGS = -DSTATIC= -DNORCSID
 LFLAGS = $(PROFILE)
+LSRC =	tokenfile.c program.c declar.c expression.c statement.c
 LOBJ =	tokenfile.o program.o declar.o expression.o statement.o
+CSRC =	LLlex.c LLmessage.c char.c error.c main.c \
+	symbol2str.c tokenname.c idf.c input.c type.c def.c \
+	scope.c misc.c enter.c defmodule.c typequiv.c node.c \
+	cstoper.c chk_expr.c options.c walk.c casestat.c desig.c \
+	code.c tmpvar.c lookup.c Version.c
 COBJ =	LLlex.o LLmessage.o char.o error.o main.o \
 	symbol2str.o tokenname.o idf.o input.o type.o def.o \
 	scope.o misc.o enter.o defmodule.o typequiv.o node.o \
 	cstoper.o chk_expr.o options.o walk.o casestat.o desig.o \
-	code.o tmpvar.o lookup.o
+	code.o tmpvar.o lookup.o Version.o
+SRC =	$(CSRC) $(LSRC) Lpars.c
 OBJ =	$(COBJ) $(LOBJ) Lpars.o
 
 # Keep the next entries up to date!
@@ -44,11 +50,11 @@ all:	Cfiles
 	@rm -f nmclash.o a.out
 
 clean:
-	rm -f $(OBJ) $(GENFILES) LLfiles hfiles Cfiles tab cclash.o cid.o cclash cid
+	rm -f $(OBJ) $(GENFILES) LLfiles hfiles Cfiles tab cclash.o cid.o cclash cid clashes
 	(cd .. ; rm -rf Xsrc)
 
 lint:	Cfiles
-	sh -c `if $(CC) nmclash.c > /dev/null 2>&1 ; then make Xlint ; else sh Resolve Xlint ; fi'
+	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
@@ -57,20 +63,22 @@ mkdep:	mkdep.o
 cclash:	cclash.o
 	$(CC) $(LFLAGS) -o cclash cclash.o
 
+clashes:	$(SRC) $(HFILES)
+	sh -c 'if test -f clashes ; then ./cclash -l7 clashes $? > Xclashes ; mv Xclashes clashes ; else ./cclash -l7 $? > clashes ; fi'
+
 cid:	cid.o
 	$(CC) $(LFLAGS) -o cid cid.o
 
 # entry points not to be used directly
 
 Xlint:
-	lint $(INCLUDES) $(LINTFLAGS) `./sources $(OBJ)`
+	lint $(INCLUDES) $(LINTFLAGS) $(SRC)
 
-Cfiles:	hfiles LLfiles $(GENHFILES) $(GENCFILES)
+Cfiles:	hfiles LLfiles $(GENCFILES) $(GENHFILES)
-	./sources $(OBJ) > Cfiles
+	echo $(SRC) $(HFILES) > Cfiles
-	sh -c 'for i in $(HFILES) ; do echo $$i ; done >> Cfiles'
 
-LLfiles:	$(LSRC)
+LLfiles:	$(GFILES)
-	$(LLGEN) $(LLGENOPTIONS) $(LSRC)
+	$(LLGEN) $(LLGENOPTIONS) $(GFILES)
 	@touch LLfiles
 
 hfiles:	Parameters make.hfiles
@@ -78,7 +86,7 @@ hfiles:	Parameters make.hfiles
 	touch hfiles
 
 main:	$(OBJ) ../src/Makefile
-	$(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
+	$(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libem_mes.a $(LIBDIR)/libemk.a $(LIBDIR)/input.a $(LIBDIR)/assert.a $(LIBDIR)/alloc.a $(LIBDIR)/dickmalloc.o $(LIBDIR)/libprint.a $(LIBDIR)/libstr.a $(LIBDIR)/libsystem.a -o ../src/main
 	size ../src/main
 
 tokenfile.g:	tokenname.c make.tokfile
@@ -114,7 +122,7 @@ char.c: ../src/char.tab ../src/tab
 depend:	mkdep
 	sed '/^#AUTOAUTO/,$$d' Makefile > Makefile.new
 	echo '#AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO' >> Makefile.new
-	./mkdep `./sources $(OBJ)` |\
+	./mkdep $(SRC) |\
 		sed 's/\.c:/\.o:/' >> Makefile.new
 	mv Makefile Makefile.old
 	mv Makefile.new Makefile
@@ -128,13 +136,13 @@ main.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.h inputtype.h ndir.h
 symbol2str.o: Lpars.h
 tokenname.o: Lpars.h idf.h tokenname.h
 idf.o: idf.h
-input.o: f_info.h input.h inputtype.h
+input.o: def.h f_info.h idf.h input.h inputtype.h scope.h
 type.o: LLlex.h const.h debug.h def.h idf.h maxset.h node.h scope.h target_sizes.h type.h walk.h
 def.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.h type.h
 scope.o: LLlex.h debug.h def.h idf.h node.h scope.h type.h
 misc.o: LLlex.h f_info.h idf.h misc.h node.h
 enter.o: LLlex.h debug.h def.h idf.h main.h node.h scope.h type.h
-defmodule.o: LLlex.h debug.h def.h f_info.h idf.h input.h inputtype.h main.h scope.h
+defmodule.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.h inputtype.h main.h node.h scope.h
 typequiv.o: LLlex.h debug.h def.h node.h type.h
 node.o: LLlex.h debug.h def.h node.h type.h
 cstoper.o: LLlex.h Lpars.h debug.h idf.h node.h standards.h target_sizes.h type.h
@@ -145,7 +153,7 @@ casestat.o: LLlex.h Lpars.h debug.h density.h desig.h node.h type.h walk.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 walk.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
+lookup.o: LLlex.h debug.h def.h idf.h node.h scope.h type.h
 tokenfile.o: Lpars.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

lang/m2/comp/Parameters

@@ -34,13 +34,13 @@
 
 /* target machine alignment requirements	*/
 #define	AL_CHAR		1
-#define	AL_SHORT	SZ_SHORT
+#define	AL_SHORT	(int)SZ_SHORT
-#define AL_WORD		SZ_WORD
+#define AL_WORD		(int)SZ_WORD
-#define	AL_INT		SZ_WORD
+#define	AL_INT		(int)SZ_WORD
-#define	AL_LONG		SZ_WORD
+#define	AL_LONG		(int)SZ_WORD
-#define	AL_FLOAT	SZ_WORD
+#define	AL_FLOAT	(int)SZ_WORD
-#define	AL_DOUBLE	SZ_WORD
+#define	AL_DOUBLE	(int)SZ_WORD
-#define	AL_POINTER	SZ_WORD
+#define	AL_POINTER	(int)SZ_WORD
 #define AL_STRUCT	1
 #define AL_UNION	1
 
@@ -55,7 +55,7 @@ extern char options[];
 #endif DEBUG
 
 !File: inputtype.h
-#undef INP_READ_IN_ONE	1	/* read input file in one	*/
+#define INP_READ_IN_ONE	1	/* read input file in one	*/
 
 
 !File: maxset.h

lang/m2/comp/Resolve

@@ -19,10 +19,10 @@ then
 	:
 else	mkdir ../Xsrc
 fi
-make cclash
+make cclash clashes cid
-make cid
+sed '/^C_/d' < clashes > tmp$$
-./cclash -c -l7 `cat Cfiles` > clashes
+./cclash -c -l7 tmp$$ > ../Xsrc/Xclashes
-sed '/^C_/d' < clashes > ../Xsrc/Xclashes
+rm -f tmp$$
 cd ../Xsrc
 if cmp -s Xclashes clashes
 then

lang/m2/comp/Version.c

@@ -0,0 +1 @@
+char Version[] = "Version 0.5";

lang/m2/comp/casestat.C

@@ -1,8 +1,11 @@
 /* C A S E   S T A T E M E N T   C O D E   G E N E R A T I O N */
 
-#ifndef NORCSID
+/*	Generation of case statements is done by first creating a
-static char *RcsId = "$Header$";
+	description structure for the statement, build a list of the
-#endif
+	case-labels, then generating a case description in the code,
+	and generating either CSA or CSB, and then generating code for the
+	cases themselves.
+*/
 
 #include	"debug.h"
 
@@ -22,30 +25,32 @@ static char *RcsId = "$Header$";
 #include	"density.h"
 
 struct switch_hdr	{
-	struct switch_hdr *next;
+	struct switch_hdr *next;	/* in the free list */
-	label sh_break;
+	label sh_break;			/* label of statement after this one */
-	label sh_default;
+	label sh_default;		/* label of ELSE part, or 0 */
-	int sh_nrofentries;
+	int sh_nrofentries;		/* number of cases */
-	struct type *sh_type;
+	struct type *sh_type;		/* type of case expression */
-	arith sh_lowerbd;
+	arith sh_lowerbd;		/* lowest case label */
-	arith sh_upperbd;
+	arith sh_upperbd;		/* highest case label */
-	struct case_entry *sh_entries;
+	struct case_entry *sh_entries;	/* the cases with their generated
+					   labels
+					*/
 };
 
-/* STATICALLOCDEF "switch_hdr" */
+/* STATICALLOCDEF "switch_hdr" 5 */
 
 struct case_entry	{
-	struct case_entry *next;
+	struct case_entry *next;	/* next in list */
-	label ce_label;
+	label ce_label;			/* generated label */
-	arith ce_value;
+	arith ce_value;			/* value of case label */
 };
 
-/* STATICALLOCDEF "case_entry" */
+/* STATICALLOCDEF "case_entry" 20 */
 
 /* The constant DENSITY determines when CSA and when CSB instructions
    are generated. Reasonable values are: 2, 3, 4.
    On machines that have lots of address space and memory, higher values
-   are also reasonable. On these machines the density of jump tables
+   might also be reasonable. On these machines the density of jump tables
    may be lower.
 */
 #define	compact(nr, low, up)	(nr != 0 && (up - low) / nr <= DENSITY)
@@ -56,30 +61,36 @@ CaseCode(nd, exitlabel)
 {
 	/*	Check the expression, stack a new case header and
 		fill in the necessary fields.
+		"exitlabel" is the exit-label of the closest enclosing
+		LOOP-statement, or 0.
 	*/
 	register struct switch_hdr *sh = new_switch_hdr();
 	register struct node *pnode = nd;
 	register struct case_entry *ce;
 	register arith val;
-	label tablabel;
+	label CaseDescrLab;
 
 	assert(pnode->nd_class == Stat && pnode->nd_symb == CASE);
 
-	clear((char *) sh, sizeof(*sh));
+	WalkExpr(pnode->nd_left);	/* evaluate case expression */
-	WalkExpr(pnode->nd_left);
 	sh->sh_type = pnode->nd_left->nd_type;
 	sh->sh_break = ++text_label;
 
 	/* Now, create case label list
 	*/
-	while (pnode && pnode->nd_right) {
+	while (pnode->nd_right) {
 		pnode = pnode->nd_right;
 		if (pnode->nd_class == Link && pnode->nd_symb == '|') {
 			if (pnode->nd_left) {
+				/* non-empty case
+				*/
 				pnode->nd_lab = ++text_label;
-				if (! AddCases(sh,
+				if (! AddCases(sh, /* to descriptor */
 					       pnode->nd_left->nd_left,
-					       pnode->nd_lab)) {
+						   /* of case labels */
+					       pnode->nd_lab
+						   /* and code label */
+					      )) {
 					FreeSh(sh);
 					return;
 				}
@@ -90,19 +101,20 @@ CaseCode(nd, exitlabel)
 			*/
 
 			sh->sh_default = ++text_label;
-			pnode = 0;
+			break;
 		}
 	}
 
 	/* Now generate code for the switch itself
+	   First the part that CSA and CSB descriptions have in common.
 	*/
-	tablabel = ++data_label;	/* the rom must have a label	*/
+	CaseDescrLab = ++data_label;	/* the rom must have a label	*/
-	C_df_dlb(tablabel);
+	C_df_dlb(CaseDescrLab);
 	if (sh->sh_default) C_rom_ilb(sh->sh_default);
 	else C_rom_ucon("0", pointer_size);
 	if (compact(sh->sh_nrofentries, sh->sh_lowerbd, sh->sh_upperbd)) {
-		/* CSA */
+		/* CSA
-
+		*/
 		C_rom_cst(sh->sh_lowerbd);
 		C_rom_cst(sh->sh_upperbd - sh->sh_lowerbd);
 		ce = sh->sh_entries;
@@ -115,24 +127,27 @@ CaseCode(nd, exitlabel)
 			else if (sh->sh_default) C_rom_ilb(sh->sh_default);
 			else C_rom_ucon("0", pointer_size);
 		}
-		C_lae_dlb(tablabel, (arith)0); /* perform the switch	*/
+		C_lae_dlb(CaseDescrLab, (arith)0);	/* perform the switch */
 		C_csa(word_size);
 	}
-	else	{ /* CSB */
+	else	{ 
+		/* CSB
+		*/
 		C_rom_cst((arith)sh->sh_nrofentries);
 		for (ce = sh->sh_entries; ce; ce = ce->next)	{
-			/* generate the entries: value + prog.label	*/
+			/* generate the entries: value + prog.label
+			*/
 			C_rom_cst(ce->ce_value);
 			C_rom_ilb(ce->ce_label);
 		}
-		C_lae_dlb(tablabel, (arith)0); /* perform the switch	*/
+		C_lae_dlb(CaseDescrLab, (arith)0);	/* perform the switch */
 		C_csb(word_size);
 	}
 
 	/* Now generate code for the cases
 	*/
 	pnode = nd;
-	while (pnode && pnode->nd_right) {
+	while (pnode->nd_right) {
 		pnode = pnode->nd_right;
 		if (pnode->nd_class == Link && pnode->nd_symb == '|') {
 			if (pnode->nd_left) {
@@ -148,7 +163,7 @@ CaseCode(nd, exitlabel)
 
 			C_df_ilb(sh->sh_default);
 			WalkNode(pnode, exitlabel);
-			pnode = 0;
+			break;
 		}
 	}
 
@@ -157,7 +172,7 @@ CaseCode(nd, exitlabel)
 }
 
 FreeSh(sh)
-	struct switch_hdr *sh;
+	register struct switch_hdr *sh;
 {
 	/*	 free the allocated switch structure	
 	*/
@@ -176,7 +191,7 @@ FreeSh(sh)
 
 AddCases(sh, node, lbl)
 	struct switch_hdr *sh;
-	struct node *node;
+	register struct node *node;
 	label lbl;
 {
 	/*	Add case labels to the case label list
@@ -208,7 +223,7 @@ AddCases(sh, node, lbl)
 
 AddOneCase(sh, node, lbl)
 	register struct switch_hdr *sh;
-	struct node *node;
+	register struct node *node;
 	label lbl;
 {
 	register struct case_entry *ce = new_case_entry();
@@ -222,15 +237,17 @@ AddOneCase(sh, node, lbl)
 		return 0;
 	}
 	if (sh->sh_entries == 0)	{
-		/* first case entry	*/
+		/* first case entry
+		*/
 		ce->next = (struct case_entry *) 0;
 		sh->sh_entries = ce;
 		sh->sh_lowerbd = sh->sh_upperbd = ce->ce_value;
 		sh->sh_nrofentries = 1;
 	}
 	else	{
-		/* second etc. case entry		*/
+		/* second etc. case entry
-		/* find the proper place to put ce into the list	*/
+		   find the proper place to put ce into the list
+		*/
 		
 		if (ce->ce_value < sh->sh_lowerbd) {
 			sh->sh_lowerbd = ce->ce_value;

lang/m2/comp/chk_expr.c

@@ -1,9 +1,5 @@
 /* E X P R E S S I O N   C H E C K I N G */
 
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
 /*	Check expressions, and try to evaluate them as far as possible.
 */
 
@@ -31,6 +27,9 @@ int
 ChkVariable(expp)
 	register struct node *expp;
 {
+	/*	Check that "expp" indicates an item that can be
+		assigned to.
+	*/
 
 	if (! ChkDesignator(expp)) return 0;
 
@@ -47,6 +46,9 @@ STATIC int
 ChkArrow(expp)
 	register struct node *expp;
 {
+	/*	Check an application of the '^' operator.
+		The operand must be a variable of a pointer type.
+	*/
 	register struct type *tp;
 
 	assert(expp->nd_class == Arrow);
@@ -59,8 +61,7 @@ ChkArrow(expp)
 	tp = expp->nd_right->nd_type;
 
 	if (tp->tp_fund != T_POINTER) {
-		node_error(expp, "illegal operand for unary operator \"%s\"",
+		node_error(expp, "illegal operand for unary operator \"^\"");
-			symbol2str(expp->nd_symb));
 		return 0;
 	}
 
@@ -72,6 +73,12 @@ STATIC int
 ChkArr(expp)
 	register struct node *expp;
 {
+	/*	Check an array selection.
+		The left hand side must be a variable of an array type,
+		and the right hand side must be an expression that is
+		assignment compatible with the array-index.
+	*/
+
 	register struct type *tpl, *tpr;
 
 	assert(expp->nd_class == Arrsel);
@@ -91,7 +98,7 @@ ChkArr(expp)
 	tpr = expp->nd_right->nd_type;
 
 	if (tpl->tp_fund != T_ARRAY) {
-		node_error(expp, "array index not belonging to an ARRAY");
+		node_error(expp, "not indexing an ARRAY type");
 		return 0;
 	}
 
@@ -110,6 +117,7 @@ ChkArr(expp)
 	return 1;
 }
 
+#ifdef DEBUG
 STATIC int
 ChkValue(expp)
 	struct node *expp;
@@ -125,11 +133,15 @@ ChkValue(expp)
 	}
 	/*NOTREACHED*/
 }
+#endif
 
 STATIC int
 ChkLinkOrName(expp)
 	register struct node *expp;
 {
+	/*	Check either an ID or a construction of the form
+		ID.ID [ .ID ]*
+	*/
 	register struct def *df;
 
 	expp->nd_type = error_type;
@@ -140,6 +152,9 @@ ChkLinkOrName(expp)
 		expp->nd_type = RemoveEqual(expp->nd_def->df_type);
 	}
 	else if (expp->nd_class == Link) {
+		/*	A selection from a record or a module.
+			Modules also have a record type.
+		*/
 		register struct node *left = expp->nd_left;
 
 		assert(expp->nd_symb == '.');
@@ -188,16 +203,17 @@ df->df_idf->id_text);
 	if (df->df_kind == D_ERROR) return 0;
 
 	if (df->df_kind & (D_ENUM | D_CONST)) {
+		/* Replace an enum-literal or a CONST identifier by its value.
+		*/
 		if (df->df_kind == D_ENUM) {
 			expp->nd_class = Value;
 			expp->nd_INT = df->enm_val;
 			expp->nd_symb = INTEGER;
 		}
 		else  {
-			unsigned int ln;
+			unsigned int ln = expp->nd_lineno;
 
 			assert(df->df_kind == D_CONST);
-			ln = expp->nd_lineno;
 			*expp = *(df->con_const);
 			expp->nd_lineno = ln;
 		}
@@ -210,25 +226,28 @@ STATIC int
 ChkExLinkOrName(expp)
 	register struct node *expp;
 {
+	/*	Check either an ID or an ID.ID [.ID]* occurring in an
+		expression.
+	*/
 	register struct def *df;
 
 	if (! ChkLinkOrName(expp)) return 0;
 	if (expp->nd_class != Def) return 1;
 	df = expp->nd_def;
 
-	if (!(df->df_kind & (D_ENUM|D_CONST|D_PROCEDURE|D_FIELD|D_VARIABLE|D_PROCHEAD))) {
+	if (!(df->df_kind & D_VALUE)) {
 		node_error(expp, "value expected");
 	}
 
 	if (df->df_kind == D_PROCEDURE) {
-		/* Check that this procedure is one that we
+		/* Check that this procedure is one that we may take the
-		   may take the address from.
+		   address from.
 		*/
 		if (df->df_type == std_type || df->df_scope->sc_level > 0) {
 			/* Address of standard or nested procedure
 			   taken.
 			*/
-node_error(expp, "it is illegal to take the address of a standard or local procedure");
+node_error(expp, "standard or local procedures may not be assigned");
 			return 0;
 		}
 	}
@@ -236,20 +255,6 @@ node_error(expp, "it is illegal to take the address of a standard or local proce
 	return 1;
 }
 
-STATIC int
-RemoveSet(set)
-	arith **set;
-{
-	/*	This routine is only used for error exits of ChkElement.
-		It frees the set indicated by "set", and returns 0.
-	*/
-	if (*set) {
-		free((char *) *set);
-		*set = 0;
-	}
-	return 0;
-}
-
 STATIC int
 ChkElement(expp, tp, set)
 	register struct node *expp;
@@ -279,7 +284,7 @@ ChkElement(expp, tp, set)
 
 		    	if (left->nd_INT > right->nd_INT) {
 node_error(expp, "lower bound exceeds upper bound in range");
-				return RemoveSet(set);
+				return 0;
 			}
 
 			if (*set) {
@@ -298,28 +303,24 @@ node_error(expp, "lower bound exceeds upper bound in range");
 
 	/* Here, a single element is checked
 	*/
-	if (!ChkExpression(expp)) {
+	if (!ChkExpression(expp)) return 0;
-		return RemoveSet(set);
-	}
 
 	if (!TstCompat(tp, expp->nd_type)) {
 		node_error(expp, "set element has incompatible type");
-		return RemoveSet(set);
+		return 0;
 	}
 
 	if (expp->nd_class == Value) {
 		/* a constant element
 		*/
-		i = expp->nd_INT;
+		arith low, high;
 
-	    	if ((tp->tp_fund != T_ENUMERATION &&
+		i = expp->nd_INT;
-		     (i < tp->sub_lb || i > tp->sub_ub))
+		getbounds(tp, &low, &high);
-		   ||
+
-		    (tp->tp_fund == T_ENUMERATION &&
+	    	if (i < low || i > high) {
-		     (i < 0 || i > tp->enm_ncst))
-		   ) {
 			node_error(expp, "set element out of range");
-			return RemoveSet(set);
+			return 0;
 		}
 
 		if (*set) (*set)[i/wrd_bits] |= (1 << (i%wrd_bits));
@@ -353,9 +354,11 @@ ChkSet(expp)
 		assert(nd->nd_class == Def);
 		df = nd->nd_def;
 
-		if (!(df->df_kind & (D_TYPE|D_ERROR)) ||
+		if (!is_type(df) ||
 		    (df->df_type->tp_fund != T_SET)) {
-node_error(expp, "specifier does not represent a set type");
+			if (df->df_kind != D_ERROR) {
+node_error(expp, "type specifier does not represent a set type");
+			}
 			return 0;
 		}
 		tp = df->df_type;
@@ -394,7 +397,8 @@ node_error(expp, "specifier does not represent a set type");
 		/* Yes, it was a constant set, and we managed to compute it!
 		   Notice that at the moment there is no such thing as
 		   partial evaluation. Either we evaluate the set, or we
-		   don't (at all). Improvement not neccesary. (???)
+		   don't (at all). Improvement not neccesary (???)
+		   ??? sets have a contant part and a variable part ???
 		*/
 		expp->nd_class = Set;
 		expp->nd_set = set;
@@ -417,7 +421,6 @@ getarg(argp, bases, designator)
 		that it must be a designator and may not be a register
 		variable.
 	*/
-	struct type *tp;
 	register struct node *arg = (*argp)->nd_right;
 	register struct node *left;
 
@@ -437,8 +440,7 @@ getarg(argp, bases, designator)
 	}
 
 	if (bases) {
-		tp = BaseType(left->nd_type);
+		if (!(BaseType(left->nd_type)->tp_fund & bases)) {
-		if (!(tp->tp_fund & bases)) {
 			node_error(arg, "unexpected type");
 			return 0;
 		}
@@ -452,7 +454,12 @@ STATIC struct node *
 getname(argp, kinds)
 	struct node **argp;
 {
+	/*	Get the next argument from argument list "argp".
+		The argument must indicate a definition, and the
+		definition kind must be one of "kinds".
+	*/
 	register struct node *arg = *argp;
+	register struct node *left;
 
 	if (!arg->nd_right) {
 		node_error(arg, "too few arguments supplied");
@@ -460,25 +467,26 @@ getname(argp, kinds)
 	}
 
 	arg = arg->nd_right;
-	if (! ChkDesignator(arg->nd_left)) return 0;
+	left = arg->nd_left;
+	if (! ChkDesignator(left)) return 0;
 
-	if (arg->nd_left->nd_class != Def && arg->nd_left->nd_class != LinkDef) {
+	if (left->nd_class != Def && left->nd_class != LinkDef) {
 		node_error(arg, "identifier expected");
 		return 0;
 	}
 
-	if (!(arg->nd_left->nd_def->df_kind & kinds)) {
+	if (!(left->nd_def->df_kind & kinds)) {
 		node_error(arg, "unexpected type");
 		return 0;
 	}
 
 	*argp = arg;
-	return arg->nd_left;
+	return left;
 }
 
 STATIC int
 ChkProcCall(expp)
-	register struct node *expp;
+	struct node *expp;
 {
 	/*	Check a procedure call
 	*/
@@ -487,11 +495,12 @@ ChkProcCall(expp)
 	register struct paramlist *param;
 
 	left = expp->nd_left;
-	arg = expp;
 	expp->nd_type = RemoveEqual(ResultType(left->nd_type));
 
+	/* Check parameter list
+	*/
 	for (param = ParamList(left->nd_type); param; param = param->next) {
-		if (!(left = getarg(&arg, 0, IsVarParam(param)))) return 0;
+		if (!(left = getarg(&expp, 0, IsVarParam(param)))) return 0;
 		if (left->nd_symb == STRING) {
 			TryToString(left, TypeOfParam(param));
 		}
@@ -504,8 +513,8 @@ node_error(left, "type incompatibility in parameter");
 		}
 	}
 
-	if (arg->nd_right) {
+	if (expp->nd_right) {
-		node_error(arg->nd_right, "too many parameters supplied");
+		node_error(expp->nd_right, "too many parameters supplied");
 		return 0;
 	}
 
@@ -517,7 +526,7 @@ ChkCall(expp)
 	register struct node *expp;
 {
 	/*	Check something that looks like a procedure or function call.
-		Of course this does not have to be a call at all.
+		Of course this does not have to be a call at all,
 		it may also be a cast or a standard procedure call.
 	*/
 	register struct node *left;
@@ -531,14 +540,14 @@ ChkCall(expp)
 	if (! ChkDesignator(left)) return 0;
 
 	if (IsCast(left)) {
-		/* It was a type cast. This is of course not portable.
+		/* It was a type cast.
 		*/
 		return ChkCast(expp, left);
 	}
 
 	if (IsProcCall(left)) {
-		/* A procedure call. it may also be a call to a
+		/* A procedure call.
-		   standard procedure
+		   It may also be a call to a standard procedure
 		*/
 		if (left->nd_type == std_type) {
 			/* A standard procedure
@@ -559,6 +568,10 @@ STATIC struct type *
 ResultOfOperation(operator, tp)
 	struct type *tp;
 {
+	/*	Return the result type of the binary operation "operator",
+		with operand type "tp".
+	*/
+
 	switch(operator) {
 	case '=':
 	case '#':
@@ -582,6 +595,10 @@ Boolean(operator)
 STATIC int
 AllowedTypes(operator)
 {
+	/*	Return a bit mask indicating the allowed operand types
+		for binary operator "operator".
+	*/
+
 	switch(operator) {
 	case '+':
 	case '-':
@@ -615,13 +632,17 @@ STATIC int
 ChkAddress(tpl, tpr)
 	register struct type *tpl, *tpr;
 {
+	/*	Check that either "tpl" or "tpr" are both of type
+		address_type, or that one of them is, but the other is
+		of type cardinal.
+	*/
 	
 	if (tpl == address_type) {
-		return tpr == address_type || tpr->tp_fund != T_POINTER;
+		return tpr == address_type || (tpr->tp_fund & T_CARDINAL);
 	}
 
 	if (tpr == address_type) {
-		return tpl->tp_fund != T_POINTER;
+		return (tpl->tp_fund & T_CARDINAL);
 	}
 
 	return 0;
@@ -656,21 +677,26 @@ ChkBinOper(expp)
 		}
 	}
 
-	expp->nd_type = ResultOfOperation(expp->nd_symb, tpl);
+	expp->nd_type = ResultOfOperation(expp->nd_symb, tpr);
 
+	/* Check that the application of the operator is allowed on the type
+	   of the operands.
+	   There are three tricky parts:
+	   - Boolean operators are only allowed on boolean operands, but
+	     the "allowed-mask" of "AllowedTypes" can only indicate
+	     an enumeration type.
+	   - All operations that are allowed on CARDINALS are also allowed
+	     on ADDRESS.
+	   - The IN-operator has as right-hand-size operand a set.
+	*/
 	if (expp->nd_symb == IN) {
-		/* Handle this one specially */
-		if (tpr->tp_fund != T_SET) {
-node_error(expp, "RHS of IN operator not a SET type");
-			return 0;
-		}
 		if (!TstAssCompat(tpl, ElementType(tpr))) {
 			/* Assignment compatible ???
 			   I don't know! Should we be allowed to check
 			   if a CARDINAL is a member of a BITSET???
 			*/
 
-node_error(expp, "IN operator: type of LHS not compatible with element type of RHS");
+node_error(expp, "incompatible types for operator \"IN\"");
 			return 0;
 		}
 		if (left->nd_class == Value && right->nd_class == Set) {
@@ -679,6 +705,25 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
 		return 1;
 	}
 
+	allowed = AllowedTypes(expp->nd_symb);
+
+	if (!(tpr->tp_fund & allowed) || !(tpl->tp_fund & allowed)) {
+	    	if (!((T_CARDINAL & allowed) &&
+	             ChkAddress(tpl, tpr))) {
+node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb));
+			return 0;
+		}
+		if (expp->nd_type->tp_fund & T_CARDINAL) {
+			expp->nd_type = address_type;
+		}
+	}
+
+	if (Boolean(expp->nd_symb) && tpl != bool_type) {
+node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb));
+	    
+		return 0;
+	}
+
 	/* Operands must be compatible (distilled from Def 8.2)
 	*/
 	if (!TstCompat(tpl, tpr)) {
@@ -687,32 +732,6 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
 		return 0;
 	}
 
-	allowed = AllowedTypes(expp->nd_symb);
-
-	/* Check that the application of the operator is allowed on the type
-	   of the operands.
-	   There are two tricky parts:
-	   - Boolean operators are only allowed on boolean operands, but
-	     the "allowed-mask" of "AllowedTypes" can only indicate
-	     an enumeration type.
-	   - All operations that are allowed on CARDINALS are also allowed
-	     on ADDRESS.
-	*/
-	if (Boolean(expp->nd_symb) && tpl != bool_type) {
-node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb));
-	    
-		return 0;
-	}
-	if (!(tpl->tp_fund & allowed)) {
-	    	if (!(tpl->tp_fund == T_POINTER &&
-	      	     (T_CARDINAL & allowed) &&
-	             ChkAddress(tpl, tpr))) {
-node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb));
-			return 0;
-		}
-		if (expp->nd_type == card_type) expp->nd_type = address_type;
-	}
-
 	if (tpl->tp_fund == T_SET) {
 	    	if (left->nd_class == Set && right->nd_class == Set) {
 			cstset(expp);
@@ -737,9 +756,8 @@ ChkUnOper(expp)
 
 	if (! ChkExpression(right)) return 0;
 
-	tpr = BaseType(right->nd_type);
+	expp->nd_type = tpr = BaseType(right->nd_type);
 	if (tpr == address_type) tpr = card_type;
-	expp->nd_type = tpr;
 
 	switch(expp->nd_symb) {
 	case '+':
@@ -799,6 +817,9 @@ STATIC struct node *
 getvariable(argp)
 	struct node **argp;
 {
+	/*	Get the next argument from argument list "argp".
+		It must obey the rules of "ChkVariable".
+	*/
 	register struct node *arg = *argp;
 
 	arg = arg->nd_right;
@@ -807,10 +828,11 @@ getvariable(argp)
 		return 0;
 	}
 
-	if (! ChkVariable(arg->nd_left)) return 0;
-
 	*argp = arg;
-	return arg->nd_left;
+	arg = arg->nd_left;
+	if (! ChkVariable(arg)) return 0;
+
+	return arg;
 }
 
 STATIC int
@@ -1104,7 +1126,11 @@ done_before(expp)
 extern int	NodeCrash();
 
 int (*ExprChkTable[])() = {
+#ifdef DEBUG
 	ChkValue,
+#else
+	done_before,
+#endif
 	ChkArr,
 	ChkBinOper,
 	ChkUnOper,
@@ -1120,7 +1146,11 @@ int (*ExprChkTable[])() = {
 };
 
 int (*DesigChkTable[])() = {
+#ifdef DEBUG
 	ChkValue,
+#else
+	done_before,
+#endif
 	ChkArr,
 	no_desig,
 	no_desig,

lang/m2/comp/chk_expr.h

@@ -1,7 +1,5 @@
 /* E X P R E S S I O N   C H E C K I N G */
 
-/* $Header$ */
-
 extern int	(*ExprChkTable[])();	/* table of expression checking
 					   functions, indexed by node class
 					*/

lang/m2/comp/class.h

@@ -1,7 +1,5 @@
 /* U S E   O F   C H A R A C T E R   C L A S S E S */
 
-/* $Header$ */
-
 /*	As a starter, chars are divided into classes, according to which
 	token they can be the start of.
 	At present such a class number is supposed to fit in 4 bits.

lang/m2/comp/code.c

@@ -1,9 +1,5 @@
 /* C O D E   G E N E R A T I O N   R O U T I N E S */
 
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
 /*	Code generation for expressions and coercions
 */
 
@@ -34,7 +30,6 @@ CodeConst(cst, size)
 {
 	/*	Generate code to push constant "cst" with size "size"
 	*/
-	label dlab;
 
 	if (size <= word_size) {
 		C_loc(cst);
@@ -43,23 +38,28 @@ CodeConst(cst, size)
 		C_ldc(cst);
 	}
 	else {
-		C_df_dlb(dlab = ++data_label);
+		crash("(CodeConst)");
+/*
+		label dlab = ++data_label;
+
+		C_df_dlb(dlab);
 		C_rom_icon(long2str((long) cst), size);
 		C_lae_dlb(dlab, (arith) 0);
 		C_loi(size);
+*/
 	}
 }
 
 CodeString(nd)
 	register struct node *nd;
 {
-	label lab;
-
 	if (nd->nd_type->tp_fund != T_STRING) {
 		C_loc(nd->nd_INT);
 	}
 	else {
-		C_df_dlb(lab = ++data_label);
+		label lab = ++data_label;
+
+		C_df_dlb(lab);
 		C_rom_scon(nd->nd_STR, WA(nd->nd_SLE + 1));
 		C_lae_dlb(lab, (arith) 0);
 	}
@@ -85,16 +85,6 @@ CodePadString(nd, sz)
 	C_loi(sizearg);
 }
 
-CodeReal(nd)
-	register struct node *nd;
-{
-	label lab = ++data_label;
-
-	C_df_dlb(lab);
-	C_rom_fcon(nd->nd_REL, nd->nd_type->tp_size);
-	C_lae_dlb(lab, (arith) 0);
-	C_loi(nd->nd_type->tp_size);
-}
 
 CodeExpr(nd, ds, true_label, false_label)
 	register struct node *nd;
@@ -136,8 +126,14 @@ CodeExpr(nd, ds, true_label, false_label)
 
 	case Value:
 		switch(nd->nd_symb) {
-		case REAL:
+		case REAL: {
-			CodeReal(nd);
+			label lab = ++data_label;
+
+			C_df_dlb(lab);
+			C_rom_fcon(nd->nd_REL, nd->nd_type->tp_size);
+			C_lae_dlb(lab, (arith) 0);
+			C_loi(nd->nd_type->tp_size);
+			}
 			break;
 		case STRING:
 			CodeString(nd);
@@ -157,8 +153,8 @@ CodeExpr(nd, ds, true_label, false_label)
 		break;
 
 	case Set: {
-		arith *st;
+		register arith *st = nd->nd_set;
-		int i;
+		register int i;
 
 		st = nd->nd_set;
 		ds->dsg_kind = DSG_LOADED;
@@ -182,6 +178,8 @@ CodeExpr(nd, ds, true_label, false_label)
 	}
 
 	if (true_label != 0) {
+		/* Only for boolean expressions
+		*/
 		CodeValue(ds, tp->tp_size);
 		*ds = InitDesig;
 		C_zne(true_label);
@@ -293,6 +291,7 @@ CodeCall(nd)
 		and result is already done.
 	*/
 	register struct node *left = nd->nd_left;
+	register struct node *right = nd->nd_right;
 	register struct type *result_tp;
 
 	if (left->nd_type == std_type) {
@@ -303,16 +302,16 @@ CodeCall(nd)
 	if (IsCast(left)) {
 		/* it was just a cast. Simply ignore it
 		*/
-		CodePExpr(nd->nd_right->nd_left);
+		CodePExpr(right->nd_left);
-		*nd = *(nd->nd_right->nd_left);
+		*nd = *(right->nd_left);
 		nd->nd_type = left->nd_def->df_type;
 		return;
 	}
 
 	assert(IsProcCall(left));
 
-	if (nd->nd_right) {
+	if (right) {
-		CodeParameters(ParamList(left->nd_type), nd->nd_right);
+		CodeParameters(ParamList(left->nd_type), right);
 	}
 
 	switch(left->nd_class) {
@@ -387,11 +386,9 @@ CodeParameters(param, arg)
 			C_loc((left_type->tp_size+word_size-1) / word_size - 1);
 		}
 		else {
-			tp = IndexType(left_type);
+			arith lb, ub;
-			if (tp->tp_fund == T_SUBRANGE) {
+			getbounds(IndexType(left_type), &lb, &ub);
-				C_loc(tp->sub_ub - tp->sub_lb);
+			C_loc(ub - lb);
-			}
-			else	C_loc((arith) (tp->enm_ncst - 1));
 		}
 		C_loc((arith) 0);
 		if (left->nd_symb == STRING) {
@@ -417,7 +414,7 @@ CodeStd(nd)
 	register struct node *arg = nd->nd_right;
 	register struct node *left = 0;
 	register struct type *tp = 0;
-	int std;
+	int std = nd->nd_left->nd_def->df_value.df_stdname;
 
 	if (arg) {
 		left = arg->nd_left;
@@ -425,7 +422,7 @@ CodeStd(nd)
 		arg = arg->nd_right;
 	}
 
-	switch(std = nd->nd_left->nd_def->df_value.df_stdname) {
+	switch(std) {
 	case S_ABS:
 		CodePExpr(left);
 		if (tp->tp_fund == T_INTEGER) {
@@ -446,7 +443,7 @@ CodeStd(nd)
 
 	case S_CAP:
 		CodePExpr(left);
-		C_loc((arith) 0137);
+		C_loc((arith) 0137);	/* ASCII assumed */
 		C_and(word_size);
 		break;
 
@@ -498,34 +495,25 @@ CodeStd(nd)
 		break;
 
 	case S_DEC:
-	case S_INC:
+	case S_INC: {
+		register arith size = tp->tp_size;
+
+		if (size < word_size) size = word_size;
 		CodePExpr(left);
 		if (arg) CodePExpr(arg->nd_left);
 		else	C_loc((arith) 1);
-		if (tp->tp_size <= word_size) {
+		if (std == S_DEC) {
-			if (std == S_DEC) {
+			if (tp->tp_fund == T_INTEGER) C_sbi(size);
-				if (tp->tp_fund == T_INTEGER) C_sbi(word_size);
+			else	C_sbu(size);
-				else	C_sbu(word_size);
-			}
-			else {
-				if (tp->tp_fund == T_INTEGER) C_adi(word_size);
-				else	C_adu(word_size);
-			}
-			RangeCheck(tp, int_type);
 		}
 		else {
-			CodeCoercion(int_type, tp);
+			if (tp->tp_fund == T_INTEGER) C_adi(size);
-			if (std == S_DEC) {
+			else	C_adu(size);
-				if (tp->tp_fund==T_INTEGER) C_sbi(tp->tp_size);
-				else	C_sbu(tp->tp_size);
-			}
-			else {
-				if (tp->tp_fund==T_INTEGER) C_adi(tp->tp_size);
-				else	C_adu(tp->tp_size);
-			}
 		}
+		if (size == word_size) RangeCheck(tp, int_type);
 		CodeDStore(left);
 		break;
+		}
 
 	case S_HALT:
 		C_cal("_halt");
@@ -552,29 +540,30 @@ CodeStd(nd)
 }
 
 CodeAssign(nd, dss, dst)
-	struct node *nd;
+	register struct node *nd;
 	struct desig *dst, *dss;
 {
 	/*	Generate code for an assignment. Testing of type
 		compatibility and the like is already done.
 	*/
 	register struct type *tp = nd->nd_right->nd_type;
+	arith size = nd->nd_left->nd_type->tp_size;
 
 	if (dss->dsg_kind == DSG_LOADED) {
 		if (tp->tp_fund == T_STRING) {
 			CodeAddress(dst);
 			C_loc(tp->tp_size);
-			C_loc(nd->nd_left->nd_type->tp_size);
+			C_loc(size);
 			C_cal("_StringAssign");
 			C_asp((int_size << 1) + (pointer_size << 1));
 			return;
 		}
-		CodeStore(dst, nd->nd_left->nd_type->tp_size);
+		CodeStore(dst, size);
 		return;
 	}
 	CodeAddress(dss);
 	CodeAddress(dst);
-	C_blm(nd->nd_left->nd_type->tp_size);
+	C_blm(size);
 }
 
 RangeCheck(tpl, tpr)
@@ -593,7 +582,10 @@ RangeCheck(tpl, tpr)
 		}
 		else {
 			/* both types are restricted. check the bounds
-			   to see wether we need a range check
+			   to see wether we need a range check.
+			   We don't need one if the range of values of the
+			   right hand side is a subset of the range of values
+			   of the left hand side.
 			*/
 			getbounds(tpl, &llo, &lhi);
 			getbounds(tpr, &rlo, &rhi);
@@ -806,6 +798,7 @@ CodeOper(expr, true_label, false_label)
 			C_bra(false_label);
 		}
 		break;
+	case OR:
 	case AND:
 	case '&': {
 		label l_true, l_false, l_maybe = ++text_label, l_end;
@@ -822,7 +815,10 @@ CodeOper(expr, true_label, false_label)
 		}
 
 		Des = InitDesig;
-		CodeExpr(leftop, &Des, l_maybe, l_false);
+		if (expr->nd_symb == OR) {
+			CodeExpr(leftop, &Des, l_true, l_maybe);
+		}
+		else	CodeExpr(leftop, &Des, l_maybe, l_false);
 		C_df_ilb(l_maybe);
 		Des = InitDesig;
 		CodeExpr(rightop, &Des, l_true, l_false);
@@ -836,34 +832,6 @@ CodeOper(expr, true_label, false_label)
 		}
 		break;
 		}
-	case OR: {
-		label l_true, l_false, l_maybe = ++text_label, l_end;
-		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);
-			C_df_ilb(l_true);
-			C_loc((arith)1);
-			C_df_ilb(l_end);
-		}
-		break;
-		}
 	default:
 		crash("(CodeOper) Bad operator %s\n",symbol2str(expr->nd_symb));
 	}
@@ -958,9 +926,9 @@ CodeUoper(nd)
 CodeSet(nd)
 	register struct node *nd;
 {
-	struct type *tp = nd->nd_type;
+	register struct type *tp = nd->nd_type;
 
-	C_zer(nd->nd_type->tp_size);	/* empty set */
+	C_zer(tp->tp_size);	/* empty set */
 	nd = nd->nd_right;
 	while (nd) {
 		assert(nd->nd_class == Link && nd->nd_symb == ',');

lang/m2/comp/const.h

@@ -1,7 +1,5 @@
 /* C O N S T A N T S   F O R   E X P R E S S I O N   H A N D L I N G */
 
-/* $Header$ */
-
 extern long
 	mach_long_sign;	/* sign bit of the machine long */
 extern int

lang/m2/comp/cstoper.c

@@ -1,9 +1,5 @@
 /* C O N S T A N T   E X P R E S S I O N   H A N D L I N G */
 
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
 #include	"debug.h"
 #include	"target_sizes.h"
 
@@ -35,8 +31,10 @@ cstunary(expp)
 	register arith o1 = expp->nd_right->nd_INT;
 
 	switch(expp->nd_symb) {
+	/* Should not get here
 	case '+':
 		break;
+	*/
 
 	case '-':
 		o1 = -o1;
@@ -71,7 +69,7 @@ cstbin(expp)
 	*/
 	register arith o1 = expp->nd_left->nd_INT;
 	register arith o2 = expp->nd_right->nd_INT;
-	int uns = expp->nd_type != int_type;
+	register int uns = expp->nd_type != int_type;
 
 	assert(expp->nd_class == Oper);
 	assert(expp->nd_left->nd_class == Value);

lang/m2/comp/declar.g

@@ -1,10 +1,6 @@
 /* D E C L A R A T I O N S */
 
 {
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
 #include	"debug.h"
 
 #include	<em_arith.h>
@@ -23,69 +19,38 @@ static char *RcsId = "$Header$";
 #include	"chk_expr.h"
 
 int		proclevel = 0;		/* nesting level of procedures */
-int		return_occurred;	/* set if a return occurred in a
+int		return_occurred;	/* set if a return occurs in a block */
-					   procedure or function
-					*/
 }
 
 ProcedureDeclaration
 {
-	register struct def *df;
+	struct def *df;
-	struct def *df1;		/* only exists because &df is illegal */
 } :
-			{ ++proclevel;
+			{ ++proclevel; }
-			  return_occurred = 0;
+	ProcedureHeading(&df, D_PROCEDURE)
-			}
+	';' block(&(df->prc_body))
-	ProcedureHeading(&df1, D_PROCEDURE)
+	IDENT
-			{ CurrentScope->sc_definedby = df = df1;
+			{ EndProc(df, dot.TOK_IDF);
-			  df->prc_vis = CurrVis;
-			}
-	';' 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 %s does not return a value", df->df_idf->id_text);
-			  }
 			  --proclevel;
 			}
 ;
 
 ProcedureHeading(struct def **pdf; int type;)
 {
-	struct paramlist *params = 0;
+	struct type *tp = 0;
-	register struct type *tp;
+#define needs_static_link()	(proclevel > 1)
-	struct type *tp1 = 0;
+	arith parmaddr = needs_static_link() ? pointer_size : 0;
-	register struct def *df;
+	struct paramlist *pr = 0;
-	arith NBytesParams;		/* parameter offset counter */
 } :
 	PROCEDURE IDENT
-		{ df = DeclProc(type);
+			{ *pdf = DeclProc(type, dot.TOK_IDF); }
-		  if (proclevel > 1) {	/* need room for static link */
+	FormalParameters(&pr, &parmaddr, &tp)?
-			NBytesParams = pointer_size;
+			{ CheckWithDef(*pdf, proc_type(tp, pr, parmaddr)); }
-		  }
-		  else	NBytesParams = 0;
-		}
-	FormalParameters(&params, &tp1, &NBytesParams)?
-		{ tp = construct_type(T_PROCEDURE, tp1);
-		  tp->prc_params = params;
-		  tp->prc_nbpar = NBytesParams;
-		  if (df->df_type) {
-			/* We already saw a definition of this type
-			   in the definition module.
-			*/
-		  	if (!TstProcEquiv(tp, df->df_type)) {
-error("inconsistent procedure declaration for \"%s\"", df->df_idf->id_text); 
-			}
-			FreeType(df->df_type);
-		  }
-		  df->df_type = tp;
-		  *pdf = df;
-		}
 ;
 
 block(struct node **pnd;) :
 	declaration*
-	[
+	[		{ return_occurred = 0; }
 		BEGIN
 		StatementSequence(pnd)
 	|
@@ -106,15 +71,12 @@ declaration:
 	ModuleDeclaration ';'
 ;
 
-FormalParameters(struct paramlist **pr;
+FormalParameters(struct paramlist *ppr; arith *parmaddr; struct type **ptp;):
-		 struct type **ptp;
-		 arith *parmaddr;)
-:	
 	'('
 	[
-		FPSection(pr, parmaddr)
+		FPSection(ppr, parmaddr)
 		[
-			';' FPSection(pr, parmaddr)
+			';' FPSection(ppr, parmaddr)
 		]*
 	]?
 	')'
@@ -134,12 +96,12 @@ FPSection(struct paramlist **ppr; arith *parmaddr;)
 
 FormalType(struct type **ptp;)
 {
-	register struct type *tp;
 	extern arith ArrayElSize();
 } :
 	ARRAY OF qualtype(ptp)
-		{ tp = construct_type(T_ARRAY, NULLTYPE);
+		{ register struct type *tp = construct_type(T_ARRAY, NULLTYPE);
-		  tp->arr_elem = *ptp; *ptp = tp;
+		  tp->arr_elem = *ptp;
+		  *ptp = tp;
 		  tp->arr_elsize = ArrayElSize(tp->arr_elem);
 		  tp->tp_align = lcm(word_align, pointer_align);
 		}
@@ -194,12 +156,12 @@ SimpleType(struct type **ptp;)
 enumeration(struct type **ptp;)
 {
 	struct node *EnumList;
-	register struct type *tp;
 } :
 	'(' IdentList(&EnumList) ')'
-		{ *ptp = tp = standard_type(T_ENUMERATION, 1, (arith) 1);
+		{
-		  EnterEnumList(EnumList, tp);
+		  *ptp = standard_type(T_ENUMERATION, 1, (arith) 1);
-		  if (tp->enm_ncst > 256) { /* ??? is this reasonable ??? */
+		  EnterEnumList(EnumList, *ptp);
+		  if ((*ptp)->enm_ncst > 256) { /* ??? is this reasonable ??? */
 			error("Too many enumeration literals");
 		  }
 		}
@@ -230,7 +192,10 @@ SubrangeType(struct type **ptp;)
 	'[' ConstExpression(&nd1)
 	UPTO ConstExpression(&nd2)
 	']'
-			{ *ptp = subr_type(nd1, nd2); }
+			{ *ptp = subr_type(nd1, nd2);
+			  free_node(nd1);
+			  free_node(nd2);
+			}
 ;
 
 ArrayType(struct type **ptp;)
@@ -254,18 +219,18 @@ ArrayType(struct type **ptp;)
 RecordType(struct type **ptp;)
 {
 	register struct scope *scope;
-	arith count;
+	arith size;
 	int xalign = struct_align;
 }
 :
 	RECORD
-		{ open_scope(OPENSCOPE);
+		{ open_scope(OPENSCOPE);	/* scope for fields of record */
 		  scope = CurrentScope;
 		  close_scope(0);
-		  count = 0;
+		  size = 0;
 		}
-	FieldListSequence(scope, &count, &xalign)
+	FieldListSequence(scope, &size, &xalign)
-		{ *ptp = standard_type(T_RECORD, xalign, WA(count));
+		{ *ptp = standard_type(T_RECORD, xalign, WA(size));
 		  (*ptp)->rec_scope = scope;
 		}
 	END
@@ -281,10 +246,10 @@ FieldListSequence(struct scope *scope; arith *cnt; int *palign;):
 FieldList(struct scope *scope; arith *cnt; int *palign;)
 {
 	struct node *FldList;
-	register struct idf *id = gen_anon_idf();
+	register struct idf *id = 0;
-	register struct def *df;
 	struct type *tp;
-	struct node *nd;
+	struct node *nd1;
+	register struct node *nd;
 	arith tcnt, max;
 } :
 [
@@ -294,77 +259,81 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
 			}
 |
 	CASE
-	/* Also accept old fashioned Modula-2 syntax, but give a warning
+	/* Also accept old fashioned Modula-2 syntax, but give a warning.
+	   Sorry for the complicated code.
 	*/
-	[	qualident(0, (struct def **) 0, (char *) 0, &nd)
+	[ qualident(0, (struct def **) 0, (char *) 0, &nd1)
-		[	':' qualtype(&tp)
+			{ nd = nd1; }
+	  [ ':' qualtype(&tp)
 			/* This is correct, in both kinds of Modula-2, if
-			   the first qualident is a single identifier.
+		   	   the first qualident is a single identifier.
 			*/
-				{ if (nd->nd_class != Name) {
+			{ if (nd->nd_class != Name) {
-					error("illegal variant tag");
+				error("illegal variant tag");
-			  	  }
+		  	  }
-			  	  else	id = nd->nd_IDF;
+		  	  else	id = nd->nd_IDF;
-				}
+			  FreeNode(nd);
-		|
+			}
-			/* Old fashioned! the first qualident now represents
+	  |		/* Old fashioned! the first qualident now represents
 			   the type
 			*/
-				{ warning("Old fashioned Modula-2 syntax!");
+			{ warning("Old fashioned Modula-2 syntax; ':' missing");
-				  if (ChkDesignator(nd) &&
+			  if (ChkDesignator(nd) &&
-				      (nd->nd_class != Def ||
+			      (nd->nd_class != Def ||
-				       !(nd->nd_def->df_kind&(D_ERROR|D_ISTYPE)) ||
+			       !(nd->nd_def->df_kind&(D_ERROR|D_ISTYPE)) ||
-				       !nd->nd_def->df_type)) {
+			       !nd->nd_def->df_type)) {
-					node_error(nd, "type expected");
+				node_error(nd, "type expected");
-					tp = error_type;
+				tp = error_type;
-				  }
+			  }
-				  else tp = nd->nd_def->df_type;
+			  else tp = nd->nd_def->df_type;
-				  FreeNode(nd);
+			  FreeNode(nd);
-				}
+			}
-		]
+	  ]
-	|
+	| ':' qualtype(&tp)
-		/* Aha, third edition. Well done! */
+	  /* Aha, third edition. Well done! */
-		':' qualtype(&tp)
 	]
-				{ if (!(tp->tp_fund & T_DISCRETE)) {
+			{ if (id) {
+			  	register struct def *df = define(id,
+								 scope,
+								 D_FIELD);
+			  	if (!(tp->tp_fund & T_DISCRETE)) {
 					error("Illegal type in variant");
-				  }
+			  	}
-				  df = define(id, scope, D_FIELD);
+			  	df->df_type = tp;
-				  df->df_type = tp;
+			  	df->fld_off = align(*cnt, tp->tp_align);
-				  df->fld_off = align(*cnt, tp->tp_align);
+			  	*cnt = tcnt = df->fld_off + tp->tp_size;
-				  *cnt = tcnt = df->fld_off + tp->tp_size;
+			  	df->df_flags |= D_QEXPORTED;
-				  df->df_flags |= D_QEXPORTED;
+			  }
-				}
+			}
 	OF variant(scope, &tcnt, tp, palign)
-				{ max = tcnt; tcnt = *cnt; }
+			{ max = tcnt; tcnt = *cnt; }
 	[
-		'|' variant(scope, &tcnt, tp, palign)
+	  '|' variant(scope, &tcnt, tp, palign)
-				{ if (tcnt > max) max = tcnt; tcnt = *cnt; }
+			{ if (tcnt > max) max = tcnt; tcnt = *cnt; }
 	]*
 	[ ELSE FieldListSequence(scope, &tcnt, palign)
-				{ if (tcnt > max) max = tcnt; }
+			{ if (tcnt > max) max = tcnt; }
 	]?
 	END
-				{ *cnt = max; }
+			{ *cnt = max; }
 ]?
 ;
 
 variant(struct scope *scope; arith *cnt; struct type *tp; int *palign;)
 {
-	struct type *tp1 = tp;
 	struct node *nd;
 } :
 	[
-		CaseLabelList(&tp1, &nd)
+		CaseLabelList(&tp, &nd)
-				{ /* Ignore the cases for the time being.
+			{ /* Ignore the cases for the time being.
-				     Maybe a checking version will be supplied
+			     Maybe a checking version will be supplied
-				     later ???
+			     later ??? (Improbable)
-				  */
+			  */
-				  FreeNode(nd);
+			  FreeNode(nd);
-				}
+			}
 		':' FieldListSequence(scope, cnt, palign)
 	]?
-					/* Changed rule in new modula-2 */
+			/* Changed rule in new modula-2 */
 ;
 
 CaseLabelList(struct type **ptp; struct node **pnd;):
@@ -376,27 +345,29 @@ CaseLabelList(struct type **ptp; struct node **pnd;):
 	]*
 ;
 
-CaseLabels(struct type **ptp; struct node **pnd;)
+CaseLabels(struct type **ptp; register struct node **pnd;)
 {
-	struct node *nd1, *nd2 = 0;
+	register struct node *nd1;
 }:
-	ConstExpression(&nd1)	{ *pnd = nd1; }
+	ConstExpression(pnd)
+			{ nd1 = *pnd; }
 	[
-		UPTO		{ *pnd = MkNode(Link,nd1,NULLNODE,&dot); }
+		UPTO	{ *pnd = MkNode(Link,nd1,NULLNODE,&dot); }
-		ConstExpression(&nd2)
+		ConstExpression(&(*pnd)->nd_right)
-				{ if (!TstCompat(nd1->nd_type, nd2->nd_type)) {
+			{ if (!TstCompat(nd1->nd_type,
-node_error(nd2,"type incompatibility in case label");
+					 (*pnd)->nd_right->nd_type)) {
-				  	nd1->nd_type = error_type;
+				node_error((*pnd)->nd_right,
-				  }
+					  "type incompatibility in case label");
-				  (*pnd)->nd_right = nd2;
+			  	nd1->nd_type = error_type;
-				}
+			  }
+			}
 	]?
-				{ if (*ptp != 0 &&
+			{ if (*ptp != 0 && !TstCompat(*ptp, nd1->nd_type)) {
-				       !TstCompat(*ptp, nd1->nd_type)) {
+				node_error(nd1,
-node_error(nd1,"type incompatibility in case label");
+					  "type incompatibility in case label");
-				  }
+			  }
-				  *ptp = nd1->nd_type;
+			  *ptp = nd1->nd_type;
-				}
+			}
 ;
 
 SetType(struct type **ptp;) :
@@ -410,7 +381,7 @@ SetType(struct type **ptp;) :
 */
 PointerType(struct type **ptp;)
 {
-	register struct node *nd;
+	register struct node *nd = 0;
 } :
 	POINTER TO
 			{ *ptp = construct_type(T_POINTER, NULLTYPE); }
@@ -418,49 +389,51 @@ PointerType(struct type **ptp;)
 		/* Either a Module or a Type, but in both cases defined
 		   in this scope, so this is the correct identification
 		*/
-		qualtype(&((*ptp)->next))
+	  qualtype(&((*ptp)->next))
-	| %if ( nd = new_node(), nd->nd_token = dot,
+	| %if ( nd = new_node(),
+		nd->nd_token = dot,
 		lookfor(nd, CurrVis, 0)->df_kind == D_MODULE)
-			{ if (dot.tk_symb == IDENT) free_node(nd); }
+	  type(&((*ptp)->next)) 
-		type(&((*ptp)->next)) 
+			{ if (nd) free_node(nd); }
 	|
-		IDENT	{ Forward(nd, (*ptp)); }
+	  IDENT		{ Forward(nd, (*ptp)); }
 	]
 ;
 
 qualtype(struct type **ptp;)
 {
-	struct def *df;
+	struct def *df = 0;
 } :
 	qualident(D_ISTYPE, &df, "type", (struct node **) 0)
-		{ if (!(*ptp = df->df_type)) {
+			{ if (df && !(*ptp = df->df_type)) {
-			error("type \"%s\" not declared", df->df_idf->id_text);
+				error("type \"%s\" not declared",
-			*ptp = error_type;
+				       df->df_idf->id_text);
-		  }
+				*ptp = error_type;
-		}
+		  	  }
+			}
 ;
 
 
 ProcedureType(struct type **ptp;)
 {
 	struct paramlist *pr = 0;
-	register struct type *tp;
+	arith parmaddr = 0;
-	arith nbytes = 0;
+}
-} :
+:
 			{ *ptp = 0; }
-	PROCEDURE FormalTypeList(&pr, ptp, &nbytes)?
+	PROCEDURE 
-			{ *ptp = tp = construct_type(T_PROCEDURE, *ptp);
+	[
-			  tp->prc_params = pr;
+	  	FormalTypeList(&pr, &parmaddr, ptp)
-			  tp->prc_nbpar = nbytes;
+	]?
-			}
+			{ *ptp = proc_type(*ptp, pr, parmaddr); }
 ;
 
-FormalTypeList(struct paramlist **ppr; struct type **ptp; arith *parmaddr;)
+FormalTypeList(struct paramlist **ppr; arith *parmaddr; struct type **ptp;)
 {
-	int VARp;
 	struct type *tp;
+	int VARp;
 } :
-	'('		{ *ppr = 0; }
+	'('
 	[
 		var(&VARp) FormalType(&tp)
 			{ EnterParamList(ppr,NULLNODE,tp,VARp,parmaddr); }

lang/m2/comp/def.H

@@ -1,7 +1,5 @@
 /* I D E N T I F I E R   D E S C R I P T O R   S T R U C T U R E */
 
-/* $Header$ */
-
 struct module {
 	arith mo_priority;	/* priority of a module */
 	struct scopelist *mo_vis;/* scope of this module */
@@ -82,12 +80,12 @@ struct def	{		/* list of definitions for a name */
 #define D_IMPORT	0x0080	/* an imported definition */
 #define D_PROCHEAD	0x0100	/* a procedure heading in a definition module */
 #define D_HIDDEN	0x0200	/* a hidden type */
-#define D_FORWARD	0x0800	/* not yet defined */
+#define D_FORWARD	0x0400	/* not yet defined */
-#define D_UNDEF_IMPORT	0x1000	/* imported from an undefined name */
+#define D_FORWMODULE	0x0800	/* module must be declared later */
-#define D_FORWMODULE	0x2000	/* module must be declared later */
+#define D_ERROR		0x1000	/* a compiler generated definition for an
-#define D_ERROR		0x4000	/* a compiler generated definition for an
 				   undefined variable
 				*/
+#define D_VALUE	(D_PROCEDURE|D_VARIABLE|D_FIELD|D_ENUM|D_CONST|D_PROCHEAD)
 #define D_ISTYPE	(D_HIDDEN|D_TYPE)
 #define is_type(dfx)	((dfx)->df_kind & D_ISTYPE)
 	char df_flags;
@@ -115,14 +113,13 @@ struct def	{		/* list of definitions for a name */
 
 #define SetUsed(df)	((df)->df_flags |= D_USED)
 
-/* ALLOCDEF "def" */
+/* ALLOCDEF "def" 50 */
 
 extern struct def
 	*define(),
 	*DefineLocalModule(),
 	*MkDef(),
-	*DeclProc(),
+	*DeclProc();
-	*ill_df;
 
 extern struct def
 	*lookup(),

lang/m2/comp/def.c

@@ -1,9 +1,5 @@
 /* D E F I N I T I O N   M E C H A N I S M */
 
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
 #include	"debug.h"
 
 #include	<alloc.h>
@@ -25,11 +21,42 @@ struct def *h_def;		/* pointer to free list of def structures */
 int	cnt_def;		/* count number of allocated ones */
 #endif
 
-struct def *ill_df;
+STATIC
+DefInFront(df)
+	register struct def *df;
+{
+	/*	Put definition "df" in front of the list of definitions
+		in its scope.
+		This is neccessary because in some cases the order in this
+		list is important.
+	*/
+	register struct def *df1 = df->df_scope->sc_def;
+
+	if (df1 != df) {
+		/* Definition "df" is not in front of the list
+		*/
+		while (df1) {
+			/* Find definition "df"
+			*/
+			if (df1->df_nextinscope == df) {
+				/* It already was in the list. Remove it
+				*/
+				df1->df_nextinscope = df->df_nextinscope;
+				break;
+			}
+			df1 = df1->df_nextinscope;
+		}
+
+		/* Now put it in front
+		*/
+		df->df_nextinscope = df->df_scope->sc_def;
+		df->df_scope->sc_def = df;
+	}
+}
 
 struct def *
 MkDef(id, scope, kind)
-	struct idf *id;
+	register struct idf *id;
 	register struct scope *scope;
 {
 	/*	Create a new definition structure in scope "scope", with
@@ -38,7 +65,6 @@ MkDef(id, scope, kind)
 	register struct def *df;
 
 	df = new_def();
-	clear((char *) df, sizeof (*df));
 	df->df_idf = id;
 	df->df_scope = scope;
 	df->df_kind = kind;
@@ -52,24 +78,16 @@ MkDef(id, scope, kind)
 	return df;
 }
 
-InitDef()
-{
-	/*	Initialize this module. Easy, the only thing to be initialized
-		is "ill_df".
-	*/
-	struct idf *gen_anon_idf();
-
-	ill_df = MkDef(gen_anon_idf(), CurrentScope, D_ERROR);
-	ill_df->df_type = error_type;
-}
-
 struct def *
 define(id, scope, kind)
 	register struct idf *id;
 	register struct scope *scope;
+	int kind;
 {
 	/*	Declare an identifier in a scope, but first check if it
-		already has been defined. If so, error message.
+		already has been defined.
+		If so, then check for the cases in which this is legal,
+		and otherwise give an error message.
 	*/
 	register struct def *df;
 
@@ -133,7 +151,8 @@ define(id, scope, kind)
 		if (kind != D_ERROR) {
 			/* Avoid spurious error messages
 			*/
-error("identifier \"%s\" already declared", id->id_text);
+			error("identifier \"%s\" already declared",
+			      id->id_text);
 		}
 
 		return df;
@@ -143,7 +162,7 @@ error("identifier \"%s\" already declared", id->id_text);
 }
 
 RemoveImports(pdf)
-	struct def **pdf;
+	register struct def **pdf;
 {
 	/*	Remove all imports from a definition module. This is
 		neccesary because the implementation module might import
@@ -165,16 +184,15 @@ RemoveImports(pdf)
 }
 
 RemoveFromIdList(df)
-	struct def *df;
+	register struct def *df;
 {
 	/*	Remove definition "df" from the definition list
 	*/
 	register struct idf *id = df->df_idf;
 	register struct def *df1;
 
-	if (id->id_def == df) id->id_def = df->next;
+	if ((df1 = id->id_def) == df) id->id_def = df->next;
 	else {
-		df1 = id->id_def;
 		while (df1->next != df) {
 			assert(df1->next != 0);
 			df1 = df1->next;
@@ -184,13 +202,15 @@ RemoveFromIdList(df)
 }
 
 struct def *
-DeclProc(type)
+DeclProc(type, id)
+	register struct idf *id;
 {
 	/*	A procedure is declared, either in a definition or a program
 		module. Create a def structure for it (if neccessary).
 		Also create a name for it.
 	*/
 	register struct def *df;
+	register struct scope *scope;
 	extern char *sprint();
 	static int nmcount;
 	char buf[256];
@@ -200,85 +220,61 @@ DeclProc(type)
 	if (type == D_PROCHEAD) {
 		/* In a definition module
 		*/
-		df = define(dot.TOK_IDF, CurrentScope, type);
+		df = define(id, CurrentScope, type);
 		df->for_node = MkLeaf(Name, &dot);
-		sprint(buf,"%s_%s",CurrentScope->sc_name,df->df_idf->id_text);
+		sprint(buf,"%s_%s",CurrentScope->sc_name,id->id_text);
 		df->for_name = Salloc(buf, (unsigned) (strlen(buf)+1));
-		if (CurrVis == Defined->mod_vis) C_exp(df->for_name);
+		if (CurrVis == Defined->mod_vis) {
+			/* The current module will define this routine.
+			   make sure the name is exported.
+			*/
+			C_exp(df->for_name);
+		}
 	}
 	else {
-		df = lookup(dot.TOK_IDF, CurrentScope);
+		char *name;
+
+		df = lookup(id, CurrentScope);
 		if (df && df->df_kind == D_PROCHEAD) {
 			/* C_exp already generated when we saw the definition
 			   in the definition module
 			*/
 			df->df_kind = D_PROCEDURE;
-			open_scope(OPENSCOPE);
+			name = df->for_name;
-			CurrentScope->sc_name = df->for_name;
-			df->prc_vis = CurrVis;
 			DefInFront(df);
 		}
 		else {
-			df = define(dot.TOK_IDF, CurrentScope, type);
+			df = define(id, CurrentScope, type);
-			open_scope(OPENSCOPE);
+			sprint(buf,"_%d_%s",++nmcount,id->id_text);
-			df->prc_vis = CurrVis;
+			name = Salloc(buf, (unsigned)(strlen(buf)+1));
-			sprint(buf,"_%d_%s",++nmcount,df->df_idf->id_text);
-			CurrentScope->sc_name = 
-				Salloc(buf, (unsigned)(strlen(buf)+1));
 			C_inp(buf);
 		}
+		open_scope(OPENSCOPE);
+		scope = CurrentScope;
+		scope->sc_name = name;
+		scope->sc_definedby = df;
+		df->prc_vis = CurrVis;
 	}
 
 	return df;
 }
 
-AddModule(id)
+EndProc(df, id)
+	register struct def *df;
 	struct idf *id;
 {
-	/*	Add the name of a module to the Module list. This list is
+	/*	The end of a procedure declaration.
-		maintained to create the initialization routine of the
+		Check that the closing identifier matches the name of the
-		program/implementation module currently defined.
+		procedure, close the scope, and check that a function
+		procedure has at least one RETURN statement.
 	*/
-	static struct node *nd_end;	/* to remember end of list */
+	extern int return_occurred;
-	register struct node *n;
-	extern struct node *Modules;
 
-	n = MkLeaf(Name, &dot);
+	match_id(id, df->df_idf);
-	n->nd_IDF = id;
+	close_scope(SC_CHKFORW|SC_REVERSE);
-	n->nd_symb = IDENT;
+	if (! return_occurred && ResultType(df->df_type)) {
-	if (nd_end) nd_end->next = n;
+		error("function procedure %s does not return a value",
-	else Modules = n;
+		      df->df_idf->id_text);
-	nd_end = n;
-}
-
-DefInFront(df)
-	register struct def *df;
-{
-	/*	Put definition "df" in front of the list of definitions
-		in its scope.
-		This is neccessary because in some cases the order in this
-		list is important.
-	*/
-	register struct def *df1 = df->df_scope->sc_def;
-
-	if (df1 != df) {
-		/* Definition "df" is not in front of the list
-		*/
-		while (df1 && df1->df_nextinscope != df) {
-			/* Find definition "df"
-			*/
-			df1 = df1->df_nextinscope;
-		}
-		if (df1) {
-			/* It already was in the list. Remove it
-			*/
-			df1->df_nextinscope = df->df_nextinscope;
-		}
-
-		/* Now put it in front
-		*/
-		df->df_nextinscope = df->df_scope->sc_def;
-		df->df_scope->sc_def = df;
 	}
 }
 
@@ -326,6 +322,27 @@ DefineLocalModule(id)
 	return df;
 }
 
+CheckWithDef(df, tp)
+	register struct def *df;
+	struct type *tp;
+{
+	/*	Check the header of a procedure declaration against a
+		possible earlier definition in the definition module.
+	*/
+
+	if (df->df_type) {
+		/* We already saw a definition of this type
+		   in the definition module.
+		*/
+	  	if (!TstProcEquiv(tp, df->df_type)) {
+			error("inconsistent procedure declaration for \"%s\"",
+			      df->df_idf->id_text); 
+		}
+		FreeType(df->df_type);
+	}
+	df->df_type = tp;
+}
+
 #ifdef DEBUG
 PrDef(df)
 	register struct def *df;

lang/m2/comp/defmodule.c

@@ -1,9 +1,5 @@
 /* D E F I N I T I O N   M O D U L E S */
 
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
 #include	"debug.h"
 
 #include	<assert.h>
@@ -15,23 +11,27 @@ static char *RcsId = "$Header$";
 #include	"scope.h"
 #include	"def.h"
 #include	"LLlex.h"
+#include	"Lpars.h"
 #include	"f_info.h"
 #include	"main.h"
+#include	"node.h"
 
 #ifdef DEBUG
 long	sys_filesize();
 #endif
 
+struct idf *	CurrentId;
+
 GetFile(name)
 	char *name;
 {
 	/*	Try to find a file with basename "name" and extension ".def",
 		in the directories mentioned in "DEFPATH".
 	*/
-	char buf[256];
+	char buf[15];
 	char *strcpy(), *strcat();
 
-	strcpy(buf, name);
+	strncpy(buf, name, 10);
 	buf[10] = '\0';			/* maximum length */
 	strcat(buf, ".def");
 	if (! InsertFile(buf, DEFPATH, &(FileName))) {
@@ -42,17 +42,18 @@ GetFile(name)
 }
 
 struct def *
-GetDefinitionModule(id)
+GetDefinitionModule(id, incr)
-	struct idf *id;
+	register struct idf *id;
 {
 	/*	Return a pointer to the "def" structure of the definition
 		module indicated by "id".
 		We may have to read the definition module itself.
+		Also increment level by "incr".
 	*/
 	struct def *df;
 	static int level;
 
-	level++;
+	level += incr;
 	df = lookup(id, GlobalScope);
 	if (!df) {
 		/* Read definition module. Make an exception for SYSTEM.
@@ -62,6 +63,8 @@ GetDefinitionModule(id)
 		}
 		else {
 			GetFile(id->id_text);
+			CurrentId = id;
+			open_scope(CLOSEDSCOPE);
 			DefModule();
 			if (level == 1) {
 				/* The module is directly imported by the
@@ -69,12 +72,23 @@ GetDefinitionModule(id)
 				   remember its name because we have to call
 				   its initialization routine
 				*/
-				AddModule(id);
+				static struct node *nd_end; /* end of list */
+				register struct node *n;
+				extern struct node *Modules;
+
+				n = MkLeaf(Name, &dot);
+				n->nd_IDF = id;
+				n->nd_symb = IDENT;
+				if (nd_end) nd_end->next = n;
+				else Modules = n;
+				nd_end = n;
 			}
+			close_scope(SC_CHKFORW);
 		}
 		df = lookup(id, GlobalScope);
 	}
+	CurrentId = 0;
 	assert(df && df->df_kind == D_MODULE);
-	level--;
+	level -= incr;
 	return df;
 }

lang/m2/comp/desig.c

@@ -1,9 +1,5 @@
 /* D E S I G N A T O R   E V A L U A T I O N */
 
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
 /*	Code generation for designators.
    	This file contains some routines that generate code common to address
 	as well as value computations, and leave a description in a "desig"
@@ -166,7 +162,6 @@ CodeFieldDesig(df, ds)
 	   in "ds". "df" indicates the definition of the field.
 	*/
 
-
 	if (ds->dsg_kind == DSG_INIT) {
 		/* In a WITH statement. We must find the designator in the
 		   WITH statement, and act as if the field is a selection

lang/m2/comp/desig.h

@@ -1,7 +1,5 @@
 /* D E S I G N A T O R   D E S C R I P T I O N S */
 
-/* $Header$ */
-
 /* Generating code for designators is not particularly easy, especially if
    you don't know wether you want the address or the value.
    The next structure is used to generate code for designators.

lang/m2/comp/enter.c

@@ -1,9 +1,5 @@
 /* H I G H   L E V E L   S Y M B O L   E N T R Y */
 
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
 #include	"debug.h"
 
 #include	<alloc.h>
@@ -119,7 +115,8 @@ EnterVarList(Idlist, type, local)
 			df->var_addrgiven = 1;
 			df->df_flags |= D_NOREG;
 			if (idlist->nd_left->nd_type != card_type) {
-node_error(idlist->nd_left,"Illegal type for address");
+				node_error(idlist->nd_left,
+					   "Illegal type for address");
 			}
 			df->var_off = idlist->nd_left->nd_INT;
 		}
@@ -155,8 +152,8 @@ node_error(idlist->nd_left,"Illegal type for address");
 }
 
 EnterParamList(ppr, Idlist, type, VARp, off)
-	struct node *Idlist;
 	struct paramlist **ppr;
+	struct node *Idlist;
 	struct type *type;
 	int VARp;
 	arith *off;
@@ -178,18 +175,14 @@ EnterParamList(ppr, Idlist, type, VARp, off)
 	for ( ; idlist; idlist = idlist->next) {
 		pr = new_paramlist();
 		pr->next = 0;
-		if (!*ppr) {
+		if (!*ppr) *ppr = pr;
-			*ppr = pr;
-		}
 		else	last->next = pr;
 		last = pr;
 		if (!DefinitionModule && idlist != dummy) {
 			df = define(idlist->nd_IDF, CurrentScope, D_VARIABLE);
 			df->var_off = *off;
 		}
-		else {
+		else	df = new_def();
-			df = new_def();
-		}
 		pr->par_def = df;
 		df->df_type = type;
 		df->df_flags = VARp;
@@ -259,11 +252,11 @@ ForwModule(df, idn)
 				   enclosing scope, but this must be done AFTER
 				   closing this one
 				*/
-	df->for_vis = vis;
-	df->for_node = MkLeaf(Name, &(idn->nd_token));
 	close_scope(0);	
 	vis->sc_encl = enclosing(CurrVis);
 				/* Here ! */
+	df->for_vis = vis;
+	df->for_node = MkLeaf(Name, &(idn->nd_token));
 	return vis;
 }
 
@@ -294,7 +287,6 @@ EnterExportList(Idlist, qualified)
 	*/
 	register struct node *idlist = Idlist;
 	register struct def *df, *df1;
-	register struct def *impmod;
 
 	for (;idlist; idlist = idlist->next) {
 		df = lookup(idlist->nd_IDF, CurrentScope);
@@ -302,13 +294,16 @@ EnterExportList(Idlist, qualified)
 		if (!df) {
 			/* undefined item in export list
 			*/
-node_error(idlist, "identifier \"%s\" not defined", idlist->nd_IDF->id_text);
+			node_error(idlist,
+				   "identifier \"%s\" not defined",
+				   idlist->nd_IDF->id_text);
 			continue;
 		}
 
 		if (df->df_flags & (D_EXPORTED|D_QEXPORTED)) {
-node_error(idlist, "identifier \"%s\" occurs more than once in export list",
+			node_error(idlist,
-idlist->nd_IDF->id_text);
+				"multiple occurrences of \"%s\" in export list",
+				idlist->nd_IDF->id_text);
 		}
 
 		df->df_flags |= qualified;
@@ -317,13 +312,13 @@ idlist->nd_IDF->id_text);
 			   Find all imports of the module in which this export
 			   occurs, and export the current definition to it
 			*/
-			impmod = CurrentScope->sc_definedby->df_idf->id_def;
+			df1 = CurrentScope->sc_definedby->df_idf->id_def;
-			while (impmod) {
+			while (df1) {
-				if (impmod->df_kind == D_IMPORT &&
+				if (df1->df_kind == D_IMPORT &&
-				    impmod->imp_def == CurrentScope->sc_definedby) {
+				    df1->imp_def == CurrentScope->sc_definedby) {
-					DoImport(df, impmod->df_scope);
+					DoImport(df, df1->df_scope);
 				}
-				impmod = impmod->next;
+				df1 = df1->next;
 			}
 
 			/* Also handle the definition as if the enclosing
@@ -345,7 +340,9 @@ idlist->nd_IDF->id_text);
 				if (df1->df_kind == D_HIDDEN &&
 				    df->df_kind == D_TYPE) {
 					if (df->df_type->tp_fund != T_POINTER) {
-node_error(idlist, "opaque type \"%s\" is not a pointer type", df->df_idf->id_text);
+						node_error(idlist,
+"opaque type \"%s\" is not a pointer type",
+							df->df_idf->id_text);
 					}
 					assert(df1->df_type->next == NULLTYPE);
 					df1->df_kind = D_TYPE;
@@ -388,23 +385,23 @@ EnterFromImportList(Idlist, FromDef)
 		vis = FromDef->mod_vis;
 		break;
 	default:
-error("identifier \"%s\" does not represent a module",
+		error("identifier \"%s\" does not represent a module",
-FromDef->df_idf->id_text);
+		       FromDef->df_idf->id_text);
 		break;
 	}
 
 	for (; idlist; idlist = idlist->next) {
-		if (forwflag) {
+		if (forwflag) df = ForwDef(idlist, vis->sc_scope);
-			df = ForwDef(idlist, vis->sc_scope);
+		else if (! (df = lookup(idlist->nd_IDF, vis->sc_scope))) {
-		}
+			node_error(idlist, 
-		else if (!(df = lookup(idlist->nd_IDF, vis->sc_scope))) {
+			  "identifier \"%s\" not declared in qualifying module",
-node_error(idlist, "identifier \"%s\" not declared in qualifying module",
+			  idlist->nd_IDF->id_text);
-idlist->nd_IDF->id_text);
 			df = define(idlist->nd_IDF,vis->sc_scope,D_ERROR);
 		}
-		else if (!(df->df_flags&(D_EXPORTED|D_QEXPORTED))) {
+		else if (! (df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
-node_error(idlist,"identifier \"%s\" not exported from qualifying module",
+			node_error(idlist,
-idlist->nd_IDF->id_text);
+			"identifier \"%s\" not exported from qualifying module",
+			idlist->nd_IDF->id_text);
 			df->df_flags |= D_QEXPORTED;
 		}
 		DoImport(df, CurrentScope);
@@ -422,14 +419,14 @@ EnterImportList(Idlist, local)
 		This case is indicated by the value 0 of the "local" flag.
 	*/
 	register struct node *idlist = Idlist;
-	register struct def *df;
+	struct scope *sc = enclosing(CurrVis)->sc_scope;
-	struct scopelist *vis = enclosing(CurrVis);
 	extern struct def *GetDefinitionModule();
 
 	for (; idlist; idlist = idlist->next) {
-		if (local) df = ForwDef(idlist, vis->sc_scope);
+		DoImport(local ?
-		else	df = GetDefinitionModule(idlist->nd_IDF);
+				ForwDef(idlist, sc) :
-		DoImport(df, CurrentScope);
+				GetDefinitionModule(idlist->nd_IDF) ,
+			 CurrentScope);
 	}
 	FreeNode(Idlist);
 }

lang/m2/comp/error.c

@@ -5,10 +5,6 @@
 	number of arguments!
 */
 
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
 #include	"errout.h"
 #include	"debug.h"
 

lang/m2/comp/expression.g

@@ -1,10 +1,6 @@
 /* E X P R E S S I O N S */
 
 {
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
 #include	"debug.h"
 
 #include	<alloc.h>
@@ -38,22 +34,19 @@ qualident(int types;
 	  struct node **p;
 	 )
 {
-	register struct def *df;
 	struct node *nd;
 } :
 	IDENT	{ nd = MkLeaf(Name, &dot); }
 	[
 		selector(&nd)
 	]*
-		{ if (types) {
+		{ if (types && ChkDesignator(nd)) {
-			df = ill_df;
+			if (nd->nd_class != Def) {
-
-			if (ChkDesignator(nd)) {
-			    if (nd->nd_class != Def) {
 				node_error(nd, "%s expected", str);
-			    }
+			}
-			    else {
+			else {
-				df = nd->nd_def;
+				register struct def *df = nd->nd_def;
+
 		  		if ( !((types|D_ERROR) & df->df_kind)) {
 				    if (df->df_kind == D_FORWARD) {
 node_error(nd,"%s \"%s\" not declared", str, df->df_idf->id_text);
@@ -62,9 +55,8 @@ node_error(nd,"%s \"%s\" not declared", str, df->df_idf->id_text);
 node_error(nd,"identifier \"%s\" is not a %s", df->df_idf->id_text, str);
 				    }
 				}
-			    }
+				if (pdf) *pdf = df;
 			}
-			*pdf = df;
 		  }
 		  if (!p) FreeNode(nd);
 		  else *p = nd;
@@ -170,10 +162,9 @@ MulOperator:
 
 factor(register struct node **p;)
 {
-	struct def *df;
 	struct node *nd;
 } :
-	qualident(0, &df, (char *) 0, p)
+	qualident(0, (struct def **) 0, (char *) 0, p)
 	[
 		designator_tail(p)?
 		[
@@ -236,10 +227,8 @@ element(struct node *nd;)
 ;
 
 designator(struct node **pnd;)
-{
+:
-	struct def *df;
+	qualident(0, (struct def **) 0, (char *) 0, pnd)
-} :
-	qualident(0, &df, (char *) 0, pnd)
 	designator_tail(pnd)?
 ;
 

lang/m2/comp/f_info.h

@@ -1,7 +1,5 @@
 /* F I L E   D E S C R I P T O R   S T R U C T U R E */
 
-/* $Header$ */
-
 struct f_info {
 	unsigned short f_lineno;
 	char *f_filename;

lang/m2/comp/idf.c

@@ -1,6 +1,4 @@
 /* I N S T A N T I A T I O N   O F   I D F   P A C K A G E */
 
-/* $Header$ */
-
 #include	"idf.h"
 #include	<idf_pkg.body>

lang/m2/comp/idf.h

@@ -1,7 +1,5 @@
 /* U S E R   D E C L A R E D   P A R T   O F   I D F */
 
-/* $Header$ */
-
 struct id_u {
 	int id_res;
 	struct def *id_df;

lang/m2/comp/input.c

@@ -1,17 +1,25 @@
 /* I N S T A N T I A T I O N   O F   I N P U T   P A C K A G E */
 
-/* $Header$ */
-
 #include	"f_info.h"
 struct f_info	file_info;
 #include	"input.h"
+#include	<em_arith.h>
+#include	<em_label.h>
+#include	"def.h"
+#include	"idf.h"
+#include	"scope.h"
 #include	<inp_pkg.body>
 
+extern struct idf *CurrentId;
+
 AtEoIF()
 {
 	/*	Make the unstacking of input streams noticable to the
 	   	lexical analyzer
 	*/
+	if (CurrentId && ! lookup(CurrentId, GlobalScope)) {
+fatal("No definition module read for \"%s\"", CurrentId->id_text);
+	}
 	return 1;
 }
 

lang/m2/comp/input.h

@@ -1,7 +1,5 @@
 /* I N S T A N T I A T I O N   O F   I N P U T   M O D U L E */
 
-/* $Header$ */
-
 #include	"inputtype.h"
 
 #define INP_NPUSHBACK 2

lang/m2/comp/lookup.c

@@ -1,9 +1,5 @@
 /* L O O K U P   R O U T I N E S */
 
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
 #include	"debug.h"
 
 #include	<em_arith.h>

lang/m2/comp/main.c

@@ -1,9 +1,5 @@
 /* M A I N   P R O G R A M */
 
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
 #include	"debug.h"
 #include	"ndir.h"
 
@@ -26,7 +22,6 @@ static char *RcsId = "$Header$";
 int		state;			/* either IMPLEMENTATION or PROGRAM */
 char		options[128];
 int		DefinitionModule; 
-int		SYSTEMModule;
 char		*ProgName;
 char		*DEFPATH[NDIRS+1];
 struct def 	*Defined;
@@ -73,7 +68,6 @@ Compile(src, dst)
 	reserve(tkidf);
 	InitScope();
 	InitTypes();
-	InitDef();
 	AddStandards();
 #ifdef DEBUG
 	if (options['l']) {
@@ -186,27 +180,29 @@ AddStandards()
 	df->enm_next = 0;
 }
 
-do_SYSTEM()
+/* How do you like that! Modula-2 in a C-program.
-{
+*/
-	/*	Simulate the reading of the SYSTEM definition module
+char SYSTEM[] = "\
-	*/
-	char *SYSTEM = "\
 DEFINITION MODULE SYSTEM;\n\
+TYPE	PROCESS = ADDRESS;\n\
 PROCEDURE NEWPROCESS(P:PROC; A:ADDRESS; n:CARDINAL; VAR p1:ADDRESS);\n\
 PROCEDURE TRANSFER(VAR p1,p2:ADDRESS);\n\
 END SYSTEM.\n";
 
+do_SYSTEM()
+{
+	/*	Simulate the reading of the SYSTEM definition module
+	*/
 	open_scope(CLOSEDSCOPE);
 	(void) Enter("WORD", D_TYPE, word_type, 0);
 	(void) Enter("ADDRESS", D_TYPE, address_type, 0);
 	(void) Enter("ADR", D_PROCEDURE, std_type, S_ADR);
 	(void) Enter("TSIZE", D_PROCEDURE, std_type, S_TSIZE);
-	if (!InsertText(SYSTEM, strlen(SYSTEM))) {
+	if (!InsertText(SYSTEM, sizeof(SYSTEM) - 1)) {
 		fatal("Could not insert text");
 	}
-	SYSTEMModule = 1;
 	DefModule();
-	SYSTEMModule = 0;
+	close_scope(SC_CHKFORW);
 }
 
 #ifdef DEBUG

lang/m2/comp/main.h

@@ -1,7 +1,5 @@
 /* S O M E   G L O B A L   V A R I A B L E S */
 
-/* $Header$ */
-
 extern char options[];	/* indicating which options were given */
 
 extern int DefinitionModule;
@@ -9,9 +7,6 @@ extern int DefinitionModule;
 			   module
 			*/
 
-extern int SYSTEMModule;/* flag indicating that we are handling the SYSTEM
-			   module
-			*/
 extern struct def *Defined;
 			/* definition structure of module defined in this
 			   compilation

lang/m2/comp/make.allocd

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

lang/m2/comp/misc.c

@@ -1,9 +1,5 @@
 /* M I S C E L L A N E O U S    R O U T I N E S */
 
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
 #include	<alloc.h>
 #include	<em_arith.h>
 #include	<em_label.h>

lang/m2/comp/misc.h

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

lang/m2/comp/node.H

@@ -1,7 +1,5 @@
 /* N O D E   O F   A N   A B S T R A C T   P A R S E T R E E */
 
-/* $Header$ */
-
 struct node {
 	struct node *next;
 #define nd_left	next
@@ -35,7 +33,7 @@ struct node {
 #define nd_REL		nd_token.TOK_REL
 };
 
-/* ALLOCDEF "node" */
+/* ALLOCDEF "node" 50 */
 
 extern struct node *MkNode(), *MkLeaf();
 

lang/m2/comp/node.c

@@ -1,9 +1,5 @@
 /* N O D E   O F   A N   A B S T R A C T   P A R S E T R E E */
 
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
 #include	"debug.h"
 
 #include	<em_label.h>

lang/m2/comp/options.c

@@ -1,9 +1,5 @@
 /* U S E R   O P T I O N - H A N D L I N G */
 
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
 #include	"idfsize.h"
 #include	"ndir.h"
 
@@ -17,7 +13,7 @@ extern int	idfsize;
 static int	ndirs;
 
 DoOption(text)
-	char *text;
+	register char *text;
 {
 	switch(*text++)	{
 
@@ -33,12 +29,15 @@ DoOption(text)
 					*/
 
 
-	case 'M':	/* maximum identifier length */
+	case 'M': {	/* maximum identifier length */
-		idfsize = txt2int(&text);
+		char *t = text;		/* because &text is illegal */
-		if (*text || idfsize <= 0)
+
+		idfsize = txt2int(&t);
+		if (*t || idfsize <= 0)
 			fatal("malformed -M option");
 		if (idfsize > IDFSIZE)
 			fatal("maximum identifier length is %d", IDFSIZE);
+		}
 		break;
 
 	case 'I' :
@@ -53,13 +52,16 @@ DoOption(text)
 		arith size;
 		int align;
 		char c;
+		char *t;
 
 		while (c = *text++)	{
-			size = txt2int(&text);
+			t = text;
+			size = txt2int(&t);
 			align = 0;
-			if (*text == '.')	{
+			if (*(text = t) == '.')	{
-				text++;
+				t = text + 1;
-				align = txt2int(&text);
+				align = txt2int(&t);
+				text = t;
 			}
 			switch (c)	{
 
@@ -104,7 +106,7 @@ DoOption(text)
 
 int
 txt2int(tp)
-	char **tp;
+	register char **tp;
 {
 	/*	the integer pointed to by *tp is read, while increasing
 		*tp; the resulting value is yielded.

lang/m2/comp/program.g

@@ -1,10 +1,6 @@
 /* O V E R A L L   S T R U C T U R E */
 
 {
-#ifndef NORCSID
-static  char *RcsId = "$Header$";
-#endif
-
 #include	"debug.h"
 
 #include	<alloc.h>
@@ -42,14 +38,11 @@ static  char *RcsId = "$Header$";
 
 ModuleDeclaration
 {
-	struct idf *id;			/* save module identifier */
 	register struct def *df;
 	struct node *exportlist = 0;
 	int qualified;
 } :
-	MODULE IDENT	{ id = dot.TOK_IDF;
+	MODULE IDENT	{ df = DefineLocalModule(dot.TOK_IDF); }
-			  df = DefineLocalModule(id);
-			}
 	priority(&(df->mod_priority))?
 	';'
 	import(1)*
@@ -59,7 +52,7 @@ ModuleDeclaration
 				EnterExportList(exportlist, qualified);
 			  }
 			  close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
-			  match_id(id, dot.TOK_IDF);
+			  match_id(df->df_idf, dot.TOK_IDF);
 			}
 ;
 
@@ -104,7 +97,7 @@ import(int local;)
 				df = lookfor(nd,enclosing(CurrVis),0);
 				FreeNode(nd);
 			  }
-			  else	df = GetDefinitionModule(dot.TOK_IDF);
+			  else	df = GetDefinitionModule(dot.TOK_IDF, 1);
 			}
 	|
 			{ fromid = 0; }
@@ -124,16 +117,13 @@ import(int local;)
 DefinitionModule
 {
 	register struct def *df;
-	struct idf *id;			/* save module identifier */
 	struct node *exportlist;
 	int dummy;
 } :
 	DEFINITION
-	MODULE IDENT	{ id = dot.TOK_IDF;
+	MODULE IDENT	{ df = define(dot.TOK_IDF, GlobalScope, D_MODULE);
-			  df = define(id, GlobalScope, D_MODULE);
 			  if (!Defined) Defined = df;
-			  if (!SYSTEMModule) open_scope(CLOSEDSCOPE);
+			  CurrentScope->sc_name = df->df_idf->id_text;
-			  CurrentScope->sc_name = id->id_text;
 			  df->mod_vis = CurrVis;
 			  df->df_type = standard_type(T_RECORD, 0, (arith) 0);
 			  df->df_type->rec_scope = df->mod_vis->sc_scope;
@@ -154,15 +144,14 @@ node_warning(exportlist, "export list in definition module ignored");
 		/* empty */
 	]
 	definition* END IDENT
-			{ df = CurrentScope->sc_def;
+			{ register struct def *df1 = CurrentScope->sc_def;
-			  while (df) {
+			  while (df1) {
 				/* Make all definitions "QUALIFIED EXPORT" */
-				df->df_flags |= D_QEXPORTED;
+				df1->df_flags |= D_QEXPORTED;
-				df = df->df_nextinscope;
+				df1 = df1->df_nextinscope;
 			  }
-			  close_scope(SC_CHKFORW);
 			  DefinitionModule--;
-			  match_id(id, dot.TOK_IDF);
+			  match_id(df->df_idf, dot.TOK_IDF);
 			}
 	'.'
 ;
@@ -206,19 +195,17 @@ Semicolon:
 
 ProgramModule
 {
-	struct idf *id;
 	struct def *GetDefinitionModule();
 	register struct def *df;
 } :
 	MODULE
-	IDENT	{ id = dot.TOK_IDF;
+	IDENT	{ if (state == IMPLEMENTATION) {
-		  if (state == IMPLEMENTATION) {
+			df = GetDefinitionModule(dot.TOK_IDF, 0);
-			df = GetDefinitionModule(id);
 			CurrVis = df->mod_vis;
 			RemoveImports(&(CurrentScope->sc_def));
 		  }
 		  else {
-			Defined = df = define(id, CurrentScope, D_MODULE);
+			Defined = df = define(dot.TOK_IDF, CurrentScope, D_MODULE);
 			open_scope(CLOSEDSCOPE);
 			df->mod_vis = CurrVis;
 			CurrentScope->sc_name = "_M2M";
@@ -229,13 +216,15 @@ ProgramModule
 	';' import(0)*
 	block(&(df->mod_body)) IDENT
 		{ close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
-		  match_id(id, dot.TOK_IDF);
+		  match_id(df->df_idf, dot.TOK_IDF);
 		}
 	'.'
 ;
 
 Module:
+				{ open_scope(CLOSEDSCOPE); }
 	DefinitionModule
+				{ close_scope(SC_CHKFORW); }
 |
 	[
 		IMPLEMENTATION	{ state = IMPLEMENTATION; }

lang/m2/comp/scope.C

@@ -1,9 +1,5 @@
 /* S C O P E   M E C H A N I S M */
 
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
 #include	"debug.h"
 
 #include	<assert.h>
@@ -23,9 +19,9 @@ struct scopelist *CurrVis;
 extern int proclevel;
 static struct scopelist *PervVis;
 
-/* STATICALLOCDEF "scope" */
+/* STATICALLOCDEF "scope" 10 */
 
-/* STATICALLOCDEF "scopelist" */
+/* STATICALLOCDEF "scopelist" 10 */
 
 open_scope(scopetype)
 {
@@ -36,15 +32,14 @@ open_scope(scopetype)
 	
 	assert(scopetype == OPENSCOPE || scopetype == CLOSEDSCOPE);
 
-	clear((char *) sc, sizeof (struct scope));
 	sc->sc_scopeclosed = scopetype == CLOSEDSCOPE;
 	sc->sc_level = proclevel;
-	if (scopetype == OPENSCOPE) {
-		ls->next = CurrVis;
-	}
-	else	ls->next = PervVis;
 	ls->sc_scope = sc;
 	ls->sc_encl = CurrVis;
+	if (scopetype == OPENSCOPE) {
+		ls->next = ls->sc_encl;
+	}
+	else	ls->next = PervVis;
 	CurrVis = ls;
 }
 
@@ -71,7 +66,7 @@ struct forwards {
 	struct type *fo_ptyp;
 };
 
-/* STATICALLOCDEF "forwards" */
+/* STATICALLOCDEF "forwards" 5 */
 
 Forward(tk, ptp)
 	struct node *tk;
@@ -83,11 +78,12 @@ Forward(tk, ptp)
 		same scope.
 	*/
 	register struct forwards *f = new_forwards();
+	register struct scope *sc = CurrentScope;
 
 	f->fo_tok = tk;
 	f->fo_ptyp = ptp;
-	f->next = CurrentScope->sc_forw;
+	f->next = sc->sc_forw;
-	CurrentScope->sc_forw = f;
+	sc->sc_forw = f;
 }
 
 STATIC
@@ -95,13 +91,14 @@ chk_proc(df)
 	register struct def *df;
 {
 	/*	Called at scope closing. Check all definitions, and if one
-		is a D_PROCHEAD, the procedure was not defined
+		is a D_PROCHEAD, the procedure was not defined.
 	*/
 	while (df) {
 		if (df->df_kind == D_PROCHEAD) {
 			/* A not defined procedure
 			*/
-error("procedure \"%s\" not defined", df->df_idf->id_text);
+			error("procedure \"%s\" not defined",
+				df->df_idf->id_text);
 			FreeNode(df->for_node);
 		}
 		df = df->df_nextinscope;
@@ -110,46 +107,48 @@ error("procedure \"%s\" not defined", df->df_idf->id_text);
 
 STATIC
 chk_forw(pdf)
-	register struct def **pdf;
+	struct def **pdf;
 {
 	/*	Called at scope close. Look for all forward definitions and
 		if the scope was a closed scope, give an error message for
 		them, and otherwise move them to the enclosing scope.
 	*/
-	while (*pdf) {
+	register struct def *df;
-		if ((*pdf)->df_kind & (D_FORWARD|D_FORWMODULE)) {
+
+	while (df = *pdf) {
+		if (df->df_kind & (D_FORWARD|D_FORWMODULE)) {
 			/* These definitions must be found in
 			   the enclosing closed scope, which of course
 			   may be the scope that is now closed!
 			*/
-			struct def *df1 = (*pdf)->df_nextinscope;
-
 			if (scopeclosed(CurrentScope)) {
 				/* Indeed, the scope was a closed
 				   scope, so give error message
 				*/
-node_error((*pdf)->for_node, "identifier \"%s\" has not been declared",
+node_error(df->for_node, "identifier \"%s\" has not been declared",
-(*pdf)->df_idf->id_text);
+df->df_idf->id_text);
-				FreeNode((*pdf)->for_node);
+				FreeNode(df->for_node);
-				pdf = &(*pdf)->df_nextinscope;
 			}
-			else {	/* This scope was an open scope.
+			else {
+				/* This scope was an open scope.
 				   Maybe the definitions are in the
 				   enclosing scope?
 				*/
-				struct scopelist *ls;
+				register struct scopelist *ls =
-
+						nextvisible(CurrVis);
-				ls = nextvisible(CurrVis);
+				struct def *df1 = df->df_nextinscope;
-				if ((*pdf)->df_kind == D_FORWMODULE) {
+	
-					(*pdf)->for_vis->next = ls;
+				if (df->df_kind == D_FORWMODULE) {
+					df->for_vis->next = ls;
 				}
-				(*pdf)->df_nextinscope = ls->sc_scope->sc_def;
+				df->df_nextinscope = ls->sc_scope->sc_def;
-				ls->sc_scope->sc_def = *pdf;
+				ls->sc_scope->sc_def = df;
-				(*pdf)->df_scope = ls->sc_scope;
+				df->df_scope = ls->sc_scope;
 				*pdf = df1;
+				continue;
 			}
 		}
-		else	pdf = &(*pdf)->df_nextinscope;
+		pdf = &df->df_nextinscope;
 	}
 }
 
@@ -163,20 +162,17 @@ rem_forwards(fo)
 
 	if (fo->next) rem_forwards(fo->next);
 	df = lookfor(fo->fo_tok, CurrVis, 0);
-	if (df->df_kind == D_ERROR) {
+	if (! is_type(df)) {
-		node_error(fo->fo_tok, "identifier \"%s\" not declared",
+		node_error(fo->fo_tok,
-			df->df_idf->id_text);
+			   "identifier \"%s\" does not represent a type",
-	}
+			   df->df_idf->id_text);
-	else if (df->df_kind != D_TYPE) {
-		node_error(fo->fo_tok, "identifier \"%s\" not a type",
-			     df->df_idf->id_text);
 	}
 	fo->fo_ptyp->next = df->df_type;
 	free_forwards(fo);
 }
 
 Reverse(pdf)
-	register struct def **pdf;
+	struct def **pdf;
 {
 	/*	Reverse the order in the list of definitions in a scope.
 		This is neccesary because this list is built in reverse.
@@ -188,23 +184,18 @@ Reverse(pdf)
 
 	df = 0;
 	df1 = *pdf;
-	while (df1) {
-		if (df1->df_kind & INTERESTING) break;
-		df1 = df1->df_nextinscope;
-	}
-
-	if (!(*pdf = df1)) return;
 
 	while (df1) {
-		*pdf = df1;
+		if (df1->df_kind & INTERESTING) {
-		df1 = df1->df_nextinscope;
+			struct def *prev = df;
-		while (df1) {
+
-			if (df1->df_kind & INTERESTING) break;
+			df = df1;
 			df1 = df1->df_nextinscope;
+			df->df_nextinscope = prev;
 		}
-		(*pdf)->df_nextinscope = df;
+		else	df1 = df1->df_nextinscope;
-		df = *pdf;
 	}
+	*pdf = df;
 }
 
 close_scope(flag)

lang/m2/comp/scope.h

@@ -1,7 +1,5 @@
 /* S C O P E   M E C H A N I S M */
 
-/* $Header$ */
-
 #define OPENSCOPE	0	/* Indicating an open scope */
 #define CLOSEDSCOPE	1	/* Indicating a closed scope (module) */
 

lang/m2/comp/standards.h

@@ -1,7 +1,5 @@
 /* S T A N D A R D   P R O C E D U R E S   A N D   F U N C T I O N S */
 
-/* $Header$ */
-
 #define S_ABS	1
 #define S_CAP	2
 #define S_CHR	3

lang/m2/comp/statement.g

@@ -1,10 +1,6 @@
 /* S T A T E M E N T S */
 
 {
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
 #include	<assert.h>
 #include	<em_arith.h>
 #include	<em_label.h>
@@ -22,6 +18,7 @@ static int	loopcount = 0;	/* Count nested loops */
 statement(register struct node **pnd;)
 {
 	register struct node *nd;
+	extern int return_occurred;
 } :
 	/*
 	 * This part is not in the reference grammar. The reference grammar
@@ -64,6 +61,7 @@ statement(register struct node **pnd;)
 			}
 |
 	ReturnStatement(pnd)
+			{ return_occurred = 1; }
 |
 	/* empty */	{ *pnd = 0; }
 ;
@@ -88,9 +86,12 @@ StatementSequence(register struct node **pnd;)
 	[ %persistent
 		';' statement(&nd)
 			{ if (nd) {
-				*pnd = MkNode(Link, *pnd, nd, &dot);
+				register struct node *nd1 = 
-				(*pnd)->nd_symb = ';';
+						MkNode(Link, *pnd, nd, &dot);
-			  	pnd = &((*pnd)->nd_right);
+
+				*pnd = nd1;
+				nd1->nd_symb = ';';
+			  	pnd = &(nd1->nd_right);
 			  }
 			}
 	]*
@@ -178,31 +179,29 @@ RepeatStatement(struct node **pnd;)
 
 ForStatement(struct node **pnd;)
 {
-	register struct node *nd;
+	register struct node *nd, *nd1;
 	struct node *dummy;
 }:
 	FOR		{ *pnd = nd = MkLeaf(Stat, &dot); }
 	IDENT		{ nd->nd_IDF = dot.TOK_IDF; }
-	BECOMES		{ nd->nd_left = MkLeaf(Stat, &dot);
+	BECOMES		{ nd->nd_left = nd1 = MkLeaf(Stat, &dot); }
-			  nd = nd->nd_left;
+	expression(&(nd1->nd_left))
-			}
-	expression(&(nd->nd_left))
 	TO
-	expression(&(nd->nd_right))
+	expression(&(nd1->nd_right))
 	[
 		BY
 		ConstExpression(&dummy)
 			{ if (!(dummy->nd_type->tp_fund & T_INTORCARD)) {
 				error("illegal type in BY clause");
 			  }
-			  nd->nd_INT = dummy->nd_INT;
+			  nd1->nd_INT = dummy->nd_INT;
 			  FreeNode(dummy);
 			}
 	|
-			{ nd->nd_INT = 1; }
+			{ nd1->nd_INT = 1; }
 	]
 	DO
-	StatementSequence(&((*pnd)->nd_right))
+	StatementSequence(&(nd->nd_right))
 	END
 ;
 
@@ -227,12 +226,9 @@ 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/tmpvar.C

@@ -1,9 +1,5 @@
 /* T E M P O R A R Y   V A R I A B L E S */
 
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
 /*	Code for the allocation and de-allocation of temporary variables,
 	allowing re-use.
 	The routines use "ProcScope" instead of "CurrentScope", because
@@ -29,7 +25,7 @@ struct tmpvar {
 	arith		t_offset;	/* offset from LocalBase */
 };
 
-/* STATICALLOCDEF "tmpvar" */
+/* STATICALLOCDEF "tmpvar" 10 */
 
 static struct tmpvar	*TmpInts,	/* for integer temporaries */
 			*TmpPtrs;	/* for pointer temporaries */
@@ -47,7 +43,7 @@ TmpOpen(sc) struct scope *sc;
 arith
 NewInt()
 {
-	arith offset;
+	register arith offset;
 	register struct tmpvar *tmp;
 
 	if (!TmpInts) {
@@ -67,7 +63,7 @@ NewInt()
 arith
 NewPtr()
 {
-	arith offset;
+	register arith offset;
 	register struct tmpvar *tmp;
 
 	if (!TmpPtrs) {

lang/m2/comp/tokenname.c

@@ -1,9 +1,5 @@
 /* T O K E N   D E F I N I T I O N S */
 
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
 #include	"tokenname.h"
 #include	"Lpars.h"
 #include	"idf.h"

lang/m2/comp/tokenname.h

@@ -1,7 +1,5 @@
 /* T O K E N N A M E   S T R U C T U R E */
 
-/* $Header$ */
-
 struct tokenname	{	/*	Used for defining the name of a
 					token as identified by its symbol
 				*/

lang/m2/comp/type.H

@@ -1,7 +1,5 @@
 /* T Y P E   D E S C R I P T O R   S T R U C T U R E */
 
-/* $Header$ */
-
 struct paramlist {		/* structure for parameterlist of a PROCEDURE */
 	struct paramlist *next;
 	struct def *par_def;	/* "df" of parameter */
@@ -9,7 +7,7 @@ struct paramlist {		/* structure for parameterlist of a PROCEDURE */
 #define TypeOfParam(xpar)	((xpar)->par_def->df_type)
 };
 
-/* ALLOCDEF "paramlist" */
+/* ALLOCDEF "paramlist" 20 */
 
 struct enume {
 	struct def *en_enums;	/* Definitions of enumeration literals */
@@ -86,7 +84,7 @@ struct type	{
 	} tp_value;
 };
 
-/* ALLOCDEF "type" */
+/* ALLOCDEF "type" 50 */
 
 extern struct type
 	*bool_type,
@@ -125,11 +123,11 @@ extern arith
 	align();		/* type.c */
 
 struct type
-	*create_type(),
 	*construct_type(),
 	*standard_type(),
 	*set_type(),
 	*subr_type(),
+	*proc_type(),
 	*RemoveEqual();	/* All from type.c */
 
 #define NULLTYPE ((struct type *) 0)

lang/m2/comp/type.c

@@ -1,9 +1,5 @@
 /*	T Y P E   D E F I N I T I O N   M E C H A N I S M	 */
 
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
 #include	"target_sizes.h"
 #include	"debug.h"
 #include	"maxset.h"
@@ -66,21 +62,6 @@ struct type *h_type;
 int	cnt_type;
 #endif
 
-struct type *
-create_type(fund)
-	int fund;
-{
-	/*	A brand new struct type is created, and its tp_fund set
-		to fund.
-	*/
-	register struct type *ntp = new_type();
-
-	clear((char *)ntp, sizeof(struct type));
-	ntp->tp_fund = fund;
-
-	return ntp;
-}
-
 struct type *
 construct_type(fund, tp)
 	int fund;
@@ -89,9 +70,9 @@ construct_type(fund, tp)
 	/*	fund must be a type constructor.
 		The pointer to the constructed type is returned.
 	*/
-	register struct type *dtp = create_type(fund);
+	register struct type *dtp = new_type();
 
-	switch (fund)	{
+	switch (dtp->tp_fund = fund)	{
 	case T_PROCEDURE:
 	case T_POINTER:
 	case T_HIDDEN:
@@ -135,8 +116,9 @@ standard_type(fund, align, size)
 	int align;
 	arith size;
 {
-	register struct type *tp = create_type(fund);
+	register struct type *tp = new_type();
 
+	tp->tp_fund = fund;
 	tp->tp_align = align;
 	tp->tp_size = size;
 
@@ -167,10 +149,6 @@ InitTypes()
 		fatal("long real size smaller than real size");
 	}
 
-	if (!pointer_size || pointer_size % word_size != 0) {
-		fatal("illegal pointer size");
-	}
-
 	/* character type
 	*/
 	char_type = standard_type(T_CHAR, 1, (arith) 1);
@@ -303,6 +281,19 @@ subr_type(lb, ub)
 	return res;
 }
 
+struct type *
+proc_type(result_type, parameters, n_bytes_params)
+	struct type *result_type;
+	struct paramlist *parameters;
+	arith n_bytes_params;
+{
+	register struct type *tp = construct_type(T_PROCEDURE, result_type);
+
+	tp->prc_params = parameters;
+	tp->prc_nbpar = n_bytes_params;
+	return tp;
+}
+
 genrck(tp)
 	register struct type *tp;
 {
@@ -310,20 +301,22 @@ genrck(tp)
 		neccessary. Return its label.
 	*/
 	arith lb, ub;
-	label ol, l;
+	register label ol;
+	int newlabel = 0;
 
 	getbounds(tp, &lb, &ub);
 
 	if (tp->tp_fund == T_SUBRANGE) {
 		if (!(ol = tp->sub_rck)) {
-			tp->sub_rck = l = ++data_label;
+			tp->sub_rck = ol = ++data_label;
+			newlabel = 1;
 		}
 	}
 	else if (!(ol = tp->enm_rck)) {
-		tp->enm_rck = l = ++data_label;
+		tp->enm_rck = ol = ++data_label;
+		newlabel = 1;
 	}
-	if (!ol) {
+	if (newlabel) {
-		ol = l;
 		C_df_dlb(ol);
 		C_rom_cst(lb);
 		C_rom_cst(ub);
@@ -385,7 +378,7 @@ ArrayElSize(tp)
 	   Also make sure that its size is either a dividor of the word_size,
 	   or a multiple of it.
 	*/
-	arith algn;
+	register arith algn;
 
 	if (tp->tp_fund == T_ARRAY) ArraySizes(tp);
 	algn = align(tp->tp_size, tp->tp_align);
@@ -446,6 +439,7 @@ FreeType(tp)
 	while (pr) {
 		pr1 = pr;
 		pr = pr->next;
+		free_def(pr1->par_def);
 		free_paramlist(pr1);
 	}
 
@@ -520,21 +514,14 @@ DumpType(tp)
 {
 	if (!tp) return;
 
-	print(" a:%d; s:%ld;", tp->tp_align, (long) tp->tp_size);
+	print("align:%d; size:%ld;", tp->tp_align, (long) tp->tp_size);
-	if (tp->next && tp->tp_fund != T_POINTER) {
-		/* Avoid printing recursive types!
-		*/
-		print(" n:(");
-		DumpType(tp->next);
-		print(")");
-	}
 
-	print(" f:");
+	print(" fund:");
 	switch(tp->tp_fund) {
 	case T_RECORD:
 		print("RECORD"); break;
 	case T_ENUMERATION:
-		print("ENUMERATION; n:%d", tp->enm_ncst); break;
+		print("ENUMERATION; ncst:%d", tp->enm_ncst); break;
 	case T_INTEGER:
 		print("INTEGER"); break;
 	case T_CARDINAL:
@@ -562,7 +549,7 @@ DumpType(tp)
 
 		print("PROCEDURE");
 		if (par) {
-			print("; p:");
+			print("(");
 			while(par) {
 				if (IsVarParam(par)) print("VAR ");
 				DumpType(TypeOfParam(par));
@@ -573,11 +560,12 @@ DumpType(tp)
 		}
 	case T_ARRAY:
 		print("ARRAY");
-		print("; el:");
+		print("; element:");
 		DumpType(tp->arr_elem);
 		print("; index:");
 		DumpType(tp->next);
-		break;
+		print(";");
+		return;
 	case T_STRING:
 		print("STRING"); break;
 	case T_INTORCARD:
@@ -585,6 +573,13 @@ DumpType(tp)
 	default:
 		crash("DumpType");
 	}
+	if (tp->next && tp->tp_fund != T_POINTER) {
+		/* Avoid printing recursive types!
+		*/
+		print(" next:(");
+		DumpType(tp->next);
+		print(")");
+	}
 	print(";");
 }
 #endif

lang/m2/comp/typequiv.c

@@ -1,9 +1,5 @@
 /* T Y P E   E Q U I V A L E N C E */
 
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
 /*	Routines for testing type equivalence, type compatibility, and
 	assignment compatibility
 */

lang/m2/comp/walk.c

@@ -1,9 +1,5 @@
 /* P A R S E   T R E E   W A L K E R */
 
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
 /*	Routines to walk through parts of the parse tree, and generate
 	code for these parts.
 */
@@ -103,11 +99,6 @@ WalkModule(module)
 			C_loe_dlb(l1, (arith) 0);
 			C_zne(RETURN_LABEL);
 			C_ine_dlb(l1, (arith) 0);
-			/* Prevent this module from calling its own
-			   initialization routine
-			*/
-			assert(nd->nd_IDF == module->df_idf);
-			nd = nd->next;
 		}
 
 		for (; nd; nd = nd->next) {
@@ -415,17 +406,16 @@ WalkStat(nd, exit_label)
 		break;
 
 	case IF:
-		{	label l1, l2, l3;
+		{	label l1 = ++text_label, l3 = ++text_label;
 
-			l1 = ++text_label;
-			l2 = ++text_label;
-			l3 = ++text_label;
 			ExpectBool(left, l3, l1);
 			assert(right->nd_symb == THEN);
 			C_df_ilb(l3);
 			WalkNode(right->nd_left, exit_label);
 
 			if (right->nd_right) {	/* ELSE part */
+				label l2 = ++text_label;
+
 				C_bra(l2);
 				C_df_ilb(l1);
 				WalkNode(right->nd_right, exit_label);
@@ -440,73 +430,72 @@ WalkStat(nd, exit_label)
 		break;
 
 	case WHILE:
-		{	label l1, l2, l3;
+		{	label	loop = ++text_label,
+				exit = ++text_label,
+				dummy = ++text_label;
 
-			l1 = ++text_label;
+			C_df_ilb(loop);
-			l2 = ++text_label;
+			ExpectBool(left, dummy, exit);
-			l3 = ++text_label;
+			C_df_ilb(dummy);
-			C_df_ilb(l1);
-			ExpectBool(left, l3, l2);
-			C_df_ilb(l3);
 			WalkNode(right, exit_label);
-			C_bra(l1);
+			C_bra(loop);
-			C_df_ilb(l2);
+			C_df_ilb(exit);
 			break;
 		}
 
 	case REPEAT:
-		{	label l1, l2;
+		{	label loop = ++text_label, exit = ++text_label;
 
-			l1 = ++text_label;
+			C_df_ilb(loop);
-			l2 = ++text_label;
-			C_df_ilb(l1);
 			WalkNode(left, exit_label);
-			ExpectBool(right, l2, l1);
+			ExpectBool(right, exit, loop);
-			C_df_ilb(l2);
+			C_df_ilb(exit);
 			break;
 		}
 
 	case LOOP:
-		{	label l1, l2;
+		{	label loop = ++text_label, exit = ++text_label;
 
-			l1 = ++text_label;
+			C_df_ilb(loop);
-			l2 = ++text_label;
+			WalkNode(right, exit);
-			C_df_ilb(l1);
+			C_bra(loop);
-			WalkNode(right, l2);
+			C_df_ilb(exit);
-			C_bra(l1);
-			C_df_ilb(l2);
 			break;
 		}
 
 	case FOR:
 		{
 			arith tmp = 0;
-			struct node *fnd;
+			register struct node *fnd;
 			label l1 = ++text_label;
 			label l2 = ++text_label;
 
 			if (! DoForInit(nd, left)) break;
 			fnd = left->nd_right;
 			if (fnd->nd_class != Value) {
+				/* Upperbound not constant.
+				   The expression may only be evaluated once,
+				   so generate a temporary for it
+				*/
 				CodePExpr(fnd);
 				tmp = NewInt();
 				C_stl(tmp);
 			}
-			C_bra(l1);
+			C_df_ilb(l1);
-			C_df_ilb(l2);
+			C_dup(int_size);
+			if (tmp) C_lol(tmp); else C_loc(fnd->nd_INT);
+			if (left->nd_INT > 0) {
+				C_bgt(l2);
+			}
+			else	C_blt(l2);
 			RangeCheck(nd->nd_type, int_type);
 			CodeDStore(nd);
 			WalkNode(right, exit_label);
 			CodePExpr(nd);
 			C_loc(left->nd_INT);
 			C_adi(int_size);
-			C_df_ilb(l1);
+			C_bra(l1);
-			C_dup(int_size);
+			C_df_ilb(l2);
-			if (tmp) C_lol(tmp); else C_loc(fnd->nd_INT);
-			if (left->nd_INT > 0) {
-				C_ble(l2);
-			}
-			else	C_bge(l2);
 			C_asp(int_size);
 			if (tmp) FreeInt(tmp);
 		}
@@ -517,7 +506,6 @@ WalkStat(nd, exit_label)
 			struct scopelist link;
 			struct withdesig wds;
 			struct desig ds;
-			arith tmp = 0;
 
 			if (! WalkDesignator(left, &ds)) break;
 			if (left->nd_type->tp_fund != T_RECORD) {
@@ -532,7 +520,7 @@ WalkStat(nd, exit_label)
 			ds.dsg_kind = DSG_FIXED;
 			/* Create a designator structure for the temporary.
 			*/
-			ds.dsg_offset = tmp = NewPtr();
+			ds.dsg_offset = NewPtr();
 			ds.dsg_name = 0;
 			CodeStore(&ds, pointer_size);
 			ds.dsg_kind = DSG_PFIXED;
@@ -544,7 +532,7 @@ WalkStat(nd, exit_label)
 			WalkNode(right, exit_label);
 			CurrVis = link.next;
 			WithDesigs = wds.w_next;
-			FreePtr(tmp);
+			FreePtr(ds.dsg_offset);
 			break;
 		}
 
@@ -648,12 +636,13 @@ DoForInit(nd, left)
 	nd->nd_symb = IDENT;
 
 	if (! ChkVariable(nd) ||
-	    ! ChkExpression(left->nd_left) ||
+	    ! WalkExpr(left->nd_left) ||
 	    ! ChkExpression(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");
+		node_error(nd,
+			   "FOR-loop variable may not be a field of a record");
 		return 0;
 	}
 
@@ -665,14 +654,15 @@ DoForInit(nd, left)
 	if (df->df_scope != CurrentScope) {
 		register struct scopelist *sc = CurrVis;
 
-		while (sc && sc->sc_scope != df->df_scope) {
+		for (;;) {
+			if (!sc) {
+				node_error(nd,
+				      "FOR-loop variable may not be imported");
+				return 0;
+			}
+			if (sc->sc_scope == df->df_scope) break;
 			sc = nextvisible(sc);
 		}
-
-		if (!sc) {
-			node_error(nd, "FOR-loop variable may not be imported");
-			return 0;
-		}
 	}
 
 	if (df->df_type->tp_size > word_size ||
@@ -691,8 +681,6 @@ DoForInit(nd, left)
 node_warning(nd, "old-fashioned! compatibility required in FOR statement");
 	}
 
-	CodePExpr(left->nd_left);
-
 	return 1;
 }
 
@@ -703,11 +691,12 @@ DoAssign(nd, left, right)
 	/* May we do it in this order (expression first) ???
 	   The reference manual sais nothing about it, but the book does:
 	   it sais that the left hand side is evaluated first.
+	   DAMN THE BOOK!
 	*/
 	struct desig dsl, dsr;
 
-	if (! ChkExpression(right)) return;
+	if (! ChkExpression(right) || ! ChkVariable(left)) return;
-	if (! ChkVariable(left)) return;
+
 	if (right->nd_symb == STRING) TryToString(right, left->nd_type);
 	dsr = InitDesig;
 	CodeExpr(right, &dsr, NO_LABEL, NO_LABEL);

lang/m2/comp/walk.h

@@ -1,7 +1,5 @@
 /* P A R S E   T R E E   W A L K E R */
 
-/* $Header$ */
-
 /*	Definition of WalkNode macro
 */