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