New version, with an option for strict Modula-2, and

warnings for unused or uninitialized variables

lang/m2/comp/Makefile

@@ -40,7 +40,7 @@ OBJ =	$(COBJ) $(LOBJ) Lpars.o
 GENH=	errout.h\
 	idfsize.h numsize.h strsize.h target_sizes.h \
 	inputtype.h maxset.h density.h squeeze.h \
-	def.h debugcst.h type.h Lpars.h node.h desig.h
+	def.h debugcst.h type.h Lpars.h node.h desig.h strict3rd.h
 HFILES=		LLlex.h\
 	chk_expr.h class.h const.h debug.h f_info.h idf.h\
 	input.h main.h misc.h scope.h standards.h tokenname.h\
@@ -181,6 +181,7 @@ error.o: input.h
 error.o: inputtype.h
 error.o: main.h
 error.o: node.h
+error.o: strict3rd.h
 error.o: warning.h
 main.o: LLlex.h
 main.o: Lpars.h
@@ -195,6 +196,7 @@ main.o: inputtype.h
 main.o: node.h
 main.o: scope.h
 main.o: standards.h
+main.o: strict3rd.h
 main.o: tokenname.h
 main.o: type.h
 main.o: warning.h
@@ -264,7 +266,9 @@ typequiv.o: debug.h
 typequiv.o: debugcst.h
 typequiv.o: def.h
 typequiv.o: idf.h
+typequiv.o: main.h
 typequiv.o: node.h
+typequiv.o: strict3rd.h
 typequiv.o: type.h
 typequiv.o: warning.h
 node.o: LLlex.h
@@ -291,14 +295,17 @@ chk_expr.o: debug.h
 chk_expr.o: debugcst.h
 chk_expr.o: def.h
 chk_expr.o: idf.h
+chk_expr.o: main.h
 chk_expr.o: misc.h
 chk_expr.o: node.h
 chk_expr.o: scope.h
 chk_expr.o: standards.h
+chk_expr.o: strict3rd.h
 chk_expr.o: type.h
 chk_expr.o: warning.h
 options.o: idfsize.h
 options.o: main.h
+options.o: strict3rd.h
 options.o: type.h
 options.o: warning.h
 walk.o: LLlex.h
@@ -314,6 +321,7 @@ walk.o: main.h
 walk.o: node.h
 walk.o: scope.h
 walk.o: squeeze.h
+walk.o: strict3rd.h
 walk.o: type.h
 walk.o: walk.h
 walk.o: warning.h
@@ -360,6 +368,7 @@ program.o: idf.h
 program.o: main.h
 program.o: node.h
 program.o: scope.h
+program.o: strict3rd.h
 program.o: type.h
 program.o: warning.h
 declar.o: LLlex.h
@@ -373,6 +382,7 @@ declar.o: main.h
 declar.o: misc.h
 declar.o: node.h
 declar.o: scope.h
+declar.o: strict3rd.h
 declar.o: type.h
 declar.o: warning.h
 expression.o: LLlex.h
@@ -401,6 +411,7 @@ casestat.o: Lpars.h
 casestat.o: chk_expr.h
 casestat.o: debug.h
 casestat.o: debugcst.h
+casestat.o: def.h
 casestat.o: density.h
 casestat.o: desig.h
 casestat.o: node.h

lang/m2/comp/Parameters

@@ -65,3 +65,10 @@
 #undef SQUEEZE 1		/* define on "small" machines */
 
 
+!File: strict3rd.h
+#undef STRICT_3RD_ED 1		/* define on "small" machines, and if you want
+				   a compiler that only implements "3rd edition"
+				   Modula-2
+				*/
+
+

lang/m2/comp/SYSTEM.h

@@ -11,8 +11,15 @@
 
 /* Text of SYSTEM module, for as far as it can be expressed in Modula-2 */
 
+#ifndef STRICT_3RD_ED
 #define SYSTEMTEXT "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"
+#else
+#define SYSTEMTEXT "DEFINITION MODULE SYSTEM;\n\
+PROCEDURE NEWPROCESS(P:PROC; A:ADDRESS; n:CARDINAL; VAR p1:ADDRESS);\n\
+PROCEDURE TRANSFER(VAR p1,p2:ADDRESS);\n\
+END SYSTEM.\n"
+#endif

lang/m2/comp/Version.c

@@ -1 +1 @@
-static char Version[] = "ACK Modula-2 compiler Version 0.20";
+static char Version[] = "ACK Modula-2 compiler Version 0.21";

lang/m2/comp/casestat.C

@@ -32,6 +32,7 @@
 #include	"desig.h"
 #include	"walk.h"
 #include	"chk_expr.h"
+#include	"def.h"
 
 #include	"density.h"
 

lang/m2/comp/chk_expr.c

@@ -19,6 +19,7 @@
 #include	<assert.h>
 #include	<alloc.h>
 
+#include	"strict3rd.h"
 #include	"Lpars.h"
 #include	"idf.h"
 #include	"type.h"
@@ -31,6 +32,7 @@
 #include	"chk_expr.h"
 #include	"misc.h"
 #include	"warning.h"
+#include	"main.h"
 
 extern char *symbol2str();
 extern char *sprint();
@@ -125,14 +127,14 @@ MkCoercion(pnd, tp)
 }
 
 int
-ChkVariable(expp)
+ChkVariable(expp, flags)
 	register t_node *expp;
 {
 	/*	Check that "expp" indicates an item that can be
 		assigned to.
 	*/
 
-	return ChkDesignator(expp) &&
+	return ChkDesig(expp, flags) &&
 		( expp->nd_class != Def ||
 	    	  ( expp->nd_def->df_kind & (D_FIELD|D_VARIABLE)) ||
 		  df_error(expp, "variable expected", expp->nd_def));
@@ -152,7 +154,7 @@ ChkArrow(expp)
 
 	expp->nd_type = error_type;
 
-	if (! ChkVariable(expp->nd_right)) return 0;
+	if (! ChkVariable(expp->nd_right, D_USED)) return 0;
 
 	tp = expp->nd_right->nd_type;
 
@@ -166,7 +168,7 @@ ChkArrow(expp)
 }
 
 STATIC int
-ChkArr(expp)
+ChkArr(expp, flags)
 	register t_node *expp;
 {
 	/*	Check an array selection.
@@ -182,7 +184,7 @@ ChkArr(expp)
 
 	expp->nd_type = error_type;
 
-	if (! (ChkVariable(expp->nd_left) & ChkExpression(expp->nd_right))) {
+	if (! (ChkVariable(expp->nd_left, flags) & ChkExpression(expp->nd_right))) {
 		/* Bitwise and, because we want them both evaluated.
 		*/
 		return 0;
@@ -225,7 +227,7 @@ ChkValue(expp)
 #endif
 
 STATIC int
-ChkLinkOrName(expp)
+ChkLinkOrName(expp, flags)
 	register t_node *expp;
 {
 	/*	Check either an ID or a construction of the form
@@ -236,9 +238,10 @@ ChkLinkOrName(expp)
 	expp->nd_type = error_type;
 
 	if (expp->nd_class == Name) {
-		expp->nd_def = lookfor(expp, CurrVis, 1);
+		expp->nd_def = df = lookfor(expp, CurrVis, 1);
 		expp->nd_class = Def;
-		expp->nd_type = RemoveEqual(expp->nd_def->df_type);
+		expp->nd_type = RemoveEqual(df->df_type);
+		df->df_flags |= flags;
 	}
 	else if (expp->nd_class == Link) {
 		/*	A selection from a record or a module.
@@ -248,7 +251,7 @@ ChkLinkOrName(expp)
 
 		assert(expp->nd_symb == '.');
 
-		if (! ChkDesignator(left)) return 0;
+		if (! ChkDesig(left, flags)) return 0;
 
 		if (left->nd_class==Def &&
 		    (left->nd_type->tp_fund != T_RECORD ||
@@ -266,6 +269,7 @@ ChkLinkOrName(expp)
 			id_not_declared(expp);
 			return 0;
 		}
+		df->df_flags |= flags;
 		expp->nd_def = df;
 		expp->nd_type = RemoveEqual(df->df_type);
 		expp->nd_class = Def;
@@ -300,7 +304,7 @@ ChkExLinkOrName(expp)
 	*/
 	register t_def *df;
 
-	if (! ChkLinkOrName(expp)) return 0;
+	if (! ChkLinkOrName(expp, D_USED)) return 0;
 
 	df = expp->nd_def;
 
@@ -537,7 +541,7 @@ getarg(argp, bases, designator, edf)
 	register t_node *left = nextarg(argp, edf);
 
 	if (! left ||
-	    ! (designator ? ChkVariable(left) : ChkExpression(left))) {
+	    ! (designator ? ChkVariable(left, D_USED|D_DEFINED) : ChkExpression(left))) {
 		return 0;
 	}
 
@@ -616,7 +620,9 @@ ChkProcCall(expp)
 	*/
 	for (param = ParamList(left->nd_type); param; param = param->par_next) {
 		if (!(left = getarg(&expp, 0, IsVarParam(param), edf))) {
-			return 0;
+			retval = 0;
+			cnt++;
+			continue;
 		}
 		cnt++;
 		if (left->nd_symb == STRING) {
@@ -673,7 +679,7 @@ ChkCall(expp)
 
 	/* First, get the name of the function or procedure
 	*/
-	if (ChkDesignator(left)) {
+	if (ChkDesig(left, D_USED)) {
 		if (IsCast(left)) {
 			/* It was a type cast.
 			*/
@@ -920,8 +926,8 @@ ChkUnOper(expp)
 		return 1;
 
 	case '-':
-		if (tpr->tp_fund & T_INTORCARD) {
+		if (tpr->tp_fund == T_INTORCARD || tpr->tp_fund == T_INTEGER) {
-			if (tpr == intorcard_type || tpr == card_type) {
+			if (tpr == intorcard_type) {
 				expp->nd_type = int_type;
 			}
 			if (right->nd_class == Value) {
@@ -957,7 +963,7 @@ ChkUnOper(expp)
 }
 
 STATIC t_node *
-getvariable(argp, edf)
+getvariable(argp, edf, flags)
 	t_node **argp;
 	t_def *edf;
 {
@@ -966,7 +972,7 @@ getvariable(argp, edf)
 	*/
 	register t_node *left = nextarg(argp, edf);
 
-	if (!left || !ChkVariable(left)) return 0;
+	if (!left || !ChkVariable(left, flags)) return 0;
 
 	return left;
 }
@@ -1072,6 +1078,7 @@ ChkStandard(expp)
 		if (left->nd_type->tp_fund == T_ARRAY) {
 			expp->nd_type = IndexType(left->nd_type);
 			if (! IsConformantArray(left->nd_type)) {
+				left->nd_type = expp->nd_type;
 				cstcall(expp, S_MAX);
 			}
 			break;
@@ -1120,11 +1127,19 @@ ChkStandard(expp)
 
 			if (!warning_given) {
 				warning_given = 1;
+#ifndef STRICT_3RD_ED
+				if (! options['3'])
 	node_warning(expp, W_OLDFASHIONED, "NEW and DISPOSE are obsolete");
+				else
+#endif
+	node_error(expp, "NEW and DISPOSE are obsolete");
 			}
 		}
+#ifdef STRICT_3RD_ED
+		return 0;
+#else
 		expp->nd_type = 0;
-		if (! (left = getvariable(&arg, edf))) return 0;
+		if (! (left = getvariable(&arg, edf,D_DEFINED))) return 0;
 		if (! (left->nd_type->tp_fund == T_POINTER)) {
 			return df_error(left, "pointer variable expected", edf);
 		}
@@ -1150,6 +1165,7 @@ ChkStandard(expp)
 			expp->nd_left = MkLeaf(Name, &dt);
 		}
 		return ChkCall(expp);
+#endif
 
 	case S_TSIZE:	/* ??? */
 	case S_SIZE:
@@ -1197,7 +1213,7 @@ ChkStandard(expp)
 	case S_DEC:
 	case S_INC:
 		expp->nd_type = 0;
-		if (! (left = getvariable(&arg, edf))) return 0;
+		if (! (left = getvariable(&arg, edf, D_USED|D_DEFINED))) return 0;
 		if (! (left->nd_type->tp_fund & T_DISCRETE)) {
 			return df_error(left,"illegal parameter type", edf);
 		}
@@ -1217,7 +1233,7 @@ ChkStandard(expp)
 		t_node *dummy;
 
 		expp->nd_type = 0;
-		if (!(left = getvariable(&arg, edf))) return 0;
+		if (!(left = getvariable(&arg, edf, D_USED|D_DEFINED))) return 0;
 		tp = left->nd_type;
 		if (tp->tp_fund != T_SET) {
 			return df_error(arg, "SET parameter expected", edf);

lang/m2/comp/chk_expr.h

@@ -16,8 +16,9 @@ extern int	(*DesigChkTable[])();	/* table of designator checking
 					   functions, indexed by node class
 					*/
 
-#define	ChkExpression(expp)	((*ExprChkTable[(expp)->nd_class])(expp))
+#define	ChkExpression(expp)	((*ExprChkTable[(expp)->nd_class])(expp,D_USED))
-#define ChkDesignator(expp)	((*DesigChkTable[(expp)->nd_class])(expp))
+#define ChkDesignator(expp)	((*DesigChkTable[(expp)->nd_class])(expp,0))
+#define ChkDesig(expp, flags)	((*DesigChkTable[(expp)->nd_class])(expp,flags))
 
 #define inc_refcount(s)		(*((s) - 1) += 1)
 #define dec_refcount(s)		(*((s) - 1) -= 1)

lang/m2/comp/const.h

@@ -14,8 +14,6 @@ extern long
 extern int
 	mach_long_size;	/* size of long on this machine == sizeof(long) */
 extern arith
-	max_int,	/* maximum integer on target machine	*/
+	max_int;	/* maximum integer on target machine	*/
-	max_unsigned, 	/* maximum unsigned on target machine	*/
-	max_longint;	/* maximum longint on target machine	*/
 extern unsigned int
 	wrd_bits;	/* Number of bits in a word */

lang/m2/comp/cstoper.c

@@ -29,8 +29,6 @@ int mach_long_size;	/* size of long on this machine == sizeof(long) */
 long full_mask[MAXSIZE];/* full_mask[1] == 0xFF, full_mask[2] == 0xFFFF, .. */
 long int_mask[MAXSIZE];	/* int_mask[1] == 0x7F, int_mask[2] == 0x7FFF, .. */
 arith max_int;		/* maximum integer on target machine	*/
-arith max_unsigned;	/* maximum unsigned on target machine	*/
-arith max_longint;	/* maximum longint on target machine	*/
 unsigned int wrd_bits;	/* number of bits in a word */
 
 extern char options[];
@@ -52,10 +50,10 @@ cstunary(expp)
 	*/
 
 	case '-':
+		if (right->nd_INT < -int_mask[(int)(right->nd_type->tp_size)])
+			node_warning(expp, W_ORDINARY, ovflow);
+		
 		expp->nd_INT = -right->nd_INT;
-		if (expp->nd_type->tp_fund == T_INTORCARD) {
-			expp->nd_type = int_type;
-		}
 		break;
 
 	case NOT:
@@ -74,6 +72,62 @@ cstunary(expp)
 	expp->nd_right = 0;
 }
 
+STATIC
+divide(pdiv, prem, uns)
+	arith *pdiv, *prem;
+{
+	/*	Divide *pdiv by *prem, and store result in *pdiv,
+		remainder in *prem
+	*/
+	register arith o1 = *pdiv;
+	register arith o2 = *prem;
+
+	if (uns)	{
+		/*	this is more of a problem than you might
+			think on C compilers which do not have
+			unsigned long.
+		*/
+		if (o2 & mach_long_sign)	{/* o2 > max_long */
+			if (! (o1 >= 0 || o1 < o2)) {
+				/*	this is the unsigned test
+					o1 < o2 for o2 > max_long
+				*/
+				*prem = o2 - o1;
+				*pdiv = 1;
+			}
+			else {
+				*pdiv = 0;
+			}
+		}
+		else	{		/* o2 <= max_long */
+			long half, bit, hdiv, hrem, rem;
+
+			half = (o1 >> 1) & ~mach_long_sign;
+			bit = o1 & 01;
+			/*	now o1 == 2 * half + bit
+				and half <= max_long
+				and bit <= max_long
+			*/
+			hdiv = half / o2;
+			hrem = half % o2;
+			rem = 2 * hrem + bit;
+			*pdiv = 2*hdiv;
+			*prem = rem;
+			if (rem < 0 || rem >= o2) {
+				/*	that is the unsigned compare
+					rem >= o2 for o2 <= max_long
+				*/
+				*pdiv += 1;
+				*prem -= o2;
+			}
+		}
+	}
+	else {
+		*pdiv = o1 / o2;		/* ??? */
+		*prem = o1 - *pdiv * o2;
+	}
+}
+
 cstbin(expp)
 	register t_node *expp;
 {
@@ -81,8 +135,8 @@ cstbin(expp)
 		expressions below it, and the result restored in
 		expp.
 	*/
-	register arith o1 = expp->nd_left->nd_INT;
+	arith o1 = expp->nd_left->nd_INT;
-	register arith o2 = expp->nd_right->nd_INT;
+	arith o2 = expp->nd_right->nd_INT;
 	register int uns = expp->nd_left->nd_type != int_type;
 
 	assert(expp->nd_class == Oper);
@@ -99,37 +153,7 @@ cstbin(expp)
 			node_error(expp, "division by 0");
 			return;
 		}
-		if (uns)	{
+		divide(&o1, &o2, uns);
-			/*	this is more of a problem than you might
-				think on C compilers which do not have
-				unsigned long.
-			*/
-			if (o2 & mach_long_sign)	{/* o2 > max_long */
-				o1 = ! (o1 >= 0 || o1 < o2);
-				/*	this is the unsigned test
-					o1 < o2 for o2 > max_long
-				*/
-			}
-			else	{		/* o2 <= max_long */
-				long half, bit, hdiv, hrem, rem;
-
-				half = (o1 >> 1) & ~mach_long_sign;
-				bit = o1 & 01;
-				/*	now o1 == 2 * half + bit
-					and half <= max_long
-					and bit <= max_long
-				*/
-				hdiv = half / o2;
-				hrem = half % o2;
-				rem = 2 * hrem + bit;
-				o1 = 2 * hdiv + (rem < 0 || rem >= o2);
-				/*	that is the unsigned compare
-					rem >= o2 for o2 <= max_long
-				*/
-			}
-		}
-		else
-			o1 /= o2;
 		break;
 
 	case MOD:
@@ -137,29 +161,8 @@ cstbin(expp)
 			node_error(expp, "modulo by 0");
 			return;
 		}
-		if (uns)	{
+		divide(&o1, &o2, uns);
-			if (o2 & mach_long_sign)	{/* o2 > max_long */
+		o1 = o2;
-				o1 = (o1 >= 0 || o1 < o2) ? o1 : o1 - o2;
-				/*	this is the unsigned test
-					o1 < o2 for o2 > max_long
-				*/
-			}
-			else	{		/* o2 <= max_long */
-				long half, bit, hrem, rem;
-
-				half = (o1 >> 1) & ~mach_long_sign;
-				bit = o1 & 01;
-				/*	now o1 == 2 * half + bit
-					and half <= max_long
-					and bit <= max_long
-				*/
-				hrem = half % o2;
-				rem = 2 * hrem + bit;
-				o1 = (rem < 0 || rem >= o2) ? rem - o2 : rem;
-			}
-		}
-		else
-			o1 %= o2;
 		break;
 
 	case '+':
@@ -343,15 +346,15 @@ cstcall(expp, call)
 	/*	a standard procedure call is found that can be evaluated
 		compile time, so do so.
 	*/
-	register t_node *expr = 0;
+	register t_node *expr;
+	register t_type *tp;
 
 	assert(expp->nd_class == Call);
 
-	if (expp->nd_right) {
+	expr = expp->nd_right->nd_left;
-		expr = expp->nd_right->nd_left;
+	expp->nd_right->nd_left = 0;
-		expp->nd_right->nd_left = 0;
+	FreeNode(expp->nd_right);
-		FreeNode(expp->nd_right);
+	tp = expr->nd_type;
-	}
 
 	expp->nd_class = Value;
 	expp->nd_symb = INTEGER;
@@ -370,32 +373,25 @@ cstcall(expp, call)
 		break;
 
 	case S_MAX:
-		if (expp->nd_type == int_type) {
+		if (tp->tp_fund == T_INTEGER) {
-			expp->nd_INT = max_int;
+			expp->nd_INT = int_mask[(int)(tp->tp_size)];
 		}
-		else if (expp->nd_type == longint_type) {
+		else if (tp == card_type) {
-			expp->nd_INT = max_longint;
+			expp->nd_INT = full_mask[(int)(int_size)];
 		}
-		else if (expp->nd_type == card_type) {
+		else if (tp->tp_fund == T_SUBRANGE) {
-			expp->nd_INT = max_unsigned;
+			expp->nd_INT = tp->sub_ub;
 		}
-		else if (expp->nd_type->tp_fund == T_SUBRANGE) {
+		else	expp->nd_INT = tp->enm_ncst - 1;
-			expp->nd_INT = expp->nd_type->sub_ub;
-		}
-		else	expp->nd_INT = expp->nd_type->enm_ncst - 1;
 		break;
 
 	case S_MIN:
-		if (expp->nd_type == int_type) {
+		if (tp->tp_fund == T_INTEGER) {
-			expp->nd_INT = -max_int;
+			expp->nd_INT = -int_mask[(int)(tp->tp_size)];
 			if (! options['s']) expp->nd_INT--;
 		}
-		else if (expp->nd_type == longint_type) {
+		else if (tp->tp_fund == T_SUBRANGE) {
-			expp->nd_INT = - max_longint;
+			expp->nd_INT = tp->sub_lb;
-			if (! options['s']) expp->nd_INT--;
-		}
-		else if (expp->nd_type->tp_fund == T_SUBRANGE) {
-			expp->nd_INT = expp->nd_type->sub_lb;
 		}
 		else	expp->nd_INT = 0;
 		break;
@@ -405,7 +401,7 @@ cstcall(expp, call)
 		break;
 
 	case S_SIZE:
-		expp->nd_INT = expr->nd_type->tp_size;
+		expp->nd_INT = tp->tp_size;
 		break;
 
 	default:
@@ -466,8 +462,6 @@ InitCst()
 		fatal("sizeof (long) insufficient on this machine");
 	}
 
-	max_int = int_mask[int_size];
+	max_int = int_mask[(int)int_size];
-	max_unsigned = full_mask[int_size];
-	max_longint = int_mask[long_size];
 	wrd_bits = 8 * (unsigned) word_size;
 }

lang/m2/comp/declar.g

@@ -17,6 +17,7 @@
 #include	<alloc.h>
 #include	<assert.h>
 
+#include	"strict3rd.h"
 #include	"idf.h"
 #include	"LLlex.h"
 #include	"def.h"
@@ -336,8 +337,13 @@ FieldList(t_scope *scope; arith *cnt; int *palign;)
 	  |		/* Old fashioned! the first qualident now represents
 			   the type
 			*/
-			{ warning(W_OLDFASHIONED,
+			{
+#ifndef STRICT_3RD_ED
+			  if (! options['3']) warning(W_OLDFASHIONED,
 			      "old fashioned Modula-2 syntax; ':' missing");
+			  else
+#endif
+			  error("':' missing");
 			  tp = qualified_type(nd);
 			}
 	  ]

lang/m2/comp/def.c

@@ -73,6 +73,7 @@ MkDef(id, scope, kind)
 	df->df_scope = scope;
 	df->df_kind = kind;
 	df->df_next = id->id_def;
+	df->df_flags = D_USED | D_DEFINED;
 	id->id_def = df;
 	if (kind == D_ERROR || kind == D_FORWARD) df->df_type = error_type;
 
@@ -241,6 +242,7 @@ DeclProc(type, id)
 		*/
 		df = define(id, CurrentScope, type);
 		df->for_node = dot2leaf(Name);
+		df->df_flags |= D_USED | D_DEFINED;
 		if (CurrentScope->sc_definedby->df_flags & D_FOREIGN) {
 			df->for_name = id->id_text;
 		}
@@ -275,6 +277,7 @@ DeclProc(type, id)
 				C_exp(buf);
 			}
 			else	C_inp(buf);
+			df->df_flags |= D_DEFINED;
 		}
 		open_scope(OPENSCOPE);
 		scope = CurrentScope;
@@ -360,11 +363,12 @@ CheckWithDef(df, tp)
 		possible earlier definition in the definition module.
 	*/
 
-	if (df->df_kind == D_PROCHEAD && df->df_type != error_type) {
+	if (df->df_kind == D_PROCHEAD &&
+	    df->df_type &&
+	    df->df_type != error_type) {
 		/* We already saw a definition of this type
 		   in the definition module.
 		*/
-		assert(df->df_type != 0);
 
 	  	if (!TstProcEquiv(tp, df->df_type)) {
 			error("inconsistent procedure declaration for \"%s\"",

lang/m2/comp/enter.c

@@ -129,6 +129,7 @@ EnterVarList(Idlist, type, local)
 	for (; idlist; idlist = idlist->nd_right) {
 		df = define(idlist->nd_IDF, CurrentScope, D_VARIABLE);
 		df->df_type = type;
+		df->df_flags &= ~(D_USED | D_DEFINED);
 		if (idlist->nd_left) {
 			/* An address was supplied
 			*/
@@ -166,6 +167,7 @@ EnterVarList(Idlist, type, local)
 			df->df_flags |= D_NOREG;
 
  			if (DefinitionModule) {
+				df->df_flags |= D_USED | D_DEFINED;
 				if (sc == Defined->mod_vis) {
 					C_exa_dnam(df->var_name);
 				}
@@ -212,7 +214,8 @@ EnterParamList(ppr, Idlist, type, VARp, off)
 		else	df = new_def();
 		pr->par_def = df;
 		df->df_type = type;
-		df->df_flags = VARp;
+		df->df_flags |= (VARp | D_DEFINED);
+		if (df->df_flags & D_VARPAR) df->df_flags |= D_USED;
 
 		if (IsConformantArray(type)) {
 			/* we need room for the base address and a descriptor
@@ -240,6 +243,10 @@ DoImport(df, scope)
 
 	define(df->df_idf, scope, D_IMPORT)->imp_def = df;
 
+	while (df->df_kind == D_IMPORT) {
+		df = df->imp_def;
+	}
+
 	if (df->df_kind == D_TYPE && df->df_type->tp_fund == T_ENUMERATION) {
 		/* Also import all enumeration literals
 		*/
@@ -305,7 +312,7 @@ ForwDef(ids, scope)
 	*/
 	register t_def *df;
 
-	if (!(df = lookup(ids->nd_IDF, scope, 1))) {
+	if (!(df = lookup(ids->nd_IDF, scope, 0))) {
 		df = define(ids->nd_IDF, scope, D_FORWARD);
 		df->for_node = MkLeaf(Name, &(ids->nd_token));
 	}
@@ -341,8 +348,6 @@ EnterExportList(Idlist, qualified)
 				idlist->nd_IDF->id_text);
 		}
 
-		if (df->df_kind == D_IMPORT) df = df->imp_def;
-
 		df->df_flags |= qualified;
 		if (qualified == D_EXPORTED) {
 			/* Export, but not qualified.
@@ -368,15 +373,20 @@ EnterExportList(Idlist, qualified)
 				   scope. There are two legal possibilities,
 				   which are examined below.
 				*/
+				t_def *df2 = df;
+
+				while (df2->df_kind == D_IMPORT) {
+					df2 = df2->imp_def;
+				}
 				if (df1->df_kind == D_PROCHEAD &&
-				     df->df_kind == D_PROCEDURE) {
+				     df2->df_kind == D_PROCEDURE) {
 					df1->df_kind = D_IMPORT;
 					df1->imp_def = df;
 					continue;
 				}
 				if (df1->df_kind == D_HIDDEN &&
-				    df->df_kind == D_TYPE) {
+				    df2->df_kind == D_TYPE) {
-					DeclareType(idlist, df1, df->df_type);
+					DeclareType(idlist, df1, df2->df_type);
 					df1->df_kind = D_TYPE;
 					continue;
 				}
@@ -388,14 +398,13 @@ EnterExportList(Idlist, qualified)
 	FreeNode(Idlist);
 }
 
-EnterFromImportList(Idlist, FromDef, FromId)
+EnterFromImportList(idlist, FromDef, FromId)
-	t_node *Idlist;
+	register t_node *idlist;
 	register t_def *FromDef;
 	t_node *FromId;
 {
 	/*	Import the list Idlist from the module indicated by Fromdef.
 	*/
-	register t_node *idlist = Idlist;
 	register t_scopelist *vis;
 	register t_def *df;
 	char *module_name = FromDef->df_idf->id_text;
@@ -430,7 +439,7 @@ node_error(FromId,"identifier \"%s\" does not represent a module",module_name);
 
 	for (; idlist; idlist = idlist->nd_left) {
 		if (forwflag) df = ForwDef(idlist, vis->sc_scope);
-		else if (! (df = lookup(idlist->nd_IDF, vis->sc_scope, 1))) {
+		else if (! (df = lookup(idlist->nd_IDF, vis->sc_scope, 0))) {
 			if (! is_anon_idf(idlist->nd_IDF)) {
 				node_error(idlist,
 			"identifier \"%s\" not declared in module \"%s\"",
@@ -450,30 +459,38 @@ node_error(FromId,"identifier \"%s\" does not represent a module",module_name);
 	}
 
 	if (!forwflag) FreeNode(FromId);
-	FreeNode(Idlist);
 }
 
-EnterImportList(Idlist, local)
+EnterGlobalImportList(idlist)
-	t_node *Idlist;
+	register t_node *idlist;
 {
-	/*	Import "Idlist" from the enclosing scope.
+	/*	Import "idlist" from the enclosing scope.
-		An exception must be made for imports of the compilation unit.
+		Definition modules must be read for "idlist".
-		In this case, definition modules must be read for "Idlist".
-		This case is indicated by the value 0 of the "local" flag.
 	*/
-	register t_node *idlist = Idlist;
-	t_scope *sc = enclosing(CurrVis)->sc_scope;
 	extern t_def *GetDefinitionModule();
 	struct f_info f;
 	
 	f = file_info;
 
 	for (; idlist; idlist = idlist->nd_left) {
-		DoImport(local ?
+		DoImport(GetDefinitionModule(idlist->nd_IDF, 1), CurrentScope);
-				ForwDef(idlist, sc) :
-				GetDefinitionModule(idlist->nd_IDF, 1) ,
-			 CurrentScope);
 		file_info = f;
 	}
-	FreeNode(Idlist);
+}
+
+EnterImportList(idlist)
+	register t_node *idlist;
+{
+	/*	Import "idlist" from the enclosing scope.
+	*/
+	t_scope *sc = enclosing(CurrVis)->sc_scope;
+	extern t_def *GetDefinitionModule();
+
+	for (; idlist; idlist = idlist->nd_left) {
+		t_def *df;
+
+		DoImport(ForwDef(idlist, sc), CurrentScope);
+		df = lookup(idlist->nd_def, CurrentScope, 0);
+		df->df_flags |= D_EXPORTED;
+	}
 }

lang/m2/comp/error.c

@@ -21,6 +21,7 @@
 #include	<em_arith.h>
 #include	<em_label.h>
 
+#include	"strict3rd.h"
 #include	"input.h"
 #include	"f_info.h"
 #include	"LLlex.h"
@@ -170,9 +171,11 @@ _error(class, node, fmt, argv)
 	case WARNING:
 	case LEXWARNING:
 		switch(warn_class) {
+#ifndef STRICT_3RD_ED
 		case W_OLDFASHIONED:
 			remark = "(old-fashioned use)";
 			break;
+#endif
 		case W_STRICT:
 			remark = "(strict)";
 			break;

lang/m2/comp/main.c

@@ -16,6 +16,7 @@
 #include	<em_label.h>
 #include	<alloc.h>
 
+#include	"strict3rd.h"
 #include	"input.h"
 #include	"f_info.h"
 #include	"idf.h"

lang/m2/comp/options.c

@@ -15,6 +15,7 @@
 #include	<em_label.h>
 #include	<alloc.h>
 
+#include	"strict3rd.h"
 #include	"type.h"
 #include	"main.h"
 #include	"warning.h"
@@ -44,6 +45,9 @@ DoOption(text)
 	case 'n':	/* no register messages */
 	case 'x':	/* every name global */
 	case 's':	/* symmetric: MIN(INTEGER) = -MAX(INTEGER) */
+#ifndef STRICT_3RD_ED
+	case '3':	/* strict 3rd edition Modula-2 */
+#endif
 		options[text[-1]]++;
 		break;
 
@@ -64,9 +68,11 @@ DoOption(text)
 		if (*text) {
 			while (*text) {
 				switch(*text++) {
+#ifndef STRICT_3RD_ED
 				case 'O':
 					warning_classes &= ~W_OLDFASHIONED;
 					break;
+#endif
 				case 'R':
 					warning_classes &= ~W_STRICT;
 					break;
@@ -83,9 +89,11 @@ DoOption(text)
 		if (*text) {
 			while (*text) {
 				switch(*text++) {
+#ifndef STRICT_3RD_ED
 				case 'O':
 					warning_classes |= W_OLDFASHIONED;
 					break;
+#endif
 				case 'R':
 					warning_classes |= W_STRICT;
 					break;

lang/m2/comp/program.g

@@ -16,6 +16,7 @@
 #include	<em_arith.h>
 #include	<em_label.h>
 
+#include	"strict3rd.h"
 #include	"main.h"
 #include	"idf.h"
 #include	"LLlex.h"
@@ -114,7 +115,9 @@ import(int local;)
 			{ if (FromId) {
 				EnterFromImportList(ImportList, df, FromId);
 			  }
-			  else EnterImportList(ImportList, local);
+			  else if (local) EnterImportList(ImportList);
+			  else EnterGlobalImportList(ImportList);
+			  FreeNode(ImportList);
 			}
 ;
 
@@ -150,8 +153,13 @@ DefinitionModule
 			modules. Issue a warning.
 		*/
 			{ 
+#ifndef STRICT_3RD_ED
+			  if (! options['3'])
 node_warning(exportlist, W_OLDFASHIONED, "export list in definition module ignored");
-				FreeNode(exportlist);
+			  else
+#endif
+				error("export list not allowed in definition module");
+			  FreeNode(exportlist);
 			}
 	|
 		/* empty */

lang/m2/comp/scope.C

@@ -217,6 +217,10 @@ close_scope(flag)
 
 	assert(sc != 0);
 
+	if (! sc->sc_end) {
+		sc->sc_end = dot2leaf(Link);
+	}
+
 	if (flag) {
 		DO_DEBUG(options['S'],(print("List of definitions in currently ended scope:\n"), DumpScope(sc->sc_def)));
 		if (flag & SC_CHKPROC) chk_proc(sc->sc_def);

lang/m2/comp/scope.h

@@ -30,6 +30,7 @@ struct scope {
 	char sc_scopeclosed;	/* flag indicating closed or open scope */
 	int sc_level;		/* level of this scope */
 	struct def *sc_definedby; /* The def structure defining this scope */
+	struct node *sc_end;	/* node to remember line number of end of scope */
 };
 
 struct scopelist {

lang/m2/comp/type.c

@@ -611,7 +611,7 @@ type_or_forward(ptp)
 		   in this scope, so this is the correct identification
 		*/
 		if (df1->df_kind == D_FORWTYPE) {
-			nd = dot2node(NULLNODE, df1->df_forw_node, 0);
+			nd = dot2node(0, NULLNODE, df1->df_forw_node);
 			df1->df_forw_node = nd;
 			nd->nd_type = *ptp;
 		}

lang/m2/comp/typequiv.c

@@ -18,12 +18,14 @@
 #include	<em_label.h>
 #include	<assert.h>
 
+#include	"strict3rd.h"
 #include	"type.h"
 #include	"LLlex.h"
 #include	"idf.h"
 #include	"def.h"
 #include	"node.h"
 #include	"warning.h"
+#include	"main.h"
 
 extern char *sprint();
 
@@ -239,7 +241,8 @@ TstParCompat(parno, formaltype, VARflag, nd, edf)
 		)
 	)
 		return 1;
-	if (VARflag && TstCompat(formaltype, actualtype)) {
+#ifndef STRICT_3RD_ED
+	if (! options['3'] && VARflag && TstCompat(formaltype, actualtype)) {
 		if (formaltype->tp_size == actualtype->tp_size) {
 			sprint(ebuf1, ebuf, "identical types required");
 			node_warning(*nd,
@@ -251,7 +254,7 @@ TstParCompat(parno, formaltype, VARflag, nd, edf)
 		node_error(*nd, ebuf1);
 		return 0;
 	}
-				
+#endif
 	sprint(ebuf1, ebuf, "type incompatibility");
 	node_error(*nd, ebuf1);
 	return 0;

lang/m2/comp/walk.c

@@ -23,6 +23,7 @@
 #include	<assert.h>
 #include	<alloc.h>
 
+#include	"strict3rd.h"
 #include	"squeeze.h"
 #include	"LLlex.h"
 #include	"def.h"
@@ -40,14 +41,22 @@
 
 extern arith		NewPtr();
 extern arith		NewInt();
+
 extern int		proclevel;
+
 label			text_label;
 label			data_label = 1;
-static t_type		*func_type;
 struct withdesig	*WithDesigs;
-t_node		*Modules;
+t_node			*Modules;
+
+static t_type		*func_type;
 static arith		priority;
 
+static int		RegisterMessage();
+static int		WalkDef();
+static int		MkCalls();
+static int		UseWarnings();
+
 #define	NO_EXIT_LABEL	((label) 0)
 #define RETURN_LABEL	((label) 1)
 
@@ -119,7 +128,7 @@ WalkModule(module)
 
 	/* Walk through it's local definitions
 	*/
-	WalkDef(sc->sc_def);
+	WalkDefList(sc->sc_def, WalkDef);
 
 	/* Now, generate initialization code for this module.
 	   First call initialization routines for modules defined within
@@ -156,7 +165,7 @@ WalkModule(module)
 			C_cal(nd->nd_IDF->id_text);
 		}
 	}
-	MkCalls(sc->sc_def);
+	WalkDefList(sc->sc_def, MkCalls);
 	proclevel++;
 	WalkNode(module->mod_body, NO_EXIT_LABEL);
 	DO_DEBUG(options['X'], PrNode(module->mod_body, 0));
@@ -168,6 +177,7 @@ WalkModule(module)
 	TmpClose();
 
 	CurrVis = savevis;
+	WalkDefList(sc->sc_def, UseWarnings);
 }
 
 WalkProcedure(procedure)
@@ -190,7 +200,7 @@ WalkProcedure(procedure)
 
 	/* Generate code for all local modules and procedures
 	*/
-	WalkDef(sc->sc_def);
+	WalkDefList(sc->sc_def, WalkDef);
 
 	/* Generate code for this procedure
 	*/
@@ -221,7 +231,7 @@ WalkProcedure(procedure)
 	/* Generate calls to initialization routines of modules defined within
 	   this procedure
 	*/
-	MkCalls(sc->sc_def);
+	WalkDefList(sc->sc_def, MkCalls);
 
 	/* Make sure that arguments of size < word_size are on a
 	   fixed place.
@@ -327,54 +337,53 @@ WalkProcedure(procedure)
 	}
 	EndPriority();
 	C_ret(func_res_size);
-	if (! options['n']) RegisterMessages(sc->sc_def);
+	if (! options['n']) WalkDefList(sc->sc_def, RegisterMessage);
 	C_end(-sc->sc_off);
 	TmpClose();
 	CurrVis = savevis;
 	proclevel--;
+	WalkDefList(sc->sc_def, UseWarnings);
 }
 
+static int
 WalkDef(df)
 	register t_def *df;
 {
 	/*	Walk through a list of definitions
 	*/
 
-	for ( ; df; df = df->df_nextinscope) {
+	switch(df->df_kind) {
-		switch(df->df_kind) {
+	case D_MODULE:
-		case D_MODULE:
+		WalkModule(df);
-			WalkModule(df);
+		break;
-			break;
+	case D_PROCEDURE:
-		case D_PROCEDURE:
+		WalkProcedure(df);
-			WalkProcedure(df);
+		break;
-			break;
+	case D_VARIABLE:
-		case D_VARIABLE:
+		if (!proclevel  && !(df->df_flags & D_ADDRGIVEN)) {
-			if (!proclevel  && !(df->df_flags & D_ADDRGIVEN)) {
+			C_df_dnam(df->var_name);
-				C_df_dnam(df->var_name);
+			C_bss_cst(
-				C_bss_cst(
+				WA(df->df_type->tp_size),
-					WA(df->df_type->tp_size),
+				(arith) 0, 0);
-					(arith) 0, 0);
-			}
-			break;
-		default:
-			/* nothing */
-			;
 		}
+		break;
+	default:
+		/* nothing */
+		;
 	}
 }
 
+static int
 MkCalls(df)
 	register t_def *df;
 {
 	/*	Generate calls to initialization routines of modules
 	*/
 
-	for ( ; df; df = df->df_nextinscope) {
+	if (df->df_kind == D_MODULE) {
-		if (df->df_kind == D_MODULE) {
+		C_lxl((arith) 0);
-			C_lxl((arith) 0);
+		C_cal(df->mod_vis->sc_scope->sc_name);
-			C_cal(df->mod_vis->sc_scope->sc_name);
+		C_asp(pointer_size);
-			C_asp(pointer_size);
-		}
 	}
 }
 
@@ -579,7 +588,7 @@ WalkStat(nd, exit_label)
 			struct withdesig wds;
 			t_desig ds;
 
-			if (! WalkDesignator(left, &ds)) break;
+			if (! WalkDesignator(left, &ds, D_USED|D_DEFINED)) break;
 			if (left->nd_type->tp_fund != T_RECORD) {
 				node_error(left, "record variable expected");
 				break;
@@ -686,14 +695,14 @@ ExpectBool(nd, true_label, false_label)
 }
 
 int
-WalkDesignator(nd, ds)
+WalkDesignator(nd, ds, flags)
 	t_node *nd;
 	t_desig *ds;
 {
 	/*	Check designator and generate code for it
 	*/
 
-	if (! ChkVariable(nd)) return 0;
+	if (! ChkVariable(nd, flags)) return 0;
 
 	clear((char *) ds, sizeof(t_desig));
 	CodeDesig(nd, ds);
@@ -711,7 +720,7 @@ DoForInit(nd)
 	nd->nd_class = Name;
 	nd->nd_symb = IDENT;
 
-	if (!( ChkVariable(nd) &
+	if (!( ChkVariable(nd, D_USED|D_DEFINED) &
 	       ChkExpression(left->nd_left) &
 	       ChkExpression(left->nd_right))) return 0;
 
@@ -749,13 +758,22 @@ DoForInit(nd)
 
 	tpl = left->nd_left->nd_type;
 	tpr = left->nd_right->nd_type;
-	if (!ChkAssCompat(&(left->nd_left), df->df_type, "FOR statement") ||
+#ifndef STRICT_3RD_ED
-	    !ChkAssCompat(&(left->nd_right), BaseType(df->df_type), "FOR statement")) {
+	if (! options['3']) {
+	  if (!ChkAssCompat(&(left->nd_left), df->df_type, "FOR statement") ||
+	      !ChkAssCompat(&(left->nd_right), BaseType(df->df_type), "FOR statement")) {
 		return 1;
-	}
+	  }
-	if (!TstCompat(df->df_type, tpl) ||
+	  if (!TstCompat(df->df_type, tpl) ||
-	    !TstCompat(df->df_type, tpr)) {
+	      !TstCompat(df->df_type, tpr)) {
 node_warning(nd, W_OLDFASHIONED, "compatibility required in FOR statement");
+		node_error(nd, "compatibility required in FOR statement");
+	  }
+	} else
+#endif
+	if (!ChkCompat(&(left->nd_left), df->df_type, "FOR statement") ||
+	    !ChkCompat(&(left->nd_right), BaseType(df->df_type), "FOR statement")) {
+		return 1;
 	}
 
 	CodePExpr(left->nd_left);
@@ -774,7 +792,7 @@ DoAssign(left, right)
 	register t_desig *dsr;
 	register t_type *tp;
 
-	if (! (ChkExpression(right) & ChkVariable(left))) return;
+	if (! (ChkExpression(right) & ChkVariable(left, D_DEFINED))) return;
 	tp = left->nd_type;
 
 	if (right->nd_symb == STRING) TryToString(right, tp);
@@ -798,20 +816,22 @@ DoAssign(left, right)
 	free_desig(dsr);
 }
 
-RegisterMessages(df)
+static int
+RegisterMessage(df)
 	register t_def *df;
 {
 	register t_type *tp;
 	arith sz;
-	int regtype = -1;
+	int regtype;
 
-	for (; df; df = df->df_nextinscope) {
+	if (df->df_kind == D_VARIABLE) {
-		if (df->df_kind == D_VARIABLE && !(df->df_flags & D_NOREG)) {
+		if ( !(df->df_flags & D_NOREG)) {
 			/* Examine type and size
 			*/
+			regtype = -1;
 			tp = BaseType(df->df_type);
 			if ((df->df_flags & D_VARPAR) ||
-				 (tp->tp_fund & (T_POINTER|T_HIDDEN|T_EQUAL))) {
+			    (tp->tp_fund&(T_POINTER|T_HIDDEN|T_EQUAL))) {
 				sz = pointer_size;
 				regtype = reg_pointer;
 			}
@@ -826,3 +846,38 @@ RegisterMessages(df)
 		}
 	}
 }
+
+static int
+UseWarnings(df)
+	register t_def *df;
+{
+	if (df->df_kind & (D_IMPORT | D_VARIABLE | D_PROCEDURE)) {
+		struct node *nd;
+
+		if (df->df_flags & (D_EXPORTED | D_QEXPORTED)) return;
+		if (df->df_kind == D_IMPORT) df = df->imp_def;
+		if (! (df->df_kind & (D_VARIABLE|D_PROCEDURE))) return;
+		nd = df->df_scope->sc_end;
+		if (! (df->df_flags & D_DEFINED)) {
+			node_warning(nd,
+				     W_ORDINARY,
+				     "identifier \"%s\" never assigned",
+				     df->df_idf->id_text);
+		}
+		if (! (df->df_flags & D_USED)) {
+			node_warning(nd,
+				     W_ORDINARY,
+				     "identifier \"%s\" never used",
+				     df->df_idf->id_text);
+		}
+	}
+}
+
+WalkDefList(df, proc)
+	register t_def *df;
+	int (*proc)();
+{
+	for (; df; df = df->df_nextinscope) {
+		(*proc)(df);
+	}
+}