Return to io.c CVS log

Up to [CSRG BSD Unix] / 42BSD / usr.bin / f77 / src / f77pass1

Annotation of 42BSD/usr.bin/f77/src/f77pass1/io.c, revision 1.1

1.1     ! root        1: /* @(#)io.c    1.3 (Berkeley) 6/1/81 */
        !             2: /* Routines to generate code for I/O statements.
        !             3:    Some corrections and improvements due to David Wasley, U. C. Berkeley
        !             4: */
        !             5: 
        !             6: /* TEMPORARY */
        !             7: #define TYIOINT TYLONG
        !             8: #define SZIOINT SZLONG
        !             9: 
        !            10: #include "defs.h"
        !            11: #include "io.h"
        !            12: 
        !            13: 
        !            14: LOCAL char ioroutine[XL+1];
        !            15: 
        !            16: LOCAL int ioendlab;
        !            17: LOCAL int ioerrlab;
        !            18: LOCAL int endbit;
        !            19: LOCAL int errbit;
        !            20: LOCAL int jumplab;
        !            21: LOCAL int skiplab;
        !            22: LOCAL int ioformatted;
        !            23: LOCAL int statstruct = NO;
        !            24: LOCAL ftnint blklen;
        !            25: 
        !            26: LOCAL offsetlist *mkiodata();
        !            27: 
        !            28: 
        !            29: #define UNFORMATTED 0
        !            30: #define FORMATTED 1
        !            31: #define LISTDIRECTED 2
        !            32: #define NAMEDIRECTED 3
        !            33: 
        !            34: #define V(z)   ioc[z].iocval
        !            35: 
        !            36: #define IOALL 07777
        !            37: 
        !            38: LOCAL struct Ioclist
        !            39:        {
        !            40:        char *iocname;
        !            41:        int iotype;
        !            42:        expptr iocval;
        !            43:        } ioc[ ] =
        !            44:        {
        !            45:                { "", 0 },
        !            46:                { "unit", IOALL },
        !            47:                { "fmt", M(IOREAD) | M(IOWRITE) },
        !            48:                { "err", IOALL },
        !            49:                { "end", M(IOREAD) },
        !            50:                { "iostat", IOALL },
        !            51:                { "rec", M(IOREAD) | M(IOWRITE) },
        !            52:                { "recl", M(IOOPEN) | M(IOINQUIRE) },
        !            53:                { "file", M(IOOPEN) | M(IOINQUIRE) },
        !            54:                { "status", M(IOOPEN) | M(IOCLOSE) },
        !            55:                { "access", M(IOOPEN) | M(IOINQUIRE) },
        !            56:                { "form", M(IOOPEN) | M(IOINQUIRE) },
        !            57:                { "blank", M(IOOPEN) | M(IOINQUIRE) },
        !            58:                { "exist", M(IOINQUIRE) },
        !            59:                { "opened", M(IOINQUIRE) },
        !            60:                { "number", M(IOINQUIRE) },
        !            61:                { "named", M(IOINQUIRE) },
        !            62:                { "name", M(IOINQUIRE) },
        !            63:                { "sequential", M(IOINQUIRE) },
        !            64:                { "direct", M(IOINQUIRE) },
        !            65:                { "formatted", M(IOINQUIRE) },
        !            66:                { "unformatted", M(IOINQUIRE) },
        !            67:                { "nextrec", M(IOINQUIRE) }
        !            68:        } ;
        !            69: 
        !            70: #define NIOS (sizeof(ioc)/sizeof(struct Ioclist) - 1)
        !            71: #define MAXIO  SZFLAG + 10*SZIOINT + 15*SZADDR
        !            72: 
        !            73: #define IOSUNIT 1
        !            74: #define IOSFMT 2
        !            75: #define IOSERR 3
        !            76: #define IOSEND 4
        !            77: #define IOSIOSTAT 5
        !            78: #define IOSREC 6
        !            79: #define IOSRECL 7
        !            80: #define IOSFILE 8
        !            81: #define IOSSTATUS 9
        !            82: #define IOSACCESS 10
        !            83: #define IOSFORM 11
        !            84: #define IOSBLANK 12
        !            85: #define IOSEXISTS 13
        !            86: #define IOSOPENED 14
        !            87: #define IOSNUMBER 15
        !            88: #define IOSNAMED 16
        !            89: #define IOSNAME 17
        !            90: #define IOSSEQUENTIAL 18
        !            91: #define IOSDIRECT 19
        !            92: #define IOSFORMATTED 20
        !            93: #define IOSUNFORMATTED 21
        !            94: #define IOSNEXTREC 22
        !            95: 
        !            96: #define IOSTP V(IOSIOSTAT)
        !            97: 
        !            98: 
        !            99: /* offsets in generated structures */
        !           100: 
        !           101: #define SZFLAG SZIOINT
        !           102: 
        !           103: /* offsets for external READ and WRITE statements */
        !           104: 
        !           105: #define XERR 0
        !           106: #define XUNIT  SZFLAG
        !           107: #define XEND   SZFLAG + SZIOINT
        !           108: #define XFMT   2*SZFLAG + SZIOINT
        !           109: #define XREC   2*SZFLAG + SZIOINT + SZADDR
        !           110: #define XRLEN  2*SZFLAG + 2*SZADDR
        !           111: #define XRNUM  2*SZFLAG + 2*SZADDR + SZIOINT
        !           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" , CNULL);
        !           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", CNULL);
        !           180:        return(-1);
        !           181:        }
        !           182: return(lp->labelno);
        !           183: }
        !           184: 
        !           185: 
        !           186: 
        !           187: setfmt(lp)
        !           188: struct Labelblock *lp;
        !           189: {
        !           190: int 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: 
        !           222: /* set up for error recovery */
        !           223: 
        !           224: ioerrlab = ioendlab = skiplab = jumplab = 0;
        !           225: 
        !           226: if(p = V(IOSEND))
        !           227:        if(ISICON(p))
        !           228:                ioendlab = execlab(p->constblock.const.ci) ->labelno;
        !           229:        else
        !           230:                err("bad end= clause");
        !           231: 
        !           232: if(p = V(IOSERR))
        !           233:        if(ISICON(p))
        !           234:                ioerrlab = execlab(p->constblock.const.ci) ->labelno;
        !           235:        else
        !           236:                err("bad err= clause");
        !           237: 
        !           238: if(IOSTP)
        !           239:        if(IOSTP->tag!=TADDR || ! ISINT(IOSTP->addrblock.vtype) )
        !           240:                {
        !           241:                err("iostat must be an integer variable");
        !           242:                frexpr(IOSTP);
        !           243:                IOSTP = NULL;
        !           244:                }
        !           245: 
        !           246: if(iostmt == IOREAD)
        !           247:        {
        !           248:        if(IOSTP)
        !           249:                {
        !           250:                if(ioerrlab && ioendlab && ioerrlab==ioendlab)
        !           251:                        jumplab = ioerrlab;
        !           252:                else
        !           253:                        skiplab = jumplab = newlabel();
        !           254:                }
        !           255:        else    {
        !           256:                if(ioerrlab && ioendlab && ioerrlab!=ioendlab)
        !           257:                        {
        !           258:                        IOSTP = (expptr) mktemp(TYINT, PNULL);
        !           259:                        skiplab = jumplab = newlabel();
        !           260:                        }
        !           261:                else
        !           262:                        jumplab = (ioerrlab ? ioerrlab : ioendlab);
        !           263:                }
        !           264:        }
        !           265: else if(iostmt == IOWRITE)
        !           266:        {
        !           267:        if(IOSTP && !ioerrlab)
        !           268:                skiplab = jumplab = newlabel();
        !           269:        else
        !           270:                jumplab = ioerrlab;
        !           271:        }
        !           272: else
        !           273:        jumplab = ioerrlab;
        !           274: 
        !           275: endbit = IOSTP!=NULL || ioendlab!=0;   /* for use in startrw() */
        !           276: errbit = IOSTP!=NULL || ioerrlab!=0;
        !           277: if(iostmt!=IOREAD && iostmt!=IOWRITE)
        !           278:        {
        !           279:        if(ioblkp == NULL)
        !           280:                ioblkp = autovar( (MAXIO+SZIOINT-1)/SZIOINT , TYIOINT, PNULL);
        !           281:        ioset(TYIOINT, XERR, ICON(errbit));
        !           282:        }
        !           283: 
        !           284: switch(iostmt)
        !           285:        {
        !           286:        case IOOPEN:
        !           287:                dofopen();  break;
        !           288: 
        !           289:        case IOCLOSE:
        !           290:                dofclose();  break;
        !           291: 
        !           292:        case IOINQUIRE:
        !           293:                dofinquire();  break;
        !           294: 
        !           295:        case IOBACKSPACE:
        !           296:                dofmove("f_back"); break;
        !           297: 
        !           298:        case IOREWIND:
        !           299:                dofmove("f_rew");  break;
        !           300: 
        !           301:        case IOENDFILE:
        !           302:                dofmove("f_end");  break;
        !           303: 
        !           304:        case IOREAD:
        !           305:        case IOWRITE:
        !           306:                startrw();  break;
        !           307: 
        !           308:        default:
        !           309:                fatali("impossible iostmt %d", iostmt);
        !           310:        }
        !           311: for(i = 1 ; i<=NIOS ; ++i)
        !           312:        if(i!=IOSIOSTAT && V(i)!=NULL)
        !           313:                frexpr(V(i));
        !           314: }
        !           315: 
        !           316: 
        !           317: 
        !           318: iocname()
        !           319: {
        !           320: register int i;
        !           321: int found, mask;
        !           322: 
        !           323: found = 0;
        !           324: mask = M(iostmt);
        !           325: for(i = 1 ; i <= NIOS ; ++i)
        !           326:        if(toklen==strlen(ioc[i].iocname) && eqn(toklen, token, ioc[i].iocname))
        !           327:                if(ioc[i].iotype & mask)
        !           328:                        return(i);
        !           329:                else    found = i;
        !           330: if(found)
        !           331:        errstr("invalid control %s for statement", ioc[found].iocname);
        !           332: else
        !           333:        errstr("unknown iocontrol %s", varstr(toklen, token) );
        !           334: return(IOSBAD);
        !           335: }
        !           336: 
        !           337: 
        !           338: ioclause(n, p)
        !           339: register int n;
        !           340: register expptr p;
        !           341: {
        !           342: struct Ioclist *iocp;
        !           343: 
        !           344: ++nioctl;
        !           345: if(n == IOSBAD)
        !           346:        return;
        !           347: if(n == IOSPOSITIONAL)
        !           348:        {
        !           349:        if(nioctl > IOSFMT)
        !           350:                {
        !           351:                err("illegal positional iocontrol");
        !           352:                return;
        !           353:                }
        !           354:        n = nioctl;
        !           355:        }
        !           356: 
        !           357: if(p == NULL)
        !           358:        {
        !           359:        if(n == IOSUNIT)
        !           360:                p = (expptr) (iostmt==IOREAD ? IOSTDIN : IOSTDOUT);
        !           361:        else if(n != IOSFMT)
        !           362:                {
        !           363:                err("illegal * iocontrol");
        !           364:                return;
        !           365:                }
        !           366:        }
        !           367: if(n == IOSFMT)
        !           368:        ioformatted = (p==NULL ? LISTDIRECTED : FORMATTED);
        !           369: 
        !           370: iocp = & ioc[n];
        !           371: if(iocp->iocval == NULL)
        !           372:        {
        !           373:        if(n!=IOSFMT && ( n!=IOSUNIT || (p!=NULL && p->headblock.vtype!=TYCHAR) ) )
        !           374:                p = fixtype(p);
        !           375:        if(p!=NULL && ISCONST(p) && p->constblock.vtype==TYCHAR)
        !           376:                p = (expptr) putconst(p);
        !           377:        iocp->iocval = p;
        !           378: }
        !           379: else
        !           380:        errstr("iocontrol %s repeated", iocp->iocname);
        !           381: }
        !           382: 
        !           383: /* io list item */
        !           384: 
        !           385: doio(list)
        !           386: chainp list;
        !           387: {
        !           388: expptr call0();
        !           389: 
        !           390: if(ioformatted == NAMEDIRECTED)
        !           391:        {
        !           392:        if(list)
        !           393:                err("no I/O list allowed in NAMELIST read/write");
        !           394:        }
        !           395: else
        !           396:        {
        !           397:        doiolist(list);
        !           398:        ioroutine[0] = 'e';
        !           399:        putiocall( call0(TYINT, ioroutine) );
        !           400:        }
        !           401: }
        !           402: 
        !           403: 
        !           404: 
        !           405: 
        !           406: 
        !           407: LOCAL doiolist(p0)
        !           408: chainp p0;
        !           409: {
        !           410: chainp p;
        !           411: register tagptr q;
        !           412: register expptr qe;
        !           413: register Namep qn;
        !           414: Addrp tp, mkscalar();
        !           415: int range;
        !           416: expptr expr;
        !           417: 
        !           418: for (p = p0 ; p ; p = p->nextp)
        !           419:        {
        !           420:        q = p->datap;
        !           421:        if(q->tag == TIMPLDO)
        !           422:                {
        !           423:                exdo(range=newlabel(), q->impldoblock.impdospec);
        !           424:                doiolist(q->impldoblock.datalist);
        !           425:                enddo(range);
        !           426:                free( (charptr) q);
        !           427:                }
        !           428:        else    {
        !           429:                if(q->tag==TPRIM && q->primblock.argsp==NULL
        !           430:                    && q->primblock.namep->vdim!=NULL)
        !           431:                        {
        !           432:                        vardcl(qn = q->primblock.namep);
        !           433:                        if(qn->vdim->nelt)
        !           434:                                putio( fixtype(cpexpr(qn->vdim->nelt)),
        !           435:                                        mkscalar(qn) );
        !           436:                        else
        !           437:                                err("attempt to i/o array of unknown size");
        !           438:                        }
        !           439:                else if(q->tag==TPRIM && q->primblock.argsp==NULL &&
        !           440:                    (qe = (expptr) memversion(q->primblock.namep)) )
        !           441:                        putio(ICON(1),qe);
        !           442:                else if( (qe = fixtype(cpexpr(q)))->tag==TADDR)
        !           443:                        putio(ICON(1), qe);
        !           444:                else if(qe->headblock.vtype != TYERROR)
        !           445:                        {
        !           446:                        if(iostmt == IOWRITE)
        !           447:                                {
        !           448:                                ftnint lencat();
        !           449:                                expptr qvl;
        !           450:                                qvl = NULL;
        !           451:                                if( ISCHAR(qe) )
        !           452:                                        {
        !           453:                                        qvl = (expptr)
        !           454:                                                cpexpr(qe->headblock.vleng);
        !           455:                                        tp = mktemp(qe->headblock.vtype,
        !           456:                                                     ICON(lencat(qe)));
        !           457:                                        }
        !           458:                                else
        !           459:                                        tp = mktemp(qe->headblock.vtype,
        !           460:                                                qe->headblock.vleng);
        !           461:                                if (optimflag)
        !           462:                                        {
        !           463:                                        expr = mkexpr(OPASSIGN,cpexpr(tp),qe);
        !           464:                                        optbuff (SKEQ,expr,0,0);
        !           465:                                        }
        !           466:                                else
        !           467:                                        puteq (cpexpr(tp),qe);
        !           468:                                if(qvl) /* put right length on block */
        !           469:                                        {
        !           470:                                        frexpr(tp->vleng);
        !           471:                                        tp->vleng = qvl;
        !           472:                                        }
        !           473:                                putio(ICON(1), tp);
        !           474:                                }
        !           475:                        else
        !           476:                                err("non-left side in READ list");
        !           477:                        }
        !           478:                frexpr(q);
        !           479:                }
        !           480:        }
        !           481: frchain( &p0 );
        !           482: }
        !           483: 
        !           484: 
        !           485: 
        !           486: 
        !           487: 
        !           488: LOCAL putio(nelt, addr)
        !           489: expptr nelt;
        !           490: register expptr addr;
        !           491: {
        !           492: int type;
        !           493: register expptr q;
        !           494: 
        !           495: type = addr->headblock.vtype;
        !           496: if(ioformatted!=LISTDIRECTED && ISCOMPLEX(type) )
        !           497:        {
        !           498:        nelt = mkexpr(OPSTAR, ICON(2), nelt);
        !           499:        type -= (TYCOMPLEX-TYREAL);
        !           500:        }
        !           501: 
        !           502: /* pass a length with every item.  for noncharacter data, fake one */
        !           503: if(type != TYCHAR)
        !           504:        {
        !           505:        addr->headblock.vtype = TYCHAR;
        !           506:        addr->headblock.vleng = ICON( typesize[type] );
        !           507:        }
        !           508: 
        !           509: nelt = fixtype( mkconv(TYLENG,nelt) );
        !           510: if(ioformatted == LISTDIRECTED)
        !           511:        q = call3(TYINT, "do_lio", mkconv(TYLONG, ICON(type)), nelt, addr);
        !           512: else
        !           513:        q = call2(TYINT, (ioformatted==FORMATTED ? "do_fio" : "do_uio"),
        !           514:                nelt, addr);
        !           515: putiocall(q);
        !           516: }
        !           517: 
        !           518: 
        !           519: 
        !           520: 
        !           521: endio()
        !           522: {
        !           523: if(skiplab)
        !           524:        {
        !           525:        if (optimflag)
        !           526:                optbuff (SKLABEL, 0, skiplab, 0);
        !           527:        else
        !           528:                putlabel (skiplab);
        !           529:        if(ioendlab)
        !           530:                {
        !           531:                expptr test;
        !           532:                test = mkexpr(OPGE, cpexpr(IOSTP), ICON(0));
        !           533:                if (optimflag)
        !           534:                        optbuff (SKIOIFN,test,ioendlab,0);
        !           535:                else
        !           536:                        putif (test,ioendlab);
        !           537:                }
        !           538:        if(ioerrlab)
        !           539:                {
        !           540:                expptr test;
        !           541:                test = mkexpr
        !           542:                        ( ((iostmt==IOREAD||iostmt==IOWRITE) ? OPLE : OPEQ),
        !           543:                        cpexpr(IOSTP), ICON(0));
        !           544:                if (optimflag)
        !           545:                        optbuff (SKIOIFN,test,ioerrlab,0);
        !           546:                else
        !           547:                        putif (test,ioerrlab);
        !           548:                }
        !           549:        }
        !           550: if(IOSTP)
        !           551:        frexpr(IOSTP);
        !           552: }
        !           553: 
        !           554: 
        !           555: 
        !           556: LOCAL putiocall(q)
        !           557: register expptr q;
        !           558: {
        !           559: if(IOSTP)
        !           560:        {
        !           561:        q->headblock.vtype = TYINT;
        !           562:        q = fixexpr( mkexpr(OPASSIGN, cpexpr(IOSTP), q));
        !           563:        }
        !           564: 
        !           565: if(jumplab)
        !           566:        if (optimflag)
        !           567:                optbuff (SKIOIFN,mkexpr(OPEQ,q,ICON(0)),jumplab,0);
        !           568:        else
        !           569:                putif (mkexpr(OPEQ,q,ICON(0)),jumplab);
        !           570: else
        !           571:        if (optimflag)
        !           572:                optbuff (SKEQ, q, 0, 0);
        !           573:        else
        !           574:                putexpr(q);
        !           575: }
        !           576: 
        !           577: startrw()
        !           578: {
        !           579: register expptr p;
        !           580: register Namep np;
        !           581: register Addrp unitp, fmtp, recp, tioblkp;
        !           582: register expptr nump;
        !           583: register ioblock *t;
        !           584: Addrp mkscalar();
        !           585: expptr mkaddcon();
        !           586: int k;
        !           587: flag intfile, sequential, ok, varfmt;
        !           588: 
        !           589: /* First look at all the parameters and determine what is to be done */
        !           590: 
        !           591: ok = YES;
        !           592: statstruct = YES;
        !           593: 
        !           594: intfile = NO;
        !           595: if(p = V(IOSUNIT))
        !           596:        {
        !           597:        if( ISINT(p->headblock.vtype) )
        !           598:                unitp = (Addrp) cpexpr(p);
        !           599:        else if(p->headblock.vtype == TYCHAR)
        !           600:                {
        !           601:                intfile = YES;
        !           602:                if(p->tag==TPRIM && p->primblock.argsp==NULL &&
        !           603:                    (np = p->primblock.namep)->vdim!=NULL)
        !           604:                        {
        !           605:                        vardcl(np);
        !           606:                        if(np->vdim->nelt)
        !           607:                                {
        !           608:                                nump = (expptr) cpexpr(np->vdim->nelt);
        !           609:                                if( ! ISCONST(nump) )
        !           610:                                        statstruct = NO;
        !           611:                                }
        !           612:                        else
        !           613:                                {
        !           614:                                err("attempt to use internal unit array of unknown size");
        !           615:                                ok = NO;
        !           616:                                nump = ICON(1);
        !           617:                                }
        !           618:                        unitp = mkscalar(np);
        !           619:                        }
        !           620:                else    {
        !           621:                        nump = ICON(1);
        !           622:                        unitp = (Addrp) fixtype(cpexpr(p));
        !           623:                        }
        !           624:                if(! isstatic(unitp) )
        !           625:                        statstruct = NO;
        !           626:                }
        !           627:        else
        !           628:                {
        !           629:                err("bad unit specifier type");
        !           630:                ok = NO;
        !           631:                }
        !           632:        }
        !           633: else
        !           634:        {
        !           635:        err("bad unit specifier");
        !           636:        ok = NO;
        !           637:        }
        !           638: 
        !           639: sequential = YES;
        !           640: if(p = V(IOSREC))
        !           641:        if( ISINT(p->headblock.vtype) )
        !           642:                {
        !           643:                recp = (Addrp) cpexpr(p);
        !           644:                sequential = NO;
        !           645:                }
        !           646:        else    {
        !           647:                err("bad REC= clause");
        !           648:                ok = NO;
        !           649:                }
        !           650: else
        !           651:        recp = NULL;
        !           652: 
        !           653: 
        !           654: varfmt = YES;
        !           655: fmtp = NULL;
        !           656: if(p = V(IOSFMT))
        !           657:        {
        !           658:        if(p->tag==TPRIM && p->primblock.argsp==NULL)
        !           659:                {
        !           660:                np = p->primblock.namep;
        !           661:                if(np->vclass == CLNAMELIST)
        !           662:                        {
        !           663:                        ioformatted = NAMEDIRECTED;
        !           664:                        fmtp = (Addrp) fixtype(p);
        !           665:                        goto endfmt;
        !           666:                        }
        !           667:                vardcl(np);
        !           668:                if(np->vdim)
        !           669:                        {
        !           670:                        if( ! ONEOF(np->vstg, MSKSTATIC) )
        !           671:                                statstruct = NO;
        !           672:                        fmtp = mkscalar(np);
        !           673:                        goto endfmt;
        !           674:                        }
        !           675:                if( ISINT(np->vtype) )  /* ASSIGNed label */
        !           676:                        {
        !           677:                        statstruct = NO;
        !           678:                        varfmt = NO;
        !           679:                        fmtp = (Addrp) fixtype(p);
        !           680:                        goto endfmt;
        !           681:                        }
        !           682:                }
        !           683:        p = V(IOSFMT) = fixtype(p);
        !           684:        if(p->headblock.vtype == TYCHAR)
        !           685:                {
        !           686:                if (p->tag == TCONST) p = (expptr) putconst(p);
        !           687:                if( ! isstatic(p) )
        !           688:                        statstruct = NO;
        !           689:                fmtp = (Addrp) cpexpr(p);
        !           690:                }
        !           691:        else if( ISICON(p) )
        !           692:                {
        !           693:                if( (k = fmtstmt( mklabel(p->constblock.const.ci) )) > 0 )
        !           694:                        {
        !           695:                        fmtp = (Addrp) mkaddcon(k);
        !           696:                        varfmt = NO;
        !           697:                        }
        !           698:                else
        !           699:                        ioformatted = UNFORMATTED;
        !           700:                }
        !           701:        else    {
        !           702:                err("bad format descriptor");
        !           703:                ioformatted = UNFORMATTED;
        !           704:                ok = NO;
        !           705:                }
        !           706:        }
        !           707: else
        !           708:        fmtp = NULL;
        !           709: 
        !           710: endfmt:
        !           711:        if(intfile && ioformatted==UNFORMATTED)
        !           712:                {
        !           713:                err("unformatted internal I/O not allowed");
        !           714:                ok = NO;
        !           715:                }
        !           716:        if(!sequential && ioformatted==LISTDIRECTED)
        !           717:                {
        !           718:                err("direct list-directed I/O not allowed");
        !           719:                ok = NO;
        !           720:                }
        !           721:        if(!sequential && ioformatted==NAMEDIRECTED)
        !           722:                {
        !           723:                err("direct namelist I/O not allowed");
        !           724:                ok = NO;
        !           725:                }
        !           726: 
        !           727: if( ! ok )
        !           728:        return;
        !           729: 
        !           730: if (optimflag && ISCONST (fmtp))
        !           731:        fmtp = putconst ( (expptr) fmtp);
        !           732: 
        !           733: /*
        !           734:    Now put out the I/O structure, statically if all the clauses
        !           735:    are constants, dynamically otherwise
        !           736: */
        !           737: 
        !           738: if(statstruct)
        !           739:        {
        !           740:        tioblkp = ioblkp;
        !           741:        ioblkp = ALLOC(Addrblock);
        !           742:        ioblkp->tag = TADDR;
        !           743:        ioblkp->vtype = TYIOINT;
        !           744:        ioblkp->vclass = CLVAR;
        !           745:        ioblkp->vstg = STGINIT;
        !           746:        ioblkp->memno = ++lastvarno;
        !           747:        ioblkp->memoffset = ICON(0);
        !           748:        blklen = (intfile ? XIREC+SZIOINT :
        !           749:                        (sequential ? XFMT+SZADDR : XRNUM+SZIOINT) );
        !           750:        t = ALLOC(IoBlock);
        !           751:        t->blkno = ioblkp->memno;
        !           752:        t->len = blklen;
        !           753:        t->next = iodata;
        !           754:        iodata = t;
        !           755:        }
        !           756: else if(ioblkp == NULL)
        !           757:        ioblkp = autovar( (MAXIO+SZIOINT-1)/SZIOINT , TYIOINT, PNULL);
        !           758: 
        !           759: ioset(TYIOINT, XERR, ICON(errbit));
        !           760: if(iostmt == IOREAD)
        !           761:        ioset(TYIOINT, (intfile ? XIEND : XEND), ICON(endbit) );
        !           762: 
        !           763: if(intfile)
        !           764:        {
        !           765:        ioset(TYIOINT, XIRNUM, nump);
        !           766:        ioset(TYIOINT, XIRLEN, cpexpr(unitp->vleng) );
        !           767:        ioseta(XIUNIT, unitp);
        !           768:        }
        !           769: else
        !           770:        ioset(TYIOINT, XUNIT, (expptr) unitp);
        !           771: 
        !           772: if(recp)
        !           773:        ioset(TYIOINT, (intfile ? XIREC : XREC) , (expptr) recp);
        !           774: 
        !           775: if(varfmt)
        !           776:        ioseta( intfile ? XIFMT : XFMT , fmtp);
        !           777: else
        !           778:        ioset(TYADDR, intfile ? XIFMT : XFMT, (expptr) fmtp);
        !           779: 
        !           780: ioroutine[0] = 's';
        !           781: ioroutine[1] = '_';
        !           782: ioroutine[2] = (iostmt==IOREAD ? 'r' : 'w');
        !           783: ioroutine[3] = (sequential ? 's' : 'd');
        !           784: ioroutine[4] = "ufln" [ioformatted];
        !           785: ioroutine[5] = (intfile ? 'i' : 'e');
        !           786: ioroutine[6] = '\0';
        !           787: 
        !           788: putiocall( call1(TYINT, ioroutine, cpexpr(ioblkp) ));
        !           789: 
        !           790: if(statstruct)
        !           791:        {
        !           792:        frexpr(ioblkp);
        !           793:        ioblkp = tioblkp;
        !           794:        statstruct = NO;
        !           795:        }
        !           796: }
        !           797: 
        !           798: 
        !           799: 
        !           800: LOCAL dofopen()
        !           801: {
        !           802: register expptr p;
        !           803: 
        !           804: if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
        !           805:        ioset(TYIOINT, XUNIT, cpexpr(p) );
        !           806: else
        !           807:        err("bad unit in open");
        !           808: if( (p = V(IOSFILE)) )
        !           809:        if(p->headblock.vtype == TYCHAR)
        !           810:                ioset(TYIOINT, XFNAMELEN, cpexpr(p->headblock.vleng) );
        !           811:        else
        !           812:                err("bad file in open");
        !           813: 
        !           814: iosetc(XFNAME, p);
        !           815: 
        !           816: if(p = V(IOSRECL))
        !           817:        if( ISINT(p->headblock.vtype) )
        !           818:                ioset(TYIOINT, XRECLEN, cpexpr(p) );
        !           819:        else
        !           820:                err("bad recl");
        !           821: else
        !           822:        ioset(TYIOINT, XRECLEN, ICON(0) );
        !           823: 
        !           824: iosetc(XSTATUS, V(IOSSTATUS));
        !           825: iosetc(XACCESS, V(IOSACCESS));
        !           826: iosetc(XFORMATTED, V(IOSFORM));
        !           827: iosetc(XBLANK, V(IOSBLANK));
        !           828: 
        !           829: putiocall( call1(TYINT, "f_open", cpexpr(ioblkp) ));
        !           830: }
        !           831: 
        !           832: 
        !           833: LOCAL dofclose()
        !           834: {
        !           835: register expptr p;
        !           836: 
        !           837: if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
        !           838:        {
        !           839:        ioset(TYIOINT, XUNIT, cpexpr(p) );
        !           840:        iosetc(XCLSTATUS, V(IOSSTATUS));
        !           841:        putiocall( call1(TYINT, "f_clos", cpexpr(ioblkp)) );
        !           842:        }
        !           843: else
        !           844:        err("bad unit in close statement");
        !           845: }
        !           846: 
        !           847: 
        !           848: LOCAL dofinquire()
        !           849: {
        !           850: register expptr p;
        !           851: if(p = V(IOSUNIT))
        !           852:        {
        !           853:        if( V(IOSFILE) )
        !           854:                err("inquire by unit or by file, not both");
        !           855:        ioset(TYIOINT, XUNIT, cpexpr(p) );
        !           856:        }
        !           857: else if( ! V(IOSFILE) )
        !           858:        err("must inquire by unit or by file");
        !           859: iosetlc(IOSFILE, XFILE, XFILELEN);
        !           860: iosetip(IOSEXISTS, XEXISTS);
        !           861: iosetip(IOSOPENED, XOPEN);
        !           862: iosetip(IOSNUMBER, XNUMBER);
        !           863: iosetip(IOSNAMED, XNAMED);
        !           864: iosetlc(IOSNAME, XNAME, XNAMELEN);
        !           865: iosetlc(IOSACCESS, XQACCESS, XQACCLEN);
        !           866: iosetlc(IOSSEQUENTIAL, XSEQ, XSEQLEN);
        !           867: iosetlc(IOSDIRECT, XDIRECT, XDIRLEN);
        !           868: iosetlc(IOSFORM, XFORM, XFORMLEN);
        !           869: iosetlc(IOSFORMATTED, XFMTED, XFMTEDLEN);
        !           870: iosetlc(IOSUNFORMATTED, XUNFMT, XUNFMTLEN);
        !           871: iosetip(IOSRECL, XQRECL);
        !           872: iosetip(IOSNEXTREC, XNEXTREC);
        !           873: iosetlc(IOSBLANK, XQBLANK, XQBLANKLEN);
        !           874: 
        !           875: putiocall( call1(TYINT,  "f_inqu", cpexpr(ioblkp) ));
        !           876: }
        !           877: 
        !           878: 
        !           879: 
        !           880: LOCAL dofmove(subname)
        !           881: char *subname;
        !           882: {
        !           883: register expptr p;
        !           884: 
        !           885: if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
        !           886:        {
        !           887:        ioset(TYIOINT, XUNIT, cpexpr(p) );
        !           888:        putiocall( call1(TYINT, subname, cpexpr(ioblkp) ));
        !           889:        }
        !           890: else
        !           891:        err("bad unit in I/O motion statement");
        !           892: }
        !           893: 
        !           894: 
        !           895: 
        !           896: LOCAL
        !           897: ioset(type, offset, p)
        !           898: int type;
        !           899: int offset;
        !           900: register expptr p;
        !           901: {
        !           902:   static char *badoffset = "badoffset in ioset";
        !           903: 
        !           904:   register Addrp q;
        !           905:   register offsetlist *op;
        !           906: 
        !           907:   q = (Addrp) cpexpr(ioblkp);
        !           908:   q->vtype = type;
        !           909:   q->memoffset = fixtype( mkexpr(OPPLUS, q->memoffset, ICON(offset)) );
        !           910: 
        !           911:   if (statstruct && ISCONST(p))
        !           912:     {
        !           913:       if (!ISICON(q->memoffset))
        !           914:        fatal(badoffset);
        !           915: 
        !           916:       op = mkiodata(q->memno, q->memoffset->constblock.const.ci, blklen);
        !           917:       if (op->tag != 0)
        !           918:        fatal(badoffset);
        !           919: 
        !           920:       if (type == TYADDR)
        !           921:        {
        !           922:          op->tag = NDLABEL;
        !           923:          op->val.label = p->constblock.const.ci;
        !           924:        }
        !           925:       else
        !           926:        {
        !           927:          op->tag = NDDATA;
        !           928:          op->val.cp = (Constp) convconst(type, 0, p);
        !           929:        }
        !           930: 
        !           931:       frexpr((tagptr) p);
        !           932:       frexpr((tagptr) q);
        !           933:     }
        !           934:   else
        !           935:     if (optimflag)
        !           936:       optbuff (SKEQ, mkexpr(OPASSIGN,q,p), 0,0);
        !           937:     else
        !           938:       puteq (q,p);
        !           939: 
        !           940:   return;
        !           941: }
        !           942: 
        !           943: 
        !           944: 
        !           945: 
        !           946: LOCAL iosetc(offset, p)
        !           947: int offset;
        !           948: register expptr p;
        !           949: {
        !           950: if(p == NULL)
        !           951:        ioset(TYADDR, offset, ICON(0) );
        !           952: else if(p->headblock.vtype == TYCHAR)
        !           953:        ioset(TYADDR, offset, addrof(cpexpr(p) ));
        !           954: else
        !           955:        err("non-character control clause");
        !           956: }
        !           957: 
        !           958: 
        !           959: 
        !           960: LOCAL ioseta(offset, p)
        !           961: int offset;
        !           962: register Addrp p;
        !           963: {
        !           964:   static char *badoffset = "bad offset in ioseta";
        !           965: 
        !           966:   int blkno;
        !           967:   register offsetlist *op;
        !           968: 
        !           969:   if(statstruct)
        !           970:     {
        !           971:       blkno = ioblkp->memno;
        !           972:       op = mkiodata(blkno, offset, blklen);
        !           973:       if (op->tag != 0)
        !           974:        fatal(badoffset);
        !           975: 
        !           976:       if (p == NULL)
        !           977:        op->tag = NDNULL;
        !           978:       else if (p->tag == TADDR)
        !           979:        {
        !           980:          op->tag = NDADDR;
        !           981:          op->val.addr.stg = p->vstg;
        !           982:          op->val.addr.memno = p->memno;
        !           983:          op->val.addr.offset = p->memoffset->constblock.const.ci;
        !           984:        }
        !           985:       else
        !           986:        badtag("ioseta", p->tag);
        !           987:     }
        !           988:   else
        !           989:     ioset(TYADDR, offset, p ? addrof(p) : ICON(0) );
        !           990: 
        !           991:   return;
        !           992: }
        !           993: 
        !           994: 
        !           995: 
        !           996: 
        !           997: LOCAL iosetip(i, offset)
        !           998: int i, offset;
        !           999: {
        !          1000: register expptr p;
        !          1001: 
        !          1002: if(p = V(i))
        !          1003:        if(p->tag==TADDR &&
        !          1004:            ONEOF(p->addrblock.vtype, M(TYLONG)|M(TYLOGICAL)) )
        !          1005:                ioset(TYADDR, offset, addrof(cpexpr(p)) );
        !          1006:        else
        !          1007:                errstr("impossible inquire parameter %s", ioc[i].iocname);
        !          1008: else
        !          1009:        ioset(TYADDR, offset, ICON(0) );
        !          1010: }
        !          1011: 
        !          1012: 
        !          1013: 
        !          1014: LOCAL iosetlc(i, offp, offl)
        !          1015: int i, offp, offl;
        !          1016: {
        !          1017: register expptr p;
        !          1018: if( (p = V(i)) && p->headblock.vtype==TYCHAR)
        !          1019:        ioset(TYIOINT, offl, cpexpr(p->headblock.vleng) );
        !          1020: iosetc(offp, p);
        !          1021: }
        !          1022: 
        !          1023: 
        !          1024: LOCAL offsetlist *
        !          1025: mkiodata(blkno, offset, len)
        !          1026: int blkno;
        !          1027: ftnint offset;
        !          1028: ftnint len;
        !          1029: {
        !          1030:   register offsetlist *p, *q;
        !          1031:   register ioblock *t;
        !          1032:   register int found;
        !          1033: 
        !          1034:   found = NO;
        !          1035:   t = iodata;
        !          1036: 
        !          1037:   while (found == NO && t != NULL)
        !          1038:     {
        !          1039:       if (t->blkno == blkno)
        !          1040:        found = YES;
        !          1041:       else
        !          1042:        t = t->next;
        !          1043:     }
        !          1044: 
        !          1045:   if (found == NO)
        !          1046:     {
        !          1047:       t = ALLOC(IoBlock);
        !          1048:       t->blkno = blkno;
        !          1049:       t->next = iodata;
        !          1050:       iodata = t;
        !          1051:     }
        !          1052: 
        !          1053:   if (len > t->len)
        !          1054:     t->len = len;
        !          1055: 
        !          1056:   p = t->olist;
        !          1057: 
        !          1058:   if (p == NULL)
        !          1059:     {
        !          1060:       p = ALLOC(OffsetList);
        !          1061:       p->next = NULL;
        !          1062:       p->offset = offset;
        !          1063:       t->olist = p;
        !          1064:       return (p);
        !          1065:     }
        !          1066: 
        !          1067:   for (;;)
        !          1068:     {
        !          1069:       if (p->offset == offset)
        !          1070:        return (p);
        !          1071:       else if (p->next != NULL &&
        !          1072:               p->next->offset <= offset)
        !          1073:        p = p->next;
        !          1074:       else
        !          1075:        {
        !          1076:          q = ALLOC(OffsetList);
        !          1077:          q->next = p->next;
        !          1078:          p->next = q;
        !          1079:          q->offset = offset;
        !          1080:          return (q);
        !          1081:        }
        !          1082:     }
        !          1083: }
        !          1084: 
        !          1085: 
        !          1086: outiodata()
        !          1087: {
        !          1088:   static char *varfmt = "\t.align\t2\nv.%d:\n";
        !          1089: 
        !          1090:   register ioblock *p;
        !          1091:   register ioblock *t;
        !          1092: 
        !          1093:   if (iodata == NULL) return;
        !          1094: 
        !          1095:   p = iodata;
        !          1096: 
        !          1097:   while (p != NULL)
        !          1098:     {
        !          1099:       fprintf(initfile, varfmt, p->blkno);
        !          1100:       outolist(p->olist, p->len);
        !          1101: 
        !          1102:       t = p;
        !          1103:       p = t->next;
        !          1104:       free((char *) t);
        !          1105:     }
        !          1106: 
        !          1107:   iodata = NULL;
        !          1108:   return;
        !          1109: }
        !          1110: 
        !          1111: 
        !          1112: 
        !          1113: LOCAL
        !          1114: outolist(op, len)
        !          1115: register offsetlist *op;
        !          1116: register int len;
        !          1117: {
        !          1118:   static char *overlap = "overlapping i/o fields in outolist";
        !          1119:   static char *toolong = "offset too large in outolist";
        !          1120: 
        !          1121:   static char *spacefmt = "\t.space\t%d\n";
        !          1122: 
        !          1123:   register offsetlist *t;
        !          1124:   register ftnint clen;
        !          1125:   register Constp cp;
        !          1126:   register int type;
        !          1127: 
        !          1128:   clen = 0;
        !          1129: 
        !          1130:   while (op != NULL)
        !          1131:     {
        !          1132:       if (clen > op->offset)
        !          1133:        fatal(overlap);
        !          1134: 
        !          1135:       if (clen < op->offset)
        !          1136:        {
        !          1137:          fprintf(initfile, spacefmt, op->offset - clen);
        !          1138:          clen = op->offset;
        !          1139:        }
        !          1140: 
        !          1141:       switch (op->tag)
        !          1142:        {
        !          1143:        default:
        !          1144:          badtag("outolist", op->tag);
        !          1145: 
        !          1146:        case NDDATA:
        !          1147:          cp = op->val.cp;
        !          1148:          type = cp->vtype;
        !          1149:          if (type != TYIOINT)
        !          1150:            badtype("outolist", type);
        !          1151:          prconi(initfile, type, cp->const.ci);
        !          1152:          clen += typesize[type];
        !          1153:          frexpr((tagptr) cp);
        !          1154:          break;
        !          1155: 
        !          1156:        case NDLABEL:
        !          1157:          prcona(initfile, op->val.label);
        !          1158:          clen += typesize[TYADDR];
        !          1159:          break;
        !          1160: 
        !          1161:        case NDADDR:
        !          1162:          praddr(initfile, op->val.addr.stg, op->val.addr.memno,
        !          1163:                 op->val.addr.offset);
        !          1164:          clen += typesize[TYADDR];
        !          1165:          break;
        !          1166: 
        !          1167:        case NDNULL:
        !          1168:          praddr(initfile, STGNULL, 0, (ftnint) 0);
        !          1169:          clen += typesize[TYADDR];
        !          1170:          break;
        !          1171:        }
        !          1172: 
        !          1173:       t = op;
        !          1174:       op = t->next;
        !          1175:       free((char *) t);
        !          1176:     }
        !          1177: 
        !          1178:   if (clen > len)
        !          1179:     fatal(toolong);
        !          1180: 
        !          1181:   if (clen < len)
        !          1182:     fprintf(initfile, spacefmt, len - clen);
        !          1183: 
        !          1184:   return;
        !          1185: }

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