Exemplo n.º 1
0
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;
}
Exemplo n.º 2
0
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);
}
Exemplo n.º 3
0
int
is_intrinsic_function(ID id) {
    return (SYM_TYPE(ID_SYM(id)) == S_INTR) ? TRUE : FALSE;
}
Exemplo n.º 4
0
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);
	}
}