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