made to fit on PDP-11 again, and some other minor mods

lang/m2/comp/LLlex.c

@@ -82,10 +82,10 @@ SkipComment()
 				options[ch] = !on_on_minus;
 				break;
 			}
+			ch = c;
 		}
 			/* fall through */
 		default:
-			PushBack();
 			break;
 		}
 	}
@@ -152,7 +152,8 @@ GetString(upto)
 		}
 	}
 	str->s_length = p - str->s_str;
-	while (p - str->s_str < len) *p++ = '\0';
+	*p = '\0';
+	str->s_str = Realloc(str->s_str, (unsigned)(str->s_length) + 1);
 	if (str->s_length == 0) str->s_length = 1;
 	/* ??? string length at least 1 ??? */
 	return str;
@@ -236,6 +237,13 @@ CheckForLineDirective()
 	LineNumber = i;
 }
 
+static
+UnloadChar(ch)
+{
+	if (ch == EOI) eofseen = 1;
+	else PushBack();
+}
+	
 int
 LLlex()
 {
@@ -297,8 +305,7 @@ again:
 				SkipComment();
 				goto again;
 			}
-			else if (nch == EOI) eofseen = 1;
+			UnloadChar(nch);
-			else PushBack();
 		}
 		if (ch == '&') return tk->tk_symb = AND;
 		if (ch == '~') return tk->tk_symb = NOT;
@@ -338,8 +345,7 @@ again:
 		default :
 			crash("(LLlex, STCOMP)");
 		}
-		if (nch == EOI) eofseen = 1;
+		UnloadChar(nch);
-		else PushBack();
 		return tk->tk_symb = ch;
 
 	case STIDF:
@@ -355,8 +361,7 @@ again:
 			LoadChar(ch);
 		} while(in_idf(ch));
 
-		if (ch == EOI) eofseen = 1;
+		UnloadChar(ch);
-		else PushBack();
 		*tag = '\0';
 		if (*(tag - 1) == '_') {
 			lexerror("last character of an identifier may not be an underscore");
@@ -377,10 +382,10 @@ again:
 		}
 		else {
 			tk->tk_data.tk_str = str;
-			if (! fit(str->s_length, (int) word_size)) {
+			if (! fit((arith)(str->s_length), (int) word_size)) {
 				lexerror("string too long");
 			}
-			toktype = standard_type(T_STRING, 1, str->s_length);
+			toktype = standard_type(T_STRING, 1, (arith)(str->s_length));
 		}
 		return tk->tk_symb = STRING;
 		}
@@ -429,8 +434,7 @@ again:
 				else {
 					state = End;
 					if (ch == 'H') base = 16;
-					else if (ch == EOI) eofseen = 1;
+					UnloadChar(ch);
-					else PushBack();
 				}
 				break;
 
@@ -456,8 +460,7 @@ again:
 				state = End;
 				if (ch != 'H') {
 					lexerror("H expected after hex number");
-					if (ch == EOI) eofseen = 1;
+					UnloadChar(ch);
-					else PushBack();
 				}
 				break;
 
@@ -473,8 +476,7 @@ again:
 					state = Hex;
 					break;
 				}
-				if (ch == EOI) eofseen = 1;
+				UnloadChar(ch);
-				else PushBack();
 				ch = *--np;
 				*np++ = '\0';
 				base = 8;
@@ -593,8 +595,7 @@ lexwarning(W_ORDINARY, "overflow in constant");
 
 noscale:
 		*np++ = '\0';
-		if (ch == EOI) eofseen = 1;
+		UnloadChar(ch);
-		else PushBack();
 
 		if (np >= &buf[NUMSIZE]) {
 			tk->TOK_REL = Salloc("0.0", 5);

lang/m2/comp/LLlex.h

@@ -12,7 +12,7 @@
 /* Structure to store a string constant
 */
 struct string {
-	arith s_length;			/* length of a string */
+	unsigned s_length;		/* length of a string */
 	char *s_str;			/* the string itself */
 };
 

lang/m2/comp/Version.c

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

lang/m2/comp/chk_expr.c

@@ -84,19 +84,12 @@ MkCoercion(pnd, tp)
 	if (nd->nd_class == Value &&
 	    nd_tp->tp_fund != T_REAL &&
 	    tp->tp_fund != T_REAL) {
-		/* Constant expression mot involving REALs */
+		/* Constant expression not involving REALs */
 		switch(tp->tp_fund) {
 		case T_SUBRANGE:
-			if (! chk_bounds(tp->sub_lb, nd->nd_INT, 
-				BaseType(tp)->tp_fund) ||
-			    ! chk_bounds(nd->nd_INT, tp->sub_ub,
-				BaseType(tp)->tp_fund)) {
-				wmess = "range bound";
-			}
-			break;
 		case T_ENUMERATION:
 		case T_CHAR:
-			if (nd->nd_INT < 0 || nd->nd_INT >= tp->enm_ncst) {
+			if (! in_range(nd->nd_INT, tp)) {
 				wmess = "range bound";
 			}
 			break;
@@ -109,12 +102,10 @@ MkCoercion(pnd, tp)
 			}
 			break;
 		case T_INTEGER:  {
-			long i = ~max_int[(int)(tp->tp_size)];
+			long i = min_int[(int)(tp->tp_size)];
 			long j = nd->nd_INT & i;
 
-			if ((nd_tp->tp_fund == T_INTEGER &&
+			if (j != 0 && (nd_tp->tp_fund != T_INTEGER || j != i)) {
-			     j != i && j != 0) ||
-			    (nd_tp->tp_fund != T_INTEGER && j)) {
 				wmess = "conversion";
 			}
 			}
@@ -377,7 +368,7 @@ ChkElement(expp, tp, set)
 	register t_node *expr = *expp;
 	t_type *el_type = ElementType(tp);
 	register unsigned int i;
-	arith lo, hi, low, high;
+	arith low, high;
 
 	if (expr->nd_class == Link && expr->nd_symb == UPTO) {
 		/* { ... , expr1 .. expr2,  ... }
@@ -407,13 +398,12 @@ ChkElement(expp, tp, set)
 		}
 		low = high = expr->nd_INT;
 	}
-	if (low > high) {
+	if (! chk_bounds(low, high, BaseType(el_type)->tp_fund)) {
 		node_error(expr, "lower bound exceeds upper bound in range");
 		return 0;
 	}
 
-	getbounds(el_type, &lo, &hi);
+	if (! in_range(low, el_type) || ! in_range(high, el_type)) {
-	if (low < lo || high > hi) {
 		node_error(expr, "set element out of range");
 		return 0;
 	}
@@ -665,17 +655,12 @@ ChkFunCall(expp)
 	/*	Check a call that must have a result
 	*/
 
-	if (! ChkCall(expp)) {
+	if (ChkCall(expp)) {
-		expp->nd_type = error_type;
+		if (expp->nd_type != 0) return 1;
-		return 0;
-	}
-
-	if (expp->nd_type == 0) {
 		node_error(expp, "function call expected");
-		expp->nd_type = error_type;
-		return 0;
 	}
-	return 1;
+	expp->nd_type = error_type;
+	return 0;
 }
 
 int

lang/m2/comp/code.c

@@ -83,7 +83,7 @@ CodeString(nd)
 		return;
 	}
 	C_df_dlb(++data_label);
-	C_rom_scon(nd->nd_STR, WA(nd->nd_SLE + 1));
+	C_rom_scon(nd->nd_STR, WA((arith)(nd->nd_SLE + 1)));
 	c_lae_dlb(data_label);
 }
 
@@ -395,7 +395,7 @@ CodeParameters(param, arg)
 			}
 		}
 		else if (left->nd_symb == STRING) {
-			C_loc(left->nd_SLE - 1);
+			C_loc((arith)(left->nd_SLE - 1));
 		}
 		else if (elem == word_type) {
 			C_loc((left_type->tp_size+word_size-1) / word_size - 1);
@@ -612,28 +612,25 @@ RangeCheck(tpl, tpr)
 	/*	Generate a range check if neccessary
 	*/
 
-	arith llo, lhi, rlo, rhi;
+	arith rlo, rhi;
 
 	if (options['R']) return;
 
 	if (bounded(tpl)) {
-		/* in this case we might need a range check */
+		/* In this case we might need a range check.
-		if (!bounded(tpr)) {
+		   If both types are restricted. check the bounds
-			/* yes, we need one */
-			genrck(tpl);
-			return;
-		}
-		/* both types are restricted. check the bounds
 		   to see wether we need a range check.
 		   We don't need one if the range of values of the
 		   right hand side is a subset of the range of values
 		   of the left hand side.
 		*/
-		getbounds(tpl, &llo, &lhi);
+		if (bounded(tpr)) {
-		getbounds(tpr, &rlo, &rhi);
+			getbounds(tpr, &rlo, &rhi);
-		if (llo > rlo || lhi < rhi) {
+			if (in_range(rlo, tpl) && in_range(rhi, tpl)) {
-			genrck(tpl);
+				return;
+			}
 		}
+		genrck(tpl);
 		return;
 	}
 	if (tpl->tp_size <= tpr->tp_size &&

lang/m2/comp/defmodule.c

@@ -41,10 +41,9 @@ getwdir(fn)
 	register char *p;
 	char *strrindex();
 
-	p = strrindex(fn, '/');
+	while ((p = strrindex(fn,'/')) && *(p + 1) == '\0') {
-	while (p && *(p + 1) == '\0') {	/* remove trailing /'s */
+		/* remove trailing /'s */
 		*p = '\0';
-		p = strrindex(fn, '/');
 	}
 
 	if (p) {
@@ -53,7 +52,7 @@ getwdir(fn)
 		*p = '/';
 		return fn;
 	}
-	else return ".";
+	return ".";
 }
 
 STATIC
@@ -101,23 +100,23 @@ GetDefinitionModule(id, incr)
 	if (!df) {
 		/* Read definition module. Make an exception for SYSTEM.
 		*/
+		extern int ForeignFlag;
+
+		ForeignFlag = 0;
 		DefId = id;
+		open_scope(CLOSEDSCOPE);
 		if (!strcmp(id->id_text, "SYSTEM")) {
 			do_SYSTEM();
 			df = lookup(id, GlobalScope, D_IMPORTED, 0);
 		}
 		else {
-			extern int ForeignFlag;
-
-			ForeignFlag = 0;
-			open_scope(CLOSEDSCOPE);
 			newsc = CurrentScope;
 			if (!is_anon_idf(id) && GetFile(id->id_text)) {
 
 				DefModule();
 				df = lookup(id, GlobalScope, D_IMPORTED, 0);
 				if (level == 1 &&
-				    (!df || !(df->df_flags & D_FOREIGN))) {
+				    (df && !(df->df_flags & D_FOREIGN))) {
 					/* The module is directly imported by
 					   the currently defined module, and
 					   is not foreign, so we have to
@@ -129,7 +128,7 @@ GetDefinitionModule(id, incr)
 					extern t_node *Modules;
 
 					n = dot2leaf(Def);
-					n->nd_def = CurrentScope->sc_definedby;
+					n->nd_def = newsc->sc_definedby;
 					if (nd_end) nd_end->nd_left = n;
 					else Modules = n;
 					nd_end = n;
@@ -140,8 +139,8 @@ GetDefinitionModule(id, incr)
 				newsc->sc_name = id->id_text;
 			}
 			vis = CurrVis;
-			close_scope(SC_CHKFORW);
 		}
+		close_scope(SC_CHKFORW);
 		if (! df) {
 			df = MkDef(id, GlobalScope, D_ERROR);
 			df->mod_vis = vis;

lang/m2/comp/main.c

@@ -236,7 +236,6 @@ do_SYSTEM()
 	*/
 	static char systemtext[] = SYSTEMTEXT;
 
-	open_scope(CLOSEDSCOPE);
 	EnterType("WORD", word_type);
 	EnterType("BYTE", byte_type);
 	EnterType("ADDRESS",address_type);
@@ -245,7 +244,6 @@ do_SYSTEM()
 		fatal("could not insert text");
 	}
 	DefModule();
-	close_scope(SC_CHKFORW);
 }
 
 #ifdef DEBUG

lang/m2/comp/type.H

@@ -206,12 +206,15 @@ extern t_type
 					(tpx)->tp_next)
 #define PointedtoType(tpx)	(assert((tpx)->tp_fund == T_POINTER),\
 					(tpx)->tp_next)
+#define SubBaseType(tpx)	(assert((tpx)->tp_fund == T_SUBRANGE), \
+					(tpx)->tp_next)
 #else DEBUG
 #define ResultType(tpx)		((tpx)->tp_next)
 #define ParamList(tpx)		((tpx)->prc_params)
 #define IndexType(tpx)		((tpx)->tp_next)
 #define ElementType(tpx)	((tpx)->tp_next)
 #define PointedtoType(tpx)	((tpx)->tp_next)
+#define SubBaseType(tpx)	((tpx)->tp_next)
 #endif DEBUG
 #define BaseType(tpx)		((tpx)->tp_fund == T_SUBRANGE ? (tpx)->tp_next : \
 					(tpx))

lang/m2/comp/type.c

@@ -291,31 +291,25 @@ chk_basesubrange(tp, base)
 		/* Check that the bounds of "tp" fall within the range
 		   of "base".
 		*/
-		int fund = base->tp_next->tp_fund;
+		if (! in_range(tp->sub_lb, base) || 
-
+		    ! in_range(tp->sub_ub, base)) {
-		if (! chk_bounds(base->sub_lb, tp->sub_lb, fund) || 
-		    ! chk_bounds(tp->sub_ub, base->sub_ub, fund)) {
 			error("base type has insufficient range");
 		}
 		base = base->tp_next;
 	}
 
-	if (base->tp_fund & (T_ENUMERATION|T_CHAR)) {
+	if ((base->tp_fund & (T_ENUMERATION|T_CHAR)) || base == card_type) {
 		if (tp->tp_next != base) {
 			error("specified base does not conform");
 		}
 	}
-	else if (base != card_type && base != int_type) {
+	else if (base == int_type) {
-		error("illegal base for a subrange");
+		if (tp->tp_next == card_type &&
+		    ! chk_bounds(tp->sub_ub,max_int[(int)int_size],T_CARDINAL)){
+			error("upperbound to large for type INTEGER");
+		}
 	}
-	else if (base == int_type && tp->tp_next == card_type &&
+	else	error("illegal base for a subrange");
-		 (tp->sub_ub > max_int[(int) word_size] || tp->sub_ub < 0)) {
-		error("upperbound to large for type INTEGER");
-	}
-	else if (base != tp->tp_next && base != int_type) {
-		error("specified base does not conform");
-	}
-
 	tp->tp_next = base;
 }
 
@@ -334,6 +328,28 @@ chk_bounds(l1, l2, fund)
 	       );
 }
 
+int
+in_range(i, tp)
+	arith		i;
+	register t_type	*tp;
+{
+	/*	Check that the value i fits in the subrange or enumeration
+		type tp.  Return 1 if so, 0 otherwise
+	*/
+
+	switch(tp->tp_fund) {
+	case T_ENUMERATION:
+	case T_CHAR:
+		return i >= 0 && i < tp->enm_ncst;
+
+	case T_SUBRANGE:
+		return	chk_bounds(i, tp->sub_ub, SubBaseType(tp)->tp_fund) &&
+			chk_bounds(tp->sub_lb, i, SubBaseType(tp)->tp_fund);
+	}
+	assert(0);
+	/*NOTREACHED*/
+}
+
 t_type *
 subr_type(lb, ub)
 	register t_node *lb;
@@ -536,7 +552,7 @@ ArraySizes(tp)
 	/*	Assign sizes to an array type, and check index type
 	*/
 	register t_type *index_type = IndexType(tp);
-	arith lo, hi, diff;
+	arith diff;
 
 	ArrayElSize(tp);
 
@@ -548,10 +564,8 @@ ArraySizes(tp)
 		return;
 	}
 
-	getbounds(index_type, &lo, &hi);
+	getbounds(index_type, &(tp->arr_low), &(tp->arr_high));
-	tp->arr_low = lo;
+	diff = tp->arr_high - tp->arr_low;
-	tp->arr_high = hi;
-	diff = hi - lo;
 
 	if (! fit(diff, (int) int_size)) {
 		error("too many elements in array");