some minor bug fixes

lang/m2/comp/LLlex.c

@@ -411,8 +411,20 @@ again1:
 				/* Fall through */
 				
 			case End:
-				*np++ = '\0';
+				*np = '\0';
-				tk->TOK_INT = str2long(&buf[1], base);
+				if (np >= &buf[NUMSIZE]) {
+					tk->TOK_INT = 1;
+					lexerror("constant too long");
+				}
+				else {
+					np = &buf[1];
+					while (*np == '0') np++;
+					tk->TOK_INT = str2long(np, base);
+					if (strlen(np) > 14 /* ??? */ ||
+				    	    tk->TOK_INT < 0) {
+lexwarning(W_ORDINARY, "overflow in constant");
+					}
+				}
 				if (ch == 'C' && base == 8) {
 					toktype = char_type;
 					if (tk->TOK_INT<0 || tk->TOK_INT>255) {

lang/m2/comp/LLmessage.c

@@ -16,16 +16,39 @@
 
 extern char		*symbol2str();
 extern struct idf	*gen_anon_idf();
-extern int		err_occurred;
 
 LLmessage(tk)
-	int tk;
+	register int tk;
 {
 	if (tk > 0)	{
 		/* if (tk > 0), it represents the token to be inserted.
 		*/
+		register struct token *dotp = ˙
+
 		error("%s missing", symbol2str(tk));
-		insert_token(tk);
+
+		aside = *dotp;
+
+		dotp->tk_symb = tk;
+
+		switch (tk)	{
+		/* The operands need some body */
+		case IDENT:
+			dotp->TOK_IDF = gen_anon_idf();
+			break;
+		case STRING:
+			dotp->tk_data.tk_str = (struct string *)
+						Malloc(sizeof (struct string));
+			dotp->TOK_SLE = 1;
+			dotp->TOK_STR = Salloc("", 1);
+			break;
+		case INTEGER:
+			dotp->TOK_INT = 1;
+			break;
+		case REAL:
+			dotp->TOK_REL = Salloc("0.0", 4);
+			break;
+		}
 	}
 	else if (tk  < 0) {
 		error("garbage at end of program");
@@ -33,31 +56,3 @@ LLmessage(tk)
 	else	error("%s deleted", symbol2str(dot.tk_symb));
 }
 
-insert_token(tk)
-	int tk;
-{
-	register struct token *dotp = &dot;
-
-	aside = *dotp;
-
-	dotp->tk_symb = tk;
-
-	switch (tk)	{
-	/* The operands need some body */
-	case IDENT:
-		dotp->TOK_IDF = gen_anon_idf();
-		break;
-	case STRING:
-		dotp->tk_data.tk_str = (struct string *)
-					Malloc(sizeof (struct string));
-		dotp->TOK_SLE = 1;
-		dotp->TOK_STR = Salloc("", 1);
-		break;
-	case INTEGER:
-		dotp->TOK_INT = 1;
-		break;
-	case REAL:
-		dotp->TOK_REL = Salloc("0.0", 4);
-		break;
-	}
-}

lang/m2/comp/Makefile

@@ -141,8 +141,8 @@ type.o: LLlex.h const.h debug.h debugcst.h def.h idf.h maxset.h node.h scope.h t
 def.o: LLlex.h Lpars.h debug.h debugcst.h def.h idf.h main.h node.h scope.h type.h
 scope.o: LLlex.h debug.h debugcst.h def.h idf.h node.h scope.h type.h
 misc.o: LLlex.h f_info.h idf.h misc.h node.h
-enter.o: LLlex.h debug.h debugcst.h def.h idf.h main.h node.h scope.h type.h
+enter.o: LLlex.h debug.h debugcst.h def.h idf.h main.h misc.h node.h scope.h type.h
-defmodule.o: LLlex.h Lpars.h debug.h debugcst.h def.h f_info.h idf.h input.h inputtype.h main.h node.h scope.h type.h
+defmodule.o: LLlex.h Lpars.h debug.h debugcst.h def.h f_info.h idf.h input.h inputtype.h main.h misc.h node.h scope.h type.h
 typequiv.o: LLlex.h debug.h debugcst.h def.h node.h type.h warning.h
 node.o: LLlex.h debug.h debugcst.h def.h node.h type.h
 cstoper.o: LLlex.h Lpars.h debug.h debugcst.h idf.h node.h standards.h target_sizes.h type.h warning.h

lang/m2/comp/chk_expr.c

@@ -994,23 +994,24 @@ ChkStandard(expp, left)
 		/* Now, make it look like a call to ALLOCATE or DEALLOCATE */
 		{
 			struct token dt;
+			register struct token *tk = &dt;
 			struct node *nd;
 
-			dt.TOK_INT = PointedtoType(left->nd_type)->tp_size;
+			tk->TOK_INT = PointedtoType(left->nd_type)->tp_size;
-			dt.tk_symb = INTEGER;
+			tk->tk_symb = INTEGER;
-			dt.tk_lineno = left->nd_lineno;
+			tk->tk_lineno = left->nd_lineno;
 			nd = MkLeaf(Value, &dt);
 			nd->nd_type = card_type;
-			dt.tk_symb = ',';
+			tk->tk_symb = ',';
-			arg->nd_right = MkNode(Link, nd, NULLNODE, &dt);
+			arg->nd_right = MkNode(Link, nd, NULLNODE, tk);
 			/* Ignore other arguments to NEW and/or DISPOSE ??? */
 
 			FreeNode(expp->nd_left);
-			dt.tk_symb = IDENT;
+			tk->tk_symb = IDENT;
-			dt.tk_lineno = expp->nd_left->nd_lineno;
+			tk->tk_lineno = expp->nd_left->nd_lineno;
-			dt.TOK_IDF = str2idf(std == S_NEW ?
+			tk->TOK_IDF = str2idf(std == S_NEW ?
 						"ALLOCATE" : "DEALLOCATE", 0);
-			expp->nd_left = MkLeaf(Name, &dt);
+			expp->nd_left = MkLeaf(Name, tk);
 		}
 		return ChkCall(expp);
 
@@ -1145,7 +1146,7 @@ ChkCast(expp, left)
 }
 
 TryToString(nd, tp)
-	struct node *nd;
+	register struct node *nd;
 	struct type *tp;
 {
 	/*	Try a coercion from character constant to string.

lang/m2/comp/code.c

@@ -401,16 +401,7 @@ CodeParameters(param, arg)
 		return;
 	}
 	if (left_type->tp_fund == T_STRING) {
-		register arith szarg = WA(left_type->tp_size);
+		CodePString(left, tp);
-		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);
@@ -418,6 +409,22 @@ CodeParameters(param, arg)
 	CodeCoercion(left_type, tp);
 }
 
+CodePString(nd, tp)
+	struct node *nd;
+	struct type *tp;
+{
+	arith szarg = WA(nd->nd_type->tp_size);
+	register arith zersz = WA(tp->tp_size) - szarg;
+
+	if (zersz) {
+		/* null padding required */
+		assert(zersz > 0);
+		C_zer(zersz);
+	}
+	CodeString(nd);	/* push address of string */
+	C_loi(szarg);
+}
+
 CodeStd(nd)
 	struct node *nd;
 {
@@ -731,8 +738,8 @@ CodeOper(expr, true_label, false_label)
 			C_cmi(tp->tp_size);
 			break;
 		case T_POINTER:
-		case T_EQUAL:
 		case T_HIDDEN:
+		case T_EQUAL:
 		case T_CARDINAL:
 		case T_INTORCARD:
 			C_cmu(tp->tp_size);

lang/m2/comp/declar.g

@@ -116,10 +116,15 @@ TypeDeclaration
 {
 	struct def *df;
 	struct type *tp;
+	struct node *nd;
 }:
-	IDENT		{ df = define(dot.TOK_IDF, CurrentScope, D_TYPE); }
+	IDENT		{ df = define(dot.TOK_IDF, CurrentScope, D_TYPE);
+			  nd = MkLeaf(Name, &dot);
+			}
 	'=' type(&tp)
-			{ DeclareType(df, tp); }
+			{ DeclareType(nd, df, tp);
+			  free_node(nd);
+			}
 ;
 
 type(struct type **ptp;):
@@ -239,7 +244,11 @@ RecordType(struct type **ptp;)
 		  close_scope(0);
 		}
 	FieldListSequence(scope, &size, &xalign)
-		{ *ptp = standard_type(T_RECORD, xalign, size);
+		{ if (size == 0) {
+			warning(W_ORDINARY, "empty record declaration");
+			size = 1;
+		  }
+		  *ptp = standard_type(T_RECORD, xalign, size);
 		  (*ptp)->rec_scope = scope;
 		}
 	END

lang/m2/comp/def.H

@@ -1,7 +1,7 @@
 /* I D E N T I F I E R   D E S C R I P T O R   S T R U C T U R E */
 
 struct module {
-	arith mo_priority;	/* priority of a module */
+	struct node *mo_priority;/* priority of a module */
 	struct scopelist *mo_vis;/* scope of this module */
 	struct node *mo_body;	/* body of this module */
 #define mod_priority	df_value.df_module.mo_priority

lang/m2/comp/enter.c

@@ -15,6 +15,7 @@
 #include	"LLlex.h"
 #include	"node.h"
 #include	"main.h"
+#include	"misc.h"
 
 struct def *
 Enter(name, kind, type, pnam)
@@ -351,14 +352,8 @@ EnterExportList(Idlist, qualified)
 				}
 				if (df1->df_kind == D_HIDDEN &&
 				    df->df_kind == D_TYPE) {
-					if (df->df_type->tp_fund != T_POINTER) {
+					DeclareType(idlist, df1, df->df_type);
-						node_error(idlist,
-"opaque type \"%s\" is not a pointer type",
-							df->df_idf->id_text);
-					}
-					assert(df1->df_type->next == NULLTYPE);
 					df1->df_kind = D_TYPE;
-					df1->df_type->next = df->df_type;
 					continue;
 				}
 			}
@@ -379,6 +374,7 @@ EnterFromImportList(Idlist, FromDef, FromId)
 	register struct node *idlist = Idlist;
 	register struct scopelist *vis;
 	register struct def *df;
+	char *module_name = FromDef->df_idf->id_text;
 	int forwflag = 0;
 
 	switch(FromDef->df_kind) {
@@ -399,27 +395,31 @@ EnterFromImportList(Idlist, FromDef, FromId)
 	case D_MODULE:
 		vis = FromDef->mod_vis;
 		if (vis == CurrVis) {
-node_error(FromId, "cannot import from current module \"%s\"",
+node_error(FromId, "cannot import from current module \"%s\"", module_name);
-		        	FromDef->df_idf->id_text);
 			return;
 		}
 		break;
 	default:
-node_error(FromId, "identifier \"%s\" does not represent a module",
+node_error(FromId,"identifier \"%s\" does not represent a module",module_name);
-		       FromDef->df_idf->id_text);
 		return;
 	}
 
 	for (; idlist; idlist = idlist->next) {
 		if (forwflag) df = ForwDef(idlist, vis->sc_scope);
 		else if (! (df = lookup(idlist->nd_IDF, vis->sc_scope, 1))) {
-		    not_declared("identifier", idlist, " in qualifying module");
+			if (! is_anon_idf(idlist->nd_IDF)) {
-		    df = define(idlist->nd_IDF,vis->sc_scope,D_ERROR);
+				node_error(idlist,
+			"identifier \"%s\" not declared in module \"%s\"",
+					idlist->nd_IDF->id_text,
+					module_name);
+			}
+			df = define(idlist->nd_IDF,vis->sc_scope,D_ERROR);
 		}
 		else if (! (df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
 			node_error(idlist,
-			"identifier \"%s\" not exported from qualifying module",
+			"identifier \"%s\" not exported from module \"%s\"",
-			idlist->nd_IDF->id_text);
+			idlist->nd_IDF->id_text,
+			module_name);
 			df->df_flags |= D_QEXPORTED;
 		}
 		DoImport(df, CurrentScope);

lang/m2/comp/main.c

@@ -81,15 +81,15 @@ Compile(src, dst)
 		return 1;
 	}
 #endif DEBUG
-	open_scope(CLOSEDSCOPE);
+	open_scope(OPENSCOPE);
-	GlobalScope = CurrentScope;
+	GlobalVis = CurrVis;
+	close_scope(0);
 	C_init(word_size, pointer_size);
 	if (! C_open(dst)) fatal("could not open output file");
 	C_magic();
 	C_ms_emx(word_size, pointer_size);
 	CompUnit();
 	C_ms_src((arith) (LineNumber - 1), FileName);
-	close_scope(SC_REVERSE);
 	if (!err_occurred) {
 		C_exp(Defined->mod_vis->sc_scope->sc_name);
 		WalkModule(Defined);

lang/m2/comp/program.g

@@ -44,7 +44,7 @@ ModuleDeclaration
 	int qualified;
 } :
 	MODULE IDENT	{ df = DefineLocalModule(dot.TOK_IDF); }
-	priority(&(df->mod_priority))?
+	priority(df)
 	';'
 	import(1)*
 	export(&qualified, &exportlist)?
@@ -57,19 +57,21 @@ ModuleDeclaration
 			}
 ;
 
-priority(arith *pprio;)
+priority(register struct def *df;)
 {
 	register struct node *nd;
-	struct node *nd1;		/* &nd is illegal */
 } :
-	'[' ConstExpression(&nd1) ']'
+	[
-			{ nd = nd1;
+		'[' ConstExpression(&(df->mod_priority)) ']'
-			  if (!(nd->nd_type->tp_fund & T_CARDINAL)) {
+			{ if (!(df->mod_priority->nd_type->tp_fund &
-				node_error(nd, "illegal priority");
+				T_CARDINAL)) {
+				node_error(df->mod_priority,
+					   "illegal priority");
 			  }
-			  *pprio = nd->nd_INT;
-			  FreeNode(nd);
 			}
+	|
+			{ df->mod_priority = 0; }
+	]
 ;
 
 export(int *QUALflag; struct node **ExportList;):
@@ -121,7 +123,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, 1, (arith) 0);
+			  df->df_type = standard_type(T_RECORD, 1, (arith) 1);
 			  df->df_type->rec_scope = df->mod_vis->sc_scope;
 			  DefinitionModule++;
 			}
@@ -194,14 +196,14 @@ ProgramModule
 			RemoveImports(&(CurrentScope->sc_def));
 		  }
 		  else {
-			Defined = df = define(dot.TOK_IDF, CurrentScope, D_MODULE);
+			Defined = df = define(dot.TOK_IDF, GlobalScope, D_MODULE);
 			open_scope(CLOSEDSCOPE);
 			df->mod_vis = CurrVis;
 			CurrentScope->sc_name = "_M2M";
 		  }
 		  CurrentScope->sc_definedby = df;
 		}
-	priority(&(df->mod_priority))?
+	priority(df)
 	';' import(0)*
 	block(&(df->mod_body)) IDENT
 		{ close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);

lang/m2/comp/scope.C

@@ -14,8 +14,8 @@
 #include	"def.h"
 #include	"node.h"
 
-struct scope *PervasiveScope, *GlobalScope;
+struct scope *PervasiveScope;
-struct scopelist *CurrVis;
+struct scopelist *CurrVis, *GlobalVis;
 extern int proclevel;
 static struct scopelist *PervVis;
 extern char options[];
@@ -85,9 +85,14 @@ chk_proc(df)
 {
 	/*	Called at scope closing. Check all definitions, and if one
 		is a D_PROCHEAD, the procedure was not defined.
+		Also check that hidden types are defined.
 	*/
 	while (df) {
-		if (df->df_kind == D_PROCHEAD) {
+		if (df->df_kind == D_HIDDEN) {
+			error("hidden type \"%s\" not declared",
+				df->df_idf->id_text);
+		}
+		else if (df->df_kind == D_PROCHEAD) {
 			/* A not defined procedure
 			*/
 			error("procedure \"%s\" not defined",
@@ -121,6 +126,7 @@ 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);
+			continue;
 		}
 		else if (df->df_kind == D_FTYPE) {
 			df->df_kind = D_TYPE;

lang/m2/comp/scope.h

@@ -30,13 +30,13 @@ struct scopelist {
 };
 
 extern struct scope
-	*PervasiveScope,
+	*PervasiveScope;
-	*GlobalScope;
 
 extern struct scopelist
-	*CurrVis;
+	*CurrVis, *GlobalVis;
 
 #define CurrentScope	(CurrVis->sc_scope)
+#define GlobalScope	(GlobalVis->sc_scope)
 #define enclosing(x)	((x)->sc_encl)
 #define scopeclosed(x)	((x)->sc_scopeclosed)
 #define nextvisible(x)	((x)->next)		/* use with scopelists */

lang/m2/comp/tokenname.c

@@ -14,7 +14,7 @@
 struct tokenname tkspec[] =	{	/* the names of the special tokens */
 	{IDENT, "identifier"},
 	{STRING, "string"},
-	{INTEGER, "integer"},
+	{INTEGER, "number"},
 	{REAL, "real"},
 	{0, ""}
 };

lang/m2/comp/type.c

@@ -473,9 +473,10 @@ FreeType(tp)
 	free_type(tp);
 }
 
-DeclareType(df, tp)
+DeclareType(nd, df, tp)
 	register struct def *df;
 	register struct type *tp;
+	struct node *nd;
 {
 	/*	A type with type-description "tp" is declared and must
 		be bound to definition "df".
@@ -486,7 +487,9 @@ DeclareType(df, tp)
 
 	if (df->df_type && df->df_type->tp_fund == T_HIDDEN) {
 	  	if (! (tp->tp_fund & (T_POINTER|T_HIDDEN|T_EQUAL))) {
-error("opaque type \"%s\" is not a pointer type", df->df_idf->id_text);
+			node_error(nd,
+				   "opaque type \"%s\" is not a pointer type",
+				   df->df_idf->id_text);
 		}
 		df->df_type->next = tp;
 		df->df_type->tp_fund = T_EQUAL;
@@ -495,7 +498,9 @@ error("opaque type \"%s\" is not a pointer type", df->df_idf->id_text);
 		}
 		if (tp == df->df_type) {
 			/* Circular definition! */
-error("opaque type \"%s\" has a circular definition", df->df_idf->id_text);
+			node_error(nd,
+				 "opaque type \"%s\" has a circular definition",
+				 df->df_idf->id_text);
 		}
 	}
 	else	df->df_type = tp;

lang/m2/comp/walk.c

@@ -34,10 +34,29 @@ label		data_label;
 static struct type *func_type;
 struct withdesig *WithDesigs;
 struct node	*Modules;
+static struct node	*priority;
 
 #define	NO_EXIT_LABEL	((label) 0)
 #define RETURN_LABEL	((label) 1)
 
+STATIC
+DoPriority()
+{
+	if (priority) {
+		C_loc(priority->nd_INT);
+		C_cal("_stackprio");
+		C_asp(word_size);
+	}
+}
+
+STATIC
+EndPriority()
+{
+	if (priority) {
+		C_cal("_unstackprio");
+	}
+}
+
 STATIC
 DoProfil()
 {
@@ -67,6 +86,7 @@ WalkModule(module)
 	struct scopelist *savevis = CurrVis;
 
 	CurrVis = module->mod_vis;
+	priority = module->mod_priority;
 	sc = CurrentScope;
 
 	/* Walk through it's local definitions
@@ -81,6 +101,7 @@ WalkModule(module)
 	text_label = 1;		/* label at end of initialization routine */
 	TmpOpen(sc);		/* Initialize for temporaries */
 	C_pro_narg(sc->sc_name);
+	DoPriority();
 	DoProfil();
 	if (module == Defined) {
 		/* Body of implementation or program module.
@@ -113,6 +134,7 @@ WalkModule(module)
 	DO_DEBUG(options['X'], PrNode(module->mod_body, 0));
 	WalkNode(module->mod_body, NO_EXIT_LABEL);
 	C_df_ilb(RETURN_LABEL);
+	EndPriority();
 	C_ret((arith) 0);
 	C_end(-sc->sc_off);
 	proclevel--;
@@ -146,6 +168,7 @@ WalkProcedure(procedure)
 	/* Generate code for this procedure
 	*/
 	C_pro_narg(sc->sc_name);
+	DoPriority();
 	DoProfil();
 	TmpOpen(sc);
 
@@ -277,6 +300,7 @@ WalkProcedure(procedure)
 			C_ass(word_size);
 		}
 		C_lae_dlb(func_res_label, (arith) 0);
+		EndPriority();
 		C_ret(pointer_size);
 	}
 	else if (tp) {
@@ -292,6 +316,7 @@ WalkProcedure(procedure)
 			C_lal(retsav);
 			C_loi(func_res_size);
 		}
+		EndPriority();
 		C_ret(func_res_size);
 	}
 	else	{
@@ -299,6 +324,7 @@ WalkProcedure(procedure)
 			C_lol(StackAdjustment);
 			C_ass(word_size);
 		}
+		EndPriority();
 		C_ret((arith) 0);
 	}
 	if (StackAdjustment) FreeInt(StackAdjustment);
@@ -324,7 +350,7 @@ WalkDef(df)
 			WalkProcedure(df);
 			break;
 		case D_VARIABLE:
-			if (!proclevel) {
+			if (!proclevel  && !df->var_addrgiven) {
 				C_df_dnam(df->var_name);
 				C_bss_cst(
 					WA(df->df_type->tp_size),
@@ -554,11 +580,7 @@ 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);
+				CodePString(right, func_type);
-
-				C_zer(WA(func_type->tp_size) - strsize);
-				CodePExpr(right);
-				C_loi(strsize);
 			}
 			else	CodePExpr(right);
 		}