Return to io.c CVS log

Up to [CSRG BSD Unix] / 3BSD / new / libI77uc

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

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