2.9BSD - /usr/src/cmd/f77/io.c

   1: /* Routines to generate code for I/O statements.
   2:    Some corrections and improvements due to David Wasley, U. C. Berkeley
   3:    Compile with -DKOSHER to force exact conformity with the ANSI std.
   4: */
   5: /*
   6:  * This module supports the ucb fixed libI77. Since it was done
   7:  * on a Vax, some of the naming conventions were different. These were
   8:  * changed to allow compilation on the 11/70 version. wfj 3/26/80
   9:  * <UNTESTED>
  10:  */
  11: /* Modified to handle encode/decode statements.
  12:  * Other files modified to support this feature:
  13:  *	lex.c	    "encode" & "decode" added to key[]
  14:  *	tokens	    SENCODE & SDECODE added
  15:  *	gram.io     modified in an obvious way.
  16:  * John Sender, 7/23/80.
  17:  */
  18: 
  19: #ifdef KOSHER
  20: #define IOSRETURN 1  /* to force ANSI std return on iostat= */
  21: #endif
  22: 
  23: /* TEMPORARY */
  24: #define TYIOINT TYLONG
  25: #define SZIOINT SZLONG
  26: 
  27: #include "defs"
  28: #include "string_defs"
  29: 
  30: LOCAL char ioroutine[XL+1];
  31: 
  32: LOCAL int ioendlab;
  33: LOCAL int ioerrlab;
  34: LOCAL int iostest;
  35: LOCAL int iosreturn;
  36: LOCAL int jumplab;
  37: LOCAL int skiplab;
  38: LOCAL int ioformatted;
  39: LOCAL expptr ioecdc;    /* encode/decode char cnt */    /* E-D */
  40: 
  41: #define UNFORMATTED 0
  42: #define FORMATTED 1
  43: #define LISTDIRECTED 2
  44: 
  45: #define V(z)    ioc[z].iocval
  46: 
  47: #define IOALL 07777
  48: 
  49: LOCAL struct ioclist
  50:     {
  51:     char *iocname;
  52:     int iotype;
  53:     expptr iocval;
  54:     } ioc[ ] =
  55:     {
  56:         { "", 0 },
  57:         { "unit", IOALL },
  58:         { "fmt", M(IOREAD) | M(IOWRITE) },
  59:         { "err", IOALL },
  60: #ifdef KOSHER
  61:         { "end", M(IOREAD) },
  62: #else
  63:         { "end", M(IOREAD) | M(IOWRITE) },
  64: #endif
  65:         { "iostat", IOALL },
  66:         { "rec", M(IOREAD) | M(IOWRITE) },
  67:         { "recl", M(IOOPEN) | M(IOINQUIRE) },
  68:         { "file", M(IOOPEN) | M(IOINQUIRE) },
  69:         { "status", M(IOOPEN) | M(IOCLOSE) },
  70:         { "access", M(IOOPEN) | M(IOINQUIRE) },
  71:         { "form", M(IOOPEN) | M(IOINQUIRE) },
  72:         { "blank", M(IOOPEN) | M(IOINQUIRE) },
  73:         { "exist", M(IOINQUIRE) },
  74:         { "opened", M(IOINQUIRE) },
  75:         { "number", M(IOINQUIRE) },
  76:         { "named", M(IOINQUIRE) },
  77:         { "name", M(IOINQUIRE) },
  78:         { "sequential", M(IOINQUIRE) },
  79:         { "direct", M(IOINQUIRE) },
  80:         { "formatted", M(IOINQUIRE) },
  81:         { "unformatted", M(IOINQUIRE) },
  82:         { "nextrec", M(IOINQUIRE) }
  83:     } ;
  84: 
  85: #define NIOS (sizeof(ioc)/sizeof(struct ioclist) - 1)
  86: #define MAXIO   SZFLAG + 10*SZIOINT + 15*SZADDR
  87: 
  88: #define IOSUNIT 1
  89: #define IOSFMT 2
  90: #define IOSERR 3
  91: #define IOSEND 4
  92: #define IOSIOSTAT 5
  93: #define IOSREC 6
  94: #define IOSRECL 7
  95: #define IOSFILE 8
  96: #define IOSSTATUS 9
  97: #define IOSACCESS 10
  98: #define IOSFORM 11
  99: #define IOSBLANK 12
 100: #define IOSEXISTS 13
 101: #define IOSOPENED 14
 102: #define IOSNUMBER 15
 103: #define IOSNAMED 16
 104: #define IOSNAME 17
 105: #define IOSSEQUENTIAL 18
 106: #define IOSDIRECT 19
 107: #define IOSFORMATTED 20
 108: #define IOSUNFORMATTED 21
 109: #define IOSNEXTREC 22
 110: 
 111: #define IOSTP V(IOSIOSTAT)
 112: #define IOSRW (iostmt==IOREAD || iostmt==IOWRITE)
 113: 
 114: 
 115: /* offsets in generated structures */
 116: 
 117: #define SZFLAG SZIOINT
 118: 
 119: /* offsets for external READ and WRITE statements */
 120: 
 121: #define XERR 0
 122: #define XUNIT   SZFLAG
 123: #define XEND    SZFLAG + SZIOINT
 124: #define XFMT    2*SZFLAG + SZIOINT
 125: #define XREC    2*SZFLAG + SZIOINT + SZADDR
 126: 
 127: /* offsets for internal READ and WRITE statements */
 128: 
 129: #define XIERR   0
 130: #define XIUNIT  SZFLAG
 131: #define XIEND   SZFLAG + SZADDR
 132: #define XIFMT   2*SZFLAG + SZADDR
 133: #define XIRLEN  2*SZFLAG + 2*SZADDR
 134: #define XIRNUM  2*SZFLAG + 2*SZADDR + SZIOINT
 135: #define XIREC   2*SZFLAG + 2*SZADDR + 2*SZIOINT
 136: 
 137: /* offsets for OPEN statements */
 138: 
 139: #define XFNAME  SZFLAG + SZIOINT
 140: #define XFNAMELEN   SZFLAG + SZIOINT + SZADDR
 141: #define XSTATUS SZFLAG + 2*SZIOINT + SZADDR
 142: #define XACCESS SZFLAG + 2*SZIOINT + 2*SZADDR
 143: #define XFORMATTED  SZFLAG + 2*SZIOINT + 3*SZADDR
 144: #define XRECLEN SZFLAG + 2*SZIOINT + 4*SZADDR
 145: #define XBLANK  SZFLAG + 3*SZIOINT + 4*SZADDR
 146: 
 147: /* offset for CLOSE statement */
 148: 
 149: #define XCLSTATUS   SZFLAG + SZIOINT
 150: 
 151: /* offsets for INQUIRE statement */
 152: 
 153: #define XFILE   SZFLAG + SZIOINT
 154: #define XFILELEN    SZFLAG + SZIOINT + SZADDR
 155: #define XEXISTS SZFLAG + 2*SZIOINT + SZADDR
 156: #define XOPEN   SZFLAG + 2*SZIOINT + 2*SZADDR
 157: #define XNUMBER SZFLAG + 2*SZIOINT + 3*SZADDR
 158: #define XNAMED  SZFLAG + 2*SZIOINT + 4*SZADDR
 159: #define XNAME   SZFLAG + 2*SZIOINT + 5*SZADDR
 160: #define XNAMELEN    SZFLAG + 2*SZIOINT + 6*SZADDR
 161: #define XQACCESS    SZFLAG + 3*SZIOINT + 6*SZADDR
 162: #define XQACCLEN    SZFLAG + 3*SZIOINT + 7*SZADDR
 163: #define XSEQ    SZFLAG + 4*SZIOINT + 7*SZADDR
 164: #define XSEQLEN SZFLAG + 4*SZIOINT + 8*SZADDR
 165: #define XDIRECT SZFLAG + 5*SZIOINT + 8*SZADDR
 166: #define XDIRLEN SZFLAG + 5*SZIOINT + 9*SZADDR
 167: #define XFORM   SZFLAG + 6*SZIOINT + 9*SZADDR
 168: #define XFORMLEN    SZFLAG + 6*SZIOINT + 10*SZADDR
 169: #define XFMTED  SZFLAG + 7*SZIOINT + 10*SZADDR
 170: #define XFMTEDLEN   SZFLAG + 7*SZIOINT + 11*SZADDR
 171: #define XUNFMT  SZFLAG + 8*SZIOINT + 11*SZADDR
 172: #define XUNFMTLEN   SZFLAG + 8*SZIOINT + 12*SZADDR
 173: #define XQRECL  SZFLAG + 9*SZIOINT + 12*SZADDR
 174: #define XNEXTREC    SZFLAG + 9*SZIOINT + 13*SZADDR
 175: #define XQBLANK SZFLAG + 9*SZIOINT + 14*SZADDR
 176: #define XQBLANKLEN  SZFLAG + 9*SZIOINT + 15*SZADDR
 177: 
 178: fmtstmt(lp)
 179: register struct labelblock *lp;
 180: {
 181: if(lp == NULL)
 182:     {
 183:     error("unlabeled format statement" , 0,0,EXECERR);
 184:     return(-1);
 185:     }
 186: if(lp->labtype == LABUNKNOWN)
 187:     {
 188:     lp->labtype = LABFORMAT;
 189:     lp->labelno = newlabel();
 190:     }
 191: else if(lp->labtype != LABFORMAT)
 192:     {
 193:     error("bad format number", 0,0,EXECERR);
 194:     return(-1);
 195:     }
 196: return(lp->labelno);
 197: }
 198: 
 199: 
 200: 
 201: setfmt(lp)
 202: struct labelblock *lp;
 203: {
 204: ftnint n;
 205: char *s, *lexline();
 206: 
 207: s = lexline(&n);
 208: preven(ALILONG);
 209: prlabel(asmfile, lp->labelno);
 210: putstr(asmfile, s, n);
 211: flline();
 212: }
 213: 
 214: 
 215: 
 216: startioctl()
 217: {
 218: register int i;
 219: 
 220: ioecdc = NULL;                      /* E-D */
 221: inioctl = YES;
 222: nioctl = 0;
 223: ioformatted = UNFORMATTED;
 224: for(i = 1 ; i<=NIOS ; ++i)
 225:     V(i) = NULL;
 226: }
 227: 
 228: 
 229: 
 230: iosetecdc(e)                        /* E-D */
 231: expptr e;                       /* E-D */
 232: {                           /* E-D */
 233:     ioecdc = e;                 /* E-D */
 234: }                           /* E-D */
 235: 
 236: 
 237: 
 238: endioctl()
 239: {
 240: int i;
 241: expptr p;
 242: struct labelblock *mklabel();
 243: 
 244: inioctl = NO;
 245: if(ioblkp == NULL)
 246:     ioblkp = autovar( (MAXIO+SZIOINT-1)/SZIOINT , TYIOINT, NULL);
 247: 
 248: /* set up for error recovery */
 249: 
 250: ioerrlab = ioendlab = jumplab = 0;
 251: skiplab = iosreturn = NO;
 252: 
 253: if(p = V(IOSEND))
 254:     if(ISICON(p))
 255:         ioendlab = mklabel(p->const.ci)->labelno;
 256:     else
 257:         error("bad end= clause",0,0,ERR);
 258: 
 259: if(p = V(IOSERR))
 260:     if(ISICON(p))
 261:         ioerrlab = mklabel(p->const.ci)->labelno;
 262:     else
 263:         error("bad err= clause",0,0,ERR);
 264: 
 265: if(IOSTP)
 266:     if(IOSTP->tag!=TADDR || ! ISINT(IOSTP->vtype) )
 267:         {
 268:         error("iostat must be an integer variable",0,0,ERR);
 269:         frexpr(IOSTP);
 270:         IOSTP = NULL;
 271:         }
 272: #ifdef IOSRETURN
 273:     else
 274:         iosreturn = YES;
 275: 
 276: if(iosreturn && IOSRW && !(ioerrlab && ioendlab) )
 277:     {
 278:     jumplab = newlabel();
 279:     iostest = OPEQ;
 280:     if(ioerrlab || ioendlab) skiplab = YES;
 281:     }
 282: else if(ioerrlab && !ioendlab)
 283: 
 284: #else
 285: if(ioerrlab && !ioendlab)
 286: #endif
 287:     {
 288:     jumplab = ioerrlab;
 289:     iostest = IOSRW ? OPLE : OPEQ;
 290:     }
 291: else if(!ioerrlab && ioendlab)
 292:     {
 293:     jumplab = ioendlab;
 294:     iostest = OPGE;
 295:     }
 296: else if(ioerrlab && ioendlab)
 297:     {
 298:     iostest = OPEQ;
 299:     if(ioerrlab == ioendlab)
 300:         jumplab = ioerrlab;
 301:     else
 302:         {
 303:         if(!IOSTP) IOSTP = mktemp(TYINT, NULL);
 304:         jumplab = newlabel();
 305:         skiplab = YES;
 306:         }
 307:     }
 308: /*else if(IOSTP)  /* the standard requires this return! */
 309: /*	{
 310: /*	iosreturn = YES;
 311: /*	if(iostmt==IOREAD || iostmt==IOWRITE)
 312: /*		{
 313: /*		jumplab = newlabel();
 314: /*		iostest = OPEQ;
 315: /*		}
 316: /*	}
 317:  */
 318: 
 319: 
 320: ioset(TYIOINT, XERR, ICON(ioerrlab!=0 || iosreturn) );
 321: 
 322: switch(iostmt)
 323:     {
 324:     case IOOPEN:
 325:         dofopen();  break;
 326: 
 327:     case IOCLOSE:
 328:         dofclose();  break;
 329: 
 330:     case IOINQUIRE:
 331:         dofinquire();  break;
 332: 
 333:     case IOBACKSPACE:
 334:         dofmove("f_back"); break;
 335: 
 336:     case IOREWIND:
 337:         dofmove("f_rew");  break;
 338: 
 339:     case IOENDFILE:
 340:         dofmove("f_end");  break;
 341: 
 342:     case IOREAD:
 343:     case IOWRITE:
 344:         startrw();  break;
 345: 
 346:     default:
 347:         error("impossible iostmt %d", iostmt,0,FATAL1);
 348:     }
 349: for(i = 1 ; i<=NIOS ; ++i)
 350:     if(i!=IOSIOSTAT && V(i)!=NULL)
 351:         frexpr(V(i));
 352: }
 353: 
 354: 
 355: 
 356: iocname()
 357: {
 358: register int i;
 359: int found, mask;
 360: 
 361: found = 0;
 362: mask = M(iostmt);
 363: for(i = 1 ; i <= NIOS ; ++i)
 364:     if(toklen==strlen(ioc[i].iocname) && eqn(toklen, token, ioc[i].iocname))
 365:         if(ioc[i].iotype & mask)
 366:             return(i);
 367:         else    found = i;
 368: if(found)
 369:     error("invalid control %s for statement", ioc[found].iocname,0,ERR1);
 370: else
 371:     error("unknown iocontrol %s", varstr(toklen, token),0,ERR1 );
 372: return(IOSBAD);
 373: }
 374: 
 375: 
 376: ioclause(n, p)
 377: register int n;
 378: register expptr p;
 379: {
 380: struct ioclist *iocp;
 381: 
 382: ++nioctl;
 383: if(n == IOSBAD)
 384:     return;
 385: if(n == IOSPOSITIONAL)
 386:     {
 387:     if(nioctl > IOSFMT)
 388:         {
 389:         error("illegal positional iocontrol",0,0,ERR);
 390:         return;
 391:         }
 392:     n = nioctl;
 393:     }
 394: 
 395: if(p == NULL)
 396:     {
 397:     if(n == IOSUNIT)
 398:         p = (iostmt==IOREAD ? IOSTDIN : IOSTDOUT);
 399:     else if(n != IOSFMT)
 400:         {
 401:         error("illegal * iocontrol",0,0,ERR);
 402:         return;
 403:         }
 404:     }
 405: if(n == IOSFMT)
 406:     ioformatted = (p==NULL ? LISTDIRECTED : FORMATTED);
 407: 
 408: iocp = & ioc[n];
 409: if(iocp->iocval == NULL)
 410:     {
 411:     if( !ioecdc )                   /* E-D */
 412:         if(n!=IOSFMT && ( n!=IOSUNIT || (p!=NULL && p->vtype!=TYCHAR) ) )
 413:             p = fixtype(p);
 414:     iocp->iocval = p;
 415: }
 416: else
 417:     error("iocontrol %s repeated", iocp->iocname,0,ERR1);
 418: }
 419: 
 420: /* io list item */
 421: 
 422: doio(list)
 423: chainp list;
 424: {
 425: struct exprblock *call0();
 426: doiolist(list);
 427: ioroutine[0] = 'e';
 428: putiocall( call0(TYINT, ioroutine) );
 429: }
 430: 
 431: 
 432: 
 433: 
 434: 
 435: LOCAL doiolist(p0)
 436: chainp p0;
 437: {
 438: chainp p;
 439: register tagptr q;
 440: register expptr qe;
 441: register struct nameblock *qn;
 442: struct addrblock *tp, *mkscalar();
 443: int range;
 444: 
 445: for (p = p0 ; p ; p = p->nextp)
 446:     {
 447:     q = p->datap;
 448:     if(q->tag == TIMPLDO)
 449:         {
 450:         exdo(range=newlabel(), q->varnp);
 451:         doiolist(q->datalist);
 452:         enddo(range);
 453:         free(q);
 454:         }
 455:     else    {
 456:         if(q->tag==TPRIM && q->argsp==NULL
 457:             && q->namep->vdim!=NULL)
 458:             {
 459:             vardcl(qn = q->namep);
 460:             if(qn->vdim->nelt)
 461:                 putio( fixtype(cpexpr(qn->vdim->nelt)),
 462:                     mkscalar(qn) );
 463:             else
 464:                 error("attempt to i/o array of unknown size",0,0,ERR);
 465:             }
 466:         else if(q->tag==TPRIM && q->argsp==NULL &&
 467:             (qe = memversion(q->namep)) )
 468:             putio(ICON(1),qe);
 469:         else if( (qe = fixtype(cpexpr(q)))->tag==TADDR)
 470:             putio(ICON(1), qe);
 471:         else if(qe->vtype != TYERROR)
 472:             {
 473:             if(iostmt == IOWRITE)
 474:                 {
 475:                 tp = mktemp(qe->vtype, qe->vleng);
 476:                 puteq( cpexpr(tp), qe);
 477:                 putio(ICON(1), tp);
 478:                 }
 479:             else
 480: /*				error("non-left side in READ list",0,0,ERR);
 481: */
 482: /*! changed error message PLWard 10/80 */
 483:                 error("function in READ list",0,0,ERR);
 484:             }
 485:         frexpr(q);
 486:         }
 487:     }
 488: frchain( &p0 );
 489: }
 490: 
 491: 
 492: 
 493: 
 494: 
 495: LOCAL putio(nelt, addr)
 496: expptr nelt;
 497: register expptr addr;
 498: {
 499: int type;
 500: register struct exprblock *q;
 501: struct exprblock *call2(), *call3();
 502: 
 503: type = addr->vtype;
 504: if(ioformatted!=LISTDIRECTED && ISCOMPLEX(type) )
 505:     {
 506:     nelt = mkexpr(OPSTAR, ICON(2), nelt);
 507:     type -= (TYCOMPLEX-TYREAL);
 508:     }
 509: 
 510: /* pass a length with every item.  for noncharacter data, fake one */
 511: if(type != TYCHAR)
 512:     {
 513:     if( ISCONST(addr) )
 514:         addr = putconst(addr);
 515:     addr->vtype = TYCHAR;
 516:     addr->vleng = ICON( typesize[type] );
 517:     }
 518: 
 519: nelt = fixtype( mkconv(TYLENG,nelt) );
 520: if(ioformatted == LISTDIRECTED)
 521:     q = call3(TYINT, "do_lio", mkconv(TYLONG, ICON(type)), nelt, addr);
 522: else
 523:     q = call2(TYINT, (ioformatted==FORMATTED ? "do_fio" : "do_uio"),
 524:         nelt, addr);
 525: putiocall(q);
 526: }
 527: 
 528: 
 529: 
 530: 
 531: endio()
 532: {
 533: if(skiplab)
 534:     {
 535:     putlabel(jumplab);
 536:     if(ioendlab) putif( mkexpr(OPGE, cpexpr(IOSTP), ICON(0)), ioendlab);
 537:     if(ioerrlab) putif( mkexpr(OPLE, cpexpr(IOSTP), ICON(0)), ioerrlab);
 538:     }
 539: else if(iosreturn && jumplab)
 540:     putlabel(jumplab);
 541: if(IOSTP)
 542:     frexpr(IOSTP);
 543: }
 544: 
 545: 
 546: 
 547: LOCAL putiocall(q)
 548: register struct exprblock *q;
 549: {
 550: if(IOSTP)
 551:     {
 552:     q->vtype = TYINT;
 553:     q = fixexpr( mkexpr(OPASSIGN, cpexpr(IOSTP), q));
 554:     }
 555: 
 556: if(jumplab)
 557:     putif( mkexpr(iostest, q, ICON(0) ), jumplab);
 558: else
 559:     putexpr(q);
 560: }
 561: 
 562: 
 563: startrw()
 564: {
 565: register expptr p;
 566: register struct nameblock *np;
 567: register struct addrblock *unitp, *nump;
 568: struct constblock *mkaddcon();
 569: int k, fmtoff;
 570: int intfile, sequential;
 571: 
 572: intfile = NO;
 573: if(p = V(IOSUNIT))
 574:     {
 575:     if( ISINT(p->vtype) )
 576:         ioset(TYIOINT, XUNIT, cpexpr(p) );
 577:     else if( ioecdc || p->vtype == TYCHAR)      /* E-D */
 578:         {
 579:         intfile = YES;
 580:         if(p->tag==TPRIM && p->argsp==NULL &&
 581:             (np = p->namep)->vdim!=NULL)
 582:             {
 583:             vardcl(np);
 584:             if( ioecdc )            /* E-D */
 585:                 nump = ICON(1);     /* E-D */
 586:             else if(np->vdim->nelt)     /* E-D */
 587:                 nump = cpexpr(np->vdim->nelt);
 588:             else
 589:                 {
 590:                 error("attempt to use internal unit array of unknown size",0,0,ERR);
 591:                 nump = ICON(1);
 592:                 }
 593:             unitp = mkscalar(np);
 594:             }
 595:         else    {
 596:             nump = ICON(1);
 597:             unitp = fixtype(cpexpr(p));
 598:             }
 599:         if( ioecdc )                /* E-D */
 600:             {               /* E-D */
 601:             frexpr( unitp->vleng );     /* E-D */
 602:             unitp->vleng = ioecdc;      /* E-D */
 603:             }               /* E-D */
 604:         ioset(TYIOINT, XIRNUM, nump);
 605:         ioset(TYIOINT, XIRLEN, cpexpr(unitp->vleng) );
 606:         ioset(TYADDR, XIUNIT, addrof(unitp) );
 607:         }
 608:     }
 609: else
 610:     error("bad unit specifier",0,0,ERR);
 611: 
 612: sequential = YES;
 613: if(p = V(IOSREC))
 614:     if( ISINT(p->vtype) )
 615:         {
 616:         ioset(TYIOINT, (intfile ? XIREC : XREC), cpexpr(p) );
 617:         sequential = NO;
 618:         }
 619:     else
 620:         error("bad REC= clause",0,0,ERR);
 621: 
 622: ioset(TYIOINT, (intfile ? XIEND : XEND), ICON(ioendlab!=0 || iosreturn) );
 623: 
 624: fmtoff = (intfile ? XIFMT : XFMT);
 625: 
 626: if(p = V(IOSFMT))
 627:     {
 628:     if(p->tag==TPRIM && p->argsp==NULL)
 629:         {
 630:         vardcl(np = p->namep);
 631:         if(np->vdim)
 632:             {
 633:             ioset(TYADDR, fmtoff, addrof(mkscalar(np)) );
 634:             goto endfmt;
 635:             }
 636:         if( ISINT(np->vtype) )
 637:             {
 638:             ioset(TYADDR, fmtoff, p);
 639:             goto endfmt;
 640:             }
 641:         }
 642:     p = V(IOSFMT) = fixtype(p);
 643:     if(p->vtype == TYCHAR)
 644:         ioset(TYADDR, fmtoff, addrof(cpexpr(p)) );
 645:     else if( ISICON(p) )
 646:         {
 647:         if( (k = fmtstmt( mklabel(p->const.ci) )) > 0 )
 648:             ioset(TYADDR, fmtoff, mkaddcon(k) );
 649:         else
 650:             ioformatted = UNFORMATTED;
 651:         }
 652:     else    {
 653:         error("bad format descriptor",0,0,ERR);
 654:         ioformatted = UNFORMATTED;
 655:         }
 656:     }
 657: else
 658:     ioset(TYADDR, fmtoff, ICON(0) );
 659: 
 660: endfmt:
 661:     if(intfile && ioformatted==UNFORMATTED)
 662:         error("unformatted internal I/O not allowed",0,0,ERR);
 663:     if(!sequential && ioformatted==LISTDIRECTED)
 664:         error("direct list-directed I/O not allowed",0,0,ERR);
 665: 
 666: ioroutine[0] = 's';
 667: ioroutine[1] = '_';
 668: ioroutine[2] = (iostmt==IOREAD ? 'r' : 'w');
 669: ioroutine[3] = (sequential ? 's' : 'd');
 670: ioroutine[4] = "ufl" [ioformatted];
 671: ioroutine[5] = (intfile ? 'i' : 'e');
 672: ioroutine[6] = '\0';
 673: putiocall( call1(TYINT, ioroutine, cpexpr(ioblkp) ));
 674: }
 675: 
 676: 
 677: 
 678: LOCAL dofopen()
 679: {
 680: register expptr p;
 681: 
 682: if( (p = V(IOSUNIT)) && ISINT(p->vtype) )
 683:     ioset(TYIOINT, XUNIT, cpexpr(p) );
 684: else
 685:     error("bad unit in open",0,0,ERR);
 686: if( (p = V(IOSFILE)) )
 687:     if(p->vtype == TYCHAR)
 688:         ioset(TYIOINT, XFNAMELEN, cpexpr(p->vleng) );
 689:     else
 690:         error("bad file in open",0,0,ERR);
 691: 
 692: iosetc(XFNAME, p);
 693: 
 694: if(p = V(IOSRECL))
 695:     if( ISINT(p->vtype) )
 696:         ioset(TYIOINT, XRECLEN, cpexpr(p) );
 697:     else
 698:         error("bad recl",0,0,ERR);
 699: else
 700:     ioset(TYIOINT, XRECLEN, ICON(0) );
 701: 
 702: iosetc(XSTATUS, V(IOSSTATUS));
 703: iosetc(XACCESS, V(IOSACCESS));
 704: iosetc(XFORMATTED, V(IOSFORM));
 705: iosetc(XBLANK, V(IOSBLANK));
 706: 
 707: putiocall( call1(TYINT, "f_open", cpexpr(ioblkp) ));
 708: }
 709: 
 710: 
 711: LOCAL dofclose()
 712: {
 713: register expptr p;
 714: 
 715: if( (p = V(IOSUNIT)) && ISINT(p->vtype) )
 716:     {
 717:     ioset(TYIOINT, XUNIT, cpexpr(p) );
 718:     iosetc(XCLSTATUS, V(IOSSTATUS));
 719:     putiocall( call1(TYINT, "f_clos", cpexpr(ioblkp)) );
 720:     }
 721: else
 722:     error("bad unit in close statement",0,0,ERR);
 723: }
 724: 
 725: 
 726: LOCAL dofinquire()
 727: {
 728: register expptr p;
 729: if(p = V(IOSUNIT))
 730:     {
 731:     if( V(IOSFILE) )
 732:         error("inquire by unit or by file, not both",0,0,ERR);
 733:     ioset(TYIOINT, XUNIT, cpexpr(p) );
 734:     }
 735: else if( ! V(IOSFILE) )
 736:     error("must inquire by unit or by file",0,0,ERR);
 737: iosetlc(IOSFILE, XFILE, XFILELEN);
 738: iosetip(IOSEXISTS, XEXISTS);
 739: iosetip(IOSOPENED, XOPEN);
 740: iosetip(IOSNUMBER, XNUMBER);
 741: iosetip(IOSNAMED, XNAMED);
 742: iosetlc(IOSNAME, XNAME, XNAMELEN);
 743: iosetlc(IOSACCESS, XQACCESS, XQACCLEN);
 744: iosetlc(IOSSEQUENTIAL, XSEQ, XSEQLEN);
 745: iosetlc(IOSDIRECT, XDIRECT, XDIRLEN);
 746: iosetlc(IOSFORM, XFORM, XFORMLEN);
 747: iosetlc(IOSFORMATTED, XFMTED, XFMTEDLEN);
 748: iosetlc(IOSUNFORMATTED, XUNFMT, XUNFMTLEN);
 749: iosetip(IOSRECL, XQRECL);
 750: iosetip(IOSNEXTREC, XNEXTREC);
 751: iosetlc(IOSBLANK, XQBLANK, XQBLANKLEN);
 752: 
 753: putiocall( call1(TYINT,  "f_inqu", cpexpr(ioblkp) ));
 754: }
 755: 
 756: 
 757: 
 758: LOCAL dofmove(subname)
 759: char *subname;
 760: {
 761: register expptr p;
 762: 
 763: if( (p = V(IOSUNIT)) && ISINT(p->vtype) )
 764:     {
 765:     ioset(TYIOINT, XUNIT, cpexpr(p) );
 766:     putiocall( call1(TYINT, subname, cpexpr(ioblkp) ));
 767:     }
 768: else
 769:     error("bad unit in I/O motion statement",0,0,ERR);
 770: }
 771: 
 772: 
 773: 
 774: LOCAL ioset(type, offset, p)
 775: int type, offset;
 776: expptr p;
 777: {
 778: register struct addrblock *q;
 779: 
 780: q = cpexpr(ioblkp);
 781: q->vtype = type;
 782: q->memoffset = fixtype( mkexpr(OPPLUS, q->memoffset, ICON(offset)) );
 783: puteq(q, p);
 784: }
 785: 
 786: 
 787: 
 788: 
 789: LOCAL iosetc(offset, p)
 790: int offset;
 791: register expptr p;
 792: {
 793: if(p == NULL)
 794:     ioset(TYADDR, offset, ICON(0) );
 795: else if(p->vtype == TYCHAR)
 796:     ioset(TYADDR, offset, addrof(cpexpr(p) ));
 797: else
 798:     error("non-character control clause",0,0,ERR);
 799: }
 800: 
 801: 
 802: 
 803: LOCAL iosetip(i, offset)
 804: int i, offset;
 805: {
 806: register expptr p;
 807: 
 808: if(p = V(i))
 809:     if(p->tag==TADDR &&
 810:         ONEOF(p->vtype, M(TYLONG)|M(TYLOGICAL)) )
 811:         ioset(TYADDR, offset, addrof(cpexpr(p)) );
 812:     else
 813:         error("impossible inquire parameter %s", ioc[i].iocname,0,ERR1);
 814: else
 815:     ioset(TYADDR, offset, ICON(0) );
 816: }
 817: 
 818: 
 819: 
 820: LOCAL iosetlc(i, offp, offl)
 821: int i, offp, offl;
 822: {
 823: register expptr p;
 824: if( (p = V(i)) && p->vtype==TYCHAR)
 825:     ioset(TYIOINT, offl, cpexpr(p->vleng) );
 826: iosetc(offp, p);
 827: }

Defined functions

Defined variables

Defined struct's

Defined macros