2.9BSD - /usr/src/cmd/f77/data.c

   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

Defined variables