re PR fortran/22244 (dimension information is lost for multi-dimension array)

	PR fortran/22244
	* langhooks-def.h (LANG_HOOKS_GET_ARRAY_DESCR_INFO): Define.
	(LANG_HOOKS_FOR_TYPES_INITIALIZER): Add it.
	* langhooks.h (struct array_descr_info): Forward declaration.
	(struct lang_hooks_for_types): Add get_array_descr_info field.
	* dwarf2.h (DW_AT_bit_stride, DW_AT_byte_stride): New.
	(DW_AT_stride_size, DW_AT_stride): Keep around for Dwarf2
	compatibility.
	* dwarf2out.h (struct array_descr_info): New type.
	* dwarf2out.c (dwarf_attr_name): Rename DW_AT_stride to
	DW_AT_byte_stride and DW_AT_stride_size to DW_AT_bit_size.
	(descr_info_loc, add_descr_info_field, gen_descr_array_type_die):
	New functions.
	(gen_type_die_with_usage): Call lang_hooks.types.get_array_descr_info
	and gen_descr_array_type_die.

	* trans.h (struct array_descr_info): Forward declaration.
	(gfc_get_array_descr_info): New prototype.
	(enum gfc_array_kind): New type.
	(struct lang_type): Add akind field.
	(GFC_TYPE_ARRAY_AKIND): Define.
	* trans-types.c: Include dwarf2out.h.
	(gfc_build_array_type): Add akind argument.  Adjust
	gfc_get_array_type_bounds call.
	(gfc_get_nodesc_array_type): Include proper debug info even for
	assumed-size arrays.
	(gfc_get_array_type_bounds): Add akind argument, set
	GFC_TYPE_ARRAY_AKIND to it.
	(gfc_sym_type, gfc_get_derived_type): Adjust gfc_build_array_type
	callers.
	(gfc_get_array_descr_info): New function.
	* trans-array.c (gfc_trans_create_temp_array,
	gfc_conv_expr_descriptor): Adjust gfc_get_array_type_bounds
	callers.
	* trans-stmt.c (gfc_trans_pointer_assign_need_temp): Likewise.
	* trans-types.h (gfc_get_array_type_bounds): Adjust prototype.
	* Make-lang.in (fortran/trans-types.o): Depend on dwarf2out.h.
	* f95-lang.c (LANG_HOOKS_GET_ARRAY_DESCR_INFO): Define.

From-SVN: r130724

gcc/ChangeLog

+2007-12-09  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/22244
+	* langhooks-def.h (LANG_HOOKS_GET_ARRAY_DESCR_INFO): Define.
+	(LANG_HOOKS_FOR_TYPES_INITIALIZER): Add it.
+	* langhooks.h (struct array_descr_info): Forward declaration.
+	(struct lang_hooks_for_types): Add get_array_descr_info field.
+	* dwarf2.h (DW_AT_bit_stride, DW_AT_byte_stride): New.
+	(DW_AT_stride_size, DW_AT_stride): Keep around for Dwarf2
+	compatibility.
+	* dwarf2out.h (struct array_descr_info): New type.
+	* dwarf2out.c (dwarf_attr_name): Rename DW_AT_stride to
+	DW_AT_byte_stride and DW_AT_stride_size to DW_AT_bit_size.
+	(descr_info_loc, add_descr_info_field, gen_descr_array_type_die):
+	New functions.
+	(gen_type_die_with_usage): Call lang_hooks.types.get_array_descr_info
+	and gen_descr_array_type_die.
+
 2007-12-08  Richard Guenther  <rguenther@suse.de>
 
 	PR tree-optimization/34391

gcc/dwarf2.h

@@ -274,7 +274,8 @@ enum dwarf_attribute
     DW_AT_prototyped = 0x27,
     DW_AT_return_addr = 0x2a,
     DW_AT_start_scope = 0x2c,
-    DW_AT_stride_size = 0x2e,
+    DW_AT_bit_stride = 0x2e,
+    DW_AT_stride_size = DW_AT_bit_stride,
     DW_AT_upper_bound = 0x2f,
     DW_AT_abstract_origin = 0x31,
     DW_AT_accessibility = 0x32,
@@ -309,7 +310,8 @@ enum dwarf_attribute
     DW_AT_allocated     = 0x4e,
     DW_AT_associated    = 0x4f,
     DW_AT_data_location = 0x50,
-    DW_AT_stride        = 0x51,
+    DW_AT_byte_stride   = 0x51,
+    DW_AT_stride        = DW_AT_byte_stride,
     DW_AT_entry_pc      = 0x52,
     DW_AT_use_UTF8      = 0x53,
     DW_AT_extension     = 0x54,

gcc/dwarf2out.c

@@ -4263,6 +4263,7 @@ static tree member_declared_type (const_tree);
 static const char *decl_start_label (tree);
 #endif
 static void gen_array_type_die (tree, dw_die_ref);
+static void gen_descr_array_type_die (tree, struct array_descr_info *, dw_die_ref);
 #if 0
 static void gen_entry_point_die (tree, dw_die_ref);
 #endif
@@ -4669,8 +4670,8 @@ dwarf_attr_name (unsigned int attr)
       return "DW_AT_return_addr";
     case DW_AT_start_scope:
       return "DW_AT_start_scope";
-    case DW_AT_stride_size:
-      return "DW_AT_stride_size";
+    case DW_AT_bit_stride:
+      return "DW_AT_bit_stride";
     case DW_AT_upper_bound:
       return "DW_AT_upper_bound";
     case DW_AT_abstract_origin:
@@ -4738,8 +4739,8 @@ dwarf_attr_name (unsigned int attr)
       return "DW_AT_associated";
     case DW_AT_data_location:
       return "DW_AT_data_location";
-    case DW_AT_stride:
-      return "DW_AT_stride";
+    case DW_AT_byte_stride:
+      return "DW_AT_byte_stride";
     case DW_AT_entry_pc:
       return "DW_AT_entry_pc";
     case DW_AT_use_UTF8:
@@ -11675,6 +11676,163 @@ gen_array_type_die (tree type, dw_die_ref context_die)
     add_pubtype (type, array_die);
 }
 
+static dw_loc_descr_ref
+descr_info_loc (tree val, tree base_decl)
+{
+  HOST_WIDE_INT size;
+  dw_loc_descr_ref loc, loc2;
+  enum dwarf_location_atom op;
+
+  if (val == base_decl)
+    return new_loc_descr (DW_OP_push_object_address, 0, 0);
+
+  switch (TREE_CODE (val))
+    {
+    case NOP_EXPR:
+    case CONVERT_EXPR:
+      return descr_info_loc (TREE_OPERAND (val, 0), base_decl);
+    case INTEGER_CST:
+      if (host_integerp (val, 0))
+	return int_loc_descriptor (tree_low_cst (val, 0));
+      break;
+    case INDIRECT_REF:
+      size = int_size_in_bytes (TREE_TYPE (val));
+      if (size < 0)
+	break;
+      loc = descr_info_loc (TREE_OPERAND (val, 0), base_decl);
+      if (!loc)
+	break;
+      if (size == DWARF2_ADDR_SIZE)
+	add_loc_descr (&loc, new_loc_descr (DW_OP_deref, 0, 0));
+      else
+	add_loc_descr (&loc, new_loc_descr (DW_OP_deref_size, size, 0));
+      return loc;
+    case POINTER_PLUS_EXPR:
+    case PLUS_EXPR:
+      if (host_integerp (TREE_OPERAND (val, 1), 1)
+	  && (unsigned HOST_WIDE_INT) tree_low_cst (TREE_OPERAND (val, 1), 1)
+	     < 16384)
+	{
+	  loc = descr_info_loc (TREE_OPERAND (val, 0), base_decl);
+	  if (!loc)
+	    break;
+	  add_loc_descr (&loc,
+			 new_loc_descr (DW_OP_plus_uconst,
+					tree_low_cst (TREE_OPERAND (val, 1),
+						      1), 0));
+	}
+      else
+	{
+	  op = DW_OP_plus;
+	do_binop:
+	  loc = descr_info_loc (TREE_OPERAND (val, 0), base_decl);
+	  if (!loc)
+	    break;
+	  loc2 = descr_info_loc (TREE_OPERAND (val, 1), base_decl);
+	  if (!loc2)
+	    break;
+	  add_loc_descr (&loc, loc2);
+	  add_loc_descr (&loc2, new_loc_descr (op, 0, 0));
+	}
+      return loc;
+    case MINUS_EXPR:
+      op = DW_OP_minus;
+      goto do_binop;
+    case MULT_EXPR:
+      op = DW_OP_mul;
+      goto do_binop;
+    case EQ_EXPR:
+      op = DW_OP_eq;
+      goto do_binop;
+    case NE_EXPR:
+      op = DW_OP_ne;
+      goto do_binop;
+    default:
+      break;
+    }
+  return NULL;
+}
+
+static void
+add_descr_info_field (dw_die_ref die, enum dwarf_attribute attr,
+		      tree val, tree base_decl)
+{
+  dw_loc_descr_ref loc;
+
+  if (host_integerp (val, 0))
+    {
+      add_AT_unsigned (die, attr, tree_low_cst (val, 0));
+      return;
+    }
+
+  loc = descr_info_loc (val, base_decl);
+  if (!loc)
+    return;
+
+  add_AT_loc (die, attr, loc);
+}
+
+/* This routine generates DIE for array with hidden descriptor, details
+   are filled into *info by a langhook.  */
+
+static void
+gen_descr_array_type_die (tree type, struct array_descr_info *info,
+			  dw_die_ref context_die)
+{
+  dw_die_ref scope_die = scope_die_for (type, context_die);
+  dw_die_ref array_die;
+  int dim;
+
+  array_die = new_die (DW_TAG_array_type, scope_die, type);
+  add_name_attribute (array_die, type_tag (type));
+  equate_type_number_to_die (type, array_die);
+
+  if (info->data_location)
+    add_descr_info_field (array_die, DW_AT_data_location, info->data_location,
+			  info->base_decl);
+  if (info->associated)
+    add_descr_info_field (array_die, DW_AT_associated, info->associated,
+			  info->base_decl);
+  if (info->allocated)
+    add_descr_info_field (array_die, DW_AT_allocated, info->allocated,
+			  info->base_decl);
+
+  for (dim = 0; dim < info->ndimensions; dim++)
+    {
+      dw_die_ref subrange_die
+	= new_die (DW_TAG_subrange_type, array_die, NULL);
+
+      if (info->dimen[dim].lower_bound)
+	{
+	  /* If it is the default value, omit it.  */
+	  if ((is_c_family () || is_java ())
+	      && integer_zerop (info->dimen[dim].lower_bound))
+	    ;
+	  else if (is_fortran ()
+		   && integer_onep (info->dimen[dim].lower_bound))
+	    ;
+	  else
+	    add_descr_info_field (subrange_die, DW_AT_lower_bound,
+				  info->dimen[dim].lower_bound,
+				  info->base_decl);
+	}
+      if (info->dimen[dim].upper_bound)
+	add_descr_info_field (subrange_die, DW_AT_upper_bound,
+			      info->dimen[dim].upper_bound,
+			      info->base_decl);
+      if (info->dimen[dim].stride)
+	add_descr_info_field (subrange_die, DW_AT_byte_stride,
+			      info->dimen[dim].stride,
+			      info->base_decl);
+    }
+
+  gen_type_die (info->element_type, context_die);
+  add_type_attribute (array_die, info->element_type, 0, 0, context_die);
+
+  if (get_AT (array_die, DW_AT_name))
+    add_pubtype (type, array_die);
+}
+
 #if 0
 static void
 gen_entry_point_die (tree decl, dw_die_ref context_die)
@@ -13051,6 +13209,7 @@ gen_type_die_with_usage (tree type, dw_die_ref context_die,
 				enum debug_info_usage usage)
 {
   int need_pop;
+  struct array_descr_info info;
 
   if (type == NULL_TREE || type == error_mark_node)
     return;
@@ -13069,6 +13228,16 @@ gen_type_die_with_usage (tree type, dw_die_ref context_die,
       return;
     }
 
+  /* If this is an array type with hidden descriptor, handle it first.  */
+  if (!TREE_ASM_WRITTEN (type)
+      && lang_hooks.types.get_array_descr_info
+      && lang_hooks.types.get_array_descr_info (type, &info))
+    {
+      gen_descr_array_type_die (type, &info, context_die);
+      TREE_ASM_WRITTEN (type) = 1;
+      return;
+    }
+
   /* We are going to output a DIE to represent the unqualified version
      of this type (i.e. without any const or volatile qualifiers) so
      get the main variant (i.e. the unqualified version) of this type

gcc/dwarf2out.h

@@ -25,3 +25,19 @@ extern void debug_dwarf (void);
 struct die_struct;
 extern void debug_dwarf_die (struct die_struct *);
 extern void dwarf2out_set_demangle_name_func (const char *(*) (const char *));
+
+struct array_descr_info
+{
+  int ndimensions;
+  tree element_type;
+  tree base_decl;
+  tree data_location;
+  tree allocated;
+  tree associated;
+  struct array_descr_dimen
+    {
+      tree lower_bound;
+      tree upper_bound;
+      tree stride;
+    } dimen[10];
+};

gcc/fortran/ChangeLog

+2007-12-09  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/22244
+	* trans.h (struct array_descr_info): Forward declaration.
+	(gfc_get_array_descr_info): New prototype.
+	(enum gfc_array_kind): New type.
+	(struct lang_type): Add akind field.
+	(GFC_TYPE_ARRAY_AKIND): Define.
+	* trans-types.c: Include dwarf2out.h.
+	(gfc_build_array_type): Add akind argument.  Adjust
+	gfc_get_array_type_bounds call.
+	(gfc_get_nodesc_array_type): Include proper debug info even for
+	assumed-size arrays.
+	(gfc_get_array_type_bounds): Add akind argument, set
+	GFC_TYPE_ARRAY_AKIND to it.
+	(gfc_sym_type, gfc_get_derived_type): Adjust gfc_build_array_type
+	callers.
+	(gfc_get_array_descr_info): New function.
+	* trans-array.c (gfc_trans_create_temp_array,
+	gfc_conv_expr_descriptor): Adjust gfc_get_array_type_bounds
+	callers.
+	* trans-stmt.c (gfc_trans_pointer_assign_need_temp): Likewise.
+	* trans-types.h (gfc_get_array_type_bounds): Adjust prototype.
+	* Make-lang.in (fortran/trans-types.o): Depend on dwarf2out.h.
+	* f95-lang.c (LANG_HOOKS_GET_ARRAY_DESCR_INFO): Define.
+
 2007-12-09  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/32129
@@ -19,7 +45,6 @@
 	PR fortran/34345
 	PR fortran/18026
 	PR fortran/29471
-
 	* gfortran.texi (BOZ literal constants): Improve documentation
 	and adapt for BOZ changes.
 	* Make-lang.ini (resolve.o): Add target-memory.h dependency.

gcc/fortran/Make-lang.in

@@ -312,7 +312,7 @@ fortran/trans-decl.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-decl.h \
   $(CGRAPH_H) $(TARGET_H) $(FUNCTION_H) $(FLAGS_H) $(RTL_H) $(TREE_GIMPLE_H) \
   $(TREE_DUMP_H)
 fortran/trans-types.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-types.h \
-  $(REAL_H) toplev.h $(TARGET_H) $(FLAGS_H)
+  $(REAL_H) toplev.h $(TARGET_H) $(FLAGS_H) dwarf2out.h
 fortran/trans-const.o: $(GFORTRAN_TRANS_DEPS)
 fortran/trans-expr.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h
 fortran/trans-stmt.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h

gcc/fortran/f95-lang.c

@@ -120,6 +120,7 @@ static alias_set_type gfc_get_alias_set (tree);
 #undef LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE
 #undef LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES
 #undef LANG_HOOKS_BUILTIN_FUNCTION
+#undef LANG_HOOKS_GET_ARRAY_DESCR_INFO
 
 /* Define lang hooks.  */
 #define LANG_HOOKS_NAME                 "GNU F95"
@@ -143,6 +144,7 @@ static alias_set_type gfc_get_alias_set (tree);
 #define LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES \
   gfc_omp_firstprivatize_type_sizes
 #define LANG_HOOKS_BUILTIN_FUNCTION          gfc_builtin_function
+#define LANG_HOOKS_GET_ARRAY_DESCR_INFO	     gfc_get_array_descr_info
 
 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
 

gcc/fortran/trans-array.c

@@ -608,7 +608,8 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
 
   /* Initialize the descriptor.  */
   type =
-    gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1);
+    gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1,
+			       GFC_ARRAY_UNKNOWN);
   desc = gfc_create_var (type, "atmp");
   GFC_DECL_PACKED_ARRAY (desc) = 1;
 
@@ -4783,7 +4784,8 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 	  /* Otherwise make a new one.  */
 	  parmtype = gfc_get_element_type (TREE_TYPE (desc));
 	  parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
-						loop.from, loop.to, 0);
+						loop.from, loop.to, 0,
+						GFC_ARRAY_UNKNOWN);
 	  parm = gfc_create_var (parmtype, "parm");
 	}
 

gcc/fortran/trans-stmt.c

@@ -2525,7 +2525,8 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
       /* Make a new descriptor.  */
       parmtype = gfc_get_element_type (TREE_TYPE (desc));
       parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
-                                            loop.from, loop.to, 1);
+                                            loop.from, loop.to, 1,
+					    GFC_ARRAY_UNKNOWN);
 
       /* Allocate temporary for nested forall construct.  */
       tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,

gcc/fortran/trans-types.c

@@ -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 "dwarf2out.h"
 
 
 #if (GFC_MAX_DIMENSIONS < 10)
@@ -1047,7 +1048,8 @@ gfc_is_nodesc_array (gfc_symbol * sym)
 /* 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)
 {
   tree lbound[GFC_MAX_DIMENSIONS];
   tree ubound[GFC_MAX_DIMENSIONS];
@@ -1063,7 +1065,9 @@ gfc_build_array_type (tree type, gfc_array_spec * as)
       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);
 }
 
 /* Returns the struct descriptor_dimension type.  */
@@ -1246,7 +1250,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,
-                                  gfc_index_integer_kind);
+				      gfc_index_integer_kind);
         }
       else
         {
@@ -1338,7 +1342,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed)
   /* 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)
+  if (known_offset && write_symbols != NO_DEBUG)
     {
       tree gtype = etype, rtype, type_decl;
 
@@ -1428,7 +1432,8 @@ gfc_get_array_descriptor_base (int dimen)
 
 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)
 {
   char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
   tree fat_type, base_type, arraytype, lower, upper, stride, tmp;
@@ -1455,6 +1460,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_AKIND (fat_type) = akind;
 
   /* Build an array descriptor record type.  */
   if (packed != 0)
@@ -1573,9 +1579,14 @@ gfc_sym_type (gfc_symbol * sym)
 	    }
         }
       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);
+	}
     }
   else
     {
@@ -1801,9 +1812,14 @@ gfc_get_derived_type (gfc_symbol * derived)
 	{
 	  if (c->pointer || c->allocatable)
 	    {
+	      enum gfc_array_kind akind;
+	      if (c->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.  */
-	      field_type = gfc_build_array_type (field_type, c->as);
+	      field_type = gfc_build_array_type (field_type, c->as, akind);
 	    }
 	  else
 	    field_type = gfc_get_nodesc_array_type (field_type, c->as,
@@ -2121,4 +2137,124 @@ gfc_type_for_mode (enum machine_mode mode, int unsignedp)
   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, offset_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);
+  if (indirect)
+    {
+      info->base_decl = build_decl (VAR_DECL, NULL_TREE,
+				    build_pointer_type (ptype));
+      base_decl = build1 (INDIRECT_REF, ptype, info->base_decl);
+    }
+  else
+    info->base_decl = base_decl = build_decl (VAR_DECL, NULL_TREE, ptype);
+
+  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);
+  offset_off = byte_position (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"

gcc/fortran/trans-types.h

@@ -67,7 +67,8 @@ tree gfc_type_for_size (unsigned, int);
 tree gfc_type_for_mode (enum machine_mode, int);
 
 tree gfc_get_element_type (tree);
-tree gfc_get_array_type_bounds (tree, int, tree *, tree *, int);
+tree gfc_get_array_type_bounds (tree, int, tree *, tree *, int,
+				enum gfc_array_kind);
 tree gfc_get_nodesc_array_type (tree, gfc_array_spec *, gfc_packed);
 
 /* Add a field of given name and type to a UNION_TYPE or RECORD_TYPE.  */

gcc/fortran/trans.h

@@ -483,6 +483,8 @@ tree poplevel (int, int, int);
 tree getdecls (void);
 tree gfc_truthvalue_conversion (tree);
 tree gfc_builtin_function (tree);
+struct array_descr_info;
+bool gfc_get_array_descr_info (const_tree, struct array_descr_info *);
 
 /* In trans-openmp.c */
 bool gfc_omp_privatize_by_reference (const_tree);
@@ -569,10 +571,19 @@ extern GTY(()) tree gfor_fndecl_sr_kind;
 
 /* G95-specific declaration information.  */
 
+enum gfc_array_kind
+{
+  GFC_ARRAY_UNKNOWN,
+  GFC_ARRAY_ASSUMED_SHAPE,
+  GFC_ARRAY_ALLOCATABLE,
+  GFC_ARRAY_POINTER
+};
+
 /* Array types only.  */
 struct lang_type		GTY(())
 {
   int rank;
+  enum gfc_array_kind akind;
   tree lbound[GFC_MAX_DIMENSIONS];
   tree ubound[GFC_MAX_DIMENSIONS];
   tree stride[GFC_MAX_DIMENSIONS];
@@ -626,7 +637,8 @@ struct lang_decl		GTY(())
 #define GFC_TYPE_ARRAY_RANK(node) (TYPE_LANG_SPECIFIC(node)->rank)
 #define GFC_TYPE_ARRAY_SIZE(node) (TYPE_LANG_SPECIFIC(node)->size)
 #define GFC_TYPE_ARRAY_OFFSET(node) (TYPE_LANG_SPECIFIC(node)->offset)
-/* Code should use gfc_get_dtype instead of accesig this directly.  It may
+#define GFC_TYPE_ARRAY_AKIND(node) (TYPE_LANG_SPECIFIC(node)->akind)
+/* Code should use gfc_get_dtype instead of accesing this directly.  It may
    not be known when the type is created.  */
 #define GFC_TYPE_ARRAY_DTYPE(node) (TYPE_LANG_SPECIFIC(node)->dtype)
 #define GFC_TYPE_ARRAY_DATAPTR_TYPE(node) \

gcc/langhooks-def.h

@@ -180,6 +180,7 @@ extern tree lhd_make_node (enum tree_code);
 #define LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES \
   lhd_omp_firstprivatize_type_sizes
 #define LANG_HOOKS_TYPE_HASH_EQ		NULL
+#define LANG_HOOKS_GET_ARRAY_DESCR_INFO	NULL
 #define LANG_HOOKS_HASH_TYPES		true
 
 #define LANG_HOOKS_FOR_TYPES_INITIALIZER { \
@@ -193,6 +194,7 @@ extern tree lhd_make_node (enum tree_code);
   LANG_HOOKS_TYPE_MAX_SIZE, \
   LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES, \
   LANG_HOOKS_TYPE_HASH_EQ, \
+  LANG_HOOKS_GET_ARRAY_DESCR_INFO, \
   LANG_HOOKS_HASH_TYPES \
 }
 

gcc/langhooks.h

@@ -28,6 +28,8 @@ struct diagnostic_info;
 
 struct gimplify_omp_ctx;
 
+struct array_descr_info;
+
 /* A print hook for print_tree ().  */
 typedef void (*lang_print_tree_hook) (FILE *, tree, int indent);
 
@@ -136,6 +138,10 @@ struct lang_hooks_for_types
      FUNCTION_TYPEs.  */
   bool (*type_hash_eq) (const_tree, const_tree);
 
+  /* Return TRUE if TYPE uses a hidden descriptor and fills in information
+     for the debugger about the array bounds, strides, etc.  */
+  bool (*get_array_descr_info) (const_tree, struct array_descr_info *);
+
   /* Nonzero if types that are identical are to be hashed so that only
      one copy is kept.  If a language requires unique types for each
      user-specified type, such as Ada, this should be set to TRUE.  */