OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [fortran/] [trans-const.c] - Diff between revs 816 and 826

Only display areas with differences | Details | Blame | View Log

Rev 816 Rev 826
/* Translation of constants
/* Translation of constants
   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software
   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software
   Foundation, Inc.
   Foundation, Inc.
   Contributed by Paul Brook
   Contributed by Paul Brook
 
 
This file is part of GCC.
This file is part of GCC.
 
 
GCC is free software; you can redistribute it and/or modify it under
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
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 3, or (at your option) any later
Software Foundation; either version 3, or (at your option) any later
version.
version.
 
 
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
for more details.
for more details.
 
 
You should have received a copy of the GNU General Public License
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3.  If not see
along with GCC; see the file COPYING3.  If not see
<http://www.gnu.org/licenses/>.  */
<http://www.gnu.org/licenses/>.  */
 
 
/* trans-const.c -- convert constant values */
/* trans-const.c -- convert constant values */
 
 
#include "config.h"
#include "config.h"
#include "system.h"
#include "system.h"
#include "coretypes.h"
#include "coretypes.h"
#include "tree.h"
#include "tree.h"
#include "ggc.h"
#include "ggc.h"
#include "toplev.h"
#include "toplev.h"
#include "real.h"
#include "real.h"
#include "double-int.h"
#include "double-int.h"
#include "gfortran.h"
#include "gfortran.h"
#include "trans.h"
#include "trans.h"
#include "trans-const.h"
#include "trans-const.h"
#include "trans-types.h"
#include "trans-types.h"
#include "target-memory.h"
#include "target-memory.h"
 
 
tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1];
tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1];
 
 
/* Build a constant with given type from an int_cst.  */
/* Build a constant with given type from an int_cst.  */
 
 
tree
tree
gfc_build_const (tree type, tree intval)
gfc_build_const (tree type, tree intval)
{
{
  tree val;
  tree val;
  tree zero;
  tree zero;
 
 
  switch (TREE_CODE (type))
  switch (TREE_CODE (type))
    {
    {
    case INTEGER_TYPE:
    case INTEGER_TYPE:
      val = convert (type, intval);
      val = convert (type, intval);
      break;
      break;
 
 
    case REAL_TYPE:
    case REAL_TYPE:
      val = build_real_from_int_cst (type, intval);
      val = build_real_from_int_cst (type, intval);
      break;
      break;
 
 
    case COMPLEX_TYPE:
    case COMPLEX_TYPE:
      val = build_real_from_int_cst (TREE_TYPE (type), intval);
      val = build_real_from_int_cst (TREE_TYPE (type), intval);
      zero = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
      zero = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
      val = build_complex (type, val, zero);
      val = build_complex (type, val, zero);
      break;
      break;
 
 
    default:
    default:
      gcc_unreachable ();
      gcc_unreachable ();
    }
    }
  return val;
  return val;
}
}
 
 
/* Build a string constant with C char type.  */
/* Build a string constant with C char type.  */
 
 
tree
tree
gfc_build_string_const (int length, const char *s)
gfc_build_string_const (int length, const char *s)
{
{
  tree str;
  tree str;
  tree len;
  tree len;
 
 
  str = build_string (length, s);
  str = build_string (length, s);
  len = build_int_cst (NULL_TREE, length);
  len = build_int_cst (NULL_TREE, length);
  TREE_TYPE (str) =
  TREE_TYPE (str) =
    build_array_type (gfc_character1_type_node,
    build_array_type (gfc_character1_type_node,
                      build_range_type (gfc_charlen_type_node,
                      build_range_type (gfc_charlen_type_node,
                                        integer_one_node, len));
                                        integer_one_node, len));
  return str;
  return str;
}
}
 
 
 
 
/* Build a string constant with a type given by its kind; take care of
/* Build a string constant with a type given by its kind; take care of
   non-default character kinds.  */
   non-default character kinds.  */
 
 
tree
tree
gfc_build_wide_string_const (int kind, int length, const gfc_char_t *string)
gfc_build_wide_string_const (int kind, int length, const gfc_char_t *string)
{
{
  int i;
  int i;
  tree str, len;
  tree str, len;
  size_t size;
  size_t size;
  char *s;
  char *s;
 
 
  i = gfc_validate_kind (BT_CHARACTER, kind, false);
  i = gfc_validate_kind (BT_CHARACTER, kind, false);
  size = length * gfc_character_kinds[i].bit_size / 8;
  size = length * gfc_character_kinds[i].bit_size / 8;
 
 
  s = XCNEWVAR (char, size);
  s = XCNEWVAR (char, size);
  gfc_encode_character (kind, length, string, (unsigned char *) s, size);
  gfc_encode_character (kind, length, string, (unsigned char *) s, size);
 
 
  str = build_string (size, s);
  str = build_string (size, s);
  gfc_free (s);
  gfc_free (s);
 
 
  len = build_int_cst (NULL_TREE, length);
  len = build_int_cst (NULL_TREE, length);
  TREE_TYPE (str) =
  TREE_TYPE (str) =
    build_array_type (gfc_get_char_type (kind),
    build_array_type (gfc_get_char_type (kind),
                      build_range_type (gfc_charlen_type_node,
                      build_range_type (gfc_charlen_type_node,
                                        integer_one_node, len));
                                        integer_one_node, len));
  return str;
  return str;
}
}
 
 
 
 
/* Build a Fortran character constant from a zero-terminated string.
/* Build a Fortran character constant from a zero-terminated string.
   There a two version of this function, one that translates the string
   There a two version of this function, one that translates the string
   and one that doesn't.  */
   and one that doesn't.  */
tree
tree
gfc_build_cstring_const (const char *string)
gfc_build_cstring_const (const char *string)
{
{
  return gfc_build_string_const (strlen (string) + 1, string);
  return gfc_build_string_const (strlen (string) + 1, string);
}
}
 
 
tree
tree
gfc_build_localized_cstring_const (const char *msgid)
gfc_build_localized_cstring_const (const char *msgid)
{
{
  const char *localized = _(msgid);
  const char *localized = _(msgid);
  return gfc_build_string_const (strlen (localized) + 1, localized);
  return gfc_build_string_const (strlen (localized) + 1, localized);
}
}
 
 
 
 
/* Return a string constant with the given length.  Used for static
/* Return a string constant with the given length.  Used for static
   initializers.  The constant will be padded or truncated to match
   initializers.  The constant will be padded or truncated to match
   length.  */
   length.  */
 
 
tree
tree
gfc_conv_string_init (tree length, gfc_expr * expr)
gfc_conv_string_init (tree length, gfc_expr * expr)
{
{
  gfc_char_t *s;
  gfc_char_t *s;
  HOST_WIDE_INT len;
  HOST_WIDE_INT len;
  int slen;
  int slen;
  tree str;
  tree str;
  bool free_s = false;
  bool free_s = false;
 
 
  gcc_assert (expr->expr_type == EXPR_CONSTANT);
  gcc_assert (expr->expr_type == EXPR_CONSTANT);
  gcc_assert (expr->ts.type == BT_CHARACTER);
  gcc_assert (expr->ts.type == BT_CHARACTER);
  gcc_assert (INTEGER_CST_P (length));
  gcc_assert (INTEGER_CST_P (length));
  gcc_assert (TREE_INT_CST_HIGH (length) == 0);
  gcc_assert (TREE_INT_CST_HIGH (length) == 0);
 
 
  len = TREE_INT_CST_LOW (length);
  len = TREE_INT_CST_LOW (length);
  slen = expr->value.character.length;
  slen = expr->value.character.length;
 
 
  if (len > slen)
  if (len > slen)
    {
    {
      s = gfc_get_wide_string (len);
      s = gfc_get_wide_string (len);
      memcpy (s, expr->value.character.string, slen * sizeof (gfc_char_t));
      memcpy (s, expr->value.character.string, slen * sizeof (gfc_char_t));
      gfc_wide_memset (&s[slen], ' ', len - slen);
      gfc_wide_memset (&s[slen], ' ', len - slen);
      free_s = true;
      free_s = true;
    }
    }
  else
  else
    s = expr->value.character.string;
    s = expr->value.character.string;
 
 
  str = gfc_build_wide_string_const (expr->ts.kind, len, s);
  str = gfc_build_wide_string_const (expr->ts.kind, len, s);
 
 
  if (free_s)
  if (free_s)
    gfc_free (s);
    gfc_free (s);
 
 
  return str;
  return str;
}
}
 
 
 
 
/* Create a tree node for the string length if it is constant.  */
/* Create a tree node for the string length if it is constant.  */
 
 
void
void
gfc_conv_const_charlen (gfc_charlen * cl)
gfc_conv_const_charlen (gfc_charlen * cl)
{
{
  if (!cl || cl->backend_decl)
  if (!cl || cl->backend_decl)
    return;
    return;
 
 
  if (cl->length && cl->length->expr_type == EXPR_CONSTANT)
  if (cl->length && cl->length->expr_type == EXPR_CONSTANT)
    {
    {
      cl->backend_decl = gfc_conv_mpz_to_tree (cl->length->value.integer,
      cl->backend_decl = gfc_conv_mpz_to_tree (cl->length->value.integer,
                                               cl->length->ts.kind);
                                               cl->length->ts.kind);
      cl->backend_decl = fold_convert (gfc_charlen_type_node,
      cl->backend_decl = fold_convert (gfc_charlen_type_node,
                                        cl->backend_decl);
                                        cl->backend_decl);
    }
    }
}
}
 
 
void
void
gfc_init_constants (void)
gfc_init_constants (void)
{
{
  int n;
  int n;
 
 
  for (n = 0; n <= GFC_MAX_DIMENSIONS; n++)
  for (n = 0; n <= GFC_MAX_DIMENSIONS; n++)
    gfc_rank_cst[n] = build_int_cst (gfc_array_index_type, n);
    gfc_rank_cst[n] = build_int_cst (gfc_array_index_type, n);
}
}
 
 
/* Converts a GMP integer into a backend tree node.  */
/* Converts a GMP integer into a backend tree node.  */
 
 
tree
tree
gfc_conv_mpz_to_tree (mpz_t i, int kind)
gfc_conv_mpz_to_tree (mpz_t i, int kind)
{
{
  double_int val = mpz_get_double_int (gfc_get_int_type (kind), i, true);
  double_int val = mpz_get_double_int (gfc_get_int_type (kind), i, true);
  return double_int_to_tree (gfc_get_int_type (kind), val);
  return double_int_to_tree (gfc_get_int_type (kind), val);
}
}
 
 
/* Converts a backend tree into a GMP integer.  */
/* Converts a backend tree into a GMP integer.  */
 
 
void
void
gfc_conv_tree_to_mpz (mpz_t i, tree source)
gfc_conv_tree_to_mpz (mpz_t i, tree source)
{
{
  double_int val = tree_to_double_int (source);
  double_int val = tree_to_double_int (source);
  mpz_set_double_int (i, val, TYPE_UNSIGNED (TREE_TYPE (source)));
  mpz_set_double_int (i, val, TYPE_UNSIGNED (TREE_TYPE (source)));
}
}
 
 
/* Converts a real constant into backend form.  */
/* Converts a real constant into backend form.  */
 
 
tree
tree
gfc_conv_mpfr_to_tree (mpfr_t f, int kind, int is_snan)
gfc_conv_mpfr_to_tree (mpfr_t f, int kind, int is_snan)
{
{
  tree type;
  tree type;
  int n;
  int n;
  REAL_VALUE_TYPE real;
  REAL_VALUE_TYPE real;
 
 
  n = gfc_validate_kind (BT_REAL, kind, false);
  n = gfc_validate_kind (BT_REAL, kind, false);
  gcc_assert (gfc_real_kinds[n].radix == 2);
  gcc_assert (gfc_real_kinds[n].radix == 2);
 
 
  type = gfc_get_real_type (kind);
  type = gfc_get_real_type (kind);
  if (mpfr_nan_p (f) && is_snan)
  if (mpfr_nan_p (f) && is_snan)
     real_from_string (&real, "SNaN");
     real_from_string (&real, "SNaN");
  else
  else
    real_from_mpfr (&real, f, type, GFC_RND_MODE);
    real_from_mpfr (&real, f, type, GFC_RND_MODE);
 
 
  return build_real (type, real);
  return build_real (type, real);
}
}
 
 
/* Converts a backend tree into a real constant.  */
/* Converts a backend tree into a real constant.  */
 
 
void
void
gfc_conv_tree_to_mpfr (mpfr_ptr f, tree source)
gfc_conv_tree_to_mpfr (mpfr_ptr f, tree source)
{
{
  mpfr_from_real (f, TREE_REAL_CST_PTR (source), GFC_RND_MODE);
  mpfr_from_real (f, TREE_REAL_CST_PTR (source), GFC_RND_MODE);
}
}
 
 
/* Translate any literal constant to a tree.  Constants never have
/* Translate any literal constant to a tree.  Constants never have
   pre or post chains.  Character literal constants are special
   pre or post chains.  Character literal constants are special
   special because they have a value and a length, so they cannot be
   special because they have a value and a length, so they cannot be
   returned as a single tree.  It is up to the caller to set the
   returned as a single tree.  It is up to the caller to set the
   length somewhere if necessary.
   length somewhere if necessary.
 
 
   Returns the translated constant, or aborts if it gets a type it
   Returns the translated constant, or aborts if it gets a type it
   can't handle.  */
   can't handle.  */
 
 
tree
tree
gfc_conv_constant_to_tree (gfc_expr * expr)
gfc_conv_constant_to_tree (gfc_expr * expr)
{
{
  tree res;
  tree res;
 
 
  gcc_assert (expr->expr_type == EXPR_CONSTANT);
  gcc_assert (expr->expr_type == EXPR_CONSTANT);
 
 
  /* If it is has a prescribed memory representation, we build a string
  /* If it is has a prescribed memory representation, we build a string
     constant and VIEW_CONVERT to its type.  */
     constant and VIEW_CONVERT to its type.  */
 
 
  switch (expr->ts.type)
  switch (expr->ts.type)
    {
    {
    case BT_INTEGER:
    case BT_INTEGER:
      if (expr->representation.string)
      if (expr->representation.string)
        return fold_build1 (VIEW_CONVERT_EXPR,
        return fold_build1 (VIEW_CONVERT_EXPR,
                            gfc_get_int_type (expr->ts.kind),
                            gfc_get_int_type (expr->ts.kind),
                            gfc_build_string_const (expr->representation.length,
                            gfc_build_string_const (expr->representation.length,
                                                    expr->representation.string));
                                                    expr->representation.string));
      else
      else
        return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
        return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
 
 
    case BT_REAL:
    case BT_REAL:
      if (expr->representation.string)
      if (expr->representation.string)
        return fold_build1 (VIEW_CONVERT_EXPR,
        return fold_build1 (VIEW_CONVERT_EXPR,
                            gfc_get_real_type (expr->ts.kind),
                            gfc_get_real_type (expr->ts.kind),
                            gfc_build_string_const (expr->representation.length,
                            gfc_build_string_const (expr->representation.length,
                                                    expr->representation.string));
                                                    expr->representation.string));
      else
      else
        return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind, expr->is_snan);
        return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind, expr->is_snan);
 
 
    case BT_LOGICAL:
    case BT_LOGICAL:
      if (expr->representation.string)
      if (expr->representation.string)
        {
        {
          tree tmp = fold_build1 (VIEW_CONVERT_EXPR,
          tree tmp = fold_build1 (VIEW_CONVERT_EXPR,
                                  gfc_get_int_type (expr->ts.kind),
                                  gfc_get_int_type (expr->ts.kind),
                                  gfc_build_string_const (expr->representation.length,
                                  gfc_build_string_const (expr->representation.length,
                                                          expr->representation.string));
                                                          expr->representation.string));
          if (!integer_zerop (tmp) && !integer_onep (tmp))
          if (!integer_zerop (tmp) && !integer_onep (tmp))
            gfc_warning ("Assigning value other than 0 or 1 to LOGICAL"
            gfc_warning ("Assigning value other than 0 or 1 to LOGICAL"
                         " has undefined result at %L", &expr->where);
                         " has undefined result at %L", &expr->where);
          return fold_convert (gfc_get_logical_type (expr->ts.kind), tmp);
          return fold_convert (gfc_get_logical_type (expr->ts.kind), tmp);
        }
        }
      else
      else
        return build_int_cst (gfc_get_logical_type (expr->ts.kind),
        return build_int_cst (gfc_get_logical_type (expr->ts.kind),
                              expr->value.logical);
                              expr->value.logical);
 
 
    case BT_COMPLEX:
    case BT_COMPLEX:
      if (expr->representation.string)
      if (expr->representation.string)
        return fold_build1 (VIEW_CONVERT_EXPR,
        return fold_build1 (VIEW_CONVERT_EXPR,
                            gfc_get_complex_type (expr->ts.kind),
                            gfc_get_complex_type (expr->ts.kind),
                            gfc_build_string_const (expr->representation.length,
                            gfc_build_string_const (expr->representation.length,
                                                    expr->representation.string));
                                                    expr->representation.string));
      else
      else
        {
        {
          tree real = gfc_conv_mpfr_to_tree (mpc_realref (expr->value.complex),
          tree real = gfc_conv_mpfr_to_tree (mpc_realref (expr->value.complex),
                                          expr->ts.kind, expr->is_snan);
                                          expr->ts.kind, expr->is_snan);
          tree imag = gfc_conv_mpfr_to_tree (mpc_imagref (expr->value.complex),
          tree imag = gfc_conv_mpfr_to_tree (mpc_imagref (expr->value.complex),
                                          expr->ts.kind, expr->is_snan);
                                          expr->ts.kind, expr->is_snan);
 
 
          return build_complex (gfc_typenode_for_spec (&expr->ts),
          return build_complex (gfc_typenode_for_spec (&expr->ts),
                                real, imag);
                                real, imag);
        }
        }
 
 
    case BT_CHARACTER:
    case BT_CHARACTER:
      res = gfc_build_wide_string_const (expr->ts.kind,
      res = gfc_build_wide_string_const (expr->ts.kind,
                                         expr->value.character.length,
                                         expr->value.character.length,
                                         expr->value.character.string);
                                         expr->value.character.string);
      return res;
      return res;
 
 
    case BT_HOLLERITH:
    case BT_HOLLERITH:
      return gfc_build_string_const (expr->representation.length,
      return gfc_build_string_const (expr->representation.length,
                                     expr->representation.string);
                                     expr->representation.string);
 
 
    default:
    default:
      fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",
      fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",
                   gfc_typename (&expr->ts));
                   gfc_typename (&expr->ts));
    }
    }
}
}
 
 
 
 
/* Like gfc_conv_constant_to_tree, but for a simplified expression.
/* Like gfc_conv_constant_to_tree, but for a simplified expression.
   We can handle character literal constants here as well.  */
   We can handle character literal constants here as well.  */
 
 
void
void
gfc_conv_constant (gfc_se * se, gfc_expr * expr)
gfc_conv_constant (gfc_se * se, gfc_expr * expr)
{
{
  /* We may be receiving an expression for C_NULL_PTR or C_NULL_FUNPTR.  If
  /* We may be receiving an expression for C_NULL_PTR or C_NULL_FUNPTR.  If
     so, the expr_type will not yet be an EXPR_CONSTANT.  We need to make
     so, the expr_type will not yet be an EXPR_CONSTANT.  We need to make
     it so here.  */
     it so here.  */
  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
      && expr->ts.u.derived->attr.is_iso_c)
      && expr->ts.u.derived->attr.is_iso_c)
    {
    {
      if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
      if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
          || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
          || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
        {
        {
          /* Create a new EXPR_CONSTANT expression for our local uses.  */
          /* Create a new EXPR_CONSTANT expression for our local uses.  */
          expr = gfc_int_expr (0);
          expr = gfc_int_expr (0);
        }
        }
    }
    }
 
 
  if (expr->expr_type != EXPR_CONSTANT)
  if (expr->expr_type != EXPR_CONSTANT)
    {
    {
      gfc_error ("non-constant initialization expression at %L", &expr->where);
      gfc_error ("non-constant initialization expression at %L", &expr->where);
      se->expr = gfc_conv_constant_to_tree (gfc_int_expr (0));
      se->expr = gfc_conv_constant_to_tree (gfc_int_expr (0));
      return;
      return;
    }
    }
 
 
  if (se->ss != NULL)
  if (se->ss != NULL)
    {
    {
      gcc_assert (se->ss != gfc_ss_terminator);
      gcc_assert (se->ss != gfc_ss_terminator);
      gcc_assert (se->ss->type == GFC_SS_SCALAR);
      gcc_assert (se->ss->type == GFC_SS_SCALAR);
      gcc_assert (se->ss->expr == expr);
      gcc_assert (se->ss->expr == expr);
 
 
      se->expr = se->ss->data.scalar.expr;
      se->expr = se->ss->data.scalar.expr;
      se->string_length = se->ss->string_length;
      se->string_length = se->ss->string_length;
      gfc_advance_se_ss_chain (se);
      gfc_advance_se_ss_chain (se);
      return;
      return;
    }
    }
 
 
  /* Translate the constant and put it in the simplifier structure.  */
  /* Translate the constant and put it in the simplifier structure.  */
  se->expr = gfc_conv_constant_to_tree (expr);
  se->expr = gfc_conv_constant_to_tree (expr);
 
 
  /* If this is a CHARACTER string, set its length in the simplifier
  /* If this is a CHARACTER string, set its length in the simplifier
     structure, too.  */
     structure, too.  */
  if (expr->ts.type == BT_CHARACTER)
  if (expr->ts.type == BT_CHARACTER)
    se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
    se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
}
}
 
 

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.