4.3BSD - /usr/src/usr.bin/efl/io.c

   1: #include <ctype.h>
   2: 
   3: #include "defs"
   4: 
   5: static int lastfmtchar;
   6: static int writeop;
   7: static int needcomma;
   8: 
   9: 
  10: ptr mkiost(kwd,unit,list)
  11: int kwd;
  12: ptr unit;
  13: ptr list;
  14: {
  15: register ptr p;
  16: 
  17: if(unit!=NULL && unit->vtype!=TYINT)
  18:     {
  19:     execerr("I/O unit must be an integer", "");
  20:     return(NULL);
  21:     }
  22: p = allexpblock();
  23: p->tag = TIOSTAT;
  24: p->vtype = TYINT;
  25: p->iokwd = kwd;
  26: p->iounit = unit;
  27: p->iolist = list;
  28: 
  29: return(p);
  30: }
  31: 
  32: 
  33: 
  34: 
  35: struct iogroup *mkiogroup(list, format, dop)
  36: ptr list;
  37: char *format;
  38: ptr dop;
  39: {
  40: register struct iogroup *p;
  41: 
  42: p = ALLOC(iogroup);
  43: p->tag = TIOGROUP;
  44: p->doptr = dop;
  45: p->iofmt = format;
  46: p->ioitems = list;
  47: return(p);
  48: }
  49: 
  50: ptr exio(iostp, errhandle)
  51: struct iostblock *iostp;
  52: int errhandle;
  53: {
  54: ptr unit, list;
  55: int fmtlabel, errlabel, endlabel, jumplabel;
  56: ptr errval;
  57: int fmtio;
  58: 
  59: if(iostp == NULL)
  60:     return( errnode() );
  61: unit = iostp->iounit;
  62: list = iostp->iolist;
  63: 
  64: /* kwd=	0  binary input 	2  formatted input
  65: 	1  binary output	3  formatted output
  66: */
  67: 
  68: writeop = iostp->iokwd & 01;
  69: if( fmtio = (iostp->iokwd & 02) )
  70:     fmtlabel = nextlab() ;
  71: frexpblock(iostp);
  72: 
  73: errval = 0;
  74: endlabel = 0;
  75: if(errhandle)
  76:     {
  77:     switch(tailor.errmode)
  78:         {
  79:         default:
  80:             execerr("no error handling ", "");
  81:             return( errnode() );
  82: 
  83:         case IOERRIBM:  /* ibm: err=, end= */
  84:             jumplabel = nextlab();
  85:             break;
  86: 
  87:         case IOERRFORT77:   /* New Fortran Standard: iostat= */
  88:             break;
  89: 
  90:         }
  91:     errval = gent(TYINT, PNULL);
  92:     }
  93: if(unit)
  94:     unit = simple(RVAL, unit);
  95: else    unit = mkint(writeop ? tailor.ftnout : tailor.ftnin);
  96: 
  97: if(unit->tag!=TCONST && (unit->tag!=TNAME || unit->vsubs!=0))
  98:     unit = simple(LVAL, mknode(TASGNOP,OPASGN,gent(TYINT,PNULL),unit));
  99: 
 100: simlist(list);
 101: 
 102: exlab(0);
 103: putic(ICKEYWORD, (writeop ? FWRITE : FREAD) );
 104: putic(ICOP, OPLPAR);
 105: prexpr(unit);
 106: frexpr(unit);
 107: 
 108: if( fmtio )
 109:     {
 110:     putic(ICOP, OPCOMMA);
 111:     putic(ICLABEL, fmtlabel);
 112:     }
 113: 
 114: if(errhandle) switch(tailor.errmode)
 115:     {
 116:     case IOERRIBM:
 117:         putic(ICOP,OPCOMMA);
 118:         putsii(ICCONST, "err =");
 119:         putic(ICLABEL, errlabel = nextlab() );
 120:         if(!writeop)
 121:             {
 122:             putic(ICOP,OPCOMMA);
 123:             putsii(ICCONST, "end =");
 124:             putic(ICLABEL, endlabel = nextlab() );
 125:             }
 126:         break;
 127: 
 128:     case IOERRFORT77:
 129:         putic(ICOP,OPCOMMA);
 130:         putsii(ICCONST, "iostat =");
 131:         putname(errval);
 132:         break;
 133:     }
 134: 
 135: putic(ICOP,OPRPAR);
 136: putic(ICBLANK, 1);
 137: 
 138: needcomma = NO;
 139: doiolist(list);
 140: if(fmtio)
 141:     {
 142:     exlab(fmtlabel);
 143:     putic(ICKEYWORD, FFORMAT);
 144:     putic(ICOP, OPLPAR);
 145:     lastfmtchar = '(';
 146:     doformat(1, list);
 147:     putic(ICOP, OPRPAR);
 148:     }
 149: friolist(list);
 150: 
 151: if(errhandle && tailor.errmode==IOERRIBM)
 152:     {
 153:     exasgn(cpexpr(errval), OPASGN, mkint(0) );
 154:     exgoto(jumplabel);
 155:     exlab(errlabel);
 156:     exasgn(cpexpr(errval), OPASGN, mkint(1) );
 157:     if(endlabel)
 158:         {
 159:         exgoto(jumplabel);
 160:         exlab(endlabel);
 161:         exasgn(cpexpr(errval), OPASGN,
 162:             mknode(TNEGOP,OPMINUS,mkint(1),PNULL) );
 163:         }
 164:     exlab(jumplabel);
 165:     }
 166: 
 167: return( errval );
 168: }
 169: 
 170: doiolist(list)
 171: ptr list;
 172: {
 173: register ptr p, q;
 174: register struct doblock *dop;
 175: for(p = list ; p ; p = p->nextp)
 176:     {
 177:     switch( (q = p->datap) ->tag)
 178:         {
 179:         case TIOGROUP:
 180:             if(dop = q->doptr)
 181:                 {
 182:                 if(needcomma)
 183:                     putic(ICOP, OPCOMMA);
 184:                 putic(ICOP, OPLPAR);
 185:                 needcomma = NO;
 186:                 }
 187:             doiolist(q->ioitems);
 188:             if(dop)
 189:                 {
 190:                 putic(ICOP,OPCOMMA);
 191:                 prexpr(dop->dovar);
 192:                 putic(ICOP, OPEQUALS);
 193:                 prexpr(dop->dopar[0]);
 194:                 putic(ICOP, OPCOMMA);
 195:                 prexpr(dop->dopar[1]);
 196:                 if(dop->dopar[2])
 197:                     {
 198:                     putic(ICOP, OPCOMMA);
 199:                     prexpr(dop->dopar[2]);
 200:                     }
 201:                 putic(ICOP, OPRPAR);
 202:                 needcomma = YES;
 203:                 }
 204:             break;
 205: 
 206:         case TIOITEM:
 207:             if(q->ioexpr)
 208:                 {
 209:                 if(needcomma)
 210:                     putic(ICOP, OPCOMMA);
 211:                 prexpr(q->ioexpr);
 212:                 needcomma = YES;
 213:                 }
 214:             break;
 215: 
 216:         default:
 217:             badtag("doiolist", q->tag);
 218:         }
 219:     }
 220: }
 221: 
 222: doformat(nrep, list)
 223: int nrep;
 224: ptr list;
 225: {
 226: register ptr p, q;
 227: int k;
 228: ptr arrsize();
 229: 
 230: if(nrep > 1)
 231:     {
 232:     fmtnum(nrep);
 233:     fmtop(OPLPAR);
 234:     }
 235: 
 236: for(p = list ; p ; p = p->nextp)
 237:     switch( (q = p->datap) ->tag)
 238:         {
 239:         case TIOGROUP:
 240:             if(q->iofmt)
 241:                 prfmt(q->nrep, q->iofmt);
 242:             else    {
 243:                 doformat(q->nrep>0 ? q->nrep :
 244:                     (q->doptr ? repfac(q->doptr) : 1),
 245:                     q->ioitems);
 246:                 }
 247:             break;
 248: 
 249:         case TIOITEM:
 250:             if(q->iofmt == NULL)
 251:                 break;
 252: 
 253:             if(q->nrep==0 && q->ioexpr && q->ioexpr->vdim)
 254:                 {
 255:                 if( ! isicon(arrsize(q->ioexpr), &k) )
 256:                     execerr("io of adjustable array", "");
 257:                 else
 258:                     prfmt(k, q->iofmt);
 259:                 }
 260:             else
 261:                 prfmt(q->nrep, q->iofmt);
 262:         }
 263: if(nrep > 1)
 264:     fmtop(OPRPAR);
 265: }
 266: 
 267: fmtop(op)
 268: register int op;
 269: {
 270: register c;
 271: 
 272: c = (op==OPLPAR ? '(' : (op==OPRPAR ? ')' : 'x') );
 273: fmtcom(c);
 274: putic(ICOP, op);
 275: lastfmtchar = c;
 276: }
 277: 
 278: 
 279: 
 280: 
 281: fmtnum(k)
 282: int k;
 283: {
 284: fmtcom('1');
 285: prexpr( mkint(k) );
 286: lastfmtchar = ',';  /* prevent further comma after factor*/
 287: }
 288: 
 289: 
 290: 
 291: 
 292: 
 293: 
 294: 
 295: 
 296: /* separate formats with comma unless already a slash*/
 297: fmtcom(c)
 298: int c;
 299: {
 300: if( c!='/' && c!=')' && lastfmtchar!='/' && lastfmtchar!='(' && lastfmtchar!=',' )
 301:     {
 302:     putic(ICOP, OPCOMMA);
 303:     lastfmtchar = ',';
 304:     }
 305: }
 306: 
 307: prfmt(nrep, str)
 308: int nrep;
 309: char *str;
 310: {
 311: char fmt[20];
 312: register int k, k0, k1, k2;
 313: register char *t;
 314: 
 315: fmtcom(nrep>1 ? '1' : str[0]);
 316: 
 317: if(nrep > 1)
 318:     {
 319:     fmtnum(nrep);
 320:     fmtop(OPLPAR);
 321:     }
 322: 
 323: switch(str[0])
 324:     {
 325:     case 'd':
 326:     case 'e':
 327:     case 'g':
 328:         if(writeop)
 329:             {
 330:             putsii(ICCONST, "1p");
 331:             break;
 332:             }
 333: 
 334:     case 'f':
 335:         putsii(ICCONST, "0p");
 336:         break;
 337: 
 338:     case 'c':
 339:         k = convci(str+1);
 340:         k0 = tailor.ftnchwd;
 341:         k1 = k / k0;
 342:         k2 = k % k0;
 343:         if(k1>0 && k2>0)
 344:             sprintf(fmt, "(%da%d,a%d)",k1,k0,k2);
 345:         else if(k1>1)
 346:             sprintf(fmt, "(%da%d)", k1, k0);
 347:         else    sprintf(fmt, "a%d", k);
 348:         putsii(ICCONST, fmt);
 349:         lastfmtchar = 'f';  /* last char isnt operator */
 350:         goto close;
 351: 
 352:     default:
 353:         break;
 354:     }
 355: putsii(ICCONST,str);
 356: /* if the format is an nH, act as if it ended with a non-operator character */
 357: if( isdigit(str[0]) )
 358:     {
 359:     for(t = str+1 ; isdigit(*t) ; ++t);
 360:         ;
 361:     if(*t=='h' || *t=='H')
 362:         {
 363:         lastfmtchar = 'f';
 364:         goto close;
 365:         }
 366:     }
 367: lastfmtchar = str[ strlen(str)-1 ];
 368: 
 369: close:
 370:     if(nrep > 1)
 371:         fmtop(OPRPAR);
 372: }
 373: 
 374: friolist(list)
 375: ptr list;
 376: {
 377: register ptr p, q;
 378: register struct doblock *dop;
 379: 
 380: for(p = list; p; p = p->nextp)
 381:     {
 382:     switch ( (q = p->datap) ->tag)
 383:         {
 384:         case TIOGROUP:
 385:             if(dop = q->doptr)
 386:                 {
 387:                 frexpr(dop->dovar);
 388:                 frexpr(dop->dopar[0]);
 389:                 frexpr(dop->dopar[1]);
 390:                 if(dop->dopar[2])
 391:                     frexpr(dop->dopar[2]);
 392:                 cfree(dop);
 393:                 }
 394:             friolist(q->ioitems);
 395:             break;
 396: 
 397:         case TIOITEM:
 398:             if(q->ioexpr)
 399:                 frexpr(q->ioexpr);
 400:             break;
 401: 
 402:         default:
 403:             badtag("friolist", q->tag);
 404:         }
 405:     if(q->iofmt)
 406:         cfree(q->iofmt);
 407:     cfree(q);
 408:     }
 409: frchain( &list );
 410: }
 411: 
 412: simlist(p)
 413: register ptr p;
 414: {
 415: register ptr q, ep;
 416: struct iogroup *enloop();
 417: 
 418: for( ; p ; p = p->nextp)
 419:     switch( (q = p->datap) ->tag )
 420:         {
 421:         case TIOGROUP:
 422:             simlist(q->ioitems);
 423:             break;
 424: 
 425:         case TIOITEM:
 426:             if(ep = q->ioexpr)
 427:                 {
 428:                 /* if element is a subaggregate, need
 429: 				   an implied do loop */
 430:                 if( (ep->voffset || ep->vsubs) &&
 431:                     (ep->vdim || ep->vtypep) )
 432:                     p->datap = enloop(q);
 433:                 else
 434:                     q->ioexpr = simple(LVAL,ep);
 435:                 }
 436:             break;
 437: 
 438:         default:
 439:             badtag("ioblock", q->tag);
 440:         }
 441: }
 442: 
 443: 
 444: 
 445: 
 446: /* replace an aggregate by an implied do loop of elements */
 447: 
 448: struct iogroup *enloop(p)
 449: struct ioitem *p;
 450: {
 451: register struct doblock *dop;
 452: struct iogroup *gp;
 453: ptr np, q, v, arrsize(), mkioitem();
 454: int nrep, k, nwd;
 455: 
 456: q = p->ioexpr;
 457: np = arrsize(q);
 458: if( ! isicon(np, &nrep) )
 459:     nrep = 0;
 460: 
 461: if(q->vtype == TYCHAR)
 462:     {
 463:     nwd = ceil(conval(q->vtypep), tailor.ftnchwd);
 464:     if(nwd != 1)
 465:         np = simple(LVAL, mknode(TAROP,OPSTAR,np,mkint(nwd)));
 466:     }
 467: else
 468:     nwd = 0;
 469: 
 470: if( isicon(np, &k) && k==1)
 471:     return(p);
 472: 
 473: dop = ALLOC(doblock);
 474: dop->tag = TDOBLOCK;
 475: 
 476: dop->dovar = v = gent(TYINT, PNULL);
 477: dop->dopar[0] = mkint(1);
 478: dop->dopar[1] = simple(SUBVAL, np);
 479: dop->dopar[2] = NULL;
 480: 
 481: q = simple(LVAL, q);
 482: if(q->vsubs == NULL)
 483:     q->vsubs = mknode(TLIST,0, mkchain(cpexpr(v),CHNULL), PNULL);
 484: else
 485:     q->vsubs->leftp->datap = simple(SUBVAL, mknode(TAROP,OPPLUS, cpexpr(v),
 486:              mknode(TAROP,OPMINUS,q->vsubs->leftp->datap,mkint(1))));
 487: q->vdim = NULL;
 488: gp = mkiogroup( mkchain(mkioitem(q,CNULL), CHNULL), p->iofmt, dop);
 489: gp->nrep = nrep;
 490: cfree(p);
 491: return(gp);
 492: }
 493: 
 494: ptr mkformat(letter, n1, n2)
 495: char letter;
 496: register ptr n1, n2;
 497: {
 498: char f[20], *fp, *s;
 499: int k;
 500: 
 501: if(letter == 's')
 502:     {
 503:     if(n1)
 504:         {
 505:         k = conval(n1);
 506:         frexpr(n1);
 507:         }
 508:     else    k = 1;
 509: 
 510:     for(fp = f; k-->0 ; )
 511:         *fp++ = '/';
 512:     *fp = '\0';
 513:     return( copys(f) );
 514:     }
 515: 
 516: f[0] = letter;
 517: fp = f+1;
 518: 
 519: if(n1)  {
 520:     n1 = simple(RVAL,n1);
 521:     if(n1->tag==TCONST && n1->vtype==TYINT)
 522:         {
 523:         for(s = n1->leftp ; *s; )
 524:             *fp++ = *s++;
 525:         }
 526:     else    execerr("bad format component %s", n1->leftp);
 527:     frexpr(n1);
 528:     }
 529: 
 530: if(n2)  {
 531:     if(n2->tag==TCONST && n2->vtype==TYINT)
 532:         {
 533:         *fp++ = '.';
 534:         for(s = n2->leftp ; *s; )
 535:             *fp++ = *s++;
 536:         }
 537:     else    execerr("bad format component %s", n2->leftp);
 538:     frexpr(n2);
 539:     }
 540: 
 541: if( letter == 'x' )
 542:     {
 543:     if(n1 == 0)
 544:         *fp++ = '1';
 545:     fp[0] = 'x';
 546:     fp[1] = '\0';
 547:     return( copys(f+1) );
 548:     }
 549: else    {
 550:     *fp = '\0';
 551:     return( copys(f) );
 552:     }
 553: }
 554: 
 555: ptr mkioitem(e,f)
 556: register ptr e;
 557: char *f;
 558: {
 559: register ptr p;
 560: char fmt[10];
 561: ptr gentemp();
 562: 
 563: p = ALLOC(ioitem);
 564: p->tag = TIOITEM;
 565: if(e!=NULL && e->tag==TCONST)
 566:     if(e->vtype==TYCHAR && (f==0 || (f[0]=='c' && f[1]=='\0') ))
 567:         {
 568:         p->ioexpr = 0;
 569:         sprintf(msg, "%dh%s", strlen(e->leftp), e->leftp);
 570:         p->iofmt = copys(msg);
 571:         frexpr(e);
 572:         return(p);
 573:         }
 574:     else    e = mknode(TASGNOP,OPASGN,gentemp(e),e);
 575: 
 576: if(e && e->vtype==TYCHAR && f && f[0]=='c' && f[1]=='\0')
 577:     f = NULL;
 578: if(f == NULL)
 579:     {
 580:     switch(e->vtype)
 581:         {
 582:         case TYINT:
 583:         case TYREAL:
 584:         case TYLREAL:
 585:         case TYCOMPLEX:
 586:         case TYLOG:
 587:             f = copys( tailor.dfltfmt[e->vtype] );
 588:             break;
 589: 
 590:         case TYCHAR:
 591:             if(e->vtypep->tag != TCONST)
 592:                 {
 593:                 execerr("no adjustable character formats", "");
 594:                 f = 0;
 595:                 }
 596:             else    {
 597:                 sprintf(fmt, "c%s", e->vtypep->leftp);
 598:                 f = copys(fmt);
 599:                 }
 600:             break;
 601: 
 602:         default:
 603:             execerr("cannot do I/O on structures", "");
 604:             f = 0;
 605:             break;
 606:         }
 607:     }
 608: 
 609: p->ioexpr = e;
 610: p->iofmt = f;
 611: return(p);
 612: }
 613: 
 614: 
 615: 
 616: ptr arrsize(p)
 617: ptr p;
 618: {
 619: register ptr b;
 620: ptr f, q;
 621: 
 622: q = mkint(1);
 623: 
 624: if(b = p->vdim)
 625:     for(b = b->datap ; b ; b = b->nextp)
 626:     {
 627:     if(b->upperb == 0) continue;
 628:     f = cpexpr(b->upperb);
 629:     if(b->lowerb)
 630:         f = mknode(TAROP,OPPLUS,f,
 631:             mknode(TAROP,OPMINUS,mkint(1),cpexpr(b->lowerb)));
 632:     q = simple(RVAL, mknode(TAROP,OPSTAR,q,f));
 633:     }
 634: return(q);
 635: }
 636: 
 637: 
 638: 
 639: 
 640: repfac(dop)
 641: register struct doblock *dop;
 642: {
 643: int m1, m2, m3;
 644: 
 645: m3 = 1;
 646: if( isicon(dop->dopar[0],&m1) &&  isicon(dop->dopar[1],&m2) &&
 647:   (dop->dopar[2]==NULL || isicon(dop->dopar[2],&m3)) )
 648:     {
 649:     if(m3 > 0)
 650:         return(1 + (m2-m1)/m3);
 651:     }
 652: else    execerr("nonconstant implied do", "");
 653: return(1);
 654: }
 655: 
 656: 
 657: 
 658: ioop(s)
 659: char *s;
 660: {
 661: if( equals(s, "backspace") )
 662:     return(FBACKSPACE);
 663: if( equals(s, "rewind") )
 664:     return(FREWIND);
 665: if( equals(s, "endfile") )
 666:     return(FENDFILE);
 667: return(0);
 668: }
 669: 
 670: 
 671: 
 672: 
 673: ptr exioop(p, errcheck)
 674: register struct exprblock *p;
 675: int errcheck;
 676: {
 677: register ptr q, t;
 678: 
 679: if( (q = p->rightp)==NULL || (q = q->leftp)==NULL  )
 680:     {
 681:     execerr("bad I/O operation", "");
 682:     return(NULL);
 683:     }
 684: q = simple(LVAL, cpexpr(q->datap) );
 685: 
 686: exlab(0);
 687: putic(ICKEYWORD, ioop(p->leftp->sthead->namep));
 688: 
 689: if(errcheck)
 690:     {
 691:     if(tailor.errmode != IOERRFORT77)
 692:         {
 693:         execerr("cannot test value of IOOP without ftn77", "");
 694:         return( errnode() );
 695:         }
 696:     putic(ICOP, OPLPAR);
 697:     prexpr(q);
 698:     putic(ICOP, OPCOMMA);
 699:     putsii(ICCONST, "iostat =");
 700:     prexpr(cpexpr( t = gent(TYINT,PNULL)));
 701:     putic(ICOP, OPRPAR);
 702:     return( t );
 703:     }
 704: else    {
 705:     putic(ICBLANK, 1);
 706:     prexpr(q);
 707:     }
 708: }

Defined functions

Defined variables