diff mbox

fort_dyn_array: enable dynamic array of types

Message ID 1446738991-23962-1-git-send-email-keven.boell@intel.com
State New
Headers show

Commit Message

Keven Boell Nov. 5, 2015, 3:56 p.m. UTC
This patch enables dynamic arrays of types in Fortran.

2015-03-20  Keven Boell  <keven.boell@intel.com>

	* gdbtypes.c (resolve_dyn_properties): New.
	(resolve_dynamic_range): Add call to resolve_dyn_properties
	to resolve data_location.
	(resolve_dynamic_array): Add call to resolve_dyn_properties
	to resolve data_location.
	(resolve_dynamic_union): Add call to resolve_dyn_properties
	to resolve_data_location.
	(resolve_dynamic_struct): Add call to resolve_dyn_properties
	to resolve_data_location.  Adjust address of inner types of
	a struct to reflect the offset of the inner's type data_location.
	(resolve_dynamic_type_internal): Remove data_location computation.
	* value.c (set_value_component_location): Adjust the value address
	for single value prints.
	(value_primitive_field): Use lazy fetch to re-evaluate a field to
	get the actual value.
	(value_fetch_lazy): Use address provided by DWARF data_location
	attribute if present.

testsuite/gdb.fortran:

	* vla-type.exp: New file.
	* vla-type.f90: New file.
---
 gdb/gdbtypes.c                         |   33 ++++++++++-
 gdb/testsuite/gdb.fortran/vla-type.exp |   94 ++++++++++++++++++++++++++++++++
 gdb/testsuite/gdb.fortran/vla-type.f90 |   89 ++++++++++++++++++++++++++++++
 gdb/value.c                            |   47 +++++++++++++---
 4 files changed, 253 insertions(+), 10 deletions(-)
 create mode 100755 gdb/testsuite/gdb.fortran/vla-type.exp
 create mode 100755 gdb/testsuite/gdb.fortran/vla-type.f90

Comments

Joel Brobecker Nov. 5, 2015, 4:56 p.m. UTC | #1
Keven,

On Thu, Nov 05, 2015 at 04:56:31PM +0100, Keven Boell wrote:
> This patch enables dynamic arrays of types in Fortran.
> 
> 2015-03-20  Keven Boell  <keven.boell@intel.com>
> 
> 	* gdbtypes.c (resolve_dyn_properties): New.
> 	(resolve_dynamic_range): Add call to resolve_dyn_properties
> 	to resolve data_location.
> 	(resolve_dynamic_array): Add call to resolve_dyn_properties
> 	to resolve data_location.
> 	(resolve_dynamic_union): Add call to resolve_dyn_properties
> 	to resolve_data_location.
> 	(resolve_dynamic_struct): Add call to resolve_dyn_properties
> 	to resolve_data_location.  Adjust address of inner types of
> 	a struct to reflect the offset of the inner's type data_location.
> 	(resolve_dynamic_type_internal): Remove data_location computation.
> 	* value.c (set_value_component_location): Adjust the value address
> 	for single value prints.
> 	(value_primitive_field): Use lazy fetch to re-evaluate a field to
> 	get the actual value.
> 	(value_fetch_lazy): Use address provided by DWARF data_location
> 	attribute if present.
> 
> testsuite/gdb.fortran:
> 
> 	* vla-type.exp: New file.
> 	* vla-type.f90: New file.

This is really not the way I tried to explained how these changes
should be submitted. I don't know about others, but I can't understand
the reasons for the changes if you don't show me what's happening
today, the debugging info, why the debugger is failing, and explain
how you are fixing the issue.

For instance, I suspect that this patch can be split into smaller,
independent patches, which themselves fixes a smaller set of issues.
And I'd like to make sure we have a test for each hunk that you're
adding.
diff mbox

Patch

diff --git a/gdb/gdbtypes.c b/gdb/gdbtypes.c
index b9850cf..4a9cae8 100644
--- a/gdb/gdbtypes.c
+++ b/gdb/gdbtypes.c
@@ -1878,6 +1878,21 @@  is_dynamic_type (struct type *type)
 static struct type *resolve_dynamic_type_internal
   (struct type *type, struct property_addr_info *addr_stack, int top_level);
 
+static void
+resolve_dyn_properties (struct type *type, struct property_addr_info *addr_stack)
+{
+  CORE_ADDR value;
+  struct dynamic_prop *prop;
+
+  /* Resolve data_location attribute.  */
+  prop = TYPE_DATA_LOCATION (type);
+  if (prop != NULL && dwarf2_evaluate_property (prop, NULL, addr_stack, &value))
+    {
+      TYPE_DYN_PROP_ADDR (prop) = value;
+      TYPE_DYN_PROP_KIND (prop) = PROP_CONST;
+    }
+}
+
 /* Given a dynamic range type (dyn_range_type) and a stack of
    struct property_addr_info elements, return a static version
    of that type.  */
@@ -1929,6 +1944,7 @@  resolve_dynamic_range (struct type *dyn_range_type,
 					 static_target_type,
 					 &low_bound, &high_bound);
   TYPE_RANGE_DATA (static_range_type)->flag_bound_evaluated = 1;
+  resolve_dyn_properties (static_range_type, addr_stack);
   return static_range_type;
 }
 
@@ -1945,6 +1961,7 @@  resolve_dynamic_array (struct type *type,
   struct type *range_type;
   struct type *ary_dim;
   struct dynamic_prop *prop;
+  struct type *return_type;
 
   gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
 
@@ -1976,8 +1993,10 @@  resolve_dynamic_array (struct type *type,
   else
     elt_type = TYPE_TARGET_TYPE (type);
 
-  return create_array_type_with_stride (type, elt_type, range_type,
-                                        TYPE_FIELD_BITSIZE (type, 0));
+  return_type = create_array_type_with_stride (type,
+			    elt_type, range_type, TYPE_FIELD_BITSIZE (type, 0));
+  resolve_dyn_properties (return_type, addr_stack);
+  return return_type;
 }
 
 /* Resolve dynamic bounds of members of the union TYPE to static
@@ -2017,6 +2036,7 @@  resolve_dynamic_union (struct type *type,
     }
 
   TYPE_LENGTH (resolved_type) = max_len;
+  resolve_dyn_properties (resolved_type, addr_stack);
   return resolved_type;
 }
 
@@ -2043,6 +2063,9 @@  resolve_dynamic_struct (struct type *type,
   memcpy (TYPE_FIELDS (resolved_type),
 	  TYPE_FIELDS (type),
 	  TYPE_NFIELDS (resolved_type) * sizeof (struct field));
+
+  resolve_dyn_properties (resolved_type, addr_stack);
+
   for (i = 0; i < TYPE_NFIELDS (resolved_type); ++i)
     {
       unsigned new_bit_length;
@@ -2064,7 +2087,11 @@  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;
+      if (TYPE_CODE (TYPE_FIELD_TYPE (resolved_type, i)) != TYPE_CODE_RANGE)
+        pinfo.addr = addr_stack->addr
+                + (TYPE_FIELD_BITPOS (resolved_type, i) / 8);
+      else
+        pinfo.addr = addr_stack->addr;
       pinfo.next = addr_stack;
 
       TYPE_FIELD_TYPE (resolved_type, i)
diff --git a/gdb/testsuite/gdb.fortran/vla-type.exp b/gdb/testsuite/gdb.fortran/vla-type.exp
new file mode 100755
index 0000000..ffd0ab4
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/vla-type.exp
@@ -0,0 +1,94 @@ 
+# Copyright 2015 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
+}
+
+# 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" "\\$\\d+ = \\\( <not allocated>, <not allocated> \\\)" \
+  "print twov before allocated"
+gdb_test "print twov%ivla1" "\\$\\d+ = <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)" "\\$\\d+ = 1" "print onev%ivla(5, 11, 23)"
+gdb_test "print onev%ivla(1, 2, 3)" "\\$\\d+ = 123" "print onev%ivla(1, 2, 3)"
+gdb_test "print onev%ivla(3, 2, 1)" "\\$\\d+ = 321" "print onev%ivla(3, 2, 1)"
+gdb_test "ptype onev" \
+  "type = Type one\r\n\\s+real\\\(kind=4\\\) :: ivla\\\(11,22,33\\\)\r\nEnd Type one" \
+  "ptype onev"
+
+# 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)" "\\$\\d+ = 1" \
+  "print twov%ivla1(5, 11, 23)"
+gdb_test "print twov%ivla1(1, 2, 3)" "\\$\\d+ = 123" \
+  "print twov%ivla1(1, 2, 3)"
+gdb_test "print twov%ivla1(3, 2, 1)" "\\$\\d+ = 321" \
+  "print twov%ivla1(3, 2, 1)"
+gdb_test "ptype twov" \
+  "type = Type two\r\n\\s+real\\\(kind=4\\\) :: ivla1\\\(5,12,99\\\)\r\n\\s+real\\\(kind=4\\\) :: ivla2\\\(9,12\\\)\r\nEnd Type two" \
+  "ptype twov"
+
+# 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)" "\\$\\d+ = 1" "print threev%ivla(1)"
+gdb_test "print threev%ivla(5)" "\\$\\d+ = 42" "print threev%ivla(5)"
+gdb_test "print threev%ivla(14)" "\\$\\d+ = 24" "print threev%ivla(14)"
+gdb_test "print threev%ivar" "\\$\\d+ = 3.14\\d+?" "print threev%ivar"
+gdb_test "ptype threev" \
+  "type = Type three\r\n\\s+real\\\(kind=4\\\) :: ivar\r\n\\s+real\\\(kind=4\\\) :: ivla\\\(20\\\)\r\nEnd Type three" \
+  "ptype threev"
+
+# 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)" "\\$\\d+ = 1" "print fourv%ivla(1)"
+gdb_test "print fourv%ivla(2)" "\\$\\d+ = 2" "print fourv%ivla(2)"
+gdb_test "print fourv%ivla(7)" "\\$\\d+ = 7" "print fourv%ivla(7)"
+gdb_test "print fourv%ivla(12)" "no such vector element" "print fourv%ivla(12)"
+gdb_test "print fourv%ivar" "\\$\\d+ = 3.14\\d+?" "print fourv%ivar"
+gdb_test "ptype fourv" \
+  "type = Type four\r\n\\s+real\\\(kind=4\\\) :: ivla\\\(10\\\)\r\n\\s+real\\\(kind=4\\\) :: ivar\r\nEnd Type four" \
+  "ptype fourv"
+
+# 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)" "\\$\\d+ = 1" \
+  "print fivev%tone%ivla(5, 5, 1)"
+gdb_test "print fivev%tone%ivla(1, 2, 3)" "\\$\\d+ = 123" \
+  "print fivev%tone%ivla(1, 2, 3)"
+gdb_test "print fivev%tone%ivla(3, 2, 1)" "\\$\\d+ = 321" \
+  "print fivev%tone%ivla(3, 2, 1)"
+gdb_test "ptype fivev" \
+  "type = Type five\r\n\\s+Type one\r\n\\s+real\\\(kind=4\\\) :: ivla\\\(10,10,10\\\)\r\n\\s+End Type one :: tone\r\nEnd Type five" \
+  "ptype fivev"
diff --git a/gdb/testsuite/gdb.fortran/vla-type.f90 b/gdb/testsuite/gdb.fortran/vla-type.f90
new file mode 100755
index 0000000..cf3f24b
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/vla-type.f90
@@ -0,0 +1,89 @@ 
+! Copyright 2015 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 2 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, write to the Free Software
+! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+program vla_struct
+  type :: one
+    real, allocatable :: ivla (:, :, :)
+  end type one
+  type :: two
+    real, allocatable :: ivla1 (:, :, :)
+    real, allocatable :: ivla2 (:, :)
+  end type two
+  type :: three
+    real :: ivar
+    real, allocatable :: ivla (:)
+  end type three
+  type :: four
+    real, allocatable :: ivla (:)
+    real :: 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.14                      ! 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.14
+  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 91bf49e..365cbaf 100644
--- a/gdb/value.c
+++ b/gdb/value.c
@@ -1788,6 +1788,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);
+        }
+    }
 }
 
 
@@ -3095,13 +3114,21 @@  value_primitive_field (struct value *arg1, int offset,
 	v = allocate_value_lazy (type);
       else
 	{
-	  v = allocate_value (type);
-	  value_contents_copy_raw (v, value_embedded_offset (v),
-				   arg1, value_embedded_offset (arg1) + offset,
-				   type_length_units (type));
+      if (TYPE_DATA_LOCATION (type)
+          && TYPE_DATA_LOCATION_KIND (type) == PROP_CONST)
+        v = value_at_lazy (type, value_address (arg1) + offset);
+      else
+        {
+          v = allocate_value (type);
+          value_contents_copy_raw (v, value_embedded_offset (v),
+                 arg1, value_embedded_offset (arg1) + offset,
+                 TYPE_LENGTH (type));
+        }
 	}
-      v->offset = (value_offset (arg1) + offset
-		   + value_embedded_offset (arg1));
+      if (!TYPE_DATA_LOCATION (type)
+              || !TYPE_DATA_LOCATION_KIND (type) == PROP_CONST)
+        v->offset = (value_offset (arg1) + offset
+         + value_embedded_offset (arg1));
     }
   set_value_component_location (v, arg1);
   VALUE_REGNUM (v) = VALUE_REGNUM (arg1);
@@ -3834,9 +3861,15 @@  value_fetch_lazy (struct value *val)
     }
   else if (VALUE_LVAL (val) == lval_memory)
     {
-      CORE_ADDR addr = value_address (val);
+      CORE_ADDR addr;
       struct type *type = check_typedef (value_enclosing_type (val));
 
+      if (TYPE_DATA_LOCATION (type) != NULL
+              && TYPE_DATA_LOCATION_KIND (type) == PROP_CONST)
+        addr = TYPE_DATA_LOCATION_ADDR (type);
+      else
+        addr = value_address (val);
+
       if (TYPE_LENGTH (type))
 	read_value_memory (val, 0, value_stack (val),
 			   addr, value_contents_all_raw (val),