![[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 / f2c|
Return to data.c CVS log | Up to [Research Unix] / researchv10no / cmd / f2c |
1.1 ! root 1: /**************************************************************** ! 2: Copyright 1990, 1993 by AT&T Bell Laboratories and Bellcore. ! 3: ! 4: Permission to use, copy, modify, and distribute this software ! 5: and its documentation for any purpose and without fee is hereby ! 6: granted, provided that the above copyright notice appear in all ! 7: copies and that both that the copyright notice and this ! 8: permission notice and warranty disclaimer appear in supporting ! 9: documentation, and that the names of AT&T Bell Laboratories or ! 10: Bellcore or any of their entities not be used in advertising or ! 11: publicity pertaining to distribution of the software without ! 12: specific, written prior permission. ! 13: ! 14: AT&T and Bellcore disclaim all warranties with regard to this ! 15: software, including all implied warranties of merchantability ! 16: and fitness. In no event shall AT&T or Bellcore be liable for ! 17: any special, indirect or consequential damages or any damages ! 18: whatsoever resulting from loss of use, data or profits, whether ! 19: in an action of contract, negligence or other tortious action, ! 20: arising out of or in connection with the use or performance of ! 21: this software. ! 22: ****************************************************************/ ! 23: ! 24: #include "defs.h" ! 25: ! 26: /* ROUTINES CALLED DURING DATA AND PARAMETER STATEMENT PROCESSING */ ! 27: ! 28: static char datafmt[] = "%s\t%09ld\t%d"; ! 29: static char *cur_varname; ! 30: ! 31: /* another initializer, called from parser */ ! 32: dataval(repp, valp) ! 33: register expptr repp, valp; ! 34: { ! 35: int i, nrep; ! 36: ftnint elen; ! 37: register Addrp p; ! 38: Addrp nextdata(); ! 39: ! 40: if (parstate < INDATA) { ! 41: frexpr(repp); ! 42: goto ret; ! 43: } ! 44: if(repp == NULL) ! 45: nrep = 1; ! 46: else if (ISICON(repp) && repp->constblock.Const.ci >= 0) ! 47: nrep = repp->constblock.Const.ci; ! 48: else ! 49: { ! 50: err("invalid repetition count in DATA statement"); ! 51: frexpr(repp); ! 52: goto ret; ! 53: } ! 54: frexpr(repp); ! 55: ! 56: if( ! ISCONST(valp) ) ! 57: { ! 58: err("non-constant initializer"); ! 59: goto ret; ! 60: } ! 61: ! 62: if(toomanyinit) goto ret; ! 63: for(i = 0 ; i < nrep ; ++i) ! 64: { ! 65: p = nextdata(&elen); ! 66: if(p == NULL) ! 67: { ! 68: err("too many initializers"); ! 69: toomanyinit = YES; ! 70: goto ret; ! 71: } ! 72: setdata((Addrp)p, (Constp)valp, elen); ! 73: frexpr((expptr)p); ! 74: } ! 75: ! 76: ret: ! 77: frexpr(valp); ! 78: } ! 79: ! 80: ! 81: Addrp nextdata(elenp) ! 82: ftnint *elenp; ! 83: { ! 84: register struct Impldoblock *ip; ! 85: struct Primblock *pp; ! 86: register Namep np; ! 87: register struct Rplblock *rp; ! 88: tagptr p; ! 89: expptr neltp; ! 90: register expptr q; ! 91: int skip; ! 92: ftnint off, vlen; ! 93: ! 94: while(curdtp) ! 95: { ! 96: p = (tagptr)curdtp->datap; ! 97: if(p->tag == TIMPLDO) ! 98: { ! 99: ip = &(p->impldoblock); ! 100: if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL) ! 101: fatali("bad impldoblock 0%o", (int) ip); ! 102: if(ip->isactive) ! 103: ip->varvp->Const.ci += ip->impdiff; ! 104: else ! 105: { ! 106: q = fixtype(cpexpr(ip->implb)); ! 107: if( ! ISICON(q) ) ! 108: goto doerr; ! 109: ip->varvp = (Constp) q; ! 110: ! 111: if(ip->impstep) ! 112: { ! 113: q = fixtype(cpexpr(ip->impstep)); ! 114: if( ! ISICON(q) ) ! 115: goto doerr; ! 116: ip->impdiff = q->constblock.Const.ci; ! 117: frexpr(q); ! 118: } ! 119: else ! 120: ip->impdiff = 1; ! 121: ! 122: q = fixtype(cpexpr(ip->impub)); ! 123: if(! ISICON(q)) ! 124: goto doerr; ! 125: ip->implim = q->constblock.Const.ci; ! 126: frexpr(q); ! 127: ! 128: ip->isactive = YES; ! 129: rp = ALLOC(Rplblock); ! 130: rp->rplnextp = rpllist; ! 131: rpllist = rp; ! 132: rp->rplnp = ip->varnp; ! 133: rp->rplvp = (expptr) (ip->varvp); ! 134: rp->rpltag = TCONST; ! 135: } ! 136: ! 137: if( (ip->impdiff>0 && (ip->varvp->Const.ci <= ip->implim)) ! 138: || (ip->impdiff<0 && (ip->varvp->Const.ci >= ip->implim)) ) ! 139: { /* start new loop */ ! 140: curdtp = ip->datalist; ! 141: goto next; ! 142: } ! 143: ! 144: /* clean up loop */ ! 145: ! 146: if(rpllist) ! 147: { ! 148: rp = rpllist; ! 149: rpllist = rpllist->rplnextp; ! 150: free( (charptr) rp); ! 151: } ! 152: else ! 153: Fatal("rpllist empty"); ! 154: ! 155: frexpr((expptr)ip->varvp); ! 156: ip->isactive = NO; ! 157: curdtp = curdtp->nextp; ! 158: goto next; ! 159: } ! 160: ! 161: pp = (struct Primblock *) p; ! 162: np = pp->namep; ! 163: cur_varname = np->fvarname; ! 164: skip = YES; ! 165: ! 166: if(p->primblock.argsp==NULL && np->vdim!=NULL) ! 167: { /* array initialization */ ! 168: q = (expptr) mkaddr(np); ! 169: off = typesize[np->vtype] * curdtelt; ! 170: if(np->vtype == TYCHAR) ! 171: off *= np->vleng->constblock.Const.ci; ! 172: q->addrblock.memoffset = ! 173: mkexpr(OPPLUS, q->addrblock.memoffset, mkintcon(off) ); ! 174: if( (neltp = np->vdim->nelt) && ISCONST(neltp)) ! 175: { ! 176: if(++curdtelt < neltp->constblock.Const.ci) ! 177: skip = NO; ! 178: } ! 179: else ! 180: err("attempt to initialize adjustable array"); ! 181: } ! 182: else ! 183: q = mklhs((struct Primblock *)cpexpr((expptr)pp), 0); ! 184: if(skip) ! 185: { ! 186: curdtp = curdtp->nextp; ! 187: curdtelt = 0; ! 188: } ! 189: if(q->headblock.vtype == TYCHAR) ! 190: if(ISICON(q->headblock.vleng)) ! 191: *elenp = q->headblock.vleng->constblock.Const.ci; ! 192: else { ! 193: err("initialization of string of nonconstant length"); ! 194: continue; ! 195: } ! 196: else *elenp = typesize[q->headblock.vtype]; ! 197: ! 198: if (np->vstg == STGBSS) { ! 199: vlen = np->vtype==TYCHAR ! 200: ? np->vleng->constblock.Const.ci ! 201: : typesize[np->vtype]; ! 202: if(vlen > 0) ! 203: np->vstg = STGINIT; ! 204: } ! 205: return( (Addrp) q ); ! 206: ! 207: doerr: ! 208: err("nonconstant implied DO parameter"); ! 209: frexpr(q); ! 210: curdtp = curdtp->nextp; ! 211: ! 212: next: ! 213: curdtelt = 0; ! 214: } ! 215: ! 216: return(NULL); ! 217: } ! 218: ! 219: ! 220: ! 221: LOCAL FILEP dfile; ! 222: ! 223: ! 224: setdata(varp, valp, elen) ! 225: register Addrp varp; ! 226: ftnint elen; ! 227: register Constp valp; ! 228: { ! 229: struct Constblock con; ! 230: register int type; ! 231: int i, k, valtype; ! 232: ftnint offset; ! 233: char *dataname(), *varname; ! 234: static Addrp badvar; ! 235: register unsigned char *s; ! 236: static int last_lineno; ! 237: static char *last_varname; ! 238: ! 239: if (varp->vstg == STGCOMMON) { ! 240: if (!(dfile = blkdfile)) ! 241: dfile = blkdfile = opf(blkdfname, textwrite); ! 242: } ! 243: else { ! 244: if (procclass == CLBLOCK) { ! 245: if (varp != badvar) { ! 246: badvar = varp; ! 247: warn1("%s is not in a COMMON block", ! 248: varp->uname_tag == UNAM_NAME ! 249: ? varp->user.name->fvarname ! 250: : "???"); ! 251: } ! 252: return; ! 253: } ! 254: if (!(dfile = initfile)) ! 255: dfile = initfile = opf(initfname, textwrite); ! 256: } ! 257: varname = dataname(varp->vstg, varp->memno); ! 258: offset = varp->memoffset->constblock.Const.ci; ! 259: type = varp->vtype; ! 260: valtype = valp->vtype; ! 261: if(type!=TYCHAR && valtype==TYCHAR) ! 262: { ! 263: if(! ftn66flag ! 264: && (last_varname != cur_varname || last_lineno != lineno)) { ! 265: /* prevent multiple warnings */ ! 266: last_lineno = lineno; ! 267: warn1( ! 268: "non-character datum %.42s initialized with character string", ! 269: last_varname = cur_varname); ! 270: } ! 271: varp->vleng = ICON(typesize[type]); ! 272: varp->vtype = type = TYCHAR; ! 273: } ! 274: else if( (type==TYCHAR && valtype!=TYCHAR) || ! 275: (cktype(OPASSIGN,type,valtype) == TYERROR) ) ! 276: { ! 277: err("incompatible types in initialization"); ! 278: return; ! 279: } ! 280: if(type == TYADDR) ! 281: con.Const.ci = valp->Const.ci; ! 282: else if(type != TYCHAR) ! 283: { ! 284: if(valtype == TYUNKNOWN) ! 285: con.Const.ci = valp->Const.ci; ! 286: else consconv(type, &con, valp); ! 287: } ! 288: ! 289: k = 1; ! 290: ! 291: switch(type) ! 292: { ! 293: case TYLOGICAL: ! 294: if (tylogical != TYLONG) ! 295: type = tylogical; ! 296: case TYINT1: ! 297: case TYLOGICAL1: ! 298: case TYLOGICAL2: ! 299: case TYSHORT: ! 300: case TYLONG: ! 301: #ifdef TYQUAD ! 302: case TYQUAD: ! 303: #endif ! 304: dataline(varname, offset, type); ! 305: prconi(dfile, con.Const.ci); ! 306: break; ! 307: ! 308: case TYADDR: ! 309: dataline(varname, offset, type); ! 310: prcona(dfile, con.Const.ci); ! 311: break; ! 312: ! 313: case TYCOMPLEX: ! 314: case TYDCOMPLEX: ! 315: k = 2; ! 316: case TYREAL: ! 317: case TYDREAL: ! 318: dataline(varname, offset, type); ! 319: prconr(dfile, &con, k); ! 320: break; ! 321: ! 322: case TYCHAR: ! 323: k = valp -> vleng -> constblock.Const.ci; ! 324: if (elen < k) ! 325: k = elen; ! 326: s = (unsigned char *)valp->Const.ccp; ! 327: for(i = 0 ; i < k ; ++i) { ! 328: dataline(varname, offset++, TYCHAR); ! 329: fprintf(dfile, "\t%d\n", *s++); ! 330: } ! 331: k = elen - valp->vleng->constblock.Const.ci; ! 332: if(k > 0) { ! 333: dataline(varname, offset, TYBLANK); ! 334: fprintf(dfile, "\t%d\n", k); ! 335: } ! 336: break; ! 337: ! 338: default: ! 339: badtype("setdata", type); ! 340: } ! 341: ! 342: } ! 343: ! 344: ! 345: ! 346: /* ! 347: output form of name is padded with blanks and preceded ! 348: with a storage class digit ! 349: */ ! 350: char *dataname(stg,memno) ! 351: int stg; ! 352: long memno; ! 353: { ! 354: static char varname[64]; ! 355: register char *s, *t; ! 356: char buf[16], *memname(); ! 357: ! 358: if (stg == STGCOMMON) { ! 359: varname[0] = '2'; ! 360: sprintf(s = buf, "Q.%ld", memno); ! 361: } ! 362: else { ! 363: varname[0] = stg==STGEQUIV ? '1' : '0'; ! 364: s = memname(stg, memno); ! 365: } ! 366: t = varname + 1; ! 367: while(*t++ = *s++); ! 368: *t = 0; ! 369: return(varname); ! 370: } ! 371: ! 372: ! 373: ! 374: ! 375: ! 376: frdata(p0) ! 377: chainp p0; ! 378: { ! 379: register struct Chain *p; ! 380: register tagptr q; ! 381: ! 382: for(p = p0 ; p ; p = p->nextp) ! 383: { ! 384: q = (tagptr)p->datap; ! 385: if(q->tag == TIMPLDO) ! 386: { ! 387: if(q->impldoblock.isbusy) ! 388: return; /* circular chain completed */ ! 389: q->impldoblock.isbusy = YES; ! 390: frdata(q->impldoblock.datalist); ! 391: free( (charptr) q); ! 392: } ! 393: else ! 394: frexpr(q); ! 395: } ! 396: ! 397: frchain( &p0); ! 398: } ! 399: ! 400: ! 401: ! 402: dataline(varname, offset, type) ! 403: char *varname; ! 404: ftnint offset; ! 405: int type; ! 406: { ! 407: fprintf(dfile, datafmt, varname, offset, type); ! 408: } ! 409: ! 410: void ! 411: make_param(p, e) ! 412: register struct Paramblock *p; ! 413: expptr e; ! 414: { ! 415: register expptr q; ! 416: ! 417: p->vclass = CLPARAM; ! 418: impldcl((Namep)p); ! 419: p->paramval = q = mkconv(p->vtype, e); ! 420: if (p->vtype == TYCHAR) { ! 421: if (q->tag == TEXPR) ! 422: p->paramval = q = fixexpr(q); ! 423: if (!ISCONST(q) || q->constblock.vtype != TYCHAR) { ! 424: errstr("invalid value for character parameter %s", ! 425: p->fvarname); ! 426: return; ! 427: } ! 428: if (!(e = p->vleng)) ! 429: p->vleng = ICON(q->constblock.vleng->constblock.Const.ci ! 430: + q->constblock.Const.ccp1.blanks); ! 431: else if (q->constblock.vleng->constblock.Const.ci ! 432: > e->constblock.Const.ci) { ! 433: q->constblock.vleng->constblock.Const.ci ! 434: = e->constblock.Const.ci; ! 435: q->constblock.Const.ccp1.blanks = 0; ! 436: } ! 437: else ! 438: q->constblock.Const.ccp1.blanks ! 439: = e->constblock.Const.ci ! 440: - q->constblock.vleng->constblock.Const.ci; ! 441: } ! 442: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.