![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to putpcc.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / f2c|
Return to putpcc.c CVS log | Up to [Research Unix] / researchv10no / cmd / f2c |
1.1 ! root 1: /**************************************************************** ! 2: Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore. ! 3: ! 4: Permission to use, copy, modify, and distribute this software ! 5: and its documentation for any purpose and without fee is hereby ! 6: granted, provided that the above copyright notice appear in all ! 7: copies and that both that the copyright notice and this ! 8: permission notice and warranty disclaimer appear in supporting ! 9: documentation, and that the names of AT&T Bell Laboratories or ! 10: Bellcore or any of their entities not be used in advertising or ! 11: publicity pertaining to distribution of the software without ! 12: specific, written prior permission. ! 13: ! 14: AT&T and Bellcore disclaim all warranties with regard to this ! 15: software, including all implied warranties of merchantability ! 16: and fitness. In no event shall AT&T or Bellcore be liable for ! 17: any special, indirect or consequential damages or any damages ! 18: whatsoever resulting from loss of use, data or profits, whether ! 19: in an action of contract, negligence or other tortious action, ! 20: arising out of or in connection with the use or performance of ! 21: this software. ! 22: ****************************************************************/ ! 23: ! 24: /* INTERMEDIATE CODE GENERATION FOR S. C. JOHNSON C COMPILERS */ ! 25: /* NEW VERSION USING BINARY POLISH POSTFIX INTERMEDIATE */ ! 26: ! 27: #include "defs.h" ! 28: #include "pccdefs.h" ! 29: #include "output.h" /* for nice_printf */ ! 30: #include "names.h" ! 31: #include "p1defs.h" ! 32: ! 33: Addrp realpart(); ! 34: LOCAL Addrp intdouble(), putcx1(), putcxeq (), putch1 (); ! 35: LOCAL putct1 (); ! 36: ! 37: expptr putcxop(); ! 38: LOCAL expptr putcall (), putmnmx (), putcheq(), putcat (); ! 39: LOCAL expptr putaddr(), putchcmp (), putpower(), putop(); ! 40: LOCAL expptr putcxcmp (); ! 41: expptr imagpart(); ! 42: ftnint lencat(); ! 43: ! 44: #define FOUR 4 ! 45: extern int ops2[]; ! 46: extern int proc_argchanges, proc_protochanges; ! 47: extern int krparens; ! 48: ! 49: #define P2BUFFMAX 128 ! 50: ! 51: /* Puthead -- output the header information about subroutines, functions ! 52: and entry points */ ! 53: ! 54: puthead(s, class) ! 55: char *s; ! 56: int class; ! 57: { ! 58: if (headerdone == NO) { ! 59: if (class == CLMAIN) ! 60: s = "MAIN__"; ! 61: p1_head (class, s); ! 62: headerdone = YES; ! 63: } ! 64: } ! 65: ! 66: putif(p, else_if_p) ! 67: register expptr p; ! 68: int else_if_p; ! 69: { ! 70: register int k; ! 71: int n; ! 72: long where; ! 73: ! 74: if (else_if_p) { ! 75: p1put(P1_ELSEIFSTART); ! 76: where = ftell(pass1_file); ! 77: } ! 78: if( !ISLOGICAL((k = (p = fixtype(p))->headblock.vtype )) ) ! 79: { ! 80: if(k != TYERROR) ! 81: err("non-logical expression in IF statement"); ! 82: } ! 83: else { ! 84: if (else_if_p) { ! 85: if (ei_next >= ei_last) ! 86: { ! 87: k = ei_last - ei_first; ! 88: n = k + 100; ! 89: ei_next = mem(n,0); ! 90: ei_last = ei_first + n; ! 91: if (k) ! 92: memcpy(ei_next, ei_first, k); ! 93: ei_first = ei_next; ! 94: ei_next += k; ! 95: ei_last = ei_first + n; ! 96: } ! 97: p = putx(p); ! 98: if (*ei_next++ = ftell(pass1_file) > where) { ! 99: p1_if(p); ! 100: new_endif(); ! 101: } ! 102: else ! 103: p1_elif(p); ! 104: } ! 105: else { ! 106: p = putx(p); ! 107: p1_if(p); ! 108: } ! 109: } ! 110: } ! 111: ! 112: ! 113: putout(p) ! 114: expptr p; ! 115: { ! 116: p1_expr (p); ! 117: ! 118: /* Used to make temporaries in holdtemps available here, but they */ ! 119: /* may be reused too soon (e.g. when multiple **'s are involved). */ ! 120: } ! 121: ! 122: ! 123: ! 124: putcmgo(index, nlab, labs) ! 125: expptr index; ! 126: int nlab; ! 127: struct Labelblock *labs[]; ! 128: { ! 129: if(! ISINT(index->headblock.vtype) ) ! 130: { ! 131: execerr("computed goto index must be integer", CNULL); ! 132: return; ! 133: } ! 134: ! 135: p1comp_goto (index, nlab, labs); ! 136: } ! 137: ! 138: static expptr ! 139: krput(p) ! 140: register expptr p; ! 141: { ! 142: register expptr e, e1; ! 143: register unsigned op; ! 144: int t = krparens == 2 ? TYDREAL : p->exprblock.vtype; ! 145: ! 146: op = p->exprblock.opcode; ! 147: e = p->exprblock.leftp; ! 148: if (e->tag == TEXPR && e->exprblock.opcode == op) { ! 149: e1 = (expptr)mktmp(t, ENULL); ! 150: putout(putassign(cpexpr(e1), e)); ! 151: p->exprblock.leftp = e1; ! 152: } ! 153: else ! 154: p->exprblock.leftp = putx(e); ! 155: ! 156: e = p->exprblock.rightp; ! 157: if (e->tag == TEXPR && e->exprblock.opcode == op) { ! 158: e1 = (expptr)mktmp(t, ENULL); ! 159: putout(putassign(cpexpr(e1), e)); ! 160: p->exprblock.rightp = e1; ! 161: } ! 162: else ! 163: p->exprblock.rightp = putx(e); ! 164: return p; ! 165: } ! 166: ! 167: expptr putx(p) ! 168: register expptr p; ! 169: { ! 170: int opc; ! 171: int k; ! 172: ! 173: if (p) ! 174: switch(p->tag) ! 175: { ! 176: case TERROR: ! 177: break; ! 178: ! 179: case TCONST: ! 180: switch(p->constblock.vtype) ! 181: { ! 182: case TYLOGICAL1: ! 183: case TYLOGICAL2: ! 184: case TYLOGICAL: ! 185: #ifdef TYQUAD ! 186: case TYQUAD: ! 187: #endif ! 188: case TYLONG: ! 189: case TYSHORT: ! 190: case TYINT1: ! 191: break; ! 192: ! 193: case TYADDR: ! 194: break; ! 195: case TYREAL: ! 196: case TYDREAL: ! 197: ! 198: /* Don't write it out to the p2 file, since you'd need to call putconst, ! 199: which is just what we need to avoid in the translator */ ! 200: ! 201: break; ! 202: default: ! 203: p = putx( (expptr)putconst((Constp)p) ); ! 204: break; ! 205: } ! 206: break; ! 207: ! 208: case TEXPR: ! 209: switch(opc = p->exprblock.opcode) ! 210: { ! 211: case OPCALL: ! 212: case OPCCALL: ! 213: if( ISCOMPLEX(p->exprblock.vtype) ) ! 214: p = putcxop(p); ! 215: else p = putcall(p, (Addrp *)NULL); ! 216: break; ! 217: ! 218: case OPMIN: ! 219: case OPMAX: ! 220: p = putmnmx(p); ! 221: break; ! 222: ! 223: ! 224: case OPASSIGN: ! 225: if(ISCOMPLEX(p->exprblock.leftp->headblock.vtype) ! 226: || ISCOMPLEX(p->exprblock.rightp->headblock.vtype)) { ! 227: (void) putcxeq(p); ! 228: p = ENULL; ! 229: } else if( ISCHAR(p) ) ! 230: p = putcheq(p); ! 231: else ! 232: goto putopp; ! 233: break; ! 234: ! 235: case OPEQ: ! 236: case OPNE: ! 237: if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) || ! 238: ISCOMPLEX(p->exprblock.rightp->headblock.vtype) ) ! 239: { ! 240: p = putcxcmp(p); ! 241: break; ! 242: } ! 243: case OPLT: ! 244: case OPLE: ! 245: case OPGT: ! 246: case OPGE: ! 247: if(ISCHAR(p->exprblock.leftp)) ! 248: { ! 249: p = putchcmp(p); ! 250: break; ! 251: } ! 252: goto putopp; ! 253: ! 254: case OPPOWER: ! 255: p = putpower(p); ! 256: break; ! 257: ! 258: case OPSTAR: ! 259: /* m * (2**k) -> m<<k */ ! 260: if(INT(p->exprblock.leftp->headblock.vtype) && ! 261: ISICON(p->exprblock.rightp) && ! 262: ( (k = log_2(p->exprblock.rightp->constblock.Const.ci))>0) ) ! 263: { ! 264: p->exprblock.opcode = OPLSHIFT; ! 265: frexpr(p->exprblock.rightp); ! 266: p->exprblock.rightp = ICON(k); ! 267: goto putopp; ! 268: } ! 269: if (krparens && ISREAL(p->exprblock.vtype)) ! 270: return krput(p); ! 271: ! 272: case OPMOD: ! 273: goto putopp; ! 274: case OPPLUS: ! 275: if (krparens && ISREAL(p->exprblock.vtype)) ! 276: return krput(p); ! 277: case OPMINUS: ! 278: case OPSLASH: ! 279: case OPNEG: ! 280: case OPNEG1: ! 281: case OPABS: ! 282: case OPDABS: ! 283: if( ISCOMPLEX(p->exprblock.vtype) ) ! 284: p = putcxop(p); ! 285: else goto putopp; ! 286: break; ! 287: ! 288: case OPCONV: ! 289: if( ISCOMPLEX(p->exprblock.vtype) ) ! 290: p = putcxop(p); ! 291: else if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) ) ! 292: { ! 293: p = putx( mkconv(p->exprblock.vtype, ! 294: (expptr)realpart(putcx1(p->exprblock.leftp)))); ! 295: } ! 296: else goto putopp; ! 297: break; ! 298: ! 299: case OPNOT: ! 300: case OPOR: ! 301: case OPAND: ! 302: case OPEQV: ! 303: case OPNEQV: ! 304: case OPADDR: ! 305: case OPPLUSEQ: ! 306: case OPSTAREQ: ! 307: case OPCOMMA: ! 308: case OPQUEST: ! 309: case OPCOLON: ! 310: case OPBITOR: ! 311: case OPBITAND: ! 312: case OPBITXOR: ! 313: case OPBITNOT: ! 314: case OPLSHIFT: ! 315: case OPRSHIFT: ! 316: case OPASSIGNI: ! 317: case OPIDENTITY: ! 318: case OPCHARCAST: ! 319: case OPMIN2: ! 320: case OPMAX2: ! 321: case OPDMIN: ! 322: case OPDMAX: ! 323: putopp: ! 324: p = putop(p); ! 325: break; ! 326: ! 327: case OPCONCAT: ! 328: /* weird things like ichar(a//a) */ ! 329: p = (expptr)putch1(p); ! 330: break; ! 331: ! 332: default: ! 333: badop("putx", opc); ! 334: p = errnode (); ! 335: } ! 336: break; ! 337: ! 338: case TADDR: ! 339: p = putaddr(p); ! 340: break; ! 341: ! 342: default: ! 343: badtag("putx", p->tag); ! 344: p = errnode (); ! 345: } ! 346: ! 347: return p; ! 348: } ! 349: ! 350: ! 351: ! 352: LOCAL expptr putop(p) ! 353: expptr p; ! 354: { ! 355: expptr lp, tp; ! 356: int pt, lt, lt1; ! 357: int comma; ! 358: ! 359: switch(p->exprblock.opcode) /* check for special cases and rewrite */ ! 360: { ! 361: case OPCONV: ! 362: pt = p->exprblock.vtype; ! 363: lp = p->exprblock.leftp; ! 364: lt = lp->headblock.vtype; ! 365: ! 366: /* Simplify nested type casts */ ! 367: ! 368: while(p->tag==TEXPR && p->exprblock.opcode==OPCONV && ! 369: ( (ISREAL(pt)&&ONEOF(lt,MSKREAL|MSKCOMPLEX)) || ! 370: (INT(pt)&&(ONEOF(lt,MSKINT|MSKADDR|MSKCHAR|M(TYSUBR)))) )) ! 371: { ! 372: if(pt==TYDREAL && lt==TYREAL) ! 373: { ! 374: if(lp->tag==TEXPR ! 375: && lp->exprblock.opcode == OPCONV) { ! 376: lt1 = lp->exprblock.leftp->headblock.vtype; ! 377: if (lt1 == TYDREAL) { ! 378: lp->exprblock.leftp = ! 379: putx(lp->exprblock.leftp); ! 380: return p; ! 381: } ! 382: if (lt1 == TYDCOMPLEX) { ! 383: lp->exprblock.leftp = putx( ! 384: (expptr)realpart( ! 385: putcx1(lp->exprblock.leftp))); ! 386: return p; ! 387: } ! 388: } ! 389: break; ! 390: } ! 391: else if (ISREAL(pt) && ISCOMPLEX(lt)) { ! 392: p->exprblock.leftp = putx(mkconv(pt, ! 393: (expptr)realpart( ! 394: putcx1(p->exprblock.leftp)))); ! 395: break; ! 396: } ! 397: if(lt==TYCHAR && lp->tag==TEXPR && ! 398: lp->exprblock.opcode==OPCALL) ! 399: { ! 400: ! 401: /* May want to make a comma expression here instead. I had one, but took ! 402: it out for my convenience, not for the convenience of the end user */ ! 403: ! 404: putout (putcall (lp, (Addrp *) &(p -> ! 405: exprblock.leftp))); ! 406: return putop (p); ! 407: } ! 408: if (lt == TYCHAR) { ! 409: p->exprblock.leftp = putx(p->exprblock.leftp); ! 410: return p; ! 411: } ! 412: frexpr(p->exprblock.vleng); ! 413: free( (charptr) p ); ! 414: p = lp; ! 415: if (p->tag != TEXPR) ! 416: goto retputx; ! 417: pt = lt; ! 418: lp = p->exprblock.leftp; ! 419: lt = lp->headblock.vtype; ! 420: } /* while */ ! 421: if(p->tag==TEXPR && p->exprblock.opcode==OPCONV) ! 422: break; ! 423: retputx: ! 424: return putx(p); ! 425: ! 426: case OPADDR: ! 427: comma = NO; ! 428: lp = p->exprblock.leftp; ! 429: free( (charptr) p ); ! 430: if(lp->tag != TADDR) ! 431: { ! 432: tp = (expptr) ! 433: mktmp(lp->headblock.vtype,lp->headblock.vleng); ! 434: p = putx( mkexpr(OPASSIGN, cpexpr(tp), lp) ); ! 435: lp = tp; ! 436: comma = YES; ! 437: } ! 438: if(comma) ! 439: p = mkexpr(OPCOMMA, p, putaddr(lp)); ! 440: else ! 441: p = (expptr)putaddr(lp); ! 442: return p; ! 443: ! 444: case OPASSIGN: ! 445: case OPASSIGNI: ! 446: case OPLT: ! 447: case OPLE: ! 448: case OPGT: ! 449: case OPGE: ! 450: case OPEQ: ! 451: case OPNE: ! 452: ; ! 453: } ! 454: ! 455: if( ops2[p->exprblock.opcode] <= 0) ! 456: badop("putop", p->exprblock.opcode); ! 457: p -> exprblock.leftp = putx (p -> exprblock.leftp); ! 458: if (p -> exprblock.rightp) ! 459: p -> exprblock.rightp = putx (p -> exprblock.rightp); ! 460: return p; ! 461: } ! 462: ! 463: LOCAL expptr putpower(p) ! 464: expptr p; ! 465: { ! 466: expptr base; ! 467: Addrp t1, t2; ! 468: ftnint k; ! 469: int type; ! 470: char buf[80]; /* buffer for text of comment */ ! 471: ! 472: if(!ISICON(p->exprblock.rightp) || ! 473: (k = p->exprblock.rightp->constblock.Const.ci)<2) ! 474: Fatal("putpower: bad call"); ! 475: base = p->exprblock.leftp; ! 476: type = base->headblock.vtype; ! 477: t1 = mktmp(type, ENULL); ! 478: t2 = NULL; ! 479: ! 480: free ((charptr) p); ! 481: p = putassign (cpexpr((expptr) t1), base); ! 482: ! 483: sprintf (buf, "Computing %ld%s power", k, ! 484: k == 2 ? "nd" : k == 3 ? "rd" : "th"); ! 485: p1_comment (buf); ! 486: ! 487: for( ; (k&1)==0 && k>2 ; k>>=1 ) ! 488: { ! 489: p = mkexpr (OPCOMMA, p, putsteq(t1, t1)); ! 490: } ! 491: ! 492: if(k == 2) { ! 493: ! 494: /* Write the power computation out immediately */ ! 495: putout (p); ! 496: p = putx( mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1))); ! 497: } else { ! 498: t2 = mktmp(type, ENULL); ! 499: p = mkexpr (OPCOMMA, p, putassign(cpexpr((expptr)t2), ! 500: cpexpr((expptr)t1))); ! 501: ! 502: for(k>>=1 ; k>1 ; k>>=1) ! 503: { ! 504: p = mkexpr (OPCOMMA, p, putsteq(t1, t1)); ! 505: if(k & 1) ! 506: { ! 507: p = mkexpr (OPCOMMA, p, putsteq(t2, t1)); ! 508: } ! 509: } ! 510: /* Write the power computation out immediately */ ! 511: putout (p); ! 512: p = putx( mkexpr(OPSTAR, cpexpr((expptr)t2), ! 513: mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1)))); ! 514: } ! 515: frexpr((expptr)t1); ! 516: if(t2) ! 517: frexpr((expptr)t2); ! 518: return p; ! 519: } ! 520: ! 521: ! 522: ! 523: ! 524: LOCAL Addrp intdouble(p) ! 525: Addrp p; ! 526: { ! 527: register Addrp t; ! 528: ! 529: t = mktmp(TYDREAL, ENULL); ! 530: putout (putassign(cpexpr((expptr)t), (expptr)p)); ! 531: return(t); ! 532: } ! 533: ! 534: ! 535: ! 536: ! 537: ! 538: /* Complex-type variable assignment */ ! 539: ! 540: LOCAL Addrp putcxeq(p) ! 541: register expptr p; ! 542: { ! 543: register Addrp lp, rp; ! 544: expptr code; ! 545: ! 546: if(p->tag != TEXPR) ! 547: badtag("putcxeq", p->tag); ! 548: ! 549: lp = putcx1(p->exprblock.leftp); ! 550: rp = putcx1(p->exprblock.rightp); ! 551: code = putassign ( (expptr)realpart(lp), (expptr)realpart(rp)); ! 552: ! 553: if( ISCOMPLEX(p->exprblock.vtype) ) ! 554: { ! 555: code = mkexpr (OPCOMMA, code, putassign ! 556: (imagpart(lp), imagpart(rp))); ! 557: } ! 558: putout (code); ! 559: frexpr((expptr)rp); ! 560: free ((charptr) p); ! 561: return lp; ! 562: } ! 563: ! 564: ! 565: ! 566: /* putcxop -- used to write out embedded calls to complex functions, and ! 567: complex arguments to procedures */ ! 568: ! 569: expptr putcxop(p) ! 570: expptr p; ! 571: { ! 572: return (expptr)putaddr((expptr)putcx1(p)); ! 573: } ! 574: ! 575: #define PAIR(x,y) mkexpr (OPCOMMA, (x), (y)) ! 576: ! 577: LOCAL Addrp putcx1(p) ! 578: register expptr p; ! 579: { ! 580: expptr q; ! 581: Addrp lp, rp; ! 582: register Addrp resp; ! 583: int opcode; ! 584: int ltype, rtype; ! 585: long ts, tskludge; ! 586: expptr mkrealcon(); ! 587: ! 588: if(p == NULL) ! 589: return(NULL); ! 590: ! 591: switch(p->tag) ! 592: { ! 593: case TCONST: ! 594: if( ISCOMPLEX(p->constblock.vtype) ) ! 595: p = (expptr) putconst((Constp)p); ! 596: return( (Addrp) p ); ! 597: ! 598: case TADDR: ! 599: resp = &p->addrblock; ! 600: if (addressable(p)) ! 601: return (Addrp) p; ! 602: ts = tskludge = 0; ! 603: if (q = resp->memoffset) { ! 604: if (resp->uname_tag == UNAM_REF) { ! 605: q = cpexpr((tagptr)resp); ! 606: q->addrblock.vtype = tyint; ! 607: q->addrblock.cmplx_sub = 1; ! 608: p->addrblock.skip_offset = 1; ! 609: resp->user.name->vsubscrused = 1; ! 610: resp->uname_tag = UNAM_NAME; ! 611: tskludge = typesize[resp->vtype] ! 612: * (resp->Field ? 2 : 1); ! 613: } ! 614: else if (resp->isarray ! 615: && resp->vtype != TYCHAR) { ! 616: if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV)) ! 617: && resp->uname_tag == UNAM_NAME) ! 618: q = mkexpr(OPMINUS, q, ! 619: mkintcon(resp->user.name->voffset)); ! 620: ts = typesize[resp->vtype] ! 621: * (resp->Field ? 2 : 1); ! 622: q = resp->memoffset = mkexpr(OPSLASH, q, ! 623: ICON(ts)); ! 624: } ! 625: } ! 626: resp = mktmp(tyint, ENULL); ! 627: putout(putassign(cpexpr((expptr)resp), q)); ! 628: p->addrblock.memoffset = tskludge ! 629: ? mkexpr(OPSTAR, resp, ICON(tskludge)) ! 630: : (expptr)resp; ! 631: if (ts) { ! 632: resp = &p->addrblock; ! 633: q = mkexpr(OPSTAR, resp->memoffset, ICON(ts)); ! 634: if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV)) ! 635: && resp->uname_tag == UNAM_NAME) ! 636: q = mkexpr(OPPLUS, q, ! 637: mkintcon(resp->user.name->voffset)); ! 638: resp->memoffset = q; ! 639: } ! 640: return (Addrp) p; ! 641: ! 642: case TEXPR: ! 643: if( ISCOMPLEX(p->exprblock.vtype) ) ! 644: break; ! 645: resp = mktmp(TYDREAL, ENULL); ! 646: putout (putassign( cpexpr((expptr)resp), p)); ! 647: return(resp); ! 648: ! 649: default: ! 650: badtag("putcx1", p->tag); ! 651: } ! 652: ! 653: opcode = p->exprblock.opcode; ! 654: if(opcode==OPCALL || opcode==OPCCALL) ! 655: { ! 656: Addrp t; ! 657: p = putcall(p, &t); ! 658: putout(p); ! 659: return t; ! 660: } ! 661: else if(opcode == OPASSIGN) ! 662: { ! 663: return putcxeq (p); ! 664: } ! 665: ! 666: /* BUG (inefficient) Generates too many temporary variables */ ! 667: ! 668: resp = mktmp(p->exprblock.vtype, ENULL); ! 669: if(lp = putcx1(p->exprblock.leftp) ) ! 670: ltype = lp->vtype; ! 671: if(rp = putcx1(p->exprblock.rightp) ) ! 672: rtype = rp->vtype; ! 673: ! 674: switch(opcode) ! 675: { ! 676: case OPCOMMA: ! 677: frexpr((expptr)resp); ! 678: resp = rp; ! 679: rp = NULL; ! 680: break; ! 681: ! 682: case OPNEG: ! 683: case OPNEG1: ! 684: putout (PAIR ( ! 685: putassign( (expptr)realpart(resp), ! 686: mkexpr(OPNEG, (expptr)realpart(lp), ENULL)), ! 687: putassign( imagpart(resp), ! 688: mkexpr(OPNEG, imagpart(lp), ENULL)))); ! 689: break; ! 690: ! 691: case OPPLUS: ! 692: case OPMINUS: { expptr r; ! 693: r = putassign( (expptr)realpart(resp), ! 694: mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp) )); ! 695: if(rtype < TYCOMPLEX) ! 696: q = putassign( imagpart(resp), imagpart(lp) ); ! 697: else if(ltype < TYCOMPLEX) ! 698: { ! 699: if(opcode == OPPLUS) ! 700: q = putassign( imagpart(resp), imagpart(rp) ); ! 701: else ! 702: q = putassign( imagpart(resp), ! 703: mkexpr(OPNEG, imagpart(rp), ENULL) ); ! 704: } ! 705: else ! 706: q = putassign( imagpart(resp), ! 707: mkexpr(opcode, imagpart(lp), imagpart(rp) )); ! 708: r = PAIR (r, q); ! 709: putout (r); ! 710: break; ! 711: } /* case OPPLUS, OPMINUS: */ ! 712: case OPSTAR: ! 713: if(ltype < TYCOMPLEX) ! 714: { ! 715: if( ISINT(ltype) ) ! 716: lp = intdouble(lp); ! 717: putout (PAIR ( ! 718: putassign( (expptr)realpart(resp), ! 719: mkexpr(OPSTAR, cpexpr((expptr)lp), ! 720: (expptr)realpart(rp))), ! 721: putassign( imagpart(resp), ! 722: mkexpr(OPSTAR, cpexpr((expptr)lp), imagpart(rp))))); ! 723: } ! 724: else if(rtype < TYCOMPLEX) ! 725: { ! 726: if( ISINT(rtype) ) ! 727: rp = intdouble(rp); ! 728: putout (PAIR ( ! 729: putassign( (expptr)realpart(resp), ! 730: mkexpr(OPSTAR, cpexpr((expptr)rp), ! 731: (expptr)realpart(lp))), ! 732: putassign( imagpart(resp), ! 733: mkexpr(OPSTAR, cpexpr((expptr)rp), imagpart(lp))))); ! 734: } ! 735: else { ! 736: putout (PAIR ( ! 737: putassign( (expptr)realpart(resp), mkexpr(OPMINUS, ! 738: mkexpr(OPSTAR, (expptr)realpart(lp), ! 739: (expptr)realpart(rp)), ! 740: mkexpr(OPSTAR, imagpart(lp), imagpart(rp)))), ! 741: putassign( imagpart(resp), mkexpr(OPPLUS, ! 742: mkexpr(OPSTAR, (expptr)realpart(lp), imagpart(rp)), ! 743: mkexpr(OPSTAR, imagpart(lp), ! 744: (expptr)realpart(rp)))))); ! 745: } ! 746: break; ! 747: ! 748: case OPSLASH: ! 749: /* fixexpr has already replaced all divisions ! 750: * by a complex by a function call ! 751: */ ! 752: if( ISINT(rtype) ) ! 753: rp = intdouble(rp); ! 754: putout (PAIR ( ! 755: putassign( (expptr)realpart(resp), ! 756: mkexpr(OPSLASH, (expptr)realpart(lp), cpexpr((expptr)rp))), ! 757: putassign( imagpart(resp), ! 758: mkexpr(OPSLASH, imagpart(lp), cpexpr((expptr)rp))))); ! 759: break; ! 760: ! 761: case OPCONV: ! 762: if( ISCOMPLEX(lp->vtype) ) ! 763: q = imagpart(lp); ! 764: else if(rp != NULL) ! 765: q = (expptr) realpart(rp); ! 766: else ! 767: q = mkrealcon(TYDREAL, "0"); ! 768: putout (PAIR ( ! 769: putassign( (expptr)realpart(resp), (expptr)realpart(lp)), ! 770: putassign( imagpart(resp), q))); ! 771: break; ! 772: ! 773: default: ! 774: badop("putcx1", opcode); ! 775: } ! 776: ! 777: frexpr((expptr)lp); ! 778: frexpr((expptr)rp); ! 779: free( (charptr) p ); ! 780: return(resp); ! 781: } ! 782: ! 783: ! 784: ! 785: ! 786: /* Only .EQ. and .NE. may be performed on COMPLEX data, other relations ! 787: are not defined */ ! 788: ! 789: LOCAL expptr putcxcmp(p) ! 790: register expptr p; ! 791: { ! 792: int opcode; ! 793: register Addrp lp, rp; ! 794: expptr q; ! 795: ! 796: if(p->tag != TEXPR) ! 797: badtag("putcxcmp", p->tag); ! 798: ! 799: opcode = p->exprblock.opcode; ! 800: lp = putcx1(p->exprblock.leftp); ! 801: rp = putcx1(p->exprblock.rightp); ! 802: ! 803: q = mkexpr( opcode==OPEQ ? OPAND : OPOR , ! 804: mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp)), ! 805: mkexpr(opcode, imagpart(lp), imagpart(rp)) ); ! 806: ! 807: free( (charptr) lp); ! 808: free( (charptr) rp); ! 809: free( (charptr) p ); ! 810: return putx( fixexpr((Exprp)q) ); ! 811: } ! 812: ! 813: /* putch1 -- Forces constants into the literal pool, among other things */ ! 814: ! 815: LOCAL Addrp putch1(p) ! 816: register expptr p; ! 817: { ! 818: Addrp t; ! 819: expptr e; ! 820: ! 821: switch(p->tag) ! 822: { ! 823: case TCONST: ! 824: return( putconst((Constp)p) ); ! 825: ! 826: case TADDR: ! 827: return( (Addrp) p ); ! 828: ! 829: case TEXPR: ! 830: switch(p->exprblock.opcode) ! 831: { ! 832: expptr q; ! 833: ! 834: case OPCALL: ! 835: case OPCCALL: ! 836: ! 837: p = putcall(p, &t); ! 838: putout (p); ! 839: break; ! 840: ! 841: case OPCONCAT: ! 842: t = mktmp(TYCHAR, ICON(lencat(p))); ! 843: q = (expptr) cpexpr(p->headblock.vleng); ! 844: p = putcat( cpexpr((expptr)t), p ); ! 845: /* put the correct length on the block */ ! 846: frexpr(t->vleng); ! 847: t->vleng = q; ! 848: putout (p); ! 849: break; ! 850: ! 851: case OPCONV: ! 852: if(!ISICON(p->exprblock.vleng) ! 853: || p->exprblock.vleng->constblock.Const.ci!=1 ! 854: || ! INT(p->exprblock.leftp->headblock.vtype) ) ! 855: Fatal("putch1: bad character conversion"); ! 856: t = mktmp(TYCHAR, ICON(1)); ! 857: e = mkexpr(OPCONV, (expptr)t, ENULL); ! 858: e->headblock.vtype = TYCHAR; ! 859: p = putop( mkexpr(OPASSIGN, cpexpr(e), p)); ! 860: putout (p); ! 861: break; ! 862: default: ! 863: badop("putch1", p->exprblock.opcode); ! 864: } ! 865: return(t); ! 866: ! 867: default: ! 868: badtag("putch1", p->tag); ! 869: } ! 870: /* NOT REACHED */ return 0; ! 871: } ! 872: ! 873: ! 874: /* putchop -- Write out a character actual parameter; that is, this is ! 875: part of a procedure invocation */ ! 876: ! 877: Addrp putchop(p) ! 878: expptr p; ! 879: { ! 880: p = putaddr((expptr)putch1(p)); ! 881: return (Addrp)p; ! 882: } ! 883: ! 884: ! 885: ! 886: ! 887: LOCAL expptr putcheq(p) ! 888: register expptr p; ! 889: { ! 890: expptr lp, rp; ! 891: int nbad; ! 892: ! 893: if(p->tag != TEXPR) ! 894: badtag("putcheq", p->tag); ! 895: ! 896: lp = p->exprblock.leftp; ! 897: rp = p->exprblock.rightp; ! 898: frexpr(p->exprblock.vleng); ! 899: free( (charptr) p ); ! 900: ! 901: /* If s = t // u, don't bother copying the result, write it directly into ! 902: this buffer */ ! 903: ! 904: nbad = badchleng(lp) + badchleng(rp); ! 905: if( rp->tag==TEXPR && rp->exprblock.opcode==OPCONCAT ) ! 906: p = putcat(lp, rp); ! 907: else if( !nbad ! 908: && ISONE(lp->headblock.vleng) ! 909: && ISONE(rp->headblock.vleng) ) { ! 910: lp = mkexpr(OPCONV, lp, ENULL); ! 911: rp = mkexpr(OPCONV, rp, ENULL); ! 912: lp->headblock.vtype = rp->headblock.vtype = TYCHAR; ! 913: p = putop(mkexpr(OPASSIGN, lp, rp)); ! 914: } ! 915: else ! 916: p = putx( call2(TYSUBR, "s_copy", lp, rp) ); ! 917: return p; ! 918: } ! 919: ! 920: ! 921: ! 922: ! 923: LOCAL expptr putchcmp(p) ! 924: register expptr p; ! 925: { ! 926: expptr lp, rp; ! 927: ! 928: if(p->tag != TEXPR) ! 929: badtag("putchcmp", p->tag); ! 930: ! 931: lp = p->exprblock.leftp; ! 932: rp = p->exprblock.rightp; ! 933: ! 934: if(ISONE(lp->headblock.vleng) && ISONE(rp->headblock.vleng) ) { ! 935: lp = mkexpr(OPCONV, lp, ENULL); ! 936: rp = mkexpr(OPCONV, rp, ENULL); ! 937: lp->headblock.vtype = rp->headblock.vtype = TYCHAR; ! 938: } ! 939: else { ! 940: lp = call2(TYINT,"s_cmp", lp, rp); ! 941: rp = ICON(0); ! 942: } ! 943: p->exprblock.leftp = lp; ! 944: p->exprblock.rightp = rp; ! 945: p = putop(p); ! 946: return p; ! 947: } ! 948: ! 949: ! 950: ! 951: ! 952: ! 953: /* putcat -- Writes out a concatenation operation. Two temporary arrays ! 954: are allocated, putct1() is called to initialize them, and then a ! 955: call to runtime library routine s_cat() is inserted. ! 956: ! 957: This routine generates code which will perform an (nconc lhs rhs) ! 958: at runtime. The runtime funciton does not return a value, the routine ! 959: that calls this putcat must remember the name of lhs. ! 960: */ ! 961: ! 962: ! 963: LOCAL expptr putcat(lhs0, rhs) ! 964: expptr lhs0; ! 965: register expptr rhs; ! 966: { ! 967: register Addrp lhs = (Addrp)lhs0; ! 968: int n, tyi; ! 969: Addrp length_var, string_var; ! 970: expptr p; ! 971: static char Writing_concatenation[] = "Writing concatenation"; ! 972: ! 973: /* Create the temporary arrays */ ! 974: ! 975: n = ncat(rhs); ! 976: length_var = mktmpn(n, tyioint, ENULL); ! 977: string_var = mktmpn(n, TYADDR, ENULL); ! 978: frtemp((Addrp)cpexpr((expptr)length_var)); ! 979: frtemp((Addrp)cpexpr((expptr)string_var)); ! 980: ! 981: /* Initialize the arrays */ ! 982: ! 983: n = 0; ! 984: /* p1_comment scribbles on its argument, so we ! 985: * cannot safely pass a string literal here. */ ! 986: p1_comment(Writing_concatenation); ! 987: putct1(rhs, length_var, string_var, &n); ! 988: ! 989: /* Create the invocation */ ! 990: ! 991: tyi = tyint; ! 992: tyint = tyioint; /* for -I2 */ ! 993: p = putx (call4 (TYSUBR, "s_cat", ! 994: (expptr)lhs, ! 995: (expptr)string_var, ! 996: (expptr)length_var, ! 997: (expptr)putconst((Constp)ICON(n)))); ! 998: tyint = tyi; ! 999: ! 1000: return p; ! 1001: } ! 1002: ! 1003: ! 1004: ! 1005: ! 1006: ! 1007: LOCAL putct1(q, length_var, string_var, ip) ! 1008: register expptr q; ! 1009: register Addrp length_var, string_var; ! 1010: int *ip; ! 1011: { ! 1012: int i; ! 1013: Addrp length_copy, string_copy; ! 1014: expptr e; ! 1015: extern int szleng; ! 1016: ! 1017: if(q->tag==TEXPR && q->exprblock.opcode==OPCONCAT) ! 1018: { ! 1019: putct1(q->exprblock.leftp, length_var, string_var, ! 1020: ip); ! 1021: putct1(q->exprblock.rightp, length_var, string_var, ! 1022: ip); ! 1023: frexpr (q -> exprblock.vleng); ! 1024: free ((charptr) q); ! 1025: } ! 1026: else ! 1027: { ! 1028: i = (*ip)++; ! 1029: e = cpexpr(q->headblock.vleng); ! 1030: if (!e) ! 1031: return; /* error -- character*(*) */ ! 1032: length_copy = (Addrp) cpexpr((expptr)length_var); ! 1033: length_copy->memoffset = ! 1034: mkexpr(OPPLUS,length_copy->memoffset, ICON(i*szleng)); ! 1035: string_copy = (Addrp) cpexpr((expptr)string_var); ! 1036: string_copy->memoffset = ! 1037: mkexpr(OPPLUS, string_copy->memoffset, ! 1038: ICON(i*typesize[TYADDR])); ! 1039: putout (PAIR (putassign((expptr)length_copy, e), ! 1040: putassign((expptr)string_copy, addrof((expptr)putch1(q))))); ! 1041: } ! 1042: } ! 1043: ! 1044: /* putaddr -- seems to write out function invocation actual parameters */ ! 1045: ! 1046: LOCAL expptr putaddr(p0) ! 1047: expptr p0; ! 1048: { ! 1049: register Addrp p; ! 1050: chainp cp; ! 1051: ! 1052: if (!(p = (Addrp)p0)) ! 1053: return ENULL; ! 1054: ! 1055: if( p->tag==TERROR || (p->memoffset!=NULL && ISERROR(p->memoffset)) ) ! 1056: { ! 1057: frexpr((expptr)p); ! 1058: return ENULL; ! 1059: } ! 1060: if (p->isarray && p->memoffset) ! 1061: if (p->uname_tag == UNAM_REF) { ! 1062: cp = p->memoffset->listblock.listp; ! 1063: for(; cp; cp = cp->nextp) ! 1064: cp->datap = (char *)fixtype((tagptr)cp->datap); ! 1065: } ! 1066: else ! 1067: p->memoffset = putx(p->memoffset); ! 1068: return (expptr) p; ! 1069: } ! 1070: ! 1071: LOCAL expptr ! 1072: addrfix(e) /* fudge character string length if it's a TADDR */ ! 1073: expptr e; ! 1074: { ! 1075: return e->tag == TADDR ? mkexpr(OPIDENTITY, e, ENULL) : e; ! 1076: } ! 1077: ! 1078: LOCAL int ! 1079: typekludge(ccall, q, at, j) ! 1080: int ccall; ! 1081: register expptr q; ! 1082: Atype *at; ! 1083: int j; /* alternate type */ ! 1084: { ! 1085: register int i, k; ! 1086: extern int iocalladdr; ! 1087: register Namep np; ! 1088: ! 1089: /* Return value classes: ! 1090: * < 100 ==> Fortran arg (pointer to type) ! 1091: * < 200 ==> C arg ! 1092: * < 300 ==> procedure arg ! 1093: * < 400 ==> external, no explicit type ! 1094: * < 500 ==> arg that may turn out to be ! 1095: * either a variable or a procedure ! 1096: */ ! 1097: ! 1098: k = q->headblock.vtype; ! 1099: if (ccall) { ! 1100: if (k == TYREAL) ! 1101: k = TYDREAL; /* force double for library routines */ ! 1102: return k + 100; ! 1103: } ! 1104: if (k == TYADDR) ! 1105: return iocalladdr; ! 1106: i = q->tag; ! 1107: if ((i == TEXPR && q->exprblock.opcode != OPCOMMA_ARG) ! 1108: || (i == TADDR && q->addrblock.charleng) ! 1109: || i == TCONST) ! 1110: k = TYFTNLEN + 100; ! 1111: else if (i == TADDR) ! 1112: switch(q->addrblock.vclass) { ! 1113: case CLPROC: ! 1114: if (q->addrblock.uname_tag != UNAM_NAME) ! 1115: k += 200; ! 1116: else if ((np = q->addrblock.user.name)->vprocclass ! 1117: != PTHISPROC) { ! 1118: if (k && !np->vimpltype) ! 1119: k += 200; ! 1120: else { ! 1121: if (j > 200 && infertypes && j < 300) { ! 1122: k = j; ! 1123: inferdcl(np, j-200); ! 1124: } ! 1125: else k = (np->vstg == STGEXT ! 1126: ? extsymtab[np->vardesc.varno].extype ! 1127: : 0) + 200; ! 1128: at->cp = mkchain((char *)np, at->cp); ! 1129: } ! 1130: } ! 1131: else if (k == TYSUBR) ! 1132: k += 200; ! 1133: break; ! 1134: ! 1135: case CLUNKNOWN: ! 1136: if (q->addrblock.vstg == STGARG ! 1137: && q->addrblock.uname_tag == UNAM_NAME) { ! 1138: k += 400; ! 1139: at->cp = mkchain((char *)q->addrblock.user.name, ! 1140: at->cp); ! 1141: } ! 1142: } ! 1143: else if (i == TNAME && q->nameblock.vstg == STGARG) { ! 1144: np = &q->nameblock; ! 1145: switch(np->vclass) { ! 1146: case CLPROC: ! 1147: if (!np->vimpltype) ! 1148: k += 200; ! 1149: else if (j <= 200 || !infertypes || j >= 300) ! 1150: k += 300; ! 1151: else { ! 1152: k = j; ! 1153: inferdcl(np, j-200); ! 1154: } ! 1155: goto add2chain; ! 1156: ! 1157: case CLUNKNOWN: ! 1158: /* argument may be a scalar variable or a function */ ! 1159: if (np->vimpltype && j && infertypes ! 1160: && j < 300) { ! 1161: inferdcl(np, j % 100); ! 1162: k = j; ! 1163: } ! 1164: else ! 1165: k += 400; ! 1166: ! 1167: /* to handle procedure args only so far known to be ! 1168: * external, save a pointer to the symbol table entry... ! 1169: */ ! 1170: add2chain: ! 1171: at->cp = mkchain((char *)np, at->cp); ! 1172: } ! 1173: } ! 1174: return k; ! 1175: } ! 1176: ! 1177: char * ! 1178: Argtype(k, buf) ! 1179: int k; ! 1180: char *buf; ! 1181: { ! 1182: if (k < 100) { ! 1183: sprintf(buf, "%s variable", ftn_types[k]); ! 1184: return buf; ! 1185: } ! 1186: if (k < 200) { ! 1187: k -= 100; ! 1188: return ftn_types[k]; ! 1189: } ! 1190: if (k < 300) { ! 1191: k -= 200; ! 1192: if (k == TYSUBR) ! 1193: return ftn_types[TYSUBR]; ! 1194: sprintf(buf, "%s function", ftn_types[k]); ! 1195: return buf; ! 1196: } ! 1197: if (k < 400) ! 1198: return "external argument"; ! 1199: k -= 400; ! 1200: sprintf(buf, "%s argument", ftn_types[k]); ! 1201: return buf; ! 1202: } ! 1203: ! 1204: static void ! 1205: atype_squawk(at, msg) ! 1206: Argtypes *at; ! 1207: char *msg; ! 1208: { ! 1209: register Atype *a, *ae; ! 1210: warn(msg); ! 1211: for(a = at->atypes, ae = a + at->nargs; a < ae; a++) ! 1212: frchain(&a->cp); ! 1213: at->nargs = -1; ! 1214: if (at->changes & 2 && !at->defined) ! 1215: proc_protochanges++; ! 1216: } ! 1217: ! 1218: static char inconsist[] = "inconsistent calling sequences for "; ! 1219: ! 1220: void ! 1221: bad_atypes(at, fname, i, j, k, here, prev) ! 1222: Argtypes *at; ! 1223: char *fname, *here, *prev; ! 1224: int i, j, k; ! 1225: { ! 1226: char buf[208], buf1[32], buf2[32]; ! 1227: ! 1228: sprintf(buf, "%s%.90s,\n\targ %d: %s%s%s %s.", ! 1229: inconsist, fname, i, here, Argtype(k, buf1), ! 1230: prev, Argtype(j, buf2)); ! 1231: atype_squawk(at, buf); ! 1232: } ! 1233: ! 1234: int ! 1235: type_fixup(at,a,k) ! 1236: Argtypes *at; ! 1237: Atype *a; ! 1238: int k; ! 1239: { ! 1240: register struct Entrypoint *ep; ! 1241: if (!infertypes) ! 1242: return 0; ! 1243: for(ep = entries; ep; ep = ep->entnextp) ! 1244: if (at == ep->entryname->arginfo) { ! 1245: a->type = k % 100; ! 1246: return proc_argchanges = 1; ! 1247: } ! 1248: return 0; ! 1249: } ! 1250: ! 1251: ! 1252: void ! 1253: save_argtypes(arglist, at0, at1, ccall, fname, stg, nchargs, type, zap) ! 1254: chainp arglist; ! 1255: Argtypes **at0, **at1; ! 1256: int ccall, stg, nchargs, type, zap; ! 1257: char *fname; ! 1258: { ! 1259: Argtypes *at; ! 1260: chainp cp; ! 1261: int i, i0, j, k, nargs, nbad, *t, *te; ! 1262: Atype *atypes; ! 1263: expptr q; ! 1264: char buf[208], buf1[32], buf2[32]; ! 1265: static int initargs[4] = {TYCOMPLEX, TYDCOMPLEX, TYCHAR, TYFTNLEN+100}; ! 1266: static int *init_ap[TYSUBR+1] = {0,0,0,0,0,0,0, ! 1267: #ifdef TYQUAD ! 1268: 0, ! 1269: #endif ! 1270: initargs, initargs+1,0,0,0,initargs+2}; ! 1271: extern int init_ac[TYSUBR+1]; ! 1272: ! 1273: i0 = init_ac[type]; ! 1274: t = init_ap[type]; ! 1275: te = t + i0; ! 1276: if (at = *at0) { ! 1277: *at1 = at; ! 1278: nargs = at->nargs; ! 1279: if (nargs < 0 && type && at->changes & 2 && !at->defined) ! 1280: --proc_protochanges; ! 1281: if (at->dnargs >= 0 && zap != 2) ! 1282: type = 0; ! 1283: if (nargs < 0) { /* inconsistent usage seen */ ! 1284: if (type) ! 1285: goto newlist; ! 1286: return; ! 1287: } ! 1288: atypes = at->atypes; ! 1289: i = nchargs; ! 1290: for(nbad = 0; t < te; atypes++) { ! 1291: if (++i > nargs) { ! 1292: toomany: ! 1293: i = nchargs + i0; ! 1294: for(cp = arglist; cp; cp = cp->nextp) ! 1295: i++; ! 1296: toofew: ! 1297: switch(zap) { ! 1298: case 2: zap = 6; break; ! 1299: case 1: if (at->defined & 4) ! 1300: return; ! 1301: } ! 1302: sprintf(buf, ! 1303: "%s%.90s:\n\there %d, previously %d args and string lengths.", ! 1304: inconsist, fname, i, nargs); ! 1305: atype_squawk(at, buf); ! 1306: if (type) ! 1307: goto newlist; ! 1308: return; ! 1309: } ! 1310: j = atypes->type; ! 1311: k = *t++; ! 1312: if (j != k) ! 1313: goto badtypes; ! 1314: } ! 1315: for(cp = arglist; cp; atypes++, cp = cp->nextp) { ! 1316: if (++i > nargs) ! 1317: goto toomany; ! 1318: j = atypes->type; ! 1319: if (!(q = (expptr)cp->datap)) ! 1320: continue; ! 1321: k = typekludge(ccall, q, atypes, j); ! 1322: if (k >= 300 || k == j) ! 1323: continue; ! 1324: if (j >= 300) { ! 1325: if (k >= 200) { ! 1326: if (k == TYUNKNOWN + 200) ! 1327: continue; ! 1328: if (j % 100 != k - 200 ! 1329: && k != TYSUBR + 200 ! 1330: && j != TYUNKNOWN + 300 ! 1331: && !type_fixup(at,atypes,k)) ! 1332: goto badtypes; ! 1333: } ! 1334: else if (j % 100 % TYSUBR != k % TYSUBR ! 1335: && !type_fixup(at,atypes,k)) ! 1336: goto badtypes; ! 1337: } ! 1338: else if (k < 200 || j < 200) ! 1339: if (j) { ! 1340: if (k == TYUNKNOWN ! 1341: && q->tag == TNAME ! 1342: && q->nameblock.vinfproc) { ! 1343: q->nameblock.vdcldone = 0; ! 1344: impldcl((Namep)q); ! 1345: } ! 1346: goto badtypes; ! 1347: } ! 1348: else ; /* fall through to update */ ! 1349: else if (k == TYUNKNOWN+200) ! 1350: continue; ! 1351: else if (j != TYUNKNOWN+200) ! 1352: { ! 1353: badtypes: ! 1354: if (++nbad == 1) ! 1355: bad_atypes(at, fname, i, j, k, "here ", ! 1356: ", previously"); ! 1357: else ! 1358: fprintf(stderr, ! 1359: "\targ %d: here %s, previously %s.\n", ! 1360: i, Argtype(k,buf1), ! 1361: Argtype(j,buf2)); ! 1362: continue; ! 1363: } ! 1364: /* We've subsequently learned the right type, ! 1365: as in the call on zoo below... ! 1366: ! 1367: subroutine foo(x, zap) ! 1368: external zap ! 1369: call goo(zap) ! 1370: x = zap(3) ! 1371: call zoo(zap) ! 1372: end ! 1373: */ ! 1374: if (!nbad) { ! 1375: atypes->type = k; ! 1376: at->changes |= 1; ! 1377: } ! 1378: } ! 1379: if (i < nargs) ! 1380: goto toofew; ! 1381: if (nbad) { ! 1382: if (type) { ! 1383: /* we're defining the procedure */ ! 1384: t = init_ap[type]; ! 1385: te = t + i0; ! 1386: proc_argchanges = 1; ! 1387: goto newlist; ! 1388: } ! 1389: return; ! 1390: } ! 1391: if (zap == 1 && (at->changes & 5) != 5) ! 1392: at->changes = 0; ! 1393: return; ! 1394: } ! 1395: newlist: ! 1396: i = i0 + nchargs; ! 1397: for(cp = arglist; cp; cp = cp->nextp) ! 1398: i++; ! 1399: k = sizeof(Argtypes) + (i-1)*sizeof(Atype); ! 1400: *at0 = *at1 = at = stg == STGEXT ? (Argtypes *)gmem(k,1) ! 1401: : (Argtypes *) mem(k,1); ! 1402: at->dnargs = at->nargs = i; ! 1403: at->defined = zap & 6; ! 1404: at->changes = type ? 0 : 4; ! 1405: atypes = at->atypes; ! 1406: for(; t < te; atypes++) { ! 1407: atypes->type = *t++; ! 1408: atypes->cp = 0; ! 1409: } ! 1410: for(cp = arglist; cp; atypes++, cp = cp->nextp) { ! 1411: atypes->cp = 0; ! 1412: atypes->type = (q = (expptr)cp->datap) ! 1413: ? typekludge(ccall, q, atypes, 0) ! 1414: : 0; ! 1415: } ! 1416: for(; --nchargs >= 0; atypes++) { ! 1417: atypes->type = TYFTNLEN + 100; ! 1418: atypes->cp = 0; ! 1419: } ! 1420: } ! 1421: ! 1422: void ! 1423: saveargtypes(p) /* for writing prototypes */ ! 1424: register Exprp p; ! 1425: { ! 1426: Addrp a; ! 1427: Argtypes **at0, **at1; ! 1428: Namep np; ! 1429: chainp arglist; ! 1430: expptr rp; ! 1431: Extsym *e; ! 1432: char *fname; ! 1433: ! 1434: a = (Addrp)p->leftp; ! 1435: switch(a->vstg) { ! 1436: case STGEXT: ! 1437: switch(a->uname_tag) { ! 1438: case UNAM_EXTERN: /* e.g., sqrt() */ ! 1439: e = extsymtab + a->memno; ! 1440: at0 = at1 = &e->arginfo; ! 1441: fname = e->fextname; ! 1442: break; ! 1443: case UNAM_NAME: ! 1444: np = a->user.name; ! 1445: at0 = &extsymtab[np->vardesc.varno].arginfo; ! 1446: at1 = &np->arginfo; ! 1447: fname = np->fvarname; ! 1448: break; ! 1449: default: ! 1450: goto bug; ! 1451: } ! 1452: break; ! 1453: case STGARG: ! 1454: if (a->uname_tag != UNAM_NAME) ! 1455: goto bug; ! 1456: np = a->user.name; ! 1457: at0 = at1 = &np->arginfo; ! 1458: fname = np->fvarname; ! 1459: break; ! 1460: default: ! 1461: bug: ! 1462: Fatal("Confusion in saveargtypes"); ! 1463: } ! 1464: rp = p->rightp; ! 1465: arglist = rp && rp->tag == TLIST ? rp->listblock.listp : 0; ! 1466: save_argtypes(arglist, at0, at1, p->opcode == OPCCALL, ! 1467: fname, a->vstg, 0, 0, 0); ! 1468: } ! 1469: ! 1470: /* putcall - fix up the argument list, and write out the invocation. p ! 1471: is expected to be initialized and point to an OPCALL or OPCCALL ! 1472: expression. The return value is a pointer to a temporary holding the ! 1473: result of a COMPLEX or CHARACTER operation, or NULL. */ ! 1474: ! 1475: LOCAL expptr putcall(p0, temp) ! 1476: expptr p0; ! 1477: Addrp *temp; ! 1478: { ! 1479: register Exprp p = (Exprp)p0; ! 1480: chainp arglist; /* Pointer to actual arguments, if any */ ! 1481: chainp charsp; /* List of copies of the variables which ! 1482: hold the lengths of character ! 1483: parameters (other than procedure ! 1484: parameters) */ ! 1485: chainp cp; /* Iterator over argument lists */ ! 1486: register expptr q; /* Pointer to the current argument */ ! 1487: Addrp fval; /* Function return value */ ! 1488: int type; /* type of the call - presumably this was ! 1489: set elsewhere */ ! 1490: int byvalue; /* True iff we don't want to massage the ! 1491: parameter list, since we're calling a C ! 1492: library routine */ ! 1493: char *s; ! 1494: extern struct Listblock *mklist(); ! 1495: ! 1496: type = p -> vtype; ! 1497: charsp = NULL; ! 1498: byvalue = (p->opcode == OPCCALL); ! 1499: ! 1500: /* Verify the actual parameters */ ! 1501: ! 1502: if (p == (Exprp) NULL) ! 1503: err ("putcall: NULL call expression"); ! 1504: else if (p -> tag != TEXPR) ! 1505: erri ("putcall: expected TEXPR, got '%d'", p -> tag); ! 1506: ! 1507: /* Find the argument list */ ! 1508: ! 1509: if(p->rightp && p -> rightp -> tag == TLIST) ! 1510: arglist = p->rightp->listblock.listp; ! 1511: else ! 1512: arglist = NULL; ! 1513: ! 1514: /* Count the number of explicit arguments, including lengths of character ! 1515: variables */ ! 1516: ! 1517: for(cp = arglist ; cp ; cp = cp->nextp) ! 1518: if(!byvalue) { ! 1519: q = (expptr) cp->datap; ! 1520: if( ISCONST(q) ) ! 1521: { ! 1522: ! 1523: /* Even constants are passed by reference, so we need to put them in the ! 1524: literal table */ ! 1525: ! 1526: q = (expptr) putconst((Constp)q); ! 1527: cp->datap = (char *) q; ! 1528: } ! 1529: ! 1530: /* Save the length expression of character variables (NOT character ! 1531: procedures) for the end of the argument list */ ! 1532: ! 1533: if( ISCHAR(q) && ! 1534: (q->headblock.vclass != CLPROC ! 1535: || q->headblock.vstg == STGARG ! 1536: && q->tag == TADDR ! 1537: && q->addrblock.uname_tag == UNAM_NAME ! 1538: && q->addrblock.user.name->vprocclass == PTHISPROC)) ! 1539: { ! 1540: p0 = cpexpr(q->headblock.vleng); ! 1541: charsp = mkchain((char *)p0, charsp); ! 1542: if (q->headblock.vclass == CLUNKNOWN ! 1543: && q->headblock.vstg == STGARG) ! 1544: q->addrblock.user.name->vpassed = 1; ! 1545: else if (q->tag == TADDR ! 1546: && q->addrblock.uname_tag == UNAM_CONST) ! 1547: p0->constblock.Const.ci ! 1548: += q->addrblock.user.Const.ccp1.blanks; ! 1549: } ! 1550: } ! 1551: charsp = revchain(charsp); ! 1552: ! 1553: /* If the routine is a CHARACTER function ... */ ! 1554: ! 1555: if(type == TYCHAR) ! 1556: { ! 1557: if( ISICON(p->vleng) ) ! 1558: { ! 1559: ! 1560: /* Allocate a temporary to hold the return value of the function */ ! 1561: ! 1562: fval = mktmp(TYCHAR, p->vleng); ! 1563: } ! 1564: else { ! 1565: err("adjustable character function"); ! 1566: if (temp) ! 1567: *temp = 0; ! 1568: return 0; ! 1569: } ! 1570: } ! 1571: ! 1572: /* If the routine is a COMPLEX function ... */ ! 1573: ! 1574: else if( ISCOMPLEX(type) ) ! 1575: fval = mktmp(type, ENULL); ! 1576: else ! 1577: fval = NULL; ! 1578: ! 1579: /* Write the function name, without taking its address */ ! 1580: ! 1581: p -> leftp = putx(fixtype(putaddr(p->leftp))); ! 1582: ! 1583: if(fval) ! 1584: { ! 1585: chainp prepend; ! 1586: ! 1587: /* Prepend a copy of the function return value buffer out as the first ! 1588: argument. */ ! 1589: ! 1590: prepend = mkchain((char *)putx(putaddr(cpexpr((expptr)fval))), arglist); ! 1591: ! 1592: /* If it's a character function, also prepend the length of the result */ ! 1593: ! 1594: if(type==TYCHAR) ! 1595: { ! 1596: ! 1597: prepend->nextp = mkchain((char *)putx(mkconv(TYLENG, ! 1598: p->vleng)), arglist); ! 1599: } ! 1600: if (!(q = p->rightp)) ! 1601: p->rightp = q = (expptr)mklist(CHNULL); ! 1602: q->listblock.listp = prepend; ! 1603: } ! 1604: ! 1605: /* Scan through the fortran argument list */ ! 1606: ! 1607: for(cp = arglist ; cp ; cp = cp->nextp) ! 1608: { ! 1609: q = (expptr) (cp->datap); ! 1610: if (q == ENULL) ! 1611: err ("putcall: NULL argument"); ! 1612: ! 1613: /* call putaddr only when we've got a parameter for a C routine or a ! 1614: memory resident parameter */ ! 1615: ! 1616: if (q -> tag == TCONST && !byvalue) ! 1617: q = (expptr) putconst ((Constp)q); ! 1618: ! 1619: if(q->tag==TADDR && (byvalue || q->addrblock.vstg!=STGREG) ) { ! 1620: if (q->addrblock.parenused ! 1621: && !byvalue && q->headblock.vtype != TYCHAR) ! 1622: goto make_copy; ! 1623: cp->datap = (char *)putaddr(q); ! 1624: } ! 1625: else if( ISCOMPLEX(q->headblock.vtype) ) ! 1626: cp -> datap = (char *) putx (fixtype(putcxop(q))); ! 1627: else if (ISCHAR(q) ) ! 1628: cp -> datap = (char *) putx (fixtype((expptr)putchop(q))); ! 1629: else if( ! ISERROR(q) ) ! 1630: { ! 1631: if(byvalue ! 1632: || q->tag == TEXPR && q->exprblock.opcode == OPCHARCAST) ! 1633: cp -> datap = (char *) putx(q); ! 1634: else { ! 1635: expptr t, t1; ! 1636: ! 1637: /* If we've got a register parameter, or (maybe?) a constant, save it in a ! 1638: temporary first */ ! 1639: make_copy: ! 1640: t = (expptr) mktmp(q->headblock.vtype, q->headblock.vleng); ! 1641: ! 1642: /* Assign to temporary variables before invoking the subroutine or ! 1643: function */ ! 1644: ! 1645: t1 = putassign( cpexpr(t), q ); ! 1646: if (doin_setbound) ! 1647: t = mkexpr(OPCOMMA_ARG, t1, t); ! 1648: else ! 1649: putout(t1); ! 1650: cp -> datap = (char *) t; ! 1651: } /* else */ ! 1652: } /* if !ISERROR(q) */ ! 1653: } ! 1654: ! 1655: /* Now adjust the lengths of the CHARACTER parameters */ ! 1656: ! 1657: for(cp = charsp ; cp ; cp = cp->nextp) ! 1658: cp->datap = (char *)addrfix(putx( ! 1659: /* in case MAIN has a character*(*)... */ ! 1660: (s = cp->datap) ? mkconv(TYLENG,(expptr)s) ! 1661: : ICON(0))); ! 1662: ! 1663: /* ... and add them to the end of the argument list */ ! 1664: ! 1665: hookup (arglist, charsp); ! 1666: ! 1667: /* Return the name of the temporary used to hold the results, if any was ! 1668: necessary. */ ! 1669: ! 1670: if (temp) *temp = fval; ! 1671: else frexpr ((expptr)fval); ! 1672: ! 1673: saveargtypes(p); ! 1674: ! 1675: return (expptr) p; ! 1676: } ! 1677: ! 1678: ! 1679: ! 1680: /* putmnmx -- Put min or max. p must point to an EXPR, not just a ! 1681: CONST */ ! 1682: ! 1683: LOCAL expptr putmnmx(p) ! 1684: register expptr p; ! 1685: { ! 1686: int op, op2, type; ! 1687: expptr arg, qp, temp; ! 1688: chainp p0, p1; ! 1689: Addrp sp, tp; ! 1690: char comment_buf[80]; ! 1691: char *what; ! 1692: ! 1693: if(p->tag != TEXPR) ! 1694: badtag("putmnmx", p->tag); ! 1695: ! 1696: type = p->exprblock.vtype; ! 1697: op = p->exprblock.opcode; ! 1698: op2 = op == OPMIN ? OPMIN2 : OPMAX2; ! 1699: p0 = p->exprblock.leftp->listblock.listp; ! 1700: free( (charptr) (p->exprblock.leftp) ); ! 1701: free( (charptr) p ); ! 1702: ! 1703: /* special case for two addressable operands */ ! 1704: ! 1705: if (addressable((expptr)p0->datap) ! 1706: && (p1 = p0->nextp) ! 1707: && addressable((expptr)p1->datap) ! 1708: && !p1->nextp) { ! 1709: if (type == TYREAL && forcedouble) ! 1710: op2 = op == OPMIN ? OPDMIN : OPDMAX; ! 1711: p = mkexpr(op2, mkconv(type, cpexpr((expptr)p0->datap)), ! 1712: mkconv(type, cpexpr((expptr)p1->datap))); ! 1713: frchain(&p0); ! 1714: return p; ! 1715: } ! 1716: ! 1717: /* general case */ ! 1718: ! 1719: sp = mktmp(type, ENULL); ! 1720: ! 1721: /* We only need a second temporary if the arg list has an unaddressable ! 1722: value */ ! 1723: ! 1724: tp = (Addrp) NULL; ! 1725: qp = ENULL; ! 1726: for (p1 = p0 -> nextp; p1; p1 = p1 -> nextp) ! 1727: if (!addressable ((expptr) p1 -> datap)) { ! 1728: tp = mktmp(type, ENULL); ! 1729: qp = mkexpr(op2, cpexpr((expptr)sp), cpexpr((expptr)tp)); ! 1730: qp = fixexpr((Exprp)qp); ! 1731: break; ! 1732: } /* if */ ! 1733: ! 1734: /* Now output the appropriate number of assignments and comparisons. Min ! 1735: and max are implemented by the simple O(n) algorithm: ! 1736: ! 1737: min (a, b, c, d) ==> ! 1738: { <type> t1, t2; ! 1739: ! 1740: t1 = a; ! 1741: t2 = b; t1 = (t1 < t2) ? t1 : t2; ! 1742: t2 = c; t1 = (t1 < t2) ? t1 : t2; ! 1743: t2 = d; t1 = (t1 < t2) ? t1 : t2; ! 1744: } ! 1745: */ ! 1746: ! 1747: if (!doin_setbound) { ! 1748: switch(op) { ! 1749: case OPLT: ! 1750: case OPMIN: ! 1751: case OPDMIN: ! 1752: case OPMIN2: ! 1753: what = "IN"; ! 1754: break; ! 1755: default: ! 1756: what = "AX"; ! 1757: } ! 1758: sprintf (comment_buf, "Computing M%s", what); ! 1759: p1_comment (comment_buf); ! 1760: } ! 1761: ! 1762: p1 = p0->nextp; ! 1763: temp = (expptr)p0->datap; ! 1764: if (addressable(temp) && addressable((expptr)p1->datap)) { ! 1765: p = mkconv(type, cpexpr(temp)); ! 1766: arg = mkconv(type, cpexpr((expptr)p1->datap)); ! 1767: temp = mkexpr(op2, p, arg); ! 1768: if (!ISCONST(temp)) ! 1769: temp = fixexpr((Exprp)temp); ! 1770: p1 = p1->nextp; ! 1771: } ! 1772: p = putassign (cpexpr((expptr)sp), temp); ! 1773: ! 1774: for(; p1 ; p1 = p1->nextp) ! 1775: { ! 1776: if (addressable ((expptr) p1 -> datap)) { ! 1777: arg = mkconv(type, cpexpr((expptr)p1->datap)); ! 1778: temp = mkexpr(op2, cpexpr((expptr)sp), arg); ! 1779: temp = fixexpr((Exprp)temp); ! 1780: } else { ! 1781: temp = (expptr) cpexpr (qp); ! 1782: p = mkexpr(OPCOMMA, p, ! 1783: putassign(cpexpr((expptr)tp), (expptr)p1->datap)); ! 1784: } /* else */ ! 1785: ! 1786: if(p1->nextp) ! 1787: p = mkexpr(OPCOMMA, p, ! 1788: putassign(cpexpr((expptr)sp), temp)); ! 1789: else { ! 1790: if (type == TYREAL && forcedouble) ! 1791: temp->exprblock.opcode = ! 1792: op == OPMIN ? OPDMIN : OPDMAX; ! 1793: if (doin_setbound) ! 1794: p = mkexpr(OPCOMMA, p, temp); ! 1795: else { ! 1796: putout (p); ! 1797: p = putx(temp); ! 1798: } ! 1799: if (qp) ! 1800: frexpr (qp); ! 1801: } /* else */ ! 1802: } /* for */ ! 1803: ! 1804: frchain( &p0 ); ! 1805: return p; ! 1806: } ! 1807: ! 1808: ! 1809: void ! 1810: putwhile(p) ! 1811: expptr p; ! 1812: { ! 1813: long where; ! 1814: int k, n; ! 1815: ! 1816: if (wh_next >= wh_last) ! 1817: { ! 1818: k = wh_last - wh_first; ! 1819: n = k + 100; ! 1820: wh_next = mem(n,0); ! 1821: wh_last = wh_first + n; ! 1822: if (k) ! 1823: memcpy(wh_next, wh_first, k); ! 1824: wh_first = wh_next; ! 1825: wh_next += k; ! 1826: wh_last = wh_first + n; ! 1827: } ! 1828: if( !ISLOGICAL((k = (p = fixtype(p))->headblock.vtype))) ! 1829: { ! 1830: if(k != TYERROR) ! 1831: err("non-logical expression in DO WHILE statement"); ! 1832: } ! 1833: else { ! 1834: p1put(P1_WHILE1START); ! 1835: where = ftell(pass1_file); ! 1836: p = putx(p); ! 1837: *wh_next++ = ftell(pass1_file) > where; ! 1838: p1put(P1_WHILE2START); ! 1839: p1_expr(p); ! 1840: } ! 1841: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.