/* ref_type -- find type of a reference */
PUBLIC type ref_type(sym x, tree p, env e, tree cxt)
{
def d = find_def(x, e);
frame f;
if (d == NULL) {
#ifdef ASSUME
type t;
if (qflag && p == nil && (t = assume_type(x)) != NULL)
return t;
#endif
if (! partial_env(e)) {
tc_error(cxt->x_loc, "Identifier %n is not declared", x);
if (cxt->x_kind != REF)
tc_e_etc("Expression: %z", cxt);
tc_e_end();
}
return err_type;
}
f = new_frame(d->d_nparams, cxt);
if (p != nil)
switch (d->d_kind) {
case GSET:
case VAR:
tc_error(cxt->x_loc, "%s %n cannot have parameters",
d->d_kind == GSET ? "Basic type" : "Variable", x);
tc_e_etc("Expression: %z", cxt);
tc_e_end();
return err_type;
case GENCONST:
get_params("Generic constant", x, p, e, f, cxt->x_loc);
break;
default:
bad_tag("ref_type", d->d_kind);
}
if (! aflag && d->d_abbrev)
return mk_power(mk_abbrev(d, (p != nil ? f : alias(f))));
else
return seal(d->d_type, f);
}
static int exec_free (EORB_CPP_node * n)
{
int rv = 0;
int l;
int r;
switch (n->op)
{
case 0:
rv = n->leaf;
break;
case '-':
if (n->left)
{
rv = exec_free(n->left);
}
else
{
rv = 0;
}
rv -= exec_free(n->right);
break;
case '!':
rv = ! exec_free(n->right);
break;
case '~':
rv = ~ exec_free(n->right);
break;
case 'd':
rv = !! find_def(n->name);
os_free(n->name);
break;
#define BIN(key,op) case key:l=exec_free(n->left);r=exec_free(n->right);rv=l op r;break;
ALLBINS
#undef BIN
}
OLD(n);
return (rv);
}
void do_ifndef (int sharp)
{
char *w;
#ifdef DEBUG_IF
if (debugging)
{
outputc('<');
outputc(sharp ? '#' : '@');
outputs("ifndef: ");
// fflush(outfile);
}
#endif
if (in_false_if())
{
n_skipped_ifs ++;
#ifdef DEBUG_IF
if (debugging)
{
outputs("in-false, skipped>");
// fflush(outfile);
}
#endif
}
else
{
w = read_ident();
if (! w)
{
#ifdef DEBUG_IF
if (debugging)
{
outputs("no ident ");
// fflush(outfile);
}
#endif
iftrue();
}
else
{
#ifdef DEBUG_IF
if (debugging)
{
outputs(w);
outputc(' ');
// fflush(outfile);
}
#endif
if (find_def(w))
{
iffalse();
}
else
{
iftrue();
}
os_free(w);
}
#ifdef DEBUG_IF
if (debugging)
{
outputc('>');
// fflush(outfile);
}
#endif
}
if (sharp)
{
flush_sharp_line();
}
}
/**
* Find the definition entry for the name passed in.
* It is okay to find block entries IFF they are found on the
* current level. Once you start traversing up the tree,
* the macro must be a text macro. Return an indicator saying if
* the element has been indexed (so the caller will not try
* to traverse the list of twins).
*/
static tDefEntry*
find_def(char * pzName, tDefCtx* pDefCtx, ag_bool* pIsIndexed)
{
char * brace;
char br_ch;
tDefEntry * ent;
ag_bool dummy;
ag_bool noNesting = AG_FALSE;
static int nestingDepth = 0;
/*
* IF we are at the start of a search, then canonicalize the name
* we are hunting for, copying it to a modifiable buffer, and
* initialize the "indexed" boolean to false (we have not found
* an index yet).
*/
if (nestingDepth == 0) {
canonicalizeName(zDefinitionName, pzName, (int)strlen(pzName));
pzName = zDefinitionName;
if (pIsIndexed != NULL)
*pIsIndexed = AG_FALSE;
else pIsIndexed = &dummy;
if (*pzName == name_sep_ch) {
noNesting = AG_TRUE;
pzName++;
}
}
brace = BRK_NAME_SEP_CHARS(pzName);
br_ch = *brace;
*brace = NUL;
if (br_ch == '[') *pIsIndexed = AG_TRUE;
for (;;) {
/*
* IF we are at the end of the definitions (reached ROOT),
* THEN it is time to bail out.
*/
ent = pDefCtx->pDefs;
if (ent == NULL)
return NULL;
do {
/*
* IF the name matches
* THEN break out of the double loop
*/
if (strcmp(ent->pzDefName, pzName) == 0)
goto found_def_entry;
ent = ent->pNext;
} while (ent != NULL);
/*
* IF we are nested, then we cannot change the definition level.
* So, we did not find anything.
*/
if ((nestingDepth != 0) || noNesting)
return NULL;
/*
* Let's go try the definitions at the next higher level.
*/
pDefCtx = pDefCtx->pPrev;
if (pDefCtx == NULL)
return NULL;
} found_def_entry:;
/*
* At this point, we have found the entry that matches the supplied name,
* up to the '[' or name_sep_ch or NUL character. It *must* be one of
* those three characters.
*/
*brace = br_ch;
switch (br_ch) {
case NUL:
return ent;
case '[':
/*
* We have to find a specific entry in a list.
*/
brace = SPN_WHITESPACE_CHARS(brace + 1);
ent = find_by_index(ent, brace);
if (ent == NULL)
return ent;
/*
* We must find the closing brace, or there is an error
*/
brace = strchr(brace, ']');
if (brace == NULL)
ILLFORMEDNAME();
/*
* What follows the closing brace? IF we are at the end of the
* definition, THEN return what we found. However, if there's
* another name, then we have to go look that one up, too.
*/
switch (*++brace) {
case NUL:
return ent;
case '.': case '/':
/*
* Which one? One is valid, the other not and it is not known
* at compile time.
*/
if (*brace == name_sep_ch) {
pzName = brace + 1;
break;
}
/* FALLTHROUGH */
default:
ILLFORMEDNAME();
}
break;
case '.': case '/':
if (br_ch == name_sep_ch) {
/*
* Which one? One is valid, the other not and it is not known
* at compile time.
*
* It is a segmented value name. Set the name pointer
* to the next segment and search starting from the newly
* available set of definitions.
*/
pzName = brace + 1;
break;
}
/* FALLTHROUGH */
default:
ILLFORMEDNAME();
}
/*
* We cannot find a member of a non-block type macro definition.
*/
if (ent->valType != VALTYP_BLOCK)
return NULL;
/*
* Loop through all the twins of the entry we found until
* we find the entry we want. We ignore twins if we just
* used a subscript.
*/
nestingDepth++;
{
tDefCtx ctx = { NULL, &currDefCtx };
ctx.pDefs = ent->val.pDefEntry;
for (;;) {
tDefEntry* res;
res = find_def(pzName, &ctx, pIsIndexed);
if ((res != NULL) || (br_ch == '[')) {
nestingDepth--;
return res;
}
ent = ent->pTwin;
if (ent == NULL)
break;
ctx.pDefs = ent->val.pDefEntry;
}
}
nestingDepth--;
return NULL;
}
/* tc_apply -- check a function application */
PRIVATE type tc_apply(int kind, tree t, tree fun, tree arg, env e)
{
type actual = tc_expr(arg, e);
type fun_type, formal, result;
type formarg[MAX_ARGS], actarg[MAX_ARGS];
int n_formals, n_actuals, i;
frame param = arid;
def d;
if (! aflag && fun->x_kind == REF
&& (d = find_def((sym) fun->x_tag, e)) != NULL
&& d->d_tame && fun->x_params == nil)
/* A tame function */
fun_type = seal(d->d_type,
param = new_frame(d->d_nparams, fun));
else
fun_type = tc_expr(fun, e);
if (! anal_rel_type(fun_type, &formal, &result, fun)) {
if (fun_type != err_type) {
if (kind == APPLY)
tc_error(t->x_loc, "Application of a non-function");
else
tc_error(t->x_loc, "%s operator %n is not a function",
(kind == INOP ? "Infix" : "Postfix"),
fun->x_tag);
tc_e_etc("Expression: %z", t);
tc_e_etc("Found type: %t", fun_type);
tc_e_end();
}
mark_error();
return err_type;
}
if (arg->x_kind == TUPLE
&& anal_cproduct(formal, formarg, &n_formals)) {
/* Special case: actual parameter is a tuple, and formal
parameter type is a cproduct. Check args one by one. */
if (! anal_cproduct(actual, actarg, &n_actuals))
panic("tc_apply");
if (n_actuals != n_formals) {
tc_error(t->x_loc, "Function expects %d arguments",
n_formals);
tc_e_etc("Expression: %z", t);
tc_e_end();
mark_error();
return err_type;
}
for (i = 0; i < n_actuals; i++) {
if (param_unify(actarg[i], formarg[i], param))
continue;
if (kind == INOP)
tc_error(t->x_loc,
"%s argument of operator %n has wrong type",
(i == 0 ? "Left" : "Right"), fun->x_tag);
else
tc_error(t->x_loc, "Argument %d has wrong type", i+1);
tc_e_etc("Expression: %z", t);
tc_e_etc("Arg type: %t", actarg[i]);
tc_e_etc("Expected: %t", formarg[i]);
tc_e_end();
}
}
else if (! param_unify(actual, formal, param)) {
/* General case: check the single arg as a whole. */
tc_error(t->x_loc, "Argument of %s has wrong type",
(kind == POSTOP ? "postfix operator" : "application"));
tc_e_etc("Expression: %z", t);
tc_e_etc("Arg type: %t", actual);
tc_e_etc("Expected: %t", formal);
tc_e_end();
}
return result;
}
int preprocess_getc(void)
{
int result = 0;
int backslash = 0;
do
{
int c;
int haddigit;
result = read_char();
if (result != 0)
{
break;
}
c = Get();
if (c == -1)
{
break;
}
if (backslash)
{
maybe_print(c);
backslash = 0;
continue;
}
if (!incldep && (isdigit((int) c) || (c == '.')))
{
haddigit = 0;
while (isdigit((int) c) || (c == '.'))
{
haddigit |= isdigit((int) c);
maybe_print(c);
c = Get();
if (c == -1)
{
return 0;
}
}
if (haddigit && ((c == 'e') || (c == 'E')))
{
maybe_print(c);
c = Get();
if (c == -1)
{
return 0;
}
while (isdigit((int) c))
{
maybe_print(c);
c = Get();
if (c == -1)
{
return 0;
}
}
}
Push(c);
continue;
}
if (quote)
{
if (c == '\\')
{
maybe_print(c);
backslash = 1;
continue;
}
else if ((c == quote) || (c == '\n'))
{
maybe_print(c);
quote = 0;
continue;
}
else
{
maybe_print(c);
continue;
}
}
if (c == '\\') /* this weirdness is Reiser semantics.... */
{
backslash = 1;
maybe_print(c);
continue;
}
if ((c == '\'') || (c == '"'))
{
quote = c;
maybe_print(c);
}
else if (linefirst && (c == '#'))
{
do_sharp();
}
else if (do_at_ctrls && (c == '@'))
{
do_at();
}
else if (! incldep)
{
if (isbsymchar(c) && !in_false_if())
{
char *cp;
DEF *d;
cp = init_accum();
while (issymchar(c))
{
accum_char(cp, c);
c = Get();
if (c == -1)
{
return 0;
}
}
Push(c);
cp = accum_result(cp);
#ifdef DEBUG_MAIN
if (debugging)
{
outputs("<word:");
outputs(cp);
outputs(">");
}
#endif
d = find_def(cp);
if (d)
{
expand_def(d);
}
else
{
for (;*cp;cp++)
{
maybe_print(*cp);
}
}
}
else if (c == '/')
{
int d;
d = Get();
if (d == -1)
{
return 0;
}
if (d == '*')
{
d = '\0';
if (keep_comments)
{
maybe_print('/');
maybe_print('*');
}
do
{
c = d;
d = Get();
if (d == -1)
{
return 0;
}
if ((d == '\n') || keep_comments)
{
maybe_print(d);
}
}
while ((c != '*') || (d != '/'));
}
else if (d == '/')
{
if (keep_comments)
{
maybe_print('/');
maybe_print('/');
}
do
{
c = Get();
if (c == -1)
{
return 0;
}
if ((c == '\n') || keep_comments)
{
maybe_print(c);
}
}
while (c != '\n');
}
else
{
Push(d);
maybe_print(c);
}
}
else
{
maybe_print(c);
}
}
} while (result == 0);
return result;
}
