fort_dyn_array: Enable dynamic member types inside a structure.

Fortran supports dynamic types for which bounds, size and location
can vary during their lifetime. As a result of the dynamic
behaviour, they have to be resolved at every query.
This patch will resolve the type of a structure field when it
is dynamic.

2016-04-26  Bernhard Heckel  <bernhard.heckel@intel.com>
2016-04-26  Keven Boell  <keven.boell@intel.com>

Before:
(gdb) print threev%ivla(1)
Cannot access memory at address 0x3
(gdb) print threev%ivla(5)
no such vector element

After:
(gdb) print threev%ivla(1)
$9 = 1
(gdb) print threev%ivla(5)
$10 = 42

gdb/Changelog:

	* NEWS: Add new supported features for fortran.
	* gdbtypes.c (remove_dyn_prop): New.
	(resolve_dynamic_struct): Keep type length for fortran structs.
	* gdbtypes.h: Forward declaration of new function.
	* value.c (value_address): Return dynamic resolved location of a value.
	(set_value_component_location): Adjust the value address
	for single value prints.
	(value_primitive_field): Support value types with a dynamic location.
	(set_internalvar): Remove dynamic location property of
	internal variables.

gdb/testsuite/Changelog:

	* gdb.fortran/vla-type.f90: New file.
	* gdb.fortran/vla-type.exp: New file.

8 files changed, 292 insertions, 6 deletions

diff --git a/gdb/ChangeLog b/gdb/ChangeLog
index 5c94832..be192e7 100644
--- a/gdb/ChangeLog
+++ b/gdb/ChangeLog
@@ -1,3 +1,17 @@
+2016-04-26  Bernhard Heckel  <bernhard.heckel@intel.com>
+	    Keven Boell  <kevel.boell@intel.com>
+
+	* NEWS: Add new supported features for fortran.
+	* gdbtypes.c (remove_dyn_prop): New.
+	(resolve_dynamic_struct): Keep type length for fortran structs.
+	* gdbtypes.h: Forward declaration of new function.
+	* value.c (value_address): Return dynamic resolved location of a value.
+	(set_value_component_location): Adjust the value address
+	for single value prints.
+	(value_primitive_field): Support value types with a dynamic location.
+	(set_internalvar): Remove dynamic location property of
+	internal variables.
+
 2016-04-25  Pedro Alves  <palves@redhat.com>
 	    Yao Qi  <yao.qi@linaro.org>
 
diff --git a/gdb/NEWS b/gdb/NEWS
index 39d99b7..7bf1e1a 100644
--- a/gdb/NEWS
+++ b/gdb/NEWS
@@ -3,6 +3,9 @@
 
 *** Changes since GDB 7.11
 
+* Fortran: Support structures with fields of dynamic types and 
+  arrays of dynamic types.
+
 * GDB now supports multibit bitfields and enums in target register
   descriptions.
 
diff --git a/gdb/gdbtypes.c b/gdb/gdbtypes.c
index 65758bf..c8fd0c1 100644
--- a/gdb/gdbtypes.c
+++ b/gdb/gdbtypes.c
@@ -2064,7 +2064,9 @@ resolve_dynamic_struct (struct type *type,
 
       pinfo.type = check_typedef (TYPE_FIELD_TYPE (type, i));
       pinfo.valaddr = addr_stack->valaddr;
-      pinfo.addr = addr_stack->addr;
+      pinfo.addr
+	= (addr_stack->addr
+	   + (TYPE_FIELD_BITPOS (resolved_type, i) / TARGET_CHAR_BIT));
       pinfo.next = addr_stack;
 
       TYPE_FIELD_TYPE (resolved_type, i)
@@ -2090,8 +2092,13 @@ resolve_dynamic_struct (struct type *type,
 	resolved_type_bit_length = new_bit_length;
     }
 
-  TYPE_LENGTH (resolved_type)
-    = (resolved_type_bit_length + TARGET_CHAR_BIT - 1) / TARGET_CHAR_BIT;
+  /* The length of a type won't change for fortran, but it does for C and Ada.
+     For fortran the size of dynamic fields might change over time but not the
+     type length of the structure.  If we adapt it, we run into problems
+     when calculating the element offset for arrays of structs.  */
+  if (current_language->la_language != language_fortran)
+    TYPE_LENGTH (resolved_type)
+      = (resolved_type_bit_length + TARGET_CHAR_BIT - 1) / TARGET_CHAR_BIT;
 
   /* The Ada language uses this field as a cache for static fixed types: reset
      it as RESOLVED_TYPE must have its own static fixed type.  */
@@ -2224,6 +2231,37 @@ add_dyn_prop (enum dynamic_prop_node_kind prop_kind, struct dynamic_prop prop,
   TYPE_DYN_PROP_LIST (type) = temp;
 }
 
+/* Remove dynamic property from TYPE in case it exists.  */
+
+void
+remove_dyn_prop (enum dynamic_prop_node_kind prop_kind,
+                 struct type *type)
+{
+  struct dynamic_prop_list *prev_node, *curr_node;
+
+  curr_node = TYPE_DYN_PROP_LIST (type);
+  prev_node = NULL;
+
+  while (NULL != curr_node)
+    {
+      if (curr_node->prop_kind == prop_kind)
+	{
+	  /* Update the linked list but don't free anything.
+	     The property was allocated on objstack and it is not known
+	     if we are on top of it.  Nevertheless, everything is released
+	     when the complete objstack is freed.  */
+	  if (NULL == prev_node)
+	    TYPE_DYN_PROP_LIST (type) = curr_node->next;
+	  else
+	    prev_node->next = curr_node->next;
+
+	  return;
+	}
+
+      prev_node = curr_node;
+      curr_node = curr_node->next;
+    }
+}
 
 /* Find the real type of TYPE.  This function returns the real type,
    after removing all layers of typedefs, and completing opaque or stub
diff --git a/gdb/gdbtypes.h b/gdb/gdbtypes.h
index 1518a7a..c651c88 100644
--- a/gdb/gdbtypes.h
+++ b/gdb/gdbtypes.h
@@ -1826,6 +1826,9 @@ extern void add_dyn_prop
   (enum dynamic_prop_node_kind kind, struct dynamic_prop prop,
    struct type *type, struct objfile *objfile);
 
+extern void remove_dyn_prop (enum dynamic_prop_node_kind prop_kind,
+                             struct type *type);
+
 extern struct type *check_typedef (struct type *);
 
 extern void check_stub_method_group (struct type *, int);
diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog
index c919c47..bb52582 100644
--- a/gdb/testsuite/ChangeLog
+++ b/gdb/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2016-04-26  Bernhard Heckel  <bernhard.heckel@intel.com>
+
+	* gdb.fortran/vla-type.f90: New file.
+	* gdb.fortran/vla-type.exp: New file.
+
 2016-04-25  Yao Qi  <yao.qi@linaro.org>
 
 	* gdb.base/branch-to-self.c: New file.
diff --git a/gdb/testsuite/gdb.fortran/vla-type.exp b/gdb/testsuite/gdb.fortran/vla-type.exp
new file mode 100755
index 0000000..24191fe
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/vla-type.exp
@@ -0,0 +1,102 @@
+# Copyright 2016 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"
+load_lib "fortran.exp"
+
+if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
+     {debug f90 quiet}] } {
+    return -1
+}
+
+if ![runto_main] {
+    untested "could not run to main"
+    return -1
+}
+
+# Depending on the compiler being used, the type names can be printed differently.
+set int [fortran_int4]
+
+# Check if not allocated VLA in type does not break
+# the debugger when accessing it.
+gdb_breakpoint [gdb_get_line_number "before-allocated"]
+gdb_continue_to_breakpoint "before-allocated"
+gdb_test "print twov" " = \\\( <not allocated>, <not allocated> \\\)" \
+  "print twov before allocated"
+gdb_test "print twov%ivla1" " = <not allocated>" \
+  "print twov%ivla1 before allocated"
+
+# Check type with one VLA's inside
+gdb_breakpoint [gdb_get_line_number "onev-filled"]
+gdb_continue_to_breakpoint "onev-filled"
+gdb_test "print onev%ivla(5, 11, 23)" " = 1"
+gdb_test "print onev%ivla(1, 2, 3)" " = 123"
+gdb_test "print onev%ivla(3, 2, 1)" " = 321"
+gdb_test "ptype onev" \
+         [multi_line "type = Type one" \
+                     "\\s+$int :: ivla\\\(11,22,33\\\)" \
+                     "End Type one" ]
+
+# Check type with two VLA's inside
+gdb_breakpoint [gdb_get_line_number "twov-filled"]
+gdb_continue_to_breakpoint "twov-filled"
+gdb_test "print twov%ivla1(5, 11, 23)" " = 1"
+gdb_test "print twov%ivla1(1, 2, 3)" " = 123"
+gdb_test "print twov%ivla1(3, 2, 1)" " = 321"
+gdb_test "ptype twov" \
+         [multi_line "type = Type two" \
+                     "\\s+$int :: ivla1\\\(5,12,99\\\)" \
+                     "\\s+$int :: ivla2\\\(9,12\\\)" \
+                     "End Type two" ]
+
+# Check type with attribute at beginn of type
+gdb_breakpoint [gdb_get_line_number "threev-filled"]
+gdb_continue_to_breakpoint "threev-filled"
+gdb_test "print threev%ivla(1)" " = 1"
+gdb_test "print threev%ivla(5)" " = 42"
+gdb_test "print threev%ivla(14)" " = 24"
+gdb_test "print threev%ivar" " = 3"
+gdb_test "ptype threev" \
+         [multi_line "type = Type three" \
+                     "\\s+$int :: ivar" \
+                     "\\s+$int :: ivla\\\(20\\\)" \
+                     "End Type three" ]
+
+# Check type with attribute at end of type
+gdb_breakpoint [gdb_get_line_number "fourv-filled"]
+gdb_continue_to_breakpoint "fourv-filled"
+gdb_test "print fourv%ivla(1)" " = 1"
+gdb_test "print fourv%ivla(2)" " = 2"
+gdb_test "print fourv%ivla(7)" " = 7"
+gdb_test "print fourv%ivla(12)" "no such vector element"
+gdb_test "print fourv%ivar" " = 3"
+gdb_test "ptype fourv" \
+         [multi_line "type = Type four" \
+                     "\\s+$int :: ivla\\\(10\\\)" \
+                     "\\s+$int :: ivar" \
+                     "End Type four" ]
+
+# Check nested types containing a VLA
+gdb_breakpoint [gdb_get_line_number "fivev-filled"]
+gdb_continue_to_breakpoint "fivev-filled"
+gdb_test "print fivev%tone%ivla(5, 5, 1)" " = 1"
+gdb_test "print fivev%tone%ivla(1, 2, 3)" " = 123"
+gdb_test "print fivev%tone%ivla(3, 2, 1)" " = 321"
+gdb_test "ptype fivev" \
+         [multi_line "type = Type five" \
+                     "\\s+Type one" \
+                     "\\s+$int :: ivla\\\(10,10,10\\\)" \
+                     "\\s+End Type one :: tone" \
+                     "End Type five" ]
diff --git a/gdb/testsuite/gdb.fortran/vla-type.f90 b/gdb/testsuite/gdb.fortran/vla-type.f90
new file mode 100755
index 0000000..a106617
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/vla-type.f90
@@ -0,0 +1,88 @@
+! Copyright 2016 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/>.
+
+program vla_struct
+  type :: one
+    integer, allocatable :: ivla (:, :, :)
+  end type one
+  type :: two
+    integer, allocatable :: ivla1 (:, :, :)
+    integer, allocatable :: ivla2 (:, :)
+  end type two
+  type :: three
+    integer :: ivar
+    integer, allocatable :: ivla (:)
+  end type three
+  type :: four
+    integer, allocatable :: ivla (:)
+    integer :: ivar
+  end type four
+  type :: five
+    type(one) :: tone
+  end type five
+
+  type(one), target        :: onev
+  type(two)                :: twov
+  type(three)              :: threev
+  type(four)               :: fourv
+  type(five)               :: fivev
+  logical                  :: l
+  integer                  :: i, j
+
+  allocate (onev%ivla (11,22,33))         ! before-allocated
+  l = allocated(onev%ivla)
+
+  onev%ivla(:, :, :) = 1
+  onev%ivla(1, 2, 3) = 123
+  onev%ivla(3, 2, 1) = 321
+
+  allocate (twov%ivla1 (5,12,99))         ! onev-filled
+  l = allocated(twov%ivla1)
+  allocate (twov%ivla2 (9,12))
+  l = allocated(twov%ivla2)
+
+  twov%ivla1(:, :, :) = 1
+  twov%ivla1(1, 2, 3) = 123
+  twov%ivla1(3, 2, 1) = 321
+
+  twov%ivla2(:, :) = 1
+  twov%ivla2(1, 2) = 12
+  twov%ivla2(2, 1) = 21
+
+  threev%ivar = 3                      ! twov-filled
+  allocate (threev%ivla (20))
+  l = allocated(threev%ivla)
+
+  threev%ivla(:) = 1
+  threev%ivla(5) = 42
+  threev%ivla(14) = 24
+
+  allocate (fourv%ivla (10))             ! threev-filled
+  l = allocated(fourv%ivla)
+
+  fourv%ivar = 3
+  fourv%ivla(:) = 1
+  fourv%ivla(2) = 2
+  fourv%ivla(7) = 7
+
+  allocate (fivev%tone%ivla (10, 10, 10))         ! fourv-filled
+  l = allocated(fivev%tone%ivla)
+  fivev%tone%ivla(:, :, :) = 1
+  fivev%tone%ivla(1, 2, 3) = 123
+  fivev%tone%ivla(3, 2, 1) = 321
+
+  ! dummy statement for bp
+  l = allocated(fivev%tone%ivla)                  ! fivev-filled
+end program vla_struct
diff --git a/gdb/value.c b/gdb/value.c
index 9657b89..e1e7f5e 100644
--- a/gdb/value.c
+++ b/gdb/value.c
@@ -1541,8 +1541,13 @@ value_address (const struct value *value)
     return 0;
   if (value->parent != NULL)
     return value_address (value->parent) + value->offset;
-  else
-    return value->location.address + value->offset;
+  if (NULL != TYPE_DATA_LOCATION (value_type (value)))
+    {
+      gdb_assert (PROP_CONST == TYPE_DATA_LOCATION_KIND (value_type (value)));
+      return TYPE_DATA_LOCATION_ADDR (value_type (value));
+    }
+
+  return value->location.address + value->offset;
 }
 
 CORE_ADDR
@@ -1857,6 +1862,8 @@ void
 set_value_component_location (struct value *component,
 			      const struct value *whole)
 {
+  struct type *type;
+
   gdb_assert (whole->lval != lval_xcallable);
 
   if (whole->lval == lval_internalvar)
@@ -1872,9 +1879,15 @@ set_value_component_location (struct value *component,
       if (funcs->copy_closure)
         component->location.computed.closure = funcs->copy_closure (whole);
     }
+
+  /* If type has a dynamic resolved location property
+     update it's value address.  */
+  type = value_type (whole);
+  if (NULL != TYPE_DATA_LOCATION (type)
+      && TYPE_DATA_LOCATION_KIND (type) == PROP_CONST)
+    set_value_address (component, TYPE_DATA_LOCATION_ADDR (type));
 }
 
-
 /* Access to the value history.  */
 
 /* Record a new value in the value history.
@@ -2427,6 +2440,15 @@ set_internalvar (struct internalvar *var, struct value *val)
 	 call error () until new_data is installed into the var->u to avoid
 	 leaking memory.  */
       release_value (new_data.value);
+
+      /* Internal variables which are created from values with a dynamic
+         location don't need the location property of the origin anymore.
+         The resolved dynamic location is used prior then any other address
+         when accessing the value.
+         If we keep it, we would still refer to the origin value.
+         Remove the location property in case it exist.  */
+      remove_dyn_prop (DYN_PROP_DATA_LOCATION, value_type (new_data.value));
+
       break;
     }
 
@@ -3168,6 +3190,17 @@ value_primitive_field (struct value *arg1, int offset,
       v->offset = value_offset (arg1);
       v->embedded_offset = offset + value_embedded_offset (arg1) + boffset;
     }
+  else if (NULL != TYPE_DATA_LOCATION (type))
+    {
+      /* Field is a dynamic data member.  */
+
+      gdb_assert (0 == offset);
+      /* We expect an already resolved data location.  */
+      gdb_assert (PROP_CONST == TYPE_DATA_LOCATION_KIND (type));
+      /* For dynamic data types defer memory allocation
+         until we actual access the value.  */
+      v = allocate_value_lazy (type);
+    }
   else
     {
       /* Plain old data member */