# 2.11BSD#431 - /usr/src/usr.bin/f77/data.c

##### Functions

    dataval           X
    frdata            X
    nextdata          X
    setdata           X

       1: #include "defs"
       2: #include "string_defs"
       3:
       4: /* ROUTINES CALLED DURING DATA STATEMENT PROCESSING */
       5:
       6: static char *datafmt = "%s\t%05ld\t%05ld\t%d" ;
       7:
       8: /* another initializer, called from parser */
       9: dataval(repp, valp)
      10: register struct constblock *repp, *valp;
      11: {
      12: int i, nrep;
      13: ftnint elen, vlen;
      14: register struct addrblock *p;
      15: struct addrblock *nextdata();
      16:
      17: if(repp == NULL)
      18:     nrep = 1;
      19: else if (ISICON(repp) && repp->const.ci >= 0)
      20:     nrep = repp->const.ci;
      21: else
      22:     {
      23:     error("invalid repetition count in DATA statement",0,0,ERR);
      24:     frexpr(repp);
      25:     goto ret;
      26:     }
      27: frexpr(repp);
      28:
      29: if( ! ISCONST(valp) )
      30:     {
      31:     error("nonconstant initializer",0,0,ERR);
      32:     goto ret;
      33:     }
      34:
      35: if(toomanyinit) goto ret;
      36: for(i = 0 ; i < nrep ; ++i)
      37:     {
      38:     p = nextdata(&elen, &vlen);
      39:     if(p == NULL)
      40:         {
      41:         error("too many initializers",0,0,ERR);
      42:         toomanyinit = YES;
      43:         goto ret;
      44:         }
      45:     setdata(p, valp, elen, vlen);
      46:     frexpr(p);
      47:     }
      48:
      49: ret:
      50:     frexpr(valp);
      51: }
      52:
      53:
      54: struct addrblock *nextdata(elenp, vlenp)
      55: ftnint *elenp, *vlenp;
      56: {
      57: register struct impldoblock *ip;
      58: struct primblock *pp;
      59: register struct nameblock *np;
      60: register struct rplblock *rp;
      61: tagptr p;
      62: expptr neltp;
      63: register expptr q;
      64: int skip;
      65: ftnint off;
      66: struct constblock *mkintcon();
      67:
      68: while(curdtp)
      69:     {
      70:     p = curdtp->datap;
      71:     if(p->tag == TIMPLDO)
      72:         {
      73:         ip = p;
      74:         if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL)
      75:             error("bad impldoblock 0%o", ip,0,FATAL1);
      76:         if(ip->isactive)
      77:             ip->varvp->const.ci += ip->impdiff;
      78:         else
      79:             {
      80:             q = fixtype(cpexpr(ip->implb));
      81:             if( ! ISICON(q) )
      82:                 goto doerr;
      83:             ip->varvp = q;
      84:
      85:             if(ip->impstep)
      86:                 {
      87:                 q = fixtype(cpexpr(ip->impstep));
      88:                 if( ! ISICON(q) )
      89:                     goto doerr;
      90:                 ip->impdiff = q->const.ci;
      91:                 frexpr(q);
      92:                 }
      93:             else
      94:                 ip->impdiff = 1;
      95:
      96:             q = fixtype(cpexpr(ip->impub));
      97:             if(! ISICON(q))
      98:                 goto doerr;
      99:             ip->implim = q->const.ci;
     100:             frexpr(q);
     101:
     102:             ip->isactive = YES;
     103:             rp = ALLOC(rplblock);
     104:             rp->nextp = rpllist;
     105:             rpllist = rp;
     106:             rp->rplnp = ip->varnp;
     107:             rp->rplvp = ip->varvp;
     108:             rp->rpltag = TCONST;
     109:             }
     110:
     111:         if( (ip->impdiff>0 && (ip->varvp->const.ci <= ip->implim))
     112:          || (ip->impdiff<0 && (ip->varvp->const.ci >= ip->implim)) )
     113:             { /* start new loop */
     114:             curdtp = ip->datalist;
     115:             goto next;
     116:             }
     117:
     118:         /* clean up loop */
     119:
     120:         popstack(&rpllist);
     121:
     122:         frexpr(ip->varvp);
     123:         ip->isactive = NO;
     124:         curdtp = curdtp->nextp;
     125:         goto next;
     126:         }
     127:
     128:     pp = p;
     129:     np = pp->namep;
     130:     skip = YES;
     131:
     132:     if(p->argsp==NULL && np->vdim!=NULL)
     133:         {   /* array initialization */
     134:         q = mkaddr(np);
     135:         off = typesize[np->vtype] * curdtelt;
     136:         if(np->vtype == TYCHAR)
     137:             off *= np->vleng->const.ci;
     138:         q->memoffset = mkexpr(OPPLUS, q->memoffset, mkintcon(off) );
     139:         if( (neltp = np->vdim->nelt) && ISCONST(neltp))
     140:             {
     141:             if(++curdtelt < neltp->const.ci)
     142:                 skip = NO;
     143:             }
     144:         else
     145:             error("attempt to initialize adjustable array",0,0,ERR);
     146:         }
     147:     else
     148:         q = mklhs( cpexpr(pp) );
     149:     if(skip)
     150:         {
     151:         curdtp = curdtp->nextp;
     152:         curdtelt = 0;
     153:         }
     154:     if(q->vtype == TYCHAR)
     155:         if(ISICON(q->vleng))
     156:             *elenp = q->vleng->const.ci;
     157:         else    {
     158:             error("initialization of string of nonconstant length",0,0,ERR);
     159:             continue;
     160:             }
     161:     else    *elenp = typesize[q->vtype];
     162:
     163:     if(np->vstg == STGCOMMON)
     164:         *vlenp = extsymtab[np->vardesc.varno].maxleng;
     165:     else if(np->vstg == STGEQUIV)
     166:         *vlenp = eqvclass[np->vardesc.varno].eqvleng;
     167:     else    {
     168:         *vlenp =  (np->vtype==TYCHAR ?
     169:                 np->vleng->const.ci : typesize[np->vtype]);
     170:         if(np->vdim)
     171:             *vlenp *= np->vdim->nelt->const.ci;
     172:         }
     173:     return(q);
     174:
     175: doerr:
     176:         error("nonconstant implied DO parameter",0,0,ERR);
     177:         frexpr(q);
     178:         curdtp = curdtp->nextp;
     179:
     180: next:   curdtelt = 0;
     181:     }
     182:
     183: return(NULL);
     184: }
     185:
     186:
     187:
     188:
     189:
     190:
     191: LOCAL setdata(varp, valp, elen, vlen)
     192: struct addrblock *varp;
     193: ftnint elen, vlen;
     194: struct constblock *valp;
     195: {
     196: union constant con;
     197: int i, k;
     198: int stg, type, valtype;
     199: ftnint offset;
     200: register char *s, *t;
     201: char *memname();
     202: static char varname[XL+2];
     203:
     204: /* output form of name is padded with blanks and preceded
     205:    with a storage class digit
     206: */
     207:
     208: stg = varp->vstg;
     209: varname[0] = (stg==STGCOMMON ? '2' : (stg==STGEQUIV ? '1' : '0') );
     210: s = memname(stg, varp->memno);
     211: for(t = varname+1 ; *s ; )
     212:     *t++ = *s++;
     213: while(t < varname+XL+1)
     214:     *t++ = ' ';
     215: varname[XL+1] = '\0';
     216:
     217: offset = varp->memoffset->const.ci;
     218: type = varp->vtype;
     219: valtype = valp->vtype;
     220: if(type!=TYCHAR && valtype==TYCHAR)
     221:     {
     222:     if(! ftn66flag)
     223:         error("noncharacter type initialized with string",0,0,WARN);
     224:     varp->vleng = ICON(typesize[type]);
     225:     varp->vtype = type = TYCHAR;
     226:     }
     227: else if( (type==TYCHAR && valtype!=TYCHAR) ||
     228:      (cktype(OPASSIGN,type,valtype) == TYERROR) )
     229:     {
     230:     error("incompatible types in initialization",0,0,ERR);
     231:     return;
     232:     }
     233: if(type != TYCHAR)
     234:     if(valtype == TYUNKNOWN)
     235:         con.ci = valp->const.ci;
     236:     else    consconv(type, &con, valtype, &valp->const);
     237:
     238: k = 1;
     239: switch(type)
     240:     {
     241:     case TYLOGICAL:
     242:         type = tylogical;
     243:     case TYSHORT:
     244:     case TYLONG:
     245:         fprintf(initfile, datafmt, varname, offset, vlen, type);
     246:         prconi(initfile, type, con.ci);
     247:         break;
     248:
     249:     case TYCOMPLEX:
     250:         k = 2;
     251:         type = TYREAL;
     252:     case TYREAL:
     253:         goto flpt;
     254:
     255:     case TYDCOMPLEX:
     256:         k = 2;
     257:         type = TYDREAL;
     258:     case TYDREAL:
     259:     flpt:
     260:
     261:         for(i = 0 ; i < k ; ++i)
     262:             {
     263:             fprintf(initfile, datafmt, varname, offset, vlen, type);
     264:             prconr(initfile, type, con.cd[i]);
     265:             offset += typesize[type];
     266:             }
     267:         break;
     268:
     269:     case TYCHAR:
     270:         k = valp->vleng->const.ci;
     271:         if(elen < k)
     272:             k = elen;
     273:
     274:         for(i = 0 ; i < k ; ++i)
     275:             {
     276:             fprintf(initfile, datafmt, varname, offset++, vlen, TYCHAR);
     277:             fprintf(initfile, "\t%d\n", valp->const.ccp[i]);
     278:             }
     279:         k = elen - valp->vleng->const.ci;
     280:         while( k-- > 0)
     281:             {
     282:             fprintf(initfile, datafmt, varname, offset++, vlen, TYCHAR);
     283:             fprintf(initfile, "\t%d\n", ' ');
     284:             }
     285:         break;
     286:
     287:     default:
     288:         error("setdata: impossible type %d", type,0,FATAL1);
     289:     }
     290:
     291: }
     292:
     293:
     294:
     295: frdata(p0)
     296: chainp p0;
     297: {
     298: register chainp p;
     299: register tagptr q;
     300:
     301: for(p = p0 ; p ; p = p->nextp)
     302:     {
     303:     q = p->datap;
     304:     if(q->tag == TIMPLDO)
     305:         {
     306:         if(q->isbusy)
     307:             return; /* circular chain completed */
     308:         q->isbusy = YES;
     309:         frdata(q->datalist);
     310:         free(q);
     311:         }
     312:     else
     313:         frexpr(q);
     314:     }
     315:
     316: frchain( &p0);
     317: }

#### Defined functions

dataval defined in line 9; used 2 times

- in /usr/src/usr.bin/f77/gram.dcl line 148-150(2)

frdata defined in line 295; used 2 times

- in line 309
- in /usr/src/usr.bin/f77/gram.dcl line 138

nextdata defined in line 54; used 4 times

- in line 15, 38
- in /usr/src/usr.bin/f77/gram.dcl line 133
- in /usr/src/usr.bin/f77/gram.head line 24

setdata defined in line 191; used 1 times

- in line 45

#### Defined variables

datafmt defined in line 6; used 4 times

- in line 245, 263, 276, 282

Last modified: 1987-02-17 Generated: 2016-12-26 | Generated by src2html V0.67 page hit count: 741 |