UNIX 7th Ed. - /usr/src/cmd/f77/data.c

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

Defined functions

Defined variables