New version with different parameter passing mechanism and some

minor fixes

lang/m2/comp/LLlex.c

@@ -152,9 +152,11 @@ GetString(upto)
 		}
 	}
 	str->s_length = p - str->s_str;
-	*p = '\0';
+	len = (str->s_length+(int)word_size) & ~((int)word_size-1);
-	str->s_str = Realloc(str->s_str,
+	while (p - str->s_str < len) {
-	  (unsigned)((str->s_length+(int)word_size) & ~((int)word_size-1)));
+		*p++ = '\0';
+	}
+	str->s_str = Realloc(str->s_str, (unsigned) len);
 	if (str->s_length == 0) str->s_length = 1;
 	/* ??? string length at least 1 ??? */
 	return str;

lang/m2/comp/Version.c

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

lang/m2/comp/casestat.C

@@ -77,7 +77,8 @@ compact(nr, low, up)
 		diff / nr <= (DENSITY - 1));
 }
 
-CaseCode(nd, exitlabel)
+int
+CaseCode(nd, exitlabel, end_reached)
 	t_node *nd;
 	label exitlabel;
 {
@@ -91,6 +92,7 @@ CaseCode(nd, exitlabel)
 	register struct case_entry *ce;
 	register arith val;
 	label CaseDescrLab;
+	int rval;
 
 	assert(pnode->nd_class == Stat && pnode->nd_symb == CASE);
 
@@ -109,15 +111,12 @@ CaseCode(nd, exitlabel)
 				/* non-empty case
 				*/
 				pnode->nd_lab = ++text_label;
-				if (! AddCases(sh, /* to descriptor */
+				AddCases(sh, /* to descriptor */
-					       pnode->nd_left->nd_left,
+					 pnode->nd_left->nd_left,
-						   /* of case labels */
+					     /* of case labels */
-					       pnode->nd_lab
+					 pnode->nd_lab
-						   /* and code label */
+					     /* and code label */
-					      )) {
+					      );
-					FreeSh(sh);
-					return;
-				}
 			}
 		}
 		else {
@@ -135,8 +134,6 @@ CaseCode(nd, exitlabel)
 		*/
 		if (! (sh->sh_type->tp_fund & T_DISCRETE)) {
 			node_error(nd, "illegal type in CASE-expression");
-			FreeSh(sh);
-			return;
 		}
 	}
 
@@ -184,12 +181,13 @@ CaseCode(nd, exitlabel)
 	/* Now generate code for the cases
 	*/
 	pnode = nd;
+	rval = 0;
 	while (pnode = pnode->nd_right) {
 		if (pnode->nd_class == Link && pnode->nd_symb == '|') {
 			if (pnode->nd_left) {
-				LblWalkNode(pnode->nd_lab,
+				rval |= LblWalkNode(pnode->nd_lab,
 					    pnode->nd_left->nd_right,
-					    exitlabel);
+					    exitlabel, end_reached);
 				C_bra(sh->sh_break);
 			}
 		}
@@ -198,13 +196,15 @@ CaseCode(nd, exitlabel)
 			*/
 			assert(sh->sh_default != 0);
 
-			LblWalkNode(sh->sh_default, pnode, exitlabel);
+			rval |= LblWalkNode(sh->sh_default,
+					pnode, exitlabel, end_reached);
 			break;
 		}
 	}
 
 	def_ilb(sh->sh_break);
 	FreeSh(sh);
+	return rval;
 }
 
 FreeSh(sh)
@@ -241,22 +241,23 @@ AddCases(sh, node, lbl)
 			node->nd_type = node->nd_left->nd_type;
 			node->nd_INT = node->nd_left->nd_INT;
 			for (;;) {
-				if (! AddOneCase(sh, node, lbl)) return 0;
+				AddOneCase(sh, node, lbl);
 			        if (node->nd_INT == node->nd_right->nd_INT) {
 					break;
 				}
 			     	node->nd_INT++;
 			}
-			return 1;
+			return;
 		}
 
 		assert(node->nd_symb == ',');
-		return	AddCases(sh, node->nd_left, lbl) &&
+		AddCases(sh, node->nd_left, lbl);
-		    	AddCases(sh, node->nd_right, lbl);
+		AddCases(sh, node->nd_right, lbl);
+		return;
 	}
 
 	assert(node->nd_class == Value);
-	return AddOneCase(sh, node, lbl);
+	AddOneCase(sh, node, lbl);
 }
 
 AddOneCase(sh, node, lbl)
@@ -271,8 +272,6 @@ AddOneCase(sh, node, lbl)
 	ce->ce_label = lbl;
 	ce->ce_value = node->nd_INT;
 	if (! ChkCompat(&node, sh->sh_type, "case")) {
-		free_case_entry(ce);
-		return 0;
 	}
 	if (sh->sh_entries == 0)	{
 		/* first case entry
@@ -311,7 +310,6 @@ AddOneCase(sh, node, lbl)
 			if (c1->ce_value == ce->ce_value)	{
 node_error(node, "multiple case entry for value %ld", ce->ce_value);
 				free_case_entry(ce);
-				return 0;
 			}
 			if (c2)	{
 				ce->ce_next = c2->ce_next;
@@ -330,5 +328,4 @@ node_error(node, "multiple case entry for value %ld", ce->ce_value);
 		}
 		(sh->sh_nrofentries)++;
 	}
-	return 1;
 }

lang/m2/comp/chk_expr.c

@@ -207,23 +207,24 @@ ChkArr(expp, flags)
 			    "index type");
 }
 
-#ifdef DEBUG
+/*ARGSUSED*/
 STATIC int
 ChkValue(expp)
 	t_node *expp;
 {
+#ifdef DEBUG
 	switch(expp->nd_symb) {
 	case REAL:
 	case STRING:
 	case INTEGER:
-		return 1;
+		break;
 
 	default:
 		crash("(ChkValue)");
 	}
-	/*NOTREACHED*/
-}
 #endif
+	return 1;
+}
 
 STATIC int
 ChkLinkOrName(expp, flags)
@@ -430,7 +431,6 @@ MkSet(size)
 {
 	register arith	*s;
 
-	size = (size / (int) word_size + 1) * sizeof(arith);
 	s = (arith *) Malloc(size);
 	clear((char *) s , size);
 	s++;
@@ -492,7 +492,7 @@ ChkSet(expp)
 	   First allocate room for the set.
 	*/
 
-	expp->nd_set = MkSet((unsigned)(tp->tp_size));
+	expp->nd_set = MkSet(tp->set_sz);
 
 	/* Now check the elements, one by one
 	*/
@@ -1163,7 +1163,7 @@ ChkStandard(expp)
 		}
 		left = getvariable(&arg,
 			edf,
-			edf->df_value.df_stdname == S_NEW ? D_DEFINED : D_USED);
+			D_USED|D_DEFINED);
 		expp->nd_type = 0;
 		if (! left) return 0;
 		if (! (left->nd_type->tp_fund == T_POINTER)) {
@@ -1395,19 +1395,17 @@ no_desig(expp)
 }
 
 STATIC int
-done_before()
+add_flags(expp, flags)
+	t_node *expp;
 {
+	expp->nd_def->df_flags |= flags;
 	return 1;
 }
 
 extern int	NodeCrash();
 
 int (*ExprChkTable[])() = {
-#ifdef DEBUG
 	ChkValue,
-#else
-	done_before,
-#endif
 	ChkArr,
 	ChkBinOper,
 	ChkUnOper,
@@ -1416,7 +1414,7 @@ int (*ExprChkTable[])() = {
 	ChkExLinkOrName,
 	NodeCrash,
 	ChkSet,
-	done_before,
+	add_flags,
 	NodeCrash,
 	ChkExLinkOrName,
 };
@@ -1431,7 +1429,7 @@ int (*DesigChkTable[])() = {
 	ChkLinkOrName,
 	NodeCrash,
 	no_desig,
-	done_before,
+	add_flags,
 	NodeCrash,
 	ChkLinkOrName,
 };

lang/m2/comp/code.c

@@ -417,6 +417,8 @@ CodeParameters(param, arg)
 			C_loc(left_type->arr_high - left_type->arr_low);
 		}
 		c_loc(0);
+	}
+	if (IsConformantArray(tp) || IsVarParam(param) || IsBigParamTp(tp)) {
 		if (left->nd_symb == STRING) {
 			CodeString(left);
 		}
@@ -438,10 +440,6 @@ CodeParameters(param, arg)
 		}
 		return;
 	}
-	if (IsVarParam(param)) {
-		CodeDAddress(left, 1);
-		return;
-	}
 	if (left_type->tp_fund == T_STRING) {
 		CodePString(left, tp);
 		return;

lang/m2/comp/cstoper.c

@@ -371,6 +371,10 @@ cstset(expp)
 	setsize = (unsigned) (expp->nd_right->nd_type->tp_size) / (unsigned) word_size;
 
 	if (expp->nd_symb == IN) {
+		/*	The setsize must fit in an unsigned, as it is
+			allocated with Malloc, so we can do the arithmetic
+			in an unsigned too.
+		*/
 		unsigned i;
 
 		assert(expp->nd_left->nd_class == Value);
@@ -378,6 +382,10 @@ cstset(expp)
 		expp->nd_left->nd_INT -= expp->nd_right->nd_type->set_low;
 		i = expp->nd_left->nd_INT;
 		expp->nd_class = Value;
+		/*	Careful here; use expp->nd_left->nd_INT to see if
+			it falls in the range of the set. Do not use i
+			for this, as i may be truncated.
+		*/
 		expp->nd_INT = (expp->nd_left->nd_INT >= 0 &&
 				expp->nd_left->nd_INT < setsize * wrd_bits &&
 		    (set2[i / wrd_bits] & (1 << (i % wrd_bits))));
@@ -393,7 +401,7 @@ cstset(expp)
 	case '-': /* Set difference */
 	case '*': /* Set intersection */
 	case '/': /* Symmetric set difference */
-		expp->nd_set = resultset = MkSet(setsize * (unsigned) word_size);
+		expp->nd_set = resultset = MkSet(expp->nd_type->set_sz);
 		for (j = 0; j < setsize; j++) {
 			switch(expp->nd_symb) {
 			case '+':

lang/m2/comp/declar.g

@@ -402,7 +402,7 @@ CaseLabels(t_type **ptp; register t_node **pnd;)
 			{ 
 			  if (*ptp != 0) {
 				t_type *tp = intorcard(*ptp,
-					BaseType((*pnd)->nd_type), 0);
+					BaseType((*pnd)->nd_type));
 				if (tp) *ptp = tp;
 				ChkCompat(pnd, *ptp, "case label");
 			  }

lang/m2/comp/desig.H

@@ -55,6 +55,7 @@ typedef struct desig	t_desig;
 
 struct withdesig {
 	struct withdesig *w_next;
+	int w_flags;		/* D_USED|D_DEFINED */
 	struct scope *w_scope;	/* scope in which fields of this record
 				   reside
 				*/

lang/m2/comp/desig.c

@@ -514,6 +514,7 @@ CodeFieldDesig(df, ds)
 		/* Found it. Now, act like it was a selection.
 		*/
 		*ds = wds->w_desig;
+		wds->w_flags |= df->df_flags;
 		assert(ds->dsg_kind == DSG_PFIXED);
 	}
 
@@ -583,10 +584,11 @@ CodeVarDesig(df, ds)
 			*/
 			C_lxa((arith) difflevel);
 			if ((df->df_flags & D_VARPAR) ||
+			    IsBigParamTp(df->df_type) ||
 			    IsConformantArray(df->df_type)) {
-				/* var parameter or conformant array.
+				/* var parameter, big parameter,
-				   For conformant array's, the address is
+				   or conformant array.
-				   passed.
+				   The address is passed.
 				*/
 				C_adp(df->var_off);
 				C_loi(pointer_size);
@@ -603,7 +605,9 @@ CodeVarDesig(df, ds)
 
 	/* Now, finally, we have a local variable or a local parameter
 	*/
-	if ((df->df_flags & D_VARPAR) || IsConformantArray(df->df_type)) {
+	if ((df->df_flags & D_VARPAR) ||
+	    ((df->df_flags & D_VALPAR) && IsBigParamTp(df->df_type)) ||
+	    IsConformantArray(df->df_type)) {
 		/* a var parameter; address directly accessible.
 		*/
 		ds->dsg_kind = DSG_PFIXED;

lang/m2/comp/enter.c

@@ -222,7 +222,7 @@ EnterParamList(ppr, Idlist, type, VARp, off)
 			*/
 			*off += pointer_size + word_size + dword_size;
 		}
-		else if (VARp == D_VARPAR) {
+		else if (VARp == D_VARPAR || IsBigParamTp(type)) {
 			*off += pointer_size;
 		}
 		else {

lang/m2/comp/main.c

@@ -53,7 +53,7 @@ main(argc, argv)
 	register char **Nargv = &argv[0];
 
 	ProgName = *argv++;
-	DEFPATH = (char **) Malloc(mDEF * sizeof(char *));
+	DEFPATH = (char **) Malloc((unsigned)mDEF * sizeof(char *));
 
 	while (--argc > 0) {
 		if (**argv == '-')

lang/m2/comp/type.H

@@ -64,14 +64,16 @@ struct record {
 
 struct proc {
 	struct paramlist *pr_params;
-	arith pr_nbpar;
+	arith pr_nbpar;		/* number of bytes parameters accessed */
 #define prc_params	tp_value.tp_proc.pr_params
 #define prc_nbpar	tp_value.tp_proc.pr_nbpar
 };
 
 struct set {
-	arith st_low;
+	arith st_low;		/* lowerbound of subrange type of set */
+	unsigned st_sz;		/* size of constant set in compiler */
 #define set_low		tp_value.tp_set.st_low
+#define set_sz		tp_value.tp_set.st_sz
 };
 
 struct type	{
@@ -224,6 +226,7 @@ extern t_type
 					(tpx))
 #define	IsConstructed(tpx)	((tpx)->tp_fund & T_CONSTRUCTED)
 #define	TooBigForReturnArea(tpx) ((tpx)->tp_size > ret_area_size)
+#define IsBigParamTp(tpx)	((tpx)->tp_size > double_size)
 
 extern long full_mask[];
 extern long max_int[];

lang/m2/comp/type.c

@@ -503,7 +503,7 @@ set_type(tp)
 	/*	Construct a set type with base type "tp", but first
 		perform some checks
 	*/
-	arith lb, ub, diff;
+	arith lb, ub, diff, alloc_size;
 
 	if (! bounded(tp) || tp->tp_size > word_size) {
 		error("illegal base type for set");
@@ -526,6 +526,12 @@ set_type(tp)
 
 	tp = construct_type(T_SET, tp);
 	tp->tp_size = WA((diff + 7) >> 3);
+	alloc_size = (tp->tp_size / word_size + 1) * sizeof(arith);
+	tp->set_sz = alloc_size;
+	if (tp->set_sz != alloc_size) {
+		error("set size too large");
+		return error_type;
+	}
 	tp->set_low = lb;
 	return tp;
 }

lang/m2/comp/walk.c

@@ -41,6 +41,7 @@
 
 extern arith		NewPtr();
 extern arith		NewInt();
+extern arith		TmpSpace();
 
 extern int		proclevel;
 
@@ -61,7 +62,11 @@ static int		UseWarnings();
 #define	NO_EXIT_LABEL	((label) 0)
 #define RETURN_LABEL	((label) 1)
 
-LblWalkNode(lbl, nd, exit)
+#define REACH_FLAG	1
+#define EXIT_FLAG	2
+
+int
+LblWalkNode(lbl, nd, exit, reach)
 	label lbl, exit;
 	register t_node *nd;
 {
@@ -71,7 +76,7 @@ LblWalkNode(lbl, nd, exit)
 	*/
 
 	def_ilb(lbl);
-	WalkNode(nd, exit);
+	return WalkNode(nd, exit, reach);
 }
 
 static arith tmpprio;
@@ -104,6 +109,8 @@ EndPriority()
 def_ilb(l)
 	label l;
 {
+	/*	Instruction label definition. Forget about line number.
+	*/
 	C_df_ilb(l);
 	oldlineno = 0;
 }
@@ -111,7 +118,11 @@ def_ilb(l)
 DoLineno(nd)
 	register t_node *nd;
 {
-	if (! options['L'] && nd->nd_lineno && nd->nd_lineno != oldlineno) {
+	/*	Generate line number information, if necessary.
+	*/
+	if (! options['L'] &&
+	    nd->nd_lineno &&
+	    nd->nd_lineno != oldlineno) {
 		oldlineno = nd->nd_lineno;
 		C_lin((arith) nd->nd_lineno);
 	}
@@ -119,6 +130,11 @@ DoLineno(nd)
 
 DoFilename(needed)
 {
+	/*	Generate filename information, when needed.
+		This routine is called at the generation of a
+		procedure entry, and after generating a call to
+		another procedure.
+	*/
 	static label	filename_label = 0;
 
 	oldlineno = 0;	/* always invalidate remembered line number */
@@ -182,6 +198,9 @@ WalkModule(module)
 			C_ine_dlb(data_label, (arith) 0);
 		}
 		else if (! options['R']) {
+			/* put funny value in BSS, in an attempt to detect
+			   uninitialized variables
+			*/
 			C_cal("killbss");
 		}
 
@@ -192,7 +211,7 @@ WalkModule(module)
 	}
 	WalkDefList(sc->sc_def, MkCalls);
 	proclevel++;
-	WalkNode(module->mod_body, NO_EXIT_LABEL);
+	WalkNode(module->mod_body, NO_EXIT_LABEL, REACH_FLAG);
 	DO_DEBUG(options['X'], PrNode(module->mod_body, 0));
 	def_ilb(RETURN_LABEL);
 	EndPriority();
@@ -215,10 +234,13 @@ WalkProcedure(procedure)
 	register t_scope *procscope = procedure->prc_vis->sc_scope;
 	register t_type *tp;
 	register t_param *param;
-	int too_big = 0;
+	int too_big = 0;		/* returnsize larger than returnarea */
-	arith StackAdjustment = 0;
+	arith StackAdjustment = 0;	/* space for conformant arrays */
-	arith retsav = 0;
+	arith retsav = 0;		/* temporary space for return value */
 	arith func_res_size = 0;
+	int partno = C_getid();
+	int partno2 = C_getid();
+	int end_reached;		/* can fall through ... */
 
 	proclevel++;
 	CurrVis = procedure->prc_vis;
@@ -242,17 +264,22 @@ WalkProcedure(procedure)
 
 	/* Generate code for this procedure
 	*/
-	C_pro_narg(procscope->sc_name);
-	C_ms_par(procedure->df_type->prc_nbpar +
-		 (too_big ? func_res_size : 0));
 	TmpOpen(procscope);
+	C_insertpart(partno2);
+	C_insertpart(partno);
+
+	text_label = 1;		/* label at end of procedure */
+
+	end_reached = WalkNode(procedure->prc_body, NO_EXIT_LABEL, REACH_FLAG);
+
+	C_beginpart(partno);
 	DoPriority();
 	/* generate code for filename only when the procedure can be
 	   exported, either directly or by taking the address.
-	   This cannot be done if the level is not zero (because in
+	   This cannot be done if the level is bigger than one (because in
 	   this case it is a nested procedure).
 	*/
-	DoFilename(! procscope->sc_level);
+	DoFilename(procscope->sc_level == 1);
 
 	/* Generate calls to initialization routines of modules defined within
 	   this procedure
@@ -261,7 +288,7 @@ WalkProcedure(procedure)
 
 	/* Make sure that arguments of size < word_size are on a
 	   fixed place.
-	   Also make copies of conformant arrays when neccessary.
+	   Also make copies of parameters when neccessary.
 	*/
 	for (param = ParamList(procedure->df_type);
 	     param;
@@ -273,17 +300,37 @@ WalkProcedure(procedure)
 				if (tp->tp_size < word_size &&
 				    (int) word_size % (int) tp->tp_size == 0) {
 					C_lol(param->par_def->var_off);
-					STL(param->par_def->var_off, tp->tp_size);
+					STL(param->par_def->var_off,
+					    tp->tp_size);
+					continue;
 				}
+				if (IsBigParamTp(tp) &&
+				    (param->par_def->df_flags & D_DEFINED)){
+					/* Value parameter changed in body.
+					   Make a copy
+					*/
+					arith tmp = TmpSpace(tp->tp_size,
+							     tp->tp_align);
+					LOL(param->par_def->var_off,
+					    pointer_size);
+					C_lal(tmp);
+					CodeConst(WA(tp->tp_size),
+						  (int)pointer_size);
+					C_bls(pointer_size);
+					C_lal(tmp);
+					STL(param->par_def->var_off,
+					    pointer_size);
+				}
+				continue;
 			}
-			else {
+			if (param->par_def->df_flags & D_DEFINED) {
 				/* Here, we have to make a copy of the
 				   array. We must also remember how much
 				   room is reserved for copies, because
 				   we have to adjust the stack pointer before
 				   a RET is done. This is even more complicated
 				   when the procedure returns a value.
-				   Then, the value must be saved (in retval),
+				   Then, the value must be saved,
 				   the stack adjusted, the return value pushed
 				   again, and then RET
 				*/
@@ -295,9 +342,8 @@ WalkProcedure(procedure)
 						   needed if the value itself
 						   is returned
 						*/
-						procscope->sc_off -=
+						retsav= TmpSpace(func_res_size,
-							func_res_size;
+								1);
-						retsav = procscope->sc_off;
 					}
 					StackAdjustment = NewPtr();
 					C_lor((arith) 1);
@@ -316,12 +362,13 @@ WalkProcedure(procedure)
 			}
 		}
 	}
-
+	C_endpart(partno);
-	text_label = 1;		/* label at end of procedure */
-
-	WalkNode(procedure->prc_body, NO_EXIT_LABEL);
 	DO_DEBUG(options['X'], PrNode(procedure->prc_body, 0));
-	if (func_res_size) {
+	if ((end_reached & REACH_FLAG) && func_res_size) {
+		node_warning(procscope->sc_end,
+			     W_ORDINARY,
+			     "function procedure \"%s\" does not always return a value",
+			     procedure->df_idf->id_text);
 		c_loc(M2_NORESULT);
 		C_trp();
 		C_asp(-func_res_size);
@@ -357,10 +404,16 @@ WalkProcedure(procedure)
 	}
 	EndPriority();
 	C_ret(func_res_size);
+	C_beginpart(partno2);
+	C_pro(procscope->sc_name, -procscope->sc_off);
+	C_ms_par(procedure->df_type->prc_nbpar +
+		 (too_big ? func_res_size : 0));
 	if (! options['n']) WalkDefList(procscope->sc_def, RegisterMessage);
+	C_endpart(partno2);
 	C_end(-procscope->sc_off);
 	if (! fit(procscope->sc_off, (int) word_size)) {
-		node_error(procedure->prc_body, "maximum local byte count exceeded");
+		node_error(procedure->prc_body,
+			   "maximum local byte count exceeded");
 	}
 	TmpClose();
 	CurrVis = savevis;
@@ -409,19 +462,22 @@ MkCalls(df)
 	}
 }
 
-WalkLink(nd, exit_label)
+WalkLink(nd, exit_label, end_reached)
 	register t_node *nd;
 	label exit_label;
 {
 	/*	Walk node "nd", which is a link.
+		"exit_label" is set to a label number when inside a LOOP.
+		"end_reached" maintains info about reachability (REACH_FLAG),
+		and whether an EXIT statement was seen (EXIT_FLAG).
 	*/
 
 	while (nd && nd->nd_class == Link) {	 /* statement list */
-		WalkNode(nd->nd_left, exit_label);
+		end_reached = WalkNode(nd->nd_left, exit_label, end_reached);
 		nd = nd->nd_right;
 	}
 
-	WalkNode(nd, exit_label);
+	return WalkNode(nd, exit_label, end_reached);
 }
 
 STATIC
@@ -434,7 +490,8 @@ ForLoopVarExpr(nd)
 	CodeCoercion(tp, BaseType(tp));
 }
 
-WalkStat(nd, exit_label)
+int
+WalkStat(nd, exit_label, end_reached)
 	register t_node *nd;
 	label exit_label;
 {
@@ -445,8 +502,11 @@ WalkStat(nd, exit_label)
 
 	assert(nd->nd_class == Stat);
 
-	if (nd->nd_symb == ';') return;
+	if (nd->nd_symb == ';') return 1;
 
+	if (! end_reached & REACH_FLAG) {
+		node_warning(nd, W_ORDINARY, "statement not reached");
+	}
 	DoLineno(nd);
 	options['R'] = (nd->nd_flags & ROPTION);
 	options['A'] = (nd->nd_flags & AOPTION);
@@ -467,24 +527,26 @@ WalkStat(nd, exit_label)
 
 	case IF:
 		{	label l1 = ++text_label, l3 = ++text_label;
+			int end_r;
 
 			ExpectBool(left, l3, l1);
 			assert(right->nd_symb == THEN);
-			LblWalkNode(l3, right->nd_left, exit_label);
+			end_r = LblWalkNode(l3, right->nd_left, exit_label, end_reached);
 
 			if (right->nd_right) {	/* ELSE part */
 				label l2 = ++text_label;
 
 				C_bra(l2);
-				LblWalkNode(l1, right->nd_right, exit_label);
+				end_reached = end_r | LblWalkNode(l1, right->nd_right, exit_label, end_reached);
 				l1 = l2;
 			}
+			else	end_reached |= end_r;
 			def_ilb(l1);
 			break;
 		}
 
 	case CASE:
-		CaseCode(nd, exit_label);
+		end_reached = CaseCode(nd, exit_label, end_reached);
 		break;
 
 	case WHILE:
@@ -492,10 +554,10 @@ WalkStat(nd, exit_label)
 				exit = ++text_label,
 				dummy = ++text_label;
 
-			def_ilb(loop);
+			C_bra(dummy);
-			ExpectBool(left, dummy, exit);
+			end_reached |= LblWalkNode(loop, right, exit_label, end_reached);
-			LblWalkNode(dummy, right, exit_label);
+			def_ilb(dummy);
-			C_bra(loop);
+			ExpectBool(left, loop, exit);
 			def_ilb(exit);
 			break;
 		}
@@ -503,7 +565,7 @@ WalkStat(nd, exit_label)
 	case REPEAT:
 		{	label loop = ++text_label, exit = ++text_label;
 
-			LblWalkNode(loop, left, exit_label);
+			end_reached = LblWalkNode(loop, left, exit_label, end_reached);
 			ExpectBool(right, exit, loop);
 			def_ilb(exit);
 			break;
@@ -512,7 +574,10 @@ WalkStat(nd, exit_label)
 	case LOOP:
 		{	label loop = ++text_label, exit = ++text_label;
 
-			LblWalkNode(loop, right, exit);
+			if (LblWalkNode(loop, right, exit, end_reached) & EXIT_FLAG) {
+				end_reached &= REACH_FLAG;
+			}
+			else	end_reached = 0;
 			C_bra(loop);
 			def_ilb(exit);
 			break;
@@ -575,7 +640,7 @@ WalkStat(nd, exit_label)
 
 					ForLoopVarExpr(nd);
 					C_stl(tmp2);
-					WalkNode(right, exit_label);
+					end_reached |= WalkNode(right, exit_label, end_reached);
 					C_lol(tmp2);
 					ForLoopVarExpr(nd);
 					C_beq(x);
@@ -583,7 +648,7 @@ WalkStat(nd, exit_label)
 					C_trp();
 					def_ilb(x);
 				}
-				else	WalkNode(right, exit_label);
+				else	end_reached |= WalkNode(right, exit_label, end_reached);
 				nd->nd_def->df_flags &= ~D_FORLOOP;
 				FreeInt(tmp2);
 				if (stepsize) {
@@ -601,7 +666,7 @@ WalkStat(nd, exit_label)
 				}
 			}
 			else {
-				WalkNode(right, exit_label);
+				end_reached |= WalkNode(right, exit_label, end_reached);
 				nd->nd_def->df_flags &= ~D_FORLOOP;
 			}
 			C_bra(l1);
@@ -620,13 +685,14 @@ WalkStat(nd, exit_label)
 			struct withdesig wds;
 			t_desig ds;
 
-			if (! WalkDesignator(left, &ds, D_USED|D_DEFINED)) break;
+			if (! WalkDesignator(left, &ds, D_USED)) break;
 			if (left->nd_type->tp_fund != T_RECORD) {
 				node_error(left, "record variable expected");
 				break;
 			}
 
 			wds.w_next = WithDesigs;
+			wds.w_flags = D_USED;
 			WithDesigs = &wds;
 			wds.w_scope = left->nd_type->rec_scope;
 			CodeAddress(&ds);
@@ -642,20 +708,23 @@ WalkStat(nd, exit_label)
 			link.sc_scope = wds.w_scope;
 			link.sc_next = CurrVis;
 			CurrVis = &link;
-			WalkNode(right, exit_label);
+			end_reached = WalkNode(right, exit_label, end_reached);
 			CurrVis = link.sc_next;
 			WithDesigs = wds.w_next;
 			FreePtr(ds.dsg_offset);
+			WalkDesignator(left, &ds, wds.w_flags & (D_USED|D_DEFINED));
 			break;
 		}
 
 	case EXIT:
 		assert(exit_label != 0);
 
+		if (end_reached & REACH_FLAG) end_reached = EXIT_FLAG;
 		C_bra(exit_label);
 		break;
 
 	case RETURN:
+		end_reached &= ~REACH_FLAG;
 		if (right) {
 			if (! ChkExpression(right)) break;
 			/* The type of the return-expression must be
@@ -677,6 +746,7 @@ WalkStat(nd, exit_label)
 	default:
 		crash("(WalkStat)");
 	}
+	return end_reached;
 }
 
 extern int	NodeCrash();
@@ -900,16 +970,18 @@ UseWarnings(df)
 	}
 	switch(df->df_flags & (D_USED|D_DEFINED|D_VALPAR|D_VARPAR)) {
 	case 0:
-	case D_VALPAR:
 	case D_VARPAR:
 		warning = "never used/assigned";
 		break;
 	case D_USED|D_VARPAR:
-		warning = "never assigned, could be value parameter";
+		if (df->df_type->tp_fund != T_EQUAL) {
+			warning = "never assigned, could be value parameter";
+		}
 		break;
 	case D_USED:
 		warning = "never assigned";
 		break;
+	case D_VALPAR:
 	case D_DEFINED:
 	case D_DEFINED|D_VALPAR:
 		warning = "never used";
@@ -924,7 +996,10 @@ warn:
 			     "%s \"%s\" %s",
 			     (df->df_flags & D_VALPAR) ? "value parameter" :
 			      (df->df_flags & D_VARPAR) ? "variable parameter" :
-			       "identifier",
+			       (df->df_kind == D_VARIABLE) ? "variable" :
+				(df->df_kind == D_TYPE) ? "type" :
+				 (df->df_kind == D_CONST) ? "constant" :
+				  "procedure",
 			     df->df_idf->id_text, warning);
 	}
 }

lang/m2/comp/walk.h

@@ -14,7 +14,7 @@
 
 extern int (*WalkTable[])();
 
-#define	WalkNode(xnd, xlab)	(*WalkTable[(xnd)->nd_class])((xnd), (xlab))
+#define	WalkNode(xnd, xlab, rch)	(*WalkTable[(xnd)->nd_class])((xnd), (xlab),(rch))
 
 extern label	text_label;
 extern label	data_label;