UNIX 7th Ed. - /usr/src/cmd/f77/putscj.c

   1: /* INTERMEDIATE CODE GENERATION FOR S C JOHNSON C COMPILERS */
   2: /* NEW VERSION USING BINARY POLISH POSTFIX INTERMEDIATE */
   3: #if FAMILY != SCJ
   4:     WRONG put FULE !!!!
   5: #endif
   6: 
   7: #include "defs"
   8: #include "scjdefs"
   9: 
  10: #define FOUR 4
  11: extern int ops2[];
  12: extern int types2[];
  13: 
  14: #define P2BUFFMAX 128
  15: static long int p2buff[P2BUFFMAX];
  16: static long int *p2bufp     = &p2buff[0];
  17: static long int *p2bufend   = &p2buff[P2BUFFMAX];
  18: 
  19: 
  20: puthead(s)
  21: char *s;
  22: {
  23: char buff[100];
  24: #if TARGET == VAX
  25:     if(s)
  26:         p2pass( sprintf(buff, "\t.globl\t_%s", s) );
  27: #endif
  28: /* put out fake copy of left bracket line, to be redone later */
  29: if( ! headerdone )
  30:     {
  31: #if FAMILY==SCJ && OUTPUT==BINARY
  32:     p2flush();
  33: #endif
  34:     headoffset = ftell(textfile);
  35:     prhead(textfile);
  36:     headerdone = YES;
  37:     p2triple(P2STMT, (strlen(infname)+FOUR-1)/FOUR, 0);
  38:     p2str(infname);
  39:     }
  40: }
  41: 
  42: 
  43: 
  44: 
  45: 
  46: /* It is necessary to precede each procedure with a "left bracket"
  47:  * line that tells pass 2 how many register variables and how
  48:  * much automatic space is required for the function.  This compiler
  49:  * does not know how much automatic space is needed until the
  50:  * entire procedure has been processed.  Therefore, "puthead"
  51:  * is called at the begining to record the current location in textfile,
  52:  * then to put out a placeholder left bracket line.  This procedure
  53:  * repositions the file and rewrites that line, then puts the
  54:  * file pointer back to the end of the file.
  55:  */
  56: 
  57: putbracket()
  58: {
  59: long int hereoffset;
  60: 
  61: #if FAMILY==SCJ && OUTPUT==BINARY
  62:     p2flush();
  63: #endif
  64: hereoffset = ftell(textfile);
  65: if(fseek(textfile, headoffset, 0))
  66:     fatal("fseek failed");
  67: prhead(textfile);
  68: if(fseek(textfile, hereoffset, 0))
  69:     fatal("fseek failed 2");
  70: }
  71: 
  72: 
  73: 
  74: 
  75: putrbrack(k)
  76: int k;
  77: {
  78: p2op(P2RBRACKET, k);
  79: }
  80: 
  81: 
  82: 
  83: putnreg()
  84: {
  85: }
  86: 
  87: 
  88: 
  89: 
  90: 
  91: 
  92: puteof()
  93: {
  94: p2op(P2EOF, 0);
  95: p2flush();
  96: }
  97: 
  98: 
  99: 
 100: putstmt()
 101: {
 102: p2triple(P2STMT, 0, lineno);
 103: }
 104: 
 105: 
 106: 
 107: 
 108: /* put out code for if( ! p) goto l  */
 109: putif(p,l)
 110: register expptr p;
 111: int l;
 112: {
 113: register int k;
 114: 
 115: if( ( k = (p = fixtype(p))->vtype) != TYLOGICAL)
 116:     {
 117:     if(k != TYERROR)
 118:         err("non-logical expression in IF statement");
 119:     frexpr(p);
 120:     }
 121: else
 122:     {
 123:     putex1(p);
 124:     p2icon( (long int) l , P2INT);
 125:     p2op(P2CBRANCH, 0);
 126:     putstmt();
 127:     }
 128: }
 129: 
 130: 
 131: 
 132: 
 133: 
 134: /* put out code for  goto l   */
 135: putgoto(label)
 136: int label;
 137: {
 138: p2triple(P2GOTO, 1, label);
 139: putstmt();
 140: }
 141: 
 142: 
 143: /* branch to address constant or integer variable */
 144: putbranch(p)
 145: register struct addrblock *p;
 146: {
 147: putex1(p);
 148: p2op(P2GOTO, P2INT);
 149: putstmt();
 150: }
 151: 
 152: 
 153: 
 154: /* put out label  l:     */
 155: putlabel(label)
 156: int label;
 157: {
 158: p2op(P2LABEL, label);
 159: }
 160: 
 161: 
 162: 
 163: 
 164: putexpr(p)
 165: expptr p;
 166: {
 167: putex1(p);
 168: putstmt();
 169: }
 170: 
 171: 
 172: 
 173: 
 174: putcmgo(index, nlab, labs)
 175: expptr index;
 176: int nlab;
 177: struct labelblock *labs[];
 178: {
 179: int i, labarray, skiplabel;
 180: 
 181: if(! ISINT(index->vtype) )
 182:     {
 183:     execerr("computed goto index must be integer", NULL);
 184:     return;
 185:     }
 186: 
 187: #if TARGET == VAX
 188:     /* use special case instruction */
 189:     vaxgoto(index, nlab, labs);
 190: #else
 191:     labarray = newlabel();
 192:     preven(ALIADDR);
 193:     prlabel(asmfile, labarray);
 194:     prcona(asmfile, (ftnint) (skiplabel = newlabel()) );
 195:     for(i = 0 ; i < nlab ; ++i)
 196:         prcona(asmfile, (ftnint)(labs[i]->labelno) );
 197:     prcmgoto(index, nlab, skiplabel, labarray);
 198:     putlabel(skiplabel);
 199: #endif
 200: }
 201: 
 202: putx(p)
 203: expptr p;
 204: {
 205: struct addrblock *putcall(), *putcx1(), *realpart();
 206: char *memname();
 207: int opc;
 208: int ncomma;
 209: int type, k;
 210: 
 211: switch(p->tag)
 212:     {
 213:     case TERROR:
 214:         free(p);
 215:         break;
 216: 
 217:     case TCONST:
 218:         switch(type = p->vtype)
 219:             {
 220:             case TYLOGICAL:
 221:                 type = tyint;
 222:             case TYLONG:
 223:             case TYSHORT:
 224:                 p2icon(p->const.ci, types2[type]);
 225:                 free(p);
 226:                 break;
 227: 
 228:             case TYADDR:
 229:                 p2triple(P2ICON, 1, P2INT|P2PTR);
 230:                 p2word(0L);
 231:                 p2name(memname(STGCONST, (int) p->const.ci) );
 232:                 free(p);
 233:                 break;
 234: 
 235:             default:
 236:                 putx( putconst(p) );
 237:                 break;
 238:             }
 239:         break;
 240: 
 241:     case TEXPR:
 242:         switch(opc = p->opcode)
 243:             {
 244:             case OPCALL:
 245:             case OPCCALL:
 246:                 if( ISCOMPLEX(p->vtype) )
 247:                     putcxop(p);
 248:                 else    putcall(p);
 249:                 break;
 250: 
 251:             case OPMIN:
 252:             case OPMAX:
 253:                 putmnmx(p);
 254:                 break;
 255: 
 256: 
 257:             case OPASSIGN:
 258:                 if( ISCOMPLEX(p->leftp->vtype) || ISCOMPLEX(p->rightp->vtype) )
 259:                     frexpr( putcxeq(p) );
 260:                 else if( ISCHAR(p) )
 261:                     putcheq(p);
 262:                 else
 263:                     goto putopp;
 264:                 break;
 265: 
 266:             case OPEQ:
 267:             case OPNE:
 268:                 if( ISCOMPLEX(p->leftp->vtype) || ISCOMPLEX(p->rightp->vtype) )
 269:                     {
 270:                     putcxcmp(p);
 271:                     break;
 272:                     }
 273:             case OPLT:
 274:             case OPLE:
 275:             case OPGT:
 276:             case OPGE:
 277:                 if(ISCHAR(p->leftp))
 278:                     putchcmp(p);
 279:                 else
 280:                     goto putopp;
 281:                 break;
 282: 
 283:             case OPPOWER:
 284:                 putpower(p);
 285:                 break;
 286: 
 287:             case OPSTAR:
 288: #if FAMILY == SCJ
 289:                 /*   m * (2**k) -> m<<k   */
 290:                 if(INT(p->leftp->vtype) && ISICON(p->rightp) &&
 291:                    ( (k = log2(p->rightp->const.ci))>0) )
 292:                     {
 293:                     p->opcode = OPLSHIFT;
 294:                     frexpr(p->rightp);
 295:                     p->rightp = ICON(k);
 296:                     goto putopp;
 297:                     }
 298: #endif
 299: 
 300:             case OPMOD:
 301:                 goto putopp;
 302:             case OPPLUS:
 303:             case OPMINUS:
 304:             case OPSLASH:
 305:             case OPNEG:
 306:                 if( ISCOMPLEX(p->vtype) )
 307:                     putcxop(p);
 308:                 else    goto putopp;
 309:                 break;
 310: 
 311:             case OPCONV:
 312:                 if( ISCOMPLEX(p->vtype) )
 313:                     putcxop(p);
 314:                 else if( ISCOMPLEX(p->leftp->vtype) )
 315:                     {
 316:                     ncomma = 0;
 317:                     putx( mkconv(p->vtype,
 318:                         realpart(putcx1(p->leftp, &ncomma))));
 319:                     putcomma(ncomma, p->vtype, NO);
 320:                     free(p);
 321:                     }
 322:                 else    goto putopp;
 323:                 break;
 324: 
 325:             case OPNOT:
 326:             case OPOR:
 327:             case OPAND:
 328:             case OPEQV:
 329:             case OPNEQV:
 330:             case OPADDR:
 331:             case OPPLUSEQ:
 332:             case OPSTAREQ:
 333:             case OPCOMMA:
 334:             case OPQUEST:
 335:             case OPCOLON:
 336:             case OPBITOR:
 337:             case OPBITAND:
 338:             case OPBITXOR:
 339:             case OPBITNOT:
 340:             case OPLSHIFT:
 341:             case OPRSHIFT:
 342:         putopp:
 343:                 putop(p);
 344:                 break;
 345: 
 346:             default:
 347:                 fatal1("putx: invalid opcode %d", opc);
 348:             }
 349:         break;
 350: 
 351:     case TADDR:
 352:         putaddr(p, YES);
 353:         break;
 354: 
 355:     default:
 356:         fatal1("putx: impossible tag %d", p->tag);
 357:     }
 358: }
 359: 
 360: 
 361: 
 362: LOCAL putop(p)
 363: expptr p;
 364: {
 365: int k;
 366: expptr lp, tp;
 367: int pt, lt;
 368: int comma;
 369: 
 370: switch(p->opcode)   /* check for special cases and rewrite */
 371:     {
 372:     case OPCONV:
 373:         pt = p->vtype;
 374:         lp = p->leftp;
 375:         lt = lp->vtype;
 376:         while(p->tag==TEXPR && p->opcode==OPCONV &&
 377:              ( (ISREAL(pt)&&ISREAL(lt)) ||
 378:             (INT(pt)&&(ONEOF(lt,MSKINT|MSKADDR|MSKCHAR|M(TYSUBR)))) ))
 379:             {
 380: #if SZINT < SZLONG
 381:             if(lp->tag != TEXPR)
 382:                 {
 383:                 if(pt==TYINT && lt==TYLONG)
 384:                     break;
 385:                 if(lt==TYINT && pt==TYLONG)
 386:                     break;
 387:                 }
 388: #endif
 389:             free(p);
 390:             p = lp;
 391:             pt = lt;
 392:             lp = p->leftp;
 393:             lt = lp->vtype;
 394:             }
 395:         if(p->tag==TEXPR && p->opcode==OPCONV)
 396:             break;
 397:         putx(p);
 398:         return;
 399: 
 400:     case OPADDR:
 401:         comma = NO;
 402:         lp = p->leftp;
 403:         if(lp->tag != TADDR)
 404:             {
 405:             tp = mktemp(lp->vtype, lp->vleng);
 406:             putx( mkexpr(OPASSIGN, cpexpr(tp), lp) );
 407:             lp = tp;
 408:             comma = YES;
 409:             }
 410:         putaddr(lp, NO);
 411:         if(comma)
 412:             putcomma(1, TYINT, NO);
 413:         free(p);
 414:         return;
 415:     }
 416: 
 417: if( (k = ops2[p->opcode]) <= 0)
 418:     fatal1("putop: invalid opcode %d", p->opcode);
 419: putx(p->leftp);
 420: if(p->rightp)
 421:     putx(p->rightp);
 422: p2op(k, types2[p->vtype]);
 423: 
 424: if(p->vleng)
 425:     frexpr(p->vleng);
 426: free(p);
 427: }
 428: 
 429: putforce(t, p)
 430: int t;
 431: expptr p;
 432: {
 433: p = mkconv(t, fixtype(p));
 434: putx(p);
 435: p2op(P2FORCE,
 436:     (t==TYSHORT ? P2SHORT : (t==TYLONG ? P2LONG : P2DREAL)) );
 437: putstmt();
 438: }
 439: 
 440: 
 441: 
 442: LOCAL putpower(p)
 443: expptr p;
 444: {
 445: expptr base;
 446: struct addrblock *t1, *t2;
 447: ftnint k;
 448: int type;
 449: int ncomma;
 450: 
 451: if(!ISICON(p->rightp) || (k = p->rightp->const.ci)<2)
 452:     fatal("putpower: bad call");
 453: base = p->leftp;
 454: type = base->vtype;
 455: t1 = mktemp(type, NULL);
 456: t2 = NULL;
 457: ncomma = 1;
 458: putassign(cpexpr(t1), cpexpr(base) );
 459: 
 460: for( ; (k&1)==0 && k>2 ; k>>=1 )
 461:     {
 462:     ++ncomma;
 463:     putsteq(t1, t1);
 464:     }
 465: 
 466: if(k == 2)
 467:     putx( mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)) );
 468: else
 469:     {
 470:     t2 = mktemp(type, NULL);
 471:     ++ncomma;
 472:     putassign(cpexpr(t2), cpexpr(t1));
 473: 
 474:     for(k>>=1 ; k>1 ; k>>=1)
 475:         {
 476:         ++ncomma;
 477:         putsteq(t1, t1);
 478:         if(k & 1)
 479:             {
 480:             ++ncomma;
 481:             putsteq(t2, t1);
 482:             }
 483:         }
 484:     putx( mkexpr(OPSTAR, cpexpr(t2),
 485:         mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)) ));
 486:     }
 487: putcomma(ncomma, type, NO);
 488: frexpr(t1);
 489: if(t2)
 490:     frexpr(t2);
 491: frexpr(p);
 492: }
 493: 
 494: 
 495: 
 496: 
 497: LOCAL struct addrblock *intdouble(p, ncommap)
 498: struct addrblock *p;
 499: int *ncommap;
 500: {
 501: register struct addrblock *t;
 502: 
 503: t = mktemp(TYDREAL, NULL);
 504: ++*ncommap;
 505: putassign(cpexpr(t), p);
 506: return(t);
 507: }
 508: 
 509: 
 510: 
 511: 
 512: 
 513: LOCAL putcxeq(p)
 514: register struct exprblock *p;
 515: {
 516: register struct addrblock *lp, *rp;
 517: int ncomma;
 518: 
 519: ncomma = 0;
 520: lp = putcx1(p->leftp, &ncomma);
 521: rp = putcx1(p->rightp, &ncomma);
 522: putassign(realpart(lp), realpart(rp));
 523: if( ISCOMPLEX(p->vtype) )
 524:     {
 525:     ++ncomma;
 526:     putassign(imagpart(lp), imagpart(rp));
 527:     }
 528: putcomma(ncomma, TYREAL, NO);
 529: frexpr(rp);
 530: free(p);
 531: return(lp);
 532: }
 533: 
 534: 
 535: 
 536: LOCAL putcxop(p)
 537: expptr p;
 538: {
 539: struct addrblock *putcx1();
 540: int ncomma;
 541: 
 542: ncomma = 0;
 543: putaddr( putcx1(p, &ncomma), NO);
 544: putcomma(ncomma, TYINT, NO);
 545: }
 546: 
 547: 
 548: 
 549: LOCAL struct addrblock *putcx1(p, ncommap)
 550: register expptr p;
 551: int *ncommap;
 552: {
 553: struct addrblock *q, *lp, *rp;
 554: register struct addrblock *resp;
 555: int opcode;
 556: int ltype, rtype;
 557: 
 558: if(p == NULL)
 559:     return(NULL);
 560: 
 561: switch(p->tag)
 562:     {
 563:     case TCONST:
 564:         if( ISCOMPLEX(p->vtype) )
 565:             p = putconst(p);
 566:         return( p );
 567: 
 568:     case TADDR:
 569:         if( ! addressable(p) )
 570:             {
 571:             ++*ncommap;
 572:             resp = mktemp(tyint, NULL);
 573:             putassign( cpexpr(resp), p->memoffset );
 574:             p->memoffset = resp;
 575:             }
 576:         return( p );
 577: 
 578:     case TEXPR:
 579:         if( ISCOMPLEX(p->vtype) )
 580:             break;
 581:         ++*ncommap;
 582:         resp = mktemp(TYDREAL, NO);
 583:         putassign( cpexpr(resp), p);
 584:         return(resp);
 585: 
 586:     default:
 587:         fatal1("putcx1: bad tag %d", p->tag);
 588:     }
 589: 
 590: opcode = p->opcode;
 591: if(opcode==OPCALL || opcode==OPCCALL)
 592:     {
 593:     ++*ncommap;
 594:     return( putcall(p) );
 595:     }
 596: else if(opcode == OPASSIGN)
 597:     {
 598:     ++*ncommap;
 599:     return( putcxeq(p) );
 600:     }
 601: resp = mktemp(p->vtype, NULL);
 602: if(lp = putcx1(p->leftp, ncommap) )
 603:     ltype = lp->vtype;
 604: if(rp = putcx1(p->rightp, ncommap) )
 605:     rtype = rp->vtype;
 606: 
 607: switch(opcode)
 608:     {
 609:     case OPCOMMA:
 610:         frexpr(resp);
 611:         resp = rp;
 612:         rp = NULL;
 613:         break;
 614: 
 615:     case OPNEG:
 616:         putassign( realpart(resp), mkexpr(OPNEG, realpart(lp), NULL) );
 617:         putassign( imagpart(resp), mkexpr(OPNEG, imagpart(lp), NULL) );
 618:         *ncommap += 2;
 619:         break;
 620: 
 621:     case OPPLUS:
 622:     case OPMINUS:
 623:         putassign( realpart(resp), mkexpr(opcode, realpart(lp), realpart(rp) ));
 624:         if(rtype < TYCOMPLEX)
 625:             putassign( imagpart(resp), imagpart(lp) );
 626:         else if(ltype < TYCOMPLEX)
 627:             {
 628:             if(opcode == OPPLUS)
 629:                 putassign( imagpart(resp), imagpart(rp) );
 630:             else    putassign( imagpart(resp), mkexpr(OPNEG, imagpart(rp), NULL) );
 631:             }
 632:         else
 633:             putassign( imagpart(resp), mkexpr(opcode, imagpart(lp), imagpart(rp) ));
 634: 
 635:         *ncommap += 2;
 636:         break;
 637: 
 638:     case OPSTAR:
 639:         if(ltype < TYCOMPLEX)
 640:             {
 641:             if( ISINT(ltype) )
 642:                 lp = intdouble(lp, ncommap);
 643:             putassign( realpart(resp), mkexpr(OPSTAR, cpexpr(lp), realpart(rp) ));
 644:             putassign( imagpart(resp), mkexpr(OPSTAR, cpexpr(lp), imagpart(rp) ));
 645:             }
 646:         else if(rtype < TYCOMPLEX)
 647:             {
 648:             if( ISINT(rtype) )
 649:                 rp = intdouble(rp, ncommap);
 650:             putassign( realpart(resp), mkexpr(OPSTAR, cpexpr(rp), realpart(lp) ));
 651:             putassign( imagpart(resp), mkexpr(OPSTAR, cpexpr(rp), imagpart(lp) ));
 652:             }
 653:         else    {
 654:             putassign( realpart(resp), mkexpr(OPMINUS,
 655:                 mkexpr(OPSTAR, realpart(lp), realpart(rp)),
 656:                 mkexpr(OPSTAR, imagpart(lp), imagpart(rp)) ));
 657:             putassign( imagpart(resp), mkexpr(OPPLUS,
 658:                 mkexpr(OPSTAR, realpart(lp), imagpart(rp)),
 659:                 mkexpr(OPSTAR, imagpart(lp), realpart(rp)) ));
 660:             }
 661:         *ncommap += 2;
 662:         break;
 663: 
 664:     case OPSLASH:
 665:         /* fixexpr has already replaced all divisions
 666: 		 * by a complex by a function call
 667: 		 */
 668:         if( ISINT(rtype) )
 669:             rp = intdouble(rp, ncommap);
 670:         putassign( realpart(resp), mkexpr(OPSLASH, realpart(lp), cpexpr(rp)) );
 671:         putassign( imagpart(resp), mkexpr(OPSLASH, imagpart(lp), cpexpr(rp)) );
 672:         *ncommap += 2;
 673:         break;
 674: 
 675:     case OPCONV:
 676:         putassign( realpart(resp), realpart(lp) );
 677:         if( ISCOMPLEX(lp->vtype) )
 678:             q = imagpart(lp);
 679:         else if(rp != NULL)
 680:             q = realpart(rp);
 681:         else
 682:             q = mkrealcon(TYDREAL, 0.0);
 683:         putassign( imagpart(resp), q);
 684:         *ncommap += 2;
 685:         break;
 686: 
 687:     default:
 688:         fatal1("putcx1 of invalid opcode %d", opcode);
 689:     }
 690: 
 691: frexpr(lp);
 692: frexpr(rp);
 693: free(p);
 694: return(resp);
 695: }
 696: 
 697: 
 698: 
 699: 
 700: LOCAL putcxcmp(p)
 701: register struct exprblock *p;
 702: {
 703: int opcode;
 704: int ncomma;
 705: register struct addrblock *lp, *rp;
 706: struct exprblock *q;
 707: 
 708: ncomma = 0;
 709: opcode = p->opcode;
 710: lp = putcx1(p->leftp, &ncomma);
 711: rp = putcx1(p->rightp, &ncomma);
 712: 
 713: q = mkexpr( opcode==OPEQ ? OPAND : OPOR ,
 714:     mkexpr(opcode, realpart(lp), realpart(rp)),
 715:     mkexpr(opcode, imagpart(lp), imagpart(rp)) );
 716: putx( fixexpr(q) );
 717: putcomma(ncomma, TYINT, NO);
 718: 
 719: free(lp);
 720: free(rp);
 721: free(p);
 722: }
 723: 
 724: LOCAL struct addrblock *putch1(p, ncommap)
 725: register expptr p;
 726: int * ncommap;
 727: {
 728: register struct addrblock *t;
 729: struct addrblock *mktemp(), *putconst();
 730: 
 731: switch(p->tag)
 732:     {
 733:     case TCONST:
 734:         return( putconst(p) );
 735: 
 736:     case TADDR:
 737:         return(p);
 738: 
 739:     case TEXPR:
 740:         ++*ncommap;
 741: 
 742:         switch(p->opcode)
 743:             {
 744:             case OPCALL:
 745:             case OPCCALL:
 746:                 t = putcall(p);
 747:                 break;
 748: 
 749:             case OPCONCAT:
 750:                 t = mktemp(TYCHAR, cpexpr(p->vleng) );
 751:                 putcat( cpexpr(t), p );
 752:                 break;
 753: 
 754:             case OPCONV:
 755:                 if(!ISICON(p->vleng) || p->vleng->const.ci!=1
 756:                    || ! INT(p->leftp->vtype) )
 757:                     fatal("putch1: bad character conversion");
 758:                 t = mktemp(TYCHAR, ICON(1) );
 759:                 putop( mkexpr(OPASSIGN, cpexpr(t), p) );
 760:                 break;
 761:             default:
 762:                 fatal1("putch1: invalid opcode %d", p->opcode);
 763:             }
 764:         return(t);
 765: 
 766:     default:
 767:         fatal1("putch1: bad tag %d", p->tag);
 768:     }
 769: /* NOTREACHED */
 770: }
 771: 
 772: 
 773: 
 774: 
 775: LOCAL putchop(p)
 776: expptr p;
 777: {
 778: int ncomma;
 779: 
 780: ncomma = 0;
 781: putaddr( putch1(p, &ncomma) , NO );
 782: putcomma(ncomma, TYCHAR, YES);
 783: }
 784: 
 785: 
 786: 
 787: 
 788: LOCAL putcheq(p)
 789: register struct exprblock *p;
 790: {
 791: int ncomma;
 792: 
 793: ncomma = 0;
 794: if( p->rightp->tag==TEXPR && p->rightp->opcode==OPCONCAT )
 795:     putcat(p->leftp, p->rightp);
 796: else if( ISONE(p->leftp->vleng) && ISONE(p->rightp->vleng) )
 797:     {
 798:     putaddr( putch1(p->leftp, &ncomma) , YES );
 799:     putaddr( putch1(p->rightp, &ncomma) , YES );
 800:     putcomma(ncomma, TYINT, NO);
 801:     p2op(P2ASSIGN, P2CHAR);
 802:     }
 803: else
 804:     {
 805:     putx( call2(TYINT, "s_copy", p->leftp, p->rightp) );
 806:     putcomma(ncomma, TYINT, NO);
 807:     }
 808: 
 809: frexpr(p->vleng);
 810: free(p);
 811: }
 812: 
 813: 
 814: 
 815: 
 816: LOCAL putchcmp(p)
 817: register struct exprblock *p;
 818: {
 819: int ncomma;
 820: 
 821: ncomma = 0;
 822: if(ISONE(p->leftp->vleng) && ISONE(p->rightp->vleng) )
 823:     {
 824:     putaddr( putch1(p->leftp, &ncomma) , YES );
 825:     putaddr( putch1(p->rightp, &ncomma) , YES );
 826:     p2op(ops2[p->opcode], P2CHAR);
 827:     free(p);
 828:     putcomma(ncomma, TYINT, NO);
 829:     }
 830: else
 831:     {
 832:     p->leftp = call2(TYINT,"s_cmp", p->leftp, p->rightp);
 833:     p->rightp = ICON(0);
 834:     putop(p);
 835:     }
 836: }
 837: 
 838: 
 839: 
 840: 
 841: 
 842: LOCAL putcat(lhs, rhs)
 843: register struct addrblock *lhs;
 844: register expptr rhs;
 845: {
 846: int n, ncomma;
 847: struct addrblock *lp, *cp;
 848: 
 849: ncomma = 0;
 850: n = ncat(rhs);
 851: lp = mktmpn(n, TYLENG, NULL);
 852: cp = mktmpn(n, TYADDR, NULL);
 853: 
 854: n = 0;
 855: putct1(rhs, lp, cp, &n, &ncomma);
 856: 
 857: putx( call4(TYSUBR, "s_cat", lhs, cp, lp, ICON(n) ) );
 858: putcomma(ncomma, TYINT, NO);
 859: }
 860: 
 861: 
 862: 
 863: 
 864: 
 865: LOCAL ncat(p)
 866: register expptr p;
 867: {
 868: if(p->tag==TEXPR && p->opcode==OPCONCAT)
 869:     return( ncat(p->leftp) + ncat(p->rightp) );
 870: else    return(1);
 871: }
 872: 
 873: 
 874: 
 875: 
 876: LOCAL putct1(q, lp, cp, ip, ncommap)
 877: register expptr q;
 878: register struct addrblock *lp, *cp;
 879: int *ip, *ncommap;
 880: {
 881: int i;
 882: struct addrblock *lp1, *cp1;
 883: 
 884: if(q->tag==TEXPR && q->opcode==OPCONCAT)
 885:     {
 886:     putct1(q->leftp, lp, cp, ip, ncommap);
 887:     putct1(q->rightp, lp, cp , ip, ncommap);
 888:     frexpr(q->vleng);
 889:     free(q);
 890:     }
 891: else
 892:     {
 893:     i = (*ip)++;
 894:     lp1 = cpexpr(lp);
 895:     lp1->memoffset = mkexpr(OPPLUS, lp1->memoffset, ICON(i*SZLENG));
 896:     cp1 = cpexpr(cp);
 897:     cp1->memoffset = mkexpr(OPPLUS, cp1->memoffset, ICON(i*SZADDR));
 898:     putassign( lp1, cpexpr(q->vleng) );
 899:     putassign( cp1, addrof(putch1(q,ncommap)) );
 900:     *ncommap += 2;
 901:     }
 902: }
 903: 
 904: LOCAL putaddr(p, indir)
 905: register struct addrblock *p;
 906: int indir;
 907: {
 908: int type, type2, funct;
 909: ftnint offset, simoffset();
 910: expptr offp, shorten();
 911: 
 912: type = p->vtype;
 913: type2 = types2[type];
 914: funct = (p->vclass==CLPROC ? P2FUNCT<<2 : 0);
 915: 
 916: offp = (p->memoffset ? cpexpr(p->memoffset) : NULL);
 917: 
 918: 
 919: #if (FUDGEOFFSET != 1)
 920: if(offp)
 921:     offp = mkexpr(OPSTAR, ICON(FUDGEOFFSET), offp);
 922: #endif
 923: 
 924: offset = simoffset( &offp );
 925: #if SZINT < SZLONG
 926:     if(offp)
 927:         if(shortsubs)
 928:             offp = shorten(offp);
 929:         else
 930:             offp = mkconv(TYINT, offp);
 931: #else
 932:     if(offp)
 933:         offp = mkconv(TYINT, offp);
 934: #endif
 935: 
 936: switch(p->vstg)
 937:     {
 938:     case STGAUTO:
 939:         if(indir && !offp)
 940:             {
 941:             p2oreg(offset, AUTOREG, type2);
 942:             break;
 943:             }
 944: 
 945:         if(!indir && !offp && !offset)
 946:             {
 947:             p2reg(AUTOREG, type2 | P2PTR);
 948:             break;
 949:             }
 950: 
 951:         p2reg(AUTOREG, type2 | P2PTR);
 952:         if(offp)
 953:             {
 954:             putx(offp);
 955:             if(offset)
 956:                 p2icon(offset, P2INT);
 957:             }
 958:         else
 959:             p2icon(offset, P2INT);
 960:         if(offp && offset)
 961:             p2op(P2PLUS, type2 | P2PTR);
 962:         p2op(P2PLUS, type2 | P2PTR);
 963:         if(indir)
 964:             p2op(P2INDIRECT, type2);
 965:         break;
 966: 
 967:     case STGARG:
 968:         p2oreg(
 969: #ifdef ARGOFFSET
 970:             ARGOFFSET +
 971: #endif
 972:             (ftnint) (FUDGEOFFSET*p->memno),
 973:             ARGREG,   type2 | P2PTR | funct );
 974: 
 975:         if(offp)
 976:             putx(offp);
 977:         if(offset)
 978:             p2icon(offset, P2INT);
 979:         if(offp && offset)
 980:             p2op(P2PLUS, type2 | P2PTR);
 981:         if(offp || offset)
 982:             p2op(P2PLUS, type2 | P2PTR);
 983:         if(indir)
 984:             p2op(P2INDIRECT, type2);
 985:         break;
 986: 
 987:     case STGLENG:
 988:         if(indir)
 989:             {
 990:             p2oreg(
 991: #ifdef ARGOFFSET
 992:                 ARGOFFSET +
 993: #endif
 994:                 (ftnint) (FUDGEOFFSET*p->memno),
 995:                 ARGREG,   type2 | P2PTR );
 996:             }
 997:         else    {
 998:             p2reg(ARGREG, type2 | P2PTR );
 999:             p2icon(
1000: #ifdef ARGOFFSET
1001:                 ARGOFFSET +
1002: #endif
1003:                 (ftnint) (FUDGEOFFSET*p->memno), P2INT);
1004:             p2op(P2PLUS, type2 | P2PTR );
1005:             }
1006:         break;
1007: 
1008: 
1009:     case STGBSS:
1010:     case STGINIT:
1011:     case STGEXT:
1012:     case STGCOMMON:
1013:     case STGEQUIV:
1014:     case STGCONST:
1015:         if(offp)
1016:             {
1017:             putx(offp);
1018:             putmem(p, P2ICON, offset);
1019:             p2op(P2PLUS, type2 | P2PTR);
1020:             if(indir)
1021:                 p2op(P2INDIRECT, type2);
1022:             }
1023:         else
1024:             putmem(p, (indir ? P2NAME : P2ICON), offset);
1025: 
1026:         break;
1027: 
1028:     case STGREG:
1029:         if(indir)
1030:             p2reg(p->memno, type2);
1031:         else
1032:             fatal("attempt to take address of a register");
1033:         break;
1034: 
1035:     default:
1036:         fatal1("putaddr: invalid vstg %d", p->vstg);
1037:     }
1038: frexpr(p);
1039: }
1040: 
1041: 
1042: 
1043: 
1044: LOCAL putmem(p, class, offset)
1045: expptr p;
1046: int class;
1047: ftnint offset;
1048: {
1049: int type2;
1050: int funct;
1051: char *name,  *memname();
1052: 
1053: funct = (p->vclass==CLPROC ? P2FUNCT<<2 : 0);
1054: type2 = types2[p->vtype];
1055: if(p->vclass == CLPROC)
1056:     type2 |= (P2FUNCT<<2);
1057: name = memname(p->vstg, p->memno);
1058: if(class == P2ICON)
1059:     {
1060:     p2triple(P2ICON, name[0]!='\0', type2|P2PTR);
1061:     p2word(offset);
1062:     if(name[0])
1063:         p2name(name);
1064:     }
1065: else
1066:     {
1067:     p2triple(P2NAME, offset!=0, type2);
1068:     if(offset != 0)
1069:         p2word(offset);
1070:     p2name(name);
1071:     }
1072: }
1073: 
1074: 
1075: 
1076: LOCAL struct addrblock *putcall(p)
1077: struct exprblock *p;
1078: {
1079: chainp arglist, charsp, cp;
1080: int n, first;
1081: struct addrblock *t;
1082: struct exprblock *q;
1083: struct exprblock *fval;
1084: int type, type2, ctype, indir;
1085: 
1086: type2 = types2[type = p->vtype];
1087: charsp = NULL;
1088: indir =  (p->opcode == OPCCALL);
1089: n = 0;
1090: first = YES;
1091: 
1092: if(p->rightp)
1093:     {
1094:     arglist = p->rightp->listp;
1095:     free(p->rightp);
1096:     }
1097: else
1098:     arglist = NULL;
1099: 
1100: for(cp = arglist ; cp ; cp = cp->nextp)
1101:     if(indir)
1102:         ++n;
1103:     else    {
1104:         q = cp->datap;
1105:         if(q->tag == TCONST)
1106:             cp->datap = q = putconst(q);
1107:         if( ISCHAR(q) )
1108:             {
1109:             charsp = hookup(charsp, mkchain(cpexpr(q->vleng), 0) );
1110:             n += 2;
1111:             }
1112:         else if(q->vclass == CLPROC)
1113:             {
1114:             charsp = hookup(charsp, mkchain( ICON(0) , 0));
1115:             n += 2;
1116:             }
1117:         else
1118:             n += 1;
1119:         }
1120: 
1121: if(type == TYCHAR)
1122:     {
1123:     if( ISICON(p->vleng) )
1124:         {
1125:         fval = mktemp(TYCHAR, p->vleng);
1126:         n += 2;
1127:         }
1128:     else    {
1129:         err("adjustable character function");
1130:         return;
1131:         }
1132:     }
1133: else if( ISCOMPLEX(type) )
1134:     {
1135:     fval = mktemp(type, NULL);
1136:     n += 1;
1137:     }
1138: else
1139:     fval = NULL;
1140: 
1141: ctype = (fval ? P2INT : type2);
1142: putaddr(p->leftp, NO);
1143: 
1144: if(fval)
1145:     {
1146:     first = NO;
1147:     putaddr( cpexpr(fval), NO);
1148:     if(type==TYCHAR)
1149:         {
1150:         putx( mkconv(TYLENG,p->vleng) );
1151:         p2op(P2LISTOP, type2);
1152:         }
1153:     }
1154: 
1155: for(cp = arglist ; cp ; cp = cp->nextp)
1156:     {
1157:     q = cp->datap;
1158:     if(q->tag==TADDR && (indir || q->vstg!=STGREG) )
1159:         putaddr(q, indir && q->vtype!=TYCHAR);
1160:     else if( ISCOMPLEX(q->vtype) )
1161:         putcxop(q);
1162:     else if (ISCHAR(q) )
1163:         putchop(q);
1164:     else if( ! ISERROR(q) )
1165:         {
1166:         if(indir)
1167:             putx(q);
1168:         else    {
1169:             t = mktemp(q->vtype, q->vleng);
1170:             putassign( cpexpr(t), q );
1171:             putaddr(t, NO);
1172:             putcomma(1, q->vtype, YES);
1173:             }
1174:         }
1175:     if(first)
1176:         first = NO;
1177:     else
1178:         p2op(P2LISTOP, type2);
1179:     }
1180: 
1181: if(arglist)
1182:     frchain(&arglist);
1183: for(cp = charsp ; cp ; cp = cp->nextp)
1184:     {
1185:     putx( mkconv(TYLENG,cp->datap) );
1186:     p2op(P2LISTOP, type2);
1187:     }
1188: frchain(&charsp);
1189: p2op(n>0 ? P2CALL : P2CALL0 , ctype);
1190: free(p);
1191: return(fval);
1192: }
1193: 
1194: 
1195: 
1196: LOCAL putmnmx(p)
1197: register struct exprblock *p;
1198: {
1199: int op, type;
1200: int ncomma;
1201: struct exprblock *qp;
1202: chainp p0, p1;
1203: struct addrblock *sp, *tp;
1204: 
1205: type = p->vtype;
1206: op = (p->opcode==OPMIN ? OPLT : OPGT );
1207: p0 = p->leftp->listp;
1208: free(p->leftp);
1209: free(p);
1210: 
1211: sp = mktemp(type, NULL);
1212: tp = mktemp(type, NULL);
1213: qp = mkexpr(OPCOLON, cpexpr(tp), cpexpr(sp));
1214: qp = mkexpr(OPQUEST, mkexpr(op, cpexpr(tp),cpexpr(sp)), qp);
1215: qp = fixexpr(qp);
1216: 
1217: ncomma = 1;
1218: putassign( cpexpr(sp), p0->datap );
1219: 
1220: for(p1 = p0->nextp ; p1 ; p1 = p1->nextp)
1221:     {
1222:     ++ncomma;
1223:     putassign( cpexpr(tp), p1->datap );
1224:     if(p1->nextp)
1225:         {
1226:         ++ncomma;
1227:         putassign( cpexpr(sp), cpexpr(qp) );
1228:         }
1229:     else
1230:         putx(qp);
1231:     }
1232: 
1233: putcomma(ncomma, type, NO);
1234: frtemp(sp);
1235: frtemp(tp);
1236: frchain( &p0 );
1237: }
1238: 
1239: 
1240: 
1241: 
1242: LOCAL putcomma(n, type, indir)
1243: int n, type, indir;
1244: {
1245: type = types2[type];
1246: if(indir)
1247:     type |= P2PTR;
1248: while(--n >= 0)
1249:     p2op(P2COMOP, type);
1250: }
1251: 
1252: 
1253: 
1254: 
1255: ftnint simoffset(p0)
1256: expptr *p0;
1257: {
1258: ftnint offset, prod;
1259: register expptr p, lp, rp;
1260: 
1261: offset = 0;
1262: p = *p0;
1263: if(p == NULL)
1264:     return(0);
1265: 
1266: if( ! ISINT(p->vtype) )
1267:     return(0);
1268: 
1269: if(p->tag==TEXPR && p->opcode==OPSTAR)
1270:     {
1271:     lp = p->leftp;
1272:     rp = p->rightp;
1273:     if(ISICON(rp) && lp->tag==TEXPR && lp->opcode==OPPLUS && ISICON(lp->rightp))
1274:         {
1275:         p->opcode = OPPLUS;
1276:         lp->opcode = OPSTAR;
1277:         prod = rp->const.ci * lp->rightp->const.ci;
1278:         lp->rightp->const.ci = rp->const.ci;
1279:         rp->const.ci = prod;
1280:         }
1281:     }
1282: 
1283: if(p->tag==TEXPR && p->opcode==OPPLUS && ISICON(p->rightp))
1284:     {
1285:     rp = p->rightp;
1286:     lp = p->leftp;
1287:     offset += rp->const.ci;
1288:     frexpr(rp);
1289:     free(p);
1290:     *p0 = lp;
1291:     }
1292: 
1293: if(p->tag == TCONST)
1294:     {
1295:     offset += p->const.ci;
1296:     frexpr(p);
1297:     *p0 = NULL;
1298:     }
1299: 
1300: return(offset);
1301: }
1302: 
1303: 
1304: 
1305: 
1306: 
1307: p2op(op, type)
1308: int op, type;
1309: {
1310: p2triple(op, 0, type);
1311: }
1312: 
1313: p2icon(offset, type)
1314: ftnint offset;
1315: int type;
1316: {
1317: p2triple(P2ICON, 0, type);
1318: p2word(offset);
1319: }
1320: 
1321: 
1322: 
1323: 
1324: p2oreg(offset, reg, type)
1325: ftnint offset;
1326: int reg, type;
1327: {
1328: p2triple(P2OREG, reg, type);
1329: p2word(offset);
1330: p2name("");
1331: }
1332: 
1333: 
1334: 
1335: 
1336: p2reg(reg, type)
1337: int reg, type;
1338: {
1339: p2triple(P2REG, reg, type);
1340: }
1341: 
1342: 
1343: 
1344: p2pass(s)
1345: char *s;
1346: {
1347: p2triple(P2PASS, (strlen(s) + FOUR-1)/FOUR, 0);
1348: p2str(s);
1349: }
1350: 
1351: 
1352: 
1353: 
1354: p2str(s)
1355: register char *s;
1356: {
1357: union { long int word; char str[FOUR]; } u;
1358: register int i;
1359: 
1360: i = 0;
1361: u.word = 0;
1362: while(*s)
1363:     {
1364:     u.str[i++] = *s++;
1365:     if(i == FOUR)
1366:         {
1367:         p2word(u.word);
1368:         u.word = 0;
1369:         i = 0;
1370:         }
1371:     }
1372: if(i > 0)
1373:     p2word(u.word);
1374: }
1375: 
1376: 
1377: 
1378: 
1379: p2triple(op, var, type)
1380: int op, var, type;
1381: {
1382: register long word;
1383: word = op | (var<<8);
1384: word |= ( (long int) type) <<16;
1385: p2word(word);
1386: }
1387: 
1388: 
1389: 
1390: 
1391: p2name(s)
1392: char *s;
1393: {
1394: int i;
1395: union  { long int word[2];  char str[8]; } u;
1396: 
1397: u.word[0] = u.word[1] = 0;
1398: for(i = 0 ; i<8 && *s ; ++i)
1399:     u.str[i] = *s++;
1400: p2word(u.word[0]);
1401: p2word(u.word[1]);
1402: }
1403: 
1404: 
1405: 
1406: 
1407: p2word(w)
1408: long int w;
1409: {
1410: *p2bufp++ = w;
1411: if(p2bufp >= p2bufend)
1412:     p2flush();
1413: }
1414: 
1415: 
1416: 
1417: p2flush()
1418: {
1419: if(p2bufp > p2buff)
1420:     write(fileno(textfile), p2buff, (p2bufp-p2buff)*sizeof(long int));
1421: p2bufp = p2buff;
1422: }

Defined functions

Defined variables

Defined macros