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

   1: #include "defs"
   2: 
   3: 
   4: ptr mkcomm(s)
   5: register char *s;
   6: {
   7: register ptr p;
   8: register char *t;
   9: 
  10: for(p = commonlist ; p ; p = p->nextp)
  11:     if(equals(s, p->datap->comname))
  12:         return(p->datap);
  13: 
  14: p = ALLOC(comentry);
  15: for(t = p->comname ; *t++ = *s++ ; ) ;
  16: p->tag = TCOMMON;
  17: p->blklevel = (blklevel>0? 1 : 0);
  18: commonlist = mkchain(p, commonlist);
  19: return(commonlist->datap);
  20: }
  21: 
  22: 
  23: 
  24: 
  25: ptr mkname(s)
  26: char *s;
  27: {
  28: char *copys();
  29: register ptr p;
  30: 
  31: if( (p = name(s,1)) == 0)
  32:     {
  33:     p = name(s,0);
  34:     p->tag = TNAME;
  35:     p->blklevel = blklevel;
  36:     }
  37: return(p);
  38: }
  39: 
  40: ptr mknode(t, o, l, r)
  41: int t,o;
  42: register ptr l;
  43: register ptr r;
  44: {
  45: register struct exprblock *p;
  46: ptr q;
  47: int lt, rt;
  48: int ll, rl;
  49: ptr mksub1(), mkchcon();
  50: 
  51: p = allexpblock();
  52: TEST fprintf(diagfile, "mknode(%d,%d,%o,%o) = %o\n", t, o, l, r, p);
  53: 
  54: top:
  55:     if(t!=TLIST && t!=TCONST && l!=0 && l->tag==TERROR)
  56:         {
  57:         frexpr(r);
  58:         frexpblock(p);
  59:         return(l);
  60:         }
  61: 
  62:     if(r!=0 && r->tag==TERROR)
  63:         {
  64:         frexpr(l);
  65:         frexpblock(p);
  66:         return(r);
  67:         }
  68:     p->tag = t;
  69:     p->subtype = o;
  70:     p->leftp = l;
  71:     p->rightp = r;
  72: 
  73: switch(t)
  74:     {
  75:     case TAROP:
  76:         ckdcl(l);
  77:         ckdcl(r);
  78:         switch(lt = l->vtype)
  79:             {
  80:             case TYCHAR:
  81:             case TYSTRUCT:
  82:             case TYLOG:
  83:                 exprerr("non-arithmetic operand of arith op","");
  84:                 goto err;
  85:             }
  86: 
  87:         switch(rt = r->vtype)
  88:             {
  89:             case TYCHAR:
  90:             case TYSTRUCT:
  91:             case TYLOG:
  92:                 exprerr("non-arithmetic operand of arith op","");
  93:                 goto err;
  94:             }
  95:         if(lt==rt || (o==OPPOWER && rt==TYINT) )
  96:             p->vtype = lt;
  97:         else if( (lt==TYREAL && rt==TYLREAL) ||
  98:             (lt==TYLREAL && rt==TYREAL) )
  99:                 p->vtype = TYLREAL;
 100:         else if(lt==TYINT)
 101:             {
 102:             l = coerce(rt,l);
 103:             goto top;
 104:             }
 105:         else if(rt==TYINT)
 106:             {
 107:             r = coerce(lt,r);
 108:             goto top;
 109:             }
 110:         else if( (lt==TYREAL && rt==TYCOMPLEX) ||
 111:              (lt==TYCOMPLEX && rt==TYREAL) )
 112:             p->vtype = TYCOMPLEX;
 113:         else if( (lt==TYLREAL && rt==TYCOMPLEX) ||
 114:              (lt==TYCOMPLEX && rt==TYLREAL) )
 115:             p->vtype = TYLCOMPLEX;
 116:         else    {
 117:             exprerr("mixed mode", CNULL);
 118:             goto err;
 119:             }
 120: 
 121:         if( (o==OPPLUS||o==OPSTAR) && l->tag==TCONST && r->tag!=TCONST )
 122:             {
 123:             p->leftp = r;
 124:             p->rightp = l;
 125:             }
 126: 
 127:         if(o==OPPLUS && l->tag==TNEGOP &&
 128:           (r->tag!=TCONST || l->leftp->tag==TCONST) )
 129:             {
 130:             p->subtype = OPMINUS;
 131:             p->leftp = r;
 132:             p->rightp = l->leftp;
 133:             }
 134: 
 135:         break;
 136: 
 137:     case TRELOP:
 138:         ckdcl(l);
 139:         ckdcl(r);
 140:         p->vtype = TYLOG;
 141:         lt = l->vtype;
 142:         rt = r->vtype;
 143:         if(lt==TYCHAR || rt==TYCHAR)
 144:             {
 145:             if(l->vtype != r->vtype)
 146:                 {
 147:                 exprerr("comparison of character and noncharacter data",CNULL);
 148:                 goto err;
 149:                 }
 150:             ll = conval(l->vtypep);
 151:             rl = conval(r->vtypep);
 152:             if( (o==OPEQ || o==OPNE) &&
 153:                 ( (ll==1 && rl==1 && tailor.charcomp==1)
 154:                 || (ll<=tailor.ftnchwd && rl<=tailor.ftnchwd
 155:                 && tailor.charcomp==2) ))
 156:                 {
 157:                 if(l->tag == TCONST)
 158:                     {
 159:                     q = cpexpr( mkchcon(l->leftp) );
 160:                     frexpr(l);
 161:                     l = q;
 162:                     }
 163:                 if(r->tag == TCONST)
 164:                     {
 165:                     q = cpexpr( mkchcon(r->leftp) );
 166:                     frexpr(r);
 167:                     r = q;
 168:                     }
 169:                 if(l->vsubs == 0)
 170:                     l->vsubs = mksub1();
 171:                 if(r->vsubs == 0)
 172:                     r->vsubs = mksub1();
 173:                 p->leftp = l;
 174:                 p->rightp = r;
 175:                 }
 176:             else    {
 177:                 p->leftp = mkcall(builtin(TYINT,"ef1cmc"), arg4(l,r));
 178:                 p->rightp = mkint(0);
 179:                 }
 180:             }
 181: 
 182:         else if(lt==TYLOG || rt==TYLOG)
 183:             exprerr("relational involving logicals", CNULL);
 184:         else if( (lt==TYCOMPLEX || rt==TYCOMPLEX) &&
 185:             o!=OPEQ && o!=OPNE)
 186:                 exprerr("order comparison of complex numbers", CNULL);
 187:         else if(lt != rt)
 188:             {
 189:             if(lt==TYINT)
 190:                 p->leftp = coerce(rt, l);
 191:             else if(rt == TYINT)
 192:                 p->rightp = coerce(lt, r);
 193:             }
 194:         break;
 195: 
 196:     case TLOGOP:
 197:         ckdcl(l);
 198:         ckdcl(r);
 199:         if(r->vtype != TYLOG)
 200:             {
 201:             exprerr("non-logical operand of logical operator",CNULL);
 202:             goto err;
 203:             }
 204:     case TNOTOP:
 205:         ckdcl(l);
 206:         if(l->vtype != TYLOG)
 207:             {
 208:             exprerr("non-logical operand of logical operator",CNULL);
 209:             }
 210:         p->vtype = TYLOG;
 211:         break;
 212: 
 213:     case TNEGOP:
 214:         ckdcl(l);
 215:         lt = l->vtype;
 216:         if(lt!=TYINT && lt!=TYREAL && lt!=TYLREAL && lt!=TYCOMPLEX)
 217:             {
 218:             exprerr("impossible unary + or - operation",CNULL);
 219:             goto err;
 220:             }
 221:         p->vtype = lt;
 222:         break;
 223: 
 224:     case TCALL:
 225:         p->vtype = l->vtype;
 226:         p->vtypep = l->vtypep;
 227:         break;
 228: 
 229:     case TASGNOP:
 230:         ckdcl(l);
 231:         ckdcl(r);
 232:         lt = l->vtype;
 233:         if(lt==TYFIELD)
 234:             lt = TYINT;
 235:         rt = r->vtype;
 236:         if(lt==TYCHAR || rt==TYCHAR || lt==TYLOG || rt==TYLOG)
 237:             {
 238:             if(lt != rt)
 239:                 {
 240:                 exprerr("illegal assignment",CNULL);
 241:                 goto err;
 242:                 }
 243:             }
 244:         else if(lt==TYSTRUCT || rt==TYSTRUCT)
 245:             {
 246:             if(lt!=rt || l->vtypep->strsize!=r->vtypep->strsize
 247:                 || l->vtypep->stralign!=r->vtypep->stralign)
 248:                 {
 249:                 exprerr("illegal structure assignment",CNULL);
 250:                 goto err;
 251:                 }
 252:             }
 253:         else if ( (lt==TYCOMPLEX || rt==TYCOMPLEX) && lt!=rt)
 254: /*			p->rightp = r = coerce(lt, r) */ ;
 255: 
 256:         p->vtype = lt;
 257:         p->vtypep = l->vtypep;
 258:         break;
 259: 
 260:     case TCONST:
 261:     case TLIST:
 262:     case TREPOP:
 263:         break;
 264: 
 265:     default:
 266:         badtag("mknode", t);
 267:     }
 268: 
 269: return(p);
 270: 
 271: err:    frexpr(p);
 272:     return( errnode() );
 273: }
 274: 
 275: 
 276: 
 277: ckdcl(p)
 278: ptr p;
 279: {
 280: if(p->vtype==TYUNDEFINED || (p->tag==TNAME&&p->vdcldone==0&&p->vadjdim==0))
 281:     {
 282: /*debug*/ printf("tag=%d, typed=%d\n", p->tag, p->vtype);
 283:     fatal("untyped subexpression");
 284:     }
 285: if(p->tag==TNAME) setvproc(p,PROCNO);
 286: }
 287: 
 288: ptr mkvar(p)
 289: register ptr p;
 290: {
 291: register ptr q;
 292: 
 293: TEST fprintf(diagfile, "mkvar(%s), blk %d\n", p->namep, blklevel);
 294: 
 295: if(p->blklevel > blklevel)
 296:     p->blklevel = blklevel;
 297: 
 298: if(instruct || p->varp==0 || p->varp->blklevel<blklevel)
 299:     {
 300:     q = allexpblock();
 301:     q->tag = TNAME;
 302:     q->sthead = p;
 303:     q->blklevel = blklevel;
 304:     if(! instruct)
 305:         ++ndecl[blklevel];
 306:     }
 307: else q = p->varp;
 308: 
 309: if(!instruct)
 310:     {
 311:     if(p->varp && p->varp->blklevel<blklevel)
 312:         hide(p);
 313:     if(p->varp == 0)
 314:         p->varp = q;
 315:     }
 316: 
 317: p->tag = TNAME;
 318: return(q);
 319: }
 320: 
 321: 
 322: ptr mkstruct(v,s)
 323: register ptr v;
 324: ptr s;
 325: {
 326: register ptr p;
 327: 
 328: p = ALLOC(typeblock);
 329: p->sthead = v;
 330: p->tag = TSTRUCT;
 331: p->blklevel = blklevel;
 332: p->strdesc = s;
 333: offsets(p);
 334: if(v)   {
 335:     v->blklevel = blklevel;
 336:     ++ndecl[blklevel];
 337:     v->varp = p;
 338:     }
 339: else    temptypelist = mkchain(p, temptypelist);
 340: return(p);
 341: }
 342: 
 343: 
 344: ptr mkcall(fn1, args)
 345: ptr fn1, args;
 346: {
 347: int i, j, first;
 348: register ptr funct, p, q;
 349: ptr r;
 350: 
 351: if(fn1->tag == TERROR)
 352:     return( errnode() );
 353: else if(fn1->tag == TNAME)
 354:     {
 355:     funct = fn1->sthead->varp;
 356:     frexpblock(fn1);
 357:     }
 358: else
 359:     funct = fn1;
 360: if(funct->vclass!=0 && funct->vclass!=CLARG)
 361:     {
 362:     exprerr("invalid invocation of %s",funct->sthead->namep);
 363:     frexpr(args);
 364:     return( errnode() );
 365:     }
 366: else    extname(funct);
 367: 
 368: if(args)  for(p = args->leftp; p ; p = p->nextp)
 369:     {
 370:     q = p->datap;
 371:     if( (q->tag==TCALL&&q->vtype==TYUNDEFINED) ||
 372:         (q->tag==TNAME&&q->vdcldone==0) )
 373:         dclit(q);
 374:     if(q->tag==TNAME && q->vproc==PROCUNKNOWN)
 375:         setvproc(q, PROCNO);
 376:     if( q->vtype == TYSTRUCT)
 377:         {
 378:         first = 1;
 379:         for(i = 0; i<NFTNTYPES ; ++i)
 380:             if(q->vbase[i] != 0)
 381:                 {
 382:                 r = cpexpr(q);
 383:                 if(first)
 384:                     {
 385:                     p->datap = r;
 386:                     first = 0;
 387:                     }
 388:                 else    p = p->nextp = mkchain(r, p->nextp);
 389:                 r->vtype = ftnefl[i];
 390:                 for(j=0; j<NFTNTYPES; ++j)
 391:                     if(i != j) r->vbase[j] = 0;
 392:                 }
 393:         frexpblock(q);
 394:         }
 395:     }
 396: 
 397: return( mknode(TCALL,0,cpexpr(funct), args) );
 398: }
 399: 
 400: 
 401: 
 402: mkcase(p,here)
 403: ptr p;
 404: int here;
 405: {
 406: register ptr q, s;
 407: 
 408: for(s = thisctl ; s!=0 && s->subtype!=STSWITCH ; s = s->prevctl)
 409:     ;
 410: if(s==0 || (here && s!=thisctl) )
 411:     {
 412:     laberr("invalid case label location",CNULL);
 413:     return(0);
 414:     }
 415: for(q = s->loopctl ; q!=0 && !eqcon(p,q->casexpr) ; q = q->nextcase)
 416:     ;
 417: if(q == 0)
 418:     {
 419:     q = ALLOC(caseblock);
 420:     q->tag = TCASE;
 421:     q->casexpr = p;
 422:     q->labelno = ( here ? thislab() : nextlab() );
 423:     q->nextcase = s->loopctl;
 424:     s->loopctl = q;
 425:     }
 426: else if(here)
 427:     if(thisexec->labelno == 0)
 428:         thisexec->labelno = q->labelno;
 429:     else if(thisexec->labelno != q->labelno)
 430:         {
 431:         exnull();
 432:         thisexec->labelno = q->labelno;
 433:         thisexec->labused = 0;
 434:         }
 435: if(here)
 436:     if(q->labdefined)
 437:         laberr("multiply defined case",CNULL);
 438:     else
 439:         q->labdefined = 1;
 440: return(q->labelno);
 441: }
 442: 
 443: 
 444: ptr mkilab(p)
 445: ptr p;
 446: {
 447: char *s, l[30];
 448: 
 449: if(p->tag!=TCONST || p->vtype!=TYINT)
 450:     {
 451:     execerr("invalid label","");
 452:     s = "";
 453:     }
 454: else    s = p->leftp;
 455: 
 456: while(*s == '0')
 457:     ++s;
 458: sprintf(l,"#%s", s);
 459: 
 460: 
 461: TEST fprintf(diagfile,"numeric label = %s\n", l);
 462: return( mkname(l) );
 463: }
 464: 
 465: 
 466: 
 467: 
 468: mklabel(p,here)
 469: ptr p;
 470: int here;
 471: {
 472: register ptr q;
 473: 
 474: if(q = p->varp)
 475:     {
 476:     if(q->tag != TLABEL)
 477:         laberr("%s is already a nonlabel\n", p->namep);
 478:     else if(q->labinacc)
 479:         warn1("label %s is inaccessible", p->namep);
 480:     else if(here)
 481:         if(q->labdefined)
 482:             laberr("%s is already defined\n", p->namep);
 483:         else if(blklevel > q->blklevel)
 484:             laberr("%s is illegally placed\n",p->namep);
 485:         else    {
 486:             q->labdefined = 1;
 487:             if(thisexec->labelno == 0)
 488:                 thisexec->labelno = q->labelno;
 489:             else if(thisexec->labelno != q->labelno)
 490:                 {
 491:                 exnull();
 492:                 thisexec->labelno = q->labelno;
 493:                 thisexec->labused = 0;
 494:                 }
 495:             }
 496:     }
 497: else    {
 498:     q = ALLOC(labelblock);
 499:     p->varp = q;
 500:     q->tag = TLABEL;
 501:     q->subtype = 0;
 502:     q->blklevel = blklevel;
 503:     ++ndecl[blklevel];
 504:     q->labdefined = here;
 505:     q->labelno = ( here ? thislab() : nextlab() );
 506:     q->sthead = p;
 507:     }
 508: 
 509: return(q->labelno);
 510: }
 511: 
 512: 
 513: thislab()
 514: {
 515: if(thisexec->labelno == 0)
 516:     thisexec->labelno = nextlab();
 517: return(thisexec->labelno);
 518: }
 519: 
 520: 
 521: nextlab()
 522: {
 523: stnos[++labno] = 0;
 524: return( labno );
 525: }
 526: 
 527: 
 528: nextindif()
 529: {
 530: if(++nxtindif < MAXINDIFS)
 531:     return(nxtindif);
 532: fatal("too many indifs");
 533: }
 534: 
 535: 
 536: 
 537: 
 538: mkkeywd(s, n)
 539: char *s;
 540: int n;
 541: {
 542: register ptr p;
 543: register ptr q;
 544: 
 545: p = name(s, 2);
 546: q = ALLOC(keyblock);
 547: p->tag = TKEYWORD;
 548: q->tag = TKEYWORD;
 549: p->subtype = n;
 550: q->subtype = n;
 551: p->blklevel = 0;
 552: p->varp = q;
 553: q->sthead = p;
 554: }
 555: 
 556: 
 557: ptr mkdef(s, v)
 558: char *s, *v;
 559: {
 560: register ptr p;
 561: register ptr q;
 562: 
 563: if(p = name(s,1))
 564:     if(p->blklevel == 0)
 565:         {
 566:         if(blklevel > 0)
 567:             hide(p);
 568:         else if(p->tag != TDEFINE)
 569:             dclerr("attempt to DEFINE a variable name", s);
 570:         else    {
 571:             if( strcmp(v, (q=p->varp) ->valp) )
 572:                 {
 573:                 warn("macro value replaced");
 574:                 cfree(q->valp);
 575:                 q->valp = copys(v);
 576:                 }
 577:             return(p);
 578:             }
 579:         }
 580:     else    {
 581:         dclerr("type already defined", s);
 582:         return( errnode() );
 583:         }
 584: else   p = name(s,0);
 585: 
 586: q = ALLOC(defblock);
 587: p->tag = TDEFINE;
 588: q->tag = TDEFINE;
 589: p->blklevel = q->blklevel = (blklevel==0 ? 0 : 1);
 590: q->sthead = p;
 591: p->varp = q;
 592: p->varp->valp = copys(v);
 593: return(p);
 594: }
 595: 
 596: 
 597: 
 598: mkknown(s,t)
 599: char *s;
 600: int t;
 601: {
 602: register ptr p;
 603: 
 604: p = ALLOC(knownname);
 605: p->nextfunct = knownlist;
 606: p->tag = TKNOWNFUNCT;
 607: knownlist = p;
 608: p->funcname = s;
 609: p->functype = t;
 610: }
 611: 
 612: 
 613: 
 614: 
 615: 
 616: 
 617: 
 618: ptr mkint(k)
 619: int k;
 620: {
 621: return( mkconst(TYINT, convic(k) ) );
 622: }
 623: 
 624: 
 625: ptr mkconst(t,p)
 626: int t;
 627: ptr p;
 628: {
 629: ptr q;
 630: 
 631: q = mknode(TCONST, 0, copys(p), PNULL);
 632: q->vtype = t;
 633: if(t == TYCHAR)
 634:     q->vtypep = mkint( strlen(p) );
 635: return(q);
 636: }
 637: 
 638: 
 639: 
 640: ptr mkimcon(t,p)
 641: int t;
 642: char *p;
 643: {
 644: ptr q;
 645: char *zero, buff[100];
 646: 
 647: zero = (t==TYCOMPLEX ? "0." : "0d0");
 648: sprintf(buff, "(%s,%s)", zero, p);
 649: q = mknode(TCONST, 0, copys(buff), PNULL);
 650: q->vtype = t;
 651: return(q);
 652: }
 653: 
 654: 
 655: 
 656: ptr mkarrow(p,t)
 657: register ptr p;
 658: ptr t;
 659: {
 660: register ptr q, s;
 661: 
 662: if(p->vsubs == 0)
 663:     if(p->vdim==0 && p->vtype!=TYCHAR && p->vtype!=TYSTRUCT)
 664:         {
 665:         exprerr("need an aggregate to the left of arrow",CNULL);
 666:         frexpr(p);
 667:         return( errnode() );
 668:         }
 669:     else    {
 670:         if(p->vdim)
 671:             {
 672:             s = 0;
 673:             for(q = p->vdim->datap ; q ; q = q->nextp)
 674:                 s = mkchain( mkint(1), s);
 675:             subscript(p, mknode(TLIST,0,s,PNULL) );
 676:             }
 677:         }
 678: 
 679: p->vtype = TYSTRUCT;
 680: p->vtypep = t->varp;
 681: return(p);
 682: }
 683: 
 684: 
 685: 
 686: 
 687: 
 688: mkequiv(p)
 689: ptr p;
 690: {
 691: ptr q, t;
 692: int first;
 693: 
 694: swii(iefile);
 695: putic(ICBEGIN, 0);
 696: putic(ICINDENT, 0);
 697: putic(ICKEYWORD, FEQUIVALENCE);
 698: putic(ICOP, OPLPAR);
 699: first = 1;
 700: 
 701: for(q = p ; q ; q = q->nextp)
 702:     {
 703:     if(first)  first = 0;
 704:     else putic(ICOP, OPCOMMA);
 705:     prexpr( t =  simple(LVAL,q->datap) );
 706:     frexpr(t);
 707:     }
 708: 
 709: putic(ICOP, OPRPAR);
 710: swii(icfile);
 711: frchain( &p );
 712: }
 713: 
 714: 
 715: 
 716: 
 717: mkgeneric(gname,atype,fname,ftype)
 718: char *gname, *fname;
 719: int atype, ftype;
 720: {
 721: register ptr p;
 722: ptr generic();
 723: 
 724: if(p = generic(gname))
 725:     {
 726:     if(p->genfname[atype])
 727:         fatal1("generic name already defined", gname);
 728:     }
 729: else    {
 730:     p = ALLOC(genblock);
 731:     p->tag = TGENERIC;
 732:     p->nextgenf = generlist;
 733:     generlist = p;
 734:     p->genname = gname;
 735:     }
 736: 
 737: p->genfname[atype] = fname;
 738: p->genftype[atype] = ftype;
 739: }
 740: 
 741: 
 742: ptr generic(s)
 743: char *s;
 744: {
 745: register ptr p;
 746: 
 747: for(p= generlist; p ; p = p->nextgenf)
 748:     if(equals(s, p->genname))
 749:         return(p);
 750: return(0);
 751: }
 752: 
 753: 
 754: knownfunct(s)
 755: char *s;
 756: {
 757: register ptr p;
 758: 
 759: for(p = knownlist ; p ; p = p->nextfunct)
 760:     if(equals(s, p->funcname))
 761:         return(p->functype);
 762: return(0);
 763: }
 764: 
 765: 
 766: 
 767: 
 768: 
 769: ptr funcinv(p)
 770: register ptr p;
 771: {
 772: ptr fp, fp1;
 773: register ptr g;
 774: char *s;
 775: register int t;
 776: int vt;
 777: 
 778: if(g = generic(s = p->leftp->sthead->namep))
 779:     {
 780:     if(p->rightp->tag==TLIST && p->rightp->leftp
 781:         && ( (vt = typearg(p->rightp->leftp)) >=0)
 782:         && (t = g->genftype[vt]) )
 783:         {
 784:         p->leftp = builtin(t, g->genfname[vt]);
 785:         }
 786:     else    {
 787:         dclerr("improper use of generic function", s);
 788:         frexpr(p);
 789:         return( errnode() );
 790:         }
 791:     }
 792: 
 793: fp = p->leftp;
 794: setvproc(fp, PROCYES);
 795: fp1 = fp->sthead->varp;
 796: s = fp->sthead->namep;
 797: 
 798: if(p->vtype==TYUNDEFINED && fp->vclass!=CLARG)
 799:     if(t = knownfunct(s))
 800:         {
 801:         p->vtype = t;
 802:         setvproc(fp, PROCINTRINSIC);
 803:         setvproc(fp1, PROCINTRINSIC);
 804:         fp1->vtype = t;
 805:         builtin(t,fp1->sthead->namep);
 806:         cpblock(fp1, fp, sizeof(struct exprblock));
 807:         }
 808: 
 809: dclit(p);
 810: return(p);
 811: }
 812: 
 813: 
 814: 
 815: 
 816: typearg(p0)
 817: register chainp p0;
 818: {
 819: register chainp p;
 820: register int vt, maxt;
 821: 
 822: if(p0 == NULL)
 823:     return(-1);
 824: maxt = p0->datap->vtype;
 825: 
 826: for(p = p0->nextp ; p ; p = p->nextp)
 827:     if( (vt = p->datap->vtype) > maxt)
 828:         maxt = vt;
 829: 
 830: for(p = p0 ; p ; p = p->nextp)
 831:     p->datap = coerce(maxt, p->datap);
 832: 
 833: return(maxt);
 834: }
 835: 
 836: 
 837: 
 838: 
 839: ptr typexpr(t,e)
 840: register ptr t, e;
 841: {
 842: ptr e1;
 843: int etag;
 844: 
 845: if(t->atdim!=0 || (e->tag==TLIST && t->attype!=TYCOMPLEX) )
 846:     goto typerr;
 847: 
 848: switch(t->attype)
 849:     {
 850:     case TYCOMPLEX:
 851:         if(e->tag==TLIST)
 852:             if(e->leftp==0 || e->leftp->nextp==0
 853:                 || e->leftp->nextp->nextp!=0)
 854:                 {
 855:                 exprerr("bad conversion to complex", "");
 856:                 return( errnode() );
 857:                 }
 858:             else    {
 859:                 e->leftp->datap = simple(RVAL,
 860:                         e->leftp->datap);
 861:                 e->leftp->nextp->datap = simple(RVAL,
 862:                         e->leftp->nextp->datap);
 863:                 if(isconst(e->leftp->datap) &&
 864:                    isconst(e->leftp->nextp->datap) )
 865:                     return( compconst(e) );
 866:                 e1 = mkcall(builtin(TYCOMPLEX,"cmplx"),
 867:                     arg2( coerce(TYREAL,e->leftp->datap),
 868:                     coerce(TYREAL,e->leftp->nextp->datap)));
 869:                 frchain( &(e->leftp) );
 870:                 frexpblock(e);
 871:                 return(e1);
 872:                 }
 873: 
 874:     case TYINT:
 875:     case TYREAL:
 876:     case TYLREAL:
 877:     case TYLOG:
 878:     case TYFIELD:
 879:         e = coerce(t->attype, simple(RVAL, e) );
 880:         etag = e->tag;
 881:         if(etag==TAROP || etag==TLOGOP || etag==TRELOP)
 882:             e->needpar = YES;
 883:         return(e);
 884: 
 885:     case TYCHAR:
 886:     case TYSTRUCT:
 887:         goto typerr;
 888:     }
 889: 
 890: typerr:
 891:     exprerr("typexpr not fully implemented", "");
 892:     frexpr(e);
 893:     return( errnode() );
 894: }
 895: 
 896: 
 897: 
 898: 
 899: ptr compconst(p)
 900: register ptr p;
 901: {
 902: register ptr a, b;
 903: int as, bs;
 904: int prec;
 905: 
 906: prec = TYREAL;
 907: p = p->leftp;
 908: if(p == 0)
 909:     goto err;
 910: if(p->datap->vtype == TYLREAL)
 911:     prec = TYLREAL;
 912: a = coerce(TYLREAL, p->datap);
 913: p = p->nextp;
 914: if(p->nextp)
 915:     goto err;
 916: if(p->datap->vtype == TYLREAL)
 917:     a = coerce(prec = TYLREAL,a);
 918: b = coerce(TYLREAL, p->datap);
 919: 
 920: if(a->tag==TNEGOP)
 921:     {
 922:     as = '-';
 923:     a = a->leftp;
 924:     }
 925: else    as = ' ';
 926: 
 927: if(b->tag==TNEGOP)
 928:     {
 929:     bs = '-';
 930:     b = b->leftp;
 931:     }
 932: else    bs = ' ';
 933: 
 934: if(a->tag!=TCONST || a->vtype!=prec ||
 935:    b->tag!=TCONST || b->vtype!=prec )
 936:         goto err;
 937: 
 938: if(prec==TYLREAL && tailor.lngcxtype==NULL)
 939:     {
 940:     ptr q, e1, e2;
 941:     struct dimblock *dp;
 942:     sprintf(msg, "_const%d", ++constno);
 943:     q = mkvar(mkname(msg));
 944:     q->vtype = TYLREAL;
 945:     dclit(q);
 946:     dp = ALLOC(dimblock);
 947:     dp->upperb = mkint(2);
 948:     q->vdim = mkchain(dp,CHNULL);
 949:     sprintf(msg, "%c%s", as, a->leftp);
 950:     e1 = mkconst(TYLREAL, msg);
 951:     sprintf(msg, "%c%s", bs, b->leftp);
 952:     e2 = mkconst(TYLREAL, msg);
 953:     mkinit(q, mknode(TLIST,0, mkchain(e1,mkchain(e2,CHNULL)),PNULL) );
 954:     cfree(q->vdim);
 955:     q->vtype = TYLCOMPLEX;
 956:     return(q);
 957:     }
 958: else
 959:     {
 960:     sprintf(msg, "(%c%s, %c%s)", as, a->leftp, bs, b->leftp);
 961:     return( mkconst(TYCOMPLEX, msg) );
 962:     }
 963: 
 964: err:    exprerr("invalid complex constant", "");
 965:     return( errnode() );
 966: }
 967: 
 968: 
 969: 
 970: 
 971: ptr mkchcon(p)
 972: char *p;
 973: {
 974: register ptr q;
 975: char buf[10];
 976: 
 977: sprintf(buf, "_const%d", ++constno);
 978: q = mkvar(mkname(buf));
 979: q->vtype = TYCHAR;
 980: q->vtypep = mkint(strlen(p));
 981: mkinit(q, mkconst(TYCHAR, p));
 982: return(q);
 983: }
 984: 
 985: 
 986: 
 987: ptr mksub1()
 988: {
 989: return( mknode(TLIST,0, mkchain(mkint(1),CHNULL), PNULL) );
 990: }

Defined functions