Return to proc.c CVS log

Up to [Power 6/32 Unix Tahoe 4.2BSD] / cci / usr / src / usr.bin / f77 / f77pass1

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

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