many bug fixes, and added flexibility in alignments

lang/m2/comp/Version.c

@@ -1 +1 @@
-char Version[] = "ACK Modula-2 compiler Version 0.8";
+static char Version[] = "ACK Modula-2 compiler Version 0.9";

lang/m2/comp/chk_expr.c

@@ -540,7 +540,7 @@ ChkProcCall(expp)
 		if (left->nd_symb == STRING) {
 			TryToString(left, TypeOfParam(param));
 		}
-		else if (! TstParCompat(RemoveEqual(TypeOfParam(param)),
+		if (! TstParCompat(RemoveEqual(TypeOfParam(param)),
 				   left->nd_type,
 				   IsVarParam(param),
 				   left)) {
@@ -1017,10 +1017,14 @@ ChkStandard(expp, left)
 	case S_TSIZE:	/* ??? */
 	case S_SIZE:
 		expp->nd_type = intorcard_type;
-		if (! getname(&arg, D_FIELD|D_VARIABLE|D_ISTYPE, 0, edf)) {
+		if (!(left = getname(&arg,D_FIELD|D_VARIABLE|D_ISTYPE,0,edf))) {
 			return 0;
 		}
-		cstcall(expp, S_SIZE);
+		if (! IsConformantArray(left->nd_type)) cstcall(expp, S_SIZE);
+		else node_warning(expp,
+				  W_STRICT,
+				  "%s on conformant array",
+				  expp->nd_left->nd_def->df_idf->id_text);
 		break;
 
 	case S_TRUNC:

lang/m2/comp/code.c

@@ -65,27 +65,6 @@ CodeString(nd)
 	}
 }
 
-STATIC
-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 = WA(nd->nd_type->tp_size);
-
-	assert(nd->nd_type->tp_fund == T_STRING);
-
-	if (sizearg != sz) {
-		/* null padding required */
-		assert(sizearg < sz);
-		C_zer(sz - sizearg);
-	}
-	CodeString(nd);		/* push address of string */
-	C_loi(sizearg);
-}
-
 CodeExpr(nd, ds, true_label, false_label)
 	register struct node *nd;
 	register struct desig *ds;
@@ -180,7 +159,7 @@ CodeExpr(nd, ds, true_label, false_label)
 	if (true_label != 0) {
 		/* Only for boolean expressions
 		*/
-		CodeValue(ds, tp->tp_size);
+		CodeValue(ds, tp->tp_size, tp->tp_align);
 		*ds = InitDesig;
 		C_zne(true_label);
 		C_bra(false_label);
@@ -422,7 +401,16 @@ CodeParameters(param, arg)
 		return;
 	}
 	if (left_type->tp_fund == T_STRING) {
-		CodePadString(left, tp->tp_size);
+		register arith szarg = WA(left_type->tp_size);
+		arith sz = WA(tp->tp_size);
+
+		if (szarg != sz) {
+			/* null padding required */
+			assert(szarg < sz);
+			C_zer(sz - szarg);
+		}
+		CodeString(left);	/* push address of string */
+		C_loi(szarg);
 		return;
 	}
 	CodePExpr(left);
@@ -480,6 +468,15 @@ CodeStd(nd)
 		DoHIGH(left);
 		break;
 
+	case S_SIZE:
+	case S_TSIZE:
+		assert(IsConformantArray(tp));
+		DoHIGH(left);
+		C_inc();
+		C_loc(tp->arr_elem->tp_size);
+		C_mlu(word_size);
+		break;
+
 	case S_ODD:
 		CodePExpr(left);
 		if (tp->tp_size == word_size) {
@@ -951,7 +948,7 @@ CodeEl(nd, tp)
 }
 
 CodePExpr(nd)
-	struct node *nd;
+	register struct node *nd;
 {
 	/*	Generate code to push the value of the expression "nd"
 		on the stack.
@@ -960,7 +957,7 @@ CodePExpr(nd)
 
 	designator = InitDesig;
 	CodeExpr(nd, &designator, NO_LABEL, NO_LABEL);
-	CodeValue(&designator, nd->nd_type->tp_size);
+	CodeValue(&designator, nd->nd_type->tp_size, nd->nd_type->tp_align);
 }
 
 CodeDAddress(nd)
@@ -988,7 +985,7 @@ CodeDStore(nd)
 
 	designator = InitDesig;
 	CodeDesig(nd, &designator);
-	CodeStore(&designator, nd->nd_type->tp_size);
+	CodeStore(&designator, nd->nd_type->tp_size, nd->nd_type->tp_align);
 }
 
 DoHIGH(nd)
@@ -1006,8 +1003,9 @@ DoHIGH(nd)
 	assert(IsConformantArray(df->df_type));
 
 	highoff = df->var_off		/* base address and descriptor */
-		  + pointer_size	/* skip base address */
+		  + 2 * word_size;	/* skip base and first field of
-		  + word_size;		/* skip first field of descriptor */
+					   descriptor
+					*/
 	if (df->df_scope->sc_level < proclevel) {
 		C_lxa((arith) (proclevel - df->df_scope->sc_level));
 		C_lof(highoff);

lang/m2/comp/cstoper.c

@@ -469,7 +469,7 @@ cstcall(expp, call)
 		break;
 
 	case S_SIZE:
-		expp->nd_INT = WA(expr->nd_type->tp_size);
+		expp->nd_INT = expr->nd_type->tp_size;
 		break;
 
 	case S_VAL:

lang/m2/comp/declar.g

@@ -62,11 +62,11 @@ block(struct node **pnd;) :
 ;
 
 declaration:
-	CONST [ ConstantDeclaration ';' ]*
+	CONST [ %persistent ConstantDeclaration ';' ]*
 |
-	TYPE [ TypeDeclaration ';' ]*
+	TYPE [ %persistent TypeDeclaration ';' ]*
 |
-	VAR [ VariableDeclaration ';' ]*
+	VAR [ %persistent VariableDeclaration ';' ]*
 |
 	ProcedureDeclaration ';'
 |
@@ -239,7 +239,7 @@ RecordType(struct type **ptp;)
 		  close_scope(0);
 		}
 	FieldListSequence(scope, &size, &xalign)
-		{ *ptp = standard_type(T_RECORD, xalign, WA(size));
+		{ *ptp = standard_type(T_RECORD, xalign, size);
 		  (*ptp)->rec_scope = scope;
 		}
 	END
@@ -525,5 +525,8 @@ VariableDeclaration
 
 IdentAddr(struct node **pnd;) :
 	IDENT		{ *pnd = MkLeaf(Name, &dot); }
-	ConstExpression(&((*pnd)->nd_left))?
+	[	'['
+		ConstExpression(&((*pnd)->nd_left))
+		']'
+	]?
 ;

lang/m2/comp/def.c

@@ -131,6 +131,9 @@ define(id, scope, kind)
 			}
 			break;
 
+		case D_TYPE:
+			if (kind == D_FORWTYPE) return df;
+			break;
 		case D_FORWTYPE:
 			if (kind == D_FORWTYPE) return df;
 			if (kind == D_TYPE) {

lang/m2/comp/defmodule.c

@@ -103,7 +103,7 @@ GetDefinitionModule(id, incr)
 			df->mod_vis = vis;
 		}
 	}
-	else if (df == Defined) {
+	else if (df == Defined && level == 1) {
 		error("cannot import from currently defined module");
 		df->df_kind = D_ERROR;
 	}

lang/m2/comp/desig.c

@@ -24,19 +24,48 @@
 extern int	proclevel;
 struct desig	InitDesig = {DSG_INIT, 0, 0};
 
-CodeValue(ds, size)
+STATIC int
+properly(ds, size, al)
+	register struct desig *ds;
+	arith size;
+{
+	/*	Check if it is allowed to load or store the value indicated
+		by "ds" with LOI/STI.
+		- if the size is not either a multiple or a dividor of the
+		  wordsize, then not.
+		- if the alignment is at least "word" then OK.
+		- if size is dividor of word_size and alignment >= size then OK.
+		- otherwise check alignment of address. This can only be done
+		  with DSG_FIXED.
+	*/
+
+	arith szmodword = size % word_size;	/* 0 if multiple of wordsize */
+	arith wordmodsz = word_size % size;	/* 0 if dividor of wordsize */
+
+	if (szmodword && wordmodsz) return 0;
+	if (al >= word_size) return 1;
+	if (szmodword && al >= szmodword) return 1;
+
+	return ds->dsg_kind == DSG_FIXED &&
+	       ((! szmodword && ds->dsg_offset % word_size == 0) ||
+		(! wordmodsz && ds->dsg_offset % size == 0));
+}
+
+CodeValue(ds, size, al)
 	register struct desig *ds;
 	arith size;
 {
 	/*	Generate code to load the value of the designator described
 		in "ds"
 	*/
+	arith tmp = 0;
 
 	switch(ds->dsg_kind) {
 	case DSG_LOADED:
 		break;
 
 	case DSG_FIXED:
+		if (ds->dsg_offset % word_size == 0) {	
 			if (size == word_size) {
 				if (ds->dsg_name) {
 					C_loe_dnam(ds->dsg_name,ds->dsg_offset);
@@ -52,12 +81,29 @@ CodeValue(ds, size)
 				else	C_ldl(ds->dsg_offset);
 				break;
 			}
+		}
 		/* Fall through */
 	case DSG_PLOADED:
 	case DSG_PFIXED:
+		if (properly(ds, size, al)) {
 			CodeAddress(ds);
 			C_loi(size);
 			break;
+		}
+		if (ds->dsg_kind == DSG_PLOADED) {
+			tmp = NewPtr();
+			C_stl(tmp);
+		}
+		C_asp(-WA(size));
+		if (!tmp) CodeAddress(ds);
+		else {
+			C_lol(tmp);
+			FreePtr(tmp);
+		}
+		C_loc(size);
+		C_cal("_load");
+		C_asp(2 * word_size);
+		break;
 
 	case DSG_INDEXED:
 		C_lar(word_size);
@@ -70,16 +116,19 @@ CodeValue(ds, size)
 	ds->dsg_kind = DSG_LOADED;
 }
 
-CodeStore(ds, size)
+CodeStore(ds, size, al)
 	register struct desig *ds;
 	arith size;
 {
 	/*	Generate code to store the value on the stack in the designator
 		described in "ds"
 	*/
+	struct desig save;
 
+	save = *ds;
 	switch(ds->dsg_kind) {
 	case DSG_FIXED:
+		if (ds->dsg_offset % word_size == 0) {
 			if (size == word_size) {
 				if (ds->dsg_name) {
 					C_ste_dnam(ds->dsg_name,ds->dsg_offset);
@@ -95,12 +144,19 @@ CodeStore(ds, size)
 				else	C_sdl(ds->dsg_offset);
 				break;
 			}
+		}
 		/* Fall through */
 	case DSG_PLOADED:
 	case DSG_PFIXED:
-		CodeAddress(ds);
+		CodeAddress(&save);
+		if (properly(ds, size, al)) {
 			C_sti(size);
 			break;
+		}
+		C_loc(size);
+		C_cal("_store");
+		C_asp(2 * word_size + WA(size));
+		break;
 
 	case DSG_INDEXED:
 		C_sar(word_size);
@@ -113,6 +169,146 @@ CodeStore(ds, size)
 	ds->dsg_kind = DSG_INIT;
 }
 
+CodeCopy(lhs, rhs, sz, psize)
+	register struct desig *lhs, *rhs;
+	arith sz, *psize;
+{
+	struct desig l, r;
+
+	l = *lhs; r = *rhs;
+	*psize -= sz;
+	lhs->dsg_offset += sz;
+	rhs->dsg_offset += sz;
+	CodeAddress(&r);
+	C_loi(sz);
+	CodeAddress(&l);
+	C_sti(sz);
+}
+
+CodeMove(rhs, left, rtp)
+	register struct desig *rhs;
+	register struct node *left;
+	struct type *rtp;
+{
+	struct desig dsl;
+	register struct desig *lhs = &dsl;
+	register struct type *tp = left->nd_type;
+	int	loadedflag = 0;
+
+	dsl = InitDesig;
+
+	/*	Generate code for an assignment. Testing of type
+		compatibility and the like is already done.
+		Go through some (considerable) trouble to see if a BLM can be
+		generated.
+	*/
+
+	switch(rhs->dsg_kind) {
+	case DSG_LOADED:
+		CodeDesig(left, lhs);
+		CodeAddress(lhs);
+		if (rtp->tp_fund == T_STRING) {
+			C_loc(rtp->tp_size);
+			C_loc(tp->tp_size);
+			C_cal("_StringAssign");
+			C_asp(word_size << 2);
+			return;
+		}
+		CodeStore(lhs, tp->tp_size, tp->tp_align);
+		return;
+	case DSG_PLOADED:
+	case DSG_PFIXED:
+		CodeAddress(rhs);
+		if (tp->tp_size % word_size == 0 && tp->tp_align >= word_size) {
+			CodeDesig(left, lhs);
+			CodeAddress(lhs);
+			C_blm(tp->tp_size);
+			return;
+		}
+		CodeValue(rhs, tp->tp_size, tp->tp_align);
+		CodeDStore(left);
+		return;
+	case DSG_FIXED:
+		CodeDesig(left, lhs);
+		if (lhs->dsg_kind == DSG_FIXED &&
+		    lhs->dsg_offset % word_size ==
+		    rhs->dsg_offset % word_size) {
+			register arith sz;
+			arith size = tp->tp_size;
+
+			while (size && (sz = (lhs->dsg_offset % word_size))) {
+				/*	First copy up to word-aligned
+					boundaries
+				*/
+				if (sz < 0) sz = -sz;	/* bloody '%' */
+				while (word_size % sz) sz--;
+				CodeCopy(lhs, rhs, sz, &size);
+			}
+			if (size > 3*dword_size) {
+				/*	Do a block move
+				*/
+				struct desig l, r;
+
+				sz = (size / word_size) * word_size;
+				l = *lhs; r = *rhs;
+				CodeAddress(&r);
+				CodeAddress(&l);
+				C_blm(sz);
+				rhs->dsg_offset += sz;
+				lhs->dsg_offset += sz;
+				size -= sz;
+			}
+			else for (sz = dword_size; sz; sz -= word_size) {
+				while (size >= sz) {
+					/*	Then copy dwords, words.
+						Depend on peephole optimizer
+					*/
+					CodeCopy(lhs, rhs, sz, &size);
+				}
+			}
+			sz = word_size;
+			while (size && --sz) {
+				/*	And then copy remaining parts
+				*/
+				while (word_size % sz) sz--;
+				while (size >= sz) {
+					CodeCopy(lhs, rhs, sz, &size);
+				}
+			}
+			return;
+		}
+		if (lhs->dsg_kind == DSG_PLOADED ||
+		    lhs->dsg_kind == DSG_INDEXED) {
+			CodeAddress(lhs);
+			loadedflag = 1;
+		}
+		if (tp->tp_size % word_size == 0 && tp->tp_align >= word_size) {
+			CodeAddress(rhs);
+			if (loadedflag) C_exg(pointer_size);
+			else CodeAddress(lhs);
+			C_blm(tp->tp_size);
+			return;
+		}
+		{
+			arith tmp;
+
+			if (loadedflag) {	
+				tmp = NewPtr();
+				lhs->dsg_offset = tmp;
+				lhs->dsg_name = 0;
+				lhs->dsg_kind = DSG_PFIXED;
+				C_stl(tmp);		/* address of lhs */
+			}
+			CodeValue(rhs, tp->tp_size, tp->tp_align);
+			CodeStore(lhs, tp->tp_size, tp->tp_align);
+			if (loadedflag) FreePtr(tmp);
+			return;
+		}
+	default:
+		crash("CodeMove");
+	}
+}
+
 CodeAddress(ds)
 	register struct desig *ds;
 {
@@ -136,8 +332,11 @@ CodeAddress(ds)
 		break;
 		
 	case DSG_PFIXED:
-		ds->dsg_kind = DSG_FIXED;
+		if (ds->dsg_name) {
-		CodeValue(ds, pointer_size);
+			C_loe_dnam(ds->dsg_name,ds->dsg_offset);
+			break;
+		}
+		C_lol(ds->dsg_offset);
 		break;
 
 	case DSG_INDEXED:
@@ -353,7 +552,7 @@ CodeDesig(nd, ds)
 		case DSG_INDEXED:
 		case DSG_PLOADED:
 		case DSG_PFIXED:
-			CodeValue(ds, pointer_size);
+			CodeValue(ds, pointer_size, pointer_align);
 			ds->dsg_kind = DSG_PLOADED;
 			ds->dsg_offset = 0;
 			break;

lang/m2/comp/enter.c

@@ -112,9 +112,11 @@ EnterVarList(Idlist, type, local)
 		if (idlist->nd_left) {
 			/* An address was supplied
 			*/
+			register struct type *tp = idlist->nd_left->nd_type;
+
 			df->var_addrgiven = 1;
 			df->df_flags |= D_NOREG;
-			if (idlist->nd_left->nd_type != card_type) {
+			if (tp != error_type && !(tp->tp_fund & T_CARDINAL)){
 				node_error(idlist->nd_left,
 					   "illegal type for address");
 			}
@@ -224,6 +226,11 @@ DoImport(df, scope)
 		/* Also import all definitions that are exported from this
 		   module
 		*/
+		if (df->mod_vis == CurrVis) {
+			error("cannot import current module \"%s\"",
+				df->df_idf->id_text);
+			return;
+		}
 		for (df = df->mod_vis->sc_scope->sc_def;
 		     df;
 		     df = df->df_nextinscope) {
@@ -391,11 +398,16 @@ EnterFromImportList(Idlist, FromDef, FromId)
 		break;
 	case D_MODULE:
 		vis = FromDef->mod_vis;
+		if (vis == CurrVis) {
+node_error(FromId, "cannot import from current module \"%s\"",
+		        	FromDef->df_idf->id_text);
+			return;
+		}
 		break;
 	default:
 node_error(FromId, "identifier \"%s\" does not represent a module",
 		       FromDef->df_idf->id_text);
-		break;
+		return;
 	}
 
 	for (; idlist; idlist = idlist->next) {

lang/m2/comp/program.g

@@ -157,10 +157,11 @@ definition
 	register struct def *df;
 	struct def *dummy;
 } :
-	CONST [ ConstantDeclaration ';' ]*
+	CONST [ %persistent ConstantDeclaration ';' ]*
 |
 	TYPE
-	[ IDENT 	{ df = define(dot.TOK_IDF, CurrentScope, D_TYPE); }
+	[ %persistent
+	  IDENT 	{ df = define(dot.TOK_IDF, CurrentScope, D_TYPE); }
 	  [ '=' type(&(df->df_type))
 	  | /* empty */
 	    /*
@@ -175,7 +176,7 @@ definition
 	  ';'
 	]*
 |
-	VAR [ VariableDeclaration ';' ]*
+	VAR [ %persistent VariableDeclaration ';' ]*
 |
 	ProcedureHeading(&dummy, D_PROCHEAD)
 	';'

lang/m2/comp/scope.C

@@ -71,6 +71,10 @@ Forward(tk, ptp)
 	*/
 	register struct def *df = define(tk->nd_IDF, CurrentScope, D_FORWTYPE);
 
+	if (df->df_kind == D_TYPE) {
+		ptp->next = df->df_type;
+		return;
+	}
 	df->df_forw_type = ptp;
 	df->df_forw_node = tk;
 }
@@ -106,8 +110,17 @@ chk_forw(pdf)
 
 	while (df = *pdf) {
 		if (df->df_kind == D_FORWTYPE) {
-node_error(df->df_forw_node, "type \"%s\" not declared", df->df_idf->id_text);
+			register struct def *df1 = df;
-			FreeNode(df->df_forw_node);
+
+			*pdf = df->df_nextinscope;
+			RemoveFromIdList(df);
+			df = lookfor(df->df_forw_node, CurrVis, 1);
+			if (! df->df_kind & (D_ERROR|D_FTYPE|D_TYPE)) {
+node_error(df1->df_forw_node, "\"%s\" is not a type", df1->df_idf->id_text);
+			}
+			df1->df_forw_type->next = df->df_type;
+			FreeNode(df1->df_forw_node);
+			free_def(df1);
 		}
 		else if (df->df_kind == D_FTYPE) {
 			df->df_kind = D_TYPE;

lang/m2/comp/statement.g

@@ -31,7 +31,12 @@ statement(register struct node **pnd;)
 				}
 		ActualParameters(&(nd->nd_right))?
 	|
-		BECOMES		{ nd = MkNode(Stat, *pnd, NULLNODE, &dot); }
+		[ BECOMES	
+		| '='		{ error("':=' expected instead of '='");
+				  DOT = BECOMES;
+				}
+		]
+				{ nd = MkNode(Stat, *pnd, NULLNODE, &dot); }
 		expression(&(nd->nd_right))
 	]
 				{ *pnd = nd; }

lang/m2/comp/walk.c

@@ -221,9 +221,11 @@ WalkProcedure(procedure)
 						/* upper - lower */
 				C_inc();	/* gives number of elements */
 				C_loc(tp->arr_elem->tp_size);
-				C_cal("_wa");
+				C_mli(word_size);
-				C_asp(dword_size);
+				C_loc(word_size - 1);
-				C_lfr(word_size);
+				C_adi(word_size);
+				C_loc(word_size);
+				C_dvi(word_size);
 						/* size in words */
 				C_loc(word_size);
 				C_mli(word_size);
@@ -241,25 +243,16 @@ WalkProcedure(procedure)
 						*/
 				C_ass(word_size);
 						/* adjusted stack pointer */
-				C_lor((arith) 1);
+				C_lol(param->par_def->var_off);
-						/* destination address (sp),
-						   also assumes stack grows
-						   downwards ???
-						*/
-				C_lal(param->par_def->var_off);
-				C_loi(pointer_size);
 						/* push source address */
-				C_exg(pointer_size);
-						/* exchange them */
 				C_lol(tmpvar);	/* push size */
-				C_bls(word_size);
+				C_cal("_load");	/* copy */
-						/* copy */
+				C_asp(2 * word_size);
 				C_lor((arith) 1);	
 						/* push new address of array
 						   ... downwards ... ???
 						*/
-				C_lal(param->par_def->var_off);
+				C_stl(param->par_def->var_off);
-				C_sti(pointer_size);
 				FreeInt(tmpvar);
 			}
 		}
@@ -529,7 +522,7 @@ WalkStat(nd, exit_label)
 			*/
 			ds.dsg_offset = NewPtr();
 			ds.dsg_name = 0;
-			CodeStore(&ds, pointer_size);
+			CodeStore(&ds, pointer_size, pointer_align);
 			ds.dsg_kind = DSG_PFIXED;
 			/* the record is indirectly available */
 			wds.w_desig = ds;
@@ -709,7 +702,7 @@ DoAssign(nd, left, right)
 	   it sais that the left hand side is evaluated first.
 	   DAMN THE BOOK!
 	*/
-	struct desig dsl, dsr;
+	struct desig dsr;
 	register struct type *rtp, *ltp;
 
 	if (! (ChkExpression(right) & ChkVariable(left))) return;
@@ -724,34 +717,18 @@ DoAssign(nd, left, right)
 		return;
 	}
 
+#define StackNeededFor(ds)	((ds)->dsg_kind == DSG_PLOADED \
+				  || (ds)->dsg_kind == DSG_INDEXED)
 	CodeExpr(right, &dsr, NO_LABEL, NO_LABEL);
-	if (complex(rtp)) CodeAddress(&dsr);
+	if (complex(rtp)) {
+		if (StackNeededFor(&dsr)) CodeAddress(&dsr);
+	}
 	else {
-		CodeValue(&dsr, rtp->tp_size);
+		CodeValue(&dsr, rtp->tp_size, rtp->tp_align);
-		RangeCheck(ltp, rtp);
 		CodeCoercion(rtp, ltp);
+		RangeCheck(ltp, rtp);
 	}
-	dsl = InitDesig;
+	CodeMove(&dsr, left, rtp);
-	CodeDesig(left, &dsl);
-
-	/*	Generate code for an assignment. Testing of type
-		compatibility and the like is already done.
-	*/
-
-	if (dsr.dsg_kind == DSG_LOADED) {
-		if (rtp->tp_fund == T_STRING) {
-			CodeAddress(&dsl);
-			C_loc(rtp->tp_size);
-			C_loc(ltp->tp_size);
-			C_cal("_StringAssign");
-			C_asp((int_size << 1) + (pointer_size << 1));
-			return;
-		}
-		CodeStore(&dsl, ltp->tp_size);
-		return;
-	}
-	CodeAddress(&dsl);
-	C_blm(ltp->tp_size);
 }
 
 RegisterMessages(df)