newer version

lang/m2/comp/Makefile

@@ -18,7 +18,7 @@ LOBJ =	tokenfile.o program.o declar.o expression.o statement.o
 COBJ =	LLlex.o LLmessage.o char.o error.o main.o \
 	symbol2str.o tokenname.o idf.o input.o type.o def.o \
 	scope.o misc.o enter.o defmodule.o typequiv.o node.o \
-	cstoper.o chk_expr.o options.o walk.o casestat.o
+	cstoper.o chk_expr.o options.o walk.o casestat.o desig.o code.o
 OBJ =	$(COBJ) $(LOBJ) Lpars.o
 GENFILES=	tokenfile.c \
 	program.c declar.c expression.c statement.c \

lang/m2/comp/casestat.C

@@ -15,6 +15,7 @@ static char *RcsId = "$Header$";
 #include	"type.h"
 #include	"LLlex.h"
 #include	"node.h"
+#include	"desig.h"
 
 #include	"density.h"
 
@@ -64,7 +65,7 @@ CaseCode(nd, exitlabel)
 
 	assert(nd->nd_class == Stat && nd->nd_symb == CASE);
 
-	WalkExpr(nd->nd_left);
+	WalkExpr(nd->nd_left, NO_LABEL, NO_LABEL);
 	sh->sh_type = nd->nd_left->nd_type;
 	sh->sh_break = text_label();
 	sh->sh_default = 0;

lang/m2/comp/chk_expr.c

@@ -371,6 +371,12 @@ node_error(arg->nd_left, "type incompatibility in parameter");
 			return 0;
 		}
 
+		if (param->par_var &&
+		    !chk_designator(arg->nd_left, VARIABLE|DESIGNATOR)) {
+			node_error(arg->nd_left,"VAR parameter expected");
+			return 0;
+		}
+
 		param = param->next;
 	}
 
@@ -445,14 +451,20 @@ chk_designator(expp, flag)
 
 	if (expp->nd_class == Link) {
 		assert(expp->nd_symb == '.');
-		assert(expp->nd_right->nd_class == Name);
 
 		if (! chk_designator(expp->nd_left,
 				     (flag|HASSELECTORS))) return 0;
 
 		tp = expp->nd_left->nd_type;
 
+		if (expp->nd_right->nd_class == Def) {
+			/* We were here already!
+			*/
+			return 1;
+		}
+
 		assert(tp->tp_fund == T_RECORD);
+		assert(expp->nd_right->nd_class == Name);
 
 		df = lookup(expp->nd_right->nd_IDF, tp->rec_scope);
 
@@ -472,7 +484,8 @@ df->df_idf->id_text);
 			}
 		}
 
-		if (expp->nd_left->nd_class == Def) {
+		if (expp->nd_left->nd_class == Def &&
+		    expp->nd_left->nd_def->df_kind == D_MODULE) {
 			expp->nd_class = Def;
 			expp->nd_def = df;
 			FreeNode(expp->nd_left);

lang/m2/comp/code.c

@@ -0,0 +1,584 @@
+/* C O D E   G E N E R A T I O N   R O U T I N E S */
+
+#ifndef NORCSID
+static char *RcsId = "$Header$";
+#endif
+
+/*	Code generation for expressions and coercions
+*/
+
+#include	"debug.h"
+
+#include	<em_arith.h>
+#include	<em_label.h>
+#include	<assert.h>
+
+#include	"type.h"
+#include	"def.h"
+#include	"scope.h"
+#include	"desig.h"
+#include	"LLlex.h"
+#include	"node.h"
+#include	"Lpars.h"
+
+extern label	data_label();
+extern char	*long2str();
+extern char	*symbol2str();
+extern int	proclevel;
+
+CodeConst(cst, size)
+	arith cst, size;
+{
+	/*	Generate code to push constant "cst" with size "size"
+	*/
+	label dlab;
+
+	if (size <= word_size) {
+		C_loc(cst);
+	}
+	else if (size == dword_size) {
+		C_ldc(cst);
+	}
+	else {
+		C_df_dlb(dlab = data_label());
+		C_rom_icon(long2str((long) cst), 10);
+		C_lae_dlb(dlab);
+		C_loi(size);
+	}
+}
+
+CodeString(nd)
+	struct node *nd;
+{
+	
+	label lab;
+	
+	C_df_dlb(lab = data_label());
+	C_rom_scon(nd->nd_STR, nd->nd_SLE);
+	C_lae_dlb(lab);
+}
+
+CodeReal(nd)
+	struct node *nd;
+{
+	label lab;
+	
+	C_df_dlb(lab = data_label());
+	C_rom_fcon(nd->nd_REL, nd->nd_type->tp_size);
+	C_lae_dlb(lab);
+	C_loi(nd->nd_type->tp_size);
+}
+
+CodeExpr(nd, ds, true_label, false_label)
+	struct node *nd;
+	struct desig *ds;
+	label true_label, false_label;
+{
+	struct desig ds1, ds2;
+
+	switch(nd->nd_class) {
+	case Def:
+		CodeDesig(nd, ds);
+		break;
+
+	case Oper:
+		if (nd->nd_symb == '[') {
+			CodeDesig(nd, ds);
+			break;
+		}
+		CodeOper(nd, true_label, false_label);
+		if (true_label == 0) ds->dsg_kind = DSG_LOADED;
+		else {
+			*ds = InitDesig;
+			true_label = 0;
+		}
+		break;
+
+	case Uoper:
+		if (nd->nd_symb == '^') {
+			CodeDesig(nd, ds);
+			break;
+		}
+		CodeExpr(nd->nd_right, ds, NO_LABEL, NO_LABEL);
+		CodeValue(ds, nd->nd_right->nd_type->tp_size);
+		CodeUoper(nd);
+		ds->dsg_kind = DSG_LOADED;
+		break;
+
+	case Value:
+		switch(nd->nd_symb) {
+		case REAL:
+			CodeReal(nd);
+			break;
+		case STRING:
+			CodeString(nd);
+			break;
+		case INTEGER:
+			CodeConst(nd->nd_INT, nd->nd_type->tp_size);
+			break;
+		default:
+			crash("Value error");
+		}
+		ds->dsg_kind = DSG_LOADED;
+		break;
+
+	case Link:
+		CodeDesig(nd, ds);
+		break;
+		
+	case Call:
+		CodeCall(nd);
+		ds->dsg_kind = DSG_LOADED;
+		break;
+
+	case Xset:
+	case Set:
+		/* ??? */
+		ds->dsg_kind = DSG_LOADED;
+		break;
+		
+	default:
+		crash("(CodeExpr) bad node type");
+	}
+
+	if (true_label != 0) {
+		CodeValue(ds, nd->nd_type->tp_size);
+		*ds = InitDesig;
+		C_zne(true_label);
+		C_bra(false_label);
+	}
+}
+
+CodeCoercion(t1, t2)
+	struct type *t1, *t2;
+{
+	/* ??? */
+}
+
+CodeCall(nd)
+	struct node *nd;
+{
+	/*	Generate code for a procedure call. Checking of parameters
+		and result is already done.
+	*/
+	register struct node *left = nd->nd_left;
+	register struct node *arg = nd;
+	register struct paramlist *param;
+	struct type *tp;
+	arith pushed = 0;
+	struct desig Des;
+
+	if (left->nd_type == std_type) {
+		CodeStd(nd);
+		return;
+	}	
+	tp = left->nd_type;
+
+	assert(tp->tp_fund == T_PROCEDURE);
+
+	for (param = left->nd_type->prc_params; param; param = param->next) {
+		Des = InitDesig;
+		arg = arg->nd_right;
+		assert(arg != 0);
+		if (param->par_var) {
+			CodeDesig(arg->nd_left, &Des);
+			CodeAddress(&Des);
+			pushed += pointer_size;
+		}
+		else {
+			CodeExpr(arg->nd_left, &Des, NO_LABEL, NO_LABEL);
+			CodeValue(&Des, arg->nd_left->nd_type->tp_size);
+			pushed += align(arg->nd_left->nd_type->tp_size, word_align);
+		}
+		/* ??? Conformant arrays */
+	}
+
+	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);
+			pushed += pointer_size;
+		}
+		C_cal(left->nd_def->prc_vis->sc_scope->sc_name);
+	}
+	else if (left->nd_class == Def && left->nd_def->df_kind == D_PROCHEAD) {
+		C_cal(left->nd_def->for_name);
+	}
+	else {
+		Des = InitDesig;
+		CodeDesig(left, &Des);
+		CodeAddress(&Des);
+		C_cai();
+	}
+	C_asp(pushed);
+	if (tp->next) {
+		C_lfr(align(tp->next->tp_size, word_align));
+	}
+}
+
+CodeStd(nd)
+	struct node *nd;
+{
+	/* ??? */
+}
+
+CodeAssign(nd, dst, dss)
+	struct node *nd;
+	struct desig *dst, dss;
+{
+	/*	Generate code for an assignment. Testing of type
+		compatibility and the like is already done.
+	*/
+	
+	CodeCoercion(nd->nd_right->nd_type, nd->nd_left->nd_type);
+	/* ??? */
+}
+
+Operands(leftop, rightop)
+	struct node *leftop, *rightop;
+{
+	struct desig Des;
+
+	Des = InitDesig;
+	CodeExpr(leftop, &Des, NO_LABEL, NO_LABEL);
+	CodeValue(&Des, leftop->nd_type->tp_size);
+	Des = InitDesig;
+
+	if (rightop->nd_type->tp_fund == T_POINTER && 
+	    leftop->nd_type->tp_size != pointer_size) {
+		CodeCoercion(leftop->nd_type, rightop->nd_type);
+		leftop->nd_type = rightop->nd_type;
+	}
+
+	CodeExpr(rightop, &Des, NO_LABEL, NO_LABEL);
+	CodeValue(&Des, rightop->nd_type->tp_size);
+}
+
+CodeOper(expr, true_label, false_label)
+	struct node *expr;	/* the expression tree itself		*/
+	label true_label;
+	label false_label;	/* labels to jump to in logical expr's	*/
+{
+	register int oper = expr->nd_symb;
+	register struct node *leftop = expr->nd_left;
+	register struct node *rightop = expr->nd_right;
+	register struct type *tp = expr->nd_type;
+	struct desig Des;
+	register struct desig *ds = &Des;
+
+	switch (oper)	{
+	case '+':
+		Operands(leftop, rightop);
+		switch (tp->tp_fund)	{
+		case T_INTEGER:
+			C_adi(tp->tp_size);
+			break;
+		case T_POINTER:
+			C_ads(rightop->nd_type->tp_size);
+			break;
+		case T_REAL:
+			C_adf(tp->tp_size);
+			break;
+		case T_CARDINAL:
+			C_adu(tp->tp_size);
+			break;
+		case T_SET:
+			C_ior(tp->tp_size);
+			break;
+		default:
+			crash("bad type +");
+		}
+		break;
+	case '-':
+		Operands(leftop, rightop);
+		switch (tp->tp_fund)	{
+		case T_INTEGER:
+			C_sbi(tp->tp_size);
+			break;
+		case T_POINTER:
+			if (rightop->nd_type->tp_fund == T_POINTER) {
+				C_sbs(pointer_size);
+			}
+			else	{
+				C_ngi(rightop->nd_type->tp_size);
+				C_ads(rightop->nd_type->tp_size);
+			}
+			break;
+		case T_REAL:
+			C_sbf(tp->tp_size);
+			break;
+		case T_CARDINAL:
+			C_sbu(tp->tp_size);
+			break;
+		case T_SET:
+			C_com(tp->tp_size);
+			C_and(tp->tp_size);
+			break;
+		default:
+			crash("bad type -");
+		}
+		break;
+	case '*':
+		Operands(leftop, rightop);
+		switch (tp->tp_fund)	{
+		case T_INTEGER:
+			C_mli(tp->tp_size);
+			break;
+		case T_POINTER:
+			CodeCoercion(rightop->nd_type, tp);
+			/* Fall through */
+		case T_CARDINAL:
+			C_mlu(tp->tp_size);
+			break;
+		case T_REAL:
+			C_mlf(tp->tp_size);
+			break;
+		case T_SET:
+			C_and(tp->tp_size);
+			break;
+		default:
+			crash("bad type *");
+		}
+		break;
+	case '/':
+		Operands(leftop, rightop);
+		switch (tp->tp_fund)	{
+		case T_REAL:
+			C_dvf(tp->tp_size);
+			break;
+		case T_SET:
+			C_xor(tp->tp_size);
+			break;
+		default:
+			crash("bad type /");
+		}
+		break;
+	case DIV:
+		Operands(leftop, rightop);
+		switch(tp->tp_fund)	{
+		case T_INTEGER:
+			C_dvi(tp->tp_size);
+			break;
+		case T_POINTER:
+			CodeCoercion(rightop->nd_type, tp);
+			/* Fall through */
+		case T_CARDINAL:
+			C_dvu(tp->tp_size);
+			break;
+		default:
+			crash("bad type DIV");
+		}
+		break;
+	case MOD:
+		Operands(leftop, rightop);
+		switch(tp->tp_fund)	{
+		case T_INTEGER:
+			C_rmi(tp->tp_size);
+			break;
+		case T_POINTER:
+			CodeCoercion(rightop->nd_type, tp);
+			/* Fall through */
+		case T_CARDINAL:
+			C_rmu(tp->tp_size);
+			break;
+		default:
+			crash("bad type MOD");
+		}
+		break;
+	case '<':
+	case LESSEQUAL:
+	case '>':
+	case GREATEREQUAL:
+	case '=':
+	case UNEQUAL:
+	case '#':
+		Operands(leftop, rightop);
+		CodeCoercion(rightop->nd_type, leftop->nd_type);
+		switch (tp->tp_fund)	{
+		case T_INTEGER:
+			C_cmi(leftop->nd_type->tp_size);
+			break;
+		case T_POINTER:
+			C_cmp();
+			break;
+		case T_CARDINAL:
+			C_cmu(leftop->nd_type->tp_size);
+			break;
+		case T_ENUMERATION:
+		case T_CHAR:
+			C_cmu(word_size);
+			break;
+		case T_REAL:
+			C_cmf(leftop->nd_type->tp_size);
+			break;
+		case T_SET:
+			C_cms(leftop->nd_type->tp_size);
+			break;
+		default:
+			crash("bad type COMPARE");
+		}
+		if (true_label != 0)	{
+			compare(oper, true_label);
+			C_bra(false_label);
+		}
+		else	{
+			truthvalue(oper);
+		}
+		break;
+	case IN:
+		Operands(leftop, rightop);
+		CodeCoercion(rightop->nd_type, word_type);
+		C_inn(leftop->nd_type->tp_size);
+		break;
+	case AND:
+	case '&':
+		if (true_label == 0)	{
+			label l_true = text_label();
+			label l_false = text_label();
+			label l_maybe = text_label();
+			label l_end = text_label();
+			struct desig Des;
+
+			Des = InitDesig;
+			CodeExpr(leftop, &Des, l_maybe, l_false);
+			C_df_ilb(l_maybe);
+			Des = InitDesig;
+			CodeExpr(rightop, &Des, l_true, l_false);
+			C_df_ilb(l_true);
+			C_loc((arith)1);
+			C_bra(l_end);
+			C_df_ilb(l_false);
+			C_loc((arith)0);
+			C_df_ilb(l_end);
+		}
+		else	{
+			label l_maybe = text_label();
+			struct desig Des;
+
+			Des = InitDesig;
+			CodeExpr(leftop, &Des, l_maybe, false_label);
+			Des = InitDesig;
+			C_df_ilb(l_maybe);
+			CodeExpr(rightop, &Des, true_label, false_label);
+		}
+		break;
+	case OR:
+		if (true_label == 0)	{
+			label l_true = text_label();
+			label l_false = text_label();
+			label l_maybe = text_label();
+			label l_end = text_label();
+			struct desig Des;
+
+			Des = InitDesig;
+			CodeExpr(leftop, &Des, l_true, l_maybe);
+			C_df_ilb(l_maybe);
+			Des = InitDesig;
+			CodeExpr(rightop, &Des, l_true, l_false);
+			C_df_ilb(l_false);
+			C_loc((arith)0);
+			C_bra(l_end);
+			C_df_ilb(l_true);
+			C_loc((arith)1);
+			C_df_ilb(l_end);
+		}
+		else	{
+			label l_maybe = text_label();
+			struct desig Des;
+
+			Des = InitDesig;
+			CodeExpr(leftop, &Des, true_label, l_maybe);
+			C_df_ilb(l_maybe);
+			Des = InitDesig;
+			CodeExpr(rightop, &Des, true_label, false_label);
+		}
+		break;
+	default:
+		crash("(CodeOper) Bad operator %s\n", symbol2str(oper));
+	}
+}
+
+/*	compare() serves as an auxiliary function of CodeOper	*/
+compare(relop, lbl)
+	int relop;
+	label lbl;
+{
+	switch (relop)	{
+	case '<':
+		C_zlt(lbl);
+		break;
+	case LESSEQUAL:
+		C_zle(lbl);
+		break;
+	case '>':
+		C_zgt(lbl);
+		break;
+	case GREATEREQUAL:
+		C_zge(lbl);
+		break;
+	case '=':
+		C_zeq(lbl);
+		break;
+	case UNEQUAL:
+	case '#':
+		C_zne(lbl);
+		break;
+	default:
+		crash("(compare)");
+	}
+}
+
+/*	truthvalue() serves as an auxiliary function of CodeOper	*/
+truthvalue(relop)
+	int relop;
+{
+	switch (relop)	{
+	case '<':
+		C_tlt();
+		break;
+	case LESSEQUAL:
+		C_tle();
+		break;
+	case '>':
+		C_tgt();
+		break;
+	case GREATEREQUAL:
+		C_tge();
+		break;
+	case '=':
+		C_teq();
+		break;
+	case UNEQUAL:
+	case '#':
+		C_tne();
+		break;
+	default:
+		crash("(truthvalue)");
+	}
+}
+
+CodeUoper(nd)
+	register struct node *nd;
+{
+	register struct type *tp = nd->nd_type;
+
+	switch(nd->nd_symb) {
+	case '~':
+	case NOT:
+		C_teq();
+		break;
+	case '-':
+		switch(tp->tp_fund) {
+		case T_INTEGER:
+			C_ngi(tp->tp_size);
+			break;
+		case T_REAL:
+			C_ngf(tp->tp_size);
+			break;
+		default:
+			crash("Bad operand to unary -");
+		}
+		break;
+	default:
+		crash("Bad unary operator");
+	}
+}

lang/m2/comp/declar.g

@@ -56,16 +56,16 @@ ProcedureHeading(struct def **pdf; int type;)
 		{
 		  if (type == D_PROCEDURE) proclevel++;
 		  df = DeclProc(type);
+		  tp = construct_type(T_PROCEDURE, tp);
 		  if (proclevel > 1) {
 			/* Room for static link
 			*/
-			df->prc_nbpar = pointer_size;
+			tp->prc_nbpar = pointer_size;
 		  }
-		  else	df->prc_nbpar = 0;
+		  else	tp->prc_nbpar = 0;
 		}
-	FormalParameters(type == D_PROCEDURE, &params, &tp, &(df->prc_nbpar))?
+	FormalParameters(type == D_PROCEDURE, &params, &(tp->next), &(tp->prc_nbpar))?
 		{
-		  tp = construct_type(T_PROCEDURE, tp);
 		  tp->prc_params = params;
 		  if (df->df_type) {
 			/* We already saw a definition of this type

lang/m2/comp/def.H

@@ -45,10 +45,8 @@ struct field {
 
 struct dfproc {
 	struct scopelist *pr_vis; /* scope of procedure */
-	arith pr_nbpar;		/* number of bytes parameters */
 	struct node *pr_body;	/* body of this procedure */
 #define prc_vis		df_value.df_proc.pr_vis
-#define prc_nbpar	df_value.df_proc.pr_nbpar
 #define prc_body	df_value.df_proc.pr_body
 };
 

lang/m2/comp/desig.c

@@ -24,6 +24,10 @@ static char *RcsId = "$Header$";
 #include	"LLlex.h"
 #include	"node.h"
 
+extern int	proclevel;
+struct desig	Desig;
+struct desig	InitDesig = {DSG_INIT, 0, 0};
+
 CodeValue(ds, size)
 	register struct desig *ds;
 {
@@ -44,7 +48,7 @@ CodeValue(ds, size)
 			break;
 		}
 
-		if (size == dwird_size) {
+		if (size == dword_size) {
 			if (ds->dsg_name) {
 				C_lde_dnam(ds->dsg_name, ds->dsg_offset);
 			}
@@ -63,7 +67,7 @@ CodeValue(ds, size)
 		break;
 
 	default:
-		assert(0);
+		crash("(CodeValue)");
 	}
 
 	ds->dsg_kind = DSG_LOADED;
@@ -101,8 +105,7 @@ CodeAddress(ds)
 		break;
 
 	default:
-		assert(0);
+		crash("(CodeAddress)");
-		break;
 	}
 
 	ds->dsg_offset = 0;
@@ -152,13 +155,176 @@ CodeFieldDesig(df, ds)
 	case DSG_PFIXED:
 	case DSG_INDEXED:
 		CodeAddress(ds);
-		ds->dsg_kind = PLOADED;
+		ds->dsg_kind = DSG_PLOADED;
 		ds->dsg_offset = df->fld_off;
 		break;
 
 	default:
-		assert(0);
+		crash("(CodeFieldDesig)");
-		break;
 	}
 }
 
+CodeVarDesig(df, ds)
+	register struct def *df;
+	register struct desig *ds;
+{
+	/*	Generate code for a variable represented by a "def" structure.
+		Of course, there are numerous cases: the variable is local,
+		it is a value parameter, it is a var parameter, it is one of
+		those of an enclosing procedure, or it is global.
+	*/
+	register struct scope *sc = df->df_scope;
+
+	/* Selections from a module are handled earlier, when identifying
+	   the variable, so ...
+	*/
+	assert(ds->dsg_kind == DSG_INIT);
+
+	if (df->var_addrgiven) {
+		/* the programmer specified an address in the declaration of
+		   the variable. Generate code to push the address.
+		*/
+		CodeConst(df->var_off, pointer_size);
+		ds->dsg_kind = DSG_PLOADED;
+		ds->dsg_offset = 0;
+		return;
+	}
+
+	if (df->var_name) {
+		/* this variable has been given a name, so it is global.
+		   It is directly accessible.
+		*/
+		ds->dsg_name = df->var_name;
+		ds->dsg_offset = 0;
+		ds->dsg_kind = DSG_FIXED;
+		return;
+	}
+	
+	if (sc->sc_level == 0) {
+		/* the variable is global, but declared in a module local
+		   to the implementation or program module.
+		   Such variables can be accessed through an offset from
+		   the name of the module.
+		*/
+		ds->dsg_name = &(sc->sc_name[1]);
+		ds->dsg_offset = df->var_off;
+		ds->dsg_kind = DSG_FIXED;
+		return;
+	}
+
+	if (sc->sc_level != proclevel) {
+		/* the variable is local to a statically enclosing procedure.
+		*/
+		assert(proclevel > sc->sc_level);
+		if (df->df_flags & (D_VARPAR|D_VALPAR)) {
+			/* value or var parameter
+			*/
+			C_lxa((arith) (proclevel - sc->sc_level));
+			if (df->df_flags & D_VARPAR) {
+				/* var parameter
+				*/
+				C_adp(df->var_off);
+				C_loi(pointer_size);
+				ds->dsg_offset = 0;
+				ds->dsg_kind = DSG_PLOADED;
+				return;
+			}
+		}
+		else	C_lxl((arith) (proclevel - sc->sc_level));
+		ds->dsg_kind = DSG_PLOADED;
+		ds->dsg_offset = df->var_off;
+		return;
+	}
+
+	/* Now, finally, we have a local variable or a local parameter
+	*/
+	if (df->df_flags & D_VARPAR) {
+		/* a var parameter; address directly accessible.
+		*/
+		ds->dsg_kind = DSG_PFIXED;
+	}
+	else	ds->dsg_kind = DSG_FIXED;
+	ds->dsg_offset =df->var_off;
+}
+
+CodeDesig(nd, ds)
+	register struct node *nd;
+	register struct desig *ds;
+{
+	/*	Generate code for a designator. Use divide and conquer
+		principle
+	*/
+
+	switch(nd->nd_class) {	/* Divide */
+	case Def: {
+		register struct def *df = nd->nd_def;
+
+		switch(df->df_kind) {
+		case D_FIELD:
+			CodeFieldDesig(df, ds);
+			break;
+
+		case D_VARIABLE:
+			CodeVarDesig(df, ds);
+			break;
+
+		default:
+			crash("(CodeDesig) Def");
+		}
+		}
+		break;
+
+	case Link:
+		assert(nd->nd_symb == '.');
+		assert(nd->nd_right->nd_class == Def);
+		CodeDesig(nd->nd_left, ds);
+		CodeFieldDesig(nd->nd_right->nd_def, ds);
+		break;
+
+	case Oper:
+		assert(nd->nd_symb == '[');
+		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);
+		CodeCoercion(nd->nd_right->nd_type, int_type);
+		if (IsConformantArray(nd->nd_left->nd_type)) {
+			/* ??? */
+		}
+		else	{
+			/* load address of descriptor
+			*/
+			/* ??? */
+		}
+		break;
+
+	case Uoper:
+		assert(nd->nd_symb == '^');
+		CodeDesig(nd->nd_right, ds);
+		switch(ds->dsg_kind) {
+		case DSG_LOADED:
+			ds->dsg_kind = DSG_PLOADED;
+			break;
+
+		case DSG_INDEXED:
+		case DSG_PLOADED:
+		case DSG_PFIXED:
+			CodeValue(ds, pointer_size);
+			ds->dsg_kind = DSG_PLOADED;
+			ds->dsg_offset = 0;
+			break;
+
+		case DSG_FIXED:
+			ds->dsg_kind = DSG_PFIXED;
+			break;
+
+		default:
+			crash("(CodeDesig) Uoper");
+		}
+		break;
+		
+	default:
+		crash("(CodeDesig) class");
+	}
+}

lang/m2/comp/desig.h

@@ -44,10 +44,12 @@ struct withdesig {
 	struct scope *w_scope;	/* scope in which fields of this record
 				   reside
 				*/
-	struct desig *w_desig;	/* a desig structure for this particular
+	struct desig w_desig;	/* a desig structure for this particular
 				   designator
 				*/
 };
 
 extern struct withdesig	*WithDesigs;
-extern struct desig	Desig;
+extern struct desig	Desig, InitDesig;
+
+#define NO_LABEL	((label) 0)

lang/m2/comp/enter.c

@@ -64,13 +64,34 @@ EnterIdList(idlist, kind, flags, type, scope, addr)
 		df->df_type = type;
 		df->df_flags |= flags;
 		if (addr) {
+			int xalign = type->tp_align;
+
+			if (xalign < word_align && kind != D_FIELD) {
+				xalign = word_align;
+			}
+
 			if (*addr >= 0) {
-				off = align(*addr, type->tp_align);
+				if (scope->sc_level) {
-				*addr = off + type->tp_size;
+					/* alignment of parameters is on
+					   word boundaries. We cannot do any
+					   better, because we don't know the
+					   alignment of the stack pointer when
+					   starting to push parameters
+					*/
+					off = *addr;
+					*addr = align(off, word_align);
 				}
 				else {
-				off = -align(-*addr, type->tp_align);
+					/* for global variables we can honour
-				*addr = off - type->tp_size;
+					   the alignment requirements totally.
+					*/
+					off = align(*addr, xalign);
+					*addr = off + type->tp_size;
+				}
+			}
+			else {
+				off = -align(-*addr-type->tp_size, xalign);
+				*addr = off;
 			}
 			if (kind == D_VARIABLE) {
 				df->var_off = off;

lang/m2/comp/error.c

@@ -111,6 +111,20 @@ fatal(fmt, args)
 	sys_stop(S_EXIT);
 }
 
+/*VARARGS1*/
+crash(fmt, args)
+	char *fmt;
+	int args;
+{
+
+	_error(CRASH, NULLNODE, fmt, &args);
+#ifdef DEBUG
+	sys_stop(S_ABORT);
+#else
+	sys_stop(S_EXIT);
+#endif
+}
+
 _error(class, node, fmt, argv)
 	int class;
 	struct node *node;

lang/m2/comp/type.H

@@ -45,7 +45,9 @@ struct record {
 
 struct proc {
 	struct paramlist *pr_params;
+	arith pr_nbpar;
 #define prc_params	tp_value.tp_proc.pr_params
+#define prc_nbpar	tp_value.tp_proc.pr_nbpar
 };
 
 struct type	{

lang/m2/comp/type.c

@@ -149,6 +149,20 @@ init_types()
 	*/
 	register struct type *tp;
 
+	/* first, do some checking
+	*/
+	if (int_size != word_size) {
+		fatal("Integer size not equal to word size");
+	}
+
+	if (long_size < int_size) {
+		fatal("Long integer size smaller than integer size");
+	}
+
+	if (double_size < float_size) {
+		fatal("Long real size smaller than real size");
+	}
+
 	/* character type
 	*/
 	char_type = standard_type(T_CHAR, 1, (arith) 1);

lang/m2/comp/walk.c

@@ -217,8 +217,11 @@ WalkStat(nd, lab)
 	assert(nd->nd_class == Stat);
 
 	switch(nd->nd_symb) {
-	case BECOMES:
+	case BECOMES: {
-		WalkExpr(right);
+		struct desig ds;
+
+		WalkExpr(right, NO_LABEL, NO_LABEL);
+		ds = Desig;
 		WalkDesignator(left);	/* May we do it in this order??? */
 
 		if (! TstAssCompat(left->nd_type, right->nd_type)) {
@@ -226,18 +229,19 @@ WalkStat(nd, lab)
 			break;
 		}
 
-		CodeAssign(nd);
+		CodeAssign(nd, &ds, &Desig);
-
+		}
 		break;
 
 	case IF:
-		{	label l1, l2;
+		{	label l1, l2, l3;
 
 			l1 = instructionlabel++;
 			l2 = instructionlabel++;
-			ExpectBool(left);
+			l3 = instructionlabel++;
+			ExpectBool(left, l3, l1);
 			assert(right->nd_symb == THEN);
-			C_zeq(l1);
+			C_df_ilb(l3);
 			WalkNode(right->nd_left, lab);
 
 			if (right->nd_right) {	/* ELSE part */
@@ -255,13 +259,14 @@ WalkStat(nd, lab)
 		break;
 
 	case WHILE:
-		{	label l1, l2;
+		{	label l1, l2, l3;
 
 			l1 = instructionlabel++;
 			l2 = instructionlabel++;
+			l3 = instructionlabel++;
 			C_df_ilb(l1);
-			ExpectBool(left);
+			ExpectBool(left, l3, l2);
-			C_zeq(l2);
+			C_df_ilb(l3);
 			WalkNode(right, lab);
 			C_bra(l1);
 			C_df_ilb(l2);
@@ -269,13 +274,14 @@ WalkStat(nd, lab)
 		}
 
 	case REPEAT:
-		{	label l1;
+		{	label l1, l2;
 
 			l1 = instructionlabel++;
+			l2 = instructionlabel++;
 			C_df_ilb(l1);
 			WalkNode(left, lab);
-			ExpectBool(right);
+			ExpectBool(right, l2, l1);
-			C_zeq(l1);
+			C_df_ilb(l2);
 			break;
 		}
 
@@ -314,10 +320,9 @@ WalkStat(nd, lab)
 			   Decide here wether to use a temporary variable or
 			   not, depending on the value of Desig.
 			   Suggestion: temporary if Desig != DSG_FIXED
-
+			   ???
-			   And then:
-			   wds.w_desig = Desig; ???
 			*/
+			wds.w_desig = Desig;
 			link.sc_scope = wds.w_scope;
 			link.next = CurrVis;
 			CurrVis = &link;
@@ -335,7 +340,7 @@ WalkStat(nd, lab)
 
 	case RETURN:
 		if (right) {
-			WalkExpr(right);
+			WalkExpr(right, NO_LABEL, NO_LABEL);
 			/* What kind of compatibility do we need here ???
 			   assignment compatibility?
 			*/
@@ -352,22 +357,24 @@ node_error(right, "type incompatibility in RETURN statement");
 	}
 }
 
-ExpectBool(nd)
+ExpectBool(nd, true_label, false_label)
 	struct node *nd;
+	label true_label, false_label;
 {
 	/*	"nd" must indicate a boolean expression. Check this and
 		generate code to evaluate the expression.
 	*/
 
-	WalkExpr(nd);
+	WalkExpr(nd, true_label, false_label);
 
 	if (nd->nd_type != bool_type && nd->nd_type != error_type) {
 		node_error(nd, "boolean expression expected");
 	}
 }
 
-WalkExpr(nd)
+WalkExpr(nd, true_label, false_label)
 	struct node *nd;
+	label true_label, false_label;
 {
 	/*	Check an expression and generate code for it
 	*/
@@ -376,7 +383,8 @@ WalkExpr(nd)
 
 	if (! chk_expr(nd)) return;
 
-	/* ??? */
+	Desig = InitDesig;
+	CodeExpr(nd, &Desig, true_label, false_label);
 }
 
 WalkDesignator(nd)
@@ -389,25 +397,8 @@ WalkDesignator(nd)
 
 	if (! chk_designator(nd, DESIGNATOR|VARIABLE)) return;
 
-	/* ??? */
+	Desig = InitDesig;
-}
+	CodeDesig(nd, &Desig);
-
-CodeCall(nd)
-	struct node *nd;
-{
-	/*	Generate code for a procedure call. Checking of parameters
-		and result is already done.
-	*/
-	/* ??? */
-}
-
-CodeAssign(nd)
-	struct node *nd;
-{
-	/*	Generate code for an assignment. Testing of type
-		compatibility and the like is already done.
-	*/
-	/* ??? */
 }
 
 #ifdef DEBUG