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