newer version

diff --git a/lang/m2/comp/LLlex.c b/lang/m2/comp/LLlex.c
index a252b60..a1ccd14 100644 (file)
--- a/lang/m2/comp/LLlex.c
+++ b/lang/m2/comp/LLlex.c
@@ -248,8 +248,11 @@ again:
                switch (ch) {
                case 'H':
 Shex:                  *np++ = '\0';
-                       numtype = card_type;
                        tk->TOK_INT = str2long(&buf[1], 16);
+                       if (tk->TOK_INT >= 0 && tk->TOK_INT <= max_int) {
+                               numtype = intorcard_type;
+                       }
+                       else    numtype = card_type;
                        return tk->tk_symb = INTEGER;
 
                case '8':
@@ -283,11 +286,17 @@ Shex:                     *np++ = '\0';
                        PushBack(ch);
                        ch = *--np;
                        *np++ = '\0';
+                       tk->TOK_INT = str2long(&buf[1], 8);
                        if (ch == 'C') {
                                numtype = char_type;
+                               if (tk->TOK_INT < 0 || tk->TOK_INT > 255) {
+lexwarning("Character constant out of range");
+                               }
+                       }
+                       else if (tk->TOK_INT >= 0 && tk->TOK_INT <= max_int) {
+                               numtype = intorcard_type;
                        }
                        else    numtype = card_type;
-                       tk->TOK_INT = str2long(&buf[1], 8);
                        return tk->tk_symb = INTEGER;
 
                case 'A':

diff --git a/lang/m2/comp/Makefile b/lang/m2/comp/Makefile
index 7081585..7d89327 100644 (file)
--- a/lang/m2/comp/Makefile
+++ b/lang/m2/comp/Makefile
@@ -82,7 +82,7 @@ LLlex.o: LLlex.h Lpars.h class.h const.h f_info.h idf.h idfsize.h input.h inputt
 LLmessage.o: LLlex.h Lpars.h idf.h
 char.o: class.h
 error.o: LLlex.h debug.h errout.h f_info.h input.h inputtype.h main.h node.h
-main.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.h inputtype.h node.h scope.h standards.h tokenname.h type.h
+main.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.h inputtype.h ndirs.h node.h scope.h standards.h tokenname.h type.h
 symbol2str.o: Lpars.h
 tokenname.o: Lpars.h idf.h tokenname.h
 idf.o: idf.h
@@ -97,7 +97,7 @@ typequiv.o: def.h type.h
 node.o: LLlex.h debug.h def.h node.h type.h
 cstoper.o: LLlex.h Lpars.h idf.h node.h standards.h target_sizes.h type.h
 chk_expr.o: LLlex.h Lpars.h const.h debug.h def.h idf.h node.h scope.h standards.h type.h
-options.o: idfsize.h type.h
+options.o: idfsize.h main.h ndir.h type.h
 walk.o: LLlex.h Lpars.h debug.h def.h main.h node.h scope.h type.h
 tokenfile.o: Lpars.h
 program.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.h type.h

diff --git a/lang/m2/comp/Parameters b/lang/m2/comp/Parameters
index fcdfc05..7604bdf 100644 (file)
--- a/lang/m2/comp/Parameters
+++ b/lang/m2/comp/Parameters
@@ -63,4 +63,8 @@ extern char options[];
                                   but what is a reasonable choice ???
                                */
 
+!File: ndir.h
+#define NDIRS  16              /* maximum number of directories searched */
+
+
 

diff --git a/lang/m2/comp/chk_expr.c b/lang/m2/comp/chk_expr.c
index 81fc53c..938fc6f 100644 (file)
--- a/lang/m2/comp/chk_expr.c
+++ b/lang/m2/comp/chk_expr.c
@@ -35,7 +35,7 @@ chk_expr(expp)
        switch(expp->nd_class) {
        case Oper:
                if (expp->nd_symb == '[') {
-                       return chk_designator(expp, DESIGNATOR);
+                       return chk_designator(expp, DESIGNATOR|VARIABLE);
                }
 
                return  chk_expr(expp->nd_left) &&
@@ -44,7 +44,7 @@ chk_expr(expp)
 
        case Uoper:
                if (expp->nd_symb == '^') {
-                       return chk_designator(expp, DESIGNATOR);
+                       return chk_designator(expp, DESIGNATOR|VARIABLE);
                }
 
                return  chk_expr(expp->nd_right) &&
@@ -66,13 +66,13 @@ chk_expr(expp)
                return chk_set(expp);
 
        case Name:
-               return chk_designator(expp, DESIGNATOR);
+               return chk_designator(expp, VALUE);
 
        case Call:
                return chk_call(expp);
 
        case Link:
-               return chk_designator(expp, DESIGNATOR);
+               return chk_designator(expp, DESIGNATOR|VALUE);
 
        default:
                assert(0);
@@ -99,7 +99,7 @@ chk_set(expp)
        if (nd = expp->nd_left) {
                /* A type was given. Check it out
                */
-               if (! chk_designator(nd, QUALONLY)) return 0;
+               if (! chk_designator(nd, 0)) return 0;
 
                assert(nd->nd_class == Def);
                df = nd->nd_def;
@@ -270,12 +270,15 @@ getname(argp, kinds)
                return 0;
        }
        argp = argp->nd_right;
-       if (! chk_designator(argp->nd_left, QUALONLY)) return 0;
+       if (! chk_designator(argp->nd_left, 0)) return 0;
+
        assert(argp->nd_left->nd_class == Def);
+
        if (!(argp->nd_left->nd_def->df_kind & kinds)) {
                node_error(argp, "unexpected type");
                return 0;
        }
+
        return argp;
 }
 
@@ -294,9 +297,8 @@ chk_call(expp)
        */
        expp->nd_type = error_type;
        left = expp->nd_left;
-       if (! chk_designator(left, DESIGNATOR)) return 0;
+       if (! chk_designator(left, 0)) return 0;
 
-       if (left->nd_type == error_type) return 0;
        if (left->nd_class == Def &&
            (left->nd_def->df_kind & (D_HTYPE|D_TYPE|D_HIDDEN))) {
                /* It was a type cast. This is of course not portable.
@@ -310,7 +312,7 @@ node_error(expp, "only one parameter expected in type cast");
                arg = arg->nd_left;
                if (! chk_expr(arg)) return 0;
                if (arg->nd_type->tp_size != left->nd_type->tp_size) {
-node_error(expp, "size of type in type cast does not match size of operand");
+node_error(expp, "unequal sizes in type cast");
                }
                arg->nd_type = left->nd_type;
                FreeNode(expp->nd_left);
@@ -352,30 +354,59 @@ chk_proccall(expp)
        register struct node *arg;
        register struct paramlist *param;
 
-       expp->nd_type = left->nd_type->next;
-       param = left->nd_type->prc_params;
        arg = expp;
+       arg->nd_type = left->nd_type->next;
+       param = left->nd_type->prc_params;
 
        while (param) {
-               arg = getarg(arg, 0);
-               if (!arg) return 0;
-               if (param->par_var &&
-                   ! TstCompat(param->par_type, arg->nd_left->nd_type)) {
-node_error(arg->nd_left, "type incompatibility in var parameter");
-                       return 0;
-               }
-               else
-               if (!param->par_var &&
-                   !TstAssCompat(param->par_type, arg->nd_left->nd_type)) {
-node_error(arg->nd_left, "type incompatibility in value parameter");
+               if (!(arg = getarg(arg, 0))) return 0;
+
+               if (! TstParCompat(param->par_type,
+                                  arg->nd_left->nd_type,
+                                  param->par_var)) {
+node_error(arg->nd_left, "type incompatibility in parameter");
                        return 0;
                }
+
                param = param->next;
        }
+
        if (arg->nd_right) {
                node_error(arg->nd_right, "too many parameters supplied");
                return 0;
        }
+
+       return 1;
+}
+
+static int
+FlagCheck(expp, df, flag)
+       struct node *expp;
+       struct def *df;
+{
+       /*      See the routine "chk_designator" for an explanation of
+               "flag". Here, a definition "df" is checked against it.
+       */
+
+       if ((flag & VARIABLE) &&
+           !(df->df_kind & (D_FIELD|D_VARIABLE))) {
+               node_error(expp, "variable expected");
+               return 0;
+       }
+
+       if ((flag & HASSELECTORS) &&
+           ( !(df->df_kind & (D_VARIABLE|D_FIELD|D_MODULE)) ||
+             df->df_type->tp_fund != T_RECORD)) {
+               node_error(expp, "illegal selection");
+               return 0;
+       }
+
+       if ((flag & VALUE) &&
+           ( !(df->df_kind & (D_VARIABLE|D_FIELD|D_CONST|D_ENUM)))) {
+               node_error(expp, "value expected");
+               return 0;
+       }
+
        return 1;
 }
 
@@ -384,7 +415,15 @@ chk_designator(expp, flag)
        register struct node *expp;
 {
        /*      Find the name indicated by "expp", starting from the current
-               scope.
+               scope.  "flag" indicates the kind of designator we expect:
+               It contains the flags VARIABLE, indicating that the result must
+               be something that can be assigned to.
+               It may also contain the flag VALUE, indicating that a
+               value is expected. In this case, VARIABLE may not be set.
+               It also contains the flag DESIGNATOR, indicating that '['
+               and '^' are allowed for this designator.
+               Also contained may be the flag HASSELECTORS, indicating that
+               the result must have selectors.
        */
        register struct def *df;
        register struct type *tp;
@@ -403,21 +442,20 @@ chk_designator(expp, flag)
                assert(expp->nd_symb == '.');
                assert(expp->nd_right->nd_class == Name);
 
-               if (! chk_designator(expp->nd_left, flag)) return 0;
+               if (! chk_designator(expp->nd_left,
+                                    (flag|HASSELECTORS)&DESIGNATOR)) return 0;
+
                tp = expp->nd_left->nd_type;
-               if (tp == error_type) return 0;
-               else if (tp->tp_fund != T_RECORD) {
-                       /* This is also true for modules */
-                       node_error(expp,"illegal selection");
-                       return 0;
-               }
-               else df = lookup(expp->nd_right->nd_IDF, tp->rec_scope);
+
+               assert(tp->tp_fund == T_RECORD);
+
+               df = lookup(expp->nd_right->nd_IDF, tp->rec_scope);
 
                if (!df) {
                        id_not_declared(expp->nd_right);
                        return 0;
                }
-               else if (df != ill_df) {
+               else {
                        expp->nd_type = df->df_type;
                        if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
 node_error(expp->nd_right,
@@ -434,12 +472,16 @@ df->df_idf->id_text);
                        FreeNode(expp->nd_right);
                        expp->nd_left = expp->nd_right = 0;
                }
-               else    return 1;
+               else {
+                       return FlagCheck(expp->nd_right, df, flag);
+               }
        }
 
        if (expp->nd_class == Def) {
                df = expp->nd_def;
 
+               if (! FlagCheck(expp, df, flag)) return 0;
+
                if (df->df_kind & (D_ENUM | D_CONST)) {
                        if (df->df_kind == D_ENUM) {
                                expp->nd_class = Value;
@@ -455,7 +497,7 @@ df->df_idf->id_text);
                return 1;
        }
 
-       if (flag == QUALONLY) {
+       if (! (flag & DESIGNATOR)) {
                node_error(expp, "identifier expected");
                return 0;
        }
@@ -466,7 +508,7 @@ df->df_idf->id_text);
                assert(expp->nd_symb == '[');
 
                if ( 
-                       !chk_designator(expp->nd_left, DESIGNATOR)
+                       !chk_designator(expp->nd_left, DESIGNATOR|VARIABLE)
                   ||
                        !chk_expr(expp->nd_right)
                   ||
@@ -498,7 +540,10 @@ df->df_idf->id_text);
        if (expp->nd_class == Uoper) {
                assert(expp->nd_symb == '^');
 
-               if (! chk_designator(expp->nd_right, DESIGNATOR)) return 0;
+               if (! chk_designator(expp->nd_right, DESIGNATOR|VARIABLE)) {
+                       return 0;
+               }
+
                if (expp->nd_right->nd_type->tp_fund != T_POINTER) {
 node_error(expp, "illegal operand for unary operator \"%s\"",
 symbol2str(expp->nd_symb));

diff --git a/lang/m2/comp/declar.g b/lang/m2/comp/declar.g
index baca3d8..ad2bcd1 100644 (file)
--- a/lang/m2/comp/declar.g
+++ b/lang/m2/comp/declar.g
@@ -17,6 +17,8 @@ static char *RcsId = "$Header$";
 #include       "misc.h"
 #include       "main.h"
 
+#include       "debug.h"
+
 int            proclevel = 0;  /* nesting level of procedures */
 extern char    *sprint();
 extern struct def *currentdef;
@@ -68,6 +70,10 @@ error("inconsistent procedure declaration for \"%s\"", df->df_idf->id_text);
                  }
                  df->df_type = tp;
                  *pdf = df;
+
+                 DO_DEBUG(1, type == D_PROCEDURE && 
+                               (print("proc %s:", df->df_idf->id_text),
+                                DumpType(tp), print("\n")));
                }
 ;
 
@@ -107,9 +113,8 @@ FormalParameters(int doparams;
        '('
        [
                FPSection(doparams, pr, parmaddr)       
-                       { pr1 = *pr; }
                [
-                       { for (; pr1->next; pr1 = pr1->next) ; }
+                       { for (pr1 = *pr; pr1->next; pr1 = pr1->next) ; }
                        ';' FPSection(doparams, &(pr1->next), parmaddr)
                ]*
        ]?
@@ -366,7 +371,7 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
                                { warning("Old fashioned Modula-2 syntax!");
                                  id = gen_anon_idf();
                                  df = ill_df;
-                                 if (chk_designator(nd, QUALONLY) &&
+                                 if (chk_designator(nd, 0) &&
                                      (nd->nd_class != Def ||
                                       !(nd->nd_def->df_kind &
                                         (D_ERROR|D_TYPE|D_HTYPE|D_HIDDEN)))) {

diff --git a/lang/m2/comp/defmodule.c b/lang/m2/comp/defmodule.c
index 808ff84..faf3b62 100644 (file)
--- a/lang/m2/comp/defmodule.c
+++ b/lang/m2/comp/defmodule.c
@@ -26,7 +26,6 @@ GetFile(name)
        /*      Try to find a file with basename "name" and extension ".def",
                in the directories mentioned in "DEFPATH".
        */
-       extern char *DEFPATH[];
        char buf[256];
        char *strcpy(), *strcat();
 

diff --git a/lang/m2/comp/expression.g b/lang/m2/comp/expression.g
index 4348fce..a3b122e 100644 (file)
--- a/lang/m2/comp/expression.g
+++ b/lang/m2/comp/expression.g
@@ -43,7 +43,7 @@ qualident(int types; struct def **pdf; char *str; struct node **p;)
                        { if (types) {
                                df = ill_df;
 
-                               if (chk_designator(nd, QUALONLY)) {
+                               if (chk_designator(nd, 0)) {
                                    if (nd->nd_class != Def) {
                                        node_error(nd, "%s expected", str);
                                    }
@@ -83,7 +83,7 @@ ExpList(struct node **pnd;)
                ','             { *nd = MkNode(Link, NULLNODE, NULLNODE, &dot);
                                }
                expression(&(*nd)->nd_left)
-                               { nd = &((*pnd)->nd_right); }
+                               { nd = &((*nd)->nd_right); }
        ]*
 ;
 

diff --git a/lang/m2/comp/main.c b/lang/m2/comp/main.c
index 0c45327..afd2b13 100644 (file)
--- a/lang/m2/comp/main.c
+++ b/lang/m2/comp/main.c
@@ -19,14 +19,14 @@ static char *RcsId = "$Header$";
 #include       "node.h"
 
 #include       "debug.h"
+#include       "ndir.h"
 
 char   options[128];
 int    DefinitionModule; 
 int    SYSTEMModule = 0;
 char   *ProgName;
 extern int err_occurred;
-char   *DEFPATH[128];
-char   *getenv();
+char   *DEFPATH[NDIRS+1];
 struct def *Defined;
 
 main(argc, argv)
@@ -67,7 +67,8 @@ Compile(src, dst)
        }
        LineNumber = 1;
        FileName = src;
-       init_DEFPATH();
+       DEFPATH[0] = "";
+       DEFPATH[NDIRS] = 0;
        init_idf();
        init_cst();
        reserve(tkidf);
@@ -181,23 +182,6 @@ add_standards()
        df->enm_next = 0;
 }
 
-init_DEFPATH()
-{
-       register char *p = getenv("M2path");
-       register int i = 0;
-
-       if (p) {
-               while (*p) {
-                       DEFPATH[i++] = p;
-                       while (*p && *p != ':') p++;
-                       if (*p) *p++ = '\0';
-               }
-       }
-       else DEFPATH[i++] = "";
-
-       DEFPATH[i] = 0;
-}
-
 do_SYSTEM()
 {
        /*      Simulate the reading of the SYSTEM definition module

diff --git a/lang/m2/comp/main.h b/lang/m2/comp/main.h
index 04ca4ed..35a0f9a 100644 (file)
--- a/lang/m2/comp/main.h
+++ b/lang/m2/comp/main.h
@@ -2,17 +2,18 @@
 
 /* $Header$ */
 
-extern char options[]; /* Indicating which options were given */
+extern char options[]; /* indicating which options were given */
 
 extern int DefinitionModule;
-                       /* Flag indicating that we are reading a definition
+                       /* flag indicating that we are reading a definition
                           module
                        */
 
-extern int SYSTEMModule;/* Flag indicating that we are handling the SYSTEM
+extern int SYSTEMModule;/* flag indicating that we are handling the SYSTEM
                           module
                        */
 extern struct def *Defined;
-                       /* Definition structure of module defined in this
+                       /* definition structure of module defined in this
                           compilation
                        */
+extern char *DEFPATH[];        /* search path for DEFINITION MODULE's */

diff --git a/lang/m2/comp/node.H b/lang/m2/comp/node.H
index f74fd3a..f4a3095 100644 (file)
--- a/lang/m2/comp/node.H
+++ b/lang/m2/comp/node.H
@@ -36,5 +36,8 @@ struct node {
 extern struct node *MkNode();
 
 #define NULLNODE ((struct node *) 0)
-#define QUALONLY 0
+
 #define DESIGNATOR 1
+#define HASSELECTORS 2
+#define VARIABLE 4
+#define VALUE 8

diff --git a/lang/m2/comp/options.c b/lang/m2/comp/options.c
index f8bc488..f372a62 100644 (file)
--- a/lang/m2/comp/options.c
+++ b/lang/m2/comp/options.c
@@ -6,12 +6,15 @@ static char *RcsId = "$Header$";
 #include       <em_label.h>
 
 #include       "idfsize.h"
+#include       "ndir.h"
 
 #include       "type.h"
+#include       "main.h"
 
-extern char options[];
 extern int     idfsize;
 
+static int     ndirs;
+
 do_option(text)
        char *text;
 {
@@ -37,6 +40,13 @@ do_option(text)
                options['p'] = 1;
                break;
 
+       case 'I' :
+               if (++ndirs >= NDIRS) {
+                       fatal("Too many -I options");
+               }
+               DEFPATH[ndirs] = text;
+               break;
+
        case 'V' :      /* set object sizes and alignment requirements  */
        {
                arith size;

diff --git a/lang/m2/comp/type.c b/lang/m2/comp/type.c
index 2d5b140..41d1e25 100644 (file)
--- a/lang/m2/comp/type.c
+++ b/lang/m2/comp/type.c
@@ -436,3 +436,70 @@ lcm(m, n)
        */
        return m * (n / gcd(m, n));
 }
+
+#ifdef DEBUG
+DumpType(tp)
+       register struct type *tp;
+{
+       print(" a:%d; s:%ld;", tp->tp_align, (long) tp->tp_size);
+       if (tp->next && tp->tp_fund != T_POINTER) {
+               /* Avoid printing recursive types!
+               */
+               print(" n:(");
+               DumpType(tp->next);
+               print(")");
+       }
+
+       print(" f:");
+       switch(tp->tp_fund) {
+       case T_RECORD:
+               print("RECORD"); break;
+       case T_ENUMERATION:
+               print("ENUMERATION; n:%d", tp->enm_ncst); break;
+       case T_INTEGER:
+               print("INTEGER"); break;
+       case T_CARDINAL:
+               print("CARDINAL"); break;
+       case T_REAL:
+               print("REAL"); break;
+       case T_POINTER:
+               print("POINTER"); break;
+       case T_CHAR:
+               print("CHAR"); break;
+       case T_WORD:
+               print("WORD"); break;
+       case T_SET:
+               print("SET"); break;
+       case T_SUBRANGE:
+               print("SUBRANGE %ld-%ld", (long) tp->sub_lb, (long) tp->sub_ub);
+               break;
+       case T_PROCEDURE:
+               {
+               register struct paramlist *par = tp->prc_params;
+
+               print("PROCEDURE");
+               if (par) {
+                       print("; p:");
+                       while(par) {
+                               if (par->par_var) print("VAR ");
+                               DumpType(par->par_type);
+                               par = par->next;
+                       }
+               }
+               break;
+               }
+       case T_ARRAY:
+               print("ARRAY %ld-%ld", (long) tp->arr_lb, (long) tp->arr_ub);
+               print("; el:");
+               DumpType(tp->arr_elem);
+               break;
+       case T_STRING:
+               print("STRING"); break;
+       case T_INTORCARD:
+               print("INTORCARD"); break;
+       default:
+               assert(0);
+       }
+       print(";");
+}
+#endif

diff --git a/lang/m2/comp/typequiv.c b/lang/m2/comp/typequiv.c
index 2a7c1a8..80c2331 100644 (file)
--- a/lang/m2/comp/typequiv.c
+++ b/lang/m2/comp/typequiv.c
@@ -150,3 +150,21 @@ int TstAssCompat(tp1, tp2)
 
        return 0;
 }
+
+int TstParCompat(formaltype, actualtype, VARflag)
+       struct type *formaltype, *actualtype;
+{
+       /*      Check type compatibility for a parameter in a procedure
+               call
+       */
+
+       return
+               TstCompat(formaltype, actualtype)
+           ||
+               ( !VARflag && TstAssCompat(formaltype, actualtype))
+           ||
+               (  formaltype->tp_fund == T_ARRAY
+               && formaltype->next == 0        
+               && actualtype->tp_fund == T_ARRAY
+               && TstTypeEquiv(formaltype->arr_elem, actualtype->arr_elem));
+}

diff --git a/lang/m2/comp/walk.c b/lang/m2/comp/walk.c
index c8fffc5..9e7c2e7 100644 (file)
--- a/lang/m2/comp/walk.c
+++ b/lang/m2/comp/walk.c
@@ -181,7 +181,9 @@ WalkStat(nd, lab)
        register struct node *right = nd->nd_right;
 
        if (nd->nd_class == Call) {
-               /* ??? */
+               if (chk_call(nd)) {
+                       /* ??? */
+               }
                return;
        }
 
@@ -189,6 +191,8 @@ WalkStat(nd, lab)
 
        switch(nd->nd_symb) {
        case BECOMES:
+               WalkExpr(nd->nd_right);
+               WalkDesignator(nd->nd_left);
                /* ??? */
                break;
 
@@ -309,6 +313,19 @@ WalkExpr(nd)
        }
 }
 
+WalkDesignator(nd)
+       struct node *nd;
+{
+       /*      Check designator and generate code for it
+       */
+
+       DO_DEBUG(1, (DumpTree(nd), print("\n")));
+
+       if (chk_designator(nd, DESIGNATOR|VARIABLE)) {
+               /* ??? */
+       }
+}
+
 #ifdef DEBUG
 DumpTree(nd)
        struct node *nd;