4.3BSD - /usr/src/usr.bin/f77/src/f77pass1/putpcc.c

   1: /*
   2:  * Copyright (c) 1980 Regents of the University of California.
   3:  * All rights reserved.  The Berkeley software License Agreement
   4:  * specifies the terms and conditions for redistribution.
   5:  */
   6: 
   7: #ifndef lint
   8: static char sccsid[] = "@(#)putpcc.c	5.2 (Berkeley) 3/9/86";
   9: #endif not lint
  10: 
  11: /*
  12:  * putpcc.c
  13:  *
  14:  * Intermediate code generation for S. C. Johnson C compilers
  15:  * New version using binary polish postfix intermediate
  16:  *
  17:  * University of Utah CS Dept modification history:
  18:  *
  19:  * $Header: putpcc.c,v 5.2 86/03/04 17:49:38 donn Exp $
  20:  * $Log:	putpcc.c,v $
  21:  * Revision 5.2  86/03/04  17:49:38  donn
  22:  * Change putct1() to emit the memoffset before the vleng -- the memoffset
  23:  * may define a temporary which is used by the vleng to avoid repeated
  24:  * evaluation of an expression with side effects.
  25:  *
  26:  * Revision 5.1  85/08/10  03:49:26  donn
  27:  * 4.3 alpha
  28:  *
  29:  * Revision 3.2  85/03/25  09:35:57  root
  30:  * fseek return -1 on error.
  31:  *
  32:  * Revision 3.1  85/02/27  19:06:55  donn
  33:  * Changed to use pcc.h instead of pccdefs.h.
  34:  *
  35:  * Revision 2.12  85/02/22  01:05:54  donn
  36:  * putaddr() didn't know about intrinsic functions...
  37:  *
  38:  * Revision 2.11  84/11/28  21:28:49  donn
  39:  * Hacked putop() to handle any character expression being converted to int,
  40:  * not just function calls.  Previously it bombed on concatenations.
  41:  *
  42:  * Revision 2.10  84/11/01  22:07:07  donn
  43:  * Yet another try at getting putop() to work right.  It appears that the
  44:  * second pass can't abide certain explicit conversions (e.g. short to long)
  45:  * so the conversion code in putop() tries to remove them.  I think this
  46:  * version (finally) works.
  47:  *
  48:  * Revision 2.9  84/10/29  02:30:57  donn
  49:  * Earlier fix to putop() for conversions was insufficient -- we NEVER want to
  50:  * see the type of the left operand of the thing left over from stripping off
  51:  * conversions...
  52:  *
  53:  * Revision 2.8  84/09/18  03:09:21  donn
  54:  * Fixed bug in putop() where the left operand of an addrblock was being
  55:  * extracted...  This caused an extremely obscure conversion error when
  56:  * an array of longs was subscripted by a short.
  57:  *
  58:  * Revision 2.7  84/08/19  20:10:19  donn
  59:  * Removed stuff in putbranch that treats STGARG parameters specially -- the
  60:  * bug in the code generation pass that motivated it has been fixed.
  61:  *
  62:  * Revision 2.6  84/08/07  21:32:23  donn
  63:  * Bumped the size of the buffer for the intermediate code file from 0.5K
  64:  * to 4K on a VAX.
  65:  *
  66:  * Revision 2.5  84/08/04  20:26:43  donn
  67:  * Fixed a goof in the new putbranch() -- it now calls mkaltemp instead of
  68:  * mktemp().  Correction due to Jerry Berkman.
  69:  *
  70:  * Revision 2.4  84/07/24  19:07:15  donn
  71:  * Fixed bug reported by Craig Leres in which putmnmx() mistakenly assumed
  72:  * that mkaltemp() returns tempblocks, and tried to free them with frtemp().
  73:  *
  74:  * Revision 2.3  84/07/19  17:22:09  donn
  75:  * Changed putch1() so that OPPAREN expressions of type CHARACTER are legal.
  76:  *
  77:  * Revision 2.2  84/07/19  12:30:38  donn
  78:  * Fixed a type clash in Bob Corbett's new putbranch().
  79:  *
  80:  * Revision 2.1  84/07/19  12:04:27  donn
  81:  * Changed comment headers for UofU.
  82:  *
  83:  * Revision 1.8  84/07/19  11:38:23  donn
  84:  * Replaced putbranch() routine so that you can ASSIGN into argument variables.
  85:  * The code is from Bob Corbett, donated by Jerry Berkman.
  86:  *
  87:  * Revision 1.7  84/05/31  00:48:32  donn
  88:  * Fixed an extremely obscure bug dealing with the comparison of CHARACTER*1
  89:  * expressions -- a foulup in the order of COMOP and the comparison caused
  90:  * one operand of the comparison to be garbage.
  91:  *
  92:  * Revision 1.6  84/04/16  09:54:19  donn
  93:  * Backed out earlier fix for bug where items in the argtemplist were
  94:  * (incorrectly) being given away; this is now fixed in mkargtemp().
  95:  *
  96:  * Revision 1.5  84/03/23  22:49:48  donn
  97:  * Took out the initialization of the subroutine argument temporary list in
  98:  * putcall() -- it needs to be done once per statement instead of once per call.
  99:  *
 100:  * Revision 1.4  84/03/01  06:48:05  donn
 101:  * Fixed bug in Bob Corbett's code for argument temporaries that caused an
 102:  * addrblock to get thrown out inadvertently when it was needed for recycling
 103:  * purposes later on.
 104:  *
 105:  * Revision 1.3  84/02/26  06:32:38  donn
 106:  * Added Berkeley changes to move data definitions around and reduce offsets.
 107:  *
 108:  * Revision 1.2  84/02/26  06:27:45  donn
 109:  * Added code to catch TTEMP values passed to putx().
 110:  *
 111:  */
 112: 
 113: #if FAMILY != PCC
 114:     WRONG put FILE !!!!
 115: #endif
 116: 
 117: #include "defs.h"
 118: #include <pcc.h>
 119: 
 120: Addrp putcall(), putcxeq(), putcx1(), realpart();
 121: expptr imagpart();
 122: ftnint lencat();
 123: 
 124: #define FOUR 4
 125: extern int ops2[];
 126: extern int types2[];
 127: 
 128: #if HERE==VAX
 129: #define PCC_BUFFMAX 1024
 130: #else
 131: #define PCC_BUFFMAX 128
 132: #endif
 133: static long int p2buff[PCC_BUFFMAX];
 134: static long int *p2bufp     = &p2buff[0];
 135: static long int *p2bufend   = &p2buff[PCC_BUFFMAX];
 136: 
 137: 
 138: puthead(s, class)
 139: char *s;
 140: int class;
 141: {
 142: char buff[100];
 143: #if TARGET == VAX
 144:     if(s)
 145:         p2ps("\t.globl\t_%s", s);
 146: #endif
 147: /* put out fake copy of left bracket line, to be redone later */
 148: if( ! headerdone )
 149:     {
 150: #if FAMILY == PCC
 151:     p2flush();
 152: #endif
 153:     headoffset = ftell(textfile);
 154:     prhead(textfile);
 155:     headerdone = YES;
 156:     p2triple(PCCF_FEXPR, (strlen(infname)+FOUR-1)/FOUR, 0);
 157:     p2str(infname);
 158: #if TARGET == PDP11
 159:     /* fake jump to start the optimizer */
 160:     if(class != CLBLOCK)
 161:         putgoto( fudgelabel = newlabel() );
 162: #endif
 163: 
 164: #if TARGET == VAX
 165:     /* jump from top to bottom */
 166:     if(s!=CNULL && class!=CLBLOCK)
 167:         {
 168:         int proflab = newlabel();
 169:         p2ps("_%s:", s);
 170:         p2pi("\t.word\tLWM%d", procno);
 171:         prsave(proflab);
 172:         p2pi("\tjbr\tL%d", fudgelabel = newlabel());
 173:         }
 174: #endif
 175:     }
 176: }
 177: 
 178: 
 179: 
 180: 
 181: 
 182: /* It is necessary to precede each procedure with a "left bracket"
 183:  * line that tells pass 2 how many register variables and how
 184:  * much automatic space is required for the function.  This compiler
 185:  * does not know how much automatic space is needed until the
 186:  * entire procedure has been processed.  Therefore, "puthead"
 187:  * is called at the begining to record the current location in textfile,
 188:  * then to put out a placeholder left bracket line.  This procedure
 189:  * repositions the file and rewrites that line, then puts the
 190:  * file pointer back to the end of the file.
 191:  */
 192: 
 193: putbracket()
 194: {
 195: long int hereoffset;
 196: 
 197: #if FAMILY == PCC
 198:     p2flush();
 199: #endif
 200: hereoffset = ftell(textfile);
 201: if(fseek(textfile, headoffset, 0) == -1)
 202:     fatal("fseek failed");
 203: prhead(textfile);
 204: if(fseek(textfile, hereoffset, 0) == -1)
 205:     fatal("fseek failed 2");
 206: }
 207: 
 208: 
 209: 
 210: 
 211: putrbrack(k)
 212: int k;
 213: {
 214: p2op(PCCF_FRBRAC, k);
 215: }
 216: 
 217: 
 218: 
 219: putnreg()
 220: {
 221: }
 222: 
 223: 
 224: 
 225: 
 226: 
 227: 
 228: puteof()
 229: {
 230: p2op(PCCF_FEOF, 0);
 231: p2flush();
 232: }
 233: 
 234: 
 235: 
 236: putstmt()
 237: {
 238: p2triple(PCCF_FEXPR, 0, lineno);
 239: }
 240: 
 241: 
 242: 
 243: 
 244: /* put out code for if( ! p) goto l  */
 245: putif(p,l)
 246: register expptr p;
 247: int l;
 248: {
 249: register int k;
 250: 
 251: if( ( k = (p = fixtype(p))->headblock.vtype) != TYLOGICAL)
 252:     {
 253:     if(k != TYERROR)
 254:         err("non-logical expression in IF statement");
 255:     frexpr(p);
 256:     }
 257: else
 258:     {
 259:     putex1(p);
 260:     p2icon( (long int) l , PCCT_INT);
 261:     p2op(PCC_CBRANCH, 0);
 262:     putstmt();
 263:     }
 264: }
 265: 
 266: 
 267: 
 268: 
 269: 
 270: /* put out code for  goto l   */
 271: putgoto(label)
 272: int label;
 273: {
 274: p2triple(PCC_GOTO, 1, label);
 275: putstmt();
 276: }
 277: 
 278: 
 279: /* branch to address constant or integer variable */
 280: putbranch(p)
 281: register Addrp p;
 282: {
 283:   putex1((expptr) p);
 284:   p2op(PCC_GOTO, PCCT_INT);
 285:   putstmt();
 286: }
 287: 
 288: 
 289: 
 290: /* put out label  l:     */
 291: putlabel(label)
 292: int label;
 293: {
 294: p2op(PCCF_FLABEL, label);
 295: }
 296: 
 297: 
 298: 
 299: 
 300: putexpr(p)
 301: expptr p;
 302: {
 303: putex1(p);
 304: putstmt();
 305: }
 306: 
 307: 
 308: 
 309: 
 310: putcmgo(index, nlab, labs)
 311: expptr index;
 312: int nlab;
 313: struct Labelblock *labs[];
 314: {
 315: int i, labarray, skiplabel;
 316: 
 317: if(! ISINT(index->headblock.vtype) )
 318:     {
 319:     execerr("computed goto index must be integer", CNULL);
 320:     return;
 321:     }
 322: 
 323: #if TARGET == VAX
 324:     /* use special case instruction */
 325:     vaxgoto(index, nlab, labs);
 326: #else
 327:     labarray = newlabel();
 328:     preven(ALIADDR);
 329:     prlabel(asmfile, labarray);
 330:     prcona(asmfile, (ftnint) (skiplabel = newlabel()) );
 331:     for(i = 0 ; i < nlab ; ++i)
 332:         if( labs[i] )
 333:             prcona(asmfile, (ftnint)(labs[i]->labelno) );
 334:     prcmgoto(index, nlab, skiplabel, labarray);
 335:     putlabel(skiplabel);
 336: #endif
 337: }
 338: 
 339: putx(p)
 340: expptr p;
 341: {
 342: char *memname();
 343: int opc;
 344: int ncomma;
 345: int type, k;
 346: 
 347: if (!p)
 348:     return;
 349: 
 350: switch(p->tag)
 351:     {
 352:     case TERROR:
 353:         free( (charptr) p );
 354:         break;
 355: 
 356:     case TCONST:
 357:         switch(type = p->constblock.vtype)
 358:             {
 359:             case TYLOGICAL:
 360:                 type = tyint;
 361:             case TYLONG:
 362:             case TYSHORT:
 363:                 p2icon(p->constblock.const.ci, types2[type]);
 364:                 free( (charptr) p );
 365:                 break;
 366: 
 367:             case TYADDR:
 368:                 p2triple(PCC_ICON, 1, PCCT_INT|PCCTM_PTR);
 369:                 p2word(0L);
 370:                 p2name(memname(STGCONST,
 371:                     (int) p->constblock.const.ci) );
 372:                 free( (charptr) p );
 373:                 break;
 374: 
 375:             default:
 376:                 putx( putconst(p) );
 377:                 break;
 378:             }
 379:         break;
 380: 
 381:     case TEXPR:
 382:         switch(opc = p->exprblock.opcode)
 383:             {
 384:             case OPCALL:
 385:             case OPCCALL:
 386:                 if( ISCOMPLEX(p->exprblock.vtype) )
 387:                     putcxop(p);
 388:                 else    putcall(p);
 389:                 break;
 390: 
 391:             case OPMIN:
 392:             case OPMAX:
 393:                 putmnmx(p);
 394:                 break;
 395: 
 396: 
 397:             case OPASSIGN:
 398:                 if(ISCOMPLEX(p->exprblock.leftp->headblock.vtype)
 399:                 || ISCOMPLEX(p->exprblock.rightp->headblock.vtype) )
 400:                     frexpr( putcxeq(p) );
 401:                 else if( ISCHAR(p) )
 402:                     putcheq(p);
 403:                 else
 404:                     goto putopp;
 405:                 break;
 406: 
 407:             case OPEQ:
 408:             case OPNE:
 409:                 if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) ||
 410:                     ISCOMPLEX(p->exprblock.rightp->headblock.vtype) )
 411:                     {
 412:                     putcxcmp(p);
 413:                     break;
 414:                     }
 415:             case OPLT:
 416:             case OPLE:
 417:             case OPGT:
 418:             case OPGE:
 419:                 if(ISCHAR(p->exprblock.leftp))
 420:                     {
 421:                     putchcmp(p);
 422:                     break;
 423:                     }
 424:                 goto putopp;
 425: 
 426:             case OPPOWER:
 427:                 putpower(p);
 428:                 break;
 429: 
 430:             case OPSTAR:
 431: #if FAMILY == PCC
 432:                 /*   m * (2**k) -> m<<k   */
 433:                 if(INT(p->exprblock.leftp->headblock.vtype) &&
 434:                    ISICON(p->exprblock.rightp) &&
 435:                    ( (k = log2(p->exprblock.rightp->constblock.const.ci))>0) )
 436:                     {
 437:                     p->exprblock.opcode = OPLSHIFT;
 438:                     frexpr(p->exprblock.rightp);
 439:                     p->exprblock.rightp = ICON(k);
 440:                     goto putopp;
 441:                     }
 442: #endif
 443: 
 444:             case OPMOD:
 445:                 goto putopp;
 446:             case OPPLUS:
 447:             case OPMINUS:
 448:             case OPSLASH:
 449:             case OPNEG:
 450:                 if( ISCOMPLEX(p->exprblock.vtype) )
 451:                     putcxop(p);
 452:                 else    goto putopp;
 453:                 break;
 454: 
 455:             case OPCONV:
 456:                 if( ISCOMPLEX(p->exprblock.vtype) )
 457:                     putcxop(p);
 458:                 else if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) )
 459:                     {
 460:                     ncomma = 0;
 461:                     putx( mkconv(p->exprblock.vtype,
 462:                         realpart(putcx1(p->exprblock.leftp,
 463:                             &ncomma))));
 464:                     putcomma(ncomma, p->exprblock.vtype, NO);
 465:                     free( (charptr) p );
 466:                     }
 467:                 else    goto putopp;
 468:                 break;
 469: 
 470:             case OPNOT:
 471:             case OPOR:
 472:             case OPAND:
 473:             case OPEQV:
 474:             case OPNEQV:
 475:             case OPADDR:
 476:             case OPPLUSEQ:
 477:             case OPSTAREQ:
 478:             case OPCOMMA:
 479:             case OPQUEST:
 480:             case OPCOLON:
 481:             case OPBITOR:
 482:             case OPBITAND:
 483:             case OPBITXOR:
 484:             case OPBITNOT:
 485:             case OPLSHIFT:
 486:             case OPRSHIFT:
 487:         putopp:
 488:                 putop(p);
 489:                 break;
 490: 
 491:             case OPPAREN:
 492:                 putx (p->exprblock.leftp);
 493:                 break;
 494:             default:
 495:                 badop("putx", opc);
 496:             }
 497:         break;
 498: 
 499:     case TADDR:
 500:         putaddr(p, YES);
 501:         break;
 502: 
 503:     case TTEMP:
 504:         /*
 505: 		 * This type is sometimes passed to putx when errors occur
 506: 		 *	upstream, I don't know why.
 507: 		 */
 508:         frexpr(p);
 509:         break;
 510: 
 511:     default:
 512:         badtag("putx", p->tag);
 513:     }
 514: }
 515: 
 516: 
 517: 
 518: LOCAL putop(p)
 519: expptr p;
 520: {
 521: int k;
 522: expptr lp, tp;
 523: int pt, lt, tt;
 524: int comma;
 525: Addrp putch1();
 526: 
 527: switch(p->exprblock.opcode) /* check for special cases and rewrite */
 528:     {
 529:     case OPCONV:
 530:         tt = pt = p->exprblock.vtype;
 531:         lp = p->exprblock.leftp;
 532:         lt = lp->headblock.vtype;
 533:         if (pt == TYREAL && lt == TYDREAL)
 534:             {
 535:             putx(lp);
 536:             p2op(PCC_SCONV, PCCT_FLOAT);
 537:             return;
 538:             }
 539:         while(p->tag==TEXPR && p->exprblock.opcode==OPCONV &&
 540:               ( (ISREAL(pt)&&ISREAL(lt)) ||
 541:             (INT(pt)&&(ONEOF(lt,MSKINT|MSKADDR|MSKCHAR|M(TYSUBR)))) ))
 542:             {
 543: #if SZINT < SZLONG
 544:             if(lp->tag != TEXPR)
 545:                 {
 546:                 if(pt==TYINT && lt==TYLONG)
 547:                     break;
 548:                 if(lt==TYINT && pt==TYLONG)
 549:                     break;
 550:                 }
 551: #endif
 552: 
 553: #if TARGET == VAX
 554:             if(pt==TYDREAL && lt==TYREAL)
 555:                 {
 556:                 if(lp->tag==TEXPR &&
 557:                    lp->exprblock.opcode==OPCONV &&
 558:                    lp->exprblock.leftp->headblock.vtype==TYDREAL)
 559:                     {
 560:                     putx(lp->exprblock.leftp);
 561:                     p2op(PCC_SCONV, PCCT_FLOAT);
 562:                     p2op(PCC_SCONV, PCCT_DOUBLE);
 563:                     free( (charptr) p );
 564:                     return;
 565:                     }
 566:                 else break;
 567:                 }
 568: #endif
 569:             if(lt==TYCHAR && lp->tag==TEXPR)
 570:                 {
 571:                 int ncomma = 0;
 572:                 p->exprblock.leftp = (expptr) putch1(lp, &ncomma);
 573:                 putop(p);
 574:                 putcomma(ncomma, pt, NO);
 575:                 free( (charptr) p );
 576:                 return;
 577:                 }
 578:             free( (charptr) p );
 579:             p = lp;
 580:             pt = lt;
 581:             if (p->tag == TEXPR)
 582:                 {
 583:                 lp = p->exprblock.leftp;
 584:                 lt = lp->headblock.vtype;
 585:                 }
 586:             }
 587:         if(p->tag==TEXPR && p->exprblock.opcode==OPCONV)
 588:             break;
 589:         putx(p);
 590:         if (types2[tt] != types2[pt] &&
 591:             ! ( (ISREAL(tt)&&ISREAL(pt)) ||
 592:             (INT(tt)&&(ONEOF(pt,MSKINT|MSKADDR|MSKCHAR|M(TYSUBR)))) ))
 593:             p2op(PCC_SCONV,types2[tt]);
 594:         return;
 595: 
 596:     case OPADDR:
 597:         comma = NO;
 598:         lp = p->exprblock.leftp;
 599:         if(lp->tag != TADDR)
 600:             {
 601:             tp = (expptr) mkaltemp
 602:                 (lp->headblock.vtype,lp->headblock.vleng);
 603:             putx( mkexpr(OPASSIGN, cpexpr(tp), lp) );
 604:             lp = tp;
 605:             comma = YES;
 606:             }
 607:         putaddr(lp, NO);
 608:         if(comma)
 609:             putcomma(1, TYINT, NO);
 610:         free( (charptr) p );
 611:         return;
 612: #if TARGET == VAX
 613: /* take advantage of a glitch in the code generator that does not check
 614:    the type clash in an assignment or comparison of an integer zero and
 615:    a floating left operand, and generates optimal code for the correct
 616:    type.  (The PCC has no floating-constant node to encode this correctly.)
 617: */
 618:     case OPASSIGN:
 619:     case OPLT:
 620:     case OPLE:
 621:     case OPGT:
 622:     case OPGE:
 623:     case OPEQ:
 624:     case OPNE:
 625:         if(ISREAL(p->exprblock.leftp->headblock.vtype) &&
 626:            ISREAL(p->exprblock.rightp->headblock.vtype) &&
 627:            ISCONST(p->exprblock.rightp) &&
 628:            p->exprblock.rightp->constblock.const.cd[0]==0)
 629:             {
 630:             p->exprblock.rightp->constblock.vtype = TYINT;
 631:             p->exprblock.rightp->constblock.const.ci = 0;
 632:             }
 633: #endif
 634:     }
 635: 
 636: if( (k = ops2[p->exprblock.opcode]) <= 0)
 637:     badop("putop", p->exprblock.opcode);
 638: putx(p->exprblock.leftp);
 639: if(p->exprblock.rightp)
 640:     putx(p->exprblock.rightp);
 641: p2op(k, types2[p->exprblock.vtype]);
 642: 
 643: if(p->exprblock.vleng)
 644:     frexpr(p->exprblock.vleng);
 645: free( (charptr) p );
 646: }
 647: 
 648: putforce(t, p)
 649: int t;
 650: expptr p;
 651: {
 652: p = mkconv(t, fixtype(p));
 653: putx(p);
 654: p2op(PCC_FORCE,
 655:     (t==TYSHORT ? PCCT_SHORT : (t==TYLONG ? PCCT_LONG : PCCT_DOUBLE)) );
 656: putstmt();
 657: }
 658: 
 659: 
 660: 
 661: LOCAL putpower(p)
 662: expptr p;
 663: {
 664: expptr base;
 665: Addrp t1, t2;
 666: ftnint k;
 667: int type;
 668: int ncomma;
 669: 
 670: if(!ISICON(p->exprblock.rightp) ||
 671:     (k = p->exprblock.rightp->constblock.const.ci)<2)
 672:     fatal("putpower: bad call");
 673: base = p->exprblock.leftp;
 674: type = base->headblock.vtype;
 675: 
 676: if ((k == 2) && base->tag == TADDR && ISCONST(base->addrblock.memoffset))
 677: {
 678:     putx( mkexpr(OPSTAR,cpexpr(base),cpexpr(base)));
 679: 
 680:     return;
 681: }
 682: t1 = mkaltemp(type, PNULL);
 683: t2 = NULL;
 684: ncomma = 1;
 685: putassign(cpexpr(t1), cpexpr(base) );
 686: 
 687: for( ; (k&1)==0 && k>2 ; k>>=1 )
 688:     {
 689:     ++ncomma;
 690:     putsteq(t1, t1);
 691:     }
 692: 
 693: if(k == 2)
 694:     putx( mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)) );
 695: else
 696:     {
 697:     t2 = mkaltemp(type, PNULL);
 698:     ++ncomma;
 699:     putassign(cpexpr(t2), cpexpr(t1));
 700: 
 701:     for(k>>=1 ; k>1 ; k>>=1)
 702:         {
 703:         ++ncomma;
 704:         putsteq(t1, t1);
 705:         if(k & 1)
 706:             {
 707:             ++ncomma;
 708:             putsteq(t2, t1);
 709:             }
 710:         }
 711:     putx( mkexpr(OPSTAR, cpexpr(t2),
 712:         mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)) ));
 713:     }
 714: putcomma(ncomma, type, NO);
 715: frexpr(t1);
 716: if(t2)
 717:     frexpr(t2);
 718: frexpr(p);
 719: }
 720: 
 721: 
 722: 
 723: 
 724: LOCAL Addrp intdouble(p, ncommap)
 725: Addrp p;
 726: int *ncommap;
 727: {
 728: register Addrp t;
 729: 
 730: t = mkaltemp(TYDREAL, PNULL);
 731: ++*ncommap;
 732: putassign(cpexpr(t), p);
 733: return(t);
 734: }
 735: 
 736: 
 737: 
 738: 
 739: 
 740: LOCAL Addrp putcxeq(p)
 741: register expptr p;
 742: {
 743: register Addrp lp, rp;
 744: int ncomma;
 745: 
 746: if(p->tag != TEXPR)
 747:     badtag("putcxeq", p->tag);
 748: 
 749: ncomma = 0;
 750: lp = putcx1(p->exprblock.leftp, &ncomma);
 751: rp = putcx1(p->exprblock.rightp, &ncomma);
 752: putassign(realpart(lp), realpart(rp));
 753: if( ISCOMPLEX(p->exprblock.vtype) )
 754:     {
 755:     ++ncomma;
 756:     putassign(imagpart(lp), imagpart(rp));
 757:     }
 758: putcomma(ncomma, TYREAL, NO);
 759: frexpr(rp);
 760: free( (charptr) p );
 761: return(lp);
 762: }
 763: 
 764: 
 765: 
 766: LOCAL putcxop(p)
 767: expptr p;
 768: {
 769: Addrp putcx1();
 770: int ncomma;
 771: 
 772: ncomma = 0;
 773: putaddr( putcx1(p, &ncomma), NO);
 774: putcomma(ncomma, TYINT, NO);
 775: }
 776: 
 777: 
 778: 
 779: LOCAL Addrp putcx1(p, ncommap)
 780: register expptr p;
 781: int *ncommap;
 782: {
 783: expptr q;
 784: Addrp lp, rp;
 785: register Addrp resp;
 786: int opcode;
 787: int ltype, rtype;
 788: expptr mkrealcon();
 789: 
 790: if(p == NULL)
 791:     return(NULL);
 792: 
 793: switch(p->tag)
 794:     {
 795:     case TCONST:
 796:         if( ISCOMPLEX(p->constblock.vtype) )
 797:             p = (expptr) putconst(p);
 798:         return( (Addrp) p );
 799: 
 800:     case TADDR:
 801:         if( ! addressable(p) )
 802:             {
 803:             ++*ncommap;
 804:             resp = mkaltemp(tyint, PNULL);
 805:             putassign( cpexpr(resp), p->addrblock.memoffset );
 806:             p->addrblock.memoffset = (expptr)resp;
 807:             }
 808:         return( (Addrp) p );
 809: 
 810:     case TEXPR:
 811:         if( ISCOMPLEX(p->exprblock.vtype) )
 812:             break;
 813:         ++*ncommap;
 814:         resp = mkaltemp(TYDREAL, NO);
 815:         putassign( cpexpr(resp), p);
 816:         return(resp);
 817: 
 818:     default:
 819:         badtag("putcx1", p->tag);
 820:     }
 821: 
 822: opcode = p->exprblock.opcode;
 823: if(opcode==OPCALL || opcode==OPCCALL)
 824:     {
 825:     ++*ncommap;
 826:     return( putcall(p) );
 827:     }
 828: else if(opcode == OPASSIGN)
 829:     {
 830:     ++*ncommap;
 831:     return( putcxeq(p) );
 832:     }
 833: resp = mkaltemp(p->exprblock.vtype, PNULL);
 834: if(lp = putcx1(p->exprblock.leftp, ncommap) )
 835:     ltype = lp->vtype;
 836: if(rp = putcx1(p->exprblock.rightp, ncommap) )
 837:     rtype = rp->vtype;
 838: 
 839: switch(opcode)
 840:     {
 841:     case OPPAREN:
 842:         frexpr (resp);
 843:         resp = lp;
 844:         lp = NULL;
 845:         break;
 846: 
 847:     case OPCOMMA:
 848:         frexpr(resp);
 849:         resp = rp;
 850:         rp = NULL;
 851:         break;
 852: 
 853:     case OPNEG:
 854:         putassign( realpart(resp), mkexpr(OPNEG, realpart(lp), ENULL) );
 855:         putassign( imagpart(resp), mkexpr(OPNEG, imagpart(lp), ENULL) );
 856:         *ncommap += 2;
 857:         break;
 858: 
 859:     case OPPLUS:
 860:     case OPMINUS:
 861:         putassign( realpart(resp),
 862:             mkexpr(opcode, realpart(lp), realpart(rp) ));
 863:         if(rtype < TYCOMPLEX)
 864:             putassign( imagpart(resp), imagpart(lp) );
 865:         else if(ltype < TYCOMPLEX)
 866:             {
 867:             if(opcode == OPPLUS)
 868:                 putassign( imagpart(resp), imagpart(rp) );
 869:             else    putassign( imagpart(resp),
 870:                     mkexpr(OPNEG, imagpart(rp), ENULL) );
 871:             }
 872:         else
 873:             putassign( imagpart(resp),
 874:                 mkexpr(opcode, imagpart(lp), imagpart(rp) ));
 875: 
 876:         *ncommap += 2;
 877:         break;
 878: 
 879:     case OPSTAR:
 880:         if(ltype < TYCOMPLEX)
 881:             {
 882:             if( ISINT(ltype) )
 883:                 lp = intdouble(lp, ncommap);
 884:             putassign( realpart(resp),
 885:                 mkexpr(OPSTAR, cpexpr(lp), realpart(rp) ));
 886:             putassign( imagpart(resp),
 887:                 mkexpr(OPSTAR, cpexpr(lp), imagpart(rp) ));
 888:             }
 889:         else if(rtype < TYCOMPLEX)
 890:             {
 891:             if( ISINT(rtype) )
 892:                 rp = intdouble(rp, ncommap);
 893:             putassign( realpart(resp),
 894:                 mkexpr(OPSTAR, cpexpr(rp), realpart(lp) ));
 895:             putassign( imagpart(resp),
 896:                 mkexpr(OPSTAR, cpexpr(rp), imagpart(lp) ));
 897:             }
 898:         else    {
 899:             putassign( realpart(resp), mkexpr(OPMINUS,
 900:                 mkexpr(OPSTAR, realpart(lp), realpart(rp)),
 901:                 mkexpr(OPSTAR, imagpart(lp), imagpart(rp)) ));
 902:             putassign( imagpart(resp), mkexpr(OPPLUS,
 903:                 mkexpr(OPSTAR, realpart(lp), imagpart(rp)),
 904:                 mkexpr(OPSTAR, imagpart(lp), realpart(rp)) ));
 905:             }
 906:         *ncommap += 2;
 907:         break;
 908: 
 909:     case OPSLASH:
 910:         /* fixexpr has already replaced all divisions
 911: 		 * by a complex by a function call
 912: 		 */
 913:         if( ISINT(rtype) )
 914:             rp = intdouble(rp, ncommap);
 915:         putassign( realpart(resp),
 916:             mkexpr(OPSLASH, realpart(lp), cpexpr(rp)) );
 917:         putassign( imagpart(resp),
 918:             mkexpr(OPSLASH, imagpart(lp), cpexpr(rp)) );
 919:         *ncommap += 2;
 920:         break;
 921: 
 922:     case OPCONV:
 923:         putassign( realpart(resp), realpart(lp) );
 924:         if( ISCOMPLEX(lp->vtype) )
 925:             q = imagpart(lp);
 926:         else if(rp != NULL)
 927:             q = (expptr) realpart(rp);
 928:         else
 929:             q = mkrealcon(TYDREAL, 0.0);
 930:         putassign( imagpart(resp), q);
 931:         *ncommap += 2;
 932:         break;
 933: 
 934:     default:
 935:         badop("putcx1", opcode);
 936:     }
 937: 
 938: frexpr(lp);
 939: frexpr(rp);
 940: free( (charptr) p );
 941: return(resp);
 942: }
 943: 
 944: 
 945: 
 946: 
 947: LOCAL putcxcmp(p)
 948: register expptr p;
 949: {
 950: int opcode;
 951: int ncomma;
 952: register Addrp lp, rp;
 953: expptr q;
 954: 
 955: if(p->tag != TEXPR)
 956:     badtag("putcxcmp", p->tag);
 957: 
 958: ncomma = 0;
 959: opcode = p->exprblock.opcode;
 960: lp = putcx1(p->exprblock.leftp, &ncomma);
 961: rp = putcx1(p->exprblock.rightp, &ncomma);
 962: 
 963: q = mkexpr( opcode==OPEQ ? OPAND : OPOR ,
 964:     mkexpr(opcode, realpart(lp), realpart(rp)),
 965:     mkexpr(opcode, imagpart(lp), imagpart(rp)) );
 966: putx( fixexpr(q) );
 967: putcomma(ncomma, TYINT, NO);
 968: 
 969: free( (charptr) lp);
 970: free( (charptr) rp);
 971: free( (charptr) p );
 972: }
 973: 
 974: LOCAL Addrp putch1(p, ncommap)
 975: register expptr p;
 976: int * ncommap;
 977: {
 978: register Addrp t;
 979: 
 980: switch(p->tag)
 981:     {
 982:     case TCONST:
 983:         return( putconst(p) );
 984: 
 985:     case TADDR:
 986:         return( (Addrp) p );
 987: 
 988:     case TEXPR:
 989:         ++*ncommap;
 990: 
 991:         switch(p->exprblock.opcode)
 992:             {
 993:             expptr q;
 994: 
 995:             case OPCALL:
 996:             case OPCCALL:
 997:                 t = putcall(p);
 998:                 break;
 999: 
1000:             case OPPAREN:
1001:                 --*ncommap;
1002:                 t = putch1(p->exprblock.leftp, ncommap);
1003:                 break;
1004: 
1005:             case OPCONCAT:
1006:                 t = mkaltemp(TYCHAR, ICON(lencat(p)) );
1007:                 q = (expptr) cpexpr(p->headblock.vleng);
1008:                 putcat( cpexpr(t), p );
1009:                 /* put the correct length on the block */
1010:                 frexpr(t->vleng);
1011:                 t->vleng = q;
1012: 
1013:                 break;
1014: 
1015:             case OPCONV:
1016:                 if(!ISICON(p->exprblock.vleng)
1017:                    || p->exprblock.vleng->constblock.const.ci!=1
1018:                    || ! INT(p->exprblock.leftp->headblock.vtype) )
1019:                     fatal("putch1: bad character conversion");
1020:                 t = mkaltemp(TYCHAR, ICON(1) );
1021:                 putop( mkexpr(OPASSIGN, cpexpr(t), p) );
1022:                 break;
1023:             default:
1024:                 badop("putch1", p->exprblock.opcode);
1025:             }
1026:         return(t);
1027: 
1028:     default:
1029:         badtag("putch1", p->tag);
1030:     }
1031: /* NOTREACHED */
1032: }
1033: 
1034: 
1035: 
1036: 
1037: LOCAL putchop(p)
1038: expptr p;
1039: {
1040: int ncomma;
1041: 
1042: ncomma = 0;
1043: putaddr( putch1(p, &ncomma) , NO );
1044: putcomma(ncomma, TYCHAR, YES);
1045: }
1046: 
1047: 
1048: 
1049: 
1050: LOCAL putcheq(p)
1051: register expptr p;
1052: {
1053: int ncomma;
1054: expptr lp, rp;
1055: 
1056: if(p->tag != TEXPR)
1057:     badtag("putcheq", p->tag);
1058: 
1059: ncomma = 0;
1060: lp = p->exprblock.leftp;
1061: rp = p->exprblock.rightp;
1062: if( rp->tag==TEXPR && rp->exprblock.opcode==OPCONCAT )
1063:     putcat(lp, rp);
1064: else if( ISONE(lp->headblock.vleng) && ISONE(rp->headblock.vleng) )
1065:     {
1066:     putaddr( putch1(lp, &ncomma) , YES );
1067:     putaddr( putch1(rp, &ncomma) , YES );
1068:     putcomma(ncomma, TYINT, NO);
1069:     p2op(PCC_ASSIGN, PCCT_CHAR);
1070:     }
1071: else
1072:     {
1073:     putx( call2(TYINT, "s_copy", lp, rp) );
1074:     putcomma(ncomma, TYINT, NO);
1075:     }
1076: 
1077: frexpr(p->exprblock.vleng);
1078: free( (charptr) p );
1079: }
1080: 
1081: 
1082: 
1083: 
1084: LOCAL putchcmp(p)
1085: register expptr p;
1086: {
1087: int ncomma;
1088: expptr lp, rp;
1089: 
1090: if(p->tag != TEXPR)
1091:     badtag("putchcmp", p->tag);
1092: 
1093: ncomma = 0;
1094: lp = p->exprblock.leftp;
1095: rp = p->exprblock.rightp;
1096: 
1097: if(ISONE(lp->headblock.vleng) && ISONE(rp->headblock.vleng) )
1098:     {
1099:     putaddr( putch1(lp, &ncomma) , YES );
1100:     putcomma(ncomma, TYINT, NO);
1101:     ncomma = 0;
1102:     putaddr( putch1(rp, &ncomma) , YES );
1103:     putcomma(ncomma, TYINT, NO);
1104:     p2op(ops2[p->exprblock.opcode], PCCT_CHAR);
1105:     free( (charptr) p );
1106:     }
1107: else
1108:     {
1109:     p->exprblock.leftp = call2(TYINT,"s_cmp", lp, rp);
1110:     p->exprblock.rightp = ICON(0);
1111:     putop(p);
1112:     }
1113: }
1114: 
1115: 
1116: 
1117: 
1118: 
1119: LOCAL putcat(lhs, rhs)
1120: register Addrp lhs;
1121: register expptr rhs;
1122: {
1123: int n, ncomma;
1124: Addrp lp, cp;
1125: 
1126: ncomma = 0;
1127: n = ncat(rhs);
1128: lp = mkaltmpn(n, TYLENG, PNULL);
1129: cp = mkaltmpn(n, TYADDR, PNULL);
1130: 
1131: n = 0;
1132: putct1(rhs, lp, cp, &n, &ncomma);
1133: 
1134: putx( call4(TYSUBR, "s_cat", lhs, cp, lp, mkconv(TYLONG, ICON(n)) ) );
1135: putcomma(ncomma, TYINT, NO);
1136: }
1137: 
1138: 
1139: 
1140: 
1141: 
1142: LOCAL putct1(q, lp, cp, ip, ncommap)
1143: register expptr q;
1144: register Addrp lp, cp;
1145: int *ip, *ncommap;
1146: {
1147: int i;
1148: Addrp lp1, cp1;
1149: 
1150: if(q->tag==TEXPR && q->exprblock.opcode==OPCONCAT)
1151:     {
1152:     putct1(q->exprblock.leftp, lp, cp, ip, ncommap);
1153:     putct1(q->exprblock.rightp, lp, cp , ip, ncommap);
1154:     frexpr(q->exprblock.vleng);
1155:     free( (charptr) q );
1156:     }
1157: else
1158:     {
1159:     i = (*ip)++;
1160:     cp1 = (Addrp) cpexpr(cp);
1161:     cp1->memoffset = mkexpr(OPPLUS, cp1->memoffset, ICON(i*SZADDR));
1162:     lp1 = (Addrp) cpexpr(lp);
1163:     lp1->memoffset = mkexpr(OPPLUS,lp1->memoffset, ICON(i*SZLENG));
1164:     putassign( cp1, addrof(putch1(cpexpr(q),ncommap)) );
1165:     putassign( lp1, q->headblock.vleng );
1166:     free( (charptr) q );
1167:     *ncommap += 2;
1168:     }
1169: }
1170: 
1171: LOCAL putaddr(p, indir)
1172: register Addrp p;
1173: int indir;
1174: {
1175: int type, type2, funct;
1176: ftnint offset, simoffset();
1177: expptr offp, shorten();
1178: 
1179: if( p->tag==TERROR || (p->memoffset!=NULL && ISERROR(p->memoffset)) )
1180:     {
1181:     frexpr(p);
1182:     return;
1183:     }
1184: if (p->tag != TADDR) badtag ("putaddr",p->tag);
1185: 
1186: type = p->vtype;
1187: type2 = types2[type];
1188: funct = (p->vclass==CLPROC ? PCCTM_FTN<<2 : 0);
1189: 
1190: offp = (p->memoffset ? (expptr) cpexpr(p->memoffset) : (expptr)NULL );
1191: 
1192: 
1193: #if (FUDGEOFFSET != 1)
1194: if(offp)
1195:     offp = mkexpr(OPSTAR, ICON(FUDGEOFFSET), offp);
1196: #endif
1197: 
1198: offset = simoffset( &offp );
1199: #if SZINT < SZLONG
1200:     if(offp)
1201:         if(shortsubs)
1202:             offp = shorten(offp);
1203:         else
1204:             offp = mkconv(TYINT, offp);
1205: #else
1206:     if(offp)
1207:         offp = mkconv(TYINT, offp);
1208: #endif
1209: 
1210: if (p->vclass == CLVAR
1211:     && (p->vstg == STGBSS || p->vstg == STGEQUIV)
1212:     && SMALLVAR(p->varsize)
1213:     && offset >= -32768 && offset <= 32767)
1214:   {
1215:     anylocals = YES;
1216:     if (indir && !offp)
1217:       p2ldisp(offset, memname(p->vstg, p->memno), type2);
1218:     else
1219:       {
1220:     p2reg(11, type2 | PCCTM_PTR);
1221:     p2triple(PCC_ICON, 1, PCCT_INT);
1222:     p2word(offset);
1223:     p2ndisp(memname(p->vstg, p->memno));
1224:     p2op(PCC_PLUS, type2 | PCCTM_PTR);
1225:     if (offp)
1226:       {
1227:         putx(offp);
1228:         p2op(PCC_PLUS, type2 | PCCTM_PTR);
1229:       }
1230:     if (indir)
1231:       p2op(PCC_DEREF, type2);
1232:       }
1233:     frexpr((tagptr) p);
1234:     return;
1235:   }
1236: 
1237: switch(p->vstg)
1238:     {
1239:     case STGAUTO:
1240:         if(indir && !offp)
1241:             {
1242:             p2oreg(offset, AUTOREG, type2);
1243:             break;
1244:             }
1245: 
1246:         if(!indir && !offp && !offset)
1247:             {
1248:             p2reg(AUTOREG, type2 | PCCTM_PTR);
1249:             break;
1250:             }
1251: 
1252:         p2reg(AUTOREG, type2 | PCCTM_PTR);
1253:         if(offp)
1254:             {
1255:             putx(offp);
1256:             if(offset)
1257:                 p2icon(offset, PCCT_INT);
1258:             }
1259:         else
1260:             p2icon(offset, PCCT_INT);
1261:         if(offp && offset)
1262:             p2op(PCC_PLUS, type2 | PCCTM_PTR);
1263:         p2op(PCC_PLUS, type2 | PCCTM_PTR);
1264:         if(indir)
1265:             p2op(PCC_DEREF, type2);
1266:         break;
1267: 
1268:     case STGARG:
1269:         p2oreg(
1270: #ifdef ARGOFFSET
1271:             ARGOFFSET +
1272: #endif
1273:             (ftnint) (FUDGEOFFSET*p->memno),
1274:             ARGREG,   type2 | PCCTM_PTR | funct );
1275: 
1276:     based:
1277:         if(offset)
1278:             {
1279:             p2icon(offset, PCCT_INT);
1280:             p2op(PCC_PLUS, type2 | PCCTM_PTR);
1281:             }
1282:         if(offp)
1283:             {
1284:             putx(offp);
1285:             p2op(PCC_PLUS, type2 | PCCTM_PTR);
1286:             }
1287:         if(indir)
1288:             p2op(PCC_DEREF, type2);
1289:         break;
1290: 
1291:     case STGLENG:
1292:         if(indir)
1293:             {
1294:             p2oreg(
1295: #ifdef ARGOFFSET
1296:                 ARGOFFSET +
1297: #endif
1298:                 (ftnint) (FUDGEOFFSET*p->memno),
1299:                 ARGREG,   type2 );
1300:             }
1301:         else    {
1302:             p2reg(ARGREG, type2 | PCCTM_PTR );
1303:             p2icon(
1304: #ifdef ARGOFFSET
1305:                 ARGOFFSET +
1306: #endif
1307:                 (ftnint) (FUDGEOFFSET*p->memno), PCCT_INT);
1308:             p2op(PCC_PLUS, type2 | PCCTM_PTR );
1309:             }
1310:         break;
1311: 
1312: 
1313:     case STGBSS:
1314:     case STGINIT:
1315:     case STGEXT:
1316:     case STGINTR:
1317:     case STGCOMMON:
1318:     case STGEQUIV:
1319:     case STGCONST:
1320:         if(offp)
1321:             {
1322:             putx(offp);
1323:             putmem(p, PCC_ICON, offset);
1324:             p2op(PCC_PLUS, type2 | PCCTM_PTR);
1325:             if(indir)
1326:                 p2op(PCC_DEREF, type2);
1327:             }
1328:         else
1329:             putmem(p, (indir ? PCC_NAME : PCC_ICON), offset);
1330: 
1331:         break;
1332: 
1333:     case STGREG:
1334:         if(indir)
1335:             p2reg(p->memno, type2);
1336:         else
1337:             fatal("attempt to take address of a register");
1338:         break;
1339: 
1340:     case STGPREG:
1341:         if(indir && !offp)
1342:             p2oreg(offset, p->memno, type2);
1343:         else
1344:             {
1345:             p2reg(p->memno, type2 | PCCTM_PTR);
1346:             goto based;
1347:             }
1348:         break;
1349: 
1350:     default:
1351:         badstg("putaddr", p->vstg);
1352:     }
1353: frexpr(p);
1354: }
1355: 
1356: 
1357: 
1358: 
1359: LOCAL putmem(p, class, offset)
1360: expptr p;
1361: int class;
1362: ftnint offset;
1363: {
1364: int type2;
1365: int funct;
1366: char *name,  *memname();
1367: 
1368: funct = (p->headblock.vclass==CLPROC ? PCCTM_FTN<<2 : 0);
1369: type2 = types2[p->headblock.vtype];
1370: if(p->headblock.vclass == CLPROC)
1371:     type2 |= (PCCTM_FTN<<2);
1372: name = memname(p->addrblock.vstg, p->addrblock.memno);
1373: if(class == PCC_ICON)
1374:     {
1375:     p2triple(PCC_ICON, name[0]!='\0', type2|PCCTM_PTR);
1376:     p2word(offset);
1377:     if(name[0])
1378:         p2name(name);
1379:     }
1380: else
1381:     {
1382:     p2triple(PCC_NAME, offset!=0, type2);
1383:     if(offset != 0)
1384:         p2word(offset);
1385:     p2name(name);
1386:     }
1387: }
1388: 
1389: 
1390: 
1391: LOCAL Addrp putcall(p)
1392: register Exprp p;
1393: {
1394: chainp arglist, charsp, cp;
1395: int n, first;
1396: Addrp t;
1397: register expptr q;
1398: Addrp fval, mkargtemp();
1399: int type, type2, ctype, qtype, indir;
1400: 
1401: type2 = types2[type = p->vtype];
1402: charsp = NULL;
1403: indir =  (p->opcode == OPCCALL);
1404: n = 0;
1405: first = YES;
1406: 
1407: if(p->rightp)
1408:     {
1409:     arglist = p->rightp->listblock.listp;
1410:     free( (charptr) (p->rightp) );
1411:     }
1412: else
1413:     arglist = NULL;
1414: 
1415: for(cp = arglist ; cp ; cp = cp->nextp)
1416:     {
1417:     q = (expptr) cp->datap;
1418:     if(indir)
1419:         ++n;
1420:     else    {
1421:         q = (expptr) (cp->datap);
1422:         if( ISCONST(q) )
1423:             {
1424:             q = (expptr) putconst(q);
1425:             cp->datap = (tagptr) q;
1426:             }
1427:         if( ISCHAR(q) && q->headblock.vclass!=CLPROC )
1428:             {
1429:             charsp = hookup(charsp,
1430:                     mkchain(cpexpr(q->headblock.vleng),
1431:                         CHNULL));
1432:             n += 2;
1433:             }
1434:         else
1435:             n += 1;
1436:         }
1437:     }
1438: 
1439: if(type == TYCHAR)
1440:     {
1441:     if( ISICON(p->vleng) )
1442:         {
1443:         fval = mkargtemp(TYCHAR, p->vleng);
1444:         n += 2;
1445:         }
1446:     else    {
1447:         err("adjustable character function");
1448:         return;
1449:         }
1450:     }
1451: else if( ISCOMPLEX(type) )
1452:     {
1453:     fval = mkargtemp(type, PNULL);
1454:     n += 1;
1455:     }
1456: else
1457:     fval = NULL;
1458: 
1459: ctype = (fval ? PCCT_INT : type2);
1460: putaddr(p->leftp, NO);
1461: 
1462: if(fval)
1463:     {
1464:     first = NO;
1465:     putaddr( cpexpr(fval), NO);
1466:     if(type==TYCHAR)
1467:         {
1468:         putx( mkconv(TYLENG,p->vleng) );
1469:         p2op(PCC_CM, type2);
1470:         }
1471:     }
1472: 
1473: for(cp = arglist ; cp ; cp = cp->nextp)
1474:     {
1475:     q = (expptr) (cp->datap);
1476:     if(q->tag==TADDR && (indir || q->addrblock.vstg!=STGREG) )
1477:         putaddr(q, indir && q->addrblock.vtype!=TYCHAR);
1478:     else if( ISCOMPLEX(q->headblock.vtype) )
1479:         putcxop(q);
1480:     else if (ISCHAR(q) )
1481:         putchop(q);
1482:     else if( ! ISERROR(q) )
1483:         {
1484:         if(indir)
1485:             putx(q);
1486:         else    {
1487:             t = mkargtemp(qtype = q->headblock.vtype,
1488:                 q->headblock.vleng);
1489:             putassign( cpexpr(t), q );
1490:             putaddr(t, NO);
1491:             putcomma(1, qtype, YES);
1492:             }
1493:         }
1494:     if(first)
1495:         first = NO;
1496:     else
1497:         p2op(PCC_CM, type2);
1498:     }
1499: 
1500: if(arglist)
1501:     frchain(&arglist);
1502: for(cp = charsp ; cp ; cp = cp->nextp)
1503:     {
1504:     putx( mkconv(TYLENG,cp->datap) );
1505:     p2op(PCC_CM, type2);
1506:     }
1507: frchain(&charsp);
1508: p2op(n>0 ? PCC_CALL : PCC_UCALL , ctype);
1509: free( (charptr) p );
1510: return(fval);
1511: }
1512: 
1513: 
1514: 
1515: LOCAL putmnmx(p)
1516: register expptr p;
1517: {
1518: int op, type;
1519: int ncomma;
1520: expptr qp;
1521: chainp p0, p1;
1522: Addrp sp, tp;
1523: 
1524: if(p->tag != TEXPR)
1525:     badtag("putmnmx", p->tag);
1526: 
1527: type = p->exprblock.vtype;
1528: op = (p->exprblock.opcode==OPMIN ? OPLT : OPGT );
1529: p0 = p->exprblock.leftp->listblock.listp;
1530: free( (charptr) (p->exprblock.leftp) );
1531: free( (charptr) p );
1532: 
1533: sp = mkaltemp(type, PNULL);
1534: tp = mkaltemp(type, PNULL);
1535: qp = mkexpr(OPCOLON, cpexpr(tp), cpexpr(sp));
1536: qp = mkexpr(OPQUEST, mkexpr(op, cpexpr(tp),cpexpr(sp)), qp);
1537: qp = fixexpr(qp);
1538: 
1539: ncomma = 1;
1540: putassign( cpexpr(sp), p0->datap );
1541: 
1542: for(p1 = p0->nextp ; p1 ; p1 = p1->nextp)
1543:     {
1544:     ++ncomma;
1545:     putassign( cpexpr(tp), p1->datap );
1546:     if(p1->nextp)
1547:         {
1548:         ++ncomma;
1549:         putassign( cpexpr(sp), cpexpr(qp) );
1550:         }
1551:     else
1552:         putx(qp);
1553:     }
1554: 
1555: putcomma(ncomma, type, NO);
1556: frexpr(sp);
1557: frexpr(tp);
1558: frchain( &p0 );
1559: }
1560: 
1561: 
1562: 
1563: 
1564: LOCAL putcomma(n, type, indir)
1565: int n, type, indir;
1566: {
1567: type = types2[type];
1568: if(indir)
1569:     type |= PCCTM_PTR;
1570: while(--n >= 0)
1571:     p2op(PCC_COMOP, type);
1572: }
1573: 
1574: 
1575: 
1576: 
1577: ftnint simoffset(p0)
1578: expptr *p0;
1579: {
1580: ftnint offset, prod;
1581: register expptr p, lp, rp;
1582: 
1583: offset = 0;
1584: p = *p0;
1585: if(p == NULL)
1586:     return(0);
1587: 
1588: if( ! ISINT(p->headblock.vtype) )
1589:     return(0);
1590: 
1591: if(p->tag==TEXPR && p->exprblock.opcode==OPSTAR)
1592:     {
1593:     lp = p->exprblock.leftp;
1594:     rp = p->exprblock.rightp;
1595:     if(ISICON(rp) && lp->tag==TEXPR &&
1596:        lp->exprblock.opcode==OPPLUS && ISICON(lp->exprblock.rightp))
1597:         {
1598:         p->exprblock.opcode = OPPLUS;
1599:         lp->exprblock.opcode = OPSTAR;
1600:         prod = rp->constblock.const.ci *
1601:             lp->exprblock.rightp->constblock.const.ci;
1602:         lp->exprblock.rightp->constblock.const.ci = rp->constblock.const.ci;
1603:         rp->constblock.const.ci = prod;
1604:         }
1605:     }
1606: 
1607: if(p->tag==TEXPR && p->exprblock.opcode==OPPLUS &&
1608:     ISICON(p->exprblock.rightp))
1609:     {
1610:     rp = p->exprblock.rightp;
1611:     lp = p->exprblock.leftp;
1612:     offset += rp->constblock.const.ci;
1613:     frexpr(rp);
1614:     free( (charptr) p );
1615:     *p0 = lp;
1616:     }
1617: 
1618: if( ISCONST(p) )
1619:     {
1620:     offset += p->constblock.const.ci;
1621:     frexpr(p);
1622:     *p0 = NULL;
1623:     }
1624: 
1625: return(offset);
1626: }
1627: 
1628: 
1629: 
1630: 
1631: 
1632: p2op(op, type)
1633: int op, type;
1634: {
1635: p2triple(op, 0, type);
1636: }
1637: 
1638: p2icon(offset, type)
1639: ftnint offset;
1640: int type;
1641: {
1642: p2triple(PCC_ICON, 0, type);
1643: p2word(offset);
1644: }
1645: 
1646: 
1647: 
1648: 
1649: p2oreg(offset, reg, type)
1650: ftnint offset;
1651: int reg, type;
1652: {
1653: p2triple(PCC_OREG, reg, type);
1654: p2word(offset);
1655: p2name("");
1656: }
1657: 
1658: 
1659: 
1660: 
1661: p2reg(reg, type)
1662: int reg, type;
1663: {
1664: p2triple(PCC_REG, reg, type);
1665: }
1666: 
1667: 
1668: 
1669: p2pi(s, i)
1670: char *s;
1671: int i;
1672: {
1673: char buff[100];
1674: sprintf(buff, s, i);
1675: p2pass(buff);
1676: }
1677: 
1678: 
1679: 
1680: p2pij(s, i, j)
1681: char *s;
1682: int i, j;
1683: {
1684: char buff[100];
1685: sprintf(buff, s, i, j);
1686: p2pass(buff);
1687: }
1688: 
1689: 
1690: 
1691: 
1692: p2ps(s, t)
1693: char *s, *t;
1694: {
1695: char buff[100];
1696: sprintf(buff, s, t);
1697: p2pass(buff);
1698: }
1699: 
1700: 
1701: 
1702: 
1703: p2pass(s)
1704: char *s;
1705: {
1706: p2triple(PCCF_FTEXT, (strlen(s) + FOUR-1)/FOUR, 0);
1707: p2str(s);
1708: }
1709: 
1710: 
1711: 
1712: 
1713: p2str(s)
1714: register char *s;
1715: {
1716: union { long int word; char str[FOUR]; } u;
1717: register int i;
1718: 
1719: i = 0;
1720: u.word = 0;
1721: while(*s)
1722:     {
1723:     u.str[i++] = *s++;
1724:     if(i == FOUR)
1725:         {
1726:         p2word(u.word);
1727:         u.word = 0;
1728:         i = 0;
1729:         }
1730:     }
1731: if(i > 0)
1732:     p2word(u.word);
1733: }
1734: 
1735: 
1736: 
1737: 
1738: p2triple(op, var, type)
1739: int op, var, type;
1740: {
1741: register long word;
1742: word = PCCM_TRIPLE(op, var, type);
1743: p2word(word);
1744: }
1745: 
1746: 
1747: 
1748: 
1749: 
1750: p2name(s)
1751: register char *s;
1752: {
1753: register int i;
1754: 
1755: #ifdef UCBPASS2
1756:     /* arbitrary length names, terminated by a null,
1757: 	   padded to a full word */
1758: 
1759: #	define WL   sizeof(long int)
1760:     union { long int word; char str[WL]; } w;
1761: 
1762:     w.word = 0;
1763:     i = 0;
1764:     while(w.str[i++] = *s++)
1765:         if(i == WL)
1766:             {
1767:             p2word(w.word);
1768:             w.word = 0;
1769:             i = 0;
1770:             }
1771:     if(i > 0)
1772:         p2word(w.word);
1773: #else
1774:     /* standard intermediate, names are 8 characters long */
1775: 
1776:     union  { long int word[2];  char str[8]; } u;
1777: 
1778:     u.word[0] = u.word[1] = 0;
1779:     for(i = 0 ; i<8 && *s ; ++i)
1780:         u.str[i] = *s++;
1781:     p2word(u.word[0]);
1782:     p2word(u.word[1]);
1783: 
1784: #endif
1785: 
1786: }
1787: 
1788: 
1789: 
1790: 
1791: p2word(w)
1792: long int w;
1793: {
1794: *p2bufp++ = w;
1795: if(p2bufp >= p2bufend)
1796:     p2flush();
1797: }
1798: 
1799: 
1800: 
1801: p2flush()
1802: {
1803: if(p2bufp > p2buff)
1804:     write(fileno(textfile), p2buff, (p2bufp-p2buff)*sizeof(long int));
1805: p2bufp = p2buff;
1806: }
1807: 
1808: 
1809: 
1810: LOCAL
1811: p2ldisp(offset, vname, type)
1812: ftnint offset;
1813: char *vname;
1814: int type;
1815: {
1816:   char buff[100];
1817: 
1818:   sprintf(buff, "%s-v.%d", vname, bsslabel);
1819:   p2triple(PCC_OREG, 11, type);
1820:   p2word(offset);
1821:   p2name(buff);
1822: }
1823: 
1824: 
1825: 
1826: p2ndisp(vname)
1827: char *vname;
1828: {
1829:   char buff[100];
1830: 
1831:   sprintf(buff, "%s-v.%d", vname, bsslabel);
1832:   p2name(buff);
1833: }

Defined functions

Defined variables

Defined macros