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