1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)p2put.c 1.11 11/11/82"; 4 5 /* 6 * functions to help pi put out 7 * polish postfix binary portable c compiler intermediate code 8 * thereby becoming the portable pascal compiler 9 */ 10 11 #include "whoami.h" 12 #ifdef PC 13 #include "0.h" 14 #include "pcops.h" 15 #include "pc.h" 16 17 /* 18 * mash into f77's format 19 * lovely, isn't it? 20 */ 21 #define TOF77( fop,val,rest ) ( ( ( (rest) & 0177777 ) << 16 ) \ 22 | ( ( (val) & 0377 ) << 8 ) \ 23 | ( (fop) & 0377 ) ) 24 25 /* 26 * emits an ftext operator and a string to the pcstream 27 */ 28 puttext( string ) 29 char *string; 30 { 31 int length = str4len( string ); 32 33 if ( !CGENNING ) 34 return; 35 p2word( TOF77( P2FTEXT , length , 0 ) ); 36 # ifdef DEBUG 37 if ( opt( 'k' ) ) { 38 fprintf( stdout , "P2FTEXT | %3d | 0 " , length ); 39 } 40 # endif 41 p2string( string ); 42 } 43 44 int 45 str4len( string ) 46 char *string; 47 { 48 49 return ( ( strlen( string ) + 3 ) / 4 ); 50 } 51 52 /* 53 * put formatted text into a buffer for printing to the pcstream. 54 * a call to putpflush actually puts out the text. 55 * none of arg1 .. arg5 need be present. 56 * and you can add more if you need them. 57 */ 58 /* VARARGS */ 59 putprintf( format , incomplete , arg1 , arg2 , arg3 , arg4 , arg5 ) 60 char *format; 61 int incomplete; 62 { 63 static char ppbuffer[ BUFSIZ ]; 64 static char *ppbufp = ppbuffer; 65 66 if ( !CGENNING ) 67 return; 68 sprintf( ppbufp , format , arg1 , arg2 , arg3 , arg4 , arg5 ); 69 ppbufp = &( ppbuffer[ strlen( ppbuffer ) ] ); 70 if ( ppbufp >= &( ppbuffer[ BUFSIZ ] ) ) 71 panic( "putprintf" ); 72 if ( ! incomplete ) { 73 puttext( ppbuffer ); 74 ppbufp = ppbuffer; 75 } 76 } 77 78 /* 79 * emit a left bracket operator to pcstream 80 * with function number, the maximum temp register, and total local bytes 81 * until i figure out how to use them, regs 0 .. 11 are free. 82 * one idea for one reg is to save the display pointer on block entry 83 */ 84 putlbracket( ftnno , localbytes ) 85 int ftnno; 86 int localbytes; 87 { 88 # define MAXTP2REG 11 89 90 p2word( TOF77( P2FLBRAC , MAXTP2REG , ftnno ) ); 91 p2word( BITSPERBYTE * localbytes ); 92 # ifdef DEBUG 93 if ( opt( 'k' ) ) { 94 fprintf( stdout 95 , "P2FLBRAC | %3d | %d " , MAXTP2REG , ftnno ); 96 fprintf( stdout , "%d\n" 97 , BITSPERBYTE * localbytes ); 98 } 99 # endif 100 } 101 102 /* 103 * emit a right bracket operator 104 * which for the binary (fortran) interface 105 * forces the stack allocate and register mask 106 */ 107 putrbracket( ftnno ) 108 int ftnno; 109 { 110 111 p2word( TOF77( P2FRBRAC , 0 , ftnno ) ); 112 # ifdef DEBUG 113 if ( opt( 'k' ) ) { 114 fprintf( stdout , "P2FRBRAC | 0 | %d\n" , ftnno ); 115 } 116 # endif 117 } 118 119 /* 120 * emit an eof operator 121 */ 122 puteof() 123 { 124 125 p2word( P2FEOF ); 126 # ifdef DEBUG 127 if ( opt( 'k' ) ) { 128 fprintf( stdout , "P2FEOF\n" ); 129 } 130 # endif 131 } 132 133 /* 134 * emit a dot operator, 135 * with a source file line number and name 136 * if line is negative, there was an error on that line, but who cares? 137 */ 138 putdot( filename , line ) 139 char *filename; 140 int line; 141 { 142 int length = str4len( filename ); 143 144 if ( line < 0 ) { 145 line = -line; 146 } 147 p2word( TOF77( P2FEXPR , length , line ) ); 148 # ifdef DEBUG 149 if ( opt( 'k' ) ) { 150 fprintf( stdout , "P2FEXPR | %3d | %d " , length , line ); 151 } 152 # endif 153 p2string( filename ); 154 } 155 156 /* 157 * put out a leaf node 158 */ 159 putleaf( op , lval , rval , type , name ) 160 int op; 161 int lval; 162 int rval; 163 int type; 164 char *name; 165 { 166 if ( !CGENNING ) 167 return; 168 switch ( op ) { 169 default: 170 panic( "[putleaf]" ); 171 case P2ICON: 172 p2word( TOF77( P2ICON , name != NIL , type ) ); 173 p2word( lval ); 174 # ifdef DEBUG 175 if ( opt( 'k' ) ) { 176 fprintf( stdout , "P2ICON | %3d | 0x%x " 177 , name != NIL , type ); 178 fprintf( stdout , "%d\n" , lval ); 179 } 180 # endif 181 if ( name ) 182 p2name( name ); 183 break; 184 case P2NAME: 185 p2word( TOF77( P2NAME , lval != 0 , type ) ); 186 if ( lval ) 187 p2word( lval ); 188 # ifdef DEBUG 189 if ( opt( 'k' ) ) { 190 fprintf( stdout , "P2NAME | %3d | 0x%x " 191 , lval != 0 , type ); 192 if ( lval ) 193 fprintf( stdout , "%d " , lval ); 194 } 195 # endif 196 p2name( name ); 197 break; 198 case P2REG: 199 p2word( TOF77( P2REG , rval , type ) ); 200 # ifdef DEBUG 201 if ( opt( 'k' ) ) { 202 fprintf( stdout , "P2REG | %3d | 0x%x\n" , 203 rval , type ); 204 } 205 # endif 206 break; 207 } 208 } 209 210 /* 211 * rvalues are just lvalues with indirection, except 212 * special cases for registers and for named globals, 213 * whose names are their rvalues. 214 */ 215 putRV( name , level , offset , other_flags , type ) 216 char *name; 217 int level; 218 int offset; 219 char other_flags; 220 int type; 221 { 222 char extname[ BUFSIZ ]; 223 char *printname; 224 int regnumber; 225 226 if ( !CGENNING ) 227 return; 228 if ( other_flags & NREGVAR ) { 229 if ( ( offset < 0 ) || ( offset > P2FP ) ) { 230 panic( "putRV regvar" ); 231 } 232 putleaf( P2REG , 0 , offset , type , 0 ); 233 return; 234 } 235 if ( whereis( level , offset , other_flags ) == GLOBALVAR ) { 236 if ( name != 0 ) { 237 if ( name[0] != '_' ) { 238 sprintf( extname , EXTFORMAT , name ); 239 printname = extname; 240 } else { 241 printname = name; 242 } 243 putleaf( P2NAME , offset , 0 , type , printname ); 244 return; 245 } else { 246 panic( "putRV no name" ); 247 } 248 } 249 putLV( name , level , offset , other_flags , type ); 250 putop( P2UNARY P2MUL , type ); 251 } 252 253 /* 254 * put out an lvalue 255 * given a level and offset 256 * special case for 257 * named globals, whose lvalues are just their names as constants. 258 */ 259 putLV( name , level , offset , other_flags , type ) 260 char *name; 261 int level; 262 int offset; 263 char other_flags; 264 int type; 265 { 266 char extname[ BUFSIZ ]; 267 char *printname; 268 269 if ( !CGENNING ) 270 return; 271 if ( other_flags & NREGVAR ) { 272 panic( "putLV regvar" ); 273 } 274 switch ( whereis( level , offset , other_flags ) ) { 275 case GLOBALVAR: 276 if ( ( name != 0 ) ) { 277 if ( name[0] != '_' ) { 278 sprintf( extname , EXTFORMAT , name ); 279 printname = extname; 280 } else { 281 printname = name; 282 } 283 putleaf( P2ICON , offset , 0 , ADDTYPE( type , P2PTR ) 284 , printname ); 285 return; 286 } else { 287 panic( "putLV no name" ); 288 } 289 case PARAMVAR: 290 if ( level == cbn ) { 291 putleaf( P2REG , 0 , P2AP , ADDTYPE( type , P2PTR ) , 0 ); 292 } else { 293 putleaf( P2NAME , (level * sizeof(struct dispsave)) + AP_OFFSET 294 , 0 , P2PTR | P2CHAR , DISPLAYNAME ); 295 parts[ level ] |= NONLOCALVAR; 296 } 297 putleaf( P2ICON , offset , 0 , P2INT , 0 ); 298 putop( P2PLUS , P2PTR | P2CHAR ); 299 break; 300 case LOCALVAR: 301 if ( level == cbn ) { 302 putleaf( P2REG , 0 , P2FP , ADDTYPE( type , P2PTR ) , 0 ); 303 } else { 304 putleaf( P2NAME , (level * sizeof(struct dispsave)) + FP_OFFSET 305 , 0 , P2PTR | P2CHAR , DISPLAYNAME ); 306 parts[ level ] |= NONLOCALVAR; 307 } 308 putleaf( P2ICON , -offset , 0 , P2INT , 0 ); 309 putop( P2MINUS , P2PTR | P2CHAR ); 310 break; 311 case NAMEDLOCALVAR: 312 if ( level == cbn ) { 313 putleaf( P2REG , 0 , P2FP , ADDTYPE( type , P2PTR ) , 0 ); 314 } else { 315 putleaf( P2NAME , (level * sizeof(struct dispsave)) + FP_OFFSET 316 , 0 , P2PTR | P2CHAR , DISPLAYNAME ); 317 parts[ level ] |= NONLOCALVAR; 318 } 319 putleaf( P2ICON , 0 , 0 , P2INT , name ); 320 putop( P2MINUS , P2PTR | P2CHAR ); 321 break; 322 } 323 return; 324 } 325 326 /* 327 * put out a floating point constant leaf node 328 * the constant is declared in aligned data space 329 * and a P2NAME leaf put out for it 330 */ 331 putCON8( val ) 332 double val; 333 { 334 int label; 335 char name[ BUFSIZ ]; 336 337 if ( !CGENNING ) 338 return; 339 putprintf( " .data" , 0 ); 340 putprintf( " .align 2" , 0 ); 341 label = getlab(); 342 putlab( label ); 343 putprintf( " .double 0d%.20e" , 0 , val ); 344 putprintf( " .text" , 0 ); 345 sprintf( name , PREFIXFORMAT , LABELPREFIX , label ); 346 putleaf( P2NAME , 0 , 0 , P2DOUBLE , name ); 347 } 348 349 /* 350 * put out either an lvalue or an rvalue for a constant string. 351 * an lvalue (for assignment rhs's) is the name as a constant, 352 * an rvalue (for parameters) is just the name. 353 */ 354 putCONG( string , length , required ) 355 char *string; 356 int length; 357 int required; 358 { 359 char name[ BUFSIZ ]; 360 int label; 361 char *cp; 362 int pad; 363 int others; 364 365 if ( !CGENNING ) 366 return; 367 putprintf( " .data" , 0 ); 368 label = getlab(); 369 putlab( label ); 370 cp = string; 371 while ( *cp ) { 372 putprintf( " .byte 0%o" , 1 , *cp ++ ); 373 for ( others = 2 ; ( others <= 8 ) && *cp ; others ++ ) { 374 putprintf( ",0%o" , 1 , *cp++ ); 375 } 376 putprintf( "" , 0 ); 377 } 378 pad = length - strlen( string ); 379 while ( pad-- > 0 ) { 380 putprintf( " .byte 0%o" , 1 , ' ' ); 381 for ( others = 2 ; ( others <= 8 ) && ( pad-- > 0 ) ; others++ ) { 382 putprintf( ",0%o" , 1 , ' ' ); 383 } 384 putprintf( "" , 0 ); 385 } 386 putprintf( " .byte 0" , 0 ); 387 putprintf( " .text" , 0 ); 388 sprintf( name , PREFIXFORMAT , LABELPREFIX , label ); 389 if ( required == RREQ ) { 390 putleaf( P2NAME , 0 , 0 , P2ARY | P2CHAR , name ); 391 } else { 392 putleaf( P2ICON , 0 , 0 , P2PTR | P2CHAR , name ); 393 } 394 } 395 396 /* 397 * map a pascal type to a c type 398 * this would be tail recursive, but i unfolded it into a for (;;). 399 * this is sort of like isa and lwidth 400 * a note on the types used by the portable c compiler: 401 * they are divided into a basic type (char, short, int, long, etc.) 402 * and qualifications on those basic types (pointer, function, array). 403 * the basic type is kept in the low 4 bits of the type descriptor, 404 * and the qualifications are arranged in two bit chunks, with the 405 * most significant on the right, 406 * and the least significant on the left 407 * e.g. int *foo(); 408 * (a function returning a pointer to an integer) 409 * is stored as 410 * <ptr><ftn><int> 411 * so, we build types recursively 412 * also, we know that /lib/f1 can only deal with 6 qualifications 413 * so we stop the recursion there. this stops infinite type recursion 414 * through mutually recursive pointer types. 415 */ 416 #define MAXQUALS 6 417 int 418 p2type( np ) 419 { 420 421 return typerecur( np , 0 ); 422 } 423 typerecur( np , quals ) 424 struct nl *np; 425 int quals; 426 { 427 428 if ( np == NIL || quals > MAXQUALS ) { 429 return P2UNDEF; 430 } 431 switch ( np -> class ) { 432 case SCAL : 433 case RANGE : 434 if ( np -> type == ( nl + TDOUBLE ) ) { 435 return P2DOUBLE; 436 } 437 switch ( bytes( np -> range[0] , np -> range[1] ) ) { 438 case 1: 439 return P2CHAR; 440 case 2: 441 return P2SHORT; 442 case 4: 443 return P2INT; 444 default: 445 panic( "p2type int" ); 446 } 447 case STR : 448 return ( P2ARY | P2CHAR ); 449 case RECORD : 450 case SET : 451 return P2STRTY; 452 case FILET : 453 return ( P2PTR | P2STRTY ); 454 case CONST : 455 case VAR : 456 case FIELD : 457 return p2type( np -> type ); 458 case TYPE : 459 switch ( nloff( np ) ) { 460 case TNIL : 461 return ( P2PTR | P2UNDEF ); 462 case TSTR : 463 return ( P2ARY | P2CHAR ); 464 case TSET : 465 return P2STRTY; 466 default : 467 return ( p2type( np -> type ) ); 468 } 469 case REF: 470 case WITHPTR: 471 case PTR : 472 return ADDTYPE( typerecur( np -> type , quals + 1 ) , P2PTR ); 473 case ARRAY : 474 return ADDTYPE( typerecur( np -> type , quals + 1 ) , P2ARY ); 475 case FUNC : 476 /* 477 * functions are really pointers to functions 478 * which return their underlying type. 479 */ 480 return ADDTYPE( ADDTYPE( typerecur( np -> type , quals + 2 ) , 481 P2FTN ) , P2PTR ); 482 case PROC : 483 /* 484 * procedures are pointers to functions 485 * which return integers (whether you look at them or not) 486 */ 487 return ADDTYPE( ADDTYPE( P2INT , P2FTN ) , P2PTR ); 488 case FFUNC : 489 case FPROC : 490 /* 491 * formal procedures and functions are pointers 492 * to structures which describe their environment. 493 */ 494 return ( P2PTR | P2STRTY ); 495 default : 496 panic( "p2type" ); 497 } 498 } 499 500 /* 501 * add a most significant type modifier to a type 502 */ 503 long 504 addtype( underlying , mtype ) 505 long underlying; 506 long mtype; 507 { 508 return ( ( ( underlying & ~P2BASETYPE ) << P2TYPESHIFT ) 509 | mtype 510 | ( underlying & P2BASETYPE ) ); 511 } 512 513 /* 514 * put a typed operator to the pcstream 515 */ 516 putop( op , type ) 517 int op; 518 int type; 519 { 520 extern char *p2opnames[]; 521 522 if ( !CGENNING ) 523 return; 524 p2word( TOF77( op , 0 , type ) ); 525 # ifdef DEBUG 526 if ( opt( 'k' ) ) { 527 fprintf( stdout , "%s (%d) | 0 | 0x%x\n" 528 , p2opnames[ op ] , op , type ); 529 } 530 # endif 531 } 532 533 /* 534 * put out a structure operator (STASG, STARG, STCALL, UNARY STCALL ) 535 * which looks just like a regular operator, only the size and 536 * alignment go in the next consecutive words 537 */ 538 putstrop( op , type , size , alignment ) 539 int op; 540 int type; 541 int size; 542 int alignment; 543 { 544 extern char *p2opnames[]; 545 546 if ( !CGENNING ) 547 return; 548 p2word( TOF77( op , 0 , type ) ); 549 p2word( size ); 550 p2word( alignment ); 551 # ifdef DEBUG 552 if ( opt( 'k' ) ) { 553 fprintf( stdout , "%s (%d) | 0 | 0x%x %d %d\n" 554 , p2opnames[ op ] , op , type , size , alignment ); 555 } 556 # endif 557 } 558 559 /* 560 * the string names of p2ops 561 */ 562 char *p2opnames[] = { 563 "", 564 "P2UNDEFINED", /* 1 */ 565 "P2NAME", /* 2 */ 566 "P2STRING", /* 3 */ 567 "P2ICON", /* 4 */ 568 "P2FCON", /* 5 */ 569 "P2PLUS", /* 6 */ 570 "", 571 "P2MINUS", /* 8 also unary == P2NEG */ 572 "", 573 "P2NEG", 574 "P2MUL", /* 11 also unary == P2INDIRECT */ 575 "", 576 "P2INDIRECT", 577 "P2AND", /* 14 also unary == P2ADDROF */ 578 "", 579 "P2ADDROF", 580 "P2OR", /* 17 */ 581 "", 582 "P2ER", /* 19 */ 583 "", 584 "P2QUEST", /* 21 */ 585 "P2COLON", /* 22 */ 586 "P2ANDAND", /* 23 */ 587 "P2OROR", /* 24 */ 588 "", /* 25 */ 589 "", /* 26 */ 590 "", /* 27 */ 591 "", /* 28 */ 592 "", /* 29 */ 593 "", /* 30 */ 594 "", /* 31 */ 595 "", /* 32 */ 596 "", /* 33 */ 597 "", /* 34 */ 598 "", /* 35 */ 599 "", /* 36 */ 600 "", /* 37 */ 601 "", /* 38 */ 602 "", /* 39 */ 603 "", /* 40 */ 604 "", /* 41 */ 605 "", /* 42 */ 606 "", /* 43 */ 607 "", /* 44 */ 608 "", /* 45 */ 609 "", /* 46 */ 610 "", /* 47 */ 611 "", /* 48 */ 612 "", /* 49 */ 613 "", /* 50 */ 614 "", /* 51 */ 615 "", /* 52 */ 616 "", /* 53 */ 617 "", /* 54 */ 618 "", /* 55 */ 619 "P2LISTOP", /* 56 */ 620 "", 621 "P2ASSIGN", /* 58 */ 622 "P2COMOP", /* 59 */ 623 "P2DIV", /* 60 */ 624 "", 625 "P2MOD", /* 62 */ 626 "", 627 "P2LS", /* 64 */ 628 "", 629 "P2RS", /* 66 */ 630 "", 631 "P2DOT", /* 68 */ 632 "P2STREF", /* 69 */ 633 "P2CALL", /* 70 also unary */ 634 "", 635 "P2UNARYCALL", 636 "P2FORTCALL", /* 73 also unary */ 637 "", 638 "P2UNARYFORTCALL", 639 "P2NOT", /* 76 */ 640 "P2COMPL", /* 77 */ 641 "P2INCR", /* 78 */ 642 "P2DECR", /* 79 */ 643 "P2EQ", /* 80 */ 644 "P2NE", /* 81 */ 645 "P2LE", /* 82 */ 646 "P2LT", /* 83 */ 647 "P2GE", /* 84 */ 648 "P2GT", /* 85 */ 649 "P2ULE", /* 86 */ 650 "P2ULT", /* 87 */ 651 "P2UGE", /* 88 */ 652 "P2UGT", /* 89 */ 653 "P2SETBIT", /* 90 */ 654 "P2TESTBIT", /* 91 */ 655 "P2RESETBIT", /* 92 */ 656 "P2ARS", /* 93 */ 657 "P2REG", /* 94 */ 658 "P2OREG", /* 95 */ 659 "P2CCODES", /* 96 */ 660 "P2FREE", /* 97 */ 661 "P2STASG", /* 98 */ 662 "P2STARG", /* 99 */ 663 "P2STCALL", /* 100 also unary */ 664 "", 665 "P2UNARYSTCALL", 666 "P2FLD", /* 103 */ 667 "P2SCONV", /* 104 */ 668 "P2PCONV", /* 105 */ 669 "P2PMCONV", /* 106 */ 670 "P2PVCONV", /* 107 */ 671 "P2FORCE", /* 108 */ 672 "P2CBRANCH", /* 109 */ 673 "P2INIT", /* 110 */ 674 "P2CAST", /* 111 */ 675 }; 676 677 /* 678 * low level routines 679 */ 680 681 /* 682 * puts a long word on the pcstream 683 */ 684 p2word( word ) 685 long word; 686 { 687 688 putw( word , pcstream ); 689 } 690 691 /* 692 * put a length 0 mod 4 null padded string onto the pcstream 693 */ 694 p2string( string ) 695 char *string; 696 { 697 int slen = strlen( string ); 698 int wlen = ( slen + 3 ) / 4; 699 int plen = ( wlen * 4 ) - slen; 700 char *cp; 701 int p; 702 703 for ( cp = string ; *cp ; cp++ ) 704 putc( *cp , pcstream ); 705 for ( p = 1 ; p <= plen ; p++ ) 706 putc( '\0' , pcstream ); 707 # ifdef DEBUG 708 if ( opt( 'k' ) ) { 709 fprintf( stdout , "\"%s" , string ); 710 for ( p = 1 ; p <= plen ; p++ ) 711 fprintf( stdout , "\\0" ); 712 fprintf( stdout , "\"\n" ); 713 } 714 # endif 715 } 716 717 /* 718 * puts a name on the pcstream 719 */ 720 p2name( name ) 721 char *name; 722 { 723 int pad; 724 725 fprintf( pcstream , NAMEFORMAT , name ); 726 pad = strlen( name ) % sizeof (long); 727 for ( ; pad < sizeof (long) ; pad++ ) { 728 putc( '\0' , pcstream ); 729 } 730 # ifdef DEBUG 731 if ( opt( 'k' ) ) { 732 fprintf( stdout , NAMEFORMAT , name ); 733 pad = strlen( name ) % sizeof (long); 734 for ( ; pad < sizeof (long) ; pad++ ) { 735 fprintf( stdout , "\\0" ); 736 } 737 fprintf( stdout , "\n" ); 738 } 739 # endif 740 } 741 742 /* 743 * put out a jump to a label 744 */ 745 putjbr( label ) 746 long label; 747 { 748 749 printjbr( LABELPREFIX , label ); 750 } 751 752 /* 753 * put out a jump to any kind of label 754 */ 755 printjbr( prefix , label ) 756 char *prefix; 757 long label; 758 { 759 760 putprintf( " jbr " , 1 ); 761 putprintf( PREFIXFORMAT , 0 , prefix , label ); 762 } 763 764 /* 765 * another version of put to catch calls to put 766 */ 767 put( arg1 , arg2 ) 768 { 769 770 putprintf( "# PUT CALLED!: arg1 = %d arg2 = 0%o" , 0 , arg1 , arg2 ); 771 } 772 773 #endif PC 774