Subversion Repositories openrisc

/* Translation of constants

   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010

   Free Software Foundation, Inc.

   Contributed by Paul Brook

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 3, 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 COPYING3.  If not see

<http://www.gnu.org/licenses/>.  */

/* trans-const.c -- convert constant values */

#include "config.h"

#include "system.h"

#include "coretypes.h"

#include "tree.h"

#include "realmpfr.h"

#include "diagnostic-core.h"    /* For fatal_error.  */

#include "double-int.h"

#include "gfortran.h"

#include "trans.h"

#include "trans-const.h"

#include "trans-types.h"

#include "target-memory.h"

tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1];

/* Build a constant with given type from an int_cst.  */

tree

gfc_build_const (tree type, tree intval)

{

  tree val;

  tree zero;

  switch (TREE_CODE (type))

    {

    case INTEGER_TYPE:

      val = convert (type, intval);

      break;

    case REAL_TYPE:

      val = build_real_from_int_cst (type, intval);

      break;

    case COMPLEX_TYPE:

      val = build_real_from_int_cst (TREE_TYPE (type), intval);

      zero = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);

      val = build_complex (type, val, zero);

      break;

    default:

      gcc_unreachable ();

    }

  return val;

}

/* Build a string constant with C char type.  */

tree

gfc_build_string_const (int length, const char *s)

{

  tree str;

  tree len;

  str = build_string (length, s);

  len = size_int (length);

  TREE_TYPE (str) =

    build_array_type (gfc_character1_type_node,

                      build_range_type (gfc_charlen_type_node,

                                        size_one_node, len));

  return str;

}

/* Build a string constant with a type given by its kind; take care of

   non-default character kinds.  */

tree

gfc_build_wide_string_const (int kind, int length, const gfc_char_t *string)

{

  int i;

  tree str, len;

  size_t size;

  char *s;

  i = gfc_validate_kind (BT_CHARACTER, kind, false);

  size = length * gfc_character_kinds[i].bit_size / 8;

  s = XCNEWVAR (char, size);

  gfc_encode_character (kind, length, string, (unsigned char *) s, size);

  str = build_string (size, s);

  free (s);

  len = size_int (length);

  TREE_TYPE (str) =

    build_array_type (gfc_get_char_type (kind),

                      build_range_type (gfc_charlen_type_node,

                                        size_one_node, len));

  return str;

}

/* Build a Fortran character constant from a zero-terminated string.

   There a two version of this function, one that translates the string

   and one that doesn't.  */

tree

gfc_build_cstring_const (const char *string)

{

  return gfc_build_string_const (strlen (string) + 1, string);

}

tree

gfc_build_localized_cstring_const (const char *msgid)

{

  const char *localized = _(msgid);

  return gfc_build_string_const (strlen (localized) + 1, localized);

}

/* Return a string constant with the given length.  Used for static

   initializers.  The constant will be padded or truncated to match

   length.  */

tree

gfc_conv_string_init (tree length, gfc_expr * expr)

{

  gfc_char_t *s;

  HOST_WIDE_INT len;

  int slen;

  tree str;

  bool free_s = false;

  gcc_assert (expr->expr_type == EXPR_CONSTANT);

  gcc_assert (expr->ts.type == BT_CHARACTER);

  gcc_assert (INTEGER_CST_P (length));

  gcc_assert (TREE_INT_CST_HIGH (length) == 0);

  len = TREE_INT_CST_LOW (length);

  slen = expr->value.character.length;

  if (len > slen)

    {

      s = gfc_get_wide_string (len);

      memcpy (s, expr->value.character.string, slen * sizeof (gfc_char_t));

      gfc_wide_memset (&s[slen], ' ', len - slen);

      free_s = true;

    }

  else

    s = expr->value.character.string;

  str = gfc_build_wide_string_const (expr->ts.kind, len, s);

  if (free_s)

    free (s);

  return str;

}

/* Create a tree node for the string length if it is constant.  */

void

gfc_conv_const_charlen (gfc_charlen * cl)

{

  if (!cl || cl->backend_decl)

    return;

  if (cl->length && cl->length->expr_type == EXPR_CONSTANT)

    {

      cl->backend_decl = gfc_conv_mpz_to_tree (cl->length->value.integer,

                                               cl->length->ts.kind);

      cl->backend_decl = fold_convert (gfc_charlen_type_node,

                                        cl->backend_decl);

    }

}

void

gfc_init_constants (void)

{

  int n;

  for (n = 0; n <= GFC_MAX_DIMENSIONS; n++)

    gfc_rank_cst[n] = build_int_cst (gfc_array_index_type, n);

}

/* Converts a GMP integer into a backend tree node.  */

tree

gfc_conv_mpz_to_tree (mpz_t i, int kind)

{

  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);

}

/* Converts a backend tree into a GMP integer.  */

void

gfc_conv_tree_to_mpz (mpz_t i, tree source)

{

  double_int val = tree_to_double_int (source);

  mpz_set_double_int (i, val, TYPE_UNSIGNED (TREE_TYPE (source)));

}

/* Converts a real constant into backend form.  */

tree

gfc_conv_mpfr_to_tree (mpfr_t f, int kind, int is_snan)

{

  tree type;

  int n;

  REAL_VALUE_TYPE real;

  n = gfc_validate_kind (BT_REAL, kind, false);

  gcc_assert (gfc_real_kinds[n].radix == 2);

  type = gfc_get_real_type (kind);

  if (mpfr_nan_p (f) && is_snan)

     real_from_string (&real, "SNaN");

  else

    real_from_mpfr (&real, f, type, GFC_RND_MODE);

  return build_real (type, real);

}

/* Returns a real constant that is +Infinity if the target

   supports infinities for this floating-point mode, and

   +HUGE_VAL otherwise (the largest representable number).  */

tree

gfc_build_inf_or_huge (tree type, int kind)

{

  if (HONOR_INFINITIES (TYPE_MODE (type)))

    {

      REAL_VALUE_TYPE real;

      real_inf (&real);

      return build_real (type, real);

    }

  else

    {

      int k = gfc_validate_kind (BT_REAL, kind, false);

      return gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge, kind, 0);

    }

}

/* Converts a backend tree into a real constant.  */

void

gfc_conv_tree_to_mpfr (mpfr_ptr f, tree source)

{

  mpfr_from_real (f, TREE_REAL_CST_PTR (source), GFC_RND_MODE);

}

/* Translate any literal constant to a tree.  Constants never have

   pre or post chains.  Character literal constants are special

   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

   length somewhere if necessary.

   Returns the translated constant, or aborts if it gets a type it

   can't handle.  */

tree

gfc_conv_constant_to_tree (gfc_expr * expr)

{

  tree res;

  gcc_assert (expr->expr_type == EXPR_CONSTANT);

  /* If it is has a prescribed memory representation, we build a string

     constant and VIEW_CONVERT to its type.  */

  switch (expr->ts.type)

    {

    case BT_INTEGER:

      if (expr->representation.string)

        return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,

                         gfc_get_int_type (expr->ts.kind),

                         gfc_build_string_const (expr->representation.length,

                                                 expr->representation.string));

      else

        return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);

    case BT_REAL:

      if (expr->representation.string)

        return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,

                         gfc_get_real_type (expr->ts.kind),

                         gfc_build_string_const (expr->representation.length,

                                                 expr->representation.string));

      else

        return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind, expr->is_snan);

    case BT_LOGICAL:

      if (expr->representation.string)

        {

          tree tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,

                        gfc_get_int_type (expr->ts.kind),

                        gfc_build_string_const (expr->representation.length,

                                                expr->representation.string));

          if (!integer_zerop (tmp) && !integer_onep (tmp))

            gfc_warning ("Assigning value other than 0 or 1 to LOGICAL"

                         " has undefined result at %L", &expr->where);

          return fold_convert (gfc_get_logical_type (expr->ts.kind), tmp);

        }

      else

        return build_int_cst (gfc_get_logical_type (expr->ts.kind),

                              expr->value.logical);

    case BT_COMPLEX:

      if (expr->representation.string)

        return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,

                         gfc_get_complex_type (expr->ts.kind),

                         gfc_build_string_const (expr->representation.length,

                                                 expr->representation.string));

      else

        {

          tree real = gfc_conv_mpfr_to_tree (mpc_realref (expr->value.complex),

                                          expr->ts.kind, expr->is_snan);

          tree imag = gfc_conv_mpfr_to_tree (mpc_imagref (expr->value.complex),

                                          expr->ts.kind, expr->is_snan);

          return build_complex (gfc_typenode_for_spec (&expr->ts),

                                real, imag);

        }

    case BT_CHARACTER:

      res = gfc_build_wide_string_const (expr->ts.kind,

                                         expr->value.character.length,

                                         expr->value.character.string);

      return res;

    case BT_HOLLERITH:

      return gfc_build_string_const (expr->representation.length,

                                     expr->representation.string);

    default:

      fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",

                   gfc_typename (&expr->ts));

    }

}

/* Like gfc_conv_constant_to_tree, but for a simplified expression.

   We can handle character literal constants here as well.  */

void

gfc_conv_constant (gfc_se * se, gfc_expr * expr)

{

  gfc_ss *ss;

  /* 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

     it so here.  */

  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived

      && expr->ts.u.derived->attr.is_iso_c)

    {

      if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR

          || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)

        {

          /* Create a new EXPR_CONSTANT expression for our local uses.  */

          expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);

        }

    }

  if (expr->expr_type != EXPR_CONSTANT)

    {

      gfc_expr *e = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);

      gfc_error ("non-constant initialization expression at %L", &expr->where);

      se->expr = gfc_conv_constant_to_tree (e);

      return;

    }

  ss = se->ss;

  if (ss != NULL)

    {

      gfc_ss_info *ss_info;

      ss_info = ss->info;

      gcc_assert (ss != gfc_ss_terminator);

      gcc_assert (ss_info->type == GFC_SS_SCALAR);

      gcc_assert (ss_info->expr == expr);

      se->expr = ss_info->data.scalar.value;

      se->string_length = ss_info->string_length;

      gfc_advance_se_ss_chain (se);

      return;

    }

  /* Translate the constant and put it in the simplifier structure.  */

  se->expr = gfc_conv_constant_to_tree (expr);

  /* If this is a CHARACTER string, set its length in the simplifier

     structure, too.  */

  if (expr->ts.type == BT_CHARACTER)

    se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));

}