newer version with some bug fixes

lang/m2/comp/LLlex.c

@@ -113,6 +113,7 @@ LLlex()
 	register struct token *tk = ˙
 	char buf[(IDFSIZE > NUMSIZE ? IDFSIZE : NUMSIZE) + 2];
 	register int ch, nch;
+	static int eofseen;
 
 	toktype = error_type;
 
@@ -124,10 +125,16 @@ LLlex()
 
 	tk->tk_lineno = LineNumber;
 
+	if (eofseen) {
+		eofseen = 0;
+		ch = EOI;
+	}
+	else {
 again:
-	LoadChar(ch);
+		LoadChar(ch);
-	if ((ch & 0200) && ch != EOI) {
+		if ((ch & 0200) && ch != EOI) {
-		fatal("non-ascii '\\%03o' read", ch & 0377);
+			fatal("non-ascii '\\%03o' read", ch & 0377);
+		}
 	}
 
 	switch (class(ch))	{
@@ -159,9 +166,8 @@ again:
 				SkipComment();
 				goto again;
 			}
-			else	{
+			else if (nch == EOI) eofseen = 1;
-				PushBack(nch);
+			else PushBack(nch);
-			}
 		}
 		return tk->tk_symb = ch;
 
@@ -200,7 +206,8 @@ again:
 		default :
 			crash("(LLlex, STCOMP)");
 		}
-		PushBack(nch);
+		if (nch == EOI) eofseen = 1;
+		else PushBack(nch);
 		return tk->tk_symb = ch;
 
 	case STIDF:
@@ -213,7 +220,8 @@ again:
 			LoadChar(ch);
 		} while(in_idf(ch));
 
-		if (ch != EOI) PushBack(ch);
+		if (ch == EOI) eofseen = 1;
+		else PushBack(ch);
 		*tag++ = '\0';
 
 		tk->TOK_IDF = id = str2idf(buf, 1);
@@ -279,6 +287,7 @@ again:
 				else {
 					state = End;
 					if (ch == 'H') base = 16;
+					else if (ch == EOI) eofseen = 1;
 					else PushBack(ch);
 				}
 				break;
@@ -292,7 +301,8 @@ again:
 				state = End;
 				if (ch != 'H') {
 					lexerror("H expected after hex number");
-					PushBack(ch);
+					if (ch == EOI) eofseen = 1;
+					else PushBack(ch);
 				}
 				break;
 
@@ -308,7 +318,8 @@ again:
 					state = Hex;
 					break;
 				}
-				PushBack(ch);
+				if (ch == EOI) eofseen = 1;
+				else PushBack(ch);
 				ch = *--np;
 				*np++ = '\0';
 				base = 8;
@@ -384,7 +395,8 @@ lexwarning("Character constant out of range");
 		}
 
 		*np++ = '\0';
-		PushBack(ch);
+		if (ch == EOI) eofseen = 1;
+		else PushBack(ch);
 
 		if (np >= &buf[NUMSIZE]) {
 			tk->TOK_REL = Salloc("0.0", 5);

lang/m2/comp/Makefile

@@ -1,5 +1,5 @@
 # make modula-2 "compiler"
-EMDIR =		/usr/ceriel/em
+EMDIR =		../../..
 MHDIR =		$(EMDIR)/modules/h
 PKGDIR =	$(EMDIR)/modules/pkg
 LIBDIR =	$(EMDIR)/modules/lib
@@ -45,12 +45,17 @@ HFILES=		LLlex.h\
 #
 GENFILES = $(GENGFILES) $(GENCFILES) $(GENHFILES)
 
+#EXCLEXCLEXCLEXCL
+
 all:	Cfiles
-	sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make main ; else sh Resolve main ; fi'
+	sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make ../comp/main ; else sh Resolve ../comp/main ; fi'
 	@rm -f nmclash.o a.out
 
+install:	all
+	cp main $(EMDIR)/lib/em_m2
+
 clean:
-	rm -f $(OBJ) $(GENFILES) LLfiles hfiles Cfiles tab clashes
+	rm -f $(OBJ) $(GENFILES) LLfiles hfiles Cfiles tab clashes main
 	(cd .. ; rm -rf Xsrc)
 
 lint:	Cfiles
@@ -62,9 +67,6 @@ clashes:	$(SRC) $(HFILES)
 
 # entry points not to be used directly
 
-Xlint:
-	lint $(INCLUDES) $(LINTFLAGS) $(SRC)
-
 Cfiles:	hfiles LLfiles $(GENCFILES) $(GENHFILES)
 	echo $(SRC) $(HFILES) > Cfiles
 
@@ -76,39 +78,35 @@ hfiles:	Parameters make.hfiles
 	make.hfiles Parameters
 	touch hfiles
 
-main:	$(OBJ) ../src/Makefile
-	$(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libem_mes.a $(LIBDIR)/libemk.a $(LIBDIR)/input.a $(LIBDIR)/assert.a $(LIBDIR)/alloc.a $(LIBDIR)/dickmalloc.o $(LIBDIR)/libprint.a $(LIBDIR)/libstr.a $(LIBDIR)/libsystem.a -o ../src/main
-	size ../src/main
-
 tokenfile.g:	tokenname.c make.tokfile
 	make.tokfile <tokenname.c >tokenfile.g
 
-symbol2str.c:	../src/tokenname.c ../src/make.tokcase
+symbol2str.c:	tokenname.c make.tokcase
-	../src/make.tokcase <../src/tokenname.c >symbol2str.c
+	make.tokcase <tokenname.c >symbol2str.c
 
-def.h:		../src/def.H ../src/make.allocd
+def.h:		def.H make.allocd
-		../src/make.allocd < ../src/def.H > def.h
+		make.allocd < def.H > def.h
 
-type.h:		../src/type.H ../src/make.allocd
+type.h:		type.H make.allocd
-		../src/make.allocd < ../src/type.H > type.h
+		make.allocd < type.H > type.h
 
-node.h:		../src/node.H ../src/make.allocd
+node.h:		node.H make.allocd
-		../src/make.allocd < ../src/node.H > node.h
+		make.allocd < node.H > node.h
 
-scope.c:	../src/scope.C ../src/make.allocd
+scope.c:	scope.C make.allocd
-		../src/make.allocd < ../src/scope.C > scope.c
+		make.allocd < scope.C > scope.c
 
-tmpvar.c:	../src/tmpvar.C ../src/make.allocd
+tmpvar.c:	tmpvar.C make.allocd
-		../src/make.allocd < ../src/tmpvar.C > tmpvar.c
+		make.allocd < tmpvar.C > tmpvar.c
 
-casestat.c:	../src/casestat.C ../src/make.allocd
+casestat.c:	casestat.C make.allocd
-		../src/make.allocd < ../src/casestat.C > casestat.c
+		make.allocd < casestat.C > casestat.c
 
-char.c: ../src/char.tab ../src/tab
+char.c: char.tab tab
-	../src/tab -fchar.tab >char.c
+	tab -fchar.tab >char.c
 
-../src/tab: 
+tab: 
-	$(CC) ../src/tab.c -o ../src/tab
+	$(CC) tab.c -o tab
 
 depend:
 	sed '/^#AUTOAUTO/,$$d' Makefile > Makefile.new
@@ -118,6 +116,15 @@ depend:
 	mv Makefile Makefile.old
 	mv Makefile.new Makefile
 
+#INCLINCLINCLINCL
+
+Xlint:
+	lint $(INCLUDES) $(LINTFLAGS) $(SRC)
+
+../comp/main:	$(OBJ) ../comp/Makefile
+	$(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libem_mes.a $(LIBDIR)/libemk.a $(LIBDIR)/input.a $(LIBDIR)/assert.a $(LIBDIR)/alloc.a $(LIBDIR)/malloc.o $(LIBDIR)/libprint.a $(LIBDIR)/libstr.a $(LIBDIR)/libsystem.a -o ../comp/main
+	size ../comp/main
+
 #AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO
 LLlex.o: LLlex.h Lpars.h class.h const.h debug.h f_info.h idf.h idfsize.h input.h inputtype.h numsize.h strsize.h type.h
 LLmessage.o: LLlex.h Lpars.h idf.h
@@ -137,14 +144,14 @@ defmodule.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.h inputtype.h ma
 typequiv.o: LLlex.h debug.h def.h node.h type.h
 node.o: LLlex.h debug.h def.h node.h type.h
 cstoper.o: LLlex.h Lpars.h debug.h idf.h node.h standards.h target_sizes.h type.h
-chk_expr.o: LLlex.h Lpars.h chk_expr.h const.h debug.h def.h idf.h node.h scope.h standards.h type.h
+chk_expr.o: LLlex.h Lpars.h chk_expr.h const.h debug.h def.h idf.h misc.h node.h scope.h standards.h type.h
 options.o: idfsize.h main.h ndir.h type.h
 walk.o: LLlex.h Lpars.h chk_expr.h debug.h def.h desig.h f_info.h idf.h main.h node.h scope.h type.h walk.h
 casestat.o: LLlex.h Lpars.h debug.h density.h desig.h node.h type.h walk.h
 desig.o: LLlex.h debug.h def.h desig.h node.h scope.h type.h
 code.o: LLlex.h Lpars.h debug.h def.h desig.h node.h scope.h standards.h type.h walk.h
 tmpvar.o: debug.h def.h main.h scope.h type.h
-lookup.o: LLlex.h debug.h def.h idf.h node.h scope.h type.h
+lookup.o: LLlex.h debug.h def.h idf.h misc.h node.h scope.h type.h
 tokenfile.o: Lpars.h
 program.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h main.h node.h scope.h type.h
 declar.o: LLlex.h Lpars.h chk_expr.h debug.h def.h idf.h main.h misc.h node.h scope.h type.h

lang/m2/comp/Resolve

@@ -1,3 +1,6 @@
+: create a directory Xsrc with name clashes resolved
+: and run make in that directory
+
 case $# in
 1)	
 	;;
@@ -6,7 +9,7 @@ case $# in
 	;;
 esac
 case $1 in
-main|Xlint)
+../comp/main|Xlint)
 	;;
 *)	echo "$0: $1: Illegal argument" 1>&2
 	exit 1
@@ -18,8 +21,10 @@ then
 else	mkdir ../Xsrc
 fi
 make clashes
+: remove code generating routines from the clashes list as they are defines.
+: code generating routine names start with C_
 sed '/^C_/d' < clashes > tmp$$
-./cclash -c -l7 tmp$$ > ../Xsrc/Xclashes
+cclash -c -l7 tmp$$ > ../Xsrc/Xclashes
 rm -f tmp$$
 PW=`pwd`
 cd ../Xsrc
@@ -30,13 +35,17 @@ else
 	mv Xclashes clashes
 fi
 rm -f Makefile
+ed - $PW/Makefile <<'EOF'
+/^#EXCLEXCL/,/^#INCLINCL/d
+w Makefile
+q
+EOF
 for i in `cat $PW/Cfiles`
 do
 	cat >> Makefile <<EOF
+
 $i:	clashes $PW/$i
 	cid -Fclashes < $PW/$i > $i
-
 EOF
 done
-make `cat $PW/Cfiles`
+make $1
-make -f $PW/Makefile $1

lang/m2/comp/chk_expr.c

@@ -20,6 +20,7 @@
 #include	"const.h"
 #include	"standards.h"
 #include	"chk_expr.h"
+#include	"misc.h"
 
 extern char *symbol2str();
 
@@ -875,17 +876,30 @@ ChkStandard(expp, left)
 		break;
 
 	case S_HIGH:
-		if (!(left = getarg(&arg, T_ARRAY, 0))) return 0;
+		if (!(left = getarg(&arg, T_ARRAY|T_STRING|T_CHAR, 0))) return 0;
 		if (IsConformantArray(left->nd_type)) {
 			/* A conformant array has no explicit index type
 			   ??? So, what can we use as index-type ???
 			*/
 			expp->nd_type = intorcard_type;
+			break;
 		}
-		else {
+		if (left->nd_type->tp_fund == T_ARRAY) {
 			expp->nd_type = IndexType(left->nd_type);
 			cstcall(expp, S_MAX);
+			break;
 		}
+		if (left->nd_type->tp_fund == T_CHAR) {
+			if (left->nd_symb != STRING) {
+				node_error(left,"HIGH: array parameter expected");
+				return 0;
+			}
+		}
+		expp->nd_type = intorcard_type;
+		expp->nd_class = Value;
+		expp->nd_INT = left->nd_type->tp_fund == T_CHAR ? 0 :
+					left->nd_SLE - 1;
+		expp->nd_symb = INTEGER;
 		break;
 
 	case S_MAX:

lang/m2/comp/code.c

@@ -380,7 +380,7 @@ CodeParameters(param, arg)
 			}
 		}
 		else if (left->nd_symb == STRING) {
-			C_loc(left->nd_SLE);
+			C_loc(left->nd_SLE - 1);
 		}
 		else if (tp->arr_elem == word_type) {
 			C_loc((left_type->tp_size+word_size-1) / word_size - 1);

lang/m2/comp/declar.g

@@ -219,7 +219,7 @@ ArrayType(struct type **ptp;)
 RecordType(struct type **ptp;)
 {
 	register struct scope *scope;
-	arith size;
+	arith size = 0;
 	int xalign = struct_align;
 }
 :
@@ -301,9 +301,10 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
 			  	}
 			  	df->df_type = tp;
 			  	df->fld_off = align(*cnt, tp->tp_align);
-			  	*cnt = tcnt = df->fld_off + tp->tp_size;
+			  	*cnt = df->fld_off + tp->tp_size;
 			  	df->df_flags |= D_QEXPORTED;
 			  }
+			  tcnt = *cnt;
 			}
 	OF variant(scope, &tcnt, tp, palign)
 			{ max = tcnt; tcnt = *cnt; }

lang/m2/comp/enter.c

@@ -393,10 +393,8 @@ EnterFromImportList(Idlist, FromDef)
 	for (; idlist; idlist = idlist->next) {
 		if (forwflag) df = ForwDef(idlist, vis->sc_scope);
 		else if (! (df = lookup(idlist->nd_IDF, vis->sc_scope))) {
-			node_error(idlist, 
+		    not_declared("identifier", idlist, " in qualifying module");
-			  "identifier \"%s\" not declared in qualifying module",
+		    df = define(idlist->nd_IDF,vis->sc_scope,D_ERROR);
-			  idlist->nd_IDF->id_text);
-			df = define(idlist->nd_IDF,vis->sc_scope,D_ERROR);
 		}
 		else if (! (df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
 			node_error(idlist,

lang/m2/comp/expression.g

@@ -49,7 +49,7 @@ qualident(int types;
 
 		  		if ( !((types|D_ERROR) & df->df_kind)) {
 				    if (df->df_kind == D_FORWARD) {
-node_error(nd,"%s \"%s\" not declared", str, df->df_idf->id_text);
+					not_declared(str, nd, "");
 				    }
 				    else {
 node_error(nd,"identifier \"%s\" is not a %s", df->df_idf->id_text, str);

lang/m2/comp/lookup.c

@@ -12,6 +12,7 @@
 #include	"LLlex.h"
 #include	"node.h"
 #include	"type.h"
+#include	"misc.h"
 
 struct def *
 lookup(id, scope)

lang/m2/comp/misc.c

@@ -40,7 +40,8 @@ gen_anon_idf()
 	return str2idf(buff, 1);
 }
 
-id_not_declared(id)
+not_declared(what, id, where)
+	char *what, *where;
 	register struct node *id;
 {
 	/*	The identifier "id" is not declared. If it is not generated,
@@ -48,6 +49,9 @@ id_not_declared(id)
 	*/
 	if (!is_anon_idf(id->nd_IDF)) {
 		node_error(id,
-			"identifier \"%s\" not declared", id->nd_IDF->id_text);
+		 	   "%s \"%s\" not declared%s",
+			   what,
+			   id->nd_IDF->id_text,
+			   where);
 	}
 }

lang/m2/comp/misc.h

@@ -1,6 +1,7 @@
 /* M I S C E L L A N E O U S */
 
-#define is_anon_idf(x)	((x)->id_text[0] == '#')
+#define is_anon_idf(x)		((x)->id_text[0] == '#')
+#define id_not_declared(x)	(not_declared("identifier", (x), ""))
 
 extern struct idf
 	*gen_anon_idf();