1 /* 2 * Copyright (c) 1983 The Regents of the University of California. 3 * All rights reserved. 4 * 5 * %sccs.include.redist.c% 6 */ 7 8 #ifndef lint 9 static char sccsid[] = "@(#)symbols.c 5.8 (Berkeley) 06/01/90"; 10 #endif /* not lint */ 11 12 /* 13 * Symbol management. 14 */ 15 16 #include "defs.h" 17 #include "symbols.h" 18 #include "languages.h" 19 #include "printsym.h" 20 #include "tree.h" 21 #include "operators.h" 22 #include "eval.h" 23 #include "mappings.h" 24 #include "events.h" 25 #include "process.h" 26 #include "runtime.h" 27 #include "machine.h" 28 #include "names.h" 29 30 #ifndef public 31 typedef struct Symbol *Symbol; 32 33 #include "machine.h" 34 #include "names.h" 35 #include "languages.h" 36 #include "tree.h" 37 38 /* 39 * Symbol classes 40 */ 41 42 typedef enum { 43 BADUSE, CONST, TYPE, VAR, ARRAY, OPENARRAY, DYNARRAY, SUBARRAY, 44 PTRFILE, RECORD, FIELD, 45 PROC, FUNC, FVAR, REF, PTR, FILET, SET, RANGE, 46 LABEL, WITHPTR, SCAL, STR, PROG, IMPROPER, VARNT, 47 FPROC, FFUNC, MODULE, TAG, COMMON, EXTREF, TYPEREF 48 } Symclass; 49 50 typedef enum { R_CONST, R_TEMP, R_ARG, R_ADJUST } Rangetype; 51 52 #define INREG 0 53 #define STK 1 54 #define EXT 2 55 56 typedef unsigned int Storage; 57 58 struct Symbol { 59 Name name; 60 Language language; 61 Symclass class : 8; 62 Storage storage : 2; 63 unsigned int level : 6; /* for variables stored on stack only */ 64 Symbol type; 65 Symbol chain; 66 union { 67 Node constval; /* value of constant symbol */ 68 int offset; /* variable address */ 69 long iconval; /* integer constant value */ 70 double fconval; /* floating constant value */ 71 int ndims; /* no. of dimensions for dynamic/sub-arrays */ 72 struct { /* field offset and size (both in bits) */ 73 int offset; 74 int length; 75 } field; 76 struct { /* common offset and chain; used to relocate */ 77 int offset; /* vars in global BSS */ 78 Symbol chain; 79 } common; 80 struct { /* range bounds */ 81 Rangetype lowertype : 16; 82 Rangetype uppertype : 16; 83 long lower; 84 long upper; 85 } rangev; 86 struct { 87 int offset : 16; /* offset for of function value */ 88 Boolean src : 1; /* true if there is source line info */ 89 Boolean inline : 1; /* true if no separate act. rec. */ 90 Boolean intern : 1; /* internal calling sequence */ 91 int unused : 13; 92 Address beginaddr; /* address of function code */ 93 } funcv; 94 struct { /* variant record info */ 95 int size; 96 Symbol vtorec; 97 Symbol vtag; 98 } varnt; 99 String typeref; /* type defined by "<module>:<type>" */ 100 Symbol extref; /* indirect symbol for external reference */ 101 } symvalue; 102 Symbol block; /* symbol containing this symbol */ 103 Symbol next_sym; /* hash chain */ 104 }; 105 106 /* 107 * Basic types. 108 */ 109 110 Symbol t_boolean; 111 Symbol t_char; 112 Symbol t_int; 113 Symbol t_real; 114 Symbol t_nil; 115 Symbol t_addr; 116 117 Symbol program; 118 Symbol curfunc; 119 120 boolean showaggrs; 121 122 #define symname(s) ident(s->name) 123 #define codeloc(f) ((f)->symvalue.funcv.beginaddr) 124 #define isblock(s) (Boolean) ( \ 125 s->class == FUNC or s->class == PROC or \ 126 s->class == MODULE or s->class == PROG \ 127 ) 128 #define isroutine(s) (Boolean) ( \ 129 s->class == FUNC or s->class == PROC \ 130 ) 131 132 #define nosource(f) (not (f)->symvalue.funcv.src) 133 #define isinline(f) ((f)->symvalue.funcv.inline) 134 135 #define isreg(s) (s->storage == INREG) 136 137 #include "tree.h" 138 139 /* 140 * Some macros to make finding a symbol with certain attributes. 141 */ 142 143 #define find(s, withname) \ 144 { \ 145 s = lookup(withname); \ 146 while (s != nil and not (s->name == (withname) and 147 148 #define where /* qualification */ 149 150 #define endfind(s) )) { \ 151 s = s->next_sym; \ 152 } \ 153 } 154 155 #endif 156 157 /* 158 * Symbol table structure currently does not support deletions. 159 * Hash table size is a power of two to make hashing faster. 160 * Using a non-prime is ok since we aren't doing rehashing. 161 */ 162 163 #define HASHTABLESIZE 8192 164 165 private Symbol hashtab[HASHTABLESIZE]; 166 167 #define hash(name) ((((unsigned) name) >> 2) & (HASHTABLESIZE - 1)) 168 169 /* 170 * Allocate a new symbol. 171 */ 172 173 #define SYMBLOCKSIZE 1000 174 175 typedef struct Sympool { 176 struct Symbol sym[SYMBLOCKSIZE]; 177 struct Sympool *prevpool; 178 } *Sympool; 179 180 private Sympool sympool = nil; 181 private Integer nleft = 0; 182 183 public Symbol symbol_alloc() 184 { 185 register Sympool newpool; 186 187 if (nleft <= 0) { 188 newpool = new(Sympool); 189 bzero(newpool, sizeof(*newpool)); 190 newpool->prevpool = sympool; 191 sympool = newpool; 192 nleft = SYMBLOCKSIZE; 193 } 194 --nleft; 195 return &(sympool->sym[nleft]); 196 } 197 198 public symbol_dump (func) 199 Symbol func; 200 { 201 register Symbol s; 202 register integer i; 203 204 printf(" symbols in %s \n",symname(func)); 205 for (i = 0; i < HASHTABLESIZE; i++) { 206 for (s = hashtab[i]; s != nil; s = s->next_sym) { 207 if (s->block == func) { 208 psym(s); 209 } 210 } 211 } 212 } 213 214 /* 215 * Free all the symbols currently allocated. 216 */ 217 218 public symbol_free() 219 { 220 Sympool s, t; 221 register Integer i; 222 223 s = sympool; 224 while (s != nil) { 225 t = s->prevpool; 226 dispose(s); 227 s = t; 228 } 229 for (i = 0; i < HASHTABLESIZE; i++) { 230 hashtab[i] = nil; 231 } 232 sympool = nil; 233 nleft = 0; 234 } 235 236 /* 237 * Create a new symbol with the given attributes. 238 */ 239 240 public Symbol newSymbol(name, blevel, class, type, chain) 241 Name name; 242 Integer blevel; 243 Symclass class; 244 Symbol type; 245 Symbol chain; 246 { 247 register Symbol s; 248 249 s = symbol_alloc(); 250 s->name = name; 251 s->language = primlang; 252 s->storage = EXT; 253 s->level = blevel; 254 s->class = class; 255 s->type = type; 256 s->chain = chain; 257 return s; 258 } 259 260 /* 261 * Insert a symbol into the hash table. 262 */ 263 264 public Symbol insert(name) 265 Name name; 266 { 267 register Symbol s; 268 register unsigned int h; 269 270 h = hash(name); 271 s = symbol_alloc(); 272 s->name = name; 273 s->next_sym = hashtab[h]; 274 hashtab[h] = s; 275 return s; 276 } 277 278 /* 279 * Symbol lookup. 280 */ 281 282 public Symbol lookup(name) 283 Name name; 284 { 285 register Symbol s; 286 register unsigned int h; 287 288 h = hash(name); 289 s = hashtab[h]; 290 while (s != nil and s->name != name) { 291 s = s->next_sym; 292 } 293 return s; 294 } 295 296 /* 297 * Delete a symbol from the symbol table. 298 */ 299 300 public delete (s) 301 Symbol s; 302 { 303 register Symbol t; 304 register unsigned int h; 305 306 h = hash(s->name); 307 t = hashtab[h]; 308 if (t == nil) { 309 panic("delete of non-symbol '%s'", symname(s)); 310 } else if (t == s) { 311 hashtab[h] = s->next_sym; 312 } else { 313 while (t->next_sym != s) { 314 t = t->next_sym; 315 if (t == nil) { 316 panic("delete of non-symbol '%s'", symname(s)); 317 } 318 } 319 t->next_sym = s->next_sym; 320 } 321 } 322 323 /* 324 * Dump out all the variables associated with the given 325 * procedure, function, or program associated with the given stack frame. 326 * 327 * This is quite inefficient. We traverse the entire symbol table 328 * each time we're called. The assumption is that this routine 329 * won't be called frequently enough to merit improved performance. 330 */ 331 332 public dumpvars(f, frame) 333 Symbol f; 334 Frame frame; 335 { 336 register Integer i; 337 register Symbol s; 338 339 for (i = 0; i < HASHTABLESIZE; i++) { 340 for (s = hashtab[i]; s != nil; s = s->next_sym) { 341 if (container(s) == f) { 342 if (should_print(s)) { 343 printv(s, frame); 344 putchar('\n'); 345 } else if (s->class == MODULE) { 346 dumpvars(s, frame); 347 } 348 } 349 } 350 } 351 } 352 353 /* 354 * Create a builtin type. 355 * Builtin types are circular in that btype->type->type = btype. 356 */ 357 358 private Symbol maketype(name, lower, upper) 359 String name; 360 long lower; 361 long upper; 362 { 363 register Symbol s; 364 Name n; 365 366 if (name == nil) { 367 n = nil; 368 } else { 369 n = identname(name, true); 370 } 371 s = insert(n); 372 s->language = primlang; 373 s->level = 0; 374 s->class = TYPE; 375 s->type = nil; 376 s->chain = nil; 377 s->type = newSymbol(nil, 0, RANGE, s, nil); 378 s->type->symvalue.rangev.lower = lower; 379 s->type->symvalue.rangev.upper = upper; 380 return s; 381 } 382 383 /* 384 * Create the builtin symbols. 385 */ 386 387 public symbols_init () 388 { 389 Symbol s; 390 391 t_boolean = maketype("$boolean", 0L, 1L); 392 t_int = maketype("$integer", 0x80000000L, 0x7fffffffL); 393 t_char = maketype("$char", 0L, 255L); 394 t_real = maketype("$real", 8L, 0L); 395 t_nil = maketype("$nil", 0L, 0L); 396 t_addr = insert(identname("$address", true)); 397 t_addr->language = primlang; 398 t_addr->level = 0; 399 t_addr->class = TYPE; 400 t_addr->type = newSymbol(nil, 1, PTR, t_int, nil); 401 s = insert(identname("true", true)); 402 s->class = CONST; 403 s->type = t_boolean; 404 s->symvalue.constval = build(O_LCON, 1L); 405 s->symvalue.constval->nodetype = t_boolean; 406 s = insert(identname("false", true)); 407 s->class = CONST; 408 s->type = t_boolean; 409 s->symvalue.constval = build(O_LCON, 0L); 410 s->symvalue.constval->nodetype = t_boolean; 411 } 412 413 /* 414 * Reduce type to avoid worrying about type names. 415 */ 416 417 public Symbol rtype(type) 418 Symbol type; 419 { 420 register Symbol t; 421 422 t = type; 423 if (t != nil) { 424 if (t->class == VAR or t->class == CONST or 425 t->class == FIELD or t->class == REF 426 ) { 427 t = t->type; 428 } 429 if (t->class == TYPEREF) { 430 resolveRef(t); 431 } 432 while (t->class == TYPE or t->class == TAG) { 433 t = t->type; 434 if (t->class == TYPEREF) { 435 resolveRef(t); 436 } 437 } 438 } 439 return t; 440 } 441 442 /* 443 * Find the end of a module name. Return nil if there is none 444 * in the given string. 445 */ 446 447 private String findModuleMark (s) 448 String s; 449 { 450 register char *p, *r; 451 register boolean done; 452 453 p = s; 454 done = false; 455 do { 456 if (*p == ':') { 457 done = true; 458 r = p; 459 } else if (*p == '\0') { 460 done = true; 461 r = nil; 462 } else { 463 ++p; 464 } 465 } while (not done); 466 return r; 467 } 468 469 /* 470 * Resolve a type reference by modifying to be the appropriate type. 471 * 472 * If the reference has a name, then it refers to an opaque type and 473 * the actual type is directly accessible. Otherwise, we must use 474 * the type reference string, which is of the form "module:{module:}name". 475 */ 476 477 public resolveRef (t) 478 Symbol t; 479 { 480 register char *p; 481 char *start; 482 Symbol s, m, outer; 483 Name n; 484 485 if (t->name != nil) { 486 s = t; 487 } else { 488 start = t->symvalue.typeref; 489 outer = program; 490 p = findModuleMark(start); 491 while (p != nil) { 492 *p = '\0'; 493 n = identname(start, true); 494 find(m, n) where m->block == outer endfind(m); 495 if (m == nil) { 496 p = nil; 497 outer = nil; 498 s = nil; 499 } else { 500 outer = m; 501 start = p + 1; 502 p = findModuleMark(start); 503 } 504 } 505 if (outer != nil) { 506 n = identname(start, true); 507 find(s, n) where s->block == outer endfind(s); 508 } 509 } 510 if (s != nil and s->type != nil) { 511 t->name = s->type->name; 512 t->class = s->type->class; 513 t->type = s->type->type; 514 t->chain = s->type->chain; 515 t->symvalue = s->type->symvalue; 516 t->block = s->type->block; 517 } 518 } 519 520 public integer regnum (s) 521 Symbol s; 522 { 523 integer r; 524 525 checkref(s); 526 if (s->storage == INREG) { 527 r = s->symvalue.offset; 528 } else { 529 r = -1; 530 } 531 return r; 532 } 533 534 public Symbol container(s) 535 Symbol s; 536 { 537 checkref(s); 538 return s->block; 539 } 540 541 public Node constval(s) 542 Symbol s; 543 { 544 checkref(s); 545 if (s->class != CONST) { 546 error("[internal error: constval(non-CONST)]"); 547 } 548 return s->symvalue.constval; 549 } 550 551 /* 552 * Return the object address of the given symbol. 553 * 554 * There are the following possibilities: 555 * 556 * globals - just take offset 557 * locals - take offset from locals base 558 * arguments - take offset from argument base 559 * register - offset is register number 560 */ 561 562 #define isglobal(s) (s->storage == EXT) 563 #define islocaloff(s) (s->storage == STK and s->symvalue.offset < 0) 564 #define isparamoff(s) (s->storage == STK and s->symvalue.offset >= 0) 565 566 public Address address (s, frame) 567 Symbol s; 568 Frame frame; 569 { 570 register Frame frp; 571 register Address addr; 572 register Symbol cur; 573 574 checkref(s); 575 if (not isactive(s->block)) { 576 error("\"%s\" is not currently defined", symname(s)); 577 } else if (isglobal(s)) { 578 addr = s->symvalue.offset; 579 } else { 580 frp = frame; 581 if (frp == nil) { 582 cur = s->block; 583 while (cur != nil and cur->class == MODULE) { 584 cur = cur->block; 585 } 586 if (cur == nil) { 587 frp = nil; 588 } else { 589 frp = findframe(cur); 590 if (frp == nil) { 591 error("[internal error: unexpected nil frame for \"%s\"]", 592 symname(s) 593 ); 594 } 595 } 596 } 597 if (islocaloff(s)) { 598 addr = locals_base(frp) + s->symvalue.offset; 599 } else if (isparamoff(s)) { 600 addr = args_base(frp) + s->symvalue.offset; 601 } else if (isreg(s)) { 602 addr = savereg(s->symvalue.offset, frp); 603 } else { 604 panic("address: bad symbol \"%s\"", symname(s)); 605 } 606 } 607 return addr; 608 } 609 610 /* 611 * Define a symbol used to access register values. 612 */ 613 614 public defregname (n, r) 615 Name n; 616 integer r; 617 { 618 Symbol s; 619 620 s = insert(n); 621 s->language = t_addr->language; 622 s->class = VAR; 623 s->storage = INREG; 624 s->level = 3; 625 s->type = t_addr; 626 s->symvalue.offset = r; 627 } 628 629 /* 630 * Resolve an "abstract" type reference. 631 * 632 * It is possible in C to define a pointer to a type, but never define 633 * the type in a particular source file. Here we try to resolve 634 * the type definition. This is problematic, it is possible to 635 * have multiple, different definitions for the same name type. 636 */ 637 638 public findtype(s) 639 Symbol s; 640 { 641 register Symbol t, u, prev; 642 643 u = s; 644 prev = nil; 645 while (u != nil and u->class != BADUSE) { 646 if (u->name != nil) { 647 prev = u; 648 } 649 u = u->type; 650 } 651 if (prev == nil) { 652 error("couldn't find link to type reference"); 653 } 654 t = lookup(prev->name); 655 while (t != nil and 656 not ( 657 t != prev and t->name == prev->name and 658 t->block->class == MODULE and t->class == prev->class and 659 t->type != nil and t->type->type != nil and 660 t->type->type->class != BADUSE 661 ) 662 ) { 663 t = t->next_sym; 664 } 665 if (t == nil) { 666 error("couldn't resolve reference"); 667 } else { 668 prev->type = t->type; 669 } 670 } 671 672 /* 673 * Find the size in bytes of the given type. 674 * 675 * This is probably the WRONG thing to do. The size should be kept 676 * as an attribute in the symbol information as is done for structures 677 * and fields. I haven't gotten around to cleaning this up yet. 678 */ 679 680 #define MAXUCHAR 255 681 #define MAXUSHORT 65535L 682 #define MINCHAR -128 683 #define MAXCHAR 127 684 #define MINSHORT -32768 685 #define MAXSHORT 32767 686 687 public findbounds (u, lower, upper) 688 Symbol u; 689 long *lower, *upper; 690 { 691 Rangetype lbt, ubt; 692 long lb, ub; 693 694 if (u->class == RANGE) { 695 lbt = u->symvalue.rangev.lowertype; 696 ubt = u->symvalue.rangev.uppertype; 697 lb = u->symvalue.rangev.lower; 698 ub = u->symvalue.rangev.upper; 699 if (lbt == R_ARG or lbt == R_TEMP) { 700 if (not getbound(u, lb, lbt, lower)) { 701 error("dynamic bounds not currently available"); 702 } 703 } else { 704 *lower = lb; 705 } 706 if (ubt == R_ARG or ubt == R_TEMP) { 707 if (not getbound(u, ub, ubt, upper)) { 708 error("dynamic bounds not currently available"); 709 } 710 } else { 711 *upper = ub; 712 } 713 } else if (u->class == SCAL) { 714 *lower = 0; 715 *upper = u->symvalue.iconval - 1; 716 } else { 717 error("[internal error: unexpected array bound type]"); 718 } 719 } 720 721 public integer size(sym) 722 Symbol sym; 723 { 724 register Symbol s, t, u; 725 register integer nel, elsize; 726 long lower, upper; 727 integer r, off, len; 728 729 t = sym; 730 checkref(t); 731 if (t->class == TYPEREF) { 732 resolveRef(t); 733 } 734 switch (t->class) { 735 case RANGE: 736 lower = t->symvalue.rangev.lower; 737 upper = t->symvalue.rangev.upper; 738 if (upper == 0 and lower > 0) { 739 /* real */ 740 r = lower; 741 } else if (lower > upper) { 742 /* unsigned long */ 743 r = sizeof(long); 744 } else if ( 745 (lower >= MINCHAR and upper <= MAXCHAR) or 746 (lower >= 0 and upper <= MAXUCHAR) 747 ) { 748 r = sizeof(char); 749 } else if ( 750 (lower >= MINSHORT and upper <= MAXSHORT) or 751 (lower >= 0 and upper <= MAXUSHORT) 752 ) { 753 r = sizeof(short); 754 } else { 755 r = sizeof(long); 756 } 757 break; 758 759 case ARRAY: 760 elsize = size(t->type); 761 nel = 1; 762 for (t = t->chain; t != nil; t = t->chain) { 763 u = rtype(t); 764 findbounds(u, &lower, &upper); 765 nel *= (upper-lower+1); 766 } 767 r = nel*elsize; 768 break; 769 770 case OPENARRAY: 771 case DYNARRAY: 772 r = (t->symvalue.ndims + 1) * sizeof(Word); 773 break; 774 775 case SUBARRAY: 776 r = (2 * t->symvalue.ndims + 1) * sizeof(Word); 777 break; 778 779 case REF: 780 case VAR: 781 r = size(t->type); 782 /* 783 * 784 if (r < sizeof(Word) and isparam(t)) { 785 r = sizeof(Word); 786 } 787 */ 788 break; 789 790 case FVAR: 791 case CONST: 792 case TAG: 793 r = size(t->type); 794 break; 795 796 case TYPE: 797 /* 798 * This causes problems on the IRIS because of the compiler bug 799 * with stab offsets for parameters. Not sure it's really 800 * necessary anyway. 801 */ 802 # ifndef IRIS 803 if (t->type->class == PTR and t->type->type->class == BADUSE) { 804 findtype(t); 805 } 806 # endif 807 r = size(t->type); 808 break; 809 810 case FIELD: 811 off = t->symvalue.field.offset; 812 len = t->symvalue.field.length; 813 r = (off + len + 7) div 8 - (off div 8); 814 break; 815 816 case RECORD: 817 case VARNT: 818 r = t->symvalue.offset; 819 if (r == 0 and t->chain != nil) { 820 panic("missing size information for record"); 821 } 822 break; 823 824 case PTR: 825 case TYPEREF: 826 case FILET: 827 r = sizeof(Word); 828 break; 829 830 case SCAL: 831 r = sizeof(Word); 832 /* 833 * 834 if (t->symvalue.iconval > 255) { 835 r = sizeof(short); 836 } else { 837 r = sizeof(char); 838 } 839 * 840 */ 841 break; 842 843 case FPROC: 844 case FFUNC: 845 r = sizeof(Word); 846 break; 847 848 case PROC: 849 case FUNC: 850 case MODULE: 851 case PROG: 852 r = sizeof(Symbol); 853 break; 854 855 case SET: 856 u = rtype(t->type); 857 switch (u->class) { 858 case RANGE: 859 r = u->symvalue.rangev.upper - u->symvalue.rangev.lower + 1; 860 break; 861 862 case SCAL: 863 r = u->symvalue.iconval; 864 break; 865 866 default: 867 error("expected range for set base type"); 868 break; 869 } 870 r = (r + BITSPERBYTE - 1) div BITSPERBYTE; 871 break; 872 873 /* 874 * These can happen in C (unfortunately) for unresolved type references 875 * Assume they are pointers. 876 */ 877 case BADUSE: 878 r = sizeof(Address); 879 break; 880 881 default: 882 if (ord(t->class) > ord(TYPEREF)) { 883 panic("size: bad class (%d)", ord(t->class)); 884 } else { 885 fprintf(stderr, "can't compute size of a %s\n", classname(t)); 886 } 887 r = 0; 888 break; 889 } 890 return r; 891 } 892 893 /* 894 * Return the size associated with a symbol that takes into account 895 * reference parameters. This might be better as the normal size function, but 896 * too many places already depend on it working the way it does. 897 */ 898 899 public integer psize (s) 900 Symbol s; 901 { 902 integer r; 903 Symbol t; 904 905 if (s->class == REF) { 906 t = rtype(s->type); 907 if (t->class == OPENARRAY) { 908 r = (t->symvalue.ndims + 1) * sizeof(Word); 909 } else if (t->class == SUBARRAY) { 910 r = (2 * t->symvalue.ndims + 1) * sizeof(Word); 911 } else { 912 r = sizeof(Word); 913 } 914 } else { 915 r = size(s); 916 } 917 return r; 918 } 919 920 /* 921 * Test if a symbol is a parameter. This is true if there 922 * is a cycle from s->block to s via chain pointers. 923 */ 924 925 public Boolean isparam(s) 926 Symbol s; 927 { 928 register Symbol t; 929 930 t = s->block; 931 while (t != nil and t != s) { 932 t = t->chain; 933 } 934 return (Boolean) (t != nil); 935 } 936 937 /* 938 * Test if a type is an open array parameter type. 939 */ 940 941 public boolean isopenarray (type) 942 Symbol type; 943 { 944 Symbol t; 945 946 t = rtype(type); 947 return (boolean) (t->class == OPENARRAY); 948 } 949 950 /* 951 * Test if a symbol is a var parameter, i.e. has class REF. 952 */ 953 954 public Boolean isvarparam(s) 955 Symbol s; 956 { 957 return (Boolean) (s->class == REF); 958 } 959 960 /* 961 * Test if a symbol is a variable (actually any addressible quantity 962 * with do). 963 */ 964 965 public Boolean isvariable(s) 966 Symbol s; 967 { 968 return (Boolean) (s->class == VAR or s->class == FVAR or s->class == REF); 969 } 970 971 /* 972 * Test if a symbol is a constant. 973 */ 974 975 public Boolean isconst(s) 976 Symbol s; 977 { 978 return (Boolean) (s->class == CONST); 979 } 980 981 /* 982 * Test if a symbol is a module. 983 */ 984 985 public Boolean ismodule(s) 986 register Symbol s; 987 { 988 return (Boolean) (s->class == MODULE); 989 } 990 991 /* 992 * Mark a procedure or function as internal, meaning that it is called 993 * with a different calling sequence. 994 */ 995 996 public markInternal (s) 997 Symbol s; 998 { 999 s->symvalue.funcv.intern = true; 1000 } 1001 1002 public boolean isinternal (s) 1003 Symbol s; 1004 { 1005 return s->symvalue.funcv.intern; 1006 } 1007 1008 /* 1009 * Decide if a field begins or ends on a bit rather than byte boundary. 1010 */ 1011 1012 public Boolean isbitfield(s) 1013 register Symbol s; 1014 { 1015 boolean b; 1016 register integer off, len; 1017 register Symbol t; 1018 1019 off = s->symvalue.field.offset; 1020 len = s->symvalue.field.length; 1021 if ((off mod BITSPERBYTE) != 0 or (len mod BITSPERBYTE) != 0) { 1022 b = true; 1023 } else { 1024 t = rtype(s->type); 1025 b = (Boolean) ( 1026 (t->class == SCAL and len != (sizeof(int)*BITSPERBYTE)) or 1027 len != (size(t)*BITSPERBYTE) 1028 ); 1029 } 1030 return b; 1031 } 1032 1033 private boolean primlang_typematch (t1, t2) 1034 Symbol t1, t2; 1035 { 1036 return (boolean) ( 1037 (t1 == t2) or 1038 ( 1039 t1->class == RANGE and t2->class == RANGE and 1040 t1->symvalue.rangev.lower == t2->symvalue.rangev.lower and 1041 t1->symvalue.rangev.upper == t2->symvalue.rangev.upper 1042 ) or ( 1043 t1->class == PTR and t2->class == RANGE and 1044 t2->symvalue.rangev.upper >= t2->symvalue.rangev.lower 1045 ) or ( 1046 t2->class == PTR and t1->class == RANGE and 1047 t1->symvalue.rangev.upper >= t1->symvalue.rangev.lower 1048 ) 1049 ); 1050 } 1051 1052 /* 1053 * Test if two types match. 1054 * Equivalent names implies a match in any language. 1055 * 1056 * Special symbols must be handled with care. 1057 */ 1058 1059 public Boolean compatible(t1, t2) 1060 register Symbol t1, t2; 1061 { 1062 Boolean b; 1063 Symbol rt1, rt2; 1064 1065 if (t1 == t2) { 1066 b = true; 1067 } else if (t1 == nil or t2 == nil) { 1068 b = false; 1069 } else if (t1 == procsym) { 1070 b = isblock(t2); 1071 } else if (t2 == procsym) { 1072 b = isblock(t1); 1073 } else if (t1->language == nil) { 1074 if (t2->language == nil) { 1075 b = false; 1076 } else if (t2->language == primlang) { 1077 b = (boolean) primlang_typematch(rtype(t1), rtype(t2)); 1078 } else { 1079 b = (boolean) (*language_op(t2->language, L_TYPEMATCH))(t1, t2); 1080 } 1081 } else if (t1->language == primlang) { 1082 if (t2->language == primlang or t2->language == nil) { 1083 b = primlang_typematch(rtype(t1), rtype(t2)); 1084 } else { 1085 b = (boolean) (*language_op(t2->language, L_TYPEMATCH))(t1, t2); 1086 } 1087 } else { 1088 b = (boolean) (*language_op(t1->language, L_TYPEMATCH))(t1, t2); 1089 } 1090 return b; 1091 } 1092 1093 /* 1094 * Check for a type of the given name. 1095 */ 1096 1097 public Boolean istypename(type, name) 1098 Symbol type; 1099 String name; 1100 { 1101 register Symbol t; 1102 Boolean b; 1103 1104 t = type; 1105 if (t == nil) { 1106 b = false; 1107 } else { 1108 b = (Boolean) ( 1109 t->class == TYPE and streq(ident(t->name), name) 1110 ); 1111 } 1112 return b; 1113 } 1114 1115 /* 1116 * Determine if a (value) parameter should actually be passed by address. 1117 */ 1118 1119 public boolean passaddr (p, exprtype) 1120 Symbol p, exprtype; 1121 { 1122 boolean b; 1123 Language def; 1124 1125 if (p == nil) { 1126 def = findlanguage(".c"); 1127 b = (boolean) (*language_op(def, L_PASSADDR))(p, exprtype); 1128 } else if (p->language == nil or p->language == primlang) { 1129 b = false; 1130 } else if (isopenarray(p->type)) { 1131 b = true; 1132 } else { 1133 b = (boolean) (*language_op(p->language, L_PASSADDR))(p, exprtype); 1134 } 1135 return b; 1136 } 1137 1138 /* 1139 * Test if the name of a symbol is uniquely defined or not. 1140 */ 1141 1142 public Boolean isambiguous(s) 1143 register Symbol s; 1144 { 1145 register Symbol t; 1146 1147 find(t, s->name) where t != s endfind(t); 1148 return (Boolean) (t != nil); 1149 } 1150 1151 typedef char *Arglist; 1152 1153 #define nextarg(type) ((type *) (ap += sizeof(type)))[-1] 1154 1155 private Symbol mkstring(); 1156 1157 /* 1158 * Determine the type of a parse tree. 1159 * 1160 * Also make some symbol-dependent changes to the tree such as 1161 * removing indirection for constant or register symbols. 1162 */ 1163 1164 public assigntypes (p) 1165 register Node p; 1166 { 1167 register Node p1; 1168 register Symbol s; 1169 1170 switch (p->op) { 1171 case O_SYM: 1172 p->nodetype = p->value.sym; 1173 break; 1174 1175 case O_LCON: 1176 p->nodetype = t_int; 1177 break; 1178 1179 case O_CCON: 1180 p->nodetype = t_char; 1181 break; 1182 1183 case O_FCON: 1184 p->nodetype = t_real; 1185 break; 1186 1187 case O_SCON: 1188 p->nodetype = mkstring(p->value.scon); 1189 break; 1190 1191 case O_INDIR: 1192 p1 = p->value.arg[0]; 1193 s = rtype(p1->nodetype); 1194 if (s->class != PTR) { 1195 beginerrmsg(); 1196 fprintf(stderr, "\""); 1197 prtree(stderr, p1); 1198 fprintf(stderr, "\" is not a pointer"); 1199 enderrmsg(); 1200 } 1201 p->nodetype = rtype(p1->nodetype)->type; 1202 break; 1203 1204 case O_DOT: 1205 p->nodetype = p->value.arg[1]->value.sym; 1206 break; 1207 1208 case O_RVAL: 1209 p1 = p->value.arg[0]; 1210 p->nodetype = p1->nodetype; 1211 if (p1->op == O_SYM) { 1212 if (p1->nodetype->class == PROC or p->nodetype->class == FUNC) { 1213 p->op = p1->op; 1214 p->value.sym = p1->value.sym; 1215 p->nodetype = p1->nodetype; 1216 dispose(p1); 1217 } else if (p1->value.sym->class == CONST) { 1218 p->op = p1->op; 1219 p->value = p1->value; 1220 p->nodetype = p1->nodetype; 1221 dispose(p1); 1222 } else if (isreg(p1->value.sym)) { 1223 p->op = O_SYM; 1224 p->value.sym = p1->value.sym; 1225 dispose(p1); 1226 } 1227 } else if (p1->op == O_INDIR and p1->value.arg[0]->op == O_SYM) { 1228 s = p1->value.arg[0]->value.sym; 1229 if (isreg(s)) { 1230 p1->op = O_SYM; 1231 dispose(p1->value.arg[0]); 1232 p1->value.sym = s; 1233 p1->nodetype = s; 1234 } 1235 } 1236 break; 1237 1238 case O_COMMA: 1239 p->nodetype = p->value.arg[0]->nodetype; 1240 break; 1241 1242 case O_CALLPROC: 1243 case O_CALL: 1244 p1 = p->value.arg[0]; 1245 p->nodetype = rtype(p1->nodetype)->type; 1246 break; 1247 1248 case O_TYPERENAME: 1249 p->nodetype = p->value.arg[1]->nodetype; 1250 break; 1251 1252 case O_ITOF: 1253 p->nodetype = t_real; 1254 break; 1255 1256 case O_NEG: 1257 s = p->value.arg[0]->nodetype; 1258 if (not compatible(s, t_int)) { 1259 if (not compatible(s, t_real)) { 1260 beginerrmsg(); 1261 fprintf(stderr, "\""); 1262 prtree(stderr, p->value.arg[0]); 1263 fprintf(stderr, "\" is improper type"); 1264 enderrmsg(); 1265 } else { 1266 p->op = O_NEGF; 1267 } 1268 } 1269 p->nodetype = s; 1270 break; 1271 1272 case O_ADD: 1273 case O_SUB: 1274 case O_MUL: 1275 binaryop(p, nil); 1276 break; 1277 1278 case O_LT: 1279 case O_LE: 1280 case O_GT: 1281 case O_GE: 1282 case O_EQ: 1283 case O_NE: 1284 binaryop(p, t_boolean); 1285 break; 1286 1287 case O_DIVF: 1288 convert(&(p->value.arg[0]), t_real, O_ITOF); 1289 convert(&(p->value.arg[1]), t_real, O_ITOF); 1290 p->nodetype = t_real; 1291 break; 1292 1293 case O_DIV: 1294 case O_MOD: 1295 convert(&(p->value.arg[0]), t_int, O_NOP); 1296 convert(&(p->value.arg[1]), t_int, O_NOP); 1297 p->nodetype = t_int; 1298 break; 1299 1300 case O_AND: 1301 case O_OR: 1302 chkboolean(p->value.arg[0]); 1303 chkboolean(p->value.arg[1]); 1304 p->nodetype = t_boolean; 1305 break; 1306 1307 case O_QLINE: 1308 p->nodetype = t_int; 1309 break; 1310 1311 default: 1312 p->nodetype = nil; 1313 break; 1314 } 1315 } 1316 1317 /* 1318 * Process a binary arithmetic or relational operator. 1319 * Convert from integer to real if necessary. 1320 */ 1321 1322 private binaryop (p, t) 1323 Node p; 1324 Symbol t; 1325 { 1326 Node p1, p2; 1327 Boolean t1real, t2real; 1328 Symbol t1, t2; 1329 1330 p1 = p->value.arg[0]; 1331 p2 = p->value.arg[1]; 1332 t1 = rtype(p1->nodetype); 1333 t2 = rtype(p2->nodetype); 1334 t1real = compatible(t1, t_real); 1335 t2real = compatible(t2, t_real); 1336 if (t1real or t2real) { 1337 p->op = (Operator) (ord(p->op) + 1); 1338 if (not t1real) { 1339 p->value.arg[0] = build(O_ITOF, p1); 1340 } else if (not t2real) { 1341 p->value.arg[1] = build(O_ITOF, p2); 1342 } 1343 p->nodetype = t_real; 1344 } else { 1345 if (size(p1->nodetype) > sizeof(integer)) { 1346 beginerrmsg(); 1347 fprintf(stderr, "operation not defined on \""); 1348 prtree(stderr, p1); 1349 fprintf(stderr, "\""); 1350 enderrmsg(); 1351 } else if (size(p2->nodetype) > sizeof(integer)) { 1352 beginerrmsg(); 1353 fprintf(stderr, "operation not defined on \""); 1354 prtree(stderr, p2); 1355 fprintf(stderr, "\""); 1356 enderrmsg(); 1357 } 1358 p->nodetype = t_int; 1359 } 1360 if (t != nil) { 1361 p->nodetype = t; 1362 } 1363 } 1364 1365 /* 1366 * Convert a tree to a type via a conversion operator; 1367 * if this isn't possible generate an error. 1368 */ 1369 1370 private convert(tp, typeto, op) 1371 Node *tp; 1372 Symbol typeto; 1373 Operator op; 1374 { 1375 Node tree; 1376 Symbol s, t; 1377 1378 tree = *tp; 1379 s = rtype(tree->nodetype); 1380 t = rtype(typeto); 1381 if (compatible(t, t_real) and compatible(s, t_int)) { 1382 /* we can convert int => floating but not the reverse */ 1383 tree = build(op, tree); 1384 } else if (not compatible(s, t)) { 1385 beginerrmsg(); 1386 prtree(stderr, tree); 1387 fprintf(stderr, ": illegal type in operation"); 1388 enderrmsg(); 1389 } 1390 *tp = tree; 1391 } 1392 1393 /* 1394 * Construct a node for the dot operator. 1395 * 1396 * If the left operand is not a record, but rather a procedure 1397 * or function, then we interpret the "." as referencing an 1398 * "invisible" variable; i.e. a variable within a dynamically 1399 * active block but not within the static scope of the current procedure. 1400 */ 1401 1402 public Node dot(record, fieldname) 1403 Node record; 1404 Name fieldname; 1405 { 1406 register Node rec, p; 1407 register Symbol s, t; 1408 1409 rec = record; 1410 if (isblock(rec->nodetype)) { 1411 find(s, fieldname) where 1412 s->block == rec->nodetype and 1413 s->class != FIELD 1414 endfind(s); 1415 if (s == nil) { 1416 beginerrmsg(); 1417 fprintf(stderr, "\"%s\" is not defined in ", ident(fieldname)); 1418 printname(stderr, rec->nodetype); 1419 enderrmsg(); 1420 } 1421 p = new(Node); 1422 p->op = O_SYM; 1423 p->value.sym = s; 1424 p->nodetype = s; 1425 } else { 1426 p = rec; 1427 t = rtype(p->nodetype); 1428 if (t->class == PTR) { 1429 s = findfield(fieldname, t->type); 1430 } else { 1431 s = findfield(fieldname, t); 1432 } 1433 if (s == nil) { 1434 beginerrmsg(); 1435 fprintf(stderr, "\"%s\" is not a field in ", ident(fieldname)); 1436 prtree(stderr, rec); 1437 enderrmsg(); 1438 } 1439 if (t->class != PTR or isreg(rec->nodetype)) { 1440 p = unrval(p); 1441 } 1442 p->nodetype = t_addr; 1443 p = build(O_DOT, p, build(O_SYM, s)); 1444 } 1445 return build(O_RVAL, p); 1446 } 1447 1448 /* 1449 * Return a tree corresponding to an array reference and do the 1450 * error checking. 1451 */ 1452 1453 public Node subscript(a, slist) 1454 Node a, slist; 1455 { 1456 Symbol t; 1457 Node p; 1458 1459 t = rtype(a->nodetype); 1460 if (t->language == nil or t->language == primlang) { 1461 p = (Node) (*language_op(findlanguage(".s"), L_BUILDAREF))(a, slist); 1462 } else { 1463 p = (Node) (*language_op(t->language, L_BUILDAREF))(a, slist); 1464 } 1465 return build(O_RVAL, p); 1466 } 1467 1468 /* 1469 * Evaluate a subscript index. 1470 */ 1471 1472 public int evalindex(s, base, i) 1473 Symbol s; 1474 Address base; 1475 long i; 1476 { 1477 Symbol t; 1478 int r; 1479 1480 t = rtype(s); 1481 if (t->language == nil or t->language == primlang) { 1482 r = ((*language_op(findlanguage(".s"), L_EVALAREF)) (s, base, i)); 1483 } else { 1484 r = ((*language_op(t->language, L_EVALAREF)) (s, base, i)); 1485 } 1486 return r; 1487 } 1488 1489 /* 1490 * Check to see if a tree is boolean-valued, if not it's an error. 1491 */ 1492 1493 public chkboolean(p) 1494 register Node p; 1495 { 1496 if (p->nodetype != t_boolean) { 1497 beginerrmsg(); 1498 fprintf(stderr, "found "); 1499 prtree(stderr, p); 1500 fprintf(stderr, ", expected boolean expression"); 1501 enderrmsg(); 1502 } 1503 } 1504 1505 /* 1506 * Construct a node for the type of a string. 1507 */ 1508 1509 private Symbol mkstring(str) 1510 String str; 1511 { 1512 register Symbol s; 1513 1514 s = newSymbol(nil, 0, ARRAY, t_char, nil); 1515 s->chain = newSymbol(nil, 0, RANGE, t_int, nil); 1516 s->chain->language = s->language; 1517 s->chain->symvalue.rangev.lower = 1; 1518 s->chain->symvalue.rangev.upper = strlen(str) + 1; 1519 return s; 1520 } 1521 1522 /* 1523 * Free up the space allocated for a string type. 1524 */ 1525 1526 public unmkstring(s) 1527 Symbol s; 1528 { 1529 dispose(s->chain); 1530 } 1531 1532 /* 1533 * Figure out the "current" variable or function being referred to 1534 * by the name n. 1535 */ 1536 1537 private boolean stwhich(), dynwhich(); 1538 1539 public Symbol which (n) 1540 Name n; 1541 { 1542 Symbol s; 1543 1544 s = lookup(n); 1545 if (s == nil) { 1546 error("\"%s\" is not defined", ident(n)); 1547 } else if (not stwhich(&s) and isambiguous(s) and not dynwhich(&s)) { 1548 printf("[using "); 1549 printname(stdout, s); 1550 printf("]\n"); 1551 } 1552 return s; 1553 } 1554 1555 /* 1556 * Static search. 1557 */ 1558 1559 private boolean stwhich (var_s) 1560 Symbol *var_s; 1561 { 1562 Name n; /* name of desired symbol */ 1563 Symbol s; /* iteration variable for symbols with name n */ 1564 Symbol f; /* iteration variable for blocks containing s */ 1565 integer count; /* number of levels from s->block to curfunc */ 1566 Symbol t; /* current best answer for stwhich(n) */ 1567 integer mincount; /* relative level for current best answer (t) */ 1568 boolean b; /* return value, true if symbol found */ 1569 1570 s = *var_s; 1571 n = s->name; 1572 t = s; 1573 mincount = 10000; /* force first match to set mincount */ 1574 do { 1575 if (s->name == n and s->class != FIELD and s->class != TAG) { 1576 f = curfunc; 1577 count = 0; 1578 while (f != nil and f != s->block) { 1579 ++count; 1580 f = f->block; 1581 } 1582 if (f != nil and count < mincount) { 1583 t = s; 1584 mincount = count; 1585 b = true; 1586 } 1587 } 1588 s = s->next_sym; 1589 } while (s != nil); 1590 if (mincount != 10000) { 1591 *var_s = t; 1592 b = true; 1593 } else { 1594 b = false; 1595 } 1596 return b; 1597 } 1598 1599 /* 1600 * Dynamic search. 1601 */ 1602 1603 private boolean dynwhich (var_s) 1604 Symbol *var_s; 1605 { 1606 Name n; /* name of desired symbol */ 1607 Symbol s; /* iteration variable for possible symbols */ 1608 Symbol f; /* iteration variable for active functions */ 1609 Frame frp; /* frame associated with stack walk */ 1610 boolean b; /* return value */ 1611 1612 f = curfunc; 1613 frp = curfuncframe(); 1614 n = (*var_s)->name; 1615 b = false; 1616 if (frp != nil) { 1617 frp = nextfunc(frp, &f); 1618 while (frp != nil) { 1619 s = *var_s; 1620 while (s != nil and 1621 ( 1622 s->name != n or s->block != f or 1623 s->class == FIELD or s->class == TAG 1624 ) 1625 ) { 1626 s = s->next_sym; 1627 } 1628 if (s != nil) { 1629 *var_s = s; 1630 b = true; 1631 break; 1632 } 1633 if (f == program) { 1634 break; 1635 } 1636 frp = nextfunc(frp, &f); 1637 } 1638 } 1639 return b; 1640 } 1641 1642 /* 1643 * Find the symbol that has the same name and scope as the 1644 * given symbol but is of the given field. Return nil if there is none. 1645 */ 1646 1647 public Symbol findfield (fieldname, record) 1648 Name fieldname; 1649 Symbol record; 1650 { 1651 register Symbol t; 1652 1653 t = rtype(record)->chain; 1654 while (t != nil and t->name != fieldname) { 1655 t = t->chain; 1656 } 1657 return t; 1658 } 1659 1660 public Boolean getbound(s,off,type,valp) 1661 Symbol s; 1662 int off; 1663 Rangetype type; 1664 int *valp; 1665 { 1666 Frame frp; 1667 Address addr; 1668 Symbol cur; 1669 1670 if (not isactive(s->block)) { 1671 return(false); 1672 } 1673 cur = s->block; 1674 while (cur != nil and cur->class == MODULE) { /* WHY*/ 1675 cur = cur->block; 1676 } 1677 if(cur == nil) { 1678 cur = whatblock(pc); 1679 } 1680 frp = findframe(cur); 1681 if (frp == nil) { 1682 return(false); 1683 } 1684 if(type == R_TEMP) addr = locals_base(frp) + off; 1685 else if (type == R_ARG) addr = args_base(frp) + off; 1686 else return(false); 1687 dread(valp,addr,sizeof(long)); 1688 return(true); 1689 } 1690