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