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