xref: /original-bsd/old/dbx/symbols.c (revision bf37e3ac)
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