[PATCH] fort_dyn_array: enable dynamic array of types

[PATCH] fort_dyn_array: enable dynamic array of types

[Keven Boell]

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);
+        }
+    }
 }
 
 \f
@@ -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

Re: [PATCH] fort_dyn_array: enable dynamic array of types

[Joel Brobecker]

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.

-- 
Joel

Re: [PATCH] fort_dyn_array: enable dynamic array of types

[Keven Boell]

Hi Joel,

I've narrowed down the patch to the bare minimum and added a more descriptive commit
message, which explains what the patch is supposed to do.  I thought you were still
familiar with the Fortran VLA patch series, were this patch was one part of it.
All hunks get tested in the attached test case.

Updated patch:
---
This patch enables dynamic arrays nested in types in Fortran by
adjusting the address of inner elements of a struct and using
the data_location attribute to fetch values of nested VLA's
in Fortran types.

Example:
type :: mytype
    REAL, ALLOCATABLE :: ivla1 (:, :)
    REAL, ALLOCATABLE :: ivla2 (:)
END TYPE mytype
[...]
type(mytype)   :: mytypev
ALLOCATE (mytypev%ivla1 (2,2))
ALLOCATE (mytypev%ivla2 (2))

mytypev%ivla1(:, :) = 1
mytypev%ivla2(:) = 1

Old:
(gdb) p mytypev%ivla1
$2 = (( 8.84481654e-39, 0) ( -nan(0x7ffffd), -nan(0x7fffff)) )

(gdb) p mytypev%ivla1(1,2)
$3 = -nan(0x7ffffd)
(gdb)

New:
(gdb) p mytypev%ivla1
$2 = (( 1, 321) ( 123, 1) )

(gdb) p mytypev%ivla1(1,2)
$3 = 1

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

	* gdbtypes (resolve_dynamic_struct): Adjust address of inner types
	of a struct to reflect the offset of the inner's type data_location
	of a VLA.
	* value.c (set_value_component_location): Adjust the value address
	for single value prints. For dynamic types compute the address of
	the component value location in sub range types based on the
	location of the sub range type. This enables accessing single
	elements of a nested array.
	(value_primitive_field): Use lazy fetch to re-evaluate a field to
	get the actual value.

testsuite/gdb.fortran:

	* vla-type.exp: New file.
	* vla-type.f90: New file.
---
 gdb/gdbtypes.c                         |    6 +-
 gdb/testsuite/gdb.fortran/vla-type.exp |   94 ++++++++++++++++++++++++++++++++
 gdb/testsuite/gdb.fortran/vla-type.f90 |   89 ++++++++++++++++++++++++++++++
 gdb/value.c                            |   39 +++++++++++--
 4 files changed, 221 insertions(+), 7 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..e8987c1 100644
--- a/gdb/gdbtypes.c
+++ b/gdb/gdbtypes.c
@@ -2064,7 +2064,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..8d8ffde 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);
+        }
+    }
 }
 
 \f
@@ -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_units (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);
-- 
1.7.9.5



Keven

Re: [PATCH] fort_dyn_array: enable dynamic array of types

[Joel Brobecker]

> I've narrowed down the patch to the bare minimum and added a more
> descriptive commit message, which explains what the patch is supposed
> to do.  I thought you were still familiar with the Fortran VLA patch
> series, were this patch was one part of it.  All hunks get tested in
> the attached test case.

Thanks very much for doing this. Again, my deepest apologies for
being so slow in reviewing these. I wish days where 26 hours long!

> ---
> This patch enables dynamic arrays nested in types in Fortran by
> adjusting the address of inner elements of a struct and using
> the data_location attribute to fetch values of nested VLA's
> in Fortran types.
> 
> Example:
> type :: mytype
>     REAL, ALLOCATABLE :: ivla1 (:, :)
>     REAL, ALLOCATABLE :: ivla2 (:)
> END TYPE mytype
> [...]
> type(mytype)   :: mytypev
> ALLOCATE (mytypev%ivla1 (2,2))
> ALLOCATE (mytypev%ivla2 (2))
> 
> mytypev%ivla1(:, :) = 1
> mytypev%ivla2(:) = 1
> 
> Old:
> (gdb) p mytypev%ivla1
> $2 = (( 8.84481654e-39, 0) ( -nan(0x7ffffd), -nan(0x7fffff)) )
> 
> (gdb) p mytypev%ivla1(1,2)
> $3 = -nan(0x7ffffd)
> (gdb)
> 
> New:
> (gdb) p mytypev%ivla1
> $2 = (( 1, 321) ( 123, 1) )
> 
> (gdb) p mytypev%ivla1(1,2)
> $3 = 1
> 
> 2015-03-20  Keven Boell  <keven.boell@intel.com>
> 
> 	* gdbtypes (resolve_dynamic_struct): Adjust address of inner types
> 	of a struct to reflect the offset of the inner's type data_location
> 	of a VLA.
> 	* value.c (set_value_component_location): Adjust the value address
> 	for single value prints. For dynamic types compute the address of
> 	the component value location in sub range types based on the
> 	location of the sub range type. This enables accessing single
> 	elements of a nested array.
> 	(value_primitive_field): Use lazy fetch to re-evaluate a field to
> 	get the actual value.

The "why" (Eg. "This enabls accessing [etc]") should almost always
go into the code, rather than being in the ChangeLog. The ChangeLog
should only mention the "what".

> 
> testsuite/gdb.fortran:
> 
> 	* vla-type.exp: New file.
> 	* vla-type.f90: New file.
> ---
>  gdb/gdbtypes.c                         |    6 +-
>  gdb/testsuite/gdb.fortran/vla-type.exp |   94 ++++++++++++++++++++++++++++++++
>  gdb/testsuite/gdb.fortran/vla-type.f90 |   89 ++++++++++++++++++++++++++++++
>  gdb/value.c                            |   39 +++++++++++--
>  4 files changed, 221 insertions(+), 7 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..e8987c1 100644
> --- a/gdb/gdbtypes.c
> +++ b/gdb/gdbtypes.c
> @@ -2064,7 +2064,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;

I don't quite understand the entire logic behind this change.
Why checking for TYPE_CODE_RANGE? Also, if you adjust pinfo.addr,
you'll need to adjust pinfo.valaddr correspondingly (but watchout
for valaddr being NULL, in which case it needs to stay that way).

[divide by TARGET_CHAR_BIT instead of dividing by 8].

> 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
> +}

See the testcase cookbook, where it shows an example of using runto
and what to do when runto fails:
https://sourceware.org/gdb/wiki/GDBTestcaseCookbook

    if ![runto_main] {
        untested "could not run to main"
        return -1
    }

> +
> +# 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> \\\)" \

For "print <expression>" tests, you don't need to match the $<number>
part, so change the expected to: " = \\\([etc]".

By the way, there are a number of predefined regexps you can use,
which is also documented in that cookbook above:
https://sourceware.org/gdb/wiki/GDBTestcaseCookbook#Convenient_variables_defined_for_use_in_output_matching

In particular, you could have used $decimal instead of \d+.

> +  "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"

For multi-line output, you can use multi_line. You might fine that
the test becomes a lot more readable when you do. This might also
help keep each line under 80 chars.

For the last argument of gdb_test, if it's identical to the command
being sent, I would simply omit it entirely. Otherwise, if you modify
the test, then you run the risk of having the label and the command
no longer match.

[this applies to the rest of the testcase file]

> 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.

Wrong license version and address. Make sure you use the up-to-date
copyright header used in the GDB project.

> diff --git a/gdb/value.c b/gdb/value.c
> index 91bf49e..8d8ffde 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);
> +        }
> +    }

Can you explain that? Most likely, a dump of the DWARF you are trying
to handle would help. The comment talks about "sub range types", but
I don't see any reference to RANGE_TYPEs in the code. And why are
internal vars excluded? You get a sense that internal vars are probably
static regardless, but I fear that the condition might be giving you
the correct result for the wrong reason. I also don't understand why
the address of the address of the component should be the data-location
of the container...

> @@ -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_units (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));

I'm sorry if I am being dense, but I don't undestand this hunk
either. I'm looking at the first "if" you added, and if the field
has a TYPE_DATA_LOCATION, and the data-location is either constant
or has been resolved, then you create a value, except that instead
of using the field's data location, you use arg1's address, which
is the container?!? And then you condition the setting of v->offset
by the opposite of that condititon - why? 

Taking a step back, one thing that strikes me is the fact that
perhaps we could avoid all that special handling of struct/union
component data location if we had resolved the type first. Then
we know that the field's location should be correct. If not, what's
preventing us from making it so, so that the rest of the code can
forget about dynamic types?

-- 
Joel