newer version

lang/m2/comp/LLlex.c

@@ -1,16 +1,19 @@
 /* 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"
+#include	"strsize.h"
 
 #include	<alloc.h>
 #include	<em_arith.h>
 #include	<em_label.h>
 #include	<assert.h>
 
-#include	"idfsize.h"
-#include	"numsize.h"
-#include	"strsize.h"
-
 #include	"input.h"
 #include	"f_info.h"
 #include	"Lpars.h"

lang/m2/comp/LLlex.h

@@ -18,6 +18,7 @@ struct token	{
 		char *tk_real;		/* REAL		*/
 		arith *tk_set;		/* only used in parse tree node */
 		struct def *tk_def;	/* only used in parse tree node */
+		label tk_lab;		/* only used in parse tree node */
 	} tk_data;
 };
 

lang/m2/comp/LLmessage.c

@@ -1,9 +1,13 @@
 /* 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
 
 #include	<alloc.h>
 #include	<em_arith.h>
+#include	<em_label.h>
+
 #include	"idf.h"
 #include	"LLlex.h"
 #include	"Lpars.h"

lang/m2/comp/Makefile

@@ -18,7 +18,7 @@ LOBJ =	tokenfile.o program.o declar.o expression.o statement.o
 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
+	cstoper.o chk_expr.o options.o walk.o casestat.o
 OBJ =	$(COBJ) $(LOBJ) Lpars.o
 GENFILES=	tokenfile.c \
 	program.c declar.c expression.c statement.c \
@@ -58,6 +58,7 @@ def.h:		def.H make.allocd
 type.h:		type.H make.allocd
 node.h:		node.H make.allocd
 scope.c:	scope.C make.allocd
+casestat.c:	casestat.C make.allocd
 
 char.c: char.tab tab
 	./tab -fchar.tab >char.c

lang/m2/comp/Parameters

@@ -67,4 +67,5 @@ extern char options[];
 #define NDIRS	16		/* maximum number of directories searched */
 
 
-
+!File: density.h
+#define DENSITY	3		/* see casestat.C for an explanation */

lang/m2/comp/casestat.C

@@ -0,0 +1,279 @@
+/* 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
+static char *RcsId = "$Header$";
+#endif
+
+#include	"debug.h"
+
+#include	<em_label.h>
+#include	<em_arith.h>
+#include	<alloc.h>
+#include	<assert.h>
+
+#include	"Lpars.h"
+#include	"type.h"
+#include	"LLlex.h"
+#include	"node.h"
+
+#include	"density.h"
+
+/* STATICALLOCDEF "caselist" */
+
+struct switch_hdr	{
+	struct switch_hdr *next;
+	label sh_break;
+	label sh_default;
+	int sh_nrofentries;
+	struct type *sh_type;
+	arith sh_lowerbd;
+	arith sh_upperbd;
+	struct case_entry *sh_entries;
+};
+
+/* STATICALLOCDEF "switch_hdr" */
+
+struct case_entry	{
+	struct case_entry *next;
+	label ce_label;
+	arith ce_value;
+};
+
+/* STATICALLOCDEF "case_entry" */
+
+/* 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
+   may be lower.
+*/
+#define	compact(nr, low, up)	(nr != 0 && (up - low) / nr <= DENSITY)
+
+extern label text_label(), data_label();
+
+CaseCode(nd, exitlabel)
+	struct node *nd;
+	label exitlabel;
+{
+	/*	Check the expression, stack a new case header and
+		fill in the necessary fields.
+	*/
+	register struct switch_hdr *sh = new_switch_hdr();
+	register struct node *pnode = nd;
+	register struct case_entry *ce;
+	register arith val;
+	label tablabel;
+
+	assert(nd->nd_class == Stat && nd->nd_symb == CASE);
+
+	WalkExpr(nd->nd_left);
+	sh->sh_type = nd->nd_left->nd_type;
+	sh->sh_break = text_label();
+	sh->sh_default = 0;
+	sh->sh_nrofentries = 0;
+	sh->sh_lowerbd = sh->sh_upperbd = (arith)0;	/* immaterial ??? */
+	sh->sh_entries = (struct case_entry *) 0; /* case-entry list	*/
+
+	/* Now, create case label list
+	*/
+	while (pnode && pnode->nd_right) {
+		pnode = pnode->nd_right;
+		if (pnode->nd_class == Link && pnode->nd_symb == '|') {
+			if (pnode->nd_left) {
+				pnode->nd_lab = text_label();
+				if (! AddCases(sh,
+					       pnode->nd_left->nd_left,
+					       pnode->nd_lab)) {
+					FreeSh(sh);
+					return;
+				}
+			}
+		}
+		else {
+			/* Else part
+			*/
+			pnode = 0;
+			sh->sh_default = text_label();
+		}
+	}
+
+	/* Now generate code for the switch itself
+	*/
+	tablabel = data_label();	/* the rom must have a label	*/
+	C_df_dlb(tablabel);
+	if (sh->sh_default) C_rom_ilb(sh->sh_default);
+	else C_rom_ucon((arith) 0, pointer_size);
+	if (compact(sh->sh_nrofentries, sh->sh_lowerbd, sh->sh_upperbd)) {
+		/* CSA */
+
+		C_rom_cst(sh->sh_lowerbd);
+		C_rom_cst(sh->sh_upperbd - sh->sh_lowerbd);
+		ce = sh->sh_entries;
+		for (val = sh->sh_lowerbd; val <= sh->sh_upperbd; val++) {
+			assert(ce);
+			if (val == ce->ce_value)	{
+				C_rom_ilb(ce->ce_label);
+				ce = ce->next;
+			}
+			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_csa(word_size);
+	}
+	else	{ /* CSB */
+		C_rom_cst((arith)sh->sh_nrofentries);
+		for (ce = sh->sh_entries; ce; ce = ce->next)	{
+			/* 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_csb(word_size);
+	}
+
+	/* Now generate code for the cases
+	*/
+	pnode = nd;
+	while (pnode && pnode->nd_right) {
+		pnode = pnode->nd_right;
+		if (pnode->nd_class == Link && pnode->nd_symb == '|') {
+			if (pnode->nd_left) {
+				C_df_ilb(pnode->nd_lab);
+				WalkNode(pnode->nd_left->nd_right, exitlabel);
+				C_bra(sh->sh_break);
+			}
+		}
+		else {
+			/* Else part
+			*/
+			assert(sh->sh_default != 0);
+
+			C_df_ilb(sh->sh_default);
+			WalkNode(pnode, exitlabel);
+			pnode = 0;
+		}
+	}
+
+	C_df_ilb(sh->sh_break);
+	FreeSh(sh);
+}
+
+FreeSh(sh)
+	struct switch_hdr *sh;
+{
+	/*	 free the allocated switch structure	
+	*/
+	register struct case_entry *ce;
+
+	ce = sh->sh_entries;
+	while (ce)	{
+		struct case_entry *tmp = ce->next;
+
+		free_case_entry(ce);
+		ce = tmp;
+	}
+
+	free_switch_hdr(sh);
+}
+
+AddCases(sh, node, lbl)
+	struct switch_hdr *sh;
+	struct node *node;
+	label lbl;
+{
+	/*	Add case labels to the case label list
+	*/
+	register arith v1, v2;
+
+	if (node->nd_class == Link) {
+		if (node->nd_symb == UPTO) {
+			assert(node->nd_left->nd_class == Value);
+			assert(node->nd_right->nd_class == Value);
+			v2 = node->nd_right->nd_INT;
+			node->nd_type = node->nd_left->nd_type;
+			for (v1 = node->nd_left->nd_INT; v1 <= v2; v1++) {
+				node->nd_INT = v1;
+				if (! AddOneCase(sh, node, lbl)) return 0;
+			}
+			return 1;
+		}
+
+		assert(node->nd_symb == ',');
+		return	AddCases(sh, node->nd_left, lbl) &&
+		    	AddCases(sh, node->nd_right, lbl);
+	}
+
+	assert(node->nd_class == Value);
+	return AddOneCase(sh, node, lbl);
+}
+
+AddOneCase(sh, node, lbl)
+	register struct switch_hdr *sh;
+	struct node *node;
+	label lbl;
+{
+	register struct case_entry *ce = new_case_entry();
+	register struct case_entry *c1 = sh->sh_entries, *c2 = 0;
+
+	ce->ce_label = lbl;
+	ce->ce_value = node->nd_INT;
+	if (! TstCompat(sh->sh_type, node->nd_type)) {
+		node_error(node, "Type incompatibility in case");
+		free_case_entry(ce);
+		return 0;
+	}
+	if (sh->sh_entries == 0)	{
+		/* 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		*/
+		/* find the proper place to put ce into the list	*/
+		
+		if (ce->ce_value < sh->sh_lowerbd) sh->sh_lowerbd = ce->ce_value;
+		else
+		if (ce->ce_value > sh->sh_upperbd) sh->sh_upperbd = ce->ce_value;
+		while (c1 && c1->ce_value < ce->ce_value)	{
+			c2 = c1;
+			c1 = c1->next;
+		}
+		/*	At this point three cases are possible:
+			1: c1 != 0 && c2 != 0:
+				insert ce somewhere in the middle
+			2: c1 != 0 && c2 == 0:
+				insert ce right after the head
+			3: c1 == 0 && c2 != 0:
+				append ce to last element
+			The case c1 == 0 && c2 == 0 cannot occur, since
+			the list is guaranteed not to be empty.
+		*/
+		if (c1)	{
+			if (c1->ce_value == ce->ce_value)	{
+				node_error("multiple case entry for value %ld",
+					ce->ce_value);
+				free_case_entry(ce);
+				return 0;
+			}
+			if (c2)	{
+				ce->next = c2->next;
+				c2->next = ce;
+			}
+			else	{
+				ce->next = sh->sh_entries;
+				sh->sh_entries = ce;
+			}
+		}
+		else	{
+			assert(c2);
+
+			ce->next = (struct case_entry *) 0;
+			c2->next = ce;
+		}
+		(sh->sh_nrofentries)++;
+	}
+	return 1;
+}

lang/m2/comp/chk_expr.c

@@ -1,9 +1,14 @@
 /* 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.
 */
+
+#include	"debug.h"
+
 #include	<em_arith.h>
 #include	<em_label.h>
 #include	<assert.h>
@@ -19,8 +24,6 @@ static char *RcsId = "$Header$";
 #include	"const.h"
 #include	"standards.h"
 
-#include	"debug.h"
-
 extern char *symbol2str();
 
 int

lang/m2/comp/cstoper.c

@@ -1,13 +1,16 @@
 /* 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"
 
 #include	<em_arith.h>
 #include	<em_label.h>
 #include	<assert.h>
 
-#include	"target_sizes.h"
-
 #include	"idf.h"
 #include	"type.h"
 #include	"LLlex.h"
@@ -47,7 +50,7 @@ cstunary(expp)
 	expp->nd_class = Value;
 	expp->nd_token = expp->nd_right->nd_token;
 	expp->nd_INT = o1;
-	cut_size(expp);
+	CutSize(expp);
 	FreeNode(expp->nd_right);
 	expp->nd_right = 0;
 }
@@ -64,11 +67,14 @@ cstbin(expp)
 	int uns = expp->nd_type != int_type;
 
 	assert(expp->nd_class == Oper);
-	assert(expp->nd_left->nd_class == Value && expp->nd_right->nd_class == Value);
+	assert(expp->nd_left->nd_class == Value);
+	assert(expp->nd_right->nd_class == Value);
+
 	switch (expp->nd_symb)	{
 	case '*':
 		o1 *= o2;
 		break;
+
 	case DIV:
 		if (o2 == 0)	{
 			node_error(expp, "division by 0");
@@ -106,6 +112,7 @@ cstbin(expp)
 		else
 			o1 /= o2;
 		break;
+
 	case MOD:
 		if (o2 == 0)	{
 			node_error(expp, "modulo by 0");
@@ -135,12 +142,15 @@ cstbin(expp)
 		else
 			o1 %= o2;
 		break;
+
 	case '+':
 		o1 += o2;
 		break;
+
 	case '-':
 		o1 -= o2;
 		break;
+
 	case '<':
 		if (uns)	{
 			o1 = (o1 & mach_long_sign ?
@@ -151,6 +161,7 @@ cstbin(expp)
 		else
 			o1 = o1 < o2;
 		break;
+
 	case '>':
 		if (uns)	{
 			o1 = (o1 & mach_long_sign ?
@@ -201,7 +212,7 @@ cstbin(expp)
 	expp->nd_class = Value;
 	expp->nd_token = expp->nd_right->nd_token;
 	expp->nd_INT = o1;
-	cut_size(expp);
+	CutSize(expp);
 	FreeNode(expp->nd_left);
 	FreeNode(expp->nd_right);
 	expp->nd_left = expp->nd_right = 0;
@@ -318,18 +329,18 @@ cstcall(expp, call)
 		}
 		if (expr->nd_INT < 0) expp->nd_INT = - expr->nd_INT;
 		else expp->nd_INT = expr->nd_INT;
-		cut_size(expp);
+		CutSize(expp);
 		break;
 	case S_CAP:
 		if (expr->nd_INT >= 'a' && expr->nd_INT <= 'z') {
 			expp->nd_INT = expr->nd_INT + ('A' - 'a');
 		}
 		else	expp->nd_INT = expr->nd_INT;
-		cut_size(expp);
+		CutSize(expp);
 		break;
 	case S_CHR:
 		expp->nd_INT = expr->nd_INT;
-		cut_size(expp);
+		CutSize(expp);
 		break;
 	case S_MAX:
 		if (expp->nd_type == int_type) {
@@ -363,7 +374,7 @@ cstcall(expp, call)
 		break;
 	case S_ORD:
 		expp->nd_INT = expr->nd_INT;
-		cut_size(expp);
+		CutSize(expp);
 		break;
 	case S_SIZE:
 		expp->nd_INT = align(expr->nd_type->tp_size, (int) word_size) /
@@ -386,7 +397,7 @@ cstcall(expp, call)
 		      )
 		    )
 		   )	node_warning(expp,"overflow in constant expression");
-		else cut_size(expp);
+		else CutSize(expp);
 		break;
 	default:
 		assert(0);
@@ -396,7 +407,7 @@ cstcall(expp, call)
 	expp->nd_right = expp->nd_left = 0;
 }
 
-cut_size(expr)
+CutSize(expr)
 	register struct node *expr;
 {
 	/*	The constant value of the expression expr is made to
@@ -430,7 +441,7 @@ cut_size(expr)
 	expr->nd_INT = o1;
 }
 
-init_cst()
+InitCst()
 {
 	int i = 0;
 	arith bt = (arith)0;

lang/m2/comp/declar.g

@@ -1,7 +1,11 @@
 /* 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>
 #include	<em_label.h>
@@ -17,8 +21,6 @@ static char *RcsId = "$Header$";
 #include	"misc.h"
 #include	"main.h"
 
-#include	"debug.h"
-
 int		proclevel = 0;	/* nesting level of procedures */
 extern char	*sprint();
 extern struct def *currentdef;
@@ -382,6 +384,9 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
 				{ id = gen_anon_idf(); }
 	]
 				{ tp = df->df_type;
+				  if (!(tp->tp_fund & T_DISCRETE)) {
+					error("Illegal type in variant");
+				  }
 				  df = define(id, scope, D_FIELD);
 				  df->df_type = tp;
 				  df->fld_off = align(*cnt, tp->tp_align);
@@ -439,8 +444,8 @@ CaseLabels(struct type **ptp; struct node **pnd;)
 		ConstExpression(&nd2)
 				{ if (!TstCompat(nd1->nd_type, nd2->nd_type)) {
 node_error(nd2,"type incompatibility in case label");
-				  }
 				  	nd1->nd_type = error_type;
+				  }
 				  (*pnd)->nd_right = nd2;
 				}
 	]?

lang/m2/comp/def.c

@@ -1,6 +1,10 @@
 /* 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>
 #include	<em_arith.h>
@@ -15,14 +19,9 @@ static char *RcsId = "$Header$";
 #include	"LLlex.h"
 #include	"node.h"
 
-#include	"debug.h"
-
 struct def *h_def;		/* Pointer to free list of def structures */
 
-static struct def illegal_def =
+struct def *ill_df;
-	{0, 0, 0, 0, D_ERROR};
-
-struct def *ill_df = &illegal_def;
 
 struct def *
 MkDef(id, scope, kind)
@@ -49,6 +48,16 @@ MkDef(id, scope, kind)
 	return df;
 }
 
+InitDef()
+{
+	/*	Initialize this module. Easy, the only thing to be initialized
+		is "illegal_def".
+	*/
+	struct idf *gen_anon_idf();
+
+	ill_df = MkDef(gen_anon_idf(), CurrentScope, D_ERROR);
+}
+
 struct def *
 define(id, scope, kind)
 	register struct idf *id;
@@ -59,8 +68,6 @@ define(id, scope, kind)
 	*/
 	register struct def *df;
 
-	DO_DEBUG(5, debug("Defining identifier \"%s\", kind = %d",
-			  id->id_text, kind));
 	df = lookup(id, scope);
 	if (	/* Already in this scope */
 		df
@@ -372,10 +379,9 @@ ids->nd_IDF->id_text);
 			else	df = GetDefinitionModule(ids->nd_IDF);
 		}
 
-DO_DEBUG(2, debug("importing \"%s\", kind %d", ids->nd_IDF->id_text,
+		define(ids->nd_IDF,CurrentScope,D_IMPORT)->imp_def = df;
-df->df_kind));
-		define(df->df_idf, CurrentScope, D_IMPORT)->imp_def = df;
 		DoImport(df, CurrentScope);
+
 		ids = ids->next;
 	}
 
@@ -463,8 +469,8 @@ DeclProc(type)
 				sprint(buf, "_%d_%s", ++nmcount,
 					df->df_idf->id_text);
 			}
-			else	(sprint(buf, "%s_%s",CurrentScope->sc_name,
+			else	sprint(buf, "%s_%s",CurrentScope->sc_name,
-						df->df_idf->id_text));
+						df->df_idf->id_text);
 			open_scope(OPENSCOPE);
 			df->prc_vis = CurrVis;
 			CurrentScope->sc_name = Malloc((unsigned)(strlen(buf)+1));
@@ -491,6 +497,6 @@ InitProc(nd, df)
 PrDef(df)
 	register struct def *df;
 {
-	debug("name: %s, kind: %d", df->df_idf->id_text, df->df_kind);
+	print("n: %s, k: %d\n", df->df_idf->id_text, df->df_kind);
 }
 #endif DEBUG

lang/m2/comp/defmodule.c

@@ -1,6 +1,10 @@
 /* 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>
 #include	<em_arith.h>
@@ -14,8 +18,6 @@ static char *RcsId = "$Header$";
 #include	"f_info.h"
 #include	"main.h"
 
-#include	"debug.h"
-
 #ifdef DEBUG
 long	sys_filesize();
 #endif

lang/m2/comp/enter.c

@@ -1,11 +1,16 @@
 /* H I G H   L E V E L   S Y M B O L   E N T R Y   A N D   L O O K U P */
 
+#ifndef NORCSID
 static char *RcsId = "$Header$";
+#endif
+
+#include	"debug.h"
 
 #include	<alloc.h>
 #include	<em_arith.h>
 #include	<em_label.h>
 #include	<assert.h>
+
 #include	"idf.h"
 #include	"def.h"
 #include	"type.h"

lang/m2/comp/error.c

@@ -5,14 +5,17 @@
 	number of arguments!
 */
 
+#ifndef NORCSID
 static char *RcsId = "$Header$";
-
+#endif
-#include	<system.h>
-#include	<em_arith.h>
 
 #include	"errout.h"
 #include	"debug.h"
 
+#include	<system.h>
+#include	<em_arith.h>
+#include	<em_label.h>
+
 #include	"input.h"
 #include	"f_info.h"
 #include	"LLlex.h"

lang/m2/comp/expression.g

@@ -1,19 +1,23 @@
 /* E X P R E S S I O N S */
 
 {
+#ifndef NORCSID
 static char *RcsId = "$Header$";
+#endif
+
+#include	"debug.h"
 
 #include	<alloc.h>
 #include	<em_arith.h>
 #include	<em_label.h>
 #include	<assert.h>
+
 #include	"LLlex.h"
 #include	"idf.h"
 #include	"def.h"
 #include	"node.h"
 #include	"const.h"
 #include	"type.h"
-#include	"debug.h"
 }
 
 number(struct node **p;)

lang/m2/comp/main.c

@@ -1,6 +1,11 @@
 /* M A I N   P R O G R A M */
 
+#ifndef NORCSID
 static char *RcsId = "$Header$";
+#endif
+
+#include	"debug.h"
+#include	"ndir.h"
 
 #include	<system.h>
 #include	<em_arith.h>
@@ -18,9 +23,6 @@ static char *RcsId = "$Header$";
 #include	"tokenname.h"
 #include	"node.h"
 
-#include	"debug.h"
-#include	"ndir.h"
-
 char	options[128];
 int	DefinitionModule; 
 int	SYSTEMModule = 0;
@@ -39,7 +41,7 @@ main(argc, argv)
 
 	while (--argc > 0) {
 		if (**argv == '-')
-			do_option((*argv++) + 1);
+			DoOption((*argv++) + 1);
 		else
 			Nargv[Nargc++] = *argv++;
 	}
@@ -70,11 +72,12 @@ Compile(src, dst)
 	DEFPATH[0] = "";
 	DEFPATH[NDIRS] = 0;
 	init_idf();
-	init_cst();
+	InitCst();
 	reserve(tkidf);
 	init_scope();
 	init_types();
-	add_standards();
+	InitDef();
+	AddStandards();
 #ifdef DEBUG
 	if (options['l']) {
 		LexScan();
@@ -133,7 +136,7 @@ LexScan()
 }
 #endif
 
-add_standards()
+AddStandards()
 {
 	register struct def *df;
 	struct def *Enter();

lang/m2/comp/misc.c

@@ -1,9 +1,13 @@
 /* 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>
+
 #include	"f_info.h"
 #include	"misc.h"
 #include	"LLlex.h"

lang/m2/comp/node.H

@@ -21,6 +21,7 @@ struct node {
 	struct token nd_token;
 #define nd_set		nd_token.tk_data.tk_set
 #define nd_def		nd_token.tk_data.tk_def
+#define nd_lab		nd_token.tk_data.tk_lab
 #define nd_symb		nd_token.tk_symb
 #define nd_lineno	nd_token.tk_lineno
 #define nd_filename	nd_token.tk_filename

lang/m2/comp/node.c

@@ -1,16 +1,20 @@
 /* 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>
 #include	<em_arith.h>
 #include	<alloc.h>
 #include	<system.h>
+
 #include	"def.h"
 #include	"type.h"
 #include	"LLlex.h"
 #include	"node.h"
-#include	"debug.h"
 
 struct node *h_node;		/* header of free list */
 

lang/m2/comp/options.c

@@ -1,21 +1,22 @@
 /* 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	<em_arith.h>
-#include	<em_label.h>
 
 #include	"idfsize.h"
 #include	"ndir.h"
 
+#include	<em_arith.h>
+#include	<em_label.h>
+
 #include	"type.h"
 #include	"main.h"
 
 extern int	idfsize;
-
 static int	ndirs;
 
-do_option(text)
+DoOption(text)
 	char *text;
 {
 	switch(*text++)	{

lang/m2/comp/program.g

@@ -1,7 +1,11 @@
 /* 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>
 #include	<em_arith.h>
@@ -15,8 +19,6 @@ static  char *RcsId = "$Header$";
 #include	"type.h"
 #include	"node.h"
 
-#include	"debug.h"
-
 static int DEFofIMPL = 0;	/* Flag indicating that we are currently
 				   parsing the definition module of the
 				   implementation module currently being

lang/m2/comp/scope.C

@@ -1,6 +1,10 @@
 /* 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>
 #include	<alloc.h>
@@ -14,8 +18,6 @@ static char *RcsId = "$Header$";
 #include	"def.h"
 #include	"node.h"
 
-#include	"debug.h"
-
 struct scope *PervasiveScope, *GlobalScope;
 struct scopelist *CurrVis;
 static int scp_level;
@@ -233,7 +235,7 @@ close_scope(flag)
 PrScopeDef(df)
 	register struct def *df;
 {
-	debug("List of definitions in currently ended scope:");
+	print("List of definitions in currently ended scope:\n");
 	while (df) {
 		PrDef(df);
 		df = df->df_nextinscope;

lang/m2/comp/statement.g

@@ -1,7 +1,9 @@
 /* S T A T E M E N T S */
 
 {
+#ifndef NORCSID
 static char *RcsId = "$Header$";
+#endif
 
 #include	<em_arith.h>
 #include	<em_label.h>

lang/m2/comp/tokenname.c

@@ -1,6 +1,8 @@
 /* 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"

lang/m2/comp/type.c

@@ -1,16 +1,18 @@
 /*	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"
 
 #include	<assert.h>
 #include	<alloc.h>
 #include	<em_arith.h>
 #include	<em_label.h>
 
-#include	"target_sizes.h"
-#include	"debug.h"
-#include	"maxset.h"
-
 #include	"def.h"
 #include	"type.h"
 #include	"idf.h"

lang/m2/comp/typequiv.c

@@ -1,12 +1,15 @@
 /* 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
 */
 #include	<em_arith.h>
 #include	<em_label.h>
+
 #include	"type.h"
 #include	"def.h"
 

lang/m2/comp/walk.c

@@ -1,11 +1,15 @@
 /* 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.
 */
 
+#include	"debug.h"
+
 #include	<em_arith.h>
 #include	<em_label.h>
 #include	<assert.h>
@@ -18,16 +22,26 @@ static char *RcsId = "$Header$";
 #include	"node.h"
 #include	"Lpars.h"
 
-#include	"debug.h"
-
 extern arith	align();
 static int	prclev = 0;
-static label	instructionlabel = 0;
+static label	instructionlabel;
-static label	datalabel = 0;
+static label	datalabel = 1;
 static label	return_label;
 static char	return_expr_occurred;
 static struct type *func_type;
 
+label
+text_label()
+{
+	return instructionlabel++;
+}
+
+label
+data_label()
+{
+	return datalabel++;
+}
+
 WalkModule(module)
 	register struct def *module;
 {
@@ -182,9 +196,7 @@ WalkStat(nd, lab)
 	register struct node *right = nd->nd_right;
 
 	if (nd->nd_class == Call) {
-		if (chk_call(nd)) {
+		if (chk_call(nd)) CodeCall(nd);
-			/* ??? */
-		}
 		return;
 	}
 
@@ -199,7 +211,9 @@ WalkStat(nd, lab)
 			node_error(nd, "type incompatibility in assignment");
 			break;
 		}
-		/* ??? */
+
+		CodeAssign(nd);
+
 		break;
 
 	case IF:
@@ -223,23 +237,8 @@ WalkStat(nd, lab)
 		}
 
 	case CASE:
-		{
+		CaseCode(nd, lab);
-			WalkExpr(left);
-
-			while (right) {
-				if (right->nd_class == Link && right->nd_symb == '|') {
-					WalkNode(right->nd_left->nd_right, lab);
-					right = right->nd_right;
-				}
-				else	{
-					WalkNode(right, lab);
-					right = 0;
-				}
-			}
-
-			/* ??? */
 		break;
-		}
 
 	case WHILE:
 		{	label l1, l2;
@@ -317,6 +316,7 @@ WalkStat(nd, lab)
 			if (!TstAssCompat(func_type, right->nd_type)) {
 node_error(right, "type incompatibility in RETURN statement");
 			}
+			return_expr_occurred = 1;
 		}
 		C_bra(return_label);
 		break;
@@ -348,10 +348,10 @@ WalkExpr(nd)
 
 	DO_DEBUG(1, (DumpTree(nd), print("\n")));
 
-	if (chk_expr(nd)) {
+	if (! chk_expr(nd)) return;
+
 	/* ??? */
 }
-}
 
 WalkDesignator(nd)
 	struct node *nd;
@@ -361,9 +361,27 @@ WalkDesignator(nd)
 
 	DO_DEBUG(1, (DumpTree(nd), print("\n")));
 
-	if (chk_designator(nd, DESIGNATOR|VARIABLE)) {
+	if (! chk_designator(nd, DESIGNATOR|VARIABLE)) return;
+
 	/* ??? */
 }
+
+CodeCall(nd)
+	struct node *nd;
+{
+	/*	Generate code for a procedure call. Checking of parameters
+		and result is already done.
+	*/
+	/* ??? */
+}
+
+CodeAssign(nd)
+	struct node *nd;
+{
+	/*	Generate code for an assignment. Testing of type
+		compatibility and the like is already done.
+	*/
+	/* ??? */
 }
 
 #ifdef DEBUG