This is the mail archive of the gdb-patches@sourceware.org mailing list for the GDB project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[PATCH] fort_dyn_array: enable dynamic array of types


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

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),
-- 
1.7.9.5


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]