Trying to check more of an expression, giving some more sophisticated error messages...

diff --git a/lang/m2/comp/LLlex.c b/lang/m2/comp/LLlex.c
index 733ba3b..c9372ec 100644 (file)
--- a/lang/m2/comp/LLlex.c
+++ b/lang/m2/comp/LLlex.c
@@ -76,10 +76,12 @@ GetString(upto)
        /*      Read a Modula-2 string, delimited by the character "upto".
        */
        register int ch;
-       register struct string *str = (struct string *) Malloc(sizeof(struct string));
+       register struct string *str = (struct string *)
+                       Malloc((unsigned) sizeof(struct string));
        register char *p;
+       register int len;
        
-       str->s_length = ISTRSIZE;
+       len = ISTRSIZE;
        str->s_str = p = Malloc((unsigned int) ISTRSIZE);
        while (LoadChar(ch), ch != upto)        {
                if (class(ch) == STNL)  {
@@ -95,15 +97,18 @@ GetString(upto)
                        break;
                }
                *p++ = ch;
-               if (p - str->s_str == str->s_length)    {
+               if (p - str->s_str == len)      {
                        str->s_str = Srealloc(str->s_str,
-                               (unsigned int) str->s_length + RSTRSIZE);
-                       p = str->s_str + str->s_length;
-                       str->s_length += RSTRSIZE;
+                               (unsigned int) len + RSTRSIZE);
+                       p = str->s_str + len;
+                       len += RSTRSIZE;
                }
        }
-       *p = '\0';
        str->s_length = p - str->s_str;
+       while (p - str->s_str < len) *p++ = '\0';
+       if (str->s_length == 0) str->s_length = 1;      /* ??? string length
+                                                          at least 1 ???
+                                                       */
        return str;
 }
 
@@ -172,7 +177,7 @@ linedirective() {
                 * Remember the file name
                 */
                if (!eofseen && strcmp(FileName,buf)) {
-                       FileName = Salloc(buf,strlen(buf) + 1);
+                       FileName = Salloc(buf,(unsigned) strlen(buf) + 1);
                }
        }
        if (eofseen) {

diff --git a/lang/m2/comp/Makefile b/lang/m2/comp/Makefile
index f9746fd..aff09b7 100644 (file)
--- a/lang/m2/comp/Makefile
+++ b/lang/m2/comp/Makefile
@@ -64,8 +64,8 @@ lint: Cfiles
        sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make Xlint ; else sh Resolve Xlint ; fi'
        @rm -f nmclash.o a.out
 
-clashes:       $(SRC) $(HFILES)
-       sh -c 'if test -f clashes ; then cclash -l7 clashes $? > Xclashes ; mv Xclashes clashes ; else cclash -l7 $? > clashes ; fi'
+longnames:     $(SRC) $(HFILES)
+       sh -c 'if test -f longnames ; then prid -l7 longnames $? > Xlongnames ; mv Xlongnames longnames ; else prid -l7 $? > longnames ; fi'
 
 # entry points not to be used directly
 

diff --git a/lang/m2/comp/Parameters b/lang/m2/comp/Parameters
index 9aa80fb..fecdc8a 100644 (file)
--- a/lang/m2/comp/Parameters
+++ b/lang/m2/comp/Parameters
@@ -1,6 +1,6 @@
 !File: errout.h
 #define        ERROUT          STDERR  /* file pointer for writing messages    */
-#define        MAXERR_LINE     5       /* maximum number of error messages given
+#define        MAXERR_LINE     100     /* maximum number of error messages given
                                        on the same input line.         */
 
 

diff --git a/lang/m2/comp/Resolve b/lang/m2/comp/Resolve
index b871249..eeb0a7b 100755 (executable)
--- a/lang/m2/comp/Resolve
+++ b/lang/m2/comp/Resolve
@@ -20,10 +20,10 @@ then
        :
 else   mkdir ../Xsrc
 fi
-make clashes
+make longnames
 : remove code generating routines from the clashes list as they are defines.
 : code generating routine names start with C_
-sed '/^C_/d' < clashes > tmp$$
+sed '/^C_/d' < longnames > tmp$$
 cclash -c -l7 tmp$$ > ../Xsrc/Xclashes
 rm -f tmp$$
 PW=`pwd`

diff --git a/lang/m2/comp/Version.c b/lang/m2/comp/Version.c
index 44e5790..521e211 100644 (file)
--- a/lang/m2/comp/Version.c
+++ b/lang/m2/comp/Version.c
@@ -1 +1 @@
-char Version[] = "Version 0.7";
+char Version[] = "ACK Modula-2 compiler Version 0.8";

diff --git a/lang/m2/comp/chk_expr.c b/lang/m2/comp/chk_expr.c
index c01ae1a..fb1dd19 100644 (file)
--- a/lang/m2/comp/chk_expr.c
+++ b/lang/m2/comp/chk_expr.c
@@ -25,6 +25,20 @@
 
 extern char *symbol2str();
 
+STATIC
+Xerror(nd, mess, edf)
+       struct node *nd;
+       char *mess;
+       struct def *edf;
+{
+       if (edf) {
+               if (edf->df_kind != D_ERROR)  {
+                       node_error(nd, "\"%s\": %s", edf->df_idf->id_text, mess);
+               }
+       }
+       else    node_error(nd, "%s", mess);
+}
+
 int
 ChkVariable(expp)
        register struct node *expp;
@@ -37,7 +51,7 @@ ChkVariable(expp)
 
        if (expp->nd_class == Def &&
            !(expp->nd_def->df_kind & (D_FIELD|D_VARIABLE))) {
-               node_error(expp, "variable expected");
+               Xerror(expp, "variable expected", expp->nd_def);
                return 0;
        }
 
@@ -63,7 +77,7 @@ ChkArrow(expp)
        tp = expp->nd_right->nd_type;
 
        if (tp->tp_fund != T_POINTER) {
-               node_error(expp, "illegal operand for unary operator \"^\"");
+               node_error(expp, "\"^\": illegal operand");
                return 0;
        }
 
@@ -82,22 +96,18 @@ ChkArr(expp)
        */
 
        register struct type *tpl, *tpr;
+       int retval;
 
        assert(expp->nd_class == Arrsel);
        assert(expp->nd_symb == '[');
 
        expp->nd_type = error_type;
 
-       if ( 
-            !ChkVariable(expp->nd_left)
-          ||
-            !ChkExpression(expp->nd_right)
-          ||
-            expp->nd_left->nd_type == error_type
-          )    return 0;
+       retval = ChkVariable(expp->nd_left) & ChkExpression(expp->nd_right);
 
        tpl = expp->nd_left->nd_type;
        tpr = expp->nd_right->nd_type;
+       if (tpl == error_type || tpr == error_type) return 0;
 
        if (tpl->tp_fund != T_ARRAY) {
                node_error(expp, "not indexing an ARRAY type");
@@ -116,7 +126,7 @@ ChkArr(expp)
        }
 
        expp->nd_type = RemoveEqual(tpl->arr_elem);
-       return 1;
+       return retval;
 }
 
 #ifdef DEBUG
@@ -168,11 +178,11 @@ ChkLinkOrName(expp)
                     !(left->nd_def->df_kind & (D_MODULE|D_VARIABLE|D_FIELD))
                    )
                   ) {
-                       node_error(left, "illegal selection");
+                       Xerror(left, "illegal selection", left->nd_def);
                        return 0;
                }
 
-               if (!(df = lookup(expp->nd_IDF, left->nd_type->rec_scope))) {
+               if (!(df = lookup(expp->nd_IDF, left->nd_type->rec_scope, 1))) {
                        id_not_declared(expp);
                        return 0;
                }
@@ -184,9 +194,7 @@ ChkLinkOrName(expp)
                                /* Fields of a record are always D_QEXPORTED,
                                   so ...
                                */
-node_error(expp, "identifier \"%s\" not exported from qualifying module",
-df->df_idf->id_text);
-                               return 0;
+Xerror(expp, "not exported from qualifying module", df);
                        }
                }
 
@@ -202,7 +210,6 @@ df->df_idf->id_text);
        assert(expp->nd_class == Def);
 
        df = expp->nd_def;
-       if (df->df_kind == D_ERROR) return 0;
 
        if (df->df_kind & (D_ENUM | D_CONST)) {
                /* Replace an enum-literal or a CONST identifier by its value.
@@ -220,8 +227,7 @@ df->df_idf->id_text);
                        expp->nd_lineno = ln;
                }
        }
-
-       return 1;
+       return df->df_kind != D_ERROR;
 }
 
 STATIC int
@@ -238,7 +244,7 @@ ChkExLinkOrName(expp)
        df = expp->nd_def;
 
        if (!(df->df_kind & D_VALUE)) {
-               node_error(expp, "value expected");
+               Xerror(expp, "value expected", df);
        }
 
        if (df->df_kind == D_PROCEDURE) {
@@ -352,19 +358,18 @@ ChkSet(expp)
                /* A type was given. Check it out
                */
                if (! ChkDesignator(nd)) return 0;
-
                assert(nd->nd_class == Def);
                df = nd->nd_def;
 
                if (!is_type(df) ||
-                   (df->df_type->tp_fund != T_SET)) {
+                   (df->df_type->tp_fund != T_SET)) {
                        if (df->df_kind != D_ERROR) {
-node_error(expp, "type specifier does not represent a set type");
+                               Xerror(expp, "not a set type", df);
                        }
                        return 0;
                }
                tp = df->df_type;
-               FreeNode(expp->nd_left);
+               FreeNode(nd);
                expp->nd_left = 0;
        }
        else    tp = bitset_type;
@@ -412,8 +417,9 @@ node_error(expp, "type specifier does not represent a set type");
 }
 
 STATIC struct node *
-getarg(argp, bases, designator)
+getarg(argp, bases, designator, edf)
        struct node **argp;
+       struct def *edf;
 {
        /*      This routine is used to fetch the next argument from an
                argument list. The argument list is indicated by "argp".
@@ -427,7 +433,7 @@ getarg(argp, bases, designator)
        register struct node *left;
 
        if (! arg) {
-               node_error(*argp, "too few arguments supplied");
+               Xerror(*argp, "too few arguments supplied", edf);
                return 0;
        }
 
@@ -443,7 +449,7 @@ getarg(argp, bases, designator)
 
        if (bases) {
                if (!(BaseType(left->nd_type)->tp_fund & bases)) {
-                       node_error(arg, "unexpected type");
+                       Xerror(arg, "unexpected parameter type", edf);
                        return 0;
                }
        }
@@ -453,8 +459,9 @@ getarg(argp, bases, designator)
 }
 
 STATIC struct node *
-getname(argp, kinds)
+getname(argp, kinds, bases, edf)
        struct node **argp;
+       struct def *edf;
 {
        /*      Get the next argument from argument list "argp".
                The argument must indicate a definition, and the
@@ -464,7 +471,7 @@ getname(argp, kinds)
        register struct node *left;
 
        if (!arg->nd_right) {
-               node_error(arg, "too few arguments supplied");
+               Xerror(arg, "too few arguments supplied", edf);
                return 0;
        }
 
@@ -473,15 +480,22 @@ getname(argp, kinds)
        if (! ChkDesignator(left)) return 0;
 
        if (left->nd_class != Def && left->nd_class != LinkDef) {
-               node_error(arg, "identifier expected");
+               Xerror(arg, "identifier expected", edf);
                return 0;
        }
 
        if (!(left->nd_def->df_kind & kinds)) {
-               node_error(arg, "unexpected type");
+               Xerror(arg, "unexpected parameter type", edf);
                return 0;
        }
 
+       if (bases) {
+               if (!(left->nd_type->tp_fund & bases)) {
+                       Xerror(arg, "unexpected parameter type", edf);
+                       return 0;
+               }
+       }
+
        *argp = arg;
        return left;
 }
@@ -493,16 +507,25 @@ ChkProcCall(expp)
        /*      Check a procedure call
        */
        register struct node *left;
-       struct node *arg;
+       struct def *edf = 0;
        register struct paramlist *param;
+       char ebuf[256];
+       int retval = 1;
+       int cnt = 0;
 
        left = expp->nd_left;
+       if (left->nd_class == Def || left->nd_class == LinkDef) {
+               edf = left->nd_def;
+       }
        expp->nd_type = RemoveEqual(ResultType(left->nd_type));
 
        /* Check parameter list
        */
        for (param = ParamList(left->nd_type); param; param = param->next) {
-               if (!(left = getarg(&expp, 0, IsVarParam(param)))) return 0;
+               if (!(left = getarg(&expp, 0, IsVarParam(param), edf))) {
+                       return 0;
+               }
+               cnt++;
                if (left->nd_symb == STRING) {
                        TryToString(left, TypeOfParam(param));
                }
@@ -510,17 +533,19 @@ ChkProcCall(expp)
                                   left->nd_type,
                                   IsVarParam(param),
                                   left)) {
-node_error(left, "type incompatibility in parameter");
-                       return 0;
+                       sprint(ebuf, "type incompatibility in parameter %d",
+                                       cnt);
+                       Xerror(left, ebuf, edf);
+                       retval = 0;
                }
        }
 
        if (expp->nd_right) {
-               node_error(expp->nd_right, "too many parameters supplied");
+               Xerror(expp->nd_right, "too many parameters supplied", edf);
                return 0;
        }
 
-       return 1;
+       return retval;
 }
 
 int
@@ -659,11 +684,12 @@ ChkBinOper(expp)
        register struct node *left, *right;
        struct type *tpl, *tpr;
        int allowed;
+       int retval;
 
        left = expp->nd_left;
        right = expp->nd_right;
 
-       if (!ChkExpression(left) || !ChkExpression(right)) return 0;
+       retval = ChkExpression(left) & ChkExpression(right);
 
        tpl = BaseType(left->nd_type);
        tpr = BaseType(right->nd_type);
@@ -695,24 +721,27 @@ ChkBinOper(expp)
                if (!TstAssCompat(tpl, ElementType(tpr))) {
                        /* Assignment compatible ???
                           I don't know! Should we be allowed to check
-                          if a CARDINAL is a member of a BITSET???
+                          if a INTEGER is a member of a BITSET???
                        */
 
-node_error(expp, "incompatible types for operator \"IN\"");
+                       node_error(expp, "\"IN\": incompatible types");
                        return 0;
                }
                if (left->nd_class == Value && right->nd_class == Set) {
                        cstset(expp);
                }
-               return 1;
+               return retval;
        }
 
+       if (!retval) return 0;
+
        allowed = AllowedTypes(expp->nd_symb);
 
        if (!(tpr->tp_fund & allowed) || !(tpl->tp_fund & allowed)) {
                if (!((T_CARDINAL & allowed) &&
                     ChkAddress(tpl, tpr))) {
-node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb));
+                       node_error(expp, "\"%s\": illegal operand type(s)", 
+                                    symbol2str(expp->nd_symb));
                        return 0;
                }
                if (expp->nd_type->tp_fund & T_CARDINAL) {
@@ -721,16 +750,15 @@ node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_
        }
 
        if (Boolean(expp->nd_symb) && tpl != bool_type) {
-node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb));
-           
+               node_error(expp, "\"%s\": illegal operand type(s)",
+                            symbol2str(expp->nd_symb));
                return 0;
        }
 
        /* Operands must be compatible (distilled from Def 8.2)
        */
        if (!TstCompat(tpl, tpr)) {
-               node_error(expp, "incompatible types for operator \"%s\"",
-                                       symbol2str(expp->nd_symb));
+               node_error(expp, "\"%s\": incompatible types", symbol2str(expp->nd_symb));
                return 0;
        }
 
@@ -810,14 +838,14 @@ ChkUnOper(expp)
        default:
                crash("ChkUnOper");
        }
-       node_error(expp, "illegal operand for unary operator \"%s\"",
-                       symbol2str(expp->nd_symb));
+       node_error(expp, "\"%s\": illegal operand", symbol2str(expp->nd_symb));
        return 0;
 }
 
 STATIC struct node *
-getvariable(argp)
+getvariable(argp, edf)
        struct node **argp;
+       struct def *edf;
 {
        /*      Get the next argument from argument list "argp".
                It must obey the rules of "ChkVariable".
@@ -826,7 +854,7 @@ getvariable(argp)
 
        arg = arg->nd_right;
        if (!arg) {
-               node_error(arg, "too few parameters supplied");
+               Xerror(arg, "too few parameters supplied", edf);
                return 0;
        }
 
@@ -844,14 +872,16 @@ ChkStandard(expp, left)
        /*      Check a call of a standard procedure or function
        */
        struct node *arg = expp;
+       register struct def *edf;
        int std;
 
        assert(left->nd_class == Def);
        std = left->nd_def->df_value.df_stdname;
+       edf = left->nd_def;
 
        switch(std) {
        case S_ABS:
-               if (!(left = getarg(&arg, T_NUMERIC, 0))) return 0;
+               if (!(left = getarg(&arg, T_NUMERIC, 0, edf))) return 0;
                expp->nd_type = left->nd_type;
                if (left->nd_class == Value &&
                    expp->nd_type->tp_fund != T_REAL) {
@@ -861,28 +891,31 @@ ChkStandard(expp, left)
 
        case S_CAP:
                expp->nd_type = char_type;
-               if (!(left = getarg(&arg, T_CHAR, 0))) return 0;
+               if (!(left = getarg(&arg, T_CHAR, 0, edf))) return 0;
                if (left->nd_class == Value) cstcall(expp, S_CAP);
                break;
 
        case S_CHR:
                expp->nd_type = char_type;
-               if (!(left = getarg(&arg, T_INTORCARD, 0))) return 0;
+               if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0;
                if (left->nd_class == Value) cstcall(expp, S_CHR);
                break;
 
        case S_FLOAT:
                expp->nd_type = real_type;
-               if (!(left = getarg(&arg, T_INTORCARD, 0))) return 0;
+               if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0;
                break;
 
        case S_HIGH:
-               if (!(left = getarg(&arg, T_ARRAY|T_STRING|T_CHAR, 0))) return 0;
+               if (!(left = getarg(&arg, T_ARRAY|T_STRING|T_CHAR, 0, edf))) {
+                       return 0;
+               }
                if (IsConformantArray(left->nd_type)) {
-                       /* A conformant array has no explicit index type
-                          ??? So, what can we use as index-type ???
+                       /* A conformant array has no explicit index type,
+                          but it is a subrange with lower bound 0, so
+                          it is of type CARDINAL !!!
                        */
-                       expp->nd_type = intorcard_type;
+                       expp->nd_type = card_type;
                        break;
                }
                if (left->nd_type->tp_fund == T_ARRAY) {
@@ -890,14 +923,17 @@ ChkStandard(expp, left)
                        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;
-                       }
+               if (left->nd_symb != STRING) {
+                       Xerror(left,"array parameter expected", edf);
+                       return 0;
                }
-               expp->nd_type = intorcard_type;
+               expp->nd_type = card_type;
                expp->nd_class = Value;
+               /* Notice that we could disallow HIGH("") here by checking
+                  that left->nd_type->tp_fund != T_CHAR || left->nd_INT != 0.
+                  ??? For the time being, we don't. !!!
+                  Maybe the empty string should not be allowed at all.
+               */
                expp->nd_INT = left->nd_type->tp_fund == T_CHAR ? 0 :
                                        left->nd_SLE - 1;
                expp->nd_symb = INTEGER;
@@ -905,9 +941,7 @@ ChkStandard(expp, left)
 
        case S_MAX:
        case S_MIN:
-               if (!(left = getname(&arg, D_ISTYPE))) return 0;
-               if (!(left->nd_type->tp_fund & (T_DISCRETE))) {
-node_error(left, "illegal type in %s", std == S_MAX ? "MAX" : "MIN");
+               if (!(left = getname(&arg, D_ISTYPE, T_DISCRETE, edf))) {
                        return 0;
                }
                expp->nd_type = left->nd_type;
@@ -915,17 +949,13 @@ node_error(left, "illegal type in %s", std == S_MAX ? "MAX" : "MIN");
                break;
 
        case S_ODD:
-               if (!(left = getarg(&arg, T_INTORCARD, 0))) return 0;
+               if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0;
                expp->nd_type = bool_type;
                if (left->nd_class == Value) cstcall(expp, S_ODD);
                break;
 
        case S_ORD:
-               if (!(left = getarg(&arg, T_DISCRETE, 0))) return 0;
-               if (left->nd_type->tp_size > word_size) {
-                       node_error(left, "illegal type in argument of ORD");
-                       return 0;
-               }
+               if (!(left = getarg(&arg, T_DISCRETE, 0, edf))) return 0;
                expp->nd_type = card_type;
                if (left->nd_class == Value) cstcall(expp, S_ORD);
                break;
@@ -937,12 +967,12 @@ node_error(left, "illegal type in %s", std == S_MAX ? "MAX" : "MIN");
 
                        if (!warning_given) {
                                warning_given = 1;
-       node_warning(expp, W_OLDFASHIONED, "NEW and DISPOSE are old-fashioned");
+       node_warning(expp, W_OLDFASHIONED, "NEW and DISPOSE are obsolete");
                        }
                }
-               if (! (left = getvariable(&arg))) return 0;
+               if (! (left = getvariable(&arg, edf))) return 0;
                if (! (left->nd_type->tp_fund == T_POINTER)) {
-                       node_error(left, "pointer variable expected");
+                       Xerror(left, "pointer variable expected", edf);
                        return 0;
                }
                if (left->nd_class == Def) {
@@ -974,23 +1004,19 @@ node_error(left, "illegal type in %s", std == S_MAX ? "MAX" : "MIN");
        case S_TSIZE:   /* ??? */
        case S_SIZE:
                expp->nd_type = intorcard_type;
-               if (! getname(&arg, D_FIELD|D_VARIABLE|D_ISTYPE)) return 0;
+               if (! getname(&arg, D_FIELD|D_VARIABLE|D_ISTYPE, 0, edf)) {
+                       return 0;
+               }
                cstcall(expp, S_SIZE);
                break;
 
        case S_TRUNC:
                expp->nd_type = card_type;
-               if (!(left = getarg(&arg, T_REAL, 0))) return 0;
+               if (!(left = getarg(&arg, T_REAL, 0, edf))) return 0;
                break;
 
        case S_VAL:
-               {
-               struct type *tp;
-
-               if (!(left = getname(&arg, D_ISTYPE))) return 0;
-               tp = left->nd_def->df_type;
-               if (!(tp->tp_fund & T_DISCRETE)) {
-                       node_error(arg, "unexpected type");
+               if (!(left = getname(&arg, D_ISTYPE, T_DISCRETE, edf))) {
                        return 0;
                }
                expp->nd_type = left->nd_def->df_type;
@@ -998,26 +1024,25 @@ node_error(left, "illegal type in %s", std == S_MAX ? "MAX" : "MIN");
                arg->nd_right = 0;
                FreeNode(arg);
                arg = expp;
-               if (!(left = getarg(&arg, T_INTORCARD, 0))) return 0;
+               if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0;
                if (left->nd_class == Value) cstcall(expp, S_VAL);
                break;
-               }
 
        case S_ADR:
                expp->nd_type = address_type;
-               if (!(left = getarg(&arg, 0, 1))) return 0;
+               if (!(left = getarg(&arg, 0, 1, edf))) return 0;
                break;
 
        case S_DEC:
        case S_INC:
                expp->nd_type = 0;
-               if (! (left = getvariable(&arg))) return 0;
+               if (! (left = getvariable(&arg, edf))) return 0;
                if (! (left->nd_type->tp_fund & T_DISCRETE)) {
-node_error(left,"illegal type in argument of %s",std == S_INC ? "INC" : "DEC");
+                       Xerror(left,"illegal parameter type", edf);
                        return 0;
                }
                if (arg->nd_right) {
-                       if (! getarg(&arg, T_INTORCARD, 0)) return 0;
+                       if (! getarg(&arg, T_INTORCARD, 0, edf)) return 0;
                }
                break;
 
@@ -1031,18 +1056,18 @@ node_error(left,"illegal type in argument of %s",std == S_INC ? "INC" : "DEC");
                struct type *tp;
 
                expp->nd_type = 0;
-               if (!(left = getvariable(&arg))) return 0;
+               if (!(left = getvariable(&arg, edf))) return 0;
                tp = left->nd_type;
                if (tp->tp_fund != T_SET) {
-node_error(arg, "%s expects a SET parameter", std == S_EXCL ? "EXCL" : "INCL");
+                       Xerror(arg, "SET parameter expected", edf);
                        return 0;
                }
-               if (!(left = getarg(&arg, T_DISCRETE, 0))) return 0;
+               if (!(left = getarg(&arg, T_DISCRETE, 0, edf))) return 0;
                if (!TstAssCompat(ElementType(tp), left->nd_type)) {
                        /* What type of compatibility do we want here?
                           apparently assignment compatibility! ??? ???
                        */
-                       node_error(arg, "unexpected type");
+                       Xerror(arg, "unexpected parameter type", edf);
                        return 0;
                }
                break;
@@ -1053,7 +1078,7 @@ node_error(arg, "%s expects a SET parameter", std == S_EXCL ? "EXCL" : "INCL");
        }
 
        if (arg->nd_right) {
-               node_error(arg->nd_right, "too many parameters supplied");
+               Xerror(arg->nd_right, "too many parameters supplied", edf);
                return 0;
        }
 
@@ -1074,7 +1099,7 @@ ChkCast(expp, left)
        register struct node *arg = expp->nd_right;
 
        if ((! arg) || arg->nd_right) {
-node_error(expp, "only one parameter expected in type cast");
+               Xerror(expp, "too many parameters in type cast", left->nd_def);
                return 0;
        }
 
@@ -1084,7 +1109,7 @@ node_error(expp, "only one parameter expected in type cast");
        if (arg->nd_type->tp_size != left->nd_type->tp_size &&
            (arg->nd_type->tp_size > word_size ||
             left->nd_type->tp_size > word_size)) {
-               node_error(expp, "unequal sizes in type cast");
+               Xerror(expp, "unequal sizes in type cast", left->nd_def);
        }
 
        if (arg->nd_class == Value) {
@@ -1132,8 +1157,7 @@ no_desig(expp)
 }
 
 STATIC int
-done_before(expp)
-       struct node *expp;
+done_before()
 {
        return 1;
 }

diff --git a/lang/m2/comp/code.c b/lang/m2/comp/code.c
index d5d419e..1fbea8b 100644 (file)
--- a/lang/m2/comp/code.c
+++ b/lang/m2/comp/code.c
@@ -65,6 +65,7 @@ CodeString(nd)
        }
 }
 
+STATIC
 CodePadString(nd, sz)
        register struct node *nd;
        arith sz;
@@ -96,7 +97,7 @@ CodeExpr(nd, ds, true_label, false_label)
        if (tp->tp_fund == T_REAL) fp_used = 1;
        switch(nd->nd_class) {
        case Def:
-               if (nd->nd_def->df_kind == D_PROCEDURE) {
+               if (nd->nd_def->df_kind & (D_PROCEDURE|D_PROCHEAD)) {
                        C_lpi(NameOfProc(nd->nd_def));
                        ds->dsg_kind = DSG_LOADED;
                        break;
@@ -380,7 +381,7 @@ CodeParameters(param, arg)
                        }
                }
                else if (left->nd_symb == STRING) {
-                       C_loc(left->nd_SLE - 1);
+                       C_loc(left->nd_SLE);
                }
                else if (tp->arr_elem == word_type) {
                        C_loc((left_type->tp_size+word_size-1) / word_size - 1);
@@ -403,8 +404,10 @@ CodeParameters(param, arg)
                if (left_type->tp_fund == T_STRING) {
                        CodePadString(left, tp->tp_size);
                }
-               else CodePExpr(left);
-               RangeCheck(left_type, tp);
+               else {
+                       CodePExpr(left);
+                       RangeCheck(left_type, tp);
+               }
        }
 }
 
@@ -413,7 +416,7 @@ CodeStd(nd)
 {
        register struct node *arg = nd->nd_right;
        register struct node *left = 0;
-       register struct type *tp = 0;
+       register struct type *tp;
        int std = nd->nd_left->nd_def->df_value.df_stdname;
 
        if (arg) {
@@ -426,15 +429,11 @@ CodeStd(nd)
        case S_ABS:
                CodePExpr(left);
                if (tp->tp_fund == T_INTEGER) {
-                       if (tp->tp_size == int_size) {
-                               C_cal("_absi");
-                       }
+                       if (tp->tp_size == int_size) C_cal("_absi");
                        else    C_cal("_absl");
                }
                else if (tp->tp_fund == T_REAL) {
-                       if (tp->tp_size == float_size) {
-                               C_cal("_absf");
-                       }
+                       if (tp->tp_size == float_size) C_cal("_absf");
                        else    C_cal("_absd");
                }
                C_asp(tp->tp_size);

diff --git a/lang/m2/comp/cstoper.c b/lang/m2/comp/cstoper.c
index aeb9bb8..5f743b4 100644 (file)
--- a/lang/m2/comp/cstoper.c
+++ b/lang/m2/comp/cstoper.c
@@ -72,7 +72,7 @@ cstbin(expp)
        */
        register arith o1 = expp->nd_left->nd_INT;
        register arith o2 = expp->nd_right->nd_INT;
-       register int uns = expp->nd_type != int_type;
+       register int uns = expp->nd_left->nd_type != int_type;
 
        assert(expp->nd_class == Oper);
        assert(expp->nd_left->nd_class == Value);

diff --git a/lang/m2/comp/declar.g b/lang/m2/comp/declar.g
index 8a277ed..00624af 100644 (file)
--- a/lang/m2/comp/declar.g
+++ b/lang/m2/comp/declar.g
@@ -50,13 +50,14 @@ ProcedureHeading(struct def **pdf; int type;)
 ;
 
 block(struct node **pnd;) :
-       declaration*
-       [               { return_occurred = 0; }
+       [       %persistent
+               declaration
+       ]*
+                       { return_occurred = 0; *pnd = 0; }
+       [       %persistent
                BEGIN
                StatementSequence(pnd)
-       |
-                       { *pnd = 0; }
-       ]
+       ]?
        END
 ;
 
@@ -72,7 +73,7 @@ declaration:
        ModuleDeclaration ';'
 ;
 
-FormalParameters(struct paramlist *ppr; arith *parmaddr; struct type **ptp;):
+FormalParameters(struct paramlist **ppr; arith *parmaddr; struct type **ptp;):
        '('
        [
                FPSection(ppr, parmaddr)
@@ -160,10 +161,15 @@ enumeration(struct type **ptp;)
 } :
        '(' IdentList(&EnumList) ')'
                {
-                 *ptp = standard_type(T_ENUMERATION, 1, (arith) 1);
+                 *ptp = standard_type(T_ENUMERATION, int_align, int_size);
                  EnterEnumList(EnumList, *ptp);
-                 if ((*ptp)->enm_ncst > 256) { /* ??? is this reasonable ??? */
-                       error("too many enumeration literals");
+                 if (ufit((*ptp)->enm_ncst-1, 1)) {
+                       (*ptp)->tp_size = 1;
+                       (*ptp)->tp_align = 1;
+                 }
+                 else if (ufit((*ptp)->enm_ncst-1, short_size)) {
+                       (*ptp)->tp_size = short_size;
+                       (*ptp)->tp_align = short_align;
                  }
                }
 ;
@@ -263,7 +269,7 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
        /* Also accept old fashioned Modula-2 syntax, but give a warning.
           Sorry for the complicated code.
        */
-       [ qualident(0, (struct def **) 0, (char *) 0, &nd1)
+       [ qualident(&nd1)
                        { nd = nd1; }
          [ ':' qualtype(&tp)
                        /* This is correct, in both kinds of Modula-2, if
@@ -387,7 +393,7 @@ PointerType(struct type **ptp;)
 } :
        POINTER TO
                        { *ptp = construct_type(T_POINTER, NULLTYPE); }
-       [ %if   ( lookup(dot.TOK_IDF, CurrentScope)
+       [ %if   ( lookup(dot.TOK_IDF, CurrentScope, 1)
                        /* Either a Module or a Type, but in both cases defined
                           in this scope, so this is the correct identification
                        */
@@ -422,18 +428,34 @@ PointerType(struct type **ptp;)
 
 qualtype(struct type **ptp;)
 {
-       struct def *df = 0;
+       register struct node *nd;
+       struct node *nd1;               /* because &nd is illegal */
 } :
-       qualident(D_ISTYPE, &df, "type", (struct node **) 0)
-                       { if (df && !(*ptp = df->df_type)) {
-                               error("type \"%s\" not declared",
-                                      df->df_idf->id_text);
-                               *ptp = error_type;
-                         }
+       qualident(&nd1)
+               { nd = nd1;
+                 *ptp = error_type;
+                 if (ChkDesignator(nd)) {
+                       if (nd->nd_class != Def) {
+                               node_error(nd, "type expected");
+                       }
+                       else {
+                               register struct def *df = nd->nd_def;
+
+                               if (df->df_kind&(D_ISTYPE|D_FORWARD|D_ERROR)) {
+                                   if (! df->df_type) {
+node_error(nd,"type \"%s\" not (yet) declared", df->df_idf->id_text);
+                                   }
+                                   else *ptp = df->df_type;
+                               }
+                               else {
+node_error(nd,"identifier \"%s\" is not a type", df->df_idf->id_text);
+                               }
                        }
+                 }
+                 FreeNode(nd);
+               }
 ;
 
-
 ProcedureType(struct type **ptp;)
 {
        struct paramlist *pr = 0;

diff --git a/lang/m2/comp/def.H b/lang/m2/comp/def.H
index 226395c..dee4b94 100644 (file)
--- a/lang/m2/comp/def.H
+++ b/lang/m2/comp/def.H
@@ -90,9 +90,8 @@ struct def    {               /* list of definitions for a name */
 #define is_type(dfx)   ((dfx)->df_kind & D_ISTYPE)
        char df_flags;
 #define D_NOREG                0x01    /* set if it may not reside in a register */
-#define D_USED         0x02    /* set if used */
-#define D_DEFINED      0x04    /* set if it is assigned a value */
-#define D_REFERRED     0x08    /* set if it is referred to */
+#define D_USED         0x02    /* set if used (future use ???) */
+#define D_DEFINED      0x04    /* set if it is assigned a value (future use ???) */
 #define D_VARPAR       0x10    /* set if it is a VAR parameter */
 #define D_VALPAR       0x20    /* set if it is a value parameter */
 #define D_EXPORTED     0x40    /* set if exported */

diff --git a/lang/m2/comp/def.c b/lang/m2/comp/def.c
index c57f915..36c8906 100644 (file)
--- a/lang/m2/comp/def.c
+++ b/lang/m2/comp/def.c
@@ -91,14 +91,14 @@ define(id, scope, kind)
        */
        register struct def *df;
 
-       df = lookup(id, scope);
+       df = lookup(id, scope, 1);
        if (    /* Already in this scope */
                df
           ||   /* A closed scope, and id defined in the pervasive scope */
                ( 
                  scopeclosed(scope)
                &&
-                 (df = lookup(id, PervasiveScope)))
+                 (df = lookup(id, PervasiveScope, 1)))
           ) {
                switch(df->df_kind) {
                case D_HIDDEN:
@@ -234,7 +234,7 @@ DeclProc(type, id)
        else {
                char *name;
 
-               df = lookup(id, CurrentScope);
+               df = lookup(id, CurrentScope, 1);
                if (df && df->df_kind == D_PROCHEAD) {
                        /* C_exp already generated when we saw the definition
                           in the definition module

diff --git a/lang/m2/comp/defmodule.c b/lang/m2/comp/defmodule.c
index aaf49e9..b381d68 100644 (file)
--- a/lang/m2/comp/defmodule.c
+++ b/lang/m2/comp/defmodule.c
@@ -16,6 +16,7 @@
 #include       "main.h"
 #include       "node.h"
 #include       "type.h"
+#include       "misc.h"
 
 #ifdef DEBUG
 long   sys_filesize();
@@ -57,7 +58,7 @@ GetDefinitionModule(id, incr)
        struct scopelist *vis;
 
        level += incr;
-       df = lookup(id, GlobalScope);
+       df = lookup(id, GlobalScope, 1);
        if (!df) {
                /* Read definition module. Make an exception for SYSTEM.
                */
@@ -66,7 +67,7 @@ GetDefinitionModule(id, incr)
                }
                else {
                        open_scope(CLOSEDSCOPE);
-                       if (GetFile(id->id_text)) {
+                       if (!is_anon_idf(id) && GetFile(id->id_text)) {
                                DefModule();
                                if (level == 1) {
                                        /* The module is directly imported by
@@ -90,14 +91,17 @@ GetDefinitionModule(id, incr)
                        vis = CurrVis;
                        close_scope(SC_CHKFORW);
                }
-               df = lookup(id, GlobalScope);
+               df = lookup(id, GlobalScope, 1);
                if (! df) {
                        df = MkDef(id, GlobalScope, D_ERROR);
                        df->df_type = error_type;
-                       df->mod_vis = CurrVis;
-                       return df;
+                       df->mod_vis = vis;
                }
        }
+       else if (df == Defined) {
+               error("cannot import from currently defined module");
+               df->df_kind = D_ERROR;
+       }
        assert(df);
        level -= incr;
        return df;

diff --git a/lang/m2/comp/desig.c b/lang/m2/comp/desig.c
index b873633..66d7ab4 100644 (file)
--- a/lang/m2/comp/desig.c
+++ b/lang/m2/comp/desig.c
@@ -219,7 +219,6 @@ CodeVarDesig(df, ds)
        */
        assert(ds->dsg_kind == DSG_INIT);
 
-       SetUsed(df);
        if (df->var_addrgiven) {
                /* the programmer specified an address in the declaration of
                   the variable. Generate code to push the address.
@@ -293,7 +292,6 @@ CodeDesig(nd, ds)
        case Def:
                df = nd->nd_def;
 
-               SetUsed(df);
                switch(df->df_kind) {
                case D_FIELD:
                        CodeFieldDesig(df, ds);

diff --git a/lang/m2/comp/enter.c b/lang/m2/comp/enter.c
index b5c0aa0..04a948e 100644 (file)
--- a/lang/m2/comp/enter.c
+++ b/lang/m2/comp/enter.c
@@ -273,7 +273,7 @@ ForwDef(ids, scope)
        */
        register struct def *df;
 
-       if (!(df = lookup(ids->nd_IDF, scope))) {
+       if (!(df = lookup(ids->nd_IDF, scope, 1))) {
                df = define(ids->nd_IDF, scope, D_FORWARD);
                df->for_node = MkLeaf(Name, &(ids->nd_token));
        }
@@ -292,9 +292,7 @@ EnterExportList(Idlist, qualified)
        register struct def *df, *df1;
 
        for (;idlist; idlist = idlist->next) {
-               extern struct def *NoImportlookup();
-
-               df = NoImportlookup(idlist->nd_IDF, CurrentScope);
+               df = lookup(idlist->nd_IDF, CurrentScope, 0);
 
                if (!df) {
                        /* undefined item in export list
@@ -332,7 +330,7 @@ EnterExportList(Idlist, qualified)
                           scope imports it.
                        */
                        df1 = lookup(idlist->nd_IDF,
-                                    enclosing(CurrVis)->sc_scope);
+                                    enclosing(CurrVis)->sc_scope, 1);
                        if (df1) {
                                /* It was already defined in the enclosing
                                   scope. There are two legal possibilities,
@@ -402,7 +400,7 @@ EnterFromImportList(Idlist, FromDef, FromId)
 
        for (; idlist; idlist = idlist->next) {
                if (forwflag) df = ForwDef(idlist, vis->sc_scope);
-               else if (! (df = lookup(idlist->nd_IDF, vis->sc_scope))) {
+               else if (! (df = lookup(idlist->nd_IDF, vis->sc_scope, 1))) {
                    not_declared("identifier", idlist, " in qualifying module");
                    df = define(idlist->nd_IDF,vis->sc_scope,D_ERROR);
                }
@@ -434,7 +432,7 @@ EnterImportList(Idlist, local)
        for (; idlist; idlist = idlist->next) {
                DoImport(local ?
                                ForwDef(idlist, sc) :
-                               GetDefinitionModule(idlist->nd_IDF) ,
+                               GetDefinitionModule(idlist->nd_IDF, 1) ,
                         CurrentScope);
        }
        FreeNode(Idlist);

diff --git a/lang/m2/comp/expression.g b/lang/m2/comp/expression.g
index 0baa335..787669b 100644 (file)
--- a/lang/m2/comp/expression.g
+++ b/lang/m2/comp/expression.g
@@ -31,39 +31,13 @@ number(struct node **p;) :
                        }
 ;
 
-qualident(int types;
-         struct def **pdf;
-         char *str;
-         struct node **p;
-        )
+qualident(struct node **p;)
 {
-       struct node *nd;
 } :
-       IDENT   { nd = MkLeaf(Name, &dot); }
+       IDENT   { *p = MkLeaf(Name, &dot); }
        [
-               selector(&nd)
+               selector(p)
        ]*
-               { if (types && ChkDesignator(nd)) {
-                       if (nd->nd_class != Def) {
-                               node_error(nd, "%s expected", str);
-                       }
-                       else {
-                               register struct def *df = nd->nd_def;
-
-                               if ( !((types|D_ERROR) & df->df_kind)) {
-                                   if (df->df_kind == D_FORWARD) {
-                                       not_declared(str, nd, "");
-                                   }
-                                   else {
-node_error(nd,"identifier \"%s\" is not a %s", df->df_idf->id_text, str);
-                                   }
-                               }
-                               if (pdf) *pdf = df;
-                       }
-                 }
-                 if (!p) FreeNode(nd);
-                 else *p = nd;
-               }
 ;
 
 selector(struct node **pnd;):
@@ -167,7 +141,7 @@ factor(register struct node **p;)
 {
        struct node *nd;
 } :
-       qualident(0, (struct def **) 0, (char *) 0, p)
+       qualident(p)
        [
                designator_tail(p)?
                [
@@ -231,7 +205,7 @@ element(struct node *nd;)
 
 designator(struct node **pnd;)
 :
-       qualident(0, (struct def **) 0, (char *) 0, pnd)
+       qualident(pnd)
        designator_tail(pnd)?
 ;
 

diff --git a/lang/m2/comp/lookup.c b/lang/m2/comp/lookup.c
index 599cf77..c4c297a 100644 (file)
--- a/lang/m2/comp/lookup.c
+++ b/lang/m2/comp/lookup.c
@@ -15,7 +15,7 @@
 #include       "misc.h"
 
 struct def *
-lookup(id, scope)
+lookup(id, scope, import)
        register struct idf *id;
        struct scope *scope;
 {
@@ -43,7 +43,7 @@ lookup(id, scope)
                        df->next = id->id_def;
                        id->id_def = df;
                }
-               if (df->df_kind == D_IMPORT) {
+               if (import && df->df_kind == D_IMPORT) {
                        assert(df->imp_def != 0);
                        return df->imp_def;
                }
@@ -51,38 +51,6 @@ lookup(id, scope)
        return df;
 }
 
-struct def *
-NoImportlookup(id, scope)
-       register struct idf *id;
-       struct scope *scope;
-{
-       /*      Look up a definition of an identifier in scope "scope".
-               Make the "def" list self-organizing.
-               Don't check if the definition is imported!
-       */
-       register struct def *df, *df1;
-
-       /* Look in the chain of definitions of this "id" for one with scope
-          "scope".
-       */
-       for (df = id->id_def, df1 = 0;
-            df && df->df_scope != scope;
-            df1 = df, df = df->next) { /* nothing */ }
-
-       if (df) {
-               /* Found it
-               */
-               if (df1) {
-                       /* Put the definition in front
-                       */
-                       df1->next = df->next;
-                       df->next = id->id_def;
-                       id->id_def = df;
-               }
-       }
-       return df;
-}
-
 struct def *
 lookfor(id, vis, give_error)
        register struct node *id;
@@ -96,7 +64,7 @@ lookfor(id, vis, give_error)
        register struct scopelist *sc = vis;
 
        while (sc) {
-               df = lookup(id->nd_IDF, sc->sc_scope);
+               df = lookup(id->nd_IDF, sc->sc_scope, 1);
                if (df) return df;
                sc = nextvisible(sc);
        }

diff --git a/lang/m2/comp/options.c b/lang/m2/comp/options.c
index 782c67a..8bdea33 100644 (file)
--- a/lang/m2/comp/options.c
+++ b/lang/m2/comp/options.c
@@ -10,6 +10,13 @@
 #include       "main.h"
 #include       "warning.h"
 
+#define        MINIDFSIZE      14
+
+#if MINIDFSIZE < 14
+You fouled up! MINIDFSIZE has to be at least 14 or the compiler will not
+recognize some keywords!
+#endif
+
 extern int     idfsize;
 static int     ndirs;
 int            warning_classes;
@@ -72,8 +79,14 @@ DoOption(text)
                idfsize = txt2int(&t);
                if (*t || idfsize <= 0)
                        fatal("malformed -M option");
-               if (idfsize > IDFSIZE)
-                       fatal("maximum identifier length is %d", IDFSIZE);
+               if (idfsize > IDFSIZE) {
+                       idfsize = IDFSIZE;
+                       warning(W_ORDINARY,"maximum identifier length is %d", IDFSIZE);
+               }
+               if (idfsize < MINIDFSIZE) {
+                       warning(W_ORDINARY, "minimum identifier length is %d", MINIDFSIZE);
+                       idfsize = MINIDFSIZE;
+               }
                }
                break;
 
@@ -113,6 +126,10 @@ DoOption(text)
                                if (size != (arith)0) int_size = size;
                                if (align != 0) int_align = align;
                                break;
+                       case 's':       /* short (subranges) */
+                               if (size != 0) short_size = size;
+                               if (align != 0) short_align = align;
+                               break;
                        case 'l':       /* longint      */
                                if (size != (arith)0) long_size = size;
                                if (align != 0) long_align = align;

diff --git a/lang/m2/comp/program.g b/lang/m2/comp/program.g
index afaeb72..100c55d 100644 (file)
--- a/lang/m2/comp/program.g
+++ b/lang/m2/comp/program.g
@@ -133,7 +133,7 @@ DefinitionModule
                        modules. Issue a warning.
                */
                        { 
-node_warning(exportlist, W_ORDINARY, "export list in definition module ignored");
+node_warning(exportlist, W_OLDFASHIONED, "export list in definition module ignored");
                                FreeNode(exportlist);
                        }
        |
@@ -183,7 +183,7 @@ definition
 
 ProgramModule
 {
-       struct def *GetDefinitionModule();
+       extern struct def *GetDefinitionModule();
        register struct def *df;
 } :
        MODULE
@@ -210,7 +210,9 @@ ProgramModule
 ;
 
 Module:
-                               { open_scope(CLOSEDSCOPE); }
+                               { open_scope(CLOSEDSCOPE);
+                                 warning(W_ORDINARY, "Compiling a definition module");
+                               }
        DefinitionModule
                                { close_scope(SC_CHKFORW); }
 |

diff --git a/lang/m2/comp/type.H b/lang/m2/comp/type.H
index 0e612f2..d8a345a 100644 (file)
--- a/lang/m2/comp/type.H
+++ b/lang/m2/comp/type.H
@@ -103,6 +103,7 @@ extern struct type
 
 extern int
        word_align,
+       short_align,
        int_align,
        long_align,
        float_align,
@@ -113,6 +114,7 @@ extern int
 extern arith
        word_size,
        dword_size,
+       short_size,
        int_size,
        long_size,
        float_size,
@@ -149,3 +151,8 @@ struct type
 #define BaseType(tpx)          ((tpx)->tp_fund == T_SUBRANGE ? (tpx)->next : \
                                        (tpx))
 #define        IsConstructed(tpx)      ((tpx)->tp_fund & T_CONSTRUCTED)
+
+extern long full_mask[];
+
+#define fit(n, i)      (((n) + (0x80<<(((i)-1)*8)) & ~full_mask[(i)]) == 0)
+#define ufit(n, i)     (((n) & ~full_mask[(i)]) == 0)

diff --git a/lang/m2/comp/type.c b/lang/m2/comp/type.c
index 13fac53..e765658 100644 (file)
--- a/lang/m2/comp/type.c
+++ b/lang/m2/comp/type.c
@@ -21,6 +21,7 @@
 
 int
        word_align = AL_WORD,
+       short_align = AL_SHORT,
        int_align = AL_INT,
        long_align = AL_LONG,
        float_align = AL_FLOAT,
@@ -32,6 +33,7 @@ arith
        word_size = SZ_WORD,
        dword_size = 2 * SZ_WORD,
        int_size = SZ_INT,
+       short_size = SZ_SHORT,
        long_size = SZ_LONG,
        float_size = SZ_FLOAT,
        double_size = SZ_DOUBLE,
@@ -280,6 +282,27 @@ subr_type(lb, ub)
        res->sub_ub = ub->nd_INT;
        res->tp_size = tp->tp_size;
        res->tp_align = tp->tp_align;
+       if (tp == card_type) {
+               if (ufit(res->sub_ub, 1)) {
+                       res->tp_size = 1;
+                       res->tp_align = 1;
+               }
+               else if (ufit(res->sub_ub, 2)) {
+                       res->tp_size = short_size;
+                       res->tp_align = short_align;
+               }
+       }
+       else if (tp == int_type) {
+               if (fit(res->sub_lb, 1) && fit(res->sub_ub, 1)) {
+                       res->tp_size = 1;
+                       res->tp_align = 1;
+               }
+               else if (fit(res->sub_lb, short_size) &&
+                        fit(res->sub_ub, short_size)) {
+                       res->tp_size = short_size;
+                       res->tp_align = short_align;
+               }
+       }
        return res;
 }
 

diff --git a/lang/m2/comp/walk.c b/lang/m2/comp/walk.c
index 1672cf5..5eb5520 100644 (file)
--- a/lang/m2/comp/walk.c
+++ b/lang/m2/comp/walk.c
@@ -636,9 +636,9 @@ DoForInit(nd, left)
        nd->nd_class = Name;
        nd->nd_symb = IDENT;
 
-       if (! ChkVariable(nd) ||
-           ! WalkExpr(left->nd_left) ||
-           ! ChkExpression(left->nd_right)) return 0;
+       if (!( ChkVariable(nd) &
+              WalkExpr(left->nd_left) &
+              ChkExpression(left->nd_right))) return 0;
 
        df = nd->nd_def;
        if (df->df_kind == D_FIELD) {
@@ -696,17 +696,17 @@ DoAssign(nd, left, right)
        */
        struct desig dsl, dsr;
 
-       if (! ChkExpression(right) || ! ChkVariable(left)) return;
+       if (! (ChkExpression(right) & ChkVariable(left))) return;
 
        if (right->nd_symb == STRING) TryToString(right, left->nd_type);
        dsr = InitDesig;
-       CodeExpr(right, &dsr, NO_LABEL, NO_LABEL);
 
        if (! TstAssCompat(left->nd_type, right->nd_type)) {
                node_error(nd, "type incompatibility in assignment");
                return;
        }
 
+       CodeExpr(right, &dsr, NO_LABEL, NO_LABEL);
        if (complex(right->nd_type)) {
                CodeAddress(&dsr);
        }