Return to proc.c CVS log

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

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

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