Return to io.c CVS log

Up to [CSRG BSD Unix] / 3BSD / cmd / f77

Annotation of 3BSD/cmd/f77/io.c, revision 1.1

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

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.