newer version

lang/m2/comp/LLlex.c

@@ -223,6 +223,7 @@ again:
 		register char *np = &buf[1];
 					/* allow a '-' to be added	*/
 
+		buf[0] = '-';
 		*np++ = ch;
 		
 		LoadChar(ch);

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
+	cstoper.o chk_expr.o
 OBJ =	$(COBJ) $(LOBJ) Lpars.o
 GENFILES=	tokenfile.c \
 	program.c declar.c expression.c statement.c \
@@ -39,6 +39,9 @@ main:	$(OBJ) Makefile
 clean:
 	rm -f $(OBJ) $(GENFILES) LLfiles 
 
+lint:	LLfiles lintlist
+	lint $(INCLUDES) `cat lintlist`
+
 tokenfile.g:	tokenname.c make.tokfile
 	make.tokfile <tokenname.c >tokenfile.g
 
@@ -74,23 +77,24 @@ LLlex.o: LLlex.h Lpars.h class.h f_info.h idf.h input.h
 LLmessage.o: LLlex.h Lpars.h idf.h
 char.o: class.h
 error.o: LLlex.h f_info.h input.h main.h node.h
-main.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.h main.h scope.h standards.h type.h
+main.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.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
 type.o: LLlex.h Lpars.h def.h def_sizes.h idf.h node.h type.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 main.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
+misc.o: LLlex.h f_info.h idf.h misc.h node.h
 enter.o: LLlex.h def.h idf.h node.h scope.h type.h
-defmodule.o: LLlex.h def.h f_info.h idf.h input.h scope.h
+defmodule.o: LLlex.h debug.h def.h f_info.h idf.h input.h scope.h
 typequiv.o: Lpars.h def.h type.h
-node.o: LLlex.h debug.h def.h main.h node.h type.h
+node.o: LLlex.h debug.h def.h node.h type.h
-cstoper.o: Lpars.h def_sizes.h idf.h node.h type.h
+cstoper.o: LLlex.h Lpars.h def_sizes.h idf.h node.h type.h
+chk_expr.o: LLlex.h Lpars.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 idf.h main.h node.h scope.h type.h
 declar.o: LLlex.h Lpars.h def.h idf.h misc.h node.h scope.h type.h
-expression.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.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
 Lpars.o: Lpars.h

lang/m2/comp/chk_expr.c

@@ -0,0 +1,379 @@
+/* E X P R E S S I O N   C H E C K I N G */
+
+static char *RcsId = "$Header$";
+
+/*	Check expressions, and try to evaluate them as far as possible.
+*/
+#include	<em_arith.h>
+#include	<em_label.h>
+#include	<assert.h>
+#include	"idf.h"
+#include	"type.h"
+#include	"def.h"
+#include	"LLlex.h"
+#include	"node.h"
+#include	"Lpars.h"
+#include	"scope.h"
+
+int
+chk_expr(expp, const)
+	register struct node *expp;
+{
+	/*	Check the expression indicated by expp for semantic errors,
+		identify identifiers used in it, replace constants by
+		their value.
+	*/
+
+	switch(expp->nd_class) {
+	case Oper:
+		return	chk_expr(expp->nd_left, const) &&
+			chk_expr(expp->nd_right, const) &&
+			chk_oper(expp, const);
+	case Uoper:
+		return	chk_expr(expp->nd_right, const) &&
+			chk_uoper(expp, const);
+	case Value:
+		switch(expp->nd_symb) {
+		case REAL:
+		case STRING:
+		case INTEGER:
+			return 1;
+		default:
+			assert(0);
+		}
+		break;
+	case Xset:
+		return chk_set(expp, const);
+	case Name:
+		return chk_name(expp, const);
+	case Call:
+		return chk_call(expp, const);
+	case Link:
+		return chk_name(expp, const);
+	}
+	/*NOTREACHED*/
+}
+
+int
+chk_set(expp, const)
+	register struct node *expp;
+{
+	/* ??? */
+	return 1;
+}
+
+int
+chk_call(expp, const)
+	register struct node *expp;
+{
+	/* ??? */
+	return 1;
+}
+
+struct def *
+findname(expp)
+	register struct node *expp;
+{
+	/*	Find the name indicated by "expp", starting from the current
+		scope.
+	*/
+	register struct def *df;
+	struct def *lookfor();
+	register struct node *nd;
+	int scope;
+	int module;
+
+	if (expp->nd_class == Name) {
+		return lookfor(expp, CurrentScope, 1);
+	}
+	assert(expp->nd_class == Link && expp->nd_symb == '.');
+	assert(expp->nd_left->nd_class == Name);
+	df = lookfor(expp->nd_left, CurrentScope, 1);
+	if (df->df_kind == D_ERROR) return df;
+	nd = expp;
+	while (nd->nd_class == Link) {
+		struct node *nd1;
+
+		if (!(scope = has_selectors(df))) {
+			node_error(nd, "identifier \"%s\" has no selectors",
+					df->df_idf->id_text);
+			return ill_df;
+		}
+		nd = nd->nd_right;
+		if (nd->nd_class == Name) nd1 = nd;
+		else nd1 = nd->nd_left;
+		module = (df->df_kind == D_MODULE);
+		df = lookup(nd1->nd_IDF, scope);
+		if (!df) {
+			id_not_declared(nd1);
+			return ill_df;
+		}
+		if (module && !(df->df_flags&(D_EXPORTED|D_QEXPORTED))) {
+node_error(nd1, "identifier \"%s\" not exprted from qualifying module",
+df->df_idf->id_text);
+		}
+	}
+	return df;
+}
+
+int
+chk_name(expp, const)
+	register struct node *expp;
+{
+	register struct def *df;
+	int retval = 1;
+
+	df = findname(expp);
+	if (df->df_kind == D_ERROR) {
+		retval = 0;
+	}
+	expp->nd_type = df->df_type;
+	if (df->df_kind == D_ENUM || df->df_kind == D_CONST) {
+		if (expp->nd_left) FreeNode(expp->nd_left);
+		if (expp->nd_right) FreeNode(expp->nd_right);
+		if (df->df_kind == D_ENUM) {
+			expp->nd_left = expp->nd_right = 0;
+			expp->nd_class = Value;
+			expp->nd_INT = df->enm_val;
+			expp->nd_symb = INTEGER;
+		}
+		else if (df->df_kind == D_CONST) {
+			*expp = *(df->con_const);
+		}
+	}
+	else if (const) {
+		node_error(expp, "constant expected");
+		retval = 0;
+	}
+	return retval;
+}
+
+int
+chk_oper(expp, const)
+	register struct node *expp;
+{
+	/*	Check a binary operation. If "const" is set, also check
+		that it is constant.
+		The code is ugly !
+	*/
+	register struct type *tpl = expp->nd_left->nd_type;
+	register struct type *tpr = expp->nd_right->nd_type;
+	char *symbol2str();
+	int errval = 1;
+	
+	if (tpl == intorcard_type) {
+		if (tpr == int_type || tpr == card_type) {
+			expp->nd_left->nd_type = tpl = tpr;
+		}
+	}
+	if (tpr == intorcard_type) {
+		if (tpl == int_type || tpl == card_type) {
+			expp->nd_right->nd_type = tpr = tpl;
+		}
+	}
+
+	if (expp->nd_symb == IN) {
+		/* Handle this one specially */
+		expp->nd_type == bool_type;
+		if (tpr->tp_fund != SET) {
+node_error(expp, "RHS of IN operator not a SET type");
+			return 0;
+		}
+		if (!TstCompat(tpl, tpr->next)) {
+node_error(expp, "IN operator: type of LHS not compatible with element type of RHS");
+			return 0;
+		}
+		return 1;
+	}
+
+	if (tpl->tp_fund == SUBRANGE) tpl = tpl->next;
+	expp->nd_type = tpl;
+
+	if (!TstCompat(tpl, tpr)) {
+node_error(expp, "Incompatible types for operator \"%s\"", symbol2str(expp->nd_symb));
+		return 0;
+	}
+	
+	switch(expp->nd_symb) {
+	case '+':
+	case '-':
+	case '*':
+		switch(tpl->tp_fund) {
+		case INTEGER:
+		case INTORCARD:
+		case CARDINAL:
+		case LONGINT:
+		case SET:
+			if (expp->nd_left->nd_class == Value &&
+			    expp->nd_right->nd_class == Value) {
+				cstbin(expp);
+			}
+			return 1;
+		case REAL:
+		case LONGREAL:
+			if (const) {
+				errval = 2;
+				break;
+			}
+			return 1;
+		}
+		break;
+	case '/':
+		switch(tpl->tp_fund) {
+		case SET:
+			if (expp->nd_left->nd_class == Value &&
+			    expp->nd_right->nd_class == Value) {
+				cstbin(expp);
+			}
+			return 1;
+		case REAL:
+		case LONGREAL:
+			if (const) {
+				errval = 2;
+				break;
+			}
+			return 1;
+		}
+		break;
+	case DIV:
+	case MOD:
+		switch(tpl->tp_fund) {
+		case INTEGER:
+		case INTORCARD:
+		case CARDINAL:
+		case LONGINT:
+			if (expp->nd_left->nd_class == Value &&
+			    expp->nd_right->nd_class == Value) {
+				cstbin(expp);
+			}
+			return 1;
+		}
+		break;
+	case OR:
+	case AND:
+		if (tpl == bool_type) {
+			if (expp->nd_left->nd_class == Value &&
+			    expp->nd_right->nd_class == Value) {
+				cstbin(expp);
+			}
+			return 1;
+		}
+		errval = 3;
+		break;
+	case '=':
+	case '#':
+	case GREATEREQUAL:
+	case LESSEQUAL:
+	case '<':
+	case '>':
+		switch(tpl->tp_fund) {
+		case SET:
+			if (expp->nd_symb == '<' || expp->nd_symb == '>') {
+				break;
+			}
+		case INTEGER:
+		case INTORCARD:
+		case LONGINT:
+		case CARDINAL:
+		case ENUMERATION:	/* includes boolean */
+		case CHAR:
+			if (expp->nd_left->nd_class == Value &&
+			    expp->nd_right->nd_class == Value) {
+				cstbin(expp);
+			}
+			return 1;
+		case POINTER:
+			if (!(expp->nd_symb == '=' || expp->nd_symb == '#')) {
+				break;
+			}
+			/* Fall through */
+		case REAL:
+		case LONGREAL:
+			if (const) {
+				errval = 2;
+				break;
+			}
+			return 1;
+		}
+	default:
+		assert(0);
+	}
+	switch(errval) {
+	case 1:
+		node_error(expp,"Operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb));
+		break;
+	case 2:
+		node_error(expp, "Expression not constant");
+		break;
+	case 3:
+		node_error(expp, "BOOLEAN type(s) expected");
+		break;
+	}
+	return 0;
+}
+
+int
+chk_uoper(expp, const)
+	register struct node *expp;
+{
+	/*	Check an unary operation. If "const" is set, also check that
+		it can be evaluated compile-time.
+	*/
+	register struct type *tpr = expp->nd_right->nd_type;
+
+	if (tpr->tp_fund == SUBRANGE) tpr = tpr->next;
+	expp->nd_type = tpr;
+
+	switch(expp->nd_symb) {
+	case '+':
+		switch(tpr->tp_fund) {
+		case INTEGER:
+		case LONGINT:
+		case REAL:
+		case LONGREAL:
+		case CARDINAL:
+		case INTORCARD:
+			expp->nd_token = expp->nd_right->nd_token;
+			FreeNode(expp->nd_right);
+			expp->nd_right = 0;
+			return 1;
+		}
+		break;
+	case '-':
+		switch(tpr->tp_fund) {
+		case INTEGER:
+		case LONGINT:
+		case INTORCARD:
+			if (expp->nd_right->nd_class == Value) {
+				cstunary(expp);
+			}
+			return 1;
+		case REAL:
+		case LONGREAL:
+			if (expp->nd_right->nd_class == Value) {
+				expp->nd_token = expp->nd_right->nd_token;
+				if (*(expp->nd_REL) == '-') {
+					expp->nd_REL++;
+				}
+				else	expp->nd_REL--;
+				FreeNode(expp->nd_right);
+				expp->nd_right = 0;
+			}
+			return 1;
+		}
+		break;
+	case NOT:
+		if (tpr == bool_type) {
+			if (expp->nd_right->nd_class == Value) {
+				cstunary(expp);
+			}
+			return 1;
+		}
+		break;
+	default:
+		assert(0);
+	}
+	node_error(expp, "Illegal operand for unary operator \"%s\"",
+			symbol2str(expp->nd_symb));
+	return 0;
+}

lang/m2/comp/cstoper.c

@@ -19,17 +19,17 @@ arith max_int;		/* maximum integer on target machine	*/
 arith max_unsigned;	/* maximum unsigned on target machine	*/
 arith max_longint;	/* maximum longint on target machine	*/
 
-cstunary(expp, oper)
+cstunary(expp)
 	register struct node *expp;
 {
-	/*	The unary operation oper is performed on the constant
+	/*	The unary operation in "expp" is performed on the constant
-		expression expp, and the result restored in expp.
+		expression below it, and the result restored in expp.
 	*/
-	arith o1 = expp->nd_INT;
+	arith o1 = expp->nd_right->nd_INT;
 
-	switch(oper) {
+	switch(expp->nd_symb) {
 	case '+':
-		return;
+		break;
 	case '-':
 		o1 = -o1;
 		break;
@@ -39,40 +39,37 @@ cstunary(expp, oper)
 	default:
 		assert(0);
 	}
+	expp->nd_class = Value;
+	expp->nd_token = expp->nd_right->nd_token;
 	expp->nd_INT = o1;
 	cut_size(expp);
+	FreeNode(expp->nd_right);
+	expp->nd_right = 0;
 }
 
-cstbin(expp, oper, expr)
+cstbin(expp)
-	register struct node *expp, *expr;
+	register struct node *expp;
 {
-	/*	The binary operation oper is performed on the constant
+	/*	The binary operation in "expp" is performed on the constant
-		expressions expp and expr, and the result restored in
+		expressions below it, and the result restored in
 		expp.
 	*/
-	arith o1 = expp->nd_INT;
+	arith o1 = expp->nd_left->nd_INT;
-	arith o2 = expr->nd_INT;
+	arith o2 = expp->nd_right->nd_INT;
 	int uns = expp->nd_type != int_type;
 
-	assert(expp->nd_class == Value && expr->nd_class == Value);
+	assert(expp->nd_class == Oper);
-	switch (oper)	{
+	if (expp->nd_right->nd_type->tp_fund == SET) {
-	case IN:
+		cstset(expp);
-		/* ??? */
-		return;
-	case '*':
-		if (expp->nd_type->tp_fund == SET) {
-			/* ??? */
 		return;
 	}
+	switch (expp->nd_symb)	{
+	case '*':
 		o1 *= o2;
 		break;
-	case '/':
-		assert(expp->nd_type->tp_fund == SET);
-		/* ??? */
-		return;
 	case DIV:
 		if (o2 == 0)	{
-			node_error(expr, "division by 0");
+			node_error(expp, "division by 0");
 			return;
 		}
 		if (uns)	{
@@ -109,7 +106,7 @@ cstbin(expp, oper, expr)
 		break;
 	case MOD:
 		if (o2 == 0)	{
-			node_error(expr, "modulo by 0");
+			node_error(expp, "modulo by 0");
 			return;
 		}
 		if (uns)	{
@@ -137,17 +134,9 @@ cstbin(expp, oper, expr)
 			o1 %= o2;
 		break;
 	case '+':
-		if (expp->nd_type->tp_fund == SET) {
-			/* ??? */
-			return;
-		}
 		o1 += o2;
 		break;
 	case '-':
-		if (expp->nd_type->tp_fund == SET) {
-			/* ??? */
-			return;
-		}
 		o1 -= o2;
 		break;
 	case '<':
@@ -171,10 +160,6 @@ cstbin(expp, oper, expr)
 			o1 = o1 > o2;
 		break;
 	case LESSEQUAL:
-		if (expp->nd_type->tp_fund == SET) {
-			/* ??? */
-			return;
-		}
 		if (uns)	{
 			o1 = (o1 & mach_long_sign ?
 				(o2 & mach_long_sign ? o1 <= o2 : 0) :
@@ -185,10 +170,6 @@ cstbin(expp, oper, expr)
 			o1 = o1 <= o2;
 		break;
 	case GREATEREQUAL:
-		if (expp->nd_type->tp_fund == SET) {
-			/* ??? */
-			return;
-		}
 		if (uns)	{
 			o1 = (o1 & mach_long_sign ?
 				(o2 & mach_long_sign ? o1 >= o2 : 1) :
@@ -199,17 +180,9 @@ cstbin(expp, oper, expr)
 			o1 = o1 >= o2;
 		break;
 	case '=':
-		if (expp->nd_type->tp_fund == SET) {
-			/* ??? */
-			return;
-		}
 		o1 = o1 == o2;
 		break;
 	case '#':
-		if (expp->nd_type->tp_fund == SET) {
-			/* ??? */
-			return;
-		}
 		o1 = o1 != o2;
 		break;
 	case AND:
@@ -221,8 +194,33 @@ cstbin(expp, oper, expr)
 	default:
 		assert(0);
 	}
+	expp->nd_class = Value;
+	expp->nd_token = expp->nd_right->nd_token;
 	expp->nd_INT = o1;
 	cut_size(expp);
+	FreeNode(expp->nd_left);
+	FreeNode(expp->nd_right);
+	expp->nd_left = expp->nd_right = 0;
+}
+
+cstset(expp)
+	register struct node *expp;
+{
+	switch(expp->nd_symb) {
+	case IN:
+	case '+':
+	case '-':
+	case '*':
+	case '/':
+	case GREATEREQUAL:
+	case LESSEQUAL:
+	case '=':
+	case '#':
+		/* ??? */
+		break;
+	default:
+		assert(0);
+	}
 }
 
 cut_size(expr)

lang/m2/comp/declar.g

@@ -5,6 +5,7 @@ static char *RcsId = "$Header$";
 
 #include	<em_arith.h>
 #include	<em_label.h>
+#include	<alloc.h>
 #include	<assert.h>
 #include	"idf.h"
 #include	"LLlex.h"
@@ -122,7 +123,7 @@ FPSection(int doparams; struct paramlist **ppr;)
 		  if (doparams) {
 			EnterIdList(FPList, D_VARIABLE, VARp, tp, CurrentScope);
 		  }
-		  *ppr = ParamList(FPList, tp);
+		  *ppr = ParamList(FPList, tp, VARp);
 		  FreeNode(FPList);
 		}
 ;
@@ -181,18 +182,18 @@ type(struct type **ptp;):
 SimpleType(struct type **ptp;)
 {
 	struct def *df;
-	struct type *tp;
 } :
 	qualident(D_TYPE | D_HTYPE, &df, "type", (struct node **) 0)
 	[
 		/* nothing */
+			{ *ptp = df->df_type; }
 	|
 		SubrangeType(ptp)
 		/* The subrange type is given a base type by the
 		   qualident (this is new modula-2).
 		*/
 			{
-			  chk_basesubrange(*ptp, tp);
+			  chk_basesubrange(*ptp, df->df_type);
 			}
 	]
 |
@@ -250,7 +251,7 @@ SubrangeType(struct type **ptp;)
 			{
 			  /* For the time being: */
 			  tp = int_type;
-			  tp = construct_type(SUBRANGE, tp, (arith) 0);
+			  tp = construct_type(SUBRANGE, tp);
 			  *ptp = tp;
 			}
 ;
@@ -352,7 +353,7 @@ SetType(struct type **ptp;)
 } :
 	SET OF SimpleType(&tp)
 			{
-			  *ptp = construct_type(SET, tp, (arith) 0 /* ???? */);
+			  *ptp = construct_type(SET, tp);
 			}
 ;
 
@@ -365,6 +366,7 @@ PointerType(struct type **ptp;)
 	struct type *tp;
 	struct def *df;
 	struct def *lookfor();
+	struct node *nd;
 } :
 	POINTER TO
 	[ %if ( (df = lookup(dot.TOK_IDF, CurrentScope->sc_scope)))
@@ -380,7 +382,8 @@ PointerType(struct type **ptp;)
 				  }
 				  else	tp = df->df_type;
 				}
-	| %if (df = lookfor(dot.TOK_IDF, CurrentScope, 0),
+	| %if ( nd = new_node(), nd->nd_token = dot,
+		df = lookfor(nd, CurrentScope, 0), free_node(nd),
 	        df->df_kind == D_MODULE)
 		type(&tp)
 	|
@@ -449,7 +452,7 @@ ConstantDeclaration
 }:
 	IDENT			{ id = dot.TOK_IDF; }
 	'=' ConstExpression(&nd){ df = define(id, CurrentScope, D_CONST);
-				  /* ???? */
+				  df->con_const = nd;
 				}
 ;
 

lang/m2/comp/def.H

@@ -15,8 +15,8 @@ struct variable {
 };
 
 struct constant {
-	arith co_const;		/* result of a constant expression */
+	struct node *co_const;	/* result of a constant expression */
-#define con_const	df_value.df_variable.con_const
+#define con_const	df_value.df_constant.co_const
 };
 
 struct enumval {

lang/m2/comp/def.c

@@ -6,11 +6,11 @@ static char *RcsId = "$Header$";
 #include	<em_arith.h>
 #include	<em_label.h>
 #include	<assert.h>
+#include	"main.h"
 #include	"Lpars.h"
 #include	"def.h"
 #include	"type.h"
 #include	"idf.h"
-#include	"main.h"
 #include	"scope.h"
 #include	"LLlex.h"
 #include	"node.h"
@@ -26,13 +26,12 @@ struct def *ill_df = &illegal_def;
 struct def *
 define(id, scope, kind)
 	register struct idf *id;
-	struct scope *scope;
+	register struct scope *scope;
 {
 	/*	Declare an identifier in a scope, but first check if it
 		already has been defined. If so, error message.
 	*/
 	register struct def *df;
-	register struct scope *sc;
 
 	DO_DEBUG(5, debug("Defining identifier \"%s\" in scope %d", id->id_text, scope->sc_scope));
 	df = lookup(id, scope->sc_scope);
@@ -157,7 +156,6 @@ Import(ids, idn, local)
 		identifiers defined in this module.
 	*/
 	register struct def *df;
-	register struct idf *id = 0;
 	int scope;
 	int kind;
 	int imp_kind;
@@ -165,19 +163,18 @@ Import(ids, idn, local)
 #define FROM_ENCLOSING	1
 	struct def *lookfor(), *GetDefinitionModule();
 
-	if (idn) id = idn->nd_IDF;
 	kind = D_IMPORT;
 	scope = enclosing(CurrentScope)->sc_scope;
-	if (!id) imp_kind = FROM_ENCLOSING;
+	if (!idn) imp_kind = FROM_ENCLOSING;
 	else {
 		imp_kind = FROM_MODULE;
-		if (local) df = lookfor(id, enclosing(CurrentScope), 1);
+		if (local) df = lookfor(idn, enclosing(CurrentScope), 1);
-		else df = GetDefinitionModule(id);
+		else df = GetDefinitionModule(idn->nd_IDF);
 		if (df->df_kind != D_MODULE) {
 			/* enter all "ids" with type D_ERROR */
 			kind = D_ERROR;
 			if (df->df_kind != D_ERROR) {
-node_error(idn, "identifier \"%s\" does not represent a module", id->id_text);
+node_error(idn, "identifier \"%s\" does not represent a module", idn->nd_IDF->id_text);
 			}
 		}
 		else	scope = df->mod_scope;
@@ -197,14 +194,14 @@ ids->nd_IDF->id_text);
 		}
 		else {
 			if (local) {
-				df = lookfor(ids->nd_IDF,
+				df = lookfor(ids, enclosing(CurrentScope), 0);
-					     enclosing(CurrentScope), 0);
 			} else df = GetDefinitionModule(ids->nd_IDF);
 			if (df->df_kind == D_ERROR) {
 node_error(ids, "identifier \"%s\" not visible in enclosing scope",
 ids->nd_IDF->id_text);
 			}
 		}
+		DO_DEBUG(2, debug("importing \"%s\", kind %d", ids->nd_IDF->id_text, df->df_kind));
 		define(ids->nd_IDF, CurrentScope, kind)->imp_def = df;
 		if (df->df_kind == D_TYPE &&
 		    df->df_type->tp_fund == ENUMERATION) {
@@ -218,12 +215,14 @@ ids->nd_IDF->id_text);
 
 exprt_literals(df, toscope)
 	register struct def *df;
-	register struct scope *toscope;
+	struct scope *toscope;
 {
 	/*	A list of enumeration literals is exported. This is implemented
 		as an import from the scope "toscope".
 	*/
+	DO_DEBUG(2, debug("enumeration import:"));
 	while (df) {
+		DO_DEBUG(2, debug(df->df_idf->id_text));
 		define(df->df_idf, toscope, D_IMPORT)->imp_def = df;
 		df = df->enm_next;
 	}

lang/m2/comp/defmodule.c

@@ -11,6 +11,11 @@ static char *RcsId = "$Header$";
 #include	"def.h"
 #include	"LLlex.h"
 #include	"f_info.h"
+#include	"debug.h"
+
+#ifdef DEBUG
+long	sys_filesize();
+#endif
 
 GetFile(name)
 	char *name;
@@ -30,6 +35,7 @@ GetFile(name)
 		fatal("Could'nt find a DEFINITION MODULE for \"%s\"", name);
 	}
 	LineNumber = 1;
+	DO_DEBUG(1, debug("File %s : %ld characters", FileName, sys_filesize(FileName)));
 }
 
 struct def *

lang/m2/comp/enter.c

@@ -74,7 +74,7 @@ EnterIdList(idlist, kind, flags, type, scope)
 
 struct def *
 lookfor(id, scope, give_error)
-	struct idf *id;
+	struct node *id;
 	struct scope *scope;
 {
 	/*	Look for an identifier in the visibility range started by
@@ -86,10 +86,10 @@ lookfor(id, scope, give_error)
 	register struct scope *sc = scope;
 
 	while (sc) {
-		df = lookup(id, sc->sc_scope);
+		df = lookup(id->nd_IDF, sc->sc_scope);
 		if (df) return df;
 		sc = nextvisible(sc);
 	}
 	if (give_error) id_not_declared(id);
-	return define(id, scope, D_ERROR);
+	return define(id->nd_IDF, scope, D_ERROR);
 }

lang/m2/comp/expression.g

@@ -6,7 +6,6 @@ static char *RcsId = "$Header$";
 #include	<alloc.h>
 #include	<em_arith.h>
 #include	<em_label.h>
-#include	"main.h"
 #include	"LLlex.h"
 #include	"idf.h"
 #include	"def.h"
@@ -34,53 +33,30 @@ number(struct node **p;)
 
 qualident(int types; struct def **pdf; char *str; struct node **p;)
 {
-	int scope;
-	int  module;
 	register struct def *df;
-	struct def *lookfor();
 	register struct node **pnd;
 	struct node *nd;
+	struct def *findname();
 } :
-	IDENT		{ if (types) {
+	IDENT		{ nd = MkNode(Name, NULLNODE, NULLNODE, &dot);
-				df = lookfor(dot.TOK_IDF, CurrentScope, 1);
-				*pdf = df;
-				if (df->df_kind == D_ERROR) types = 0;
-			  }
-			  nd = MkNode(Value, NULLNODE, NULLNODE, &dot);
 			  pnd = &nd;
 			}
 	[
-			{ if (types &&!(scope = has_selectors(df))) {
-				types = 0;
-				*pdf = ill_df;
-			  }
-			}
 		/* selector */
 		'.'	{ *pnd = MkNode(Link,*pnd,NULLNODE,&dot);
 			  pnd = &(*pnd)->nd_right;
 			}
 		IDENT
-			{ *pnd = MkNode(Value,NULLNODE,NULLNODE,&dot);
+			{ *pnd = MkNode(Name,NULLNODE,NULLNODE,&dot); }
-			  if (types) {
-				module = (df->df_kind == D_MODULE);
-				df = lookup(dot.TOK_IDF, scope);
-				if (!df) {
-					types = 0;
-					df = ill_df;
-					id_not_declared(dot.TOK_IDF);
-				}
-				else
-				if (module &&
-				    !(df->df_flags&(D_EXPORTED|D_QEXPORTED))) {
-					error("identifier \"%s\" not exported from qualifying module", dot.TOK_IDF->id_text);
-				}
-			  }
-			}
 	]*
-			{ if (types && !(types & df->df_kind)) {
+			{ if (types) {
+				*pdf = df = findname(nd);
+			  	if (df->df_kind != D_ERROR &&
+				    !(types & df->df_kind)) {
 					error("identifier \"%s\" is not a %s",
 					df->df_idf->id_text, str);
 				}
+			  }
 			  if (!p) FreeNode(nd);
 			  else *p = nd;
 			}
@@ -114,6 +90,7 @@ ConstExpression(struct node **pnd;):
 		{ DO_DEBUG(3,
 		     ( debug("Constant expression:"),
 		       PrNode(*pnd)));
+		  (void) chk_expr(*pnd, 1);
 		}
 ;
 
@@ -209,7 +186,7 @@ factor(struct node **p;)
 	'(' expression(p) ')'
 |
 	NOT		{ *p = MkNode(Uoper, NULLNODE, NULLNODE, &dot); }
-	factor(&((*p)->nd_left))
+	factor(&((*p)->nd_right))
 ;
 
 bare_set(struct node **pnd;)
@@ -218,7 +195,7 @@ bare_set(struct node **pnd;)
 } :
 	'{'		{
 			  dot.tk_symb = SET;
-			  *pnd = nd = MkNode(Link, NULLNODE, NULLNODE, &dot);
+			  *pnd = nd = MkNode(Xset, NULLNODE, NULLNODE, &dot);
 			  nd->nd_type = bitset_type;
 			}
 	[
@@ -261,9 +238,9 @@ designator_tail(struct node **pnd;):
 	visible_designator_tail(pnd)
 	[
 		/* selector */
-		'.'	{ *pnd = MkNode(Oper, *pnd, NULLNODE, &dot); }
+		'.'	{ *pnd = MkNode(Link, *pnd, NULLNODE, &dot); }
 		IDENT	{ (*pnd)->nd_right =
-				MkNode(Value, NULLNODE, NULLNODE, &dot);
+				MkNode(Name, NULLNODE, NULLNODE, &dot);
 			}
 	|
 		visible_designator_tail(pnd)

lang/m2/comp/main.c

@@ -10,12 +10,12 @@ static char *RcsId = "$Header$";
 #include	"idf.h"
 #include	"LLlex.h"
 #include	"Lpars.h"
-#include	"main.h"
 #include	"debug.h"
 #include	"type.h"
 #include	"def.h"
 #include	"scope.h"
 #include	"standards.h"
+#include	"tokenname.h"
 
 char	options[128];
 int	DefinitionModule; 
@@ -126,7 +126,6 @@ Option(str)
 add_standards()
 {
 	register struct def *df;
-	register struct type *tp;
 	struct def *Enter();
 
 	(void) Enter("ABS", D_STDFUNC, NULLTYPE, S_ABS);
@@ -161,11 +160,11 @@ add_standards()
 		     0);
 	df = Enter("BITSET", D_TYPE, bitset_type, 0);
 	df = Enter("FALSE", D_ENUM, bool_type, 0);
-	df->df_value.df_enum.en_val = 0;
+	df->enm_val = 0;
-	df->df_value.df_enum.en_next = Enter("TRUE", D_ENUM, bool_type, 0);
+	df->enm_next = Enter("TRUE", D_ENUM, bool_type, 0);
-	df = df->df_value.df_enum.en_next;
+	df = df->enm_next;
-	df->df_value.df_enum.en_val = 1;
+	df->enm_val = 1;
-	df->df_value.df_enum.en_next = 0;
+	df->enm_next = 0;
 }
 
 init_DEFPATH()

lang/m2/comp/misc.c

@@ -8,6 +8,7 @@ static char *RcsId = "$Header$";
 #include	"misc.h"
 #include	"LLlex.h"
 #include	"idf.h"
+#include	"node.h"
 
 match_id(id1, id2)
 	struct idf *id1, *id2;
@@ -40,12 +41,13 @@ gen_anon_idf()
 }
 
 id_not_declared(id)
-	struct idf *id;
+	struct node *id;
 {
 	/*	The identifier "id" is not declared. If it is not generated,
 		give an error message
 	*/
-	if (!is_anon_idf(id)) {
+	if (!is_anon_idf(id->nd_IDF)) {
-		error("identifier \"%s\" not declared", id->id_text);
+		node_error(id,
+			"identifier \"%s\" not declared", id->nd_IDF->id_text);
 	}
 }

lang/m2/comp/node.H

@@ -7,18 +7,28 @@ struct node {
 #define nd_left	next
 	struct node *nd_right;
 	int nd_class;		/* kind of node */
-#define Value	1		/* idf or constant */
+#define Value	1		/* constant */
 #define Oper	2		/* binary operator */
 #define Uoper	3		/* unary operator */
 #define Call	4		/* cast or procedure - or function call */
-#define Link	5
+#define Name	5		/* a qualident */
+#define Set	6		/* a set constant */
+#define Xset	7		/* a set */
+#define Def	8		/* an identified name */
+#define Link	11
 	struct type *nd_type;	/* type of this node */
 	union {
-		struct token ndu_token;
+		struct token ndu_token;	/* (Value, Oper, Uoper, Call, Name,
-		char *ndu_set;	/* Pointer to a set constant */
+					    Link)
+					*/
+		arith *ndu_set;		/* pointer to a set constant (Set) */
+		struct def *ndu_def;	/* pointer to definition structure for
+					   identified name (Def)
+					*/
 	} nd_val;
 #define nd_token	nd_val.ndu_token
 #define nd_set		nd_val.ndu_set
+#define nd_def		nd_val.ndu_def
 #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

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

lang/m2/comp/program.g

@@ -6,8 +6,8 @@ static  char *RcsId = "$Header$";
 #include	<alloc.h>
 #include	<em_arith.h>
 #include	<em_label.h>
-#include	"idf.h"
 #include	"main.h"
+#include	"idf.h"
 #include	"LLlex.h"
 #include	"scope.h"
 #include	"def.h"
@@ -148,13 +148,12 @@ DefinitionModule
 definition
 {
 	struct def *df;
-	struct type *tp;
 } :
 	CONST [ ConstantDeclaration ';' ]*
 |
 	TYPE
 	[ IDENT 	{ df = define(dot.TOK_IDF, CurrentScope, D_TYPE); }
-	  [ '=' type(&tp)
+	  [ '=' type(&(df->df_type))
 	  | /* empty */
 	    /*
 	       Here, the exported type has a hidden implementation.

lang/m2/comp/scope.C

@@ -11,7 +11,7 @@ static char *RcsId = "$Header$";
 #include	"scope.h"
 #include	"type.h"
 #include	"def.h"
-#include	"main.h"
+#include	"node.h"
 #include	"debug.h"
 
 static int maxscope;		/* maximum assigned scope number */
@@ -34,7 +34,8 @@ open_scope(scopetype, scope)
 	register struct scope *sc1;
 
 	sc->sc_scope = scope == 0 ? ++maxscope : scope;
-	sc->sc_forw = 0; sc->sc_def = 0;
+	sc->sc_forw = 0;
+	sc->sc_def = 0;
 	assert(scopetype == OPENSCOPE || scopetype == CLOSEDSCOPE);
 	DO_DEBUG(1, debug("Opening a %s scope",
 			scopetype == OPENSCOPE ? "open" : "closed"));
@@ -42,32 +43,14 @@ open_scope(scopetype, scope)
 	if (scopetype == CLOSEDSCOPE) {
 		sc1 = new_scope();
 		sc1->sc_scope = 0;		/* Pervasive scope nr */
-		sc1->sc_forw = 0; sc1->sc_def = 0;
+		sc1->sc_forw = 0;
+		sc1->sc_def = 0;
 		sc1->next = CurrentScope;
 	}
 	sc->next = sc1;
 	CurrentScope = sc;
 }
 
-static rem_forwards();
-
-close_scope()
-{
-	register struct scope *sc = CurrentScope;
-
-	assert(sc != 0);
-	DO_DEBUG(1, debug("Closing a scope"));
-	if (sc->sc_forw) rem_forwards(sc->sc_forw);
-	if (sc->next && (sc->next->sc_scope == 0)) {
-		struct scope *sc1 = sc;
-
-		sc = sc->next;
-		free_scope(sc1);
-	}
-	CurrentScope = sc->next;
-	free_scope(sc);
-}
-
 init_scope()
 {
 	register struct scope *sc = new_scope();
@@ -86,7 +69,7 @@ uniq_scope()
 
 struct forwards {
 	struct forwards *next;
-	struct token fo_tok;
+	struct node fo_tok;
 	struct type **fo_ptyp;
 };
 
@@ -103,12 +86,29 @@ Forward(tk, ptp)
 	*/
 	register struct forwards *f = new_forwards();
 
-	f->fo_tok = *tk;
+	f->fo_tok.nd_token = *tk;
 	f->fo_ptyp = ptp;
 	f->next = CurrentScope->sc_forw;
 	CurrentScope->sc_forw = f;
 }
 
+close_scope()
+{
+	register struct scope *sc = CurrentScope;
+
+	assert(sc != 0);
+	DO_DEBUG(1, debug("Closing a scope"));
+	if (sc->sc_forw) rem_forwards(sc->sc_forw);
+	if (sc->next && (sc->next->sc_scope == 0)) {
+		struct scope *sc1 = sc;
+
+		sc = sc->next;
+		free_scope(sc1);
+	}
+	CurrentScope = sc->next;
+	free_scope(sc);
+}
+
 static
 rem_forwards(fo)
 	struct forwards *fo;
@@ -116,21 +116,17 @@ rem_forwards(fo)
 	/*	When closing a scope, all forward references must be resolved
 	*/
 	register struct forwards *f;
-	struct token savetok;
 	register struct def *df;
 	struct def *lookfor();
 
-	savetok = dot;
 	while (f = fo) {
-		dot = f->fo_tok;
+		df = lookfor(&(f->fo_tok), CurrentScope, 1);
-		df = lookfor(dot.TOK_IDF, CurrentScope, 1);
 		if (!(df->df_kind & (D_TYPE | D_HTYPE | D_ERROR))) {
-			error("identifier \"%s\" not a type",
+			node_error(&(f->fo_tok), "identifier \"%s\" not a type",
 			      df->df_idf->id_text);
 		}
 		*(f->fo_ptyp) = df->df_type;
 		fo = f->next;
 		free_forwards(f);
 	}
-	dot = savetok;
 }

lang/m2/comp/typequiv.c

@@ -79,5 +79,6 @@ TstCompat(tp1, tp2)
 		  || tp1 == intorcard_type
 		  || tp1->tp_fund == POINTER
 		  )
-		);
+		)
+	;
 }