![[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 [CSRG BSD Unix] / 3BSD / cmd / f77|
Return to data.c CVS log | Up to [CSRG BSD Unix] / 3BSD / cmd / f77 |
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 struct Addrblock *p; ! 14: struct Addrblock *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: 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: ! 66: while(curdtp) ! 67: { ! 68: p = (tagptr) (curdtp->datap); ! 69: if(p->headblock.tag == TIMPLDO) ! 70: { ! 71: ip = &(p->impldoblock); ! 72: if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL) ! 73: fatali("bad impldoblock 0%o", 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 = 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->nextp = rpllist; ! 103: rpllist = rp; ! 104: rp->rplnp = ip->varnp; ! 105: rp->rplvp = 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: popstack(&rpllist); ! 119: ! 120: frexpr(ip->varvp); ! 121: ip->isactive = NO; ! 122: curdtp = curdtp->nextp; ! 123: goto next; ! 124: } ! 125: ! 126: pp = p; ! 127: np = pp->namep; ! 128: skip = YES; ! 129: ! 130: if(p->primblock.argsp==NULL && np->vdim!=NULL) ! 131: { /* array initialization */ ! 132: q = mkaddr(np); ! 133: off = typesize[np->vtype] * curdtelt; ! 134: if(np->vtype == TYCHAR) ! 135: off *= np->vleng->constblock.const.ci; ! 136: q->addrblock.memoffset = ! 137: mkexpr(OPPLUS, q->addrblock.memoffset, mkintcon(off) ); ! 138: if( (neltp = np->vdim->nelt) && ISCONST(neltp)) ! 139: { ! 140: if(++curdtelt < neltp->constblock.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->headblock.vtype == TYCHAR) ! 154: if(ISICON(q->headblock.vleng)) ! 155: *elenp = q->headblock.vleng->constblock.const.ci; ! 156: else { ! 157: err("initialization of string of nonconstant length"); ! 158: continue; ! 159: } ! 160: else *elenp = typesize[q->headblock.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->constblock.const.ci : typesize[np->vtype]); ! 169: if(np->vdim) ! 170: *vlenp *= np->vdim->nelt->constblock.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->constblock.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->constblock.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", ! 277: valp->const.ccp[i]); ! 278: } ! 279: k = elen - valp->vleng->constblock.const.ci; ! 280: if(k > 0) ! 281: { ! 282: fprintf(initfile, datafmt, varname, offset, vlen, TYBLANK); ! 283: fprintf(initfile, "\t%d\n", k); ! 284: offset += k; ! 285: } ! 286: break; ! 287: ! 288: default: ! 289: fatali("setdata: impossible type %d", type); ! 290: } ! 291: ! 292: } ! 293: ! 294: ! 295: ! 296: frdata(p0) ! 297: chainp p0; ! 298: { ! 299: register struct Chain *p; ! 300: register tagptr q; ! 301: ! 302: for(p = p0 ; p ; p = p->nextp) ! 303: { ! 304: q = p->datap; ! 305: if(q->headblock.tag == TIMPLDO) ! 306: { ! 307: if(q->impldoblock.isbusy) ! 308: return; /* circular chain completed */ ! 309: q->impldoblock.isbusy = YES; ! 310: frdata(q->impldoblock.datalist); ! 311: free(q); ! 312: } ! 313: else ! 314: frexpr(q); ! 315: } ! 316: ! 317: frchain( &p0); ! 318: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.