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