safety commit

lang/m2/comp/LLlex.h

@@ -16,6 +16,8 @@ struct token	{
 		struct string tk_str;	/* STRING	*/
 		arith tk_int;		/* INTEGER	*/
 		char *tk_real;		/* REAL		*/
+		arith *tk_set;		/* only used in parse tree node */
+		struct def *tk_def;	/* only used in parse tree node */
 	} tk_data;
 };
 

lang/m2/comp/Makefile

@@ -91,7 +91,7 @@ defmodule.o: LLlex.h debug.h def.h f_info.h idf.h input.h scope.h
 typequiv.o: Lpars.h def.h type.h
 node.o: LLlex.h debug.h def.h node.h type.h
 cstoper.o: LLlex.h Lpars.h def_sizes.h idf.h node.h type.h
-chk_expr.o: LLlex.h Lpars.h def.h idf.h node.h scope.h type.h
+chk_expr.o: LLlex.h Lpars.h const.h def.h idf.h node.h scope.h standards.h type.h
 tokenfile.o: Lpars.h
 program.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.h type.h
 declar.o: LLlex.h Lpars.h def.h idf.h misc.h node.h scope.h type.h

lang/m2/comp/chk_expr.c

@@ -7,6 +7,7 @@ static char *RcsId = "$Header$";
 #include	<em_arith.h>
 #include	<em_label.h>
 #include	<assert.h>
+#include	<alloc.h>
 #include	"idf.h"
 #include	"type.h"
 #include	"def.h"
@@ -14,6 +15,8 @@ static char *RcsId = "$Header$";
 #include	"node.h"
 #include	"Lpars.h"
 #include	"scope.h"
+#include	"const.h"
+#include	"standards.h"
 
 int
 chk_expr(expp, const)
@@ -60,10 +63,13 @@ int
 chk_set(expp, const)
 	register struct node *expp;
 {
+	/*	Check the legality of a SET aggregate, and try to evaluate it
+		compile time. Unfortunately this is all rather complicated.
+	*/
 	struct type *tp;
 	struct def *df;
 	register struct node *nd;
-	extern struct def *findname();
+	arith *set;
 
 	assert(expp->nd_symb == SET);
 
@@ -72,7 +78,9 @@ chk_set(expp, const)
 	if (expp->nd_left) {
 		/* A type was given. Check it out
 		*/
-		df = findname(expp->nd_left);
+		(void) findname(expp->nd_left);
+		assert(expp->nd_left->nd_class == Def);
+		df = expp->nd_left->nd_def;
 		if ((df->df_kind != D_TYPE && df->df_kind != D_ERROR) ||
 		    (df->df_type->tp_fund != SET)) {
 			node_error(expp, "Illegal set type");
@@ -82,48 +90,79 @@ chk_set(expp, const)
 	}
 	else	tp = bitset_type;
 
-	/* Now check the elements given
+	/* Now check the elements given, and try to compute a constant set.
 	*/
+	set = (arith *) Malloc(tp->tp_size * sizeof(arith) / wrd_size);
 	nd = expp->nd_right;
 	while (nd) {
 		assert(nd->nd_class == Link && nd->nd_symb == ',');
-		if (!chk_el(nd->nd_left, const, tp->next, 0)) return 0;
+		if (!chk_el(nd->nd_left, const, tp->next, &set)) return 0;
 		nd = nd->nd_right;
 	}
+	expp->nd_type = tp;
+	assert(!const || set);
+	if (set) {
+		/* Yes, in was a constant set, and we managed to compute it!
+		*/
+		expp->nd_class = Set;
+		expp->nd_set = set;
+		FreeNode(expp->nd_left);
+		FreeNode(expp->nd_right);
+		expp->nd_left = expp->nd_right = 0;
+	}
 	return 1;
 }
 
 int
-chk_el(expp, const, tp, level)
+chk_el(expp, const, tp, set)
-	struct node *expp;
+	register struct node *expp;
 	struct type *tp;
+	arith **set;
 {
 	/*	Check elements of a set. This routine may call itself
-		recursively, but only once.
+		recursively.
+		Also try to compute the set!
 	*/
 	if (expp->nd_class == Link && expp->nd_symb == UPTO) {
-		/*  { ... , expr1 .. expr2,  ... } */
+		/* { ... , expr1 .. expr2,  ... }
-		if (level) {
+		   First check expr1 and expr2, and try to compute them.
-			node_error(expp, "Illegal set element");
+		*/
-			return 0;
+		if (!chk_el(expp->nd_left, const, tp, set) ||
-		}
+		    !chk_el(expp->nd_right, const, tp, set)) {
-		if (!chk_el(expp->nd_left, const, tp, 1) ||
-		    !chk_el(expp->nd_right, const, tp, 1)) {
 			return 0;
 		}
 		if (expp->nd_left->nd_class == Value &&
 		    expp->nd_right->nd_class == Value) {
+			/* We have a constant range. Put all elements in the
+			   set
+			*/
+			register int i;
+
 		    	if (expp->nd_left->nd_INT > expp->nd_right->nd_INT) {
 node_error(expp, "Lower bound exceeds upper bound in range");
-				return 0;
+				return rem_set(set);
 			}
+			
+			if (*set) for (i = expp->nd_left->nd_INT + 1;
+				     i < expp->nd_right->nd_INT; i++) {
+				(*set)[i/wrd_bits] |= (1 << (i % wrd_bits));
+			}
+		}
+		else if (*set) {
+			free(*set);
+			*set = 0;
 		}
 		return 1;
 	}
-	if (!chk_expr(expp, const)) return 0;
+
+	/* Here, a single element is checked
+	*/
+	if (!chk_expr(expp, const)) {
+		return rem_set(set);
+	}
 	if (!TstCompat(tp, expp->nd_type)) {
 		node_error(expp, "Set element has incompatible type");
-		return 0;
+		return rem_set(set);
 	}
 	if (expp->nd_class == Value) {
 	    	if ((tp->tp_fund != ENUMERATION &&
@@ -133,24 +172,104 @@ node_error(expp, "Lower bound exceeds upper bound in range");
 		     (expp->nd_INT < 0 || expp->nd_INT > tp->enm_ncst))
 		   ) {
 			node_error(expp, "Set element out of range");
-#ifdef DEBUG
+			return rem_set(set);
-			debug("%d (%d, %d)", (int) expp->nd_INT, (int) tp->sub_lb, (int) tp->sub_ub);
-#endif
-			return 0;
 		}
+		if (*set) (*set)[expp->nd_INT/wrd_bits] |= (1 << (expp->nd_INT%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;
+}
+
 int
 chk_call(expp, const)
 	register struct node *expp;
 {
-	/* ??? */
+	register struct type *tp;
-	return 1;
+	register struct node *left;
+
+	expp->nd_type = error_type;
+	(void) findname(expp->nd_left);
+	left = expp->nd_left;
+	tp = left->nd_type;
+
+	if (tp == error_type) return 0;
+	if (left->nd_class == Def &&
+	    (left->nd_def->df_kind & (D_HTYPE|D_TYPE|D_HIDDEN))) {
+		/* A type cast. This is of course not portable.
+		   No runtime action. Remove it.
+		*/
+		if (!expp->nd_right ||
+		    (expp->nd_right->nd_symb == ',')) {
+node_error(expp, "Only one parameter expected in type cast");
+			return 0;
+		}
+		if (! chk_expr(expp->nd_right, const)) return 0;
+		if (expp->nd_right->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;
+		}
+		expp->nd_right->nd_type = left->nd_type;
+		left = expp->nd_right;
+		FreeNode(expp->nd_left);
+		*expp = *(expp->nd_right);
+		left->nd_left = left->nd_right = 0;
+		FreeNode(left);
+		return 1;
+	}
+
+	if ((left->nd_class == Def && left->nd_def->df_kind == D_PROCEDURE) ||
+	    tp->tp_fund == PROCVAR) {
+		/* A procedure call. it may also be a call to a
+		   standard procedure
+		*/
+		if (tp == std_type) {
+			assert(left->nd_class == Def);
+			switch(left->nd_def->df_value.df_stdname) {
+			case S_ABS:
+			case S_CAP:
+			case S_CHR:
+			case S_FLOAT:
+			case S_HIGH:
+			case S_MAX:
+			case S_MIN:
+			case S_ODD:
+			case S_ORD:
+			case S_SIZE:
+			case S_TRUNC:
+			case S_VAL:
+				break;
+			case S_DEC:
+			case S_INC:
+			case S_HALT:
+			case S_EXCL:
+			case S_INCL:
+				expp->nd_type = 0;
+				break;
+			default:
+				assert(0);
+			}
+			return 1;
+		}
+		return 1;
+	}
+	node_error(expp->nd_left, "procedure, type, or function expected");
+	return 0;
 }
 
-struct def *
 findname(expp)
 	register struct node *expp;
 {
@@ -159,41 +278,66 @@ findname(expp)
 	*/
 	register struct def *df;
 	struct def *lookfor();
-	register struct node *nd;
+	register struct type *tp;
 	int scope;
 	int module;
 
+	expp->nd_type = error_type;
 	if (expp->nd_class == Name) {
-		return lookfor(expp, CurrentScope, 1);
+		expp->nd_def = lookfor(expp, CurrentScope, 1);
+		expp->nd_class = Def;
+		expp->nd_type = expp->nd_def->df_type;
+		return;
 	}
-	assert(expp->nd_class == Link && expp->nd_symb == '.');
+	if (expp->nd_class == Link) {
-	assert(expp->nd_left->nd_class == Name);
+		assert(expp->nd_symb == '.');
-	df = lookfor(expp->nd_left, CurrentScope, 1);
+		assert(expp->nd_right->nd_class == Name);
-	if (df->df_kind == D_ERROR) return df;
+		findname(expp->nd_left);
-	nd = expp;
+		tp = expp->nd_left->nd_type;
-	while (nd->nd_class == Link) {
+		if (tp == error_type) {
-		struct node *nd1;
+			df = ill_df;
-
-		if (!(scope = has_selectors(df))) {
-			node_error(nd, "identifier \"%s\" has no selectors",
-					df->df_idf->id_text);
-			return ill_df;
 		}
-		nd = nd->nd_right;
+		else if (tp->tp_fund != RECORD) {
-		if (nd->nd_class == Name) nd1 = nd;
+			/* This is also true for modules */
-		else nd1 = nd->nd_left;
+			node_error(expp,"Illegal selection");
-		module = (df->df_kind == D_MODULE);
+			df = ill_df;
-		df = lookup(nd1->nd_IDF, scope);
+		}
+		else df = lookup(expp->nd_right->nd_IDF, tp->rec_scope);
 		if (!df) {
-			id_not_declared(nd1);
+			df = ill_df;
-			return ill_df;
+			id_not_declared(expp->nd_right);
 		}
-		if (module && !(df->df_flags&(D_EXPORTED|D_QEXPORTED))) {
+		else if (df != ill_df) {
-node_error(nd1, "identifier \"%s\" not exprted from qualifying module",
+			expp->nd_type = df->df_type;
+			if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
+node_error(expp->nd_right,
+"identifier \"%s\" not exprted from qualifying module",
 df->df_idf->id_text);
+			}
 		}
+		if (expp->nd_left->nd_class == Def) {
+			expp->nd_class = Def;
+			expp->nd_def = df;
+			FreeNode(expp->nd_left);
+			FreeNode(expp->nd_right);
+			expp->nd_left = expp->nd_right = 0;
+		}
+		return;
 	}
-	return df;
+	if (expp->nd_class == Oper) {
+		assert(expp->nd_symb == '[');
+		(void) findname(expp->nd_left);
+		if (chk_expr(expp->nd_right, 0) &&
+		    expp->nd_left->nd_type != error_type &&
+		    chk_oper(expp)) /* ??? */ ;
+		return 1;
+	}
+	if (expp->nd_class == Uoper && expp->nd_symb == '^') {
+		(void) findname(expp->nd_right);
+		if (expp->nd_right->nd_type != error_type &&
+	    		chk_uoper(expp)) /* ??? */ ;
+	}
+	return 0;
 }
 
 int
@@ -203,16 +347,14 @@ chk_name(expp, const)
 	register struct def *df;
 	int retval = 1;
 
-	df = findname(expp);
+	(void) findname(expp);
+	assert(expp->nd_class == Def);
+	df = expp->nd_def;
 	if (df->df_kind == D_ERROR) {
 		retval = 0;
 	}
-	expp->nd_type = df->df_type;
+	if (df->df_kind & (D_ENUM | D_CONST)) {
-	if (df->df_kind == D_ENUM || df->df_kind == D_CONST) {
-		if (expp->nd_left) FreeNode(expp->nd_left);
-		if (expp->nd_right) FreeNode(expp->nd_right);
 		if (df->df_kind == D_ENUM) {
-			expp->nd_left = expp->nd_right = 0;
 			expp->nd_class = Value;
 			expp->nd_INT = df->enm_val;
 			expp->nd_symb = INTEGER;
@@ -251,10 +393,11 @@ chk_oper(expp, const)
 			expp->nd_right->nd_type = tpr = tpl;
 		}
 	}
+	expp->nd_type = error_type;
 
 	if (expp->nd_symb == IN) {
 		/* Handle this one specially */
-		expp->nd_type == bool_type;
+		expp->nd_type = bool_type;
 		if (tpr->tp_fund != SET) {
 node_error(expp, "RHS of IN operator not a SET type");
 			return 0;
@@ -266,6 +409,21 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
 		return 1;
 	}
 
+	if (expp->nd_symb == '[') {
+		/* Handle ARRAY selection specially too! */
+		if (tpl->tp_fund != ARRAY) {
+node_error(expp, "array index not belonging to an ARRAY");
+			return 0;
+		}
+		if (!TstCompat(tpl->next, tpr)) {
+node_error(expp, "incompatible index type");
+			return 0;
+		}
+		expp->nd_type = tpl->arr_elem;
+		if (const) return 0;
+		return 1;
+	}
+
 	if (tpl->tp_fund == SUBRANGE) tpl = tpl->next;
 	expp->nd_type = tpl;
 
@@ -450,6 +608,11 @@ chk_uoper(expp, const)
 			return 1;
 		}
 		break;
+	case '^':
+		if (tpr->tp_fund != POINTER) break;
+		expp->nd_type = tpr->next;
+		if (const) return 0;
+		return 1;
 	default:
 		assert(0);
 	}

lang/m2/comp/const.h

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

lang/m2/comp/cstoper.c

@@ -18,6 +18,7 @@ long full_mask[MAXSIZE];/* full_mask[1] == 0xFF, full_mask[2] == 0xFFFF, .. */
 arith max_int;		/* maximum integer on target machine	*/
 arith max_unsigned;	/* maximum unsigned on target machine	*/
 arith max_longint;	/* maximum longint on target machine	*/
+arith wrd_bits;		/* number of bits in a word */
 
 cstunary(expp)
 	register struct node *expp;
@@ -206,21 +207,85 @@ cstbin(expp)
 cstset(expp)
 	register struct node *expp;
 {
-	switch(expp->nd_symb) {
+	register arith *set1 = 0, *set2;
-	case IN:
+	register int setsize, j;
-	case '+':
+
-	case '-':
+	assert(expp->nd_right->nd_class == Set);
-	case '*':
+	assert(expp->nd_symb == IN || expp->nd_left->nd_class == Set);
-	case '/':
+	set2 = expp->nd_right->nd_set;
-	case GREATEREQUAL:
+	setsize = expp->nd_right->nd_type->tp_size / wrd_size;
-	case LESSEQUAL:
+
-	case '=':
+	if (expp->nd_symb == IN) {
-	case '#':
+		arith i;
-		/* ??? */
+
-		break;
+		assert(expp->nd_left->nd_class == Value);
-	default:
+		i = expp->nd_left->nd_INT;
-		assert(0);
+		expp->nd_INT = (i >= 0 &&
+		    i < setsize * wrd_bits &&
+		    (set2[i / wrd_bits] & (1 << (i % wrd_bits))));
+		    free((char *) set2);
 	}
+	else {
+		set1 = expp->nd_left->nd_set;
+		switch(expp->nd_symb) {
+		case '+':
+			for (j = 0; j < setsize; j++) {
+				*set1++ |= *set2++;
+			}
+			break;
+		case '-':
+			for (j = 0; j < setsize; j++) {
+				*set1++ &= ~*set2++;
+			}
+			break;
+		case '*':
+			for (j = 0; j < setsize; j++) {
+				*set1++ &= *set2++;
+			}
+			break;
+		case '/':
+			for (j = 0; j < setsize; j++) {
+				*set1++ ^= *set2++;
+			}
+			break;
+		case GREATEREQUAL:
+		case LESSEQUAL:
+		case '=':
+		case '#':
+			/* Clumsy, but who cares? Nobody writes these things! */
+			for (j = 0; j < setsize; j++) {
+				switch(expp->nd_symb) {
+				case GREATEREQUAL:
+					if ((*set1 | *set2++) != *set1) break;
+					set1++;
+					continue;
+				case LESSEQUAL:
+					if ((*set2 | *set1++) != *set2) break;
+					set2++;
+					continue;
+				case '=':
+				case '#':
+					if (*set1++ != *set2++) break;
+					continue;
+				}
+				expp->nd_INT = expp->nd_symb == '#';
+				break;
+			}
+			if (j == setsize) expp->nd_INT = expp->nd_symb != '#';
+			expp->nd_class = Value;
+			free((char *) expp->nd_left->nd_set);
+			free((char *) expp->nd_right->nd_set);
+			break;
+		default:
+			assert(0);
+		}
+		free((char *) expp->nd_right->nd_set);
+		expp->nd_class = Set;
+		expp->nd_set = expp->nd_left->nd_set;
+	}
+	FreeNode(expp->nd_left);
+	FreeNode(expp->nd_right);
+	expp->nd_left = expp->nd_right = 0;
 }
 
 cut_size(expr)
@@ -273,4 +338,5 @@ init_cst()
 
 	max_int = full_mask[int_size] & ~(1 << (int_size * 8 - 1));
 	max_unsigned = full_mask[int_size];
+	wrd_bits = 8 * wrd_size;
 }

lang/m2/comp/declar.g

@@ -234,7 +234,6 @@ IdentList(struct node **p;)
 SubrangeType(struct type **ptp;)
 {
 	struct node *nd1, *nd2;
-	extern struct type *subr_type();
 }:
 	/*
 	   This is not exactly the rule in the new report, but see
@@ -340,7 +339,6 @@ CaseLabels
 SetType(struct type **ptp;)
 {
 	struct type *tp;
-	struct type *set_type();
 } :
 	SET OF SimpleType(&tp)
 			{ 

lang/m2/comp/expression.g

@@ -6,6 +6,7 @@ static char *RcsId = "$Header$";
 #include	<alloc.h>
 #include	<em_arith.h>
 #include	<em_label.h>
+#include	<assert.h>
 #include	"LLlex.h"
 #include	"idf.h"
 #include	"def.h"
@@ -36,21 +37,17 @@ qualident(int types; struct def **pdf; char *str; struct node **p;)
 	register struct def *df;
 	register struct node **pnd;
 	struct node *nd;
-	struct def *findname();
 } :
 	IDENT		{ nd = MkNode(Name, NULLNODE, NULLNODE, &dot);
 			  pnd = &nd;
 			}
 	[
-		/* selector */
+		selector(pnd)
-		'.'	{ *pnd = MkNode(Link,*pnd,NULLNODE,&dot);
-			  pnd = &(*pnd)->nd_right;
-			}
-		IDENT
-			{ *pnd = MkNode(Name,NULLNODE,NULLNODE,&dot); }
 	]*
 			{ if (types) {
-				*pdf = df = findname(nd);
+				findname(nd);
+				assert(nd->nd_class == Def);
+				*pdf = df = nd->nd_def;
 			  	if (df->df_kind != D_ERROR &&
 				    !(types & df->df_kind)) {
 					error("identifier \"%s\" is not a %s",
@@ -62,11 +59,10 @@ qualident(int types; struct def **pdf; char *str; struct node **p;)
 			}
 ;
 
-/* Inline substituted wherever it occurred
+selector(struct node **pnd;):
-selector:
+	'.'	{ *pnd = MkNode(Link,*pnd,NULLNODE,&dot); }
-	'.' IDENT
+	IDENT	{ (*pnd)->nd_right = MkNode(Name,NULLNODE,NULLNODE,&dot); }
 ;
-*/
 
 ExpList(struct node **pnd;)
 {
@@ -238,11 +234,7 @@ designator(struct node **pnd;)
 designator_tail(struct node **pnd;):
 	visible_designator_tail(pnd)
 	[
-		/* selector */
+		selector(pnd)
-		'.'	{ *pnd = MkNode(Link, *pnd, NULLNODE, &dot); }
-		IDENT	{ (*pnd)->nd_right =
-				MkNode(Name, NULLNODE, NULLNODE, &dot);
-			}
 	|
 		visible_designator_tail(pnd)
 	]*
@@ -250,8 +242,15 @@ designator_tail(struct node **pnd;):
 
 visible_designator_tail(struct node **pnd;):
 	'['		{ *pnd = MkNode(Oper, *pnd, NULLNODE, &dot); }
-	ExpList(&((*pnd)->nd_right))
+		expression(&((*pnd)->nd_right))
+		[
+			','
+			{ *pnd = MkNode(Oper, *pnd, NULLNODE, &dot);
+			  (*pnd)->nd_symb = '[';
+			}
+			expression(&((*pnd)->nd_right))
+		]*
 	']'
 |
-	'^'		{ *pnd = MkNode(Oper, *pnd, NULLNODE, &dot); }
+	'^'		{ *pnd = MkNode(Oper, NULLNODE, *pnd, &dot); }
 ;

lang/m2/comp/main.c

@@ -128,23 +128,23 @@ add_standards()
 	register struct def *df;
 	struct def *Enter();
 
-	(void) Enter("ABS", D_STDFUNC, NULLTYPE, S_ABS);
+	(void) Enter("ABS", D_PROCEDURE, std_type, S_ABS);
-	(void) Enter("CAP", D_STDFUNC, NULLTYPE, S_CAP);
+	(void) Enter("CAP", D_PROCEDURE, std_type, S_CAP);
-	(void) Enter("CHR", D_STDFUNC, NULLTYPE, S_CHR);
+	(void) Enter("CHR", D_PROCEDURE, std_type, S_CHR);
-	(void) Enter("FLOAT", D_STDFUNC, NULLTYPE, S_FLOAT);
+	(void) Enter("FLOAT", D_PROCEDURE, std_type, S_FLOAT);
-	(void) Enter("HIGH", D_STDFUNC, NULLTYPE, S_HIGH);
+	(void) Enter("HIGH", D_PROCEDURE, std_type, S_HIGH);
-	(void) Enter("HALT", D_STDPROC, NULLTYPE, S_HALT);
+	(void) Enter("HALT", D_PROCEDURE, std_type, S_HALT);
-	(void) Enter("EXCL", D_STDPROC, NULLTYPE, S_EXCL);
+	(void) Enter("EXCL", D_PROCEDURE, std_type, S_EXCL);
-	(void) Enter("DEC", D_STDPROC, NULLTYPE, S_DEC);
+	(void) Enter("DEC", D_PROCEDURE, std_type, S_DEC);
-	(void) Enter("INC", D_STDPROC, NULLTYPE, S_INC);
+	(void) Enter("INC", D_PROCEDURE, std_type, S_INC);
-	(void) Enter("VAL", D_STDFUNC, NULLTYPE, S_VAL);
+	(void) Enter("VAL", D_PROCEDURE, std_type, S_VAL);
-	(void) Enter("TRUNC", D_STDFUNC, NULLTYPE, S_TRUNC);
+	(void) Enter("TRUNC", D_PROCEDURE, std_type, S_TRUNC);
-	(void) Enter("SIZE", D_STDFUNC, NULLTYPE, S_SIZE);
+	(void) Enter("SIZE", D_PROCEDURE, std_type, S_SIZE);
-	(void) Enter("ORD", D_STDFUNC, NULLTYPE, S_ORD);
+	(void) Enter("ORD", D_PROCEDURE, std_type, S_ORD);
-	(void) Enter("ODD", D_STDFUNC, NULLTYPE, S_ODD);
+	(void) Enter("ODD", D_PROCEDURE, std_type, S_ODD);
-	(void) Enter("MAX", D_STDFUNC, NULLTYPE, S_MAX);
+	(void) Enter("MAX", D_PROCEDURE, std_type, S_MAX);
-	(void) Enter("MIN", D_STDFUNC, NULLTYPE, S_MIN);
+	(void) Enter("MIN", D_PROCEDURE, std_type, S_MIN);
-	(void) Enter("INCL", D_STDPROC, NULLTYPE, S_INCL);
+	(void) Enter("INCL", D_PROCEDURE, std_type, S_INCL);
 
 	(void) Enter("CHAR", D_TYPE, char_type, 0);
 	(void) Enter("INTEGER", D_TYPE, int_type, 0);
@@ -195,8 +195,8 @@ END SYSTEM.\n";
 	open_scope(CLOSEDSCOPE, 0);
 	(void) Enter("WORD", D_TYPE, word_type, 0);
 	(void) Enter("ADDRESS", D_TYPE, address_type, 0);
-	(void) Enter("ADR", D_STDFUNC, NULLTYPE, S_ADR);
+	(void) Enter("ADR", D_PROCEDURE, std_type, S_ADR);
-	(void) Enter("TSIZE", D_STDFUNC, NULLTYPE, S_TSIZE);
+	(void) Enter("TSIZE", D_PROCEDURE, std_type, S_TSIZE);
 	if (!InsertText(SYSTEM, strlen(SYSTEM))) {
 		fatal("Could not insert text");
 	}

lang/m2/comp/node.H

@@ -11,24 +11,16 @@ struct node {
 #define Oper	2		/* binary operator */
 #define Uoper	3		/* unary operator */
 #define Call	4		/* cast or procedure - or function call */
-#define Name	5		/* a qualident */
+#define Name	5		/* an identifier */
 #define Set	6		/* a set constant */
 #define Xset	7		/* a set */
 #define Def	8		/* an identified name */
+#define Stat	9		/* a statement */
 #define Link	11
 	struct type *nd_type;	/* type of this node */
-	union {
+	struct token nd_token;
-		struct token ndu_token;	/* (Value, Oper, Uoper, Call, Name,
+#define nd_set		nd_token.tk_data.tk_set
-					    Link)
+#define nd_def		nd_token.tk_data.tk_def
-					*/
-		arith *ndu_set;		/* pointer to a set constant (Set) */
-		struct def *ndu_def;	/* pointer to definition structure for
-					   identified name (Def)
-					*/
-	} nd_val;
-#define nd_token	nd_val.ndu_token
-#define nd_set		nd_val.ndu_set
-#define nd_def		nd_val.ndu_def
 #define nd_symb		nd_token.tk_symb
 #define nd_lineno	nd_token.tk_lineno
 #define nd_filename	nd_token.tk_filename

lang/m2/comp/program.g

@@ -47,6 +47,9 @@ ModuleDeclaration
 				  df = define(id, CurrentScope, D_MODULE);
 				  open_scope(CLOSEDSCOPE, 0);
 				  df->mod_scope = CurrentScope->sc_scope;
+				  df->df_type = 
+					standard_type(RECORD, 0, (arith) 0);
+				  df->df_type->rec_scope = df->mod_scope;
 				}
 	priority? ';'
 	import(1)*
@@ -113,6 +116,8 @@ DefinitionModule
 			  df = define(id, GlobalScope, D_MODULE);
 			  if (!SYSTEMModule) open_scope(CLOSEDSCOPE, 0);
 			  df->mod_scope = CurrentScope->sc_scope;
+			  df->df_type = standard_type(RECORD, 0, (arith) 0);
+			  df->df_type->rec_scope = df->mod_scope;
 			  DefinitionModule = 1;
 			  DO_DEBUG(1, debug("Definition module \"%s\"", id->id_text));
 			}

lang/m2/comp/statement.g

@@ -10,7 +10,7 @@ static char *RcsId = "$Header$";
 
 statement
 {
-	struct node *nd1, *nd2;
+	struct node *nd1, *nd2 = 0;
 } :
 [
 	/*
@@ -21,8 +21,12 @@ statement
 	designator(&nd1)
 	[
 		ActualParameters(&nd2)?
+				{ nd1 = MkNode(Call, nd1, nd2, &dot);
+				  nd1->nd_symb = '(';
+				}
 	|
-		BECOMES expression(&nd2)
+		BECOMES		{ nd1 = MkNode(Stat, nd1, NULLNODE, &dot); }
+		expression(&(nd1->nd_right))
 	]
 	/*
 	 * end of changed part

lang/m2/comp/type.H

@@ -80,6 +80,7 @@ extern struct type
 	*intorcard_type,
 	*string_type,
 	*bitset_type,
+	*std_type,
 	*error_type;		/* All from type.c */
 
 extern int
@@ -105,6 +106,8 @@ extern arith
 struct type
 	*create_type(),
 	*construct_type(),
-	*standard_type();	/* All from type.c */
+	*standard_type(),
+	*set_type(),
+	*subr_type();	/* All from type.c */
 
 #define NULLTYPE ((struct type *) 0)

lang/m2/comp/type.c

@@ -49,6 +49,7 @@ struct type
 	*intorcard_type,
 	*string_type,
 	*bitset_type,
+	*std_type,
 	*error_type;
 
 struct paramlist *h_paramlist;
@@ -132,7 +133,8 @@ init_types()
 
 	char_type = standard_type(CHAR, 1, (arith) 1);
 	char_type->enm_ncst = 256;
-	bool_type = standard_type(BOOLEAN, 1, (arith) 1);
+	bool_type = standard_type(ENUMERATION, 1, (arith) 1);
+	bool_type->enm_ncst = 2;
 	int_type = standard_type(INTEGER, int_align, int_size);
 	longint_type = standard_type(LONGINT, lint_align, lint_size);
 	card_type = standard_type(CARDINAL, int_align, int_size);
@@ -145,8 +147,8 @@ init_types()
 	tp = construct_type(SUBRANGE, int_type);
 	tp->sub_lb = 0;
 	tp->sub_ub = wrd_size * 8 - 1;
-	bitset_type = construct_type(SET, tp);
+	bitset_type = set_type(tp);
-	bitset_type->tp_size = wrd_size;
+	std_type = construct_type(PROCEDURE, NULLTYPE);
 	error_type = standard_type(ERRONEOUS, 1, (arith) 1);
 }