Return to dclgen.c CVS log

Up to [Research Unix] / researchv10no / cmd / efl

Annotation of researchv10no/cmd/efl/dclgen.c, revision 1.1

1.1     ! root        1: #include "defs"
        !             2: 
        !             3: #define DOCOMMON 1
        !             4: #define NOCOMMON 0
        !             5: 
        !             6: dclgen()
        !             7: {
        !             8: register chainp p;
        !             9: register struct exprblock *q;
        !            10: ptr q1;
        !            11: chainp *y, z;
        !            12: struct stentry **hp;
        !            13: int first;
        !            14: int i, j;
        !            15: extern char *types[];
        !            16: char *sp;
        !            17: 
        !            18: /*   print procedure statement and argument list */
        !            19: 
        !            20: for(p = (chainp)prevcomments ; p ; p = (chainp)p->nextp)
        !            21:        {
        !            22:        sp = (char *)p->datap;
        !            23:        fprintf(codefile, "%s\n", sp+1);
        !            24:        cfree(sp);
        !            25:        }
        !            26: frchain(&prevcomments);
        !            27: 
        !            28: if(tailor.procheader)
        !            29:        fprintf(codefile, "%s\n", tailor.procheader);
        !            30: 
        !            31: if(procname)
        !            32:        {
        !            33:        p2str("      ");
        !            34:        if(procname->vtype==TYSUBR || procname->vtype==TYUNDEFINED)
        !            35:                p2key(FSUBROUTINE);
        !            36:        else    {
        !            37:                p2str(types[procname->vtype]);
        !            38:                p2key(FFUNCTION);
        !            39:                }
        !            40: 
        !            41:        p2str(((struct stentry *)procname->sthead)->namep);
        !            42:        }
        !            43: else if(procclass == PRBLOCK)
        !            44:        {
        !            45:        p2stmt(0);
        !            46:        p2key(FBLOCKDATA);
        !            47:        }
        !            48: else   {
        !            49:        p2str("c  main program");
        !            50:        if(tailor.ftnsys == CRAY)
        !            51:                {
        !            52:                p2stmt(0);
        !            53:                p2key(FPROGRAM);
        !            54:                }
        !            55:        }
        !            56: 
        !            57: if(thisargs)
        !            58:        {
        !            59:        p2str( "(" );
        !            60:        first = 1;
        !            61: 
        !            62:        for(p = (chainp)thisargs ; p ; p = (chainp)p->nextp)
        !            63:                if( (q=(struct exprblock *)p->datap)->vextbase)
        !            64:                        {
        !            65:                        if(first) first = 0;
        !            66:                        else p2str(", ");
        !            67:                        p2str(ftnames[q->vextbase]);
        !            68:                        }
        !            69:                else    for(i=0 ; i<NFTNTYPES ; ++i)
        !            70:                                if(j = q->vbase[i])
        !            71:                                        {
        !            72:                                        if(first) first = 0;
        !            73:                                        else p2str( ", " );
        !            74:                                        p2str(ftnames[j]);
        !            75:                                        }
        !            76:        p2str( ")" );
        !            77:        }
        !            78: 
        !            79: /* first put out declarations of variables that are used as
        !            80:    adjustable dimensions
        !            81: */
        !            82: 
        !            83: y = 0;
        !            84: z = (chainp)& y;
        !            85: for(hp = hashtab ; hp<hashend; ++hp)
        !            86:        if( *hp && (q = (struct exprblock *)(*hp)->varp) )
        !            87:                if(q->tag==TNAME && q->vadjdim && (int *)q!=procname)
        !            88:                        z = (chainp)(z->nextp = (int *)mkchain(q,CHNULL));
        !            89: 
        !            90: dclchain(y, NOCOMMON);
        !            91: frchain(&y);
        !            92: 
        !            93: /* then declare the rest of the arguments */
        !            94: z = (chainp)& y;
        !            95: for(p = (chainp)thisargs ; p ; p = (chainp)p->nextp)
        !            96:        if(((struct exprblock *)p->datap)->vadjdim == 0)
        !            97:                z = (chainp)(z->nextp = (int *)mkchain(p->datap,CHNULL));
        !            98: dclchain(y, NOCOMMON);
        !            99: frchain(&y);
        !           100: frchain(&thisargs);
        !           101: 
        !           102: 
        !           103: /* now put out declarations for common blocks */
        !           104: for(p = (chainp)commonlist ; p ; p = (chainp)p->nextp)
        !           105:        prcomm(p->datap);
        !           106: 
        !           107: TEST fprintf(diagfile, "\nend of common declarations");
        !           108: z = (chainp)&y;
        !           109: 
        !           110: /* next the other variables that are in the symbol table */
        !           111: 
        !           112: for(hp = hashtab ; hp<hashend ; ++hp)
        !           113:        if( *hp && (q = (struct exprblock *)(*hp)->varp) )
        !           114:                if(q->tag==TNAME && q->vadjdim==0 && q->vclass!=CLCOMMON &&
        !           115:                    q->vclass!=CLARG && (int *)q!=procname &&
        !           116:                    (tailor.dclintrinsics || q->vproc!=PROCINTRINSIC) )
        !           117:                        z = (chainp)(z->nextp = (int *)mkchain(q,CHNULL));
        !           118: 
        !           119: dclchain(y, NOCOMMON);
        !           120: frchain(&y);
        !           121: 
        !           122: TEST fprintf(diagfile, "\nend of symbol table, start of gonelist");
        !           123: 
        !           124: /* now declare variables that are no longer in the symbol table */
        !           125: 
        !           126: dclchain(gonelist, NOCOMMON);
        !           127: 
        !           128: TEST fprintf(diagfile, "\nbeginning of hidlist");
        !           129: dclchain(hidlist, NOCOMMON);
        !           130: 
        !           131: dclchain(tempvarlist, NOCOMMON);
        !           132: 
        !           133: 
        !           134: /* finally put out equivalence statements that are generated 
        !           135:    because of structure and character variables
        !           136: */
        !           137: for(p = (chainp)genequivs; p ; p = (chainp)p->nextp)
        !           138:        {
        !           139:        q = (struct exprblock *)p->datap;
        !           140:        p2stmt(0);
        !           141:        first = 1;
        !           142:        p2key(FEQUIVALENCE);
        !           143:        p2str( "(" );
        !           144:        for(i=0; i<NFTNTYPES; ++i)
        !           145:                if(q->vbase[i])
        !           146:                        {
        !           147:                        if(first) first = 0;
        !           148:                        else p2str( ", " );
        !           149:                        p2str(ftnames[ q->vbase[i] ]);
        !           150:                        p2str( "(1" );
        !           151:                        if(q1 = q->vdim)
        !           152:                                for(q1 = q1->datap; q1 ; q1 = q1->nextp)
        !           153:                                        p2str( ",1" );
        !           154:                        p2str( ")" );
        !           155:                        }
        !           156:        p2str( ")" );
        !           157:        }
        !           158: frchain(&genequivs);
        !           159: }
        !           160: 
        !           161: 
        !           162: 
        !           163: 
        !           164: prcomm(p)
        !           165: register ptr p;
        !           166: {
        !           167: register int first;
        !           168: register ptr q;
        !           169: 
        !           170: p2stmt(0);
        !           171: p2key(FCOMMON);
        !           172: p2str( "/" );
        !           173: p2str(p->comname);
        !           174: p2str("/ ");
        !           175: first = 1;
        !           176: for(q = (int *)p->comchain ; q; q = (int *)q->nextp)
        !           177:        {
        !           178:        if(first) first=0;
        !           179:        else p2str(", ");
        !           180:        prname(q->datap);
        !           181:        }
        !           182: dclchain(p->comchain, DOCOMMON);
        !           183: }
        !           184: 
        !           185: 
        !           186: 
        !           187: prname(p)
        !           188: register ptr p;
        !           189: {
        !           190: register int i;
        !           191: 
        !           192: switch(p->tag)
        !           193:        {
        !           194:        case TCONST:
        !           195:                p2str(p->leftp);
        !           196:                return;
        !           197: 
        !           198:        case TNAME:
        !           199:                if( ! p->vdcldone )
        !           200:                        if(p->blklevel == 1)
        !           201:                                dclit(p);
        !           202:                        else    mkftnp(p);
        !           203:                for(i=0; i<NFTNTYPES ; ++i)
        !           204:                        if(p->vbase[i])
        !           205:                                {
        !           206:                                p2str(ftnames[p->vbase[i]]);
        !           207:                                return;
        !           208:                                }
        !           209:                fatal1("prname: no fortran types for name %s",
        !           210:                        ((struct stentry *)p->sthead)->namep);
        !           211: 
        !           212:        case TFTNBLOCK:
        !           213:                for(i=0; i<NFTNTYPES ; ++i)
        !           214:                        if(p->vbase[i])
        !           215:                                {
        !           216:                                p2str(ftnames[p->vbase[i]]);
        !           217:                                return;
        !           218:                                }
        !           219:                return;
        !           220: 
        !           221:        default:
        !           222:                badtag("prname", p->tag);
        !           223:        }
        !           224: }
        !           225: 
        !           226: 
        !           227: 
        !           228: 
        !           229: dclchain(chp, okcom)
        !           230: ptr chp;
        !           231: int okcom;
        !           232: {
        !           233: extern char *ftntypes[];
        !           234: register ptr pn, p;
        !           235: register int i;
        !           236: int first, nline;
        !           237: ptr q,v;
        !           238: int ntypes;
        !           239: int size,align,mask;
        !           240: int subval;
        !           241: 
        !           242: nline = 0;
        !           243: for(pn = chp ; pn ; pn = pn->nextp)
        !           244:        {
        !           245:        p = pn->datap;
        !           246:        if( (p->tag==TNAME || p->tag==TTEMP) && p->vext!=0)
        !           247:                {
        !           248:                if(nline%NAMESPERLINE == 0)
        !           249:                        {
        !           250:                        p2stmt(0);
        !           251:                        p2key(FEXTERNAL);
        !           252:                        }
        !           253:                else    p2str(", ");
        !           254:                ++nline;
        !           255:                p2str(ftnames[p->vextbase]);
        !           256:                }
        !           257:        }
        !           258: 
        !           259: 
        !           260: for(pn = chp ; pn ; pn = pn->nextp)
        !           261:        {
        !           262:        p = pn->datap;
        !           263:        if( (p->tag==TNAME || p->tag==TTEMP) &&
        !           264:            p->vtype==TYSTRUCT && p->vclass!=CLARG)
        !           265:                {
        !           266:                ntypes = 0;
        !           267:                for(i=0; i<NFTNTYPES; ++i)
        !           268:                        if(p->vbase[i])
        !           269:                                ++ntypes;
        !           270:                if(ntypes > 1)
        !           271:                        genequivs = (int *)mkchain(p, genequivs);
        !           272:                }
        !           273:        }
        !           274: 
        !           275: for(i=0; i<NFTNTYPES; ++i)
        !           276:        {
        !           277:        nline = 0;
        !           278:        for(pn = chp; pn ; pn = pn->nextp)
        !           279:                {
        !           280:                p = pn->datap;
        !           281:                if( (p->tag==TNAME || p->tag==TTEMP) &&
        !           282:                    p->vtype!=TYSUBR && p->vbase[i]!=0 &&
        !           283:                    (okcom || p->vclass!=CLCOMMON) )
        !           284:                        {
        !           285:                        if(nline%NAMESPERLINE == 0)
        !           286:                                {
        !           287:                                p2stmt(0);
        !           288:                                p2str(ftntypes[i]);
        !           289:                                }
        !           290:                        else    p2str( ", " );
        !           291:                        ++nline;
        !           292:                        p2str(ftnames[p->vbase[i]]);
        !           293:                        first = -1;
        !           294:                
        !           295:                        if(p->vtype==TYCHAR || p->vtype==TYSTRUCT ||
        !           296:                           (p->vtype==TYLCOMPLEX && tailor.lngcxtype==NULL))
        !           297:                                {
        !           298:                                p2str( "(" );
        !           299:                                sizalign(p, &size,&align,&mask);
        !           300:                                p2int( size/tailor.ftnsize[i] );
        !           301:                                first = 0;
        !           302:                                }
        !           303:                        else if(p->vdim)
        !           304:                                {
        !           305:                                p2str( "(" );
        !           306:                                first = 1;
        !           307:                                }
        !           308:                        if(first >=0)
        !           309:                                {
        !           310:                                if(q = p->vdim)
        !           311:                                    for(q = q->datap ; q ; q = q->nextp)
        !           312:                                        {
        !           313:                                        if(q->upperb == 0)
        !           314:                                                {
        !           315:                                                q->upperb = mkint(1);
        !           316:                                                if(q->lowerb)
        !           317:                                                        {
        !           318:                                                        frexpr(q->lowerb);
        !           319:                                                        q->lowerb = 0;
        !           320:                                                        }
        !           321:                                                }
        !           322:                                        else if(q->lowerb)
        !           323:                                                {
        !           324:                                                v = fold( mknode(TAROP,OPMINUS,
        !           325:                                                        mkint(1),cpexpr(q->lowerb)) );
        !           326:                                                v = fold( mknode(TAROP,OPPLUS,
        !           327:                                                        cpexpr(q->upperb),v) );
        !           328:                                                q->lowerb = 0;
        !           329:                                                q->upperb = v;
        !           330:                                                }
        !           331:                                        if(first) first = 0;
        !           332:                                        else p2str( ", " );
        !           333:                                        v = q->upperb = simple(RVAL,q->upperb);
        !           334:                                        if( (v->tag==TNAME && v->vclass==CLARG) ||
        !           335:                                            (isicon(v,&subval) && subval>0) )
        !           336:                                                prname(v);
        !           337:                                        else    dclerr("invalid array bound",
        !           338:                                                ((struct stentry *)p->sthead)->namep);
        !           339:                                        }
        !           340:                                p2str( ")" );
        !           341:                                }
        !           342:                        }
        !           343:                }
        !           344:        }
        !           345: }

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