From: ceriel <none@none>
Date: Wed, 4 Jun 1986 09:01:48 +0000 (+0000)
Subject: first, almost complete, version
X-Git-Tag: release-5-5~5286
X-Git-Url: https://git.ndcode.org/public/gitweb.cgi?a=commitdiff_plain;h=9e0ab0029bbc8197d6fb7d1548e23a5750cc486b;p=ack.git

first, almost complete, version
---

diff --git a/lang/m2/comp/LLlex.c b/lang/m2/comp/LLlex.c
index 19ffd0c18..e4a15ab91 100644
--- a/lang/m2/comp/LLlex.c
+++ b/lang/m2/comp/LLlex.c
@@ -26,9 +26,10 @@ static char *RcsId = "$Header$";
 long str2long();
 
 struct token dot, aside;
-struct type *numtype;
+struct type *toktype;
 struct string string;
 int idfsize = IDFSIZE;
+extern label	data_label();
 
 static
 SkipComment()
@@ -111,10 +112,10 @@ LLlex()
 		The putting aside of tokens is taken into account.
 	*/
 	register struct token *tk = &dot;
-	char buf[(IDFSIZE > NUMSIZE ? IDFSIZE : NUMSIZE) + 1];
+	char buf[(IDFSIZE > NUMSIZE ? IDFSIZE : NUMSIZE) + 2];
 	register int ch, nch;
 
-	numtype = error_type;
+	toktype = error_type;
 	if (ASIDE)	{	/* a token is put aside		*/
 		*tk = aside;
 		ASIDE = 0;
@@ -221,9 +222,16 @@ again:
 
 	case STSTR:
 		GetString(ch);
-		tk->tk_data.tk_str = (struct string *)
+		if (string.s_length == 1) {
+			tk->TOK_INT = *(string.s_str) & 0377;
+			toktype = char_type;
+		}
+		else {
+			tk->tk_data.tk_str = (struct string *)
 				Malloc(sizeof (struct string));
-		*(tk->tk_data.tk_str) = string;
+			*(tk->tk_data.tk_str) = string;
+			toktype = standard_type(T_STRING, 1, string.s_length);
+		}
 		return tk->tk_symb = STRING;
 
 	case STNUM:
@@ -252,9 +260,9 @@ again:
 Shex:			*np++ = '\0';
 			tk->TOK_INT = str2long(&buf[1], 16);
 			if (tk->TOK_INT >= 0 && tk->TOK_INT <= max_int) {
-				numtype = intorcard_type;
+				toktype = intorcard_type;
 			}
-			else	numtype = card_type;
+			else	toktype = card_type;
 			return tk->tk_symb = INTEGER;
 
 		case '8':
@@ -290,15 +298,15 @@ Shex:			*np++ = '\0';
 			*np++ = '\0';
 			tk->TOK_INT = str2long(&buf[1], 8);
 			if (ch == 'C') {
-				numtype = char_type;
+				toktype = char_type;
 				if (tk->TOK_INT < 0 || tk->TOK_INT > 255) {
 lexwarning("Character constant out of range");
 				}
 			}
 			else if (tk->TOK_INT >= 0 && tk->TOK_INT <= max_int) {
-				numtype = intorcard_type;
+				toktype = intorcard_type;
 			}
-			else	numtype = card_type;
+			else	toktype = card_type;
 			return tk->tk_symb = INTEGER;
 
 		case 'A':
@@ -380,12 +388,10 @@ Sreal:
 			PushBack(ch);
 
 			if (np == &buf[NUMSIZE + 1]) {
-				lexerror("floating constant too long");
 				tk->TOK_REL = Salloc("0.0", 5);
+				lexerror("floating constant too long");
 			}
-			else {
-				tk->TOK_REL = Salloc(buf, np - buf) + 1;
-			}
+			else	tk->TOK_REL = Salloc(buf, np - buf) + 1;
 			return tk->tk_symb = REAL;
 
 		default:
@@ -394,9 +400,9 @@ Sdec:
 			*np++ = '\0';
 			tk->TOK_INT = str2long(&buf[1], 10);
 			if (tk->TOK_INT < 0 || tk->TOK_INT > max_int) {
-				numtype = card_type;
+				toktype = card_type;
 			}
-			else	numtype = intorcard_type;
+			else	toktype = intorcard_type;
 			return tk->tk_symb = INTEGER;
 		}
 		/*NOTREACHED*/
diff --git a/lang/m2/comp/LLlex.h b/lang/m2/comp/LLlex.h
index dae0151a0..8ba0bd944 100644
--- a/lang/m2/comp/LLlex.h
+++ b/lang/m2/comp/LLlex.h
@@ -25,10 +25,10 @@ struct token	{
 #define TOK_STR	tk_data.tk_str->s_str
 #define TOK_SLE tk_data.tk_str->s_length
 #define TOK_INT	tk_data.tk_int
-#define TOK_REL	tk_data.tk_real
+#define TOK_REL tk_data.tk_real
 
 extern struct token dot, aside;
-extern struct type *numtype;
+extern struct type *toktype;
 
 #define DOT	dot.tk_symb
 #define ASIDE	aside.tk_symb
diff --git a/lang/m2/comp/chk_expr.c b/lang/m2/comp/chk_expr.c
index 4e69cad64..49163d6a4 100644
--- a/lang/m2/comp/chk_expr.c
+++ b/lang/m2/comp/chk_expr.c
@@ -61,7 +61,7 @@ chk_expr(expp)
 			return 1;
 
 		default:
-			assert(0);
+			crash("(chk_expr(Value))");
 		}
 		break;
 
@@ -78,7 +78,7 @@ chk_expr(expp)
 		return chk_designator(expp, DESIGNATOR|VALUE, D_USED|D_NOREG);
 
 	default:
-		assert(0);
+		crash("(chk_expr)");
 	}
 	/*NOTREACHED*/
 }
@@ -90,9 +90,9 @@ chk_set(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 type *tp;
 	register struct node *nd;
+	register struct def *df;
 	arith *set;
 	unsigned size;
 
@@ -110,7 +110,7 @@ chk_set(expp)
 
 		if (!(df->df_kind & (D_TYPE|D_ERROR)) ||
 		    (df->df_type->tp_fund != T_SET)) {
-			node_error(expp, "specifier does not represent a set type");
+node_error(expp, "specifier does not represent a set type");
 			return 0;
 		}
 		tp = df->df_type;
@@ -163,16 +163,16 @@ chk_set(expp)
 int
 chk_el(expp, tp, set)
 	register struct node *expp;
-	struct type *tp;
+	register struct type *tp;
 	arith **set;
 {
 	/*	Check elements of a set. This routine may call itself
 		recursively.
 		Also try to compute the set!
 	*/
-	register int i;
 	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,  ... }
@@ -370,7 +370,9 @@ chk_proccall(expp)
 
 	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),
@@ -734,6 +736,7 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
 			}
 			return 1;
 
+		case T_HIDDEN:
 		case T_POINTER:
 			if (chk_address(tpl, tpr) ||
 			    expp->nd_symb == '=' ||
@@ -812,16 +815,13 @@ chk_uoper(expp)
 			return 1;
 		}
 		else if (tpr->tp_fund == T_REAL) {
+			expp->nd_type = tpr;
 			if (right->nd_class == Value) {
-				expp->nd_token = right->nd_token;
+				if (*(right->nd_REL) == '-') (right->nd_REL)++;
+				else (right->nd_REL)--;
 				expp->nd_class = Value;
-				if (*(expp->nd_REL) == '-') {
-					expp->nd_REL++;
-				}
-				else {
-					expp->nd_REL--;
-					*(expp->nd_REL) = '-';
-				}
+				expp->nd_symb = REAL;
+				expp->nd_REL = right->nd_REL;
 				FreeNode(right);
 				expp->nd_right = 0;
 			}
@@ -901,7 +901,10 @@ DO_DEBUG(3,debug("standard name \"%s\", %d",left->nd_def->df_idf->id_text,std));
 	case S_ABS:
 		if (!(left = getarg(&arg, T_NUMERIC, 0))) return 0;
 		expp->nd_type = left->nd_type;
-		if (left->nd_class == Value) cstcall(expp, S_ABS);
+		if (left->nd_class == Value &&
+		    expp->nd_type->tp_fund != T_REAL) {
+			cstcall(expp, S_ABS);
+		}
 		break;
 
 	case S_CAP:
@@ -1085,3 +1088,20 @@ node_error(expp, "only one parameter expected in type cast");
 
 	return 1;
 }
+
+TryToString(nd, tp)
+	struct node *nd;
+	struct type *tp;
+{
+	/*	Try a coercion from character constant to string */
+	if (tp->tp_fund == T_ARRAY && nd->nd_type == char_type) {
+		int ch = nd->nd_INT;
+
+		nd->nd_type = standard_type(T_STRING, 1, (arith) 2);
+		nd->nd_token.tk_data.tk_str = 
+			(struct string *) Malloc(sizeof(struct string));
+		nd->nd_STR = Salloc("X", 2);
+		*(nd->nd_STR) = ch;
+		nd->nd_SLE = 1;
+	}
+}
diff --git a/lang/m2/comp/code.c b/lang/m2/comp/code.c
index f59ef69d3..ca7203184 100644
--- a/lang/m2/comp/code.c
+++ b/lang/m2/comp/code.c
@@ -50,25 +50,49 @@ CodeConst(cst, size)
 }
 
 CodeString(nd)
-	struct node *nd;
+	register struct node *nd;
 {
 	label lab;
 
-	if (nd->nd_type == charc_type) {
+	if (nd->nd_type == char_type) {
 		C_loc(nd->nd_INT);
-		return;
 	}
-	C_df_dlb(lab = data_label());
-	C_rom_scon(nd->nd_STR, nd->nd_SLE);
-	C_lae_dlb(lab, (arith) 0);
+	else {
+		C_df_dlb(lab = data_label());
+		C_rom_scon(nd->nd_STR, align(nd->nd_SLE + 1, word_size));
+		C_lae_dlb(lab, (arith) 0);
+	}
+}
+
+CodePadString(nd, sz)
+	register struct node *nd;
+	arith sz;
+{
+	/*	Generate code to push the string indicated by "nd".
+		Make it null-padded to "sz" bytes
+	*/
+	register arith sizearg = align(nd->nd_type->tp_size, word_align);
+
+	assert(nd->nd_type->tp_fund == T_STRING);
+
+	if (sizearg != sz) {
+		/* null padding required */
+		assert(sizearg < sz);
+		C_zer(sz - sizearg);
+	}
+	C_asp(-sizearg);	/* room for string */
+	CodeString(nd);		/* push address of string */
+	C_lor((arith) 1);	/* load stack pointer */
+	C_adp(pointer_size);	/* and compute target address from it */
+	C_blm(sizearg);		/* and copy */
 }
 
 CodeReal(nd)
-	struct node *nd;
+	register struct node *nd;
 {
-	label lab;
-	
-	C_df_dlb(lab = data_label());
+	label lab = data_label();
+
+	C_df_dlb(lab);
 	C_rom_fcon(nd->nd_REL, nd->nd_type->tp_size);
 	C_lae_dlb(lab, (arith) 0);
 	C_loi(nd->nd_type->tp_size);
@@ -83,10 +107,13 @@ CodeExpr(nd, ds, true_label, false_label)
 	switch(nd->nd_class) {
 	case Def:
 		if (nd->nd_def->df_kind == D_PROCEDURE) {
-			C_lpi(nd->nd_def->prc_vis->sc_scope->sc_name);
+			C_lpi(NameOfProc(nd->nd_def));
 			ds->dsg_kind = DSG_LOADED;
 			break;
 		}
+		/* Fall through */
+
+	case Link:
 		CodeDesig(nd, ds);
 		break;
 
@@ -97,10 +124,8 @@ CodeExpr(nd, ds, true_label, false_label)
 		}
 		CodeOper(nd, true_label, false_label);
 		if (true_label == 0) ds->dsg_kind = DSG_LOADED;
-		else {
-			*ds = InitDesig;
-			true_label = 0;
-		}
+		else ds->dsg_kind = DSG_INIT;
+		true_label = 0;
 		break;
 
 	case Uoper:
@@ -130,10 +155,6 @@ CodeExpr(nd, ds, true_label, false_label)
 		ds->dsg_kind = DSG_LOADED;
 		break;
 
-	case Link:
-		CodeDesig(nd, ds);
-		break;
-		
 	case Call:
 		CodeCall(nd);
 		ds->dsg_kind = DSG_LOADED;
@@ -177,7 +198,7 @@ CodeExpr(nd, ds, true_label, false_label)
 CodeCoercion(t1, t2)
 	register struct type *t1, *t2;
 {
-	int fund1, fund2;
+	register int fund1, fund2;
 
 	if (t1 == t2) return;
 	if (t1->tp_fund == T_SUBRANGE) t1 = t1->next;
@@ -285,7 +306,6 @@ CodeCall(nd)
 		CodeStd(nd);
 		return;
 	}	
-	tp = left->nd_type;
 
 	if (IsCast(left)) {
 		/* it was just a cast. Simply ignore it
@@ -299,18 +319,42 @@ CodeCall(nd)
 	assert(IsProcCall(left));
 
 	for (param = left->nd_type->prc_params; param; param = param->next) {
+		tp = TypeOfParam(param);
 		arg = arg->nd_right;
 		assert(arg != 0);
-		if (IsVarParam(param)) {
+		if (IsConformantArray(tp)) {
+			C_loc(tp->arr_elsize);
+			if (IsConformantArray(arg->nd_left->nd_type)) {
+				DoHIGH(arg->nd_left);
+			}
+			else if (arg->nd_left->nd_symb == STRING) {
+				C_loc(arg->nd_left->nd_SLE);
+			}
+			else if (tp->arr_elem == word_type) {
+				C_loc(arg->nd_left->nd_type->tp_size / word_size - 1);
+			}
+			else	C_loc(arg->nd_left->nd_type->tp_size /
+				      tp->arr_elsize - 1);
+			C_loc(0);
+			if (arg->nd_left->nd_symb == STRING) {
+				CodeString(arg->nd_left);
+			}
+			else	CodeDAddress(arg->nd_left);
+			pushed += pointer_size + 3 * word_size;
+		}
+		else if (IsVarParam(param)) {
 			CodeDAddress(arg->nd_left);
 			pushed += pointer_size;
 		}
 		else {
-			CodePExpr(arg->nd_left);
-			CheckAssign(arg->nd_left->nd_type, TypeOfParam(param));
-			pushed += align(arg->nd_left->nd_type->tp_size, word_align);
+			if (arg->nd_left->nd_type->tp_fund == T_STRING) {
+				CodePadString(arg->nd_left,
+					      align(tp->tp_size, word_align));
+			}
+			else CodePExpr(arg->nd_left);
+			CheckAssign(arg->nd_left->nd_type, tp);
+			pushed += align(tp->tp_size, word_align);
 		}
-		/* ??? Conformant arrays */
 	}
 
 	if (left->nd_class == Def && left->nd_def->df_kind == D_PROCEDURE) {
@@ -318,7 +362,7 @@ CodeCall(nd)
 			C_lxl((arith) proclevel - left->nd_def->df_scope->sc_level);
 			pushed += pointer_size;
 		}
-		C_cal(left->nd_def->prc_vis->sc_scope->sc_name);
+		C_cal(NameOfProc(left->nd_def));
 	}
 	else if (left->nd_class == Def && left->nd_def->df_kind == D_PROCHEAD) {
 		C_cal(left->nd_def->for_name);
@@ -327,9 +371,9 @@ CodeCall(nd)
 		CodePExpr(left);
 		C_cai();
 	}
-	C_asp(pushed);
-	if (tp->next) {
-		C_lfr(align(tp->next->tp_size, word_align));
+	if (pushed) C_asp(pushed);
+	if (left->nd_type->next) {
+		C_lfr(align(left->nd_type->next->tp_size, word_align));
 	}
 }
 
@@ -385,7 +429,7 @@ CodeStd(nd)
 
 	case S_HIGH:
 		assert(IsConformantArray(tp));
-		/* ??? */
+		DoHIGH(left);
 		break;
 
 	case S_ODD:
@@ -480,15 +524,24 @@ CodeAssign(nd, dss, dst)
 	/*	Generate code for an assignment. Testing of type
 		compatibility and the like is already done.
 	*/
+	register struct type *tp = nd->nd_right->nd_type;
+	extern arith align();
 
 	if (dss->dsg_kind == DSG_LOADED) {
+		if (tp->tp_fund == T_STRING) {
+			CodeAddress(dst);
+			C_loc(tp->tp_size);
+			C_loc(nd->nd_left->nd_type->tp_size);
+			C_cal("_StringAssign");
+			C_asp((int_size << 1) + (pointer_size << 1));
+			return;
+		}
 		CodeStore(dst, nd->nd_left->nd_type->tp_size);
+		return;
 	}
-	else {
-		CodeAddress(dss);
-		CodeAddress(dst);
-		C_blm(nd->nd_left->nd_type->tp_size);
-	}
+	CodeAddress(dss);
+	CodeAddress(dst);
+	C_blm(nd->nd_left->nd_type->tp_size);
 }
 
 CheckAssign(tpl, tpr)
@@ -683,6 +736,7 @@ CodeOper(expr, true_label, false_label)
 		case T_INTEGER:
 			C_cmi(tp->tp_size);
 			break;
+		case T_HIDDEN:
 		case T_POINTER:
 			C_cmp();
 			break;
@@ -904,12 +958,16 @@ CodeSet(nd)
 
 CodeEl(nd, tp)
 	register struct node *nd;
-	struct type *tp;
+	register struct type *tp;
 {
 
 	if (nd->nd_class == Link && nd->nd_symb == UPTO) {
 		C_zer(tp->tp_size);	/* empty set */
 		C_lor((arith) 1);	/* SP: address of set */
+		if (tp->next->tp_fund == T_SUBRANGE) {
+			C_loc(tp->next->sub_ub);
+		}
+		else	C_loc(tp->next->enm_ncst - 1);
 		Operands(nd->nd_left, nd->nd_right);
 		C_cal("_LtoUset");	/* library routine to fill set */
 		C_asp(2 * word_size + pointer_size);
@@ -960,3 +1018,23 @@ CodeDStore(nd)
 	CodeDesig(nd, &designator);
 	CodeStore(&designator, nd->nd_type->tp_size);
 }
+
+DoHIGH(nd)
+	struct node *nd;
+{
+	register struct def *df;
+	arith highoff;
+
+	assert(nd->nd_class == Def);
+
+	df = nd->nd_def;
+
+	assert(df->df_kind == D_VARIABLE);
+
+	highoff = df->var_off + pointer_size + word_size;
+	if (df->df_scope->sc_level < proclevel) {
+		C_lxa(proclevel - df->df_scope->sc_level);
+		C_lof(highoff);
+	}
+	else	C_lol(highoff);
+}
diff --git a/lang/m2/comp/cstoper.c b/lang/m2/comp/cstoper.c
index 20d91a50d..7c0453a5a 100644
--- a/lang/m2/comp/cstoper.c
+++ b/lang/m2/comp/cstoper.c
@@ -374,12 +374,6 @@ cstcall(expp, call)
 	expp->nd_symb = INTEGER;
 	switch(call) {
 	case S_ABS:
-		if (expr->nd_type->tp_fund == T_REAL) {
-			expp->nd_symb = REAL;
-			expp->nd_REL = expr->nd_REL;
-			if (*(expr->nd_REL) == '-') (expp->nd_REL)++;
-			break;
-		}
 		if (expr->nd_INT < 0) expp->nd_INT = - expr->nd_INT;
 		else expp->nd_INT = expr->nd_INT;
 		CutSize(expp);
diff --git a/lang/m2/comp/declar.g b/lang/m2/comp/declar.g
index b605456a3..84174ed80 100644
--- a/lang/m2/comp/declar.g
+++ b/lang/m2/comp/declar.g
@@ -54,7 +54,7 @@ ProcedureHeading(struct def **pdf; int type;)
 		{
 		  df = DeclProc(type);
 		  tp = construct_type(T_PROCEDURE, tp);
-		  if (proclevel) {
+		  if (proclevel > 1) {
 			/* Room for static link
 			*/
 			tp->prc_nbpar = pointer_size;
@@ -134,10 +134,10 @@ FPSection(struct paramlist **ppr; arith *parmaddr;)
 {
 	struct node *FPList;
 	struct type *tp;
-	int VARp = 0;
+	int VARp = D_VALPAR;
 } :
 	[
-		VAR	{ VARp = 1; }
+		VAR	{ VARp = D_VARPAR; }
 	]?
 	IdentList(&FPList) ':' FormalType(&tp)
 		{
@@ -146,43 +146,48 @@ FPSection(struct paramlist **ppr; arith *parmaddr;)
 		}
 ;
 
-FormalType(struct type **tp;)
+FormalType(struct type **ptp;)
 {
 	struct def *df;
 	int ARRAYflag = 0;
+	register struct type *tp;
+	extern arith ArrayElSize();
 } :
 	[ ARRAY OF	{ ARRAYflag = 1; }
 	]?
 	qualident(D_ISTYPE, &df, "type", (struct node **) 0)
 		{ if (ARRAYflag) {
-			*tp = construct_type(T_ARRAY, NULLTYPE);
-			(*tp)->arr_elem = df->df_type;
-			(*tp)->tp_align = lcm(word_align, pointer_align);
-			(*tp)->tp_size = align(pointer_size + word_size,
-						(*tp)->tp_align);
+			*ptp = tp = construct_type(T_ARRAY, NULLTYPE);
+			tp->arr_elem = df->df_type;
+			tp->arr_elsize = ArrayElSize(df->df_type);
+			tp->tp_align = lcm(word_align, pointer_align);
 		  }
-		  else	*tp = df->df_type;
+		  else	*ptp = df->df_type;
 		}
 ;
 
 TypeDeclaration
 {
-	struct def *df;
+	register struct def *df;
 	struct type *tp;
 }:
 	IDENT		{ df = lookup(dot.TOK_IDF, CurrentScope);
-			  if (!df) df = define( dot.TOK_IDF,
-						CurrentScope,
-						D_TYPE);
+			  if (!df) df = define(dot.TOK_IDF,CurrentScope,D_TYPE);
 			}
 	'=' type(&tp)
-			{ if (df->df_type) free_type(df->df_type); /* ??? */
-			  df->df_type = tp;
-			  if (df->df_kind == D_HIDDEN &&
-			      tp->tp_fund != T_POINTER) {
+			{ 
+			  if (df->df_kind == D_HIDDEN) {
+			  	if (tp->tp_fund != T_POINTER) {
 error("opaque type \"%s\" is not a pointer type", df->df_idf->id_text);
+				}
+				df->df_kind = D_TYPE;
+				*(df->df_type) = *tp;
+				free_type(tp);
+			  }
+			  else {	
+			  	df->df_type = tp;
+			  	df->df_kind = D_TYPE;
 			  }
-			  df->df_kind = D_TYPE;
 			}
 ;
 
@@ -235,6 +240,7 @@ enumeration(struct type **ptp;)
 				 CurrentScope, (arith *) 0);
 		  FreeNode(EnumList);
 		  if (tp->enm_ncst > 256) {
+			/* ??? is this reasonable ??? */
 			error("Too many enumeration literals");
 		  }
 		}
@@ -244,12 +250,12 @@ IdentList(struct node **p;)
 {
 	register struct node *q;
 } :
-	IDENT		{ q = MkNode(Value, NULLNODE, NULLNODE, &dot);
+	IDENT		{ q = MkLeaf(Value, &dot);
 			  *p = q;
 			}
 	[
 		',' IDENT
-			{ q->next = MkNode(Value,NULLNODE,NULLNODE,&dot);
+			{ q->next = MkLeaf(Value, &dot);
 			  q = q->next;
 			}
 	]*
@@ -572,11 +578,11 @@ VariableDeclaration
 IdentAddrList(struct node **pnd;)
 {
 } :
-	IDENT		{ *pnd = MkNode(Name, NULLNODE, NULLNODE, &dot); }
+	IDENT		{ *pnd = MkLeaf(Name, &dot); }
 	ConstExpression(&(*pnd)->nd_left)?
 	[		{ pnd = &((*pnd)->nd_right); }
 		',' IDENT
-			{ *pnd = MkNode(Name, NULLNODE, NULLNODE, &dot); }
+			{ *pnd = MkLeaf(Name, &dot); }
 		ConstExpression(&(*pnd)->nd_left)?
 	]*
 ;
diff --git a/lang/m2/comp/def.H b/lang/m2/comp/def.H
index df4517a98..bdf908815 100644
--- a/lang/m2/comp/def.H
+++ b/lang/m2/comp/def.H
@@ -48,6 +48,7 @@ struct dfproc {
 	struct node *pr_body;	/* body of this procedure */
 #define prc_vis		df_value.df_proc.pr_vis
 #define prc_body	df_value.df_proc.pr_body
+#define NameOfProc(xdf)	((xdf)->prc_vis->sc_scope->sc_name)
 };
 
 struct import {
diff --git a/lang/m2/comp/def.c b/lang/m2/comp/def.c
index c3a98030e..80bc6ea22 100644
--- a/lang/m2/comp/def.c
+++ b/lang/m2/comp/def.c
@@ -30,7 +30,7 @@ struct def *ill_df;
 struct def *
 MkDef(id, scope, kind)
 	struct idf *id;
-	struct scope *scope;
+	register struct scope *scope;
 {
 	/*	Create a new definition structure in scope "scope", with
 		id "id" and kind "kind".
@@ -55,7 +55,7 @@ MkDef(id, scope, kind)
 InitDef()
 {
 	/*	Initialize this module. Easy, the only thing to be initialized
-		is "illegal_def".
+		is "ill_df".
 	*/
 	struct idf *gen_anon_idf();
 
@@ -83,6 +83,9 @@ define(id, scope, kind)
 	   ) {
 		switch(df->df_kind) {
 		case D_HIDDEN:
+			/* An opaque type. We may now have found the
+			   definition of this type.
+			*/
 			if (kind == D_TYPE && !DefinitionModule) {
 				df->df_kind = D_TYPE;
 				return df;
@@ -90,6 +93,10 @@ define(id, scope, kind)
 			break;
 
 		case D_FORWMODULE:
+			/* A forward reference to a module. We may have found
+			   another one, or we may have found the definition
+			   for this module.
+			*/
 			if (kind == D_FORWMODULE) {
 				return df;
 			}
@@ -104,19 +111,27 @@ define(id, scope, kind)
 			break;
 
 		case D_FORWARD:
+			/* A forward reference, for which we may now have
+			   found a definition.
+			*/
 			if (kind != D_FORWARD) {
 				FreeNode(df->for_node);
 			}
 
-			df->df_kind = kind;
-			return df;
+			/* Fall through */
 
 		case D_ERROR:
+			/* A definition generated by the compiler, because
+			   it found an error. Maybe, the user gives a
+			   definition after all.
+			*/
 			df->df_kind = kind;
 			return df;
 		}
 
 		if (kind != D_ERROR) {
+			/* Avoid spurious error messages
+			*/
 error("identifier \"%s\" already declared", id->id_text);
 		}
 
@@ -149,6 +164,8 @@ lookup(id, scope)
 				assert(retval != 0);
 			}
 			if (df1) {
+				/* Put the definition now found in front
+				*/
 				df1->next = df->next;
 				df->next = id->id_def;
 				id->id_def = df;
@@ -162,30 +179,34 @@ lookup(id, scope)
 }
 
 DoImport(df, scope)
-	struct def *df;
+	register struct def *df;
 	struct scope *scope;
 {
-	register struct def *df1;
+	/*	Definition "df" is imported to scope "scope".
+		Handle the case that it is an enumeration type or a module.
+	*/
+
+	define(df->df_idf, scope, D_IMPORT)->imp_def = df;
 
 	if (df->df_kind == D_TYPE && df->df_type->tp_fund == T_ENUMERATION) {
 		/* Also import all enumeration literals
 		*/
-		df1 = df->df_type->enm_enums;
-		while (df1) {
-			define(df1->df_idf, scope, D_IMPORT)->imp_def = df1;
-			df1 = df1->enm_next;
+		df = df->df_type->enm_enums;
+		while (df) {
+			define(df->df_idf, scope, D_IMPORT)->imp_def = df;
+			df = df->enm_next;
 		}
 	}
 	else if (df->df_kind == D_MODULE) {
 		/* Also import all definitions that are exported from this
 		   module
 		*/
-		df1 = df->mod_vis->sc_scope->sc_def;
-		while (df1) {
-			if (df1->df_flags & D_EXPORTED) {
-				define(df1->df_idf, scope, D_IMPORT)->imp_def = df1;
+		df = df->mod_vis->sc_scope->sc_def;
+		while (df) {
+			if (df->df_flags & D_EXPORTED) {
+				define(df->df_idf,scope,D_IMPORT)->imp_def = df;
 			}
-			df1 = df1->df_nextinscope;
+			df = df->df_nextinscope;
 		}
 	}
 }
@@ -213,7 +234,7 @@ node_error(ids, "identifier \"%s\" not defined", ids->nd_IDF->id_text);
 		}
 
 		if (df->df_flags & (D_EXPORTED|D_QEXPORTED)) {
-node_error(ids, "Identifier \"%s\" occurs more than once in export list",
+node_error(ids, "identifier \"%s\" occurs more than once in export list",
 df->df_idf->id_text);
 		}
 
@@ -225,6 +246,8 @@ df->df_idf->id_text);
 			   Find all imports of the module in which this export
 			   occurs, and export the current definition to it
 			*/
+			df->df_flags |= D_EXPORTED;
+
 			impmod = moddef->df_idf->id_def;
 			while (impmod) {
 				if (impmod->df_kind == D_IMPORT &&
@@ -234,7 +257,6 @@ df->df_idf->id_text);
 				impmod = impmod->next;
 			}
 
-			df->df_flags |= D_EXPORTED;
 			df1 = lookup(ids->nd_IDF, enclosing(CurrVis)->sc_scope);
 			if (df1 && df1->df_kind == D_PROCHEAD) {
 				if (df->df_kind == D_PROCEDURE) {
@@ -255,10 +277,6 @@ error("opaque type \"%s\" is not a pointer type", df->df_idf->id_text);
 				}
 			}
 
-			df1 = define(ids->nd_IDF,
-						enclosing(CurrVis)->sc_scope,
-						D_IMPORT);
-			df1->imp_def = df;
 			DoImport(df, enclosing(CurrVis)->sc_scope);
 		}
 	}
@@ -283,7 +301,7 @@ ForwModule(df, idn)
 				   closing this one
 				*/
 	df->for_vis = vis;
-	df->for_node = MkNode(Name, NULLNODE, NULLNODE, &(idn->nd_token));
+	df->for_node = MkLeaf(Name, &(idn->nd_token));
 	close_scope(0);	
 	vis->sc_encl = enclosing(CurrVis);
 				/* Here ! */
@@ -302,7 +320,7 @@ ForwDef(ids, scope)
 
 	if (!(df = lookup(ids->nd_IDF, scope))) {
 		df = define(ids->nd_IDF, scope, D_FORWARD);
-		df->for_node = MkNode(Name,NULLNODE,NULLNODE,&(ids->nd_token));
+		df->for_node = MkLeaf(Name, &(ids->nd_token));
 	}
 	return df;
 }
@@ -384,7 +402,6 @@ ids->nd_IDF->id_text);
 			else	df = GetDefinitionModule(ids->nd_IDF);
 		}
 
-		define(ids->nd_IDF,CurrentScope,D_IMPORT)->imp_def = df;
 		DoImport(df, CurrentScope);
 
 		ids = ids->next;
@@ -393,7 +410,7 @@ ids->nd_IDF->id_text);
 	FreeNode(idn);
 }
 
-RemImports(pdf)
+RemoveImports(pdf)
 	struct def **pdf;
 {
 	/*	Remove all imports from a definition module. This is
@@ -404,7 +421,7 @@ RemImports(pdf)
 
 	while (df) {
 		if (df->df_kind == D_IMPORT) {
-			RemFromId(df);
+			RemoveFromIdList(df);
 			*pdf = df->df_nextinscope;
 			free_def(df);
 		}
@@ -415,7 +432,7 @@ RemImports(pdf)
 	}
 }
 
-RemFromId(df)
+RemoveFromIdList(df)
 	struct def *df;
 {
 	/*	Remove definition "df" from the definition list
@@ -438,11 +455,11 @@ struct def *
 DeclProc(type)
 {
 	/*	A procedure is declared, either in a definition or a program
-		module. Create a def structure for it (if neccessary)
+		module. Create a def structure for it (if neccessary).
+		Also create a name for it.
 	*/
 	register struct def *df;
 	static int nmcount = 0;
-	extern char *Malloc();
 	extern char *strcpy();
 	extern char *sprint();
 	char buf[256];
@@ -453,7 +470,7 @@ DeclProc(type)
 		/* In a definition module
 		*/
 		df = define(dot.TOK_IDF, CurrentScope, type);
-		df->for_node = MkNode(Name, NULLNODE, NULLNODE, &dot);
+		df->for_node = MkLeaf(Name, &dot);
 		sprint(buf,"%s_%s",CurrentScope->sc_name,df->df_idf->id_text);
 		df->for_name = Malloc((unsigned) (strlen(buf)+1));
 		strcpy(df->for_name, buf);
@@ -512,12 +529,12 @@ AddModule(id)
 	register struct node *n;
 	extern struct node *Modules;
 
-	n = MkNode(Name, NULLNODE, NULLNODE, &dot);
+	n = MkLeaf(Name, &dot);
 	n->nd_IDF = id;
 	n->nd_symb = IDENT;
 	if (nd_end) nd_end->next = n;
+	else Modules = n;
 	nd_end = n;
-	if (!Modules) Modules = n;
 }
 
 DefInFront(df)
@@ -528,14 +545,24 @@ DefInFront(df)
 		This is neccessary because in some cases the order in this
 		list is important.
 	*/
-	register struct def *df1;
+	register struct def *df1 = df->df_scope->sc_def;
 
-	if (df->df_scope->sc_def != df) {
-		df1 = df->df_scope->sc_def;
+	if (df1 != df) {
+		/* Definition "df" is not in front of the list
+		*/
 		while (df1 && df1->df_nextinscope != df) {
+			/* Find definition "df"
+			*/
 			df1 = df1->df_nextinscope;
 		}
-		if (df1) df1->df_nextinscope = df->df_nextinscope;
+		if (df1) {
+			/* It already was in the list. Remove it
+			*/
+			df1->df_nextinscope = df->df_nextinscope;
+		}
+
+		/* Now put it in front
+		*/
 		df->df_nextinscope = df->df_scope->sc_def;
 		df->df_scope->sc_def = df;
 	}
diff --git a/lang/m2/comp/desig.c b/lang/m2/comp/desig.c
index 04f2fd8b9..47780bfc6 100644
--- a/lang/m2/comp/desig.c
+++ b/lang/m2/comp/desig.c
@@ -268,7 +268,8 @@ CodeVarDesig(df, ds)
 			/* value or var parameter
 			*/
 			C_lxa((arith) (proclevel - sc->sc_level));
-			if (df->df_flags & D_VARPAR) {
+			if ((df->df_flags & D_VARPAR) ||
+			    IsConformantArray(df->df_type)) {
 				/* var parameter
 				*/
 				C_adp(df->var_off);
@@ -287,7 +288,7 @@ CodeVarDesig(df, ds)
 
 	/* Now, finally, we have a local variable or a local parameter
 	*/
-	if (df->df_flags & D_VARPAR) {
+	if ((df->df_flags & D_VARPAR) || IsConformantArray(df->df_type)) {
 		/* a var parameter; address directly accessible.
 		*/
 		ds->dsg_kind = DSG_PFIXED;
@@ -303,10 +304,11 @@ CodeDesig(nd, ds)
 	/*	Generate code for a designator. Use divide and conquer
 		principle
 	*/
+	register struct def *df;
 
 	switch(nd->nd_class) {	/* Divide */
-	case Def: {
-		register struct def *df = nd->nd_def;
+	case Def:
+		df = nd->nd_def;
 
 		df->df_flags |= D_USED;
 		switch(df->df_kind) {
@@ -321,7 +323,6 @@ CodeDesig(nd, ds)
 		default:
 			crash("(CodeDesig) Def");
 		}
-		}
 		break;
 
 	case Link:
@@ -336,18 +337,24 @@ CodeDesig(nd, ds)
 
 		CodeDesig(nd->nd_left, ds);
 		CodeAddress(ds);
-		*ds = InitDesig;
-		CodeExpr(nd->nd_right, ds, NO_LABEL, NO_LABEL);
-		CodeValue(ds, nd->nd_right->nd_type->tp_size);
+		CodePExpr(nd->nd_right);
 		if (nd->nd_right->nd_type->tp_size > word_size) {
 			CodeCoercion(nd->nd_right->nd_type, int_type);
 		}
+
+		/* Now load address of descriptor
+		*/
 		if (IsConformantArray(nd->nd_left->nd_type)) {
-			/* ??? */
+			assert(nd->nd_left->nd_class == Def);
+
+			df = nd->nd_left->nd_def;
+			if (proclevel > df->df_scope->sc_level) {
+				C_lxa(proclevel - df->df_scope->sc_level);
+				C_adp(df->var_off + pointer_size);
+			}
+			else	C_lal(df->var_off + pointer_size);
 		}
 		else	{
-			/* load address of descriptor
-			*/
 			C_lae_dlb(nd->nd_left->nd_type->arr_descr, (arith) 0);
 		}
 		ds->dsg_kind = DSG_INDEXED;
diff --git a/lang/m2/comp/expression.g b/lang/m2/comp/expression.g
index f0c144e60..80a75780d 100644
--- a/lang/m2/comp/expression.g
+++ b/lang/m2/comp/expression.g
@@ -26,48 +26,51 @@ number(struct node **p;)
 } :
 [
 	%default
-	INTEGER		{ tp = numtype; }
+	INTEGER		{ tp = toktype; }
 |
 	REAL		{ tp = real_type; }
-]			{ *p = MkNode(Value, NULLNODE, NULLNODE, &dot);
+]			{ *p = MkLeaf(Value, &dot);
 			  (*p)->nd_type = tp;
 			}
 ;
 
-qualident(int types; struct def **pdf; char *str; struct node **p;)
+qualident(int types;
+	  struct def **pdf;
+	  char *str;
+	  struct node **p;
+	 )
 {
 	register struct def *df;
 	struct node *nd;
 } :
-	IDENT		{ nd = MkNode(Name, NULLNODE, NULLNODE, &dot);
-			}
+	IDENT	{ nd = MkLeaf(Name, &dot); }
 	[
 		selector(&nd)
 	]*
-			{ if (types) {
-				df = ill_df;
+		{ if (types) {
+			df = ill_df;
 
-				if (chk_designator(nd, 0, D_REFERRED)) {
-				    if (nd->nd_class != Def) {
-					node_error(nd, "%s expected", str);
+			if (chk_designator(nd, 0, D_REFERRED)) {
+			    if (nd->nd_class != Def) {
+				node_error(nd, "%s expected", str);
+			    }
+			    else {
+				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 {
-					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;
+			    }
 			}
+			*pdf = df;
+		  }
+		  if (!p) FreeNode(nd);
+		  else *p = nd;
+		}
 ;
 
 selector(struct node **pnd;):
@@ -84,7 +87,7 @@ ExpList(struct node **pnd;)
 				  nd = &((*pnd)->nd_right);
 				}
 	[
-		','		{ *nd = MkNode(Link, NULLNODE, NULLNODE, &dot);
+		','		{ *nd = MkLeaf(Link, &dot);
 				}
 		expression(&(*nd)->nd_left)
 				{ nd = &((*nd)->nd_right); }
@@ -131,7 +134,7 @@ SimpleExpression(struct node **pnd;)
 } :
 	[
 		[ '+' | '-' ]
-			{ *pnd = MkNode(Uoper, NULLNODE, NULLNODE, &dot);
+			{ *pnd = MkLeaf(Uoper, &dot);
 			  pnd = &((*pnd)->nd_right);
 			}
 	]?
@@ -191,23 +194,13 @@ factor(struct node **p;)
 	number(p)
 |
 	STRING	{
-		  *p = MkNode(Value, NULLNODE, NULLNODE, &dot);
-		  if (dot.TOK_SLE == 1) {
-			int i;
-
-			tp = charc_type;
-			i = *(dot.TOK_STR) & 0377;
-			free(dot.TOK_STR);
-			free((char *) dot.tk_data.tk_str);
-			(*p)->nd_INT = i;
-		  }
-		  else	tp = standard_type(T_STRING, 1, dot.TOK_SLE);
-		  (*p)->nd_type = tp;
+		  *p = MkLeaf(Value, &dot);
+		  (*p)->nd_type = toktype;
 		}
 |
 	'(' expression(p) ')'
 |
-	NOT		{ *p = MkNode(Uoper, NULLNODE, NULLNODE, &dot); }
+	NOT		{ *p = MkLeaf(Uoper, &dot); }
 	factor(&((*p)->nd_right))
 ;
 
@@ -217,7 +210,7 @@ bare_set(struct node **pnd;)
 } :
 	'{'		{
 			  dot.tk_symb = SET;
-			  *pnd = nd = MkNode(Xset, NULLNODE, NULLNODE, &dot);
+			  *pnd = nd = MkLeaf(Xset, &dot);
 			  nd->nd_type = bitset_type;
 			}
 	[
diff --git a/lang/m2/comp/main.c b/lang/m2/comp/main.c
index 53d0a92e6..1372165b4 100644
--- a/lang/m2/comp/main.c
+++ b/lang/m2/comp/main.c
@@ -111,27 +111,27 @@ Compile(src, dst)
 #ifdef DEBUG
 LexScan()
 {
-	register int symb;
-	char *symbol2str();
+	register struct token *tkp = &dot;
+	extern char *symbol2str();
 
-	while ((symb = LLlex()) > 0) {
-		print(">>> %s ", symbol2str(symb));
-		switch(symb) {
+	while (LLlex() > 0) {
+		print(">>> %s ", symbol2str(tkp->tk_symb));
+		switch(tkp->tk_symb) {
 
 		case IDENT:
-			print("%s\n", dot.TOK_IDF->id_text);
+			print("%s\n", tkp->TOK_IDF->id_text);
 			break;
 		
 		case INTEGER:
-			print("%ld\n", dot.TOK_INT);
+			print("%ld\n", tkp->TOK_INT);
 			break;
 		
 		case REAL:
-			print("%s\n", dot.TOK_REL);
+			print("%s\n", tkp->TOK_REL);
 			break;
-		
+
 		case STRING:
-			print("\"%s\"\n", dot.TOK_STR);
+			print("\"%s\"\n", tkp->TOK_STR);
 			break;
 
 		default:
diff --git a/lang/m2/comp/node.H b/lang/m2/comp/node.H
index db0467a83..dfbe94fe9 100644
--- a/lang/m2/comp/node.H
+++ b/lang/m2/comp/node.H
@@ -33,7 +33,7 @@ struct node {
 
 /* ALLOCDEF "node" */
 
-extern struct node *MkNode();
+extern struct node *MkNode(), *MkLeaf();
 
 #define NULLNODE ((struct node *) 0)
 
diff --git a/lang/m2/comp/node.c b/lang/m2/comp/node.c
index b1556d148..c940e4273 100644
--- a/lang/m2/comp/node.c
+++ b/lang/m2/comp/node.c
@@ -39,6 +39,19 @@ MkNode(class, left, right, token)
 	return nd;
 }
 
+struct node *
+MkLeaf(class, token)
+	struct token *token;
+{
+	register struct node *nd = new_node();
+
+	nd->nd_left = nd->nd_right = 0;
+	nd->nd_token = *token;
+	nd->nd_type = error_type;
+	nd->nd_class = class;
+	return nd;
+}
+
 FreeNode(nd)
 	register struct node *nd;
 {
diff --git a/lang/m2/comp/program.g b/lang/m2/comp/program.g
index ac0d48540..cbf86b8a9 100644
--- a/lang/m2/comp/program.g
+++ b/lang/m2/comp/program.g
@@ -19,11 +19,6 @@ static  char *RcsId = "$Header$";
 #include	"type.h"
 #include	"node.h"
 
-static int DEFofIMPL = 0;	/* Flag indicating that we are currently
-				   parsing the definition module of the
-				   implementation module currently being
-				   compiled
-				*/
 }
 /*
 	The grammar as given by Wirth is already almost LL(1); the
@@ -132,7 +127,7 @@ import(int local;)
 	struct node *id = 0;
 } :
 	[ FROM
-	  IDENT		{ id = MkNode(Value, NULLNODE, NULLNODE, &dot); }
+	  IDENT		{ id = MkLeaf(Value, &dot); }
 	]?
 	IMPORT IdentList(&ImportList) ';'
 	/*
@@ -176,12 +171,6 @@ DefinitionModule
 	*/
 	definition* END IDENT
 			{
-			  if (DEFofIMPL) {
-				/* Just read the definition module of the
-				   implementation module being compiled
-				*/
-				RemImports(&(CurrentScope->sc_def));
-			  }
 			  df = CurrentScope->sc_def;
 			  while (df) {
 				/* Make all definitions "QUALIFIED EXPORT" */
@@ -211,7 +200,7 @@ definition
 	       It is restricted to pointer types.
 	    */
 	    		{ df->df_kind = D_HIDDEN;
-			  df->df_type = construct_type(T_POINTER, NULLTYPE);
+			  df->df_type = construct_type(T_HIDDEN, NULLTYPE);
 			}
 	  ]
 	  Semicolon
@@ -239,11 +228,10 @@ ProgramModule
 	IDENT	{ 
 		  id = dot.TOK_IDF;
 		  if (state == IMPLEMENTATION) {
-			DEFofIMPL = 1;
 			df = GetDefinitionModule(id);
 			CurrVis = df->mod_vis;
 			CurrentScope = CurrVis->sc_scope;
-			DEFofIMPL = 0;
+			RemoveImports(&(CurrentScope->sc_def));
 		  }
 		  else {
 			df = define(id, CurrentScope, D_MODULE);
diff --git a/lang/m2/comp/statement.g b/lang/m2/comp/statement.g
index b0a05b208..aef6e22c2 100644
--- a/lang/m2/comp/statement.g
+++ b/lang/m2/comp/statement.g
@@ -18,11 +18,10 @@ static char *RcsId = "$Header$";
 static int	loopcount = 0;	/* Count nested loops */
 }
 
-statement(struct node **pnd;)
+statement(register struct node **pnd;)
 {
 	register struct node *nd;
 } :
-				{ *pnd = 0; }
 [
 	/*
 	 * This part is not in the reference grammar. The reference grammar
@@ -61,11 +60,13 @@ statement(struct node **pnd;)
 |
 	EXIT
 			{ if (!loopcount) error("EXIT not in a LOOP");
-			  *pnd = MkNode(Stat, NULLNODE, NULLNODE, &dot);
+			  *pnd = MkLeaf(Stat, &dot);
 			}
 |
 	ReturnStatement(pnd)
-]?
+|
+	/* empty */	{ *pnd = 0; }
+]
 ;
 
 /*
@@ -80,7 +81,9 @@ ProcedureCall:
 ;
 */
 
-StatementSequence(struct node **pnd;):
+StatementSequence(register struct node **pnd;)
+{
+} :
 	statement(pnd)
 	[
 		';'	{ *pnd = MkNode(Link, *pnd, NULLNODE, &dot);
@@ -94,21 +97,21 @@ IfStatement(struct node **pnd;)
 {
 	register struct node *nd;
 } :
-	IF		{ nd = MkNode(Stat, NULLNODE, NULLNODE, &dot);
+	IF		{ nd = MkLeaf(Stat, &dot);
 			  *pnd = nd;
 			}
 	expression(&(nd->nd_left))
-	THEN		{ nd = MkNode(Link, NULLNODE, NULLNODE, &dot);
-			  (*pnd)->nd_right = nd;
+	THEN		{ nd->nd_right = MkLeaf(Link, &dot);
+			  nd = nd->nd_right;
 			}
 	StatementSequence(&(nd->nd_left))
 	[
-		ELSIF	{ nd->nd_right = MkNode(Stat,NULLNODE,NULLNODE,&dot);
+		ELSIF	{ nd->nd_right = MkLeaf(Stat, &dot);
 			  nd = nd->nd_right;
 			  nd->nd_symb = IF;
 			}
 		expression(&(nd->nd_left))
-		THEN	{ nd->nd_right = MkNode(Link,NULLNODE,NULLNODE,&dot);
+		THEN	{ nd->nd_right = MkLeaf(Link, &dot);
 			  nd = nd->nd_right;
 			}
 		StatementSequence(&(nd->nd_left))
@@ -125,7 +128,7 @@ CaseStatement(struct node **pnd;)
 	register struct node *nd;
 	struct type *tp = 0;
 } :
-	CASE		{ *pnd = nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
+	CASE		{ *pnd = nd = MkLeaf(Stat, &dot); }
 	expression(&(nd->nd_left))
 	OF
 	case(&(nd->nd_right), &tp)
@@ -140,12 +143,10 @@ CaseStatement(struct node **pnd;)
 ;
 
 case(struct node **pnd; struct type **ptp;) :
-			{ *pnd = 0; }
 	[ CaseLabelList(ptp, pnd)
 	  ':'		{ *pnd = MkNode(Link, *pnd, NULLNODE, &dot); }
 	  StatementSequence(&((*pnd)->nd_right))
 	]?
-				/* This rule is changed in new modula-2 */
 			{ *pnd = MkNode(Link, *pnd, NULLNODE, &dot);
 			  (*pnd)->nd_symb = '|';
 			}
@@ -155,7 +156,7 @@ WhileStatement(struct node **pnd;)
 {
 	register struct node *nd;
 }:
-	WHILE		{ *pnd = nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
+	WHILE		{ *pnd = nd = MkLeaf(Stat, &dot); }
 	expression(&(nd->nd_left))
 	DO
 	StatementSequence(&(nd->nd_right))
@@ -166,7 +167,7 @@ RepeatStatement(struct node **pnd;)
 {
 	register struct node *nd;
 }:
-	REPEAT		{ *pnd = nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
+	REPEAT		{ *pnd = nd = MkLeaf(Stat, &dot); }
 	StatementSequence(&(nd->nd_left))
 	UNTIL
 	expression(&(nd->nd_right))
@@ -177,10 +178,10 @@ ForStatement(struct node **pnd;)
 	register struct node *nd;
 	struct node *dummy;
 }:
-	FOR		{ *pnd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
-	IDENT		{ (*pnd)->nd_IDF = dot.TOK_IDF; }
-	BECOMES		{ nd = MkNode(Stat, NULLNODE, NULLNODE, &dot);
-			  (*pnd)->nd_left = nd;
+	FOR		{ *pnd = nd = MkLeaf(Stat, &dot); }
+	IDENT		{ nd->nd_IDF = dot.TOK_IDF; }
+	BECOMES		{ nd->nd_left = MkLeaf(Stat, &dot);
+			  nd = nd->nd_left;
 			}
 	expression(&(nd->nd_left))
 	TO
@@ -204,7 +205,7 @@ ForStatement(struct node **pnd;)
 ;
 
 LoopStatement(struct node **pnd;):
-	LOOP		{ *pnd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
+	LOOP		{ *pnd = MkLeaf(Stat, &dot); }
 	StatementSequence(&((*pnd)->nd_right))
 	END
 ;
@@ -213,7 +214,7 @@ WithStatement(struct node **pnd;)
 {
 	register struct node *nd;
 }:
-	WITH		{ *pnd = nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
+	WITH		{ *pnd = nd = MkLeaf(Stat, &dot); }
 	designator(&(nd->nd_left))
 	DO
 	StatementSequence(&(nd->nd_right))
@@ -226,7 +227,7 @@ ReturnStatement(struct node **pnd;)
 	register struct node *nd;
 } :
 
-	RETURN		{ *pnd = nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
+	RETURN		{ *pnd = nd = MkLeaf(Stat, &dot); }
 	[
 		expression(&(nd->nd_right))
 			{ if (scopeclosed(CurrentScope)) {
diff --git a/lang/m2/comp/type.H b/lang/m2/comp/type.H
index 958a76e7d..010b9e04a 100644
--- a/lang/m2/comp/type.H
+++ b/lang/m2/comp/type.H
@@ -21,18 +21,20 @@ struct enume {
 };
 
 struct subrange {
-	arith su_lb, su_ub;	/* Lower bound and upper bound */
-	label su_rck;		/* Label of range check descriptor */
+	arith su_lb, su_ub;	/* lower bound and upper bound */
+	label su_rck;		/* label of range check descriptor */
 #define sub_lb	tp_value.tp_subrange.su_lb
 #define sub_ub	tp_value.tp_subrange.su_ub
 #define sub_rck	tp_value.tp_subrange.su_rck
 };
 
 struct array {
-	struct type *ar_elem;	/* Type of elements */
-	label ar_descr;		/* Label of array descriptor */
+	struct type *ar_elem;	/* type of elements */
+	label ar_descr;		/* label of array descriptor */
+	arith ar_elsize;	/* size of elements */
 #define arr_elem	tp_value.tp_arr.ar_elem
 #define arr_descr	tp_value.tp_arr.ar_descr
+#define arr_elsize	tp_value.tp_arr.ar_elsize
 };
 
 struct record {
@@ -59,7 +61,7 @@ struct type	{
 #define T_CARDINAL	0x0008
 /* #define T_LONGINT	0x0010 */
 #define T_REAL		0x0020
-/* #define T_LONGREAL	0x0040 */
+#define T_HIDDEN	0x0040
 #define T_POINTER	0x0080
 #define T_CHAR		0x0100
 #define T_WORD		0x0200
@@ -89,7 +91,6 @@ struct type	{
 extern struct type
 	*bool_type,
 	*char_type,
-	*charc_type,
 	*int_type,
 	*card_type,
 	*longint_type,
@@ -132,7 +133,7 @@ struct type
 
 #define NULLTYPE ((struct type *) 0)
 
-#define IsConformantArray(tpx)	((tpx)->tp_fund == T_ARRAY && (tpx)->next == 0)
+#define IsConformantArray(tpx)	((tpx)->tp_fund==T_ARRAY && (tpx)->next==0)
 #define bounded(tpx)	((tpx)->tp_fund & T_INDEX)
 #define complex(tpx)	((tpx)->tp_fund & (T_RECORD|T_ARRAY))
 #define returntype(tpx)	(((tpx)->tp_fund & T_PRCRESULT) ||\
diff --git a/lang/m2/comp/type.c b/lang/m2/comp/type.c
index 9319f9d95..974c8669e 100644
--- a/lang/m2/comp/type.c
+++ b/lang/m2/comp/type.c
@@ -45,7 +45,6 @@ arith
 struct type
 	*bool_type,
 	*char_type,
-	*charc_type,
 	*int_type,
 	*card_type,
 	*longint_type,
@@ -72,7 +71,7 @@ extern label	data_label();
 
 struct type *
 create_type(fund)
-	register int fund;
+	int fund;
 {
 	/*	A brand new struct type is created, and its tp_fund set
 		to fund.
@@ -81,29 +80,29 @@ create_type(fund)
 
 	clear((char *)ntp, sizeof(struct type));
 	ntp->tp_fund = fund;
-	ntp->tp_size = (arith)-1;
 
 	return ntp;
 }
 
 struct type *
 construct_type(fund, tp)
-	struct type *tp;
+	int fund;
+	register struct type *tp;
 {
 	/*	fund must be a type constructor.
 		The pointer to the constructed type is returned.
 	*/
-	struct type *dtp = create_type(fund);
+	register struct type *dtp = create_type(fund);
 
 	switch (fund)	{
 	case T_PROCEDURE:
 	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 (tp != bitset_type &&
-			    !(tp->tp_fund&(T_NUMERIC|T_INDEX|T_WORD|T_POINTER))) {
+			if (! returntype(tp)) {
 				error("illegal procedure result type");
 			}
 		}
@@ -142,7 +141,9 @@ align(pos, al)
 
 struct type *
 standard_type(fund, align, size)
-	int align; arith size;
+	int fund;
+	int align;
+	arith size;
 {
 	register struct type *tp = create_type(fund);
 
@@ -161,15 +162,19 @@ init_types()
 	/* first, do some checking
 	*/
 	if (int_size != word_size) {
-		fatal("Integer size not equal to word size");
+		fatal("integer size not equal to word size");
 	}
 
-	if (long_size < int_size) {
-		fatal("Long integer size smaller than integer size");
+	if (long_size < int_size || long_size % word_size != 0) {
+		fatal("illegal long integer size");
 	}
 
 	if (double_size < float_size) {
-		fatal("Long real size smaller than real size");
+		fatal("long real size smaller than real size");
+	}
+
+	if (!pointer_size || pointer_size % word_size != 0) {
+		fatal("illegal pointer size");
 	}
 
 	/* character type
@@ -177,12 +182,6 @@ init_types()
 	char_type = standard_type(T_CHAR, 1, (arith) 1);
 	char_type->enm_ncst = 256;
 	
-	/* character constant type, different from character type because
-	   of compatibility with character array's
-	*/
-	charc_type = standard_type(T_CHAR, 1, (arith) 1);
-	charc_type->enm_ncst = 256;
-
 	/* boolean type
 	*/
 	bool_type = standard_type(T_ENUMERATION, 1, (arith) 1);
@@ -226,28 +225,36 @@ ParamList(ppr, ids, tp, VARp, off)
 	register struct node *ids;
 	struct paramlist **ppr;
 	struct type *tp;
+	int VARp;
 	arith *off;
 {
 	/*	Create (part of) a parameterlist of a procedure.
 		"ids" indicates the list of identifiers, "tp" their type, and
-		"VARp" is set when the parameters are VAR-parameters.
-*/
+		"VARp" indicates D_VARPAR or D_VALPAR.
+	*/
 	register struct paramlist *pr;
 	register struct def *df;
-	struct paramlist *pstart;
 
-	while (ids) {
+	for ( ; ids; ids = ids->next) {
 		pr = new_paramlist();
 		pr->next = *ppr;
 		*ppr = pr;
 		df = define(ids->nd_IDF, CurrentScope, D_VARIABLE);
 		pr->par_def = df;
 		df->df_type = tp;
-		if (VARp) df->df_flags = D_VARPAR;
-		else	df->df_flags = D_VALPAR;
 		df->var_off = align(*off, word_align);
-		*off = df->var_off + tp->tp_size;
-		ids = ids->next;
+		df->df_flags = VARp;
+		if (IsConformantArray(tp)) {
+			/* we need room for the base address and a descriptor
+			*/
+			*off = df->var_off + pointer_size + 3 * word_size;
+		}
+		else if (VARp == D_VARPAR) {
+			*off = df->var_off + pointer_size;
+		}
+		else {
+			*off = df->var_off + tp->tp_size;
+		}
 	}
 }
 
@@ -267,7 +274,7 @@ chk_basesubrange(tp, base)
 		base = base->next;
 	}
 
-	if (base->tp_fund == T_ENUMERATION || base->tp_fund == T_CHAR) {
+	if (base->tp_fund & (T_ENUMERATION|T_CHAR)) {
 		if (tp->next != base) {
 			error("Specified base does not conform");
 		}
@@ -384,7 +391,7 @@ getbounds(tp, plo, phi)
 }
 struct type *
 set_type(tp)
-	struct type *tp;
+	register struct type *tp;
 {
 	/*	Construct a set type with base type "tp", but first
 		perform some checks
@@ -414,22 +421,33 @@ set_type(tp)
 	return tp;
 }
 
+arith
+ArrayElSize(tp)
+	register struct type *tp;
+{
+	/* Align element size to alignment requirement of element type.
+	   Also make sure that its size is either a dividor of the word_size,
+	   or a multiple of it.
+	*/
+	arith algn;
+
+	if (tp->tp_fund == T_ARRAY) ArraySizes(tp);
+	algn = align(tp->tp_size, tp->tp_align);
+	if (!(algn % word_size == 0 || word_size % algn == 0)) {
+		algn = align(algn, word_size);
+	}
+	return algn;
+}
+
 ArraySizes(tp)
 	register struct type *tp;
 {
 	/*	Assign sizes to an array type, and check index type
 	*/
-	arith elem_size;
 	register struct type *index_type = tp->next;
 	register struct type *elem_type = tp->arr_elem;
 
-	if (elem_type->tp_fund == T_ARRAY) {
-		ArraySizes(elem_type);
-	}
-
-	/* align element size to alignment requirement of element type
-	*/
-	elem_size = align(elem_type->tp_size, elem_type->tp_align);
+	tp->arr_elsize = ArrayElSize(elem_type);
 	tp->tp_align = elem_type->tp_align;
 
 	/* check index type
@@ -447,7 +465,7 @@ ArraySizes(tp)
 
 	switch(index_type->tp_fund) {
 	case T_SUBRANGE:
-		tp->tp_size = elem_size *
+		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);
@@ -455,7 +473,7 @@ ArraySizes(tp)
 
 	case T_CHAR:
 	case T_ENUMERATION:
-		tp->tp_size = elem_size * index_type->enm_ncst;
+		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;
@@ -464,7 +482,7 @@ ArraySizes(tp)
 		crash("Funny index type");
 	}
 	
-	C_rom_cst(elem_size);
+	C_rom_cst(tp->arr_elsize);
 
 	/* ??? overflow checking ???
 	*/
@@ -473,7 +491,9 @@ ArraySizes(tp)
 FreeType(tp)
 	struct type *tp;
 {
-	/*	Release type structures indicated by "tp"
+	/*	Release type structures indicated by "tp".
+		This procedure is only called for types, constructed with
+		T_PROCEDURE.
 	*/
 	register struct paramlist *pr, *pr1;
 
diff --git a/lang/m2/comp/typequiv.c b/lang/m2/comp/typequiv.c
index b46971bcd..aa2234092 100644
--- a/lang/m2/comp/typequiv.c
+++ b/lang/m2/comp/typequiv.c
@@ -105,10 +105,6 @@ TstCompat(tp1, tp2)
 		&&
 		   (tp1 == int_type || tp1 == card_type)
 		)
-	    ||
-		(tp1 == char_type && tp2 == charc_type)
-	    ||
-		(tp2 == char_type && tp1 == charc_type)
 	    ||
 		(  tp1 == address_type
 		&& 
@@ -145,8 +141,6 @@ TstAssCompat(tp1, tp2)
 	if ((tp1->tp_fund & T_INTORCARD) &&
 	    (tp2->tp_fund & T_INTORCARD)) return 1;
 
-	if (tp1 == char_type && tp2 == charc_type) return 1;
-
 	if (tp1->tp_fund == T_ARRAY) {
 		/* check for string
 		*/
@@ -162,12 +156,8 @@ TstAssCompat(tp1, tp2)
 		if (tp1->tp_fund == T_SUBRANGE) tp1 = tp1->next;
 	    	return
 			tp1 == char_type
-		    &&
-			(
-			    tp2 == charc_type
-			||
-			    (tp2->tp_fund == T_STRING && size >= tp2->tp_size)
-			);
+		    &&	(tp2->tp_fund  == T_STRING && size >= tp2->tp_size)
+			;
 	}
 
 	return 0;
diff --git a/lang/m2/comp/walk.c b/lang/m2/comp/walk.c
index 578cc67cd..eb655e678 100644
--- a/lang/m2/comp/walk.c
+++ b/lang/m2/comp/walk.c
@@ -25,7 +25,6 @@ static char *RcsId = "$Header$";
 #include	"f_info.h"
 #include	"idf.h"
 
-extern arith	align();
 extern arith	NewPtr();
 extern arith	NewInt();
 extern int	proclevel;
@@ -58,7 +57,7 @@ DoProfil()
 		if (!filename_label) {
 			filename_label = data_label();
 			C_df_dlb(filename_label);
-			C_rom_scon(FileName, (arith) strlen(FileName));
+			C_rom_scon(FileName, (arith) (strlen(FileName) + 1));
 		}
 
 		C_fil_dlb(filename_label, (arith) 0);
@@ -131,20 +130,22 @@ WalkModule(module)
 		   Call initialization routines of imported modules.
 		   Also prevent recursive calls of this one.
 		*/
-		label l1 = data_label(), l2 = text_label();
 		struct node *nd;
 
-		/* 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_ret((arith) 0);
-		C_df_ilb(l2);
-		C_loc((arith) 1);
-		C_ste_dlb(l1, (arith) 0);
+		if (state == IMPLEMENTATION) {
+			label l1 = data_label(), l2 = text_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_ret((arith) 0);
+			C_df_ilb(l2);
+			C_loc((arith) 1);
+			C_ste_dlb(l1, (arith) 0);
+		}
 
 		nd = Modules;
 		while (nd) {
@@ -278,7 +279,7 @@ WalkStat(nd, lab)
 		return;
 	}
 
-	if (options['L']) C_lin((arith) nd->nd_lineno);
+	if (! options['L']) C_lin((arith) nd->nd_lineno);
 
 	if (nd->nd_class == Call) {
 		if (chk_call(nd)) {
@@ -541,8 +542,11 @@ DoAssign(nd, left, right)
 	/* May we do it in this order (expression first) ??? */
 	struct desig ds;
 
-	WalkExpr(right, NO_LABEL, NO_LABEL);
+	if (!chk_expr(right)) return;
 	if (! chk_designator(left, DESIGNATOR|VARIABLE, D_DEFINED)) return;
+	TryToString(right, left->nd_type);
+	Desig = InitDesig;
+	CodeExpr(right, &Desig, NO_LABEL, NO_LABEL);
 
 	if (! TstAssCompat(left->nd_type, right->nd_type)) {
 		node_error(nd, "type incompatibility in assignment");