Return to namgen.c CVS log

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

Annotation of researchv10dc/cmd/efl/namgen.c, revision 1.1

1.1     ! root        1: #include "defs"
        !             2: 
        !             3: impldecl(p)
        !             4: register ptr p;
        !             5: {
        !             6: extern char *types[];
        !             7: register ptr q;
        !             8: int n;
        !             9: 
        !            10: if(p->vtype==TYSUBR) return;
        !            11: if(p->tag == TCALL)
        !            12:        {
        !            13:        impldecl(p->leftp);
        !            14:        p->vtype = ((struct exprblock *)p->leftp)->vtype;
        !            15:        p->vtypep = ((struct exprblock *)p->leftp)->vtypep;
        !            16:        return;
        !            17:        }
        !            18: 
        !            19: if(inbound)
        !            20:        n = TYINT;
        !            21: else   {
        !            22:        n = impltype[((struct stentry *)p->sthead)->namep[0] - 'a' ];
        !            23:        if(n==TYREAL && p->vprec!=0)
        !            24:                n = TYLREAL;
        !            25:        sprintf(msg,  "%s implicitly typed %s",((struct stentry *)p->sthead)->namep, types[n]);
        !            26:        warn(msg);
        !            27:        }
        !            28: q = ((struct stentry *)p->sthead)->varp;
        !            29: p->vtype = q->vtype = n;
        !            30: if(p->blklevel>1 && p->vdclstart==0)
        !            31:        {
        !            32:        p->blklevel = q->blklevel = ((struct headbits *)p->sthead)->blklevel = 1;
        !            33:        p->vdclstart = q->vdclstart = 1;
        !            34:        --ndecl[blklevel];
        !            35:        ++ndecl[1];
        !            36:        }
        !            37: }
        !            38: 
        !            39: 
        !            40: 
        !            41: extname(p)
        !            42: register ptr p;
        !            43: {
        !            44: register int i;
        !            45: register char *q, *s;
        !            46: 
        !            47: /*     if(p->vclass == CLARG) return;  */
        !            48: if(p->vextbase) return;
        !            49: q = ((struct stentry *)p->sthead)->namep;
        !            50: setvproc(p, PROCYES);
        !            51: 
        !            52: /* external names are automatically at block level 1 */
        !            53: 
        !            54: if( (i =p->blklevel) >1)
        !            55:        {
        !            56:        ((struct headbits *)p->sthead)->blklevel = 1;
        !            57:        p->blklevel = 1;
        !            58:        ((struct headbits *)((struct stentry *)p->sthead)->varp)->blklevel = 1;
        !            59:        ++ndecl[1];
        !            60:        --ndecl[i];
        !            61:        }
        !            62: 
        !            63: if(p->vclass!=CLUNDEFINED && p->vclass!=CLARG)
        !            64:        {
        !            65:        dclerr("illegal class for procedure", q);
        !            66:        return;
        !            67:        }
        !            68: if(p->vclass!=CLARG && strlen(q)>XL)
        !            69:        {
        !            70:        if(! ioop(q) )
        !            71:                dclerr("procedure name too long", q);
        !            72:        return;
        !            73:        }
        !            74: if(lookftn(q) > 0)
        !            75:        dclerr("procedure name already used", q);
        !            76: else   {
        !            77:        for(i=0 ; i<NFTNTYPES ; ++i)
        !            78:                if(p->vbase[i]) break;
        !            79:        if(i < NFTNTYPES)
        !            80:                p->vextbase = p->vbase[i];
        !            81:        else    p->vextbase = nxtftn();
        !            82: 
        !            83:        if(p->vext==0 || p->vclass!=CLARG)
        !            84:                for(s = ftnames[ p->vextbase ]; *s++ = *q++ ; ) ; 
        !            85:        return;
        !            86:        }
        !            87: }
        !            88: 
        !            89: 
        !            90: 
        !            91: dclit(p)
        !            92: register ptr p;
        !            93: {
        !            94: register ptr q;
        !            95: 
        !            96: if(p->tag == TERROR)
        !            97:        return;
        !            98: 
        !            99: q = ((struct stentry *)p->sthead)->varp;
        !           100: 
        !           101: if(p->tag == TCALL)
        !           102:        {
        !           103:        dclit(p->leftp);
        !           104:        if( ioop(((struct stentry *)((struct typeblock *)p->leftp)->sthead)->namep) )
        !           105:                ((struct exprblock *)p->leftp)->vtype = TYLOG;
        !           106:        p->vtype = ((struct exprblock *)p->leftp)->vtype;
        !           107:        p->vtypep = ((struct varblock *)p->leftp)->vtypep;
        !           108:        return;
        !           109:        }
        !           110: 
        !           111: if(q->vdcldone == 0)
        !           112:        mkftnp(q);
        !           113: if(p != q)
        !           114:        cpblock(q,p, sizeof(struct exprblock));
        !           115: }
        !           116: 
        !           117: 
        !           118: mkftnp(p)
        !           119: register ptr p;
        !           120: {
        !           121: int i,k;
        !           122: if(inbound || p->vdcldone) return;
        !           123: if(p == 0)
        !           124:        fatal("mkftnp: zero argument");
        !           125: if(p->tag!=TNAME && p->tag!=TTEMP)
        !           126:        badtag("mkftnp", p->tag);
        !           127: 
        !           128: if(p->vtype == TYUNDEFINED)
        !           129:        if(p->vextbase)
        !           130:                return;
        !           131:        else    impldecl(p);
        !           132: p->vdcldone = 1;
        !           133: 
        !           134: switch(p->vtype)
        !           135:        {
        !           136:        case TYCHAR:
        !           137:        case TYINT:
        !           138:        case TYREAL:
        !           139:        case TYLREAL:
        !           140:        case TYLOG:
        !           141:        case TYCOMPLEX:
        !           142:        case TYLCOMPLEX:
        !           143:                p->vbase[ eflftn[p->vtype] ] = nxtftn();
        !           144:                break;
        !           145: 
        !           146:        case TYSTRUCT:
        !           147:                k = ((struct typeblock *)p->vtypep)->basetypes;
        !           148:                for(i=0; i<NFTNTYPES ; ++i)
        !           149:                        if(k & ftnmask[i])
        !           150:                                p->vbase[i] = nxtftn();
        !           151:                break;
        !           152: 
        !           153:        case TYSUBR:
        !           154:                break;
        !           155: 
        !           156:        default:
        !           157:                fatal1("invalid type for %s", ((struct stentry *)p->sthead)->namep);
        !           158:                break;
        !           159:        }
        !           160: }
        !           161: 
        !           162: 
        !           163: namegen()
        !           164: {
        !           165: register ptr p;
        !           166: register struct stentry **hp;
        !           167: register int i;
        !           168: 
        !           169: for(hp = hashtab ; hp<hashend ; ++hp)
        !           170:        if(*hp && (p = (*hp)->varp) )
        !           171:                if(p->tag == TNAME)
        !           172:                        mkft(p);
        !           173: 
        !           174: for(p = (int *)gonelist ; p ; p = p->nextp)
        !           175:        mkft(p->datap);
        !           176: 
        !           177: for(p = (int *)hidlist ; p ; p = p->nextp)
        !           178:        if(((struct headbits *)p->datap)->tag == TNAME)  mkft(p->datap);
        !           179: 
        !           180: for(p = (int *)tempvarlist ; p ; p = p->nextp)
        !           181:        mkft(p->datap);
        !           182: 
        !           183: TEST fprintf(diagfile, "Fortran names:\n");
        !           184: TEST for(i=1; i<=nftnames ; ++i)  fprintf(diagfile, "%s\n", ftnames[i]);
        !           185: }
        !           186: 
        !           187: 
        !           188: mkft(p)
        !           189: register ptr p;
        !           190: {
        !           191: int i;
        !           192: register char *s, *t;
        !           193: 
        !           194: if(p->vnamedone)
        !           195:        return;
        !           196: 
        !           197: if(p->vdcldone==0 && p!=procname)
        !           198:        {
        !           199:        if(p->vext && p->vtype==TYUNDEFINED)
        !           200:                p->vtype = TYSUBR;
        !           201:        else if(p->vextbase==0 && p->vadjdim==0 && p->vclass!=CLCOMMON)
        !           202:                warn1("%s never used", ((struct stentry *)p->sthead)->namep);
        !           203:        mkftnp(p);
        !           204:        }
        !           205: 
        !           206: if(p->vextbase)
        !           207:        mkftname(p->vextbase, ((struct stentry *)p->sthead)->namep);
        !           208: 
        !           209: for(i=0; i<NFTNTYPES ; ++i)
        !           210:        if(p->vbase[i] != 0)
        !           211:        if(p!=procname && p->vextbase!=0)
        !           212:                {
        !           213:                s = ftnames[p->vextbase];
        !           214:                t = ftnames[p->vbase[i]];
        !           215:                while(*t++ = *s++ )
        !           216:                        ;
        !           217:                }
        !           218:        else if(p->sthead)
        !           219:                mkftname(p->vbase[i], ((struct stentry *)p->sthead)->namep);
        !           220:        else
        !           221:                mkftname(p->vbase[i], CHNULL);
        !           222: p->vnamedone = 1;
        !           223: }
        !           224: 
        !           225: 
        !           226: 
        !           227: 
        !           228: 
        !           229: mkftname(n,s)
        !           230: int n;
        !           231: char *s;
        !           232: {
        !           233: int i, j;
        !           234: register int k;
        !           235: char fn[7];
        !           236: register char *c1, *c2;
        !           237: 
        !           238: if(ftnames[n][0] != '\0')  return;
        !           239: 
        !           240: if(s==0 || *s=='\0')
        !           241:        s = "temp";
        !           242: else if(*s == '_')
        !           243:        ++s;
        !           244: k = strlen(s);
        !           245: 
        !           246: for(i=0; i<k && i<(XL/2) ; ++i)
        !           247:        fn[i] = s[i];
        !           248: if(k > XL)
        !           249:        {
        !           250:        s += (k-XL);
        !           251:        k = XL;
        !           252:        }
        !           253: 
        !           254: for( ; i<k ; ++i)
        !           255:        fn[i] = s[i];
        !           256: fn[i] = '\0';
        !           257: 
        !           258: if( lookftn(fn) )
        !           259:        {
        !           260:        if(k < XL)
        !           261:                ++k;
        !           262:        fn[k] = '\0';
        !           263:        c1 = fn + k-1;
        !           264:        for(*c1 = '1' ; *c1 <= '9' ; *c1 += 1)
        !           265:                if(lookftn(fn) == 0)
        !           266:                        goto nameok;
        !           267: 
        !           268:        if(k < XL)
        !           269:                ++k;
        !           270:        fn[k] = '\0';
        !           271:        c1 = fn + k-2;
        !           272:        c2 = c1 + 1;
        !           273: 
        !           274:        for(*c1 = '1' ; *c1 <= '9' ; *c1 += 1)
        !           275:                for(*c2 = '0' ; *c2 <= '9' ; *c2 += 1)
        !           276:                        if(lookftn(fn) == 0)
        !           277:                                goto nameok;
        !           278:        fatal1("mkftname: cannot generate fortran name for %s", s);
        !           279:        }
        !           280: 
        !           281: nameok:
        !           282: for(j=0; j<=k ; ++j)
        !           283:        ftnames[n][j] = fn[j];
        !           284: }
        !           285: 
        !           286: 
        !           287: 
        !           288: nxtftn()
        !           289: {
        !           290: if( ++nftnames < MAXFTNAMES)
        !           291:        {
        !           292:        ftnames[nftnames][0] = '\0';
        !           293:        return(nftnames);
        !           294:        }
        !           295: 
        !           296: fatal("too many Fortran names generated");
        !           297: /* NOTREACHED */ return 0;
        !           298: }
        !           299: 
        !           300: 
        !           301: 
        !           302: lookftn(s)
        !           303: char *s;
        !           304: {
        !           305: register int i;
        !           306: 
        !           307: for(i=1 ; i<=nftnames ; ++i)
        !           308:        if(equals(ftnames[i],s))  return(i);
        !           309: return(0);
        !           310: }
        !           311: 
        !           312: 
        !           313: 
        !           314: ptr mkftnblock(type, name)
        !           315: int type;
        !           316: char *name;
        !           317: {
        !           318: register struct varblock *p;
        !           319: register int k;
        !           320: 
        !           321: p = (struct varblock *)allexpblock();
        !           322: p->tag = TFTNBLOCK;
        !           323: p->vtype = type;
        !           324: p->vdcldone = 1;
        !           325: 
        !           326: if( (k = lookftn(name)) == 0)
        !           327:        {
        !           328:        k = nxtftn();
        !           329:        strcpy(ftnames[k], name);
        !           330:        }
        !           331: p->vbase[ eflftn[type] ] = k;
        !           332: p->vextbase = k;
        !           333: return((int *)p);
        !           334: }

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