[V3 02/21] vla: make dynamic fortran arrays functional.

[Keven Boell <keven.boell@intel.com>]

This patch enables GDB to print the value of a dynamic
array (VLA) if allocated/associated in fortran. If not the
allocation status will be printed to the command line.

(gdb) p vla_not_allocated
$1 = <not allocated>

(gdb) p vla_allocated
$1 = (1, 2, 3)

(gdb) p vla_not_associated
$1 = <not associated>

(gdb) p vla_associated
$1 = (3, 2, 1)

The patch covers various locations where the allocation/
association status makes sense to print.

2014-05-28  Keven Boell  <keven.boell@intel.com>
            Sanimir Agovic  <sanimir.agovic@intel.com>

	* dwarf2loc.c (dwarf2_address_data_valid): New
	function.
	* dwarf2loc.h (dwarf2_address_data_valid): New
	function.
	* f-typeprint.c (f_print_type): Print allocation/
	association status.
	(f_type_print_varspec_suffix): Print allocation/
	association status for &-operator usages.
	* gdbtypes.c (create_array_type_with_stride): Add
	query for valid data location.
	(is_dynamic_type): Extend dynamic type detection
	with allocated/associated. Add type detection for
	fields.
	(resolve_dynamic_range): Copy type before resolving
	it as dynamic attributes need to be preserved.
	(resolve_dynamic_array): Copy type before resolving
	it as dynamic attributes need to be preserved. Add
	resolving of allocated/associated attributes.
	(resolve_dynamic_type): Add call to nested
	type resolving.
	(copy_type_recursive): Add allocated/associated
	attributes to be copied.
	(copy_type): Copy allocated/associated/data_location
	as well as the fields structure if available.
	* valarith.c (value_subscripted_rvalue): Print allocated/
	associated status when indexing a VLA.
	* valprint.c (valprint_check_validity): Print allocated/
	associated status.
	(val_print_not_allocated): New function.
	(val_print_not_associated): New function.
	* valprint.h (val_print_not_allocated): New function.
	(val_print_not_associated): New function.
	* value.c (set_value_component_location): Adjust the value
	address for single value prints.


---
 gdb/dwarf2loc.c   |   19 ++++++++++
 gdb/dwarf2loc.h   |    6 ++++
 gdb/f-typeprint.c |   62 +++++++++++++++++++++------------
 gdb/gdbtypes.c    |   99 ++++++++++++++++++++++++++++++++++++++++++++++++++---
 gdb/valarith.c    |    9 ++++-
 gdb/valprint.c    |   40 ++++++++++++++++++++++
 gdb/valprint.h    |    4 +++
 gdb/value.c       |   20 +++++++++++
 8 files changed, 232 insertions(+), 27 deletions(-)

diff --git a/gdb/dwarf2loc.c b/gdb/dwarf2loc.c
index e347e59..ad33078 100644
--- a/gdb/dwarf2loc.c
+++ b/gdb/dwarf2loc.c
@@ -2285,6 +2285,11 @@ dwarf2_evaluate_loc_desc_full (struct type *type, struct frame_info *frame,
 	    int in_stack_memory = dwarf_expr_fetch_in_stack_memory (ctx, 0);
 
 	    do_cleanups (value_chain);
+
+	    /* Select right frame to correctly evaluate VLA's during a backtrace.  */
+	    if (is_dynamic_type (type))
+	      select_frame (frame);
+
 	    retval = value_at_lazy (type, address + byte_offset);
 	    if (in_stack_memory)
 	      set_value_stack (retval, 1);
@@ -2508,6 +2513,20 @@ dwarf2_evaluate_property (const struct dynamic_prop *prop,
   return 0;
 }
 
+/* See dwarf2loc.h.  */
+
+int
+dwarf2_address_data_valid (const struct type *type)
+{
+  if (TYPE_NOT_ASSOCIATED (type))
+    return 0;
+
+  if (TYPE_NOT_ALLOCATED (type))
+    return 0;
+
+  return 1;
+}
+
 \f
 /* Helper functions and baton for dwarf2_loc_desc_needs_frame.  */
 
diff --git a/gdb/dwarf2loc.h b/gdb/dwarf2loc.h
index 96925e4..e04dca5 100644
--- a/gdb/dwarf2loc.h
+++ b/gdb/dwarf2loc.h
@@ -102,6 +102,12 @@ int dwarf2_evaluate_property (const struct dynamic_prop *prop,
 CORE_ADDR dwarf2_read_addr_index (struct dwarf2_per_cu_data *per_cu,
 				  unsigned int addr_index);
 
+/* Checks if a dwarf location definition is valid.
+   Returns 1 if valid; 0 otherwise.  */
+
+extern int dwarf2_address_data_valid (const struct type *type);
+
+
 /* The symbol location baton types used by the DWARF-2 reader (i.e.
    SYMBOL_LOCATION_BATON for a LOC_COMPUTED symbol).  "struct
    dwarf2_locexpr_baton" is for a symbol with a single location
diff --git a/gdb/f-typeprint.c b/gdb/f-typeprint.c
index 7474051..be719c6 100644
--- a/gdb/f-typeprint.c
+++ b/gdb/f-typeprint.c
@@ -30,6 +30,7 @@
 #include "gdbcore.h"
 #include "target.h"
 #include "f-lang.h"
+#include "valprint.h"
 
 #if 0				/* Currently unused.  */
 static void f_type_print_args (struct type *, struct ui_file *);
@@ -53,6 +54,17 @@ f_print_type (struct type *type, const char *varstring, struct ui_file *stream,
   enum type_code code;
   int demangled_args;
 
+  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);
   code = TYPE_CODE (type);
   if ((varstring != NULL && *varstring != '\0')
@@ -167,28 +179,36 @@ f_type_print_varspec_suffix (struct type *type, struct ui_file *stream,
       if (arrayprint_recurse_level == 1)
 	fprintf_filtered (stream, "(");
 
-      if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY)
-	f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0,
-				     arrayprint_recurse_level);
-
-      lower_bound = f77_get_lowerbound (type);
-      if (lower_bound != 1)	/* Not the default.  */
-	fprintf_filtered (stream, "%d:", lower_bound);
-
-      /* Make sure that, if we have an assumed size array, we
-         print out a warning and print the upperbound as '*'.  */
-
-      if (TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (type))
-	fprintf_filtered (stream, "*");
+      if (TYPE_NOT_ASSOCIATED (type))
+        val_print_not_associated (stream);
+      else if (TYPE_NOT_ALLOCATED (type))
+        val_print_not_allocated (stream);
       else
-	{
-	  upper_bound = f77_get_upperbound (type);
-	  fprintf_filtered (stream, "%d", upper_bound);
-	}
-
-      if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_ARRAY)
-	f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0,
-				     arrayprint_recurse_level);
+        {
+
+          if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY)
+            f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0,
+                 arrayprint_recurse_level);
+
+          lower_bound = f77_get_lowerbound (type);
+          if (lower_bound != 1)	/* Not the default.  */
+            fprintf_filtered (stream, "%d:", lower_bound);
+
+          /* Make sure that, if we have an assumed size array, we
+             print out a warning and print the upperbound as '*'.  */
+
+          if (TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (type))
+            fprintf_filtered (stream, "*");
+          else
+            {
+              upper_bound = f77_get_upperbound (type);
+              fprintf_filtered (stream, "%d", upper_bound);
+            }
+
+          if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_ARRAY)
+            f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0,
+                 arrayprint_recurse_level);
+      }
       if (arrayprint_recurse_level == 1)
 	fprintf_filtered (stream, ")");
       else
diff --git a/gdb/gdbtypes.c b/gdb/gdbtypes.c
index 1326f85..9653c6f 100644
--- a/gdb/gdbtypes.c
+++ b/gdb/gdbtypes.c
@@ -1001,7 +1001,8 @@ create_array_type_with_stride (struct type *result_type,
 
   TYPE_CODE (result_type) = TYPE_CODE_ARRAY;
   TYPE_TARGET_TYPE (result_type) = element_type;
-  if (has_static_range (TYPE_RANGE_DATA (range_type)))
+  if (has_static_range (TYPE_RANGE_DATA (range_type))
+      && dwarf2_address_data_valid (result_type))
     {
       LONGEST low_bound, high_bound;
 
@@ -1614,6 +1615,11 @@ stub_noname_complaint (void)
 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.  */
@@ -1631,6 +1637,20 @@ is_dynamic_type_internal (struct type *type, int top_level)
 	  || TYPE_DATA_LOCATION_KIND (type) == PROP_LOCLIST))
     return 1;
 
+  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;
+
   switch (TYPE_CODE (type))
     {
     case TYPE_CODE_RANGE:
@@ -1686,6 +1706,7 @@ resolve_dynamic_range (struct type *dyn_range_type, CORE_ADDR addr)
   const struct dynamic_prop *prop;
   const struct dwarf2_locexpr_baton *baton;
   struct dynamic_prop low_bound, high_bound;
+  struct type *range_copy = copy_type (dyn_range_type);
 
   gdb_assert (TYPE_CODE (dyn_range_type) == TYPE_CODE_RANGE);
 
@@ -1717,8 +1738,8 @@ resolve_dynamic_range (struct type *dyn_range_type, CORE_ADDR addr)
       high_bound.data.const_val = 0;
     }
 
-  static_range_type = create_range_type (copy_type (dyn_range_type),
-					 TYPE_TARGET_TYPE (dyn_range_type),
+  static_range_type = create_range_type (range_copy,
+					 TYPE_TARGET_TYPE (range_copy),
 					 &low_bound, &high_bound);
   TYPE_RANGE_DATA (static_range_type)->flag_bound_evaluated = 1;
   return static_range_type;
@@ -1735,6 +1756,8 @@ resolve_dynamic_array (struct type *type, CORE_ADDR addr)
   struct type *elt_type;
   struct type *range_type;
   struct type *ary_dim;
+  struct dynamic_prop *prop;
+  struct type *copy = copy_type (type);
 
   gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
 
@@ -1742,14 +1765,28 @@ resolve_dynamic_array (struct type *type, CORE_ADDR addr)
   range_type = check_typedef (TYPE_INDEX_TYPE (elt_type));
   range_type = resolve_dynamic_range (range_type, addr);
 
+  prop = TYPE_ALLOCATED_PROP (type);
+  if (dwarf2_evaluate_property (prop, addr, &value))
+    {
+      TYPE_ALLOCATED_PROP (copy)->kind = PROP_CONST;
+      TYPE_ALLOCATED_PROP (copy)->data.const_val = value;
+    }
+
+  prop = TYPE_ASSOCIATED_PROP (type);
+  if (dwarf2_evaluate_property (prop, addr, &value))
+    {
+      TYPE_ASSOCIATED_PROP (copy)->kind = PROP_CONST;
+      TYPE_ASSOCIATED_PROP (copy)->data.const_val = value;
+    }
+
   ary_dim = check_typedef (TYPE_TARGET_TYPE (elt_type));
 
   if (ary_dim != NULL && TYPE_CODE (ary_dim) == TYPE_CODE_ARRAY)
-    elt_type = resolve_dynamic_array (TYPE_TARGET_TYPE (type), addr);
+    elt_type = resolve_dynamic_array (TYPE_TARGET_TYPE (copy), addr);
   else
     elt_type = TYPE_TARGET_TYPE (type);
 
-  return create_array_type (copy_type (type),
+  return create_array_type (copy,
 			    elt_type,
 			    range_type);
 }
@@ -4142,6 +4179,20 @@ copy_type_recursive (struct objfile *objfile,
 	      sizeof (struct dynamic_prop));
     }
 
+  /* Copy allocated information.  */
+  if (TYPE_ALLOCATED_PROP (type) != NULL)
+    {
+      TYPE_ALLOCATED_PROP (new_type) = xmalloc (sizeof (struct dynamic_prop));
+      *TYPE_ALLOCATED_PROP (new_type) = *TYPE_ALLOCATED_PROP (type);
+    }
+
+  /* Copy associated information.  */
+  if (TYPE_ASSOCIATED_PROP (type) != NULL)
+    {
+      TYPE_ASSOCIATED_PROP (new_type) = xmalloc (sizeof (struct dynamic_prop));
+      *TYPE_ASSOCIATED_PROP (new_type) = *TYPE_ASSOCIATED_PROP (type);
+    }
+
   /* Copy pointers to other types.  */
   if (TYPE_TARGET_TYPE (type))
     TYPE_TARGET_TYPE (new_type) = 
@@ -4195,6 +4246,44 @@ copy_type (const struct type *type)
 	      sizeof (struct dynamic_prop));
     }
 
+  if (TYPE_ALLOCATED_PROP (type))
+    {
+      TYPE_ALLOCATED_PROP (new_type)
+              = OBSTACK_ZALLOC (&TYPE_OWNER (type).objfile->objfile_obstack,
+                                struct dynamic_prop);
+      memcpy (TYPE_ALLOCATED_PROP (new_type), TYPE_ALLOCATED_PROP (type),
+        sizeof (struct dynamic_prop));
+    }
+
+  if (TYPE_ASSOCIATED_PROP (type))
+    {
+      TYPE_ASSOCIATED_PROP (new_type)
+              = OBSTACK_ZALLOC (&TYPE_OWNER (type).objfile->objfile_obstack,
+                                struct dynamic_prop);
+      memcpy (TYPE_ASSOCIATED_PROP (new_type), TYPE_ASSOCIATED_PROP (type),
+        sizeof (struct dynamic_prop));
+    }
+
+  if (TYPE_DATA_LOCATION (type))
+    {
+      TYPE_DATA_LOCATION (new_type)
+              = OBSTACK_ZALLOC (&TYPE_OWNER (type).objfile->objfile_obstack,
+                                struct dynamic_prop);
+      memcpy (TYPE_DATA_LOCATION (new_type), TYPE_DATA_LOCATION (type),
+        sizeof (struct dynamic_prop));
+    }
+
+  if (TYPE_NFIELDS (type))
+    {
+      int nfields = TYPE_NFIELDS (type);
+
+      TYPE_FIELDS (new_type)
+              = OBSTACK_CALLOC (&TYPE_OWNER (type).objfile->objfile_obstack,
+                                nfields, struct field);
+      memcpy (TYPE_FIELDS (new_type), TYPE_FIELDS (type),
+        nfields * sizeof (struct field));
+   }
+
   return new_type;
 }
 \f
diff --git a/gdb/valarith.c b/gdb/valarith.c
index 44673a1..2f3b58a 100644
--- a/gdb/valarith.c
+++ b/gdb/valarith.c
@@ -199,7 +199,14 @@ value_subscripted_rvalue (struct value *array, LONGEST index, int lowerbound)
 
   if (index < lowerbound || (!TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (array_type)
 			     && elt_offs >= TYPE_LENGTH (array_type)))
-    error (_("no such vector element"));
+    {
+      if (TYPE_NOT_ASSOCIATED (array_type))
+        error (_("no such vector element because not associated"));
+      else if (TYPE_NOT_ALLOCATED (array_type))
+        error (_("no such vector element because not allocated"));
+      else
+        error (_("no such vector element"));
+    }
 
   if (VALUE_LVAL (array) == lval_memory && value_lazy (array))
     v = allocate_value_lazy (elt_type);
diff --git a/gdb/valprint.c b/gdb/valprint.c
index 8cb5c74..5794bad 100644
--- a/gdb/valprint.c
+++ b/gdb/valprint.c
@@ -304,6 +304,18 @@ valprint_check_validity (struct ui_file *stream,
 {
   CHECK_TYPEDEF (type);
 
+  if (TYPE_NOT_ASSOCIATED (type))
+    {
+      val_print_not_associated (stream);
+      return 0;
+    }
+
+  if (TYPE_NOT_ALLOCATED (type))
+    {
+      val_print_not_allocated (stream);
+      return 0;
+    }
+
   if (TYPE_CODE (type) != TYPE_CODE_UNION
       && TYPE_CODE (type) != TYPE_CODE_STRUCT
       && TYPE_CODE (type) != TYPE_CODE_ARRAY)
@@ -360,6 +372,18 @@ val_print_invalid_address (struct ui_file *stream)
   fprintf_filtered (stream, _("<invalid address>"));
 }
 
+void
+val_print_not_allocated (struct ui_file *stream)
+{
+  fprintf_filtered (stream, _("<not allocated>"));
+}
+
+void
+val_print_not_associated (struct ui_file *stream)
+{
+  fprintf_filtered (stream, _("<not associated>"));
+}
+
 /* A generic val_print that is suitable for use by language
    implementations of the la_val_print method.  This function can
    handle most type codes, though not all, notably exception
@@ -801,12 +825,16 @@ static int
 value_check_printable (struct value *val, struct ui_file *stream,
 		       const struct value_print_options *options)
 {
+  const struct type *type;
+
   if (val == 0)
     {
       fprintf_filtered (stream, _("<address of value unknown>"));
       return 0;
     }
 
+  type = value_type (val);
+
   if (value_entirely_optimized_out (val))
     {
       if (options->summary && !val_print_scalar_type_p (value_type (val)))
@@ -832,6 +860,18 @@ value_check_printable (struct value *val, struct ui_file *stream,
       return 0;
     }
 
+  if (TYPE_NOT_ASSOCIATED (type))
+    {
+      val_print_not_associated (stream);
+      return 0;
+    }
+
+  if (TYPE_NOT_ALLOCATED (type))
+    {
+      val_print_not_allocated (stream);
+      return 0;
+    }
+
   return 1;
 }
 
diff --git a/gdb/valprint.h b/gdb/valprint.h
index 6698247..7a415cf 100644
--- a/gdb/valprint.h
+++ b/gdb/valprint.h
@@ -217,4 +217,8 @@ extern void output_command_const (const char *args, int from_tty);
 
 extern int val_print_scalar_type_p (struct type *type);
 
+extern void val_print_not_allocated (struct ui_file *stream);
+
+extern void val_print_not_associated (struct ui_file *stream);
+
 #endif
diff --git a/gdb/value.c b/gdb/value.c
index 077d234..4ed70e7 100644
--- a/gdb/value.c
+++ b/gdb/value.c
@@ -41,6 +41,7 @@
 #include "tracepoint.h"
 #include "cp-abi.h"
 #include "user-regs.h"
+#include "dwarf2loc.h"
 
 /* Prototypes for exported functions.  */
 
@@ -1732,6 +1733,25 @@ set_value_component_location (struct value *component,
       if (funcs->copy_closure)
         component->location.computed.closure = funcs->copy_closure (whole);
     }
+
+  /* For dynamic types compute the address of the component value location in
+     sub range types based on the location of the sub range type, if not being
+     an internal GDB variable or parts of it.  */
+  if (VALUE_LVAL (component) != lval_internalvar
+      && VALUE_LVAL (component) != lval_internalvar_component)
+    {
+      CORE_ADDR addr;
+      struct type *type = value_type (whole);
+
+      addr = value_raw_address (component);
+
+      if (TYPE_DATA_LOCATION (type)
+          && TYPE_DATA_LOCATION_KIND (type) == PROP_CONST)
+        {
+          addr = TYPE_DATA_LOCATION_ADDR (type);
+          set_value_address (component, addr);
+        }
+    }
 }
 
 \f
-- 
1.7.9.5