symbols.c

<B>Digital的Unix操作系统VAX 4.2源码</B>

			        			b = (boolean) (*language_op(t1->language, 
														L_TYPEMATCH))(t1, t2);
    		            	}
							else {
								b = false;
							}
    		            }
			}
    return b;
}

/*
 * Check for a type of the given name.
 */

public Boolean istypename(type, name)
Symbol type;
String name;
{
    register Symbol t;
    Boolean b;

    t = type;
    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;
}

/*
 * Test if the name of a symbol is uniquely defined or not.
 */

public Boolean isambiguous(s)
register Symbol s;
{
    register Symbol t;

    find(t, s->name) where t != s endfind(t);
    return (Boolean) (t != nil);
}

typedef char *Arglist;

#define nextarg(type)  ((type *) (ap += sizeof(type)))[-1]

private Symbol mkstring();

/*
 * Determine the type of a parse tree.
 *
 * Also make some symbol-dependent changes to the tree such as
 * removing indirection for constant or register symbols.
 */

public assigntypes (p)
register Node p;
{
    register Node p1;
    register Symbol s;

    switch (p->op) {
	case O_SYM:
	    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->nodetype = mkstring(p->value.scon);
	    break;

	case O_INDIR:
	    p1 = p->value.arg[0];
	    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;

	case O_DOT:
	    p->nodetype = p->value.arg[1]->value.sym;
	    break;

	case O_RVAL:
	    p1 = p->value.arg[0];
	    p->nodetype = p1->nodetype;
	    if (p1->op == O_SYM) {
		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) {
		    p->op = p1->op;
		    p->value = p1->value;
		    p->nodetype = p1->nodetype;
		    dispose(p1);
		} else if (isvreg(p1->value.sym)) {
		    /* Start vector support */
		    p->op = O_VREG;
		    p->value.sym = p1->value.sym;
		    dispose(p1);
		    /* End vector support */
		} else if (isreg(p1->value.sym)) {
		    p->op = O_SYM;
		    p->value.sym = p1->value.sym;
		    dispose(p1);
		}
	    } else if (p1->op == O_INDIR and p1->value.arg[0]->op == O_SYM) {
		s = p1->value.arg[0]->value.sym;
		if (isreg(s)) {
		    p1->op = O_SYM;
		    dispose(p1->value.arg[0]);
		    p1->value.sym = s;
		    p1->nodetype = s;
		}
	    }
	    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;
	    break;

	case O_TYPERENAME:
	    s = p->value.arg[1]->nodetype;
	    /* Start vector Support */
	    p1 = p->value.arg[0];
	    if (p1->op == O_VREG) {
	        /* Apply cast to an element of a vector register */
	        if (size(s) == sizeof(Vquad)) {
		    	s = newSymbol(p1->nodetype->name, 0, ARRAY, s, nil);
		    	s->chain = rtype(p1->nodetype)->chain;
			} else {
		    	beginerrmsg();
		    	fprintf(stderr, "\"");
		    	prtree(stderr, p->value.arg[1]);
		    	fprintf(stderr, "\" is improper type");
		    	enderrmsg();
			}
	    }
	    /* End vector Support */
	    p->nodetype = s;
	    break;

	case O_ITOF:
	    p->nodetype = t_real;
	    break;

	case O_NEG:
	    s = p->value.arg[0]->nodetype;
	    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");
		    enderrmsg();
		} else {
		    p->op = O_NEGF;
		}
	    }
	    p->nodetype = s;
	    break;

	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:
	    binaryop(p, t_boolean);
	    break;

	case O_DIVF:
	    convert(&(p->value.arg[0]), t_real, O_ITOF);
	    convert(&(p->value.arg[1]), t_real, O_ITOF);
	    p->nodetype = t_real;
	    break;

	case O_DIV:
	case O_MOD:
	    convert(&(p->value.arg[0]), t_int, O_NOP);
	    convert(&(p->value.arg[1]), t_int, O_NOP);
	    p->nodetype = t_int;
	    break;

	case O_AND:
	case O_OR:
	    chkboolean(p->value.arg[0]);
	    chkboolean(p->value.arg[1]);
	    p->nodetype = t_boolean;
	    break;

	case O_QLINE:
	    p->nodetype = t_int;
	    break;

	default:
	    p->nodetype = nil;
	    break;
    }
}

/*
 * Process a binary arithmetic or relational operator.
 * Convert from integer to real if necessary.
 */

private binaryop (p, t)
Node p;
Symbol t;
{
    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 {
        if (t != nil and p1->op == O_SCON) {
	    beginerrmsg();
	    fprintf(stderr, "operation not defined on a string constant (");
	    prtree(stderr, p1);
	    fprintf(stderr, ")");
	    enderrmsg();
        } else if (t != nil and p2->op == O_SCON) {
	    beginerrmsg();
	    fprintf(stderr, "operation not defined on a string constant (");
	    prtree(stderr, p2);
	    fprintf(stderr, ")");
	    enderrmsg();
	} else 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;
    }
}

/*
 * 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)
Node *tp;
Symbol typeto;
Operator op;
{
    Node tree;
    Symbol s, t;

    tree = *tp;
    s = rtype(tree->nodetype);
    t = rtype(typeto);
    if (compatible(t, t_real) and compatible(s, t_int)) {
	tree = build(op, tree);
    } else if (not compatible(s, t)) {
	beginerrmsg();
	fprintf(stderr, "expected integer or real, found \"");
	prtree(stderr, tree);
	fprintf(stderr, "\"");
	enderrmsg();
    } else if (op != O_NOP and s != t) {
	tree = build(op, tree);
    }
    *tp = tree;
}

/*
 * Construct a node for the dot operator.
 *
 * If the left operand is not a record, but rather a procedure
 * or function, then we interpret the "." as referencing an
 * "invisible" variable; i.e. a variable within a dynamically
 * active block but not within the static scope of the current procedure.
 */

public Node dot(record, fieldname)
Node record;
Name fieldname;
{
    register Node rec, p;
    register Symbol s, t;

    rec = record;
    if (isblock(rec->nodetype)) {
	find(s, fieldname) where
	    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, rec->nodetype);
	    enderrmsg();
	}
	p = new(Node);
	p->op = O_SYM;
	p->value.sym = s;
	p->nodetype = s;
    } else {
	p = rec;
	t = rtype(p->nodetype);
	if (t->class == PTR) {
	    s = findfield(fieldname, t->type);
	} else {
	    s = findfield(fieldname, t);
	}
	if (s == nil) {
	    beginerrmsg();
	    fprintf(stderr, "\"%s\" is not a field in ", ident(fieldname));
	    prtree(stderr, rec);
	    enderrmsg();
	}
	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 build(O_RVAL, p);
}

/*
 * Return a tree corresponding to an array reference and do the
 * error checking.
 */

public Node subscript(a, slist)
Node a, slist;
{
    Symbol t;
    Node p;

    t = rtype(a->nodetype);
    if (t->language == nil or t->language == primlang) {
	p = (Node) (*language_op(findlanguage(ASSEMBLER), 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, base, i)
Symbol s;
Address base;
long i;
{
    Symbol t;
    int r;

    t = rtype(s);
    if (t->language == nil or t->language == primlang) {
	r = ((*language_op(findlanguage(ASSEMBLER), L_EVALAREF)) (s, base, i));
    } else {
	r = ((*language_op(t->language, L_EVALAREF)) (s, base, i));
    }
    return r;
}

/*
 * Check to see if a tree is boolean-valued, if not it's an error.
 */

public chkboolean(p)
register Node p;
{
    if (p->nodetype != t_boolean) {
	beginerrmsg();
	fprintf(stderr, "found ");
	prtree(stderr, p);
	fprintf(stderr, ", expected boolean expression");
	enderrmsg();
    }
}

/*
 * Construct a node for the type of a string.
 */

private Symbol mkstring(str)
String str;
{
    register Symbol s;

    s = newSymbol(nil, 0, ARRAY, t_char, nil);
    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 = strlen(str) + 1;
    return s;
}

/*
 * Free up the space allocated for a string type.
 */

public unmkstring(s)
Symbol s;
{
    dispose(s->chain);
}

/*
 * Figure out the "current" variable or function being referred to
 * by the name n.
 */

private boolean stwhich(), dynwhich();

public Symbol which (n)
Name n;
{
    Symbol s;

/* RBN 3-28-90 * RBN 3-28-90 * RBN 3-28-90 * RBN 3-28-90 * RBN 3-28-90 */
    Char oldid[81];
    register Char *oid, *p;

    s = lookup(n);
    if (s == nil) {
        p = n->identifier;      /* store original identifier in oldid */
        oid = oldid;
        while (*oid++ = *p++);
        p = oldid;            /* convert identifier to all lower-case */
        while (*p != '\0') {
            if (*p >= 'A' and *p <= 'Z') {
                *p = *p + 'a' - 'A';
            }
            ++p;
        }
        s = lookup(identname(oldid, true));           /* search again */
        if (s == nil) {
            p = oldid;        /* convert identifier to all UPPER-case */
            while (*p != '\0') {
                if (*p >= 'a' and *p <= 'z') {
                    *p = *p - 'a' + 'A';
                }
                ++p;
            }
            s = lookup(identname(oldid, true));          /* once more */
            if (s == nil) {
                error("\"%s\" is not defined", n->identifier);
            }
        }
    }
/* RBN 3-28-90 * RBN 3-28-90 * RBN 3-28-90 * RBN 3-28-90 * RBN 3-28-90 */

    if(isvreg(s))
        return s;
    if (not stwhich(&s) and isambiguous(s) and not dynwhich(&s)) {
        printf("[using ");
        printname(stdout, s);
        printf("]\n");
    }
    if (no_dstmap(s)) {
        error("symbolic information not available for symbol \"%s\"",
        symname(s));
    }
    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 {
	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 b;
}

/*
 * 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)
Name fieldname;
Symbol record;
{
    register Symbol t;

    t = rtype(record)->chain;
    while (t != nil and t->name != fieldname) {
	t = t->chain;
    }
    return t;
}

public Boolean getbound(s,off,type,valp)
Symbol s;
int off;
Rangetype type;
int *valp;
{
    Frame frp;
    Address addr;
    Symbol cur;

    if (not isactive(s->block)) {
	return(false);
    }
    cur = s->block;
    while (cur != nil and cur->class == MODULE) {  /* WHY*/
    		cur = cur->block;
    }
    if(cur == nil) {
		cur = whatblock(pc);
    }
    frp = findframe(cur);
    if (frp == nil) {
	return(false);
    }
    if(type == R_TEMP) addr = locals_base(frp) + off;
    else if (type == R_ARG) addr = args_base(frp) + off;
    else return(false);
    dread(valp,addr,sizeof(long));
    return(true);
}