some fixes, and changed priority of unary minus

lang/m2/comp/LLlex.c

@@ -24,6 +24,7 @@
 #include	"Lpars.h"
 #include	"class.h"
 #include	"idf.h"
+#include	"def.h"
 #include	"type.h"
 #include	"LLlex.h"
 #include	"const.h"
@@ -62,7 +63,7 @@ SkipComment()
 			   of the names. Also, don't generate call to
 			   initialization routine.
 			*/
-			ForeignFlag = 1;
+			ForeignFlag = D_FOREIGN;
 			break;
 		}
 	}
@@ -231,8 +232,6 @@ LLlex()
 		return tk->tk_symb;
 	}
 
-	tk->tk_lineno = LineNumber;
-
 again1:
 	if (eofseen) {
 		eofseen = 0;
@@ -247,6 +246,8 @@ again:
 		}
 	}
 
+	tk->tk_lineno = LineNumber;
+
 	switch (class(ch))	{
 
 	case STNL:
@@ -254,7 +255,6 @@ again:
 #ifdef DEBUG
 		cntlines++;
 #endif
-		tk->tk_lineno++;
 		CheckForLineDirective();
 		goto again1;
 

lang/m2/comp/Makefile

@@ -158,6 +158,7 @@ LLlex.o: class.h
 LLlex.o: const.h
 LLlex.o: debug.h
 LLlex.o: debugcst.h
+LLlex.o: def.h
 LLlex.o: f_info.h
 LLlex.o: idf.h
 LLlex.o: idfsize.h

lang/m2/comp/chk_expr.c

@@ -758,6 +758,10 @@ ChkBinOper(expp)
 	   - The IN-operator has as right-hand-size operand a set.
 	*/
 	if (expp->nd_symb == IN) {
+		if (tpr->tp_fund != T_SET) {
+			node_error(expp, "\"IN\": right operand must be a set");
+			return 0;
+		}
 		if (!TstAssCompat(tpl, ElementType(tpr))) {
 			/* Assignment compatible ???
 			   I don't know! Should we be allowed to check
@@ -831,12 +835,13 @@ ChkUnOper(expp)
 
 	switch(expp->nd_symb) {
 	case '+':
-		if (tpr->tp_fund & T_NUMERIC) {
+		if (!(tpr->tp_fund & T_NUMERIC)) break;
-			*expp = *right;
+		/* fall through */
-			free_node(right);
+
-			return 1;
+	case '(':
-		}
+		*expp = *right;
-		break;
+		free_node(right);
+		return 1;
 
 	case '-':
 		if (tpr->tp_fund & T_INTORCARD) {

lang/m2/comp/code.c

@@ -396,8 +396,14 @@ CodeParameters(param, arg)
 		return;
 	}
 	CodePExpr(left);
-	RangeCheck(tp, left_type);
+	CodeCheckExpr(left, tp);
-	CodeCoercion(left_type, tp);
+}
+
+CodeCheckExpr(tp1, tp2)
+	struct type *tp1, *tp2;
+{
+	CodeCoercion(tp1, tp2);
+	RangeCheck(tp2, tp1);
 }
 
 CodePString(nd, tp)
@@ -749,6 +755,7 @@ CodeOper(expr, true_label, false_label)
 				C_dup(2*tp->tp_size);
 				C_asp(tp->tp_size);
 				C_ior(tp->tp_size);
+				expr->nd_symb = '=';
 			}
 			else if (expr->nd_symb == LESSEQUAL) {
 				/* A <= B is the same as A - B = {}
@@ -756,6 +763,7 @@ CodeOper(expr, true_label, false_label)
 				C_com(tp->tp_size);
 				C_and(tp->tp_size);
 				C_zer(tp->tp_size);
+				expr->nd_symb = '=';
 			}
 			C_cms(tp->tp_size);
 			break;

lang/m2/comp/cstoper.c

@@ -262,6 +262,7 @@ cstset(expp)
 		expp->nd_INT = (i >= 0 && i < setsize * wrd_bits &&
 		    (set2[i / wrd_bits] & (1 << (i % wrd_bits))));
 		free((char *) set2);
+		expp->nd_symb = INTEGER;
 	}
 	else {
 		set1 = expp->nd_left->nd_set;

lang/m2/comp/declar.g

@@ -169,7 +169,7 @@ SimpleType(register struct type **ptp;)
 		/* The subrange type is given a base type by the
 		   qualident (this is new modula-2).
 		*/
-			{ chk_basesubrange(tp, *ptp); }
+			{ chk_basesubrange(tp, *ptp); *ptp = tp; }
 	]
 |
 	enumeration(ptp)

lang/m2/comp/def.H

@@ -33,7 +33,7 @@ struct constant {
 };
 
 struct enumval {
-	unsigned int en_val;	/* value of this enumeration literal */
+	arith en_val;	/* value of this enumeration literal */
 	struct def *en_next;	/* next enumeration literal */
 #define enm_val		df_value.df_enum.en_val
 #define enm_next	df_value.df_enum.en_next

lang/m2/comp/defmodule.c

@@ -92,6 +92,8 @@ GetDefinitionModule(id, incr)
 	register struct def *df;
 	static int level;
 	struct scopelist *vis;
+	char *fn = FileName;
+	int ln = LineNumber;
 
 	level += incr;
 	df = lookup(id, GlobalScope, 1);
@@ -109,6 +111,7 @@ GetDefinitionModule(id, incr)
 			ForeignFlag = 0;
 			open_scope(CLOSEDSCOPE);
 			if (!is_anon_idf(id) && GetFile(id->id_text)) {
+
 				DefModule();
 				df = lookup(id, GlobalScope, 1);
 				if (level == 1 &&
@@ -152,6 +155,8 @@ GetDefinitionModule(id, incr)
 		error("cannot import from currently defined module");
 		df->df_kind = D_ERROR;
 	}
+	FileName = fn;
+	LineNumber = ln;
 	assert(df);
 	level -= incr;
 	return df;

lang/m2/comp/expression.g

@@ -29,6 +29,7 @@
 extern char	options[];
 }
 
+/* inline, we need room for pdp/11
 number(struct node **p;) :
 [
 	%default
@@ -39,6 +40,7 @@ number(struct node **p;) :
 			  (*p)->nd_type = toktype;
 			}
 ;
+*/
 
 qualident(struct node **p;)
 {
@@ -112,21 +114,28 @@ relation:
 
 SimpleExpression(struct node **pnd;)
 {
+	register struct node *nd = 0;
 } :
 	[
 		[ '+' | '-' ]
-			{ *pnd = MkLeaf(Uoper, &dot);
+			{ nd = MkLeaf(Uoper, &dot);
-			  pnd = &((*pnd)->nd_right);
 			  /* priority of unary operator ??? */
 			}
 	]?
 	term(pnd)
+			{ if (nd) {
+				nd->nd_right = *pnd;
+				*pnd = nd;
+			  }
+			  nd = *pnd;
+			}
 	[
 		/* AddOperator */
 		[ '+' | '-' | OR ]
-			{ *pnd = MkNode(Oper, *pnd, NULLNODE, &dot); }
+			{ nd = MkNode(Oper, nd, NULLNODE, &dot); }
-		term(&((*pnd)->nd_right))
+		term(&(nd->nd_right))
 	]*
+			{ *pnd = nd; }
 ;
 
 /* Inline in "SimpleExpression"
@@ -171,13 +180,35 @@ factor(register struct node **p;)
 |
 	bare_set(p)
 | %default
-	number(p)
+	[
+		%default
+		INTEGER
+	|
+		REAL
+	|
+		STRING
+	]		{ *p = MkLeaf(Value, &dot);
+			  (*p)->nd_type = toktype;
+			}
 |
-	STRING	{ *p = MkLeaf(Value, &dot);
+	'(' 	{ nd = MkLeaf(Uoper, &dot); }
-		  (*p)->nd_type = toktype;
+	expression(p)
+		{ /*	In some cases we must leave the '(' as an unary
+			operator, because otherwise we cannot see that the
+			factor was not a designator
+		  */
+		  register int class = (*p)->nd_class;
+
+		  if (class == Arrsel ||
+		      class == Arrow ||
+		      class == Name ||
+		      class == Link) {
+			nd->nd_right = *p;
+			*p = nd;
+		  }
+		  else free_node(nd);
 		}
-|
+	')'
-	'(' expression(p) ')'
 |
 	NOT		{ *p = MkLeaf(Uoper, &dot); }
 	factor(&((*p)->nd_right))
@@ -204,7 +235,7 @@ ActualParameters(struct node **pnd;):
 	'(' ExpList(pnd)? ')'
 ;
 
-element(struct node *nd;)
+element(register struct node *nd;)
 {
 	struct node *nd1;
 } :
@@ -235,17 +266,23 @@ designator_tail(struct node **pnd;):
 	]*
 ;
 
-visible_designator_tail(register struct node **pnd;):
+visible_designator_tail(struct node **pnd;)
-	'['		{ *pnd = MkNode(Arrsel, *pnd, NULLNODE, &dot); }
+{
-		expression(&((*pnd)->nd_right))
+	register struct node *nd = *pnd;
+}:
+[
+	'['		{ nd = MkNode(Arrsel, nd, NULLNODE, &dot); }
+		expression(&(nd->nd_right))
 		[
 			','
-			{ *pnd = MkNode(Arrsel, *pnd, NULLNODE, &dot);
+			{ nd = MkNode(Arrsel, nd, NULLNODE, &dot);
-			  (*pnd)->nd_symb = '[';
+			  nd->nd_symb = '[';
 			}
-			expression(&((*pnd)->nd_right))
+			expression(&(nd->nd_right))
 		]*
 	']'
 |
-	'^'		{ *pnd = MkNode(Arrow, NULLNODE, *pnd, &dot); }
+	'^'		{ nd = MkNode(Arrow, NULLNODE, nd, &dot); }
+]
+			{ *pnd = nd; }
 ;

lang/m2/comp/program.g

@@ -129,7 +129,7 @@ DefinitionModule
 	DEFINITION
 	MODULE IDENT	{ df = define(dot.TOK_IDF, GlobalScope, D_MODULE);
 			  df->df_flags |= D_BUSY;
-			  if (ForeignFlag) df->df_flags |= D_FOREIGN;
+			  df->df_flags |= ForeignFlag;
 			  if (!Defined) Defined = df;
 		  	  CurrentScope->sc_definedby = df;
 			  if (df->df_idf != DefId) {

lang/m2/comp/type.H

@@ -20,7 +20,7 @@ struct paramlist {		/* structure for parameterlist of a PROCEDURE */
 
 struct enume {
 	struct def *en_enums;	/* Definitions of enumeration literals */
-	unsigned int en_ncst;	/* Number of constants */
+	arith en_ncst;		/* Number of constants */
 	label en_rck;		/* Label of range check descriptor */
 #define enm_enums	tp_value.tp_enum.en_enums
 #define enm_ncst	tp_value.tp_enum.en_ncst

lang/m2/comp/type.c

@@ -231,6 +231,9 @@ enum_type(EnumList)
 		standard_type(T_ENUMERATION, int_align, int_size);
 
 	EnterEnumList(EnumList, tp);
+	if (! fit(tp->enm_ncst, (int) int_size)) {
+		node_error(EnumList, "too many enumeration literals");
+	}
 	u_small(tp, (arith) (tp->enm_ncst-1));
 	return tp;
 }

lang/m2/comp/walk.c

@@ -760,8 +760,7 @@ DoAssign(nd, left, right)
 	}
 	else {
 		CodeValue(&dsr, rtp->tp_size, rtp->tp_align);
-		CodeCoercion(rtp, ltp);
+		CodeCheckExpr(rtp, ltp);
-		RangeCheck(ltp, rtp);
 	}
 	CodeMove(&dsr, left, rtp);
 }