made to fit on PDP-11 again

lang/m2/comp/Version.c

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

lang/m2/comp/chk_expr.h

@@ -20,6 +20,7 @@ extern int	(*DesigChkTable[])();	/* table of designator checking
 #define ChkDesignator(expp)	((*DesigChkTable[(expp)->nd_class])(expp,0))
 #define ChkDesig(expp, flags)	((*DesigChkTable[(expp)->nd_class])(expp,flags))
 
-#define inc_refcount(s)		(*((s) - 1) += 1)
+/* handle reference counts for sets */
-#define dec_refcount(s)		(*((s) - 1) -= 1)
+#define inc_refcount(s)		(*((int *)(s) - 1) += 1)
-#define refcount(s)		(*((s) - 1))
+#define dec_refcount(s)		(*((int *)(s) - 1) -= 1)
+#define refcount(s)		(*((int *)(s) - 1))

lang/m2/comp/code.c

@@ -429,8 +429,7 @@ CodeParameters(param, arg)
 
 			CodePExpr(left);
 			tmp = TmpSpace(left->nd_type->tp_size, left->nd_type->tp_align);
-			C_lal(tmp);
+			STL(tmp, WA(left->nd_type->tp_size));
-			C_sti(WA(left->nd_type->tp_size));
 			C_lal(tmp);
 			}
 			break;
@@ -892,8 +891,7 @@ CodeOper(expr, true_label, false_label)
 		}
 		else	CodeExpr(leftop, Des, l_maybe, false_label);
 		def_ilb(l_maybe);
-		free_desig(Des);
+		clear((char *) Des, sizeof(t_desig));
-		Des = new_desig();
 		CodeExpr(rightop, Des, true_label, false_label);
 		if (genlabels) {
 			def_ilb(true_label);

lang/m2/comp/desig.c

@@ -32,6 +32,7 @@
 #include	"node.h"
 #include	"warning.h"
 #include	"walk.h"
+#include	"squeeze.h"
 
 extern int	proclevel;
 extern arith	NewPtr();
@@ -52,6 +53,36 @@ WordOrDouble(ds, size)
 	return 0;
 }
 
+LOL(offset, size)
+	arith offset, size;
+{
+	if (size == word_size) {
+		C_lol(offset);
+	}
+	else if (size == dword_size) {
+		C_ldl(offset);
+	}
+	else {
+		C_lal(offset);
+		C_loi(size);
+	}
+}
+
+STL(offset, size)
+	arith offset, size;
+{
+	if (size == word_size) {
+		C_stl(offset);
+	}
+	else if (size == dword_size) {
+		C_sdl(offset);
+	}
+	else {
+		C_lal(offset);
+		C_sti(size);
+	}
+}
+
 int
 DoLoad(ds, size)
 	register t_desig *ds;
@@ -106,30 +137,22 @@ DoStore(ds, size)
 	return 1;
 }
 
-int
-word_multiple(tp)
-	register t_type *tp;
-{
 	/*	Return 1 if the type indicated by tp has a size that is a
 		multiple of the word_size and is also word_aligned
 	*/
-	return  (int)(tp->tp_size) % (int)word_size == 0 &&
+#define word_multiple(tp) \
-		tp->tp_align >= word_align;
+	( (int)(tp->tp_size) % (int)word_size == 0 && \
-}
+	  tp->tp_align >= word_align)
 
-int
-word_dividor(tp)
-	register t_type *tp;
-{
 	/*	Return 1 if the type indicated by tp has a size that is a proper
 		dividor of the word_size, and has alignment >= size or
 		alignment >= word_align
 	*/
-	return	tp->tp_size < word_size && 
+#define word_dividor(tp) \
-		(int)word_size % (int)(tp->tp_size) == 0 &&
+	(	tp->tp_size < word_size &&  \
-		(tp->tp_align >= word_align ||
+		(int)word_size % (int)(tp->tp_size) == 0 && \
-		 tp->tp_align >= (int)(tp->tp_size));
+		(tp->tp_align >= word_align || \
-}
+		 tp->tp_align >= (int)(tp->tp_size)))
 
 #define USE_LOI_STI	0
 #define USE_LOS_STS	1
@@ -139,14 +162,15 @@ word_dividor(tp)
 				*/
 
 STATIC int
-type_to_stack(tp)
+suitable_move(tp)
 	register t_type *tp;
 {
 	/*	Find out how to load or store the value indicated by "ds".
 		There are three ways:
-		- with LOI/STI
+		- suitable for BLM/LOI/STI
-		- with LOS/STS
+		- suitable for LOI/STI
-		- with calls to _load/_store
+		- suitable for LOS/STS/BLS
+		- suitable for calls to load/store/blockmove
 	*/
 
 	if (! word_multiple(tp)) {
@@ -175,12 +199,14 @@ CodeValue(ds, tp)
 		/* Fall through */
 	case DSG_PLOADED:
 	case DSG_PFIXED:
-		switch (type_to_stack(tp)) {
+		switch (suitable_move(tp)) {
 		case USE_BLM:
 		case USE_LOI_STI:
+#ifndef SQUEEZE
 			CodeAddress(ds);
 			C_loi(tp->tp_size);
 			break;
+#endif
 		case USE_LOS_STS:
 			CodeAddress(ds);
 			CodeConst(tp->tp_size, (int)pointer_size);
@@ -188,16 +214,14 @@ CodeValue(ds, tp)
 			break;
 		case USE_LOAD_STORE:
 			sz = WA(tp->tp_size);
-			if (ds->dsg_kind == DSG_PLOADED) {
+			if (ds->dsg_kind != DSG_PFIXED) {
 				arith tmp = NewPtr();
 
 				CodeAddress(ds);
-				C_lal(tmp);
+				STL(tmp, pointer_size);
-				C_sti(pointer_size);
 				CodeConst(-sz, (int) pointer_size);
 				C_ass(pointer_size);
-				C_lal(tmp);
+				LOL(tmp, pointer_size);
-				C_loi(pointer_size);
 				FreePtr(tmp);
 			}
 			else  {
@@ -224,7 +248,7 @@ CodeValue(ds, tp)
 }
 
 ChkForFOR(nd)
-	t_node *nd;
+	register t_node *nd;
 {
 	/*	Check for an assignment to a FOR-loop control variable
 	*/
@@ -248,9 +272,6 @@ CodeStore(ds, tp)
 	/*	Generate code to store the value on the stack in the designator
 		described in "ds"
 	*/
-	t_desig save;
-
-	save = *ds;
 
 	switch(ds->dsg_kind) {
 	case DSG_FIXED:
@@ -258,12 +279,14 @@ CodeStore(ds, tp)
 		/* Fall through */
 	case DSG_PLOADED:
 	case DSG_PFIXED:
-		CodeAddress(&save);
+		CodeAddress(ds);
-		switch (type_to_stack(tp)) {
+		switch (suitable_move(tp)) {
 		case USE_BLM:
 		case USE_LOI_STI:
+#ifndef SQUEEZE
 			C_sti(tp->tp_size);
 			break;
+#endif
 		case USE_LOS_STS:
 			CodeConst(tp->tp_size, (int) pointer_size);
 			C_sts(pointer_size);
@@ -326,6 +349,7 @@ CodeMove(rhs, left, rtp)
 	*/
 	register t_desig *lhs = new_desig();
 	register t_type *tp = left->nd_type;
+	int loadedflag = 0;
 
 	ChkForFOR(left);
 	switch(rhs->dsg_kind) {
@@ -345,61 +369,60 @@ CodeMove(rhs, left, rtp)
 		CodeStore(lhs, tp);
 		break;
 	case DSG_FIXED:
+		CodeDesig(left, lhs);
 		if (lhs->dsg_kind == DSG_FIXED &&
 		    fit(tp->tp_size, (int) word_size) &&
-		    (int) (lhs->dsg_offset) % (int) word_size ==
+		    (int) (lhs->dsg_offset) % word_align ==
-		    (int) (rhs->dsg_offset) % (int) word_size) {
+		    (int) (rhs->dsg_offset) % word_align) {
-			register int sz;
+			register int sz = 1;
 			arith size = tp->tp_size;
 
-			CodeDesig(left, lhs);
+			while (size && sz < word_align) {
-			while (size &&
-			       (sz = ((int)(lhs->dsg_offset)%(int)word_size))) {
 				/*	First copy up to word-aligned
 					boundaries
 				*/
-				if (sz < 0) sz = -sz;	/* bloody '%' */
+				if (!((int)(lhs->dsg_offset)%(sz+sz))) {
-				while ((int) word_size % sz) sz--;
+					sz += sz;
-				CodeCopy(lhs, rhs, (arith) sz, &size);
 				}
-			if (size > 3*dword_size) {
+				else	CodeCopy(lhs, rhs, (arith) sz, &size);
-				/*	Do a block move
+			}
+			/*	Now copy the bulk
 			*/
-				arith sz;
+			sz = (int) size % (int) word_size;
-
+			size -= sz;
-				sz = size - size % word_size;
+			CodeCopy(lhs, rhs, size, &size);
-				CodeCopy(lhs, rhs, sz, &size);
+			size = sz;
-			}
-			else for (sz = (int) dword_size;
-				  sz; sz -= (int) word_size) {
-				while (size >= sz) {
-					/*	Then copy dwords, words.
-						Depend on peephole optimizer
-					*/
-					CodeCopy(lhs, rhs, (arith) sz, &size);
-				}
-			}
 			sz = word_size;
-			while (size && --sz) {
+			while (size) {
 				/*	And then copy remaining parts
 				*/
-				while ((int) word_size % sz) sz--;
+				sz >>= 1;
-				while (size >= sz) {
+				if (size >= sz) {
 					CodeCopy(lhs, rhs, (arith) sz, &size);
 				}
 			}
 			break;
 		}
+		CodeAddress(lhs);
+		loadedflag = 1;
 		/* Fall through */
 	case DSG_PLOADED:
 	case DSG_PFIXED:
+		assert(! loadedflag || rhs->dsg_kind == DSG_FIXED);
 		CodeAddress(rhs);
+		if (loadedflag) {
+			C_exg(pointer_size);
+		}
+		else {
 			CodeDesig(left, lhs);
 			CodeAddress(lhs);
-		switch (type_to_stack(tp)) {
+		}
+		switch (suitable_move(tp)) {
 		case USE_BLM:
+#ifndef SQUEEZE
 			C_blm(tp->tp_size);
 			break;
+#endif
 		case USE_LOS_STS:
 			CodeConst(tp->tp_size, (int) pointer_size);
 			C_bls(pointer_size);

lang/m2/comp/main.c

@@ -42,9 +42,8 @@ int		nDEF, mDEF;
 int		pass_1;
 t_def	 	*Defined;
 extern int 	err_occurred;
-extern int 	Roption;
 extern int	fp_used;		/* set if floating point used */
-static t_node	_emptystat = { NULLNODE, NULLNODE, Stat, NULLTYPE, { ';' }};
+static t_node	_emptystat = { NULLNODE, NULLNODE, Stat, 0, NULLTYPE, { ';' }};
 t_node		*EmptyStatement = &_emptystat;
 
 main(argc, argv)
@@ -92,7 +91,6 @@ Compile(src, dst)
 	InitScope();
 	InitTypes();
 	AddStandards();
-	Roption = options['R'];
 #ifdef DEBUG
 	if (options['l']) {
 		LexScan();
@@ -159,7 +157,7 @@ LexScan()
 static struct stdproc {
 	char *st_nam;
 	int  st_con;
-} stdproc[] = {
+} stdprocs[] = {
 	{ "ABS",	S_ABS },
 	{ "CAP",	S_CAP },
 	{ "CHR",	S_CHR },
@@ -188,20 +186,30 @@ static struct stdproc {
 	{ 0,		0 }
 };
 
+static struct stdproc sysprocs[] = {
+	{ "TSIZE",	S_TSIZE },
+	{ "ADR",	S_ADR },
+	{ 0,		0 }
+};
+
 extern t_def *Enter();
 
-AddStandards()
+AddProcs(p)
-{
-	register t_def *df;
 	register struct stdproc *p;
-	static t_token nilconst = { INTEGER, 0};
+{
-
+	for (; p->st_nam != 0; p++) {
-	for (p = stdproc; p->st_nam != 0; p++) {
 		if (! Enter(p->st_nam, D_PROCEDURE, std_type, p->st_con)) {
 			assert(0);
 		}
 	}
+}
 
+AddStandards()
+{
+	register t_def *df;
+	static t_token nilconst = { INTEGER, 0};
+
+	AddProcs(stdprocs);
 	EnterType("CHAR", char_type);
 	EnterType("INTEGER", int_type);
 	EnterType("LONGINT", longint_type);
@@ -232,12 +240,7 @@ do_SYSTEM()
 	EnterType("WORD", word_type);
 	EnterType("BYTE", byte_type);
 	EnterType("ADDRESS",address_type);
-	if (! Enter("ADR", D_PROCEDURE, std_type, S_ADR)) {
+	AddProcs(sysprocs);
-		assert(0);
-	}
-	if (! Enter("TSIZE", D_PROCEDURE, std_type, S_TSIZE)) {
-		assert(0);
-	}
 	if (!InsertText(systemtext, sizeof(systemtext) - 1)) {
 		fatal("could not insert text");
 	}

lang/m2/comp/node.H

@@ -12,7 +12,7 @@
 struct node {
 	struct node *nd_left;
 	struct node *nd_right;
-	int nd_class;		/* kind of node */
+	char nd_class;		/* kind of node */
 #define Value	0		/* constant */
 #define Arrsel  1		/* array selection */
 #define Oper	2		/* binary operator */
@@ -25,8 +25,10 @@ struct node {
 #define Def	9		/* an identified name */
 #define Stat	10		/* a statement */
 #define Link	11
-#define Option	12
 				/* do NOT change the order or the numbers!!! */
+	char nd_flags;		/* options */
+#define ROPTION	1
+#define AOPTION 2
 	struct type *nd_type;	/* type of this node */
 	struct token nd_token;
 #define nd_set		nd_token.tk_data.tk_set

lang/m2/comp/node.c

@@ -20,6 +20,7 @@
 #include	"def.h"
 #include	"type.h"
 #include	"node.h"
+#include	"main.h"
 
 t_node *
 MkNode(class, left, right, token)
@@ -34,6 +35,8 @@ MkNode(class, left, right, token)
 	nd->nd_right = right;
 	nd->nd_token = *token;
 	nd->nd_class = class;
+	if (options['R']) nd->nd_flags |= ROPTION;
+	if (options['A']) nd->nd_flags |= AOPTION;
 	return nd;
 }
 
@@ -48,17 +51,13 @@ t_node *
 MkLeaf(class, token)
 	t_token *token;
 {
-	register t_node *nd = new_node();
+	return MkNode(class, NULLNODE, NULLNODE, token);
-
-	nd->nd_token = *token;
-	nd->nd_class = class;
-	return nd;
 }
 
 t_node *
 dot2leaf(class)
 {
-	return MkLeaf(class, &dot);
+	return MkNode(class, NULLNODE, NULLNODE, &dot);
 }
 
 FreeLR(nd)

lang/m2/comp/scope.C

@@ -46,7 +46,7 @@ open_scope(scopetype)
 	sc->sc_level = proclevel;
 	ls->sc_scope = sc;
 	ls->sc_encl = CurrVis;
-	if (scopetype == OPENSCOPE) {
+	if (! sc->sc_scopeclosed) {
 		ls->sc_next = ls->sc_encl;
 	}
 	CurrVis = ls;
@@ -68,12 +68,8 @@ InitScope()
 	register t_scope *sc = new_scope();
 	register t_scopelist *ls = new_scopelist();
 
-	sc->sc_scopeclosed = 0;
-	sc->sc_def = 0;
 	sc->sc_level = proclevel;
 	PervasiveScope = sc;
-	ls->sc_next = 0;
-	ls->sc_encl = 0;
 	ls->sc_scope = PervasiveScope;
 	PervVis = ls;
 	CurrVis = ls;

lang/m2/comp/statement.g

@@ -22,8 +22,6 @@
 #include	"node.h"
 
 static int	loopcount = 0;	/* Count nested loops */
-int		Roption;
-extern char	options[];
 extern t_node *EmptyStatement;
 }
 
@@ -32,24 +30,6 @@ statement(register t_node **pnd;)
 	register t_node *nd;
 	extern int return_occurred;
 } :
-	/* We need some method for making sure lookahead is done, so ...
-	*/
-	[	PROGRAM
-		/* LLlex never returns this */
-	| %default
-				{ if (options['R'] != Roption) {
-					Roption = options['R'];
-					nd = dot2leaf(Option);
-					nd->nd_symb = 'R';
-					nd->nd_INT = Roption;
-					*pnd = nd =
-					    dot2node(Link, nd, NULLNODE);
-					nd->nd_symb = ';';
-					pnd = &(nd->nd_right);
-				  }
-				}
-	]
-[
 	/*
 	 * This part is not in the reference grammar. The reference grammar
 	 * states : assignment | ProcedureCall | ...
@@ -108,7 +88,6 @@ statement(register t_node **pnd;)
 			{ return_occurred = 1; }
 |
 	/* empty */	{ *pnd = EmptyStatement; }
-]
 ;
 
 /*

lang/m2/comp/type.H

@@ -220,5 +220,4 @@ extern long full_mask[];
 extern long max_int[];
 extern long min_int[];
 
-#define fit(n, i)	(((n) + ((arith)0x80<<(((i)-1)*8)) & ~full_mask[(i)]) == 0)
 #define ufit(n, i)	(((n) & ~full_mask[(i)]) == 0)

lang/m2/comp/type.c

@@ -210,6 +210,13 @@ InitTypes()
 	*error_type = *char_type;
 }
 
+int
+fit(sz, nbytes)
+	arith sz;
+{
+	return ((sz) + ((arith)0x80<<(((nbytes)-1)*8)) & ~full_mask[(nbytes)]) == 0;
+}
+
 STATIC
 u_small(tp, n)
 	register t_type *tp;

lang/m2/comp/walk.c

@@ -268,8 +268,7 @@ WalkProcedure(procedure)
 				if (tp->tp_size < word_size &&
 				    (int) word_size % (int) tp->tp_size == 0) {
 					C_lol(param->par_def->var_off);
-					C_lal(param->par_def->var_off);
+					STL(param->par_def->var_off, tp->tp_size);
-					C_sti(tp->tp_size);
 				}
 			}
 			else {
@@ -297,8 +296,7 @@ WalkProcedure(procedure)
 					}
 					StackAdjustment = NewPtr();
 					C_lor((arith) 1);
-					C_lal(StackAdjustment);
+					STL(StackAdjustment, pointer_size);
-					C_sti(pointer_size);
 				}
 				/* First compute new stackpointer */
 				C_lal(param->par_def->var_off);
@@ -307,8 +305,7 @@ WalkProcedure(procedure)
 				C_lfr(pointer_size);
 				C_str((arith) 1);
 						/* adjusted stack pointer */
-				C_lal(param->par_def->var_off);
+				LOL(param->par_def->var_off, pointer_size);
-				C_loi(pointer_size);
 						/* push source address */
 				C_cal("_copy_array");
 						/* copy */
@@ -336,8 +333,7 @@ WalkProcedure(procedure)
 		if (StackAdjustment) {
 			/* Remove copies of conformant arrays
 			*/
-			C_lal(StackAdjustment);
+			LOL(StackAdjustment, pointer_size);
-			C_loi(pointer_size);
 			C_str((arith) 1);
 		}
 		c_lae_dlb(func_res_label);
@@ -349,17 +345,13 @@ WalkProcedure(procedure)
 		   and put function result back on the stack
 		*/
 		if (func_type) {
-			C_lal(retsav);
+			STL(retsav, func_res_size);
-			C_sti(func_res_size);
 		}
-		C_lal(StackAdjustment);
+		LOL(StackAdjustment, pointer_size);
-		C_loi(pointer_size);
 		C_str((arith) 1);
 		if (func_type) {
-			C_lal(retsav);
+			LOL(retsav, func_res_size);
-			C_loi(func_res_size);
 		}
-		FreePtr(StackAdjustment);
 	}
 	EndPriority();
 	C_ret(func_res_size);
@@ -453,6 +445,8 @@ WalkStat(nd, exit_label)
 	assert(nd->nd_class == Stat);
 
 	DoLineno(nd);
+	if (nd->nd_flags & ROPTION) options['R'] = 1;
+	if (nd->nd_flags & AOPTION) options['A'] = 1;
 	switch(nd->nd_symb) {
 	case '(':
 		if (ChkCall(nd)) {
@@ -682,16 +676,6 @@ WalkStat(nd, exit_label)
 
 extern int	NodeCrash();
 
-STATIC
-WalkOption(nd)
-	t_node *nd;
-{
-	/* Set option indicated by node "nd"
-	*/
-
-	options[nd->nd_symb] = nd->nd_INT;
-}
-
 int (*WalkTable[])() = {
 	NodeCrash,
 	NodeCrash,
@@ -705,7 +689,6 @@ int (*WalkTable[])() = {
 	NodeCrash,
 	WalkStat,
 	WalkLink,
-	WalkOption
 };
 
 ExpectBool(nd, true_label, false_label)
@@ -883,11 +866,14 @@ static int
 UseWarnings(df)
 	register t_def *df;
 {
-	if (is_anon_idf(df->df_idf)) return;
+	char *warning = 0;
-	if (df->df_kind & (D_IMPORTED | D_VARIABLE | D_PROCEDURE | D_CONST | D_TYPE)) {
+
-		struct node *nd;
+	if (is_anon_idf(df->df_idf) ||
+	    !(df->df_kind&(D_IMPORTED|D_VARIABLE|D_PROCEDURE|D_CONST|D_TYPE)) ||
+	    (df->df_flags&(D_EXPORTED|D_QEXPORTED))) {
+		return;
+	}
 
-		if (df->df_flags & (D_EXPORTED | D_QEXPORTED)) return;
 	if (df->df_kind & D_IMPORTED) {
 		register t_def *df1 = df->imp_def;
 
@@ -895,33 +881,38 @@ UseWarnings(df)
 		if (df->df_kind == D_INUSE) return;
 		if ( !(df->df_flags & D_IMP_BY_EXP)) {
 			if (! (df->df_flags & (D_USED | D_DEFINED))) {
-					node_warning(
+				if (df1->df_kind == D_VARIABLE) {
-						df->df_scope->sc_end,
+					warning = "imported but not used/assigned";
-						W_ORDINARY,
+				}
-						"identifier \"%s\" imported but not %s",
+				else	warning = "imported but not used";
-						df->df_idf->id_text,
+				goto warn;
-						df1->df_kind == D_VARIABLE ?
-							"used/assigned" :
-							"used");
 			}
 			return;
 		}
 		df = df1;
 	}
-		if (! (df->df_kind & (D_VARIABLE|D_PROCEDURE|D_TYPE|D_CONST))) return;
+	if (! (df->df_kind & (D_VARIABLE|D_PROCEDURE|D_TYPE|D_CONST))) {
-		nd = df->df_scope->sc_end;
+		return;
-		if (! (df->df_flags & D_DEFINED)) {
-			node_warning(nd,
-				     W_ORDINARY,
-				     "identifier \"%s\" never assigned",
-				     df->df_idf->id_text);
 	}
-		if (! (df->df_flags & D_USED)) {
+	switch(df->df_flags & (D_USED|D_DEFINED)) {
-			node_warning(nd,
+	case 0:
-				     W_ORDINARY,
+		warning = "never used/assigned";
-				     "identifier \"%s\" never used",
+		break;
-				     df->df_idf->id_text);
+	case D_USED:
+		warning = "never assigned";
+		break;
+	case D_DEFINED:
+		warning = "never used";
+		break;
+	case D_USED|D_DEFINED:
+		return;
 	}
+warn:
+	if (warning) {
+		node_warning(df->df_scope->sc_end,
+			     W_ORDINARY,
+			     "identifier \"%s\" %s",
+			     df->df_idf->id_text, warning);
 	}
 }