Return to proc.c CVS log

Up to [CSRG BSD Unix] / 43BSDTahoe / usr.bin / f77 / f77.tahoe / f77pass1

Annotation of 43BSDTahoe/usr.bin/f77/f77.tahoe/f77pass1/proc.c, revision 1.1

1.1     ! root        1: /*
        !             2:  * Copyright (c) 1980 Regents of the University of California.
        !             3:  * All rights reserved.  The Berkeley software License Agreement
        !             4:  * specifies the terms and conditions for redistribution.
        !             5:  */
        !             6: 
        !             7: #ifndef lint
        !             8: static char sccsid[] = "@(#)proc.c     5.2 (Berkeley) 6/9/85";
        !             9: #endif not lint
        !            10: 
        !            11: /*
        !            12:  * proc.c
        !            13:  *
        !            14:  * Routines for handling procedures, f77 compiler, pass 1.
        !            15:  *
        !            16:  * University of Utah CS Dept modification history:
        !            17:  *
        !            18:  * $Header: proc.c,v 3.11 85/06/04 03:45:29 donn Exp $
        !            19:  * $Log:       proc.c,v $
        !            20:  * Revision 3.11  85/06/04  03:45:29  donn
        !            21:  * Changed retval() to recognize that a function declaration might have
        !            22:  * bombed out earlier, leaving an error node behind...
        !            23:  * 
        !            24:  * Revision 3.10  85/03/08  23:13:06  donn
        !            25:  * Finally figured out why function calls and array elements are not legal
        !            26:  * dummy array dimension declarator elements.  Hacked safedim() to stop 'em.
        !            27:  * 
        !            28:  * Revision 3.9  85/02/02  00:26:10  donn
        !            29:  * Removed the call to entrystab() in enddcl() -- this was redundant (it was
        !            30:  * also done in startproc()) and confusing to dbx to boot.
        !            31:  * 
        !            32:  * Revision 3.8  85/01/14  04:21:53  donn
        !            33:  * Added changes to implement Jerry's '-q' option.
        !            34:  * 
        !            35:  * Revision 3.7  85/01/11  21:10:35  donn
        !            36:  * In conjunction with other changes to implement SAVE statements, function
        !            37:  * nameblocks were changed to make it appear that they are 'saved' too --
        !            38:  * this arranges things so that function return values are forced out of
        !            39:  * register before a return.
        !            40:  * 
        !            41:  * Revision 3.6  84/12/10  19:27:20  donn
        !            42:  * comblock() signals an illegal common block name by returning a null pointer,
        !            43:  * but incomm() wasn't able to handle it, leading to core dumps.  I put the
        !            44:  * fix in incomm() to pick up null common blocks.
        !            45:  * 
        !            46:  * Revision 3.5  84/11/21  20:33:31  donn
        !            47:  * It seems that I/O elements are treated as character strings so that their
        !            48:  * length can be passed to the I/O routines...  Unfortunately the compiler
        !            49:  * assumes that no temporaries can be of type CHARACTER and casually tosses
        !            50:  * length and type info away when removing TEMP blocks.  This has been fixed...
        !            51:  * 
        !            52:  * Revision 3.4  84/11/05  22:19:30  donn
        !            53:  * Fixed a silly bug in the last fix.
        !            54:  * 
        !            55:  * Revision 3.3  84/10/29  08:15:23  donn
        !            56:  * Added code to check the type and shape of subscript declarations,
        !            57:  * per Jerry Berkman's suggestion.
        !            58:  * 
        !            59:  * Revision 3.2  84/10/29  05:52:07  donn
        !            60:  * Added change suggested by Jerry Berkman to report an error when an array
        !            61:  * is redimensioned.
        !            62:  * 
        !            63:  * Revision 3.1  84/10/13  02:12:31  donn
        !            64:  * Merged Jerry Berkman's version into mine.
        !            65:  * 
        !            66:  * Revision 2.1  84/07/19  12:04:09  donn
        !            67:  * Changed comment headers for UofU.
        !            68:  * 
        !            69:  * Revision 1.6  84/07/19  11:32:15  donn
        !            70:  * Incorporated fix to setbound() to detect backward array subscript limits.
        !            71:  * The fix is by Bob Corbett, donated by Jerry Berkman.
        !            72:  * 
        !            73:  * Revision 1.5  84/07/18  18:25:50  donn
        !            74:  * Fixed problem with doentry() where a placeholder for a return value
        !            75:  * was not allocated if the first entry didn't require one but a later
        !            76:  * entry did.
        !            77:  * 
        !            78:  * Revision 1.4  84/05/24  20:52:09  donn
        !            79:  * Installed firewall #ifdef around the code that recycles stack temporaries,
        !            80:  * since it seems to be broken and lacks a good fix for the time being.
        !            81:  * 
        !            82:  * Revision 1.3  84/04/16  09:50:46  donn
        !            83:  * Fixed mkargtemp() so that it only passes back a copy of a temporary, keeping
        !            84:  * the original for its own use.  This fixes a set of bugs that are caused by
        !            85:  * elements in the argtemplist getting stomped on.
        !            86:  * 
        !            87:  * Revision 1.2  84/02/28  21:12:58  donn
        !            88:  * Added Berkeley changes for subroutine call argument temporaries fix.
        !            89:  * 
        !            90:  */
        !            91: 
        !            92: #include "defs.h"
        !            93: 
        !            94: #ifdef SDB
        !            95: #      include <a.out.h>
        !            96: #      ifndef N_SO
        !            97: #              include <stab.h>
        !            98: #      endif
        !            99: #endif
        !           100: 
        !           101: extern flag namesflag;
        !           102: 
        !           103: typedef
        !           104:   struct SizeList
        !           105:     {
        !           106:       struct SizeList *next;
        !           107:       ftnint size;
        !           108:       struct VarList *vars;
        !           109:     }
        !           110:   sizelist;
        !           111: 
        !           112: 
        !           113: typedef
        !           114:   struct VarList
        !           115:     {
        !           116:       struct VarList *next;
        !           117:       Namep np;
        !           118:       struct Equivblock *ep;
        !           119:     }
        !           120:   varlist;
        !           121: 
        !           122: 
        !           123: LOCAL sizelist *varsizes;
        !           124: 
        !           125: 
        !           126: /* start a new procedure */
        !           127: 
        !           128: newproc()
        !           129: {
        !           130: if(parstate != OUTSIDE)
        !           131:        {
        !           132:        execerr("missing end statement", CNULL);
        !           133:        endproc();
        !           134:        }
        !           135: 
        !           136: parstate = INSIDE;
        !           137: procclass = CLMAIN;    /* default */
        !           138: }
        !           139: 
        !           140: 
        !           141: 
        !           142: /* end of procedure. generate variables, epilogs, and prologs */
        !           143: 
        !           144: endproc()
        !           145: {
        !           146: struct Labelblock *lp;
        !           147: 
        !           148: if(parstate < INDATA)
        !           149:        enddcl();
        !           150: if(ctlstack >= ctls)
        !           151:        err("DO loop or BLOCK IF not closed");
        !           152: for(lp = labeltab ; lp < labtabend ; ++lp)
        !           153:        if(lp->stateno!=0 && lp->labdefined==NO)
        !           154:                errstr("missing statement number %s", convic(lp->stateno) );
        !           155: 
        !           156: if (optimflag)
        !           157:   optimize();
        !           158: 
        !           159: outiodata();
        !           160: epicode();
        !           161: procode();
        !           162: donmlist();
        !           163: dobss();
        !           164: 
        !           165: #if FAMILY == PCC
        !           166:        putbracket();
        !           167: #endif
        !           168: procinit();    /* clean up for next procedure */
        !           169: }
        !           170: 
        !           171: 
        !           172: 
        !           173: /* End of declaration section of procedure.  Allocate storage. */
        !           174: 
        !           175: enddcl()
        !           176: {
        !           177: register struct Entrypoint *ep;
        !           178: 
        !           179: parstate = INEXEC;
        !           180: docommon();
        !           181: doequiv();
        !           182: docomleng();
        !           183: for(ep = entries ; ep ; ep = ep->entnextp) {
        !           184:        doentry(ep);
        !           185: }
        !           186: }
        !           187: 
        !           188: /* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */
        !           189: 
        !           190: /* Main program or Block data */
        !           191: 
        !           192: startproc(prgname, class)
        !           193: Namep prgname;
        !           194: int class;
        !           195: {
        !           196: struct Extsym *progname;
        !           197: register struct Entrypoint *p;
        !           198: 
        !           199: if(prgname)
        !           200:        procname = prgname->varname;
        !           201: if(namesflag == YES) {
        !           202:        fprintf(diagfile, "   %s", (class==CLMAIN ? "MAIN" : "BLOCK DATA") );
        !           203:        if(prgname)
        !           204:                fprintf(diagfile, " %s", varstr(XL, procname) );
        !           205:        fprintf(diagfile, ":\n");
        !           206:        }
        !           207: 
        !           208: if( prgname ) 
        !           209:        progname = newentry( prgname );
        !           210: else
        !           211:        progname = NULL;
        !           212: 
        !           213: p = ALLOC(Entrypoint);
        !           214: if(class == CLMAIN)
        !           215:        puthead("MAIN_", CLMAIN);
        !           216: else
        !           217:        puthead(CNULL, CLBLOCK);
        !           218: if(class == CLMAIN)
        !           219:        newentry( mkname(5, "MAIN") );
        !           220: p->entryname = progname;
        !           221: p->entrylabel = newlabel();
        !           222: entries = p;
        !           223: 
        !           224: procclass = class;
        !           225: retlabel = newlabel();
        !           226: #ifdef SDB
        !           227: if(sdbflag) {
        !           228:          entrystab(p,class);
        !           229: }
        !           230: #endif
        !           231: }
        !           232: 
        !           233: /* subroutine or function statement */
        !           234: 
        !           235: struct Extsym *newentry(v)
        !           236: register Namep v;
        !           237: {
        !           238: register struct Extsym *p;
        !           239: 
        !           240: p = mkext( varunder(VL, v->varname) );
        !           241: 
        !           242: if(p==NULL || p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) )
        !           243:        {
        !           244:        if(p == 0)
        !           245:                dclerr("invalid entry name", v);
        !           246:        else    dclerr("external name already used", v);
        !           247:        return(0);
        !           248:        }
        !           249: v->vstg = STGAUTO;
        !           250: v->vprocclass = PTHISPROC;
        !           251: v->vclass = CLPROC;
        !           252: p->extstg = STGEXT;
        !           253: p->extinit = YES;
        !           254: return(p);
        !           255: }
        !           256: 
        !           257: 
        !           258: entrypt(class, type, length, entname, args)
        !           259: int class, type;
        !           260: ftnint length;
        !           261: Namep entname;
        !           262: chainp args;
        !           263: {
        !           264: struct Extsym *entry;
        !           265: register Namep q;
        !           266: register struct Entrypoint *p, *ep;
        !           267: 
        !           268: if(namesflag == YES) {
        !           269:        if(class == CLENTRY)
        !           270:                fprintf(diagfile, "       entry ");
        !           271:        if(entname)
        !           272:                fprintf(diagfile, "   %s", varstr(XL, entname->varname) );
        !           273:        fprintf(diagfile, ":\n");
        !           274:        }
        !           275: 
        !           276: if( entname->vclass == CLPARAM ) {
        !           277:        errstr("entry name %s used in 'parameter' statement", 
        !           278:                varstr(XL, entname->varname) );
        !           279:        return;
        !           280:        }
        !           281: if( ((type == TYSUBR) || (class == CLENTRY && proctype == TYSUBR)) 
        !           282:        && (entname->vtype != TYUNKNOWN && entname->vtype != TYSUBR) ) {
        !           283:        errstr("subroutine entry %s previously declared",
        !           284:                varstr(XL, entname->varname) );
        !           285:        return;
        !           286:        }
        !           287: if(  (entname->vstg != STGEXT && entname->vstg != STGUNKNOWN)
        !           288:        ||  (entname->vdim != NULL) ) {
        !           289:        errstr("subroutine or function entry %s previously declared",
        !           290:                varstr(XL, entname->varname) );
        !           291:        return;
        !           292:        }
        !           293: 
        !           294: if( (class == CLPROC || class == CLENTRY) && type != TYSUBR )
        !           295:        /* arrange to save function return values */
        !           296:        entname->vsave = YES;
        !           297:        
        !           298: entry = newentry( entname );
        !           299: 
        !           300: if(class != CLENTRY)
        !           301:        puthead( varstr(XL, procname = entry->extname), class);
        !           302: q = mkname(VL, nounder(XL,entry->extname) );
        !           303: 
        !           304: if( (type = lengtype(type, (int) length)) != TYCHAR)
        !           305:        length = 0;
        !           306: if(class == CLPROC)
        !           307:        {
        !           308:        procclass = CLPROC;
        !           309:        proctype = type;
        !           310:        procleng = length;
        !           311: 
        !           312:        retlabel = newlabel();
        !           313:        if(type == TYSUBR)
        !           314:                ret0label = newlabel();
        !           315:        }
        !           316: 
        !           317: p = ALLOC(Entrypoint);
        !           318: if(entries)    /* put new block at end of entries list */
        !           319:        {
        !           320:        for(ep = entries; ep->entnextp; ep = ep->entnextp)
        !           321:                ;
        !           322:        ep->entnextp = p;
        !           323:        }
        !           324: else
        !           325:        entries = p;
        !           326: 
        !           327: p->entryname = entry;
        !           328: p->arglist = args;
        !           329: p->entrylabel = newlabel();
        !           330: p->enamep = q;
        !           331: 
        !           332: if(class == CLENTRY)
        !           333:        {
        !           334:        class = CLPROC;
        !           335:        if(proctype == TYSUBR)
        !           336:                type = TYSUBR;
        !           337:        }
        !           338: 
        !           339: q->vclass = class;
        !           340: q->vprocclass = PTHISPROC;
        !           341: settype(q, type, (int) length);
        !           342: /* hold all initial entry points till end of declarations */
        !           343: if(parstate >= INDATA) {
        !           344:        doentry(p);
        !           345: }
        !           346: #ifdef SDB
        !           347:        if(sdbflag)
        !           348:        { /* may need to preserve CLENTRY here */
        !           349:        entrystab(p,class);
        !           350:        }
        !           351: #endif
        !           352: }
        !           353: 
        !           354: /* generate epilogs */
        !           355: 
        !           356: LOCAL epicode()
        !           357: {
        !           358: register int i;
        !           359: 
        !           360: if(procclass==CLPROC)
        !           361:        {
        !           362:        if(proctype==TYSUBR)
        !           363:                {
        !           364:                putlabel(ret0label);
        !           365:                if(substars)
        !           366:                        putforce(TYINT, ICON(0) );
        !           367:                putlabel(retlabel);
        !           368:                goret(TYSUBR);
        !           369:                }
        !           370:        else    {
        !           371:                putlabel(retlabel);
        !           372:                if(multitype)
        !           373:                        {
        !           374:                        typeaddr = autovar(1, TYADDR, PNULL);
        !           375:                        putbranch( cpexpr(typeaddr) );
        !           376:                        for(i = 0; i < NTYPES ; ++i)
        !           377:                                if(rtvlabel[i] != 0)
        !           378:                                        {
        !           379:                                        putlabel(rtvlabel[i]);
        !           380:                                        retval(i);
        !           381:                                        }
        !           382:                        }
        !           383:                else
        !           384:                        retval(proctype);
        !           385:                }
        !           386:        }
        !           387: 
        !           388: else if(procclass != CLBLOCK)
        !           389:        {
        !           390:        putlabel(retlabel);
        !           391:        goret(TYSUBR);
        !           392:        }
        !           393: }
        !           394: 
        !           395: 
        !           396: /* generate code to return value of type  t */
        !           397: 
        !           398: LOCAL retval(t)
        !           399: register int t;
        !           400: {
        !           401: register Addrp p;
        !           402: 
        !           403: switch(t)
        !           404:        {
        !           405:        case TYCHAR:
        !           406:        case TYCOMPLEX:
        !           407:        case TYDCOMPLEX:
        !           408:                break;
        !           409: 
        !           410:        case TYLOGICAL:
        !           411:                t = tylogical;
        !           412:        case TYADDR:
        !           413:        case TYSHORT:
        !           414:        case TYLONG:
        !           415:                p = (Addrp) cpexpr(retslot);
        !           416:                p->vtype = t;
        !           417:                putforce(t, p);
        !           418:                break;
        !           419: 
        !           420:        case TYREAL:
        !           421:        case TYDREAL:
        !           422:                p = (Addrp) cpexpr(retslot);
        !           423:                p->vtype = t;
        !           424:                putforce(t, p);
        !           425:                break;
        !           426: 
        !           427:        case TYERROR:
        !           428:                return;         /* someone else already complained */
        !           429: 
        !           430:        default:
        !           431:                badtype("retval", t);
        !           432:        }
        !           433: goret(t);
        !           434: }
        !           435: 
        !           436: 
        !           437: /* Allocate extra argument array if needed. Generate prologs. */
        !           438: 
        !           439: LOCAL procode()
        !           440: {
        !           441: register struct Entrypoint *p;
        !           442: Addrp argvec;
        !           443: 
        !           444: #if TARGET==GCOS 
        !           445:        argvec = autovar(lastargslot/SZADDR, TYADDR, PNULL);
        !           446: #else
        !           447:        if(lastargslot>0 && nentry>1)
        !           448: #if TARGET == VAX || TARGET == TAHOE
        !           449:                argvec = autovar(1 + lastargslot/SZADDR, TYADDR, PNULL);
        !           450: #else
        !           451:                argvec = autovar(lastargslot/SZADDR, TYADDR, PNULL);
        !           452: #endif
        !           453:        else
        !           454:                argvec = NULL;
        !           455: #endif
        !           456: 
        !           457: 
        !           458: #if TARGET == PDP11
        !           459:        /* for the optimizer */
        !           460:        if(fudgelabel)
        !           461:                putlabel(fudgelabel);
        !           462: #endif
        !           463: 
        !           464: for(p = entries ; p ; p = p->entnextp)
        !           465:        prolog(p, argvec);
        !           466: 
        !           467: #if FAMILY == PCC
        !           468:        putrbrack(procno);
        !           469: #endif
        !           470: 
        !           471: prendproc();
        !           472: }
        !           473: 
        !           474: 
        !           475: /*
        !           476:    manipulate argument lists (allocate argument slot positions)
        !           477:  * keep track of return types and labels
        !           478:  */
        !           479: 
        !           480: LOCAL doentry(ep)
        !           481: struct Entrypoint *ep;
        !           482: {
        !           483: register int type;
        !           484: register Namep np;
        !           485: chainp p;
        !           486: register Namep q;
        !           487: Addrp mkarg();
        !           488: 
        !           489: ++nentry;
        !           490: if(procclass == CLMAIN)
        !           491:        {
        !           492:        if (optimflag)
        !           493:                optbuff (SKLABEL, 0, ep->entrylabel, 0);
        !           494:        else
        !           495:                putlabel(ep->entrylabel);
        !           496:        return;
        !           497:        }
        !           498: else if(procclass == CLBLOCK)
        !           499:        return;
        !           500: 
        !           501: impldcl( np = mkname(VL, nounder(XL, ep->entryname->extname) ) );
        !           502: type = np->vtype;
        !           503: if(proctype == TYUNKNOWN)
        !           504:        if( (proctype = type) == TYCHAR)
        !           505:                procleng = (np->vleng ? np->vleng->constblock.const.ci : (ftnint) (-1));
        !           506: 
        !           507: if(proctype == TYCHAR)
        !           508:        {
        !           509:        if(type != TYCHAR)
        !           510:                err("noncharacter entry of character function");
        !           511:        else if( (np->vleng ? np->vleng->constblock.const.ci : (ftnint) (-1)) != procleng)
        !           512:                err("mismatched character entry lengths");
        !           513:        }
        !           514: else if(type == TYCHAR)
        !           515:        err("character entry of noncharacter function");
        !           516: else if(type != proctype)
        !           517:        multitype = YES;
        !           518: if(rtvlabel[type] == 0)
        !           519:        rtvlabel[type] = newlabel();
        !           520: ep->typelabel = rtvlabel[type];
        !           521: 
        !           522: if(type == TYCHAR)
        !           523:        {
        !           524:        if(chslot < 0)
        !           525:                {
        !           526:                chslot = nextarg(TYADDR);
        !           527:                chlgslot = nextarg(TYLENG);
        !           528:                }
        !           529:        np->vstg = STGARG;
        !           530:        np->vardesc.varno = chslot;
        !           531:        if(procleng < 0)
        !           532:                np->vleng = (expptr) mkarg(TYLENG, chlgslot);
        !           533:        }
        !           534: else if( ISCOMPLEX(type) )
        !           535:        {
        !           536:        np->vstg = STGARG;
        !           537:        if(cxslot < 0)
        !           538:                cxslot = nextarg(TYADDR);
        !           539:        np->vardesc.varno = cxslot;
        !           540:        }
        !           541: else if(type != TYSUBR)
        !           542:        {
        !           543:        if(retslot == NULL)
        !           544:                retslot = autovar(1, TYDREAL, PNULL);
        !           545:        np->vstg = STGAUTO;
        !           546:        np->voffset = retslot->memoffset->constblock.const.ci;
        !           547:        }
        !           548: 
        !           549: for(p = ep->arglist ; p ; p = p->nextp)
        !           550:        if(! (( q = (Namep) (p->datap) )->vdcldone) )
        !           551:                q->vardesc.varno = nextarg(TYADDR);
        !           552: 
        !           553: for(p = ep->arglist ; p ; p = p->nextp)
        !           554:        if(! (( q = (Namep) (p->datap) )->vdcldone) )
        !           555:                {
        !           556:                impldcl(q);
        !           557:                q->vdcldone = YES;
        !           558:                if(q->vtype == TYCHAR)
        !           559:                        {
        !           560:                        if(q->vleng == NULL)    /* character*(*) */
        !           561:                                q->vleng = (expptr)
        !           562:                                                mkarg(TYLENG, nextarg(TYLENG) );
        !           563:                        else if(nentry == 1)
        !           564:                                nextarg(TYLENG);
        !           565:                        }
        !           566:                else if(q->vclass==CLPROC && nentry==1)
        !           567:                        nextarg(TYLENG) ;
        !           568: #ifdef SDB
        !           569:                if(sdbflag) {
        !           570:                        namestab(q);
        !           571:                }
        !           572: #endif
        !           573:                }
        !           574: 
        !           575: if (optimflag)
        !           576:        optbuff (SKLABEL, 0, ep->entrylabel, 0);
        !           577: else
        !           578:        putlabel(ep->entrylabel);
        !           579: }
        !           580: 
        !           581: 
        !           582: 
        !           583: LOCAL nextarg(type)
        !           584: int type;
        !           585: {
        !           586: int k;
        !           587: k = lastargslot;
        !           588: lastargslot += typesize[type];
        !           589: return(k);
        !           590: }
        !           591: 
        !           592: /* generate variable references */
        !           593: 
        !           594: LOCAL dobss()
        !           595: {
        !           596: register struct Hashentry *p;
        !           597: register Namep q;
        !           598: register int i;
        !           599: int align;
        !           600: ftnint leng, iarrl;
        !           601: char *memname();
        !           602: int qstg, qclass, qtype;
        !           603: 
        !           604: pruse(asmfile, USEBSS);
        !           605: varsizes = NULL;
        !           606: 
        !           607: for(p = hashtab ; p<lasthash ; ++p)
        !           608:     if(q = p->varp)
        !           609:        {
        !           610:        qstg = q->vstg;
        !           611:        qtype = q->vtype;
        !           612:        qclass = q->vclass;
        !           613: 
        !           614:        if( (qclass==CLUNKNOWN && qstg!=STGARG) ||
        !           615:            (qclass==CLVAR && qstg==STGUNKNOWN) )
        !           616:                warn1("local variable %s never used", varstr(VL,q->varname) );
        !           617:        else if(qclass==CLPROC && q->vprocclass==PEXTERNAL && qstg!=STGARG)
        !           618:                mkext(varunder(VL, q->varname)) ->extstg = STGEXT;
        !           619: 
        !           620:        if (qclass == CLVAR && qstg == STGBSS)
        !           621:          {
        !           622:            if (SMALLVAR(q->varsize))
        !           623:              {
        !           624:                enlist(q->varsize, q, NULL);
        !           625:                q->inlcomm = NO;
        !           626:              }
        !           627:            else
        !           628:              {
        !           629:                if (q->init == NO)
        !           630:                  {
        !           631:                    preven(ALIDOUBLE);
        !           632:                    prlocvar(memname(qstg, q->vardesc.varno), q->varsize);
        !           633:                    q->inlcomm = YES;
        !           634:                  }
        !           635:                else
        !           636:                  prlocdata(memname(qstg, q->vardesc.varno), q->varsize,
        !           637:                            q->vtype, q->initoffset, &(q->inlcomm));
        !           638:              }
        !           639:          }
        !           640:        else if(qclass==CLVAR && qstg!=STGARG)
        !           641:                {
        !           642:                if(q->vdim && !ISICON(q->vdim->nelt) )
        !           643:                        dclerr("adjustable dimension on non-argument", q);
        !           644:                if(qtype==TYCHAR && (q->vleng==NULL || !ISICON(q->vleng)))
        !           645:                        dclerr("adjustable leng on nonargument", q);
        !           646:                }
        !           647: 
        !           648:        chkdim(q);
        !           649:        }
        !           650: 
        !           651: for (i = 0 ; i < nequiv ; ++i)
        !           652:   if ( (leng = eqvclass[i].eqvleng) != 0 )
        !           653:     {
        !           654:       if (SMALLVAR(leng))
        !           655:        enlist(leng, NULL, eqvclass + i);
        !           656:       else if (eqvclass[i].init == NO)
        !           657:        {
        !           658:          preven(ALIDOUBLE);
        !           659:          prlocvar(memname(STGEQUIV, i), leng);
        !           660:          eqvclass[i].inlcomm = YES;
        !           661:        }
        !           662:       else
        !           663:        prlocdata(memname(STGEQUIV, i), leng, TYDREAL, 
        !           664:                  eqvclass[i].initoffset, &(eqvclass[i].inlcomm));
        !           665:     }
        !           666: 
        !           667:   outlocvars();
        !           668: #ifdef SDB
        !           669:     if(sdbflag) {
        !           670:       for(p = hashtab ; p<lasthash ; ++p) if(q = p->varp) {
        !           671:          qstg = q->vstg;
        !           672:          qclass = q->vclass;
        !           673:           if( ONEOF(qclass, M(CLVAR))) {
        !           674:             if (! ONEOF(qstg,M(STGCOMMON)|M(STGARG) ) ) namestab(q);
        !           675:          } 
        !           676:       }
        !           677:     }
        !           678: #endif
        !           679: 
        !           680:   close(vdatafile);
        !           681:   close(vchkfile);
        !           682:   unlink(vdatafname);
        !           683:   unlink(vchkfname);
        !           684:   vdatahwm = 0;
        !           685: }
        !           686: 
        !           687: 
        !           688: 
        !           689: donmlist()
        !           690: {
        !           691: register struct Hashentry *p;
        !           692: register Namep q;
        !           693: 
        !           694: pruse(asmfile, USEINIT);
        !           695: 
        !           696: for(p=hashtab; p<lasthash; ++p)
        !           697:        if( (q = p->varp) && q->vclass==CLNAMELIST)
        !           698:                namelist(q);
        !           699: }
        !           700: 
        !           701: 
        !           702: doext()
        !           703: {
        !           704: struct Extsym *p;
        !           705: 
        !           706: for(p = extsymtab ; p<nextext ; ++p)
        !           707:        prext(p);
        !           708: }
        !           709: 
        !           710: 
        !           711: 
        !           712: 
        !           713: ftnint iarrlen(q)
        !           714: register Namep q;
        !           715: {
        !           716: ftnint leng;
        !           717: 
        !           718: leng = typesize[q->vtype];
        !           719: if(leng <= 0)
        !           720:        return(-1);
        !           721: if(q->vdim)
        !           722:        if( ISICON(q->vdim->nelt) )
        !           723:                leng *= q->vdim->nelt->constblock.const.ci;
        !           724:        else    return(-1);
        !           725: if(q->vleng)
        !           726:        if( ISICON(q->vleng) )
        !           727:                leng *= q->vleng->constblock.const.ci;
        !           728:        else    return(-1);
        !           729: return(leng);
        !           730: }
        !           731: 
        !           732: /* This routine creates a static block representing the namelist.
        !           733:    An equivalent declaration of the structure produced is:
        !           734:        struct namelist
        !           735:                {
        !           736:                char namelistname[16];
        !           737:                struct namelistentry
        !           738:                        {
        !           739:                        char varname[16];
        !           740:                        char *varaddr;
        !           741:                        int type; # negative means -type= number of chars
        !           742:                        struct dimensions *dimp; # null means scalar
        !           743:                        } names[];
        !           744:                };
        !           745: 
        !           746:        struct dimensions
        !           747:                {
        !           748:                int numberofdimensions;
        !           749:                int numberofelements
        !           750:                int baseoffset;
        !           751:                int span[numberofdimensions];
        !           752:                };
        !           753:    where the namelistentry list terminates with a null varname
        !           754:    If dimp is not null, then the corner element of the array is at
        !           755:    varaddr.  However,  the element with subscripts (i1,...,in) is at
        !           756:    varaddr - dimp->baseoffset + sizeoftype * (i1+span[0]*(i2+span[1]*...)
        !           757: */
        !           758: 
        !           759: namelist(np)
        !           760: Namep np;
        !           761: {
        !           762: register chainp q;
        !           763: register Namep v;
        !           764: register struct Dimblock *dp;
        !           765: char *memname();
        !           766: int type, dimno, dimoffset;
        !           767: flag bad;
        !           768: 
        !           769: 
        !           770: preven(ALILONG);
        !           771: fprintf(asmfile, LABELFMT, memname(STGINIT, np->vardesc.varno));
        !           772: putstr(asmfile, varstr(VL, np->varname), 16);
        !           773: dimno = ++lastvarno;
        !           774: dimoffset = 0;
        !           775: bad = NO;
        !           776: 
        !           777: for(q = np->varxptr.namelist ; q ; q = q->nextp)
        !           778:        {
        !           779:        vardcl( v = (Namep) (q->datap) );
        !           780:        type = v->vtype;
        !           781:        if( ONEOF(v->vstg, MSKSTATIC) )
        !           782:                {
        !           783:                preven(ALILONG);
        !           784:                putstr(asmfile, varstr(VL,v->varname), 16);
        !           785:                praddr(asmfile, v->vstg, v->vardesc.varno, v->voffset);
        !           786:                prconi(asmfile, TYINT,
        !           787:                        type==TYCHAR ?
        !           788:                            -(v->vleng->constblock.const.ci) : (ftnint) type);
        !           789:                if(v->vdim)
        !           790:                        {
        !           791:                        praddr(asmfile, STGINIT, dimno, (ftnint)dimoffset);
        !           792:                        dimoffset += 3 + v->vdim->ndim;
        !           793:                        }
        !           794:                else
        !           795:                        praddr(asmfile, STGNULL,0,(ftnint) 0);
        !           796:                }
        !           797:        else
        !           798:                {
        !           799:                dclerr("may not appear in namelist", v);
        !           800:                bad = YES;
        !           801:                }
        !           802:        }
        !           803: 
        !           804: if(bad)
        !           805:        return;
        !           806: 
        !           807: putstr(asmfile, "", 16);
        !           808: 
        !           809: if(dimoffset > 0)
        !           810:        {
        !           811:        fprintf(asmfile, LABELFMT, memname(STGINIT,dimno));
        !           812:        for(q = np->varxptr.namelist ; q ; q = q->nextp)
        !           813:                if(dp = q->datap->nameblock.vdim)
        !           814:                        {
        !           815:                        int i;
        !           816:                        prconi(asmfile, TYINT, (ftnint) (dp->ndim) );
        !           817:                        prconi(asmfile, TYINT,
        !           818:                                (ftnint) (dp->nelt->constblock.const.ci) );
        !           819:                        prconi(asmfile, TYINT,
        !           820:                                (ftnint) (dp->baseoffset->constblock.const.ci));
        !           821:                        for(i=0; i<dp->ndim ; ++i)
        !           822:                                prconi(asmfile, TYINT,
        !           823:                                        dp->dims[i].dimsize->constblock.const.ci);
        !           824:                        }
        !           825:        }
        !           826: 
        !           827: }
        !           828: 
        !           829: LOCAL docommon()
        !           830: {
        !           831: register struct Extsym *p;
        !           832: register chainp q;
        !           833: struct Dimblock *t;
        !           834: expptr neltp;
        !           835: register Namep v;
        !           836: ftnint size;
        !           837: int type;
        !           838: 
        !           839: for(p = extsymtab ; p<nextext ; ++p)
        !           840:        if(p->extstg==STGCOMMON)
        !           841:                {
        !           842: #ifdef SDB
        !           843:                if(sdbflag)
        !           844:                        prstab(varstr(XL,p->extname), N_BCOMM, 0, 0);
        !           845: #endif
        !           846:                for(q = p->extp ; q ; q = q->nextp)
        !           847:                        {
        !           848:                        v = (Namep) (q->datap);
        !           849:                        if(v->vdcldone == NO)
        !           850:                                vardcl(v);
        !           851:                        type = v->vtype;
        !           852:                        if(p->extleng % typealign[type] != 0)
        !           853:                                {
        !           854:                                dclerr("common alignment", v);
        !           855:                                p->extleng = roundup(p->extleng, typealign[type]);
        !           856:                                }
        !           857:                        v->voffset = p->extleng;
        !           858:                        v->vardesc.varno = p - extsymtab;
        !           859:                        if(type == TYCHAR)
        !           860:                                size = v->vleng->constblock.const.ci;
        !           861:                        else    size = typesize[type];
        !           862:                        if(t = v->vdim)
        !           863:                                if( (neltp = t->nelt) && ISCONST(neltp) )
        !           864:                                        size *= neltp->constblock.const.ci;
        !           865:                                else
        !           866:                                        dclerr("adjustable array in common", v);
        !           867:                        p->extleng += size;
        !           868: #ifdef SDB
        !           869:                        if(sdbflag)
        !           870:                                {
        !           871:                                namestab(v);
        !           872:                                }
        !           873: #endif
        !           874:                        }
        !           875: 
        !           876:                frchain( &(p->extp) );
        !           877: #ifdef SDB
        !           878:                if(sdbflag)
        !           879:                        prstab(varstr(XL,p->extname), N_ECOMM, 0, 0);
        !           880: #endif
        !           881:                }
        !           882: }
        !           883: 
        !           884: 
        !           885: 
        !           886: 
        !           887: 
        !           888: LOCAL docomleng()
        !           889: {
        !           890: register struct Extsym *p;
        !           891: 
        !           892: for(p = extsymtab ; p < nextext ; ++p)
        !           893:        if(p->extstg == STGCOMMON)
        !           894:                {
        !           895:                if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng
        !           896:                    && !eqn(XL,"_BLNK__ ",p->extname) )
        !           897:                        warn1("incompatible lengths for common block %s",
        !           898:                                nounder(XL, p->extname) );
        !           899:                if(p->maxleng < p->extleng)
        !           900:                        p->maxleng = p->extleng;
        !           901:                p->extleng = 0;
        !           902:        }
        !           903: }
        !           904: 
        !           905: 
        !           906: 
        !           907: 
        !           908: /* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */
        !           909: 
        !           910: /*  frees a temporary block  */
        !           911: 
        !           912: frtemp(p)
        !           913: Tempp p;
        !           914: {
        !           915: Addrp t;
        !           916: 
        !           917: if (optimflag)
        !           918:        {
        !           919:        if (p->tag != TTEMP)
        !           920:                badtag ("frtemp",p->tag);
        !           921:        t = p->memalloc;
        !           922:        }
        !           923: else
        !           924:        t = (Addrp) p;
        !           925: 
        !           926: /* restore clobbered character string lengths */
        !           927: if(t->vtype==TYCHAR && t->varleng!=0)
        !           928:        {
        !           929:        frexpr(t->vleng);
        !           930:        t->vleng = ICON(t->varleng);
        !           931:        }
        !           932: 
        !           933: /* put block on chain of temps to be reclaimed */
        !           934: holdtemps = mkchain(t, holdtemps);
        !           935: }
        !           936: 
        !           937: 
        !           938: 
        !           939: /* allocate an automatic variable slot */
        !           940: 
        !           941: Addrp autovar(nelt, t, lengp)
        !           942: register int nelt, t;
        !           943: expptr lengp;
        !           944: {
        !           945: ftnint leng;
        !           946: register Addrp q;
        !           947: 
        !           948: if(lengp)
        !           949:        if( ISICON(lengp) )
        !           950:                leng = lengp->constblock.const.ci;
        !           951:        else    {
        !           952:                fatal("automatic variable of nonconstant length");
        !           953:                }
        !           954: else
        !           955:        leng = typesize[t];
        !           956: autoleng = roundup( autoleng, typealign[t]);
        !           957: 
        !           958: q = ALLOC(Addrblock);
        !           959: q->tag = TADDR;
        !           960: q->vtype = t;
        !           961: if(lengp)
        !           962:        {
        !           963:        q->vleng = ICON(leng);
        !           964:        q->varleng = leng;
        !           965:        }
        !           966: q->vstg = STGAUTO;
        !           967: q->memno = newlabel();
        !           968: q->ntempelt = nelt;
        !           969: #if TARGET==PDP11 || TARGET==VAX || TARGET == TAHOE
        !           970:        /* stack grows downward */
        !           971:        autoleng += nelt*leng;
        !           972:        q->memoffset = ICON( - autoleng );
        !           973: #else
        !           974:        q->memoffset = ICON( autoleng );
        !           975:        autoleng += nelt*leng;
        !           976: #endif
        !           977: 
        !           978: return(q);
        !           979: }
        !           980: 
        !           981: 
        !           982: 
        !           983: /*
        !           984:  *  create a temporary block (TTEMP) when optimizing,
        !           985:  *  an ordinary TADDR block when not optimizing
        !           986:  */
        !           987: 
        !           988: Tempp mktmpn(nelt, type, lengp)
        !           989: int nelt;
        !           990: register int type;
        !           991: expptr lengp;
        !           992: {
        !           993: ftnint leng;
        !           994: chainp p, oldp;
        !           995: register Tempp q;
        !           996: Addrp altemp;
        !           997: 
        !           998: if (! optimflag)
        !           999:        return ( (Tempp) mkaltmpn(nelt,type,lengp) );
        !          1000: if(type==TYUNKNOWN || type==TYERROR)
        !          1001:        badtype("mktmpn", type);
        !          1002: 
        !          1003: if(type==TYCHAR)
        !          1004:        if( ISICON(lengp) )
        !          1005:                leng = lengp->constblock.const.ci;
        !          1006:        else    {
        !          1007:                err("adjustable length");
        !          1008:                return( (Tempp) errnode() );
        !          1009:                }
        !          1010: else
        !          1011:        leng = typesize[type];
        !          1012: 
        !          1013: q = ALLOC(Tempblock);
        !          1014: q->tag = TTEMP;
        !          1015: q->vtype = type;
        !          1016: if(type == TYCHAR)
        !          1017:        {
        !          1018:        q->vleng = ICON(leng);
        !          1019:        q->varleng = leng;
        !          1020:        }
        !          1021: 
        !          1022: altemp = ALLOC(Addrblock);
        !          1023: altemp->tag = TADDR;
        !          1024: altemp->vstg = STGUNKNOWN;
        !          1025: q->memalloc = altemp;
        !          1026: 
        !          1027: q->ntempelt = nelt;
        !          1028: q->istemp = YES;
        !          1029: return(q);
        !          1030: }
        !          1031: 
        !          1032: 
        !          1033: 
        !          1034: Addrp mktemp(type, lengp)
        !          1035: int type;
        !          1036: expptr lengp;
        !          1037: {
        !          1038: return( (Addrp) mktmpn(1,type,lengp) );
        !          1039: }
        !          1040: 
        !          1041: 
        !          1042: 
        !          1043: /*  allocate a temporary location for the given temporary block;
        !          1044:     if already allocated, return its location  */
        !          1045: 
        !          1046: Addrp altmpn(tp)
        !          1047: Tempp tp;
        !          1048: 
        !          1049: {
        !          1050: Addrp t, q;
        !          1051: 
        !          1052: if (tp->tag != TTEMP)
        !          1053:        badtag ("altmpn",tp->tag);
        !          1054: 
        !          1055: t = tp->memalloc;
        !          1056: if (t->vstg != STGUNKNOWN)
        !          1057:        {
        !          1058:        if (tp->vtype == TYCHAR)
        !          1059:                {
        !          1060:                /*
        !          1061:                 * Unformatted I/O parameters are treated like character
        !          1062:                 *      strings (sigh) -- propagate type and length.
        !          1063:                 */
        !          1064:                t = (Addrp) cpexpr(t);
        !          1065:                t->vtype = tp->vtype;
        !          1066:                t->vleng = tp->vleng;
        !          1067:                t->varleng = tp->varleng;
        !          1068:                }
        !          1069:        return (t);
        !          1070:        }
        !          1071: 
        !          1072: q = mkaltmpn (tp->ntempelt, tp->vtype, tp->vleng);
        !          1073: cpn (sizeof(struct Addrblock), (char*)q, (char*)t);
        !          1074: free ( (charptr) q);
        !          1075: return(t);
        !          1076: }
        !          1077: 
        !          1078: 
        !          1079: 
        !          1080: /*  create and allocate space immediately for a temporary  */
        !          1081: 
        !          1082: Addrp mkaltemp(type,lengp)
        !          1083: int type;
        !          1084: expptr lengp;
        !          1085: {
        !          1086: return (mkaltmpn(1,type,lengp));
        !          1087: }
        !          1088: 
        !          1089: 
        !          1090: 
        !          1091: Addrp mkaltmpn(nelt,type,lengp)
        !          1092: int nelt;
        !          1093: register int type;
        !          1094: expptr lengp;
        !          1095: {
        !          1096: ftnint leng;
        !          1097: chainp p, oldp;
        !          1098: register Addrp q;
        !          1099: 
        !          1100: if(type==TYUNKNOWN || type==TYERROR)
        !          1101:        badtype("mkaltmpn", type);
        !          1102: 
        !          1103: if(type==TYCHAR)
        !          1104:        if( ISICON(lengp) )
        !          1105:                leng = lengp->constblock.const.ci;
        !          1106:        else    {
        !          1107:                err("adjustable length");
        !          1108:                return( (Addrp) errnode() );
        !          1109:                }
        !          1110: 
        !          1111: /*
        !          1112:  * if a temporary of appropriate shape is on the templist,
        !          1113:  * remove it from the list and return it
        !          1114:  */
        !          1115: 
        !          1116: #ifdef notdef
        !          1117: /*
        !          1118:  * This code is broken until SKFRTEMP slots can be processed in putopt()
        !          1119:  *     instead of in optimize() -- all kinds of things in putpcc.c can
        !          1120:  *     bomb because of this.  Sigh.
        !          1121:  */
        !          1122: for(oldp=CHNULL, p=templist  ;  p  ;  oldp=p, p=p->nextp)
        !          1123:        {
        !          1124:        q = (Addrp) (p->datap);
        !          1125:        if(q->vtype==type && q->ntempelt==nelt &&
        !          1126:            (type!=TYCHAR || q->vleng->constblock.const.ci==leng) )
        !          1127:                {
        !          1128:                if(oldp)
        !          1129:                        oldp->nextp = p->nextp;
        !          1130:                else
        !          1131:                        templist = p->nextp;
        !          1132:                free( (charptr) p);
        !          1133: 
        !          1134:                if (debugflag[14])
        !          1135:                        fprintf(diagfile,"mkaltmpn reusing offset %d\n",
        !          1136:                                q->memoffset->constblock.const.ci);
        !          1137:                return(q);
        !          1138:                }
        !          1139:        }
        !          1140: #endif notdef
        !          1141: q = autovar(nelt, type, lengp);
        !          1142: q->istemp = YES;
        !          1143: 
        !          1144: if (debugflag[14])
        !          1145:        fprintf(diagfile,"mkaltmpn new offset %d\n",
        !          1146:                q->memoffset->constblock.const.ci);
        !          1147: return(q);
        !          1148: }
        !          1149: 
        !          1150: 
        !          1151: 
        !          1152: /*  The following routine is a patch which is only needed because the  */
        !          1153: /*  code for processing actual arguments for calls does not allocate   */
        !          1154: /*  the temps it needs before optimization takes place.  A better      */
        !          1155: /*  solution is possible, but I do not have the time to implement it   */
        !          1156: /*  now.                                                               */
        !          1157: /*                                                                     */
        !          1158: /*                                     Robert P. Corbett               */
        !          1159: 
        !          1160: Addrp
        !          1161: mkargtemp(type, lengp)
        !          1162: int type;
        !          1163: expptr lengp;
        !          1164: {
        !          1165:   ftnint leng;
        !          1166:   chainp oldp, p;
        !          1167:   Addrp q;
        !          1168: 
        !          1169:   if (type == TYUNKNOWN || type == TYERROR)
        !          1170:     badtype("mkargtemp", type);
        !          1171: 
        !          1172:   if (type == TYCHAR)
        !          1173:     {
        !          1174:       if (ISICON(lengp))
        !          1175:        leng = lengp->constblock.const.ci;
        !          1176:       else
        !          1177:        {
        !          1178:          err("adjustable length");
        !          1179:          return ((Addrp) errnode());
        !          1180:        }
        !          1181:     }
        !          1182: 
        !          1183:   oldp = CHNULL;
        !          1184:   p = argtemplist;
        !          1185: 
        !          1186:   while (p)
        !          1187:     {
        !          1188:       q = (Addrp) (p->datap);
        !          1189:       if (q->vtype == type
        !          1190:          && (type != TYCHAR || q->vleng->constblock.const.ci == leng))
        !          1191:        {
        !          1192:          if (oldp)
        !          1193:            oldp->nextp = p->nextp;
        !          1194:          else
        !          1195:            argtemplist = p->nextp;
        !          1196: 
        !          1197:          p->nextp = activearglist;
        !          1198:          activearglist = p;
        !          1199: 
        !          1200:          return ((Addrp) cpexpr(q));
        !          1201:        }
        !          1202: 
        !          1203:       oldp = p;
        !          1204:       p = p->nextp;
        !          1205:     }
        !          1206: 
        !          1207:   q = autovar(1, type, lengp);
        !          1208:   activearglist = mkchain(q, activearglist);
        !          1209:   return ((Addrp) cpexpr(q));
        !          1210: }
        !          1211: 
        !          1212: /* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */
        !          1213: 
        !          1214: struct Extsym *comblock(len, s)
        !          1215: register int len;
        !          1216: register char *s;
        !          1217: {
        !          1218: struct Extsym *p;
        !          1219: 
        !          1220: if(len == 0)
        !          1221:        {
        !          1222:        s = BLANKCOMMON;
        !          1223:        len = strlen(s);
        !          1224:        }
        !          1225: p = mkext( varunder(len, s) );
        !          1226: if(p->extstg == STGUNKNOWN)
        !          1227:        p->extstg = STGCOMMON;
        !          1228: else if(p->extstg != STGCOMMON)
        !          1229:        {
        !          1230:        errstr("%s cannot be a common block name", s);
        !          1231:        return(0);
        !          1232:        }
        !          1233: 
        !          1234: return( p );
        !          1235: }
        !          1236: 
        !          1237: 
        !          1238: incomm(c, v)
        !          1239: struct Extsym *c;
        !          1240: Namep v;
        !          1241: {
        !          1242: if(v->vstg != STGUNKNOWN)
        !          1243:        dclerr("incompatible common declaration", v);
        !          1244: else
        !          1245:        {
        !          1246:        if(c == (struct Extsym *) 0)
        !          1247:                return;         /* Illegal common block name upstream */
        !          1248:        v->vstg = STGCOMMON;
        !          1249:        c->extp = hookup(c->extp, mkchain(v,CHNULL) );
        !          1250:        }
        !          1251: }
        !          1252: 
        !          1253: 
        !          1254: 
        !          1255: 
        !          1256: settype(v, type, length)
        !          1257: register Namep  v;
        !          1258: register int type;
        !          1259: register int length;
        !          1260: {
        !          1261: if(type == TYUNKNOWN)
        !          1262:        return;
        !          1263: 
        !          1264: if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG)
        !          1265:        {
        !          1266:        v->vtype = TYSUBR;
        !          1267:        frexpr(v->vleng);
        !          1268:        }
        !          1269: else if(type < 0)      /* storage class set */
        !          1270:        {
        !          1271:        if(v->vstg == STGUNKNOWN)
        !          1272:                v->vstg = - type;
        !          1273:        else if(v->vstg != -type)
        !          1274:                dclerr("incompatible storage declarations", v);
        !          1275:        }
        !          1276: else if(v->vtype == TYUNKNOWN)
        !          1277:        {
        !          1278:        if( (v->vtype = lengtype(type, length))==TYCHAR && length>=0)
        !          1279:                v->vleng = ICON(length);
        !          1280:        }
        !          1281: else if(v->vtype!=type || (type==TYCHAR && v->vleng->constblock.const.ci!=length) )
        !          1282:        dclerr("incompatible type declarations", v);
        !          1283: }
        !          1284: 
        !          1285: 
        !          1286: 
        !          1287: 
        !          1288: 
        !          1289: lengtype(type, length)
        !          1290: register int type;
        !          1291: register int length;
        !          1292: {
        !          1293: switch(type)
        !          1294:        {
        !          1295:        case TYREAL:
        !          1296:                if(length == 8)
        !          1297:                        return(TYDREAL);
        !          1298:                if(length == 4)
        !          1299:                        goto ret;
        !          1300:                break;
        !          1301: 
        !          1302:        case TYCOMPLEX:
        !          1303:                if(length == 16)
        !          1304:                        return(TYDCOMPLEX);
        !          1305:                if(length == 8)
        !          1306:                        goto ret;
        !          1307:                break;
        !          1308: 
        !          1309:        case TYSHORT:
        !          1310:        case TYDREAL:
        !          1311:        case TYDCOMPLEX:
        !          1312:        case TYCHAR:
        !          1313:        case TYUNKNOWN:
        !          1314:        case TYSUBR:
        !          1315:        case TYERROR:
        !          1316:                goto ret;
        !          1317: 
        !          1318:        case TYLOGICAL:
        !          1319:                if(length == typesize[TYLOGICAL])
        !          1320:                        goto ret;
        !          1321:                break;
        !          1322: 
        !          1323:        case TYLONG:
        !          1324:                if(length == 0 )
        !          1325:                        return(tyint);
        !          1326:                if(length == 2)
        !          1327:                        return(TYSHORT);
        !          1328:                if(length == 4 )
        !          1329:                        goto ret;
        !          1330:                break;
        !          1331:        default:
        !          1332:                badtype("lengtype", type);
        !          1333:        }
        !          1334: 
        !          1335: if(length != 0)
        !          1336:        err("incompatible type-length combination");
        !          1337: 
        !          1338: ret:
        !          1339:        return(type);
        !          1340: }
        !          1341: 
        !          1342: 
        !          1343: 
        !          1344: 
        !          1345: 
        !          1346: setintr(v)
        !          1347: register Namep  v;
        !          1348: {
        !          1349: register int k;
        !          1350: 
        !          1351: if(v->vstg == STGUNKNOWN)
        !          1352:        v->vstg = STGINTR;
        !          1353: else if(v->vstg!=STGINTR)
        !          1354:        dclerr("incompatible use of intrinsic function", v);
        !          1355: if(v->vclass==CLUNKNOWN)
        !          1356:        v->vclass = CLPROC;
        !          1357: if(v->vprocclass == PUNKNOWN)
        !          1358:        v->vprocclass = PINTRINSIC;
        !          1359: else if(v->vprocclass != PINTRINSIC)
        !          1360:        dclerr("invalid intrinsic declaration", v);
        !          1361: if(k = intrfunct(v->varname))
        !          1362:        v->vardesc.varno = k;
        !          1363: else
        !          1364:        dclerr("unknown intrinsic function", v);
        !          1365: }
        !          1366: 
        !          1367: 
        !          1368: 
        !          1369: setext(v)
        !          1370: register Namep  v;
        !          1371: {
        !          1372: if(v->vclass == CLUNKNOWN)
        !          1373:        v->vclass = CLPROC;
        !          1374: else if(v->vclass != CLPROC)
        !          1375:        dclerr("conflicting declarations", v);
        !          1376: 
        !          1377: if(v->vprocclass == PUNKNOWN)
        !          1378:        v->vprocclass = PEXTERNAL;
        !          1379: else if(v->vprocclass != PEXTERNAL)
        !          1380:        dclerr("conflicting declarations", v);
        !          1381: }
        !          1382: 
        !          1383: 
        !          1384: 
        !          1385: 
        !          1386: /* create dimensions block for array variable */
        !          1387: 
        !          1388: setbound(v, nd, dims)
        !          1389: register Namep  v;
        !          1390: int nd;
        !          1391: struct { expptr lb, ub; } dims[ ];
        !          1392: {
        !          1393: register expptr q, t;
        !          1394: register struct Dimblock *p;
        !          1395: int i;
        !          1396: 
        !          1397: if(v->vclass == CLUNKNOWN)
        !          1398:        v->vclass = CLVAR;
        !          1399: else if(v->vclass != CLVAR)
        !          1400:        {
        !          1401:        dclerr("only variables may be arrays", v);
        !          1402:        return;
        !          1403:        }
        !          1404: if(v->vdim)
        !          1405:        {
        !          1406:        dclerr("redimensioned array", v);
        !          1407:        return;
        !          1408:        }
        !          1409: 
        !          1410: v->vdim = p = (struct Dimblock *)
        !          1411:                ckalloc( sizeof(int) + (3+6*nd)*sizeof(expptr) );
        !          1412: p->ndim = nd;
        !          1413: p->nelt = ICON(1);
        !          1414: 
        !          1415: for(i=0 ; i<nd ; ++i)
        !          1416:        {
        !          1417: #ifdef SDB
        !          1418:         if(sdbflag) {
        !          1419: /* Save the bounds trees built up by the grammar routines for use in stabs */
        !          1420: 
        !          1421:                if(dims[i].lb == NULL) p->dims[i].lb=ICON(1);
        !          1422:                else p->dims[i].lb= (expptr) cpexpr(dims[i].lb);
        !          1423:                 if(ISCONST(p->dims[i].lb)) p->dims[i].lbaddr = (expptr) PNULL;
        !          1424:                 else p->dims[i].lbaddr = (expptr) autovar(1, tyint, PNULL);
        !          1425: 
        !          1426:                if(dims[i].ub == NULL) p->dims[i].ub=ICON(1);
        !          1427:                else p->dims[i].ub = (expptr) cpexpr(dims[i].ub);
        !          1428:                 if(ISCONST(p->dims[i].ub)) p->dims[i].ubaddr = (expptr) PNULL;
        !          1429:                 else p->dims[i].ubaddr = (expptr) autovar(1, tyint, PNULL);
        !          1430:        }
        !          1431: #endif
        !          1432:        if( (q = dims[i].ub) == NULL)
        !          1433:                {
        !          1434:                if(i == nd-1)
        !          1435:                        {
        !          1436:                        frexpr(p->nelt);
        !          1437:                        p->nelt = NULL;
        !          1438:                        }
        !          1439:                else
        !          1440:                        err("only last bound may be asterisk");
        !          1441:                p->dims[i].dimsize = ICON(1);;
        !          1442:                p->dims[i].dimexpr = NULL;
        !          1443:                }
        !          1444:        else
        !          1445:                {
        !          1446:                if(dims[i].lb)
        !          1447:                        {
        !          1448:                        q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb));
        !          1449:                        q = mkexpr(OPPLUS, q, ICON(1) );
        !          1450:                        }
        !          1451:                if( ISCONST(q) )
        !          1452:                        {
        !          1453:                        if (!ISINT(q->headblock.vtype)) {
        !          1454:                           dclerr("dimension bounds must be integer expression", v);
        !          1455:                           frexpr(q);
        !          1456:                           q = ICON(0);
        !          1457:                           }
        !          1458:                        if ( q->constblock.const.ci <= 0)
        !          1459:                           {
        !          1460:                           dclerr("array bounds out of sequence", v);
        !          1461:                           frexpr(q);
        !          1462:                           q = ICON(0);
        !          1463:                           }
        !          1464:                        p->dims[i].dimsize = q;
        !          1465:                        p->dims[i].dimexpr = (expptr) PNULL;
        !          1466:                        }
        !          1467:                else    {
        !          1468:                        p->dims[i].dimsize = (expptr) autovar(1, tyint, PNULL);
        !          1469:                        p->dims[i].dimexpr = q;
        !          1470:                        }
        !          1471:                if(p->nelt)
        !          1472:                        p->nelt = mkexpr(OPSTAR, p->nelt,
        !          1473:                                        cpexpr(p->dims[i].dimsize) );
        !          1474:                }
        !          1475:        }
        !          1476: 
        !          1477: q = dims[nd-1].lb;
        !          1478: if(q == NULL)
        !          1479:        q = ICON(1);
        !          1480: 
        !          1481: for(i = nd-2 ; i>=0 ; --i)
        !          1482:        {
        !          1483:        t = dims[i].lb;
        !          1484:        if(t == NULL)
        !          1485:                t = ICON(1);
        !          1486:        if(p->dims[i].dimsize)
        !          1487:                q = mkexpr(OPPLUS, t, mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q) );
        !          1488:        }
        !          1489: 
        !          1490: if( ISCONST(q) )
        !          1491:        {
        !          1492:        p->baseoffset = q;
        !          1493:        p->basexpr = NULL;
        !          1494:        }
        !          1495: else
        !          1496:        {
        !          1497:        p->baseoffset = (expptr) autovar(1, tyint, PNULL);
        !          1498:        p->basexpr = q;
        !          1499:        }
        !          1500: }
        !          1501: 
        !          1502: 
        !          1503: 
        !          1504: /*
        !          1505:  * Check the dimensions of q to ensure that they are appropriately defined.
        !          1506:  */
        !          1507: LOCAL chkdim(q)
        !          1508: register Namep q;
        !          1509: {
        !          1510:   register struct Dimblock *p;
        !          1511:   register int i;
        !          1512:   expptr e;
        !          1513: 
        !          1514:   if (q == NULL)
        !          1515:     return;
        !          1516:   if (q->vclass != CLVAR)
        !          1517:     return;
        !          1518:   if (q->vdim == NULL)
        !          1519:     return;
        !          1520:   p = q->vdim;
        !          1521:   for (i = 0; i < p->ndim; ++i)
        !          1522:     {
        !          1523: #ifdef SDB
        !          1524:       if (sdbflag)
        !          1525:        {
        !          1526:          if (e = p->dims[i].lb)
        !          1527:            chkdime(e, q);
        !          1528:          if (e = p->dims[i].ub)
        !          1529:            chkdime(e, q);
        !          1530:        }
        !          1531:       else
        !          1532: #endif SDB
        !          1533:       if (e = p->dims[i].dimexpr)
        !          1534:        chkdime(e, q);
        !          1535:     }
        !          1536: }
        !          1537: 
        !          1538: 
        !          1539: 
        !          1540: /*
        !          1541:  * The actual checking for chkdim() -- examines each expression.
        !          1542:  */
        !          1543: LOCAL chkdime(expr, q)
        !          1544: expptr expr;
        !          1545: Namep q;
        !          1546: {
        !          1547:   register expptr e;
        !          1548: 
        !          1549:   e = fixtype(cpexpr(expr));
        !          1550:   if (!ISINT(e->exprblock.vtype))
        !          1551:     dclerr("non-integer dimension", q);
        !          1552:   else if (!safedim(e))
        !          1553:     dclerr("undefined dimension", q);
        !          1554:   frexpr(e);
        !          1555:   return;
        !          1556: }
        !          1557: 
        !          1558: 
        !          1559: 
        !          1560: /*
        !          1561:  * A recursive routine to find undefined variables in dimension expressions.
        !          1562:  */
        !          1563: LOCAL safedim(e)
        !          1564: expptr e;
        !          1565: {
        !          1566:   chainp cp;
        !          1567: 
        !          1568:   if (e == NULL)
        !          1569:     return 1;
        !          1570:   switch (e->tag)
        !          1571:     {
        !          1572:       case TEXPR:
        !          1573:        if (e->exprblock.opcode == OPCALL || e->exprblock.opcode == OPCCALL)
        !          1574:          return 0;
        !          1575:        return safedim(e->exprblock.leftp) && safedim(e->exprblock.rightp);
        !          1576:       case TADDR:
        !          1577:        switch (e->addrblock.vstg)
        !          1578:          {
        !          1579:            case STGCOMMON:
        !          1580:            case STGARG:
        !          1581:            case STGCONST:
        !          1582:            case STGEQUIV:
        !          1583:              if (e->addrblock.isarray)
        !          1584:                return 0;
        !          1585:              return safedim(e->addrblock.memoffset);
        !          1586:            default:
        !          1587:              return 0;
        !          1588:          }
        !          1589:       case TCONST:
        !          1590:       case TTEMP:
        !          1591:        return 1;
        !          1592:     }
        !          1593:   return 0;
        !          1594: }
        !          1595: 
        !          1596: 
        !          1597: 
        !          1598: LOCAL enlist(size, np, ep)
        !          1599: ftnint size;
        !          1600: Namep np;
        !          1601: struct Equivblock *ep;
        !          1602: {
        !          1603:   register sizelist *sp;
        !          1604:   register sizelist *t;
        !          1605:   register varlist *p;
        !          1606: 
        !          1607:   sp = varsizes;
        !          1608: 
        !          1609:   if (sp == NULL)
        !          1610:     {
        !          1611:       sp = ALLOC(SizeList);
        !          1612:       sp->size = size;
        !          1613:       varsizes = sp;
        !          1614:     }
        !          1615:   else
        !          1616:     {
        !          1617:       while (sp->size != size)
        !          1618:        {
        !          1619:          if (sp->next != NULL && sp->next->size <= size)
        !          1620:            sp = sp->next;
        !          1621:          else
        !          1622:            {
        !          1623:              t = sp;
        !          1624:              sp = ALLOC(SizeList);
        !          1625:              sp->size = size;
        !          1626:              sp->next = t->next;
        !          1627:              t->next = sp;
        !          1628:            }
        !          1629:        }
        !          1630:     }
        !          1631: 
        !          1632:   p = ALLOC(VarList);
        !          1633:   p->next = sp->vars;
        !          1634:   p->np = np;
        !          1635:   p->ep = ep;
        !          1636: 
        !          1637:   sp->vars = p;
        !          1638: 
        !          1639:   return;
        !          1640: }
        !          1641: 
        !          1642: 
        !          1643: 
        !          1644: outlocvars()
        !          1645: {
        !          1646: 
        !          1647:   register varlist *first, *last;
        !          1648:   register varlist *vp, *t;
        !          1649:   register sizelist *sp, *sp1;
        !          1650:   register Namep np;
        !          1651:   register struct Equivblock *ep;
        !          1652:   register int i;
        !          1653:   register int alt;
        !          1654:   register int type;
        !          1655:   char sname[100];
        !          1656:   char setbuff[100];
        !          1657: 
        !          1658:   sp = varsizes;
        !          1659:   if (sp == NULL)
        !          1660:     return;
        !          1661: 
        !          1662:   vp = sp->vars;
        !          1663:   if (vp->np != NULL)
        !          1664:     {
        !          1665:       np = vp->np;
        !          1666:       sprintf(setbuff, "\t.set\tv.%d,v.%d\n", bsslabel,
        !          1667:              np->vardesc.varno);
        !          1668:     }
        !          1669:   else
        !          1670:     {
        !          1671:       i = vp->ep - eqvclass;
        !          1672:       sprintf(setbuff, "\t.set\tv.%d,q.%d\n", bsslabel, i + eqvstart);
        !          1673:     }
        !          1674: 
        !          1675:   first = last = NULL;
        !          1676:   alt = NO;
        !          1677: 
        !          1678:   while (sp != NULL)
        !          1679:     {
        !          1680:       vp = sp->vars;
        !          1681:       while (vp != NULL)
        !          1682:        {
        !          1683:          t = vp->next;
        !          1684:          if (alt == YES)
        !          1685:            {
        !          1686:              alt = NO;
        !          1687:              vp->next = first;
        !          1688:              first = vp;
        !          1689:            }
        !          1690:          else
        !          1691:            {
        !          1692:              alt = YES;
        !          1693:              if (last != NULL)
        !          1694:                last->next = vp;
        !          1695:              else
        !          1696:                first = vp;
        !          1697:              vp->next = NULL;
        !          1698:              last = vp;
        !          1699:            }
        !          1700:          vp = t;
        !          1701:        }
        !          1702:       sp1 = sp;
        !          1703:       sp = sp->next;
        !          1704:       free((char *) sp1);
        !          1705:     }
        !          1706: 
        !          1707:   vp = first;
        !          1708:   while(vp != NULL)
        !          1709:     {
        !          1710:       if (vp->np != NULL)
        !          1711:        {
        !          1712:          np = vp->np;
        !          1713:          sprintf(sname, "v.%d", np->vardesc.varno);
        !          1714:          pralign(typealign[np->vtype]);
        !          1715:          if (np->init)
        !          1716:            prlocdata(sname, np->varsize, np->vtype, np->initoffset,
        !          1717:                      &(np->inlcomm));
        !          1718:          else
        !          1719:            {
        !          1720:              if (typealign[np->vtype] == 1)    
        !          1721:                  pralign(3);
        !          1722:              fprintf(initfile, "%s:\n\t.space\t%d\n", sname,
        !          1723:                      np->varsize);
        !          1724:            }
        !          1725:          np->inlcomm = NO;
        !          1726:        }
        !          1727:       else
        !          1728:        {
        !          1729:          ep = vp->ep;
        !          1730:          i = ep - eqvclass;
        !          1731:          if (ep->eqvleng >= 8)
        !          1732:            type = TYDREAL;
        !          1733:          else if (ep->eqvleng >= 4)
        !          1734:            type = TYLONG;
        !          1735:          else if (ep->eqvleng >= 2)
        !          1736:            type = TYSHORT;
        !          1737:          else
        !          1738:            type = TYCHAR;
        !          1739:          sprintf(sname, "q.%d", i + eqvstart);
        !          1740:          if (ep->init)
        !          1741:            prlocdata(sname, ep->eqvleng, type, ep->initoffset,
        !          1742:                      &(ep->inlcomm));
        !          1743:          else
        !          1744:            {
        !          1745:              pralign(typealign[type]);
        !          1746:              fprintf(initfile, "%s:\n\t.space\t%d\n", sname, ep->eqvleng);
        !          1747:            }
        !          1748:          ep->inlcomm = NO;
        !          1749:        }
        !          1750:       t = vp;
        !          1751:       vp = vp->next;
        !          1752:       free((char *) t);
        !          1753:     }
        !          1754:   fprintf(initfile, "%s\n", setbuff);
        !          1755:   return;
        !          1756: }

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