2010-03-17 Tobias Burnus <burnus@net-b.de>

[pf3gnuchains/gcc-fork.git] / gcc / fortran / trans-types.c

diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 5202539..ebe4c2f 100644 (file)
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1,6 +1,6 @@
 /* Backend support for Fortran 95 basic types and derived types.
 /* Backend support for Fortran 95 basic types and derived types.

-   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
-   Foundation, Inc.
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+   Free Software Foundation, Inc.

    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
 
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
 


@@ -37,6 +37,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "trans-const.h"
 #include "real.h"
 #include "flags.h"
 #include "trans-const.h"
 #include "real.h"
 #include "flags.h"

+#include "dwarf2out.h"

 \f
 
 #if (GFC_MAX_DIMENSIONS < 10)
 \f
 
 #if (GFC_MAX_DIMENSIONS < 10)


@@ -52,12 +53,11 @@ along with GCC; see the file COPYING3.  If not see
 /* array of structs so we don't have to worry about xmalloc or free */
 CInteropKind_t c_interop_kinds_table[ISOCBINDING_NUMBER];
 
 /* array of structs so we don't have to worry about xmalloc or free */
 CInteropKind_t c_interop_kinds_table[ISOCBINDING_NUMBER];
 

-static tree gfc_get_derived_type (gfc_symbol * derived);
-

 tree gfc_array_index_type;
 tree gfc_array_range_type;
 tree gfc_character1_type_node;
 tree pvoid_type_node;
 tree 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;
 tree pfunc_type_node;
 tree ppvoid_type_node;
 tree pchar_type_node;
 tree pfunc_type_node;


@@ -66,7 +66,7 @@ tree gfc_charlen_type_node;
 
 static GTY(()) tree gfc_desc_dim_type;
 static GTY(()) tree gfc_max_array_element_size;
 
 static GTY(()) tree gfc_desc_dim_type;
 static GTY(()) tree gfc_max_array_element_size;

-static GTY(()) tree gfc_array_descriptor_base[GFC_MAX_DIMENSIONS];
+static GTY(()) tree gfc_array_descriptor_base[2 * GFC_MAX_DIMENSIONS];

 
 /* Arrays for all integral and real kinds.  We'll fill this in at runtime
    after the target has a chance to process command-line options.  */
 
 /* 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.  */


@@ -82,6 +82,11 @@ 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];
 
 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];
+

 
 /* The integer kind to use for array indices.  This will be set to the
    proper value based on target information from the backend.  */
 
 /* The integer kind to use for array indices.  This will be set to the
    proper value based on target information from the backend.  */


@@ -111,21 +116,7 @@ int gfc_numeric_storage_size;
 int gfc_character_storage_size;
 
 
 int gfc_character_storage_size;
 
 

-/* Validate that the f90_type of the given gfc_typespec is valid for
-   the type it represents.  The f90_type represents the Fortran types
-   this C kind can be used with.  For example, c_int has a f90_type of
-   BT_INTEGER and c_float has a f90_type of BT_REAL.  Returns FAILURE
-   if a mismatch occurs between ts->f90_type and ts->type; SUCCESS if
-   they match.  */
-
-try
-gfc_validate_c_kind (gfc_typespec *ts)
-{
-   return ((ts->type == ts->f90_type) ? SUCCESS : FAILURE);
-}
-
-
-try
+gfc_try

 gfc_check_any_c_kind (gfc_typespec *ts)
 {
   int i;
 gfc_check_any_c_kind (gfc_typespec *ts)
 {
   int i;


@@ -171,6 +162,96 @@ get_int_kind_from_node (tree type)
   return -1;
 }
 
   return -1;
 }
 

+/* Return a typenode for the "standard" C type with a given name.  */
+static tree
+get_typenode_from_name (const char *name)
+{
+  if (name == NULL || *name == '\0')
+    return NULL_TREE;
+
+  if (strcmp (name, "char") == 0)
+    return char_type_node;
+  if (strcmp (name, "unsigned char") == 0)
+    return unsigned_char_type_node;
+  if (strcmp (name, "signed char") == 0)
+    return signed_char_type_node;
+
+  if (strcmp (name, "short int") == 0)
+    return short_integer_type_node;
+  if (strcmp (name, "short unsigned int") == 0)
+    return short_unsigned_type_node;
+
+  if (strcmp (name, "int") == 0)
+    return integer_type_node;
+  if (strcmp (name, "unsigned int") == 0)
+    return unsigned_type_node;
+
+  if (strcmp (name, "long int") == 0)
+    return long_integer_type_node;
+  if (strcmp (name, "long unsigned int") == 0)
+    return long_unsigned_type_node;
+
+  if (strcmp (name, "long long int") == 0)
+    return long_long_integer_type_node;
+  if (strcmp (name, "long long unsigned int") == 0)
+    return long_long_unsigned_type_node;
+
+  gcc_unreachable ();
+}
+
+static int
+get_int_kind_from_name (const char *name)
+{
+  return get_int_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;
+}
+
+/* Get the kind number corresponding to a real of given storage size,
+   following the required return values for ISO_FORTRAN_ENV REAL* constants:
+   -2 is returned if we support a kind of larger size, -1 otherwise.  */
+int
+gfc_get_real_kind_from_width_isofortranenv (int size)
+{
+  int i;
+
+  size /= 8;
+
+  /* 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)
+      return gfc_real_kinds[i].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)
+      return -2;
+
+  return -1;
+}
+
+
+

 static int
 get_int_kind_from_width (int size)
 {
 static int
 get_int_kind_from_width (int size)
 {


@@ -203,11 +284,6 @@ static
 void init_c_interop_kinds (void)
 {
   int i;
 void init_c_interop_kinds (void)
 {
   int i;

-  tree intmax_type_node = INT_TYPE_SIZE == LONG_LONG_TYPE_SIZE ?
-                         integer_type_node :
-                         (LONG_TYPE_SIZE == LONG_LONG_TYPE_SIZE ?
-                          long_integer_type_node :
-                          long_long_integer_type_node);

 
   /* init all pointers in the list to NULL */
   for (i = 0; i < ISOCBINDING_NUMBER; i++)
 
   /* init all pointers in the list to NULL */
   for (i = 0; i < ISOCBINDING_NUMBER; i++)


@@ -218,7 +294,7 @@ void init_c_interop_kinds (void)
       c_interop_kinds_table[i].f90_type = BT_UNKNOWN;
     }
 
       c_interop_kinds_table[i].f90_type = BT_UNKNOWN;
     }
 

-#define NAMED_INTCST(a,b,c) \
+#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;
   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;


@@ -260,8 +336,8 @@ void init_c_interop_kinds (void)
 void
 gfc_init_kinds (void)
 {
 void
 gfc_init_kinds (void)
 {

-  enum machine_mode mode;
-  int i_index, r_index;
+  unsigned int mode;
+  int i_index, r_index, kind;

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


@@ -269,7 +345,7 @@ gfc_init_kinds (void)
     {
       int kind, bitsize;
 
     {
       int kind, bitsize;
 

-      if (!targetm.scalar_mode_supported_p (mode))
+      if (!targetm.scalar_mode_supported_p ((enum machine_mode) mode))

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


@@ -317,12 +393,13 @@ gfc_init_kinds (void)
 
   for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++)
     {
 
   for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++)
     {

-      const struct real_format *fmt = REAL_MODE_FORMAT (mode);
+      const struct real_format *fmt =
+       REAL_MODE_FORMAT ((enum machine_mode) mode);

       int kind;
 
       if (fmt == NULL)
        continue;
       int kind;
 
       if (fmt == NULL)
        continue;

-      if (!targetm.scalar_mode_supported_p (mode))
+      if (!targetm.scalar_mode_supported_p ((enum machine_mode) mode))

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


@@ -355,7 +432,7 @@ gfc_init_kinds (void)
       if (kind == 16)
        saw_r16 = true;
 
       if (kind == 16)
        saw_r16 = true;
 

-      /* Careful we don't stumble a wierd internal 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);
       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);


@@ -387,7 +464,7 @@ gfc_init_kinds (void)
       gfc_default_integer_kind = 8;
 
       /* Even if the user specified that the default integer kind be 8,
       gfc_default_integer_kind = 8;
 
       /* Even if the user specified that the default integer kind be 8,

-         the numerica storage size isn't 64.  In this case, a warning will
+         the numeric storage size isn't 64.  In this case, a warning will

         be issued when NUMERIC_STORAGE_SIZE is used.  */
       gfc_numeric_storage_size = 4 * 8;
     }
         be issued when NUMERIC_STORAGE_SIZE is used.  */
       gfc_numeric_storage_size = 4 * 8;
     }


@@ -449,8 +526,27 @@ gfc_init_kinds (void)
   gfc_default_logical_kind = gfc_default_integer_kind;
   gfc_default_complex_kind = gfc_default_real_kind;
 
   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.  */
   /* Choose the smallest integer kind for our default character.  */

-  gfc_default_character_kind = gfc_integer_kinds[0].kind;
+  gfc_default_character_kind = gfc_character_kinds[0].kind;

   gfc_character_storage_size = gfc_default_character_kind * 8;
 
   /* Choose the integer kind the same size as "void*" for our index kind.  */
   gfc_character_storage_size = gfc_default_character_kind * 8;
 
   /* Choose the integer kind the same size as "void*" for our index kind.  */


@@ -504,7 +600,13 @@ validate_logical (int kind)
 static int
 validate_character (int kind)
 {
 static int
 validate_character (int kind)
 {

-  return kind == gfc_default_character_kind ? 0 : -1;
+  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
 }
 
 /* Validate a kind given a basic type.  The return value is the same


@@ -578,6 +680,24 @@ gfc_build_int_type (gfc_integer_info *info)
   return make_signed_type (mode_precision);
 }
 
   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_real_type (gfc_real_info *info)
 {
 static tree
 gfc_build_real_type (gfc_real_info *info)
 {


@@ -644,6 +764,7 @@ gfc_build_logical_type (gfc_logical_info *info)
   return new_type;
 }
 
   return new_type;
 }
 

+

 #if 0
 /* Return the bit size of the C "size_t".  */
 
 #if 0
 /* Return the bit size of the C "size_t".  */
 


@@ -681,11 +802,15 @@ gfc_init_types (void)
 
   /* Create and name the types.  */
 #define PUSH_TYPE(name, node) \
 
   /* Create and name the types.  */
 #define PUSH_TYPE(name, node) \

-  pushdecl (build_decl (TYPE_DECL, get_identifier (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]);
 
   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);
       gfc_integer_types[index] = type;
       snprintf (name_buf, sizeof(name_buf), "integer(kind=%d)",
                gfc_integer_kinds[index].kind);


@@ -716,9 +841,17 @@ gfc_init_types (void)
       PUSH_TYPE (name_buf, type);
     }
 
       PUSH_TYPE (name_buf, type);
     }
 

-  gfc_character1_type_node = build_type_variant (unsigned_char_type_node, 
-                                                0, 0);
-  PUSH_TYPE ("character(kind=1)", gfc_character1_type_node);
+  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];

 
   PUSH_TYPE ("byte", unsigned_char_type_node);
   PUSH_TYPE ("void", void_type_node);
 
   PUSH_TYPE ("byte", unsigned_char_type_node);
   PUSH_TYPE ("void", void_type_node);


@@ -732,6 +865,7 @@ gfc_init_types (void)
 #undef PUSH_TYPE
 
   pvoid_type_node = build_pointer_type (void_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
   ppvoid_type_node = build_pointer_type (pvoid_type_node);
   pchar_type_node = build_pointer_type (gfc_character1_type_node);
   pfunc_type_node


@@ -798,23 +932,43 @@ gfc_get_logical_type (int kind)
   int index = gfc_validate_kind (BT_LOGICAL, kind, true);
   return index < 0 ? 0 : gfc_logical_types[index];
 }
   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
 \f
 /* Create a character type with the given kind and length.  */
 
 tree

-gfc_get_character_type_len (int kind, tree len)
+gfc_get_character_type_len_for_eltype (tree eltype, tree len)

 {
   tree bounds, type;
 
 {
   tree bounds, type;
 

-  gfc_validate_kind (BT_CHARACTER, kind, false);
-

   bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len);
   bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len);

-  type = build_array_type (gfc_character1_type_node, bounds);
+  type = build_array_type (eltype, bounds);

   TYPE_STRING_FLAG (type) = 1;
 
   return type;
 }
 
   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.  */
 
 
 /* Get a type node for a character kind.  */
 


@@ -846,8 +1000,8 @@ gfc_typenode_for_spec (gfc_typespec * spec)
          C_FUNPTR to simple variables that get translated to (void *).  */
       if (spec->f90_type == BT_VOID)
        {
          C_FUNPTR to simple variables that get translated to (void *).  */
       if (spec->f90_type == BT_VOID)
        {

-         if (spec->derived
-             && spec->derived->intmod_sym_id == ISOCBINDING_PTR)
+         if (spec->u.derived
+             && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR)

            basetype = ptr_type_node;
          else
            basetype = pfunc_type_node;
            basetype = ptr_type_node;
          else
            basetype = pfunc_type_node;


@@ -869,21 +1023,22 @@ gfc_typenode_for_spec (gfc_typespec * spec)
       break;
 
     case BT_CHARACTER:
       break;
 
     case BT_CHARACTER:

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

       break;
 
     case BT_DERIVED:
       break;
 
     case BT_DERIVED:

-      basetype = gfc_get_derived_type (spec->derived);
+    case BT_CLASS:
+      basetype = gfc_get_derived_type (spec->u.derived);

 
       /* 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 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->derived->attr.is_iso_c)
+      if (spec->u.derived->attr.is_iso_c)

         {
         {

-          spec->type = spec->derived->ts.type;
-          spec->kind = spec->derived->ts.kind;
-          spec->f90_type = spec->derived->ts.f90_type;
+          spec->type = spec->u.derived->ts.type;
+          spec->kind = spec->u.derived->ts.kind;
+          spec->f90_type = spec->u.derived->ts.f90_type;

         }
       break;
     case BT_VOID:
         }
       break;
     case BT_VOID:


@@ -892,8 +1047,8 @@ gfc_typenode_for_spec (gfc_typespec * spec)
       basetype = ptr_type_node;
       if (spec->f90_type == BT_VOID)
        {
       basetype = ptr_type_node;
       if (spec->f90_type == BT_VOID)
        {

-         if (spec->derived
-             && spec->derived->intmod_sym_id == ISOCBINDING_PTR)
+         if (spec->u.derived
+             && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR)

            basetype = ptr_type_node;
          else
            basetype = pfunc_type_node;
            basetype = ptr_type_node;
          else
            basetype = pfunc_type_node;


@@ -988,8 +1143,8 @@ gfc_get_element_type (tree type)
    ARRAYS comment.
 
    The data component points to the first element in the array.  The
    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 (ie element
-   (0, 0 ...)).  This may be outsite the bounds of the array.
+   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]
 
    An element is accessed by
     data[offset + index0*stride0 + index1*stride1 + index2*stride2]


@@ -1001,7 +1156,7 @@ gfc_get_element_type (tree type)
    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 >
    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 stride02 would overflow.  This may
+   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.
 
    still work, but I haven't checked, and it relies on the overflow
    doing the right thing.
 


@@ -1038,7 +1193,7 @@ gfc_is_nodesc_array (gfc_symbol * sym)
   if (sym->attr.result || sym->attr.function)
     return 0;
 
   if (sym->attr.result || sym->attr.function)
     return 0;
 

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

 
   return 1;
 }
 
   return 1;
 }


@@ -1047,7 +1202,8 @@ gfc_is_nodesc_array (gfc_symbol * sym)
 /* Create an array descriptor type.  */
 
 static tree
 /* Create an array descriptor type.  */
 
 static tree

-gfc_build_array_type (tree type, gfc_array_spec * as)
+gfc_build_array_type (tree type, gfc_array_spec * as,
+                     enum gfc_array_kind akind, bool restricted)

 {
   tree lbound[GFC_MAX_DIMENSIONS];
   tree ubound[GFC_MAX_DIMENSIONS];
 {
   tree lbound[GFC_MAX_DIMENSIONS];
   tree ubound[GFC_MAX_DIMENSIONS];


@@ -1063,7 +1219,10 @@ gfc_build_array_type (tree type, gfc_array_spec * as)
       ubound[n] = gfc_conv_array_bound (as->upper[n]);
     }
 
       ubound[n] = gfc_conv_array_bound (as->upper[n]);
     }
 

-  return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0);
+  if (as->type == AS_ASSUMED_SHAPE)
+    akind = GFC_ARRAY_ASSUMED_SHAPE;
+  return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0, akind,
+                                   restricted);

 }
 \f
 /* Returns the struct descriptor_dimension type.  */
 }
 \f
 /* Returns the struct descriptor_dimension type.  */


@@ -1085,19 +1244,22 @@ gfc_get_desc_dim_type (void)
   TYPE_PACKED (type) = 1;
 
   /* Consists of the stride, lbound and ubound members.  */
   TYPE_PACKED (type) = 1;
 
   /* Consists of the stride, lbound and ubound members.  */

-  decl = build_decl (FIELD_DECL,
+  decl = build_decl (input_location,
+                    FIELD_DECL,

                     get_identifier ("stride"), gfc_array_index_type);
   DECL_CONTEXT (decl) = type;
   TREE_NO_WARNING (decl) = 1;
   fieldlist = decl;
 
                     get_identifier ("stride"), gfc_array_index_type);
   DECL_CONTEXT (decl) = type;
   TREE_NO_WARNING (decl) = 1;
   fieldlist = decl;
 

-  decl = build_decl (FIELD_DECL,
+  decl = build_decl (input_location,
+                    FIELD_DECL,

                     get_identifier ("lbound"), gfc_array_index_type);
   DECL_CONTEXT (decl) = type;
   TREE_NO_WARNING (decl) = 1;
   fieldlist = chainon (fieldlist, decl);
 
                     get_identifier ("lbound"), gfc_array_index_type);
   DECL_CONTEXT (decl) = type;
   TREE_NO_WARNING (decl) = 1;
   fieldlist = chainon (fieldlist, decl);
 

-  decl = build_decl (FIELD_DECL,
+  decl = build_decl (input_location,
+                    FIELD_DECL,

                     get_identifier ("ubound"), gfc_array_index_type);
   DECL_CONTEXT (decl) = type;
   TREE_NO_WARNING (decl) = 1;
                     get_identifier ("ubound"), gfc_array_index_type);
   DECL_CONTEXT (decl) = type;
   TREE_NO_WARNING (decl) = 1;


@@ -1205,7 +1367,8 @@ gfc_get_dtype (tree type)
    to the value of PACKED.  */
 
 tree
    to the value of PACKED.  */
 
 tree

-gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed)
+gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
+                          bool restricted)

 {
   tree range;
   tree type;
 {
   tree range;
   tree type;


@@ -1246,7 +1409,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed)
       if (expr->expr_type == EXPR_CONSTANT)
         {
           tmp = gfc_conv_mpz_to_tree (expr->value.integer,
       if (expr->expr_type == EXPR_CONSTANT)
         {
           tmp = gfc_conv_mpz_to_tree (expr->value.integer,

-                                  gfc_index_integer_kind);
+                                     gfc_index_integer_kind);

         }
       else
         {
         }
       else
         {


@@ -1314,6 +1477,10 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed)
   /* TODO: use main type if it is unbounded.  */
   GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
     build_pointer_type (build_array_type (etype, range));
   /* 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 (known_stride)
     {
 
   if (known_stride)
     {


@@ -1335,10 +1502,10 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed)
   mpz_clear (stride);
   mpz_clear (delta);
 
   mpz_clear (stride);
   mpz_clear (delta);
 

-  /* In debug info represent packed arrays as multi-dimensional
-     if they have rank > 1 and with proper bounds, instead of flat
-     arrays.  */
-  if (known_stride && write_symbols != NO_DEBUG)
+  /* 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;
 
     {
       tree gtype = etype, rtype, type_decl;
 


@@ -1349,7 +1516,8 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed)
                                    GFC_TYPE_ARRAY_UBOUND (type, n));
          gtype = build_array_type (gtype, rtype);
        }
                                    GFC_TYPE_ARRAY_UBOUND (type, n));
          gtype = build_array_type (gtype, rtype);
        }

-      TYPE_NAME (type) = type_decl = build_decl (TYPE_DECL, NULL, gtype);
+      TYPE_NAME (type) = type_decl = build_decl (input_location,
+                                                TYPE_DECL, NULL, gtype);

       DECL_ORIGINAL_TYPE (type_decl) = gtype;
     }
 
       DECL_ORIGINAL_TYPE (type_decl) = gtype;
     }
 


@@ -1358,6 +1526,8 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed)
       /* For dummy arrays and automatic (heap allocated) arrays we
         want a pointer to the array.  */
       type = build_pointer_type (type);
       /* 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));
     }
       GFC_ARRAY_TYPE_P (type) = 1;
       TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
     }


@@ -1367,14 +1537,15 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed)
 /* Return or create the base type for an array descriptor.  */
 
 static tree
 /* Return or create the base type for an array descriptor.  */
 
 static tree

-gfc_get_array_descriptor_base (int dimen)
+gfc_get_array_descriptor_base (int dimen, bool restricted)

 {
   tree fat_type, fieldlist, decl, arraytype;
   char name[16 + GFC_RANK_DIGITS + 1];
 {
   tree fat_type, fieldlist, decl, arraytype;
   char name[16 + GFC_RANK_DIGITS + 1];

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

 
   gcc_assert (dimen >= 1 && dimen <= GFC_MAX_DIMENSIONS);
 
   gcc_assert (dimen >= 1 && dimen <= GFC_MAX_DIMENSIONS);

-  if (gfc_array_descriptor_base[dimen - 1])
-    return gfc_array_descriptor_base[dimen - 1];
+  if (gfc_array_descriptor_base[idx])
+    return gfc_array_descriptor_base[idx];

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


@@ -1383,20 +1554,24 @@ gfc_get_array_descriptor_base (int dimen)
   TYPE_NAME (fat_type) = get_identifier (name);
 
   /* Add the data member as the first element of the descriptor.  */
   TYPE_NAME (fat_type) = get_identifier (name);
 
   /* Add the data member as the first element of the descriptor.  */

-  decl = build_decl (FIELD_DECL, get_identifier ("data"), ptr_type_node);
+  decl = build_decl (input_location,
+                    FIELD_DECL, get_identifier ("data"),
+                    restricted ? prvoid_type_node : ptr_type_node);

 
   DECL_CONTEXT (decl) = fat_type;
   fieldlist = decl;
 
   /* Add the base component.  */
 
   DECL_CONTEXT (decl) = fat_type;
   fieldlist = decl;
 
   /* Add the base component.  */

-  decl = build_decl (FIELD_DECL, get_identifier ("offset"),
+  decl = build_decl (input_location,
+                    FIELD_DECL, get_identifier ("offset"),

                     gfc_array_index_type);
   DECL_CONTEXT (decl) = fat_type;
   TREE_NO_WARNING (decl) = 1;
   fieldlist = chainon (fieldlist, decl);
 
   /* Add the dtype component.  */
                     gfc_array_index_type);
   DECL_CONTEXT (decl) = fat_type;
   TREE_NO_WARNING (decl) = 1;
   fieldlist = chainon (fieldlist, decl);
 
   /* Add the dtype component.  */

-  decl = build_decl (FIELD_DECL, get_identifier ("dtype"),
+  decl = build_decl (input_location,
+                    FIELD_DECL, get_identifier ("dtype"),

                     gfc_array_index_type);
   DECL_CONTEXT (decl) = fat_type;
   TREE_NO_WARNING (decl) = 1;
                     gfc_array_index_type);
   DECL_CONTEXT (decl) = fat_type;
   TREE_NO_WARNING (decl) = 1;


@@ -1409,7 +1584,8 @@ gfc_get_array_descriptor_base (int dimen)
                                        gfc_index_zero_node,
                                        gfc_rank_cst[dimen - 1]));
 
                                        gfc_index_zero_node,
                                        gfc_rank_cst[dimen - 1]));
 

-  decl = build_decl (FIELD_DECL, get_identifier ("dim"), arraytype);
+  decl = build_decl (input_location,
+                    FIELD_DECL, get_identifier ("dim"), arraytype);

   DECL_CONTEXT (decl) = fat_type;
   TREE_NO_WARNING (decl) = 1;
   fieldlist = chainon (fieldlist, decl);
   DECL_CONTEXT (decl) = fat_type;
   TREE_NO_WARNING (decl) = 1;
   fieldlist = chainon (fieldlist, decl);


@@ -1420,7 +1596,7 @@ gfc_get_array_descriptor_base (int dimen)
   gfc_finish_type (fat_type);
   TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1;
 
   gfc_finish_type (fat_type);
   TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1;
 

-  gfc_array_descriptor_base[dimen - 1] = fat_type;
+  gfc_array_descriptor_base[idx] = fat_type;

   return fat_type;
 }
 
   return fat_type;
 }
 


@@ -1428,25 +1604,31 @@ gfc_get_array_descriptor_base (int dimen)
 
 tree
 gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
 
 tree
 gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,

-                          tree * ubound, int packed)
+                          tree * ubound, int packed,
+                          enum gfc_array_kind akind, bool restricted)

 {
   char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
 {
   char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];

-  tree fat_type, base_type, arraytype, lower, upper, stride, tmp;
-  const char *typename;
+  tree fat_type, base_type, arraytype, lower, upper, stride, tmp, rtype;
+  const char *type_name;

   int n;
 
   int n;
 

-  base_type = gfc_get_array_descriptor_base (dimen);
-  fat_type = build_variant_type_copy (base_type);
+  base_type = gfc_get_array_descriptor_base (dimen, restricted);
+  fat_type = build_distinct_type_copy (base_type);
+  /* 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, false);
+  TYPE_CANONICAL (fat_type) = base_type;
+  TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type);

 
   tmp = TYPE_NAME (etype);
   if (tmp && TREE_CODE (tmp) == TYPE_DECL)
     tmp = DECL_NAME (tmp);
   if (tmp)
 
   tmp = TYPE_NAME (etype);
   if (tmp && TREE_CODE (tmp) == TYPE_DECL)
     tmp = DECL_NAME (tmp);
   if (tmp)

-    typename = IDENTIFIER_POINTER (tmp);
+    type_name = IDENTIFIER_POINTER (tmp);

   else
   else

-    typename = "unknown";
+    type_name = "unknown";

   sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen,
   sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen,

-          GFC_MAX_SYMBOL_LEN, typename);
+          GFC_MAX_SYMBOL_LEN, type_name);

   TYPE_NAME (fat_type) = get_identifier (name);
 
   GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
   TYPE_NAME (fat_type) = get_identifier (name);
 
   GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;


@@ -1455,6 +1637,7 @@ gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
 
   GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
   GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
 
   GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
   GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;

+  GFC_TYPE_ARRAY_AKIND (fat_type) = akind;

 
   /* Build an array descriptor record type.  */
   if (packed != 0)
 
   /* Build an array descriptor record type.  */
   if (packed != 0)


@@ -1505,13 +1688,30 @@ gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
   /* TODO: known offsets for descriptors.  */
   GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
 
   /* TODO: known offsets for descriptors.  */
   GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
 

-  /* We define data as an unknown size array. Much better than doing
-     pointer arithmetic.  */
-  arraytype =
-    build_array_type (etype, gfc_array_range_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,
+                                              integer_one_node, 0));
+  else
+    rtype = gfc_array_range_type;
+  arraytype = build_array_type (etype, rtype);

   arraytype = build_pointer_type (arraytype);
   arraytype = build_pointer_type (arraytype);

+  if (restricted)
+    arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT);

   GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
 
   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
   return fat_type;
 }
 \f


@@ -1539,6 +1739,17 @@ gfc_sym_type (gfc_symbol * sym)
 {
   tree type;
   int byref;
 {
   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;
 
   if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
     return void_type_node;


@@ -1549,13 +1760,22 @@ gfc_sym_type (gfc_symbol * sym)
   if (sym->backend_decl && !sym->attr.function)
     return TREE_TYPE (sym->backend_decl);
 
   if (sym->backend_decl && !sym->attr.function)
     return TREE_TYPE (sym->backend_decl);
 

-  type = gfc_typenode_for_spec (&sym->ts);
+  if (sym->ts.type == BT_CHARACTER
+      && ((sym->attr.function && sym->attr.is_bind_c)
+         || (sym->attr.result
+             && sym->ns->proc_name
+             && sym->ns->proc_name->attr.is_bind_c)))
+    type = gfc_character1_type_node;
+  else
+    type = gfc_typenode_for_spec (&sym->ts);

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

+  restricted = !sym->attr.target && !sym->attr.pointer
+               && !sym->attr.proc_pointer && !sym->attr.cray_pointee;

   if (sym->attr.dimension)
     {
       if (gfc_is_nodesc_array (sym))
   if (sym->attr.dimension)
     {
       if (gfc_is_nodesc_array (sym))


@@ -1564,18 +1784,24 @@ gfc_sym_type (gfc_symbol * sym)
             base type.  */
          if (sym->ts.type != BT_CHARACTER
              || !(sym->attr.dummy || sym->attr.function)
             base type.  */
          if (sym->ts.type != BT_CHARACTER
              || !(sym->attr.dummy || sym->attr.function)

-             || sym->ts.cl->backend_decl)
+             || sym->ts.u.cl->backend_decl)

            {
              type = gfc_get_nodesc_array_type (type, sym->as,
                                                byref ? PACKED_FULL
            {
              type = gfc_get_nodesc_array_type (type, sym->as,
                                                byref ? PACKED_FULL

-                                                     : PACKED_STATIC);
+                                                     : PACKED_STATIC,
+                                               restricted);

              byref = 0;
            }
         }
       else
              byref = 0;
            }
         }
       else

-      {
-       type = gfc_build_array_type (type, sym->as);
-    }
+       {
+         enum gfc_array_kind akind = GFC_ARRAY_UNKNOWN;
+         if (sym->attr.pointer)
+           akind = GFC_ARRAY_POINTER;
+         else if (sym->attr.allocatable)
+           akind = GFC_ARRAY_ALLOCATABLE;
+         type = gfc_build_array_type (type, sym->as, akind, restricted);
+       }

     }
   else
     {
     }
   else
     {


@@ -1595,7 +1821,11 @@ gfc_sym_type (gfc_symbol * sym)
       if (sym->attr.optional || sym->ns->proc_name->attr.entry_master)
        type = build_pointer_type (type);
       else
       if (sym->attr.optional || sym->ns->proc_name->attr.entry_master)
        type = build_pointer_type (type);
       else

-       type = build_reference_type (type);
+       {
+         type = build_reference_type (type);
+         if (restricted)
+           type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
+       }

     }
 
   return (type);
     }
 
   return (type);


@@ -1608,7 +1838,8 @@ gfc_finish_type (tree type)
 {
   tree decl;
 
 {
   tree decl;
 

-  decl = build_decl (TYPE_DECL, NULL_TREE, type);
+  decl = build_decl (input_location,
+                    TYPE_DECL, NULL_TREE, type);

   TYPE_STUB_DECL (type) = decl;
   layout_type (type);
   rest_of_type_compilation (type, 1);
   TYPE_STUB_DECL (type) = decl;
   layout_type (type);
   rest_of_type_compilation (type, 1);


@@ -1627,7 +1858,8 @@ gfc_add_field_to_struct (tree *fieldlist, tree context,
 {
   tree decl;
 
 {
   tree decl;
 

-  decl = build_decl (FIELD_DECL, name, type);
+  decl = build_decl (input_location,
+                    FIELD_DECL, name, type);

 
   DECL_CONTEXT (decl) = context;
   DECL_INITIAL (decl) = 0;
 
   DECL_CONTEXT (decl) = context;
   DECL_INITIAL (decl) = 0;


@@ -1645,7 +1877,8 @@ gfc_add_field_to_struct (tree *fieldlist, tree context,
    in 4.4.2 and resolved by gfc_compare_derived_types.  */
 
 static int
    in 4.4.2 and resolved by gfc_compare_derived_types.  */
 
 static int

-copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to)
+copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to,
+                      bool from_gsym)

 {
   gfc_component *to_cm;
   gfc_component *from_cm;
 {
   gfc_component *to_cm;
   gfc_component *from_cm;


@@ -1668,28 +1901,54 @@ copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to)
   for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
     {
       to_cm->backend_decl = from_cm->backend_decl;
   for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
     {
       to_cm->backend_decl = from_cm->backend_decl;

-      if (!from_cm->pointer && from_cm->ts.type == BT_DERIVED)
-       gfc_get_derived_type (to_cm->ts.derived);
+      if ((!from_cm->attr.pointer || from_gsym)
+             && from_cm->ts.type == BT_DERIVED)
+       gfc_get_derived_type (to_cm->ts.u.derived);

 
       else if (from_cm->ts.type == BT_CHARACTER)
 
       else if (from_cm->ts.type == BT_CHARACTER)

-       to_cm->ts.cl->backend_decl = from_cm->ts.cl->backend_decl;
+       to_cm->ts.u.cl->backend_decl = from_cm->ts.u.cl->backend_decl;

     }
 
   return 1;
 }
 
 
     }
 
   return 1;
 }
 
 

+/* Build a tree node for a procedure pointer component.  */
+
+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;
+
+  return build_pointer_type (build_function_type (t, NULL_TREE));
+}
+
+

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

-static tree
+tree

 gfc_get_derived_type (gfc_symbol * derived)
 {
   tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL;
 gfc_get_derived_type (gfc_symbol * derived)
 {
   tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL;

+  tree canonical = NULL_TREE;
+  bool got_canonical = false;

   gfc_component *c;
   gfc_dt_list *dt;
   gfc_component *c;
   gfc_dt_list *dt;

+  gfc_namespace *ns;
+  gfc_gsymbol *gsym;

 
   gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
 
 
   gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
 


@@ -1721,20 +1980,74 @@ gfc_get_derived_type (gfc_symbol * derived)
       
       return derived->backend_decl;
     }
       
       return derived->backend_decl;
     }

-  
+
+/* If use associated, use the module type for this one.  */
+  if (gfc_option.flag_whole_file
+       && derived->backend_decl == NULL
+       && derived->attr.use_assoc
+       && derived->module)
+    {
+      gsym =  gfc_find_gsymbol (gfc_gsym_root, derived->module);
+      if (gsym && gsym->ns && gsym->type == GSYM_MODULE)
+       {
+         gfc_symbol *s;
+         s = NULL;
+         gfc_find_symbol (derived->name, gsym->ns, 0, &s);
+         if (s && s->backend_decl)
+           {
+             copy_dt_decls_ifequal (s, derived, true);
+             goto copy_derived_types;
+           }
+       }
+    }
+
+  /* If a whole file compilation, the derived types from an earlier
+     namespace can be used as the the canonical type.  */
+  if (gfc_option.flag_whole_file
+       && derived->backend_decl == NULL
+       && !derived->attr.use_assoc
+       && gfc_global_ns_list)
+    {
+      for (ns = gfc_global_ns_list;
+          ns->translated && !got_canonical;
+          ns = ns->sibling)
+       {
+         dt = ns->derived_types;
+         for (; dt && !canonical; dt = dt->next)
+           {
+             copy_dt_decls_ifequal (dt->derived, derived, true);
+             if (derived->backend_decl)
+               got_canonical = true;
+           }
+       }
+    }
+
+  /* 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)
     {
   /* derived->backend_decl != 0 means we saw it before, but its
      components' backend_decl may have not been built.  */
   if (derived->backend_decl)
     {

-      /* Its components' backend_decl have been built.  */
-      if (TYPE_FIELDS (derived->backend_decl))
+      /* 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)
+           || derived->attr.proc_pointer_comp)

         return derived->backend_decl;
       else
         typenode = derived->backend_decl;
     }
   else
     {
         return 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);
       /* We see this derived type first time, so build the type node.  */
       typenode = make_node (RECORD_TYPE);
       TYPE_NAME (typenode) = get_identifier (derived->name);


@@ -1749,20 +2062,21 @@ gfc_get_derived_type (gfc_symbol * derived)
      will be built and so we can return the type.  */
   for (c = derived->components; c; c = c->next)
     {
      will be built and so we can return the type.  */
   for (c = derived->components; c; c = c->next)
     {

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

        continue;
 
        continue;
 

-      if (!c->pointer || c->ts.derived->backend_decl == NULL)
-       c->ts.derived->backend_decl = gfc_get_derived_type (c->ts.derived);
+      if ((!c->attr.pointer && !c->attr.proc_pointer)
+         || c->ts.u.derived->backend_decl == NULL)
+       c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived);

 
 

-      if (c->ts.derived && c->ts.derived->attr.is_iso_c)
+      if (c->ts.u.derived && 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.  */
         {
           /* 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.derived->ts.type;
-          c->ts.kind = c->ts.derived->ts.kind;
-          c->ts.f90_type = c->ts.derived->ts.f90_type;
+          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;
          if (c->initializer)
            {
              c->initializer->ts.type = c->ts.type;


@@ -1781,15 +2095,17 @@ gfc_get_derived_type (gfc_symbol * derived)
   fieldlist = NULL_TREE;
   for (c = derived->components; c; c = c->next)
     {
   fieldlist = NULL_TREE;
   for (c = derived->components; c; c = c->next)
     {

-      if (c->ts.type == BT_DERIVED)
-        field_type = c->ts.derived->backend_decl;
+      if (c->attr.proc_pointer)
+       field_type = gfc_get_ppc_type (c);
+      else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+        field_type = c->ts.u.derived->backend_decl;

       else
        {
          if (c->ts.type == BT_CHARACTER)
            {
              /* Evaluate the string length.  */
       else
        {
          if (c->ts.type == BT_CHARACTER)
            {
              /* Evaluate the string length.  */

-             gfc_conv_const_charlen (c->ts.cl);
-             gcc_assert (c->ts.cl->backend_decl);
+             gfc_conv_const_charlen (c->ts.u.cl);
+             gcc_assert (c->ts.u.cl->backend_decl);

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


@@ -1797,24 +2113,32 @@ gfc_get_derived_type (gfc_symbol * derived)
 
       /* This returns an array descriptor type.  Initialization may be
          required.  */
 
       /* This returns an array descriptor type.  Initialization may be
          required.  */

-      if (c->dimension)
+      if (c->attr.dimension && !c->attr.proc_pointer)

        {
        {

-         if (c->pointer || c->allocatable)
+         if (c->attr.pointer || c->attr.allocatable)

            {
            {

+             enum gfc_array_kind akind;
+             if (c->attr.pointer)
+               akind = GFC_ARRAY_POINTER;
+             else
+               akind = GFC_ARRAY_ALLOCATABLE;

              /* Pointers to arrays aren't actually pointer types.  The
                 descriptors are separate, but the data is common.  */
              /* Pointers to arrays aren't actually pointer types.  The
                 descriptors are separate, but the data is common.  */

-             field_type = gfc_build_array_type (field_type, c->as);
+             field_type = gfc_build_array_type (field_type, c->as, akind,
+                                                !c->attr.target
+                                                && !c->attr.pointer);

            }
          else
            field_type = gfc_get_nodesc_array_type (field_type, c->as,
            }
          else
            field_type = gfc_get_nodesc_array_type (field_type, c->as,

-                                                   PACKED_STATIC);
+                                                   PACKED_STATIC,
+                                                   !c->attr.target);

        }
        }

-      else if (c->pointer)
+      else if ((c->attr.pointer || c->attr.allocatable)
+              && !c->attr.proc_pointer)

        field_type = build_pointer_type (field_type);
 
       field = gfc_add_field_to_struct (&fieldlist, typenode,
        field_type = build_pointer_type (field_type);
 
       field = gfc_add_field_to_struct (&fieldlist, typenode,

-                                      get_identifier (c->name),
-                                      field_type);
+                                      get_identifier (c->name), field_type);

       if (c->loc.lb)
        gfc_set_decl_location (field, &c->loc);
       else if (derived->declared_at.lb)
       if (c->loc.lb)
        gfc_set_decl_location (field, &c->loc);
       else if (derived->declared_at.lb)


@@ -1830,15 +2154,30 @@ gfc_get_derived_type (gfc_symbol * derived)
   /* Now we have the final fieldlist.  Record it, then lay out the
      derived type, including the fields.  */
   TYPE_FIELDS (typenode) = fieldlist;
   /* Now we have the final fieldlist.  Record it, then lay out the
      derived type, including the fields.  */
   TYPE_FIELDS (typenode) = fieldlist;

+  if (canonical)
+    TYPE_CANONICAL (typenode) = canonical;

 
   gfc_finish_type (typenode);
   gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at);
 
   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;
 
 
   derived->backend_decl = typenode;
 

-    /* Add this backend_decl to all the other, equal derived types.  */
-    for (dt = gfc_derived_types; dt; dt = dt->next)
-      copy_dt_decls_ifequal (derived, dt->derived);
+copy_derived_types:
+
+  for (dt = gfc_derived_types; dt; dt = dt->next)
+    copy_dt_decls_ifequal (derived, dt->derived, false);

 
   return derived->backend_decl;
 }
 
   return derived->backend_decl;
 }


@@ -1853,7 +2192,11 @@ gfc_return_by_reference (gfc_symbol * sym)
   if (sym->attr.dimension)
     return 1;
 
   if (sym->attr.dimension)
     return 1;
 

-  if (sym->ts.type == BT_CHARACTER)
+  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.
     return 1;
 
   /* Possibly return complex numbers by reference for g77 compatibility.


@@ -1898,7 +2241,8 @@ gfc_get_mixed_entry_union (gfc_namespace *ns)
 
       if (el == el2)
        {
 
       if (el == el2)
        {

-         decl = build_decl (FIELD_DECL,
+         decl = build_decl (input_location,
+                            FIELD_DECL,

                             get_identifier (el->sym->result->name),
                             gfc_sym_type (el->sym->result));
          DECL_CONTEXT (decl) = type;
                             get_identifier (el->sym->result->name),
                             gfc_sym_type (el->sym->result));
          DECL_CONTEXT (decl) = type;


@@ -1942,17 +2286,17 @@ gfc_get_function_type (gfc_symbol * sym)
       typelist = gfc_chainon_list (typelist, gfc_array_index_type);
     }
 
       typelist = gfc_chainon_list (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))
     {
   /* Some functions we use an extra parameter for the return value.  */
   if (gfc_return_by_reference (sym))
     {

-      if (sym->result)
-       arg = sym->result;
-      else
-       arg = sym;
-
-      if (arg->ts.type == BT_CHARACTER)
-       gfc_conv_const_charlen (arg->ts.cl);
-

       type = gfc_sym_type (arg);
       if (arg->ts.type == BT_COMPLEX
          || arg->attr.dimension
       type = gfc_sym_type (arg);
       if (arg->ts.type == BT_COMPLEX
          || arg->attr.dimension


@@ -1973,7 +2317,7 @@ gfc_get_function_type (gfc_symbol * sym)
          /* Evaluate constant character lengths here so that they can be
             included in the type.  */
          if (arg->ts.type == BT_CHARACTER)
          /* 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.cl);
+           gfc_conv_const_charlen (arg->ts.u.cl);

 
          if (arg->attr.flavor == FL_PROCEDURE)
            {
 
          if (arg->attr.flavor == FL_PROCEDURE)
            {


@@ -1997,7 +2341,7 @@ gfc_get_function_type (gfc_symbol * sym)
             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.  */
             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.  */

-         if (arg->ts.type == BT_CHARACTER)
+         if (arg->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)

             nstr++;
          typelist = gfc_chainon_list (typelist, type);
        }
             nstr++;
          typelist = gfc_chainon_list (typelist, type);
        }


@@ -2035,6 +2379,20 @@ gfc_get_function_type (gfc_symbol * sym)
       type = gfc_typenode_for_spec (&sym->ts);
       sym->ts.kind = gfc_default_real_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);
 
   else
     type = gfc_sym_type (sym);
 


@@ -2062,7 +2420,7 @@ gfc_type_for_size (unsigned bits, int unsignedp)
        }
 
       /* Handle TImode as a special case because it is used by some backends
        }
 
       /* Handle TImode as a special case because it is used by some backends

-         (eg. ARM) even though it is not available for normal use.  */
+         (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;
 #if HOST_BITS_PER_WIDE_INT >= 64
       if (bits == TYPE_PRECISION (intTI_type_node))
        return intTI_type_node;


@@ -2121,4 +2479,128 @@ gfc_type_for_mode (enum machine_mode mode, int unsignedp)
   return NULL_TREE;
 }
 
   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, field, t, base_decl;
+  tree data_off, dim_off, dim_size, elem_size;
+  tree lower_suboff, upper_suboff, stride_suboff;
+
+  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) (sizeof (info->dimen) / sizeof (info->dimen[0])))
+    return false;
+
+  etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
+  gcc_assert (POINTER_TYPE_P (etype));
+  etype = TREE_TYPE (etype);
+  gcc_assert (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)
+    {
+      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->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_decl (input_location, VAR_DECL, NULL_TREE,
+                             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);
+
+  if (GFC_TYPE_ARRAY_SPAN (type))
+    elem_size = GFC_TYPE_ARRAY_SPAN (type);
+  else
+    elem_size = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (etype));
+  field = TYPE_FIELDS (TYPE_MAIN_VARIANT (type));
+  data_off = byte_position (field);
+  field = TREE_CHAIN (field);
+  field = TREE_CHAIN (field);
+  field = TREE_CHAIN (field);
+  dim_off = byte_position (field);
+  dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (field)));
+  field = TYPE_FIELDS (TREE_TYPE (TREE_TYPE (field)));
+  stride_suboff = byte_position (field);
+  field = TREE_CHAIN (field);
+  lower_suboff = byte_position (field);
+  field = TREE_CHAIN (field);
+  upper_suboff = byte_position (field);
+
+  t = base_decl;
+  if (!integer_zerop (data_off))
+    t = build2 (POINTER_PLUS_EXPR, ptype, t, data_off);
+  t = build1 (NOP_EXPR, build_pointer_type (ptr_type_node), t);
+  info->data_location = build1 (INDIRECT_REF, ptr_type_node, t);
+  if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
+    info->allocated = build2 (NE_EXPR, boolean_type_node,
+                             info->data_location, null_pointer_node);
+  else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER)
+    info->associated = build2 (NE_EXPR, boolean_type_node,
+                              info->data_location, null_pointer_node);
+
+  for (dim = 0; dim < rank; dim++)
+    {
+      t = build2 (POINTER_PLUS_EXPR, ptype, 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 = build2 (POINTER_PLUS_EXPR, ptype, 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 (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE)
+       {
+         /* 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 = build2 (POINTER_PLUS_EXPR, ptype, 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;
+      dim_off = size_binop (PLUS_EXPR, dim_off, dim_size);
+    }
+
+  return true;
+}
+

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