Subversion Repositories scarts

/* Backend support for Fortran 95 basic types and derived types.

   Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.

   Contributed by Paul Brook <paul@nowt.org>

   and Steven Bosscher <s.bosscher@student.tudelft.nl>

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-types.c -- gfortran backend types */

#include "config.h"

#include "system.h"

#include "coretypes.h"

#include "tree.h"

#include "tm.h"

#include "target.h"

#include "ggc.h"

#include "toplev.h"

#include "gfortran.h"

#include "trans.h"

#include "trans-types.h"

#include "trans-const.h"

#include "real.h"

#if (GFC_MAX_DIMENSIONS < 10)

#define GFC_RANK_DIGITS 1

#define GFC_RANK_PRINTF_FORMAT "%01d"

#elif (GFC_MAX_DIMENSIONS < 100)

#define GFC_RANK_DIGITS 2

#define GFC_RANK_PRINTF_FORMAT "%02d"

#else

#error If you really need >99 dimensions, continue the sequence above...

#endif

static tree gfc_get_derived_type (gfc_symbol * derived);

tree gfc_array_index_type;

tree gfc_array_range_type;

tree gfc_character1_type_node;

tree pvoid_type_node;

tree ppvoid_type_node;

tree pchar_type_node;

tree gfc_charlen_type_node;

static GTY(()) tree gfc_desc_dim_type;

static GTY(()) tree gfc_max_array_element_size;

static GTY(()) tree gfc_array_descriptor_base[GFC_MAX_DIMENSIONS];

/* Arrays for all integral and real kinds.  We'll fill this in at runtime

   after the target has a chance to process command-line options.  */

#define MAX_INT_KINDS 5

gfc_integer_info gfc_integer_kinds[MAX_INT_KINDS + 1];

gfc_logical_info gfc_logical_kinds[MAX_INT_KINDS + 1];

static GTY(()) tree gfc_integer_types[MAX_INT_KINDS + 1];

static GTY(()) tree gfc_logical_types[MAX_INT_KINDS + 1];

#define MAX_REAL_KINDS 5

gfc_real_info gfc_real_kinds[MAX_REAL_KINDS + 1];

static GTY(()) tree gfc_real_types[MAX_REAL_KINDS + 1];

static GTY(()) tree gfc_complex_types[MAX_REAL_KINDS + 1];

/* The integer kind to use for array indices.  This will be set to the

   proper value based on target information from the backend.  */

int gfc_index_integer_kind;

/* The default kinds of the various types.  */

int gfc_default_integer_kind;

int gfc_max_integer_kind;

int gfc_default_real_kind;

int gfc_default_double_kind;

int gfc_default_character_kind;

int gfc_default_logical_kind;

int gfc_default_complex_kind;

int gfc_c_int_kind;

/* Query the target to determine which machine modes are available for

   computation.  Choose KIND numbers for them.  */

void

gfc_init_kinds (void)

{

  enum machine_mode mode;

  int i_index, r_index;

  bool saw_i4 = false, saw_i8 = false;

  bool saw_r4 = false, saw_r8 = false, saw_r16 = false;

  for (i_index = 0, mode = MIN_MODE_INT; mode <= MAX_MODE_INT; mode++)

    {

      int kind, bitsize;

      if (!targetm.scalar_mode_supported_p (mode))

        continue;

      /* The middle end doesn't support constants larger than 2*HWI.

         Perhaps the target hook shouldn't have accepted these either,

         but just to be safe...  */

      bitsize = GET_MODE_BITSIZE (mode);

      if (bitsize > 2*HOST_BITS_PER_WIDE_INT)

        continue;

      gcc_assert (i_index != MAX_INT_KINDS);

      /* Let the kind equal the bit size divided by 8.  This insulates the

         programmer from the underlying byte size.  */

      kind = bitsize / 8;

      if (kind == 4)

        saw_i4 = true;

      if (kind == 8)

        saw_i8 = true;

      gfc_integer_kinds[i_index].kind = kind;

      gfc_integer_kinds[i_index].radix = 2;

      gfc_integer_kinds[i_index].digits = bitsize - 1;

      gfc_integer_kinds[i_index].bit_size = bitsize;

      gfc_logical_kinds[i_index].kind = kind;

      gfc_logical_kinds[i_index].bit_size = bitsize;

      i_index += 1;

    }

  /* Set the maximum integer kind.  Used with at least BOZ constants.  */

  gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind;

  for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++)

    {

      const struct real_format *fmt = REAL_MODE_FORMAT (mode);

      int kind;

      if (fmt == NULL)

        continue;

      if (!targetm.scalar_mode_supported_p (mode))

        continue;

      /* Only let float/double/long double go through because the fortran

         library assumes these are the only floating point types.  */

      if (mode != TYPE_MODE (float_type_node)

          && (mode != TYPE_MODE (double_type_node))

          && (mode != TYPE_MODE (long_double_type_node)))

        continue;

      /* Let the kind equal the precision divided by 8, rounding up.  Again,

         this insulates the programmer from the underlying byte size.

         Also, it effectively deals with IEEE extended formats.  There, the

         total size of the type may equal 16, but it's got 6 bytes of padding

         and the increased size can get in the way of a real IEEE quad format

         which may also be supported by the target.

         We round up so as to handle IA-64 __floatreg (RFmode), which is an

         82 bit type.  Not to be confused with __float80 (XFmode), which is

         an 80 bit type also supported by IA-64.  So XFmode should come out

         to be kind=10, and RFmode should come out to be kind=11.  Egads.  */

      kind = (GET_MODE_PRECISION (mode) + 7) / 8;

      if (kind == 4)

        saw_r4 = true;

      if (kind == 8)

        saw_r8 = true;

      if (kind == 16)

        saw_r16 = true;

      /* Careful we don't stumble a wierd internal mode.  */

      gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind);

      /* Or have too many modes for the allocated space.  */

      gcc_assert (r_index != MAX_REAL_KINDS);

      gfc_real_kinds[r_index].kind = kind;

      gfc_real_kinds[r_index].radix = fmt->b;

      gfc_real_kinds[r_index].digits = fmt->p;

      gfc_real_kinds[r_index].min_exponent = fmt->emin;

      gfc_real_kinds[r_index].max_exponent = fmt->emax;

      if (fmt->pnan < fmt->p)

        /* This is an IBM extended double format (or the MIPS variant)

           made up of two IEEE doubles.  The value of the long double is

           the sum of the values of the two parts.  The most significant

           part is required to be the value of the long double rounded

           to the nearest double.  If we use emax of 1024 then we can't

           represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because

           rounding will make the most significant part overflow.  */

        gfc_real_kinds[r_index].max_exponent = fmt->emax - 1;

      gfc_real_kinds[r_index].mode_precision = GET_MODE_PRECISION (mode);

      r_index += 1;

    }

  /* Choose the default integer kind.  We choose 4 unless the user

     directs us otherwise.  */

  if (gfc_option.flag_default_integer)

    {

      if (!saw_i8)

        fatal_error ("integer kind=8 not available for -fdefault-integer-8 option");

      gfc_default_integer_kind = 8;

    }

  else if (saw_i4)

    gfc_default_integer_kind = 4;

  else

    gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind;

  /* Choose the default real kind.  Again, we choose 4 when possible.  */

  if (gfc_option.flag_default_real)

    {

      if (!saw_r8)

        fatal_error ("real kind=8 not available for -fdefault-real-8 option");

      gfc_default_real_kind = 8;

    }

  else if (saw_r4)

    gfc_default_real_kind = 4;

  else

    gfc_default_real_kind = gfc_real_kinds[0].kind;

  /* Choose the default double kind.  If -fdefault-real and -fdefault-double

     are specified, we use kind=8, if it's available.  If -fdefault-real is

     specified without -fdefault-double, we use kind=16, if it's available.

     Otherwise we do not change anything.  */

  if (gfc_option.flag_default_double && !gfc_option.flag_default_real)

    fatal_error ("Use of -fdefault-double-8 requires -fdefault-real-8");

  if (gfc_option.flag_default_real && gfc_option.flag_default_double && saw_r8)

    gfc_default_double_kind = 8;

  else if (gfc_option.flag_default_real && saw_r16)

    gfc_default_double_kind = 16;

  else if (saw_r4 && saw_r8)

    gfc_default_double_kind = 8;

  else

    {

      /* F95 14.6.3.1: A nonpointer scalar object of type double precision

         real ... occupies two contiguous numeric storage units.

         Therefore we must be supplied a kind twice as large as we chose

         for single precision.  There are loopholes, in that double

         precision must *occupy* two storage units, though it doesn't have

         to *use* two storage units.  Which means that you can make this

         kind artificially wide by padding it.  But at present there are

         no GCC targets for which a two-word type does not exist, so we

         just let gfc_validate_kind abort and tell us if something breaks.  */

      gfc_default_double_kind

        = gfc_validate_kind (BT_REAL, gfc_default_real_kind * 2, false);

    }

  /* The default logical kind is constrained to be the same as the

     default integer kind.  Similarly with complex and real.  */

  gfc_default_logical_kind = gfc_default_integer_kind;

  gfc_default_complex_kind = gfc_default_real_kind;

  /* Choose the smallest integer kind for our default character.  */

  gfc_default_character_kind = gfc_integer_kinds[0].kind;

  /* Choose the integer kind the same size as "void*" for our index kind.  */

  gfc_index_integer_kind = POINTER_SIZE / 8;

  /* Pick a kind the same size as the C "int" type.  */

  gfc_c_int_kind = INT_TYPE_SIZE / 8;

}

/* Make sure that a valid kind is present.  Returns an index into the

   associated kinds array, -1 if the kind is not present.  */

static int

validate_integer (int kind)

{

  int i;

  for (i = 0; gfc_integer_kinds[i].kind != 0; i++)

    if (gfc_integer_kinds[i].kind == kind)

      return i;

  return -1;

}

static int

validate_real (int kind)

{

  int i;

  for (i = 0; gfc_real_kinds[i].kind != 0; i++)

    if (gfc_real_kinds[i].kind == kind)

      return i;

  return -1;

}

static int

validate_logical (int kind)

{

  int i;

  for (i = 0; gfc_logical_kinds[i].kind; i++)

    if (gfc_logical_kinds[i].kind == kind)

      return i;

  return -1;

}

static int

validate_character (int kind)

{

  return kind == gfc_default_character_kind ? 0 : -1;

}

/* Validate a kind given a basic type.  The return value is the same

   for the child functions, with -1 indicating nonexistence of the

   type.  If MAY_FAIL is false, then -1 is never returned, and we ICE.  */

int

gfc_validate_kind (bt type, int kind, bool may_fail)

{

  int rc;

  switch (type)

    {

    case BT_REAL:               /* Fall through */

    case BT_COMPLEX:

      rc = validate_real (kind);

      break;

    case BT_INTEGER:

      rc = validate_integer (kind);

      break;

    case BT_LOGICAL:

      rc = validate_logical (kind);

      break;

    case BT_CHARACTER:

      rc = validate_character (kind);

      break;

    default:

      gfc_internal_error ("gfc_validate_kind(): Got bad type");

    }

  if (rc < 0 && !may_fail)

    gfc_internal_error ("gfc_validate_kind(): Got bad kind");

  return rc;

}

/* Four subroutines of gfc_init_types.  Create type nodes for the given kind.

   Reuse common type nodes where possible.  Recognize if the kind matches up

   with a C type.  This will be used later in determining which routines may

   be scarfed from libm.  */

static tree

gfc_build_int_type (gfc_integer_info *info)

{

  int mode_precision = info->bit_size;

  if (mode_precision == CHAR_TYPE_SIZE)

    info->c_char = 1;

  if (mode_precision == SHORT_TYPE_SIZE)

    info->c_short = 1;

  if (mode_precision == INT_TYPE_SIZE)

    info->c_int = 1;

  if (mode_precision == LONG_TYPE_SIZE)

    info->c_long = 1;

  if (mode_precision == LONG_LONG_TYPE_SIZE)

    info->c_long_long = 1;

  if (TYPE_PRECISION (intQI_type_node) == mode_precision)

    return intQI_type_node;

  if (TYPE_PRECISION (intHI_type_node) == mode_precision)

    return intHI_type_node;

  if (TYPE_PRECISION (intSI_type_node) == mode_precision)

    return intSI_type_node;

  if (TYPE_PRECISION (intDI_type_node) == mode_precision)

    return intDI_type_node;

  if (TYPE_PRECISION (intTI_type_node) == mode_precision)

    return intTI_type_node;

  return make_signed_type (mode_precision);

}

static tree

gfc_build_real_type (gfc_real_info *info)

{

  int mode_precision = info->mode_precision;

  tree new_type;

  if (mode_precision == FLOAT_TYPE_SIZE)

    info->c_float = 1;

  if (mode_precision == DOUBLE_TYPE_SIZE)

    info->c_double = 1;

  if (mode_precision == LONG_DOUBLE_TYPE_SIZE)

    info->c_long_double = 1;

  if (TYPE_PRECISION (float_type_node) == mode_precision)

    return float_type_node;

  if (TYPE_PRECISION (double_type_node) == mode_precision)

    return double_type_node;

  if (TYPE_PRECISION (long_double_type_node) == mode_precision)

    return long_double_type_node;

  new_type = make_node (REAL_TYPE);

  TYPE_PRECISION (new_type) = mode_precision;

  layout_type (new_type);

  return new_type;

}

static tree

gfc_build_complex_type (tree scalar_type)

{

  tree new_type;

  if (scalar_type == NULL)

    return NULL;

  if (scalar_type == float_type_node)

    return complex_float_type_node;

  if (scalar_type == double_type_node)

    return complex_double_type_node;

  if (scalar_type == long_double_type_node)

    return complex_long_double_type_node;

  new_type = make_node (COMPLEX_TYPE);

  TREE_TYPE (new_type) = scalar_type;

  layout_type (new_type);

  return new_type;

}

static tree

gfc_build_logical_type (gfc_logical_info *info)

{

  int bit_size = info->bit_size;

  tree new_type;

  if (bit_size == BOOL_TYPE_SIZE)

    {

      info->c_bool = 1;

      return boolean_type_node;

    }

  new_type = make_unsigned_type (bit_size);

  TREE_SET_CODE (new_type, BOOLEAN_TYPE);

  TYPE_MAX_VALUE (new_type) = build_int_cst (new_type, 1);

  TYPE_PRECISION (new_type) = 1;

  return new_type;

}

#if 0

/* Return the bit size of the C "size_t".  */

static unsigned int

c_size_t_size (void)

{

#ifdef SIZE_TYPE  

  if (strcmp (SIZE_TYPE, "unsigned int") == 0)

    return INT_TYPE_SIZE;

  if (strcmp (SIZE_TYPE, "long unsigned int") == 0)

    return LONG_TYPE_SIZE;

  if (strcmp (SIZE_TYPE, "short unsigned int") == 0)

    return SHORT_TYPE_SIZE;

  gcc_unreachable ();

#else

  return LONG_TYPE_SIZE;

#endif

}

#endif

/* Create the backend type nodes. We map them to their

   equivalent C type, at least for now.  We also give

   names to the types here, and we push them in the

   global binding level context.*/

void

gfc_init_types (void)

{

  char name_buf[16];

  int index;

  tree type;

  unsigned n;

  unsigned HOST_WIDE_INT hi;

  unsigned HOST_WIDE_INT lo;

  /* Create and name the types.  */

#define PUSH_TYPE(name, node) \

  pushdecl (build_decl (TYPE_DECL, get_identifier (name), node))

  for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)

    {

      type = gfc_build_int_type (&gfc_integer_kinds[index]);

      gfc_integer_types[index] = type;

      snprintf (name_buf, sizeof(name_buf), "int%d",

                gfc_integer_kinds[index].kind);

      PUSH_TYPE (name_buf, type);

    }

  for (index = 0; gfc_logical_kinds[index].kind != 0; ++index)

    {

      type = gfc_build_logical_type (&gfc_logical_kinds[index]);

      gfc_logical_types[index] = type;

      snprintf (name_buf, sizeof(name_buf), "logical%d",

                gfc_logical_kinds[index].kind);

      PUSH_TYPE (name_buf, type);

    }

  for (index = 0; gfc_real_kinds[index].kind != 0; index++)

    {

      type = gfc_build_real_type (&gfc_real_kinds[index]);

      gfc_real_types[index] = type;

      snprintf (name_buf, sizeof(name_buf), "real%d",

                gfc_real_kinds[index].kind);

      PUSH_TYPE (name_buf, type);

      type = gfc_build_complex_type (type);

      gfc_complex_types[index] = type;

      snprintf (name_buf, sizeof(name_buf), "complex%d",

                gfc_real_kinds[index].kind);

      PUSH_TYPE (name_buf, type);

    }

  gfc_character1_type_node = build_type_variant (unsigned_char_type_node,

                                                 0, 0);

  PUSH_TYPE ("char", gfc_character1_type_node);

  PUSH_TYPE ("byte", unsigned_char_type_node);

  PUSH_TYPE ("void", void_type_node);

  /* DBX debugging output gets upset if these aren't set.  */

  if (!TYPE_NAME (integer_type_node))

    PUSH_TYPE ("c_integer", integer_type_node);

  if (!TYPE_NAME (char_type_node))

    PUSH_TYPE ("c_char", char_type_node);

#undef PUSH_TYPE

  pvoid_type_node = build_pointer_type (void_type_node);

  ppvoid_type_node = build_pointer_type (pvoid_type_node);

  pchar_type_node = build_pointer_type (gfc_character1_type_node);

  gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);

  /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,

     since this function is called before gfc_init_constants.  */

  gfc_array_range_type

          = build_range_type (gfc_array_index_type,

                              build_int_cst (gfc_array_index_type, 0),

                              NULL_TREE);

  /* The maximum array element size that can be handled is determined

     by the number of bits available to store this field in the array

     descriptor.  */

  n = TYPE_PRECISION (gfc_array_index_type) - GFC_DTYPE_SIZE_SHIFT;

  lo = ~ (unsigned HOST_WIDE_INT) 0;

  if (n > HOST_BITS_PER_WIDE_INT)

    hi = lo >> (2*HOST_BITS_PER_WIDE_INT - n);

  else

    hi = 0, lo >>= HOST_BITS_PER_WIDE_INT - n;

  gfc_max_array_element_size

    = build_int_cst_wide (long_unsigned_type_node, lo, hi);

  size_type_node = gfc_array_index_type;

  boolean_type_node = gfc_get_logical_type (gfc_default_logical_kind);

  boolean_true_node = build_int_cst (boolean_type_node, 1);

  boolean_false_node = build_int_cst (boolean_type_node, 0);

  /* ??? Shouldn't this be based on gfc_index_integer_kind or so?  */

  gfc_charlen_type_node = gfc_get_int_type (4);

}

/* Get the type node for the given type and kind.  */

tree

gfc_get_int_type (int kind)

{

  int index = gfc_validate_kind (BT_INTEGER, kind, true);

  return index < 0 ? 0 : gfc_integer_types[index];

}

tree

gfc_get_real_type (int kind)

{

  int index = gfc_validate_kind (BT_REAL, kind, true);

  return index < 0 ? 0 : gfc_real_types[index];

}

tree

gfc_get_complex_type (int kind)

{

  int index = gfc_validate_kind (BT_COMPLEX, kind, true);

  return index < 0 ? 0 : gfc_complex_types[index];

}

tree

gfc_get_logical_type (int kind)

{

  int index = gfc_validate_kind (BT_LOGICAL, kind, true);

  return index < 0 ? 0 : gfc_logical_types[index];

}

/* Create a character type with the given kind and length.  */

tree

gfc_get_character_type_len (int kind, tree len)

{

  tree bounds, type;

  gfc_validate_kind (BT_CHARACTER, kind, false);

  bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len);

  type = build_array_type (gfc_character1_type_node, bounds);

  TYPE_STRING_FLAG (type) = 1;

  return type;

}

/* Get a type node for a character kind.  */

tree

gfc_get_character_type (int kind, gfc_charlen * cl)

{

  tree len;

  len = (cl == NULL) ? NULL_TREE : cl->backend_decl;

  return gfc_get_character_type_len (kind, len);

}

/* Covert a basic type.  This will be an array for character types.  */

tree

gfc_typenode_for_spec (gfc_typespec * spec)

{

  tree basetype;

  switch (spec->type)

    {

    case BT_UNKNOWN:

      gcc_unreachable ();

    case BT_INTEGER:

      basetype = gfc_get_int_type (spec->kind);

      break;

    case BT_REAL:

      basetype = gfc_get_real_type (spec->kind);

      break;

    case BT_COMPLEX:

      basetype = gfc_get_complex_type (spec->kind);

      break;

    case BT_LOGICAL:

      basetype = gfc_get_logical_type (spec->kind);

      break;

    case BT_CHARACTER:

      basetype = gfc_get_character_type (spec->kind, spec->cl);

      break;

    case BT_DERIVED:

      basetype = gfc_get_derived_type (spec->derived);

      break;

    default:

      gcc_unreachable ();

    }

  return basetype;

}

/* Build an INT_CST for constant expressions, otherwise return NULL_TREE.  */

static tree

gfc_conv_array_bound (gfc_expr * expr)

{

  /* If expr is an integer constant, return that.  */

  if (expr != NULL && expr->expr_type == EXPR_CONSTANT)

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

  /* Otherwise return NULL.  */

  return NULL_TREE;

}

tree

gfc_get_element_type (tree type)

{

  tree element;

  if (GFC_ARRAY_TYPE_P (type))

    {

      if (TREE_CODE (type) == POINTER_TYPE)