cobol: Respect error in cobol.install-common.

[thirdparty/gcc.git] / gcc / fortran / trans-types.cc

/* Backend support for Fortran 95 basic types and derived types.
   Copyright (C) 2002-2025 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 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-types.cc -- gfortran backend types */

#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "target.h"
#include "tree.h"
#include "gfortran.h"
#include "trans.h"
#include "stringpool.h"
#include "fold-const.h"
#include "stor-layout.h"
#include "langhooks.h"	/* For iso-c-bindings.def.  */
#include "toplev.h"	/* For rest_of_decl_compilation.  */
#include "trans-types.h"
#include "trans-const.h"
#include "trans-array.h"
#include "dwarf2out.h"	/* For struct array_descr_info.  */
#include "attribs.h"
#include "alias.h"
\f

#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

/* array of structs so we don't have to worry about xmalloc or free */
CInteropKind_t c_interop_kinds_table[ISOCBINDING_NUMBER];

tree gfc_array_index_type;
tree gfc_array_range_type;
tree gfc_character1_type_node;
tree pvoid_type_node;
tree prvoid_type_node;
tree ppvoid_type_node;
tree pchar_type_node;
static tree pfunc_type_node;

tree logical_type_node;
tree logical_true_node;
tree logical_false_node;
tree gfc_charlen_type_node;

tree gfc_float128_type_node = NULL_TREE;
tree gfc_complex_float128_type_node = NULL_TREE;

bool gfc_real16_is_float128 = false;
bool gfc_real16_use_iec_60559 = false;

static GTY(()) tree gfc_desc_dim_type;
static GTY(()) tree gfc_max_array_element_size;
static GTY(()) tree gfc_array_descriptor_base[2 * (GFC_MAX_DIMENSIONS+1)];
static GTY(()) tree gfc_array_descriptor_base_caf[2 * (GFC_MAX_DIMENSIONS+1)];
static GTY(()) tree gfc_cfi_descriptor_base[2 * (CFI_MAX_RANK + 2)];

/* 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];
gfc_unsigned_info gfc_unsigned_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];
static GTY(()) tree gfc_unsigned_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];

#define MAX_CHARACTER_KINDS 2
gfc_character_info gfc_character_kinds[MAX_CHARACTER_KINDS + 1];
static GTY(()) tree gfc_character_types[MAX_CHARACTER_KINDS + 1];
static GTY(()) tree gfc_pcharacter_types[MAX_CHARACTER_KINDS + 1];

static tree gfc_add_field_to_struct_1 (tree, tree, tree, tree **);

/* 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_default_unsigned_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;
int gfc_c_uint_kind;
int gfc_c_intptr_kind;
int gfc_atomic_int_kind;
int gfc_atomic_logical_kind;

/* The kind size used for record offsets. If the target system supports
   kind=8, this will be set to 8, otherwise it is set to 4.  */
int gfc_intio_kind;

/* The integer kind used to store character lengths.  */
int gfc_charlen_int_kind;

/* Kind of internal integer for storing object sizes.  */
int gfc_size_kind;

/* The size of the numeric storage unit and character storage unit.  */
int gfc_numeric_storage_size;
int gfc_character_storage_size;

static tree dtype_type_node = NULL_TREE;


/* Build the dtype_type_node if necessary.  */
tree get_dtype_type_node (void)
{
  tree field;
  tree dtype_node;
  tree *dtype_chain = NULL;

  if (dtype_type_node == NULL_TREE)
    {
      dtype_node = make_node (RECORD_TYPE);
      TYPE_NAME (dtype_node) = get_identifier ("dtype_type");
      TYPE_NAMELESS (dtype_node) = 1;
      field = gfc_add_field_to_struct_1 (dtype_node,
					 get_identifier ("elem_len"),
					 size_type_node, &dtype_chain);
      suppress_warning (field);
      field = gfc_add_field_to_struct_1 (dtype_node,
					 get_identifier ("version"),
					 integer_type_node, &dtype_chain);
      suppress_warning (field);
      field = gfc_add_field_to_struct_1 (dtype_node,
					 get_identifier ("rank"),
					 signed_char_type_node, &dtype_chain);
      suppress_warning (field);
      field = gfc_add_field_to_struct_1 (dtype_node,
					 get_identifier ("type"),
					 signed_char_type_node, &dtype_chain);
      suppress_warning (field);
      field = gfc_add_field_to_struct_1 (dtype_node,
					 get_identifier ("attribute"),
					 short_integer_type_node, &dtype_chain);
      suppress_warning (field);
      gfc_finish_type (dtype_node);
      TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (dtype_node)) = 1;
      dtype_type_node = dtype_node;
    }
  return dtype_type_node;
}

static int
get_real_kind_from_node (tree type)
{
  int i;

  for (i = 0; gfc_real_kinds[i].kind != 0; i++)
    if (gfc_real_kinds[i].mode_precision == TYPE_PRECISION (type))
      {
	/* On Power, we have three 128-bit scalar floating-point modes
	   and all of their types have 128 bit type precision, so we
	   should check underlying real format details further.  */
#if defined(HAVE_TFmode) && defined(HAVE_IFmode) && defined(HAVE_KFmode)
	if (gfc_real_kinds[i].kind == 16)
	  {
	    machine_mode mode = TYPE_MODE (type);
	    const struct real_format *fmt = REAL_MODE_FORMAT (mode);
	    if (fmt->p != gfc_real_kinds[i].digits)
	      continue;
	  }
#endif
	return gfc_real_kinds[i].kind;
      }

  return -4;
}

static int
get_int_kind_from_node (tree type)
{
  int i;

  if (!type)
    return -2;

  for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
    if (gfc_integer_kinds[i].bit_size == TYPE_PRECISION (type))
      return gfc_integer_kinds[i].kind;

  return -1;
}

static int
get_int_kind_from_name (const char *name)
{
  return get_int_kind_from_node (get_typenode_from_name (name));
}

static int
get_unsigned_kind_from_node (tree type)
{
  int i;

  if (!type)
    return -2;

  for (i = 0; gfc_unsigned_kinds[i].kind != 0; i++)
    if (gfc_unsigned_kinds[i].bit_size == TYPE_PRECISION (type))
      return gfc_unsigned_kinds[i].kind;

  return -1;
}

static int
get_uint_kind_from_name (const char *name)
{
  return get_unsigned_kind_from_node (get_typenode_from_name (name));
}

/* Get the kind number corresponding to an integer of given size,
   following the required return values for ISO_FORTRAN_ENV INT* constants:
   -2 is returned if we support a kind of larger size, -1 otherwise.  */
int
gfc_get_int_kind_from_width_isofortranenv (int size)
{
  int i;

  /* Look for a kind with matching storage size.  */
  for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
    if (gfc_integer_kinds[i].bit_size == size)
      return gfc_integer_kinds[i].kind;

  /* Look for a kind with larger storage size.  */
  for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
    if (gfc_integer_kinds[i].bit_size > size)
      return -2;

  return -1;
}

/* Same, but for unsigned.  */

int
gfc_get_uint_kind_from_width_isofortranenv (int size)
{
  int i;

  /* Look for a kind with matching storage size.  */
  for (i = 0; gfc_unsigned_kinds[i].kind != 0; i++)
    if (gfc_unsigned_kinds[i].bit_size == size)
      return gfc_unsigned_kinds[i].kind;

  /* Look for a kind with larger storage size.  */
  for (i = 0; gfc_unsigned_kinds[i].kind != 0; i++)
    if (gfc_unsigned_kinds[i].bit_size > size)
      return -2;

  return -1;
}


/* Get the kind number corresponding to a real of a given storage size.
   If two real's have the same storage size, then choose the real with
   the largest precision.  If a kind type is unavailable and a real
   exists with wider storage, then return -2; otherwise, return -1.  */

int
gfc_get_real_kind_from_width_isofortranenv (int size)
{
  int digits, i, kind;

  size /= 8;

  kind = -1;
  digits = 0;

  /* Look for a kind with matching storage size.  */
  for (i = 0; gfc_real_kinds[i].kind != 0; i++)
    if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) == size)
      {
	if (gfc_real_kinds[i].digits > digits)
	  {
	    digits = gfc_real_kinds[i].digits;
	    kind = gfc_real_kinds[i].kind;
	  }
      }

  if (kind != -1)
    return kind;

  /* Look for a kind with larger storage size.  */
  for (i = 0; gfc_real_kinds[i].kind != 0; i++)
    if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) > size)
      kind = -2;

  return kind;
}



static int
get_int_kind_from_width (int size)
{
  int i;

  for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
    if (gfc_integer_kinds[i].bit_size == size)
      return gfc_integer_kinds[i].kind;

  return -2;
}

static int
get_int_kind_from_minimal_width (int size)
{
  int i;

  for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
    if (gfc_integer_kinds[i].bit_size >= size)
      return gfc_integer_kinds[i].kind;

  return -2;
}

static int
get_uint_kind_from_width (int size)
{
  int i;

  for (i = 0; gfc_unsigned_kinds[i].kind != 0; i++)
    if (gfc_integer_kinds[i].bit_size == size)
      return gfc_integer_kinds[i].kind;

  return -2;
}


/* Generate the CInteropKind_t objects for the C interoperable
   kinds.  */

void
gfc_init_c_interop_kinds (void)
{
  int i;

  /* init all pointers in the list to NULL */
  for (i = 0; i < ISOCBINDING_NUMBER; i++)
    {
      /* Initialize the name and value fields.  */
      c_interop_kinds_table[i].name[0] = '\0';
      c_interop_kinds_table[i].value = -100;
      c_interop_kinds_table[i].f90_type = BT_UNKNOWN;
    }

#define NAMED_INTCST(a,b,c,d) \
  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
  c_interop_kinds_table[a].f90_type = BT_INTEGER; \
  c_interop_kinds_table[a].value = c;
#define NAMED_UINTCST(a,b,c,d) \
  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
  c_interop_kinds_table[a].f90_type = BT_UNSIGNED; \
  c_interop_kinds_table[a].value = c;
#define NAMED_REALCST(a,b,c,d) \
  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
  c_interop_kinds_table[a].f90_type = BT_REAL; \
  c_interop_kinds_table[a].value = c;
#define NAMED_CMPXCST(a,b,c,d) \
  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
  c_interop_kinds_table[a].f90_type = BT_COMPLEX; \
  c_interop_kinds_table[a].value = c;
#define NAMED_LOGCST(a,b,c) \
  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
  c_interop_kinds_table[a].f90_type = BT_LOGICAL; \
  c_interop_kinds_table[a].value = c;
#define NAMED_CHARKNDCST(a,b,c) \
  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
  c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
  c_interop_kinds_table[a].value = c;
#define NAMED_CHARCST(a,b,c) \
  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
  c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
  c_interop_kinds_table[a].value = c;
#define DERIVED_TYPE(a,b,c) \
  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
  c_interop_kinds_table[a].f90_type = BT_DERIVED; \
  c_interop_kinds_table[a].value = c;
#define NAMED_FUNCTION(a,b,c,d) \
  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
  c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
  c_interop_kinds_table[a].value = c;
#define NAMED_SUBROUTINE(a,b,c,d) \
  strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
  c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
  c_interop_kinds_table[a].value = c;
#include "iso-c-binding.def"
}


/* Query the target to determine which machine modes are available for
   computation.  Choose KIND numbers for them.  */

void
gfc_init_kinds (void)
{
  opt_scalar_int_mode int_mode_iter;
  opt_scalar_float_mode float_mode_iter;
  int i_index, r_index, kind;
  bool saw_i4 = false, saw_i8 = false;
  bool saw_r4 = false, saw_r8 = false, saw_r10 = false, saw_r16 = false;
  scalar_mode r16_mode = QImode;
  scalar_mode composite_mode = QImode;

  i_index = 0;
  FOR_EACH_MODE_IN_CLASS (int_mode_iter, MODE_INT)
    {
      scalar_int_mode mode = int_mode_iter.require ();
      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;

      if (flag_unsigned)
	{
	  gfc_unsigned_kinds[i_index].kind = kind;
	  gfc_unsigned_kinds[i_index].radix = 2;
	  gfc_unsigned_kinds[i_index].digits = bitsize;
	  gfc_unsigned_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 kind used to match GFC_INT_IO in libgfortran.  This is
     used for large file access.  */

  if (saw_i8)
    gfc_intio_kind = 8;
  else
    gfc_intio_kind = 4;

  /* If we do not at least have kind = 4, everything is pointless.  */
  gcc_assert(saw_i4);

  /* Set the maximum integer kind.  Used with at least BOZ constants.  */
  gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind;

  r_index = 0;
  FOR_EACH_MODE_IN_CLASS (float_mode_iter, MODE_FLOAT)
    {
      scalar_float_mode mode = float_mode_iter.require ();
      const struct real_format *fmt = REAL_MODE_FORMAT (mode);
      int kind;

      if (fmt == NULL)
	continue;
      if (!targetm.scalar_mode_supported_p (mode))
	continue;

      if (MODE_COMPOSITE_P (mode)
	  && (GET_MODE_PRECISION (mode) + 7) / 8 == 16)
	composite_mode = mode;

      /* Only let float, double, long double and TFmode go through.
	 Runtime support for others is not provided, so they would be
	 useless.  */
      if (!targetm.libgcc_floating_mode_supported_p (mode))
	continue;
      if (mode != TYPE_MODE (float_type_node)
	    && (mode != TYPE_MODE (double_type_node))
	    && (mode != TYPE_MODE (long_double_type_node))
#if defined(HAVE_TFmode) && defined(ENABLE_LIBQUADMATH_SUPPORT)
	    && (mode != TFmode)
#endif
	   )
	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.

	 TODO: The kind calculation has to be modified to support all
	 three 128-bit floating-point modes on PowerPC as IFmode, KFmode,
	 and TFmode since the following line would all map to kind=16.
	 However, currently only float, double, long double, and TFmode
	 reach this code.
      */

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

      if (kind == 4)
	saw_r4 = true;
      if (kind == 8)
	saw_r8 = true;
      if (kind == 10)
	saw_r10 = true;
      if (kind == 16)
	{
	  saw_r16 = true;
	  r16_mode = mode;
	}

      /* Careful we don't stumble a weird 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].abi_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;
    }

  /* Detect the powerpc64le-linux case with -mabi=ieeelongdouble, where
     the long double type is non-MODE_COMPOSITE_P TFmode but one can use
     -mabi=ibmlongdouble too and get MODE_COMPOSITE_P TFmode with the same
     precision.  For libgfortran calls pretend the IEEE 754 quad TFmode has
     kind 17 rather than 16 and use kind 16 for the IBM extended format
     TFmode.  */
  if (composite_mode != QImode && saw_r16 && !MODE_COMPOSITE_P (r16_mode))
    {
      for (int i = 0; i < r_index; ++i)
	if (gfc_real_kinds[i].kind == 16)
	  {
	    gfc_real_kinds[i].abi_kind = 17;
	    if (flag_building_libgfortran
		&& (TARGET_GLIBC_MAJOR < 2
		    || (TARGET_GLIBC_MAJOR == 2 && TARGET_GLIBC_MINOR < 32)))
	      {
		if (TARGET_GLIBC_MAJOR == 2 && TARGET_GLIBC_MINOR >= 26)
		  {
		    gfc_real16_use_iec_60559 = true;
		    gfc_real_kinds[i].use_iec_60559 = 1;
		  }
		gfc_real16_is_float128 = true;
		gfc_real_kinds[i].c_float128 = 1;
	      }
	  }
    }
  else if ((flag_convert & (GFC_CONVERT_R16_IEEE | GFC_CONVERT_R16_IBM)) != 0)
    gfc_fatal_error ("%<-fconvert=r16_ieee%> or %<-fconvert=r16_ibm%> not "
		     "supported on this architecture");

  /* Choose the default integer kind.  We choose 4 unless the user directs us
     otherwise.  Even if the user specified that the default integer kind is 8,
     the numeric storage size is not 64 bits.  In this case, a warning will be
     issued when NUMERIC_STORAGE_SIZE is used.  Set NUMERIC_STORAGE_SIZE to 32.  */

  gfc_numeric_storage_size = 4 * 8;

  if (flag_default_integer)
    {
      if (!saw_i8)
	gfc_fatal_error ("INTEGER(KIND=8) is not available for "
			 "%<-fdefault-integer-8%> option");

      gfc_default_integer_kind = 8;

    }
  else if (flag_integer4_kind == 8)
    {
      if (!saw_i8)
	gfc_fatal_error ("INTEGER(KIND=8) is not available for "
			 "%<-finteger-4-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;
      gfc_numeric_storage_size = gfc_integer_kinds[i_index - 1].bit_size;
    }

  gfc_default_unsigned_kind = gfc_default_integer_kind;

  /* Choose the default real kind.  Again, we choose 4 when possible.  */
  if (flag_default_real_8)
    {
      if (!saw_r8)
	gfc_fatal_error ("REAL(KIND=8) is not available for "
			 "%<-fdefault-real-8%> option");

      gfc_default_real_kind = 8;
    }
  else if (flag_default_real_10)
  {
    if (!saw_r10)
      gfc_fatal_error ("REAL(KIND=10) is not available for "
			"%<-fdefault-real-10%> option");

    gfc_default_real_kind = 10;
  }
  else if (flag_default_real_16)
  {
    if (!saw_r16)
      gfc_fatal_error ("REAL(KIND=16) is not available for "
			"%<-fdefault-real-16%> option");

    gfc_default_real_kind = 16;
  }
  else if (flag_real4_kind == 8)
  {
    if (!saw_r8)
      gfc_fatal_error ("REAL(KIND=8) is not available for %<-freal-4-real-8%> "
		       "option");

    gfc_default_real_kind = 8;
  }
  else if (flag_real4_kind == 10)
  {
    if (!saw_r10)
      gfc_fatal_error ("REAL(KIND=10) is not available for "
		       "%<-freal-4-real-10%> option");

    gfc_default_real_kind = 10;
  }
  else if (flag_real4_kind == 16)
  {
    if (!saw_r16)
      gfc_fatal_error ("REAL(KIND=16) is not available for "
		       "%<-freal-4-real-16%> option");

    gfc_default_real_kind = 16;
  }
  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 (flag_default_double && saw_r8)
    gfc_default_double_kind = 8;
  else if (flag_default_real_8 || flag_default_real_10 || flag_default_real_16)
    {
      /* Use largest available kind.  */
      if (saw_r16)
	gfc_default_double_kind = 16;
      else if (saw_r10)
	gfc_default_double_kind = 10;
      else if (saw_r8)
	gfc_default_double_kind = 8;
      else
	gfc_default_double_kind = gfc_default_real_kind;
    }
  else if (flag_real8_kind == 4)
    {
      if (!saw_r4)
	gfc_fatal_error ("REAL(KIND=4) is not available for "
			 "%<-freal-8-real-4%> option");

      gfc_default_double_kind = 4;
    }
  else if (flag_real8_kind == 10 )
    {
      if (!saw_r10)
	gfc_fatal_error ("REAL(KIND=10) is not available for "
			 "%<-freal-8-real-10%> option");

      gfc_default_double_kind = 10;
    }
  else if (flag_real8_kind == 16 )
    {
      if (!saw_r16)
	gfc_fatal_error ("REAL(KIND=10) is not available for "
			 "%<-freal-8-real-16%> option");

      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;

  /* We only have two character kinds: ASCII and UCS-4.
     ASCII corresponds to a 8-bit integer type, if one is available.
     UCS-4 corresponds to a 32-bit integer type, if one is available.  */
  i_index = 0;
  if ((kind = get_int_kind_from_width (8)) > 0)
    {
      gfc_character_kinds[i_index].kind = kind;
      gfc_character_kinds[i_index].bit_size = 8;
      gfc_character_kinds[i_index].name = "ascii";
      i_index++;
    }
  if ((kind = get_int_kind_from_width (32)) > 0)
    {
      gfc_character_kinds[i_index].kind = kind;
      gfc_character_kinds[i_index].bit_size = 32;
      gfc_character_kinds[i_index].name = "iso_10646";
      i_index++;
    }

  /* Choose the smallest integer kind for our default character.  */
  gfc_default_character_kind = gfc_character_kinds[0].kind;
  gfc_character_storage_size = gfc_default_character_kind * 8;

  gfc_index_integer_kind = get_int_kind_from_name (PTRDIFF_TYPE);

  /* Pick a kind the same size as the C "int" type.  */
  gfc_c_int_kind = INT_TYPE_SIZE / 8;

  /* UNSIGNED has the same as INT.  */
  gfc_c_uint_kind = gfc_c_int_kind;

  /* Choose atomic kinds to match C's int.  */
  gfc_atomic_int_kind = gfc_c_int_kind;
  gfc_atomic_logical_kind = gfc_c_int_kind;

  gfc_c_intptr_kind = POINTER_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_unsigned (int kind)
{
  int i;

  for (i = 0; gfc_unsigned_kinds[i].kind != 0; i++)
    if (gfc_unsigned_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)
{
  int i;

  for (i = 0; gfc_character_kinds[i].kind; i++)
    if (gfc_character_kinds[i].kind == kind)
      return i;

  return -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_UNSIGNED:
      rc = validate_unsigned (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);
}

tree
gfc_build_uint_type (int size)
{
  if (size == CHAR_TYPE_SIZE)
    return unsigned_char_type_node;
  if (size == SHORT_TYPE_SIZE)
    return short_unsigned_type_node;
  if (size == INT_TYPE_SIZE)
    return unsigned_type_node;
  if (size == LONG_TYPE_SIZE)
    return long_unsigned_type_node;
  if (size == LONG_LONG_TYPE_SIZE)
    return long_long_unsigned_type_node;

  return make_unsigned_type (size);
}

static tree
gfc_build_unsigned_type (gfc_unsigned_info *info)
{
  int mode_precision = info->bit_size;

  if (mode_precision == CHAR_TYPE_SIZE)
    info->c_unsigned_char = 1;
  if (mode_precision == SHORT_TYPE_SIZE)
    info->c_unsigned_short = 1;
  if (mode_precision == INT_TYPE_SIZE)
    info->c_unsigned_int = 1;
  if (mode_precision == LONG_TYPE_SIZE)
    info->c_unsigned_long = 1;
  if (mode_precision == LONG_LONG_TYPE_SIZE)
    info->c_unsigned_long_long = 1;

  return gfc_build_uint_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 == TYPE_PRECISION (float_type_node))
    info->c_float = 1;
  if (mode_precision == TYPE_PRECISION (double_type_node))
    info->c_double = 1;
  if (mode_precision == TYPE_PRECISION (long_double_type_node)
      && !info->c_float128)
    info->c_long_double = 1;
  if (mode_precision != TYPE_PRECISION (long_double_type_node)
      && mode_precision == 128)
    {
      /* TODO: see PR101835.  */
      info->c_float128 = 1;
      gfc_real16_is_float128 = true;
      if (TARGET_GLIBC_MAJOR > 2
	  || (TARGET_GLIBC_MAJOR == 2 && TARGET_GLIBC_MINOR >= 26))
	{
	  info->use_iec_60559 = 1;
	  gfc_real16_use_iec_60559 = true;
	}
    }

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


/* 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[26];
  int index;
  tree type;
  unsigned n;

  /* Create and name the types.  */
#define PUSH_TYPE(name, node) \
  pushdecl (build_decl (input_location, \
			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]);
      /* Ensure integer(kind=1) doesn't have TYPE_STRING_FLAG set.  */
      if (TYPE_STRING_FLAG (type))
	type = make_signed_type (gfc_integer_kinds[index].bit_size);
      gfc_integer_types[index] = type;
      snprintf (name_buf, sizeof(name_buf), "integer(kind=%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(kind=%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(kind=%d)",
		gfc_real_kinds[index].kind);
      PUSH_TYPE (name_buf, type);

      if (gfc_real_kinds[index].c_float128)
	gfc_float128_type_node = type;

      type = gfc_build_complex_type (type);
      gfc_complex_types[index] = type;
      snprintf (name_buf, sizeof(name_buf), "complex(kind=%d)",
		gfc_real_kinds[index].kind);
      PUSH_TYPE (name_buf, type);

      if (gfc_real_kinds[index].c_float128)
	gfc_complex_float128_type_node = type;
    }

  for (index = 0; gfc_character_kinds[index].kind != 0; ++index)
    {
      type = gfc_build_uint_type (gfc_character_kinds[index].bit_size);
      type = build_qualified_type (type, TYPE_UNQUALIFIED);
      snprintf (name_buf, sizeof(name_buf), "character(kind=%d)",
		gfc_character_kinds[index].kind);
      PUSH_TYPE (name_buf, type);
      gfc_character_types[index] = type;
      gfc_pcharacter_types[index] = build_pointer_type (type);
    }
  gfc_character1_type_node = gfc_character_types[0];

  if (flag_unsigned)
    {
      for (index = 0; gfc_unsigned_kinds[index].kind != 0;++index)
	{
	  int index_char = -1;
	  for (int i=0; gfc_character_kinds[i].kind != 0; i++)
	    {
	      if (gfc_character_kinds[i].bit_size
		  == gfc_unsigned_kinds[index].bit_size)
		{
		  index_char = i;
		  break;
		}
	    }
	  if (index_char > -1)
	    {
	      type = gfc_character_types[index_char];
	      if (TYPE_STRING_FLAG (type))
		{
		  type = build_distinct_type_copy (type);
		  TYPE_CANONICAL (type)
		    = TYPE_CANONICAL (gfc_character_types[index_char]);
		}
	      else
		type = build_variant_type_copy (type);
	      TYPE_NAME (type) = NULL_TREE;
	      TYPE_STRING_FLAG (type) = 0;
	    }
	  else
	    type = gfc_build_unsigned_type (&gfc_unsigned_kinds[index]);
	  gfc_unsigned_types[index] = type;
	  snprintf (name_buf, sizeof(name_buf), "unsigned(kind=%d)",
		    gfc_integer_kinds[index].kind);
	  PUSH_TYPE (name_buf, type);
	}
    }

  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);
  prvoid_type_node = build_qualified_type (pvoid_type_node, TYPE_QUAL_RESTRICT);
  ppvoid_type_node = build_pointer_type (pvoid_type_node);
  pchar_type_node = build_pointer_type (gfc_character1_type_node);
  pfunc_type_node
    = build_pointer_type (build_function_type_list (void_type_node, NULL_TREE));

  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 (size_type_node);
  gfc_max_array_element_size
    = wide_int_to_tree (size_type_node,
			wi::mask (n, UNSIGNED,
				  TYPE_PRECISION (size_type_node)));

  logical_type_node = gfc_get_logical_type (gfc_default_logical_kind);
  logical_true_node = build_int_cst (logical_type_node, 1);
  logical_false_node = build_int_cst (logical_type_node, 0);

  /* Character lengths are of type size_t, except signed.  */
  gfc_charlen_int_kind = get_int_kind_from_node (size_type_node);
  gfc_charlen_type_node = gfc_get_int_type (gfc_charlen_int_kind);

  /* Fortran kind number of size_type_node (size_t). This is used for
     the _size member in vtables.  */
  gfc_size_kind = get_int_kind_from_node (size_type_node);
}

/* 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_unsigned_type (int kind)
{
  int index = gfc_validate_kind (BT_UNSIGNED, kind, true);
  return index < 0 ? 0 : gfc_unsigned_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];
}

tree
gfc_get_char_type (int kind)
{
  int index = gfc_validate_kind (BT_CHARACTER, kind, true);
  return index < 0 ? 0 : gfc_character_types[index];
}

tree
gfc_get_pchar_type (int kind)
{
  int index = gfc_validate_kind (BT_CHARACTER, kind, true);
  return index < 0 ? 0 : gfc_pcharacter_types[index];
}

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

tree
gfc_get_character_type_len_for_eltype (tree eltype, tree len)
{
  tree bounds, type;

  bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len);
  type = build_array_type (eltype, bounds);
  TYPE_STRING_FLAG (type) = 1;

  return type;
}

tree
gfc_get_character_type_len (int kind, tree len)
{
  gfc_validate_kind (BT_CHARACTER, kind, false);
  return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind), len);
}


/* 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;
  if (len && POINTER_TYPE_P (TREE_TYPE (len)))
    len = build_fold_indirect_ref (len);

  return gfc_get_character_type_len (kind, len);
}
\f
/* Convert a basic type.  This will be an array for character types.  */

tree
gfc_typenode_for_spec (gfc_typespec * spec, int codim)
{
  tree basetype;

  switch (spec->type)
    {
    case BT_UNKNOWN:
      gcc_unreachable ();

    case BT_INTEGER:
      /* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol
         has been resolved.  This is done so we can convert C_PTR and
         C_FUNPTR to simple variables that get translated to (void *).  */
      if (spec->f90_type == BT_VOID)
	{
	  if (spec->u.derived
	      && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR)
	    basetype = ptr_type_node;
	  else
	    basetype = pfunc_type_node;
	}
      else
        basetype = gfc_get_int_type (spec->kind);
      break;

    case BT_UNSIGNED:
      basetype = gfc_get_unsigned_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->u.cl);
      break;

    case BT_HOLLERITH:
      /* Since this cannot be used, return a length one character.  */
      basetype = gfc_get_character_type_len (gfc_default_character_kind,
					     gfc_index_one_node);
      break;

    case BT_UNION:
      basetype = gfc_get_union_type (spec->u.derived);
      break;

    case BT_DERIVED:
    case BT_CLASS:
      basetype = gfc_get_derived_type (spec->u.derived, codim);

      if (spec->type == BT_CLASS)
	GFC_CLASS_TYPE_P (basetype) = 1;

      /* If we're dealing with either C_PTR or C_FUNPTR, we modified the
         type and kind to fit a (void *) and the basetype returned was a
         ptr_type_node.  We need to pass up this new information to the
         symbol that was declared of type C_PTR or C_FUNPTR.  */
      if (spec->u.derived->ts.f90_type == BT_VOID)
        {
          spec->type = BT_INTEGER;
          spec->kind = gfc_index_integer_kind;
	  spec->f90_type = BT_VOID;
	  spec->is_c_interop = 1;  /* Mark as escaping later.  */
        }
      break;
    case BT_VOID:
    case BT_ASSUMED:
      /* This is for the second arg to c_f_pointer and c_f_procpointer
         of the iso_c_binding module, to accept any ptr type.  */
      basetype = ptr_type_node;
      if (spec->f90_type == BT_VOID)
	{
	  if (spec->u.derived
	      && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR)
	    basetype = ptr_type_node;
	  else
	    basetype = pfunc_type_node;
	}
       break;
    case BT_PROCEDURE:
      basetype = pfunc_type_node;
      break;
    default:
      gcc_unreachable ();
    }
  return basetype;
}
\f
/* 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;
}
\f
/* Return the type of an element of the array.  Note that scalar coarrays
   are special.  In particular, for GFC_ARRAY_TYPE_P, the original argument
   (with POINTER_TYPE stripped) is returned.  */

tree
gfc_get_element_type (tree type)
{
  tree element;

  if (GFC_ARRAY_TYPE_P (type))
    {
      if (TREE_CODE (type) == POINTER_TYPE)
        type = TREE_TYPE (type);
      if (GFC_TYPE_ARRAY_RANK (type) == 0)
	{
	  gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0);
	  element = type;
	}
      else
	{
	  gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
	  element = TREE_TYPE (type);
	}
    }
  else
    {
      gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
      element = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);

      gcc_assert (TREE_CODE (element) == POINTER_TYPE);
      element = TREE_TYPE (element);

      /* For arrays, which are not scalar coarrays.  */
      if (TREE_CODE (element) == ARRAY_TYPE && !TYPE_STRING_FLAG (element))
	element = TREE_TYPE (element);
    }

  return element;
}
\f
/* Build an array.  This function is called from gfc_sym_type().
   Actually returns array descriptor type.

   Format of array descriptors is as follows:

    struct gfc_array_descriptor
    {
      array *data;
      index offset;
      struct dtype_type dtype;
      struct descriptor_dimension dimension[N_DIM];
    }

    struct dtype_type
    {
      size_t elem_len;
      int version;
      signed char rank;
      signed char type;
      signed short attribute;
    }

    struct descriptor_dimension
    {
      index stride;
      index lbound;
      index ubound;
    }

   Translation code should use gfc_conv_descriptor_* rather than
   accessing the descriptor directly.  Any changes to the array
   descriptor type will require changes in gfc_conv_descriptor_* and
   gfc_build_array_initializer.

   This is represented internally as a RECORD_TYPE. The index nodes
   are gfc_array_index_type and the data node is a pointer to the
   data.  See below for the handling of character types.

   I originally used nested ARRAY_TYPE nodes to represent arrays, but
   this generated poor code for assumed/deferred size arrays.  These
   require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part
   of the GENERIC grammar.  Also, there is no way to explicitly set
   the array stride, so all data must be packed(1).  I've tried to
   mark all the functions which would require modification with a GCC
   ARRAYS comment.

   The data component points to the first element in the array.  The
   offset field is the position of the origin of the array (i.e. element
   (0, 0 ...)).  This may be outside the bounds of the array.

   An element is accessed by
    data[offset + index0*stride0 + index1*stride1 + index2*stride2]
   This gives good performance as the computation does not involve the
   bounds of the array.  For packed arrays, this is optimized further
   by substituting the known strides.

   This system has one problem: all array bounds must be within 2^31
   elements of the origin (2^63 on 64-bit machines).  For example
    integer, dimension (80000:90000, 80000:90000, 2) :: array
   may not work properly on 32-bit machines because 80000*80000 >
   2^31, so the calculation for stride2 would overflow.  This may
   still work, but I haven't checked, and it relies on the overflow
   doing the right thing.

   The way to fix this problem is to access elements as follows:
    data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
   Obviously this is much slower.  I will make this a compile time
   option, something like -fsmall-array-offsets.  Mixing code compiled
   with and without this switch will work.

   (1) This can be worked around by modifying the upper bound of the
   previous dimension.  This requires extra fields in the descriptor
   (both real_ubound and fake_ubound).  */


/* Returns true if the array sym does not require a descriptor.  */

bool
gfc_is_nodesc_array (gfc_symbol * sym)
{
  symbol_attribute *array_attr;
  gfc_array_spec *as;
  bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);

  array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
  as = is_classarray ? CLASS_DATA (sym)->as : sym->as;

  gcc_assert (array_attr->dimension || array_attr->codimension);

  /* We only want local arrays.  */
  if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
      || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
      || array_attr->allocatable)
    return 0;

  /* We want a descriptor for associate-name arrays that do not have an
	 explicitly known shape already.  */
  if (sym->assoc && as->type != AS_EXPLICIT)
    return 0;

  /* The dummy is stored in sym and not in the component.  */
  if (sym->attr.dummy)
    return as->type != AS_ASSUMED_SHAPE
	&& as->type != AS_ASSUMED_RANK;

  if (sym->attr.result || sym->attr.function)
    return 0;

  gcc_assert (as->type == AS_EXPLICIT || as->cp_was_assumed);

  return 1;
}


/* Create an array descriptor type.  */

static tree
gfc_build_array_type (tree type, gfc_array_spec * as,
		      enum gfc_array_kind akind, bool restricted,
		      bool contiguous, int codim)
{
  tree lbound[GFC_MAX_DIMENSIONS];
  tree ubound[GFC_MAX_DIMENSIONS];
  int n, corank;

  /* Assumed-shape arrays do not have codimension information stored in the
     descriptor.  */
  corank = MAX (as->corank, codim);
  if (as->type == AS_ASSUMED_SHAPE ||
      (as->type == AS_ASSUMED_RANK && akind == GFC_ARRAY_ALLOCATABLE))
    corank = codim;

  if (as->type == AS_ASSUMED_RANK)
    for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
      {
	lbound[n] = NULL_TREE;
	ubound[n] = NULL_TREE;
      }

  for (n = 0; n < as->rank; n++)
    {
      /* Create expressions for the known bounds of the array.  */
      if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL)
        lbound[n] = gfc_index_one_node;
      else
        lbound[n] = gfc_conv_array_bound (as->lower[n]);
      ubound[n] = gfc_conv_array_bound (as->upper[n]);
    }

  for (n = as->rank; n < as->rank + corank; n++)
    {
      if (as->type != AS_DEFERRED && as->lower[n] == NULL)
        lbound[n] = gfc_index_one_node;
      else
        lbound[n] = gfc_conv_array_bound (as->lower[n]);

      if (n < as->rank + corank - 1)
	ubound[n] = gfc_conv_array_bound (as->upper[n]);
    }

  if (as->type == AS_ASSUMED_SHAPE)
    akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT
		       : GFC_ARRAY_ASSUMED_SHAPE;
  else if (as->type == AS_ASSUMED_RANK)
    {
      if (akind == GFC_ARRAY_ALLOCATABLE)
	akind = GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE;
      else if (akind == GFC_ARRAY_POINTER || akind == GFC_ARRAY_POINTER_CONT)
	akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_POINTER_CONT
			   : GFC_ARRAY_ASSUMED_RANK_POINTER;
      else
	akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_CONT
			   : GFC_ARRAY_ASSUMED_RANK;
    }
  return gfc_get_array_type_bounds (type, as->rank == -1
					  ? GFC_MAX_DIMENSIONS : as->rank,
				    corank, lbound, ubound, 0, akind,
				    restricted);
}
\f
/* Returns the struct descriptor_dimension type.  */

static tree
gfc_get_desc_dim_type (void)
{
  tree type;
  tree decl, *chain = NULL;

  if (gfc_desc_dim_type)
    return gfc_desc_dim_type;

  /* Build the type node.  */
  type = make_node (RECORD_TYPE);

  TYPE_NAME (type) = get_identifier ("descriptor_dimension");
  TYPE_PACKED (type) = 1;

  /* Consists of the stride, lbound and ubound members.  */
  decl = gfc_add_field_to_struct_1 (type,
				    get_identifier ("stride"),
				    gfc_array_index_type, &chain);
  suppress_warning (decl);

  decl = gfc_add_field_to_struct_1 (type,
				    get_identifier ("lbound"),
				    gfc_array_index_type, &chain);
  suppress_warning (decl);

  decl = gfc_add_field_to_struct_1 (type,
				    get_identifier ("ubound"),
				    gfc_array_index_type, &chain);
  suppress_warning (decl);

  /* Finish off the type.  */
  gfc_finish_type (type);
  TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;

  gfc_desc_dim_type = type;
  return type;
}


/* Return the DTYPE for an array.  This describes the type and type parameters
   of the array.  */
/* TODO: Only call this when the value is actually used, and make all the
   unknown cases abort.  */

tree
gfc_get_dtype_rank_type (int rank, tree etype)
{
  tree ptype;
  tree size;
  int n;
  tree tmp;
  tree dtype;
  tree field;
  vec<constructor_elt, va_gc> *v = NULL;

  ptype = etype;
  while (TREE_CODE (etype) == POINTER_TYPE
	 || TREE_CODE (etype) == ARRAY_TYPE)
    {
      ptype = etype;
      etype = TREE_TYPE (etype);
    }

  gcc_assert (etype);

  switch (TREE_CODE (etype))
    {
    case INTEGER_TYPE:
      if (TREE_CODE (ptype) == ARRAY_TYPE
	  && TYPE_STRING_FLAG (ptype))
	n = BT_CHARACTER;
      else
	{
	  if (TYPE_UNSIGNED (etype))
	    n = BT_UNSIGNED;
	  else
	    n = BT_INTEGER;
	}
      break;

    case BOOLEAN_TYPE:
      n = BT_LOGICAL;
      break;

    case REAL_TYPE:
      n = BT_REAL;
      break;

    case COMPLEX_TYPE:
      n = BT_COMPLEX;
      break;

    case RECORD_TYPE:
      if (GFC_CLASS_TYPE_P (etype))
	n = BT_CLASS;
      else
	n = BT_DERIVED;
      break;

    case FUNCTION_TYPE:
    case VOID_TYPE:
      n = BT_VOID;
      break;

    default:
      /* TODO: Don't do dtype for temporary descriptorless arrays.  */
      /* We can encounter strange array types for temporary arrays.  */
      gcc_unreachable ();
    }

  switch (n)
    {
    case BT_CHARACTER:
      gcc_assert (TREE_CODE (ptype) == ARRAY_TYPE);
      size = gfc_get_character_len_in_bytes (ptype);
      break;
    case BT_VOID:
      gcc_assert (TREE_CODE (ptype) == POINTER_TYPE);
      size = size_in_bytes (ptype);
      break;
    default:
      size = size_in_bytes (etype);
      break;
    }

  gcc_assert (size);

  STRIP_NOPS (size);
  size = fold_convert (size_type_node, size);
  tmp = get_dtype_type_node ();
  field = gfc_advance_chain (TYPE_FIELDS (tmp),
			     GFC_DTYPE_ELEM_LEN);
  CONSTRUCTOR_APPEND_ELT (v, field,
			  fold_convert (TREE_TYPE (field), size));
  field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
			     GFC_DTYPE_VERSION);
  CONSTRUCTOR_APPEND_ELT (v, field,
			  build_zero_cst (TREE_TYPE (field)));

  field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
			     GFC_DTYPE_RANK);
  if (rank >= 0)
    CONSTRUCTOR_APPEND_ELT (v, field,
			    build_int_cst (TREE_TYPE (field), rank));

  field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
			     GFC_DTYPE_TYPE);
  CONSTRUCTOR_APPEND_ELT (v, field,
			  build_int_cst (TREE_TYPE (field), n));

  dtype = build_constructor (tmp, v);

  return dtype;
}


tree
gfc_get_dtype (tree type, int * rank)
{
  tree dtype;
  tree etype;
  int irnk;

  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));

  irnk = (rank) ? (*rank) : (GFC_TYPE_ARRAY_RANK (type));
  etype = gfc_get_element_type (type);
  dtype = gfc_get_dtype_rank_type (irnk, etype);

  GFC_TYPE_ARRAY_DTYPE (type) = dtype;
  return dtype;
}


/* Build an array type for use without a descriptor, packed according
   to the value of PACKED.  */

tree
gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
			   bool restricted)
{
  tree range;
  tree type;
  tree tmp;
  int n;
  int known_stride;
  int known_offset;
  mpz_t offset;
  mpz_t stride;
  mpz_t delta;
  gfc_expr *expr;

  mpz_init_set_ui (offset, 0);
  mpz_init_set_ui (stride, 1);
  mpz_init (delta);

  /* We don't use build_array_type because this does not include
     lang-specific information (i.e. the bounds of the array) when checking
     for duplicates.  */
  if (as->rank)
    type = make_node (ARRAY_TYPE);
  else
    type = build_variant_type_copy (etype);

  GFC_ARRAY_TYPE_P (type) = 1;
  TYPE_LANG_SPECIFIC (type) = ggc_cleared_alloc<struct lang_type> ();

  known_stride = (packed != PACKED_NO);
  known_offset = 1;
  for (n = 0; n < as->rank; n++)
    {
      /* Fill in the stride and bound components of the type.  */
      if (known_stride)
	tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
      else
        tmp = NULL_TREE;
      GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;

      expr = as->lower[n];
      if (expr && expr->expr_type == EXPR_CONSTANT)
        {
          tmp = gfc_conv_mpz_to_tree (expr->value.integer,
				      gfc_index_integer_kind);
        }
      else
        {
          known_stride = 0;
          tmp = NULL_TREE;
        }
      GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;

      if (known_stride)
	{
          /* Calculate the offset.  */
          mpz_mul (delta, stride, as->lower[n]->value.integer);
          mpz_sub (offset, offset, delta);
	}
      else
	known_offset = 0;

      expr = as->upper[n];
      if (expr && expr->expr_type == EXPR_CONSTANT)
        {
	  tmp = gfc_conv_mpz_to_tree (expr->value.integer,
			          gfc_index_integer_kind);
        }
      else
        {
          tmp = NULL_TREE;
          known_stride = 0;
        }
      GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;

      if (known_stride)
        {
          /* Calculate the stride.  */
          mpz_sub (delta, as->upper[n]->value.integer,
	           as->lower[n]->value.integer);
          mpz_add_ui (delta, delta, 1);
          mpz_mul (stride, stride, delta);
        }

      /* Only the first stride is known for partial packed arrays.  */
      if (packed == PACKED_NO || packed == PACKED_PARTIAL)
        known_stride = 0;
    }
  for (n = as->rank; n < as->rank + as->corank; n++)
    {
      expr = as->lower[n];
      if (expr && expr->expr_type == EXPR_CONSTANT)
	tmp = gfc_conv_mpz_to_tree (expr->value.integer,
				    gfc_index_integer_kind);
      else
	tmp = NULL_TREE;
      GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;

      expr = as->upper[n];
      if (expr && expr->expr_type == EXPR_CONSTANT)
	tmp = gfc_conv_mpz_to_tree (expr->value.integer,
				    gfc_index_integer_kind);
      else
 	tmp = NULL_TREE;
      if (n < as->rank + as->corank - 1)
	GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
    }

  if (known_offset)
    {
      GFC_TYPE_ARRAY_OFFSET (type) =
        gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
    }
  else
    GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;

  if (known_stride)
    {
      GFC_TYPE_ARRAY_SIZE (type) =
        gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
    }
  else
    GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;

  GFC_TYPE_ARRAY_RANK (type) = as->rank;
  GFC_TYPE_ARRAY_CORANK (type) = as->corank;
  GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
  range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
			    NULL_TREE);
  /* TODO: use main type if it is unbounded.  */
  GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
    build_pointer_type (build_array_type (etype, range));
  if (restricted)
    GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
      build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type),
			    TYPE_QUAL_RESTRICT);

  if (as->rank == 0)
    {
      if (packed != PACKED_STATIC  || flag_coarray == GFC_FCOARRAY_LIB)
	{
	  type = build_pointer_type (type);

	  if (restricted)
	    type = build_qualified_type (type, TYPE_QUAL_RESTRICT);

	  GFC_ARRAY_TYPE_P (type) = 1;
	  TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
	}

      goto array_type_done;
    }

  if (known_stride)
    {
      mpz_sub_ui (stride, stride, 1);
      range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
    }
  else
    range = NULL_TREE;

  range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
  TYPE_DOMAIN (type) = range;

  build_pointer_type (etype);
  TREE_TYPE (type) = etype;

  layout_type (type);

  /* Represent packed arrays as multi-dimensional if they have rank >
     1 and with proper bounds, instead of flat arrays.  This makes for
     better debug info.  */
  if (known_offset)
    {
      tree gtype = etype, rtype, type_decl;

      for (n = as->rank - 1; n >= 0; n--)
	{
	  rtype = build_range_type (gfc_array_index_type,
				    GFC_TYPE_ARRAY_LBOUND (type, n),
				    GFC_TYPE_ARRAY_UBOUND (type, n));
	  gtype = build_array_type (gtype, rtype);
	}
      TYPE_NAME (type) = type_decl = build_decl (input_location,
						 TYPE_DECL, NULL, gtype);
      DECL_ORIGINAL_TYPE (type_decl) = gtype;
    }

  if (packed != PACKED_STATIC || !known_stride
      || (as->corank && flag_coarray == GFC_FCOARRAY_LIB))
    {
      /* For dummy arrays and automatic (heap allocated) arrays we
	 want a pointer to the array.  */
      type = build_pointer_type (type);
      if (restricted)
	type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
      GFC_ARRAY_TYPE_P (type) = 1;
      TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
    }

array_type_done:
  mpz_clear (offset);
  mpz_clear (stride);
  mpz_clear (delta);

  return type;
}


/* Return or create the base type for an array descriptor.  */

static tree
gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
{
  tree fat_type, decl, arraytype, *chain = NULL;
  char name[16 + 2*GFC_RANK_DIGITS + 1 + 1];
  int idx;

  /* Assumed-rank array.  */
  if (dimen == -1)
    dimen = GFC_MAX_DIMENSIONS;

  idx = 2 * (codimen + dimen) + restricted;

  gcc_assert (codimen + dimen >= 0 && codimen + dimen <= GFC_MAX_DIMENSIONS);

  if (flag_coarray == GFC_FCOARRAY_LIB && codimen)
    {
      if (gfc_array_descriptor_base_caf[idx])
	return gfc_array_descriptor_base_caf[idx];
    }
  else if (gfc_array_descriptor_base[idx])
    return gfc_array_descriptor_base[idx];

  /* Build the type node.  */
  fat_type = make_node (RECORD_TYPE);

  sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen + codimen);
  TYPE_NAME (fat_type) = get_identifier (name);
  TYPE_NAMELESS (fat_type) = 1;

  /* Add the data member as the first element of the descriptor.  */
  gfc_add_field_to_struct_1 (fat_type,
			     get_identifier ("data"),
			     (restricted
			      ? prvoid_type_node
			      : ptr_type_node), &chain);

  /* Add the base component.  */
  decl = gfc_add_field_to_struct_1 (fat_type,
				    get_identifier ("offset"),
				    gfc_array_index_type, &chain);
  suppress_warning (decl);

  /* Add the dtype component.  */
  decl = gfc_add_field_to_struct_1 (fat_type,
				    get_identifier ("dtype"),
				    get_dtype_type_node (), &chain);
  suppress_warning (decl);

  /* Add the span component.  */
  decl = gfc_add_field_to_struct_1 (fat_type,
				    get_identifier ("span"),
				    gfc_array_index_type, &chain);
  suppress_warning (decl);

  /* Build the array type for the stride and bound components.  */
  if (dimen + codimen > 0)
    {
      arraytype =
	build_array_type (gfc_get_desc_dim_type (),
			  build_range_type (gfc_array_index_type,
					    gfc_index_zero_node,
					    gfc_rank_cst[codimen + dimen - 1]));

      decl = gfc_add_field_to_struct_1 (fat_type, get_identifier ("dim"),
					arraytype, &chain);
      suppress_warning (decl);
    }

  if (flag_coarray == GFC_FCOARRAY_LIB)
    {
      decl = gfc_add_field_to_struct_1 (fat_type,
					get_identifier ("token"),
					prvoid_type_node, &chain);
      suppress_warning (decl);
    }

  /* Finish off the type.  */
  gfc_finish_type (fat_type);
  TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1;

  if (flag_coarray == GFC_FCOARRAY_LIB && codimen)
    gfc_array_descriptor_base_caf[idx] = fat_type;
  else
    gfc_array_descriptor_base[idx] = fat_type;

  return fat_type;
}


/* Build an array (descriptor) type with given bounds.  */

tree
gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
			   tree * ubound, int packed,
			   enum gfc_array_kind akind, bool restricted)
{
  char name[8 + 2*GFC_RANK_DIGITS + 1 + GFC_MAX_SYMBOL_LEN];
  tree fat_type, base_type, arraytype, lower, upper, stride, tmp, rtype;
  const char *type_name;
  int n;

  base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted);
  fat_type = build_distinct_type_copy (base_type);
  /* Unshare TYPE_FIELDs.  */
  for (tree *tp = &TYPE_FIELDS (fat_type); *tp; tp = &DECL_CHAIN (*tp))
    {
      tree next = DECL_CHAIN (*tp);
      *tp = copy_node (*tp);
      DECL_CONTEXT (*tp) = fat_type;
      DECL_CHAIN (*tp) = next;
    }
  /* Make sure that nontarget and target array type have the same canonical
     type (and same stub decl for debug info).  */
  base_type = gfc_get_array_descriptor_base (dimen, codimen, false);
  TYPE_CANONICAL (fat_type) = base_type;
  TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type);
  /* Arrays of unknown type must alias with all array descriptors.  */
  TYPE_TYPELESS_STORAGE (base_type) = 1;
  TYPE_TYPELESS_STORAGE (fat_type) = 1;
  gcc_checking_assert (!get_alias_set (base_type) && !get_alias_set (fat_type));

  tmp = etype;
  if (TREE_CODE (tmp) == ARRAY_TYPE
      && TYPE_STRING_FLAG (tmp))
    tmp = TREE_TYPE (etype);
  tmp = TYPE_NAME (tmp);
  if (tmp && TREE_CODE (tmp) == TYPE_DECL)
    tmp = DECL_NAME (tmp);
  if (tmp)
    type_name = IDENTIFIER_POINTER (tmp);
  else
    type_name = "unknown";
  sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen + codimen,
	   GFC_MAX_SYMBOL_LEN, type_name);
  TYPE_NAME (fat_type) = get_identifier (name);
  TYPE_NAMELESS (fat_type) = 1;

  GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
  TYPE_LANG_SPECIFIC (fat_type) = ggc_cleared_alloc<struct lang_type> ();

  GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
  GFC_TYPE_ARRAY_CORANK (fat_type) = codimen;
  GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
  GFC_TYPE_ARRAY_AKIND (fat_type) = akind;

  /* Build an array descriptor record type.  */
  if (packed != 0)
    stride = gfc_index_one_node;
  else
    stride = NULL_TREE;
  for (n = 0; n < dimen + codimen; n++)
    {
      if (n < dimen)
	GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;

      if (lbound)
	lower = lbound[n];
      else
	lower = NULL_TREE;

      if (lower != NULL_TREE)
	{
	  if (INTEGER_CST_P (lower))
	    GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
	  else
	    lower = NULL_TREE;
	}

      if (codimen && n == dimen + codimen - 1)
	break;

      upper = ubound[n];
      if (upper != NULL_TREE)
	{
	  if (INTEGER_CST_P (upper))
	    GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
	  else
	    upper = NULL_TREE;
	}

      if (n >= dimen)
	continue;

      if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
	{
	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
				 gfc_array_index_type, upper, lower);
	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
				 gfc_array_index_type, tmp,
				 gfc_index_one_node);
	  stride = fold_build2_loc (input_location, MULT_EXPR,
				    gfc_array_index_type, tmp, stride);
	  /* Check the folding worked.  */
	  gcc_assert (INTEGER_CST_P (stride));
	}
      else
	stride = NULL_TREE;
    }
  GFC_TYPE_ARRAY_SIZE (fat_type) = stride;

  /* TODO: known offsets for descriptors.  */
  GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;

  if (dimen == 0)
    {
      arraytype =  build_pointer_type (etype);
      if (restricted)
	arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT);

      GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
      return fat_type;
    }

  /* We define data as an array with the correct size if possible.
     Much better than doing pointer arithmetic.  */
  if (stride)
    rtype = build_range_type (gfc_array_index_type, gfc_index_zero_node,
			      int_const_binop (MINUS_EXPR, stride,
					       build_int_cst (TREE_TYPE (stride), 1)));
  else
    rtype = gfc_array_range_type;
  arraytype = build_array_type (etype, rtype);
  arraytype = build_pointer_type (arraytype);
  if (restricted)
    arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT);
  GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;

  /* This will generate the base declarations we need to emit debug
     information for this type.  FIXME: there must be a better way to
     avoid divergence between compilations with and without debug
     information.  */
  {
    struct array_descr_info info;
    gfc_get_array_descr_info (fat_type, &info);
    gfc_get_array_descr_info (build_pointer_type (fat_type), &info);
  }

  return fat_type;
}
\f
/* Build a pointer type. This function is called from gfc_sym_type().  */

static tree
gfc_build_pointer_type (gfc_symbol * sym, tree type)
{
  /* Array pointer types aren't actually pointers.  */
  if (sym->attr.dimension)
    return type;
  else
    return build_pointer_type (type);
}

static tree gfc_nonrestricted_type (tree t);
/* Given two record or union type nodes TO and FROM, ensure
   that all fields in FROM have a corresponding field in TO,
   their type being nonrestrict variants.  This accepts a TO
   node that already has a prefix of the fields in FROM.  */
static void
mirror_fields (tree to, tree from)
{
  tree fto, ffrom;
  tree *chain;

  /* Forward to the end of TOs fields.  */
  fto = TYPE_FIELDS (to);
  ffrom = TYPE_FIELDS (from);
  chain = &TYPE_FIELDS (to);
  while (fto)
    {
      gcc_assert (ffrom && DECL_NAME (fto) == DECL_NAME (ffrom));
      chain = &DECL_CHAIN (fto);
      fto = DECL_CHAIN (fto);
      ffrom = DECL_CHAIN (ffrom);
    }

  /* Now add all fields remaining in FROM (starting with ffrom).  */
  for (; ffrom; ffrom = DECL_CHAIN (ffrom))
    {
      tree newfield = copy_node (ffrom);
      DECL_CONTEXT (newfield) = to;
      /* The store to DECL_CHAIN might seem redundant with the
	 stores to *chain, but not clearing it here would mean
	 leaving a chain into the old fields.  If ever
	 our called functions would look at them confusion
	 will arise.  */
      DECL_CHAIN (newfield) = NULL_TREE;
      *chain = newfield;
      chain = &DECL_CHAIN (newfield);

      if (TREE_CODE (ffrom) == FIELD_DECL)
	{
	  tree elemtype = gfc_nonrestricted_type (TREE_TYPE (ffrom));
	  TREE_TYPE (newfield) = elemtype;
	}
    }
  *chain = NULL_TREE;
}

/* Given a type T, returns a different type of the same structure,
   except that all types it refers to (recursively) are always
   non-restrict qualified types.  */
static tree
gfc_nonrestricted_type (tree t)
{
  tree ret = t;

  /* If the type isn't laid out yet, don't copy it.  If something
     needs it for real it should wait until the type got finished.  */
  if (!TYPE_SIZE (t))
    return t;

  if (!TYPE_LANG_SPECIFIC (t))
    TYPE_LANG_SPECIFIC (t) = ggc_cleared_alloc<struct lang_type> ();
  /* If we're dealing with this very node already further up
     the call chain (recursion via pointers and struct members)
     we haven't yet determined if we really need a new type node.
     Assume we don't, return T itself.  */
  if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type == error_mark_node)
    return t;

  /* If we have calculated this all already, just return it.  */
  if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type)
    return TYPE_LANG_SPECIFIC (t)->nonrestricted_type;

  /* Mark this type.  */
  TYPE_LANG_SPECIFIC (t)->nonrestricted_type = error_mark_node;

  switch (TREE_CODE (t))
    {
      default:
	break;

      case POINTER_TYPE:
      case REFERENCE_TYPE:
	{
	  tree totype = gfc_nonrestricted_type (TREE_TYPE (t));
	  if (totype == TREE_TYPE (t))
	    ret = t;
	  else if (TREE_CODE (t) == POINTER_TYPE)
	    ret = build_pointer_type (totype);
	  else
	    ret = build_reference_type (totype);
	  ret = build_qualified_type (ret,
				      TYPE_QUALS (t) & ~TYPE_QUAL_RESTRICT);
	}
	break;

      case ARRAY_TYPE:
	{
	  tree elemtype = gfc_nonrestricted_type (TREE_TYPE (t));
	  if (elemtype == TREE_TYPE (t))
	    ret = t;
	  else
	    {
	      ret = build_variant_type_copy (t);
	      TREE_TYPE (ret) = elemtype;
	      if (TYPE_LANG_SPECIFIC (t)
		  && GFC_TYPE_ARRAY_DATAPTR_TYPE (t))
		{
		  tree dataptr_type = GFC_TYPE_ARRAY_DATAPTR_TYPE (t);
		  dataptr_type = gfc_nonrestricted_type (dataptr_type);
		  if (dataptr_type != GFC_TYPE_ARRAY_DATAPTR_TYPE (t))
		    {
		      TYPE_LANG_SPECIFIC (ret)
			= ggc_cleared_alloc<struct lang_type> ();
		      *TYPE_LANG_SPECIFIC (ret) = *TYPE_LANG_SPECIFIC (t);
		      GFC_TYPE_ARRAY_DATAPTR_TYPE (ret) = dataptr_type;
		    }
		}
	    }
	}
	break;

      case RECORD_TYPE:
      case UNION_TYPE:
      case QUAL_UNION_TYPE:
	{
	  tree field;
	  /* First determine if we need a new type at all.
	     Careful, the two calls to gfc_nonrestricted_type per field
	     might return different values.  That happens exactly when
	     one of the fields reaches back to this very record type
	     (via pointers).  The first calls will assume that we don't
	     need to copy T (see the error_mark_node marking).  If there
	     are any reasons for copying T apart from having to copy T,
	     we'll indeed copy it, and the second calls to
	     gfc_nonrestricted_type will use that new node if they
	     reach back to T.  */
	  for (field = TYPE_FIELDS (t); field; field = DECL_CHAIN (field))
	    if (TREE_CODE (field) == FIELD_DECL)
	      {
		tree elemtype = gfc_nonrestricted_type (TREE_TYPE (field));
		if (elemtype != TREE_TYPE (field))
		  break;
	      }
	  if (!field)
	    break;
	  ret = build_variant_type_copy (t);
	  TYPE_FIELDS (ret) = NULL_TREE;

	  /* Here we make sure that as soon as we know we have to copy
	     T, that also fields reaching back to us will use the new
	     copy.  It's okay if that copy still contains the old fields,
	     we won't look at them.  */
	  TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret;
	  mirror_fields (ret, t);
	}
        break;
    }

  TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret;
  return ret;
}

\f
/* Return the type for a symbol.  Special handling is required for character
   types to get the correct level of indirection.
   For functions return the return type.
   For subroutines return void_type_node.
   Calling this multiple times for the same symbol should be avoided,
   especially for character and array types.  */

tree
gfc_sym_type (gfc_symbol * sym, bool is_bind_c)
{
  tree type;
  int byref;
  bool restricted;

  /* Procedure Pointers inside COMMON blocks.  */
  if (sym->attr.proc_pointer && sym->attr.in_common)
    {
      /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type.  */
      sym->attr.proc_pointer = 0;
      type = build_pointer_type (gfc_get_function_type (sym));
      sym->attr.proc_pointer = 1;
      return type;
    }

  if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
    return void_type_node;

  /* In the case of a function the fake result variable may have a
     type different from the function type, so don't return early in
     that case.  */
  if (sym->backend_decl && !sym->attr.function)
    return TREE_TYPE (sym->backend_decl);

  if (sym->attr.result
      && sym->ts.type == BT_CHARACTER
      && sym->ts.u.cl->backend_decl == NULL_TREE
      && sym->ns->proc_name
      && sym->ns->proc_name->ts.u.cl
      && sym->ns->proc_name->ts.u.cl->backend_decl != NULL_TREE)
    sym->ts.u.cl->backend_decl = sym->ns->proc_name->ts.u.cl->backend_decl;

  if (sym->ts.type == BT_CHARACTER
      && ((sym->attr.function && sym->attr.is_bind_c)
	  || ((sym->attr.result || sym->attr.value)
	      && sym->ns->proc_name
	      && sym->ns->proc_name->attr.is_bind_c)
	  || (sym->ts.deferred
	      && (!sym->ts.u.cl
		  || !sym->ts.u.cl->backend_decl
		  || sym->attr.save))
	  || (sym->attr.dummy
	      && sym->attr.value
	      && gfc_length_one_character_type_p (&sym->ts))))
    type = gfc_get_char_type (sym->ts.kind);
  else
    type = gfc_typenode_for_spec (&sym->ts, sym->attr.codimension);

  if (sym->attr.dummy && !sym->attr.function && !sym->attr.value
      && !sym->pass_as_value)
    byref = 1;
  else
    byref = 0;

  restricted = (!sym->attr.target && !IS_POINTER (sym)
		&& !IS_PROC_POINTER (sym) && !sym->attr.cray_pointee);
  if (!restricted)
    type = gfc_nonrestricted_type (type);

  /* Dummy argument to a bind(C) procedure.  */
  if (is_bind_c && is_CFI_desc (sym, NULL))
    type = gfc_get_cfi_type (sym->attr.dimension ? sym->as->rank : 0,
			     /* restricted = */ false);
  else if (sym->attr.dimension || sym->attr.codimension)
    {
      if (gfc_is_nodesc_array (sym))
        {
	  /* If this is a character argument of unknown length, just use the
	     base type.  */
	  if (sym->ts.type != BT_CHARACTER
	      || !(sym->attr.dummy || sym->attr.function)
	      || sym->ts.u.cl->backend_decl)
	    {
	      type = gfc_get_nodesc_array_type (type, sym->as,
						byref ? PACKED_FULL
						      : PACKED_STATIC,
						restricted);
	      byref = 0;
	    }
        }
      else
	{
	  enum gfc_array_kind akind = GFC_ARRAY_UNKNOWN;
	  if (sym->attr.pointer)
	    akind = sym->attr.contiguous ? GFC_ARRAY_POINTER_CONT
					 : GFC_ARRAY_POINTER;
	  else if (sym->attr.allocatable)
	    akind = GFC_ARRAY_ALLOCATABLE;
	  type = gfc_build_array_type (type, sym->as, akind, restricted,
				       sym->attr.contiguous, sym->as->corank);
	}
    }
  else
    {
      if (sym->attr.allocatable || sym->attr.pointer
	  || gfc_is_associate_pointer (sym))
	type = gfc_build_pointer_type (sym, type);
    }

  /* We currently pass all parameters by reference.
     See f95_get_function_decl.  For dummy function parameters return the
     function type.  */
  if (byref)
    {
      /* We must use pointer types for potentially absent variables.  The
	 optimizers assume a reference type argument is never NULL.  */
      if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
	  || sym->attr.optional
	  || (sym->ns->proc_name && sym->ns->proc_name->attr.entry_master))
	type = build_pointer_type (type);
      else
	type = build_reference_type (type);

      if (restricted)
	type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
    }

  return (type);
}
\f
/* Layout and output debug info for a record type.  */

void
gfc_finish_type (tree type)
{
  tree decl;

  decl = build_decl (input_location,
		     TYPE_DECL, NULL_TREE, type);
  TYPE_STUB_DECL (type) = decl;
  layout_type (type);
  rest_of_type_compilation (type, 1);
  rest_of_decl_compilation (decl, 1, 0);
}
\f
/* Add a field of given NAME and TYPE to the context of a UNION_TYPE
   or RECORD_TYPE pointed to by CONTEXT.  The new field is chained
   to the end of the field list pointed to by *CHAIN.

   Returns a pointer to the new field.  */

static tree
gfc_add_field_to_struct_1 (tree context, tree name, tree type, tree **chain)
{
  tree decl = build_decl (input_location, FIELD_DECL, name, type);

  DECL_CONTEXT (decl) = context;
  DECL_CHAIN (decl) = NULL_TREE;
  if (TYPE_FIELDS (context) == NULL_TREE)
    TYPE_FIELDS (context) = decl;
  if (chain != NULL)
    {
      if (*chain != NULL)
	**chain = decl;
      *chain = &DECL_CHAIN (decl);
    }

  return decl;
}

/* Like `gfc_add_field_to_struct_1', but adds alignment
   information.  */

tree
gfc_add_field_to_struct (tree context, tree name, tree type, tree **chain)
{
  tree decl = gfc_add_field_to_struct_1 (context, name, type, chain);

  DECL_INITIAL (decl) = 0;
  SET_DECL_ALIGN (decl, 0);
  DECL_USER_ALIGN (decl) = 0;

  return decl;
}


/* Copy the backend_decl and component backend_decls if
   the two derived type symbols are "equal", as described
   in 4.4.2 and resolved by gfc_compare_derived_types.  */

bool
gfc_copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to,
			   bool from_gsym)
{
  gfc_component *to_cm;
  gfc_component *from_cm;

  if (from == to)
    return 1;

  if (from->backend_decl == NULL
	|| !gfc_compare_derived_types (from, to))
    return 0;

  to->backend_decl = from->backend_decl;

  to_cm = to->components;
  from_cm = from->components;

  /* Copy the component declarations.  If a component is itself
     a derived type, we need a copy of its component declarations.
     This is done by recursing into gfc_get_derived_type and
     ensures that the component's component declarations have
     been built.  If it is a character, we need the character
     length, as well.  */
  for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
    {
      to_cm->backend_decl = from_cm->backend_decl;
      to_cm->caf_token = from_cm->caf_token;
      if (from_cm->ts.type == BT_UNION)
        gfc_get_union_type (to_cm->ts.u.derived);
      else if (from_cm->ts.type == BT_DERIVED
	  && (!from_cm->attr.pointer || from_gsym))
	gfc_get_derived_type (to_cm->ts.u.derived);
      else if (from_cm->ts.type == BT_CLASS
	       && (!CLASS_DATA (from_cm)->attr.class_pointer || from_gsym))
	gfc_get_derived_type (to_cm->ts.u.derived);
      else if (from_cm->ts.type == BT_CHARACTER)
	to_cm->ts.u.cl->backend_decl = from_cm->ts.u.cl->backend_decl;
    }

  return 1;
}


/* Build a tree node for a procedure pointer component.  */

static tree
gfc_get_ppc_type (gfc_component* c)
{
  tree t;

  /* Explicit interface.  */
  if (c->attr.if_source != IFSRC_UNKNOWN && c->ts.interface)
    return build_pointer_type (gfc_get_function_type (c->ts.interface));

  /* Implicit interface (only return value may be known).  */
  if (c->attr.function && !c->attr.dimension && c->ts.type != BT_CHARACTER)
    t = gfc_typenode_for_spec (&c->ts);
  else
    t = void_type_node;

  /* FIXME: it would be better to provide explicit interfaces in all
     cases, since they should be known by the compiler.  */
  return build_pointer_type (build_function_type (t, NULL_TREE));
}


/* Build a tree node for a union type. Requires building each map
   structure which is an element of the union. */

tree
gfc_get_union_type (gfc_symbol *un)
{
    gfc_component *map = NULL;
    tree typenode = NULL, map_type = NULL, map_field = NULL;
    tree *chain = NULL;

    if (un->backend_decl)
      {
        if (TYPE_FIELDS (un->backend_decl) || un->attr.proc_pointer_comp)
          return un->backend_decl;
        else
          typenode = un->backend_decl;
      }
    else
      {
        typenode = make_node (UNION_TYPE);
        TYPE_NAME (typenode) = get_identifier (un->name);
      }

    /* Add each contained MAP as a field. */
    for (map = un->components; map; map = map->next)
      {
        gcc_assert (map->ts.type == BT_DERIVED);

        /* The map's type node, which is defined within this union's context. */
        map_type = gfc_get_derived_type (map->ts.u.derived);
        TYPE_CONTEXT (map_type) = typenode;

        /* The map field's declaration. */
        map_field = gfc_add_field_to_struct(typenode, get_identifier(map->name),
                                            map_type, &chain);
	if (GFC_LOCUS_IS_SET (map->loc))
	  gfc_set_decl_location (map_field, &map->loc);
	else if (GFC_LOCUS_IS_SET (un->declared_at))
	  gfc_set_decl_location (map_field, &un->declared_at);

        DECL_PACKED (map_field) |= TYPE_PACKED (typenode);
        DECL_NAMELESS(map_field) = true;

        /* We should never clobber another backend declaration for this map,
           because each map component is unique. */
        if (!map->backend_decl)
          map->backend_decl = map_field;
      }

    un->backend_decl = typenode;
    gfc_finish_type (typenode);

    return typenode;
}

bool
cobounds_match_decl (const gfc_symbol *derived)
{
  tree arrtype, tmp;
  gfc_array_spec *as;

  if (!derived->backend_decl)
    return false;
  /* Care only about coarray declarations.  Everything else is ok with us.  */
  if (!derived->components || strcmp (derived->components->name, "_data") != 0)
    return true;
  if (!derived->components->attr.codimension)
    return true;

  arrtype = TREE_TYPE (TYPE_FIELDS (derived->backend_decl));
  as = derived->components->as;
  if (GFC_TYPE_ARRAY_CORANK (arrtype) != as->corank)
    return false;

  for (int dim = as->rank; dim < as->rank + as->corank; ++dim)
    {
      /* Check lower bound.  */
      tmp = TYPE_LANG_SPECIFIC (arrtype)->lbound[dim];
      if (!tmp || !INTEGER_CST_P (tmp))
	return false;
      if (as->lower[dim]->expr_type != EXPR_CONSTANT
	  || as->lower[dim]->ts.type != BT_INTEGER)
	return false;
      if (*tmp->int_cst.val != mpz_get_si (as->lower[dim]->value.integer))
	return false;

      /* Check upper bound.  */
      tmp = TYPE_LANG_SPECIFIC (arrtype)->ubound[dim];
      if (!tmp && !as->upper[dim])
	continue;

      if (!tmp || !INTEGER_CST_P (tmp))
	return false;
      if (as->upper[dim]->expr_type != EXPR_CONSTANT
	  || as->upper[dim]->ts.type != BT_INTEGER)
	return false;
      if (*tmp->int_cst.val != mpz_get_si (as->upper[dim]->value.integer))
	return false;
    }

  return true;
}

/* Build a tree node for a derived type.  If there are equal
   derived types, with different local names, these are built
   at the same time.  If an equal derived type has been built
   in a parent namespace, this is used.  */

tree
gfc_get_derived_type (gfc_symbol * derived, int codimen)
{
  tree typenode = NULL, field = NULL, field_type = NULL;
  tree canonical = NULL_TREE;
  tree *chain = NULL;
  bool got_canonical = false;
  bool unlimited_entity = false;
  gfc_component *c;
  gfc_namespace *ns;
  tree tmp;
  bool coarray_flag, class_coarray_flag;

  coarray_flag = flag_coarray == GFC_FCOARRAY_LIB
		 && derived->module && !derived->attr.vtype;
  class_coarray_flag = derived->components
		       && derived->components->ts.type == BT_DERIVED
		       && strcmp (derived->components->name, "_data") == 0
		       && derived->components->attr.codimension
		       && derived->components->as->cotype == AS_EXPLICIT;

  gcc_assert (!derived->attr.pdt_template);

  if (derived->attr.unlimited_polymorphic
      || (flag_coarray == GFC_FCOARRAY_LIB
	  && derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
	  && (derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE
	      || derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE
	      || derived->intmod_sym_id == ISOFORTRAN_TEAM_TYPE)))
    return ptr_type_node;

  if (flag_coarray != GFC_FCOARRAY_LIB
      && derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
      && (derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE
	  || derived->intmod_sym_id == ISOFORTRAN_TEAM_TYPE))
    return gfc_get_int_type (gfc_default_integer_kind);

  if (derived && derived->attr.flavor == FL_PROCEDURE
      && derived->attr.generic)
    derived = gfc_find_dt_in_generic (derived);

  /* See if it's one of the iso_c_binding derived types.  */
  if (derived->attr.is_iso_c == 1 || derived->ts.f90_type == BT_VOID)
    {
      if (derived->backend_decl)
	return derived->backend_decl;

      if (derived->intmod_sym_id == ISOCBINDING_PTR)
	derived->backend_decl = ptr_type_node;
      else
	derived->backend_decl = pfunc_type_node;

      derived->ts.kind = gfc_index_integer_kind;
      derived->ts.type = BT_INTEGER;
      /* Set the f90_type to BT_VOID as a way to recognize something of type
         BT_INTEGER that needs to fit a void * for the purpose of the
         iso_c_binding derived types.  */
      derived->ts.f90_type = BT_VOID;

      return derived->backend_decl;
    }

  /* If use associated, use the module type for this one.  */
  if (derived->backend_decl == NULL
      && (derived->attr.use_assoc || derived->attr.used_in_submodule)
      && derived->module
      && gfc_get_module_backend_decl (derived))
    goto copy_derived_types;

  /* The derived types from an earlier namespace can be used as the
     canonical type.  */
  if (derived->backend_decl == NULL
      && !derived->attr.use_assoc
      && !derived->attr.used_in_submodule
      && gfc_global_ns_list)
    {
      for (ns = gfc_global_ns_list;
	   ns->translated && !got_canonical;
	   ns = ns->sibling)
	{
	  if (ns->derived_types)
	    {
	      for (gfc_symbol *dt = ns->derived_types; dt && !got_canonical;
		   dt = dt->dt_next)
		{
		  gfc_copy_dt_decls_ifequal (dt, derived, true);
		  if (derived->backend_decl)
		    got_canonical = true;
		  if (dt->dt_next == ns->derived_types)
		    break;
		}
 	    }
 	}
    }

  /* Store up the canonical type to be added to this one.  */
  if (got_canonical)
    {
      if (TYPE_CANONICAL (derived->backend_decl))
	canonical = TYPE_CANONICAL (derived->backend_decl);
      else
	canonical = derived->backend_decl;

      derived->backend_decl = NULL_TREE;
    }

  /* derived->backend_decl != 0 means we saw it before, but its
     components' backend_decl may have not been built.  */
  if (derived->backend_decl
      && (!class_coarray_flag || cobounds_match_decl (derived)))
    {
      /* Its components' backend_decl have been built or we are
	 seeing recursion through the formal arglist of a procedure
	 pointer component.  */
      if (TYPE_FIELDS (derived->backend_decl))
	return derived->backend_decl;
      else if (derived->attr.abstract
	       && derived->attr.proc_pointer_comp)
	{
	  /* If an abstract derived type with procedure pointer
	     components has no other type of component, return the
	     backend_decl. Otherwise build the components if any of the
	     non-procedure pointer components have no backend_decl.  */
	  for (c = derived->components; c; c = c->next)
	    {
	      bool same_alloc_type = c->attr.allocatable
				     && derived == c->ts.u.derived;
	      if (!c->attr.proc_pointer
		  && !same_alloc_type
		  && c->backend_decl == NULL)
		break;
	      else if (c->next == NULL)
		return derived->backend_decl;
	    }
	  typenode = derived->backend_decl;
	}
      else
        typenode = derived->backend_decl;
    }
  else
    {
      /* We see this derived type first time, so build the type node.  */
      typenode = make_node (RECORD_TYPE);
      TYPE_NAME (typenode) = get_identifier (derived->name);
      TYPE_PACKED (typenode) = flag_pack_derived;
      derived->backend_decl = typenode;
    }

  if (derived->components
      && derived->components->ts.type == BT_DERIVED
      && startswith (derived->name, "__class")
      && strcmp (derived->components->name, "_data") == 0
      && derived->components->ts.u.derived->attr.unlimited_polymorphic)
    unlimited_entity = true;

  /* Go through the derived type components, building them as
     necessary. The reason for doing this now is that it is
     possible to recurse back to this derived type through a
     pointer component (PR24092). If this happens, the fields
     will be built and so we can return the type.  */
  for (c = derived->components; c; c = c->next)
    {
      if (c->ts.type == BT_UNION && c->ts.u.derived->backend_decl == NULL)
        c->ts.u.derived->backend_decl = gfc_get_union_type (c->ts.u.derived);

      if (c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
	continue;

      const bool incomplete_type
	= c->ts.u.derived->backend_decl
	  && TREE_CODE (c->ts.u.derived->backend_decl) == RECORD_TYPE
	  && !(TYPE_LANG_SPECIFIC (c->ts.u.derived->backend_decl)
	       && TYPE_LANG_SPECIFIC (c->ts.u.derived->backend_decl)->size);
      const bool pointer_component
	= c->attr.pointer || c->attr.allocatable || c->attr.proc_pointer;

      /* Prevent endless recursion on recursive types (i.e. types that reference
	 themself in a component.  Break the recursion by not building pointers
	 to incomplete types again, aka types that are already in the build.  */
      if (c->ts.u.derived->backend_decl == NULL
	  || (c->attr.codimension && c->as->corank != codimen)
	  || !(incomplete_type && pointer_component))
	{
	  int local_codim = c->attr.codimension ? c->as->corank: codimen;
	  c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived,
								local_codim);
	}

      if (c->ts.u.derived->attr.is_iso_c)
        {
          /* Need to copy the modified ts from the derived type.  The
             typespec was modified because C_PTR/C_FUNPTR are translated
             into (void *) from derived types.  */
          c->ts.type = c->ts.u.derived->ts.type;
          c->ts.kind = c->ts.u.derived->ts.kind;
          c->ts.f90_type = c->ts.u.derived->ts.f90_type;
	  if (c->initializer)
	    {
	      c->initializer->ts.type = c->ts.type;
	      c->initializer->ts.kind = c->ts.kind;
	      c->initializer->ts.f90_type = c->ts.f90_type;
	      c->initializer->expr_type = EXPR_NULL;
	    }
        }
    }

  if (!class_coarray_flag && TYPE_FIELDS (derived->backend_decl))
    return derived->backend_decl;

  /* Build the type member list. Install the newly created RECORD_TYPE
     node as DECL_CONTEXT of each FIELD_DECL. In this case we must go
     through only the top-level linked list of components so we correctly
     build UNION_TYPE nodes for BT_UNION components. MAPs and other nested
     types are built as part of gfc_get_union_type.  */
  for (c = derived->components; c; c = c->next)
    {
      bool same_alloc_type = c->attr.allocatable
			     && derived == c->ts.u.derived;
      /* Prevent infinite recursion, when the procedure pointer type is
	 the same as derived, by forcing the procedure pointer component to
	 be built as if the explicit interface does not exist.  */
      if (c->attr.proc_pointer
	  && (c->ts.type != BT_DERIVED || (c->ts.u.derived
		    && !gfc_compare_derived_types (derived, c->ts.u.derived)))
	  && (c->ts.type != BT_CLASS || (CLASS_DATA (c)->ts.u.derived
		    && !gfc_compare_derived_types (derived, CLASS_DATA (c)->ts.u.derived))))
	field_type = gfc_get_ppc_type (c);
      else if (c->attr.proc_pointer && derived->backend_decl)
	{
	  tmp = build_function_type (derived->backend_decl, NULL_TREE);
	  field_type = build_pointer_type (tmp);
	}
      else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
	field_type = c->ts.u.derived->backend_decl;
      else if (c->attr.caf_token)
	field_type = pvoid_type_node;
      else
	{
	  if (c->ts.type == BT_CHARACTER
	      && !c->ts.deferred && !c->attr.pdt_string)
	    {
	      /* Evaluate the string length.  */
	      gfc_conv_const_charlen (c->ts.u.cl);
	      gcc_assert (c->ts.u.cl->backend_decl);
	    }
	  else if (c->ts.type == BT_CHARACTER)
	    c->ts.u.cl->backend_decl
			= build_int_cst (gfc_charlen_type_node, 0);

	  field_type = gfc_typenode_for_spec (&c->ts, codimen);
	}

      /* This returns an array descriptor type.  Initialization may be
         required.  */
      if ((c->attr.dimension || c->attr.codimension) && !c->attr.proc_pointer )
	{
	  if (c->attr.pointer || c->attr.allocatable || c->attr.pdt_array)
	    {
	      enum gfc_array_kind akind;
	      bool is_ptr = ((c == derived->components
			      && derived->components->ts.type == BT_DERIVED
			      && startswith (derived->name, "__class")
			      && (strcmp (derived->components->name, "_data")
				  == 0))
			     ? c->attr.class_pointer : c->attr.pointer);
	      if (is_ptr)
		akind = c->attr.contiguous ? GFC_ARRAY_POINTER_CONT
					   : GFC_ARRAY_POINTER;
	      else if (c->attr.allocatable)
		akind = GFC_ARRAY_ALLOCATABLE;
	      else if (c->as->type == AS_ASSUMED_RANK)
		akind = GFC_ARRAY_ASSUMED_RANK;
	      else
		/* FIXME – see PR fortran/104651.  Additionally, the following
		   gfc_build_array_type should use !is_ptr instead of
		   c->attr.pointer and codim unconditionally without '? :'. */
		akind = GFC_ARRAY_ASSUMED_SHAPE;
	      /* Pointers to arrays aren't actually pointer types.  The
		 descriptors are separate, but the data is common.  Every
		 array pointer in a coarray derived type needs to provide space
		 for the coarray management, too.  Therefore treat coarrays
		 and pointers to coarrays in derived types the same.  */
	      field_type = gfc_build_array_type
		(
		  field_type, c->as, akind, !c->attr.target && !c->attr.pointer,
		  c->attr.contiguous,
		  c->attr.codimension || c->attr.pointer ? codimen : 0
		);
	    }
	  else
	    field_type = gfc_get_nodesc_array_type (field_type, c->as,
						    PACKED_STATIC,
						    !c->attr.target);
	}
      else if ((c->attr.pointer || c->attr.allocatable || c->attr.pdt_string)
	       && !c->attr.proc_pointer
	       && !(unlimited_entity && c == derived->components))
	field_type = build_pointer_type (field_type);

      if (c->attr.pointer || same_alloc_type)
	field_type = gfc_nonrestricted_type (field_type);

      /* vtype fields can point to different types to the base type.  */
      if (c->ts.type == BT_DERIVED
	    && c->ts.u.derived && c->ts.u.derived->attr.vtype)
	  field_type = build_pointer_type_for_mode (TREE_TYPE (field_type),
						    ptr_mode, true);

      /* Ensure that the CLASS language specific flag is set.  */
      if (c->ts.type == BT_CLASS)
	{
	  if (POINTER_TYPE_P (field_type))
	    GFC_CLASS_TYPE_P (TREE_TYPE (field_type)) = 1;
	  else
	    GFC_CLASS_TYPE_P (field_type) = 1;
	}

      field = gfc_add_field_to_struct (typenode,
				       get_identifier (c->name),
				       field_type, &chain);
      if (GFC_LOCUS_IS_SET (c->loc))
	gfc_set_decl_location (field, &c->loc);
      else if (GFC_LOCUS_IS_SET (derived->declared_at))
	gfc_set_decl_location (field, &derived->declared_at);

      gfc_finish_decl_attrs (field, &c->attr);

      DECL_PACKED (field) |= TYPE_PACKED (typenode);

      gcc_assert (field);
      /* Overwrite for class array to supply different bounds for different
	 types.  */
      if (class_coarray_flag || !c->backend_decl || c->attr.caf_token)
	c->backend_decl = field;

      if (c->attr.pointer && (c->attr.dimension || c->attr.codimension)
	  && !(c->ts.type == BT_DERIVED && strcmp (c->name, "_data") == 0))
	GFC_DECL_PTR_ARRAY_P (c->backend_decl) = 1;
    }

  /* Now lay out the derived type, including the fields.  */
  if (canonical)
    TYPE_CANONICAL (typenode) = canonical;

  gfc_finish_type (typenode);
  gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at);
  if (derived->module && derived->ns->proc_name
      && derived->ns->proc_name->attr.flavor == FL_MODULE)
    {
      if (derived->ns->proc_name->backend_decl
	  && TREE_CODE (derived->ns->proc_name->backend_decl)
	     == NAMESPACE_DECL)
	{
	  TYPE_CONTEXT (typenode) = derived->ns->proc_name->backend_decl;
	  DECL_CONTEXT (TYPE_STUB_DECL (typenode))
	    = derived->ns->proc_name->backend_decl;
	}
    }

  derived->backend_decl = typenode;

copy_derived_types:

  if (!derived->attr.vtype)
    for (c = derived->components; c; c = c->next)
      {
	/* Do not add a caf_token field for class container components.  */
	if (codimen && coarray_flag && !c->attr.dimension
	    && !c->attr.codimension && (c->attr.allocatable || c->attr.pointer)
	    && !derived->attr.is_class)
	  {
	    /* Provide sufficient space to hold "_caf_symbol".  */
	    char caf_name[GFC_MAX_SYMBOL_LEN + 6];
	    gfc_component *token;
	    snprintf (caf_name, sizeof (caf_name), "_caf_%s", c->name);
	    token = gfc_find_component (derived, caf_name, true, true, NULL);
	    gcc_assert (token);
	    gfc_comp_caf_token (c) = token->backend_decl;
	    suppress_warning (gfc_comp_caf_token (c));
	  }
      }

  for (gfc_symbol *dt = gfc_derived_types; dt; dt = dt->dt_next)
    {
      gfc_copy_dt_decls_ifequal (derived, dt, false);
      if (dt->dt_next == gfc_derived_types)
	break;
    }

  return derived->backend_decl;
}


bool
gfc_return_by_reference (gfc_symbol * sym)
{
  if (!sym->attr.function)
    return 0;

  if (sym->attr.dimension)
    return 1;

  if (sym->ts.type == BT_CHARACTER
      && !sym->attr.is_bind_c
      && (!sym->attr.result
	  || !sym->ns->proc_name
	  || !sym->ns->proc_name->attr.is_bind_c))
    return 1;

  /* Possibly return complex numbers by reference for g77 compatibility.
     We don't do this for calls to intrinsics (as the library uses the
     -fno-f2c calling convention) except for calls to specific wrappers
     (_gfortran_f2c_specific_*), nor for calls to functions which always
     require an explicit interface, as no compatibility problems can
     arise there.  */
  if (flag_f2c && sym->ts.type == BT_COMPLEX
      && !sym->attr.pointer
      && !sym->attr.allocatable
      && !sym->attr.always_explicit)
    return 1;

  return 0;
}
\f
static tree
gfc_get_mixed_entry_union (gfc_namespace *ns)
{
  tree type;
  tree *chain = NULL;
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_entry_list *el, *el2;

  gcc_assert (ns->proc_name->attr.mixed_entry_master);
  gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0);

  snprintf (name, GFC_MAX_SYMBOL_LEN, "munion.%s", ns->proc_name->name + 7);

  /* Build the type node.  */
  type = make_node (UNION_TYPE);

  TYPE_NAME (type) = get_identifier (name);

  for (el = ns->entries; el; el = el->next)
    {
      /* Search for duplicates.  */
      for (el2 = ns->entries; el2 != el; el2 = el2->next)
	if (el2->sym->result == el->sym->result)
	  break;

      if (el == el2)
	gfc_add_field_to_struct_1 (type,
				   get_identifier (el->sym->result->name),
				   gfc_sym_type (el->sym->result), &chain);
    }

  /* Finish off the type.  */
  gfc_finish_type (type);
  TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
  return type;
}
\f
/* Create a "fn spec" based on the formal arguments;
   cf. create_function_arglist.  */

static tree
create_fn_spec (gfc_symbol *sym, tree fntype)
{
  char spec[150];
  size_t spec_len;
  gfc_formal_arglist *f;
  tree tmp;

  memset (&spec, 0, sizeof (spec));
  spec[0] = '.';
  spec[1] = ' ';
  spec_len = 2;

  if (sym->attr.entry_master)
    {
      spec[spec_len++] = 'R';
      spec[spec_len++] = ' ';
    }
  if (gfc_return_by_reference (sym))
    {
      gfc_symbol *result = sym->result ? sym->result : sym;

      if (result->attr.pointer || sym->attr.proc_pointer)
	{
	  spec[spec_len++] = '.';
	  spec[spec_len++] = ' ';
	}
      else
	{
	  spec[spec_len++] = 'w';
	  spec[spec_len++] = ' ';
	}
      if (sym->ts.type == BT_CHARACTER)
	{
	  if (!sym->ts.u.cl->length
	      && (sym->attr.allocatable || sym->attr.pointer))
	    spec[spec_len++] = 'w';
	  else
	    spec[spec_len++] = 'R';
	  spec[spec_len++] = ' ';
	}
    }

  for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
    if (spec_len < sizeof (spec))
      {
	bool is_class = false;
	bool is_pointer = false;

	if (f->sym)
	  {
	    is_class = f->sym->ts.type == BT_CLASS && CLASS_DATA (f->sym)
	      && f->sym->attr.class_ok;
	    is_pointer = is_class ? CLASS_DATA (f->sym)->attr.class_pointer
				  : f->sym->attr.pointer;
	  }

	if (f->sym == NULL || is_pointer || f->sym->attr.target
	    || f->sym->attr.external || f->sym->attr.cray_pointer
	    || (f->sym->ts.type == BT_DERIVED
		&& (f->sym->ts.u.derived->attr.proc_pointer_comp
		    || f->sym->ts.u.derived->attr.pointer_comp))
	    || (is_class
		&& (CLASS_DATA (f->sym)->ts.u.derived->attr.proc_pointer_comp
		    || CLASS_DATA (f->sym)->ts.u.derived->attr.pointer_comp))
	    || (f->sym->ts.type == BT_INTEGER && f->sym->ts.is_c_interop))
	  {
	    spec[spec_len++] = '.';
	    spec[spec_len++] = ' ';
	  }
	else if (f->sym->attr.intent == INTENT_IN)
	  {
	    spec[spec_len++] = 'r';
	    spec[spec_len++] = ' ';
	  }
	else if (f->sym)
	  {
	    spec[spec_len++] = 'w';
	    spec[spec_len++] = ' ';
	  }
      }

  tmp = build_tree_list (NULL_TREE, build_string (spec_len, spec));
  tmp = tree_cons (get_identifier ("fn spec"), tmp, TYPE_ATTRIBUTES (fntype));
  return build_type_attribute_variant (fntype, tmp);
}


/* NOTE: The returned function type must match the argument list created by
   create_function_arglist.  */

tree
gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args,
		       const char *fnspec)
{
  tree type;
  vec<tree, va_gc> *typelist = NULL;
  vec<tree, va_gc> *hidden_typelist = NULL;
  gfc_formal_arglist *f;
  gfc_symbol *arg;
  int alternate_return = 0;
  bool is_varargs = true;

  /* Make sure this symbol is a function, a subroutine or the main
     program.  */
  gcc_assert (sym->attr.flavor == FL_PROCEDURE
	      || sym->attr.flavor == FL_PROGRAM);

  /* To avoid recursing infinitely on recursive types, we use error_mark_node
     so that they can be detected here and handled further down.  */
  if (sym->backend_decl == NULL)
    sym->backend_decl = error_mark_node;
  else if (sym->backend_decl == error_mark_node)
    goto arg_type_list_done;
  else if (sym->attr.proc_pointer)
    return TREE_TYPE (TREE_TYPE (sym->backend_decl));
  else
    return TREE_TYPE (sym->backend_decl);

  if (sym->attr.entry_master)
    /* Additional parameter for selecting an entry point.  */
    vec_safe_push (typelist, gfc_array_index_type);

  if (sym->result)
    arg = sym->result;
  else
    arg = sym;

  if (arg->ts.type == BT_CHARACTER)
    gfc_conv_const_charlen (arg->ts.u.cl);

  /* Some functions we use an extra parameter for the return value.  */
  if (gfc_return_by_reference (sym))
    {
      type = gfc_sym_type (arg);
      if (arg->ts.type == BT_COMPLEX
	  || arg->attr.dimension
	  || arg->ts.type == BT_CHARACTER)
	type = build_reference_type (type);

      vec_safe_push (typelist, type);
      if (arg->ts.type == BT_CHARACTER)
	{
	  if (!arg->ts.deferred)
	    /* Transfer by value.  */
	    vec_safe_push (typelist, gfc_charlen_type_node);
	  else
	    /* Deferred character lengths are transferred by reference
	       so that the value can be returned.  */
	    vec_safe_push (typelist, build_pointer_type(gfc_charlen_type_node));
	}
    }
  if (sym->backend_decl == error_mark_node && actual_args != NULL
      && sym->formal == NULL && (sym->attr.proc == PROC_EXTERNAL
				 || sym->attr.proc == PROC_UNKNOWN))
    gfc_get_formal_from_actual_arglist (sym, actual_args);

  /* Build the argument types for the function.  */
  for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
    {
      arg = f->sym;
      if (arg)
	{
	  /* Evaluate constant character lengths here so that they can be
	     included in the type.  */
	  if (arg->ts.type == BT_CHARACTER)
	    gfc_conv_const_charlen (arg->ts.u.cl);

	  if (arg->attr.flavor == FL_PROCEDURE)
	    {
	      type = gfc_get_function_type (arg);
	      type = build_pointer_type (type);
	    }
	  else
	    type = gfc_sym_type (arg, sym->attr.is_bind_c);

	  /* Parameter Passing Convention

	     We currently pass all parameters by reference.
	     Parameters with INTENT(IN) could be passed by value.
	     The problem arises if a function is called via an implicit
	     prototype. In this situation the INTENT is not known.
	     For this reason all parameters to global functions must be
	     passed by reference.  Passing by value would potentially
	     generate bad code.  Worse there would be no way of telling that
	     this code was bad, except that it would give incorrect results.

	     Contained procedures could pass by value as these are never
	     used without an explicit interface, and cannot be passed as
	     actual parameters for a dummy procedure.  */

	  vec_safe_push (typelist, type);
	}
      else
        {
          if (sym->attr.subroutine)
            alternate_return = 1;
        }
    }

  /* Add hidden arguments.  */
  for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
    {
      arg = f->sym;
      /* Add hidden string length parameters.  */
      if (arg && arg->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)
	{
	  if (!arg->ts.deferred)
	    /* Transfer by value.  */
	    type = gfc_charlen_type_node;
	  else
	    /* Deferred character lengths are transferred by reference
	       so that the value can be returned.  */
	    type = build_pointer_type (gfc_charlen_type_node);

	  vec_safe_push (hidden_typelist, type);
	}
      /* For scalar intrinsic types or derived types, VALUE passes the value,
	 hence, the optional status cannot be transferred via a NULL pointer.
	 Thus, we will use a hidden argument in that case.  */
      if (arg
	  && arg->attr.optional
	  && arg->attr.value
	  && !arg->attr.dimension
	  && arg->ts.type != BT_CLASS)
	vec_safe_push (typelist, boolean_type_node);
      /* Coarrays which are descriptorless or assumed-shape pass with
	 -fcoarray=lib the token and the offset as hidden arguments.  */
      if (arg
	  && flag_coarray == GFC_FCOARRAY_LIB
	  && ((arg->ts.type != BT_CLASS
	       && arg->attr.codimension
	       && !arg->attr.allocatable)
	      || (arg->ts.type == BT_CLASS
		  && CLASS_DATA (arg)->attr.codimension
		  && !CLASS_DATA (arg)->attr.allocatable)))
	{
	  vec_safe_push (hidden_typelist, pvoid_type_node);  /* caf_token.  */
	  vec_safe_push (hidden_typelist, gfc_array_index_type);  /* caf_offset.  */
	}
    }

  /* Put hidden character length, caf_token, caf_offset at the end.  */
  vec_safe_reserve (typelist, vec_safe_length (hidden_typelist));
  vec_safe_splice (typelist, hidden_typelist);

  if (!vec_safe_is_empty (typelist)
      || sym->attr.is_main_program
      || sym->attr.if_source != IFSRC_UNKNOWN)
    is_varargs = false;

  if (sym->backend_decl == error_mark_node)
    sym->backend_decl = NULL_TREE;

arg_type_list_done:

  if (alternate_return)
    type = integer_type_node;
  else if (!sym->attr.function || gfc_return_by_reference (sym))
    type = void_type_node;
  else if (sym->attr.mixed_entry_master)
    type = gfc_get_mixed_entry_union (sym->ns);
  else if (flag_f2c && sym->ts.type == BT_REAL
	   && sym->ts.kind == gfc_default_real_kind
	   && !sym->attr.pointer
	   && !sym->attr.allocatable
	   && !sym->attr.always_explicit)
    {
      /* Special case: f2c calling conventions require that (scalar)
	 default REAL functions return the C type double instead.  f2c
	 compatibility is only an issue with functions that don't
	 require an explicit interface, as only these could be
	 implemented in Fortran 77.  */
      sym->ts.kind = gfc_default_double_kind;
      type = gfc_typenode_for_spec (&sym->ts);
      sym->ts.kind = gfc_default_real_kind;
    }
  else if (sym->result && sym->result->attr.proc_pointer)
    /* Procedure pointer return values.  */
    {
      if (sym->result->attr.result && strcmp (sym->name,"ppr@") != 0)
	{
	  /* Unset proc_pointer as gfc_get_function_type
	     is called recursively.  */
	  sym->result->attr.proc_pointer = 0;
	  type = build_pointer_type (gfc_get_function_type (sym->result));
	  sym->result->attr.proc_pointer = 1;
	}
      else
       type = gfc_sym_type (sym->result);
    }
  else
    type = gfc_sym_type (sym);

  if (is_varargs)
    /* This should be represented as an unprototyped type, not a type
       with (...) prototype.  */
    type = build_function_type (type, NULL_TREE);
  else
    type = build_function_type_vec (type, typelist);

  /* If we were passed an fn spec, add it here, otherwise determine it from
     the formal arguments.  */
  if (fnspec)
    {
      tree tmp;
      int spec_len = strlen (fnspec);
      tmp = build_tree_list (NULL_TREE, build_string (spec_len, fnspec));
      tmp = tree_cons (get_identifier ("fn spec"), tmp, TYPE_ATTRIBUTES (type));
      type = build_type_attribute_variant (type, tmp);
    }
  else
    type = create_fn_spec (sym, type);

  return type;
}
\f
/* Language hooks for middle-end access to type nodes.  */

/* Return an integer type with BITS bits of precision,
   that is unsigned if UNSIGNEDP is nonzero, otherwise signed.  */

tree
gfc_type_for_size (unsigned bits, int unsignedp)
{
  if (!unsignedp)
    {
      int i;
      for (i = 0; i <= MAX_INT_KINDS; ++i)
	{
	  tree type = gfc_integer_types[i];
	  if (type && bits == TYPE_PRECISION (type))
	    return type;
	}

      /* Handle TImode as a special case because it is used by some backends
         (e.g. ARM) even though it is not available for normal use.  */
#if HOST_BITS_PER_WIDE_INT >= 64
      if (bits == TYPE_PRECISION (intTI_type_node))
	return intTI_type_node;
#endif

      if (bits <= TYPE_PRECISION (intQI_type_node))
	return intQI_type_node;
      if (bits <= TYPE_PRECISION (intHI_type_node))
	return intHI_type_node;
      if (bits <= TYPE_PRECISION (intSI_type_node))
	return intSI_type_node;
      if (bits <= TYPE_PRECISION (intDI_type_node))
	return intDI_type_node;
      if (bits <= TYPE_PRECISION (intTI_type_node))
	return intTI_type_node;
    }
  else
    {
      if (bits <= TYPE_PRECISION (unsigned_intQI_type_node))
        return unsigned_intQI_type_node;
      if (bits <= TYPE_PRECISION (unsigned_intHI_type_node))
	return unsigned_intHI_type_node;
      if (bits <= TYPE_PRECISION (unsigned_intSI_type_node))
	return unsigned_intSI_type_node;
      if (bits <= TYPE_PRECISION (unsigned_intDI_type_node))
	return unsigned_intDI_type_node;
      if (bits <= TYPE_PRECISION (unsigned_intTI_type_node))
	return unsigned_intTI_type_node;
    }

  return NULL_TREE;
}

/* Return a data type that has machine mode MODE.  If the mode is an
   integer, then UNSIGNEDP selects between signed and unsigned types.  */

tree
gfc_type_for_mode (machine_mode mode, int unsignedp)
{
  int i;
  tree *base;
  scalar_int_mode int_mode;

  if (GET_MODE_CLASS (mode) == MODE_FLOAT)
    base = gfc_real_types;
  else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT)
    base = gfc_complex_types;
  else if (is_a <scalar_int_mode> (mode, &int_mode))
    {
      tree type = gfc_type_for_size (GET_MODE_PRECISION (int_mode), unsignedp);
      return type != NULL_TREE && mode == TYPE_MODE (type) ? type : NULL_TREE;
    }
  else if (GET_MODE_CLASS (mode) == MODE_VECTOR_BOOL
	   && valid_vector_subparts_p (GET_MODE_NUNITS (mode)))
    {
      unsigned int elem_bits = vector_element_size (GET_MODE_PRECISION (mode),
						    GET_MODE_NUNITS (mode));
      tree bool_type = build_nonstandard_boolean_type (elem_bits);
      return build_vector_type_for_mode (bool_type, mode);
    }
  else if (VECTOR_MODE_P (mode)
	   && valid_vector_subparts_p (GET_MODE_NUNITS (mode)))
    {
      machine_mode inner_mode = GET_MODE_INNER (mode);
      tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
      if (inner_type != NULL_TREE)
        return build_vector_type_for_mode (inner_type, mode);
      return NULL_TREE;
    }
  else
    return NULL_TREE;

  for (i = 0; i <= MAX_REAL_KINDS; ++i)
    {
      tree type = base[i];
      if (type && mode == TYPE_MODE (type))
	return type;
    }

  return NULL_TREE;
}

/* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO
   in that case.  */

bool
gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
{
  int rank, dim;
  bool indirect = false;
  tree etype, ptype, t, base_decl;
  tree data_off, span_off, dim_off, dtype_off, dim_size, elem_size;
  tree lower_suboff, upper_suboff, stride_suboff;
  tree dtype, field, rank_off;

  if (! GFC_DESCRIPTOR_TYPE_P (type))
    {
      if (! POINTER_TYPE_P (type))
	return false;
      type = TREE_TYPE (type);
      if (! GFC_DESCRIPTOR_TYPE_P (type))
	return false;
      indirect = true;
    }

  rank = GFC_TYPE_ARRAY_RANK (type);
  if (rank >= (int) (ARRAY_SIZE (info->dimen)))
    return false;

  etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
  gcc_assert (POINTER_TYPE_P (etype));
  etype = TREE_TYPE (etype);

  /* If the type is not a scalar coarray.  */
  if (TREE_CODE (etype) == ARRAY_TYPE)
    etype = TREE_TYPE (etype);

  /* Can't handle variable sized elements yet.  */
  if (int_size_in_bytes (etype) <= 0)
    return false;
  /* Nor non-constant lower bounds in assumed shape arrays.  */
  if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE
      || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT)
    {
      for (dim = 0; dim < rank; dim++)
	if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE
	    || TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) != INTEGER_CST)
	  return false;
    }

  memset (info, '\0', sizeof (*info));
  info->ndimensions = rank;
  info->ordering = array_descr_ordering_column_major;
  info->element_type = etype;
  ptype = build_pointer_type (gfc_array_index_type);
  base_decl = GFC_TYPE_ARRAY_BASE_DECL (type, indirect);
  if (!base_decl)
    {
      base_decl = build_debug_expr_decl (indirect
					 ? build_pointer_type (ptype) : ptype);
      GFC_TYPE_ARRAY_BASE_DECL (type, indirect) = base_decl;
    }
  info->base_decl = base_decl;
  if (indirect)
    base_decl = build1 (INDIRECT_REF, ptype, base_decl);

  gfc_get_descriptor_offsets_for_info (type, &data_off, &dtype_off, &span_off,
				       &dim_off, &dim_size, &stride_suboff,
				       &lower_suboff, &upper_suboff);

  t = fold_build_pointer_plus (base_decl, span_off);
  elem_size = build1 (INDIRECT_REF, gfc_array_index_type, t);

  t = base_decl;
  if (!integer_zerop (data_off))
    t = fold_build_pointer_plus (t, data_off);
  t = build1 (NOP_EXPR, build_pointer_type (ptr_type_node), t);
  info->data_location = build1 (INDIRECT_REF, ptr_type_node, t);
  enum gfc_array_kind akind = GFC_TYPE_ARRAY_AKIND (type);
  if (akind == GFC_ARRAY_ALLOCATABLE
      || akind == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE)
    info->allocated = build2 (NE_EXPR, logical_type_node,
			      info->data_location, null_pointer_node);
  else if (akind == GFC_ARRAY_POINTER
	   || akind == GFC_ARRAY_POINTER_CONT
	   || akind == GFC_ARRAY_ASSUMED_RANK_POINTER
	   || akind == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT)
    info->associated = build2 (NE_EXPR, logical_type_node,
			       info->data_location, null_pointer_node);
  if ((akind == GFC_ARRAY_ASSUMED_RANK
       || akind == GFC_ARRAY_ASSUMED_RANK_CONT
       || akind == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
       || akind == GFC_ARRAY_ASSUMED_RANK_POINTER
       || akind == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT)
      && dwarf_version >= 5)
    {
      rank = 1;
      info->ndimensions = 1;
      t = fold_build_pointer_plus (base_decl, dtype_off);
      dtype = TYPE_MAIN_VARIANT (get_dtype_type_node ());
      field = gfc_advance_chain (TYPE_FIELDS (dtype), GFC_DTYPE_RANK);
      rank_off = byte_position (field);
      t = fold_build_pointer_plus (t, rank_off);

      t = build1 (NOP_EXPR, build_pointer_type (TREE_TYPE (field)), t);
      t = build1 (INDIRECT_REF, TREE_TYPE (field), t);
      info->rank = t;
      t = build0 (PLACEHOLDER_EXPR, TREE_TYPE (dim_off));
      t = size_binop (MULT_EXPR, t, dim_size);
      dim_off = build2 (PLUS_EXPR, TREE_TYPE (dim_off), t, dim_off);
    }

  for (dim = 0; dim < rank; dim++)
    {
      t = fold_build_pointer_plus (base_decl,
				   size_binop (PLUS_EXPR,
					       dim_off, lower_suboff));
      t = build1 (INDIRECT_REF, gfc_array_index_type, t);
      info->dimen[dim].lower_bound = t;
      t = fold_build_pointer_plus (base_decl,
				   size_binop (PLUS_EXPR,
					       dim_off, upper_suboff));
      t = build1 (INDIRECT_REF, gfc_array_index_type, t);
      info->dimen[dim].upper_bound = t;
      if (akind == GFC_ARRAY_ASSUMED_SHAPE
	  || akind == GFC_ARRAY_ASSUMED_SHAPE_CONT)
	{
	  /* Assumed shape arrays have known lower bounds.  */
	  info->dimen[dim].upper_bound
	    = build2 (MINUS_EXPR, gfc_array_index_type,
		      info->dimen[dim].upper_bound,
		      info->dimen[dim].lower_bound);
	  info->dimen[dim].lower_bound
	    = fold_convert (gfc_array_index_type,
			    GFC_TYPE_ARRAY_LBOUND (type, dim));
	  info->dimen[dim].upper_bound
	    = build2 (PLUS_EXPR, gfc_array_index_type,
		      info->dimen[dim].lower_bound,
		      info->dimen[dim].upper_bound);
	}
      t = fold_build_pointer_plus (base_decl,
				   size_binop (PLUS_EXPR,
					       dim_off, stride_suboff));
      t = build1 (INDIRECT_REF, gfc_array_index_type, t);
      t = build2 (MULT_EXPR, gfc_array_index_type, t, elem_size);
      info->dimen[dim].stride = t;
      if (dim + 1 < rank)
	dim_off = size_binop (PLUS_EXPR, dim_off, dim_size);
    }

  return true;
}


/* Create a type to handle vector subscripts for coarray library calls. It
   has the form:
     struct caf_vector_t {
       size_t nvec;  // size of the vector
       union {
         struct {
           void *vector;
           int kind;
         } v;
         struct {
           ptrdiff_t lower_bound;
           ptrdiff_t upper_bound;
           ptrdiff_t stride;
         } triplet;
       } u;
     }
   where nvec == 0 for DIMEN_ELEMENT or DIMEN_RANGE and nvec being the vector
   size in case of DIMEN_VECTOR, where kind is the integer type of the vector.  */

tree
gfc_get_caf_vector_type (int dim)
{
  static tree vector_types[GFC_MAX_DIMENSIONS];
  static tree vec_type = NULL_TREE;
  tree triplet_struct_type, vect_struct_type, union_type, tmp, *chain;

  if (vector_types[dim-1] != NULL_TREE)
    return vector_types[dim-1];

  if (vec_type == NULL_TREE)
    {
      chain = 0;
      vect_struct_type = make_node (RECORD_TYPE);
      tmp = gfc_add_field_to_struct_1 (vect_struct_type,
				       get_identifier ("vector"),
				       pvoid_type_node, &chain);
      suppress_warning (tmp);
      tmp = gfc_add_field_to_struct_1 (vect_struct_type,
				       get_identifier ("kind"),
				       integer_type_node, &chain);
      suppress_warning (tmp);
      gfc_finish_type (vect_struct_type);

      chain = 0;
      triplet_struct_type = make_node (RECORD_TYPE);
      tmp = gfc_add_field_to_struct_1 (triplet_struct_type,
				       get_identifier ("lower_bound"),
				       gfc_array_index_type, &chain);
      suppress_warning (tmp);
      tmp = gfc_add_field_to_struct_1 (triplet_struct_type,
				       get_identifier ("upper_bound"),
				       gfc_array_index_type, &chain);
      suppress_warning (tmp);
      tmp = gfc_add_field_to_struct_1 (triplet_struct_type, get_identifier ("stride"),
				       gfc_array_index_type, &chain);
      suppress_warning (tmp);
      gfc_finish_type (triplet_struct_type);

      chain = 0;
      union_type = make_node (UNION_TYPE);
      tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("v"),
                                       vect_struct_type, &chain);
      suppress_warning (tmp);
      tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("triplet"),
				       triplet_struct_type, &chain);
      suppress_warning (tmp);
      gfc_finish_type (union_type);

      chain = 0;
      vec_type = make_node (RECORD_TYPE);
      tmp = gfc_add_field_to_struct_1 (vec_type, get_identifier ("nvec"),
				       size_type_node, &chain);
      suppress_warning (tmp);
      tmp = gfc_add_field_to_struct_1 (vec_type, get_identifier ("u"),
				       union_type, &chain);
      suppress_warning (tmp);
      gfc_finish_type (vec_type);
      TYPE_NAME (vec_type) = get_identifier ("caf_vector_t");
    }

  tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
			  gfc_rank_cst[dim-1]);
  vector_types[dim-1] = build_array_type (vec_type, tmp);
  return vector_types[dim-1];
}


tree
gfc_get_caf_reference_type ()
{
  static tree reference_type = NULL_TREE;
  tree c_struct_type, s_struct_type, v_struct_type, union_type, dim_union_type,
      a_struct_type, u_union_type, tmp, *chain;

  if (reference_type != NULL_TREE)
    return reference_type;

  chain = 0;
  c_struct_type = make_node (RECORD_TYPE);
  tmp = gfc_add_field_to_struct_1 (c_struct_type,
				   get_identifier ("offset"),
				   gfc_array_index_type, &chain);
  suppress_warning (tmp);
  tmp = gfc_add_field_to_struct_1 (c_struct_type,
				   get_identifier ("caf_token_offset"),
				   gfc_array_index_type, &chain);
  suppress_warning (tmp);
  gfc_finish_type (c_struct_type);

  chain = 0;
  s_struct_type = make_node (RECORD_TYPE);
  tmp = gfc_add_field_to_struct_1 (s_struct_type,
				   get_identifier ("start"),
				   gfc_array_index_type, &chain);
  suppress_warning (tmp);
  tmp = gfc_add_field_to_struct_1 (s_struct_type,
				   get_identifier ("end"),
				   gfc_array_index_type, &chain);
  suppress_warning (tmp);
  tmp = gfc_add_field_to_struct_1 (s_struct_type,
				   get_identifier ("stride"),
				   gfc_array_index_type, &chain);
  suppress_warning (tmp);
  gfc_finish_type (s_struct_type);

  chain = 0;
  v_struct_type = make_node (RECORD_TYPE);
  tmp = gfc_add_field_to_struct_1 (v_struct_type,
				   get_identifier ("vector"),
				   pvoid_type_node, &chain);
  suppress_warning (tmp);
  tmp = gfc_add_field_to_struct_1 (v_struct_type,
				   get_identifier ("nvec"),
				   size_type_node, &chain);
  suppress_warning (tmp);
  tmp = gfc_add_field_to_struct_1 (v_struct_type,
				   get_identifier ("kind"),
				   integer_type_node, &chain);
  suppress_warning (tmp);
  gfc_finish_type (v_struct_type);

  chain = 0;
  union_type = make_node (UNION_TYPE);
  tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("s"),
				   s_struct_type, &chain);
  suppress_warning (tmp);
  tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("v"),
				   v_struct_type, &chain);
  suppress_warning (tmp);
  gfc_finish_type (union_type);

  tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
			  gfc_rank_cst[GFC_MAX_DIMENSIONS - 1]);
  dim_union_type = build_array_type (union_type, tmp);

  chain = 0;
  a_struct_type = make_node (RECORD_TYPE);
  tmp = gfc_add_field_to_struct_1 (a_struct_type, get_identifier ("mode"),
		build_array_type (unsigned_char_type_node,
				  build_range_type (gfc_array_index_type,
						    gfc_index_zero_node,
					 gfc_rank_cst[GFC_MAX_DIMENSIONS - 1])),
		&chain);
  suppress_warning (tmp);
  tmp = gfc_add_field_to_struct_1 (a_struct_type,
				   get_identifier ("static_array_type"),
				   integer_type_node, &chain);
  suppress_warning (tmp);
  tmp = gfc_add_field_to_struct_1 (a_struct_type, get_identifier ("dim"),
				   dim_union_type, &chain);
  suppress_warning (tmp);
  gfc_finish_type (a_struct_type);

  chain = 0;
  u_union_type = make_node (UNION_TYPE);
  tmp = gfc_add_field_to_struct_1 (u_union_type, get_identifier ("c"),
				   c_struct_type, &chain);
  suppress_warning (tmp);
  tmp = gfc_add_field_to_struct_1 (u_union_type, get_identifier ("a"),
				   a_struct_type, &chain);
  suppress_warning (tmp);
  gfc_finish_type (u_union_type);

  chain = 0;
  reference_type = make_node (RECORD_TYPE);
  tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("next"),
				   build_pointer_type (reference_type), &chain);
  suppress_warning (tmp);
  tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("type"),
				   integer_type_node, &chain);
  suppress_warning (tmp);
  tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("item_size"),
				   size_type_node, &chain);
  suppress_warning (tmp);
  tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("u"),
				   u_union_type, &chain);
  suppress_warning (tmp);
  gfc_finish_type (reference_type);
  TYPE_NAME (reference_type) = get_identifier ("caf_reference_t");

  return reference_type;
}

static tree
gfc_get_cfi_dim_type ()
{
  static tree CFI_dim_t = NULL;

  if (CFI_dim_t)
    return CFI_dim_t;

  CFI_dim_t = make_node (RECORD_TYPE);
  TYPE_NAME (CFI_dim_t) = get_identifier ("CFI_dim_t");
  TYPE_NAMELESS (CFI_dim_t) = 1;
  tree field;
  tree *chain = NULL;
  field = gfc_add_field_to_struct_1 (CFI_dim_t, get_identifier ("lower_bound"),
				     gfc_array_index_type, &chain);
  suppress_warning (field);
  field = gfc_add_field_to_struct_1 (CFI_dim_t, get_identifier ("extent"),
				     gfc_array_index_type, &chain);
  suppress_warning (field);
  field = gfc_add_field_to_struct_1 (CFI_dim_t, get_identifier ("sm"),
				     gfc_array_index_type, &chain);
  suppress_warning (field);
  gfc_finish_type (CFI_dim_t);
  TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (CFI_dim_t)) = 1;
  return CFI_dim_t;
}


/* Return the CFI type; use dimen == -1 for dim[] (only for pointers);
   otherwise dim[dimen] is used.  */

tree
gfc_get_cfi_type (int dimen, bool restricted)
{
  gcc_assert (dimen >= -1 && dimen <= CFI_MAX_RANK);

  int idx = 2*(dimen + 1) + restricted;

  if (gfc_cfi_descriptor_base[idx])
    return gfc_cfi_descriptor_base[idx];

  /* Build the type node.  */
  tree CFI_cdesc_t = make_node (RECORD_TYPE);
  char name[GFC_MAX_SYMBOL_LEN + 1];
  if (dimen != -1)
    sprintf (name, "CFI_cdesc_t" GFC_RANK_PRINTF_FORMAT, dimen);
  TYPE_NAME (CFI_cdesc_t) = get_identifier (dimen < 0 ? "CFI_cdesc_t" : name);
  TYPE_NAMELESS (CFI_cdesc_t) = 1;

  tree field;
  tree *chain = NULL;
  field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("base_addr"),
				     (restricted ? prvoid_type_node
						 : ptr_type_node), &chain);
  suppress_warning (field);
  field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("elem_len"),
				     size_type_node, &chain);
  suppress_warning (field);
  field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("version"),
				     integer_type_node, &chain);
  suppress_warning (field);
  field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("rank"),
				     signed_char_type_node, &chain);
  suppress_warning (field);
  field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("attribute"),
				     signed_char_type_node, &chain);
  suppress_warning (field);
  field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("type"),
				     get_typenode_from_name (INT16_TYPE),
				     &chain);
  suppress_warning (field);

  if (dimen != 0)
    {
      tree range = NULL_TREE;
      if (dimen > 0)
	range = gfc_rank_cst[dimen - 1];
      range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
				range);
      tree CFI_dim_t = build_array_type (gfc_get_cfi_dim_type (), range);
      field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("dim"),
					 CFI_dim_t, &chain);
      suppress_warning (field);
    }

  TYPE_TYPELESS_STORAGE (CFI_cdesc_t) = 1;
  gfc_finish_type (CFI_cdesc_t);
  gfc_cfi_descriptor_base[idx] = CFI_cdesc_t;
  return CFI_cdesc_t;
}

#include "gt-fortran-trans-types.h"