4.3BSD - /usr/src/usr.bin/efl/namgen.c

   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 = p->leftp->vtype;
  15:     p->vtypep = p->leftp->vtypep;
  16:     return;
  17:     }
  18: 
  19: if(inbound)
  20:     n = TYINT;
  21: else    {
  22:     n = impltype[p->sthead->namep[0] - 'a' ];
  23:     if(n==TYREAL && p->vprec!=0)
  24:         n = TYLREAL;
  25:     sprintf(msg,  "%s implicitly typed %s",p->sthead->namep, types[n]);
  26:     warn(msg);
  27:     }
  28: q = p->sthead->varp;
  29: p->vtype = q->vtype = n;
  30: if(p->blklevel>1 && p->vdclstart==0)
  31:     {
  32:     p->blklevel = q->blklevel = 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 = 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:     p->sthead->blklevel = 1;
  57:     p->blklevel = 1;
  58:     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 = p->sthead->varp;
 100: 
 101: if(p->tag == TCALL)
 102:     {
 103:     dclit(p->leftp);
 104:     if( ioop(p->leftp->sthead->namep) )
 105:         p->leftp->vtype = TYLOG;
 106:     p->vtype = p->leftp->vtype;
 107:     p->vtypep = 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 = 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", 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 = gonelist ; p ; p = p->nextp)
 175:     mkft(p->datap);
 176: 
 177: for(p = hidlist ; p ; p = p->nextp)
 178:     if(p->datap->tag == TNAME)  mkft(p->datap);
 179: 
 180: for(p = 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", p->sthead->namep);
 203:     mkftnp(p);
 204:     }
 205: 
 206: if(p->vextbase)
 207:     mkftname(p->vextbase, 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], 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 */
 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 = 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(p);
 334: }

Defined functions