![[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 / f77|
Return to io.c CVS log | Up to [Research Unix] / researchv10no / cmd / f77 |
1.1 ! root 1: /* Routines to generate code for I/O statements. ! 2: Some corrections and improvements due to David Wasley, U. C. Berkeley ! 3: */ ! 4: ! 5: /* TEMPORARY */ ! 6: #define TYIOINT TYLONG ! 7: #define SZIOINT SZLONG ! 8: ! 9: #include "defs" ! 10: ! 11: LOCAL int doiolist(), dofclose(), dofinquire(), dofopen(), dofmove(), ! 12: ioset(), ioseta(), iosetc(), iosetip(), iosetlc(), putio(), ! 13: putiocall(); ! 14: ! 15: ! 16: LOCAL char ioroutine[XL+1]; ! 17: ! 18: LOCAL int ioendlab; ! 19: LOCAL int ioerrlab; ! 20: LOCAL int endbit; ! 21: LOCAL int errbit; ! 22: LOCAL int jumplab; ! 23: LOCAL int skiplab; ! 24: LOCAL int ioformatted; ! 25: LOCAL int statstruct = NO; ! 26: LOCAL ftnint blklen; ! 27: ! 28: #define UNFORMATTED 0 ! 29: #define FORMATTED 1 ! 30: #define LISTDIRECTED 2 ! 31: #define NAMEDIRECTED 3 ! 32: ! 33: #define V(z) ioc[z].iocval ! 34: ! 35: #define IOALL 07777 ! 36: ! 37: LOCAL struct Ioclist ! 38: { ! 39: char *iocname; ! 40: int iotype; ! 41: expptr iocval; ! 42: } ! 43: ioc[ ] = ! 44: { ! 45: { "", 0 }, ! 46: { "unit", IOALL }, ! 47: { "fmt", M(IOREAD) | M(IOWRITE) }, ! 48: { "err", IOALL }, ! 49: { "end", M(IOREAD) }, ! 50: { "iostat", IOALL }, ! 51: { "rec", M(IOREAD) | M(IOWRITE) }, ! 52: { "recl", M(IOOPEN) | M(IOINQUIRE) }, ! 53: { "file", M(IOOPEN) | M(IOINQUIRE) }, ! 54: { "status", M(IOOPEN) | M(IOCLOSE) }, ! 55: { "access", M(IOOPEN) | M(IOINQUIRE) }, ! 56: { "form", M(IOOPEN) | M(IOINQUIRE) }, ! 57: { "blank", M(IOOPEN) | M(IOINQUIRE) }, ! 58: { "exist", M(IOINQUIRE) }, ! 59: { "opened", M(IOINQUIRE) }, ! 60: { "number", M(IOINQUIRE) }, ! 61: { "named", M(IOINQUIRE) }, ! 62: { "name", M(IOINQUIRE) }, ! 63: { "sequential", M(IOINQUIRE) }, ! 64: { "direct", M(IOINQUIRE) }, ! 65: { "formatted", M(IOINQUIRE) }, ! 66: { "unformatted", M(IOINQUIRE) }, ! 67: { "nextrec", M(IOINQUIRE) }, ! 68: { "nml", M(IOREAD) | M(IOWRITE) } ! 69: }; ! 70: ! 71: #define NIOS (sizeof(ioc)/sizeof(struct Ioclist) - 1) ! 72: #define MAXIO SZFLAG + 10*SZIOINT + 15*SZADDR ! 73: ! 74: #define IOSUNIT 1 ! 75: #define IOSFMT 2 ! 76: #define IOSERR 3 ! 77: #define IOSEND 4 ! 78: #define IOSIOSTAT 5 ! 79: #define IOSREC 6 ! 80: #define IOSRECL 7 ! 81: #define IOSFILE 8 ! 82: #define IOSSTATUS 9 ! 83: #define IOSACCESS 10 ! 84: #define IOSFORM 11 ! 85: #define IOSBLANK 12 ! 86: #define IOSEXISTS 13 ! 87: #define IOSOPENED 14 ! 88: #define IOSNUMBER 15 ! 89: #define IOSNAMED 16 ! 90: #define IOSNAME 17 ! 91: #define IOSSEQUENTIAL 18 ! 92: #define IOSDIRECT 19 ! 93: #define IOSFORMATTED 20 ! 94: #define IOSUNFORMATTED 21 ! 95: #define IOSNEXTREC 22 ! 96: #define IOSNML 23 ! 97: ! 98: #define IOSTP V(IOSIOSTAT) ! 99: ! 100: ! 101: /* offsets in generated structures */ ! 102: ! 103: #define SZFLAG SZIOINT ! 104: ! 105: /* offsets for external READ and WRITE statements */ ! 106: ! 107: #define XERR 0 ! 108: #define XUNIT SZFLAG ! 109: #define XEND SZFLAG + SZIOINT ! 110: #define XFMT 2*SZFLAG + SZIOINT ! 111: #define XREC 2*SZFLAG + SZIOINT + SZADDR ! 112: #define XRLEN 2*SZFLAG + 2*SZADDR ! 113: #define XRNUM 2*SZFLAG + 2*SZADDR + SZIOINT ! 114: ! 115: /* offsets for internal READ and WRITE statements */ ! 116: ! 117: #define XIERR 0 ! 118: #define XIUNIT SZFLAG ! 119: #define XIEND SZFLAG + SZADDR ! 120: #define XIFMT 2*SZFLAG + SZADDR ! 121: #define XIRLEN 2*SZFLAG + 2*SZADDR ! 122: #define XIRNUM 2*SZFLAG + 2*SZADDR + SZIOINT ! 123: #define XIREC 2*SZFLAG + 2*SZADDR + 2*SZIOINT ! 124: ! 125: /* offsets for OPEN statements */ ! 126: ! 127: #define XFNAME SZFLAG + SZIOINT ! 128: #define XFNAMELEN SZFLAG + SZIOINT + SZADDR ! 129: #define XSTATUS SZFLAG + 2*SZIOINT + SZADDR ! 130: #define XACCESS SZFLAG + 2*SZIOINT + 2*SZADDR ! 131: #define XFORMATTED SZFLAG + 2*SZIOINT + 3*SZADDR ! 132: #define XRECLEN SZFLAG + 2*SZIOINT + 4*SZADDR ! 133: #define XBLANK SZFLAG + 3*SZIOINT + 4*SZADDR ! 134: ! 135: /* offset for CLOSE statement */ ! 136: ! 137: #define XCLSTATUS SZFLAG + SZIOINT ! 138: ! 139: /* offsets for INQUIRE statement */ ! 140: ! 141: #define XFILE SZFLAG + SZIOINT ! 142: #define XFILELEN SZFLAG + SZIOINT + SZADDR ! 143: #define XEXISTS SZFLAG + 2*SZIOINT + SZADDR ! 144: #define XOPEN SZFLAG + 2*SZIOINT + 2*SZADDR ! 145: #define XNUMBER SZFLAG + 2*SZIOINT + 3*SZADDR ! 146: #define XNAMED SZFLAG + 2*SZIOINT + 4*SZADDR ! 147: #define XNAME SZFLAG + 2*SZIOINT + 5*SZADDR ! 148: #define XNAMELEN SZFLAG + 2*SZIOINT + 6*SZADDR ! 149: #define XQACCESS SZFLAG + 3*SZIOINT + 6*SZADDR ! 150: #define XQACCLEN SZFLAG + 3*SZIOINT + 7*SZADDR ! 151: #define XSEQ SZFLAG + 4*SZIOINT + 7*SZADDR ! 152: #define XSEQLEN SZFLAG + 4*SZIOINT + 8*SZADDR ! 153: #define XDIRECT SZFLAG + 5*SZIOINT + 8*SZADDR ! 154: #define XDIRLEN SZFLAG + 5*SZIOINT + 9*SZADDR ! 155: #define XFORM SZFLAG + 6*SZIOINT + 9*SZADDR ! 156: #define XFORMLEN SZFLAG + 6*SZIOINT + 10*SZADDR ! 157: #define XFMTED SZFLAG + 7*SZIOINT + 10*SZADDR ! 158: #define XFMTEDLEN SZFLAG + 7*SZIOINT + 11*SZADDR ! 159: #define XUNFMT SZFLAG + 8*SZIOINT + 11*SZADDR ! 160: #define XUNFMTLEN SZFLAG + 8*SZIOINT + 12*SZADDR ! 161: #define XQRECL SZFLAG + 9*SZIOINT + 12*SZADDR ! 162: #define XNEXTREC SZFLAG + 9*SZIOINT + 13*SZADDR ! 163: #define XQBLANK SZFLAG + 9*SZIOINT + 14*SZADDR ! 164: #define XQBLANKLEN SZFLAG + 9*SZIOINT + 15*SZADDR ! 165: ! 166: fmtstmt(lp) ! 167: register struct Labelblock *lp; ! 168: { ! 169: extern expptr labelfudge(); ! 170: int oldlbl; ! 171: ! 172: if(lp == NULL) ! 173: { ! 174: execerr("unlabeled format statement" , CNULL); ! 175: return(-1); ! 176: } ! 177: if(lp->labtype == LABUNKNOWN) ! 178: { ! 179: oldlbl = lp->labelno; ! 180: lp->labtype = LABFORMAT; ! 181: lp->labelno = newlabel(); ! 182: labelfudge(oldlbl, lp->labelno); ! 183: } ! 184: else if(lp->labtype != LABFORMAT) ! 185: { ! 186: execerr("bad format number", CNULL); ! 187: return(-1); ! 188: } ! 189: return(lp->labelno); ! 190: } ! 191: ! 192: ! 193: ! 194: setfmt(lp) ! 195: struct Labelblock *lp; ! 196: { ! 197: int n; ! 198: char *s, *lexline(); ! 199: ! 200: s = lexline(&n); ! 201: preven(ALILONG); ! 202: prlabel(asmfile, lp->labelno); ! 203: putstr(asmfile, s, n); ! 204: flline(); ! 205: } ! 206: ! 207: ! 208: ! 209: startioctl() ! 210: { ! 211: register int i; ! 212: ! 213: inioctl = YES; ! 214: nioctl = 0; ! 215: ioformatted = UNFORMATTED; ! 216: for(i = 1 ; i<=NIOS ; ++i) ! 217: V(i) = NULL; ! 218: } ! 219: ! 220: ! 221: ! 222: endioctl() ! 223: { ! 224: int i; ! 225: expptr p; ! 226: ! 227: inioctl = NO; ! 228: ! 229: /* set up for error recovery */ ! 230: ! 231: ioerrlab = ioendlab = skiplab = jumplab = 0; ! 232: ! 233: if(p = V(IOSEND)) ! 234: if(ISICON(p)) ! 235: ioendlab = execlab(p->constblock.Const.ci) ->labelno; ! 236: else ! 237: err("bad end= clause"); ! 238: ! 239: if(p = V(IOSERR)) ! 240: if(ISICON(p)) ! 241: ioerrlab = execlab(p->constblock.Const.ci) ->labelno; ! 242: else ! 243: err("bad err= clause"); ! 244: ! 245: if(IOSTP) ! 246: if(IOSTP->tag!=TADDR || ! ISINT(IOSTP->addrblock.vtype) ) ! 247: { ! 248: err("iostat must be an integer variable"); ! 249: frexpr(IOSTP); ! 250: IOSTP = NULL; ! 251: } ! 252: ! 253: if(iostmt == IOREAD) ! 254: { ! 255: if(IOSTP) ! 256: { ! 257: if(ioerrlab && ioendlab && ioerrlab==ioendlab) ! 258: jumplab = ioerrlab; ! 259: else ! 260: skiplab = jumplab = newlabel(); ! 261: } ! 262: else { ! 263: if(ioerrlab && ioendlab && ioerrlab!=ioendlab) ! 264: { ! 265: IOSTP = (expptr) mktemp(TYINT, PNULL); ! 266: skiplab = jumplab = newlabel(); ! 267: } ! 268: else ! 269: jumplab = (ioerrlab ? ioerrlab : ioendlab); ! 270: } ! 271: } ! 272: else if(iostmt == IOWRITE) ! 273: { ! 274: if(IOSTP && !ioerrlab) ! 275: skiplab = jumplab = newlabel(); ! 276: else ! 277: jumplab = ioerrlab; ! 278: } ! 279: else ! 280: jumplab = ioerrlab; ! 281: ! 282: endbit = IOSTP!=NULL || ioendlab!=0; /* for use in startrw() */ ! 283: errbit = IOSTP!=NULL || ioerrlab!=0; ! 284: if(iostmt!=IOREAD && iostmt!=IOWRITE) ! 285: { ! 286: if(ioblkp == NULL) ! 287: ioblkp = autovar( (MAXIO+SZIOINT-1)/SZIOINT , TYIOINT, PNULL); ! 288: ioset(TYIOINT, XERR, ICON(errbit)); ! 289: } ! 290: ! 291: switch(iostmt) ! 292: { ! 293: case IOOPEN: ! 294: dofopen(); ! 295: break; ! 296: ! 297: case IOCLOSE: ! 298: dofclose(); ! 299: break; ! 300: ! 301: case IOINQUIRE: ! 302: dofinquire(); ! 303: break; ! 304: ! 305: case IOBACKSPACE: ! 306: dofmove("f_back"); ! 307: break; ! 308: ! 309: case IOREWIND: ! 310: dofmove("f_rew"); ! 311: break; ! 312: ! 313: case IOENDFILE: ! 314: dofmove("f_end"); ! 315: break; ! 316: ! 317: case IOREAD: ! 318: case IOWRITE: ! 319: startrw(); ! 320: break; ! 321: ! 322: default: ! 323: fatali("impossible iostmt %d", iostmt); ! 324: } ! 325: for(i = 1 ; i<=NIOS ; ++i) ! 326: if(i!=IOSIOSTAT && V(i)!=NULL) ! 327: frexpr(V(i)); ! 328: } ! 329: ! 330: ! 331: ! 332: iocname() ! 333: { ! 334: register int i; ! 335: int found, mask; ! 336: ! 337: found = 0; ! 338: mask = M(iostmt); ! 339: for(i = 1 ; i <= NIOS ; ++i) ! 340: if(toklen==strlen(ioc[i].iocname) && eqn(toklen, token, ioc[i].iocname)) ! 341: if(ioc[i].iotype & mask) ! 342: return(i); ! 343: else found = i; ! 344: if(found) ! 345: errstr("invalid control %s for statement", ioc[found].iocname); ! 346: else ! 347: errstr("unknown iocontrol %s", varstr(toklen, token) ); ! 348: return(IOSBAD); ! 349: } ! 350: ! 351: ! 352: ioclause(n, p) ! 353: register int n; ! 354: register expptr p; ! 355: { ! 356: struct Ioclist *iocp; ! 357: ! 358: ++nioctl; ! 359: if(n == IOSBAD) ! 360: return; ! 361: if(n == IOSPOSITIONAL) ! 362: { ! 363: n = nioctl; ! 364: if (nioctl == IOSFMT) { ! 365: if (iostmt == IOOPEN) { ! 366: n = IOSFILE; ! 367: NOEXT("file= specifier omitted from open"); ! 368: } ! 369: else if (iostmt < IOREAD) ! 370: goto illegal; ! 371: } ! 372: else if(nioctl > IOSFMT) ! 373: { ! 374: illegal: ! 375: err("illegal positional iocontrol"); ! 376: return; ! 377: } ! 378: } ! 379: else if (n == IOSNML) ! 380: n = IOSFMT; ! 381: ! 382: if(p == NULL) ! 383: { ! 384: if(n == IOSUNIT) ! 385: p = (expptr) (iostmt==IOREAD ? IOSTDIN : IOSTDOUT); ! 386: else if(n != IOSFMT) ! 387: { ! 388: err("illegal * iocontrol"); ! 389: return; ! 390: } ! 391: } ! 392: if(n == IOSFMT) ! 393: ioformatted = (p==NULL ? LISTDIRECTED : FORMATTED); ! 394: ! 395: iocp = & ioc[n]; ! 396: if(iocp->iocval == NULL) ! 397: { ! 398: if(n!=IOSFMT && ( n!=IOSUNIT || (p!=NULL && p->headblock.vtype!=TYCHAR) ) ) ! 399: p = fixtype(p); ! 400: iocp->iocval = p; ! 401: } ! 402: else ! 403: errstr("iocontrol %s repeated", iocp->iocname); ! 404: } ! 405: ! 406: /* io list item */ ! 407: ! 408: doio(list) ! 409: chainp list; ! 410: { ! 411: expptr call0(); ! 412: ! 413: if(ioformatted == NAMEDIRECTED) ! 414: { ! 415: if(list) ! 416: err("no I/O list allowed in NAMELIST read/write"); ! 417: } ! 418: else ! 419: { ! 420: doiolist(list); ! 421: ioroutine[0] = 'e'; ! 422: putiocall( call0(TYINT, ioroutine) ); ! 423: } ! 424: } ! 425: ! 426: ! 427: ! 428: ! 429: ! 430: LOCAL doiolist(p0) ! 431: chainp p0; ! 432: { ! 433: chainp p; ! 434: register tagptr q; ! 435: register expptr qe; ! 436: register Namep qn; ! 437: Addrp tp, mkscalar(); ! 438: int range; ! 439: ! 440: for (p = p0 ; p ; p = p->nextp) ! 441: { ! 442: q = p->datap; ! 443: if(q->tag == TIMPLDO) ! 444: { ! 445: exdo(range=newlabel(), q->impldoblock.impdospec); ! 446: doiolist(q->impldoblock.datalist); ! 447: enddo(range); ! 448: free( (charptr) q); ! 449: } ! 450: else { ! 451: if(q->tag==TPRIM && q->primblock.argsp==NULL ! 452: && q->primblock.namep->vdim!=NULL) ! 453: { ! 454: vardcl(qn = q->primblock.namep); ! 455: if(qn->vdim->nelt) ! 456: putio( fixtype(cpexpr(qn->vdim->nelt)), ! 457: mkscalar(qn) ); ! 458: else ! 459: err("attempt to i/o array of unknown size"); ! 460: } ! 461: else if(q->tag==TPRIM && q->primblock.argsp==NULL && ! 462: (qe = (expptr) memversion(q->primblock.namep)) ) ! 463: putio(ICON(1),qe); ! 464: else if( (qe = fixtype(cpexpr(q)))->tag==TADDR) ! 465: putio(ICON(1), qe); ! 466: else if(qe->headblock.vtype != TYERROR) ! 467: { ! 468: if(iostmt == IOWRITE) ! 469: { ! 470: ftnint lencat(); ! 471: expptr qvl; ! 472: qvl = NULL; ! 473: if( ISCHAR(qe) ) ! 474: { ! 475: qvl = (expptr) ! 476: cpexpr(qe->headblock.vleng); ! 477: tp = mktemp(qe->headblock.vtype, ! 478: ICON(lencat(qe))); ! 479: } ! 480: else ! 481: tp = mktemp(qe->headblock.vtype, ! 482: qe->headblock.vleng); ! 483: puteq( cpexpr(tp), qe); ! 484: if(qvl) /* put right length on block */ ! 485: { ! 486: frexpr(tp->vleng); ! 487: tp->vleng = qvl; ! 488: } ! 489: putio(ICON(1), tp); ! 490: } ! 491: else ! 492: err("non-left side in READ list"); ! 493: } ! 494: frexpr(q); ! 495: } ! 496: } ! 497: frchain( &p0 ); ! 498: } ! 499: ! 500: ! 501: ! 502: ! 503: ! 504: LOCAL putio(nelt, addr) ! 505: expptr nelt; ! 506: register expptr addr; ! 507: { ! 508: int type; ! 509: register expptr q; ! 510: ! 511: type = addr->headblock.vtype; ! 512: if(ioformatted!=LISTDIRECTED && ISCOMPLEX(type) ) ! 513: { ! 514: nelt = mkexpr(OPSTAR, ICON(2), nelt); ! 515: type -= (TYCOMPLEX-TYREAL); ! 516: } ! 517: ! 518: /* pass a length with every item. for noncharacter data, fake one */ ! 519: if(type != TYCHAR) ! 520: { ! 521: if( ISCONST(addr) ) ! 522: addr = (expptr) putconst(addr); ! 523: addr->headblock.vtype = TYCHAR; ! 524: addr->headblock.vleng = ICON( typesize[type] ); ! 525: } ! 526: ! 527: nelt = fixtype( mkconv(TYLENG,nelt) ); ! 528: if(ioformatted == LISTDIRECTED) ! 529: q = call3(TYINT, "do_lio", mkconv(TYLONG, ICON(type)), nelt, addr); ! 530: else ! 531: q = call2(TYINT, (ioformatted==FORMATTED ? "do_fio" : "do_uio"), ! 532: nelt, addr); ! 533: putiocall(q); ! 534: } ! 535: ! 536: ! 537: ! 538: ! 539: endio() ! 540: { ! 541: if(skiplab) ! 542: { ! 543: putlabel(skiplab); ! 544: if(ioendlab) ! 545: putif( mkexpr(OPGE, cpexpr(IOSTP), ICON(0)), ioendlab); ! 546: if(ioerrlab) ! 547: putif( mkexpr( ( (iostmt==IOREAD||iostmt==IOWRITE) ? OPLE : OPEQ), ! 548: cpexpr(IOSTP), ICON(0)) , ioerrlab); ! 549: } ! 550: if(IOSTP) ! 551: frexpr(IOSTP); ! 552: } ! 553: ! 554: ! 555: ! 556: LOCAL putiocall(q) ! 557: register expptr q; ! 558: { ! 559: if(IOSTP) ! 560: { ! 561: q->headblock.vtype = TYINT; ! 562: q = fixexpr( mkexpr(OPASSIGN, cpexpr(IOSTP), q)); ! 563: } ! 564: ! 565: if(jumplab) ! 566: putif( mkexpr(OPEQ, q, ICON(0) ), jumplab); ! 567: else ! 568: putexpr(q); ! 569: } ! 570: ! 571: startrw() ! 572: { ! 573: register expptr p; ! 574: register Namep np; ! 575: register Addrp unitp, fmtp, recp, tioblkp; ! 576: register expptr nump; ! 577: Addrp mkscalar(); ! 578: expptr mkaddcon(); ! 579: int k; ! 580: flag intfile, sequential, ok, varfmt; ! 581: ! 582: /* First look at all the parameters and determine what is to be done */ ! 583: ! 584: ok = YES; ! 585: statstruct = YES; ! 586: ! 587: intfile = NO; ! 588: if(p = V(IOSUNIT)) ! 589: { ! 590: if( ISINT(p->headblock.vtype) ) ! 591: unitp = (Addrp) cpexpr(p); ! 592: else if(p->headblock.vtype == TYCHAR) ! 593: { ! 594: intfile = YES; ! 595: if(p->tag==TPRIM && p->primblock.argsp==NULL && ! 596: (np = p->primblock.namep)->vdim!=NULL) ! 597: { ! 598: vardcl(np); ! 599: if(np->vdim->nelt) ! 600: { ! 601: nump = (expptr) cpexpr(np->vdim->nelt); ! 602: if( ! ISCONST(nump) ) ! 603: statstruct = NO; ! 604: } ! 605: else ! 606: { ! 607: err("attempt to use internal unit array of unknown size"); ! 608: ok = NO; ! 609: nump = ICON(1); ! 610: } ! 611: unitp = mkscalar(np); ! 612: } ! 613: else { ! 614: nump = ICON(1); ! 615: unitp = (Addrp /*pjw */) fixtype(cpexpr(p)); ! 616: } ! 617: if(! isstatic(unitp) ) ! 618: statstruct = NO; ! 619: } ! 620: } ! 621: else ! 622: { ! 623: err("bad unit specifier"); ! 624: ok = NO; ! 625: } ! 626: ! 627: sequential = YES; ! 628: if(p = V(IOSREC)) ! 629: if( ISINT(p->headblock.vtype) ) ! 630: { ! 631: recp = (Addrp) cpexpr(p); ! 632: sequential = NO; ! 633: } ! 634: else { ! 635: err("bad REC= clause"); ! 636: ok = NO; ! 637: } ! 638: else ! 639: recp = NULL; ! 640: ! 641: ! 642: varfmt = YES; ! 643: fmtp = NULL; ! 644: if(p = V(IOSFMT)) ! 645: { ! 646: if(p->tag==TPRIM && p->primblock.argsp==NULL) ! 647: { ! 648: np = p->primblock.namep; ! 649: if(np->vclass == CLNAMELIST) ! 650: { ! 651: ioformatted = NAMEDIRECTED; ! 652: fmtp = (Addrp) fixtype(p); ! 653: V(IOSFMT) = (expptr)fmtp; ! 654: goto endfmt; ! 655: } ! 656: vardcl(np); ! 657: if(np->vdim) ! 658: { ! 659: if( ! ONEOF(np->vstg, MSKSTATIC) ) ! 660: statstruct = NO; ! 661: fmtp = mkscalar(np); ! 662: goto endfmt; ! 663: } ! 664: if( ISINT(np->vtype) ) /* ASSIGNed label */ ! 665: { ! 666: statstruct = NO; ! 667: varfmt = NO; ! 668: fmtp = (Addrp) fixtype(p); ! 669: if (!(bugwarn & 2)) { ! 670: V(IOSFMT) = 0; ! 671: if (bugwarn) ! 672: warnb("old f77 died here"); ! 673: } ! 674: goto endfmt; ! 675: } ! 676: } ! 677: p = V(IOSFMT) = fixtype(p); ! 678: if(p->headblock.vtype == TYCHAR) ! 679: { ! 680: if( ! isstatic(p) ) ! 681: statstruct = NO; ! 682: fmtp = (Addrp) cpexpr(p); ! 683: } ! 684: else if( ISICON(p) ) ! 685: { ! 686: if( (k = fmtstmt( mklabel(p->constblock.Const.ci) )) > 0 ) ! 687: { ! 688: fmtp = (Addrp) mkaddcon(k); ! 689: varfmt = NO; ! 690: } ! 691: else ! 692: ioformatted = UNFORMATTED; ! 693: } ! 694: else { ! 695: err("bad format descriptor"); ! 696: ioformatted = UNFORMATTED; ! 697: ok = NO; ! 698: } ! 699: } ! 700: else ! 701: fmtp = NULL; ! 702: ! 703: endfmt: ! 704: if(intfile) { ! 705: if (ioformatted==UNFORMATTED) { ! 706: err("unformatted internal I/O not allowed"); ! 707: ok = NO; ! 708: } ! 709: if (recp) { ! 710: err("direct internal I/O not allowed"); ! 711: ok = NO; ! 712: } ! 713: } ! 714: if(!sequential && ioformatted==LISTDIRECTED) ! 715: { ! 716: err("direct list-directed I/O not allowed"); ! 717: ok = NO; ! 718: } ! 719: if(!sequential && ioformatted==NAMEDIRECTED) ! 720: { ! 721: err("direct namelist I/O not allowed"); ! 722: ok = NO; ! 723: } ! 724: ! 725: if( ! ok ) ! 726: return; ! 727: ! 728: /* ! 729: Now put out the I/O structure, statically if all the clauses ! 730: are constants, dynamically otherwise ! 731: */ ! 732: ! 733: if(statstruct) ! 734: { ! 735: tioblkp = ioblkp; ! 736: ioblkp = ALLOC(Addrblock); ! 737: ioblkp->tag = TADDR; ! 738: ioblkp->vtype = TYIOINT; ! 739: ioblkp->vclass = CLVAR; ! 740: ioblkp->vstg = STGINIT; ! 741: ioblkp->memno = ++lastvarno; ! 742: ioblkp->memoffset = ICON(0); ! 743: blklen = (intfile ? XIREC+SZIOINT : ! 744: (sequential ? XFMT+SZADDR : XRNUM+SZIOINT) ); ! 745: } ! 746: else if(ioblkp == NULL) ! 747: ioblkp = autovar( (MAXIO+SZIOINT-1)/SZIOINT , TYIOINT, PNULL); ! 748: ! 749: ioset(TYIOINT, XERR, ICON(errbit)); ! 750: if(iostmt == IOREAD) ! 751: ioset(TYIOINT, (intfile ? XIEND : XEND), ICON(endbit) ); ! 752: ! 753: if(intfile) ! 754: { ! 755: ioset(TYIOINT, XIRNUM, nump); ! 756: ioset(TYIOINT, XIRLEN, cpexpr(unitp->vleng) ); ! 757: ioseta(XIUNIT, unitp); ! 758: } ! 759: else ! 760: ioset(TYIOINT, XUNIT, (expptr) unitp); ! 761: ! 762: if(recp) ! 763: ioset(TYIOINT, (intfile ? XIREC : XREC) , (expptr) recp); ! 764: ! 765: if(varfmt) ! 766: ioseta( intfile ? XIFMT : XFMT , fmtp); ! 767: else ! 768: ioset(TYADDR, intfile ? XIFMT : XFMT, (expptr) fmtp); ! 769: ! 770: ioroutine[0] = 's'; ! 771: ioroutine[1] = '_'; ! 772: ioroutine[2] = (iostmt==IOREAD ? 'r' : 'w'); ! 773: ioroutine[3] = (sequential ? 's' : 'd'); ! 774: ioroutine[4] = "ufln" [ioformatted]; ! 775: ioroutine[5] = (intfile ? 'i' : 'e'); ! 776: ioroutine[6] = '\0'; ! 777: ! 778: putiocall( call1(TYINT, ioroutine, cpexpr(ioblkp) )); ! 779: ! 780: if(statstruct) ! 781: { ! 782: frexpr(ioblkp); ! 783: ioblkp = tioblkp; ! 784: statstruct = NO; ! 785: } ! 786: } ! 787: ! 788: ! 789: ! 790: LOCAL dofopen() ! 791: { ! 792: register expptr p; ! 793: ! 794: if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) ) ! 795: ioset(TYIOINT, XUNIT, cpexpr(p) ); ! 796: else ! 797: err("bad unit in open"); ! 798: if( (p = V(IOSFILE)) ) ! 799: if(p->headblock.vtype == TYCHAR) ! 800: ioset(TYIOINT, XFNAMELEN, cpexpr(p->headblock.vleng) ); ! 801: else ! 802: err("bad file in open"); ! 803: ! 804: iosetc(XFNAME, p); ! 805: ! 806: if(p = V(IOSRECL)) ! 807: if( ISINT(p->headblock.vtype) ) ! 808: ioset(TYIOINT, XRECLEN, cpexpr(p) ); ! 809: else ! 810: err("bad recl"); ! 811: else ! 812: ioset(TYIOINT, XRECLEN, ICON(0) ); ! 813: ! 814: iosetc(XSTATUS, V(IOSSTATUS)); ! 815: iosetc(XACCESS, V(IOSACCESS)); ! 816: iosetc(XFORMATTED, V(IOSFORM)); ! 817: iosetc(XBLANK, V(IOSBLANK)); ! 818: ! 819: putiocall( call1(TYINT, "f_open", cpexpr(ioblkp) )); ! 820: } ! 821: ! 822: ! 823: LOCAL dofclose() ! 824: { ! 825: register expptr p; ! 826: ! 827: if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) ) ! 828: { ! 829: ioset(TYIOINT, XUNIT, cpexpr(p) ); ! 830: iosetc(XCLSTATUS, V(IOSSTATUS)); ! 831: putiocall( call1(TYINT, "f_clos", cpexpr(ioblkp)) ); ! 832: } ! 833: else ! 834: err("bad unit in close statement"); ! 835: } ! 836: ! 837: ! 838: LOCAL dofinquire() ! 839: { ! 840: register expptr p; ! 841: if(p = V(IOSUNIT)) ! 842: { ! 843: if( V(IOSFILE) ) ! 844: err("inquire by unit or by file, not both"); ! 845: ioset(TYIOINT, XUNIT, cpexpr(p) ); ! 846: } ! 847: else if( ! V(IOSFILE) ) ! 848: err("must inquire by unit or by file"); ! 849: iosetlc(IOSFILE, XFILE, XFILELEN); ! 850: iosetip(IOSEXISTS, XEXISTS); ! 851: iosetip(IOSOPENED, XOPEN); ! 852: iosetip(IOSNUMBER, XNUMBER); ! 853: iosetip(IOSNAMED, XNAMED); ! 854: iosetlc(IOSNAME, XNAME, XNAMELEN); ! 855: iosetlc(IOSACCESS, XQACCESS, XQACCLEN); ! 856: iosetlc(IOSSEQUENTIAL, XSEQ, XSEQLEN); ! 857: iosetlc(IOSDIRECT, XDIRECT, XDIRLEN); ! 858: iosetlc(IOSFORM, XFORM, XFORMLEN); ! 859: iosetlc(IOSFORMATTED, XFMTED, XFMTEDLEN); ! 860: iosetlc(IOSUNFORMATTED, XUNFMT, XUNFMTLEN); ! 861: iosetip(IOSRECL, XQRECL); ! 862: iosetip(IOSNEXTREC, XNEXTREC); ! 863: iosetlc(IOSBLANK, XQBLANK, XQBLANKLEN); ! 864: ! 865: putiocall( call1(TYINT, "f_inqu", cpexpr(ioblkp) )); ! 866: } ! 867: ! 868: ! 869: ! 870: LOCAL dofmove(subname) ! 871: char *subname; ! 872: { ! 873: register expptr p; ! 874: ! 875: if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) ) ! 876: { ! 877: ioset(TYIOINT, XUNIT, cpexpr(p) ); ! 878: putiocall( call1(TYINT, subname, cpexpr(ioblkp) )); ! 879: } ! 880: else ! 881: err("bad unit in I/O motion statement"); ! 882: } ! 883: ! 884: ! 885: ! 886: LOCAL ioset(type, offset, p) ! 887: int type, offset; ! 888: register expptr p; ! 889: { ! 890: register Addrp q; ! 891: ! 892: q = (Addrp) cpexpr(ioblkp); ! 893: q->vtype = type; ! 894: q->memoffset = fixtype( mkexpr(OPPLUS, q->memoffset, ICON(offset)) ); ! 895: if(statstruct && ISCONST(p)) ! 896: { ! 897: setdata(q, p, 0L, blklen); ! 898: frexpr(q); ! 899: frexpr(p); ! 900: } ! 901: else ! 902: puteq(q, p); ! 903: } ! 904: ! 905: ! 906: ! 907: ! 908: LOCAL iosetc(offset, p) ! 909: int offset; ! 910: register expptr p; ! 911: { ! 912: if(p == NULL) ! 913: ioset(TYADDR, offset, ICON(0) ); ! 914: else if(p->headblock.vtype == TYCHAR) ! 915: ioset(TYADDR, offset, addrof(cpexpr(p) )); ! 916: else ! 917: err("non-character control clause"); ! 918: } ! 919: ! 920: ! 921: ! 922: LOCAL ioseta(offset, p) ! 923: int offset; ! 924: register Addrp p; ! 925: { ! 926: char *dataname(); ! 927: ! 928: if(statstruct) ! 929: { ! 930: dataline(dataname(STGINIT,ioblkp->memno), (ftnint) offset, ! 931: blklen, TYADDR); ! 932: if(p) ! 933: praddr(initfile, p->vstg, p->memno, ! 934: p->memoffset->constblock.Const.ci); ! 935: else ! 936: praddr(initfile, STGNULL, 0, (ftnint) 0); ! 937: } ! 938: else ! 939: ioset(TYADDR, offset, p ? addrof(p) : ICON(0) ); ! 940: } ! 941: ! 942: ! 943: ! 944: ! 945: LOCAL iosetip(i, offset) ! 946: int i, offset; ! 947: { ! 948: register expptr p; ! 949: ! 950: if(p = V(i)) ! 951: if(p->tag==TADDR && ! 952: ONEOF(p->addrblock.vtype, M(TYLONG)|M(TYLOGICAL)) ) ! 953: ioset(TYADDR, offset, addrof(cpexpr(p)) ); ! 954: else ! 955: errstr("impossible inquire parameter %s", ioc[i].iocname); ! 956: else ! 957: ioset(TYADDR, offset, ICON(0) ); ! 958: } ! 959: ! 960: ! 961: ! 962: LOCAL iosetlc(i, offp, offl) ! 963: int i, offp, offl; ! 964: { ! 965: register expptr p; ! 966: if( (p = V(i)) && p->headblock.vtype==TYCHAR) ! 967: ioset(TYIOINT, offl, cpexpr(p->headblock.vleng) ); ! 968: iosetc(offp, p); ! 969: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.