fixes, added some standard functions to handle LONGREAL, LONGINT

diff --git a/lang/m2/comp/.distr b/lang/m2/comp/.distr
new file mode 100644 (file)
index 0000000..d5a1d58
--- /dev/null
+++ b/lang/m2/comp/.distr
@@ -0,0 +1,62 @@
+LLlex.c
+LLlex.h
+LLmessage.c
+Makefile
+Parameters
+Resolve
+SYSTEM.h
+Version.c
+casestat.C
+char.tab
+chk_expr.c
+chk_expr.h
+class.h
+code.c
+const.h
+cstoper.c
+debug.h
+declar.g
+def.H
+def.c
+defmodule.c
+desig.c
+desig.h
+em_m2.6
+enter.c
+error.c
+expression.g
+f_info.h
+idf.c
+idf.h
+input.c
+input.h
+lookup.c
+main.c
+main.h
+make.allocd
+make.hfiles
+make.next
+make.tokcase
+make.tokfile
+misc.c
+misc.h
+modula-2.1
+nmclash.c
+node.H
+node.c
+options.c
+program.g
+scope.C
+scope.h
+standards.h
+statement.g
+tab.c
+tmpvar.C
+tokenname.c
+tokenname.h
+type.H
+type.c
+typequiv.c
+walk.c
+walk.h
+warning.h

diff --git a/lang/m2/comp/LLlex.c b/lang/m2/comp/LLlex.c
index 3c6a047..95098c9 100644 (file)
--- a/lang/m2/comp/LLlex.c
+++ b/lang/m2/comp/LLlex.c
@@ -59,7 +59,8 @@ SkipComment()
                        /* Foreign; This definition module has an
                           implementation in another language.
                           In this case, don't generate prefixes in front
-                          of the names
+                          of the names. Also, don't generate call to
+                          initialization routine.
                        */
                        ForeignFlag = 1;
                        break;
@@ -359,7 +360,7 @@ again:
                        have to read the number with the help of a rather
                        complex finite automaton.
                */
-               enum statetp {Oct,Hex,Dec,OctEndOrHex,End,OptReal,Real};
+               enum statetp {Oct,OptHex,Hex,Dec,OctEndOrHex,End,OptReal,Real};
                register enum statetp state;
                register int base;
                register char *np = &buf[1];
@@ -390,7 +391,8 @@ again:
                                        }
                                        LoadChar(ch);
                                }
-                               if (is_hex(ch)) state = Hex;
+                               if (ch == 'D') state = OptHex;
+                               else if (is_hex(ch)) state = Hex;
                                else if (ch == '.') state = OptReal;
                                else {
                                        state = End;
@@ -400,6 +402,15 @@ again:
                                }
                                break;
 
+                       case OptHex:
+                               LoadChar(ch);
+                               if (is_hex(ch)) {
+                                       if (np < &buf[NUMSIZE]) *np++ = 'D';
+                                       state = Hex;
+                               }
+                               else    state = End;
+                               break;
+
                        case Hex:
                                while (is_hex(ch))      {
                                        if (np < &buf[NUMSIZE]) *np++ = ch;
@@ -454,6 +465,9 @@ lexwarning(W_ORDINARY, "overflow in constant");
 lexwarning(W_ORDINARY, "character constant out of range");
                                        }
                                }
+                               else if (ch == 'D' && base == 10) {
+                                       toktype = longint_type;
+                               }
                                else if (tk->TOK_INT>=0 &&
                                         tk->TOK_INT<=max_int) {
                                        toktype = intorcard_type;
@@ -485,6 +499,8 @@ lexwarning(W_ORDINARY, "character constant out of range");
                /* a real real constant */
                if (np < &buf[NUMSIZE]) *np++ = '.';
 
+               toktype = real_type;
+
                while (is_dig(ch)) {
                        /*      Fractional part
                        */
@@ -492,9 +508,15 @@ lexwarning(W_ORDINARY, "character constant out of range");
                        LoadChar(ch);
                }
 
-               if (ch == 'E') {
+               if (ch == 'E' || ch == 'D') {
                        /*      Scale factor
                        */
+                       if (ch == 'D') {
+                               toktype = longreal_type;
+                               LoadChar(ch);
+                               if (!(ch == '+' || ch == '-' || is_dig(ch)))
+                                       goto noscale;
+                       }
                        if (np < &buf[NUMSIZE]) *np++ = 'E';
                        LoadChar(ch);
                        if (ch == '+' || ch == '-') {
@@ -514,6 +536,7 @@ lexwarning(W_ORDINARY, "character constant out of range");
                        }
                }
 
+noscale:
                *np++ = '\0';
                if (ch == EOI) eofseen = 1;
                else PushBack();
@@ -523,7 +546,6 @@ lexwarning(W_ORDINARY, "character constant out of range");
                        lexerror("floating constant too long");
                }
                else    tk->TOK_REL = Salloc(buf, (unsigned) (np - buf)) + 1;
-               toktype = real_type;
                return tk->tk_symb = REAL;
 
                /*NOTREACHED*/

diff --git a/lang/m2/comp/chk_expr.c b/lang/m2/comp/chk_expr.c
index 75e20d6..9da7a71 100644 (file)
--- a/lang/m2/comp/chk_expr.c
+++ b/lang/m2/comp/chk_expr.c
@@ -840,7 +840,7 @@ ChkUnOper(expp)
 
        case '-':
                if (tpr->tp_fund & T_INTORCARD) {
-                       if (tpr == intorcard_type) {
+                       if (tpr == intorcard_type || tpr == card_type) {
                                expp->nd_type = int_type;
                        }
                        if (right->nd_class == Value) {
@@ -849,7 +849,6 @@ ChkUnOper(expp)
                        return 1;
                }
                else if (tpr->tp_fund == T_REAL) {
-                       expp->nd_type = tpr;
                        if (right->nd_class == Value) {
                                if (*(right->nd_REL) == '-') (right->nd_REL)++;
                                else (right->nd_REL)--;
@@ -939,11 +938,47 @@ ChkStandard(expp, left)
                if (left->nd_class == Value) cstcall(expp, S_CHR);
                break;
 
+       case S_FLOATD:
        case S_FLOAT:
                expp->nd_type = real_type;
+               if (std == S_FLOATD) expp->nd_type = longreal_type;
                if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0;
                break;
 
+       case S_LONG: {
+               struct type *tp;
+
+               if (!(left = getarg(&arg, 0, 0, edf))) {
+                       return 0;
+               }
+               tp = BaseType(left->nd_type);
+               if (tp == int_type) expp->nd_type = longint_type;
+               else if (tp == real_type) expp->nd_type = longreal_type;
+               else {
+                       expp->nd_type = error_type;
+                       Xerror(left, "unexpected parameter type", edf);
+               }
+               if (left->nd_class == Value) cstcall(expp, S_LONG);
+               break;
+               }
+
+       case S_SHORT: {
+               struct type *tp;
+
+               if (!(left = getarg(&arg, 0, 0, edf))) {
+                       return 0;
+               }
+               tp = BaseType(left->nd_type);
+               if (tp == longint_type) expp->nd_type = int_type;
+               else if (tp == longreal_type) expp->nd_type = real_type;
+               else {
+                       expp->nd_type = error_type;
+                       Xerror(left, "unexpected parameter type", edf);
+               }
+               if (left->nd_class == Value) cstcall(expp, S_SHORT);
+               break;
+               }
+
        case S_HIGH:
                if (!(left = getarg(&arg, T_ARRAY|T_STRING|T_CHAR, 0, edf))) {
                        return 0;
@@ -1053,8 +1088,10 @@ ChkStandard(expp, left)
                                  expp->nd_left->nd_def->df_idf->id_text);
                break;
 
+       case S_TRUNCD:
        case S_TRUNC:
                expp->nd_type = card_type;
+               if (std == S_TRUNCD) expp->nd_type = longint_type;
                if (!(left = getarg(&arg, T_REAL, 0, edf))) return 0;
                break;
 

diff --git a/lang/m2/comp/code.c b/lang/m2/comp/code.c
index 305d2c4..ed6062b 100644 (file)
--- a/lang/m2/comp/code.c
+++ b/lang/m2/comp/code.c
@@ -456,11 +456,6 @@ CodeStd(nd)
                RangeCheck(char_type, tp);
                break;
 
-       case S_FLOAT:
-               CodePExpr(left);
-               CodeCoercion(tp, real_type);
-               break;
-
        case S_HIGH:
                assert(IsConformantArray(tp));
                DoHIGH(left->nd_def);
@@ -493,9 +488,14 @@ CodeStd(nd)
                CodePExpr(left);
                break;
 
+       case S_TRUNCD:
        case S_TRUNC:
+       case S_FLOAT:
+       case S_FLOATD:
+       case S_LONG:
+       case S_SHORT:
                CodePExpr(left);
-               CodeCoercion(tp, card_type);
+               CodeCoercion(tp, nd->nd_type);
                break;
 
        case S_VAL:

diff --git a/lang/m2/comp/cstoper.c b/lang/m2/comp/cstoper.c
index a02cb38..a2f182f 100644 (file)
--- a/lang/m2/comp/cstoper.c
+++ b/lang/m2/comp/cstoper.c
@@ -386,14 +386,19 @@ cstcall(expp, call)
                CutSize(expp);
                break;
 
+       case S_LONG:
+       case S_SHORT: {
+               struct type *tp = expp->nd_type;
+
+               *expp = *expr;
+               expp->nd_type = tp;
+               break;
+               }
        case S_CAP:
                if (expr->nd_INT >= 'a' && expr->nd_INT <= 'z') {
-                       expp->nd_INT = expr->nd_INT + ('A' - 'a');
+                       expr->nd_INT = expr->nd_INT + ('A' - 'a');
                }
-               else    expp->nd_INT = expr->nd_INT;
-               CutSize(expp);
-               break;
-
+               /* fall through */
        case S_CHR:
                expp->nd_INT = expr->nd_INT;
                CutSize(expp);

diff --git a/lang/m2/comp/defmodule.c b/lang/m2/comp/defmodule.c
index 6b91332..0bbe2e0 100644 (file)
--- a/lang/m2/comp/defmodule.c
+++ b/lang/m2/comp/defmodule.c
@@ -34,7 +34,7 @@ long  sys_filesize();
 
 struct idf *DefId;
 
-STATIC char *
+char *
 getwdir(fn)
        register char *fn;
 {
@@ -65,7 +65,6 @@ GetFile(name)
        */
        char buf[15];
        char *strncpy(), *strcat();
-       static char *WorkingDir = ".";
 
        strncpy(buf, name, 10);
        buf[10] = '\0';                 /* maximum length */

diff --git a/lang/m2/comp/desig.c b/lang/m2/comp/desig.c
index 4d1635a..e9d3735 100644 (file)
--- a/lang/m2/comp/desig.c
+++ b/lang/m2/comp/desig.c
@@ -31,7 +31,7 @@
 #include       "node.h"
 
 extern int     proclevel;
-struct desig   InitDesig = {DSG_INIT, 0, 0};
+struct desig   InitDesig = {DSG_INIT, 0, 0, 0};
 
 int    C_ste_dnam(), C_sde_dnam(), C_loe_dnam(), C_lde_dnam();
 int    C_stl(), C_sdl(), C_lol(), C_ldl();
@@ -54,6 +54,7 @@ static int (*ext_ld_and_str[2][2])() = {
 int
 DoLoadOrStore(ds, size, LoadOrStoreFlag)
        register struct desig *ds;
+       arith size;
 {
        int sz;
 
@@ -223,8 +224,8 @@ CodeMove(rhs, left, rtp)
        switch(rhs->dsg_kind) {
        case DSG_LOADED:
                CodeDesig(left, lhs);
-               CodeAddress(lhs);
                if (rtp->tp_fund == T_STRING) {
+                       CodeAddress(lhs);
                        C_loc(rtp->tp_size);
                        C_loc(tp->tp_size);
                        C_cal("_StringAssign");
@@ -315,6 +316,7 @@ CodeMove(rhs, left, rtp)
                                lhs->dsg_offset = tmp;
                                lhs->dsg_name = 0;
                                lhs->dsg_kind = DSG_PFIXED;
+                               lhs->dsg_def = 0;
                                C_stl(tmp);             /* address of lhs */
                        }
                        CodeValue(rhs, tp->tp_size, tp->tp_align);
@@ -347,6 +349,7 @@ CodeAddress(ds)
                        break;
                }
                C_lal(ds->dsg_offset);
+               if (ds->dsg_def) ds->dsg_def->df_flags |= D_NOREG;
                break;
                
        case DSG_PFIXED:
@@ -489,7 +492,8 @@ CodeVarDesig(df, ds)
                ds->dsg_kind = DSG_PFIXED;
        }
        else    ds->dsg_kind = DSG_FIXED;
-       ds->dsg_offset =df->var_off;
+       ds->dsg_offset = df->var_off;
+       ds->dsg_def = df;
 }
 
 CodeDesig(nd, ds)

diff --git a/lang/m2/comp/desig.h b/lang/m2/comp/desig.h
index 690dd9b..6a9f67d 100644 (file)
--- a/lang/m2/comp/desig.h
+++ b/lang/m2/comp/desig.h
@@ -40,6 +40,9 @@ struct desig {
        char    *dsg_name;      /* name of global variable, used for
                                   FIXED and PFIXED
                                */
+       struct def *dsg_def;    /* def structure associated with this
+                                  designator, or 0
+                               */
 };
 
 /* The next structure describes the designator in a with-statement.

diff --git a/lang/m2/comp/expression.g b/lang/m2/comp/expression.g
index ba91265..92cc725 100644 (file)
--- a/lang/m2/comp/expression.g
+++ b/lang/m2/comp/expression.g
@@ -79,16 +79,16 @@ ConstExpression(struct node **pnd;)
         * Check that the expression is a constant expression and evaluate!
         */
                { nd = *pnd;
-                 DO_DEBUG(options['X'], print("CONSTANT EXPRESSION\n"));
-                 DO_DEBUG(options['X'], PrNode(nd, 0));
+                 DO_DEBUG(options['C'], print("CONSTANT EXPRESSION\n"));
+                 DO_DEBUG(options['C'], PrNode(nd, 0));
 
                  if (ChkExpression(nd) &&
                      ((nd)->nd_class != Set && (nd)->nd_class != Value)) {
                        error("constant expression expected");
                  }
 
-                 DO_DEBUG(options['X'], print("RESULTS IN\n"));
-                 DO_DEBUG(options['X'], PrNode(nd, 0));
+                 DO_DEBUG(options['C'], print("RESULTS IN\n"));
+                 DO_DEBUG(options['C'], PrNode(nd, 0));
                }
 ;
 

diff --git a/lang/m2/comp/f_info.h b/lang/m2/comp/f_info.h
index 4d8c040..452d8a3 100644 (file)
--- a/lang/m2/comp/f_info.h
+++ b/lang/m2/comp/f_info.h
@@ -18,3 +18,4 @@ struct f_info {
 extern struct f_info file_info;
 #define LineNumber file_info.f_lineno
 #define FileName file_info.f_filename
+#define WorkingDir file_info.f_workingdir

diff --git a/lang/m2/comp/main.c b/lang/m2/comp/main.c
index 0c76c65..9f5bc8e 100644 (file)
--- a/lang/m2/comp/main.c
+++ b/lang/m2/comp/main.c
@@ -74,6 +74,7 @@ Compile(src, dst)
        char *src, *dst;
 {
        extern struct tokenname tkidf[];
+       extern char *getwdir();
 
        if (! InsertFile(src, (char **) 0, &src)) {
                fprint(STDERR,"%s: cannot open %s\n", ProgName, src);
@@ -81,6 +82,7 @@ Compile(src, dst)
        }
        LineNumber = 1;
        FileName = src;
+       WorkingDir = getwdir(src);
        init_idf();
        InitCst();
        reserve(tkidf);
@@ -171,6 +173,10 @@ static struct stdproc {
        { "MAX",        S_MAX },
        { "MIN",        S_MIN },
        { "INCL",       S_INCL },
+       { "LONG",       S_LONG },
+       { "SHORT",      S_SHORT },
+       { "TRUNCD",     S_TRUNCD },
+       { "FLOATD",     S_FLOATD },
        { 0,            0 }
 };
 
@@ -246,3 +252,13 @@ cnt_scope, cnt_scopelist, cnt_tmpvar);
 print("\nNumber of lines read: %d\n", cntlines);
 }
 #endif
+
+No_Mem()
+{
+       fatal("out of memory");
+}
+
+C_failed()
+{
+       fatal("write failed");
+}

diff --git a/lang/m2/comp/node.c b/lang/m2/comp/node.c
index 1aa825d..f0c49da 100644 (file)
--- a/lang/m2/comp/node.c
+++ b/lang/m2/comp/node.c
@@ -84,7 +84,13 @@ printnode(nd, lvl)
        register struct node *nd;
 {
        indnt(lvl);
-       print("C: %d; T: %s\n", nd->nd_class, symbol2str(nd->nd_symb));
+       print("Class: %d; Symbol: %s\n", nd->nd_class, symbol2str(nd->nd_symb));
+       if (nd->nd_type) {
+               indnt(lvl);
+               print("Type: ");
+               DumpType(nd->nd_type);
+               print("\n");
+       }
 }
 
 PrNode(nd, lvl)

diff --git a/lang/m2/comp/standards.h b/lang/m2/comp/standards.h
index e229ff7..5dd28a6 100644 (file)
--- a/lang/m2/comp/standards.h
+++ b/lang/m2/comp/standards.h
@@ -28,6 +28,10 @@
 #define S_VAL  17
 #define S_NEW  18
 #define S_DISPOSE 19
+#define S_LONG 20
+#define S_SHORT        21
+#define S_TRUNCD 22
+#define S_FLOATD 23
 
 /* Standard procedures and functions defined in the SYSTEM module ... */
 

diff --git a/lang/m2/comp/type.H b/lang/m2/comp/type.H
index 06cc533..da40e3b 100644 (file)
--- a/lang/m2/comp/type.H
+++ b/lang/m2/comp/type.H
@@ -150,6 +150,7 @@ struct type
 #define bounded(tpx)           ((tpx)->tp_fund & T_INDEX)
 #define complex(tpx)           ((tpx)->tp_fund & (T_RECORD|T_ARRAY))
 #define WA(sz)                 (align(sz, (int) word_size))
+#ifdef DEBUG
 #define ResultType(tpx)                (assert((tpx)->tp_fund == T_PROCEDURE),\
                                        (tpx)->next)
 #define ParamList(tpx)         (assert((tpx)->tp_fund == T_PROCEDURE),\
@@ -160,6 +161,13 @@ struct type
                                        (tpx)->next)
 #define PointedtoType(tpx)     (assert((tpx)->tp_fund == T_POINTER),\
                                        (tpx)->next)
+#else DEBUG
+#define ResultType(tpx)                ((tpx)->next)
+#define ParamList(tpx)         ((tpx)->prc_params)
+#define IndexType(tpx)         ((tpx)->next)
+#define ElementType(tpx)       ((tpx)->next)
+#define PointedtoType(tpx)     ((tpx)->next)
+#endif DEBUG
 #define BaseType(tpx)          ((tpx)->tp_fund == T_SUBRANGE ? (tpx)->next : \
                                        (tpx))
 #define        IsConstructed(tpx)      ((tpx)->tp_fund & T_CONSTRUCTED)

diff --git a/lang/m2/comp/type.c b/lang/m2/comp/type.c
index 9afdc88..431218c 100644 (file)
--- a/lang/m2/comp/type.c
+++ b/lang/m2/comp/type.c
@@ -652,8 +652,7 @@ DumpType(tp)
        print(" fund:");
        switch(tp->tp_fund) {
        case T_RECORD:
-               print("RECORD\n");
-               DumpScope(tp->rec_scope->sc_def);
+               print("RECORD");
                break;
        case T_ENUMERATION:
                print("ENUMERATION; ncst:%d", tp->enm_ncst); break;

diff --git a/lang/m2/comp/typequiv.c b/lang/m2/comp/typequiv.c
index 565fb8b..0452b1f 100644 (file)
--- a/lang/m2/comp/typequiv.c
+++ b/lang/m2/comp/typequiv.c
@@ -63,7 +63,7 @@ TstParEquiv(tp1, tp2)
 
 int
 TstProcEquiv(tp1, tp2)
-       register struct type *tp1, *tp2;
+       struct type *tp1, *tp2;
 {
        /*      Test if two procedure types are equivalent. This routine
                may also be used for the testing of assignment compatibility
@@ -105,31 +105,24 @@ TstCompat(tp1, tp2)
 
        tp1 = BaseType(tp1);
        tp2 = BaseType(tp2);
+       if (tp2 != intorcard_type &&
+           (tp1 == intorcard_type || tp1 == address_type)) {
+               struct type *tmp = tp2;
+               
+               tp2 = tp1;
+               tp1 = tmp;
+       }
 
        return  tp1 == tp2
-           ||
-               (  tp1 == intorcard_type
-               &&
-                  (tp2 == int_type || tp2 == card_type || tp2 == address_type)
-               )
            ||
                (  tp2 == intorcard_type
                &&
                   (tp1 == int_type || tp1 == card_type || tp1 == address_type)
                )
-           ||
-               (  tp1 == address_type
-               && 
-                 (  tp2 == card_type
-                 || tp2->tp_fund == T_POINTER
-                 )
-               )
            ||
                (  tp2 == address_type
                && 
-                 (  tp1 == card_type
-                 || tp1->tp_fund == T_POINTER
-                 )
+                 ( tp1 == card_type || tp1->tp_fund == T_POINTER)
                )
        ;
 }
@@ -151,6 +144,9 @@ TstAssCompat(tp1, tp2)
        if ((tp1->tp_fund & T_INTORCARD) &&
            (tp2->tp_fund & T_INTORCARD)) return 1;
 
+       if ((tp1->tp_fund == T_REAL) &&
+           (tp2->tp_fund == T_REAL)) return 1;
+
        if (tp1->tp_fund == T_PROCEDURE &&
            tp2->tp_fund == T_PROCEDURE) {
                return TstProcEquiv(tp1, tp2);

diff --git a/lang/m2/comp/walk.c b/lang/m2/comp/walk.c
index f64ac40..ad0bae8 100644 (file)
--- a/lang/m2/comp/walk.c
+++ b/lang/m2/comp/walk.c
@@ -141,8 +141,8 @@ WalkModule(module)
        }
        MkCalls(sc->sc_def);
        proclevel++;
-       DO_DEBUG(options['X'], PrNode(module->mod_body, 0));
        WalkNode(module->mod_body, NO_EXIT_LABEL);
+       DO_DEBUG(options['X'], PrNode(module->mod_body, 0));
        C_df_ilb(RETURN_LABEL);
        EndPriority();
        C_ret((arith) 0);
@@ -293,8 +293,8 @@ WalkProcedure(procedure)
 
        text_label = 1;         /* label at end of procedure */
 
-       DO_DEBUG(options['X'], PrNode(procedure->prc_body, 0));
        WalkNode(procedure->prc_body, NO_EXIT_LABEL);
+       DO_DEBUG(options['X'], PrNode(procedure->prc_body, 0));
        C_df_ilb(RETURN_LABEL); /* label at end */
        tp = func_type;
        if (func_res_label) {