expv
compile_intrinsic_call(ID id, expv args) {
intrinsic_entry *ep = NULL;
int found = 0;
int nArgs = 0;
int nIntrArgs = 0;
int i;
expv ret = NULL;
expv a = NULL;
TYPE_DESC tp = NULL, ftp;
list lp;
INTR_OPS iOps = INTR_END;
const char *iName = NULL;
expv kindV = NULL;
int typeNotMatch = 0;
int isVarArgs = 0;
EXT_ID extid;
if (SYM_TYPE(ID_SYM(id)) != S_INTR) {
//fatal("%s: not intrinsic symbol", __func__);
// declarea as intrinsic but not defined in the intrinc table
SYM_TYPE(ID_SYM(id)) = S_INTR;
if (args == NULL) {
args = list0(LIST);
}
if (ID_TYPE(id) == NULL) implicit_declaration(id);
tp = ID_TYPE(id);
//tp = BASIC_TYPE_DESC(TYPE_SUBR);
expv symV = expv_sym_term(F_FUNC, NULL, ID_SYM(id));
ftp = function_type(tp);
TYPE_SET_INTRINSIC(ftp);
extid = new_external_id_for_external_decl(ID_SYM(id), ftp);
ID_TYPE(id) = ftp;
PROC_EXT_ID(id) = extid;
if (TYPE_IS_EXTERNAL(tp)){
ID_STORAGE(id) = STG_EXT;
}
else{
EXT_PROC_CLASS(extid) = EP_INTRINSIC;
}
ret = expv_cons(FUNCTION_CALL, tp, symV, args);
return ret;
}
ep = &(intrinsic_table[SYM_VAL(ID_SYM(id))]);
iOps = INTR_OP(ep);
iName = ID_NAME(id);
/* Count a number of argument, first. */
nArgs = 0;
if (args == NULL) {
args = list0(LIST);
}
FOR_ITEMS_IN_LIST(lp, args) {
nArgs++;
}
/* Search an intrinsic by checking argument types. */
found = 0;
for (;
((INTR_OP(ep) == iOps) &&
((strcasecmp(iName, INTR_NAME(ep)) == 0) ||
!(isValidString(INTR_NAME(ep)))));
ep++) {
kindV = NULL;
typeNotMatch = 0;
isVarArgs = 0;
/* Check a number of arguments. */
if (INTR_N_ARGS(ep) < 0 ||
INTR_N_ARGS(ep) == nArgs) {
/* varriable args or no kind arg. */
if (INTR_N_ARGS(ep) < 0) {
isVarArgs = 1;
}
nIntrArgs = nArgs;
} else if (INTR_HAS_KIND_ARG(ep) &&
((INTR_N_ARGS(ep) + 1) == nArgs)) {
/* could be intrinsic call with kind arg. */
expv lastV = expr_list_get_n(args, nArgs - 1);
if (lastV == NULL) {
return NULL; /* error recovery */
}
if (EXPV_KW_IS_KIND(lastV)) {
goto gotKind;
}
tp = EXPV_TYPE(lastV);
if (!(isValidType(tp))) {
return NULL; /* error recovery */
}
if (TYPE_BASIC_TYPE(tp) != TYPE_INT) {
/* kind arg must be integer type. */
continue;
}
gotKind:
nIntrArgs = INTR_N_ARGS(ep);
kindV = lastV;
} else {
continue;
}
/* The number of arguments matchs. Then check types. */
for (i = 0; i < nIntrArgs; i++) {
a = expr_list_get_n(args, i);
if (a == NULL) {
return NULL; /* error recovery */
}
tp = EXPV_TYPE(a);
if (!(isValidType(tp))) {
//return NULL; /* error recovery */
continue;
}
if (compare_intrinsic_arg_type(a, tp,
((isVarArgs == 0) ?
INTR_ARG_TYPE(ep)[i] :
INTR_ARG_TYPE(ep)[0])) != 0) {
/* Type mismatch. */
typeNotMatch = 1;
break;
}
}
if (typeNotMatch == 1) {
continue;
} else {
found = 1;
break;
}
}
if (found == 1) {
/* Yes we found an intrinsic to use. */
SYMBOL sp = NULL;
expv symV = NULL;
/* Then we have to determine return type. */
if (INTR_RETURN_TYPE(ep) != INTR_TYPE_NONE) {
tp = get_intrinsic_return_type(ep, args, kindV);
if (!(isValidType(tp))) {
//fatal("%s: can't determine return type.", __func__);
//return NULL;
tp = BASIC_TYPE_DESC(TYPE_GNUMERIC_ALL);
}
} else {
tp = BASIC_TYPE_DESC(TYPE_SUBR);
}
/* Finally find symbol for the intrinsic and make it expv. */
sp = find_symbol((char *)iName);
if (sp == NULL) {
fatal("%s: symbol '%s' is not created??",
__func__,
INTR_NAME(ep));
/* not reached */
return NULL;
}
symV = expv_sym_term(F_FUNC, NULL, sp);
if (symV == NULL) {
fatal("%s: symbol expv creation failure.", __func__);
/* not reached */
return NULL;
}
ftp = function_type(tp);
TYPE_SET_INTRINSIC(ftp);
/* set external id for functionType's type ID.
* dont call declare_external_id() */
extid = new_external_id_for_external_decl(ID_SYM(id), ftp);
ID_TYPE(id) = ftp;
PROC_EXT_ID(id) = extid;
if(TYPE_IS_EXTERNAL(tp)){
ID_STORAGE(id) = STG_EXT;
}else{
EXT_PROC_CLASS(extid) = EP_INTRINSIC;
}
ret = expv_cons(FUNCTION_CALL, tp, symV, args);
}
if (ret == NULL) {
error_at_node((expr)args,
"argument(s) mismatch for an intrinsic '%s()'.",
iName);
}
return ret;
}
static void
uCount(DUG * dug, /* flow graph */
BRANCH * branch, /* branch to possible use node */
BVPTR * list, /* list of nodes visited already */
DU * def, /* symbol definition */
int p_use, /* use type of previous node */
int *counts) /* counts of C-uses & P-uses */
{
LIST *i;
BRANCH *f;
DU *use;
int use_type;
if (branch->to->block_id == 0)
return;
/*
* ?unknown? Block 0 is the start block. But, branch back to block 0
* means return. This should be a valid P-USE but the runtime won't
* catch it so we don't report it. Since block 0 always has exactly
* one branch, to block 1, and block 1 is on the visited list, and
* there are never any Uses at block 0, we could just remove the line
* above this comment to have the "P-USE at return" print.
*/
/*
* If PUSE in previous node, print PUSE here.
*/
if (p_use & VAR_PUSE)
++counts[1];
/*
* Already visited this node ?
*/
if (BVTEST(list, branch->to->block_id))
return;
BVSET(list, branch->to->block_id);
use = du_use_type(dug, branch->to, ID_SYM(def->var_id), def->ref_type);
if (use) {
use_type = use->ref_type;
} else {
use_type = 0;
}
/*
* If C-USE at node, print it.
*/
if (use_type & VAR_CUSE)
++counts[0];
/*
* Defining use?
*/
if (use_type & VAR_DEF)
return;
/*
* Visit each node reachable from node.
*/
if (branch->to->branches)
for (i = 0; LIST_NEXT(branch->to->branches, &i, &f);)
uCount(dug, f, list, def, use_type, counts);
}
int
is_intrinsic_function(ID id) {
return (SYM_TYPE(ID_SYM(id)) == S_INTR) ? TRUE : FALSE;
}
static void
u_traverse(DUG * dug, /* flow graph */
BRANCH * branch, /* branch to possible use node */
BVPTR * list, /* list of nodes visited already */
BLOCK * d_node, /* defining node */
DU * def, /* symbol definition */
int p_use, /* use type of previous node */
BLOCK * prev_node, /* possible use node */
TNODE * prevPos, /* parse position of prev_node; */
int feasableOnly) {
LIST *i;
BRANCH *f;
DU *use;
int use_type;
TNODE *usePos;
if (branch->to->block_id == 0)
return;
/*
* ?unknown? Block 0 is the start block. But, branch back to block 0 means return.
* This should be a valid P-USE but the runtime won't catch it so we don't
* report it. Since block 0 always has exactly one branch, to block 1,
* and block 1 is on the visited list, and there are never any Uses at block 0,
* we could just remove the line above this comment to have the "P-USE at
* return" print.
*/
/*
* If PUSE in previous node, print PUSE here.
*/
if (p_use & VAR_PUSE)
print_dupath(VAR_PUSE, ID_SYM(def->var_id), d_node, branch,
prev_node, def->defPos, prevPos);
/*
* Already visited this node ?
*/
if (BVTEST(list, branch->to->block_id))
return;
BVSET(list, branch->to->block_id);
use = du_use_type(dug, branch->to, ID_SYM(def->var_id), def->ref_type);
if (use) {
use_type = use->ref_type;
usePos = use->usePos;
} else {
use_type = 0;
usePos = 0;
}
/*
* If C-USE at node, print it.
*/
if (use_type & VAR_CUSE)
print_dupath(VAR_CUSE, ID_SYM(def->var_id), d_node, branch,
prev_node, def->defPos, usePos);
/*
* Defining use?
*/
if (use_type & VAR_DEF)
return;
/*
* Visit each node reachable from node.
*/
if (branch->to->branches)
for (i = 0; LIST_NEXT(branch->to->branches, &i, &f);) {
if (feasableOnly && !feasableBranch(f))
continue;
u_traverse(dug, f, list, d_node, def, use_type,
branch->to, usePos, feasableOnly);
}
}