![[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 [Research Unix] / researchv10no / cmd / efl|
Return to mk.c CVS log | Up to [Research Unix] / researchv10no / cmd / 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 = (int *)commonlist ; p ; p = p->nextp) ! 11: if(equals(s, ((struct comentry *)p->datap)->comname)) ! 12: return(p->datap); ! 13: ! 14: p = (int *)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 = (int *)name(s,1)) == 0) ! 32: { ! 33: p = (int *)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 = (struct exprblock *)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 || ((struct headbits *)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 || ((struct typeblock *)l->vtypep)->strsize!=((struct typeblock *)r->vtypep)->strsize ! 247: || ((struct typeblock *)l->vtypep)->stralign!=((struct typeblock *)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((int *)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(p->tag == TLABEL) ! 299: { ! 300: laberr("attempt to use label as variable", p->namep); ! 301: return( errnode() ); ! 302: } ! 303: if(instruct || p->varp==0 || ((struct headbits *)p->varp)->blklevel<blklevel) ! 304: { ! 305: q = allexpblock(); ! 306: q->tag = TNAME; ! 307: q->sthead = p; ! 308: q->blklevel = blklevel; ! 309: if(! instruct) ! 310: ++ndecl[blklevel]; ! 311: } ! 312: else q = p->varp; ! 313: ! 314: if(!instruct) ! 315: { ! 316: if(p->varp && ((struct headbits *)p->varp)->blklevel<blklevel) ! 317: hide(p); ! 318: if(p->varp == 0) ! 319: p->varp = q; ! 320: } ! 321: ! 322: p->tag = TNAME; ! 323: return(q); ! 324: } ! 325: ! 326: ! 327: ptr mkstruct(v,s) ! 328: register ptr v; ! 329: ptr s; ! 330: { ! 331: register ptr p; ! 332: ! 333: p = (int *)ALLOC(typeblock); ! 334: p->sthead = v; ! 335: p->tag = TSTRUCT; ! 336: p->blklevel = blklevel; ! 337: p->strdesc = s; ! 338: offsets(p); ! 339: if(v) { ! 340: v->blklevel = blklevel; ! 341: ++ndecl[blklevel]; ! 342: v->varp = p; ! 343: } ! 344: else temptypelist = mkchain(p, temptypelist); ! 345: return(p); ! 346: } ! 347: ! 348: ! 349: ptr mkcall(fn1, args) ! 350: ptr fn1, args; ! 351: { ! 352: int i, j, first; ! 353: register ptr funct, p, q; ! 354: ptr r; ! 355: ! 356: if(fn1->tag == TERROR) ! 357: return( errnode() ); ! 358: else if(fn1->tag == TNAME) ! 359: { ! 360: funct = ((struct stentry *)fn1->sthead)->varp; ! 361: frexpblock(fn1); ! 362: } ! 363: else ! 364: funct = fn1; ! 365: if(funct->vclass!=0 && funct->vclass!=CLARG) ! 366: { ! 367: exprerr("invalid invocation of %s",((struct stentry *)funct->sthead)->namep); ! 368: frexpr(args); ! 369: return( errnode() ); ! 370: } ! 371: else extname(funct); ! 372: ! 373: if(args) for(p = args->leftp; p ; p = p->nextp) ! 374: { ! 375: q = p->datap; ! 376: if( (q->tag==TCALL&&q->vtype==TYUNDEFINED) || ! 377: (q->tag==TNAME&&q->vdcldone==0) ) ! 378: dclit(q); ! 379: if(q->tag==TNAME && q->vproc==PROCUNKNOWN) ! 380: setvproc(q, PROCNO); ! 381: if( q->vtype == TYSTRUCT) ! 382: { ! 383: first = 1; ! 384: for(i = 0; i<NFTNTYPES ; ++i) ! 385: if(q->vbase[i] != 0) ! 386: { ! 387: r = cpexpr(q); ! 388: if(first) ! 389: { ! 390: p->datap = r; ! 391: first = 0; ! 392: } ! 393: else p = p->nextp = (int *)mkchain(r, p->nextp); ! 394: r->vtype = ftnefl[i]; ! 395: for(j=0; j<NFTNTYPES; ++j) ! 396: if(i != j) r->vbase[j] = 0; ! 397: } ! 398: frexpblock(q); ! 399: } ! 400: } ! 401: ! 402: return( mknode(TCALL,0,cpexpr(funct), args) ); ! 403: } ! 404: ! 405: ! 406: ! 407: mkcase(p,here) ! 408: ptr p; ! 409: int here; ! 410: { ! 411: register ptr q, s; ! 412: ! 413: for(s = thisctl ; s!=0 && s->subtype!=STSWITCH ; s = s->prevctl) ! 414: ; ! 415: if(s==0 || (here && s!=thisctl) ) ! 416: { ! 417: laberr("invalid case label location",CNULL); ! 418: return(0); ! 419: } ! 420: ! 421: p = simple(RVAL,p); ! 422: for(q = s->loopctl ; q!=0 && !eqcon(p,q->casexpr) ; q = q->nextcase) ! 423: ; ! 424: if(q == 0) ! 425: { ! 426: q = (int *)ALLOC(caseblock); ! 427: q->tag = TCASE; ! 428: q->casexpr = p; ! 429: q->labelno = ( here ? thislab() : nextlab() ); ! 430: q->nextcase = s->loopctl; ! 431: s->loopctl = q; ! 432: } ! 433: else if(here) ! 434: if(thisexec->labelno == 0) ! 435: thisexec->labelno = q->labelno; ! 436: else if(thisexec->labelno != q->labelno) ! 437: { ! 438: exnull(); ! 439: thisexec->labelno = q->labelno; ! 440: thisexec->labused = 0; ! 441: } ! 442: if(here) ! 443: if(q->labdefined) ! 444: laberr("multiply defined case",CNULL); ! 445: else ! 446: q->labdefined = 1; ! 447: return(q->labelno); ! 448: } ! 449: ! 450: ! 451: ptr mkilab(p) ! 452: ptr p; ! 453: { ! 454: char *s, l[30]; ! 455: ! 456: if(p->tag!=TCONST || p->vtype!=TYINT) ! 457: { ! 458: execerr("invalid label",""); ! 459: s = ""; ! 460: } ! 461: else s = (char *)p->leftp; ! 462: ! 463: while(*s == '0') ! 464: ++s; ! 465: sprintf(l,"#%s", s); ! 466: ! 467: ! 468: TEST fprintf(diagfile,"numeric label = %s\n", l); ! 469: return( mkname(l) ); ! 470: } ! 471: ! 472: ! 473: ! 474: ! 475: mklabel(p,here) ! 476: ptr p; ! 477: int here; ! 478: { ! 479: register ptr q; ! 480: ! 481: if(q = p->varp) ! 482: { ! 483: if(q->tag != TLABEL) ! 484: laberr("%s is already a nonlabel\n", p->namep); ! 485: else if(q->labinacc) ! 486: warn1("label %s is inaccessible", p->namep); ! 487: else if(here) ! 488: if(q->labdefined) ! 489: laberr("%s is already defined\n", p->namep); ! 490: /* ! 491: else if(blklevel > q->blklevel) ! 492: laberr("%s is illegally placed\n",p->namep); ! 493: */ ! 494: /* dirty fixup for wm coughran */ ! 495: else { ! 496: if(blklevel > q->blklevel) ! 497: labwarn("%s is illegally placed\n",p->namep); ! 498: ! 499: q->labdefined = 1; ! 500: if(thisexec->labelno == 0) ! 501: thisexec->labelno = q->labelno; ! 502: else if(thisexec->labelno != q->labelno) ! 503: { ! 504: exnull(); ! 505: thisexec->labelno = q->labelno; ! 506: thisexec->labused = 0; ! 507: } ! 508: } ! 509: } ! 510: else { ! 511: q = (int *)ALLOC(labelblock); ! 512: p->varp = q; ! 513: q->tag = TLABEL; ! 514: q->subtype = 0; ! 515: q->blklevel = blklevel; ! 516: ++ndecl[blklevel]; ! 517: q->labdefined = here; ! 518: q->labelno = ( here ? thislab() : nextlab() ); ! 519: q->sthead = p; ! 520: } ! 521: ! 522: return(q->labelno); ! 523: } ! 524: ! 525: ! 526: thislab() ! 527: { ! 528: if(thisexec->labelno == 0) ! 529: thisexec->labelno = nextlab(); ! 530: return(thisexec->labelno); ! 531: } ! 532: ! 533: ! 534: nextlab() ! 535: { ! 536: stnos[++labno] = 0; ! 537: return( labno ); ! 538: } ! 539: ! 540: ! 541: nextindif() ! 542: { ! 543: if(++nxtindif < MAXINDIFS) ! 544: return(nxtindif); ! 545: fatal("too many indifs"); return 0; ! 546: } ! 547: ! 548: ! 549: ! 550: ! 551: mkkeywd(s, n) ! 552: char *s; ! 553: int n; ! 554: { ! 555: register ptr p; ! 556: register ptr q; ! 557: ! 558: p = (int *)name(s, 2); ! 559: q = (int *)ALLOC(keyblock); ! 560: p->tag = TKEYWORD; ! 561: q->tag = TKEYWORD; ! 562: p->subtype = n; ! 563: q->subtype = n; ! 564: p->blklevel = 0; ! 565: p->varp = q; ! 566: q->sthead = p; ! 567: } ! 568: ! 569: ! 570: ptr mkdef(s, v) ! 571: char *s, *v; ! 572: { ! 573: register ptr p; ! 574: register ptr q; ! 575: ! 576: if(p = (int *)name(s,1)) ! 577: if(p->blklevel == 0) ! 578: { ! 579: if(blklevel > 0) ! 580: hide(p); ! 581: else if(p->tag != TDEFINE) ! 582: dclerr("attempt to DEFINE a variable name", s); ! 583: else { ! 584: if( strcmp(v, ((struct defblock *)(q=p->varp))->valp) ) ! 585: { ! 586: warn("macro value replaced"); ! 587: cfree(q->valp); ! 588: q->valp = copys(v); ! 589: } ! 590: return(p); ! 591: } ! 592: } ! 593: else { ! 594: dclerr("type already defined", s); ! 595: return( errnode() ); ! 596: } ! 597: else p = (int *)name(s,0); ! 598: ! 599: q = (int *)ALLOC(defblock); ! 600: p->tag = TDEFINE; ! 601: q->tag = TDEFINE; ! 602: p->blklevel = q->blklevel = (blklevel==0 ? 0 : 1); ! 603: q->sthead = p; ! 604: p->varp = q; ! 605: ((struct defblock *)p->varp)->valp = copys(v); ! 606: return(p); ! 607: } ! 608: ! 609: ! 610: ! 611: mkknown(s,t) ! 612: char *s; ! 613: int t; ! 614: { ! 615: register ptr p; ! 616: ! 617: p = (int *)ALLOC(knownname); ! 618: p->nextfunct = knownlist; ! 619: p->tag = TKNOWNFUNCT; ! 620: knownlist = p; ! 621: p->funcname = s; ! 622: p->functype = t; ! 623: } ! 624: ! 625: ! 626: ! 627: ! 628: ! 629: ! 630: ! 631: ptr mkint(k) ! 632: int k; ! 633: { ! 634: return( mkconst(TYINT, convic(k) ) ); ! 635: } ! 636: ! 637: ! 638: ptr mkconst(t,p) ! 639: int t; ! 640: ptr p; ! 641: { ! 642: ptr q; ! 643: ! 644: q = mknode(TCONST, 0, copys(p), PNULL); ! 645: q->vtype = t; ! 646: if(t == TYCHAR) ! 647: q->vtypep = mkint( strlen(p) ); ! 648: return(q); ! 649: } ! 650: ! 651: ! 652: ! 653: ptr mkimcon(t,p) ! 654: int t; ! 655: char *p; ! 656: { ! 657: ptr q; ! 658: char *zero, buff[100]; ! 659: ! 660: zero = (t==TYCOMPLEX ? "0." : "0d0"); ! 661: sprintf(buff, "(%s,%s)", zero, p); ! 662: q = mknode(TCONST, 0, copys(buff), PNULL); ! 663: q->vtype = t; ! 664: return(q); ! 665: } ! 666: ! 667: ! 668: ! 669: ptr mkarrow(p,t) ! 670: register ptr p; ! 671: ptr t; ! 672: { ! 673: register ptr q, s; ! 674: ! 675: if(p->vsubs == 0) ! 676: if(p->vdim==0 && p->vtype!=TYCHAR && p->vtype!=TYSTRUCT) ! 677: { ! 678: exprerr("need an aggregate to the left of arrow",CNULL); ! 679: frexpr(p); ! 680: return( errnode() ); ! 681: } ! 682: else { ! 683: if(p->vdim) ! 684: { ! 685: s = 0; ! 686: for(q = ((chainp)p->vdim)->datap ; q ; q = q->nextp) ! 687: s = (int *)mkchain( mkint(1), s); ! 688: subscript(p, mknode(TLIST,0,s,PNULL) ); ! 689: } ! 690: } ! 691: ! 692: p->vtype = TYSTRUCT; ! 693: p->vtypep = t->varp; ! 694: return(p); ! 695: } ! 696: ! 697: ! 698: ! 699: ! 700: ! 701: mkequiv(p) ! 702: ptr p; ! 703: { ! 704: ptr q, t; ! 705: int first; ! 706: ! 707: swii(iefile); ! 708: putic(ICBEGIN, 0); ! 709: putic(ICINDENT, 0); ! 710: putic(ICKEYWORD, FEQUIVALENCE); ! 711: putic(ICOP, OPLPAR); ! 712: first = 1; ! 713: ! 714: for(q = p ; q ; q = q->nextp) ! 715: { ! 716: if(first) first = 0; ! 717: else putic(ICOP, OPCOMMA); ! 718: prexpr( t = simple(LVAL,q->datap) ); ! 719: frexpr(t); ! 720: } ! 721: ! 722: putic(ICOP, OPRPAR); ! 723: swii(icfile); ! 724: frchain( &p ); ! 725: } ! 726: ! 727: ! 728: ! 729: ! 730: mkgeneric(gname,atype,fname,ftype) ! 731: char *gname, *fname; ! 732: int atype, ftype; ! 733: { ! 734: register ptr p; ! 735: ptr generic(); ! 736: ! 737: if(p = generic(gname)) ! 738: { ! 739: if(p->genfname[atype]) ! 740: fatal1("generic name already defined", gname); ! 741: } ! 742: else { ! 743: p = (int *)ALLOC(genblock); ! 744: p->tag = TGENERIC; ! 745: p->nextgenf = generlist; ! 746: generlist = p; ! 747: p->genname = gname; ! 748: } ! 749: ! 750: p->genfname[atype] = fname; ! 751: p->genftype[atype] = ftype; ! 752: } ! 753: ! 754: ! 755: ptr generic(s) ! 756: char *s; ! 757: { ! 758: register ptr p; ! 759: ! 760: for(p= generlist; p ; p = p->nextgenf) ! 761: if(equals(s, p->genname)) ! 762: return(p); ! 763: return(0); ! 764: } ! 765: ! 766: ! 767: knownfunct(s) ! 768: char *s; ! 769: { ! 770: register ptr p; ! 771: ! 772: for(p = knownlist ; p ; p = p->nextfunct) ! 773: if(equals(s, p->funcname)) ! 774: return(p->functype); ! 775: return(0); ! 776: } ! 777: ! 778: ! 779: ! 780: ! 781: ! 782: ptr funcinv(p) ! 783: register ptr p; ! 784: { ! 785: ptr fp, fp1; ! 786: register ptr g; ! 787: char *s; ! 788: register int t; ! 789: int vt; ! 790: ! 791: if(g = generic(s = ((struct stentry *)((struct typeblock *)p->leftp)->sthead)->namep)) ! 792: { ! 793: if(((struct headbits *)p->rightp)->tag==TLIST && ((struct exprblock *)p->rightp)->leftp ! 794: && ( (vt = typearg(((struct exprblock *)p->rightp)->leftp)) >=0) ! 795: && (t = g->genftype[vt]) ) ! 796: { ! 797: p->leftp = builtin(t, g->genfname[vt]); ! 798: } ! 799: else { ! 800: dclerr("improper use of generic function", s); ! 801: frexpr(p); ! 802: return( errnode() ); ! 803: } ! 804: } ! 805: ! 806: fp = p->leftp; ! 807: setvproc(fp, PROCYES); ! 808: fp1 = ((struct stentry *)fp->sthead)->varp; ! 809: s = ((struct stentry *)fp->sthead)->namep; ! 810: ! 811: if(p->vtype==TYUNDEFINED && fp->vclass!=CLARG) ! 812: if(t = knownfunct(s)) ! 813: { ! 814: p->vtype = t; ! 815: setvproc(fp, PROCINTRINSIC); ! 816: setvproc(fp1, PROCINTRINSIC); ! 817: fp1->vtype = t; ! 818: builtin(t,((struct stentry *)fp1->sthead)->namep); ! 819: cpblock(fp1, fp, sizeof(struct exprblock)); ! 820: } ! 821: ! 822: dclit(p); ! 823: return(p); ! 824: } ! 825: ! 826: ! 827: ! 828: ! 829: typearg(p0) ! 830: register chainp p0; ! 831: { ! 832: register chainp p; ! 833: register int vt, maxt; ! 834: ! 835: if(p0 == NULL) ! 836: return(-1); ! 837: maxt = ((struct exprblock *)p0->datap)->vtype; ! 838: ! 839: for(p = (chainp)p0->nextp ; p ; p = (chainp)p->nextp) ! 840: if( (vt = ((struct exprblock *)p->datap)->vtype) > maxt) ! 841: maxt = vt; ! 842: ! 843: for(p = p0 ; p ; p = (chainp)p->nextp) ! 844: p->datap = coerce(maxt, p->datap); ! 845: ! 846: return(maxt); ! 847: } ! 848: ! 849: ! 850: ! 851: ! 852: ptr typexpr(t,e) ! 853: register ptr t, e; ! 854: { ! 855: ptr e1; ! 856: int etag; ! 857: ! 858: if(t->atdim!=0 || (e->tag==TLIST && t->attype!=TYCOMPLEX) ) ! 859: goto typerr; ! 860: ! 861: switch(t->attype) ! 862: { ! 863: case TYCOMPLEX: ! 864: if(e->tag==TLIST) ! 865: if(e->leftp==0 || ((chainp)e->leftp)->nextp==0 ! 866: || ((chainp)((chainp)e->leftp)->nextp)->nextp!=0) ! 867: { ! 868: exprerr("bad conversion to complex", ""); ! 869: return( errnode() ); ! 870: } ! 871: else { ! 872: ((chainp)e->leftp)->datap = simple(RVAL, ! 873: ((chainp)e->leftp)->datap); ! 874: ((chainp)((chainp)e->leftp)->nextp)->datap = simple(RVAL, ! 875: ((chainp)((chainp)e->leftp)->nextp)->datap); ! 876: if(isconst(((chainp)e->leftp)->datap) && ! 877: isconst(((chainp)((chainp)e->leftp)->nextp)->datap) ) ! 878: return( compconst(e) ); ! 879: e1 = mkcall(builtin(TYCOMPLEX,"cmplx"), ! 880: arg2( coerce(TYREAL,((chainp)e->leftp)->datap), ! 881: coerce(TYREAL,((chainp)((chainp)e->leftp)->nextp)->datap))); ! 882: frchain( &(e->leftp) ); ! 883: frexpblock(e); ! 884: return(e1); ! 885: } ! 886: ! 887: case TYINT: ! 888: case TYREAL: ! 889: case TYLREAL: ! 890: case TYLOG: ! 891: case TYFIELD: ! 892: e = coerce(t->attype, simple(RVAL, e) ); ! 893: etag = e->tag; ! 894: if(etag==TAROP || etag==TLOGOP || etag==TRELOP) ! 895: e->needpar = YES; ! 896: return(e); ! 897: ! 898: case TYCHAR: ! 899: case TYSTRUCT: ! 900: goto typerr; ! 901: } ! 902: ! 903: typerr: ! 904: exprerr("typexpr not fully implemented", ""); ! 905: frexpr(e); ! 906: return( errnode() ); ! 907: } ! 908: ! 909: ! 910: ! 911: ! 912: ptr compconst(p) ! 913: register ptr p; ! 914: { ! 915: register ptr a, b; ! 916: int as, bs; ! 917: int prec; ! 918: ! 919: prec = TYREAL; ! 920: p = p->leftp; ! 921: if(p == 0) ! 922: goto err; ! 923: if(((struct exprblock *)p->datap)->vtype == TYLREAL) ! 924: prec = TYLREAL; ! 925: a = coerce(TYLREAL, p->datap); ! 926: p = p->nextp; ! 927: if(p->nextp) ! 928: goto err; ! 929: if(((struct exprblock *)p->datap)->vtype == TYLREAL) ! 930: a = coerce(prec = TYLREAL,a); ! 931: b = coerce(TYLREAL, p->datap); ! 932: ! 933: if(a->tag==TNEGOP) ! 934: { ! 935: as = '-'; ! 936: a = a->leftp; ! 937: } ! 938: else as = ' '; ! 939: ! 940: if(b->tag==TNEGOP) ! 941: { ! 942: bs = '-'; ! 943: b = b->leftp; ! 944: } ! 945: else bs = ' '; ! 946: ! 947: if(a->tag!=TCONST || a->vtype!=prec || ! 948: b->tag!=TCONST || b->vtype!=prec ) ! 949: goto err; ! 950: ! 951: if(prec==TYLREAL && tailor.lngcxtype==NULL) ! 952: { ! 953: ptr q, e1, e2; ! 954: struct dimblock *dp; ! 955: sprintf(msg, "_const%d", ++constno); ! 956: q = mkvar(mkname(msg)); ! 957: q->vtype = TYLREAL; ! 958: dclit(q); ! 959: dp = ALLOC(dimblock); ! 960: dp->upperb = mkint(2); ! 961: q->vdim = (int *)mkchain(dp,CHNULL); ! 962: sprintf(msg, "%c%s", as, a->leftp); ! 963: e1 = mkconst(TYLREAL, msg); ! 964: sprintf(msg, "%c%s", bs, b->leftp); ! 965: e2 = mkconst(TYLREAL, msg); ! 966: mkinit(q, mknode(TLIST,0, mkchain(e1,mkchain(e2,CHNULL)),PNULL) ); ! 967: cfree(q->vdim); ! 968: q->vtype = TYLCOMPLEX; ! 969: return(q); ! 970: } ! 971: else ! 972: { ! 973: sprintf(msg, "(%c%s, %c%s)", as, a->leftp, bs, b->leftp); ! 974: return( mkconst(TYCOMPLEX, msg) ); ! 975: } ! 976: ! 977: err: exprerr("invalid complex constant", ""); ! 978: return( errnode() ); ! 979: } ! 980: ! 981: ! 982: ! 983: ! 984: ptr mkchcon(p) ! 985: char *p; ! 986: { ! 987: register ptr q; ! 988: char buf[10]; ! 989: ! 990: sprintf(buf, "_const%d", ++constno); ! 991: q = mkvar(mkname(buf)); ! 992: q->vtype = TYCHAR; ! 993: q->vtypep = mkint(strlen(p)); ! 994: mkinit(q, mkconst(TYCHAR, p)); ! 995: return(q); ! 996: } ! 997: ! 998: ! 999: ! 1000: ptr mksub1() ! 1001: { ! 1002: return( mknode(TLIST,0, mkchain(mkint(1),CHNULL), PNULL) ); ! 1003: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.