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

   1: #include "defs"
   2: 
   3: 
   4: static char mess[ ] = "inconsistent attributes";
   5: 
   6: attatt(a1 , a2)
   7: register struct atblock *a1, *a2;
   8: {
   9: #define MERGE1(x) {if(a1->x==0) a1->x = a2->x; else if(a2->x!=0 && a1->x!=a2->x) dclerr(mess,"x"+2); }
  10: 
  11: MERGE1(attype);
  12: MERGE1(attypep);
  13: MERGE1(atprec);
  14: MERGE1(atclass);
  15: MERGE1(atext);
  16: MERGE1(atcommon);
  17: MERGE1(atdim);
  18: 
  19: if(a1->atprec!=0 && (a1->attype==TYREAL || a1->attype==TYCOMPLEX) )
  20:     a1->attype += (TYLREAL-TYREAL);
  21: 
  22: cfree(a2);
  23: }
  24: 
  25: 
  26: 
  27: attvars(a , v)
  28: register struct atblock * a;
  29: register chainp v;
  30: {
  31: register chainp p;
  32: 
  33: for(p=v; p!=0 ; p = p->nextp)
  34:     attvr1(a, p->datap);
  35: 
  36: if(a->attype == TYFIELD)
  37:     cfree(a->attypep);
  38: else if(a->attype == TYCHAR)
  39:     frexpr(a->attypep);
  40: 
  41: cfree(a);
  42: }
  43: 
  44: #define MERGE(x,y) {if(v->y==0) v->y = a->x; else if(a->x!=0 && a->x!=v->y) dclerr(mess,"x"+2); }
  45: 
  46: 
  47: 
  48: 
  49: 
  50: attvr1(a, v)
  51: register struct atblock * a;
  52: register struct varblock * v;
  53: {
  54: register chainp p;
  55: 
  56: if(v->vdcldone)
  57:     {
  58:     dclerr("attempt to declare variable after use", v->sthead->namep);
  59:     return;
  60:     }
  61: v->vdclstart = 1;
  62: if(v->vclass == CLMOS)
  63:     dclerr("attempt to redefine structure member", v->sthead->namep);
  64: if (v->vdim == 0)
  65:     v->vdim = a->atdim;
  66: else if(!eqdim(a->atdim, v->vdim))
  67:     dclerr("inconsistent dimensions", v->sthead->namep);
  68: if(v->vprec == 0)
  69:     v->vprec = a->atprec;
  70: 
  71: MERGE(attype,vtype);
  72: 
  73: if(v->vtypep == 0)
  74:     {
  75:     if(a->attypep != 0)
  76:         if(a->attype == TYFIELD)
  77:             {
  78:             v->vtypep = ALLOC(fieldspec);
  79:             cpblock(a->attypep, v->vtypep, sizeof(struct fieldspec));
  80:             }
  81:         else if(a->attype == TYCHAR)
  82:             v->vtypep = cpexpr(a->attypep);
  83:         else    v->vtypep = a->attypep;
  84:     else if(a->attypep!=0 && a->attypep!=v->vtypep)
  85:         dclerr("inconsistent attributes", "typep");
  86:     }
  87: 
  88: if(v->vprec!=0 && (v->vtype==TYREAL || v->vtype==TYCOMPLEX) )
  89:     v->vtype += (TYLREAL-TYREAL);
  90: 
  91: if(a->atcommon)
  92:     if(v->vclass !=  0)
  93:         dclerr("common variable already in common, argument list, or external",
  94:             v->sthead->namep);
  95:     else    {
  96:         if(blklevel != a->atcommon->blklevel)
  97:             dclerr("inconsistent common block usage", "");
  98:         for(p = &(a->atcommon->comchain) ; p->nextp!=0 ; p = p->nextp) ;
  99:         p->nextp = mkchain(v, PNULL);
 100:     }
 101: 
 102: if(a->atext!=0 && v->vext==0)
 103:     {
 104:     v->vext = 1;
 105:     extname(v);
 106:     }
 107: else if(a->atclass == CLVALUE)
 108:     if(v->vclass==CLARG || v->vclass==CLVALUE)
 109:         v->vclass = CLVALUE;
 110:     else dclerr("cannot value a non-argument variable",v->sthead->namep);
 111: else  MERGE(atclass,vclass);
 112: if(v->vclass==CLCOMMON || v->vclass==CLVALUE || v->vclass==CLAUTO)
 113:     setvproc(v, PROCNO);
 114: }
 115: 
 116: 
 117: 
 118: 
 119: 
 120: eqdim(a,b)
 121: register ptr a, b;
 122: {
 123: if(a==0 || b==0 || a==b)  return(1);
 124: 
 125: a = a->datap;
 126: b = b->datap;
 127: 
 128: while(a!=0 && b!=0)
 129:     {
 130:     if(!eqexpr(a->lowerb,b->lowerb) || !eqexpr(a->upperb,b->upperb))
 131:         return(0);
 132: 
 133:     a = a->nextp;
 134:     b = b->nextp;
 135:     }
 136: 
 137: return( a == b );
 138: }
 139: 
 140: 
 141: eqexpr(a,b)
 142: register ptr a, b;
 143: {
 144: if(a==b) return(1);
 145: if(a==0 || b==0) return(0);
 146: if(a->tag!=b->tag || a->subtype!=b->subtype)
 147:     return(0);
 148: 
 149: switch(a->tag)
 150:     {
 151: case TCONST:
 152:     return( equals(a->leftp, b->leftp) );
 153: 
 154: case TNAME:
 155:     return( a->sthead ==  b->sthead );
 156: 
 157: case TLIST:
 158:     a = a->leftp;
 159:     b = b->leftp;
 160: 
 161:     while(a!=0 && b!=0)
 162:         {
 163:         if(!eqexpr(a->datap,b->datap))
 164:             return(0);
 165:         a = a->nextp;
 166:         b = b->nextp;
 167:         }
 168:     return( a == b );
 169: 
 170: case TAROP:
 171: case TASGNOP:
 172: case TLOGOP:
 173: case TRELOP:
 174: case TCALL:
 175: case TREPOP:
 176:     return(eqexpr(a->leftp,b->leftp) && eqexpr(a->rightp,b->rightp));
 177: 
 178: case TNOTOP:
 179: case TNEGOP:
 180:     return(eqexpr(a->leftp,b->leftp));
 181: 
 182: default:
 183:     badtag("eqexpr", a->tag);
 184:     }
 185: /* NOTREACHED */
 186: }
 187: 
 188: 
 189: 
 190: setimpl(type, c1, c2)
 191: int type;
 192: register int c1, c2;
 193: {
 194: register int i;
 195: 
 196: if(c1<'a' || c2<c1 || c2>'z')
 197:     dclerr("bad implicit range", CNULL);
 198: else if(type==TYUNDEFINED || type>TYLCOMPLEX)
 199:     dclerr("bad type in implicit statement", CNULL);
 200: else
 201:     for(i = c1 ; i<=c2 ; ++i)
 202:         impltype[i-'a'] = type;
 203: }
 204: 
 205: doinits(p)
 206: register ptr p;
 207: {
 208: register ptr q;
 209: 
 210: for( ; p ; p = p->nextp)
 211:     if( (q = p->datap)->vinit)
 212:         {
 213:         mkinit(q, q->vinit);
 214:         q->vinit = 0;
 215:         }
 216: }
 217: 
 218: 
 219: 
 220: 
 221: mkinit(v, e)
 222: register ptr v;
 223: register ptr e;
 224: {
 225: if(v->vdcldone == 0)
 226:     dclit(v);
 227: 
 228: swii(idfile);
 229: 
 230: if(v->vtype!=TYCHAR && v->vtypep)
 231:     dclerr("structure initialization", v->sthead->namep);
 232: else if(v->vdim==NULL || v->vsubs!=NULL)
 233:     {
 234:     if(e->tag==TLIST && (v->vtype==TYCOMPLEX || v->vtype==TYLCOMPLEX) )
 235:         e = compconst(e);
 236:     valinit(v, e);
 237:     }
 238: else
 239:     arrinit(v,e);
 240: 
 241: swii(icfile);
 242: 
 243: frexpr(e);
 244: }
 245: 
 246: 
 247: 
 248: 
 249: 
 250: valinit(v, e)
 251: register ptr v;
 252: register ptr e;
 253: {
 254: static char buf[4] = "1hX";
 255: int vt;
 256: 
 257: vt = v->vtype;
 258: /*check for special case of one-character initialization of
 259:   non-character datum
 260: */
 261: if(vt==TYCHAR || e->vtype!=TYCHAR || !isconst(e) || strlen(e->leftp)!=1)
 262:     {
 263:     e = simple(RVAL, coerce(vt,e) );
 264:     if(e->tag == TERROR)
 265:         return;
 266:     if( ! isconst(e) )
 267:         {
 268:         dclerr("nonconstant initializer", v->sthead->namep);
 269:         return;
 270:         }
 271:     }
 272: if(vt == TYCHAR)
 273:     {
 274:     charinit(v, e->leftp);
 275:     return;
 276:     }
 277: prexpr( simple(LVAL,v) );
 278: putic(ICOP,OPSLASH);
 279: if(e->vtype != TYCHAR)
 280:     prexpr(e);
 281: else if(strlen(e->leftp) == 1)
 282:     {
 283:     buf[2] = e->leftp[0];
 284:     putsii(ICCONST, buf);
 285:     }
 286: else    dclerr("character initialization of nonchar", v->sthead->namep);
 287: putic(ICOP,OPSLASH);
 288: putic(ICMARK,0);
 289: }
 290: 
 291: 
 292: 
 293: arrinit(v, e)
 294: register ptr v;
 295: register ptr e;
 296: {
 297: struct exprblock *listinit(), *firstelt(), *nextelt();
 298: ptr arrsize();
 299: 
 300: if(e->tag!=TLIST && e->tag!=TREPOP)
 301:     e = mknode(TREPOP, 0, arrsize(v), e);
 302: if( listinit(v, firstelt(v), e) )
 303:     warn("too few initializers");
 304: if(v->vsubs)
 305:     {
 306:     frexpr(v->vsubs);
 307:     v->vsubs = NULL;
 308:     }
 309: }
 310: 
 311: 
 312: 
 313: struct exprblock *listinit(v, subs, e)
 314: register struct varblock *v;
 315: struct exprblock *subs;
 316: register ptr e;
 317: {
 318: struct varblock *vt;
 319: register chainp p;
 320: int n;
 321: struct varblock *subscript();
 322: struct exprblock *nextelt();
 323: 
 324: switch(e->tag)
 325:     {
 326:     case TLIST:
 327:         for(p = e->leftp; p; p = p->nextp)
 328:             {
 329:             if(subs == NULL)
 330:                 goto toomany;
 331:             subs = listinit(v, subs, p->datap);
 332:             }
 333:         return(subs);
 334: 
 335:     case TREPOP:
 336:         if( ! isicon(e->leftp, &n) )
 337:             {
 338:             dclerr("nonconstant repetition factor");
 339:             return(subs);
 340:             }
 341:         while(--n >= 0)
 342:             {
 343:             if(subs == NULL)
 344:                 goto toomany;
 345:             subs = listinit(v, subs, e->rightp);
 346:             }
 347:         return(subs);
 348: 
 349:     default:
 350:         if(subs == NULL)
 351:             goto toomany;
 352:         vt = subscript(cpexpr(v), cpexpr(subs));
 353:         valinit(vt, e);
 354:         frexpr(vt);
 355:         return( nextelt(v,subs) );
 356: 
 357:     }
 358: 
 359: toomany:
 360:     dclerr("too many initializers", NULL);
 361:     return(NULL);
 362: }
 363: 
 364: 
 365: 
 366: 
 367: charinit(v,e)
 368: ptr v;
 369: char *e;
 370: {
 371: register char *bp;
 372: char buf[50];
 373: register int i, j;
 374: int nwd, nch;
 375: 
 376: v = cpexpr(v);
 377: if(v->vsubs == 0)
 378:     v->vsubs = mknode(TLIST,0, mkchain(mkint(1),CHNULL), PNULL);
 379: 
 380: nwd = ceil( nch = conval(v->vtypep) , tailor.ftnchwd);
 381: sprintf(buf,"%dh", tailor.ftnchwd);
 382: for(bp = buf ; *bp ; ++bp )
 383:     ;
 384: 
 385: 
 386: for(i = 0; i<nwd ; ++i)
 387:     {
 388:     if(i > 0) v->vsubs->leftp->datap =
 389:         mknode(TAROP,OPPLUS, v->vsubs->leftp->datap, mkint(1));
 390:     prexpr( v = simple(LVAL,v) );
 391: 
 392:     for(j = 0 ; j<tailor.ftnchwd && *e!='\0' && nch-->0 ; )
 393:         bp[j++] = *e++;
 394:     while(j < tailor.ftnchwd)
 395:         {
 396:         bp[j++] = ' ';
 397:         nch--;
 398:         }
 399:     bp[j] = '\0';
 400: 
 401:     putic(ICOP,OPSLASH);
 402:     putsii(ICCONST, buf);
 403:     putic(ICOP,OPSLASH);
 404:     putic(ICMARK,0);
 405:     }
 406: 
 407: frexpr(v);
 408: }
 409: 
 410: 
 411: 
 412: 
 413: 
 414: 
 415: 
 416: struct exprblock *firstelt(v)
 417: register struct varblock *v;
 418: {
 419: register struct dimblock *b;
 420: register chainp s;
 421: ptr t;
 422: int junk;
 423: 
 424: if(v->vdim==NULL || v->vsubs!=NULL)
 425:     fatal("firstelt: bad argument");
 426: s = NULL;
 427: for(b = v->vdim->datap ; b; b = b->nextp)
 428:     {
 429:     t = (b->lowerb ? cpexpr(b->lowerb) : mkint(1) );
 430:     s = hookup(s, mkchain(t,CHNULL) );
 431:     if(!isicon(b->upperb,&junk) || (b->lowerb && !isicon(b->lowerb,&junk)) )
 432:         dclerr("attempt to initialize adjustable array",
 433:             v->sthead->namep);
 434:     }
 435: return( mknode(TLIST, 0, s, PNULL) );
 436: }
 437: 
 438: 
 439: 
 440: 
 441: struct exprblock *nextelt(v,subs)
 442: struct varblock *v;
 443: struct exprblock *subs;
 444: {
 445: register struct dimblock *b;
 446: register chainp *s;
 447: int sv;
 448: 
 449: if(v == NULL)
 450:     return(NULL);
 451: 
 452: b = v->vdim->datap;
 453: s = subs->leftp;
 454: 
 455: while(b && s)
 456:     {
 457:     sv = conval(s->datap);
 458:     frexpr(s->datap);
 459:     if( sv < conval(b->upperb) )
 460:         {
 461:         s->datap =mkint(sv+1);
 462:         return(subs);
 463:         }
 464:     s->datap = (b->lowerb ? cpexpr(b->lowerb) : mkint(1) );
 465: 
 466:     b = b->nextp;
 467:     s = s->nextp;
 468:     }
 469: 
 470: if(b || s)
 471:     fatal("nextelt: bad subscript count");
 472: return(NULL);
 473: }

Defined functions

Defined variables

Defined macros