1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)put.c 1.8 01/22/81"; 4 5 #include "whoami.h" 6 #include "opcode.h" 7 #include "0.h" 8 #include "objfmt.h" 9 #ifdef PC 10 # include "pc.h" 11 #endif PC 12 13 short *obufp = obuf; 14 15 /* 16 * If DEBUG is defined, include the table 17 * of the printing opcode names. 18 */ 19 #ifdef DEBUG 20 #include "OPnames.h" 21 #endif 22 23 #ifdef OBJ 24 /* 25 * Put is responsible for the interpreter equivalent of code 26 * generation. Since the interpreter is specifically designed 27 * for Pascal, little work is required here. 28 */ 29 put(a) 30 { 31 register int *p, i; 32 register char *cp; 33 int n, subop, suboppr, op, oldlc, w; 34 char *string; 35 static int casewrd; 36 37 /* 38 * It would be nice to do some more 39 * optimizations here. The work 40 * done to collapse offsets in lval 41 * should be done here, the IFEQ etc 42 * relational operators could be used 43 * etc. 44 */ 45 oldlc = lc; 46 if (cgenflg < 0) 47 /* 48 * code disabled - do nothing 49 */ 50 return (oldlc); 51 p = &a; 52 n = *p++; 53 suboppr = subop = (*p>>8) & 0377; 54 op = *p & 0377; 55 string = 0; 56 #ifdef DEBUG 57 if ((cp = otext[op]) == NIL) { 58 printf("op= %o\n", op); 59 panic("put"); 60 } 61 #endif 62 switch (op) { 63 case O_ABORT: 64 cp = "*"; 65 break; 66 case O_LINO: 67 /***** 68 if (line == codeline) 69 return (oldlc); 70 codeline = line; 71 *****/ 72 case O_NEW: 73 case O_DISPOSE: 74 case O_AS: 75 case O_IND: 76 case O_LVCON: 77 case O_CON: 78 case O_OFF: 79 case O_INX2: 80 case O_INX4: 81 case O_CARD: 82 case O_ADDT: 83 case O_SUBT: 84 case O_MULT: 85 case O_IN: 86 case O_CASE1OP: 87 case O_CASE2OP: 88 case O_CASE4OP: 89 case O_FRTN: 90 case O_WRITES: 91 case O_WRITEF: 92 case O_MAX: 93 case O_MIN: 94 case O_ARGV: 95 case O_CTTOT: 96 case O_INCT: 97 case O_RANG2: 98 case O_RSNG2: 99 case O_RANG42: 100 case O_RSNG42: 101 case O_SUCC2: 102 case O_SUCC24: 103 case O_PRED2: 104 case O_PRED24: 105 if (p[1] == 0) 106 break; 107 case O_CON2: 108 case O_CON24: 109 if (p[1] < 128 && p[1] >= -128) { 110 suboppr = subop = p[1]; 111 p++; 112 n--; 113 if (op == O_CON2) { 114 op = O_CON1; 115 cp = otext[O_CON1]; 116 } 117 if (op == O_CON24) { 118 op = O_CON14; 119 cp = otext[O_CON14]; 120 } 121 } 122 break; 123 case O_CON8: 124 { 125 short *sp = &p[1]; 126 127 #ifdef DEBUG 128 if ( opt( 'k' ) ) 129 printf ( ")#%5d\tCON8\t%10.3f\n" , 130 lc - HEADER_BYTES , 131 * ( ( double * ) &p[1] ) ); 132 #endif 133 word ( op ); 134 for ( i = 1 ; i <= 4 ; i ++ ) 135 word ( *sp ++ ); 136 return ( oldlc ); 137 } 138 default: 139 if (op >= O_REL2 && op <= O_REL84) { 140 if ((i = (subop >> INDX) * 5 ) >= 30) 141 i -= 30; 142 else 143 i += 2; 144 #ifdef DEBUG 145 string = &"IFEQ\0IFNE\0IFLT\0IFGT\0IFLE\0IFGE"[i]; 146 #endif 147 suboppr = 0; 148 } 149 break; 150 case O_IF: 151 case O_TRA: 152 /***** 153 codeline = 0; 154 *****/ 155 /* relative addressing */ 156 p[1] -= ( unsigned ) lc + sizeof(short); 157 break; 158 case O_FOR1U: 159 case O_FOR2U: 160 case O_FOR1D: 161 case O_FOR2D: 162 /* relative addressing */ 163 p[3] -= ( unsigned ) lc + 3 * sizeof(short); 164 break; 165 case O_CONG: 166 i = p[1]; 167 cp = * ( ( char ** ) &p[2] ) ; 168 #ifdef DEBUG 169 if (opt('k')) 170 printf(")#%5d\tCONG:%d\t%s\n", 171 lc - HEADER_BYTES, i, cp); 172 #endif 173 if (i <= 127) 174 word(O_CON | i << 8); 175 else { 176 word(O_CON); 177 word(i); 178 } 179 while (i > 0) { 180 w = *cp ? *cp++ : ' '; 181 w |= (*cp ? *cp++ : ' ') << 8; 182 word(w); 183 i -= 2; 184 } 185 return (oldlc); 186 case O_CONC: 187 #ifdef DEBUG 188 (string = "'x'")[1] = p[1]; 189 #endif 190 suboppr = 0; 191 op = O_CON1; 192 cp = otext[O_CON1]; 193 subop = p[1]; 194 goto around; 195 case O_CONC4: 196 #ifdef DEBUG 197 (string = "'x'")[1] = p[1]; 198 #endif 199 suboppr = 0; 200 op = O_CON14; 201 subop = p[1]; 202 goto around; 203 case O_CON1: 204 case O_CON14: 205 suboppr = subop = p[1]; 206 around: 207 n--; 208 break; 209 case O_CASEBEG: 210 casewrd = 0; 211 return (oldlc); 212 case O_CASEEND: 213 if ((unsigned) lc & 1) { 214 lc--; 215 word(casewrd); 216 } 217 return (oldlc); 218 case O_CASE1: 219 #ifdef DEBUG 220 if (opt('k')) 221 printf(")#%5d\tCASE1\t%d\n" 222 , lc - HEADER_BYTES 223 , ( int ) *( ( long * ) &p[1] ) ); 224 #endif 225 /* 226 * this to build a byte size case table 227 * saving bytes across calls in casewrd 228 * so they can be put out by word() 229 */ 230 lc++; 231 if ((unsigned) lc & 1) 232 casewrd = *( ( long * ) &p[1] ) & 0377; 233 else { 234 lc -= 2; 235 word ( casewrd 236 | ( ( int ) *( ( long * ) &p[1] ) << 8 ) ); 237 } 238 return (oldlc); 239 case O_CASE2: 240 #ifdef DEBUG 241 if (opt('k')) 242 printf(")#%5d\tCASE2\t%d\n" 243 , lc - HEADER_BYTES 244 , ( int ) *( ( long * ) &p[1] ) ); 245 #endif 246 word( ( short ) *( ( long * ) &p[1] ) ); 247 return (oldlc); 248 case O_FCALL: 249 if (p[1] == 0) 250 goto longgen; 251 /* and fall through */ 252 case O_PUSH: 253 if (p[1] == 0) 254 return (oldlc); 255 if (p[1] < 128 && p[1] >= -128) { 256 suboppr = subop = p[1]; 257 p++; 258 n--; 259 break; 260 } 261 goto longgen; 262 case O_FOR4U: 263 case O_FOR4D: 264 /* relative addressing */ 265 p[3] -= ( unsigned ) lc + 266 (sizeof(short) + 2 * sizeof(long)); 267 goto longgen; 268 case O_TRA4: 269 case O_CALL: 270 case O_FSAV: 271 case O_GOTO: 272 case O_NAM: 273 case O_READE: 274 /* absolute long addressing */ 275 p[1] -= HEADER_BYTES; 276 goto longgen; 277 case O_RV1: 278 case O_RV14: 279 case O_RV2: 280 case O_RV24: 281 case O_RV4: 282 case O_RV8: 283 case O_RV: 284 case O_LV: 285 /* 286 * positive offsets represent arguments 287 * and must use "ap" display entry rather 288 * than the "fp" entry 289 */ 290 if (p[1] >= 0) { 291 subop++; 292 suboppr++; 293 } 294 /* 295 * offsets out of range of word addressing 296 * must use long offset opcodes 297 */ 298 if (p[1] < SHORTADDR && p[1] >= -SHORTADDR) 299 break; 300 else { 301 op += O_LRV - O_RV; 302 cp = otext[op]; 303 } 304 /* and fall through */ 305 case O_BEG: 306 case O_NODUMP: 307 case O_CON4: 308 case O_CASE4: 309 case O_RANG4: 310 case O_RANG24: 311 case O_RSNG4: 312 case O_RSNG24: 313 case O_SUCC4: 314 case O_PRED4: 315 longgen: 316 { 317 short *sp = &p[1]; 318 long *lp = &p[1]; 319 320 n = (n << 1) - 1; 321 if ( op == O_LRV || op == O_FOR4U || op == O_FOR4D) 322 n--; 323 #ifdef DEBUG 324 if (opt('k')) 325 { 326 printf( ")#%5d\t%s" , lc - HEADER_BYTES , cp+1 ); 327 if (suboppr) 328 printf(":%1d", suboppr); 329 for ( i = 1 ; i < n 330 ; i += sizeof ( long )/sizeof ( short ) ) 331 printf( "\t%D " , *lp ++ ); 332 pchr ( '\n' ); 333 } 334 #endif 335 if ( op != O_CASE4 ) 336 word ( op | subop<<8 ); 337 for ( i = 1 ; i < n ; i ++ ) 338 word ( *sp ++ ); 339 return ( oldlc ); 340 } 341 } 342 #ifdef DEBUG 343 if (opt('k')) { 344 printf(")#%5d\t%s", lc - HEADER_BYTES, cp+1); 345 if (suboppr) 346 printf(":%d", suboppr); 347 if (string) 348 printf("\t%s",string); 349 if (n > 1) 350 pchr('\t'); 351 for (i=1; i<n; i++) 352 printf("%d ", ( short ) p[i]); 353 pchr('\n'); 354 } 355 #endif 356 if (op != NIL) 357 word(op | subop << 8); 358 for (i=1; i<n; i++) 359 word(p[i]); 360 return (oldlc); 361 } 362 #endif OBJ 363 364 /* 365 * listnames outputs a list of enumerated type names which 366 * can then be selected from to output a TSCAL 367 * a pointer to the address in the code of the namelist 368 * is kept in value[ NL_ELABEL ]. 369 */ 370 listnames(ap) 371 372 register struct nl *ap; 373 { 374 struct nl *next; 375 register int oldlc, len; 376 register unsigned w; 377 register char *strptr; 378 379 if (cgenflg < 0) 380 /* code is off - do nothing */ 381 return(NIL); 382 if (ap->class != TYPE) 383 ap = ap->type; 384 if (ap->value[ NL_ELABEL ] != 0) { 385 /* the list already exists */ 386 return( ap -> value[ NL_ELABEL ] ); 387 } 388 # ifdef OBJ 389 oldlc = lc; 390 put(2, O_TRA, lc); 391 ap->value[ NL_ELABEL ] = lc; 392 # endif OBJ 393 # ifdef PC 394 putprintf( " .data" , 0 ); 395 putprintf( " .align 1" , 0 ); 396 ap -> value[ NL_ELABEL ] = getlab(); 397 putlab( ap -> value[ NL_ELABEL ] ); 398 # endif PC 399 /* number of scalars */ 400 next = ap->type; 401 len = next->range[1]-next->range[0]+1; 402 # ifdef OBJ 403 put(2, O_CASE2, len); 404 # endif OBJ 405 # ifdef PC 406 putprintf( " .word %d" , 0 , len ); 407 # endif PC 408 /* offsets of each scalar name */ 409 len = (len+1)*sizeof(short); 410 # ifdef OBJ 411 put(2, O_CASE2, len); 412 # endif OBJ 413 # ifdef PC 414 putprintf( " .word %d" , 0 , len ); 415 # endif PC 416 next = ap->chain; 417 do { 418 for(strptr = next->symbol; *strptr++; len++) 419 continue; 420 len++; 421 # ifdef OBJ 422 put(2, O_CASE2, len); 423 # endif OBJ 424 # ifdef PC 425 putprintf( " .word %d" , 0 , len ); 426 # endif PC 427 } while (next = next->chain); 428 /* list of scalar names */ 429 strptr = getnext(ap, &next); 430 # ifdef OBJ 431 do { 432 w = (unsigned) *strptr; 433 if (!*strptr++) 434 strptr = getnext(next, &next); 435 w |= *strptr << 8; 436 if (!*strptr++) 437 strptr = getnext(next, &next); 438 word(w); 439 } while (next); 440 /* jump over the mess */ 441 patch(oldlc); 442 # endif OBJ 443 # ifdef PC 444 while ( next ) { 445 while ( *strptr ) { 446 putprintf( " .byte 0%o" , 1 , *strptr++ ); 447 for ( w = 2 ; ( w <= 8 ) && *strptr ; w ++ ) { 448 putprintf( ",0%o" , 1 , *strptr++ ); 449 } 450 putprintf( "" , 0 ); 451 } 452 putprintf( " .byte 0" , 0 ); 453 strptr = getnext( next , &next ); 454 } 455 putprintf( " .text" , 0 ); 456 # endif PC 457 return( ap -> value[ NL_ELABEL ] ); 458 } 459 460 getnext(next, new) 461 462 struct nl *next, **new; 463 { 464 if (next != NIL) { 465 next = next->chain; 466 *new = next; 467 } 468 if (next == NIL) 469 return(""); 470 #ifdef OBJ 471 if (opt('k') && cgenflg >= 0) 472 printf(")#%5d\t\t\"%s\"\n", lc-HEADER_BYTES, next->symbol); 473 #endif OBJ 474 return(next->symbol); 475 } 476 477 #ifdef OBJ 478 /* 479 * Putspace puts out a table 480 * of nothing to leave space 481 * for the case branch table e.g. 482 */ 483 putspace(n) 484 int n; 485 { 486 register i; 487 488 if (cgenflg < 0) 489 /* 490 * code disabled - do nothing 491 */ 492 return(lc); 493 #ifdef DEBUG 494 if (opt('k')) 495 printf(")#%5d\t.=.+%d\n", lc - HEADER_BYTES, n); 496 #endif 497 for (i = even(n); i > 0; i -= 2) 498 word(0); 499 } 500 501 putstr(sptr, padding) 502 503 char *sptr; 504 int padding; 505 { 506 register unsigned short w; 507 register char *strptr = sptr; 508 register int pad = padding; 509 510 if (cgenflg < 0) 511 /* 512 * code disabled - do nothing 513 */ 514 return(lc); 515 #ifdef DEBUG 516 if (opt('k')) 517 printf(")#%5D\t\t\"%s\"\n", lc-HEADER_BYTES, strptr); 518 #endif 519 if (pad == 0) { 520 do { 521 w = (unsigned short) * strptr; 522 if (w) 523 w |= *++strptr << 8; 524 word(w); 525 } while (*strptr++); 526 } else { 527 do { 528 w = (unsigned short) * strptr; 529 if (w) { 530 if (*++strptr) 531 w |= *strptr << 8; 532 else { 533 w |= ' ' << 8; 534 pad--; 535 } 536 word(w); 537 } 538 } while (*strptr++); 539 while (pad > 1) { 540 word(' '); 541 pad -= 2; 542 } 543 if (pad == 1) 544 word(' '); 545 else 546 word(0); 547 } 548 } 549 #endif OBJ 550 551 lenstr(sptr, padding) 552 553 char *sptr; 554 int padding; 555 556 { 557 register int cnt; 558 register char *strptr = sptr; 559 560 cnt = padding; 561 do { 562 cnt++; 563 } while (*strptr++); 564 return((++cnt) & ~1); 565 } 566 567 /* 568 * Patch repairs the branch 569 * at location loc to come 570 * to the current location. 571 * for PC, this puts down the label 572 * and the branch just references that label. 573 * lets here it for two pass assemblers. 574 */ 575 patch(loc) 576 { 577 578 # ifdef OBJ 579 patchfil(loc, lc-loc-2, 1); 580 # endif OBJ 581 # ifdef PC 582 putlab( loc ); 583 # endif PC 584 } 585 586 #ifdef OBJ 587 patch4(loc) 588 { 589 590 patchfil(loc, lc - HEADER_BYTES, 2); 591 } 592 593 /* 594 * Patchfil makes loc+2 have value 595 * as its contents. 596 */ 597 patchfil(loc, value, words) 598 PTR_DCL loc; 599 int value, words; 600 { 601 register i; 602 603 if (cgenflg < 0) 604 return; 605 if (loc > (unsigned) lc) 606 panic("patchfil"); 607 #ifdef DEBUG 608 if (opt('k')) 609 printf(")#\tpatch %u %d\n", loc - HEADER_BYTES, value); 610 #endif 611 do { 612 i = ((unsigned) loc + 2 - ((unsigned) lc & ~01777))/2; 613 if (i >= 0 && i < 1024) 614 obuf[i] = value; 615 else { 616 lseek(ofil, (long) loc+2, 0); 617 write(ofil, &value, 2); 618 lseek(ofil, (long) 0, 2); 619 } 620 loc += 2; 621 value = value >> 16; 622 } while (--words); 623 } 624 625 /* 626 * Put the word o into the code 627 */ 628 word(o) 629 int o; 630 { 631 632 *obufp = o; 633 obufp++; 634 lc += 2; 635 if (obufp >= obuf+512) 636 pflush(); 637 } 638 639 extern char *obj; 640 /* 641 * Flush the code buffer 642 */ 643 pflush() 644 { 645 register i; 646 647 i = (obufp - ( ( short * ) obuf ) ) * 2; 648 if (i != 0 && write(ofil, obuf, i) != i) 649 perror(obj), pexit(DIED); 650 obufp = obuf; 651 } 652 #endif OBJ 653 654 /* 655 * Getlab - returns the location counter. 656 * included here for the eventual code generator. 657 * for PC, thank you! 658 */ 659 getlab() 660 { 661 # ifdef OBJ 662 663 return (lc); 664 # endif OBJ 665 # ifdef PC 666 static long lastlabel; 667 668 return ( ++lastlabel ); 669 # endif PC 670 } 671 672 /* 673 * Putlab - lay down a label. 674 * for PC, just print the label name with a colon after it. 675 */ 676 putlab(l) 677 int l; 678 { 679 680 # ifdef PC 681 putprintf( PREFIXFORMAT , 1 , LABELPREFIX , l ); 682 putprintf( ":" , 0 ); 683 # endif PC 684 return (l); 685 } 686 687