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