newer version with some bug fixes

diff --git a/lang/m2/comp/LLlex.c b/lang/m2/comp/LLlex.c
index 2884c02..6489389 100644 (file)
--- a/lang/m2/comp/LLlex.c
+++ b/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);
-       if ((ch & 0200) && ch != EOI) {
-               fatal("non-ascii '\\%03o' read", ch & 0377);
+               LoadChar(ch);
+               if ((ch & 0200) && ch != EOI) {
+                       fatal("non-ascii '\\%03o' read", ch & 0377);
+               }
        }
 
        switch (class(ch))      {
@@ -159,9 +166,8 @@ again:
                                SkipComment();
                                goto again;
                        }
-                       else    {
-                               PushBack(nch);
-                       }
+                       else if (nch == EOI) eofseen = 1;
+                       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);

diff --git a/lang/m2/comp/Makefile b/lang/m2/comp/Makefile
index da51723..3e4ad43 100644 (file)
--- a/lang/m2/comp/Makefile
+++ b/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
-       ../src/make.tokcase <../src/tokenname.c >symbol2str.c
+symbol2str.c:  tokenname.c make.tokcase
+       make.tokcase <tokenname.c >symbol2str.c
 
-def.h:         ../src/def.H ../src/make.allocd
-               ../src/make.allocd < ../src/def.H > def.h
+def.h:         def.H make.allocd
+               make.allocd < def.H > def.h
 
-type.h:                ../src/type.H ../src/make.allocd
-               ../src/make.allocd < ../src/type.H > type.h
+type.h:                type.H make.allocd
+               make.allocd < type.H > type.h
 
-node.h:                ../src/node.H ../src/make.allocd
-               ../src/make.allocd < ../src/node.H > node.h
+node.h:                node.H make.allocd
+               make.allocd < node.H > node.h
 
-scope.c:       ../src/scope.C ../src/make.allocd
-               ../src/make.allocd < ../src/scope.C > scope.c
+scope.c:       scope.C make.allocd
+               make.allocd < scope.C > scope.c
 
-tmpvar.c:      ../src/tmpvar.C ../src/make.allocd
-               ../src/make.allocd < ../src/tmpvar.C > tmpvar.c
+tmpvar.c:      tmpvar.C make.allocd
+               make.allocd < tmpvar.C > tmpvar.c
 
-casestat.c:    ../src/casestat.C ../src/make.allocd
-               ../src/make.allocd < ../src/casestat.C > casestat.c
+casestat.c:    casestat.C make.allocd
+               make.allocd < casestat.C > casestat.c
 
-char.c: ../src/char.tab ../src/tab
-       ../src/tab -fchar.tab >char.c
+char.c: char.tab tab
+       tab -fchar.tab >char.c
 
-../src/tab: 
-       $(CC) ../src/tab.c -o ../src/tab
+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

diff --git a/lang/m2/comp/Resolve b/lang/m2/comp/Resolve
index def1f2a..b871249 100755 (executable)
--- a/lang/m2/comp/Resolve
+++ b/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 -f $PW/Makefile $1
+make $1

diff --git a/lang/m2/comp/chk_expr.c b/lang/m2/comp/chk_expr.c
index 0b96383..40a2064 100644 (file)
--- a/lang/m2/comp/chk_expr.c
+++ b/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:

diff --git a/lang/m2/comp/code.c b/lang/m2/comp/code.c
index 9a58a7a..d5d419e 100644 (file)
--- a/lang/m2/comp/code.c
+++ b/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);

diff --git a/lang/m2/comp/declar.g b/lang/m2/comp/declar.g
index 9087a00..7bca82d 100644 (file)
--- a/lang/m2/comp/declar.g
+++ b/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; }

diff --git a/lang/m2/comp/enter.c b/lang/m2/comp/enter.c
index 85f1f76..fb87c58 100644 (file)
--- a/lang/m2/comp/enter.c
+++ b/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, 
-                         "identifier \"%s\" not declared in qualifying module",
-                         idlist->nd_IDF->id_text);
-                       df = define(idlist->nd_IDF,vis->sc_scope,D_ERROR);
+                   not_declared("identifier", idlist, " in qualifying module");
+                   df = define(idlist->nd_IDF,vis->sc_scope,D_ERROR);
                }
                else if (! (df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
                        node_error(idlist,

diff --git a/lang/m2/comp/expression.g b/lang/m2/comp/expression.g
index bd2f8d6..5edf0c8 100644 (file)
--- a/lang/m2/comp/expression.g
+++ b/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);

diff --git a/lang/m2/comp/lookup.c b/lang/m2/comp/lookup.c
index 7109e6a..6143502 100644 (file)
--- a/lang/m2/comp/lookup.c
+++ b/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)

diff --git a/lang/m2/comp/misc.c b/lang/m2/comp/misc.c
index 573fd03..d945e55 100644 (file)
--- a/lang/m2/comp/misc.c
+++ b/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);
        }
 }

diff --git a/lang/m2/comp/misc.h b/lang/m2/comp/misc.h
index 5cf1ae8..8d8b48e 100644 (file)
--- a/lang/m2/comp/misc.h
+++ b/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();