-/* Copyright (c) 1982 Regents of the University of California */
+/*
+ * Copyright (c) 1983 Regents of the University of California.
+ * All rights reserved. The Berkeley software License Agreement
+ * specifies the terms and conditions for redistribution.
+ */
+
+#ifndef lint
+static char sccsid[] = "@(#)symbols.c 5.5 (Berkeley) %G%";
+#endif not lint
-static char sccsid[] = "@(#)symbols.c 1.12 %G%";
+static char rcsid[] = "$Header: symbols.c,v 1.4 88/04/02 01:29:03 donn Exp $";
/*
* Symbol management.
#include "machine.h"
#include "names.h"
#include "languages.h"
+#include "tree.h"
/*
* Symbol classes
*/
typedef enum {
- BADUSE, CONST, TYPE, VAR, ARRAY, PTRFILE, RECORD, FIELD,
+ BADUSE, CONST, TYPE, VAR, ARRAY, OPENARRAY, DYNARRAY, SUBARRAY,
+ PTRFILE, RECORD, FIELD,
PROC, FUNC, FVAR, REF, PTR, FILET, SET, RANGE,
LABEL, WITHPTR, SCAL, STR, PROG, IMPROPER, VARNT,
- FPROC, FFUNC, MODULE, TAG, COMMON, TYPEREF
+ FPROC, FFUNC, MODULE, TAG, COMMON, EXTREF, TYPEREF
} Symclass;
typedef enum { R_CONST, R_TEMP, R_ARG, R_ADJUST } Rangetype;
+#define INREG 0
+#define STK 1
+#define EXT 2
+
+typedef unsigned integer Storage;
+
struct Symbol {
Name name;
Language language;
Symclass class : 8;
- Integer level : 8;
+ Storage storage : 2;
+ unsigned int level : 6; /* for variables stored on stack only */
Symbol type;
Symbol chain;
union {
+ Node constval; /* value of constant symbol */
int offset; /* variable address */
long iconval; /* integer constant value */
double fconval; /* floating constant value */
+ int ndims; /* no. of dimensions for dynamic/sub-arrays */
struct { /* field offset and size (both in bits) */
int offset;
int length;
} rangev;
struct {
int offset : 16; /* offset for of function value */
- Boolean src : 8; /* true if there is source line info */
- Boolean inline : 8; /* true if no separate act. rec. */
+ Boolean src : 1; /* true if there is source line info */
+ Boolean inline : 1; /* true if no separate act. rec. */
+ Boolean intern : 1; /* internal calling sequence */
+ int unused : 13;
Address beginaddr; /* address of function code */
} funcv;
struct { /* variant record info */
Symbol vtorec;
Symbol vtag;
} varnt;
+ String typeref; /* type defined by "<module>:<type>" */
+ Symbol extref; /* indirect symbol for external reference */
} symvalue;
Symbol block; /* symbol containing this symbol */
Symbol next_sym; /* hash chain */
Symbol t_int;
Symbol t_real;
Symbol t_nil;
+Symbol t_addr;
Symbol program;
Symbol curfunc;
+boolean showaggrs;
+
#define symname(s) ident(s->name)
#define codeloc(f) ((f)->symvalue.funcv.beginaddr)
#define isblock(s) (Boolean) ( \
s->class == FUNC or s->class == PROC or \
s->class == MODULE or s->class == PROG \
)
+#define isroutine(s) (Boolean) ( \
+ s->class == FUNC or s->class == PROC \
+)
#define nosource(f) (not (f)->symvalue.funcv.src)
#define isinline(f) ((f)->symvalue.funcv.inline)
+#define isreg(s) (s->storage == INREG)
+
#include "tree.h"
/*
/*
* Symbol table structure currently does not support deletions.
+ * Hash table size is a power of two to make hashing faster.
+ * Using a non-prime is ok since we aren't doing rehashing.
*/
-#define HASHTABLESIZE 2003
+#define HASHTABLESIZE 8192
private Symbol hashtab[HASHTABLESIZE];
-#define hash(name) ((((unsigned) name) >> 2) mod HASHTABLESIZE)
+#define hash(name) ((((unsigned) name) >> 2) & (HASHTABLESIZE - 1))
/*
* Allocate a new symbol.
*/
-#define SYMBLOCKSIZE 100
+#define SYMBLOCKSIZE 1000
typedef struct Sympool {
struct Symbol sym[SYMBLOCKSIZE];
if (nleft <= 0) {
newpool = new(Sympool);
- bzero(newpool, sizeof(newpool));
+ bzero(newpool, sizeof(*newpool));
newpool->prevpool = sympool;
sympool = newpool;
nleft = SYMBLOCKSIZE;
return &(sympool->sym[nleft]);
}
-
-public symbol_dump(func)
+public symbol_dump (func)
Symbol func;
{
register Symbol s;
- register Integer i;
+ register integer i;
printf(" symbols in %s \n",symname(func));
- for (i = 0; i< HASHTABLESIZE; i++) {
+ for (i = 0; i < HASHTABLESIZE; i++) {
for (s = hashtab[i]; s != nil; s = s->next_sym) {
if (s->block == func) {
psym(s);
s = symbol_alloc();
s->name = name;
+ s->language = primlang;
+ s->storage = EXT;
s->level = blevel;
s->class = class;
s->type = type;
return s;
}
+/*
+ * Delete a symbol from the symbol table.
+ */
+
+public delete (s)
+Symbol s;
+{
+ register Symbol t;
+ register unsigned int h;
+
+ h = hash(s->name);
+ t = hashtab[h];
+ if (t == nil) {
+ panic("delete of non-symbol '%s'", symname(s));
+ } else if (t == s) {
+ hashtab[h] = s->next_sym;
+ } else {
+ while (t->next_sym != s) {
+ t = t->next_sym;
+ if (t == nil) {
+ panic("delete of non-symbol '%s'", symname(s));
+ }
+ }
+ t->next_sym = s->next_sym;
+ }
+}
+
/*
* Dump out all the variables associated with the given
- * procedure, function, or program at the given recursive level.
+ * procedure, function, or program associated with the given stack frame.
*
* This is quite inefficient. We traverse the entire symbol table
* each time we're called. The assumption is that this routine
}
}
-/*
- * Create base types.
- */
-
-public symbols_init()
-{
- t_boolean = maketype("$boolean", 0L, 1L);
- t_int = maketype("$integer", 0x80000000L, 0x7fffffffL);
- t_char = maketype("$char", 0L, 127L);
- t_real = maketype("$real", 8L, 0L);
- t_nil = maketype("$nil", 0L, 0L);
-}
-
/*
* Create a builtin type.
* Builtin types are circular in that btype->type->type = btype.
*/
-public Symbol maketype(name, lower, upper)
+private Symbol maketype(name, lower, upper)
String name;
long lower;
long upper;
{
register Symbol s;
+ Name n;
- s = newSymbol(identname(name, true), 0, TYPE, nil, nil);
- s->language = findlanguage(".c");
+ if (name == nil) {
+ n = nil;
+ } else {
+ n = identname(name, true);
+ }
+ s = insert(n);
+ s->language = primlang;
+ s->level = 0;
+ s->class = TYPE;
+ s->type = nil;
+ s->chain = nil;
s->type = newSymbol(nil, 0, RANGE, s, nil);
s->type->symvalue.rangev.lower = lower;
s->type->symvalue.rangev.upper = upper;
}
/*
- * These functions are now compiled inline.
- *
- * public String symname(s)
-Symbol s;
-{
- checkref(s);
- return ident(s->name);
-}
+ * Create the builtin symbols.
+ */
- *
- * public Address codeloc(f)
-Symbol f;
+public symbols_init ()
{
- checkref(f);
- if (not isblock(f)) {
- panic("codeloc: \"%s\" is not a block", ident(f->name));
- }
- return f->symvalue.funcv.beginaddr;
+ Symbol s;
+
+ t_boolean = maketype("$boolean", 0L, 1L);
+ t_int = maketype("$integer", 0x80000000L, 0x7fffffffL);
+ t_char = maketype("$char", 0L, 255L);
+ t_real = maketype("$real", 8L, 0L);
+ t_nil = maketype("$nil", 0L, 0L);
+ t_addr = insert(identname("$address", true));
+ t_addr->language = primlang;
+ t_addr->level = 0;
+ t_addr->class = TYPE;
+ t_addr->type = newSymbol(nil, 1, PTR, t_int, nil);
+ s = insert(identname("true", true));
+ s->class = CONST;
+ s->type = t_boolean;
+ s->symvalue.constval = build(O_LCON, 1L);
+ s->symvalue.constval->nodetype = t_boolean;
+ s = insert(identname("false", true));
+ s->class = CONST;
+ s->type = t_boolean;
+ s->symvalue.constval = build(O_LCON, 0L);
+ s->symvalue.constval->nodetype = t_boolean;
}
- *
- */
/*
* Reduce type to avoid worrying about type names.
t = type;
if (t != nil) {
- if (t->class == VAR or t->class == FIELD or t->class == REF ) {
+ if (t->class == VAR or t->class == CONST or
+ t->class == FIELD or t->class == REF
+ ) {
t = t->type;
}
+ if (t->class == TYPEREF) {
+ resolveRef(t);
+ }
while (t->class == TYPE or t->class == TAG) {
t = t->type;
+ if (t->class == TYPEREF) {
+ resolveRef(t);
+ }
}
}
return t;
}
-public Integer level(s)
+/*
+ * Find the end of a module name. Return nil if there is none
+ * in the given string.
+ */
+
+private String findModuleMark (s)
+String s;
+{
+ register char *p, *r;
+ register boolean done;
+
+ p = s;
+ done = false;
+ do {
+ if (*p == ':') {
+ done = true;
+ r = p;
+ } else if (*p == '\0') {
+ done = true;
+ r = nil;
+ } else {
+ ++p;
+ }
+ } while (not done);
+ return r;
+}
+
+/*
+ * Resolve a type reference by modifying to be the appropriate type.
+ *
+ * If the reference has a name, then it refers to an opaque type and
+ * the actual type is directly accessible. Otherwise, we must use
+ * the type reference string, which is of the form "module:{module:}name".
+ */
+
+public resolveRef (t)
+Symbol t;
+{
+ register char *p;
+ char *start;
+ Symbol s, m, outer;
+ Name n;
+
+ if (t->name != nil) {
+ s = t;
+ } else {
+ start = t->symvalue.typeref;
+ outer = program;
+ p = findModuleMark(start);
+ while (p != nil) {
+ *p = '\0';
+ n = identname(start, true);
+ find(m, n) where m->block == outer endfind(m);
+ if (m == nil) {
+ p = nil;
+ outer = nil;
+ s = nil;
+ } else {
+ outer = m;
+ start = p + 1;
+ p = findModuleMark(start);
+ }
+ }
+ if (outer != nil) {
+ n = identname(start, true);
+ find(s, n) where s->block == outer endfind(s);
+ }
+ }
+ if (s != nil and s->type != nil) {
+ t->name = s->type->name;
+ t->class = s->type->class;
+ t->type = s->type->type;
+ t->chain = s->type->chain;
+ t->symvalue = s->type->symvalue;
+ t->block = s->type->block;
+ }
+}
+
+public integer regnum (s)
Symbol s;
{
+ integer r;
+
checkref(s);
- return s->level;
+ if (s->storage == INREG) {
+ r = s->symvalue.offset;
+ } else {
+ r = -1;
+ }
+ return r;
}
public Symbol container(s)
return s->block;
}
+public Node constval(s)
+Symbol s;
+{
+ checkref(s);
+ if (s->class != CONST) {
+ error("[internal error: constval(non-CONST)]");
+ }
+ return s->symvalue.constval;
+}
+
/*
* Return the object address of the given symbol.
*
* register - offset is register number
*/
-#define isglobal(s) (s->level == 1 or s->level == 2)
-#define islocaloff(s) (s->level >= 3 and s->symvalue.offset < 0)
-#define isparamoff(s) (s->level >= 3 and s->symvalue.offset >= 0)
-#define isreg(s) (s->level < 0)
+#define isglobal(s) (s->storage == EXT)
+#define islocaloff(s) (s->storage == STK and s->symvalue.offset < 0)
+#define isparamoff(s) (s->storage == STK and s->symvalue.offset >= 0)
-public Address address(s, frame)
+public Address address (s, frame)
Symbol s;
Frame frame;
{
cur = cur->block;
}
if (cur == nil) {
- cur = whatblock(pc);
- }
- frp = findframe(cur);
- if (frp == nil) {
- panic("unexpected nil frame for \"%s\"", symname(s));
+ frp = nil;
+ } else {
+ frp = findframe(cur);
+ if (frp == nil) {
+ error("[internal error: unexpected nil frame for \"%s\"]",
+ symname(s)
+ );
+ }
}
}
if (islocaloff(s)) {
* Define a symbol used to access register values.
*/
-public defregname(n, r)
+public defregname (n, r)
Name n;
-Integer r;
+integer r;
{
- register Symbol s, t;
+ Symbol s;
s = insert(n);
- t = newSymbol(nil, 0, PTR, t_int, nil);
- t->language = findlanguage(".s");
- s->language = t->language;
+ s->language = t_addr->language;
s->class = VAR;
- s->level = -3;
- s->type = t;
- s->block = program;
+ s->storage = INREG;
+ s->level = 3;
+ s->type = t_addr;
s->symvalue.offset = r;
}
if (prev == nil) {
error("couldn't find link to type reference");
}
- find(t, prev->name) where
- t->type != nil and t->class == prev->class and
- t->type->class != BADUSE and t->block->class == MODULE
- endfind(t);
+ t = lookup(prev->name);
+ while (t != nil and
+ not (
+ t != prev and t->name == prev->name and
+ t->block->class == MODULE and t->class == prev->class and
+ t->type != nil and t->type->type != nil and
+ t->type->type->class != BADUSE
+ )
+ ) {
+ t = t->next_sym;
+ }
if (t == nil) {
error("couldn't resolve reference");
} else {
#define MINSHORT -32768
#define MAXSHORT 32767
-public Integer size(sym)
+public findbounds (u, lower, upper)
+Symbol u;
+long *lower, *upper;
+{
+ Rangetype lbt, ubt;
+ long lb, ub;
+
+ if (u->class == RANGE) {
+ lbt = u->symvalue.rangev.lowertype;
+ ubt = u->symvalue.rangev.uppertype;
+ lb = u->symvalue.rangev.lower;
+ ub = u->symvalue.rangev.upper;
+ if (lbt == R_ARG or lbt == R_TEMP) {
+ if (not getbound(u, lb, lbt, lower)) {
+ error("dynamic bounds not currently available");
+ }
+ } else {
+ *lower = lb;
+ }
+ if (ubt == R_ARG or ubt == R_TEMP) {
+ if (not getbound(u, ub, ubt, upper)) {
+ error("dynamic bounds not currently available");
+ }
+ } else {
+ *upper = ub;
+ }
+ } else if (u->class == SCAL) {
+ *lower = 0;
+ *upper = u->symvalue.iconval - 1;
+ } else {
+ error("[internal error: unexpected array bound type]");
+ }
+}
+
+public integer size(sym)
Symbol sym;
{
- register Symbol s, t;
- register int nel, elsize;
+ register Symbol s, t, u;
+ register integer nel, elsize;
long lower, upper;
- int r;
+ integer r, off, len;
t = sym;
checkref(t);
+ if (t->class == TYPEREF) {
+ resolveRef(t);
+ }
switch (t->class) {
case RANGE:
lower = t->symvalue.rangev.lower;
upper = t->symvalue.rangev.upper;
- if (upper == 0 and lower > 0) { /* real */
+ if (upper == 0 and lower > 0) {
+ /* real */
r = lower;
+ } else if (lower > upper) {
+ /* unsigned long */
+ r = sizeof(long);
} else if (
(lower >= MINCHAR and upper <= MAXCHAR) or
(lower >= 0 and upper <= MAXUCHAR)
elsize = size(t->type);
nel = 1;
for (t = t->chain; t != nil; t = t->chain) {
- if (t->symvalue.rangev.lowertype == R_ARG or
- t->symvalue.rangev.lowertype == R_TEMP) {
- if (not getbound(t, t->symvalue.rangev.lower,
- t->symvalue.rangev.lowertype, &lower)) {
- error("dynamic bounds not currently available");
- }
- } else {
- lower = t->symvalue.rangev.lower;
- }
- if (t->symvalue.rangev.uppertype == R_ARG or
- t->symvalue.rangev.uppertype == R_TEMP) {
- if (not getbound(t, t->symvalue.rangev.upper,
- t->symvalue.rangev.uppertype, &upper)) {
- error("dynamic bounds nor currently available");
- }
- } else {
- upper = t->symvalue.rangev.upper;
- }
+ u = rtype(t);
+ findbounds(u, &lower, &upper);
nel *= (upper-lower+1);
}
r = nel*elsize;
break;
+ case OPENARRAY:
+ case DYNARRAY:
+ r = (t->symvalue.ndims + 1) * sizeof(Word);
+ break;
+
+ case SUBARRAY:
+ r = (2 * t->symvalue.ndims + 1) * sizeof(Word);
+ break;
+
case REF:
case VAR:
- case FVAR:
r = size(t->type);
/*
*
*/
break;
+ case FVAR:
case CONST:
+ case TAG:
r = size(t->type);
break;
case TYPE:
+ /*
+ * This causes problems on the IRIS because of the compiler bug
+ * with stab offsets for parameters. Not sure it's really
+ * necessary anyway.
+ */
+# ifndef IRIS
if (t->type->class == PTR and t->type->type->class == BADUSE) {
findtype(t);
}
- r = size(t->type);
- break;
-
- case TAG:
+# endif
r = size(t->type);
break;
case FIELD:
- r = (t->symvalue.field.length + 7) div 8;
+ off = t->symvalue.field.offset;
+ len = t->symvalue.field.length;
+ r = (off + len + 7) div 8 - (off div 8);
break;
case RECORD:
break;
case PTR:
+ case TYPEREF:
case FILET:
r = sizeof(Word);
break;
r = sizeof(Symbol);
break;
+ case SET:
+ u = rtype(t->type);
+ switch (u->class) {
+ case RANGE:
+ r = u->symvalue.rangev.upper - u->symvalue.rangev.lower + 1;
+ break;
+
+ case SCAL:
+ r = u->symvalue.iconval;
+ break;
+
+ default:
+ error("expected range for set base type");
+ break;
+ }
+ r = (r + BITSPERBYTE - 1) div BITSPERBYTE;
+ break;
+
+ /*
+ * These can happen in C (unfortunately) for unresolved type references
+ * Assume they are pointers.
+ */
+ case BADUSE:
+ r = sizeof(Address);
+ break;
+
default:
if (ord(t->class) > ord(TYPEREF)) {
panic("size: bad class (%d)", ord(t->class));
} else {
- error("improper operation on a %s", classname(t));
+ fprintf(stderr, "can't compute size of a %s\n", classname(t));
}
- /* NOTREACHED */
+ r = 0;
+ break;
+ }
+ return r;
+}
+
+/*
+ * Return the size associated with a symbol that takes into account
+ * reference parameters. This might be better as the normal size function, but
+ * too many places already depend on it working the way it does.
+ */
+
+public integer psize (s)
+Symbol s;
+{
+ integer r;
+ Symbol t;
+
+ if (s->class == REF) {
+ t = rtype(s->type);
+ if (t->class == OPENARRAY) {
+ r = (t->symvalue.ndims + 1) * sizeof(Word);
+ } else if (t->class == SUBARRAY) {
+ r = (2 * t->symvalue.ndims + 1) * sizeof(Word);
+ } else {
+ r = sizeof(Word);
+ }
+ } else {
+ r = size(s);
}
return r;
}
return (Boolean) (t != nil);
}
+/*
+ * Test if a type is an open array parameter type.
+ */
+
+public boolean isopenarray (type)
+Symbol type;
+{
+ Symbol t;
+
+ t = rtype(type);
+ return (boolean) (t->class == OPENARRAY);
+}
+
/*
* Test if a symbol is a var parameter, i.e. has class REF.
*/
*/
public Boolean isvariable(s)
-register Symbol s;
+Symbol s;
{
return (Boolean) (s->class == VAR or s->class == FVAR or s->class == REF);
}
/*
- * Test if a symbol is a block, e.g. function, procedure, or the
- * main program.
- *
- * This function is now expanded inline for efficiency.
- *
- * public Boolean isblock(s)
-register Symbol s;
+ * Test if a symbol is a constant.
+ */
+
+public Boolean isconst(s)
+Symbol s;
{
- return (Boolean) (
- s->class == FUNC or s->class == PROC or
- s->class == MODULE or s->class == PROG
- );
+ return (Boolean) (s->class == CONST);
}
- *
- */
/*
* Test if a symbol is a module.
}
/*
- * Test if a symbol is builtin, that is, a predefined type or
- * reserved word.
+ * Mark a procedure or function as internal, meaning that it is called
+ * with a different calling sequence.
*/
-public Boolean isbuiltin(s)
+public markInternal (s)
+Symbol s;
+{
+ s->symvalue.funcv.intern = true;
+}
+
+public boolean isinternal (s)
+Symbol s;
+{
+ return s->symvalue.funcv.intern;
+}
+
+/*
+ * Decide if a field begins or ends on a bit rather than byte boundary.
+ */
+
+public Boolean isbitfield(s)
register Symbol s;
{
- return (Boolean) (s->level == 0 and s->class != PROG and s->class != VAR);
+ boolean b;
+ register integer off, len;
+ register Symbol t;
+
+ off = s->symvalue.field.offset;
+ len = s->symvalue.field.length;
+ if ((off mod BITSPERBYTE) != 0 or (len mod BITSPERBYTE) != 0) {
+ b = true;
+ } else {
+ t = rtype(s->type);
+ b = (Boolean) (
+ (t->class == SCAL and len != (sizeof(int)*BITSPERBYTE)) or
+ len != (size(t)*BITSPERBYTE)
+ );
+ }
+ return b;
+}
+
+private boolean primlang_typematch (t1, t2)
+Symbol t1, t2;
+{
+ return (boolean) (
+ (t1 == t2) or
+ (
+ t1->class == RANGE and t2->class == RANGE and
+ t1->symvalue.rangev.lower == t2->symvalue.rangev.lower and
+ t1->symvalue.rangev.upper == t2->symvalue.rangev.upper
+ ) or (
+ t1->class == PTR and t2->class == RANGE and
+ t2->symvalue.rangev.upper >= t2->symvalue.rangev.lower
+ ) or (
+ t2->class == PTR and t1->class == RANGE and
+ t1->symvalue.rangev.upper >= t1->symvalue.rangev.lower
+ )
+ );
}
/*
register Symbol t1, t2;
{
Boolean b;
+ Symbol rt1, rt2;
if (t1 == t2) {
b = true;
} else if (t2 == procsym) {
b = isblock(t1);
} else if (t1->language == nil) {
- b = (Boolean) (t2->language == nil or
- (*language_op(t2->language, L_TYPEMATCH))(t1, t2));
- } else if (t2->language == nil) {
- b = (Boolean) (*language_op(t1->language, L_TYPEMATCH))(t1, t2);
- } else if ( isbuiltin(t1) or isbuiltin(t1->type) ) {
- b = (Boolean) (*language_op(t2->language, L_TYPEMATCH))(t1, t2);
+ if (t2->language == nil) {
+ b = false;
+ } else if (t2->language == primlang) {
+ b = (boolean) primlang_typematch(rtype(t1), rtype(t2));
+ } else {
+ b = (boolean) (*language_op(t2->language, L_TYPEMATCH))(t1, t2);
+ }
+ } else if (t1->language == primlang) {
+ if (t2->language == primlang or t2->language == nil) {
+ b = primlang_typematch(rtype(t1), rtype(t2));
+ } else {
+ b = (boolean) (*language_op(t2->language, L_TYPEMATCH))(t1, t2);
+ }
} else {
- b = (Boolean) (*language_op(t1->language, L_TYPEMATCH))(t1, t2);
+ b = (boolean) (*language_op(t1->language, L_TYPEMATCH))(t1, t2);
}
return b;
}
Symbol type;
String name;
{
- Symbol t;
+ register Symbol t;
Boolean b;
t = type;
- checkref(t);
- b = (Boolean) (
- t->class == TYPE and t->name == identname(name, true)
- );
+ if (t == nil) {
+ b = false;
+ } else {
+ b = (Boolean) (
+ t->class == TYPE and streq(ident(t->name), name)
+ );
+ }
+ return b;
+}
+
+/*
+ * Determine if a (value) parameter should actually be passed by address.
+ */
+
+public boolean passaddr (p, exprtype)
+Symbol p, exprtype;
+{
+ boolean b;
+ Language def;
+
+ if (p == nil) {
+ def = findlanguage(".c");
+ b = (boolean) (*language_op(def, L_PASSADDR))(p, exprtype);
+ } else if (p->language == nil or p->language == primlang) {
+ b = false;
+ } else if (isopenarray(p->type)) {
+ b = true;
+ } else {
+ b = (boolean) (*language_op(p->language, L_PASSADDR))(p, exprtype);
+ }
return b;
}
#define nextarg(type) ((type *) (ap += sizeof(type)))[-1]
private Symbol mkstring();
-private Symbol namenode();
/*
* Determine the type of a parse tree.
+ *
* Also make some symbol-dependent changes to the tree such as
- * changing removing RVAL nodes for constant symbols.
+ * removing indirection for constant or register symbols.
*/
-public assigntypes(p)
+public assigntypes (p)
register Node p;
{
register Node p1;
switch (p->op) {
case O_SYM:
- p->nodetype = namenode(p);
+ p->nodetype = p->value.sym;
break;
case O_LCON:
p->nodetype = t_int;
break;
+ case O_CCON:
+ p->nodetype = t_char;
+ break;
+
case O_FCON:
p->nodetype = t_real;
break;
case O_SCON:
- p->value.scon = strdup(p->value.scon);
- s = mkstring(p->value.scon);
- if (s == t_char) {
- p->op = O_LCON;
- p->value.lcon = p->value.scon[0];
- }
- p->nodetype = s;
+ p->nodetype = mkstring(p->value.scon);
break;
case O_INDIR:
p1 = p->value.arg[0];
- chkclass(p1, PTR);
+ s = rtype(p1->nodetype);
+ if (s->class != PTR) {
+ beginerrmsg();
+ fprintf(stderr, "\"");
+ prtree(stderr, p1);
+ fprintf(stderr, "\" is not a pointer");
+ enderrmsg();
+ }
p->nodetype = rtype(p1->nodetype)->type;
break;
p1 = p->value.arg[0];
p->nodetype = p1->nodetype;
if (p1->op == O_SYM) {
- if (p1->nodetype->class == FUNC) {
- p->op = O_CALL;
- p->value.arg[1] = nil;
+ if (p1->nodetype->class == PROC or p->nodetype->class == FUNC) {
+ p->op = p1->op;
+ p->value.sym = p1->value.sym;
+ p->nodetype = p1->nodetype;
+ dispose(p1);
} else if (p1->value.sym->class == CONST) {
- if (compatible(p1->value.sym->type, t_real)) {
- p->op = O_FCON;
- p->value.fcon = p1->value.sym->symvalue.fconval;
- p->nodetype = t_real;
- dispose(p1);
- } else {
- p->op = O_LCON;
- p->value.lcon = p1->value.sym->symvalue.iconval;
- p->nodetype = p1->value.sym->type;
- dispose(p1);
- }
+ p->op = p1->op;
+ p->value = p1->value;
+ p->nodetype = p1->nodetype;
+ dispose(p1);
} else if (isreg(p1->value.sym)) {
p->op = O_SYM;
p->value.sym = p1->value.sym;
}
break;
+ case O_COMMA:
+ p->nodetype = p->value.arg[0]->nodetype;
+ break;
+
+ case O_CALLPROC:
case O_CALL:
p1 = p->value.arg[0];
p->nodetype = rtype(p1->nodetype)->type;
if (not compatible(s, t_int)) {
if (not compatible(s, t_real)) {
beginerrmsg();
+ fprintf(stderr, "\"");
prtree(stderr, p->value.arg[0]);
- fprintf(stderr, "is improper type");
+ fprintf(stderr, "\" is improper type");
enderrmsg();
} else {
p->op = O_NEGF;
case O_ADD:
case O_SUB:
case O_MUL:
+ binaryop(p, nil);
+ break;
+
case O_LT:
case O_LE:
case O_GT:
case O_GE:
case O_EQ:
case O_NE:
- {
- Boolean t1real, t2real;
- Symbol t1, t2;
-
- t1 = rtype(p->value.arg[0]->nodetype);
- t2 = rtype(p->value.arg[1]->nodetype);
- t1real = compatible(t1, t_real);
- t2real = compatible(t2, t_real);
- if (t1real or t2real) {
- p->op = (Operator) (ord(p->op) + 1);
- if (not t1real) {
- p->value.arg[0] = build(O_ITOF, p->value.arg[0]);
- } else if (not t2real) {
- p->value.arg[1] = build(O_ITOF, p->value.arg[1]);
- }
- } else {
- if (t1real) {
- convert(&(p->value.arg[0]), t_int, O_NOP);
- }
- if (t2real) {
- convert(&(p->value.arg[1]), t_int, O_NOP);
- }
- }
- if (ord(p->op) >= ord(O_LT)) {
- p->nodetype = t_boolean;
- } else {
- if (t1real or t2real) {
- p->nodetype = t_real;
- } else {
- p->nodetype = t_int;
- }
- }
+ binaryop(p, t_boolean);
break;
- }
case O_DIVF:
convert(&(p->value.arg[0]), t_real, O_ITOF);
}
/*
- * Create a node for a name. The symbol for the name has already
- * been chosen, either implicitly with "which" or explicitly from
- * the dot routine.
+ * Process a binary arithmetic or relational operator.
+ * Convert from integer to real if necessary.
*/
-private Symbol namenode(p)
+private binaryop (p, t)
Node p;
+Symbol t;
{
- register Symbol r, s;
- register Node np;
-
- s = p->value.sym;
- if (s->class == REF) {
- np = new(Node);
- np->op = p->op;
- np->nodetype = s;
- np->value.sym = s;
- p->op = O_INDIR;
- p->value.arg[0] = np;
- }
-/*
- * Old way
- *
- if (s->class == CONST or s->class == VAR or s->class == FVAR) {
- r = s->type;
+ Node p1, p2;
+ Boolean t1real, t2real;
+ Symbol t1, t2;
+
+ p1 = p->value.arg[0];
+ p2 = p->value.arg[1];
+ t1 = rtype(p1->nodetype);
+ t2 = rtype(p2->nodetype);
+ t1real = compatible(t1, t_real);
+ t2real = compatible(t2, t_real);
+ if (t1real or t2real) {
+ p->op = (Operator) (ord(p->op) + 1);
+ if (not t1real) {
+ p->value.arg[0] = build(O_ITOF, p1);
+ } else if (not t2real) {
+ p->value.arg[1] = build(O_ITOF, p2);
+ }
+ p->nodetype = t_real;
} else {
- r = s;
+ if (size(p1->nodetype) > sizeof(integer)) {
+ beginerrmsg();
+ fprintf(stderr, "operation not defined on \"");
+ prtree(stderr, p1);
+ fprintf(stderr, "\"");
+ enderrmsg();
+ } else if (size(p2->nodetype) > sizeof(integer)) {
+ beginerrmsg();
+ fprintf(stderr, "operation not defined on \"");
+ prtree(stderr, p2);
+ fprintf(stderr, "\"");
+ enderrmsg();
+ }
+ p->nodetype = t_int;
+ }
+ if (t != nil) {
+ p->nodetype = t;
}
- *
- */
- return s;
}
/*
* Convert a tree to a type via a conversion operator;
* if this isn't possible generate an error.
- *
- * Note the tree is call by address, hence the #define below.
*/
private convert(tp, typeto, op)
Symbol typeto;
Operator op;
{
-#define tree (*tp)
-
- Symbol s;
+ Node tree;
+ Symbol s, t;
+ tree = *tp;
s = rtype(tree->nodetype);
- typeto = rtype(typeto);
- if (compatible(typeto, t_real) and compatible(s, t_int)) {
+ t = rtype(typeto);
+ if (compatible(t, t_real) and compatible(s, t_int)) {
+ /* we can convert int => floating but not the reverse */
tree = build(op, tree);
- } else if (not compatible(s, typeto)) {
+ } else if (not compatible(s, t)) {
beginerrmsg();
- prtree(stderr, s);
- fprintf(stderr, " is improper type");
+ prtree(stderr, tree);
+ fprintf(stderr, ": illegal type in operation");
enderrmsg();
- } else if (op != O_NOP and s != typeto) {
- tree = build(op, tree);
}
-
-#undef tree
+ *tp = tree;
}
/*
Node record;
Name fieldname;
{
- register Node p;
+ register Node rec, p;
register Symbol s, t;
- if (isblock(record->nodetype)) {
+ rec = record;
+ if (isblock(rec->nodetype)) {
find(s, fieldname) where
- s->block == record->nodetype and
- s->class != FIELD and s->class != TAG
+ s->block == rec->nodetype and
+ s->class != FIELD
endfind(s);
if (s == nil) {
beginerrmsg();
fprintf(stderr, "\"%s\" is not defined in ", ident(fieldname));
- printname(stderr, record->nodetype);
+ printname(stderr, rec->nodetype);
enderrmsg();
}
p = new(Node);
p->op = O_SYM;
p->value.sym = s;
- p->nodetype = namenode(p);
+ p->nodetype = s;
} else {
- p = record;
+ p = rec;
t = rtype(p->nodetype);
if (t->class == PTR) {
s = findfield(fieldname, t->type);
if (s == nil) {
beginerrmsg();
fprintf(stderr, "\"%s\" is not a field in ", ident(fieldname));
- prtree(stderr, record);
+ prtree(stderr, rec);
enderrmsg();
}
- if (t->class == PTR and not isreg(record->nodetype)) {
- p = build(O_INDIR, record);
+ if (t->class != PTR or isreg(rec->nodetype)) {
+ p = unrval(p);
}
+ p->nodetype = t_addr;
p = build(O_DOT, p, build(O_SYM, s));
}
- return p;
+ return build(O_RVAL, p);
}
/*
public Node subscript(a, slist)
Node a, slist;
{
-Symbol t;
+ Symbol t;
+ Node p;
- t = rtype(a->nodetype);
- if(t->language == nil) {
- error("unknown language");
- }
- else {
- return ( (Node)
- (*language_op(t->language, L_BUILDAREF)) (a,slist)
- );
- }
+ t = rtype(a->nodetype);
+ if (t->language == nil or t->language == primlang) {
+ p = (Node) (*language_op(findlanguage(".s"), L_BUILDAREF))(a, slist);
+ } else {
+ p = (Node) (*language_op(t->language, L_BUILDAREF))(a, slist);
+ }
+ return build(O_RVAL, p);
}
/*
* Evaluate a subscript index.
*/
-public int evalindex(s, i)
+public int evalindex(s, base, i)
Symbol s;
+Address base;
long i;
{
-Symbol t;
+ Symbol t;
+ int r;
- t = rtype(s);
- if(t->language == nil) {
- error("unknown language");
- }
- else {
- return (
- (*language_op(t->language, L_EVALAREF)) (s,i)
- );
- }
+ t = rtype(s);
+ if (t->language == nil or t->language == primlang) {
+ r = ((*language_op(findlanguage(".s"), L_EVALAREF)) (s, base, i));
+ } else {
+ r = ((*language_op(t->language, L_EVALAREF)) (s, base, i));
+ }
+ return r;
}
/*
}
/*
- * Check to make sure the given tree has a type of the given class.
- */
-
-private chkclass(p, class)
-Node p;
-Symclass class;
-{
- struct Symbol tmpsym;
-
- tmpsym.class = class;
- if (rtype(p->nodetype)->class != class) {
- beginerrmsg();
- fprintf(stderr, "\"");
- prtree(stderr, p);
- fprintf(stderr, "\" is not a %s", classname(&tmpsym));
- enderrmsg();
- }
-}
-
-/*
- * Construct a node for the type of a string. While we're at it,
- * scan the string for '' that collapse to ', and chop off the ends.
+ * Construct a node for the type of a string.
*/
private Symbol mkstring(str)
String str;
{
- register char *p, *q;
register Symbol s;
- p = str;
- q = str;
- while (*p != '\0') {
- if (*p == '\\') {
- ++p;
- }
- *q = *p;
- ++p;
- ++q;
- }
- *q = '\0';
s = newSymbol(nil, 0, ARRAY, t_char, nil);
- s->language = findlanguage(".s");
s->chain = newSymbol(nil, 0, RANGE, t_int, nil);
s->chain->language = s->language;
s->chain->symvalue.rangev.lower = 1;
- s->chain->symvalue.rangev.upper = p - str + 1;
+ s->chain->symvalue.rangev.upper = strlen(str) + 1;
return s;
}
}
/*
- * Figure out the "current" variable or function being referred to,
- * this is either the active one or the most visible from the
- * current scope.
+ * Figure out the "current" variable or function being referred to
+ * by the name n.
*/
-public Symbol which(n)
+private boolean stwhich(), dynwhich();
+
+public Symbol which (n)
Name n;
{
- register Symbol s, p, t, f;
+ Symbol s;
- find(s, n)
- where s->class != FIELD and s->class != TAG and s->class != MODULE
- endfind(s);
- if (s == nil) {
- s = lookup(n);
- }
+ s = lookup(n);
if (s == nil) {
error("\"%s\" is not defined", ident(n));
- } else if (s == program or isbuiltin(s)) {
- t = s;
+ } else if (not stwhich(&s) and isambiguous(s) and not dynwhich(&s)) {
+ printf("[using ");
+ printname(stdout, s);
+ printf("]\n");
+ }
+ return s;
+}
+
+/*
+ * Static search.
+ */
+
+private boolean stwhich (var_s)
+Symbol *var_s;
+{
+ Name n; /* name of desired symbol */
+ Symbol s; /* iteration variable for symbols with name n */
+ Symbol f; /* iteration variable for blocks containing s */
+ integer count; /* number of levels from s->block to curfunc */
+ Symbol t; /* current best answer for stwhich(n) */
+ integer mincount; /* relative level for current best answer (t) */
+ boolean b; /* return value, true if symbol found */
+
+ s = *var_s;
+ n = s->name;
+ t = s;
+ mincount = 10000; /* force first match to set mincount */
+ do {
+ if (s->name == n and s->class != FIELD and s->class != TAG) {
+ f = curfunc;
+ count = 0;
+ while (f != nil and f != s->block) {
+ ++count;
+ f = f->block;
+ }
+ if (f != nil and count < mincount) {
+ t = s;
+ mincount = count;
+ b = true;
+ }
+ }
+ s = s->next_sym;
+ } while (s != nil);
+ if (mincount != 10000) {
+ *var_s = t;
+ b = true;
} else {
- /* start with current function */
- p = curfunc;
- do {
- find(t, n) where
- t->block == p and t->class != FIELD and
- t->class != TAG and t->class != MODULE
- endfind(t);
- p = p->block;
- } while (t == nil and p != nil);
- if (t == nil) {
- t = s;
+ b = false;
+ }
+ return b;
+}
+
+/*
+ * Dynamic search.
+ */
+
+private boolean dynwhich (var_s)
+Symbol *var_s;
+{
+ Name n; /* name of desired symbol */
+ Symbol s; /* iteration variable for possible symbols */
+ Symbol f; /* iteration variable for active functions */
+ Frame frp; /* frame associated with stack walk */
+ boolean b; /* return value */
+
+ f = curfunc;
+ frp = curfuncframe();
+ n = (*var_s)->name;
+ b = false;
+ if (frp != nil) {
+ frp = nextfunc(frp, &f);
+ while (frp != nil) {
+ s = *var_s;
+ while (s != nil and
+ (
+ s->name != n or s->block != f or
+ s->class == FIELD or s->class == TAG
+ )
+ ) {
+ s = s->next_sym;
+ }
+ if (s != nil) {
+ *var_s = s;
+ b = true;
+ break;
+ }
+ if (f == program) {
+ break;
+ }
+ frp = nextfunc(frp, &f);
}
}
- return t;
+ return b;
}
/*
- * Find the symbol which is has the same name and scope as the
+ * Find the symbol that has the same name and scope as the
* given symbol but is of the given field. Return nil if there is none.
*/
-public Symbol findfield(fieldname, record)
+public Symbol findfield (fieldname, record)
Name fieldname;
Symbol record;
{