![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to data.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / f77 / old|
Return to data.c CVS log | Up to [Research Unix] / researchv10no / cmd / f77 / old |
1.1 ! root 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 expptr repp, valp; ! 10: { ! 11: int i, nrep; ! 12: ftnint elen, vlen; ! 13: register Addrp p; ! 14: Addrp nextdata(); ! 15: ! 16: if(repp == NULL) ! 17: nrep = 1; ! 18: else if (ISICON(repp) && repp->constblock.const.ci >= 0) ! 19: nrep = repp->constblock.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: Addrp nextdata(elenp, vlenp) ! 54: ftnint *elenp, *vlenp; ! 55: { ! 56: register struct Impldoblock *ip; ! 57: struct Primblock *pp; ! 58: register Namep np; ! 59: register struct Rplblock *rp; ! 60: tagptr p; ! 61: expptr neltp; ! 62: register expptr q; ! 63: int skip; ! 64: ftnint off; ! 65: ! 66: while(curdtp) ! 67: { ! 68: p = curdtp->datap; ! 69: if(p->tag == TIMPLDO) ! 70: { ! 71: ip = &(p->impldoblock); ! 72: if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL) ! 73: fatali("bad impldoblock 0%o", (int) ip); ! 74: if(ip->isactive) ! 75: ip->varvp->const.ci += ip->impdiff; ! 76: else ! 77: { ! 78: q = fixtype(cpexpr(ip->implb)); ! 79: if( ! ISICON(q) ) ! 80: goto doerr; ! 81: ip->varvp = (Constp) q; ! 82: ! 83: if(ip->impstep) ! 84: { ! 85: q = fixtype(cpexpr(ip->impstep)); ! 86: if( ! ISICON(q) ) ! 87: goto doerr; ! 88: ip->impdiff = q->constblock.const.ci; ! 89: frexpr(q); ! 90: } ! 91: else ! 92: ip->impdiff = 1; ! 93: ! 94: q = fixtype(cpexpr(ip->impub)); ! 95: if(! ISICON(q)) ! 96: goto doerr; ! 97: ip->implim = q->constblock.const.ci; ! 98: frexpr(q); ! 99: ! 100: ip->isactive = YES; ! 101: rp = ALLOC(Rplblock); ! 102: rp->rplnextp = rpllist; ! 103: rpllist = rp; ! 104: rp->rplnp = ip->varnp; ! 105: rp->rplvp = (expptr) (ip->varvp); ! 106: rp->rpltag = TCONST; ! 107: } ! 108: ! 109: if( (ip->impdiff>0 && (ip->varvp->const.ci <= ip->implim)) ! 110: || (ip->impdiff<0 && (ip->varvp->const.ci >= ip->implim)) ) ! 111: { /* start new loop */ ! 112: curdtp = ip->datalist; ! 113: goto next; ! 114: } ! 115: ! 116: /* clean up loop */ ! 117: ! 118: if(rpllist) ! 119: { ! 120: rp = rpllist; ! 121: rpllist = rpllist->rplnextp; ! 122: free( (charptr) rp); ! 123: } ! 124: else ! 125: fatal("rpllist empty"); ! 126: ! 127: frexpr(ip->varvp); ! 128: ip->isactive = NO; ! 129: curdtp = curdtp->nextp; ! 130: goto next; ! 131: } ! 132: ! 133: pp = (struct Primblock *) p; ! 134: np = pp->namep; ! 135: skip = YES; ! 136: ! 137: if(p->primblock.argsp==NULL && np->vdim!=NULL) ! 138: { /* array initialization */ ! 139: q = (expptr) mkaddr(np); ! 140: off = typesize[np->vtype] * curdtelt; ! 141: if(np->vtype == TYCHAR) ! 142: off *= np->vleng->constblock.const.ci; ! 143: q->addrblock.memoffset = ! 144: mkexpr(OPPLUS, q->addrblock.memoffset, mkintcon(off) ); ! 145: if( (neltp = np->vdim->nelt) && ISCONST(neltp)) ! 146: { ! 147: if(++curdtelt < neltp->constblock.const.ci) ! 148: skip = NO; ! 149: } ! 150: else ! 151: err("attempt to initialize adjustable array"); ! 152: } ! 153: else ! 154: q = mklhs( cpexpr(pp) ); ! 155: if(skip) ! 156: { ! 157: curdtp = curdtp->nextp; ! 158: curdtelt = 0; ! 159: } ! 160: if(q->headblock.vtype == TYCHAR) ! 161: if(ISICON(q->headblock.vleng)) ! 162: *elenp = q->headblock.vleng->constblock.const.ci; ! 163: else { ! 164: err("initialization of string of nonconstant length"); ! 165: continue; ! 166: } ! 167: else *elenp = typesize[q->headblock.vtype]; ! 168: ! 169: if(np->vstg == STGCOMMON) ! 170: *vlenp = extsymtab[np->vardesc.varno].maxleng; ! 171: else if(np->vstg == STGEQUIV) ! 172: *vlenp = eqvclass[np->vardesc.varno].eqvleng; ! 173: else { ! 174: *vlenp = (np->vtype==TYCHAR ? ! 175: np->vleng->constblock.const.ci : ! 176: typesize[np->vtype]); ! 177: if(np->vstg==STGBSS && *vlenp>0) ! 178: np->vstg = STGINIT; ! 179: if(np->vdim) ! 180: *vlenp *= np->vdim->nelt->constblock.const.ci; ! 181: } ! 182: return( (Addrp) q ); ! 183: ! 184: doerr: ! 185: err("nonconstant implied DO parameter"); ! 186: frexpr(q); ! 187: curdtp = curdtp->nextp; ! 188: ! 189: next: curdtelt = 0; ! 190: } ! 191: ! 192: return(NULL); ! 193: } ! 194: ! 195: ! 196: ! 197: ! 198: ! 199: ! 200: setdata(varp, valp, elen, vlen) ! 201: register Addrp varp; ! 202: ftnint elen, vlen; ! 203: register Constp valp; ! 204: { ! 205: union Constant con; ! 206: register int type; ! 207: int i, k, valtype; ! 208: ftnint offset; ! 209: char *dataname(), *varname; ! 210: ! 211: varname = dataname(varp->vstg, varp->memno); ! 212: offset = varp->memoffset->constblock.const.ci; ! 213: type = varp->vtype; ! 214: valtype = valp->vtype; ! 215: if(type!=TYCHAR && valtype==TYCHAR) ! 216: { ! 217: if(! ftn66flag) ! 218: warn("non-character datum initialized with character string"); ! 219: varp->vleng = ICON(typesize[type]); ! 220: varp->vtype = type = TYCHAR; ! 221: } ! 222: else if( (type==TYCHAR && valtype!=TYCHAR) || ! 223: (cktype(OPASSIGN,type,valtype) == TYERROR) ) ! 224: { ! 225: err("incompatible types in initialization"); ! 226: return; ! 227: } ! 228: if(type == TYADDR) ! 229: con.ci = valp->const.ci; ! 230: else if(type != TYCHAR) ! 231: { ! 232: if(valtype == TYUNKNOWN) ! 233: con.ci = valp->const.ci; ! 234: else consconv(type, &con, valtype, &valp->const); ! 235: } ! 236: ! 237: k = 1; ! 238: switch(type) ! 239: { ! 240: case TYLOGICAL: ! 241: type = tylogical; ! 242: case TYSHORT: ! 243: case TYLONG: ! 244: dataline(varname, offset, vlen, type); ! 245: prconi(initfile, type, con.ci); ! 246: break; ! 247: ! 248: case TYADDR: ! 249: dataline(varname, offset, vlen, type); ! 250: prcona(initfile, con.ci); ! 251: break; ! 252: ! 253: case TYCOMPLEX: ! 254: k = 2; ! 255: type = TYREAL; ! 256: case TYREAL: ! 257: goto flpt; ! 258: ! 259: case TYDCOMPLEX: ! 260: k = 2; ! 261: type = TYDREAL; ! 262: case TYDREAL: ! 263: flpt: ! 264: ! 265: for(i = 0 ; i < k ; ++i) ! 266: { ! 267: dataline(varname, offset, vlen, type); ! 268: prconr(initfile, type, con.cd[i]); ! 269: offset += typesize[type]; ! 270: } ! 271: break; ! 272: ! 273: case TYCHAR: ! 274: k = valp->vleng->constblock.const.ci; ! 275: if(elen < k) ! 276: k = elen; ! 277: ! 278: for(i = 0 ; i < k ; ++i) ! 279: { ! 280: dataline(varname, offset++, vlen, TYCHAR); ! 281: fprintf(initfile, "\t%d\n", ! 282: valp->const.ccp[i]); ! 283: } ! 284: k = elen - valp->vleng->constblock.const.ci; ! 285: if(k > 0) ! 286: { ! 287: dataline(varname, offset, vlen, TYBLANK); ! 288: fprintf(initfile, "\t%d\n", k); ! 289: offset += k; ! 290: } ! 291: break; ! 292: ! 293: default: ! 294: badtype("setdata", type); ! 295: } ! 296: ! 297: } ! 298: ! 299: ! 300: ! 301: /* ! 302: output form of name is padded with blanks and preceded ! 303: with a storage class digit ! 304: */ ! 305: char *dataname(stg,memno) ! 306: int stg, memno; ! 307: { ! 308: static char varname[XL+2]; ! 309: register char *s, *t; ! 310: char *memname(); ! 311: ! 312: varname[0] = (stg==STGCOMMON ? '2' : (stg==STGEQUIV ? '1' : '0') ); ! 313: s = memname(stg, memno); ! 314: for(t = varname+1 ; *s ; ) ! 315: *t++ = *s++; ! 316: while(t < varname+XL+1) ! 317: *t++ = ' '; ! 318: varname[XL+1] = '\0'; ! 319: return(varname); ! 320: } ! 321: ! 322: ! 323: ! 324: ! 325: ! 326: frdata(p0) ! 327: chainp p0; ! 328: { ! 329: register struct Chain *p; ! 330: register tagptr q; ! 331: ! 332: for(p = p0 ; p ; p = p->nextp) ! 333: { ! 334: q = p->datap; ! 335: if(q->tag == TIMPLDO) ! 336: { ! 337: if(q->impldoblock.isbusy) ! 338: return; /* circular chain completed */ ! 339: q->impldoblock.isbusy = YES; ! 340: frdata(q->impldoblock.datalist); ! 341: free( (charptr) q); ! 342: } ! 343: else ! 344: frexpr(q); ! 345: } ! 346: ! 347: frchain( &p0); ! 348: } ! 349: ! 350: ! 351: ! 352: dataline(varname, offset, vlen, type) ! 353: char *varname; ! 354: ftnint offset, vlen; ! 355: int type; ! 356: { ! 357: fprintf(initfile, datafmt, varname, offset, vlen, type); ! 358: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.