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