![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to mk.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / usr.bin / efl|
Return to mk.c CVS log | Up to [CSRG BSD Unix] / 43BSD / usr.bin / efl |
1.1 ! root 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: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.