merge in conformant array code by Carol Nishizak

SCCS-vsn: usr.bin/pascal/src/OPnames.h 1.8
SCCS-vsn: usr.bin/pascal/src/conv.c 1.7
SCCS-vsn: usr.bin/pascal/src/tree.h 1.4
SCCS-vsn: usr.bin/pascal/src/type.c 1.12
SCCS-vsn: usr.bin/pascal/src/pclval.c 1.8
SCCS-vsn: usr.bin/pascal/src/pas.y 1.13
SCCS-vsn: usr.bin/pascal/src/lval.c 1.12
SCCS-vsn: usr.bin/pascal/src/var.c 1.19
SCCS-vsn: usr.bin/pascal/src/fhdr.c 1.9
SCCS-vsn: usr.bin/pascal/src/stat.c 1.14
SCCS-vsn: usr.bin/pascal/src/call.c 1.27
SCCS-vsn: usr.bin/pascal/src/0.h 1.23
SCCS-vsn: usr.bin/pascal/src/nl.c 1.15
SCCS-vsn: usr.bin/pascal/src/p2put.c 1.16
SCCS-vsn: usr.bin/pascal/src/clas.c 1.8
SCCS-vsn: usr.bin/pascal/src/tree_ty.h 1.5

diff --git a/usr/src/usr.bin/pascal/src/0.h b/usr/src/usr.bin/pascal/src/0.h
index 812ade6..6263d56 100644 (file)
--- a/usr/src/usr.bin/pascal/src/0.h
+++ b/usr/src/usr.bin/pascal/src/0.h
@@ -1,6 +1,6 @@
 /* Copyright (c) 1979 Regents of the University of California */
 
 /* Copyright (c) 1979 Regents of the University of California */
 

-/* static char sccsid[] = "@(#)0.h 1.22 %G%"; */
+/* static char sccsid[] = "@(#)0.h 1.23 %G%"; */

 
 #define DEBUG
 #define CONSETS
 
 #define DEBUG
 #define CONSETS


@@ -248,6 +248,7 @@ struct      nl {
                int        un_value[5];
                long       un_range[2];
                double     un_real;
                int        un_value[5];
                long       un_range[2];
                double     un_real;

+               struct nl  *un_nptr[5]; /* Points to conformant array bounds */

        } nl_un;
 #      ifdef PTREE
            pPointer    inTree;
        } nl_un;
 #      ifdef PTREE
            pPointer    inTree;


@@ -264,6 +265,7 @@ struct      nl {
 #define value  nl_un.un_value
 #define ptr    nl_un.un_ptr
 #define real   nl_un.un_real
 #define value  nl_un.un_value
 #define ptr    nl_un.un_ptr
 #define real   nl_un.un_real

+#define nptr   nl_un.un_nptr   

 
 extern struct nl *nlp, *disptab[077+1], *Fp;
 extern struct nl nl[INL];
 
 extern struct nl *nlp, *disptab[077+1], *Fp;
 extern struct nl nl[INL];


@@ -397,6 +399,7 @@ extern struct nl nl[INL];
 #define        VARNT   22
 #define        FPROC   23
 #define        FFUNC   24
 #define        VARNT   22
 #define        FPROC   23
 #define        FFUNC   24

+#define CRANGE 25

 
 /*
  * Clnames points to an array of names for the
 
 /*
  * Clnames points to an array of names for the

diff --git a/usr/src/usr.bin/pascal/src/OPnames.h b/usr/src/usr.bin/pascal/src/OPnames.h
index 3ddd6d3..4dab970 100644 (file)
--- a/usr/src/usr.bin/pascal/src/OPnames.h
+++ b/usr/src/usr.bin/pascal/src/OPnames.h
@@ -1,4 +1,4 @@
-/* static      char sccsid[] = "@(#)OPnames.h 1.7 %G%"; */
+/* static      char sccsid[] = "@(#)OPnames.h 1.8 %G%"; */

 
 #ifndef PC
 char   *otext[] = {
 
 #ifndef PC
 char   *otext[] = {


@@ -33,7 +33,7 @@ char  *otext[] = {
        " AND",
        " OR",
        " NOT",
        " AND",
        " OR",
        " NOT",

-       0,
+       " VAS",

        " AS2",
        " AS4",
        " AS24",
        " AS2",
        " AS4",
        " AS24",


@@ -150,10 +150,10 @@ char      *otext[] = {
        " LLIMIT",
        " BUFF",
        " HALT",
        " LLIMIT",
        " BUFF",
        " HALT",

-       0,
-       0,
-       0,
-       0,
+       " VINX2",
+       " VINX24",
+       " VINX42",
+       " VINX4",

        "*ORD2",
        "*CONG",
        "*CONC",
        "*ORD2",
        "*CONG",
        "*CONC",

diff --git a/usr/src/usr.bin/pascal/src/call.c b/usr/src/usr.bin/pascal/src/call.c
index d6f65d3..27a75b6 100644 (file)
--- a/usr/src/usr.bin/pascal/src/call.c
+++ b/usr/src/usr.bin/pascal/src/call.c
@@ -57,8 +57,10 @@ call(p, argv_node, porf, psbn)
        struct tnode    *argv_node;     /* list node */
        int porf, psbn;
 {
        struct tnode    *argv_node;     /* list node */
        int porf, psbn;
 {

-       register struct nl *p1, *q;
+       register struct nl *p1, *q, *p2;
+       register struct nl *ptype, *ctype;

        struct tnode *rnode;
        struct tnode *rnode;

+       int i, j, d;

        bool chk = TRUE;
        struct nl       *savedispnp;    /* temporary to hold saved display */
 #      ifdef PC
        bool chk = TRUE;
        struct nl       *savedispnp;    /* temporary to hold saved display */
 #      ifdef PC


@@ -197,6 +199,7 @@ call(p, argv_node, porf, psbn)
         * arguments to the proc/func.
         *      ... ( ... args ... ) ...
         */
         * arguments to the proc/func.
         *      ... ( ... args ... ) ...
         */

+       ptype = NIL;

        for (p1 = plist(p); p1 != NLNIL; p1 = p1->chain) {
            if (argv_node == TR_NIL) {
                    error("Not enough arguments to %s", p->symbol);
        for (p1 = plist(p); p1 != NLNIL; p1 = p1->chain) {
            if (argv_node == TR_NIL) {
                    error("Not enough arguments to %s", p->symbol);


@@ -219,10 +222,103 @@ call(p, argv_node, porf, psbn)
                                chk = FALSE;
                                break;
                        }
                                chk = FALSE;
                                break;
                        }

-                       if (q != p1->type) {
+                       p2 = p1->type;
+                       if (p2->chain->class != CRANGE) {
+                           if (q != p2) {

                                error("Parameter type not identical to type of var parameter %s of %s", p1->symbol, p->symbol);
                                chk = FALSE;
                                error("Parameter type not identical to type of var parameter %s of %s", p1->symbol, p->symbol);
                                chk = FALSE;

-                               break;
+                           }
+                           break;
+                       } else {
+                           /* conformant array */
+                           if (p1 == ptype) {
+                               if (q != ctype) {
+                                   error("Conformant array parameters in the same specification must be the same type.");
+                                   goto conf_err;
+                               }
+                           } else {
+                               if (classify(q) != TARY && classify(q) != TSTR) {
+                                   error("Array type required for var parameter %s of %s",p1->symbol,p->symbol);
+                                   goto conf_err;
+                               }
+                               /* check base type of array */
+                               if (p2->type != q->type) {
+                                   error("Base type of array not identical to that of conformant array parameter %s of %s", p1->symbol, p->symbol);
+                                   goto conf_err;
+                               }
+                               if (p2->value[0] != q->value[0]) {
+                                   error("Subscript number mismatch on conformant array parameter %s of %s", p1->symbol, p->symbol);
+                                   /* Don't process array bounds & width */
+conf_err:                          if (p1->chain->type->class == CRANGE) {
+                                       d = p1->value[0];
+                                       for (i = 1; i <= d; i++) {
+                                           /* for each subscript, pass by
+                                            * bounds and width
+                                            */
+                                           p1 = p1->chain->chain->chain;
+                                       }
+                                   }
+                                   ptype = ctype = NLNIL;
+                                   chk = FALSE;
+                                   break;
+                               }
+                               /*
+                                * Save array type for all parameters with same
+                                * specification.
+                                */
+                               ctype = q;
+                               ptype = p2;
+                               /*
+                                * If at end of conformant array list,
+                                * get bounds.
+                                */
+                               if (p1->chain->type->class == CRANGE) {
+                                   /* check each subscript, put on stack */
+                                   d = ptype->value[0];
+                                   q = ctype;
+                                   for (i = 1; i <= d; i++) {
+                                       p1 = p1->chain;
+                                       q = q->chain;
+                                       if (incompat(q, p1->type, TR_NIL)){
+                                           error("Subscript type not conformable with parameter %s of %s", p1->symbol, p->symbol);
+                                           chk = FALSE;
+                                           break;
+                                       }
+                                       /* Put lower and upper bound & width */
+#                                      ifdef OBJ
+                                       if (q->type->class == CRANGE) {
+                                           putcbnds(q->type);
+                                       } else {
+                                           put(2, width(p1->type) <= 2 ? O_CON2
+                                               : O_CON4, q->range[0]);
+                                           put(2, width(p1->type) <= 2 ? O_CON2
+                                               : O_CON4, q->range[1]);
+                                           put(2, width(p1->type) <= 2 ? O_CON2
+                                               : O_CON4, aryconst(ctype,i));
+                                       }
+#                                      endif OBJ
+#                                      ifdef PC
+                                       if (q->type->class == CRANGE) {
+                                           for (j = 1; j <= 3; j++) {
+                                               p2 = p->nptr[j];
+                                               putRV(p2->symbol, (p2->nl_block
+                                                   & 037), p2->value[0],
+                                                   p2->extra_flags,p2type(p2));
+                                               putop(P2LISTOP, P2INT);
+                                           }
+                                       } else {
+                                           putleaf(P2ICON, q->range[0], 0,P2INT,0);
+                                           putop( P2LISTOP , P2INT );
+                                           putleaf(P2ICON, q->range[1], 0,P2INT,0);
+                                           putop( P2LISTOP , P2INT );
+                                           putleaf(P2ICON,aryconst(ctype,i),0,P2INT,0);
+                                           putop( P2LISTOP , P2INT );
+                                       }
+#                                      endif PC
+                                       p1 = p1->chain->chain;
+                                   }
+                               }
+                           }

                        }
                        break;
                case VAR:
                        }
                        break;
                case VAR:

diff --git a/usr/src/usr.bin/pascal/src/clas.c b/usr/src/usr.bin/pascal/src/clas.c
index 51ba5fd..6b81027 100644 (file)
--- a/usr/src/usr.bin/pascal/src/clas.c
+++ b/usr/src/usr.bin/pascal/src/clas.c
@@ -1,7 +1,7 @@
 /* Copyright (c) 1979 Regents of the University of California */
 
 #ifndef lint
 /* Copyright (c) 1979 Regents of the University of California */
 
 #ifndef lint

-static char sccsid[] = "@(#)clas.c 1.9 %G%";
+static char sccsid[] = "@(#)clas.c 1.8 %G%";

 #endif
 
 #include "whoami.h"
 #endif
 
 #include "whoami.h"


@@ -71,6 +71,7 @@ swit:
                        return (TSTR);
                case SET:
                        return (TSET);
                        return (TSTR);
                case SET:
                        return (TSET);

+               case CRANGE:

                case RANGE:
                        p = p->type;
                        goto swit;
                case RANGE:
                        p = p->type;
                        goto swit;


@@ -119,7 +120,7 @@ scalar(p1)
        p = p1;
        if (p == NLNIL)
                return (NLNIL);
        p = p1;
        if (p == NLNIL)
                return (NLNIL);

-       if (p->class == RANGE)
+       if (p->class == RANGE || p->class == CRANGE)

                p = p->type;
        if (p == NLNIL)
                return (NLNIL);
                p = p->type;
        if (p == NLNIL)
                return (NLNIL);


@@ -148,8 +149,9 @@ isa(p, s)
         * map ranges down to
         * the base type
         */
         * map ranges down to
         * the base type
         */

-       if (p->class == RANGE)
+       if (p->class == RANGE) {

                p = p->type;
                p = p->type;

+       }

        /*
         * the following character/class
         * associations are made:
        /*
         * the following character/class
         * associations are made:


@@ -168,6 +170,19 @@ isa(p, s)
                case SCAL:
                        i = 0;
                        break;
                case SCAL:
                        i = 0;
                        break;

+               case CRANGE:
+                       /*
+                        * find the base type of a conformant array range
+                        */
+                       switch (classify(p->type)) {
+                               case TBOOL: i = 1; break;
+                               case TCHAR: i = 2; break;
+                               case TINT: i = 3; break;
+                               case TSCAL: i = 0; break;
+                               default:
+                                       panic( "isa" );
+                       }
+                       break;

                default:
                        i = p - nl;
        }
                default:
                        i = p - nl;
        }

diff --git a/usr/src/usr.bin/pascal/src/conv.c b/usr/src/usr.bin/pascal/src/conv.c
index 775208e..3f079f5 100644 (file)
--- a/usr/src/usr.bin/pascal/src/conv.c
+++ b/usr/src/usr.bin/pascal/src/conv.c
@@ -1,7 +1,7 @@
 /* Copyright (c) 1979 Regents of the University of California */
 
 #ifndef lint
 /* Copyright (c) 1979 Regents of the University of California */
 
 #ifndef lint

-static char sccsid[] = "@(#)conv.c 1.6 %G%";
+static char sccsid[] = "@(#)conv.c 1.7 %G%";

 #endif
 
 #include "whoami.h"
 #endif
 
 #include "whoami.h"


@@ -176,7 +176,7 @@ rangechk(p, q)
            wq = width(q);
            wrp = width(rp);
            op = wq != wrp && (wq == 4 || wrp == 4);
            wq = width(q);
            wrp = width(rp);
            op = wq != wrp && (wq == 4 || wrp == 4);

-           if (rp->class == TYPE)
+           if (rp->class == TYPE || rp->class == CRANGE)

                    rp = rp->type;
            switch (rp->class) {
            case RANGE:
                    rp = rp->type;
            switch (rp->class) {
            case RANGE:


@@ -249,6 +249,10 @@ precheck( p , name1 , name2 )
            p = p -> type;
        }
        switch ( p -> class ) {
            p = p -> type;
        }
        switch ( p -> class ) {

+           case CRANGE:
+               putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
+                           , name1);
+               break;

            case RANGE:
                if ( p != nl + T4INT ) {
                    putleaf( P2ICON , 0 , 0 ,
            case RANGE:
                if ( p != nl + T4INT ) {
                    putleaf( P2ICON , 0 , 0 ,


@@ -279,6 +283,7 @@ postcheck(need, have)
     struct nl  *need;
     struct nl  *have;
 {
     struct nl  *need;
     struct nl  *have;
 {

+    struct nl  *p;

 
     if ( opt( 't' ) == 0 ) {
        return;
 
     if ( opt( 't' ) == 0 ) {
        return;


@@ -305,6 +310,19 @@ postcheck(need, have)
                sconv(P2INT, p2type(have));
            }
            break;
                sconv(P2INT, p2type(have));
            }
            break;

+       case CRANGE:
+           sconv(p2type(have), P2INT);
+           p = need->nptr[0];
+           putRV(p->symbol, (p->nl_block & 037), p->value[0],
+                   p->extra_flags, p2type( p ) );
+           putop( P2LISTOP , P2INT );
+           p = need->nptr[1];
+           putRV(p->symbol, (p->nl_block & 037), p->value[0],
+                   p->extra_flags, p2type( p ) );
+           putop( P2LISTOP , P2INT );
+           putop( P2CALL , P2INT );
+           sconv(P2INT, p2type(have));
+           break;

        case SCAL:
            break;
        default:
        case SCAL:
            break;
        default:

diff --git a/usr/src/usr.bin/pascal/src/fhdr.c b/usr/src/usr.bin/pascal/src/fhdr.c
index 1bd15b7..8d036d3 100644 (file)
--- a/usr/src/usr.bin/pascal/src/fhdr.c
+++ b/usr/src/usr.bin/pascal/src/fhdr.c
@@ -1,7 +1,7 @@
 /* Copyright (c) 1979 Regents of the University of California */
 
 #ifndef lint
 /* Copyright (c) 1979 Regents of the University of California */
 
 #ifndef lint

-static char sccsid[] = "@(#)fhdr.c 1.8 %G%";
+static char sccsid[] = "@(#)fhdr.c 1.9 %G%";

 #endif
 
 #include "whoami.h"
 #endif
 
 #include "whoami.h"


@@ -317,7 +317,7 @@ params(p, formalist)
        struct nl *dp;
        register struct tnode *formalp; /* an element of the formal list */
        register struct tnode *formal;  /* a formal */
        struct nl *dp;
        register struct tnode *formalp; /* an element of the formal list */
        register struct tnode *formal;  /* a formal */

-       struct tnode *typ, *idlist;
+       struct tnode *r, *s, *t, *typ, *idlist;

        int w, o;
 
        /*
        int w, o;
 
        /*


@@ -358,12 +358,7 @@ params(p, formalist)
                        error("Procedures cannot have types");
                        p = NLNIL;
                    } else {
                        error("Procedures cannot have types");
                        p = NLNIL;
                    } else {

-                       if (typ->tag != T_TYID) {
-                               error("Types for arguments can be specified only by using type identifiers");
-                               p = NLNIL;
-                       } else {
-                               p = gtype(typ);
-                       }
+                       p = gtype(typ);

                    }
                }
                for (idlist = formal->param.id_list; idlist != TR_NIL;
                    }
                }
                for (idlist = formal->param.id_list; idlist != TR_NIL;


@@ -461,6 +456,51 @@ params(p, formalist)
                                chainp = dp;
                        }
                }
                                chainp = dp;
                        }
                }

+               if (typ->tag == T_TYCARY) {
+#                  ifdef OBJ
+                       w = -even(lwidth(p->chain));
+#                      ifndef DEC11
+                           w = (w > -2)? w + 1 : w;
+#                      endif
+#                  endif OBJ
+#                  ifdef PC
+                       w = lwidth(p->chain);
+                       o = roundup(o, (long)A_STACK);
+#                  endif PC
+                   /*
+                    * Allocate space for upper and
+                    * lower bounds and width.
+                    */
+                   for (s=typ; s->tag == T_TYCARY; s = s->ary_ty.type) {
+                       for (r=s->ary_ty.type_list; r != TR_NIL;
+                                               r = r->list_node.next) {
+                           t = r->list_node.list;
+                           p = p->chain;
+#                          ifdef OBJ
+                               o += w;
+#                          endif OBJ
+                           chainp->chain = defnl(t->crang_ty.lwb_var,
+                                                               VAR, p, o);
+                           chainp = chainp->chain;
+                           chainp->nl_flags |= (NMOD | NUSED);
+                           p->nptr[0] = chainp;
+                           o += w;
+                           chainp->chain = defnl(t->crang_ty.upb_var,
+                                                               VAR, p, o);
+                           chainp = chainp->chain;
+                           chainp->nl_flags |= (NMOD | NUSED);
+                           p->nptr[1] = chainp;
+                           o += w;
+                           chainp->chain  = defnl(0, VAR, p, o);
+                           chainp = chainp->chain;
+                           chainp->nl_flags |= (NMOD | NUSED);
+                           p->nptr[2] = chainp;
+#                          ifdef PC
+                               o += w;
+#                          endif PC
+                       }
+                   }
+               }

        }
        p = savedp;
 #      ifdef OBJ
        }
        p = savedp;
 #      ifdef OBJ

diff --git a/usr/src/usr.bin/pascal/src/lval.c b/usr/src/usr.bin/pascal/src/lval.c
index c5e4d8b..b91179f 100644 (file)
--- a/usr/src/usr.bin/pascal/src/lval.c
+++ b/usr/src/usr.bin/pascal/src/lval.c
@@ -1,7 +1,7 @@
 /* Copyright (c) 1979 Regents of the University of California */
 
 #ifndef lint
 /* Copyright (c) 1979 Regents of the University of California */
 
 #ifndef lint

-static char sccsid[] = "@(#)lval.c 1.11 %G%";
+static char sccsid[] = "@(#)lval.c 1.12 %G%";

 #endif
 
 #include "whoami.h"
 #endif
 
 #include "whoami.h"


@@ -34,7 +34,7 @@ lvalue(var, modflag , required )
        register struct nl *p;
        struct nl *firstp, *lastp;
        register struct tnode *c, *co;
        register struct nl *p;
        struct nl *firstp, *lastp;
        register struct tnode *c, *co;

-       int f, o;
+       int f, o, s;

        /*
         * Note that the local optimizations
         * done here for offsets would more
        /*
         * Note that the local optimizations
         * done here for offsets would more


@@ -121,8 +121,13 @@ lvalue(var, modflag , required )
                        o = 0;
                        break;
                case VAR:
                        o = 0;
                        break;
                case VAR:

-                       f = 1;          /* no lv on stack yet */
-                       o = p->value[0];
+                       if (p->type->class != CRANGE) {
+                           f = 1;              /* no lv on stack yet */
+                           o = p->value[0];
+                       } else {
+                           error("Conformant array bound %s found where variable required", p->symbol);
+                           return(NLNIL);
+                       }

                        break;
                default:
                        error("%s %s found where variable required", classes[p->class], p->symbol);
                        break;
                default:
                        error("%s %s found where variable required", classes[p->class], p->symbol);


@@ -136,6 +141,7 @@ lvalue(var, modflag , required )
                error("Can't modify the for variable %s in the range of the loop", p->symbol);
                return (NLNIL);
        }
                error("Can't modify the for variable %s in the range of the loop", p->symbol);
                return (NLNIL);
        }

+       s = 0;          /* subscripts seen */

        for (; c != TR_NIL; c = c->list_node.next) {
                co = c->list_node.list; /* co is a ptr to a tnode */
                if (co == TR_NIL) {
        for (; c != TR_NIL; c = c->list_node.next) {
                co = c->list_node.list; /* co is a ptr to a tnode */
                if (co == TR_NIL) {


@@ -146,6 +152,14 @@ lvalue(var, modflag , required )
                if (p == NLNIL) {
                        return (NLNIL);
                }
                if (p == NLNIL) {
                        return (NLNIL);
                }

+               /*
+                * If we haven't seen enough subscripts, and the next
+                * qualification isn't array reference, then it's an error.
+                */
+               if (s && co->tag != T_ARY) {
+                       error("Too few subscripts (%d given, %d required)",
+                               s, p->value[0]);
+               }

                switch (co->tag) {
                        case T_PTR:
                                /*
                switch (co->tag) {
                        case T_PTR:
                                /*


@@ -225,12 +239,20 @@ lvalue(var, modflag , required )
                                            (void) put(2, O_OFF, o);
                                        }
                                }
                                            (void) put(2, O_OFF, o);
                                        }
                                }

-                               switch (arycod(p, co->ary_node.expr_list)) {
+                               switch(s = arycod(p,co->ary_node.expr_list,s)) {
+                                       /*
+                                        * This is the number of subscripts seen
+                                        */

                                        case 0:
                                                return (NLNIL);
                                        case -1:
                                                goto bad;
                                }
                                        case 0:
                                                return (NLNIL);
                                        case -1:
                                                goto bad;
                                }

+                               if (s == p->value[0]) {
+                                       s = 0;
+                               } else {
+                                       p = lastp;
+                               }

                                f = o = 0;
                                continue;
                        case T_FIELD:
                                f = o = 0;
                                continue;
                        case T_FIELD:


@@ -273,6 +295,10 @@ lvalue(var, modflag , required )
                                panic("lval2");
                }
        }
                                panic("lval2");
                }
        }

+       if (s) {
+               error("Too few subscripts (%d given, %d required)",
+                       s, p->type->value[0]);
+       }

        if (f) {
                if (bn == 0)
                        /*
        if (f) {
                if (bn == 0)
                        /*


@@ -324,10 +350,14 @@ int lptr(c)
  * Arycod does the
  * code generation
  * for subscripting.
  * Arycod does the
  * code generation
  * for subscripting.

+ * n is the number of
+ * subscripts already seen
+ * (CLN 09/13/83)

  */
  */

-int arycod(np, el)
+int arycod(np, el, n)

        struct nl *np;
        struct tnode *el;
        struct nl *np;
        struct tnode *el;

+       int n;

 {
        register struct nl *p, *ap;
        long sub;
 {
        register struct nl *p, *ap;
        long sub;


@@ -341,16 +371,19 @@ int arycod(np, el)
                return (0);
        }
        d = p->value[0];
                return (0);
        }
        d = p->value[0];

+       for (i = 1; i <= n; i++) {
+               p = p->chain;
+       }

        /*
         * Check each subscript
         */
        /*
         * Check each subscript
         */

-       for (i = 1; i <= d; i++) {
+       for (i = n+1; i <= d; i++) {

                if (el == TR_NIL) {
                if (el == TR_NIL) {

-                       error("Too few subscripts (%d given, %d required)", (char *) i-1, (char *) d);
-                       return (-1);
+                       return (i-1);

                }
                p = p->chain;
                }
                p = p->chain;

-               if (constsub = constval(el->list_node.list)) {
+               if ((p->class != CRANGE) &&
+                       (constsub = constval(el->list_node.list))) {

                    ap = con.ctype;
                    sub = con.crval;
                    if (sub < p->range[0] || sub > p->range[1]) {
                    ap = con.ctype;
                    sub = con.crval;
                    if (sub < p->range[0] || sub > p->range[1]) {


@@ -378,7 +411,11 @@ int arycod(np, el)
                        }
                        return (-1);
                }
                        }
                        return (-1);
                }

-               w = aryconst(np, i);
+               if (p->class == CRANGE) {
+                       constsub = 0;
+               } else {
+                       w = aryconst(np, i);
+               }

 #              ifdef OBJ
                    if (constsub) {
                        sub *= w;
 #              ifdef OBJ
                    if (constsub) {
                        sub *= w;


@@ -390,7 +427,11 @@ int arycod(np, el)
                        el = el->list_node.next;
                        continue;
                    }
                        el = el->list_node.next;
                        continue;
                    }

-                   if (opt('t') == 0) {
+                   if (p->class == CRANGE) {
+                       putcbnds(p, 0);
+                       putcbnds(p, 1);
+                       putcbnds(p, 2);
+                   } else if (opt('t') == 0) {

                            switch (w) {
                            case 8:
                                    w = 6;
                            switch (w) {
                            case 8:
                                    w = 6;


@@ -402,8 +443,16 @@ int arycod(np, el)
                                    continue;
                            }
                    }
                                    continue;
                            }
                    }

-                   (void) put(4, width(ap) != 4 ? O_INX2 : O_INX4, w,
-                       (short)p->range[0], (short)(p->range[1]));
+                   if (p->class == CRANGE) {
+                       if (width(p) == 4) {
+                           put(1, width(ap) != 4 ? O_VINX42 : O_VINX4);
+                       } else {
+                           put(1, width(ap) != 4 ? O_VINX2 : O_VINX24);
+                       }
+                   } else {
+                       put(4, width(ap) != 4 ? O_INX2 : O_INX4, w,
+                           (short)p->range[0], (short)(p->range[1]));
+                   }

                    el = el->list_node.next;
                    continue;
 #              endif OBJ
                    el = el->list_node.next;
                    continue;
 #              endif OBJ


@@ -420,16 +469,33 @@ int arycod(np, el)
                        el = el->list_node.next;
                        continue;
                    }
                        el = el->list_node.next;
                        continue;
                    }

-                   if ( p -> range[ 0 ] != 0 ) {
-                       putleaf( P2ICON , (int) p -> range[0] , 0 , P2INT , (char *) 0 );
-                       putop( P2MINUS , P2INT );
-                   }
+                   if (p->class == CRANGE) {
+                       /*
+                        *      if conformant array, subtract off lower bound
+                        */
+                       ap = p->nptr[0];
+                       putRV(ap->symbol, (ap->nl_block & 037), ap->value[0], 
+                               ap->extra_flags, p2type( ap ) );
+                       putop( P2MINUS, P2INT );

                        /*
                        /*

-                        *      multiply by the width of the elements
+                        *      and multiply by the width of the elements

                         */
                         */

-                   if ( w != 1 ) {
-                       putleaf( P2ICON , w , 0 , P2INT , (char *) 0 );
+                       ap = p->nptr[2];
+                       putRV( 0 , (ap->nl_block & 037), ap->value[0], 
+                               ap->extra_flags, p2type( ap ) );

                        putop( P2MUL , P2INT );
                        putop( P2MUL , P2INT );

+                   } else {
+                       if ( p -> range[ 0 ] != 0 ) {
+                           putleaf( P2ICON , (int) p -> range[0] , 0 , P2INT , (char *) 0 );
+                           putop( P2MINUS , P2INT );
+                       }
+                           /*
+                            *  multiply by the width of the elements
+                            */
+                       if ( w != 1 ) {
+                           putleaf( P2ICON , w , 0 , P2INT , (char *) 0 );
+                           putop( P2MUL , P2INT );
+                       }

                    }
                        /*
                         *      and add it to the base address
                    }
                        /*
                         *      and add it to the base address


@@ -439,12 +505,44 @@ int arycod(np, el)
 #              endif PC
        }
        if (el != TR_NIL) {
 #              endif PC
        }
        if (el != TR_NIL) {

+           if (np->type->class != ARRAY) {

                do {
                        el = el->list_node.next;
                        i++;
                } while (el != TR_NIL);
                error("Too many subscripts (%d given, %d required)", (char *) (i-1), (char *) d);
                return (-1);
                do {
                        el = el->list_node.next;
                        i++;
                } while (el != TR_NIL);
                error("Too many subscripts (%d given, %d required)", (char *) (i-1), (char *) d);
                return (-1);

+           } else {
+               return(arycod(np->type, el, d));
+           }
+       }
+       return (d);
+}
+
+#ifdef OBJ
+/*
+ * Put out the conformant array bounds (lower bound, upper bound or width)
+ * for conformant array type ctype.
+ * The value of i determines which is being put
+ * i = 0: lower bound, i=1: upper bound, i=2: width
+ */
+putcbnds(ctype, i)
+struct nl *ctype;
+int i;
+{
+       switch(width(ctype->type)) {
+           case 1:
+               put(2, O_RV1 | (ctype->nl_block & 037) << 8+INDX,
+                       (int)ctype->nptr[i]->value[0]);
+               break;
+           case 2:
+               put(2, O_RV2 | (ctype->nl_block & 037) << 8+INDX,
+                       (int)ctype->nptr[i]->value[0]);
+               break;
+           case 4:
+           default:
+               put(2, O_RV4 | (ctype->nl_block & 037) << 8+INDX,
+                       (int)ctype->nptr[i]->value[0]);

        }
        }

-       return (1);

 }
 }

+#endif OBJ

diff --git a/usr/src/usr.bin/pascal/src/nl.c b/usr/src/usr.bin/pascal/src/nl.c
index c657de8..a1448b7 100644 (file)
--- a/usr/src/usr.bin/pascal/src/nl.c
+++ b/usr/src/usr.bin/pascal/src/nl.c
@@ -1,7 +1,7 @@
 /* Copyright (c) 1979 Regents of the University of California */
 
 #ifndef lint
 /* Copyright (c) 1979 Regents of the University of California */
 
 #ifndef lint

-static char sccsid[] = "@(#)nl.c 1.14 %G%";
+static char sccsid[] = "@(#)nl.c 1.15 %G%";

 #endif
 
 #include "whoami.h"
 #endif
 
 #include "whoami.h"


@@ -499,7 +499,8 @@ char        *ctext[] =
        "IMPROPER",
        "VARNT",
        "FPROC",
        "IMPROPER",
        "VARNT",
        "FPROC",

-       "FFUNC"
+       "FFUNC",
+       "CRANGE"

 };
 
 char   *stars  = "\t***";
 };
 
 char   *stars  = "\t***";


@@ -598,6 +599,10 @@ con:
                        case RANGE:
                                printf("\t%ld..%ld", p->range[0], p->range[1]);
                                break;
                        case RANGE:
                                printf("\t%ld..%ld", p->range[0], p->range[1]);
                                break;

+                       case CRANGE:
+                               printf("\t%s..%s", p->nptr[0]->symbol,
+                                       p->nptr[1]->symbol);
+                               break;

                        case RECORD:
                                printf("\t%d", v);
                                break;
                        case RECORD:
                                printf("\t%d", v);
                                break;


@@ -824,7 +829,8 @@ enter(np)
        hp = disptab[i];
        if (rp->class != BADUSE && rp->class != FIELD)
        for (p = hp; p != NIL && (p->nl_block & 037) == cbn; p = p->nl_next)
        hp = disptab[i];
        if (rp->class != BADUSE && rp->class != FIELD)
        for (p = hp; p != NIL && (p->nl_block & 037) == cbn; p = p->nl_next)

-               if (p->symbol == rp->symbol && p->class != BADUSE && p->class != FIELD) {
+               if (p->symbol == rp->symbol && p->symbol != NIL &&
+                   p->class != BADUSE && p->class != FIELD) {

 #ifndef PI1
                        error("%s is already defined in this block", rp->symbol);
 #endif
 #ifndef PI1
                        error("%s is already defined in this block", rp->symbol);
 #endif

diff --git a/usr/src/usr.bin/pascal/src/p2put.c b/usr/src/usr.bin/pascal/src/p2put.c
index 8e36db0..e26c664 100644 (file)
--- a/usr/src/usr.bin/pascal/src/p2put.c
+++ b/usr/src/usr.bin/pascal/src/p2put.c
@@ -1,7 +1,7 @@
 /* Copyright (c) 1979 Regents of the University of California */
 
 #ifndef lint
 /* Copyright (c) 1979 Regents of the University of California */
 
 #ifndef lint

-static char sccsid[] = "@(#)p2put.c 1.15 %G%";
+static char sccsid[] = "@(#)p2put.c 1.16 %G%";

 #endif
 
     /*
 #endif
 
     /*


@@ -451,6 +451,7 @@ typerecur( np , quals )
        switch ( np -> class ) {
            case SCAL :
            case RANGE :
        switch ( np -> class ) {
            case SCAL :
            case RANGE :

+           case CRANGE :

                if ( np -> type == ( nl + TDOUBLE ) ) {
                    return P2DOUBLE;
                }
                if ( np -> type == ( nl + TDOUBLE ) ) {
                    return P2DOUBLE;
                }

diff --git a/usr/src/usr.bin/pascal/src/pas.y b/usr/src/usr.bin/pascal/src/pas.y
index 77e3d65..882bdf4 100644 (file)
--- a/usr/src/usr.bin/pascal/src/pas.y
+++ b/usr/src/usr.bin/pascal/src/pas.y
@@ -88,7 +88,7 @@
 
 /* Copyright (c) 1979 Regents of the University of California */
 
 
 /* Copyright (c) 1979 Regents of the University of California */
 

-/* static      char sccsid[] = "@(#)pas.y 1.12 %G%"; */
+/* static      char sccsid[] = "@(#)pas.y 1.13 %G%"; */

 
 /*
  * The following line marks the end of the yacc
 
 /*
  * The following line marks the end of the yacc


@@ -98,7 +98,7 @@
 ##
 /* Copyright (c) 1979 Regents of the University of California */
 
 ##
 /* Copyright (c) 1979 Regents of the University of California */
 

-static char sccsid[] = "@(#)pas.y 1.12 %G%";
+static char sccsid[] = "@(#)pas.y 1.13 %G%";

 
 #include "whoami.h"
 #include "0.h"
 
 #include "whoami.h"
 #include "0.h"


@@ -320,7 +320,7 @@ param:
        id_list ':' type
                = $$.tr_entry = tree3(T_PVAL, (int) fixlist($1.tr_entry), $3.tr_entry);
                |
        id_list ':' type
                = $$.tr_entry = tree3(T_PVAL, (int) fixlist($1.tr_entry), $3.tr_entry);
                |

-       YVAR id_list ':' type
+       YVAR id_list ':' vtype

                = $$.tr_entry = tree3(T_PVAR, (int) fixlist($2.tr_entry), $4.tr_entry);
                |
        YFUNCTION id_list params ftype
                = $$.tr_entry = tree3(T_PVAR, (int) fixlist($2.tr_entry), $4.tr_entry);
                |
        YFUNCTION id_list params ftype


@@ -340,6 +340,28 @@ ftype:
        /* lambda */
                = $$.tr_entry = TR_NIL;
                ;
        /* lambda */
                = $$.tr_entry = TR_NIL;
                ;

+vtype:
+       type_id
+               |
+       c_ary
+               ;
+c_ary:
+       YARRAY '[' i_type_list ']' YOF vtype
+               = $$.tr_entry = tree4(T_TYCARY, lineof($1.i_entry),
+                               fixlist($3.tr_entry), $6.tr_entry);
+               ;
+i_type_list:
+       i_type
+               = $$.tr_entry = newlist($1.tr_entry);
+               |
+       i_type_list ';' i_type
+               = $$.tr_entry = addlist($1.tr_entry, $3.tr_entry);
+               ;
+i_type:
+       YID YDOTDOT YID ':' type_id
+               = $$.tr_entry = tree5(T_TYCRANG,lineof($2.i_entry), $1.tr_entry,
+                               $3.tr_entry, $5.tr_entry);
+               ;

 param_list:
        param
                = $$.tr_entry = newlist($1.tr_entry);
 param_list:
        param
                = $$.tr_entry = newlist($1.tr_entry);


@@ -347,6 +369,7 @@ param_list:
        param_list ';' param
                = $$.tr_entry = addlist($1.tr_entry, $3.tr_entry);
                ;
        param_list ';' param
                = $$.tr_entry = addlist($1.tr_entry, $3.tr_entry);
                ;

+

 \f
 /*
  * CONSTANTS
 \f
 /*
  * CONSTANTS

diff --git a/usr/src/usr.bin/pascal/src/pclval.c b/usr/src/usr.bin/pascal/src/pclval.c
index bfd4cb6..9fb4629 100644 (file)
--- a/usr/src/usr.bin/pascal/src/pclval.c
+++ b/usr/src/usr.bin/pascal/src/pclval.c
@@ -1,7 +1,7 @@
 /* Copyright (c) 1979 Regents of the University of California */
 
 #ifndef lint
 /* Copyright (c) 1979 Regents of the University of California */
 
 #ifndef lint

-static char sccsid[] = "@(#)pclval.c 1.7 %G%";
+static char sccsid[] = "@(#)pclval.c 1.8 %G%";

 #endif
 
 #include "whoami.h"
 #endif
 
 #include "whoami.h"


@@ -40,10 +40,11 @@ pclvalue( var , modflag , required )
        struct tnode            l_node, tr;
        VAR_NODE                *v_node;
        LIST_NODE               *tr_ptr;
        struct tnode            l_node, tr;
        VAR_NODE                *v_node;
        LIST_NODE               *tr_ptr;

-       struct nl               *firstp;
+       struct nl               *firstp, *lastp;

        char                    *firstsymbol;
        char                    firstextra_flags;
        int                     firstbn;
        char                    *firstsymbol;
        char                    firstextra_flags;
        int                     firstbn;

+       int                     s;

 
        if ( var == TR_NIL ) {
                return NLNIL;
 
        if ( var == TR_NIL ) {
                return NLNIL;


@@ -110,8 +111,13 @@ pclvalue( var , modflag , required )
                        o = 0;
                        break;
                case VAR:
                        o = 0;
                        break;
                case VAR:

-                       f = 1;          /* no lv on stack yet */
-                       o = p -> value[0];
+                       if (p->type->class != CRANGE) {
+                               f = 1;          /* no lv on stack yet */
+                               o = p -> value[0];
+                       } else {
+                               error("Conformant array bound %s found where variable required", p->symbol);
+                               return(NIL);
+                       }

                        break;
                default:
                        error("%s %s found where variable required", classes[p -> class], p -> symbol);
                        break;
                default:
                        error("%s %s found where variable required", classes[p -> class], p -> symbol);


@@ -127,11 +133,13 @@ pclvalue( var , modflag , required )
                error("Can't modify the for variable %s in the range of the loop", p -> symbol);
                return (NLNIL);
        }
                error("Can't modify the for variable %s in the range of the loop", p -> symbol);
                return (NLNIL);
        }

+       s = 0;

        for ( ; c != TR_NIL ; c = c->list_node.next ) {
                co = c->list_node.list;
                if ( co == TR_NIL ) {
                        return NLNIL;
                }
        for ( ; c != TR_NIL ; c = c->list_node.next ) {
                co = c->list_node.list;
                if ( co == TR_NIL ) {
                        return NLNIL;
                }

+               lastp = p;

                p = p -> type;
                if ( p == NLNIL ) {
                        return NLNIL;
                p = p -> type;
                if ( p == NLNIL ) {
                        return NLNIL;


@@ -194,7 +202,12 @@ pclvalue( var , modflag , required )
                                            putop( P2PLUS , P2INT );
                                        }
                                }
                                            putop( P2PLUS , P2INT );
                                        }
                                }

-                               (void) arycod( p , co->ary_node.expr_list );
+                               s = arycod( p , co->ary_node.expr_list, s);
+                               if (s == p->value[0]) {
+                                       s = 0;
+                               } else {
+                                       p = lastp;
+                               }

                                f = o = 0;
                                continue;
                        case T_FIELD:
                                f = o = 0;
                                continue;
                        case T_FIELD:


@@ -247,6 +260,7 @@ nilfnil( p , c , modflag , firstp , r2 )
        struct tnode    *co;
        struct nl       *lastp;
        int             t;
        struct tnode    *co;
        struct nl       *lastp;
        int             t;

+       static int      s = 0;

 
        if ( c == TR_NIL ) {
            return TRUE;
 
        if ( c == TR_NIL ) {
            return TRUE;


@@ -289,14 +303,19 @@ nilfnil( p , c , modflag , firstp , r2 )
                            goto bad;
                    }
                    codeoff();
                            goto bad;
                    }
                    codeoff();

-                   t = arycod( p , co->ary_node.expr_list );
+                   s = arycod( p , co->ary_node.expr_list , s );

                    codeon();
                    codeon();

-                   switch ( t ) {
+                   switch ( s ) {

                            case 0:
                                    return FALSE;
                            case -1:
                                    goto bad;
                    }
                            case 0:
                                    return FALSE;
                            case -1:
                                    goto bad;
                    }

+                   if (s == p->value[0]) {
+                           s = 0;
+                   } else {
+                           p = lastp;
+                   }

                    break;
            case T_FIELD:
                    /*
                    break;
            case T_FIELD:
                    /*

diff --git a/usr/src/usr.bin/pascal/src/stat.c b/usr/src/usr.bin/pascal/src/stat.c
index 66bf24c..f0b75a4 100644 (file)
--- a/usr/src/usr.bin/pascal/src/stat.c
+++ b/usr/src/usr.bin/pascal/src/stat.c
@@ -1,7 +1,7 @@
 /* Copyright (c) 1979 Regents of the University of California */
 
 #ifndef lint
 /* Copyright (c) 1979 Regents of the University of California */
 
 #ifndef lint

-static char sccsid[] = "@(#)stat.c 1.13 %G%";
+static char sccsid[] = "@(#)stat.c 1.14 %G%";

 #endif
 
 #include "whoami.h"
 #endif
 
 #include "whoami.h"


@@ -360,12 +360,42 @@ asgnop1(r, p)
                w = width(p);
 #          endif OBJ
 #          ifdef PC
                w = width(p);
 #          endif OBJ
 #          ifdef PC

+               /* check for conformant array type */
+               codeoff();
+               p = rvalue(r->lhs_var, MOD|ASGN|NOUSE, LREQ);
+               codeon();
+               if ((classify(p) == TARY || classify(p) == TSTR)
+                   && p->chain->class == CRANGE) {
+                   putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR)
+                           , "_blkcpy" );
+                   /* find total size */
+                   /* upper bound */
+                   p1 = p->chain->nptr[1];
+                   putRV(p1->symbol, (p1->nl_block & 037), p1->value[0],
+                       p1->extra_flags, p2type( p1 ) );
+                   /* minus lower bound */
+                   p1 = p->chain->nptr[0];
+                   putRV(p1->symbol, (p1->nl_block & 037), p1->value[0],
+                       p1->extra_flags, p2type( p1 ) );
+                   putop( P2MINUS, P2INT );
+                   /* add one */
+                   putleaf(P2ICON, 1, 0, P2INT, 0);
+                   putop( P2PLUS, P2INT );
+                   /* and multiply by the width */
+                   p1 = p->chain->nptr[2];
+                   putRV(p1->symbol, (p1->nl_block & 037), p1->value[0],
+                       p1->extra_flags, p2type( p1 ) );
+                   putop( P2MUL , P2INT );
+                   p = lvalue( r->lhs_var , MOD|ASGN|NOUSE , RREQ );
+                   putop(P2LISTOP, P2INT);
+               } else {

                    /*
                     * since the second pass knows that it should reference
                     * the lefthandside of asignments, what i need here is
                     * an rvalue.
                     */
                    /*
                     * since the second pass knows that it should reference
                     * the lefthandside of asignments, what i need here is
                     * an rvalue.
                     */

-               p = lvalue( r->lhs_var , MOD|ASGN|NOUSE , RREQ );
+                   p = lvalue( r->lhs_var , MOD|ASGN|NOUSE , RREQ );
+               }

 #          endif PC
            if ( p == NLNIL ) {
                (void) rvalue( r->rhs_expr , NLNIL , RREQ );
 #          endif PC
            if ( p == NLNIL ) {
                (void) rvalue( r->rhs_expr , NLNIL , RREQ );


@@ -382,7 +412,12 @@ asgnop1(r, p)
                if (w < 2)
                    w = 2;
            }
                if (w < 2)
                    w = 2;
            }

-           p1 = rvalue(r->rhs_expr, p , RREQ );
+           if ((classify(p) == TARY || classify(p) == TSTR)
+               && p->chain->class == CRANGE) {
+               p1 = lvalue(r->rhs_expr, p , LREQ );
+           } else {
+               p1 = rvalue(r->rhs_expr, p , RREQ );
+           }

 #      endif OBJ
 #      ifdef PC
                /*
 #      endif OBJ
 #      ifdef PC
                /*


@@ -426,6 +461,23 @@ asgnop1(r, p)
                    case TPTR:
                            (void) gen(O_AS2, O_AS2, w, width(p1));
                            break;
                    case TPTR:
                            (void) gen(O_AS2, O_AS2, w, width(p1));
                            break;

+                   case TARY:
+                   case TSTR:
+                           if (p->chain->class == CRANGE) {
+                               /* conformant array assignment */
+                               p1 = p->chain;
+                               w = width(p1->type);
+                               putcbnds(p1, 1);
+                               putcbnds(p1, 0);
+                               gen(NIL, T_SUB, w, w);
+                               put(2, w > 2? O_CON24: O_CON2, 1);
+                               gen(NIL, T_ADD, w, w);
+                               putcbnds(p1, 2);
+                               gen(NIL, T_MULT, w, w);
+                               put(1, O_VAS);
+                               break;
+                           }
+                           /* else fall through */

                    default:
                            (void) put(2, O_AS, w);
                            break;
                    default:
                            (void) put(2, O_AS, w);
                            break;


@@ -451,6 +503,18 @@ asgnop1(r, p)
                            putop( P2ASSIGN , p2type( p ) );
                            putdot( filename , line );
                            break;
                            putop( P2ASSIGN , p2type( p ) );
                            putdot( filename , line );
                            break;

+                   case TARY:
+                   case TSTR:
+                           /* handle conformant array assignment with
+                            * library call.
+                            */
+                           if (p->chain->class == CRANGE) {
+                               putop(P2LISTOP, P2INT);
+                               putop(P2CALL, P2INT);
+                               putdot( filename , line);
+                               break;
+                           }
+                           /* else fall through */

                    default:
                            putstrop(P2STASG, ADDTYPE(p2type(p), P2PTR),
                                        (int) lwidth(p), align(p));
                    default:
                            putstrop(P2STASG, ADDTYPE(p2type(p), P2PTR),
                                        (int) lwidth(p), align(p));

diff --git a/usr/src/usr.bin/pascal/src/tree.h b/usr/src/usr.bin/pascal/src/tree.h
index c530147..e730c06 100644 (file)
--- a/usr/src/usr.bin/pascal/src/tree.h
+++ b/usr/src/usr.bin/pascal/src/tree.h
@@ -1,6 +1,6 @@
 /* Copyright (c) 1979 Regents of the University of California */
 
 /* Copyright (c) 1979 Regents of the University of California */
 

-/* static      char sccsid[] = "@(#)tree.h 1.3 %G%"; */
+/* static      char sccsid[] = "@(#)tree.h 1.4 %G%"; */

 
 #define T_MINUS 1
 #define T_MOD 2
 
 #define T_MINUS 1
 #define T_MOD 2


@@ -82,3 +82,5 @@
 #define T_RFIELD 79
 #define T_FLDLST 80
 #define T_LAST 81
 #define T_RFIELD 79
 #define T_FLDLST 80
 #define T_LAST 81

+#define T_TYCRANG 82
+#define T_TYCARY 83

diff --git a/usr/src/usr.bin/pascal/src/tree_ty.h b/usr/src/usr.bin/pascal/src/tree_ty.h
index 29060bf..25fe02e 100644 (file)
--- a/usr/src/usr.bin/pascal/src/tree_ty.h
+++ b/usr/src/usr.bin/pascal/src/tree_ty.h
@@ -1,6 +1,6 @@
-/* Copyright (c) 1979 Regents of the University of California */
+/* Copyright (c) 1984 Regents of the University of California */

  
  

-/* static char sccsid[]="@(#)tree_ty.h 1.4     (Berkeley)      83/10/11"; */
+/* static char sccsid[]="@(#)tree_ty.h 1.5     (Berkeley)      84/02/08"; */

 
 typedef struct /* T_FORU, T_FORD */
 {
 
 typedef struct /* T_FORU, T_FORD */
 {


@@ -130,7 +130,14 @@ typedef struct             /* T_TYRANG */
     struct tnode       *const1;
     struct tnode       *const2;
 } RANG_TY;
     struct tnode       *const1;
     struct tnode       *const2;
 } RANG_TY;

-typedef struct         /* T_TYARY */
+typedef struct         /* T_TYCRANG */
+{
+    int                         line_no;
+    struct tnode       *lwb_var;
+    struct tnode       *upb_var;
+    struct tnode       *type;
+} CRANG_TY;
+typedef struct         /* T_TYARY, T_TYCARY */

 {
     int                         line_no;
     struct tnode       *type_list;
 {
     int                         line_no;
     struct tnode       *type_list;


@@ -259,6 +266,7 @@ struct tnode
        COMP_TY         t_comp_ty;
        PTR_TY          t_ptr_ty;
        RANG_TY         t_rang_ty;
        COMP_TY         t_comp_ty;
        PTR_TY          t_ptr_ty;
        RANG_TY         t_rang_ty;

+       CRANG_TY        t_crang_ty;

        ARY_TY          t_ary_ty;
        VARPT           t_varpt;
        TYVARNT         t_tyvarnt;
        ARY_TY          t_ary_ty;
        VARPT           t_varpt;
        TYVARNT         t_tyvarnt;


@@ -299,6 +307,7 @@ struct tnode
 #define        comp_ty                 tree_ele.t_comp_ty
 #define        ptr_ty                  tree_ele.t_ptr_ty
 #define        rang_ty                 tree_ele.t_rang_ty
 #define        comp_ty                 tree_ele.t_comp_ty
 #define        ptr_ty                  tree_ele.t_ptr_ty
 #define        rang_ty                 tree_ele.t_rang_ty

+#define        crang_ty                tree_ele.t_crang_ty

 #define        ary_ty                  tree_ele.t_ary_ty
 #define        varpt                   tree_ele.t_varpt
 #define        tyvarnt                 tree_ele.t_tyvarnt
 #define        ary_ty                  tree_ele.t_ary_ty
 #define        varpt                   tree_ele.t_varpt
 #define        tyvarnt                 tree_ele.t_tyvarnt

diff --git a/usr/src/usr.bin/pascal/src/type.c b/usr/src/usr.bin/pascal/src/type.c
index 8e2b1e7..f7b6f4e 100644 (file)
--- a/usr/src/usr.bin/pascal/src/type.c
+++ b/usr/src/usr.bin/pascal/src/type.c
@@ -1,7 +1,7 @@
 /* Copyright (c) 1979 Regents of the University of California */
 
 #ifndef lint
 /* Copyright (c) 1979 Regents of the University of California */
 
 #ifndef lint

-static char sccsid[] = "@(#)type.c 1.11 %G%";
+static char sccsid[] = "@(#)type.c 1.12 %G%";

 #endif
 
 #include "whoami.h"
 #endif
 
 #include "whoami.h"


@@ -155,6 +155,9 @@ gtype(r)
                case T_TYSCAL:
                        np = tyscal(r);
                        break;
                case T_TYSCAL:
                        np = tyscal(r);
                        break;

+               case T_TYCRANG:
+                       np = tycrang(r);
+                       break;

                case T_TYRANG:
                        np = tyrang(r);
                        break;
                case T_TYRANG:
                        np = tyrang(r);
                        break;


@@ -167,6 +170,7 @@ gtype(r)
                case T_TYPACK:
                        np = gtype(r->comp_ty.type);
                        break;
                case T_TYPACK:
                        np = gtype(r->comp_ty.type);
                        break;

+               case T_TYCARY:

                case T_TYARY:
                        np = tyary(r);
                        break;
                case T_TYARY:
                        np = tyary(r);
                        break;


@@ -259,6 +263,25 @@ tyscal(r)
        return (np);
 }
 
        return (np);
 }
 

+/*
+ * Declare a subrange for conformant arrays.
+ */
+tycrang(r)
+       register int *r;
+{
+       register struct nl *p, *op, *tp;
+
+       tp = gtype(r->crang_ty.type);
+       if ( tp == NIL )
+               return (NIL);
+       /*
+        * Just make a new type -- the lower and upper bounds must be
+        * set by params().
+        */
+       p = defnl ( 0, CRANGE, tp, 0 );
+       return(p);
+}
+

 /*
  * Declare a subrange.
  */
 /*
  * Declare a subrange.
  */


@@ -331,31 +354,39 @@ tyary(r)
        struct tnode *r;
 {
        struct nl *np;
        struct tnode *r;
 {
        struct nl *np;

-       register struct tnode *tl;
+       register struct tnode *tl, *s;

        register struct nl *tp, *ltp;
        register struct nl *tp, *ltp;

-       int i;
+       int i, n;

 
 

-       tp = gtype(r->ary_ty.type);
+       s = r;
+       /* Count the dimensions */
+       for (n = 0; s->tag == T_TYARY || s->tag == T_TYCARY;
+                                       s = s->ary_ty.type, n++)
+               /* NULL STATEMENT */;
+       tp = gtype(s);

        if (tp == NLNIL)
                return (NLNIL);
        np = defnl((char *) 0, ARRAY, tp, 0);
        np->nl_flags |= (tp->nl_flags) & NFILES;
        ltp = np;
        i = 0;
        if (tp == NLNIL)
                return (NLNIL);
        np = defnl((char *) 0, ARRAY, tp, 0);
        np->nl_flags |= (tp->nl_flags) & NFILES;
        ltp = np;
        i = 0;

-       for (tl = r->ary_ty.type_list; tl != TR_NIL; tl = tl->list_node.next) {
+       for (s = r; s->tag == T_TYARY || s->tag == T_TYCARY;
+                                       s = s->ary_ty.type) {
+           for (tl = s->ary_ty.type_list; tl != TR_NIL; tl=tl->list_node.next){

                tp = gtype(tl->list_node.list);
                if (tp == NLNIL) {
                        np = NLNIL;
                        continue;
                }
                tp = gtype(tl->list_node.list);
                if (tp == NLNIL) {
                        np = NLNIL;
                        continue;
                }

-               if (tp->class == RANGE && tp->type == nl+TDOUBLE) {
+               if ((tp->class == RANGE || tp->class == CRANGE) &&
+                   tp->type == nl+TDOUBLE) {

 #ifndef PI1
                        error("Index type for arrays cannot be real");
 #endif
                        np = NLNIL;
                        continue;
                }
 #ifndef PI1
                        error("Index type for arrays cannot be real");
 #endif
                        np = NLNIL;
                        continue;
                }

-               if (tp->class != RANGE && tp->class != SCAL) {
+               if (tp->class != RANGE && tp->class != SCAL && tp->class !=CRANGE){

 #ifndef PI1
                        error("Array index type is a %s, not a range or scalar as required", classes[tp->class]);
 #endif
 #ifndef PI1
                        error("Array index type is a %s, not a range or scalar as required", classes[tp->class]);
 #endif


@@ -370,10 +401,12 @@ tyary(r)
                        continue;
                }
 #endif
                        continue;
                }
 #endif

-               tp = nlcopy(tp);
+               if (tp->class != CRANGE)
+                       tp = nlcopy(tp);

                i++;
                ltp->chain = tp;
                ltp = tp;
                i++;
                ltp->chain = tp;
                ltp = tp;

+           }

        }
        if (np != NLNIL)
                np->value[0] = i;
        }
        if (np != NLNIL)
                np->value[0] = i;

diff --git a/usr/src/usr.bin/pascal/src/var.c b/usr/src/usr.bin/pascal/src/var.c
index df43dfd..0c1e1fe 100644 (file)
--- a/usr/src/usr.bin/pascal/src/var.c
+++ b/usr/src/usr.bin/pascal/src/var.c
@@ -1,7 +1,7 @@
 /* Copyright (c) 1979 Regents of the University of California */
 
 #ifndef lint
 /* Copyright (c) 1979 Regents of the University of California */
 
 #ifndef lint

-static char sccsid[] = "@(#)var.c 1.18 %G%";
+static char sccsid[] = "@(#)var.c 1.19 %G%";

 #endif
 
 #include "whoami.h"
 #endif
 
 #include "whoami.h"


@@ -244,6 +244,9 @@ loop:
                        return ( sizeof ( int * ) );
                case FILET:
                        return ( sizeof(struct iorec) + lwidth( p -> type ) );
                        return ( sizeof ( int * ) );
                case FILET:
                        return ( sizeof(struct iorec) + lwidth( p -> type ) );

+               case CRANGE:
+                       p = p->type;
+                       goto loop;

                case RANGE:
                        if (p->type == nl+TDOUBLE)
 #ifdef DEBUG
                case RANGE:
                        if (p->type == nl+TDOUBLE)
 #ifdef DEBUG


@@ -330,6 +333,7 @@ alignit:
                    return A_POINT;
            case FILET:
                    return A_FILET;
                    return A_POINT;
            case FILET:
                    return A_FILET;

+           case CRANGE:

            case RANGE:
                    if ( p -> type == nl+TDOUBLE ) {
                        return A_DOUBLE;
            case RANGE:
                    if ( p -> type == nl+TDOUBLE ) {
                        return A_DOUBLE;


@@ -411,6 +415,12 @@ long aryconst(np, n)
                return (NIL);
        if (p->class != ARRAY)
                panic("ary");
                return (NIL);
        if (p->class != ARRAY)
                panic("ary");

+       /*
+        * If it is a conformant array, we cannot find the width from
+        * the type.
+        */
+       if (p->chain->class == CRANGE)
+               return (NIL);

        s = lwidth(p->type);
        /*
         * Arrays of anything but characters are word aligned.
        s = lwidth(p->type);
        /*
         * Arrays of anything but characters are word aligned.