trans-types.c

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

/* Backend support for Fortran 95 basic types and derived types.
   Copyright (C) 2002, 2003, 2004, 2005 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-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)
{