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

   1: #include "defs"
   2: 
   3: #define DOCOMMON 1
   4: #define NOCOMMON 0
   5: 
   6: dclgen()
   7: {
   8: register ptr p, q;
   9: ptr q1;
  10: chainp *y, z;
  11: register struct stentry *s;
  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 = prevcomments ; p ; p = p->nextp)
  21:     {
  22:     sp = 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(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 = thisargs ; p ; p = p->nextp)
  63:         if( (q=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 = & y;
  85: for(hp = hashtab ; hp<hashend; ++hp)
  86:     if( *hp && (q = (*hp)->varp) )
  87:         if(q->tag==TNAME && q->vadjdim && q!=procname)
  88:             z = z->nextp = mkchain(q,CHNULL);
  89: 
  90: dclchain(y, NOCOMMON);
  91: frchain(&y);
  92: 
  93: /* then declare the rest of the arguments */
  94: z = & y;
  95: for(p = thisargs ; p ; p = p->nextp)
  96:     if(p->datap->vadjdim == 0)
  97:         z = z->nextp = 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 = commonlist ; p ; p = p->nextp)
 105:     prcomm(p->datap);
 106: 
 107: TEST fprintf(diagfile, "\nend of common declarations");
 108: z = &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 = (*hp)->varp) )
 114:         if(q->tag==TNAME && q->vadjdim==0 && q->vclass!=CLCOMMON &&
 115:             q->vclass!=CLARG && q!=procname &&
 116:             (tailor.dclintrinsics || q->vproc!=PROCINTRINSIC) )
 117:             z = z->nextp = 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 = genequivs; p ; p = p->nextp)
 138:     {
 139:     q = 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 = p->comchain ; q; q = 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:             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 = 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:                         p->sthead->namep);
 339:                     }
 340:                 p2str( ")" );
 341:                 }
 342:             }
 343:         }
 344:     }
 345: }

Defined functions

Defined macros