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.9 (Berkeley) 03/05/91";
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 inlne : 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.inlne)
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
symbol_alloc()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
symbol_dump(func)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
symbol_free()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
newSymbol(name,blevel,class,type,chain)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
insert(name)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
lookup(name)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
delete(s)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
dumpvars(f,frame)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
maketype(name,lower,upper)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
symbols_init()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
rtype(type)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
findModuleMark(s)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
resolveRef(t)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
regnum(s)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
container(s)534 public Symbol container(s)
535 Symbol s;
536 {
537 checkref(s);
538 return s->block;
539 }
540
constval(s)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
address(s,frame)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
defregname(n,r)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
findtype(s)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
findbounds(u,lower,upper)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
size(sym)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
psize(s)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
isparam(s)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
isopenarray(type)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
isvarparam(s)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
isvariable(s)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
isconst(s)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
ismodule(s)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
markInternal(s)996 public markInternal (s)
997 Symbol s;
998 {
999 s->symvalue.funcv.intern = true;
1000 }
1001
isinternal(s)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
isbitfield(s)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
primlang_typematch(t1,t2)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
compatible(t1,t2)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
istypename(type,name)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
passaddr(p,exprtype)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
isambiguous(s)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
assigntypes(p)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
binaryop(p,t)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
convert(tp,typeto,op)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
dot(record,fieldname)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
subscript(a,slist)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
evalindex(s,base,i)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
chkboolean(p)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
mkstring(str)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
unmkstring(s)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
which(n)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
stwhich(var_s)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
dynwhich(var_s)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
findfield(fieldname,record)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
getbound(s,off,type,valp)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