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

Keven Boell
2015-11-06T09:28:12Z

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