trans-intrinsic.c

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

/* Intrinsic translation
   Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
   Contributed by Paul Brook <[e-mail]>
   and Steven Bosscher <[e-mail]>

This file is part of GCC.

GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 2, or (at your option) any later
version.

GCC is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
for more details.

You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING.  If not, write to the Free
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.  */

/* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics.  */

#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
#include "ggc.h"
#include "toplev.h"
#include "real.h"
#include "tree-gimple.h"
#include "flags.h"
#include "gfortran.h"
#include "arith.h"
#include "intrinsic.h"
#include "trans.h"
#include "trans-const.h"
#include "trans-types.h"
#include "trans-array.h"
#include "defaults.h"
/* Only for gfc_trans_assign and gfc_trans_pointer_assign.  */
#include "trans-stmt.h"

/* This maps fortran intrinsic math functions to external library or GCC
   builtin functions.  */
typedef struct gfc_intrinsic_map_t	GTY(())
{
  /* The explicit enum is required to work around inadequacies in the
     garbage collection/gengtype parsing mechanism.  */
  enum gfc_generic_isym_id id;

  /* Enum value from the "language-independent", aka C-centric, part
     of gcc, or END_BUILTINS of no such value set.  */
  enum built_in_function code_r4;
  enum built_in_function code_r8;
  enum built_in_function code_r10;
  enum built_in_function code_r16;
  enum built_in_function code_c4;
  enum built_in_function code_c8;
  enum built_in_function code_c10;
  enum built_in_function code_c16;

  /* True if the naming pattern is to prepend "c" for complex and
     append "f" for kind=4.  False if the naming pattern is to
     prepend "_gfortran_" and append "[rc](4|8|10|16)".  */
  bool libm_name;

  /* True if a complex version of the function exists.  */
  bool complex_available;

  /* True if the function should be marked const.  */
  bool is_constant;

  /* The base library name of this function.  */
  const char *name;

  /* Cache decls created for the various operand types.  */
  tree real4_decl;
  tree real8_decl;
  tree real10_decl;
  tree real16_decl;
  tree complex4_decl;
  tree complex8_decl;
  tree complex10_decl;
  tree complex16_decl;
}
gfc_intrinsic_map_t;

/* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
   defines complex variants of all of the entries in mathbuiltins.def
   except for atan2.  */
#define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
  { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
    BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, 0, 0, 0, 0, true, \
    false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
    NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},

#define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
  { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
    BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, \
    BUILT_IN_C ## ID, BUILT_IN_C ## ID ## L, BUILT_IN_C ## ID ## L, true, \
    true, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
    NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},

#define LIBM_FUNCTION(ID, NAME, HAVE_COMPLEX) \
  { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
    END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
    true, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
    NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }

#define LIBF_FUNCTION(ID, NAME, HAVE_COMPLEX) \
  { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
    END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
    false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
    NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }

static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
{
  /* Functions built into gcc itself.  */
#include "mathbuiltins.def"

  /* Functions in libm.  */
  /* ??? This does exist as BUILT_IN_SCALBN, but doesn't quite fit the
     pattern for other mathbuiltins.def entries.  At present we have no
     optimizations for this in the common sources.  */
  LIBM_FUNCTION (SCALE, "scalbn", false),

  /* Functions in libgfortran.  */
  LIBF_FUNCTION (FRACTION, "fraction", false),
  LIBF_FUNCTION (NEAREST, "nearest", false),
  LIBF_FUNCTION (SET_EXPONENT, "set_exponent", false),

  /* End the list.  */
  LIBF_FUNCTION (NONE, NULL, false)
};
#undef DEFINE_MATH_BUILTIN
#undef DEFINE_MATH_BUILTIN_C
#undef LIBM_FUNCTION
#undef LIBF_FUNCTION

/* Structure for storing components of a floating number to be used by
   elemental functions to manipulate reals.  */
typedef struct
{
  tree arg;     /* Variable tree to view convert to integer.  */
  tree expn;    /* Variable tree to save exponent.  */
  tree frac;    /* Variable tree to save fraction.  */
  tree smask;   /* Constant tree of sign's mask.  */
  tree emask;   /* Constant tree of exponent's mask.  */
  tree fmask;   /* Constant tree of fraction's mask.  */
  tree edigits; /* Constant tree of the number of exponent bits.  */
  tree fdigits; /* Constant tree of the number of fraction bits.  */
  tree f1;      /* Constant tree of the f1 defined in the real model.  */
  tree bias;    /* Constant tree of the bias of exponent in the memory.  */
  tree type;    /* Type tree of arg1.  */
  tree mtype;   /* Type tree of integer type. Kind is that of arg1.  */
}
real_compnt_info;


/* Evaluate the arguments to an intrinsic function.  */

static tree
gfc_conv_intrinsic_function_args (gfc_se * se, gfc_expr * expr)
{
  gfc_actual_arglist *actual;
  tree args;
  gfc_se argse;

  args = NULL_TREE;
  for (actual = expr->value.function.actual; actual; actual = actual->next)
    {
      /* Skip omitted optional arguments.  */
      if (!actual->expr)
	continue;

      /* Evaluate the parameter.  This will substitute scalarized
         references automatically.  */
      gfc_init_se (&argse, se);

      if (actual->expr->ts.type == BT_CHARACTER)
	{
	  gfc_conv_expr (&argse, actual->expr);
	  gfc_conv_string_parameter (&argse);
	  args = gfc_chainon_list (args, argse.string_length);
	}
      else
        gfc_conv_expr_val (&argse, actual->expr);

      gfc_add_block_to_block (&se->pre, &argse.pre);
      gfc_add_block_to_block (&se->post, &argse.post);
      args = gfc_chainon_list (args, argse.expr);
    }
  return args;
}


/* Conversions between different types are output by the frontend as
   intrinsic functions.  We implement these directly with inline code.  */

static void
gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
{
  tree type;
  tree arg;

  /* Evaluate the argument.  */
  type = gfc_typenode_for_spec (&expr->ts);
  gcc_assert (expr->value.function.actual->expr);
  arg = gfc_conv_intrinsic_function_args (se, expr);
  arg = TREE_VALUE (arg);

  /* Conversion from complex to non-complex involves taking the real
     component of the value.  */
  if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE
      && expr->ts.type != BT_COMPLEX)
    {
      tree artype;

      artype = TREE_TYPE (TREE_TYPE (arg));
      arg = build1 (REALPART_EXPR, artype, arg);
    }

  se->expr = convert (type, arg);
}

/* This is needed because the gcc backend only implements
   FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
   FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
   Similarly for CEILING.  */

static tree
build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
{
  tree tmp;
  tree cond;
  tree argtype;
  tree intval;

  argtype = TREE_TYPE (arg);
  arg = gfc_evaluate_now (arg, pblock);

  intval = convert (type, arg);
  intval = gfc_evaluate_now (intval, pblock);

  tmp = convert (argtype, intval);
  cond = build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);

  tmp = build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval,
		build_int_cst (type, 1));
  tmp = build3 (COND_EXPR, type, cond, intval, tmp);
  return tmp;
}


/* This is needed because the gcc backend only implements FIX_TRUNC_EXPR
   NINT(x) = INT(x + ((x > 0) ? 0.5 : -0.5)).  */

static tree
build_round_expr (stmtblock_t * pblock, tree arg, tree type)
{
  tree tmp;
  tree cond;
  tree neg;
  tree pos;
  tree argtype;
  REAL_VALUE_TYPE r;

  argtype = TREE_TYPE (arg);
  arg = gfc_evaluate_now (arg, pblock);

  real_from_string (&r, "0.5");
  pos = build_real (argtype, r);

  real_from_string (&r, "-0.5");
  neg = build_real (argtype, r);

  tmp = gfc_build_const (argtype, integer_zero_node);
  cond = fold_build2 (GT_EXPR, boolean_type_node, arg, tmp);

  tmp = fold_build3 (COND_EXPR, argtype, cond, pos, neg);
  tmp = fold_build2 (PLUS_EXPR, argtype, arg, tmp);
  return fold_build1 (FIX_TRUNC_EXPR, type, tmp);
}


/* Convert a real to an integer using a specific rounding mode.
   Ideally we would just build the corresponding GENERIC node,
   however the RTL expander only actually supports FIX_TRUNC_EXPR.  */

static tree
build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
               enum tree_code op)
{
  switch (op)
    {
    case FIX_FLOOR_EXPR:
      return build_fixbound_expr (pblock, arg, type, 0);
      break;

    case FIX_CEIL_EXPR:
      return build_fixbound_expr (pblock, arg, type, 1);
      break;

    case FIX_ROUND_EXPR:
      return build_round_expr (pblock, arg, type);

    default:
      return build1 (op, type, arg);
    }
}


/* Round a real value using the specified rounding mode.
   We use a temporary integer of that same kind size as the result.
   Values larger than those that can be represented by this kind are
   unchanged, as thay will not be accurate enough to represent the
   rounding.
    huge = HUGE (KIND (a))
    aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
   */

static void
gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum tree_code op)
{
  tree type;
  tree itype;
  tree arg;
  tree tmp;
  tree cond;
  mpfr_t huge;
  int n;
  int kind;

  kind = expr->ts.kind;

  n = END_BUILTINS;
  /* We have builtin functions for some cases.  */
  switch (op)
    {
    case FIX_ROUND_EXPR:
      switch (kind)
	{
	case 4:
	  n = BUILT_IN_ROUNDF;
	  break;

	case 8:
	  n = BUILT_IN_ROUND;
	  break;

	case 10:
	case 16:
	  n = BUILT_IN_ROUNDL;
	  break;
	}
      break;

    case FIX_TRUNC_EXPR:
      switch (kind)
	{
	case 4:
	  n = BUILT_IN_TRUNCF;
	  break;

	case 8:
	  n = BUILT_IN_TRUNC;
	  break;

	case 10:
	case 16:
	  n = BUILT_IN_TRUNCL;
	  break;
	}
      break;

    default:
      gcc_unreachable ();
    }

  /* Evaluate the argument.  */
  gcc_assert (expr->value.function.actual->expr);
  arg = gfc_conv_intrinsic_function_args (se, expr);

  /* Use a builtin function if one exists.  */
  if (n != END_BUILTINS)
    {
      tmp = built_in_decls[n];
      se->expr = gfc_build_function_call (tmp, arg);
      return;
    }

  /* This code is probably redundant, but we'll keep it lying around just
     in case.  */
  type = gfc_typenode_for_spec (&expr->ts);
  arg = TREE_VALUE (arg);
  arg = gfc_evaluate_now (arg, &se->pre);

  /* Test if the value is too large to handle sensibly.  */
  gfc_set_model_kind (kind);
  mpfr_init (huge);
  n = gfc_validate_kind (BT_INTEGER, kind, false);
  mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
  tmp = gfc_conv_mpfr_to_tree (huge, kind);
  cond = build2 (LT_EXPR, boolean_type_node, arg, tmp);

  mpfr_neg (huge, huge, GFC_RND_MODE);
  tmp = gfc_conv_mpfr_to_tree (huge, kind);
  tmp = build2 (GT_EXPR, boolean_type_node, arg, tmp);
  cond = build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
  itype = gfc_get_int_type (kind);

  tmp = build_fix_expr (&se->pre, arg, itype, op);
  tmp = convert (type, tmp);
  se->expr = build3 (COND_EXPR, type, cond, tmp, arg);
  mpfr_clear (huge);
}


/* Convert to an integer using the specified rounding mode.  */

static void
gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, int op)
{
  tree type;
  tree arg;

  /* Evaluate the argument.  */
  type = gfc_typenode_for_spec (&expr->ts);
  gcc_assert (expr->value.function.actual->expr);
  arg = gfc_conv_intrinsic_function_args (se, expr);
  arg = TREE_VALUE (arg);

  if (TREE_CODE (TREE_TYPE (arg)) == INTEGER_TYPE)
    {
      /* Conversion to a different integer kind.  */
      se->expr = convert (type, arg);
    }
  else
    {
      /* Conversion from complex to non-complex involves taking the real
         component of the value.  */
      if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE
	  && expr->ts.type != BT_COMPLEX)
	{
	  tree artype;

	  artype = TREE_TYPE (TREE_TYPE (arg));
	  arg = build1 (REALPART_EXPR, artype, arg);
	}

      se->expr = build_fix_expr (&se->pre, arg, type, op);
    }
}


/* Get the imaginary component of a value.  */

static void
gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
{
  tree arg;

  arg = gfc_conv_intrinsic_function_args (se, expr);
  arg = TREE_VALUE (arg);
  se->expr = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
}


/* Get the complex conjugate of a value.  */

static void
gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
{
  tree arg;

  arg = gfc_conv_intrinsic_function_args (se, expr);
  arg = TREE_VALUE (arg);
  se->expr = build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
}


/* Initialize function decls for library functions.  The external functions
   are created as required.  Builtin functions are added here.  */

void