trans-intrinsic.c

gcc-fortran,linux使用fortran的编译软件。很好用的。

gfc_build_intrinsic_lib_fndecls (void)
{
  gfc_intrinsic_map_t *m;

  /* Add GCC builtin functions.  */
  for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
    {
      if (m->code_r4 != END_BUILTINS)
	m->real4_decl = built_in_decls[m->code_r4];
      if (m->code_r8 != END_BUILTINS)
	m->real8_decl = built_in_decls[m->code_r8];
      if (m->code_r10 != END_BUILTINS)
	m->real10_decl = built_in_decls[m->code_r10];
      if (m->code_r16 != END_BUILTINS)
	m->real16_decl = built_in_decls[m->code_r16];
      if (m->code_c4 != END_BUILTINS)
	m->complex4_decl = built_in_decls[m->code_c4];
      if (m->code_c8 != END_BUILTINS)
	m->complex8_decl = built_in_decls[m->code_c8];
      if (m->code_c10 != END_BUILTINS)
	m->complex10_decl = built_in_decls[m->code_c10];
      if (m->code_c16 != END_BUILTINS)
	m->complex16_decl = built_in_decls[m->code_c16];
    }
}


/* Create a fndecl for a simple intrinsic library function.  */

static tree
gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
{
  tree type;
  tree argtypes;
  tree fndecl;
  gfc_actual_arglist *actual;
  tree *pdecl;
  gfc_typespec *ts;
  char name[GFC_MAX_SYMBOL_LEN + 3];

  ts = &expr->ts;
  if (ts->type == BT_REAL)
    {
      switch (ts->kind)
	{
	case 4:
	  pdecl = &m->real4_decl;
	  break;
	case 8:
	  pdecl = &m->real8_decl;
	  break;
	case 10:
	  pdecl = &m->real10_decl;
	  break;
	case 16:
	  pdecl = &m->real16_decl;
	  break;
	default:
	  gcc_unreachable ();
	}
    }
  else if (ts->type == BT_COMPLEX)
    {
      gcc_assert (m->complex_available);

      switch (ts->kind)
	{
	case 4:
	  pdecl = &m->complex4_decl;
	  break;
	case 8:
	  pdecl = &m->complex8_decl;
	  break;
	case 10:
	  pdecl = &m->complex10_decl;
	  break;
	case 16:
	  pdecl = &m->complex16_decl;
	  break;
	default:
	  gcc_unreachable ();
	}
    }
  else
    gcc_unreachable ();

  if (*pdecl)
    return *pdecl;

  if (m->libm_name)
    {
      gcc_assert (ts->kind == 4 || ts->kind == 8 || ts->kind == 10
                 || ts->kind == 16);
      snprintf (name, sizeof (name), "%s%s%s",
		ts->type == BT_COMPLEX ? "c" : "",
		m->name,
		ts->kind == 4 ? "f" : "");
    }
  else
    {
      snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
		ts->type == BT_COMPLEX ? 'c' : 'r',
		ts->kind);
    }

  argtypes = NULL_TREE;
  for (actual = expr->value.function.actual; actual; actual = actual->next)
    {
      type = gfc_typenode_for_spec (&actual->expr->ts);
      argtypes = gfc_chainon_list (argtypes, type);
    }
  argtypes = gfc_chainon_list (argtypes, void_type_node);
  type = build_function_type (gfc_typenode_for_spec (ts), argtypes);
  fndecl = build_decl (FUNCTION_DECL, get_identifier (name), type);

  /* Mark the decl as external.  */
  DECL_EXTERNAL (fndecl) = 1;
  TREE_PUBLIC (fndecl) = 1;

  /* Mark it __attribute__((const)), if possible.  */
  TREE_READONLY (fndecl) = m->is_constant;

  rest_of_decl_compilation (fndecl, 1, 0);

  (*pdecl) = fndecl;
  return fndecl;
}


/* Convert an intrinsic function into an external or builtin call.  */

static void
gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
{
  gfc_intrinsic_map_t *m;
  tree args;
  tree fndecl;
  gfc_generic_isym_id id;

  id = expr->value.function.isym->generic_id;
  /* Find the entry for this function.  */
  for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
    {
      if (id == m->id)
	break;
    }

  if (m->id == GFC_ISYM_NONE)
    {
      internal_error ("Intrinsic function %s(%d) not recognized",
		      expr->value.function.name, id);
    }

  /* Get the decl and generate the call.  */
  args = gfc_conv_intrinsic_function_args (se, expr);
  fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
  se->expr = gfc_build_function_call (fndecl, args);
}

/* Generate code for EXPONENT(X) intrinsic function.  */

static void
gfc_conv_intrinsic_exponent (gfc_se * se, gfc_expr * expr)
{
  tree args, fndecl;
  gfc_expr *a1;

  args = gfc_conv_intrinsic_function_args (se, expr);

  a1 = expr->value.function.actual->expr;
  switch (a1->ts.kind)
    {
    case 4:
      fndecl = gfor_fndecl_math_exponent4;
      break;
    case 8:
      fndecl = gfor_fndecl_math_exponent8;
      break;
    case 10:
      fndecl = gfor_fndecl_math_exponent10;
      break;
    case 16:
      fndecl = gfor_fndecl_math_exponent16;
      break;
    default:
      gcc_unreachable ();
    }

  se->expr = gfc_build_function_call (fndecl, args);
}

/* Evaluate a single upper or lower bound.  */
/* TODO: bound intrinsic generates way too much unnecessary code.  */

static void
gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
{
  gfc_actual_arglist *arg;
  gfc_actual_arglist *arg2;
  tree desc;
  tree type;
  tree bound;
  tree tmp;
  tree cond;
  gfc_se argse;
  gfc_ss *ss;
  int i;

  arg = expr->value.function.actual;
  arg2 = arg->next;

  if (se->ss)
    {
      /* Create an implicit second parameter from the loop variable.  */
      gcc_assert (!arg2->expr);
      gcc_assert (se->loop->dimen == 1);
      gcc_assert (se->ss->expr == expr);
      gfc_advance_se_ss_chain (se);
      bound = se->loop->loopvar[0];
      bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
			   se->loop->from[0]);
    }
  else
    {
      /* use the passed argument.  */
      gcc_assert (arg->next->expr);
      gfc_init_se (&argse, NULL);
      gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
      gfc_add_block_to_block (&se->pre, &argse.pre);
      bound = argse.expr;
      /* Convert from one based to zero based.  */
      bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
			   gfc_index_one_node);
    }

  /* TODO: don't re-evaluate the descriptor on each iteration.  */
  /* Get a descriptor for the first parameter.  */
  ss = gfc_walk_expr (arg->expr);
  gcc_assert (ss != gfc_ss_terminator);
  gfc_init_se (&argse, NULL);
  gfc_conv_expr_descriptor (&argse, arg->expr, ss);
  gfc_add_block_to_block (&se->pre, &argse.pre);
  gfc_add_block_to_block (&se->post, &argse.post);

  desc = argse.expr;

  if (INTEGER_CST_P (bound))
    {
      gcc_assert (TREE_INT_CST_HIGH (bound) == 0);
      i = TREE_INT_CST_LOW (bound);
      gcc_assert (i >= 0 && i < GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)));
    }
  else
    {
      if (flag_bounds_check)
        {
          bound = gfc_evaluate_now (bound, &se->pre);
          cond = fold_build2 (LT_EXPR, boolean_type_node,
			      bound, build_int_cst (TREE_TYPE (bound), 0));
          tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
          tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
          cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
          gfc_trans_runtime_check (cond, gfc_strconst_fault, &se->pre);
        }
    }

  if (upper)
    se->expr = gfc_conv_descriptor_ubound(desc, bound);
  else
    se->expr = gfc_conv_descriptor_lbound(desc, bound);

  type = gfc_typenode_for_spec (&expr->ts);
  se->expr = convert (type, se->expr);
}


static void
gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
{
  tree args;
  tree val;
  int n;

  args = gfc_conv_intrinsic_function_args (se, expr);
  gcc_assert (args && TREE_CHAIN (args) == NULL_TREE);
  val = TREE_VALUE (args);

  switch (expr->value.function.actual->expr->ts.type)
    {
    case BT_INTEGER:
    case BT_REAL:
      se->expr = build1 (ABS_EXPR, TREE_TYPE (val), val);
      break;

    case BT_COMPLEX:
      switch (expr->ts.kind)
	{
	case 4:
	  n = BUILT_IN_CABSF;
	  break;
	case 8:
	  n = BUILT_IN_CABS;
	  break;
	case 10:
	case 16:
	  n = BUILT_IN_CABSL;
	  break;
	default:
	  gcc_unreachable ();
	}
      se->expr = fold (gfc_build_function_call (built_in_decls[n], args));
      break;

    default:
      gcc_unreachable ();
    }
}


/* Create a complex value from one or two real components.  */

static void
gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
{
  tree arg;
  tree real;
  tree imag;
  tree type;

  type = gfc_typenode_for_spec (&expr->ts);
  arg = gfc_conv_intrinsic_function_args (se, expr);
  real = convert (TREE_TYPE (type), TREE_VALUE (arg));
  if (both)
    imag = convert (TREE_TYPE (type), TREE_VALUE (TREE_CHAIN (arg)));
  else if (TREE_CODE (TREE_TYPE (TREE_VALUE (arg))) == COMPLEX_TYPE)
    {
      arg = TREE_VALUE (arg);
      imag = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
      imag = convert (TREE_TYPE (type), imag);
    }
  else
    imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);

  se->expr = fold_build2 (COMPLEX_EXPR, type, real, imag);
}

/* Remainder function MOD(A, P) = A - INT(A / P) * P
                      MODULO(A, P) = A - FLOOR (A / P) * P  */
/* TODO: MOD(x, 0)  */

static void
gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
{
  tree arg;
  tree arg2;
  tree type;
  tree itype;
  tree tmp;
  tree test;
  tree test2;
  mpfr_t huge;
  int n;

  arg = gfc_conv_intrinsic_function_args (se, expr);
  arg2 = TREE_VALUE (TREE_CHAIN (arg));
  arg = TREE_VALUE (arg);
  type = TREE_TYPE (arg);

  switch (expr->ts.type)
    {
    case BT_INTEGER:
      /* Integer case is easy, we've got a builtin op.  */
      if (modulo)
       se->expr = build2 (FLOOR_MOD_EXPR, type, arg, arg2);
      else
       se->expr = build2 (TRUNC_MOD_EXPR, type, arg, arg2);
      break;

    case BT_REAL:
      /* Real values we have to do the hard way.  */
      arg = gfc_evaluate_now (arg, &se->pre);
      arg2 = gfc_evaluate_now (arg2, &se->pre);

      tmp = build2 (RDIV_EXPR, type, arg, arg2);
      /* Test if the value is too large to handle sensibly.  */
      gfc_set_model_kind (expr->ts.kind);
      mpfr_init (huge);
      n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
      mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
      test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
      test2 = build2 (LT_EXPR, boolean_type_node, tmp, test);

      mpfr_neg (huge, huge, GFC_RND_MODE);
      test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
      test = build2 (GT_EXPR, boolean_type_node, tmp, test);
      test2 = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);

      itype = gfc_get_int_type (expr->ts.kind);
      if (modulo)
       tmp = build_fix_expr (&se->pre, tmp, itype, FIX_FLOOR_EXPR);
      else
       tmp = build_fix_expr (&se->pre, tmp, itype, FIX_TRUNC_EXPR);
      tmp = convert (type, tmp);
      tmp = build3 (COND_EXPR, type, test2, tmp, arg);
      tmp = build2 (MULT_EXPR, type, tmp, arg2);
      se->expr = build2 (MINUS_EXPR, type, arg, tmp);
      mpfr_clear (huge);
      break;

    default:
      gcc_unreachable ();
    }
}

/* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y.  */

static void
gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
{
  tree arg;
  tree arg2;
  tree val;
  tree tmp;
  tree type;
  tree zero;

  arg = gfc_conv_intrinsic_function_args (se, expr);
  arg2 = TREE_VALUE (TREE_CHAIN (arg));
  arg = TREE_VALUE (arg);
  type = TREE_TYPE (arg);

  val = build2 (MINUS_EXPR, type, arg, arg2);
  val = gfc_evaluate_now (val, &se->pre);

  zero = gfc_build_const (type, integer_zero_node);
  tmp = build2 (LE_EXPR, boolean_type_node, val, zero);
  se->expr = build3 (COND_EXPR, type, tmp, zero, val);
}


/* SIGN(A, B) is absolute value of A times sign of B.
   The real value versions use library functions to ensure the correct
   handling of negative zero.  Integer case implemented as:
   SIGN(A, B) = ((a >= 0) .xor. (b >= 0)) ? a : -a
  */

static void
gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
{
  tree tmp;
  tree arg;
  tree arg2;
  tree type;
  tree zero;
  tree testa;
  tree testb;


  arg = gfc_conv_intrinsic_function_args (se, expr);
  if (expr->ts.type == BT_REAL)
    {
      switch (expr->ts.kind)
	{
	case 4:
	  tmp = built_in_decls[BUILT_IN_COPYSIGNF];
	  break;
	case 8:
	  tmp = built_in_decls[BUILT_IN_COPYSIGN];
	  break;
	case 10:
	case 16:
	  tmp = built_in_decls[BUILT_IN_COPYSIGNL];
	  break;
	default:
	  gcc_unreachable ();
	}
      se->expr = fold (gfc_build_function_call (tmp, arg));
      return;
    }

  arg2 = TREE_VALUE (TREE_CHAIN (arg));
  arg = TREE_VALUE (arg);
  type = TREE_TYPE (arg);
  zero = gfc_build_const (type, integer_zero_node);

  testa = fold_build2 (GE_EXPR, boolean_type_node, arg, zero);
  testb = fold_build2 (GE_EXPR, boolean_type_node, arg2, zero);