newer version

lang/m2/comp/LLlex.c

@@ -106,9 +106,8 @@ GetString(upto)
 	}
 	str->s_length = p - str->s_str;
 	while (p - str->s_str < len) *p++ = '\0';
-	if (str->s_length == 0) str->s_length = 1;	/* ??? string length
+	if (str->s_length == 0) str->s_length = 1;
-							   at least 1 ???
+	/* ??? string length at least 1 ??? */
-						   	*/
 	return str;
 }
 
@@ -239,12 +238,10 @@ again1:
 		goto again;
 
 	case STGARB:
-		if (040 < ch && ch < 0177)	{
+		if ((unsigned) ch - 040 < 0137)	{
 			lexerror("garbage char %c", ch);
 		}
-		else	{
+		else	lexerror("garbage char \\%03o", ch);
-			lexerror("garbage char \\%03o", ch);
-		}
 		goto again;
 
 	case STSIMP:

lang/m2/comp/Makefile

@@ -5,11 +5,11 @@ PKGDIR =	$(EMDIR)/modules/pkg
 LIBDIR =	$(EMDIR)/modules/lib
 OBJECTCODE =	$(LIBDIR)/libemk.a
 LLGEN =		$(EMDIR)/bin/LLgen
+CURRDIR =	.
 
 INCLUDES = -I$(MHDIR) -I$(EMDIR)/h -I$(PKGDIR)
 
 GFILES =	tokenfile.g program.g declar.g expression.g statement.g
-CC =	cc
 LLGENOPTIONS =
 PROFILE =
 CFLAGS = $(PROFILE) $(INCLUDES) -DSTATIC=
@@ -50,14 +50,14 @@ GENFILES = $(GENGFILES) $(GENCFILES) $(GENHFILES)
 #EXCLEXCLEXCLEXCL
 
 all:	Cfiles
-	sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make ../comp/main ; else sh Resolve ../comp/main ; fi'
+	sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make $(CURRDIR)/main ; else sh Resolve main ; fi'
 	@rm -f nmclash.o a.out
 
 install:	all
-	cp main $(EMDIR)/lib/em_m2
+	cp $(CURRDIR)/main $(EMDIR)/lib/em_m2
 
 clean:
-	rm -f $(OBJ) $(GENFILES) LLfiles hfiles Cfiles tab clashes main
+	rm -f $(OBJ) $(GENFILES) LLfiles hfiles Cfiles tab clashes $(CURRDIR)/main
 	(cd .. ; rm -rf Xsrc)
 
 lint:	Cfiles
@@ -123,9 +123,9 @@ depend:
 Xlint:
 	lint $(INCLUDES) $(LINTFLAGS) $(SRC)
 
-../comp/main:	$(OBJ) ../comp/Makefile
+$(CURRDIR)/main:	$(OBJ)
-	$(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libem_mes.a $(OBJECTCODE) $(LIBDIR)/libinput.a $(LIBDIR)/libassert.a $(LIBDIR)/liballoc.a $(MALLOC) $(LIBDIR)/libprint.a $(LIBDIR)/libstring.a $(LIBDIR)/libsystem.a -o ../comp/main
+	$(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libem_mes.a $(OBJECTCODE) $(LIBDIR)/libinput.a $(LIBDIR)/libassert.a $(LIBDIR)/liballoc.a $(MALLOC) $(LIBDIR)/libprint.a $(LIBDIR)/libstring.a $(LIBDIR)/libsystem.a -o $(CURRDIR)/main
-	size ../comp/main
+	size $(CURRDIR)/main
 
 #AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO
 LLlex.o: LLlex.h Lpars.h class.h const.h debug.h debugcst.h f_info.h idf.h idfsize.h input.h inputtype.h numsize.h strsize.h type.h warning.h

lang/m2/comp/Resolve

@@ -8,8 +8,11 @@ case $# in
 	exit 1
 	;;
 esac
+currdir=`pwd`
 case $1 in
-../comp/main|Xlint)
+main)	target=$currdir/$1
+	;;
+Xlint)	target=$1
 	;;
 *)	echo "$0: $1: Illegal argument" 1>&2
 	exit 1
@@ -48,4 +51,4 @@ $i:	clashes $PW/$i
 	cid -Fclashes < $PW/$i > $i
 EOF
 done
-make $1
+make CURRDIR=$currdir $target

lang/m2/comp/chk_expr.c

@@ -438,6 +438,7 @@ getarg(argp, bases, designator, edf)
 	}
 
 	left = arg->nd_left;
+	*argp = arg;
 
 	if (designator ? !ChkVariable(left) : !ChkExpression(left)) {
 		return 0;
@@ -454,7 +455,6 @@ getarg(argp, bases, designator, edf)
 		}
 	}
 
-	*argp = arg;
 	return left;
 }
 
@@ -470,6 +470,8 @@ getname(argp, kinds, bases, edf)
 	register struct node *arg = *argp;
 	register struct node *left;
 
+	*argp = arg->nd_right;
+
 	if (!arg->nd_right) {
 		Xerror(arg, "too few arguments supplied", edf);
 		return 0;
@@ -496,7 +498,6 @@ getname(argp, kinds, bases, edf)
 		}
 	}
 
-	*argp = arg;
 	return left;
 }
 
@@ -539,7 +540,7 @@ ChkProcCall(expp)
 		if (left->nd_symb == STRING) {
 			TryToString(left, TypeOfParam(param));
 		}
-		if (! TstParCompat(RemoveEqual(TypeOfParam(param)),
+		else if (! TstParCompat(RemoveEqual(TypeOfParam(param)),
 				   left->nd_type,
 				   IsVarParam(param),
 				   left)) {
@@ -552,6 +553,9 @@ ChkProcCall(expp)
 
 	if (expp->nd_right) {
 		Xerror(expp->nd_right, "too many parameters supplied", edf);
+		while (expp->nd_right) {
+			getarg(&expp, 0, 0, edf);
+		}
 		return 0;
 	}
 
@@ -581,7 +585,7 @@ ChkCall(expp)
 			return ChkCast(expp, left);
 		}
 
-		if (IsProcCall(left)) {
+		if (IsProcCall(left) || left->nd_type == error_type) {
 			/* A procedure call.
 		   	   It may also be a call to a standard procedure
 			*/

lang/m2/comp/code.c

@@ -86,7 +86,6 @@ CodePadString(nd, sz)
 	C_loi(sizearg);
 }
 
-
 CodeExpr(nd, ds, true_label, false_label)
 	register struct node *nd;
 	register struct desig *ds;
@@ -365,27 +364,37 @@ CodeParameters(param, arg)
 	left = arg->nd_left;
 	left_type = left->nd_type;
 	if (IsConformantArray(tp)) {
+		register struct type *elem = tp->arr_elem;
+
 		C_loc(tp->arr_elsize);
 		if (IsConformantArray(left_type)) {
 			DoHIGH(left);
-			if (tp->arr_elem->tp_size !=
+			if (elem->tp_size != left_type->arr_elem->tp_size) {
-			    left_type->arr_elem->tp_size) {
 				/* This can only happen if the formal type is
-				   ARRAY OF WORD
+				   ARRAY OF (WORD|BYTE)
 				*/
-				assert(tp->arr_elem == word_type);
 				C_loc(left_type->arr_elem->tp_size);
-				C_cal("_wa");
+				C_mli(word_size);
-				C_asp(dword_size);
+				if (elem == word_type) {
-				C_lfr(word_size);
+					C_loc(word_size - 1);
+					C_adi(word_size);
+					C_loc(word_size);
+					C_dvi(word_size);
+				}
+				else {
+					assert(elem == byte_type);
+				}
 			}
 		}
 		else if (left->nd_symb == STRING) {
-			C_loc(left->nd_SLE);
+			C_loc(left->nd_SLE - 1);
 		}
-		else if (tp->arr_elem == word_type) {
+		else if (elem == word_type) {
 			C_loc((left_type->tp_size+word_size-1) / word_size - 1);
 		}
+		else if (elem == byte_type) {
+			C_loc(left_type->tp_size - 1);
+		}
 		else {
 			arith lb, ub;
 			getbounds(IndexType(left_type), &lb, &ub);
@@ -395,20 +404,30 @@ CodeParameters(param, arg)
 		if (left->nd_symb == STRING) {
 			CodeString(left);
 		}
+		else if (left->nd_class == Call) {
+			/* ouch! forgot about this one! */
+			arith tmp, TmpSpace();
+
+			CodePExpr(left);
+			tmp = TmpSpace(left->nd_type->tp_size, left->nd_type->tp_align);
+			C_lal(tmp);
+			C_sti(WA(left->nd_type->tp_size));
+			C_lal(tmp);
+		}
 		else	CodeDAddress(left);
+		return;
 	}
-	else if (IsVarParam(param)) {
+	if (IsVarParam(param)) {
 		CodeDAddress(left);
+		return;
 	}
-	else {
 	if (left_type->tp_fund == T_STRING) {
 		CodePadString(left, tp->tp_size);
+		return;
 	}
-		else {
 	CodePExpr(left);
-			RangeCheck(left_type, tp);
+	RangeCheck(tp, left_type);
-		}
+	CodeCoercion(left_type, tp);
-	}
 }
 
 CodeStd(nd)
@@ -538,33 +557,6 @@ CodeStd(nd)
 	}
 }
 
-CodeAssign(nd, dss, dst)
-	register struct node *nd;
-	struct desig *dst, *dss;
-{
-	/*	Generate code for an assignment. Testing of type
-		compatibility and the like is already done.
-	*/
-	register struct type *tp = nd->nd_right->nd_type;
-	arith size = nd->nd_left->nd_type->tp_size;
-
-	if (dss->dsg_kind == DSG_LOADED) {
-		if (tp->tp_fund == T_STRING) {
-			CodeAddress(dst);
-			C_loc(tp->tp_size);
-			C_loc(size);
-			C_cal("_StringAssign");
-			C_asp((int_size << 1) + (pointer_size << 1));
-			return;
-		}
-		CodeStore(dst, size);
-		return;
-	}
-	CodeAddress(dss);
-	CodeAddress(dst);
-	C_blm(size);
-}
-
 RangeCheck(tpl, tpr)
 	register struct type *tpl, *tpr;
 {
@@ -800,32 +792,30 @@ CodeOper(expr, true_label, false_label)
 	case OR:
 	case AND:
 	case '&': {
-		label l_true, l_false, l_maybe = ++text_label, l_end;
+		label  l_maybe = ++text_label, l_end;
 		struct desig Des;
+		int genlabels = 0;
 
 		if (true_label == 0)	{
-			l_true = ++text_label;
+			genlabels = 1;
-			l_false = ++text_label;
+			true_label = ++text_label;
+			false_label = ++text_label;
 			l_end = ++text_label;
 		}
-		else {
-			l_true = true_label;
-			l_false = false_label;
-		}
 
 		Des = InitDesig;
 		if (expr->nd_symb == OR) {
-			CodeExpr(leftop, &Des, l_true, l_maybe);
+			CodeExpr(leftop, &Des, true_label, l_maybe);
 		}
-		else	CodeExpr(leftop, &Des, l_maybe, l_false);
+		else	CodeExpr(leftop, &Des, l_maybe, false_label);
 		C_df_ilb(l_maybe);
 		Des = InitDesig;
-		CodeExpr(rightop, &Des, l_true, l_false);
+		CodeExpr(rightop, &Des, true_label, false_label);
-		if (true_label == 0) {
+		if (genlabels) {
-			C_df_ilb(l_true);
+			C_df_ilb(true_label);
 			C_loc((arith)1);
 			C_bra(l_end);
-			C_df_ilb(l_false);
+			C_df_ilb(false_label);
 			C_loc((arith)0);
 			C_df_ilb(l_end);
 		}

lang/m2/comp/declar.g

@@ -102,10 +102,11 @@ FormalType(struct type **ptp;)
 } :
 	ARRAY OF qualtype(ptp)
 		{ register struct type *tp = construct_type(T_ARRAY, NULLTYPE);
+
 		  tp->arr_elem = *ptp;
 		  *ptp = tp;
 		  tp->arr_elsize = ArrayElSize(tp->arr_elem);
-		  tp->tp_align = lcm(word_align, pointer_align);
+		  tp->tp_align = tp->arr_elem->tp_align;
 		}
 |
 	 qualtype(ptp)
@@ -160,16 +161,18 @@ enumeration(struct type **ptp;)
 	struct node *EnumList;
 } :
 	'(' IdentList(&EnumList) ')'
-		{
+		{ register struct type *tp =
-		  *ptp = standard_type(T_ENUMERATION, int_align, int_size);
+		  	standard_type(T_ENUMERATION, int_align, int_size);
-		  EnterEnumList(EnumList, *ptp);
+
-		  if (ufit((*ptp)->enm_ncst-1, 1)) {
+		  *ptp = tp;
-			(*ptp)->tp_size = 1;
+		  EnterEnumList(EnumList, tp);
-			(*ptp)->tp_align = 1;
+		  if (ufit(tp->enm_ncst-1, 1)) {
+			tp->tp_size = 1;
+			tp->tp_align = 1;
 		  }
-		  else if (ufit((*ptp)->enm_ncst-1, short_size)) {
+		  else if (ufit(tp->enm_ncst-1, short_size)) {
-			(*ptp)->tp_size = short_size;
+			tp->tp_size = short_size;
-			(*ptp)->tp_align = short_align;
+			tp->tp_align = short_align;
 		  }
 		}
 ;
@@ -234,7 +237,6 @@ RecordType(struct type **ptp;)
 		{ open_scope(OPENSCOPE);	/* scope for fields of record */
 		  scope = CurrentScope;
 		  close_scope(0);
-		  size = 0;
 		}
 	FieldListSequence(scope, &size, &xalign)
 		{ *ptp = standard_type(T_RECORD, xalign, WA(size));

lang/m2/comp/def.H

@@ -63,13 +63,20 @@ struct dforward {
 #define for_name	df_value.df_forward.fo_name
 };
 
+struct forwtype {
+	struct node *f_node;
+	struct type *f_type;
+#define df_forw_type	df_value.df_fortype.f_type
+#define df_forw_node	df_value.df_fortype.f_node
+};
+
 struct def	{		/* list of definitions for a name */
 	struct def *next;	/* next definition in definitions chain */
 	struct def *df_nextinscope;
 				/* link all definitions in a scope */
 	struct idf *df_idf;	/* link back to the name */
 	struct scope *df_scope;	/* scope in which this definition resides */
-	short df_kind;		/* the kind of this definition: */
+	unsigned short df_kind;	/* the kind of this definition: */
 #define D_MODULE	0x0001	/* a module */
 #define D_PROCEDURE	0x0002	/* procedure of function */
 #define D_VARIABLE	0x0004	/* a variable */
@@ -82,20 +89,22 @@ struct def	{		/* list of definitions for a name */
 #define D_HIDDEN	0x0200	/* a hidden type */
 #define D_FORWARD	0x0400	/* not yet defined */
 #define D_FORWMODULE	0x0800	/* module must be declared later */
-#define D_ERROR		0x1000	/* a compiler generated definition for an
+#define D_FORWTYPE	0x1000	/* forward type */
+#define D_FTYPE		0x2000	/* resolved forward type */
+#define D_ERROR		0x4000	/* a compiler generated definition for an
 				   undefined variable
 				*/
 #define D_VALUE	(D_PROCEDURE|D_VARIABLE|D_FIELD|D_ENUM|D_CONST|D_PROCHEAD)
-#define D_ISTYPE	(D_HIDDEN|D_TYPE)
+#define D_ISTYPE	(D_HIDDEN|D_TYPE|D_FTYPE)
 #define is_type(dfx)	((dfx)->df_kind & D_ISTYPE)
 	char df_flags;
 #define D_NOREG		0x01	/* set if it may not reside in a register */
 #define D_USED		0x02	/* set if used (future use ???) */
 #define D_DEFINED	0x04	/* set if it is assigned a value (future use ???) */
-#define D_VARPAR	0x10	/* set if it is a VAR parameter */
+#define D_VARPAR	0x08	/* set if it is a VAR parameter */
-#define D_VALPAR	0x20	/* set if it is a value parameter */
+#define D_VALPAR	0x10	/* set if it is a value parameter */
-#define D_EXPORTED	0x40	/* set if exported */
+#define D_EXPORTED	0x20	/* set if exported */
-#define D_QEXPORTED	0x80	/* set if qualified exported */
+#define D_QEXPORTED	0x40	/* set if qualified exported */
 	struct type *df_type;
 	union {
 		struct module df_module;
@@ -106,6 +115,7 @@ struct def	{		/* list of definitions for a name */
 		struct import df_import;
 		struct dfproc df_proc;
 		struct dforward df_forward;
+		struct forwtype df_fortype;
 		int df_stdname;	/* define for standard name */
 	} df_value;
 };

lang/m2/comp/def.c

@@ -21,6 +21,8 @@ struct def *h_def;		/* pointer to free list of def structures */
 int	cnt_def;		/* count number of allocated ones */
 #endif
 
+extern int	(*c_inp)();
+
 STATIC
 DefInFront(df)
 	register struct def *df;
@@ -129,6 +131,18 @@ define(id, scope, kind)
 			}
 			break;
 
+		case D_FORWTYPE:
+			if (kind == D_FORWTYPE) return df;
+			if (kind == D_TYPE) {
+				df->df_kind = D_FTYPE;
+				FreeNode(df->df_forw_node);
+			}
+			else {
+				error("identifier \"%s\" must be a type",
+					id->id_text);
+			}
+			return df;
+
 		case D_FORWARD:
 			/* A forward reference, for which we may now have
 			   found a definition.
@@ -247,7 +261,7 @@ DeclProc(type, id)
 			df = define(id, CurrentScope, type);
 			sprint(buf,"_%d_%s",++nmcount,id->id_text);
 			name = Salloc(buf, (unsigned)(strlen(buf)+1));
-			C_inp(buf);
+			(*c_inp)(buf);
 		}
 		open_scope(OPENSCOPE);
 		scope = CurrentScope;
@@ -311,13 +325,13 @@ DefineLocalModule(id)
 
 	/* Create a type for it
 	*/
-	df->df_type = standard_type(T_RECORD, 0, (arith) 0);
+	df->df_type = standard_type(T_RECORD, 1, (arith) 0);
 	df->df_type->rec_scope = sc;
 
 	/* Generate code that indicates that the initialization procedure
 	   for this module is local.
 	*/
-	C_inp(buf);
+	(*c_inp)(buf);
 
 	return df;
 }

lang/m2/comp/defmodule.c

@@ -36,7 +36,7 @@ GetFile(name)
 	buf[10] = '\0';			/* maximum length */
 	strcat(buf, ".def");
 	if (! InsertFile(buf, DEFPATH, &(FileName))) {
-		error("could'nt find a DEFINITION MODULE for \"%s\"", name);
+		error("could not find a DEFINITION MODULE for \"%s\"", name);
 		return 0;
 	}
 	LineNumber = 1;
@@ -56,6 +56,7 @@ GetDefinitionModule(id, incr)
 	struct def *df;
 	static int level;
 	struct scopelist *vis;
+	int didread = 0;
 
 	level += incr;
 	df = lookup(id, GlobalScope, 1);
@@ -68,6 +69,7 @@ GetDefinitionModule(id, incr)
 		else {
 			open_scope(CLOSEDSCOPE);
 			if (!is_anon_idf(id) && GetFile(id->id_text)) {
+				didread = 1;
 				DefModule();
 				if (level == 1) {
 					/* The module is directly imported by
@@ -93,6 +95,9 @@ GetDefinitionModule(id, incr)
 		}
 		df = lookup(id, GlobalScope, 1);
 		if (! df) {
+			if (didread) {
+				error("did not read a DEFINITION MODULE for \"%s\"", id->id_text);
+			}
 			df = MkDef(id, GlobalScope, D_ERROR);
 			df->df_type = error_type;
 			df->mod_vis = vis;

lang/m2/comp/expression.g

@@ -50,7 +50,7 @@ ExpList(struct node **pnd;)
 	register struct node *nd;
 } :
 	expression(pnd)		{ *pnd = nd = MkNode(Link,*pnd,NULLNODE,&dot);
-				  (*pnd)->nd_symb = ',';
+				  nd->nd_symb = ',';
 				}
 	[
 		','		{ nd->nd_right = MkLeaf(Link, &dot);
@@ -60,20 +60,26 @@ ExpList(struct node **pnd;)
 	]*
 ;
 
-ConstExpression(struct node **pnd;):
+ConstExpression(struct node **pnd;)
+{
+	register struct node *nd;
+}:
 	expression(pnd)
 	/*
 	 * Changed rule in new Modula-2.
 	 * Check that the expression is a constant expression and evaluate!
 	 */
-		{ DO_DEBUG(options['X'], print("CONSTANT EXPRESSION\n"));
+		{ nd = *pnd;
-		  DO_DEBUG(options['X'], PrNode(*pnd, 0));
+		  DO_DEBUG(options['X'], print("CONSTANT EXPRESSION\n"));
-		  if (ChkExpression(*pnd) &&
+		  DO_DEBUG(options['X'], PrNode(nd, 0));
-		      ((*pnd)->nd_class != Set && (*pnd)->nd_class != Value)) {
+
+		  if (ChkExpression(nd) &&
+		      ((nd)->nd_class != Set && (nd)->nd_class != Value)) {
 			error("constant expression expected");
 		  }
+
 		  DO_DEBUG(options['X'], print("RESULTS IN\n"));
-		  DO_DEBUG(options['X'], PrNode(*pnd, 0));
+		  DO_DEBUG(options['X'], PrNode(nd, 0));
 		}
 ;
 
@@ -102,6 +108,7 @@ SimpleExpression(struct node **pnd;)
 		[ '+' | '-' ]
 			{ *pnd = MkLeaf(Uoper, &dot);
 			  pnd = &((*pnd)->nd_right);
+			  /* priority of unary operator ??? */
 			}
 	]?
 	term(pnd)

lang/m2/comp/main.c

@@ -29,6 +29,9 @@ struct def 	*Defined;
 extern int 	err_occurred;
 extern int	fp_used;		/* set if floating point used */
 
+extern		C_inp(), C_exp();
+int		(*c_inp)() = C_inp;
+
 main(argc, argv)
 	register char **argv;
 {
@@ -49,6 +52,7 @@ main(argc, argv)
 		fprint(STDERR, "%s: Use a file argument\n", ProgName);
 		return 1;
 	}
+	if (options['x']) c_inp = C_exp;
 	return !Compile(Nargv[1], Nargv[2]);
 }
 
@@ -197,6 +201,7 @@ do_SYSTEM()
 	*/
 	open_scope(CLOSEDSCOPE);
 	(void) Enter("WORD", D_TYPE, word_type, 0);
+	(void) Enter("BYTE", D_TYPE, byte_type, 0);
 	(void) Enter("ADDRESS", D_TYPE, address_type, 0);
 	(void) Enter("ADR", D_PROCEDURE, std_type, S_ADR);
 	(void) Enter("TSIZE", D_PROCEDURE, std_type, S_TSIZE);
@@ -215,14 +220,14 @@ Info()
 {
 	extern int cnt_def, cnt_node, cnt_paramlist, cnt_type,
 		   cnt_switch_hdr, cnt_case_entry, 
-		   cnt_scope, cnt_scopelist, cnt_forwards, cnt_tmpvar;
+		   cnt_scope, cnt_scopelist, cnt_tmpvar;
 
 	print("\
 %6d def\n%6d node\n%6d paramlist\n%6d type\n%6d switch_hdr\n\
-%6d case_entry\n%6d scope\n%6d scopelist\n%6d forwards\n%6d tmpvar\n",
+%6d case_entry\n%6d scope\n%6d scopelist\n%6d tmpvar\n",
 cnt_def, cnt_node, cnt_paramlist, cnt_type,
 cnt_switch_hdr, cnt_case_entry, 
-cnt_scope, cnt_scopelist, cnt_forwards, cnt_tmpvar);
+cnt_scope, cnt_scopelist, cnt_tmpvar);
 print("\nNumber of lines read: %d\n", cntlines);
 }
 #endif

lang/m2/comp/program.g

@@ -59,10 +59,12 @@ ModuleDeclaration
 
 priority(arith *pprio;)
 {
-	struct node *nd;
+	register struct node *nd;
+	struct node *nd1;		/* &nd is illegal */
 } :
-	'[' ConstExpression(&nd) ']'
+	'[' ConstExpression(&nd1) ']'
-			{ if (!(nd->nd_type->tp_fund & T_CARDINAL)) {
+			{ nd = nd1;
+			  if (!(nd->nd_type->tp_fund & T_CARDINAL)) {
 				node_error(nd, "illegal priority");
 			  }
 			  *pprio = nd->nd_INT;
@@ -70,9 +72,7 @@ priority(arith *pprio;)
 			}
 ;
 
-export(int *QUALflag; struct node **ExportList;)
+export(int *QUALflag; struct node **ExportList;):
-{
-} :
 	EXPORT
 	[
 		QUALIFIED
@@ -86,7 +86,7 @@ export(int *QUALflag; struct node **ExportList;)
 import(int local;)
 {
 	struct node *ImportList;
-	struct node *FromId = 0;
+	register struct node *FromId = 0;
 	register struct def *df;
 	extern struct def *GetDefinitionModule();
 } :
@@ -121,7 +121,7 @@ DefinitionModule
 			  if (!Defined) Defined = df;
 			  CurrentScope->sc_name = df->df_idf->id_text;
 			  df->mod_vis = CurrVis;
-			  df->df_type = standard_type(T_RECORD, 0, (arith) 0);
+			  df->df_type = standard_type(T_RECORD, 1, (arith) 0);
 			  df->df_type->rec_scope = df->mod_vis->sc_scope;
 			  DefinitionModule++;
 			}
@@ -210,12 +210,9 @@ ProgramModule
 ;
 
 Module:
-				{ open_scope(CLOSEDSCOPE);
+	DEFINITION
-				  warning(W_ORDINARY, "Compiling a definition module");
+				{ fatal("Compiling a definition module"); }
-				}
+|	%default
-	DefinitionModule
-				{ close_scope(SC_CHKFORW); }
-|
 	[
 		IMPLEMENTATION	{ state = IMPLEMENTATION; }
 	|

lang/m2/comp/scope.C

@@ -50,7 +50,6 @@ InitScope()
 	register struct scopelist *ls = new_scopelist();
 
 	sc->sc_scopeclosed = 0;
-	sc->sc_forw = 0;
 	sc->sc_def = 0;
 	sc->sc_level = proclevel;
 	PervasiveScope = sc;
@@ -61,14 +60,6 @@ InitScope()
 	CurrVis = ls;
 }
 
-struct forwards {
-	struct forwards *next;
-	struct node *fo_tok;
-	struct type *fo_ptyp;
-};
-
-/* STATICALLOCDEF "forwards" 5 */
-
 Forward(tk, ptp)
 	struct node *tk;
 	struct type *ptp;
@@ -78,13 +69,10 @@ Forward(tk, ptp)
 		may have forward references that must howewer be declared in the
 		same scope.
 	*/
-	register struct forwards *f = new_forwards();
+	register struct def *df = define(tk->nd_IDF, CurrentScope, D_FORWTYPE);
-	register struct scope *sc = CurrentScope;
 
-	f->fo_tok = tk;
+	df->df_forw_type = ptp;
-	f->fo_ptyp = ptp;
+	df->df_forw_node = tk;
-	f->next = sc->sc_forw;
-	sc->sc_forw = f;
 }
 
 STATIC
@@ -117,7 +105,15 @@ chk_forw(pdf)
 	register struct def *df;
 
 	while (df = *pdf) {
-		if (df->df_kind & (D_FORWARD|D_FORWMODULE)) {
+		if (df->df_kind == D_FORWTYPE) {
+node_error(df->df_forw_node, "type \"%s\" not declared", df->df_idf->id_text);
+			FreeNode(df->df_forw_node);
+		}
+		else if (df->df_kind == D_FTYPE) {
+			df->df_kind = D_TYPE;
+			df->df_forw_type->next = df->df_type;
+		}
+		else if (df->df_kind & (D_FORWARD|D_FORWMODULE)) {
 			/* These definitions must be found in
 			   the enclosing closed scope, which of course
 			   may be the scope that is now closed!
@@ -126,7 +122,7 @@ chk_forw(pdf)
 				/* Indeed, the scope was a closed
 				   scope, so give error message
 				*/
-node_error(df->for_node, "identifier \"%s\" has not been declared",
+node_error(df->for_node, "identifier \"%s\" not declared",
 df->df_idf->id_text);
 				FreeNode(df->for_node);
 			}
@@ -153,25 +149,6 @@ df->df_idf->id_text);
 	}
 }
 
-STATIC
-rem_forwards(fo)
-	register struct forwards *fo;
-{
-	/*	When closing a scope, all forward references must be resolved
-	*/
-	register struct def *df;
-
-	if (fo->next) rem_forwards(fo->next);
-	df = lookfor(fo->fo_tok, CurrVis, 0);
-	if (! is_type(df)) {
-		node_error(fo->fo_tok,
-			   "identifier \"%s\" does not represent a type",
-			   df->df_idf->id_text);
-	}
-	fo->fo_ptyp->next = df->df_type;
-	free_forwards(fo);
-}
-
 Reverse(pdf)
 	struct def **pdf;
 {
@@ -210,7 +187,6 @@ close_scope(flag)
 	assert(sc != 0);
 
 	if (flag) {
-		if (sc->sc_forw) rem_forwards(sc->sc_forw);
 		DO_DEBUG(options['S'], PrScopeDef(sc->sc_def));
 		if (flag & SC_CHKPROC) chk_proc(sc->sc_def);
 		if (flag & SC_CHKFORW) chk_forw(&(sc->sc_def));

lang/m2/comp/scope.h

@@ -15,7 +15,6 @@
 
 struct scope {
 	struct scope *next;
-	struct forwards *sc_forw;
 	char *sc_name;		/* name of this scope */
 	struct def *sc_def;	/* list of definitions in this scope */
 	arith sc_off;		/* offsets of variables in this scope */

lang/m2/comp/tmpvar.C

@@ -40,6 +40,16 @@ TmpOpen(sc) struct scope *sc;
 	ProcScope = sc;
 }
 
+arith
+TmpSpace(sz, al)
+	arith sz;
+{
+	register struct scope *sc = ProcScope;
+
+	sc->sc_off = - WA(align(sz - sc->sc_off, al));
+	return sc->sc_off;
+}
+
 arith
 NewInt()
 {
@@ -47,8 +57,7 @@ NewInt()
 	register struct tmpvar *tmp;
 
 	if (!TmpInts) {
-		offset = - WA(align(int_size - ProcScope->sc_off, int_align));
+		offset = TmpSpace(int_size, int_align);
-		ProcScope->sc_off = offset;
 		if (! options['n']) C_ms_reg(offset, int_size, reg_any, 0);
 	}
 	else {
@@ -67,8 +76,7 @@ NewPtr()
 	register struct tmpvar *tmp;
 
 	if (!TmpPtrs) {
-		offset = - WA(align(pointer_size - ProcScope->sc_off, pointer_align));
+		offset = TmpSpace(pointer_size, pointer_align);
-		ProcScope->sc_off = offset;
 		if (! options['n']) C_ms_reg(offset, pointer_size, reg_pointer, 0);
 	}
 	else {

lang/m2/comp/type.H

@@ -95,6 +95,7 @@ extern struct type
 	*real_type,
 	*longreal_type,
 	*word_type,
+	*byte_type,
 	*address_type,
 	*intorcard_type,
 	*bitset_type,

lang/m2/comp/type.c

@@ -48,6 +48,7 @@ struct type
 	*real_type,
 	*longreal_type,
 	*word_type,
+	*byte_type,
 	*address_type,
 	*intorcard_type,
 	*bitset_type,
@@ -123,7 +124,7 @@ standard_type(fund, align, size)
 	register struct type *tp = new_type();
 
 	tp->tp_fund = fund;
-	tp->tp_align = align;
+	tp->tp_align = align ? align : 1;
 	tp->tp_size = size;
 
 	return tp;
@@ -179,6 +180,7 @@ InitTypes()
 	/* SYSTEM types
 	*/
 	word_type = standard_type(T_WORD, word_align, word_size);
+	byte_type = standard_type(T_WORD, 1, (arith) 1);
 	address_type = construct_type(T_POINTER, word_type);
 
 	/* create BITSET type
@@ -407,11 +409,11 @@ ArrayElSize(tp)
 
 	if (tp->tp_fund == T_ARRAY) ArraySizes(tp);
 	algn = align(tp->tp_size, tp->tp_align);
-	if (algn && word_size % algn != 0) {
+	if (word_size % algn != 0) {
 		/* algn is not a dividor of the word size, so make sure it
 		   is a multiple
 		*/
-		algn = WA(algn);
+		return WA(algn);
 	}
 	return algn;
 }
@@ -432,13 +434,13 @@ ArraySizes(tp)
 	*/
 	if (! bounded(index_type)) {
 		error("illegal index type");
-		tp->tp_size = 0;
+		tp->tp_size = tp->arr_elsize;
 		return;
 	}
 
 	getbounds(index_type, &lo, &hi);
 
-	tp->tp_size = WA((hi - lo + 1) * tp->arr_elsize);
+	tp->tp_size = (hi - lo + 1) * tp->arr_elsize;
 
 	/* generate descriptor and remember label.
 	*/

lang/m2/comp/typequiv.c

@@ -177,7 +177,7 @@ TstParCompat(formaltype, actualtype, VARflag, nd)
 	/*	Check type compatibility for a parameter in a procedure call.
 		Assignment compatibility may do if the parameter is
 		a value parameter.
-		Otherwise, a conformant array may do, or an ARRAY OF WORD
+		Otherwise, a conformant array may do, or an ARRAY OF (WORD|BYTE)
 		may do too.
 		Or: a WORD may do.
 	*/
@@ -201,10 +201,15 @@ TstParCompat(formaltype, actualtype, VARflag, nd)
 		      )
 		   )
 		)
+	    ||
+		(  formaltype == byte_type
+		&& actualtype->tp_size == (arith) 1
+		)
 	    ||
 		(  IsConformantArray(formaltype)
 		&&
 		   (  formaltype->arr_elem == word_type
+		   || formaltype->arr_elem == byte_type
 		   ||
 		      (  actualtype->tp_fund == T_ARRAY
 		      && TstTypeEquiv(formaltype->arr_elem,actualtype->arr_elem)

lang/m2/comp/walk.c

@@ -44,13 +44,15 @@ DoProfil()
 	static label	filename_label = 0;
 
 	if (! options['L']) {
-		if (!filename_label) {
+		register label fn_label = filename_label;
-			filename_label = ++data_label;
+
-			C_df_dlb(filename_label);
+		if (!fn_label) {
+			filename_label = fn_label = ++data_label;
+			C_df_dlb(fn_label);
 			C_rom_scon(FileName, (arith) (strlen(FileName) + 1));
 		}
 
-		C_fil_dlb(filename_label, (arith) 0);
+		C_fil_dlb(fn_label, (arith) 0);
 	}
 }
 
@@ -126,7 +128,7 @@ WalkProcedure(procedure)
 		local definitions, checking and generating code.
 	*/
 	struct scopelist *savevis = CurrVis;
-	register struct scope *sc;
+	register struct scope *sc = procedure->prc_vis->sc_scope;
 	register struct type *tp;
 	register struct paramlist *param;
 	label func_res_label = 0;
@@ -136,7 +138,6 @@ WalkProcedure(procedure)
 
 	proclevel++;
 	CurrVis = procedure->prc_vis;
-	sc = CurrentScope;
 
 	/* Generate code for all local modules and procedures
 	*/
@@ -390,7 +391,7 @@ WalkCall(nd)
 }
 
 WalkStat(nd, exit_label)
-	struct node *nd;
+	register struct node *nd;
 	label exit_label;
 {
 	/*	Walk through a statement, generating code for it.
@@ -468,10 +469,11 @@ WalkStat(nd, exit_label)
 		{
 			arith tmp = 0;
 			register struct node *fnd;
+			int good_forvar;
 			label l1 = ++text_label;
 			label l2 = ++text_label;
 
-			if (! DoForInit(nd, left)) break;
+			good_forvar = DoForInit(nd, left);
 			fnd = left->nd_right;
 			if (fnd->nd_class != Value) {
 				/* Upperbound not constant.
@@ -489,15 +491,19 @@ WalkStat(nd, exit_label)
 				C_bgt(l2);
 			}
 			else	C_blt(l2);
+			if (good_forvar) {
 				RangeCheck(nd->nd_type, int_type);
 				CodeDStore(nd);
+			}
 			WalkNode(right, exit_label);
+			if (good_forvar) {	
 				CodePExpr(nd);
 				C_loc(left->nd_INT);
 				C_adi(int_size);
 				C_bra(l1);
 				C_df_ilb(l2);
 				C_asp(int_size);
+			}
 			if (tmp) FreeInt(tmp);
 		}
 		break;
@@ -545,14 +551,23 @@ WalkStat(nd, exit_label)
 
 	case RETURN:
 		if (right) {
-			if (! WalkExpr(right)) break;
+			if (! ChkExpression(right)) break;
 			/* The type of the return-expression must be
 			   assignment compatible with the result type of the
 			   function procedure (See Rep. 9.11).
 			*/
 			if (!TstAssCompat(func_type, right->nd_type)) {
 node_error(right, "type incompatibility in RETURN statement");
+				break;
 			}
+			if (right->nd_type->tp_fund == T_STRING) {
+				arith strsize = WA(right->nd_type->tp_size);
+
+				C_zer(WA(func_type->tp_size) - strsize);
+				CodePExpr(right);
+				C_loi(strsize);
+			}
+			else	CodePExpr(right);
 		}
 		C_bra(RETURN_LABEL);
 		break;
@@ -644,12 +659,12 @@ DoForInit(nd, left)
 	if (df->df_kind == D_FIELD) {
 		node_error(nd,
 			   "FOR-loop variable may not be a field of a record");
-		return 0;
+		return 1;
 	}
 
 	if (!df->var_name && df->var_off >= 0) {
 		node_error(nd, "FOR-loop variable may not be a parameter");
-		return 0;
+		return 1;
 	}
 
 	if (df->df_scope != CurrentScope) {
@@ -659,7 +674,7 @@ DoForInit(nd, left)
 			if (!sc) {
 				node_error(nd,
 				      "FOR-loop variable may not be imported");
-				return 0;
+				return 1;
 			}
 			if (sc->sc_scope == df->df_scope) break;
 			sc = nextvisible(sc);
@@ -669,7 +684,7 @@ DoForInit(nd, left)
 	if (df->df_type->tp_size > word_size ||
 	    !(df->df_type->tp_fund & T_DISCRETE)) {
 		node_error(nd, "illegal type of FOR loop variable");
-		return 0;
+		return 1;
 	}
 
 	if (!TstCompat(df->df_type, left->nd_left->nd_type) ||
@@ -677,7 +692,7 @@ DoForInit(nd, left)
 		if (!TstAssCompat(df->df_type, left->nd_left->nd_type) ||
 		    !TstAssCompat(df->df_type, left->nd_right->nd_type)) {
 			node_error(nd, "type incompatibility in FOR statement");
-			return 0;
+			return 1;
 		}
 node_warning(nd, W_OLDFASHIONED, "compatibility required in FOR statement");
 	}
@@ -695,29 +710,48 @@ DoAssign(nd, left, right)
 	   DAMN THE BOOK!
 	*/
 	struct desig dsl, dsr;
+	register struct type *rtp, *ltp;
 
 	if (! (ChkExpression(right) & ChkVariable(left))) return;
+	rtp = right->nd_type;
+	ltp = left->nd_type;
 
-	if (right->nd_symb == STRING) TryToString(right, left->nd_type);
+	if (right->nd_symb == STRING) TryToString(right, ltp);
 	dsr = InitDesig;
 
-	if (! TstAssCompat(left->nd_type, right->nd_type)) {
+	if (! TstAssCompat(ltp, rtp)) {
 		node_error(nd, "type incompatibility in assignment");
 		return;
 	}
 
 	CodeExpr(right, &dsr, NO_LABEL, NO_LABEL);
-	if (complex(right->nd_type)) {
+	if (complex(rtp)) CodeAddress(&dsr);
-		CodeAddress(&dsr);
-	}
 	else {
-		CodeValue(&dsr, right->nd_type->tp_size);
+		CodeValue(&dsr, rtp->tp_size);
-		RangeCheck(left->nd_type, right->nd_type);
+		RangeCheck(ltp, rtp);
+		CodeCoercion(rtp, ltp);
 	}
 	dsl = InitDesig;
 	CodeDesig(left, &dsl);
 
-	CodeAssign(nd, &dsr, &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)