newer version

lang/m2/comp/LLlex.c

@@ -33,7 +33,7 @@ int idfsize = IDFSIZE;
 extern int	cntlines;
 #endif
 
-static
+STATIC
 SkipComment()
 {
 	/*	Skip Modula-2 comments (* ... *).
@@ -50,16 +50,12 @@ SkipComment()
 			cntlines++;
 #endif
 		}
-		else
+		else if (ch == '(') {
-		if (ch == '(') {
 			LoadChar(ch);
-			if (ch == '*') {
+			if (ch == '*') ++NestLevel;
-				++NestLevel;
-			}
 			else	continue;
 		}
-		else
+		else if (ch == '*') {
-		if (ch == '*') {
 			LoadChar(ch);
 			if (ch == ')') {
 				if (NestLevel-- == 0) return;
@@ -70,7 +66,7 @@ SkipComment()
 	}
 }
 
-static
+STATIC
 GetString(upto)
 {
 	/*	Read a Modula-2 string, delimited by the character "upto".
@@ -118,11 +114,13 @@ LLlex()
 	register int ch, nch;
 
 	toktype = error_type;
+
 	if (ASIDE)	{	/* a token is put aside		*/
 		*tk = aside;
 		ASIDE = 0;
 		return tk->tk_symb;
 	}
+
 	tk->tk_lineno = LineNumber;
 
 again:
@@ -216,8 +214,7 @@ again:
 			LoadChar(ch);
 		} while(in_idf(ch));
 
-		if (ch != EOI)
+		if (ch != EOI) PushBack(ch);
-			PushBack(ch);
 		*tg++ = '\0';
 
 		tk->TOK_IDF = id = str2idf(buf, 1);
@@ -396,6 +393,7 @@ Sreal:
 				lexerror("floating constant too long");
 			}
 			else	tk->TOK_REL = Salloc(buf, np - buf) + 1;
+			toktype = real_type;
 			return tk->tk_symb = REAL;
 
 		default:

lang/m2/comp/Makefile

@@ -9,10 +9,11 @@ INCLUDES = -I$(HDIR) -I/usr/em/h -I$(PKGDIR) -I/user1/erikb/em/h
 
 LSRC =	tokenfile.g program.g declar.g expression.g statement.g
 CC =	cc
-GEN =	LLgen
+GEN =	/usr/em/util/LLgen/src/LLgen
-GENOPTIONS =
+GENOPTIONS = -d
-PROFILE = 
+PROFILE = -p
-CFLAGS = $(PROFILE) $(INCLUDES)
+CFLAGS = $(PROFILE) $(INCLUDES) -DSTATIC=
+LINTFLAGS = -DSTATIC= -DNORCSID
 LFLAGS = $(PROFILE)
 LOBJ =	tokenfile.o program.o declar.o expression.o statement.o
 COBJ =	LLlex.o LLmessage.o char.o error.o main.o \
@@ -46,7 +47,7 @@ clean:
 	rm -f $(OBJ) $(GENFILES) LLfiles 
 
 lint:	LLfiles hfiles
-	lint $(INCLUDES) -DNORCSID `sources $(OBJ)`
+	lint $(INCLUDES) $(LINTFLAGS) `sources $(OBJ)`
 
 tokenfile.g:	tokenname.c make.tokfile
 	make.tokfile <tokenname.c >tokenfile.g
@@ -98,16 +99,17 @@ defmodule.o: LLlex.h debug.h def.h f_info.h idf.h input.h inputtype.h main.h sco
 typequiv.o: LLlex.h def.h node.h type.h
 node.o: LLlex.h debug.h def.h node.h type.h
 cstoper.o: LLlex.h Lpars.h debug.h idf.h node.h standards.h target_sizes.h type.h
-chk_expr.o: LLlex.h Lpars.h const.h debug.h def.h idf.h node.h scope.h standards.h type.h
+chk_expr.o: LLlex.h Lpars.h chk_expr.h const.h debug.h def.h idf.h node.h scope.h standards.h type.h
 options.o: idfsize.h main.h ndir.h type.h
-walk.o: LLlex.h Lpars.h debug.h def.h desig.h f_info.h idf.h main.h node.h scope.h type.h
+walk.o: LLlex.h Lpars.h chk_expr.h debug.h def.h desig.h f_info.h idf.h main.h node.h scope.h type.h
 casestat.o: LLlex.h Lpars.h debug.h density.h desig.h node.h type.h
 desig.o: LLlex.h debug.h def.h desig.h node.h scope.h type.h
 code.o: LLlex.h Lpars.h debug.h def.h desig.h node.h scope.h standards.h type.h
 tmpvar.o: debug.h def.h scope.h type.h
+lookup.o: LLlex.h debug.h def.h idf.h node.h scope.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 debug.h def.h idf.h main.h misc.h node.h scope.h type.h
-expression.o: LLlex.h Lpars.h const.h debug.h def.h idf.h node.h type.h
+expression.o: LLlex.h Lpars.h chk_expr.h const.h debug.h def.h idf.h node.h type.h
 statement.o: LLlex.h Lpars.h def.h idf.h node.h scope.h type.h
 Lpars.o: Lpars.h

lang/m2/comp/chk_expr.c

@@ -23,81 +23,150 @@ static char *RcsId = "$Header$";
 #include	"scope.h"
 #include	"const.h"
 #include	"standards.h"
+#include	"chk_expr.h"
 
 extern char *symbol2str();
 
-int
+STATIC int
-chk_expr(expp)
+chk_arr(expp)
-	register struct node *expp;
+	struct node *expp;
 {
-	/*	Check the expression indicated by expp for semantic errors,
+	return chk_designator(expp, DESIGNATOR|VARIABLE, D_USED);
-		identify identifiers used in it, replace constants by
+}
-		their value, and try to evaluate the expression.
-	*/
 
-	switch(expp->nd_class) {
+STATIC int
-	case Arrsel:
+chk_value(expp)
-		return chk_designator(expp, DESIGNATOR|VARIABLE, D_USED);
+	struct node *expp;
-
+{
-	case Oper:
+	switch(expp->nd_symb) {
-		return	chk_oper(expp);
+	case REAL:
-
+	case STRING:
-	case Arrow:
+	case INTEGER:
-		return chk_designator(expp, DESIGNATOR|VARIABLE, D_USED);
+		return 1;
-
-	case Uoper:
-		return	chk_uoper(expp);
-
-	case Value:
-		switch(expp->nd_symb) {
-		case REAL:
-		case STRING:
-		case INTEGER:
-			return 1;
-
-		default:
-			crash("(chk_expr(Value))");
-		}
-		break;
-
-	case Xset:
-		return chk_set(expp);
-
-	case Link:
-	case Name:
-		if (chk_designator(expp, VALUE|DESIGNATOR, D_USED)) {
-			if (expp->nd_class == Def &&
-			    expp->nd_def->df_kind == D_PROCEDURE) {
-				/* Check that this procedure is one that we
-				   may take the address from.
-				*/
-				if (expp->nd_def->df_type == std_type) {
-					/* Standard procedure. Illegal */
-node_error(expp, "address of standard procedure taken");
-					return 0;
-				}
-				if (expp->nd_def->df_scope->sc_level > 0) {
-					/* Address of nested procedure taken.
-					   Illegal.
-					*/
-node_error(expp, "address of a procedure local to another one taken");
-					return 0;
-				}
-			}
-			return 1;
-		}
-		return 0;
-
-	case Call:
-		return chk_call(expp);
 
 	default:
-		crash("(chk_expr)");
+		crash("(chk_value)");
 	}
 	/*NOTREACHED*/
 }
 
-int
+STATIC int
+chk_linkorname(expp)
+	register struct node *expp;
+{
+	if (chk_designator(expp, VALUE|DESIGNATOR, D_USED)) {
+		if (expp->nd_class == Def &&
+		    expp->nd_def->df_kind == D_PROCEDURE) {
+			/* Check that this procedure is one that we
+			   may take the address from.
+			*/
+			if (expp->nd_def->df_type == std_type ||
+			    expp->nd_def->df_scope->sc_level > 0) {
+				/* Address of standard or nested procedure
+				   taken.
+				*/
+node_error(expp, "it is illegal to take the address of a standard or local procedure");
+				return 0;
+			}
+		}
+		return 1;
+	}
+	return 0;
+}
+
+STATIC int
+RemoveSet(set)
+	arith **set;
+{
+	/*	This routine is only used for error exits of chk_el.
+		It frees the set indicated by "set", and returns 0.
+	*/
+	if (*set) {
+		free((char *) *set);
+		*set = 0;
+	}
+	return 0;
+}
+
+STATIC int
+chk_el(expp, tp, set)
+	register struct node *expp;
+	register struct type *tp;
+	arith **set;
+{
+	/*	Check elements of a set. This routine may call itself
+		recursively.
+		Also try to compute the set!
+	*/
+	register struct node *left = expp->nd_left;
+	register struct node *right = expp->nd_right;
+	register int i;
+
+	if (expp->nd_class == Link && expp->nd_symb == UPTO) {
+		/* { ... , expr1 .. expr2,  ... }
+		   First check expr1 and expr2, and try to compute them.
+		*/
+		if (!chk_el(left, tp, set) || !chk_el(right, tp, set)) {
+			return 0;
+		}
+
+		if (left->nd_class == Value && right->nd_class == Value) {
+			/* We have a constant range. Put all elements in the
+			   set
+			*/
+
+		    	if (left->nd_INT > right->nd_INT) {
+node_error(expp, "lower bound exceeds upper bound in range");
+				return RemoveSet(set);
+			}
+
+			if (*set) {
+				for (i=left->nd_INT+1; i<right->nd_INT; i++) {
+					(*set)[i/wrd_bits] |= (1<<(i%wrd_bits));
+				}
+			}
+		}
+		else if (*set) {
+			free((char *) *set);
+			*set = 0;
+		}
+
+		return 1;
+	}
+
+	/* Here, a single element is checked
+	*/
+	if (!chk_expr(expp)) {
+		return RemoveSet(set);
+	}
+
+	if (!TstCompat(tp, expp->nd_type)) {
+		node_error(expp, "set element has incompatible type");
+		return RemoveSet(set);
+	}
+
+	if (expp->nd_class == Value) {
+		/* a constant element
+		*/
+		i = expp->nd_INT;
+
+	    	if ((tp->tp_fund != T_ENUMERATION &&
+		     (i < tp->sub_lb || i > tp->sub_ub))
+		   ||
+		    (tp->tp_fund == T_ENUMERATION &&
+		     (i < 0 || i > tp->enm_ncst))
+		   ) {
+			node_error(expp, "set element out of range");
+			return RemoveSet(set);
+		}
+
+		if (*set) (*set)[i/wrd_bits] |= (1 << (i%wrd_bits));
+	}
+
+	return 1;
+}
+
+STATIC int
 chk_set(expp)
 	register struct node *expp;
 {
@@ -174,126 +243,49 @@ node_error(expp, "specifier does not represent a set type");
 	return 1;
 }
 
-int
+STATIC struct node *
-chk_el(expp, tp, set)
-	register struct node *expp;
-	register struct type *tp;
-	arith **set;
-{
-	/*	Check elements of a set. This routine may call itself
-		recursively.
-		Also try to compute the set!
-	*/
-	register struct node *left = expp->nd_left;
-	register struct node *right = expp->nd_right;
-	register int i;
-
-	if (expp->nd_class == Link && expp->nd_symb == UPTO) {
-		/* { ... , expr1 .. expr2,  ... }
-		   First check expr1 and expr2, and try to compute them.
-		*/
-		if (!chk_el(left, tp, set) || !chk_el(right, tp, set)) {
-			return 0;
-		}
-
-		if (left->nd_class == Value && right->nd_class == Value) {
-			/* We have a constant range. Put all elements in the
-			   set
-			*/
-
-		    	if (left->nd_INT > right->nd_INT) {
-node_error(expp, "lower bound exceeds upper bound in range");
-				return rem_set(set);
-			}
-
-			if (*set) {
-				for (i=left->nd_INT+1; i<right->nd_INT; i++) {
-					(*set)[i/wrd_bits] |= (1<<(i%wrd_bits));
-				}
-			}
-		}
-		else if (*set) {
-			free((char *) *set);
-			*set = 0;
-		}
-
-		return 1;
-	}
-
-	/* Here, a single element is checked
-	*/
-	if (!chk_expr(expp)) {
-		return rem_set(set);
-	}
-
-	if (!TstCompat(tp, expp->nd_type)) {
-		node_error(expp, "set element has incompatible type");
-		return rem_set(set);
-	}
-
-	if (expp->nd_class == Value) {
-		/* a constant element
-		*/
-		i = expp->nd_INT;
-
-	    	if ((tp->tp_fund != T_ENUMERATION &&
-		     (i < tp->sub_lb || i > tp->sub_ub))
-		   ||
-		    (tp->tp_fund == T_ENUMERATION &&
-		     (i < 0 || i > tp->enm_ncst))
-		   ) {
-			node_error(expp, "set element out of range");
-			return rem_set(set);
-		}
-
-		if (*set) (*set)[i/wrd_bits] |= (1 << (i%wrd_bits));
-	}
-
-	return 1;
-}
-
-int
-rem_set(set)
-	arith **set;
-{
-	/*	This routine is only used for error exits of chk_el.
-		It frees the set indicated by "set", and returns 0.
-	*/
-	if (*set) {
-		free((char *) *set);
-		*set = 0;
-	}
-	return 0;
-}
-
-struct node *
 getarg(argp, bases, designator)
 	struct node **argp;
 {
+	/*	This routine is used to fetch the next argument from an
+		argument list. The argument list is indicated by "argp".
+		The parameter "bases" is a bitset indicating which types
+		are allowed at this point, and "designator" is a flag
+		indicating that the address from this argument is taken, so
+		that it must be a designator and may not be a register
+		variable.
+	*/
 	struct type *tp;
 	register struct node *arg = *argp;
+	register struct node *left;
 
-	if (!arg->nd_right) {
+	if (! arg->nd_right) {
 		node_error(arg, "too few arguments supplied");
 		return 0;
 	}
+
 	arg = arg->nd_right;
-	if ((!designator && !chk_expr(arg->nd_left)) ||
+	left = arg->nd_left;
-	    (designator && !chk_designator(arg->nd_left, DESIGNATOR, D_REFERRED))) {
+
+	if ((!designator && !chk_expr(left)) ||
+	    (designator &&
+	     !chk_designator(left, DESIGNATOR|VARIABLE, D_USED|D_NOREG))) {
 		return 0;
 	}
-	tp = arg->nd_left->nd_type;
+
+	tp = left->nd_type;
 	if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
+
 	if (bases && !(tp->tp_fund & bases)) {
 		node_error(arg, "unexpected type");
 		return 0;
 	}
 
 	*argp = arg;
-	return arg->nd_left;
+	return left;
 }
 
-struct node *
+STATIC struct node *
 getname(argp, kinds)
 	struct node **argp;
 {
@@ -303,10 +295,11 @@ getname(argp, kinds)
 		node_error(arg, "too few arguments supplied");
 		return 0;
 	}
+
 	arg = arg->nd_right;
 	if (! chk_designator(arg->nd_left, 0, D_REFERRED)) return 0;
 
-	assert(arg->nd_left->nd_class == Def);
+	if (arg->nd_left->nd_class != Def);
 
 	if (!(arg->nd_left->nd_def->df_kind & kinds)) {
 		node_error(arg, "unexpected type");
@@ -317,6 +310,42 @@ getname(argp, kinds)
 	return arg->nd_left;
 }
 
+STATIC int
+chk_proccall(expp)
+	register struct node *expp;
+{
+	/*	Check a procedure call
+	*/
+	register struct node *left;
+	struct node *arg;
+	register struct paramlist *param;
+
+	left = expp->nd_left;
+	arg = expp;
+	expp->nd_type = left->nd_type->next;
+
+	for (param = left->nd_type->prc_params; param; param = param->next) {
+		if (!(left = getarg(&arg, 0, IsVarParam(param)))) return 0;
+		if (left->nd_symb == STRING) {
+			TryToString(left, TypeOfParam(param));
+		}
+		if (! TstParCompat(TypeOfParam(param),
+				   left->nd_type,
+				   IsVarParam(param),
+				   left)) {
+node_error(left, "type incompatibility in parameter");
+			return 0;
+		}
+	}
+
+	if (arg->nd_right) {
+		node_error(arg->nd_right, "too many parameters supplied");
+		return 0;
+	}
+
+	return 1;
+}
+
 int
 chk_call(expp)
 	register struct node *expp;
@@ -358,58 +387,7 @@ chk_call(expp)
 	return 0;
 }
 
-chk_proccall(expp)
+STATIC int
-	register struct node *expp;
-{
-	/*	Check a procedure call
-	*/
-	register struct node *left;
-	struct node *arg;
-	register struct paramlist *param;
-
-	left = 0;
-	arg = expp->nd_right;
-	/* First, reverse the order in the argument list */
-	while (arg) {
-		expp->nd_right = arg;
-		arg = arg->nd_right;
-		expp->nd_right->nd_right = left;
-		left = expp->nd_right;
-	}
-
-	left = expp->nd_left;
-	arg = expp;
-	expp->nd_type = left->nd_type->next;
-	param = left->nd_type->prc_params;
-
-	while (param) {
-		if (!(left = getarg(&arg, 0, IsVarParam(param)))) return 0;
-		if (left->nd_symb == STRING) {
-			TryToString(left, TypeOfParam(param));
-		}
-		if (! TstParCompat(TypeOfParam(param),
-				   left->nd_type,
-				   IsVarParam(param),
-				   left)) {
-node_error(left, "type incompatibility in parameter");
-			return 0;
-		}
-		if (IsVarParam(param) && left->nd_class == Def) {
-			left->nd_def->df_flags |= D_NOREG;
-		}
-
-		param = param->next;
-	}
-
-	if (arg->nd_right) {
-		node_error(arg->nd_right, "too many parameters supplied");
-		return 0;
-	}
-
-	return 1;
-}
-
-static int
 FlagCheck(expp, df, flag)
 	struct node *expp;
 	struct def *df;
@@ -461,7 +439,6 @@ chk_designator(expp, flag, dflags)
 	*/
 	register struct def *df;
 	register struct type *tp;
-	struct def *lookfor();
 
 	expp->nd_type = error_type;
 
@@ -469,23 +446,20 @@ chk_designator(expp, flag, dflags)
 		expp->nd_def = lookfor(expp, CurrVis, 1);
 		expp->nd_class = Def;
 		expp->nd_type = expp->nd_def->df_type;
-		if (expp->nd_type == error_type) return 0;
 	}
+	else if (expp->nd_class == Link) {
+		register struct node *left = expp->nd_left;
 
-	if (expp->nd_class == Link) {
 		assert(expp->nd_symb == '.');
 
-		if (! chk_designator(expp->nd_left,
+		if (! chk_designator(left,
-				     flag|HASSELECTORS,
+				     (flag&DESIGNATOR)|HASSELECTORS,
-				     dflags|D_NOREG)) return 0;
+				     dflags)) return 0;
-
-		tp = expp->nd_left->nd_type;
 
+		tp = left->nd_type;
 		assert(tp->tp_fund == T_RECORD);
 
-		df = lookup(expp->nd_IDF, tp->rec_scope);
+		if (!(df = lookup(expp->nd_IDF, tp->rec_scope))) {
-
-		if (!df) {
 			id_not_declared(expp);
 			return 0;
 		}
@@ -493,17 +467,19 @@ chk_designator(expp, flag, dflags)
 			expp->nd_def = df;
 			expp->nd_type = df->df_type;
 			if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
+				/* Fields of a record are always D_QEXPORTED,
+				   so ...
+				*/
 node_error(expp, "identifier \"%s\" not exported from qualifying module",
 df->df_idf->id_text);
 				return 0;
 			}
 		}
 
-		if (expp->nd_left->nd_class == Def &&
+		if (left->nd_class == Def &&
-		    expp->nd_left->nd_def->df_kind == D_MODULE) {
+		    left->nd_def->df_kind == D_MODULE) {
 			expp->nd_class = Def;
-			expp->nd_def = df;
+			FreeNode(left);
-			FreeNode(expp->nd_left);
 			expp->nd_left = 0;
 		}
 		else {
@@ -548,12 +524,12 @@ df->df_idf->id_text);
 		assert(expp->nd_symb == '[');
 
 		if ( 
-		    	!chk_designator(expp->nd_left, DESIGNATOR|VARIABLE, dflags|D_NOREG)
+		     !chk_designator(expp->nd_left, DESIGNATOR|VARIABLE, dflags)
 		   ||
-		    	!chk_expr(expp->nd_right)
+		     !chk_expr(expp->nd_right)
 		   ||
-		    	expp->nd_left->nd_type == error_type
+		     expp->nd_left->nd_type == error_type
-		   ) return 0;
+		   )	return 0;
 
 		tpr = expp->nd_right->nd_type;
 		tpl = expp->nd_left->nd_type;
@@ -598,7 +574,7 @@ symbol2str(expp->nd_symb));
 	return 0;
 }
 
-struct type *
+STATIC struct type *
 ResultOfOperation(operator, tp)
 	struct type *tp;
 {
@@ -616,13 +592,13 @@ ResultOfOperation(operator, tp)
 	return tp;
 }
 
-int
+STATIC int
 Boolean(operator)
 {
 	return operator == OR || operator == AND || operator == '&';
 }
 
-int
+STATIC int
 AllowedTypes(operator)
 {
 	switch(operator) {
@@ -654,7 +630,23 @@ AllowedTypes(operator)
 	/*NOTREACHED*/
 }
 
-int
+STATIC int
+chk_address(tpl, tpr)
+	register struct type *tpl, *tpr;
+{
+	
+	if (tpl == address_type) {
+		return tpr == address_type || tpr->tp_fund != T_POINTER;
+	}
+
+	if (tpr == address_type) {
+		return tpl->tp_fund != T_POINTER;
+	}
+
+	return 0;
+}
+
+STATIC int
 chk_oper(expp)
 	register struct node *expp;
 {
@@ -741,23 +733,7 @@ node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_
 	return 1;
 }
 
-int
+STATIC int
-chk_address(tpl, tpr)
-	register struct type *tpl, *tpr;
-{
-	
-	if (tpl == address_type) {
-		return tpr == address_type || tpr->tp_fund != T_POINTER;
-	}
-
-	if (tpr == address_type) {
-		return tpl->tp_fund != T_POINTER;
-	}
-
-	return 0;
-}
-
-int
 chk_uoper(expp)
 	register struct node *expp;
 {
@@ -826,7 +802,7 @@ chk_uoper(expp)
 	return 0;
 }
 
-struct node *
+STATIC struct node *
 getvariable(argp)
 	struct node **argp;
 {
@@ -916,7 +892,11 @@ DO_DEBUG(3,debug("standard name \"%s\", %d",left->nd_def->df_idf->id_text,std));
 
 	case S_MAX:
 	case S_MIN:
-		if (!(left = getarg(&arg, T_DISCRETE, 0))) return 0;
+		if (!(left = getname(&arg, D_ISTYPE))) return 0;
+		if (!(left->nd_type->tp_fund & (T_DISCRETE))) {
+			node_error(left, "illegal type in MIN or MAX");
+			return 0;
+		}
 		expp->nd_type = left->nd_type;
 		cstcall(expp,std);
 		break;
@@ -1072,7 +1052,8 @@ TryToString(nd, tp)
 	struct node *nd;
 	struct type *tp;
 {
-	/*	Try a coercion from character constant to string */
+	/*	Try a coercion from character constant to string.
+	*/
 	if (tp->tp_fund == T_ARRAY && nd->nd_type == char_type) {
 		int ch = nd->nd_INT;
 
@@ -1084,3 +1065,20 @@ TryToString(nd, tp)
 		nd->nd_SLE = 1;
 	}
 }
+
+extern int	NodeCrash();
+
+int (*ChkTable[])() = {
+	chk_value,
+	chk_arr,
+	chk_oper,
+	chk_uoper,
+	chk_arr,
+	chk_call,
+	chk_linkorname,
+	NodeCrash,
+	chk_set,
+	NodeCrash,
+	NodeCrash,
+	chk_linkorname
+};

lang/m2/comp/chk_expr.h

@@ -0,0 +1,9 @@
+/* E X P R E S S I O N   C H E C K I N G */
+
+/* $Header$ */
+
+extern int	(*ChkTable[])();	/* table of expression checking
+					   functions, indexed by node class
+					*/
+
+#define	chk_expr(expp)	((*ChkTable[(expp)->nd_class])(expp))

lang/m2/comp/code.c

@@ -129,7 +129,6 @@ CodeExpr(nd, ds, true_label, false_label)
 		break;
 
 	case Uoper:
-		CodePExpr(nd->nd_right);
 		CodeUoper(nd);
 		ds->dsg_kind = DSG_LOADED;
 		break;
@@ -194,9 +193,9 @@ CodeCoercion(t1, t2)
 {
 	register int fund1, fund2;
 
-	if (t1 == t2) return;
 	if (t1->tp_fund == T_SUBRANGE) t1 = t1->next;
 	if (t2->tp_fund == T_SUBRANGE) t2 = t2->next;
+	if (t1 == t2) return;
 	if ((fund1 = t1->tp_fund) == T_WORD) fund1 = T_INTEGER;
 	if ((fund2 = t2->tp_fund) == T_WORD) fund2 = T_INTEGER;
 	switch(fund1) {
@@ -291,9 +290,6 @@ CodeCall(nd)
 		and result is already done.
 	*/
 	register struct node *left = nd->nd_left;
-	register struct node *arg = nd;
-	register struct paramlist *param;
-	struct type *tp;
 
 	if (left->nd_type == std_type) {
 		CodeStd(nd);
@@ -311,49 +307,10 @@ CodeCall(nd)
 
 	assert(IsProcCall(left));
 
-	for (param = left->nd_type->prc_params; param; param = param->next) {
+	if (nd->nd_right) {
-		tp = TypeOfParam(param);
+		CodeParameters(left->nd_type->prc_params, nd->nd_right);
-		arg = arg->nd_right;
-		assert(arg != 0);
-		left = arg->nd_left;
-		if (IsConformantArray(tp)) {
-			C_loc(tp->arr_elsize);
-			if (IsConformantArray(left->nd_type)) {
-				DoHIGH(left);
-			}
-			else if (left->nd_symb == STRING) {
-				C_loc(left->nd_SLE);
-			}
-			else if (tp->arr_elem == word_type) {
-				C_loc(left->nd_type->tp_size / word_size - 1);
-			}
-			else {
-				tp = left->nd_type->next;
-				if (tp->tp_fund == T_SUBRANGE) {
-					C_loc(tp->sub_ub - tp->sub_lb);
-				}
-				else	C_loc((arith) (tp->enm_ncst - 1));
-			}
-			C_loc((arith) 0);
-			if (left->nd_symb == STRING) {
-				CodeString(left);
-			}
-			else	CodeDAddress(left);
-		}
-		else if (IsVarParam(param)) {
-			CodeDAddress(left);
-		}
-		else {
-			if (left->nd_type->tp_fund == T_STRING) {
-				CodePadString(left, tp->tp_size);
-			}
-			else CodePExpr(left);
-			CheckAssign(left->nd_type, tp);
-		}
 	}
 
-	left = nd->nd_left;
-
 	if (left->nd_class == Def && left->nd_def->df_kind == D_PROCEDURE) {
 		if (left->nd_def->df_scope->sc_level > 0) {
 			C_lxl((arith) proclevel - left->nd_def->df_scope->sc_level);
@@ -373,6 +330,63 @@ CodeCall(nd)
 	}
 }
 
+CodeParameters(param, arg)
+	struct paramlist *param;
+	struct node *arg;
+{
+	register struct type *tp;
+	register struct node *left;
+	
+	assert(param != 0 && arg != 0);
+
+	if (param->next) {
+		CodeParameters(param->next, arg->nd_right);
+	}
+
+	tp = TypeOfParam(param);
+	left = arg->nd_left;
+	if (IsConformantArray(tp)) {
+		C_loc(tp->arr_elsize);
+		if (IsConformantArray(left->nd_type)) {
+			DoHIGH(left);
+			if (tp->arr_elem->tp_size != left->nd_type->arr_elem->tp_size) {
+				/* This can only happen if the formal type is
+				   ARRAY OF WORD
+				*/
+				/* ??? */
+			}
+		}
+		else if (left->nd_symb == STRING) {
+			C_loc(left->nd_SLE);
+		}
+		else if (tp->arr_elem == word_type) {
+			C_loc(left->nd_type->tp_size / word_size - 1);
+		}
+		else {
+			tp = left->nd_type->next;
+			if (tp->tp_fund == T_SUBRANGE) {
+				C_loc(tp->sub_ub - tp->sub_lb);
+			}
+			else	C_loc((arith) (tp->enm_ncst - 1));
+		}
+		C_loc((arith) 0);
+		if (left->nd_symb == STRING) {
+			CodeString(left);
+		}
+		else	CodeDAddress(left);
+	}
+	else if (IsVarParam(param)) {
+		CodeDAddress(left);
+	}
+	else {
+		if (left->nd_type->tp_fund == T_STRING) {
+			CodePadString(left, tp->tp_size);
+		}
+		else CodePExpr(left);
+		CheckAssign(left->nd_type, tp);
+	}
+}
+
 CodeStd(nd)
 	struct node *nd;
 {
@@ -387,7 +401,6 @@ CodeStd(nd)
 		if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
 		arg = arg->nd_right;
 	}
-	Desig = InitDesig;
 
 	switch(std = nd->nd_left->nd_def->df_value.df_stdname) {
 	case S_ABS:
@@ -546,14 +559,12 @@ CheckAssign(tpl, tpr)
 	*/
 
 	arith llo, lhi, rlo, rhi;
-	label l = 0;
-	extern label getrck();
 
 	if (bounded(tpl)) {
 		/* in this case we might need a range check */
 		if (!bounded(tpr)) {
 			/* yes, we need one */
-			l = getrck(tpl);
+			genrck(tpl);
 		}
 		else {
 			/* both types are restricted. check the bounds
@@ -562,14 +573,9 @@ CheckAssign(tpl, tpr)
 			getbounds(tpl, &llo, &lhi);
 			getbounds(tpr, &rlo, &rhi);
 			if (llo > rlo || lhi < rhi) {
-				l = getrck(tpl);
+				genrck(tpl);
 			}
 		}
-
-		if (l) {
-			C_lae_dlb(l, (arith) 0);
-			C_rck(word_size);
-		}
 	}
 }
 
@@ -916,6 +922,7 @@ CodeUoper(nd)
 {
 	register struct type *tp = nd->nd_type;
 
+	CodePExpr(nd->nd_right);
 	switch(nd->nd_symb) {
 	case '~':
 	case NOT:

lang/m2/comp/declar.g

@@ -461,7 +461,6 @@ PointerType(struct type **ptp;)
 {
 	struct type *tp;
 	struct def *df;
-	struct def *lookfor();
 	struct node *nd;
 } :
 	POINTER TO

lang/m2/comp/def.H

@@ -117,7 +117,11 @@ struct def	{		/* list of definitions for a name */
 
 extern struct def
 	*define(),
-	*lookup(),
+	*DefineLocalModule(),
+	*MkDef(),
 	*ill_df;
 
+extern struct def
+	*lookup(),
+	*lookfor();
 #define NULLDEF ((struct def *) 0)

lang/m2/comp/def.c

@@ -203,7 +203,7 @@ DeclProc(type)
 		df->for_node = MkLeaf(Name, &dot);
 		sprint(buf,"%s_%s",CurrentScope->sc_name,df->df_idf->id_text);
 		df->for_name = Salloc(buf, (unsigned) (strlen(buf)+1));
-		C_exp(df->for_name);
+		if (CurrVis == Defined->mod_vis) C_exp(df->for_name);
 		open_scope(OPENSCOPE);
 	}
 	else {
@@ -292,6 +292,51 @@ DefInFront(df)
 	}
 }
 
+struct def *
+DefineLocalModule(id)
+	struct idf *id;
+{
+	/*	Create a definition for a local module. Also give it
+		a name to be used for code generation.
+	*/
+	register struct def *df = define(id, CurrentScope, D_MODULE);
+	register struct type *tp;
+	register struct scope *sc;
+	static int modulecount = 0;
+	char buf[256];
+	extern char *sprint();
+	extern int proclevel;
+
+	sprint(buf, "_%d%s", ++modulecount, id->id_text);
+
+	if (!df->mod_vis) {	
+		/* We never saw the name of this module before. Create a
+		   scope for it.
+		*/
+	  	open_scope(CLOSEDSCOPE);
+	  	df->mod_vis = CurrVis;
+	}
+
+	CurrVis = df->mod_vis;
+
+	sc = CurrentScope;
+	sc->sc_level = proclevel;
+	sc->sc_definedby = df;
+	sc->sc_name = Salloc(buf, (unsigned) (strlen(buf) + 1));
+
+	/* Create a type for it
+	*/
+	df->df_type = tp = standard_type(T_RECORD, 0, (arith) 0);
+	tp->rec_scope = sc;
+
+	/* Generate code that indicates that the initialization procedure
+	   for this module is local.
+	*/
+	C_inp(buf);
+
+	return df;
+}
+
 #ifdef DEBUG
 PrDef(df)
 	register struct def *df;

lang/m2/comp/desig.c

@@ -25,7 +25,6 @@ static char *RcsId = "$Header$";
 #include	"node.h"
 
 extern int	proclevel;
-struct desig	Desig;
 struct desig	InitDesig = {DSG_INIT, 0, 0};
 
 CodeValue(ds, size)
@@ -225,6 +224,7 @@ CodeVarDesig(df, ds)
 	*/
 	assert(ds->dsg_kind == DSG_INIT);
 
+	df->df_flags |= D_USED;
 	if (df->var_addrgiven) {
 		/* the programmer specified an address in the declaration of
 		   the variable. Generate code to push the address.
@@ -232,7 +232,6 @@ CodeVarDesig(df, ds)
 		CodeConst(df->var_off, pointer_size);
 		ds->dsg_kind = DSG_PLOADED;
 		ds->dsg_offset = 0;
-		df->df_flags |= D_NOREG;
 		return;
 	}
 
@@ -243,7 +242,6 @@ CodeVarDesig(df, ds)
 		ds->dsg_name = df->var_name;
 		ds->dsg_offset = 0;
 		ds->dsg_kind = DSG_FIXED;
-		df->df_flags |= D_NOREG;
 		return;
 	}
 
@@ -251,6 +249,8 @@ CodeVarDesig(df, ds)
 		/* the variable is local to a statically enclosing procedure.
 		*/
 		assert(proclevel > sc->sc_level);
+
+		df->df_flags |= D_NOREG;
 		if (df->df_flags & (D_VARPAR|D_VALPAR)) {
 			/* value or var parameter
 			*/
@@ -269,7 +269,6 @@ CodeVarDesig(df, ds)
 		else	C_lxl((arith) (proclevel - sc->sc_level));
 		ds->dsg_kind = DSG_PLOADED;
 		ds->dsg_offset = df->var_off;
-		df->df_flags |= D_NOREG;
 		return;
 	}
 

lang/m2/comp/desig.h

@@ -50,6 +50,6 @@ struct withdesig {
 };
 
 extern struct withdesig	*WithDesigs;
-extern struct desig	Desig, InitDesig;
+extern struct desig	InitDesig;
 
 #define NO_LABEL	((label) 0)

lang/m2/comp/enter.c

@@ -116,6 +116,7 @@ EnterVarList(Idlist, type, local)
 			/* An address was supplied
 			*/
 			df->var_addrgiven = 1;
+			df->df_flags |= D_NOREG;
 			if (idlist->nd_left->nd_type != card_type) {
 node_error(idlist->nd_left,"Illegal type for address");
 			}
@@ -137,9 +138,12 @@ node_error(idlist->nd_left,"Illegal type for address");
 			sprint(buf,"%s_%s", sc->sc_scope->sc_name,
 					    df->df_idf->id_text);
 			df->var_name = Salloc(buf, (unsigned)(strlen(buf)+1));
+			df->df_flags |= D_NOREG;
 
  			if (DefinitionModule) {
-				C_exa_dnam(df->var_name);
+				if (sc == Defined->mod_vis) {
+					C_exa_dnam(df->var_name);
+				}
 			}
 			else {
 				C_ina_dnam(df->var_name);
@@ -163,11 +167,16 @@ EnterParamList(ppr, Idlist, type, VARp, off)
 	register struct paramlist *pr;
 	register struct def *df;
 	register struct node *idlist = Idlist;
+	static struct paramlist *last;
 
 	for ( ; idlist; idlist = idlist->next) {
 		pr = new_paramlist();
-		pr->next = *ppr;
+		pr->next = 0;
-		*ppr = pr;
+		if (!*ppr) {
+			*ppr = pr;
+		}
+		else	last->next = pr;
+		last = pr;
 		df = define(idlist->nd_IDF, CurrentScope, D_VARIABLE);
 		pr->par_def = df;
 		df->df_type = type;
@@ -188,7 +197,7 @@ EnterParamList(ppr, Idlist, type, VARp, off)
 	FreeNode(Idlist);
 }
 
-static
+STATIC
 DoImport(df, scope)
 	register struct def *df;
 	struct scope *scope;
@@ -222,7 +231,7 @@ DoImport(df, scope)
 	}
 }
 
-static struct scopelist *
+STATIC struct scopelist *
 ForwModule(df, idn)
 	register struct def *df;
 	struct node *idn;
@@ -248,7 +257,7 @@ ForwModule(df, idn)
 	return vis;
 }
 
-static struct def *
+STATIC struct def *
 ForwDef(ids, scope)
 	register struct node *ids;
 	struct scope *scope;
@@ -351,7 +360,7 @@ EnterFromImportList(Idlist, Fromid, local)
 	register struct def *df;
 	struct scopelist *vis = enclosing(CurrVis);
 	int forwflag = 0;
-	extern struct def *lookfor(), *GetDefinitionModule();
+	extern struct def *GetDefinitionModule();
 
 	if (local) {
 		df = lookfor(Fromid, vis, 0);
@@ -412,7 +421,7 @@ EnterImportList(Idlist, local)
 	register struct node *idlist = Idlist;
 	register struct def *df;
 	struct scopelist *vis = enclosing(CurrVis);
-	extern struct def *lookfor(), *GetDefinitionModule();
+	extern struct def *GetDefinitionModule();
 
 	for (; idlist; idlist = idlist->next) {
 		if (local) df = ForwDef(idlist, vis->sc_scope);

lang/m2/comp/expression.g

@@ -18,19 +18,17 @@ static char *RcsId = "$Header$";
 #include	"node.h"
 #include	"const.h"
 #include	"type.h"
+#include	"chk_expr.h"
 }
 
-number(struct node **p;)
+number(struct node **p;) :
-{
-	struct type *tp;
-} :
 [
 	%default
-	INTEGER		{ tp = toktype; }
+	INTEGER
 |
-	REAL		{ tp = real_type; }
+	REAL
 ]			{ *p = MkLeaf(Value, &dot);
-			  (*p)->nd_type = tp;
+			  (*p)->nd_type = toktype;
 			}
 ;
 

lang/m2/comp/lookup.c

@@ -16,8 +16,6 @@ static char *RcsId = "$Header$";
 #include	"LLlex.h"
 #include	"node.h"
 
-extern struct def	*MkDef();
-
 struct def *
 lookup(id, scope)
 	register struct idf *id;

lang/m2/comp/misc.c

@@ -15,7 +15,7 @@ static char *RcsId = "$Header$";
 #include	"node.h"
 
 match_id(id1, id2)
-	struct idf *id1, *id2;
+	register struct idf *id1, *id2;
 {
 	/*	Check that identifiers id1 and id2 are equal. If they
 		are not, check that we did'nt generate them in the
@@ -45,7 +45,7 @@ gen_anon_idf()
 }
 
 id_not_declared(id)
-	struct node *id;
+	register struct node *id;
 {
 	/*	The identifier "id" is not declared. If it is not generated,
 		give an error message

lang/m2/comp/node.H

@@ -19,6 +19,7 @@ struct node {
 #define Def	9		/* an identified name */
 #define Stat	10		/* a statement */
 #define Link	11
+				/* do NOT change the order or the numbers!!! */
 	struct type *nd_type;	/* type of this node */
 	struct token nd_token;
 #define nd_set		nd_token.tk_data.tk_set

lang/m2/comp/node.c

@@ -64,11 +64,17 @@ FreeNode(nd)
 	free_node(nd);
 }
 
+NodeCrash(expp)
+	struct node *expp;
+{
+	crash("Illegal node %d", expp->nd_class);
+}
+
 #ifdef DEBUG
 
 extern char *symbol2str();
 
-static
+STATIC
 printnode(nd)
 	register struct node *nd;
 {

lang/m2/comp/program.g

@@ -42,36 +42,13 @@ static  char *RcsId = "$Header$";
 ModuleDeclaration
 {
 	struct idf *id;
-	register struct def *df;
+	struct def *df;
-	extern int proclevel;
-	static int modulecount = 0;
-	char buf[256];
 	struct node *nd;
 	struct node *exportlist = 0;
 	int qualified;
-	extern char *sprint();
 } :
-	MODULE IDENT	{
+	MODULE IDENT	{ id = dot.TOK_IDF;
-			  id = dot.TOK_IDF;
+			  df = DefineLocalModule(id);
-			  df = define(id, CurrentScope, D_MODULE);
-
-			  if (!df->mod_vis) {	
-			  	open_scope(CLOSEDSCOPE);
-			  	df->mod_vis = CurrVis;
-			  }
-			  else {
-				CurrVis = df->mod_vis;
-				CurrentScope->sc_level = proclevel;
-			  }
-			  CurrentScope->sc_definedby = df;
-
-			  df->df_type = standard_type(T_RECORD, 0, (arith) 0);
-			  df->df_type->rec_scope = df->mod_vis->sc_scope;
-			  sprint(buf, "_%d%s", ++modulecount, id->id_text);
-			  CurrentScope->sc_name =
-				Salloc(buf, (unsigned) (strlen(buf) + 1));
-			  if (! proclevel) C_ina_dnam(&buf[1]);
-			  C_inp(buf);
 			}
 	priority(&(df->mod_priority))?
 	';'
@@ -92,7 +69,7 @@ priority(arith *pprio;)
 	struct node *nd;
 } :
 	'[' ConstExpression(&nd) ']'
-			{ if (!(nd->nd_type->tp_fund & T_INTORCARD)) {
+			{ if (!(nd->nd_type->tp_fund & T_CARDINAL)) {
 				node_error(nd, "Illegal priority");
 			  }
 			  *pprio = nd->nd_INT;
@@ -141,13 +118,12 @@ DefinitionModule
 	int dummy;
 } :
 	DEFINITION
-	MODULE IDENT	{ 
+	MODULE IDENT	{ id = dot.TOK_IDF;
-			  id = dot.TOK_IDF;
 			  df = define(id, GlobalScope, D_MODULE);
-			  if (!SYSTEMModule) open_scope(CLOSEDSCOPE);
 			  if (!Defined) Defined = df;
-			  df->mod_vis = CurrVis;
+			  if (!SYSTEMModule) open_scope(CLOSEDSCOPE);
 			  CurrentScope->sc_name = id->id_text;
+			  df->mod_vis = CurrVis;
 			  df->df_type = standard_type(T_RECORD, 0, (arith) 0);
 			  df->df_type->rec_scope = df->mod_vis->sc_scope;
 			  DefinitionModule++;
@@ -222,8 +198,7 @@ ProgramModule
 	struct node *nd;
 } :
 	MODULE
-	IDENT	{ 
+	IDENT	{ id = dot.TOK_IDF;
-		  id = dot.TOK_IDF;
 		  if (state == IMPLEMENTATION) {
 			df = GetDefinitionModule(id);
 			CurrVis = df->mod_vis;
@@ -232,11 +207,11 @@ ProgramModule
 		  }
 		  else {
 			df = define(id, CurrentScope, D_MODULE);
-		  	Defined = df;
 			open_scope(CLOSEDSCOPE);
 			df->mod_vis = CurrVis;
 			CurrentScope->sc_name = id->id_text;
 		  }
+		  Defined = df;
 		  CurrentScope->sc_definedby = df;
 		}
 	priority(&(df->mod_priority))?

lang/m2/comp/scope.C

@@ -90,7 +90,7 @@ Forward(tk, ptp)
 	CurrentScope->sc_forw = f;
 }
 
-static
+STATIC
 chk_proc(df)
 	register struct def *df;
 {
@@ -108,7 +108,7 @@ node_error(df->for_node, "procedure \"%s\" not defined", df->df_idf->id_text);
 	}
 }
 
-static
+STATIC
 chk_forw(pdf)
 	register struct def **pdf;
 {
@@ -153,7 +153,7 @@ node_error((*pdf)->for_node, "identifier \"%s\" has not been declared",
 	}
 }
 
-static
+STATIC
 rem_forwards(fo)
 	struct forwards *fo;
 {
@@ -161,7 +161,6 @@ rem_forwards(fo)
 	*/
 	register struct forwards *f;
 	register struct def *df;
-	struct def *lookfor();
 
 	while (f = fo) {
 		df = lookfor(&(f->fo_tok), CurrVis, 1);
@@ -181,11 +180,10 @@ Reverse(pdf)
 	/*	Reverse the order in the list of definitions in a scope.
 		This is neccesary because this list is built in reverse.
 		Also, while we're at it, remove uninteresting definitions
-		from this list. The only interesting definitions are:
+		from this list.
-		D_MODULE, D_PROCEDURE, and D_PROCHEAD.
 	*/
 	register struct def *df, *df1;
-#define INTERESTING D_MODULE|D_PROCEDURE|D_PROCHEAD
+#define INTERESTING D_MODULE|D_PROCEDURE|D_PROCHEAD|D_VARIABLE
 
 	df = 0;
 	df1 = *pdf;
@@ -217,7 +215,6 @@ close_scope(flag)
 	register struct scope *sc = CurrentScope;
 
 	assert(sc != 0);
-	DO_DEBUG(1, debug("Closing a scope"));
 
 	if (flag) {
 		if (sc->sc_forw) rem_forwards(sc->sc_forw);

lang/m2/comp/statement.g

@@ -83,13 +83,17 @@ ProcedureCall:
 
 StatementSequence(register struct node **pnd;)
 {
+	struct node *nd;
 } :
 	statement(pnd)
 	[
-		';'	{ *pnd = MkNode(Link, *pnd, NULLNODE, &dot);
+		';' statement(&nd)
-			  pnd = &((*pnd)->nd_right);
+			{ if (nd) {
+				*pnd = MkNode(Link, *pnd, nd, &dot);
+				(*pnd)->nd_symb = ';';
+			  	pnd = &((*pnd)->nd_right);
+			  }
 			}
-		statement(pnd)
 	]*
 ;
 

lang/m2/comp/type.c

@@ -21,9 +21,6 @@ static char *RcsId = "$Header$";
 #include	"const.h"
 #include	"scope.h"
 
-/*	To be created dynamically in main() from defaults or from command
-	line parameters.
-*/
 int
 	word_align = AL_WORD,
 	int_align = AL_INT,
@@ -96,38 +93,34 @@ construct_type(fund, tp)
 
 	switch (fund)	{
 	case T_PROCEDURE:
+		if (tp && !returntype(tp)) {
+			error("illegal procedure result type");
+		}
+		/* Fall through */
 	case T_POINTER:
 	case T_HIDDEN:
 		dtp->tp_align = pointer_align;
 		dtp->tp_size = pointer_size;
-		dtp->next = tp;
-		if (fund == T_PROCEDURE && tp) {
-			if (! returntype(tp)) {
-				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:
 		crash("funny type constructor");
 	}
 
+	dtp->next = tp;
 	return dtp;
 }
 
@@ -206,8 +199,11 @@ InitTypes()
 	address_type = construct_type(T_POINTER, word_type);
 
 	/* create BITSET type
+	   TYPE BITSET = SET OF [0..W-1];
+	   The subrange is a subrange of type cardinal, because the lower bound
+	   is a non-negative integer (See Rep. 6.3)
 	*/
-	tp = construct_type(T_SUBRANGE, int_type);
+	tp = construct_type(T_SUBRANGE, card_type);
 	tp->sub_lb = 0;
 	tp->sub_ub = word_size * 8 - 1;
 	bitset_type = set_type(tp);
@@ -229,7 +225,7 @@ chk_basesubrange(tp, base)
 
 	if (base->tp_fund == T_SUBRANGE) {
 		/* Check that the bounds of "tp" fall within the range
-		   of "base"
+		   of "base".
 		*/
 		if (base->sub_lb > tp->sub_lb || base->sub_ub < tp->sub_ub) {
 			error("Base type has insufficient range");
@@ -246,7 +242,7 @@ chk_basesubrange(tp, base)
 		error("Illegal base for a subrange");
 	}
 	else if (base == int_type && tp->next == card_type &&
-		 (tp->sub_ub > max_int || tp->sub_ub)) {
+		 (tp->sub_ub > max_int || tp->sub_ub < 0)) {
 		error("Upperbound to large for type INTEGER");
 	}
 	else if (base != tp->next && base != int_type) {
@@ -269,7 +265,7 @@ subr_type(lb, ub)
 	register struct type *tp = lb->nd_type, *res;
 
 	if (!TstCompat(lb->nd_type, ub->nd_type)) {
-		node_error(ub, "Types of subrange bounds not compatible");
+		node_error(ub, "Types of subrange bounds not equal");
 		return error_type;
 	}
 
@@ -306,32 +302,33 @@ subr_type(lb, ub)
 	return res;
 }
 
-label
+genrck(tp)
-getrck(tp)
 	register struct type *tp;
 {
 	/*	generate a range check descriptor for type "tp" when
-		neccessary. Return its label
+		neccessary. Return its label.
 	*/
+	arith lb, ub;
+	label ol, l;
 
-	assert(bounded(tp));
+	getbounds(tp, &lb, &ub);
 
 	if (tp->tp_fund == T_SUBRANGE) {
-		if (tp->sub_rck == (label) 0) {
+		if (!(ol = tp->sub_rck)) {
-			tp->sub_rck = data_label();
+			tp->sub_rck = l = data_label();
-			C_df_dlb(tp->sub_rck);
-			C_rom_cst(tp->sub_lb);
-			C_rom_cst(tp->sub_ub);
 		}
-		return tp->sub_rck;
 	}
-	if (tp->enm_rck == (label) 0) {
+	else if (!(ol = tp->enm_rck)) {
-		tp->enm_rck = data_label();
+		tp->enm_rck = l = data_label();
-		C_df_dlb(tp->enm_rck);
-		C_rom_cst((arith) 0);
-		C_rom_cst((arith) (tp->enm_ncst - 1));
 	}
-	return tp->enm_rck;
+	if (!ol) {
+		ol = l;
+		C_df_dlb(ol);
+		C_rom_cst(lb);
+		C_rom_cst(ub);
+	}
+	C_lae_dlb(ol, (arith) 0);
+	C_rck(word_size);
 }
 
 getbounds(tp, plo, phi)
@@ -352,6 +349,7 @@ getbounds(tp, plo, phi)
 		*phi = tp->enm_ncst - 1;
 	}
 }
+
 struct type *
 set_type(tp)
 	register struct type *tp;
@@ -361,26 +359,20 @@ set_type(tp)
 	*/
 	arith lb, ub;
 
-	if (tp->tp_fund == T_SUBRANGE) {
+	if (! bounded(tp)) {
-		if ((lb = tp->sub_lb) < 0 || (ub = tp->sub_ub) > MAXSET - 1) {
-			error("Set type limits exceeded");
-			return error_type;
-		}
-	}
-	else if (tp->tp_fund == T_ENUMERATION || tp == char_type) {
-		lb = 0;
-		if ((ub = tp->enm_ncst - 1) > MAXSET - 1) {
-			error("Set type limits exceeded");
-			return error_type;
-		}
-	}
-	else {
 		error("illegal base type for set");
 		return error_type;
 	}
 
+	getbounds(tp, &lb, &ub);
+
+	if (lb < 0 || ub > MAXSET-1) {
+		error("Set type limits exceeded");
+		return error_type;
+	}
+
 	tp = construct_type(T_SET, tp);
-	tp->tp_size = WA(((ub - lb) + 7)/8);
+	tp->tp_size = WA(((ub - lb) + 8)/8);
 	return tp;
 }
 
@@ -412,47 +404,30 @@ ArraySizes(tp)
 	*/
 	register struct type *index_type = tp->next;
 	register struct type *elem_type = tp->arr_elem;
+	arith lo, hi;
 
 	tp->arr_elsize = ArrayElSize(elem_type);
 	tp->tp_align = elem_type->tp_align;
 
 	/* check index type
 	*/
-	if (! (index_type->tp_fund & T_INDEX)) {
+	if (! bounded(index_type)) {
 		error("Illegal index type");
 		tp->tp_size = 0;
 		return;
 	}
 
-	/* find out HIGH, LOW and size of ARRAY
+	getbounds(index_type, &lo, &hi);
+
+	tp->tp_size = WA((hi - lo + 1) * tp->arr_elsize);
+
+	/* generate descriptor and remember label.
 	*/
 	tp->arr_descr = data_label();
 	C_df_dlb(tp->arr_descr);
-
+	C_rom_cst(lo);
-	switch(index_type->tp_fund) {
+	C_rom_cst(hi - lo);
-	case T_SUBRANGE:
-		tp->tp_size = tp->arr_elsize *
-			(index_type->sub_ub - index_type->sub_lb + 1);
-		C_rom_cst(index_type->sub_lb);
-		C_rom_cst(index_type->sub_ub - index_type->sub_lb);
-		break;
-
-	case T_CHAR:
-	case T_ENUMERATION:
-		tp->tp_size = tp->arr_elsize * index_type->enm_ncst;
-		C_rom_cst((arith) 0);
-		C_rom_cst((arith) (index_type->enm_ncst - 1));
-		break;
-
-	default:
-		crash("Funny index type");
-	}
-
 	C_rom_cst(tp->arr_elsize);
-	tp->tp_size = WA(tp->tp_size);
-
-	/* ??? overflow checking ???
-	*/
 }
 
 FreeType(tp)

lang/m2/comp/walk.c

@@ -12,6 +12,7 @@ static char *RcsId = "$Header$";
 
 #include	<em_arith.h>
 #include	<em_label.h>
+#include	<em_reg.h>
 #include	<assert.h>
 
 #include	"def.h"
@@ -24,6 +25,7 @@ static char *RcsId = "$Header$";
 #include	"desig.h"
 #include	"f_info.h"
 #include	"idf.h"
+#include	"chk_expr.h"
 
 extern arith	NewPtr();
 extern arith	NewInt();
@@ -49,7 +51,7 @@ data_label()
 	return ++datalabel;
 }
 
-static
+STATIC
 DoProfil()
 {
 	static label	filename_label = 0;
@@ -119,16 +121,14 @@ WalkModule(module)
 		struct node *nd;
 
 		if (state == IMPLEMENTATION) {
-			label l1 = data_label(), l2 = text_label();
+			label l1 = data_label();
 			/* we don't actually prevent recursive calls,
 			   but do nothing if called recursively
 			*/
 			C_df_dlb(l1);
 			C_bss_cst(word_size, (arith) 0, 1);
 			C_loe_dlb(l1, (arith) 0);
-			C_zeq(l2);
+			C_zne((label) 1);
-			C_ret((arith) 0);
-			C_df_ilb(l2);
 			C_loc((arith) 1);
 			C_ste_dlb(l1, (arith) 0);
 		}
@@ -159,7 +159,8 @@ WalkProcedure(procedure)
 	*/
 	struct scopelist *vis = CurrVis;
 	register struct scope *sc;
-	register struct type *res_type;
+	register struct type *tp;
+	register struct paramlist *param;
 
 	proclevel++;
 	CurrVis = procedure->prc_vis;
@@ -177,19 +178,20 @@ WalkProcedure(procedure)
 	MkCalls(sc->sc_def);
 	return_expr_occurred = 0;
 	instructionlabel = 2;
-	func_type = res_type = procedure->df_type->next;
+	func_type = tp = procedure->df_type->next;
-	if (! returntype(res_type)) {
+	if (! returntype(tp)) {
 		node_error(procedure->prc_body, "illegal result type");
 	}
 	WalkNode(procedure->prc_body, (label) 0);
 	C_df_ilb((label) 1);
-	if (res_type) {
+	if (tp) {
 		if (! return_expr_occurred) {
 node_error(procedure->prc_body,"function procedure does not return a value");
 		}
-		C_ret(WA(res_type->tp_size));
+		C_ret(WA(tp->tp_size));
 	}
 	else	C_ret((arith) 0);
+	RegisterMessages(sc->sc_def);
 	C_end(-sc->sc_off);
 	TmpClose();
 	CurrVis = vis;
@@ -257,7 +259,6 @@ WalkStat(nd, lab)
 	*/
 	register struct node *left = nd->nd_left;
 	register struct node *right = nd->nd_right;
-	register struct desig *pds = &Desig;
 
 	if (!nd) {
 		/* Empty statement
@@ -385,9 +386,10 @@ WalkStat(nd, lab)
 		{
 			struct scopelist link;
 			struct withdesig wds;
+			struct desig ds;
 			arith tmp = 0;
 
-			WalkDesignator(left);
+			WalkDesignator(left, &ds);
 			if (left->nd_type->tp_fund != T_RECORD) {
 				node_error(left, "record variable expected");
 				break;
@@ -396,19 +398,21 @@ WalkStat(nd, lab)
 			wds.w_next = WithDesigs;
 			WithDesigs = &wds;
 			wds.w_scope = left->nd_type->rec_scope;
-			if (pds->dsg_kind != DSG_PFIXED) {
+			if (ds.dsg_kind != DSG_PFIXED) {
 				/* In this case, we use a temporary variable
 				*/
-				CodeAddress(pds);
+				CodeAddress(&ds);
-				pds->dsg_kind = DSG_FIXED;
+				ds.dsg_kind = DSG_FIXED;
-				/* Only for the store ... */
+				/* Create a designator structure for the
-				pds->dsg_offset = tmp = NewPtr();
+				   temporary.
-				pds->dsg_name = 0;
+				*/
-				CodeStore(pds, pointer_size);
+				ds.dsg_offset = tmp = NewPtr();
-				pds->dsg_kind = DSG_PFIXED;
+				ds.dsg_name = 0;
+				CodeStore(&ds, pointer_size);
+				ds.dsg_kind = DSG_PFIXED;
 				/* the record is indirectly available */
 			}
-			wds.w_desig = *pds;
+			wds.w_desig = ds;
 			link.sc_scope = wds.w_scope;
 			link.next = CurrVis;
 			CurrVis = &link;
@@ -439,7 +443,7 @@ node_error(right, "type incompatibility in RETURN statement");
 		break;
 
 	default:
-		assert(0);
+		crash("(WalkStat)");
 	}
 }
 
@@ -450,6 +454,7 @@ ExpectBool(nd, true_label, false_label)
 	/*	"nd" must indicate a boolean expression. Check this and
 		generate code to evaluate the expression.
 	*/
+	struct desig ds;
 
 	if (!chk_expr(nd)) return;
 
@@ -457,8 +462,8 @@ ExpectBool(nd, true_label, false_label)
 		node_error(nd, "boolean expression expected");
 	}
 
-	Desig = InitDesig;
+	ds = InitDesig;
-	CodeExpr(nd, &Desig,  true_label, false_label);
+	CodeExpr(nd, &ds,  true_label, false_label);
 }
 
 WalkExpr(nd)
@@ -474,8 +479,9 @@ WalkExpr(nd)
 	CodePExpr(nd);
 }
 
-WalkDesignator(nd)
+WalkDesignator(nd, ds)
 	struct node *nd;
+	struct desig *ds;
 {
 	/*	Check designator and generate code for it
 	*/
@@ -484,8 +490,8 @@ WalkDesignator(nd)
 
 	if (! chk_designator(nd, DESIGNATOR|VARIABLE, D_DEFINED)) return;
 
-	Desig = InitDesig;
+	*ds = InitDesig;
-	CodeDesig(nd, &Desig);
+	CodeDesig(nd, ds);
 }
 
 DoForInit(nd, left)
@@ -527,13 +533,13 @@ DoAssign(nd, left, right)
 	register struct node *left, *right;
 {
 	/* May we do it in this order (expression first) ??? */
-	struct desig ds;
+	struct desig dsl, dsr;
 
 	if (!chk_expr(right)) return;
 	if (! chk_designator(left, DESIGNATOR|VARIABLE, D_DEFINED)) return;
 	TryToString(right, left->nd_type);
-	Desig = InitDesig;
+	dsr = InitDesig;
-	CodeExpr(right, &Desig, NO_LABEL, NO_LABEL);
+	CodeExpr(right, &dsr, NO_LABEL, NO_LABEL);
 
 	if (! TstAssCompat(left->nd_type, right->nd_type)) {
 		node_error(nd, "type incompatibility in assignment");
@@ -541,17 +547,44 @@ DoAssign(nd, left, right)
 	}
 
 	if (complex(right->nd_type)) {
-		CodeAddress(&Desig);
+		CodeAddress(&dsr);
 	}
 	else {
-		CodeValue(&Desig, right->nd_type->tp_size);
+		CodeValue(&dsr, right->nd_type->tp_size);
 		CheckAssign(left->nd_type, right->nd_type);
 	}
-	ds = Desig;
+	dsl = InitDesig;
-	Desig = InitDesig;
+	CodeDesig(left, &dsl);
-	CodeDesig(left, &Desig);
 
-	CodeAssign(nd, &ds, &Desig);
+	CodeAssign(nd, &dsr, &dsl);
+}
+
+RegisterMessages(df)
+	register struct def *df;
+{
+	struct type *tp;
+
+	for (; df; df = df->df_nextinscope) {
+		if (df->df_kind == D_VARIABLE && !(df->df_flags & D_NOREG)) {
+			/* Examine type and size
+			*/
+			tp = df->df_type;
+			if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
+			if ((tp->tp_fund & T_NUMERIC) &&
+			     tp->tp_size <= dword_size) {
+				C_ms_reg(df->var_off,
+					 tp->tp_size,
+					 tp->tp_fund == T_REAL ?
+					    reg_float : reg_any,
+					 0);
+			}
+			else if ((df->df_flags & D_VARPAR) ||
+				 tp->tp_fund == T_POINTER) {
+				C_ms_reg(df->var_off, pointer_size,
+					 reg_pointer, 0);
+			}
+		}
+	}
 }
 
 #ifdef DEBUG