[PATCH 00/23] Fortran dynamic array support

https://sourceware.org/ml/gdb-patches/2014-06/msg00108.html

https://github.com/intel-gdb/vla/tree/vla-fortran

GIT snapshot:

commit 511bff520372ffc10fa2ff569c176bdf1e6e475d

Index: gdb-7.10.50.20160106/gdb/c-valprint.c

===================================================================

--- gdb-7.10.50.20160106.orig/gdb/c-valprint.c	2016-01-08 19:15:35.065582359 +0100

+++ gdb-7.10.50.20160106/gdb/c-valprint.c	2016-01-08 19:15:44.974637630 +0100

@@ -642,7 +642,16 @@

 	{

 	  /* normal case */

 	  fprintf_filtered (stream, "(");

-	  type_print (value_type (val), "", stream, -1);

+	  if (is_dynamic_type (TYPE_TARGET_TYPE (type)))

+	    {

+	      struct value *v;

+

+	      v = value_ind (val);

+	      v = value_addr (v);

+	      type_print (value_type (v), "", stream, -1);

+	    }

+	  else

+	    type_print (value_type (val), "", stream, -1);

 	  fprintf_filtered (stream, ") ");

 	}

     }

Index: gdb-7.10.50.20160106/gdb/dwarf2loc.h

===================================================================

--- gdb-7.10.50.20160106.orig/gdb/dwarf2loc.h	2016-01-08 19:15:35.066582365 +0100

+++ gdb-7.10.50.20160106/gdb/dwarf2loc.h	2016-01-08 19:15:44.974637630 +0100

@@ -138,6 +138,11 @@

 			      struct property_addr_info *addr_stack,

 			      CORE_ADDR *value);

+/* Checks if a dwarf location definition is valid.

+   Returns 1 if valid; 0 otherwise.  */

+

+extern int dwarf2_address_data_valid (const struct type *type);

+

 /* A helper for the compiler interface that compiles a single dynamic

    property to C code.

Index: gdb-7.10.50.20160106/gdb/dwarf2read.c

===================================================================

--- gdb-7.10.50.20160106.orig/gdb/dwarf2read.c	2016-01-08 19:15:35.078582432 +0100

+++ gdb-7.10.50.20160106/gdb/dwarf2read.c	2016-01-08 19:15:44.980637663 +0100

@@ -1745,7 +1745,9 @@

 static int attr_to_dynamic_prop (const struct attribute *attr,

 				 struct die_info *die, struct dwarf2_cu *cu,

-				 struct dynamic_prop *prop);

+				 struct dynamic_prop *prop,

+				 const gdb_byte *additional_data,

+				 int additional_data_size);

 /* memory allocation interface */

@@ -11420,7 +11422,7 @@

     {

       newobj->static_link

 	= XOBNEW (&objfile->objfile_obstack, struct dynamic_prop);

-      attr_to_dynamic_prop (attr, die, cu, newobj->static_link);

+      attr_to_dynamic_prop (attr, die, cu, newobj->static_link, NULL, 0);

     }

   cu->list_in_scope = &local_symbols;

@@ -14471,29 +14473,92 @@

   struct gdbarch *gdbarch = get_objfile_arch (objfile);

   struct type *type, *range_type, *index_type, *char_type;

   struct attribute *attr;

-  unsigned int length;

+  unsigned int length = UINT_MAX;

+  index_type = objfile_type (objfile)->builtin_int;

+  range_type = create_static_range_type (NULL, index_type, 1, length);

+

+  /* If DW_AT_string_length is defined, the length is stored at some location

+   * in memory. */

   attr = dwarf2_attr (die, DW_AT_string_length, cu);

   if (attr)

     {

-      length = DW_UNSND (attr);

+      if (attr_form_is_block (attr))

+        {

+          struct attribute *byte_size, *bit_size;

+          struct dynamic_prop high;

+

+          byte_size = dwarf2_attr (die, DW_AT_byte_size, cu);

+          bit_size = dwarf2_attr (die, DW_AT_bit_size, cu);

+

+          /* DW_AT_byte_size should never occur together in combination with

+             DW_AT_string_length.  */

+          if ((byte_size == NULL && bit_size != NULL) ||

+                  (byte_size != NULL && bit_size == NULL))

+            complaint (&symfile_complaints, _("DW_AT_byte_size AND "

+                      "DW_AT_bit_size found together at the same time."));

+

+          /* If DW_AT_string_length AND DW_AT_byte_size exist together, it

+             describes the number of bytes that should be read from the length

+             memory location.  */

+          if (byte_size != NULL && bit_size == NULL)

+            {

+              /* Build new dwarf2_locexpr_baton structure with additions to the

+                 data attribute, to reflect DWARF specialities to get address

+                 sizes.  */

+              const gdb_byte append_ops[] = {

+                /* DW_OP_deref_size: size of an address on the target machine

+                   (bytes), where the size will be specified by the next

+                   operand.  */

+                DW_OP_deref_size,

+                /* Operand for DW_OP_deref_size.  */

+                DW_UNSND (byte_size) };

+

+              if (!attr_to_dynamic_prop (attr, die, cu, &high,

+                      append_ops, ARRAY_SIZE (append_ops)))

+                complaint (&symfile_complaints,

+                        _("Could not parse DW_AT_byte_size"));

+            }

+          else if (bit_size != NULL && byte_size == NULL)

+            complaint (&symfile_complaints, _("DW_AT_string_length AND "

+                      "DW_AT_bit_size found but not supported yet."));

+          /* If DW_AT_string_length WITHOUT DW_AT_byte_size exist, the default

+             is the address size of the target machine.  */

+          else

+            {

+              const gdb_byte append_ops[] = { DW_OP_deref };

+

+              if (!attr_to_dynamic_prop (attr, die, cu, &high, append_ops,

+                      ARRAY_SIZE (append_ops)))

+                complaint (&symfile_complaints,

+                        _("Could not parse DW_AT_string_length"));

+            }

+

+          TYPE_RANGE_DATA (range_type)->high = high;

+        }

+      else

+        {

+          TYPE_HIGH_BOUND (range_type) = DW_UNSND (attr);

+          TYPE_HIGH_BOUND_KIND (range_type) = PROP_CONST;

+        }

     }

   else

     {

-      /* Check for the DW_AT_byte_size attribute.  */

+      /* Check for the DW_AT_byte_size attribute, which represents the length

+         in this case.  */

       attr = dwarf2_attr (die, DW_AT_byte_size, cu);

       if (attr)

         {

-          length = DW_UNSND (attr);

+          TYPE_HIGH_BOUND (range_type) = DW_UNSND (attr);

+          TYPE_HIGH_BOUND_KIND (range_type) = PROP_CONST;

         }

       else

         {

-          length = 1;

+          TYPE_HIGH_BOUND (range_type) = 1;

+          TYPE_HIGH_BOUND_KIND (range_type) = PROP_CONST;

         }

     }

-  index_type = objfile_type (objfile)->builtin_int;

-  range_type = create_static_range_type (NULL, index_type, 1, length);

   char_type = language_string_char_type (cu->language_defn, gdbarch);

   type = create_string_type (NULL, char_type, range_type);

@@ -14816,13 +14881,15 @@

   return set_die_type (die, type, cu);

 }

+

 /* Parse dwarf attribute if it's a block, reference or constant and put the

    resulting value of the attribute into struct bound_prop.

    Returns 1 if ATTR could be resolved into PROP, 0 otherwise.  */

 static int

 attr_to_dynamic_prop (const struct attribute *attr, struct die_info *die,

-		      struct dwarf2_cu *cu, struct dynamic_prop *prop)

+		      struct dwarf2_cu *cu, struct dynamic_prop *prop,

+		      const gdb_byte *additional_data, int additional_data_size)

 {

   struct dwarf2_property_baton *baton;

   struct obstack *obstack = &cu->objfile->objfile_obstack;

@@ -14835,8 +14902,25 @@

       baton = XOBNEW (obstack, struct dwarf2_property_baton);

       baton->referenced_type = NULL;

       baton->locexpr.per_cu = cu->per_cu;

-      baton->locexpr.size = DW_BLOCK (attr)->size;

-      baton->locexpr.data = DW_BLOCK (attr)->data;

+

+      if (additional_data != NULL && additional_data_size > 0)

+        {

+          gdb_byte *data;

+

+          data = obstack_alloc (&cu->objfile->objfile_obstack,

+                  DW_BLOCK (attr)->size + additional_data_size);

+          memcpy (data, DW_BLOCK (attr)->data, DW_BLOCK (attr)->size);

+          memcpy (data + DW_BLOCK (attr)->size,

+                  additional_data, additional_data_size);

+

+          baton->locexpr.data = data;

+          baton->locexpr.size = DW_BLOCK (attr)->size + additional_data_size;

+        }

+      else

+        {

+          baton->locexpr.data = DW_BLOCK (attr)->data;

+          baton->locexpr.size = DW_BLOCK (attr)->size;

+        }

       prop->data.baton = baton;

       prop->kind = PROP_LOCEXPR;

       gdb_assert (prop->data.baton != NULL);

@@ -14872,8 +14956,28 @@

 		baton = XOBNEW (obstack, struct dwarf2_property_baton);

 		baton->referenced_type = die_type (target_die, target_cu);

 		baton->locexpr.per_cu = cu->per_cu;

-		baton->locexpr.size = DW_BLOCK (target_attr)->size;

-		baton->locexpr.data = DW_BLOCK (target_attr)->data;

+

+		if (additional_data != NULL && additional_data_size > 0)

+		  {

+		    gdb_byte *data;

+

+		    data = obstack_alloc (&cu->objfile->objfile_obstack,

+			    DW_BLOCK (target_attr)->size + additional_data_size);

+		    memcpy (data, DW_BLOCK (target_attr)->data,

+			    DW_BLOCK (target_attr)->size);

+		    memcpy (data + DW_BLOCK (target_attr)->size,

+			    additional_data, additional_data_size);

+

+		    baton->locexpr.data = data;

+		    baton->locexpr.size = (DW_BLOCK (target_attr)->size

+					   + additional_data_size);

+		  }

+		else

+		  {

+		    baton->locexpr.data = DW_BLOCK (target_attr)->data;

+		    baton->locexpr.size = DW_BLOCK (target_attr)->size;

+		  }

+

 		prop->data.baton = baton;

 		prop->kind = PROP_LOCEXPR;

 		gdb_assert (prop->data.baton != NULL);

@@ -14927,7 +15031,7 @@

   struct type *base_type, *orig_base_type;

   struct type *range_type;

   struct attribute *attr;

-  struct dynamic_prop low, high;

+  struct dynamic_prop low, high, stride;

   int low_default_is_valid;

   int high_bound_is_count = 0;

   const char *name;

@@ -14947,7 +15051,9 @@

   low.kind = PROP_CONST;

   high.kind = PROP_CONST;

+  stride.kind = PROP_CONST;

   high.data.const_val = 0;

+  stride.data.const_val = 0;

   /* Set LOW_DEFAULT_IS_VALID if current language and DWARF version allow

      omitting DW_AT_lower_bound.  */

@@ -14980,19 +15086,26 @@

       break;

     }

+  attr = dwarf2_attr (die, DW_AT_byte_stride, cu);

+  if (attr)

+    if (!attr_to_dynamic_prop (attr, die, cu, &stride, NULL, 0))

+        complaint (&symfile_complaints, _("Missing DW_AT_byte_stride "

+                  "- DIE at 0x%x [in module %s]"),

+             die->offset.sect_off, objfile_name (cu->objfile));

+

   attr = dwarf2_attr (die, DW_AT_lower_bound, cu);

   if (attr)

-    attr_to_dynamic_prop (attr, die, cu, &low);

+    attr_to_dynamic_prop (attr, die, cu, &low, NULL, 0);

   else if (!low_default_is_valid)

     complaint (&symfile_complaints, _("Missing DW_AT_lower_bound "

 				      "- DIE at 0x%x [in module %s]"),

 	       die->offset.sect_off, objfile_name (cu->objfile));

   attr = dwarf2_attr (die, DW_AT_upper_bound, cu);

-  if (!attr_to_dynamic_prop (attr, die, cu, &high))

+  if (!attr_to_dynamic_prop (attr, die, cu, &high, NULL, 0))

     {

       attr = dwarf2_attr (die, DW_AT_count, cu);

-      if (attr_to_dynamic_prop (attr, die, cu, &high))

+      if (attr_to_dynamic_prop (attr, die, cu, &high, NULL, 0))

 	{

 	  /* If bounds are constant do the final calculation here.  */

 	  if (low.kind == PROP_CONST && high.kind == PROP_CONST)

@@ -15056,7 +15169,7 @@

       && !TYPE_UNSIGNED (base_type) && (high.data.const_val & negative_mask))

     high.data.const_val |= negative_mask;

-  range_type = create_range_type (NULL, orig_base_type, &low, &high);

+  range_type = create_range_type (NULL, orig_base_type, &low, &high, &stride);

   if (high_bound_is_count)

     TYPE_RANGE_DATA (range_type)->flag_upper_bound_is_count = 1;

@@ -22360,7 +22473,7 @@

   attr = dwarf2_attr (die, DW_AT_allocated, cu);

   if (attr_form_is_block (attr))

     {

-      if (attr_to_dynamic_prop (attr, die, cu, &prop))

+      if (attr_to_dynamic_prop (attr, die, cu, &prop, NULL, 0))

         add_dyn_prop (DYN_PROP_ALLOCATED, prop, type, objfile);

     }

   else if (attr != NULL)

@@ -22375,7 +22488,7 @@

   attr = dwarf2_attr (die, DW_AT_associated, cu);

   if (attr_form_is_block (attr))

     {

-      if (attr_to_dynamic_prop (attr, die, cu, &prop))

+      if (attr_to_dynamic_prop (attr, die, cu, &prop, NULL, 0))

         add_dyn_prop (DYN_PROP_ASSOCIATED, prop, type, objfile);

     }

   else if (attr != NULL)

@@ -22388,7 +22501,7 @@

   /* Read DW_AT_data_location and set in type.  */

   attr = dwarf2_attr (die, DW_AT_data_location, cu);

-  if (attr_to_dynamic_prop (attr, die, cu, &prop))

+  if (attr_to_dynamic_prop (attr, die, cu, &prop, NULL, 0))

     add_dyn_prop (DYN_PROP_DATA_LOCATION, prop, type, objfile);

   if (dwarf2_per_objfile->die_type_hash == NULL)

Index: gdb-7.10.50.20160106/gdb/f-typeprint.c

===================================================================

--- gdb-7.10.50.20160106.orig/gdb/f-typeprint.c	2016-01-08 19:15:35.080582443 +0100

+++ gdb-7.10.50.20160106/gdb/f-typeprint.c	2016-01-08 19:15:44.980637663 +0100

@@ -31,6 +31,7 @@

 #include "target.h"

 #include "f-lang.h"

 #include "typeprint.h"

+#include "valprint.h"

 #if 0				/* Currently unused.  */

 static void f_type_print_args (struct type *, struct ui_file *);

@@ -64,6 +65,17 @@

     {

       val_print_not_allocated (stream);

       return;

+    }

+

+  if (TYPE_NOT_ASSOCIATED (type))

+    {

+      val_print_not_associated (stream);

+      return;

+    }

+  if (TYPE_NOT_ALLOCATED (type))

+    {

+      val_print_not_allocated (stream);

+      return;

     }

   f_type_print_base (type, stream, show, level);

Index: gdb-7.10.50.20160106/gdb/f-valprint.c

===================================================================

--- gdb-7.10.50.20160106.orig/gdb/f-valprint.c	2016-01-08 19:15:35.081582448 +0100

+++ gdb-7.10.50.20160106/gdb/f-valprint.c	2016-01-08 19:15:44.981637669 +0100

@@ -36,8 +36,6 @@

 extern void _initialize_f_valprint (void);

 static void info_common_command (char *, int);

-static void f77_create_arrayprint_offset_tbl (struct type *,

-					      struct ui_file *);

 static void f77_get_dynamic_length_of_aggregate (struct type *);

 int f77_array_offset_tbl[MAX_FORTRAN_DIMS + 1][2];

@@ -45,15 +43,6 @@

 /* Array which holds offsets to be applied to get a row's elements

    for a given array.  Array also holds the size of each subarray.  */

-/* The following macro gives us the size of the nth dimension, Where 

-   n is 1 based.  */

-

-#define F77_DIM_SIZE(n) (f77_array_offset_tbl[n][1])

-

-/* The following gives us the offset for row n where n is 1-based.  */

-

-#define F77_DIM_OFFSET(n) (f77_array_offset_tbl[n][0])

-

 int

 f77_get_lowerbound (struct type *type)

 {

@@ -111,47 +100,6 @@

     * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type)));

 }

-/* Function that sets up the array offset,size table for the array 

-   type "type".  */

-

-static void

-f77_create_arrayprint_offset_tbl (struct type *type, struct ui_file *stream)

-{

-  struct type *tmp_type;

-  int eltlen;

-  int ndimen = 1;

-  int upper, lower;

-

-  tmp_type = type;

-

-  while (TYPE_CODE (tmp_type) == TYPE_CODE_ARRAY)

-    {

-      upper = f77_get_upperbound (tmp_type);

-      lower = f77_get_lowerbound (tmp_type);

-

-      F77_DIM_SIZE (ndimen) = upper - lower + 1;

-

-      tmp_type = TYPE_TARGET_TYPE (tmp_type);

-      ndimen++;

-    }

-

-  /* Now we multiply eltlen by all the offsets, so that later we 

-     can print out array elements correctly.  Up till now we 

-     know an offset to apply to get the item but we also 

-     have to know how much to add to get to the next item.  */

-

-  ndimen--;

-  eltlen = TYPE_LENGTH (tmp_type);

-  F77_DIM_OFFSET (ndimen) = eltlen;

-  while (--ndimen > 0)

-    {

-      eltlen *= F77_DIM_SIZE (ndimen + 1);

-      F77_DIM_OFFSET (ndimen) = eltlen;

-    }

-}

-

-

-

 /* Actual function which prints out F77 arrays, Valaddr == address in 

    the superior.  Address == the address in the inferior.  */

@@ -164,41 +112,62 @@

 		   const struct value_print_options *options,

 		   int *elts)

 {

+  struct type *range_type = TYPE_INDEX_TYPE (check_typedef (type));

+  CORE_ADDR addr = address + embedded_offset;

+  LONGEST lowerbound, upperbound;

   int i;

+  get_discrete_bounds (range_type, &lowerbound, &upperbound);

+

   if (nss != ndimensions)

     {

-      for (i = 0;

-	   (i < F77_DIM_SIZE (nss) && (*elts) < options->print_max);

+      size_t dim_size;

+      size_t offs = 0;

+      LONGEST byte_stride = abs (TYPE_BYTE_STRIDE (range_type));

+

+      if (byte_stride)

+        dim_size = byte_stride;

+      else

+        dim_size = TYPE_LENGTH (TYPE_TARGET_TYPE (type));

+

+      for (i = lowerbound;

+	   (i < upperbound + 1 && (*elts) < options->print_max);

 	   i++)

 	{

+	  struct value *subarray = value_from_contents_and_address

+	    (TYPE_TARGET_TYPE (type), value_contents_for_printing_const (val)

+	     + offs, addr + offs);

+

 	  fprintf_filtered (stream, "( ");

-	  f77_print_array_1 (nss + 1, ndimensions, TYPE_TARGET_TYPE (type),

-			     valaddr,

-			     embedded_offset + i * F77_DIM_OFFSET (nss),

-			     address,

-			     stream, recurse, val, options, elts);

+	  f77_print_array_1 (nss + 1, ndimensions, value_type (subarray),

+			     value_contents_for_printing (subarray),

+			     value_embedded_offset (subarray),

+			     value_address (subarray),

+			     stream, recurse, subarray, options, elts);

+	  offs += dim_size;

 	  fprintf_filtered (stream, ") ");

 	}

-      if (*elts >= options->print_max && i < F77_DIM_SIZE (nss)) 

+      if (*elts >= options->print_max && i < upperbound)

 	fprintf_filtered (stream, "...");

     }

   else

     {

-      for (i = 0; i < F77_DIM_SIZE (nss) && (*elts) < options->print_max;

+      for (i = lowerbound; i < upperbound + 1 && (*elts) < options->print_max;

 	   i++, (*elts)++)

 	{

-	  val_print (TYPE_TARGET_TYPE (type),

-		     valaddr,

-		     embedded_offset + i * F77_DIM_OFFSET (ndimensions),

-		     address, stream, recurse,

-		     val, options, current_language);

+	  struct value *elt = value_subscript ((struct value *)val, i);

+

+	  val_print (value_type (elt),

+		     value_contents_for_printing (elt),

+		     value_embedded_offset (elt),

+		     value_address (elt), stream, recurse,

+		     elt, options, current_language);

-	  if (i != (F77_DIM_SIZE (nss) - 1))

+	  if (i != upperbound)

 	    fprintf_filtered (stream, ", ");

 	  if ((*elts == options->print_max - 1)

-	      && (i != (F77_DIM_SIZE (nss) - 1)))

+	      && (i != upperbound))

 	    fprintf_filtered (stream, "...");

 	}

     }

@@ -225,12 +194,6 @@

 Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"),

 	   ndimensions, MAX_FORTRAN_DIMS);

-  /* Since F77 arrays are stored column-major, we set up an 

-     offset table to get at the various row's elements.  The 

-     offset table contains entries for both offset and subarray size.  */

-

-  f77_create_arrayprint_offset_tbl (type, stream);

-

   f77_print_array_1 (1, ndimensions, type, valaddr, embedded_offset,

 		     address, stream, recurse, val, options, &elts);

 }

@@ -375,12 +338,15 @@

       fprintf_filtered (stream, "( ");

       for (index = 0; index < TYPE_NFIELDS (type); index++)

         {

-          int offset = TYPE_FIELD_BITPOS (type, index) / 8;

+	  struct value *field = value_field

+	    ((struct value *)original_value, index);

+

+          val_print (value_type (field),

+		     value_contents_for_printing (field),

+		     value_embedded_offset (field),

+		     value_address (field), stream, recurse + 1,

+		     field, options, current_language);

-          val_print (TYPE_FIELD_TYPE (type, index), valaddr,

-		     embedded_offset + offset,

-		     address, stream, recurse + 1,

-		     original_value, options, current_language);

           if (index != TYPE_NFIELDS (type) - 1)

             fputs_filtered (", ", stream);

         }

Index: gdb-7.10.50.20160106/gdb/gdbtypes.c

===================================================================

--- gdb-7.10.50.20160106.orig/gdb/gdbtypes.c	2016-01-08 19:15:35.083582459 +0100

+++ gdb-7.10.50.20160106/gdb/gdbtypes.c	2016-01-08 19:15:44.982637674 +0100

@@ -836,7 +836,8 @@

 struct type *

 create_range_type (struct type *result_type, struct type *index_type,

 		   const struct dynamic_prop *low_bound,

-		   const struct dynamic_prop *high_bound)

+		   const struct dynamic_prop *high_bound,

+		   const struct dynamic_prop *stride)

 {

   if (result_type == NULL)

     result_type = alloc_type_copy (index_type);

@@ -851,6 +852,7 @@

     TYPE_ZALLOC (result_type, sizeof (struct range_bounds));

   TYPE_RANGE_DATA (result_type)->low = *low_bound;

   TYPE_RANGE_DATA (result_type)->high = *high_bound;

+  TYPE_RANGE_DATA (result_type)->stride = *stride;

   if (low_bound->kind == PROP_CONST && low_bound->data.const_val >= 0)

     TYPE_UNSIGNED (result_type) = 1;

@@ -879,7 +881,7 @@

 create_static_range_type (struct type *result_type, struct type *index_type,

 			  LONGEST low_bound, LONGEST high_bound)

 {

-  struct dynamic_prop low, high;

+  struct dynamic_prop low, high, stride;

   low.kind = PROP_CONST;

   low.data.const_val = low_bound;

@@ -887,7 +889,11 @@

   high.kind = PROP_CONST;

   high.data.const_val = high_bound;

-  result_type = create_range_type (result_type, index_type, &low, &high);

+  stride.kind = PROP_CONST;

+  stride.data.const_val = 0;

+

+  result_type = create_range_type (result_type, index_type,

+                                   &low, &high, &stride);

   return result_type;

 }

@@ -1084,16 +1090,21 @@

       && (!type_not_associated (result_type)

 	  && !type_not_allocated (result_type)))

     {

-      LONGEST low_bound, high_bound;

+      LONGEST low_bound, high_bound, byte_stride;

       if (get_discrete_bounds (range_type, &low_bound, &high_bound) < 0)

 	low_bound = high_bound = 0;

       element_type = check_typedef (element_type);

+

+      byte_stride = abs (TYPE_BYTE_STRIDE (range_type));

+

       /* Be careful when setting the array length.  Ada arrays can be

 	 empty arrays with the high_bound being smaller than the low_bound.

 	 In such cases, the array length should be zero.  */

       if (high_bound < low_bound)

 	TYPE_LENGTH (result_type) = 0;

+      else if (byte_stride > 0)

+	TYPE_LENGTH (result_type) = byte_stride * (high_bound - low_bound + 1);

       else if (bit_stride > 0)

 	TYPE_LENGTH (result_type) =

 	  (bit_stride * (high_bound - low_bound + 1) + 7) / 8;

@@ -1804,12 +1815,31 @@

 static int

 is_dynamic_type_internal (struct type *type, int top_level)

 {

+  int index;

+

+  if (!type)

+    return 0;

+

   type = check_typedef (type);

   /* We only want to recognize references at the outermost level.  */

   if (top_level && TYPE_CODE (type) == TYPE_CODE_REF)

     type = check_typedef (TYPE_TARGET_TYPE (type));

+  if (TYPE_ASSOCIATED_PROP (type))

+    return 1;

+

+  if (TYPE_ALLOCATED_PROP (type))

+    return 1;

+

+  /* Scan field types in the Fortran case for nested dynamic types.

+     This will be done only for Fortran as in the C++ case an endless recursion

+     can occur in the area of classes.  */

+  if (current_language->la_language == language_fortran)

+    for (index = 0; index < TYPE_NFIELDS (type); index++)

+      if (is_dynamic_type (TYPE_FIELD_TYPE (type, index)))

+        return 1;

+

   /* Types that have a dynamic TYPE_DATA_LOCATION are considered

      dynamic, even if the type itself is statically defined.

      From a user's point of view, this may appear counter-intuitive;

@@ -1844,11 +1874,19 @@

       {

 	gdb_assert (TYPE_NFIELDS (type) == 1);

-	/* The array is dynamic if either the bounds are dynamic,

-	   or the elements it contains have a dynamic contents.  */

+	/* The array is dynamic if either

+     - the bounds are dynamic,

+	   - the elements it contains have a dynamic contents

+     - a data_locaton attribute was found.  */

 	if (is_dynamic_type_internal (TYPE_INDEX_TYPE (type), 0))

 	  return 1;

-	return is_dynamic_type_internal (TYPE_TARGET_TYPE (type), 0);

+	else if (TYPE_DATA_LOCATION (type) != NULL

+	         && (TYPE_DATA_LOCATION_KIND (type) == PROP_LOCEXPR

+	             || TYPE_DATA_LOCATION_KIND (type) == PROP_LOCLIST))

+    return 1;

+  else

+    return is_dynamic_type_internal (TYPE_TARGET_TYPE (type), 0);

+	break;

       }

     case TYPE_CODE_STRUCT:

@@ -1861,6 +1899,18 @@

 	      && is_dynamic_type_internal (TYPE_FIELD_TYPE (type, i), 0))

 	    return 1;

       }

+    case TYPE_CODE_PTR:

+      {

+        if (TYPE_TARGET_TYPE (type)

+            && (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_STRING

+                || TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY))

+          return is_dynamic_type (check_typedef (TYPE_TARGET_TYPE (type)));

+

+        return 0;

+        break;

+      }

+    default:

+      return 0;

       break;

     }

@@ -1890,7 +1940,8 @@

   struct type *static_range_type, *static_target_type;

   const struct dynamic_prop *prop;

   const struct dwarf2_locexpr_baton *baton;

-  struct dynamic_prop low_bound, high_bound;

+  struct dynamic_prop low_bound, high_bound, stride;

+  struct type *range_copy = copy_type (dyn_range_type);

   gdb_assert (TYPE_CODE (dyn_range_type) == TYPE_CODE_RANGE);

@@ -1922,12 +1973,19 @@

       high_bound.data.const_val = 0;

     }

+  prop = &TYPE_RANGE_DATA (dyn_range_type)->stride;

+  if (dwarf2_evaluate_property (prop, NULL, addr_stack, &value))

+    {

+      stride.kind = PROP_CONST;

+      stride.data.const_val = value;

+    }

+

   static_target_type

-    = resolve_dynamic_type_internal (TYPE_TARGET_TYPE (dyn_range_type),

+    = resolve_dynamic_type_internal (TYPE_TARGET_TYPE (range_copy),

 				     addr_stack, 0);

-  static_range_type = create_range_type (copy_type (dyn_range_type),

+  static_range_type = create_range_type (range_copy,

 					 static_target_type,

-					 &low_bound, &high_bound);

+					 &low_bound, &high_bound, &stride);

   TYPE_RANGE_DATA (static_range_type)->flag_bound_evaluated = 1;

   return static_range_type;

 }

@@ -1946,7 +2004,8 @@

   struct type *ary_dim;

   struct dynamic_prop *prop;

-  gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);

+  gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY

+	      || TYPE_CODE (type) == TYPE_CODE_STRING);

   type = copy_type (type);

@@ -1971,13 +2030,18 @@

   ary_dim = check_typedef (TYPE_TARGET_TYPE (elt_type));

-  if (ary_dim != NULL && TYPE_CODE (ary_dim) == TYPE_CODE_ARRAY)

+  if (ary_dim != NULL && (TYPE_CODE (ary_dim) == TYPE_CODE_ARRAY

+			  || TYPE_CODE (ary_dim) == TYPE_CODE_STRING))

     elt_type = resolve_dynamic_array (ary_dim, addr_stack);

   else

     elt_type = TYPE_TARGET_TYPE (type);

-  return create_array_type_with_stride (type, elt_type, range_type,

-                                        TYPE_FIELD_BITSIZE (type, 0));

+  if (TYPE_CODE (type) == TYPE_CODE_STRING

+      && TYPE_FIELD_BITSIZE (type, 0) == 0)

+    return create_string_type (type, elt_type, range_type);

+  else

+    return create_array_type_with_stride (type, elt_type, range_type,

+					  TYPE_FIELD_BITSIZE (type, 0));

 }

 /* Resolve dynamic bounds of members of the union TYPE to static

Index: gdb-7.10.50.20160106/gdb/gdbtypes.h

===================================================================

--- gdb-7.10.50.20160106.orig/gdb/gdbtypes.h	2016-01-08 19:15:35.085582471 +0100

+++ gdb-7.10.50.20160106/gdb/gdbtypes.h	2016-01-08 19:15:44.983637680 +0100

@@ -577,6 +577,10 @@

   struct dynamic_prop high;

+  /* * Stride of range.  */

+

+  struct dynamic_prop stride;

+

   /* True if HIGH range bound contains the number of elements in the

      subrange. This affects how the final hight bound is computed.  */

@@ -749,6 +753,18 @@

   /* * Contains all dynamic type properties.  */

   struct dynamic_prop_list *dyn_prop_list;

+

+  /* Structure for DW_AT_allocated.

+     The presence of this attribute indicates that the object of the type

+     can be allocated/deallocated.  The value can be a dwarf expression,

+     reference, or a constant.  */

+  struct dynamic_prop *allocated;

+

+  /* Structure for DW_AT_associated.

+     The presence of this attribute indicated that the object of the type

+     can be associated.  The value can be a dwarf expression,

+     reference, or a constant.  */

+  struct dynamic_prop *associated;

 };

 /* * A ``struct type'' describes a particular instance of a type, with

@@ -1255,6 +1271,15 @@

   TYPE_RANGE_DATA(range_type)->high.kind

 #define TYPE_LOW_BOUND_KIND(range_type) \

   TYPE_RANGE_DATA(range_type)->low.kind

+#define TYPE_BYTE_STRIDE(range_type) \

+  TYPE_RANGE_DATA(range_type)->stride.data.const_val

+#define TYPE_BYTE_STRIDE_BLOCK(range_type) \

+  TYPE_RANGE_DATA(range_type)->stride.data.locexpr

+#define TYPE_BYTE_STRIDE_LOCLIST(range_type) \

+  TYPE_RANGE_DATA(range_type)->stride.data.loclist

+#define TYPE_BYTE_STRIDE_KIND(range_type) \

+  TYPE_RANGE_DATA(range_type)->stride.kind

+

 /* Property accessors for the type data location.  */

 #define TYPE_DATA_LOCATION(thistype) \

@@ -1266,6 +1291,18 @@

 #define TYPE_DATA_LOCATION_KIND(thistype) \

   TYPE_DATA_LOCATION (thistype)->kind

+/* Allocated status of type object.  If set to non-zero it means the object

+   is allocated. A zero value means it is not allocated.  */

+#define TYPE_NOT_ALLOCATED(t)  (TYPE_ALLOCATED_PROP (t) \

+  && TYPE_ALLOCATED_PROP (t)->kind == PROP_CONST \

+  && !TYPE_ALLOCATED_PROP (t)->data.const_val)

+

+/* Associated status of type object.  If set to non-zero it means the object

+   is associated. A zero value means it is not associated.  */

+#define TYPE_NOT_ASSOCIATED(t)  (TYPE_ASSOCIATED_PROP (t) \

+  && TYPE_ASSOCIATED_PROP (t)->kind == PROP_CONST \

+  && !TYPE_ASSOCIATED_PROP (t)->data.const_val)

+

 /* Property accessors for the type allocated/associated.  */

 #define TYPE_ALLOCATED_PROP(thistype) \

   get_dyn_prop (DYN_PROP_ALLOCATED, thistype)

@@ -1289,6 +1326,9 @@

    TYPE_HIGH_BOUND_UNDEFINED(TYPE_INDEX_TYPE(arraytype))

 #define TYPE_ARRAY_LOWER_BOUND_IS_UNDEFINED(arraytype) \

    TYPE_LOW_BOUND_UNDEFINED(TYPE_INDEX_TYPE(arraytype))

+#define TYPE_ARRAY_STRIDE_IS_UNDEFINED(arraytype) \

+   (TYPE_BYTE_STRIDE(TYPE_INDEX_TYPE(arraytype)) == 0)

+

 #define TYPE_ARRAY_UPPER_BOUND_VALUE(arraytype) \

    (TYPE_HIGH_BOUND(TYPE_INDEX_TYPE((arraytype))))

@@ -1775,6 +1815,7 @@

 extern struct type *create_range_type (struct type *, struct type *,

 				       const struct dynamic_prop *,

+				       const struct dynamic_prop *,

 				       const struct dynamic_prop *);

 extern struct type *create_array_type (struct type *, struct type *,

Index: gdb-7.10.50.20160106/gdb/testsuite/gdb.fortran/vla-func.exp

===================================================================

--- /dev/null	1970-01-01 00:00:00.000000000 +0000

+++ gdb-7.10.50.20160106/gdb/testsuite/gdb.fortran/vla-func.exp	2016-01-08 19:15:44.983637680 +0100

@@ -0,0 +1,61 @@

+# Copyright 2014 Free Software Foundation, Inc.

+

+# This program 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 of the License, or

+# (at your option) any later version.

+#

+# This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.

+

+standard_testfile ".f90"

+

+if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \

+    {debug f90 quiet}] } {

+    return -1

+}

+

+if ![runto MAIN__] then {

+    perror "couldn't run to breakpoint MAIN__"

+    continue

+}

+