![[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|
Return to data.c CVS log | Up to [Research Unix] / researchv10no / cmd / f77 |
1.1 ! root 1: #include "defs" ! 2: ! 3: /* ROUTINES CALLED DURING DATA AND PARAMETER 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: ! 190: curdtelt = 0; ! 191: } ! 192: ! 193: return(NULL); ! 194: } ! 195: ! 196: ! 197: ! 198: ! 199: ! 200: ! 201: setdata(varp, valp, elen, vlen) ! 202: register Addrp varp; ! 203: ftnint elen, vlen; ! 204: register Constp valp; ! 205: { ! 206: union Constant con; ! 207: register int type; ! 208: int i, k, valtype; ! 209: ftnint offset; ! 210: char *dataname(), *varname; ! 211: ! 212: varname = dataname(varp->vstg, varp->memno); ! 213: offset = varp->memoffset->constblock.Const.ci; ! 214: type = varp->vtype; ! 215: valtype = valp->vtype; ! 216: if(type!=TYCHAR && valtype==TYCHAR) ! 217: { ! 218: if(! ftn66flag) ! 219: warn("non-character datum initialized with character string"); ! 220: varp->vleng = ICON(typesize[type]); ! 221: varp->vtype = type = TYCHAR; ! 222: } ! 223: else if( (type==TYCHAR && valtype!=TYCHAR) || ! 224: (cktype(OPASSIGN,type,valtype) == TYERROR) ) ! 225: { ! 226: err("incompatible types in initialization"); ! 227: return; ! 228: } ! 229: if(type == TYADDR) ! 230: con.ci = valp->Const.ci; ! 231: else if(type != TYCHAR) ! 232: { ! 233: if(valtype == TYUNKNOWN) ! 234: con.ci = valp->Const.ci; ! 235: else consconv(type, &con, valtype, &valp->Const); ! 236: } ! 237: ! 238: k = 1; ! 239: switch(type) ! 240: { ! 241: case TYLOGICAL: ! 242: type = tylogical; ! 243: case TYSHORT: ! 244: case TYLONG: ! 245: dataline(varname, offset, vlen, type); ! 246: prconi(initfile, type, con.ci); ! 247: break; ! 248: ! 249: case TYADDR: ! 250: dataline(varname, offset, vlen, type); ! 251: prcona(initfile, con.ci); ! 252: break; ! 253: ! 254: case TYCOMPLEX: ! 255: k = 2; ! 256: type = TYREAL; ! 257: case TYREAL: ! 258: goto flpt; ! 259: ! 260: case TYDCOMPLEX: ! 261: k = 2; ! 262: type = TYDREAL; ! 263: case TYDREAL: ! 264: flpt: ! 265: ! 266: for(i = 0 ; i < k ; ++i) ! 267: { ! 268: dataline(varname, offset, vlen, type); ! 269: prconr(initfile, type, con.cd[i]); ! 270: offset += typesize[type]; ! 271: } ! 272: break; ! 273: ! 274: case TYCHAR: ! 275: k = valp->vleng->constblock.Const.ci; ! 276: if(elen < k) ! 277: k = elen; ! 278: ! 279: for(i = 0 ; i < k ; ++i) ! 280: { ! 281: dataline(varname, offset++, vlen, TYCHAR); ! 282: fprintf(initfile, "\t%d\n", ! 283: valp->Const.ccp[i]); ! 284: } ! 285: k = elen - valp->vleng->constblock.Const.ci; ! 286: if(k > 0) ! 287: { ! 288: dataline(varname, offset, vlen, TYBLANK); ! 289: fprintf(initfile, "\t%d\n", k); ! 290: offset += k; ! 291: } ! 292: break; ! 293: ! 294: default: ! 295: badtype("setdata", type); ! 296: } ! 297: ! 298: } ! 299: ! 300: ! 301: ! 302: /* ! 303: output form of name is padded with blanks and preceded ! 304: with a storage class digit ! 305: */ ! 306: char *dataname(stg,memno) ! 307: int stg, memno; ! 308: { ! 309: static char varname[XL+2]; ! 310: register char *s, *t; ! 311: char *memname(); ! 312: ! 313: varname[0] = (stg==STGCOMMON ? '2' : (stg==STGEQUIV ? '1' : '0') ); ! 314: s = memname(stg, memno); ! 315: for(t = varname+1 ; *s ; ) ! 316: *t++ = *s++; ! 317: while(t < varname+XL+1) ! 318: *t++ = ' '; ! 319: varname[XL+1] = '\0'; ! 320: return(varname); ! 321: } ! 322: ! 323: ! 324: ! 325: ! 326: ! 327: frdata(p0) ! 328: chainp p0; ! 329: { ! 330: register struct Chain *p; ! 331: register tagptr q; ! 332: ! 333: for(p = p0 ; p ; p = p->nextp) ! 334: { ! 335: q = p->datap; ! 336: if(q->tag == TIMPLDO) ! 337: { ! 338: if(q->impldoblock.isbusy) ! 339: return; /* circular chain completed */ ! 340: q->impldoblock.isbusy = YES; ! 341: frdata(q->impldoblock.datalist); ! 342: free( (charptr) q); ! 343: } ! 344: else ! 345: frexpr(q); ! 346: } ! 347: ! 348: frchain( &p0); ! 349: } ! 350: ! 351: ! 352: ! 353: dataline(varname, offset, vlen, type) ! 354: char *varname; ! 355: ftnint offset, vlen; ! 356: int type; ! 357: { ! 358: fprintf(initfile, datafmt, varname, offset, vlen, type); ! 359: } ! 360: ! 361: ! 362: void ! 363: make_param(p, e) ! 364: register struct Paramblock *p; ! 365: expptr e; ! 366: { ! 367: p->vclass = CLPARAM; ! 368: impldcl(p); ! 369: if (p->vtype != ((Constp)e)->vtype && bugwarn & 1) ! 370: warnb1("old f77 typed parameter %s incorrectly", ! 371: varstr(VL, p->varname)); ! 372: p->paramval = (bugwarn & 2) ? e : mkconv(p->vtype, e); ! 373: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.