newer version

lang/m2/comp/chk_expr.c

@@ -21,6 +21,8 @@ static char *RcsId = "$Header$";
 
 #include	"debug.h"
 
+extern char *symbol2str();
+
 int
 chk_expr(expp)
 	register struct node *expp;
@@ -32,11 +34,19 @@ chk_expr(expp)
 
 	switch(expp->nd_class) {
 	case Oper:
+		if (expp->nd_symb == '[') {
+			return chk_designator(expp, DESIGNATOR);
+		}
+
 		return	chk_expr(expp->nd_left) &&
 			chk_expr(expp->nd_right) &&
 			chk_oper(expp);
 
 	case Uoper:
+		if (expp->nd_symb == '^') {
+			return chk_designator(expp, DESIGNATOR);
+		}
+
 		return	chk_expr(expp->nd_right) &&
 			chk_uoper(expp);
 
@@ -56,13 +66,13 @@ chk_expr(expp)
 		return chk_set(expp);
 
 	case Name:
-		return chk_name(expp);
+		return chk_designator(expp, DESIGNATOR);
 
 	case Call:
 		return chk_call(expp);
 
 	case Link:
-		return chk_name(expp);
+		return chk_designator(expp, DESIGNATOR);
 
 	default:
 		assert(0);
@@ -89,7 +99,8 @@ chk_set(expp)
 	if (nd = expp->nd_left) {
 		/* A type was given. Check it out
 		*/
-		findname(nd);
+		if (! chk_designator(nd, QUALONLY)) return 0;
+
 		assert(nd->nd_class == Def);
 		df = nd->nd_def;
 
@@ -259,7 +270,7 @@ getname(argp, kinds)
 		return 0;
 	}
 	argp = argp->nd_right;
-	findname(argp->nd_left);
+	if (! chk_designator(argp->nd_left, QUALONLY)) return 0;
 	assert(argp->nd_left->nd_class == Def);
 	if (!(argp->nd_left->nd_def->df_kind & kinds)) {
 		node_error(argp, "unexpected type");
@@ -283,7 +294,7 @@ chk_call(expp)
 	*/
 	expp->nd_type = error_type;
 	left = expp->nd_left;
-	findname(left);
+	if (! chk_designator(left, DESIGNATOR)) return 0;
 
 	if (left->nd_type == error_type) return 0;
 	if (left->nd_class == Def &&
@@ -300,7 +311,6 @@ node_error(expp, "only one parameter expected in type cast");
 		if (! chk_expr(arg)) return 0;
 		if (arg->nd_type->tp_size != left->nd_type->tp_size) {
 node_error(expp, "size of type in type cast does not match size of operand");
-			return 0;
 		}
 		arg->nd_type = left->nd_type;
 		FreeNode(expp->nd_left);
@@ -322,172 +332,7 @@ node_error(expp, "size of type in type cast does not match size of operand");
 		if (left->nd_type == std_type) {
 			/* A standard procedure
 			*/
-			assert(left->nd_class == Def);
+			return chk_std(expp, left, arg);
-DO_DEBUG(3, debug("standard name \"%s\", %d", 
-left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
-			switch(left->nd_def->df_value.df_stdname) {
-			case S_ABS:
-				arg = getarg(arg, T_NUMERIC);
-				if (! arg) return 0;
-				left = arg->nd_left;
-				expp->nd_type = left->nd_type;
-				if (left->nd_class == Value) {
-					cstcall(expp, S_ABS);
-				}
-				break;
-
-			case S_CAP:
-				arg = getarg(arg, T_CHAR);
-				expp->nd_type = char_type;
-				if (!arg) return 0;
-				left = arg->nd_left;
-				if (left->nd_class == Value) {
-					cstcall(expp, S_CAP);
-				}
-				break;
-
-			case S_CHR:
-				arg = getarg(arg, T_INTORCARD);
-				expp->nd_type = char_type;
-				if (!arg) return 0;
-				if (arg->nd_left->nd_class == Value) {
-					cstcall(expp, S_CHR);
-				}
-				break;
-
-			case S_FLOAT:
-				arg = getarg(arg, T_INTORCARD);
-				expp->nd_type = real_type;
-				if (!arg) return 0;
-				break;
-
-			case S_HIGH:
-				arg = getarg(arg, T_ARRAY);
-				if (!arg) return 0;
-				expp->nd_type = arg->nd_left->nd_type->next;
-				if (!expp->nd_type) {
-					/* A dynamic array has no explicit
-					   index type
-					*/
-					expp->nd_type = intorcard_type;
-				}
-				else	cstcall(expp, S_MAX);
-				break;
-
-			case S_MAX:
-			case S_MIN:
-				arg = getarg(arg, T_DISCRETE);
-				if (!arg) return 0;
-				expp->nd_type = arg->nd_left->nd_type;
-				cstcall(expp,left->nd_def->df_value.df_stdname);
-				break;
-
-			case S_ODD:
-				arg = getarg(arg, T_INTORCARD);
-				if (!arg) return 0;
-				expp->nd_type = bool_type;
-				if (arg->nd_left->nd_class == Value) {
-					cstcall(expp, S_ODD);
-				}
-				break;
-
-			case S_ORD:
-				arg = getarg(arg, T_DISCRETE);
-				if (!arg) return 0;
-				expp->nd_type = card_type;
-				if (arg->nd_left->nd_class == Value) {
-					cstcall(expp, S_ORD);
-				}
-				break;
-
-			case S_TSIZE:	/* ??? */
-			case S_SIZE:
-				arg = getname(arg, D_FIELD|D_VARIABLE|D_TYPE|D_HIDDEN|D_HTYPE);
-				expp->nd_type = intorcard_type;
-				if (!arg) return 0;
-				cstcall(expp, S_SIZE);
-				break;
-
-			case S_TRUNC:
-				arg = getarg(arg, T_REAL);
-				if (!arg) return 0;
-				expp->nd_type = card_type;
-				break;
-
-			case S_VAL: {
-				struct type *tp;
-
-				arg = getname(arg, D_HIDDEN|D_HTYPE|D_TYPE);
-				if (!arg) return 0;
-				tp = arg->nd_left->nd_def->df_type;
-				if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
-				if (!(tp->tp_fund & T_DISCRETE)) {
-					node_error(arg, "unexpected type");
-					return 0;
-				}
-				expp->nd_type = arg->nd_left->nd_def->df_type;
-				expp->nd_right = arg->nd_right;
-				arg->nd_right = 0;
-				FreeNode(arg);
-				arg = getarg(expp, T_INTORCARD);
-				if (!arg) return 0;
-				if (arg->nd_left->nd_class == Value) {
-					cstcall(expp, S_VAL);
-				}
-				break;
-				}
-
-			case S_ADR:
-				arg = getname(arg, D_VARIABLE|D_FIELD|D_PROCEDURE);
-				expp->nd_type = address_type;
-				if (!arg) return 0;
-				break;
-
-			case S_DEC:
-			case S_INC:
-				expp->nd_type = 0;
-				arg = getname(arg, D_VARIABLE|D_FIELD);
-				if (!arg) return 0;
-				if (arg->nd_right) {
-					arg = getarg(arg, T_INTORCARD);
-					if (!arg) return 0;
-				}
-				break;
-
-			case S_HALT:
-				expp->nd_type = 0;
-				break;
-
-			case S_EXCL:
-			case S_INCL: {
-				struct type *tp;
-
-				expp->nd_type = 0;
-				arg = getname(arg, D_VARIABLE|D_FIELD);
-				if (!arg) return 0;
-				tp = arg->nd_left->nd_type;
-				if (tp->tp_fund != T_SET) {
-node_error(arg, "EXCL and INCL expect a SET parameter");
-					return 0;
-				}
-				arg = getarg(arg, T_DISCRETE);
-				if (!arg) return 0;
-				if (!TstCompat(tp->next, arg->nd_left->nd_type)) {
-					node_error(arg, "unexpected type");
-					return 0;
-				}
-				break;
-				}
-
-			default:
-				assert(0);
-			}
-			if (arg->nd_right) {
-				node_error(arg->nd_right,
-					"too many parameters supplied");
-				return 0;
-			}
-			return 1;
 		}
 		/* Here, we have found a real procedure call. The left hand
 		   side may also represent a procedure variable.
@@ -534,7 +379,8 @@ node_error(arg->nd_left, "type incompatibility in value parameter");
 	return 1;
 }
 
-findname(expp)
+int
+chk_designator(expp, flag)
 	register struct node *expp;
 {
 	/*	Find the name indicated by "expp", starting from the current
@@ -545,29 +391,31 @@ findname(expp)
 	struct def *lookfor();
 
 	expp->nd_type = error_type;
+
 	if (expp->nd_class == Name) {
 		expp->nd_def = lookfor(expp, CurrentScope, 1);
 		expp->nd_class = Def;
 		expp->nd_type = expp->nd_def->df_type;
-		return;
+		if (expp->nd_type == error_type) return 0;
 	}
+
 	if (expp->nd_class == Link) {
 		assert(expp->nd_symb == '.');
 		assert(expp->nd_right->nd_class == Name);
-		findname(expp->nd_left);
+
+		if (! chk_designator(expp->nd_left, flag)) return 0;
 		tp = expp->nd_left->nd_type;
-		if (tp == error_type) {
+		if (tp == error_type) return 0;
-			df = ill_df;
-		}
 		else if (tp->tp_fund != T_RECORD) {
 			/* This is also true for modules */
 			node_error(expp,"illegal selection");
-			df = ill_df;
+			return 0;
 		}
 		else df = lookup(expp->nd_right->nd_IDF, tp->rec_scope);
+
 		if (!df) {
-			df = ill_df;
 			id_not_declared(expp->nd_right);
+			return 0;
 		}
 		else if (df != ill_df) {
 			expp->nd_type = df->df_type;
@@ -575,8 +423,10 @@ findname(expp)
 node_error(expp->nd_right,
 "identifier \"%s\" not exported from qualifying module",
 df->df_idf->id_text);
+				return 0;
 			}
 		}
+
 		if (expp->nd_left->nd_class == Def) {
 			expp->nd_class = Def;
 			expp->nd_def = df;
@@ -584,45 +434,83 @@ df->df_idf->id_text);
 			FreeNode(expp->nd_right);
 			expp->nd_left = expp->nd_right = 0;
 		}
-		return;
+		else	return 1;
 	}
-	if (expp->nd_class == Oper) {
-		assert(expp->nd_symb == '[');
-		findname(expp->nd_left);
-		if (chk_expr(expp->nd_right) &&
-		    expp->nd_left->nd_type != error_type &&
-		    chk_oper(expp)) /* ??? */ ;
-		return;
-	}
-	if (expp->nd_class == Uoper && expp->nd_symb == '^') {
-		findname(expp->nd_right);
-		if (expp->nd_right->nd_type != error_type &&
-	    		chk_uoper(expp)) /* ??? */ ;
-	}
-	return;
-}
 
-int
+	if (expp->nd_class == Def) {
-chk_name(expp)
-	register struct node *expp;
-{
-	register struct def *df;
-
-	findname(expp);
-	assert(expp->nd_class == Def);
 		df = expp->nd_def;
-	if (df->df_kind == D_ERROR) return 0;
+
 		if (df->df_kind & (D_ENUM | D_CONST)) {
 			if (df->df_kind == D_ENUM) {
 				expp->nd_class = Value;
 				expp->nd_INT = df->enm_val;
 				expp->nd_symb = INTEGER;
 			}
-		else if (df->df_kind == D_CONST) {
+			else  {
+				assert(df->df_kind == D_CONST);
 				*expp = *(df->con_const);
 			}
 		}
+
 		return 1;
+	}
+
+	if (flag == QUALONLY) {
+		node_error(expp, "identifier expected");
+		return 0;
+	}
+
+	if (expp->nd_class == Oper) {
+		struct type *tpl, *tpr;
+
+		assert(expp->nd_symb == '[');
+
+		if ( 
+		    	!chk_designator(expp->nd_left, DESIGNATOR)
+		   ||
+		    	!chk_expr(expp->nd_right)
+		   ||
+		    	expp->nd_left->nd_type == error_type
+		   ) return 0;
+
+		tpr = expp->nd_right->nd_type;
+		tpl = expp->nd_left->nd_type;
+
+		if (tpl->tp_fund != T_ARRAY) {
+			node_error(expp,
+				   "array index not belonging to an ARRAY");
+			return 0;
+		}
+
+		/* Type of the index must be assignment compatible with
+		   the index type of the array (Def 8.1)
+		*/
+		if ((tpl->next && !TstAssCompat(tpl->next, tpr)) ||
+		    (!tpl->next && !TstAssCompat(intorcard_type, tpr))) {
+			node_error(expp, "incompatible index type");
+			return 0;
+		}
+
+		expp->nd_type = tpl->arr_elem;
+		return 1;
+	}
+
+	if (expp->nd_class == Uoper) {
+		assert(expp->nd_symb == '^');
+
+		if (! chk_designator(expp->nd_right, DESIGNATOR)) return 0;
+		if (expp->nd_right->nd_type->tp_fund != T_POINTER) {
+node_error(expp, "illegal operand for unary operator \"%s\"",
+symbol2str(expp->nd_symb));
+			return 0;
+		}
+
+		expp->nd_type = expp->nd_right->nd_type->next;
+		return 1;
+	}
+
+	node_error(expp, "designator expected");
+	return 0;
 }
 
 int
@@ -631,19 +519,20 @@ chk_oper(expp)
 {
 	/*	Check a binary operation.
 	*/
-	register struct type *tpl = expp->nd_left->nd_type;
+	register struct node *left = expp->nd_left;
-	register struct type *tpr = expp->nd_right->nd_type;
+	register struct node *right = expp->nd_right;
-	char *symbol2str();
+	struct type *tpl = left->nd_type;
+	struct type *tpr = right->nd_type;
 	int errval = 1;
 	
 	if (tpl == intorcard_type) {
 		if (tpr == int_type || tpr == card_type) {
-			expp->nd_left->nd_type = tpl = tpr;
+			 left->nd_type = tpl = tpr;
 		}
 	}
 	if (tpr == intorcard_type) {
 		if (tpl == int_type || tpl == card_type) {
-			expp->nd_right->nd_type = tpr = tpl;
+			right->nd_type = tpr = tpl;
 		}
 	}
 	expp->nd_type = error_type;
@@ -655,41 +544,28 @@ chk_oper(expp)
 node_error(expp, "RHS of IN operator not a SET type");
 			return 0;
 		}
-		if (!TstCompat(tpl, tpr->next)) {
+		if (!TstAssCompat(tpl, tpr->next)) {
+			/* Assignment compatible ???
+			   I don't know! Should we be allowed th check
+			   if a CARDINAL is a member of a BITSET???
+			*/
+
 node_error(expp, "IN operator: type of LHS not compatible with element type of RHS");
 			return 0;
 		}
-		if (expp->nd_left->nd_class == Value &&
+		if (left->nd_class == Value && right->nd_class == Set) {
-		    expp->nd_right->nd_class == Set) {
 			cstset(expp);
 		}
 		return 1;
 	}
 
-	if (expp->nd_symb == '[') {
-		/* Handle ARRAY selection specially too!
-		*/
-		if (tpl->tp_fund != T_ARRAY) {
-			node_error(expp,
-				   "array index not belonging to an ARRAY");
-			return 0;
-		}
-
-		if ((tpl->next && !TstCompat(tpl->next, tpr)) ||
-		    (!tpl->next && !TstCompat(intorcard_type, tpr)) {
-			node_error(expp, "incompatible index type");
-		}
-
-		expp->nd_type = tpl->arr_elem;
-		return 1;
-	}
-
 	if (tpl->tp_fund == T_SUBRANGE) tpl = tpl->next;
 	expp->nd_type = tpl;
 
+	/* Operands must be compatible (distilled from Def 8.2)
+	*/
 	if (!TstCompat(tpl, tpr)) {
-		node_error(expp,
+		node_error(expp, "incompatible types for operator \"%s\"",
-			   "incompatible types for operator \"%s\"",
 					symbol2str(expp->nd_symb));
 		return 0;
 	}
@@ -702,15 +578,13 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
 		case T_INTEGER:
 		case T_CARDINAL:
 		case T_INTORCARD:
-			if (expp->nd_left->nd_class == Value &&
+			if (left->nd_class==Value && right->nd_class==Value) {
-			    expp->nd_right->nd_class == Value) {
 				cstbin(expp);
 			}
 			return 1;
 
 		case T_SET:
-			if (expp->nd_left->nd_class == Set &&
+			if (left->nd_class == Set && right->nd_class == Set) {
-			    expp->nd_right->nd_class == Set) {
 				cstset(expp);
 			}
 			/* Fall through */
@@ -723,8 +597,7 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
 	case '/':
 		switch(tpl->tp_fund) {
 		case T_SET:
-			if (expp->nd_left->nd_class == Set &&
+			if (left->nd_class == Set && right->nd_class == Set) {
-			    expp->nd_right->nd_class == Set) {
 				cstset(expp);
 			}
 			/* Fall through */
@@ -737,8 +610,7 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
 	case DIV:
 	case MOD:
 		if (tpl->tp_fund & T_INTORCARD) {
-			if (expp->nd_left->nd_class == Value &&
+			if (left->nd_class==Value && right->nd_class==Value) {
-			    expp->nd_right->nd_class == Value) {
 				cstbin(expp);
 			}
 			return 1;
@@ -749,8 +621,7 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
 	case AND:
 	case '&':
 		if (tpl == bool_type) {
-			if (expp->nd_left->nd_class == Value &&
+			if (left->nd_class==Value && right->nd_class==Value) {
-			    expp->nd_right->nd_class == Value) {
 				cstbin(expp);
 			}
 			return 1;
@@ -771,8 +642,7 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
 			if (expp->nd_symb == '<' || expp->nd_symb == '>') {
 				break;
 			}
-			if (expp->nd_left->nd_class == Set &&
+			if (left->nd_class == Set && right->nd_class == Set) {
-			    expp->nd_right->nd_class == Set) {
 				cstset(expp);
 			}
 			return 1;
@@ -782,8 +652,7 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
 		case T_ENUMERATION:	/* includes boolean */
 		case T_CHAR:
 		case T_INTORCARD:
-			if (expp->nd_left->nd_class == Value &&
+			if (left->nd_class==Value && right->nd_class==Value) {
-			    expp->nd_right->nd_class == Value) {
 				cstbin(expp);
 			}
 			return 1;
@@ -868,11 +737,6 @@ chk_uoper(expp)
 		}
 		break;
 
-	case '^':
-		if (tpr->tp_fund != T_POINTER) break;
-		expp->nd_type = tpr->next;
-		return 1;
-
 	default:
 		assert(0);
 	}
@@ -880,3 +744,179 @@ chk_uoper(expp)
 			symbol2str(expp->nd_symb));
 	return 0;
 }
+
+struct node *
+getvariable(arg)
+	register struct node *arg;
+{
+	arg = arg->nd_right;
+	if (!arg) {
+		node_error(arg, "too few parameters supplied");
+		return 0;
+	}
+
+	if (! chk_designator(arg->nd_left, DESIGNATOR)) return 0;
+	if (arg->nd_left->nd_class == Oper || arg->nd_left->nd_class == Uoper) {
+		return arg;
+	}
+
+	if (arg->nd_left->nd_class != Def ||
+	    !(arg->nd_left->nd_def->df_kind & (D_VARIABLE|D_FIELD))) {
+		node_error(arg, "variable expected");
+		return 0;
+	}
+
+	return arg;
+}
+
+int
+chk_std(expp, left, arg)
+	register struct node *expp, *left, *arg;
+{
+	/*	Check a call of a standard procedure or function
+	*/
+
+	assert(left->nd_class == Def);
+DO_DEBUG(3, debug("standard name \"%s\", %d", 
+left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
+
+	switch(left->nd_def->df_value.df_stdname) {
+	case S_ABS:
+		if (!(arg = getarg(arg, T_NUMERIC))) return 0;
+		left = arg->nd_left;
+		expp->nd_type = left->nd_type;
+		if (left->nd_class == Value) cstcall(expp, S_ABS);
+		break;
+
+	case S_CAP:
+		expp->nd_type = char_type;
+		if (!(arg = getarg(arg, T_CHAR))) return 0;
+		left = arg->nd_left;
+		if (left->nd_class == Value) cstcall(expp, S_CAP);
+		break;
+
+	case S_CHR:
+		expp->nd_type = char_type;
+		if (!(arg = getarg(arg, T_INTORCARD))) return 0;
+		left = arg->nd_left;
+		if (left->nd_class == Value) cstcall(expp, S_CHR);
+		break;
+
+	case S_FLOAT:
+		expp->nd_type = real_type;
+		if (!(arg = getarg(arg, T_INTORCARD))) return 0;
+		break;
+
+	case S_HIGH:
+		if (!(arg = getarg(arg, T_ARRAY))) return 0;
+		expp->nd_type = arg->nd_left->nd_type->next;
+		if (!expp->nd_type) {
+			/* A dynamic array has no explicit index type
+			*/
+			expp->nd_type = intorcard_type;
+		}
+		else	cstcall(expp, S_MAX);
+		break;
+
+	case S_MAX:
+	case S_MIN:
+		if (!(arg = getarg(arg, T_DISCRETE))) return 0;
+		expp->nd_type = arg->nd_left->nd_type;
+		cstcall(expp,left->nd_def->df_value.df_stdname);
+		break;
+
+	case S_ODD:
+		if (!(arg = getarg(arg, T_INTORCARD))) return 0;
+		expp->nd_type = bool_type;
+		if (arg->nd_left->nd_class == Value) cstcall(expp, S_ODD);
+		break;
+
+	case S_ORD:
+		if (!(arg = getarg(arg, T_DISCRETE))) return 0;
+		expp->nd_type = card_type;
+		if (arg->nd_left->nd_class == Value) cstcall(expp, S_ORD);
+		break;
+
+	case S_TSIZE:	/* ??? */
+	case S_SIZE:
+		expp->nd_type = intorcard_type;
+		arg = getname(arg, D_FIELD|D_VARIABLE|D_TYPE|D_HIDDEN|D_HTYPE);
+		if (!arg) return 0;
+		cstcall(expp, S_SIZE);
+		break;
+
+	case S_TRUNC:
+		expp->nd_type = card_type;
+		if (!(arg = getarg(arg, T_REAL))) return 0;
+		break;
+
+	case S_VAL:
+		{
+		struct type *tp;
+
+		if (!(arg = getname(arg, D_HIDDEN|D_HTYPE|D_TYPE))) return 0;
+		tp = arg->nd_left->nd_def->df_type;
+		if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
+		if (!(tp->tp_fund & T_DISCRETE)) {
+			node_error(arg, "unexpected type");
+			return 0;
+		}
+		expp->nd_type = arg->nd_left->nd_def->df_type;
+		expp->nd_right = arg->nd_right;
+		arg->nd_right = 0;
+		FreeNode(arg);
+		arg = getarg(expp, T_INTORCARD);
+		if (!arg) return 0;
+		if (arg->nd_left->nd_class == Value) cstcall(expp, S_VAL);
+		break;
+		}
+
+	case S_ADR:
+		expp->nd_type = address_type;
+		if (!(arg = getarg(arg, D_VARIABLE|D_FIELD))) return 0;
+		break;
+
+	case S_DEC:
+	case S_INC:
+		expp->nd_type = 0;
+		if (!(arg = getvariable(arg))) return 0;
+		if (arg->nd_right) {
+			if (!(arg = getarg(arg, T_INTORCARD))) return 0;
+		}
+		break;
+
+	case S_HALT:
+		expp->nd_type = 0;
+		break;
+
+	case S_EXCL:
+	case S_INCL:
+		{
+		struct type *tp;
+
+		expp->nd_type = 0;
+		if (!(arg = getvariable(arg))) return 0;
+		tp = arg->nd_left->nd_type;
+		if (tp->tp_fund != T_SET) {
+node_error(arg, "EXCL and INCL expect a SET parameter");
+			return 0;
+		}
+		if (!(arg = getarg(arg, T_DISCRETE))) return 0;
+		if (!TstCompat(tp->next, arg->nd_left->nd_type)) {
+			node_error(arg, "unexpected type");
+			return 0;
+		}
+		break;
+		}
+
+	default:
+		assert(0);
+	}
+
+	if (arg->nd_right) {
+		node_error(arg->nd_right, "too many parameters supplied");
+		return 0;
+	}
+
+	return 1;
+}

lang/m2/comp/declar.g

@@ -117,7 +117,8 @@ FormalParameters(int doparams;
 			{ *tp = 0; }
 	[	':' qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type",
 							(struct node **) 0)
-			{ *tp = df->df_type; }
+			{ *tp = df->df_type;
+			}
 	]?
 ;
 
@@ -364,14 +365,14 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
 			*/
 				{ warning("Old fashioned Modula-2 syntax!");
 				  id = gen_anon_idf();
-				  findname(nd);
+				  df = ill_df;
-				  assert(nd->nd_class == Def);
+				  if (chk_designator(nd, QUALONLY) &&
-				  df = nd->nd_def;
+				      (nd->nd_class != Def ||
-				  if (!(df->df_kind &
+				       !(nd->nd_def->df_kind &
-					(D_ERROR|D_TYPE|D_HTYPE|D_HIDDEN))) {
+					 (D_ERROR|D_TYPE|D_HTYPE|D_HIDDEN)))) {
-					error("identifier \"%s\" is not a type",
+					node_error(nd, "type expected");
-						df->df_idf->id_text);
 				  }
+				  else df = nd->nd_def;
 				  FreeNode(nd);
 				}
 		]

lang/m2/comp/def.c

@@ -439,6 +439,16 @@ DeclProc(type)
 	return df;
 }
 
+InitProc(nd, df)
+	struct node *nd;
+	struct def *df;
+{
+	/*	Create an initialization procedure for a module.
+	*/
+	df->mod_body = nd;
+	/* Keep it this way, or really create a procedure out of it??? */
+}
+
 #ifdef DEBUG
 PrDef(df)
 	register struct def *df;

lang/m2/comp/error.c

@@ -134,10 +134,7 @@ _error(class, node, fmt, argv)
 	case LEXERROR:
 	case CRASH:
 	case FATAL:
-		/* ????
+		if (C_busy()) C_ms_err();
-		if (C_busy())
-			C_ms_err();
-		*/
 		err_occurred = 1;
 		break;
 	

lang/m2/comp/expression.g

@@ -33,28 +33,34 @@ number(struct node **p;)
 qualident(int types; struct def **pdf; char *str; struct node **p;)
 {
 	register struct def *df;
-	register struct node **pnd;
 	struct node *nd;
 } :
 	IDENT		{ nd = MkNode(Name, NULLNODE, NULLNODE, &dot);
-			  pnd = &nd;
 			}
 	[
-		selector(pnd)
+		selector(&nd)
 	]*
 			{ if (types) {
-				findname(nd);
+				df = ill_df;
-				assert(nd->nd_class == Def);
+
-				*pdf = df = nd->nd_def;
+				if (chk_designator(nd, QUALONLY)) {
-			  	if ( !((types|D_ERROR) & df->df_kind)) {
+				    if (nd->nd_class != Def) {
-					if (df->df_kind == D_FORWARD) {
+					node_error(nd, "%s expected", str);
-node_error(*pnd,"%s \"%s\" not declared", str, df->df_idf->id_text);
 				    }
 				    else {
-node_error(*pnd,"identifier \"%s\" is not a %s", df->df_idf->id_text, str);
+					df = nd->nd_def;
+			  		if ( !((types|D_ERROR) & df->df_kind)) {
+					    if (df->df_kind == D_FORWARD) {
+node_error(nd,"%s \"%s\" not declared", str, df->df_idf->id_text);
+					    }
+					    else {
+node_error(nd,"identifier \"%s\" is not a %s", df->df_idf->id_text, str);
 					    }
 					}
 				    }
+				}
+				*pdf = df;
+			  }
 			  if (!p) FreeNode(nd);
 			  else *p = nd;
 			}

lang/m2/comp/node.H

@@ -36,3 +36,5 @@ struct node {
 extern struct node *MkNode();
 
 #define NULLNODE ((struct node *) 0)
+#define QUALONLY 0
+#define DESIGNATOR 1

lang/m2/comp/program.g

@@ -51,6 +51,7 @@ ModuleDeclaration
 	extern int proclevel;
 	static int modulecount = 0;
 	char buf[256];
+	struct node *nd;
 	extern char *sprint(), *Malloc(), *strcpy();
 } :
 	MODULE IDENT	{
@@ -78,8 +79,9 @@ ModuleDeclaration
 	';'
 	import(1)*
 	export(0)?
-	block(&(df->mod_body))
+	block(&nd)
-	IDENT		{ close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
+	IDENT		{ InitProc(nd, df);
+			  close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
 			  match_id(id, dot.TOK_IDF);
 			  currentdef = savecurr;
 			}
@@ -226,6 +228,7 @@ ProgramModule(int state;)
 	struct idf *id;
 	struct def *GetDefinitionModule();
 	register struct def *df;
+	struct node *nd;
 } :
 	MODULE
 	IDENT	{ 
@@ -243,12 +246,14 @@ ProgramModule(int state;)
 			open_scope(CLOSEDSCOPE);
 			df->mod_scope = CurrentScope;
 			df->mod_number = 0;
+			CurrentScope->sc_name = id->id_text;
 		  }
 		}
 	priority(&(df->mod_priority))?
 	';' import(0)*
-	block(&(df->mod_body)) IDENT
+	block(&nd) IDENT
-		{ close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
+		{ InitProc(nd, df);
+		  close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
 		  match_id(id, dot.TOK_IDF);
 		}
 	'.'

lang/m2/comp/statement.g

@@ -74,7 +74,12 @@ error("a module body has no result value");
 error("procedure \"%s\" has no result value", currentdef->df_idf->id_text);
 			  }
 			}
-	]?
+	|
+			{ if (currentdef->df_type->next) {
+error("procedure \"%s\" must return a value", currentdef->df_idf->id_text);
+			  }
+			}
+	]
 ]?
 ;
 

lang/m2/comp/type.c

@@ -90,23 +90,34 @@ construct_type(fund, tp)
 		dtp->tp_align = pointer_align;
 		dtp->tp_size = pointer_size;
 		dtp->next = tp;
+		if (fund == T_PROCEDURE && tp) {
+			if (tp != bitset_type &&
+			    !(tp->tp_fund&(T_NUMERIC|T_INDEX|T_WORD|T_POINTER))) {
+				error("illegal procedure result type");
+			}
+		}
 		break;
+
 	case T_SET:
 		dtp->tp_align = word_align;
 		dtp->next = tp;
 		break;
+
 	case T_ARRAY:
 		dtp->tp_align = tp->tp_align;
 		dtp->next = tp;
 		break;
+
 	case T_SUBRANGE:
 		dtp->tp_align = tp->tp_align;
 		dtp->tp_size = tp->tp_size;
 		dtp->next = tp;
 		break;
+
 	default:
 		assert(0);
 	}
+
 	return dtp;
 }
 

lang/m2/comp/typequiv.c

@@ -95,15 +95,15 @@ TstCompat(tp1, tp2)
 		&&
 		   (tp2 == int_type || tp2 == card_type)
 		)
-	    ||
-		(tp1 == char_type && tp2 == charc_type)
-	    ||
-		(tp2 == char_type && tp1 == charc_type)
 	    ||
 		(  tp2 == intorcard_type
 		&&
 		   (tp1 == int_type || tp1 == card_type)
 		)
+	    ||
+		(tp1 == char_type && tp2 == charc_type)
+	    ||
+		(tp2 == char_type && tp1 == charc_type)
 	    ||
 		(  tp1 == address_type
 		&& 

lang/m2/comp/walk.c

@@ -24,6 +24,9 @@ extern arith	align();
 static int	prclev = 0;
 static label	instructionlabel = 0;
 static label	datalabel = 0;
+static label	return_label;
+static char	return_expr_occurred;
+static struct type *func_type;
 
 WalkModule(module)
 	register struct def *module;
@@ -72,9 +75,14 @@ WalkModule(module)
 	   this module.
 	*/
 	CurrentScope->sc_off = 0;
+	instructionlabel = 1;
+	return_label = instructionlabel++;
+	func_type = 0;
 	C_pro_narg(CurrentScope->sc_name);
 	MkCalls(CurrentScope->sc_def);
 	WalkNode(module->mod_body, (label) 0);
+	C_df_ilb(return_label);
+	C_ret((label) 0);
 	C_end(align(-CurrentScope->sc_off, word_size));
 
 	CurrentScope = scope;
@@ -100,9 +108,14 @@ WalkProcedure(procedure)
 	/* generate calls to initialization routines of modules defined within
 	   this procedure
 	*/
-	instructionlabel = 1;
+	return_label = 1;
+	instructionlabel = 2;
+	func_type = procedure->df_type->next;
 	MkCalls(CurrentScope->sc_def);
 	WalkNode(procedure->prc_body, (label) 0);
+	C_df_ilb(return_label);
+	if (func_type) C_ret((arith) align(func_type->tp_size, word_align));
+	else C_ret((arith) 0);
 	C_end(align(-CurrentScope->sc_off, word_size));
 	CurrentScope = scope;
 	prclev--;
@@ -255,7 +268,13 @@ WalkStat(nd, lab)
 		break;
 
 	case RETURN:
-		/* ??? */
+		if (right) {
+			WalkExpr(right);
+			if (!TstCompat(right->nd_type, func_type)) {
+node_error(right, "type incompatibility in RETURN statement");
+			}
+		}
+		C_bra(return_label);
 		break;
 
 	default:
@@ -270,13 +289,55 @@ ExpectBool(nd)
 		generate code to evaluate the expression.
 	*/
 
-	chk_expr(nd);
+	WalkExpr(nd);
 
 	if (nd->nd_type != bool_type && nd->nd_type != error_type) {
 		node_error(nd, "boolean expression expected");
 	}
-
-	/* generate code
-	*/
-	/* ??? */
 }
+
+WalkExpr(nd)
+	struct node *nd;
+{
+	/*	Check an expression and generate code for it
+	*/
+
+	DO_DEBUG(1, (DumpTree(nd), print("\n")));
+
+	if (chk_expr(nd)) {
+		/* ??? */
+	}
+}
+
+#ifdef DEBUG
+DumpTree(nd)
+	struct node *nd;
+{
+	char *s;
+	extern char *symbol2str();
+	
+	if (!nd) {
+		print("()");
+		return;
+	}
+
+	print("(");
+	DumpTree(nd->nd_left);
+	switch(nd->nd_class) {
+	case Def:	s = "Def"; break;
+	case Oper:	s = "Oper"; break;
+	case Uoper:	s = "Uoper"; break;
+	case Name:	s = "Name"; break;
+	case Set:	s = "Set"; break;
+	case Value:	s = "Value"; break;
+	case Call:	s = "Call"; break;
+	case Xset:	s = "Xset"; break;
+	case Stat:	s = "Stat"; break;
+	case Link:	s = "Link"; break;
+	default:	s = "ERROR"; break;
+	}
+	print("%s %s", s, symbol2str(nd->nd_symb));
+	DumpTree(nd->nd_right);
+	print(")");
+}
+#endif