newer version

lang/m2/comp/Makefile

@@ -5,7 +5,7 @@ HDIR =	../../em/h
 PKGDIR =	../../em/pkg
 LIBDIR =	../../em/lib
 
-INCLUDES = -I$(HDIR) -I$(PKGDIR) -I/user1/erikb/em/h
+INCLUDES = -I$(HDIR) -I/usr/em/h -I$(PKGDIR) -I/user1/erikb/em/h
 
 LSRC =	tokenfile.g program.g declar.g expression.g statement.g
 CC =	cc
@@ -18,7 +18,8 @@ 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 desig.o code.o
+	cstoper.o chk_expr.o options.o walk.o casestat.o desig.o \
+	code.o tmpvar.o
 OBJ =	$(COBJ) $(LOBJ) Lpars.o
 GENFILES=	tokenfile.c \
 	program.c declar.c expression.c statement.c \
@@ -58,6 +59,7 @@ def.h:		def.H make.allocd
 type.h:		type.H make.allocd
 node.h:		node.H make.allocd
 scope.c:	scope.C make.allocd
+tmpvar.c:	tmpvar.C make.allocd
 casestat.c:	casestat.C make.allocd
 
 char.c: char.tab tab
@@ -100,7 +102,9 @@ cstoper.o: LLlex.h Lpars.h debug.h idf.h node.h standards.h target_sizes.h type.
 chk_expr.o: LLlex.h Lpars.h const.h debug.h def.h idf.h node.h scope.h standards.h type.h
 options.o: idfsize.h main.h ndir.h type.h
 walk.o: LLlex.h Lpars.h debug.h def.h desig.h main.h node.h scope.h type.h
-casestat.o: LLlex.h Lpars.h debug.h density.h node.h type.h
+casestat.o: LLlex.h Lpars.h debug.h density.h desig.h node.h type.h
+desig.o: LLlex.h debug.h def.h desig.h node.h scope.h type.h
+code.o: LLlex.h Lpars.h debug.h def.h desig.h node.h scope.h 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 debug.h def.h idf.h main.h misc.h node.h scope.h type.h

lang/m2/comp/chk_expr.c

@@ -244,7 +244,7 @@ rem_set(set)
 }
 
 struct node *
-getarg(argp, bases)
+getarg(argp, bases, designator)
 	struct node *argp;
 {
 	struct type *tp;
@@ -254,7 +254,10 @@ getarg(argp, bases)
 		return 0;
 	}
 	argp = argp->nd_right;
-	if (!chk_expr(argp->nd_left)) return 0;
+	if ((!designator && !chk_expr(argp->nd_left)) ||
+	    (designator && !chk_designator(argp->nd_left, DESIGNATOR))) {
+		return 0;
+	}
 	tp = argp->nd_left->nd_type;
 	if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
 	if (bases && !(tp->tp_fund & bases)) {
@@ -305,7 +308,6 @@ chk_call(expp)
 	if (left->nd_class == Def &&
 	    (left->nd_def->df_kind & (D_HTYPE|D_TYPE|D_HIDDEN))) {
 		/* It was a type cast. This is of course not portable.
-		   No runtime action. Remove it.
 		*/
 		arg = expp->nd_right;
 		if ((! arg) || arg->nd_right) {
@@ -317,14 +319,18 @@ node_error(expp, "only one parameter expected in type cast");
 		if (arg->nd_type->tp_size != left->nd_type->tp_size) {
 node_error(expp, "unequal sizes in type cast");
 		}
-		arg->nd_type = left->nd_type;
+		if (arg->nd_class == Value) {
-		FreeNode(expp->nd_left);
+			struct type *tp = left->nd_type;
-		expp->nd_right->nd_left = 0;
+
-		FreeNode(expp->nd_right);
+			FreeNode(expp->nd_left);
-		*expp = *arg;
+			expp->nd_right->nd_left = 0;
-		arg->nd_left = 0;
+			FreeNode(expp->nd_right);
-		arg->nd_right = 0;
+			expp->nd_left = expp->nd_right = 0;
-		FreeNode(arg);
+			*expp = *arg;
+			expp->nd_type = tp;
+		}
+		else expp->nd_type = left->nd_type;
+
 		return 1;
 	}
 
@@ -362,7 +368,7 @@ chk_proccall(expp)
 	param = left->nd_type->prc_params;
 
 	while (param) {
-		if (!(arg = getarg(arg, 0))) return 0;
+		if (!(arg = getarg(arg, 0, param->par_var))) return 0;
 
 		if (! TstParCompat(param->par_type,
 				   arg->nd_left->nd_type,
@@ -371,12 +377,6 @@ 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;
 	}
 
@@ -451,20 +451,14 @@ 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);
 
@@ -892,7 +886,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
 
 	switch(left->nd_def->df_value.df_stdname) {
 	case S_ABS:
-		if (!(arg = getarg(arg, T_NUMERIC))) return 0;
+		if (!(arg = getarg(arg, T_NUMERIC, 0))) return 0;
 		left = arg->nd_left;
 		expp->nd_type = left->nd_type;
 		if (left->nd_class == Value) cstcall(expp, S_ABS);
@@ -900,25 +894,25 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
 
 	case S_CAP:
 		expp->nd_type = char_type;
-		if (!(arg = getarg(arg, T_CHAR))) return 0;
+		if (!(arg = getarg(arg, T_CHAR, 0))) return 0;
 		left = arg->nd_left;
 		if (left->nd_class == Value) cstcall(expp, S_CAP);
 		break;
 
 	case S_CHR:
 		expp->nd_type = char_type;
-		if (!(arg = getarg(arg, T_INTORCARD))) return 0;
+		if (!(arg = getarg(arg, T_INTORCARD, 0))) return 0;
 		left = arg->nd_left;
 		if (left->nd_class == Value) cstcall(expp, S_CHR);
 		break;
 
 	case S_FLOAT:
 		expp->nd_type = real_type;
-		if (!(arg = getarg(arg, T_INTORCARD))) return 0;
+		if (!(arg = getarg(arg, T_INTORCARD, 0))) return 0;
 		break;
 
 	case S_HIGH:
-		if (!(arg = getarg(arg, T_ARRAY))) return 0;
+		if (!(arg = getarg(arg, T_ARRAY, 0))) return 0;
 		expp->nd_type = arg->nd_left->nd_type->next;
 		if (!expp->nd_type) {
 			/* A dynamic array has no explicit index type
@@ -930,19 +924,19 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
 
 	case S_MAX:
 	case S_MIN:
-		if (!(arg = getarg(arg, T_DISCRETE))) return 0;
+		if (!(arg = getarg(arg, T_DISCRETE, 0))) return 0;
 		expp->nd_type = arg->nd_left->nd_type;
 		cstcall(expp,left->nd_def->df_value.df_stdname);
 		break;
 
 	case S_ODD:
-		if (!(arg = getarg(arg, T_INTORCARD))) return 0;
+		if (!(arg = getarg(arg, T_INTORCARD, 0))) return 0;
 		expp->nd_type = bool_type;
 		if (arg->nd_left->nd_class == Value) cstcall(expp, S_ODD);
 		break;
 
 	case S_ORD:
-		if (!(arg = getarg(arg, T_DISCRETE))) return 0;
+		if (!(arg = getarg(arg, T_DISCRETE, 0))) return 0;
 		expp->nd_type = card_type;
 		if (arg->nd_left->nd_class == Value) cstcall(expp, S_ORD);
 		break;
@@ -957,7 +951,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
 
 	case S_TRUNC:
 		expp->nd_type = card_type;
-		if (!(arg = getarg(arg, T_REAL))) return 0;
+		if (!(arg = getarg(arg, T_REAL, 0))) return 0;
 		break;
 
 	case S_VAL:
@@ -975,7 +969,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
 		expp->nd_right = arg->nd_right;
 		arg->nd_right = 0;
 		FreeNode(arg);
-		arg = getarg(expp, T_INTORCARD);
+		arg = getarg(expp, T_INTORCARD, 0);
 		if (!arg) return 0;
 		if (arg->nd_left->nd_class == Value) cstcall(expp, S_VAL);
 		break;
@@ -983,7 +977,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
 
 	case S_ADR:
 		expp->nd_type = address_type;
-		if (!(arg = getarg(arg, D_VARIABLE|D_FIELD))) return 0;
+		if (!(arg = getarg(arg, 0, 1))) return 0;
 		break;
 
 	case S_DEC:
@@ -991,7 +985,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
 		expp->nd_type = 0;
 		if (!(arg = getvariable(arg))) return 0;
 		if (arg->nd_right) {
-			if (!(arg = getarg(arg, T_INTORCARD))) return 0;
+			if (!(arg = getarg(arg, T_INTORCARD, 0))) return 0;
 		}
 		break;
 
@@ -1011,7 +1005,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
 node_error(arg, "EXCL and INCL expect a SET parameter");
 			return 0;
 		}
-		if (!(arg = getarg(arg, T_DISCRETE))) return 0;
+		if (!(arg = getarg(arg, T_DISCRETE, 0))) return 0;
 		if (!TstAssCompat(tp->next, arg->nd_left->nd_type)) {
 			/* What type of compatibility do we want here?
 			   apparently assignment compatibility! ??? ???

lang/m2/comp/code.c

@@ -22,6 +22,7 @@ static char *RcsId = "$Header$";
 #include	"Lpars.h"
 
 extern label	data_label();
+extern label	text_label();
 extern char	*long2str();
 extern char	*symbol2str();
 extern int	proclevel;
@@ -42,7 +43,7 @@ CodeConst(cst, size)
 	else {
 		C_df_dlb(dlab = data_label());
 		C_rom_icon(long2str((long) cst), 10);
-		C_lae_dlb(dlab);
+		C_lae_dlb(dlab, (arith) 0);
 		C_loi(size);
 	}
 }
@@ -53,6 +54,10 @@ CodeString(nd)
 	
 	label lab;
 	
+	if (nd->nd_type == charc_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);
@@ -74,7 +79,6 @@ CodeExpr(nd, ds, true_label, false_label)
 	struct desig *ds;
 	label true_label, false_label;
 {
-	struct desig ds1, ds2;
 
 	switch(nd->nd_class) {
 	case Def:
@@ -174,6 +178,18 @@ CodeCall(nd)
 	}	
 	tp = left->nd_type;
 
+	if (left->nd_class == Def &&
+	    (left->nd_def->df_kind & (D_TYPE|D_HTYPE|D_HIDDEN))) {
+		/* it was just a cast. Simply ignore it
+		*/
+		Des = InitDesig;
+		CodeExpr(nd->nd_right->nd_left, &Des, NO_LABEL, NO_LABEL);
+		CodeValue(&Des);
+		*nd = *(nd->nd_right->nd_left);
+		nd->nd_type = left->nd_def->df_type;
+		return;
+	}
+
 	assert(tp->tp_fund == T_PROCEDURE);
 
 	for (param = left->nd_type->prc_params; param; param = param->next) {
@@ -223,7 +239,7 @@ CodeStd(nd)
 
 CodeAssign(nd, dst, dss)
 	struct node *nd;
-	struct desig *dst, dss;
+	struct desig *dst, *dss;
 {
 	/*	Generate code for an assignment. Testing of type
 		compatibility and the like is already done.
@@ -262,8 +278,6 @@ CodeOper(expr, true_label, false_label)
 	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 '+':

lang/m2/comp/cstoper.c

@@ -289,9 +289,13 @@ cstset(expp)
 			}
 			if (j == setsize) expp->nd_INT = expp->nd_symb == '=';
 			expp->nd_class = Value;
+			expp->nd_symb = INTEGER;
 			free((char *) expp->nd_left->nd_set);
 			free((char *) expp->nd_right->nd_set);
-			break;
+			FreeNode(expp->nd_left);
+			FreeNode(expp->nd_right);
+			expp->nd_left = expp->nd_right = 0;
+			return;
 		default:
 			assert(0);
 		}
@@ -319,6 +323,7 @@ cstcall(expp, call)
 		FreeNode(expp->nd_right);
 	}
 	expp->nd_class = Value;
+	expp->nd_symb = INTEGER;
 	switch(call) {
 	case S_ABS:
 		if (expr->nd_type->tp_fund == T_REAL) {

lang/m2/comp/desig.c

@@ -30,6 +30,7 @@ struct desig	InitDesig = {DSG_INIT, 0, 0};
 
 CodeValue(ds, size)
 	register struct desig *ds;
+	arith size;
 {
 	/*	Generate code to load the value of the designator described
 		in "ds"
@@ -73,6 +74,49 @@ CodeValue(ds, size)
 	ds->dsg_kind = DSG_LOADED;
 }
 
+CodeStore(ds, size)
+	register struct desig *ds;
+	arith size;
+{
+	/*	Generate code to store the value on the stack in the designator
+		described in "ds"
+	*/
+
+	switch(ds->dsg_kind) {
+	case DSG_FIXED:
+		if (size == word_size) {
+			if (ds->dsg_name) {
+				C_ste_dnam(ds->dsg_name, ds->dsg_offset);
+			}
+			else	C_stl(ds->dsg_offset);
+			break;
+		}
+
+		if (size == dword_size) {
+			if (ds->dsg_name) {
+				C_sde_dnam(ds->dsg_name, ds->dsg_offset);
+			}
+			else	C_sdl(ds->dsg_offset);
+			break;
+		}
+		/* Fall through */
+	case DSG_PLOADED:
+	case DSG_PFIXED:
+		CodeAddress(ds);
+		C_sti(size);
+		break;
+
+	case DSG_INDEXED:
+		C_sar(word_size);
+		break;
+
+	default:
+		crash("(CodeStore)");
+	}
+
+	ds->dsg_kind = DSG_INIT;
+}
+
 CodeAddress(ds)
 	register struct desig *ds;
 {
@@ -144,6 +188,7 @@ CodeFieldDesig(df, ds)
 		/* Found it. Now, act like it was a selection.
 		*/
 		*ds = wds->w_desig;
+		assert(ds->dsg_kind == DSG_PFIXED);
 	}
 
 	switch(ds->dsg_kind) {
@@ -277,6 +322,7 @@ CodeDesig(nd, ds)
 	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;
@@ -297,6 +343,7 @@ CodeDesig(nd, ds)
 			*/
 			/* ??? */
 		}
+		ds->dsg_kind = DSG_INDEXED;
 		break;
 
 	case Uoper:

lang/m2/comp/error.c

@@ -49,7 +49,7 @@ extern char *symbol2str();
 */
 
 #ifdef DEBUG
-/*VARARGS2*/
+/*VARARGS1*/
 debug(fmt, args)
 	char *fmt;
 {

lang/m2/comp/expression.g

@@ -200,8 +200,8 @@ factor(struct node **p;)
 
 			tp = charc_type;
 			i = *(dot.TOK_STR) & 0377;
-			free(dot.TOK_STR);
 			free((char *) dot.tk_data.tk_str);
+			free(dot.TOK_STR);
 			dot.TOK_INT = i;
 		  }
 		  else	tp = standard_type(T_STRING, 1, dot.TOK_SLE);

lang/m2/comp/tmpvar.C

@@ -0,0 +1,114 @@
+/* T E M P O R A R Y   V A R I A B L E S */
+
+#ifndef NORCSID
+static char *RcsId = "$Header$";
+#endif
+
+/*	Code for the allocation and de-allocation of temporary variables,
+	allowing re-use.
+*/
+
+#include	"debug.h"
+
+#include	<em_arith.h>
+#include	<em_label.h>
+#include	<em_reg.h>
+#include	<alloc.h>
+#include	<assert.h>
+
+#include	"def.h"
+#include	"type.h"
+#include	"scope.h"
+
+struct tmpvar {
+	struct tmpvar	*next;
+	arith		t_offset;	/* offset from LocalBase */
+};
+
+/* STATICALLOCDEF "tmpvar" */
+
+static struct tmpvar	*TmpInts,	/* for integer temporaries */
+			*TmpPtrs;	/* for pointer temporaries */
+
+extern arith align();
+
+arith
+NewInt()
+{
+	arith offset;
+	register struct tmpvar *tmp;
+
+	if (!TmpInts) {
+		offset = - align(int_size - CurrentScope->sc_off, int_align);
+		CurrentScope->sc_off = offset;
+		C_ms_reg(offset, int_size, reg_any, 0);
+	}
+	else {
+		tmp = TmpInts;
+		offset = tmp->t_offset;
+		TmpInts = tmp->next;
+		free_tmpvar(tmp);
+	}
+	return offset;
+}
+
+arith
+NewPtr()
+{
+	arith offset;
+	register struct tmpvar *tmp;
+
+	if (!TmpPtrs) {
+		offset = - align(pointer_size - CurrentScope->sc_off, pointer_align);
+		CurrentScope->sc_off = offset;
+		C_ms_reg(offset, pointer_size, reg_pointer, 0);
+	}
+	else {
+		tmp = TmpPtrs;
+		offset = tmp->t_offset;
+		TmpPtrs = tmp->next;
+		free_tmpvar(tmp);
+	}
+	return offset;
+}
+
+FreeInt(off)
+	arith off;
+{
+	register struct tmpvar *tmp;
+
+	tmp = new_tmpvar();
+	tmp->next = TmpInts;
+	tmp->t_offset = off;
+	TmpInts = tmp;
+}
+
+FreePtr(off)
+	arith off;
+{
+	register struct tmpvar *tmp;
+
+	tmp = new_tmpvar();
+	tmp->next = TmpPtrs;
+	tmp->t_offset = off;
+	TmpPtrs = tmp;
+}
+
+TmpClose()
+{
+	register struct tmpvar *tmp, *tmp1;
+
+	tmp = TmpInts;
+	while (tmp) {
+		tmp1 = tmp;
+		tmp = tmp->next;
+		free_tmpvar(tmp1);
+	}
+	tmp = TmpPtrs;
+	while (tmp) {
+		tmp1 = tmp;
+		tmp = tmp->next;
+		free_tmpvar(tmp1);
+	}
+	TmpInts = TmpPtrs = 0;
+}

lang/m2/comp/walk.c

@@ -22,8 +22,10 @@ static char *RcsId = "$Header$";
 #include	"node.h"
 #include	"Lpars.h"
 #include	"desig.h"
+#include	"f_info.h"
 
 extern arith	align();
+extern arith	NewPtr();
 extern int	proclevel;
 static label	instructionlabel;
 static char	return_expr_occurred;
@@ -44,6 +46,22 @@ data_label()
 	return ++datalabel;
 }
 
+static
+DoProfil()
+{
+	static label	filename_label = 0;
+
+	if (options['p']) {
+		if (!filename_label) {
+			filename_label = data_label();
+			C_df_dlb(filename_label);
+			C_rom_scon(FileName, (arith) strlen(FileName));
+		}
+
+		C_fil_dlb(filename_label, (arith) 0);
+	}
+}
+
 WalkModule(module)
 	register struct def *module;
 {
@@ -96,11 +114,13 @@ WalkModule(module)
 	instructionlabel = 2;
 	func_type = 0;
 	C_pro_narg(CurrentScope->sc_name);
+	DoProfil();
 	MkCalls(CurrentScope->sc_def);
 	WalkNode(module->mod_body, (label) 0);
 	C_df_ilb((label) 1);
 	C_ret(0);
-	C_end(align(-CurrentScope->sc_off, word_align));
+	C_end(-CurrentScope->sc_off);
+	TmpClose();
 
 	CurrVis = vis;
 }
@@ -121,6 +141,7 @@ WalkProcedure(procedure)
 	/* Generate code for this procedure
 	*/
 	C_pro_narg(CurrentScope->sc_name);
+	DoProfil();
 	/* generate calls to initialization routines of modules defined within
 	   this procedure
 	*/
@@ -137,7 +158,8 @@ node_error(procedure->prc_body,"function procedure does not return a value");
 		C_ret((int) align(func_type->tp_size, word_align));
 	}
 	else	C_ret(0);
-	C_end(align(-CurrentScope->sc_off, word_align));
+	C_end(-CurrentScope->sc_off);
+	TmpClose();
 	CurrVis = vis;
 	proclevel--;
 }
@@ -203,6 +225,8 @@ WalkStat(nd, lab)
 	register struct node *left = nd->nd_left;
 	register struct node *right = nd->nd_right;
 
+	if (options['p']) C_lin((arith) nd->nd_lineno);
+
 	if (!nd) {
 		/* Empty statement
 		*/
@@ -306,6 +330,7 @@ WalkStat(nd, lab)
 		{
 			struct scopelist link;
 			struct withdesig wds;
+			arith tmp = 0;
 
 			WalkDesignator(left);
 			if (left->nd_type->tp_fund != T_RECORD) {
@@ -316,12 +341,18 @@ WalkStat(nd, lab)
 			wds.w_next = WithDesigs;
 			WithDesigs = &wds;
 			wds.w_scope = left->nd_type->rec_scope;
-			/* 
+			if (Desig.dsg_kind != DSG_PFIXED) {
-			   Decide here wether to use a temporary variable or
+				/* In this case, we use a temporary variable
-			   not, depending on the value of Desig.
+				*/
-			   Suggestion: temporary if Desig != DSG_FIXED
+				CodeAddress(&Desig);
-			   ???
+				Desig.dsg_kind = DSG_FIXED;
-			*/
+				/* Only for the store ... */
+				Desig.dsg_offset = tmp = NewPtr();
+				Desig.dsg_name = 0;
+				CodeStore(&Desig, pointer_size);
+				Desig.dsg_kind = DSG_PFIXED;
+				/* the record is indirectly available */
+			}
 			wds.w_desig = Desig;
 			link.sc_scope = wds.w_scope;
 			link.next = CurrVis;
@@ -329,6 +360,7 @@ WalkStat(nd, lab)
 			WalkNode(right, lab);
 			CurrVis = link.next;
 			WithDesigs = wds.w_next;
+			if (tmp) FreePtr(tmp);
 			break;
 		}