newer version

lang/m2/comp/LLlex.c

@@ -182,7 +182,7 @@ again:
 			}
 			else
 			if (nch == '>') {
-				return tk->tk_symb = UNEQUAL;
+				return tk->tk_symb = '#';
 			}
 			PushBack(nch);
 			return tk->tk_symb = ch;
@@ -219,7 +219,9 @@ again:
 
 	case STSTR:
 		GetString(ch);
-		tk->tk_data.tk_str = string;
+		tk->tk_data.tk_str = (struct string *)
+				Malloc(sizeof (struct string));
+		*(tk->tk_data.tk_str) = string;
 		return tk->tk_symb = STRING;
 
 	case STNUM:

lang/m2/comp/LLlex.h

@@ -13,7 +13,7 @@ struct token	{
 	int tk_lineno;		/* linenumber on which it occurred */
 	union {
 		struct idf *tk_idf;	/* IDENT	*/
-		struct string tk_str;	/* STRING	*/
+		struct string *tk_str;	/* STRING	*/
 		arith tk_int;		/* INTEGER	*/
 		char *tk_real;		/* REAL		*/
 		arith *tk_set;		/* only used in parse tree node */
@@ -22,8 +22,8 @@ struct token	{
 };
 
 #define TOK_IDF	tk_data.tk_idf
-#define TOK_STR	tk_data.tk_str.s_str
+#define TOK_STR	tk_data.tk_str->s_str
-#define TOK_SLE tk_data.tk_str.s_length
+#define TOK_SLE tk_data.tk_str->s_length
 #define TOK_INT	tk_data.tk_int
 #define TOK_REL	tk_data.tk_real
 

lang/m2/comp/Makefile

@@ -82,12 +82,12 @@ LLlex.o: LLlex.h Lpars.h class.h const.h f_info.h idf.h idfsize.h input.h inputt
 LLmessage.o: LLlex.h Lpars.h idf.h
 char.o: class.h
 error.o: LLlex.h debug.h errout.h f_info.h input.h inputtype.h main.h node.h
-main.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.h inputtype.h scope.h standards.h tokenname.h type.h
+main.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.h inputtype.h node.h scope.h standards.h tokenname.h type.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
-type.o: LLlex.h const.h debug.h def.h idf.h node.h target_sizes.h type.h
+type.o: LLlex.h const.h debug.h def.h idf.h maxset.h node.h target_sizes.h type.h
 def.o: LLlex.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
@@ -98,10 +98,10 @@ node.o: LLlex.h debug.h def.h node.h type.h
 cstoper.o: LLlex.h Lpars.h idf.h node.h standards.h target_sizes.h type.h
 chk_expr.o: LLlex.h Lpars.h const.h debug.h def.h idf.h node.h scope.h standards.h type.h
 options.o: idfsize.h type.h
-walk.o: debug.h def.h main.h scope.h type.h
+walk.o: LLlex.h Lpars.h debug.h def.h main.h node.h scope.h type.h
 tokenfile.o: Lpars.h
 program.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.h type.h
 declar.o: LLlex.h Lpars.h def.h idf.h main.h misc.h node.h scope.h type.h
 expression.o: LLlex.h Lpars.h const.h debug.h def.h idf.h node.h scope.h type.h
-statement.o: LLlex.h Lpars.h node.h type.h
+statement.o: LLlex.h Lpars.h def.h idf.h node.h scope.h type.h
 Lpars.o: Lpars.h

lang/m2/comp/Parameters

@@ -58,3 +58,9 @@ extern char options[];
 #undef INP_READ_IN_ONE	1	/* read input file in one	*/
 
 
+!File: maxset.h
+#define MAXSET	1024		/* maximum number of elements in a set,
+				   but what is a reasonable choice ???
+				*/
+
+

lang/m2/comp/chk_expr.c

@@ -63,6 +63,7 @@ chk_expr(expp)
 
 	case Link:
 		return chk_name(expp);
+
 	default:
 		assert(0);
 	}
@@ -85,32 +86,42 @@ chk_set(expp)
 
 	/* First determine the type of the set
 	*/
-	if (expp->nd_left) {
+	if (nd = expp->nd_left) {
 		/* A type was given. Check it out
 		*/
-		findname(expp->nd_left);
+		findname(nd);
-		assert(expp->nd_left->nd_class == Def);
+		assert(nd->nd_class == Def);
-		df = expp->nd_left->nd_def;
+		df = nd->nd_def;
+
 		if (!(df->df_kind & (D_TYPE|D_ERROR)) ||
 		    (df->df_type->tp_fund != T_SET)) {
-			node_error(expp, "illegal set type");
+			node_error(expp, "specifier does not represent a set type");
 			return 0;
 		}
 		tp = df->df_type;
+		FreeNode(expp->nd_left);
+		expp->nd_left = 0;
 	}
 	else	tp = bitset_type;
 
 	/* Now check the elements given, and try to compute a constant set.
+	   First allocate room for the set
 	*/
 	set = (arith *)
 		Malloc((unsigned) (tp->tp_size * sizeof(arith) / word_size));
+
+	/* Now check the elements, one by one
+	*/
 	nd = expp->nd_right;
 	while (nd) {
 		assert(nd->nd_class == Link && nd->nd_symb == ',');
+
 		if (!chk_el(nd->nd_left, tp->next, &set)) return 0;
 		nd = nd->nd_right;
 	}
+
 	expp->nd_type = tp;
+
 	if (set) {
 		/* Yes, it was a constant set, and we managed to compute it!
 		   Notice that at the moment there is no such thing as
@@ -119,10 +130,10 @@ chk_set(expp)
 		*/
 		expp->nd_class = Set;
 		expp->nd_set = set;
-		FreeNode(expp->nd_left);
 		FreeNode(expp->nd_right);
-		expp->nd_left = expp->nd_right = 0;
+		expp->nd_right = 0;
 	}
+
 	return 1;
 }
 
@@ -137,35 +148,38 @@ chk_el(expp, tp, set)
 		Also try to compute the set!
 	*/
 	register int i;
+	register struct node *left = expp->nd_left;
+	register struct node *right = expp->nd_right;
 
 	if (expp->nd_class == Link && expp->nd_symb == UPTO) {
 		/* { ... , expr1 .. expr2,  ... }
 		   First check expr1 and expr2, and try to compute them.
 		*/
-		if (!chk_el(expp->nd_left, tp, set) ||
+		if (!chk_el(left, tp, set) || !chk_el(right, tp, set)) {
-		    !chk_el(expp->nd_right, tp, set)) {
 			return 0;
 		}
-		if (expp->nd_left->nd_class == Value &&
+
-		    expp->nd_right->nd_class == Value) {
+		if (left->nd_class == Value && right->nd_class == Value) {
 			/* We have a constant range. Put all elements in the
 			   set
 			*/
 
-		    	if (expp->nd_left->nd_INT > expp->nd_right->nd_INT) {
+		    	if (left->nd_INT > right->nd_INT) {
 node_error(expp, "lower bound exceeds upper bound in range");
 				return rem_set(set);
 			}
 
-			if (*set) for (i = expp->nd_left->nd_INT + 1;
+			if (*set) {
-				     i < expp->nd_right->nd_INT; i++) {
+				for (i=left->nd_INT+1; i<right->nd_INT; i++) {
 					(*set)[i/wrd_bits] |= (1<<(i%wrd_bits));
 				}
 			}
+		}
 		else if (*set) {
 			free((char *) *set);
 			*set = 0;
 		}
+
 		return 1;
 	}
 
@@ -174,12 +188,17 @@ node_error(expp, "lower bound exceeds upper bound in range");
 	if (!chk_expr(expp)) {
 		return rem_set(set);
 	}
+
 	if (!TstCompat(tp, expp->nd_type)) {
 		node_error(expp, "set element has incompatible type");
 		return rem_set(set);
 	}
+
 	if (expp->nd_class == Value) {
+		/* a constant element
+		*/
 		i = expp->nd_INT;
+
 	    	if ((tp->tp_fund != T_ENUMERATION &&
 		     (i < tp->sub_lb || i > tp->sub_ub))
 		   ||
@@ -189,8 +208,10 @@ node_error(expp, "lower bound exceeds upper bound in range");
 			node_error(expp, "set element out of range");
 			return rem_set(set);
 		}
+
 		if (*set) (*set)[i/wrd_bits] |= (1 << (i%wrd_bits));
 	}
+
 	return 1;
 }
 
@@ -552,7 +573,7 @@ findname(expp)
 			expp->nd_type = df->df_type;
 			if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
 node_error(expp->nd_right,
-"identifier \"%s\" not exprted from qualifying module",
+"identifier \"%s\" not exported from qualifying module",
 df->df_idf->id_text);
 			}
 		}
@@ -723,6 +744,7 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
 
 	case OR:
 	case AND:
+	case '&':
 		if (tpl == bool_type) {
 			if (expp->nd_left->nd_class == Value &&
 			    expp->nd_right->nd_class == Value) {
@@ -735,10 +757,12 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
 
 	case '=':
 	case '#':
+	case UNEQUAL:
 	case GREATEREQUAL:
 	case LESSEQUAL:
 	case '<':
 	case '>':
+		expp->nd_type = bool_type;
 		switch(tpl->tp_fund) {
 		case T_SET:
 			if (expp->nd_symb == '<' || expp->nd_symb == '>') {
@@ -762,10 +786,10 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
 			return 1;
 
 		case T_POINTER:
-			if (!(expp->nd_symb == '=' || expp->nd_symb == '#')) {
+			if (expp->nd_symb == '=' ||
+			    expp->nd_symb == UNEQUAL ||
+			    expp->nd_symb == '#') return 1;
 			break;
-			}
-			/* Fall through */
 
 		case T_REAL:
 			return 1;
@@ -832,6 +856,7 @@ chk_uoper(expp)
 		break;
 
 	case NOT:
+	case '~':
 		if (tpr == bool_type) {
 			if (expp->nd_right->nd_class == Value) {
 				cstunary(expp);

lang/m2/comp/cstoper.c

@@ -38,6 +38,7 @@ cstunary(expp)
 		o1 = -o1;
 		break;
 	case NOT:
+	case '~':
 		o1 = !o1;
 		break;
 	default:
@@ -184,9 +185,11 @@ cstbin(expp)
 		o1 = o1 == o2;
 		break;
 	case '#':
+	case UNEQUAL:
 		o1 = o1 != o2;
 		break;
 	case AND:
+	case '&':
 		o1 = o1 && o2;
 		break;
 	case OR:
@@ -252,6 +255,7 @@ cstset(expp)
 		case LESSEQUAL:
 		case '=':
 		case '#':
+		case UNEQUAL:
 			/* Clumsy, but who cares? Nobody writes these things! */
 			for (j = 0; j < setsize; j++) {
 				switch(expp->nd_symb) {
@@ -265,13 +269,14 @@ cstset(expp)
 					continue;
 				case '=':
 				case '#':
+				case UNEQUAL:
 					if (*set1++ != *set2++) break;
 					continue;
 				}
-				expp->nd_INT = expp->nd_symb == '#';
+				expp->nd_INT = expp->nd_symb != '=';
 				break;
 			}
-			if (j == setsize) expp->nd_INT = expp->nd_symb != '#';
+			if (j == setsize) expp->nd_INT = expp->nd_symb == '=';
 			expp->nd_class = Value;
 			free((char *) expp->nd_left->nd_set);
 			free((char *) expp->nd_right->nd_set);

lang/m2/comp/declar.g

@@ -7,6 +7,7 @@ static char *RcsId = "$Header$";
 #include	<em_label.h>
 #include	<alloc.h>
 #include	<assert.h>
+
 #include	"idf.h"
 #include	"LLlex.h"
 #include	"def.h"
@@ -18,23 +19,26 @@ static char *RcsId = "$Header$";
 
 int		proclevel = 0;	/* nesting level of procedures */
 extern char	*sprint();
+extern struct def *currentdef;
 }
 
 ProcedureDeclaration
 {
 	struct def *df;
+	struct def *savecurr = currentdef;
 } :
 	ProcedureHeading(&df, D_PROCEDURE)
 			{
 			  df->prc_level = proclevel++;
-
+			  currentdef = df;
 			}
 	';' block(&(df->prc_body)) IDENT
 			{
 			  match_id(dot.TOK_IDF, df->df_idf);
 			  df->prc_scope = CurrentScope;
-			  close_scope(SC_CHKFORW);
+			  close_scope(SC_CHKFORW|SC_REVERSE);
 			  proclevel--;
+			  currentdef = savecurr;
 			}
 ;
 
@@ -53,9 +57,15 @@ ProcedureHeading(struct def **pdf; int type;)
 		{
 		  tp = construct_type(T_PROCEDURE, tp);
 		  tp->prc_params = params;
-		  if (df->df_type && !TstTypeEquiv(tp, df->df_type)) {
+		  if (df->df_type) {
+			/* We already saw a definition of this type
+			   in the definition module.
+			*/
+		  	if (!TstTypeEquiv(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;
 		}
@@ -164,7 +174,8 @@ TypeDeclaration
 }:
 	IDENT		{ df = define(dot.TOK_IDF, CurrentScope, D_TYPE); }
 	'=' type(&tp)
-			{ df->df_type = tp;
+			{ if (df->df_type) free_type(df->df_type);
+			  df->df_type = tp;
 			  if ((df->df_flags&D_EXPORTED) &&
 			      tp->tp_fund == T_ENUMERATION) {
 				exprt_literals(tp->enm_enums,
@@ -327,7 +338,8 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
 [
 	IdentList(&FldList) ':' type(&tp)
 			{ *palign = lcm(*palign, tp->tp_align);
-			  EnterIdList(FldList, D_FIELD, 0, tp, scope, cnt);
+			  EnterIdList(FldList, D_FIELD, D_QEXPORTED,
+					tp, scope, cnt);
 			  FreeNode(FldList);
 			}
 |
@@ -373,6 +385,7 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
 				  df->df_type = tp;
 				  df->fld_off = align(*cnt, tp->tp_align);
 				  *cnt = tcnt = df->fld_off + tp->tp_size;
+				  df->df_flags |= D_QEXPORTED;
 				}
 	OF variant(scope, &tcnt, tp, palign)
 				{ max = tcnt; tcnt = *cnt; }

lang/m2/comp/def.H

@@ -53,14 +53,12 @@ struct field {
 struct dfproc {
 	struct scope *pr_scope;	/* scope of procedure */
 	short pr_level;		/* depth level of this procedure */
-	char *pr_name;		/* name of this procedure */
 	arith pr_nbpar;		/* number of bytes parameters */
 	struct node *pr_body;	/* body of this procedure */
 #define prc_scope	df_value.df_proc.pr_scope
 #define prc_level	df_value.df_proc.pr_level
 #define prc_nbpar	df_value.df_proc.pr_nbpar
 #define prc_body	df_value.df_proc.pr_body
-#define prc_name	df_value.df_proc.pr_name
 };
 
 struct import {

lang/m2/comp/def.c

@@ -73,16 +73,6 @@ define(id, scope, kind)
 		  (df = lookup(id, PervasiveScope)))
 	   ) {
 		switch(df->df_kind) {
-		case D_PROCHEAD:
-			if (kind == D_PROCEDURE) {
-				/* Definition of which the heading was
-				   already seen in a definition module
-				*/
-				df->df_kind = kind;
-				df->prc_name = df->for_name;
-				return df;
-			}
-			break;	
 		case D_HIDDEN:
 			if (kind == D_TYPE && !DefinitionModule) {
 				df->df_kind = D_HTYPE;
@@ -192,6 +182,7 @@ df->df_idf->id_text);
 				   exported from a local module!
 				*/
 				df->df_kind = df1->df_kind;
+				df->df_value.df_forward = df1->df_value.df_forward;
 				df1->df_kind = D_IMPORT;
 			}
 			df1->imp_def = df;
@@ -423,7 +414,10 @@ DeclProc(type)
 			/* C_exp already generated when we saw the definition
 			   in the definition module
 			*/
-			df->df_kind = type;
+			df->df_kind = D_PROCEDURE;
+			open_scope(OPENSCOPE);
+			CurrentScope->sc_name = df->for_name;
+			df->prc_scope = CurrentScope;
 		}
 		else {
 			df = define(dot.TOK_IDF, CurrentScope, type);
@@ -433,12 +427,13 @@ DeclProc(type)
 			}
 			else	(sprint(buf, "%s_%s",df->df_scope->sc_name,
 						df->df_idf->id_text));
-			df->prc_name = Malloc((unsigned)(strlen(buf)+1));
+			open_scope(OPENSCOPE);
-			strcpy(df->prc_name, buf);
+			df->prc_scope = CurrentScope;
+			CurrentScope->sc_name = Malloc((unsigned)(strlen(buf)+1));
+			strcpy(CurrentScope->sc_name, buf);
 			C_inp(buf);
 		}
 		df->prc_nbpar = 0;
-		open_scope(OPENSCOPE);
 	}
 
 	return df;

lang/m2/comp/enter.c

@@ -72,6 +72,7 @@ EnterIdList(idlist, kind, flags, type, scope, addr)
 			}
 			else {
 				assert(kind == D_FIELD);
+
 				df->fld_off = off;
 			}
 		}
@@ -107,6 +108,7 @@ EnterVarList(IdList, type, local)
 	extern char *sprint(), *Malloc(), *strcpy();
 
 	scope = CurrentScope;
+
 	if (local) {
 		/* Find the closest enclosing open scope. This
 		   is the procedure that we are dealing with
@@ -127,22 +129,26 @@ node_error(IdList->nd_left,"Illegal type for address");
 			df->var_off = IdList->nd_left->nd_INT;
 		}
 		else if (local) {
-			arith off;
+			/* subtract aligned size of variable to the offset,
-
+			   as the variable list exists only local to a
-			/* add aligned size of variable to the offset
+			   procedure
 			*/
-			off = scope->sc_off - type->tp_size;
+			scope->sc_off = -align(type->tp_size - scope->sc_off,
-			off = -align(-off, type->tp_align);
+						type->tp_align);
-			df->var_off = off;
+			df->var_off = scope->sc_off;
-			scope->sc_off = off;
 		}
 		else if (!DefinitionModule &&
 			 CurrentScope != Defined->mod_scope) {	
+			/* variable list belongs to an internal global
+			   module. Align offset and add size
+			*/
 			scope->sc_off = align(scope->sc_off, type->tp_align);
 			df->var_off = scope->sc_off;
 			scope->sc_off += type->tp_size;
 		}
 		else {
+			/* Global name, possibly external
+			*/
 			sprint(buf,"%s_%s", df->df_scope->sc_name,
 					    df->df_idf->id_text);
 			df->var_name = Malloc((unsigned)(strlen(buf)+1));

lang/m2/comp/expression.g

@@ -268,5 +268,5 @@ visible_designator_tail(struct node **pnd;):
 		]*
 	']'
 |
-	'^'		{ *pnd = MkNode(Oper, NULLNODE, *pnd, &dot); }
+	'^'		{ *pnd = MkNode(Uoper, NULLNODE, *pnd, &dot); }
 ;

lang/m2/comp/main.c

@@ -16,6 +16,7 @@ static char *RcsId = "$Header$";
 #include	"scope.h"
 #include	"standards.h"
 #include	"tokenname.h"
+#include	"node.h"
 
 #include	"debug.h"
 
@@ -135,6 +136,7 @@ add_standards()
 {
 	register struct def *df;
 	struct def *Enter();
+	static struct node nilnode = { 0, 0, Value, 0, { INTEGER, 0, 0}};
 
 	(void) Enter("ABS", D_PROCEDURE, std_type, S_ABS);
 	(void) Enter("CAP", D_PROCEDURE, std_type, S_CAP);
@@ -161,7 +163,11 @@ add_standards()
 	(void) Enter("LONGREAL", D_TYPE, longreal_type, 0);
 	(void) Enter("BOOLEAN", D_TYPE, bool_type, 0);
 	(void) Enter("CARDINAL", D_TYPE, card_type, 0);
-	(void) Enter("NIL", D_CONST, address_type, 0);
+	df = Enter("NIL", D_CONST, address_type, 0);
+	df->con_const = &nilnode;
+	nilnode.nd_INT = 0;
+	nilnode.nd_type = address_type;
+
 	(void) Enter("PROC",
 		     D_TYPE,
 		     construct_type(T_PROCEDURE, NULLTYPE),

lang/m2/comp/program.g

@@ -22,6 +22,7 @@ static int DEFofIMPL = 0;	/* Flag indicating that we are currently
 				   implementation module currently being
 				   compiled
 				*/
+struct def *currentdef;		/* current definition of module or procedure */
 }
 /*
 	The grammar as given by Wirth is already almost LL(1); the
@@ -46,6 +47,7 @@ ModuleDeclaration
 {
 	struct idf *id;
 	register struct def *df;
+	struct def *savecurr = currentdef;
 	extern int proclevel;
 	static int modulecount = 0;
 	char buf[256];
@@ -54,11 +56,14 @@ ModuleDeclaration
 	MODULE IDENT	{
 			  id = dot.TOK_IDF;
 			  df = define(id, CurrentScope, D_MODULE);
+			  currentdef = df;
+
 			  if (!df->mod_scope) {	
 			  	open_scope(CLOSEDSCOPE);
 			  	df->mod_scope = CurrentScope;
 			  }
 			  else	CurrentScope = df->mod_scope;
+
 			  df->df_type = standard_type(T_RECORD, 0, (arith) 0);
 			  df->df_type->rec_scope = df->mod_scope;
 			  df->mod_number = ++modulecount;
@@ -74,8 +79,9 @@ ModuleDeclaration
 	import(1)*
 	export(0)?
 	block(&(df->mod_body))
-	IDENT		{ close_scope(SC_CHKFORW|SC_CHKPROC);
+	IDENT		{ close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
 			  match_id(id, dot.TOK_IDF);
+			  currentdef = savecurr;
 			}
 ;
 
@@ -198,6 +204,7 @@ definition
 	       It is restricted to pointer types.
 	    */
 	    		{ df->df_kind = D_HIDDEN;
+			  df->df_type = construct_type(T_POINTER, NULLTYPE);
 			}
 	  ]
 	  Semicolon
@@ -226,6 +233,7 @@ ProgramModule(int state;)
 		  if (state == IMPLEMENTATION) {
 			DEFofIMPL = 1;
 			df = GetDefinitionModule(id);
+			currentdef = df;
 			CurrentScope = df->mod_scope;
 			DEFofIMPL = 0;
 		  }
@@ -240,7 +248,7 @@ ProgramModule(int state;)
 	priority(&(df->mod_priority))?
 	';' import(0)*
 	block(&(df->mod_body)) IDENT
-		{ close_scope(SC_CHKFORW|SC_CHKPROC);
+		{ close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
 		  match_id(id, dot.TOK_IDF);
 		}
 	'.'

lang/m2/comp/scope.C

@@ -6,12 +6,14 @@ static char *RcsId = "$Header$";
 #include	<alloc.h>
 #include	<em_arith.h>
 #include	<em_label.h>
+
 #include	"LLlex.h"
 #include	"idf.h"
 #include	"scope.h"
 #include	"type.h"
 #include	"def.h"
 #include	"node.h"
+
 #include	"debug.h"
 
 struct scope *CurrentScope, *PervasiveScope, *GlobalScope;
@@ -212,7 +214,7 @@ close_scope(flag)
 		DO_DEBUG(2, PrScopeDef(sc->sc_def));
 		if (flag & SC_CHKPROC) chk_proc(sc->sc_def);
 		if (flag & SC_CHKFORW) chk_forw(&(sc->sc_def));
-		Reverse(&(sc->sc_def));
+		if (flag & SC_REVERSE) Reverse(&(sc->sc_def));
 	}
 	CurrentScope = sc->next;
 	scp_level = CurrentScope->sc_level;

lang/m2/comp/scope.h

@@ -11,6 +11,9 @@
 #define SC_CHKPROC	2	/* Check for forward procedure definitions
 				   when closing a scope
 				*/
+#define SC_REVERSE	4	/* Reverse list of definitions, to get it
+				   back into original order
+				*/
 
 struct scope {
 	struct scope *next;

lang/m2/comp/statement.g

@@ -5,11 +5,15 @@ static char *RcsId = "$Header$";
 
 #include	<em_arith.h>
 #include	<em_label.h>
+#include	"idf.h"
 #include	"LLlex.h"
+#include	"scope.h"
+#include	"def.h"
 #include	"type.h"
 #include	"node.h"
 
 static int	loopcount = 0;	/* Count nested loops */
+extern struct def *currentdef;
 }
 
 statement(struct node **pnd;)
@@ -63,6 +67,13 @@ statement(struct node **pnd;)
 	RETURN		{ *pnd = nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
 	[
 		expression(&(nd->nd_right))
+			{ if (scopeclosed(CurrentScope)) {
+error("a module body has no result value");
+			  }
+			  else if (! currentdef->df_type->next) {
+error("procedure \"%s\" has no result value", currentdef->df_idf->id_text);
+			  }
+			}
 	]?
 ]?
 ;

lang/m2/comp/type.c

@@ -9,6 +9,7 @@ static char *RcsId = "$Header$";
 
 #include	"target_sizes.h"
 #include	"debug.h"
+#include	"maxset.h"
 
 #include	"def.h"
 #include	"type.h"
@@ -131,28 +132,61 @@ standard_type(fund, align, size)
 
 init_types()
 {
+	/*	Initialize the predefined types
+	*/
 	register struct type *tp;
 
+	/* character type
+	*/
 	char_type = standard_type(T_CHAR, 1, (arith) 1);
 	char_type->enm_ncst = 256;
+	
+	/* character constant, different from char because of compatibility
+	   with ARRAY OF CHAR
+	*/
 	charc_type = standard_type(T_CHAR, 1, (arith) 1);
 	charc_type->enm_ncst = 256;
+
+	/* boolean type
+	*/
 	bool_type = standard_type(T_ENUMERATION, 1, (arith) 1);
 	bool_type->enm_ncst = 2;
+
+	/* integer types, also a "intorcard", for integer constants between
+	   0 and MAX(INTEGER)
+	*/
 	int_type = standard_type(T_INTEGER, int_align, int_size);
 	longint_type = standard_type(T_INTEGER, long_align, long_size);
 	card_type = standard_type(T_CARDINAL, int_align, int_size);
+	intorcard_type = standard_type(T_INTORCARD, int_align, int_size);
+
+	/* floating types
+	*/
 	real_type = standard_type(T_REAL, float_align, float_size);
 	longreal_type = standard_type(T_REAL, double_align, double_size);
-	word_type = standard_type(T_WORD, word_align, word_size);
+
-	intorcard_type = standard_type(T_INTORCARD, int_align, int_size);
+	/* string constant type
+	*/
 	string_type = standard_type(T_STRING, 1, (arith) -1);
+
+	/* SYSTEM types
+	*/
+	word_type = standard_type(T_WORD, word_align, word_size);
 	address_type = construct_type(T_POINTER, word_type);
+
+	/* create BITSET type
+	*/
 	tp = construct_type(T_SUBRANGE, int_type);
 	tp->sub_lb = 0;
 	tp->sub_ub = word_size * 8 - 1;
 	bitset_type = set_type(tp);
+
+	/* a unique type for standard procedures and functions
+	*/
 	std_type = construct_type(T_PROCEDURE, NULLTYPE);
+
+	/* a unique type indicating an error
+	*/
 	error_type = standard_type(T_CHAR, 1, (arith) 1);
 }
 
@@ -183,11 +217,12 @@ ParamList(ids, tp, VARp)
 	return pstart;
 }
 
-/*	A subrange had a specified base. Check that the bases conform ...
-*/
 chk_basesubrange(tp, base)
 	register struct type *tp, *base;
 {
+	/*	A subrange had a specified base. Check that the bases conform.
+	*/
+
 	if (base->tp_fund == T_SUBRANGE) {
 		/* Check that the bounds of "tp" fall within the range
 		   of "base"
@@ -197,6 +232,7 @@ chk_basesubrange(tp, base)
 		}
 		base = base->next;
 	}
+
 	if (base->tp_fund == T_ENUMERATION || base->tp_fund == T_CHAR) {
 		if (tp->next != base) {
 			error("Specified base does not conform");
@@ -212,6 +248,7 @@ chk_basesubrange(tp, base)
 	else if (base != tp->next && base != int_type) {
 		error("Specified base does not conform");
 	}
+
 	tp->next = base;
 	tp->tp_size = base->tp_size;
 	tp->tp_align = base->tp_align;
@@ -233,14 +270,18 @@ subr_type(lb, ub)
 	}
 
 	if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
-	if (tp == intorcard_type) tp = card_type;	/* lower bound > 0 */
+
+	if (tp == intorcard_type) {
+		/* Lower bound >= 0; in this case, the base type is CARDINAL,
+		   according to the language definition, par. 6.3
+		*/
+		assert(lb->nd_INT >= 0);
+		tp = card_type;
+	}
 
 	/* Check base type
 	*/
-	if (tp != int_type && tp != card_type && tp != char_type &&
+	if (! (tp->tp_fund & T_DISCRETE)) {
-	    tp->tp_fund != T_ENUMERATION) {
-		/* BOOLEAN is also an ENUMERATION type
-		*/
 		node_error(ub, "Illegal base type for subrange");
 		return error_type;
 	}
@@ -258,10 +299,8 @@ subr_type(lb, ub)
 	res->sub_ub = ub->nd_INT;
 	res->tp_size = tp->tp_size;
 	res->tp_align = tp->tp_align;
-	DO_DEBUG(2,debug("Creating subrange type %ld-%ld", (long)lb->nd_INT,(long)ub->nd_INT));
 	return res;
 }
-#define MAX_SET	1024	/* ??? Maximum number of elements in a set */
 
 struct type *
 set_type(tp)
@@ -273,14 +312,14 @@ set_type(tp)
 	arith lb, ub;
 
 	if (tp->tp_fund == T_SUBRANGE) {
-		if ((lb = tp->sub_lb) < 0 || (ub = tp->sub_ub) > MAX_SET - 1) {
+		if ((lb = tp->sub_lb) < 0 || (ub = tp->sub_ub) > MAXSET - 1) {
 			error("Set type limits exceeded");
 			return error_type;
 		}
 	}
 	else if (tp->tp_fund == T_ENUMERATION || tp == char_type) {
 		lb = 0;
-		if ((ub = tp->enm_ncst - 1) > MAX_SET - 1) {
+		if ((ub = tp->enm_ncst - 1) > MAXSET - 1) {
 			error("Set type limits exceeded");
 			return error_type;
 		}
@@ -289,6 +328,7 @@ set_type(tp)
 		error("illegal base type for set");
 		return error_type;
 	}
+
 	tp = construct_type(T_SET, tp);
 	tp->tp_size = align(((ub - lb) + 7)/8, word_align);
 	return tp;
@@ -297,40 +337,68 @@ set_type(tp)
 ArraySizes(tp)
 	register struct type *tp;
 {
-	/*	Assign sizes to an array type
+	/*	Assign sizes to an array type, and check index type
 	*/
 	arith elem_size;
-	register struct type *itype = tp->next;	/* the index type */
+	register struct type *index_type = tp->next;
+	register struct type *elem_type = tp->arr_elem;
 
-	if (tp->arr_elem->tp_fund == T_ARRAY) {
+	if (elem_type->tp_fund == T_ARRAY) {
-		ArraySizes(tp->arr_elem);
+		ArraySizes(elem_type);
 	}
 
-	elem_size = align(tp->arr_elem->tp_size, tp->arr_elem->tp_align);
+	/* align element size to alignment requirement of element type
-	tp->tp_align = tp->arr_elem->tp_align;
+	*/
+	elem_size = align(elem_type->tp_size, elem_type->tp_align);
+	tp->tp_align = elem_type->tp_align;
 
-	if (! (itype->tp_fund & T_INDEX)) {
+	/* check index type
+	*/
+	if (! (index_type->tp_fund & T_INDEX)) {
 		error("Illegal index type");
 		tp->tp_size = 0;
 		return;
 	}
 
-	switch(itype->tp_fund) {
+	/* find out HIGH, LOW and size of ARRAY
+	*/
+	switch(index_type->tp_fund) {
 	case T_SUBRANGE:
-		tp->arr_lb = itype->sub_lb;
+		tp->arr_lb = index_type->sub_lb;
-		tp->arr_ub = itype->sub_ub;
+		tp->arr_ub = index_type->sub_ub;
-		tp->tp_size = elem_size * (itype->sub_ub - itype->sub_lb + 1);
+		tp->tp_size = elem_size *
+			(index_type->sub_ub - index_type->sub_lb + 1);
 		break;
 	case T_CHAR:
 	case T_ENUMERATION:
 		tp->arr_lb = 0;
-		tp->arr_ub = itype->enm_ncst - 1;
+		tp->arr_ub = index_type->enm_ncst - 1;
-		tp->tp_size = elem_size * itype->enm_ncst;
+		tp->tp_size = elem_size * index_type->enm_ncst;
 		break;
 	default:
 		assert(0);
 	}
-	/* ??? overflow checking ??? */
+	/* ??? overflow checking ???
+	*/
+}
+
+FreeType(tp)
+	struct type *tp;
+{
+	/*	Release type structures indicated by "tp"
+	*/
+	register struct paramlist *pr, *pr1;
+
+	assert(tp->tp_fund == T_PROCEDURE);
+
+	pr = tp->prc_params;
+	while (pr) {
+		pr1 = pr;
+		pr = pr->next;
+		free_paramlist(pr1);
+	}
+
+	free_type(tp);
 }
 
 int

lang/m2/comp/typequiv.c

@@ -12,21 +12,31 @@ static char *RcsId = "$Header$";
 
 int
 TstTypeEquiv(tp1, tp2)
-	register struct type *tp1, *tp2;
+	struct type *tp1, *tp2;
 {
-	/*	test if two types are equivalent. A complication comes
+	/*	test if two types are equivalent.
-		from the fact that for some procedures two declarations may
-		be given: one in the specification module and one in the
-		definition module.
-		A related problem is that two dynamic arrays with
-		equivalent base types are also equivalent.
 	*/
 
 	return     tp1 == tp2
 		||
 		   tp1 == error_type
 		||
-		   tp2 == error_type
+		   tp2 == error_type;
+}
+
+int
+TstParEquiv(tp1, tp2)
+	register struct type *tp1, *tp2;
+{
+	/*	test if two parameter types are equivalent. This routine
+		is used to check if two different procedure declarations
+		(one in the definition module, one in the implementation
+		module) are equivalent. A complication comes from dynamic
+		arrays.
+	*/
+	
+	return
+		   TstTypeEquiv(tp1, tp2)
 		||
 		   (
 		     tp1->tp_fund == T_ARRAY
@@ -38,16 +48,7 @@ TstTypeEquiv(tp1, tp2)
 		     tp2->next == 0
 		   &&
 		     TstTypeEquiv(tp1->arr_elem, tp2->arr_elem)
-		   )
-		||
-		   ( 
-		     tp1 && tp1->tp_fund == T_PROCEDURE
-		   &&
-		     tp2 && tp2->tp_fund == T_PROCEDURE
-		   &&
-		     TstProcEquiv(tp1, tp2)
 		   );
-
 }
 
 int
@@ -61,14 +62,17 @@ TstProcEquiv(tp1, tp2)
 	register struct paramlist *p1, *p2;
 
 	if (!TstTypeEquiv(tp1->next, tp2->next)) return 0;
+
 	p1 = tp1->prc_params;
 	p2 = tp2->prc_params;
+
 	while (p1 && p2) {
 		if (p1->par_var != p2->par_var ||
-		    !TstTypeEquiv(p1->par_type, p2->par_type)) return 0;
+		    !TstParEquiv(p1->par_type, p2->par_type)) return 0;
 		p1 = p1->next;
 		p2 = p2->next;
 	}
+
 	return p1 == p2;
 }
 
@@ -79,9 +83,12 @@ TstCompat(tp1, tp2)
 	/*	test if two types are compatible. See section 6.3 of the
 		Modula-2 Report for a definition of "compatible".
 	*/
+
 	if (TstTypeEquiv(tp1, tp2)) return 1;
+
 	if (tp1->tp_fund == T_SUBRANGE) tp1 = tp1->next;
 	if (tp2->tp_fund == T_SUBRANGE) tp2 = tp2->next;
+
 	return	tp1 == tp2
 	    ||
 		(  tp1 == intorcard_type
@@ -117,12 +124,15 @@ int TstAssCompat(tp1, tp2)
 {
 	/*	Test if two types are assignment compatible.
 	*/
+
 	if (TstCompat(tp1, tp2)) return 1;
 
 	if (tp1->tp_fund == T_SUBRANGE) tp1 = tp1->next;
 	if (tp2->tp_fund == T_SUBRANGE) tp2 = tp2->next;
-	if ((tp1->tp_fund & (T_INTEGER|T_CARDINAL)) &&
+
-	    (tp2->tp_fund & (T_INTEGER|T_CARDINAL))) return 1;
+	if ((tp1->tp_fund & T_INTORCARD) &&
+	    (tp2->tp_fund & T_INTORCARD)) return 1;
+
 	if (tp1 == char_type && tp2 == charc_type) return 1;
 	if (tp1->tp_fund == T_ARRAY && 
 	    (tp2 == charc_type || tp2 == string_type)) {
@@ -133,5 +143,6 @@ int TstAssCompat(tp1, tp2)
 		if (tp1->tp_fund == T_SUBRANGE) tp1 = tp1->next;
 		return tp1 == char_type;
 	}
+
 	return 0;
 }

lang/m2/comp/walk.c

@@ -16,11 +16,14 @@ static char *RcsId = "$Header$";
 #include	"main.h"
 #include	"LLlex.h"
 #include	"node.h"
+#include	"Lpars.h"
 
 #include	"debug.h"
 
 extern arith	align();
 static int	prclev = 0;
+static label	instructionlabel = 0;
+static label	datalabel = 0;
 
 WalkModule(module)
 	register struct def *module;
@@ -33,10 +36,12 @@ WalkModule(module)
 
 	scope = CurrentScope;
 	CurrentScope = module->mod_scope;
+
 	if (!prclev && module->mod_number) {
 		/* This module is a local module, but not within a
 		   procedure. Generate code to allocate storage for its
-		   variables
+		   variables. This is done by generating a "bss",
+		   with label "_<modulenumber><modulename>".
 		*/
 		arith size = align(CurrentScope->sc_off, word_size);
 
@@ -69,7 +74,7 @@ WalkModule(module)
 	CurrentScope->sc_off = 0;
 	C_pro_narg(CurrentScope->sc_name);
 	MkCalls(CurrentScope->sc_def);
-	WalkNode(module->mod_body);
+	WalkNode(module->mod_body, (label) 0);
 	C_end(align(-CurrentScope->sc_off, word_size));
 
 	CurrentScope = scope;
@@ -91,12 +96,13 @@ WalkProcedure(procedure)
 
 	/* Generate code for this procedure
 	*/
-	C_pro_narg(procedure->prc_name);
+	C_pro_narg(CurrentScope->sc_name);
 	/* generate calls to initialization routines of modules defined within
 	   this procedure
 	*/
+	instructionlabel = 1;
 	MkCalls(CurrentScope->sc_def);
-	WalkNode(procedure->prc_body);
+	WalkNode(procedure->prc_body, (label) 0);
 	C_end(align(-CurrentScope->sc_off, word_size));
 	CurrentScope = scope;
 	prclev--;
@@ -126,17 +132,151 @@ MkCalls(df)
 	while (df) {
 		if (df->df_kind == D_MODULE) {
 			C_lxl((arith) 0);
-			C_cal(df->df_scope->sc_name);
+			C_cal(df->mod_scope->sc_name);
 		}
 		df = df->df_nextinscope;
 	}
 }
 
-WalkNode(nd)
+WalkNode(nd, lab)
-	struct node *nd;
+	register struct node *nd;
+	label lab;
 {
 	/*	Node "nd" represents either a statement or a statement list.
-		Generate code for it.
+		Walk through it.
+		"lab" represents the label that must be jumped to on
+		encountering an EXIT statement.
+	*/
+	
+	while (nd->nd_class == Link) {	 /* statement list */
+		WalkStat(nd->nd_left, lab);
+		nd = nd->nd_right;
+	}
+
+	WalkStat(nd, lab);
+}
+
+WalkStat(nd, lab)
+	register struct node *nd;
+	label lab;
+{
+	/*	Walk through a statement, generating code for it.
+		"lab" represents the label that must be jumped to on
+		encountering an EXIT statement.
+	*/
+	register struct node *left = nd->nd_left;
+	register struct node *right = nd->nd_right;
+
+	if (nd->nd_class == Call) {
+		/* ??? */
+		return;
+	}
+
+	assert(nd->nd_class == Stat);
+
+	switch(nd->nd_symb) {
+	case BECOMES:
+		/* ??? */
+		break;
+
+	case IF:
+		{	label l1, l2;
+
+			l1 = instructionlabel++;
+			l2 = instructionlabel++;
+			ExpectBool(left);
+			assert(right->nd_symb == THEN);
+			C_zeq(l1);
+			WalkNode(right->nd_left, lab);
+
+			if (right->nd_right) {	/* ELSE part */
+				C_bra(l2);
+				C_df_ilb(l1);
+				WalkNode(right->nd_right, lab);
+				C_df_ilb(l2);
+			}
+			else	C_df_ilb(l1);
+			break;
+		}
+
+	case CASE:
+		/* ??? */
+		break;
+
+	case WHILE:
+		{	label l1, l2;
+
+			l1 = instructionlabel++;
+			l2 = instructionlabel++;
+			C_df_ilb(l1);
+			ExpectBool(left);
+			C_zeq(l2);
+			WalkNode(right, lab);
+			C_bra(l1);
+			C_df_ilb(l2);
+			break;
+		}
+
+	case REPEAT:
+		{	label l1;
+
+			l1 = instructionlabel++;
+			C_df_ilb(l1);
+			WalkNode(left, lab);
+			ExpectBool(right);
+			C_zeq(l1);
+			break;
+		}
+
+	case LOOP:
+		{	label l1, l2;
+
+			l1 = instructionlabel++;
+			l2 = instructionlabel++;
+			C_df_ilb(l1);
+			WalkNode(left, l2);
+			C_bra(l1);
+			C_df_ilb(l2);
+			break;
+		}
+
+	case FOR:
+		/* ??? */
+		break;
+
+	case WITH:
+		/* ??? */
+		break;
+
+	case EXIT:
+		assert(lab != 0);
+
+		C_bra(lab);
+		break;
+
+	case RETURN:
+		/* ??? */
+		break;
+
+	default:
+		assert(0);
+	}
+}
+
+ExpectBool(nd)
+	struct node *nd;
+{
+	/*	"nd" must indicate a boolean expression. Check this and
+		generate code to evaluate the expression.
+	*/
+
+	chk_expr(nd);
+
+	if (nd->nd_type != bool_type) {
+		node_error(nd, "boolean expression expected");
+	}
+
+	/* generate code
 	*/
 	/* ??? */
 }