4.3BSD - /usr/src/usr.bin/f77/src/f77pass1/io.c

   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: }

Defined functions

Defined variables

Defined struct's

Defined macros