![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to io.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 io.c CVS log | Up to [Research Unix] / researchv10no / cmd / f2c |
1.1 ! root 1: /**************************************************************** ! 2: Copyright 1990, 1991, 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: /* Routines to generate code for I/O statements. ! 25: Some corrections and improvements due to David Wasley, U. C. Berkeley ! 26: */ ! 27: ! 28: /* TEMPORARY */ ! 29: #define TYIOINT TYLONG ! 30: #define SZIOINT SZLONG ! 31: ! 32: #include "defs.h" ! 33: #include "names.h" ! 34: #include "iob.h" ! 35: ! 36: extern int inqmask; ! 37: ! 38: LOCAL void dofclose(), dofinquire(), dofinquire(), dofmove(), dofopen(), ! 39: doiolist(), ioset(), ioseta(), iosetc(), iosetip(), iosetlc(), ! 40: putio(), putiocall(); ! 41: ! 42: iob_data *iob_list; ! 43: Addrp io_structs[9]; ! 44: ! 45: LOCAL char ioroutine[12]; ! 46: ! 47: LOCAL long ioendlab; ! 48: LOCAL long ioerrlab; ! 49: LOCAL int endbit; ! 50: LOCAL int errbit; ! 51: LOCAL long jumplab; ! 52: LOCAL long skiplab; ! 53: LOCAL int ioformatted; ! 54: LOCAL int statstruct = NO; ! 55: LOCAL struct Labelblock *skiplabel; ! 56: Addrp ioblkp; ! 57: ! 58: #define UNFORMATTED 0 ! 59: #define FORMATTED 1 ! 60: #define LISTDIRECTED 2 ! 61: #define NAMEDIRECTED 3 ! 62: ! 63: #define V(z) ioc[z].iocval ! 64: ! 65: #define IOALL 07777 ! 66: ! 67: LOCAL struct Ioclist ! 68: { ! 69: char *iocname; ! 70: int iotype; ! 71: expptr iocval; ! 72: } ! 73: ioc[ ] = ! 74: { ! 75: { "", 0 }, ! 76: { "unit", IOALL }, ! 77: { "fmt", M(IOREAD) | M(IOWRITE) }, ! 78: { "err", IOALL }, ! 79: { "end", M(IOREAD) }, ! 80: { "iostat", IOALL }, ! 81: { "rec", M(IOREAD) | M(IOWRITE) }, ! 82: { "recl", M(IOOPEN) | M(IOINQUIRE) }, ! 83: { "file", M(IOOPEN) | M(IOINQUIRE) }, ! 84: { "status", M(IOOPEN) | M(IOCLOSE) }, ! 85: { "access", M(IOOPEN) | M(IOINQUIRE) }, ! 86: { "form", M(IOOPEN) | M(IOINQUIRE) }, ! 87: { "blank", M(IOOPEN) | M(IOINQUIRE) }, ! 88: { "exist", M(IOINQUIRE) }, ! 89: { "opened", M(IOINQUIRE) }, ! 90: { "number", M(IOINQUIRE) }, ! 91: { "named", M(IOINQUIRE) }, ! 92: { "name", M(IOINQUIRE) }, ! 93: { "sequential", M(IOINQUIRE) }, ! 94: { "direct", M(IOINQUIRE) }, ! 95: { "formatted", M(IOINQUIRE) }, ! 96: { "unformatted", M(IOINQUIRE) }, ! 97: { "nextrec", M(IOINQUIRE) }, ! 98: { "nml", M(IOREAD) | M(IOWRITE) } ! 99: }; ! 100: ! 101: #define NIOS (sizeof(ioc)/sizeof(struct Ioclist) - 1) ! 102: ! 103: /* #define IOSUNIT 1 */ ! 104: /* #define IOSFMT 2 */ ! 105: #define IOSERR 3 ! 106: #define IOSEND 4 ! 107: #define IOSIOSTAT 5 ! 108: #define IOSREC 6 ! 109: #define IOSRECL 7 ! 110: #define IOSFILE 8 ! 111: #define IOSSTATUS 9 ! 112: #define IOSACCESS 10 ! 113: #define IOSFORM 11 ! 114: #define IOSBLANK 12 ! 115: #define IOSEXISTS 13 ! 116: #define IOSOPENED 14 ! 117: #define IOSNUMBER 15 ! 118: #define IOSNAMED 16 ! 119: #define IOSNAME 17 ! 120: #define IOSSEQUENTIAL 18 ! 121: #define IOSDIRECT 19 ! 122: #define IOSFORMATTED 20 ! 123: #define IOSUNFORMATTED 21 ! 124: #define IOSNEXTREC 22 ! 125: #define IOSNML 23 ! 126: ! 127: #define IOSTP V(IOSIOSTAT) ! 128: ! 129: ! 130: /* offsets in generated structures */ ! 131: ! 132: #define SZFLAG SZIOINT ! 133: ! 134: /* offsets for external READ and WRITE statements */ ! 135: ! 136: #define XERR 0 ! 137: #define XUNIT SZFLAG ! 138: #define XEND SZFLAG + SZIOINT ! 139: #define XFMT 2*SZFLAG + SZIOINT ! 140: #define XREC 2*SZFLAG + SZIOINT + SZADDR ! 141: ! 142: /* offsets for internal READ and WRITE statements */ ! 143: ! 144: #define XIUNIT SZFLAG ! 145: #define XIEND SZFLAG + SZADDR ! 146: #define XIFMT 2*SZFLAG + SZADDR ! 147: #define XIRLEN 2*SZFLAG + 2*SZADDR ! 148: #define XIRNUM 2*SZFLAG + 2*SZADDR + SZIOINT ! 149: #define XIREC 2*SZFLAG + 2*SZADDR + 2*SZIOINT ! 150: ! 151: /* offsets for OPEN statements */ ! 152: ! 153: #define XFNAME SZFLAG + SZIOINT ! 154: #define XFNAMELEN SZFLAG + SZIOINT + SZADDR ! 155: #define XSTATUS SZFLAG + 2*SZIOINT + SZADDR ! 156: #define XACCESS SZFLAG + 2*SZIOINT + 2*SZADDR ! 157: #define XFORMATTED SZFLAG + 2*SZIOINT + 3*SZADDR ! 158: #define XRECLEN SZFLAG + 2*SZIOINT + 4*SZADDR ! 159: #define XBLANK SZFLAG + 3*SZIOINT + 4*SZADDR ! 160: ! 161: /* offset for CLOSE statement */ ! 162: ! 163: #define XCLSTATUS SZFLAG + SZIOINT ! 164: ! 165: /* offsets for INQUIRE statement */ ! 166: ! 167: #define XFILE SZFLAG + SZIOINT ! 168: #define XFILELEN SZFLAG + SZIOINT + SZADDR ! 169: #define XEXISTS SZFLAG + 2*SZIOINT + SZADDR ! 170: #define XOPEN SZFLAG + 2*SZIOINT + 2*SZADDR ! 171: #define XNUMBER SZFLAG + 2*SZIOINT + 3*SZADDR ! 172: #define XNAMED SZFLAG + 2*SZIOINT + 4*SZADDR ! 173: #define XNAME SZFLAG + 2*SZIOINT + 5*SZADDR ! 174: #define XNAMELEN SZFLAG + 2*SZIOINT + 6*SZADDR ! 175: #define XQACCESS SZFLAG + 3*SZIOINT + 6*SZADDR ! 176: #define XQACCLEN SZFLAG + 3*SZIOINT + 7*SZADDR ! 177: #define XSEQ SZFLAG + 4*SZIOINT + 7*SZADDR ! 178: #define XSEQLEN SZFLAG + 4*SZIOINT + 8*SZADDR ! 179: #define XDIRECT SZFLAG + 5*SZIOINT + 8*SZADDR ! 180: #define XDIRLEN SZFLAG + 5*SZIOINT + 9*SZADDR ! 181: #define XFORM SZFLAG + 6*SZIOINT + 9*SZADDR ! 182: #define XFORMLEN SZFLAG + 6*SZIOINT + 10*SZADDR ! 183: #define XFMTED SZFLAG + 7*SZIOINT + 10*SZADDR ! 184: #define XFMTEDLEN SZFLAG + 7*SZIOINT + 11*SZADDR ! 185: #define XUNFMT SZFLAG + 8*SZIOINT + 11*SZADDR ! 186: #define XUNFMTLEN SZFLAG + 8*SZIOINT + 12*SZADDR ! 187: #define XQRECL SZFLAG + 9*SZIOINT + 12*SZADDR ! 188: #define XNEXTREC SZFLAG + 9*SZIOINT + 13*SZADDR ! 189: #define XQBLANK SZFLAG + 9*SZIOINT + 14*SZADDR ! 190: #define XQBLANKLEN SZFLAG + 9*SZIOINT + 15*SZADDR ! 191: ! 192: LOCAL char *cilist_names[] = { ! 193: "cilist", ! 194: "cierr", ! 195: "ciunit", ! 196: "ciend", ! 197: "cifmt", ! 198: "cirec" ! 199: }; ! 200: LOCAL char *icilist_names[] = { ! 201: "icilist", ! 202: "icierr", ! 203: "iciunit", ! 204: "iciend", ! 205: "icifmt", ! 206: "icirlen", ! 207: "icirnum" ! 208: }; ! 209: LOCAL char *olist_names[] = { ! 210: "olist", ! 211: "oerr", ! 212: "ounit", ! 213: "ofnm", ! 214: "ofnmlen", ! 215: "osta", ! 216: "oacc", ! 217: "ofm", ! 218: "orl", ! 219: "oblnk" ! 220: }; ! 221: LOCAL char *cllist_names[] = { ! 222: "cllist", ! 223: "cerr", ! 224: "cunit", ! 225: "csta" ! 226: }; ! 227: LOCAL char *alist_names[] = { ! 228: "alist", ! 229: "aerr", ! 230: "aunit" ! 231: }; ! 232: LOCAL char *inlist_names[] = { ! 233: "inlist", ! 234: "inerr", ! 235: "inunit", ! 236: "infile", ! 237: "infilen", ! 238: "inex", ! 239: "inopen", ! 240: "innum", ! 241: "innamed", ! 242: "inname", ! 243: "innamlen", ! 244: "inacc", ! 245: "inacclen", ! 246: "inseq", ! 247: "inseqlen", ! 248: "indir", ! 249: "indirlen", ! 250: "infmt", ! 251: "infmtlen", ! 252: "inform", ! 253: "informlen", ! 254: "inunf", ! 255: "inunflen", ! 256: "inrecl", ! 257: "innrec", ! 258: "inblank", ! 259: "inblanklen" ! 260: }; ! 261: ! 262: LOCAL char **io_fields; ! 263: ! 264: #define zork(n,t) n, sizeof(n)/sizeof(char *) - 1, t ! 265: ! 266: LOCAL io_setup io_stuff[] = { ! 267: zork(cilist_names, TYCILIST), /* external read/write */ ! 268: zork(inlist_names, TYINLIST), /* inquire */ ! 269: zork(olist_names, TYOLIST), /* open */ ! 270: zork(cllist_names, TYCLLIST), /* close */ ! 271: zork(alist_names, TYALIST), /* rewind */ ! 272: zork(alist_names, TYALIST), /* backspace */ ! 273: zork(alist_names, TYALIST), /* endfile */ ! 274: zork(icilist_names,TYICILIST), /* internal read */ ! 275: zork(icilist_names,TYICILIST) /* internal write */ ! 276: }; ! 277: ! 278: #undef zork ! 279: ! 280: ! 281: fmtstmt(lp) ! 282: register struct Labelblock *lp; ! 283: { ! 284: if(lp == NULL) ! 285: { ! 286: execerr("unlabeled format statement" , CNULL); ! 287: return(-1); ! 288: } ! 289: if(lp->labtype == LABUNKNOWN) ! 290: { ! 291: lp->labtype = LABFORMAT; ! 292: lp->labelno = newlabel(); ! 293: } ! 294: else if(lp->labtype != LABFORMAT) ! 295: { ! 296: execerr("bad format number", CNULL); ! 297: return(-1); ! 298: } ! 299: return(lp->labelno); ! 300: } ! 301: ! 302: ! 303: setfmt(lp) ! 304: struct Labelblock *lp; ! 305: { ! 306: int n; ! 307: char *s0, *lexline(); ! 308: register char *s, *se, *t; ! 309: register k; ! 310: ! 311: s0 = s = lexline(&n); ! 312: se = t = s + n; ! 313: ! 314: /* warn of trivial errors, e.g. " 11 CONTINUE" (one too few spaces) */ ! 315: /* following FORMAT... */ ! 316: ! 317: if (n <= 0) ! 318: warn("No (...) after FORMAT"); ! 319: else if (*s != '(') ! 320: warni("%c rather than ( after FORMAT", *s); ! 321: else if (se[-1] != ')') { ! 322: *se = 0; ! 323: while(--t > s && *t != ')') ; ! 324: if (t <= s) ! 325: warn("No ) at end of FORMAT statement"); ! 326: else if (se - t > 30) ! 327: warn1("Extraneous text at end of FORMAT: ...%s", se-12); ! 328: else ! 329: warn1("Extraneous text at end of FORMAT: %s", t+1); ! 330: t = se; ! 331: } ! 332: ! 333: /* fix MYQUOTES (\002's) and \\'s */ ! 334: ! 335: while(s < se) ! 336: switch(*s++) { ! 337: case 2: ! 338: t += 3; break; ! 339: case '"': ! 340: case '\\': ! 341: t++; break; ! 342: } ! 343: s = s0; ! 344: if (lp) { ! 345: lp->fmtstring = t = mem((int)(t - s + 1), 0); ! 346: while(s < se) ! 347: switch(k = *s++) { ! 348: case 2: ! 349: t[0] = '\\'; ! 350: t[1] = '0'; ! 351: t[2] = '0'; ! 352: t[3] = '2'; ! 353: t += 4; ! 354: break; ! 355: case '"': ! 356: case '\\': ! 357: *t++ = '\\'; ! 358: /* no break */ ! 359: default: ! 360: *t++ = k; ! 361: } ! 362: *t = 0; ! 363: } ! 364: flline(); ! 365: } ! 366: ! 367: ! 368: ! 369: startioctl() ! 370: { ! 371: register int i; ! 372: ! 373: inioctl = YES; ! 374: nioctl = 0; ! 375: ioformatted = UNFORMATTED; ! 376: for(i = 1 ; i<=NIOS ; ++i) ! 377: V(i) = NULL; ! 378: } ! 379: ! 380: static long ! 381: newiolabel() { ! 382: long rv; ! 383: rv = ++lastiolabno; ! 384: skiplabel = mklabel(rv); ! 385: skiplabel->labdefined = 1; ! 386: return rv; ! 387: } ! 388: ! 389: ! 390: endioctl() ! 391: { ! 392: int i; ! 393: expptr p; ! 394: struct io_setup *ios; ! 395: ! 396: inioctl = NO; ! 397: ! 398: /* set up for error recovery */ ! 399: ! 400: ioerrlab = ioendlab = skiplab = jumplab = 0; ! 401: ! 402: if(p = V(IOSEND)) ! 403: if(ISICON(p)) ! 404: execlab(ioendlab = p->constblock.Const.ci); ! 405: else ! 406: err("bad end= clause"); ! 407: ! 408: if(p = V(IOSERR)) ! 409: if(ISICON(p)) ! 410: execlab(ioerrlab = p->constblock.Const.ci); ! 411: else ! 412: err("bad err= clause"); ! 413: ! 414: if(IOSTP) ! 415: if(IOSTP->tag!=TADDR || ! ISINT(IOSTP->addrblock.vtype) ) ! 416: { ! 417: err("iostat must be an integer variable"); ! 418: frexpr(IOSTP); ! 419: IOSTP = NULL; ! 420: } ! 421: ! 422: if(iostmt == IOREAD) ! 423: { ! 424: if(IOSTP) ! 425: { ! 426: if(ioerrlab && ioendlab && ioerrlab==ioendlab) ! 427: jumplab = ioerrlab; ! 428: else ! 429: skiplab = jumplab = newiolabel(); ! 430: } ! 431: else { ! 432: if(ioerrlab && ioendlab && ioerrlab!=ioendlab) ! 433: { ! 434: IOSTP = (expptr) mktmp(TYINT, ENULL); ! 435: skiplab = jumplab = newiolabel(); ! 436: } ! 437: else ! 438: jumplab = (ioerrlab ? ioerrlab : ioendlab); ! 439: } ! 440: } ! 441: else if(iostmt == IOWRITE) ! 442: { ! 443: if(IOSTP && !ioerrlab) ! 444: skiplab = jumplab = newiolabel(); ! 445: else ! 446: jumplab = ioerrlab; ! 447: } ! 448: else ! 449: jumplab = ioerrlab; ! 450: ! 451: endbit = IOSTP!=NULL || ioendlab!=0; /* for use in startrw() */ ! 452: errbit = IOSTP!=NULL || ioerrlab!=0; ! 453: if (jumplab && !IOSTP) ! 454: IOSTP = (expptr) mktmp(TYINT, ENULL); ! 455: ! 456: if(iostmt!=IOREAD && iostmt!=IOWRITE) ! 457: { ! 458: ios = io_stuff + iostmt; ! 459: io_fields = ios->fields; ! 460: ioblkp = io_structs[iostmt]; ! 461: if(ioblkp == NULL) ! 462: io_structs[iostmt] = ioblkp = ! 463: autovar(1, ios->type, ENULL, ""); ! 464: ioset(TYIOINT, XERR, ICON(errbit)); ! 465: } ! 466: ! 467: switch(iostmt) ! 468: { ! 469: case IOOPEN: ! 470: dofopen(); ! 471: break; ! 472: ! 473: case IOCLOSE: ! 474: dofclose(); ! 475: break; ! 476: ! 477: case IOINQUIRE: ! 478: dofinquire(); ! 479: break; ! 480: ! 481: case IOBACKSPACE: ! 482: dofmove("f_back"); ! 483: break; ! 484: ! 485: case IOREWIND: ! 486: dofmove("f_rew"); ! 487: break; ! 488: ! 489: case IOENDFILE: ! 490: dofmove("f_end"); ! 491: break; ! 492: ! 493: case IOREAD: ! 494: case IOWRITE: ! 495: startrw(); ! 496: break; ! 497: ! 498: default: ! 499: fatali("impossible iostmt %d", iostmt); ! 500: } ! 501: for(i = 1 ; i<=NIOS ; ++i) ! 502: if(i!=IOSIOSTAT && V(i)!=NULL) ! 503: frexpr(V(i)); ! 504: } ! 505: ! 506: ! 507: ! 508: iocname() ! 509: { ! 510: register int i; ! 511: int found, mask; ! 512: ! 513: found = 0; ! 514: mask = M(iostmt); ! 515: for(i = 1 ; i <= NIOS ; ++i) ! 516: if(!strcmp(ioc[i].iocname, token)) ! 517: if(ioc[i].iotype & mask) ! 518: return(i); ! 519: else { ! 520: found = i; ! 521: break; ! 522: } ! 523: if(found) { ! 524: if (iostmt == IOOPEN && !strcmp(ioc[i].iocname, "name")) { ! 525: NOEXT("open with \"name=\" treated as \"file=\""); ! 526: for(i = 1; strcmp(ioc[i].iocname, "file"); i++); ! 527: return i; ! 528: } ! 529: errstr("invalid control %s for statement", ioc[found].iocname); ! 530: } ! 531: else ! 532: errstr("unknown iocontrol %s", token); ! 533: return(IOSBAD); ! 534: } ! 535: ! 536: ! 537: ioclause(n, p) ! 538: register int n; ! 539: register expptr p; ! 540: { ! 541: struct Ioclist *iocp; ! 542: ! 543: ++nioctl; ! 544: if(n == IOSBAD) ! 545: return; ! 546: if(n == IOSPOSITIONAL) ! 547: { ! 548: n = nioctl; ! 549: if (n == IOSFMT) { ! 550: if (iostmt == IOOPEN) { ! 551: n = IOSFILE; ! 552: NOEXT("file= specifier omitted from open"); ! 553: } ! 554: else if (iostmt < IOREAD) ! 555: goto illegal; ! 556: } ! 557: else if(n > IOSFMT) ! 558: { ! 559: illegal: ! 560: err("illegal positional iocontrol"); ! 561: return; ! 562: } ! 563: } ! 564: else if (n == IOSNML) ! 565: n = IOSFMT; ! 566: ! 567: if(p == NULL) ! 568: { ! 569: if(n == IOSUNIT) ! 570: p = (expptr) (iostmt==IOREAD ? IOSTDIN : IOSTDOUT); ! 571: else if(n != IOSFMT) ! 572: { ! 573: err("illegal * iocontrol"); ! 574: return; ! 575: } ! 576: } ! 577: if(n == IOSFMT) ! 578: ioformatted = (p==NULL ? LISTDIRECTED : FORMATTED); ! 579: ! 580: iocp = & ioc[n]; ! 581: if(iocp->iocval == NULL) ! 582: { ! 583: if(n!=IOSFMT && ( n!=IOSUNIT || (p && p->headblock.vtype!=TYCHAR) ) ) ! 584: p = fixtype(p); ! 585: else if (p && p->tag == TPRIM ! 586: && p->primblock.namep->vclass == CLUNKNOWN) { ! 587: /* kludge made necessary by attempt to infer types ! 588: * for untyped external parameters: given an error ! 589: * in calling sequences, an integer argument might ! 590: * tentatively be assumed TYCHAR; this would otherwise ! 591: * be corrected too late in startrw after startrw ! 592: * had decided this to be an internal file. ! 593: */ ! 594: vardcl(p->primblock.namep); ! 595: p->primblock.vtype = p->primblock.namep->vtype; ! 596: } ! 597: iocp->iocval = p; ! 598: } ! 599: else ! 600: errstr("iocontrol %s repeated", iocp->iocname); ! 601: } ! 602: ! 603: /* io list item */ ! 604: ! 605: doio(list) ! 606: chainp list; ! 607: { ! 608: expptr call0(); ! 609: ! 610: if(ioformatted == NAMEDIRECTED) ! 611: { ! 612: if(list) ! 613: err("no I/O list allowed in NAMELIST read/write"); ! 614: } ! 615: else ! 616: { ! 617: doiolist(list); ! 618: ioroutine[0] = 'e'; ! 619: if (skiplab || ioroutine[4] == 'l') ! 620: jumplab = 0; ! 621: putiocall( call0(TYINT, ioroutine) ); ! 622: } ! 623: } ! 624: ! 625: ! 626: ! 627: ! 628: ! 629: LOCAL void ! 630: doiolist(p0) ! 631: chainp p0; ! 632: { ! 633: chainp p; ! 634: register tagptr q; ! 635: register expptr qe; ! 636: register Namep qn; ! 637: Addrp tp, mkscalar(); ! 638: int range; ! 639: extern char *ohalign; ! 640: ! 641: for (p = p0 ; p ; p = p->nextp) ! 642: { ! 643: q = (tagptr)p->datap; ! 644: if(q->tag == TIMPLDO) ! 645: { ! 646: exdo(range=newlabel(), (Namep)0, ! 647: q->impldoblock.impdospec); ! 648: doiolist(q->impldoblock.datalist); ! 649: enddo(range); ! 650: free( (charptr) q); ! 651: } ! 652: else { ! 653: if(q->tag==TPRIM && q->primblock.argsp==NULL ! 654: && q->primblock.namep->vdim!=NULL) ! 655: { ! 656: vardcl(qn = q->primblock.namep); ! 657: if(qn->vdim->nelt) { ! 658: putio( fixtype(cpexpr(qn->vdim->nelt)), ! 659: (expptr)mkscalar(qn) ); ! 660: qn->vlastdim = 0; ! 661: } ! 662: else ! 663: err("attempt to i/o array of unknown size"); ! 664: } ! 665: else if(q->tag==TPRIM && q->primblock.argsp==NULL && ! 666: (qe = (expptr) memversion(q->primblock.namep)) ) ! 667: putio(ICON(1),qe); ! 668: else if (ISCONST(q) && q->constblock.vtype == TYCHAR) { ! 669: halign = 0; ! 670: putio(ICON(1), qe = fixtype(cpexpr(q))); ! 671: halign = ohalign; ! 672: } ! 673: else if(((qe = fixtype(cpexpr(q)))->tag==TADDR && ! 674: (qe->addrblock.uname_tag != UNAM_CONST || ! 675: !ISCOMPLEX(qe -> addrblock.vtype))) || ! 676: (qe -> tag == TCONST && !ISCOMPLEX(qe -> ! 677: headblock.vtype))) { ! 678: if (qe -> tag == TCONST) ! 679: qe = (expptr) putconst((Constp)qe); ! 680: putio(ICON(1), qe); ! 681: } ! 682: else if(qe->headblock.vtype != TYERROR) ! 683: { ! 684: if(iostmt == IOWRITE) ! 685: { ! 686: ftnint lencat(); ! 687: expptr qvl; ! 688: qvl = NULL; ! 689: if( ISCHAR(qe) ) ! 690: { ! 691: qvl = (expptr) ! 692: cpexpr(qe->headblock.vleng); ! 693: tp = mktmp(qe->headblock.vtype, ! 694: ICON(lencat(qe))); ! 695: } ! 696: else ! 697: tp = mktmp(qe->headblock.vtype, ! 698: qe->headblock.vleng); ! 699: puteq( cpexpr((expptr)tp), qe); ! 700: if(qvl) /* put right length on block */ ! 701: { ! 702: frexpr(tp->vleng); ! 703: tp->vleng = qvl; ! 704: } ! 705: putio(ICON(1), (expptr)tp); ! 706: } ! 707: else ! 708: err("non-left side in READ list"); ! 709: } ! 710: frexpr(q); ! 711: } ! 712: } ! 713: frchain( &p0 ); ! 714: } ! 715: ! 716: int iocalladdr = TYADDR; /* for fixing TYADDR in saveargtypes */ ! 717: int typeconv[TYERROR+1] = { ! 718: #ifdef TYQUAD ! 719: 0, 1, 11, 2, 3, 14, 4, 5, 6, 7, 12, 13, 8, 9, 10, 15 ! 720: #else ! 721: 0, 1, 11, 2, 3, 4, 5, 6, 7, 12, 13, 8, 9, 10, 14 ! 722: #endif ! 723: }; ! 724: ! 725: LOCAL void ! 726: putio(nelt, addr) ! 727: expptr nelt; ! 728: register expptr addr; ! 729: { ! 730: int type; ! 731: register expptr q; ! 732: register Addrp c = 0; ! 733: ! 734: type = addr->headblock.vtype; ! 735: if(ioformatted!=LISTDIRECTED && ISCOMPLEX(type) ) ! 736: { ! 737: nelt = mkexpr(OPSTAR, ICON(2), nelt); ! 738: type -= (TYCOMPLEX-TYREAL); ! 739: } ! 740: ! 741: /* pass a length with every item. for noncharacter data, fake one */ ! 742: if(type != TYCHAR) ! 743: { ! 744: ! 745: if( ISCONST(addr) ) ! 746: addr = (expptr) putconst((Constp)addr); ! 747: c = ALLOC(Addrblock); ! 748: c->tag = TADDR; ! 749: c->vtype = TYLENG; ! 750: c->vstg = STGAUTO; ! 751: c->ntempelt = 1; ! 752: c->isarray = 1; ! 753: c->memoffset = ICON(0); ! 754: c->uname_tag = UNAM_IDENT; ! 755: c->charleng = 1; ! 756: sprintf(c->user.ident, "(ftnlen)sizeof(%s)", typename[type]); ! 757: addr = mkexpr(OPCHARCAST, addr, ENULL); ! 758: } ! 759: ! 760: nelt = fixtype( mkconv(tyioint,nelt) ); ! 761: if(ioformatted == LISTDIRECTED) { ! 762: expptr mc = mkconv(tyioint, ICON(typeconv[type])); ! 763: q = c ? call4(TYINT, "do_lio", mc, nelt, addr, (expptr)c) ! 764: : call3(TYINT, "do_lio", mc, nelt, addr); ! 765: } ! 766: else { ! 767: char *s = ioformatted==FORMATTED ? "do_fio" : "do_uio"; ! 768: q = c ? call3(TYINT, s, nelt, addr, (expptr)c) ! 769: : call2(TYINT, s, nelt, addr); ! 770: } ! 771: iocalladdr = TYCHAR; ! 772: putiocall(q); ! 773: iocalladdr = TYADDR; ! 774: } ! 775: ! 776: ! 777: ! 778: ! 779: endio() ! 780: { ! 781: extern void p1_label(); ! 782: ! 783: if(skiplab) ! 784: { ! 785: if (ioformatted != NAMEDIRECTED) ! 786: p1_label((long)(skiplabel - labeltab)); ! 787: if(ioendlab) { ! 788: exif( mkexpr(OPLT, cpexpr(IOSTP), ICON(0))); ! 789: exgoto(execlab(ioendlab)); ! 790: exendif(); ! 791: } ! 792: if(ioerrlab) { ! 793: exif( mkexpr(iostmt==IOREAD||iostmt==IOWRITE ! 794: ? OPGT : OPNE, ! 795: cpexpr(IOSTP), ICON(0))); ! 796: exgoto(execlab(ioerrlab)); ! 797: exendif(); ! 798: } ! 799: } ! 800: ! 801: if(IOSTP) ! 802: frexpr(IOSTP); ! 803: } ! 804: ! 805: ! 806: ! 807: LOCAL void ! 808: putiocall(q) ! 809: register expptr q; ! 810: { ! 811: int tyintsave; ! 812: ! 813: tyintsave = tyint; ! 814: tyint = tyioint; /* for -I2 and -i2 */ ! 815: ! 816: if(IOSTP) ! 817: { ! 818: q->headblock.vtype = TYINT; ! 819: q = fixexpr((Exprp)mkexpr(OPASSIGN, cpexpr(IOSTP), q)); ! 820: } ! 821: putexpr(q); ! 822: if(jumplab) { ! 823: exif(mkexpr(OPNE, cpexpr(IOSTP), ICON(0))); ! 824: exgoto(execlab(jumplab)); ! 825: exendif(); ! 826: } ! 827: tyint = tyintsave; ! 828: } ! 829: ! 830: void ! 831: fmtname(np, q) ! 832: Namep np; ! 833: register Addrp q; ! 834: { ! 835: register int k; ! 836: register char *s, *t; ! 837: extern chainp assigned_fmts; ! 838: ! 839: if (!np->vfmt_asg) { ! 840: np->vfmt_asg = 1; ! 841: assigned_fmts = mkchain((char *)np, assigned_fmts); ! 842: } ! 843: k = strlen(s = np->fvarname); ! 844: if (k < IDENT_LEN - 4) { ! 845: q->uname_tag = UNAM_IDENT; ! 846: t = q->user.ident; ! 847: } ! 848: else { ! 849: q->uname_tag = UNAM_CHARP; ! 850: q->user.Charp = t = mem(k + 5,0); ! 851: } ! 852: sprintf(t, "%s_fmt", s); ! 853: } ! 854: ! 855: LOCAL Addrp asg_addr(p) ! 856: union Expression *p; ! 857: { ! 858: register Addrp q; ! 859: ! 860: if (p->tag != TPRIM) ! 861: badtag("asg_addr", p->tag); ! 862: q = ALLOC(Addrblock); ! 863: q->tag = TADDR; ! 864: q->vtype = TYCHAR; ! 865: q->vstg = STGAUTO; ! 866: q->ntempelt = 1; ! 867: q->isarray = 0; ! 868: q->memoffset = ICON(0); ! 869: fmtname(p->primblock.namep, q); ! 870: return q; ! 871: } ! 872: ! 873: startrw() ! 874: { ! 875: register expptr p; ! 876: register Namep np; ! 877: register Addrp unitp, fmtp, recp; ! 878: register expptr nump; ! 879: Addrp mkscalar(); ! 880: expptr mkaddcon(); ! 881: int iostmt1; ! 882: flag intfile, sequential, ok, varfmt; ! 883: struct io_setup *ios; ! 884: ! 885: /* First look at all the parameters and determine what is to be done */ ! 886: ! 887: ok = YES; ! 888: statstruct = YES; ! 889: ! 890: intfile = NO; ! 891: if(p = V(IOSUNIT)) ! 892: { ! 893: if( ISINT(p->headblock.vtype) ) { ! 894: int_unit: ! 895: unitp = (Addrp) cpexpr(p); ! 896: } ! 897: else if(p->headblock.vtype == TYCHAR) ! 898: { ! 899: if (nioctl == 1 && iostmt == IOREAD) { ! 900: /* kludge to recognize READ(format expr) */ ! 901: V(IOSFMT) = p; ! 902: V(IOSUNIT) = p = (expptr) IOSTDIN; ! 903: ioformatted = FORMATTED; ! 904: goto int_unit; ! 905: } ! 906: intfile = YES; ! 907: if(p->tag==TPRIM && p->primblock.argsp==NULL && ! 908: (np = p->primblock.namep)->vdim!=NULL) ! 909: { ! 910: vardcl(np); ! 911: if(nump = np->vdim->nelt) ! 912: { ! 913: nump = fixtype(cpexpr(nump)); ! 914: if( ! ISCONST(nump) ) { ! 915: statstruct = NO; ! 916: np->vlastdim = 0; ! 917: } ! 918: } ! 919: else ! 920: { ! 921: err("attempt to use internal unit array of unknown size"); ! 922: ok = NO; ! 923: nump = ICON(1); ! 924: } ! 925: unitp = mkscalar(np); ! 926: } ! 927: else { ! 928: nump = ICON(1); ! 929: unitp = (Addrp /*pjw */) fixtype(cpexpr(p)); ! 930: } ! 931: if(! isstatic((expptr)unitp) ) ! 932: statstruct = NO; ! 933: } ! 934: else { ! 935: err("unit specifier not of type integer or character"); ! 936: ok = NO; ! 937: } ! 938: } ! 939: else ! 940: { ! 941: err("bad unit specifier"); ! 942: ok = NO; ! 943: } ! 944: ! 945: sequential = YES; ! 946: if(p = V(IOSREC)) ! 947: if( ISINT(p->headblock.vtype) ) ! 948: { ! 949: recp = (Addrp) cpexpr(p); ! 950: sequential = NO; ! 951: } ! 952: else { ! 953: err("bad REC= clause"); ! 954: ok = NO; ! 955: } ! 956: else ! 957: recp = NULL; ! 958: ! 959: ! 960: varfmt = YES; ! 961: fmtp = NULL; ! 962: if(p = V(IOSFMT)) ! 963: { ! 964: if(p->tag==TPRIM && p->primblock.argsp==NULL) ! 965: { ! 966: np = p->primblock.namep; ! 967: if(np->vclass == CLNAMELIST) ! 968: { ! 969: ioformatted = NAMEDIRECTED; ! 970: fmtp = (Addrp) fixtype(p); ! 971: V(IOSFMT) = (expptr)fmtp; ! 972: if (skiplab) ! 973: jumplab = 0; ! 974: goto endfmt; ! 975: } ! 976: vardcl(np); ! 977: if(np->vdim) ! 978: { ! 979: if( ! ONEOF(np->vstg, MSKSTATIC) ) ! 980: statstruct = NO; ! 981: fmtp = mkscalar(np); ! 982: goto endfmt; ! 983: } ! 984: if( ISINT(np->vtype) ) /* ASSIGNed label */ ! 985: { ! 986: statstruct = NO; ! 987: varfmt = YES; ! 988: fmtp = asg_addr(p); ! 989: goto endfmt; ! 990: } ! 991: } ! 992: p = V(IOSFMT) = fixtype(p); ! 993: if(p->headblock.vtype == TYCHAR ! 994: /* Since we allow write(6,n) */ ! 995: /* we may as well allow write(6,n(2)) */ ! 996: || p->tag == TADDR && ISINT(p->addrblock.vtype)) ! 997: { ! 998: if( ! isstatic(p) ) ! 999: statstruct = NO; ! 1000: fmtp = (Addrp) cpexpr(p); ! 1001: } ! 1002: else if( ISICON(p) ) ! 1003: { ! 1004: struct Labelblock *lp; ! 1005: lp = mklabel(p->constblock.Const.ci); ! 1006: if (fmtstmt(lp) > 0) ! 1007: { ! 1008: fmtp = (Addrp)mkaddcon(lp->stateno); ! 1009: /* lp->stateno for names fmt_nnn */ ! 1010: lp->fmtlabused = 1; ! 1011: varfmt = NO; ! 1012: } ! 1013: else ! 1014: ioformatted = UNFORMATTED; ! 1015: } ! 1016: else { ! 1017: err("bad format descriptor"); ! 1018: ioformatted = UNFORMATTED; ! 1019: ok = NO; ! 1020: } ! 1021: } ! 1022: else ! 1023: fmtp = NULL; ! 1024: ! 1025: endfmt: ! 1026: if(intfile) { ! 1027: if (ioformatted==UNFORMATTED) { ! 1028: err("unformatted internal I/O not allowed"); ! 1029: ok = NO; ! 1030: } ! 1031: if (recp) { ! 1032: err("direct internal I/O not allowed"); ! 1033: ok = NO; ! 1034: } ! 1035: } ! 1036: if(!sequential && ioformatted==LISTDIRECTED) ! 1037: { ! 1038: err("direct list-directed I/O not allowed"); ! 1039: ok = NO; ! 1040: } ! 1041: if(!sequential && ioformatted==NAMEDIRECTED) ! 1042: { ! 1043: err("direct namelist I/O not allowed"); ! 1044: ok = NO; ! 1045: } ! 1046: ! 1047: if( ! ok ) { ! 1048: statstruct = NO; ! 1049: return; ! 1050: } ! 1051: ! 1052: /* ! 1053: Now put out the I/O structure, statically if all the clauses ! 1054: are constants, dynamically otherwise ! 1055: */ ! 1056: ! 1057: if (intfile) { ! 1058: ios = io_stuff + iostmt; ! 1059: iostmt1 = IOREAD; ! 1060: } ! 1061: else { ! 1062: ios = io_stuff; ! 1063: iostmt1 = 0; ! 1064: } ! 1065: io_fields = ios->fields; ! 1066: if(statstruct) ! 1067: { ! 1068: ioblkp = ALLOC(Addrblock); ! 1069: ioblkp->tag = TADDR; ! 1070: ioblkp->vtype = ios->type; ! 1071: ioblkp->vclass = CLVAR; ! 1072: ioblkp->vstg = STGINIT; ! 1073: ioblkp->memno = ++lastvarno; ! 1074: ioblkp->memoffset = ICON(0); ! 1075: ioblkp -> uname_tag = UNAM_IDENT; ! 1076: new_iob_data(ios, ! 1077: temp_name("io_", lastvarno, ioblkp->user.ident)); } ! 1078: else if(!(ioblkp = io_structs[iostmt1])) ! 1079: io_structs[iostmt1] = ioblkp = ! 1080: autovar(1, ios->type, ENULL, ""); ! 1081: ! 1082: ioset(TYIOINT, XERR, ICON(errbit)); ! 1083: if(iostmt == IOREAD) ! 1084: ioset(TYIOINT, (intfile ? XIEND : XEND), ICON(endbit) ); ! 1085: ! 1086: if(intfile) ! 1087: { ! 1088: ioset(TYIOINT, XIRNUM, nump); ! 1089: ioset(TYIOINT, XIRLEN, cpexpr(unitp->vleng) ); ! 1090: ioseta(XIUNIT, unitp); ! 1091: } ! 1092: else ! 1093: ioset(TYIOINT, XUNIT, (expptr) unitp); ! 1094: ! 1095: if(recp) ! 1096: ioset(TYIOINT, /* intfile ? XIREC : */ XREC, (expptr) recp); ! 1097: ! 1098: if(varfmt) ! 1099: ioseta( intfile ? XIFMT : XFMT , fmtp); ! 1100: else ! 1101: ioset(TYADDR, intfile ? XIFMT : XFMT, (expptr) fmtp); ! 1102: ! 1103: ioroutine[0] = 's'; ! 1104: ioroutine[1] = '_'; ! 1105: ioroutine[2] = iostmt==IOREAD ? 'r' : 'w'; ! 1106: ioroutine[3] = "ds"[sequential]; ! 1107: ioroutine[4] = "ufln"[ioformatted]; ! 1108: ioroutine[5] = "ei"[intfile]; ! 1109: ioroutine[6] = '\0'; ! 1110: ! 1111: putiocall( call1(TYINT, ioroutine, cpexpr((expptr)ioblkp) )); ! 1112: ! 1113: if(statstruct) ! 1114: { ! 1115: frexpr((expptr)ioblkp); ! 1116: statstruct = NO; ! 1117: ioblkp = 0; /* unnecessary */ ! 1118: } ! 1119: } ! 1120: ! 1121: ! 1122: ! 1123: LOCAL void ! 1124: dofopen() ! 1125: { ! 1126: register expptr p; ! 1127: ! 1128: if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) ) ! 1129: ioset(TYIOINT, XUNIT, cpexpr(p) ); ! 1130: else ! 1131: err("bad unit in open"); ! 1132: if( (p = V(IOSFILE)) ) ! 1133: if(p->headblock.vtype == TYCHAR) ! 1134: ioset(TYIOINT, XFNAMELEN, cpexpr(p->headblock.vleng) ); ! 1135: else ! 1136: err("bad file in open"); ! 1137: ! 1138: iosetc(XFNAME, p); ! 1139: ! 1140: if(p = V(IOSRECL)) ! 1141: if( ISINT(p->headblock.vtype) ) ! 1142: ioset(TYIOINT, XRECLEN, cpexpr(p) ); ! 1143: else ! 1144: err("bad recl"); ! 1145: else ! 1146: ioset(TYIOINT, XRECLEN, ICON(0) ); ! 1147: ! 1148: iosetc(XSTATUS, V(IOSSTATUS)); ! 1149: iosetc(XACCESS, V(IOSACCESS)); ! 1150: iosetc(XFORMATTED, V(IOSFORM)); ! 1151: iosetc(XBLANK, V(IOSBLANK)); ! 1152: ! 1153: putiocall( call1(TYINT, "f_open", cpexpr((expptr)ioblkp) )); ! 1154: } ! 1155: ! 1156: ! 1157: LOCAL void ! 1158: dofclose() ! 1159: { ! 1160: register expptr p; ! 1161: ! 1162: if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) ) ! 1163: { ! 1164: ioset(TYIOINT, XUNIT, cpexpr(p) ); ! 1165: iosetc(XCLSTATUS, V(IOSSTATUS)); ! 1166: putiocall( call1(TYINT, "f_clos", cpexpr((expptr)ioblkp)) ); ! 1167: } ! 1168: else ! 1169: err("bad unit in close statement"); ! 1170: } ! 1171: ! 1172: ! 1173: LOCAL void ! 1174: dofinquire() ! 1175: { ! 1176: register expptr p; ! 1177: if(p = V(IOSUNIT)) ! 1178: { ! 1179: if( V(IOSFILE) ) ! 1180: err("inquire by unit or by file, not both"); ! 1181: ioset(TYIOINT, XUNIT, cpexpr(p) ); ! 1182: } ! 1183: else if( ! V(IOSFILE) ) ! 1184: err("must inquire by unit or by file"); ! 1185: iosetlc(IOSFILE, XFILE, XFILELEN); ! 1186: iosetip(IOSEXISTS, XEXISTS); ! 1187: iosetip(IOSOPENED, XOPEN); ! 1188: iosetip(IOSNUMBER, XNUMBER); ! 1189: iosetip(IOSNAMED, XNAMED); ! 1190: iosetlc(IOSNAME, XNAME, XNAMELEN); ! 1191: iosetlc(IOSACCESS, XQACCESS, XQACCLEN); ! 1192: iosetlc(IOSSEQUENTIAL, XSEQ, XSEQLEN); ! 1193: iosetlc(IOSDIRECT, XDIRECT, XDIRLEN); ! 1194: iosetlc(IOSFORM, XFORM, XFORMLEN); ! 1195: iosetlc(IOSFORMATTED, XFMTED, XFMTEDLEN); ! 1196: iosetlc(IOSUNFORMATTED, XUNFMT, XUNFMTLEN); ! 1197: iosetip(IOSRECL, XQRECL); ! 1198: iosetip(IOSNEXTREC, XNEXTREC); ! 1199: iosetlc(IOSBLANK, XQBLANK, XQBLANKLEN); ! 1200: ! 1201: putiocall( call1(TYINT, "f_inqu", cpexpr((expptr)ioblkp) )); ! 1202: } ! 1203: ! 1204: ! 1205: ! 1206: LOCAL void ! 1207: dofmove(subname) ! 1208: char *subname; ! 1209: { ! 1210: register expptr p; ! 1211: ! 1212: if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) ) ! 1213: { ! 1214: ioset(TYIOINT, XUNIT, cpexpr(p) ); ! 1215: putiocall( call1(TYINT, subname, cpexpr((expptr)ioblkp) )); ! 1216: } ! 1217: else ! 1218: err("bad unit in I/O motion statement"); ! 1219: } ! 1220: ! 1221: static int ioset_assign = OPASSIGN; ! 1222: ! 1223: LOCAL void ! 1224: ioset(type, offset, p) ! 1225: int type, offset; ! 1226: register expptr p; ! 1227: { ! 1228: offset /= SZLONG; ! 1229: if(statstruct && ISCONST(p)) { ! 1230: register char *s; ! 1231: switch(type) { ! 1232: case TYADDR: /* stmt label */ ! 1233: s = "fmt_"; ! 1234: break; ! 1235: case TYIOINT: ! 1236: s = ""; ! 1237: break; ! 1238: default: ! 1239: badtype("ioset", type); ! 1240: } ! 1241: iob_list->fields[offset] = ! 1242: string_num(s, p->constblock.Const.ci); ! 1243: frexpr(p); ! 1244: } ! 1245: else { ! 1246: register Addrp q; ! 1247: ! 1248: q = ALLOC(Addrblock); ! 1249: q->tag = TADDR; ! 1250: q->vtype = type; ! 1251: q->vstg = STGAUTO; ! 1252: q->ntempelt = 1; ! 1253: q->isarray = 0; ! 1254: q->memoffset = ICON(0); ! 1255: q->uname_tag = UNAM_IDENT; ! 1256: sprintf(q->user.ident, "%s.%s", ! 1257: statstruct ? iob_list->name : ioblkp->user.ident, ! 1258: io_fields[offset + 1]); ! 1259: if (type == TYADDR && p->tag == TCONST ! 1260: && p->constblock.vtype == TYADDR) { ! 1261: /* kludge */ ! 1262: register Addrp p1; ! 1263: p1 = ALLOC(Addrblock); ! 1264: p1->tag = TADDR; ! 1265: p1->vtype = type; ! 1266: p1->vstg = STGAUTO; /* wrong, but who cares? */ ! 1267: p1->ntempelt = 1; ! 1268: p1->isarray = 0; ! 1269: p1->memoffset = ICON(0); ! 1270: p1->uname_tag = UNAM_IDENT; ! 1271: sprintf(p1->user.ident, "fmt_%ld", ! 1272: p->constblock.Const.ci); ! 1273: frexpr(p); ! 1274: p = (expptr)p1; ! 1275: } ! 1276: if (type == TYADDR && p->headblock.vtype == TYCHAR) ! 1277: q->vtype = TYCHAR; ! 1278: putexpr(mkexpr(ioset_assign, (expptr)q, p)); ! 1279: } ! 1280: } ! 1281: ! 1282: ! 1283: ! 1284: ! 1285: LOCAL void ! 1286: iosetc(offset, p) ! 1287: int offset; ! 1288: register expptr p; ! 1289: { ! 1290: extern Addrp putchop(); ! 1291: ! 1292: if(p == NULL) ! 1293: ioset(TYADDR, offset, ICON(0) ); ! 1294: else if(p->headblock.vtype == TYCHAR) { ! 1295: p = putx(fixtype((expptr)putchop(cpexpr(p)))); ! 1296: ioset(TYADDR, offset, addrof(p)); ! 1297: } ! 1298: else ! 1299: err("non-character control clause"); ! 1300: } ! 1301: ! 1302: ! 1303: ! 1304: LOCAL void ! 1305: ioseta(offset, p) ! 1306: int offset; ! 1307: register Addrp p; ! 1308: { ! 1309: char *s, *s1; ! 1310: static char who[] = "ioseta"; ! 1311: expptr e, mo; ! 1312: Namep np; ! 1313: ftnint ci; ! 1314: int k; ! 1315: char buf[24], buf1[24]; ! 1316: Extsym *comm; ! 1317: extern int usedefsforcommon; ! 1318: ! 1319: if(statstruct) ! 1320: { ! 1321: if (!p) ! 1322: return; ! 1323: if (p->tag != TADDR) ! 1324: badtag(who, p->tag); ! 1325: offset /= SZLONG; ! 1326: switch(p->uname_tag) { ! 1327: case UNAM_NAME: ! 1328: mo = p->memoffset; ! 1329: if (mo->tag != TCONST) ! 1330: badtag("ioseta/memoffset", mo->tag); ! 1331: np = p->user.name; ! 1332: np->visused = 1; ! 1333: ci = mo->constblock.Const.ci - np->voffset; ! 1334: if (np->vstg == STGCOMMON ! 1335: && !np->vcommequiv ! 1336: && !usedefsforcommon) { ! 1337: comm = &extsymtab[np->vardesc.varno]; ! 1338: sprintf(buf, "%d.", comm->curno); ! 1339: k = strlen(buf) + strlen(comm->cextname) ! 1340: + strlen(np->cvarname); ! 1341: if (ci) { ! 1342: sprintf(buf1, "+%ld", ci); ! 1343: k += strlen(buf1); ! 1344: } ! 1345: else ! 1346: buf1[0] = 0; ! 1347: s = mem(k + 1, 0); ! 1348: sprintf(s, "%s%s%s%s", comm->cextname, buf, ! 1349: np->cvarname, buf1); ! 1350: } ! 1351: else if (ci) { ! 1352: sprintf(buf,"%ld", ci); ! 1353: s1 = p->user.name->cvarname; ! 1354: k = strlen(buf) + strlen(s1); ! 1355: sprintf(s = mem(k+2,0), "%s+%s", s1, buf); ! 1356: } ! 1357: else ! 1358: s = cpstring(np->cvarname); ! 1359: break; ! 1360: case UNAM_CONST: ! 1361: s = tostring(p->user.Const.ccp1.ccp0, ! 1362: (int)p->vleng->constblock.Const.ci); ! 1363: break; ! 1364: default: ! 1365: badthing("uname_tag", who, p->uname_tag); ! 1366: } ! 1367: /* kludge for Hollerith */ ! 1368: if (p->vtype != TYCHAR) { ! 1369: s1 = mem(strlen(s)+10,0); ! 1370: sprintf(s1, "(char *)%s%s", p->isarray ? "" : "&", s); ! 1371: s = s1; ! 1372: } ! 1373: iob_list->fields[offset] = s; ! 1374: } ! 1375: else { ! 1376: if (!p) ! 1377: e = ICON(0); ! 1378: else if (p->vtype != TYCHAR) { ! 1379: NOEXT("non-character variable as format or internal unit"); ! 1380: e = mkexpr(OPCHARCAST, (expptr)p, ENULL); ! 1381: } ! 1382: else ! 1383: e = addrof((expptr)p); ! 1384: ioset(TYADDR, offset, e); ! 1385: } ! 1386: } ! 1387: ! 1388: ! 1389: ! 1390: ! 1391: LOCAL void ! 1392: iosetip(i, offset) ! 1393: int i, offset; ! 1394: { ! 1395: register expptr p; ! 1396: ! 1397: if(p = V(i)) ! 1398: if(p->tag==TADDR && ! 1399: ONEOF(p->addrblock.vtype, inqmask) ) { ! 1400: ioset_assign = OPASSIGNI; ! 1401: ioset(TYADDR, offset, addrof(cpexpr(p)) ); ! 1402: ioset_assign = OPASSIGN; ! 1403: } ! 1404: else ! 1405: errstr("impossible inquire parameter %s", ioc[i].iocname); ! 1406: else ! 1407: ioset(TYADDR, offset, ICON(0) ); ! 1408: } ! 1409: ! 1410: ! 1411: ! 1412: LOCAL void ! 1413: iosetlc(i, offp, offl) ! 1414: int i, offp, offl; ! 1415: { ! 1416: register expptr p; ! 1417: if( (p = V(i)) && p->headblock.vtype==TYCHAR) ! 1418: ioset(TYIOINT, offl, cpexpr(p->headblock.vleng) ); ! 1419: iosetc(offp, p); ! 1420: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.