[PATCH 2/3] Fortran: Resolve dynamic target types of pointers.

[Bernhard Heckel <bernhard dot heckel at intel dot com>]

Dynamic target types of pointers have to be resolved before
they can be further processed. If not, GDB will show wrong
boundaries, size,... or even crash as it will access some
random memory.

2016-05-25  Bernhard Heckel  <bernhard.heckel@intel.com>

gdb/Changelog:
	* NEWS: Added new fortran feature.
	* gdbtypes.c (resolve_dynamic_pointer_types): Resolve dynamic target types.
	* valops.c (address_of_value): Handle not allocated arrays.

gdb/Testsuite/Changelog:
	* gdb.fortran/pointers.f90: Add dynamic variables.
	* gdb.fortran/pointers.exp: Test dynamic variables.
	* gdb.fortran/vla-value.exp: Adapt error message.

---
 gdb/NEWS                                 |  2 ++
 gdb/gdbtypes.c                           | 18 +++++++++++++++
 gdb/testsuite/gdb.fortran/pointers.exp   | 34 ++++++++++++++++++++++++++++
 gdb/testsuite/gdb.fortran/pointers.f90   | 38 +++++++++++++++++++++++++++++++-
 gdb/testsuite/gdb.fortran/print_type.exp | 38 +++++++++++++++++++++++++++++++-
 gdb/testsuite/gdb.fortran/vla-value.exp  |  2 +-
 gdb/valops.c                             |  3 +++
 7 files changed, 132 insertions(+), 3 deletions(-)

diff --git a/gdb/NEWS b/gdb/NEWS
index 3e8e7a1..bea86d3 100644
--- a/gdb/NEWS
+++ b/gdb/NEWS
@@ -3,6 +3,8 @@
 
 *** Changes since GDB 7.11
 
+* Fortran: Support pointers to dynamic types.
+
 * Fortran: Support structures with fields of dynamic types and 
   arrays of dynamic types.
 
diff --git a/gdb/gdbtypes.c b/gdb/gdbtypes.c
index ae5b69a..061785e 100644
--- a/gdb/gdbtypes.c
+++ b/gdb/gdbtypes.c
@@ -2165,6 +2165,24 @@ resolve_dynamic_pointer (struct type *type,
 	 associated.  For example "print *((integer*) &intvla)".  */
     }
 
+  /* Don't resolve not associated pointers.  */
+  if (type_not_associated (type))
+    return type;
+
+  pinfo.type = check_typedef (TYPE_TARGET_TYPE (type));
+  pinfo.valaddr = NULL;
+  /* Data location attr. refers to the "address of the variable".
+     Therefore we don't derefence anything here but
+     keep the "address of the variable".  */
+  if (NULL != TYPE_DATA_LOCATION (pinfo.type))
+    pinfo.addr = addr_stack->addr;
+  else
+    pinfo.addr = read_memory_typed_address (addr_stack->addr, type);
+  pinfo.next = addr_stack;
+  TYPE_TARGET_TYPE (type) =
+      resolve_dynamic_type_internal (TYPE_TARGET_TYPE (type),
+				     &pinfo, 0);
+
   return type;
 }
 
diff --git a/gdb/testsuite/gdb.fortran/pointers.exp b/gdb/testsuite/gdb.fortran/pointers.exp
index 0ab08c0..ebb04a7 100644
--- a/gdb/testsuite/gdb.fortran/pointers.exp
+++ b/gdb/testsuite/gdb.fortran/pointers.exp
@@ -40,9 +40,17 @@ gdb_test "print charp" "= <not associated>" "print charp, not associated"
 gdb_test "print charap" "= <not associated>" "print charap, not associated"
 gdb_test "print intp" "= <not associated>" "print intp, not associated"
 gdb_test "print intap" "= <not associated>" "print intap, not associated"
+gdb_test "print intvlap" "= <not associated>" "print intvlap, not associated"
 gdb_test "print realp" "= <not associated>" "print realp, not associated"
+gdb_test "print twop" "= <not associated>" "print twop, not associated"
 gdb_test "print \$my_var = intp" "= <not associated>"
 
+gdb_breakpoint [gdb_get_line_number "Before value assignment"]
+gdb_continue_to_breakpoint "Before value assignment"
+gdb_test "print twop%ivla2" "= <not allocated>"
+gdb_test "print *((integer*) &intvla)" "Array \"intvla\" is not allocated." \
+   "print temporary pointer, not allocated vla"
+
 gdb_breakpoint [gdb_get_line_number "After value assignment"]
 gdb_continue_to_breakpoint "After value assignment"
 gdb_test "print logp" "= \\(PTR TO -> \\( $logical \\)\\) $hex\( <.*>\)?"  "print logp, associated"
@@ -50,5 +58,31 @@ gdb_test "print comp" "= \\(PTR TO -> \\( $complex \\)\\) $hex\( <.*>\)?"  "prin
 gdb_test "print charp" "= \\(PTR TO -> \\( character\\*1 \\)\\) $hex\( <.*>\)?" "print charp, associated"
 gdb_test "print charap" "= \\(PTR TO -> \\( character\\*3 \\)\\) $hex\( <.*>\)?" "print charap, associated"
 gdb_test "print intp" "= \\(PTR TO -> \\( $int \\)\\) $hex\( <.*>\)?"  "print intp, associated"
+set test_name "print intap, associated"
+gdb_test_multiple "print intap" $test_name {
+  -re "= \\(1, 1, 3(, 1){7}\\)\r\n$gdb_prompt $" {
+    pass $test_name
+  }
+  -re "= \\(PTR TO -> \\( $int \\(10\\)\\)\\) $hex\( <.*>\)?\r\n$gdb_prompt $" {
+    pass $test_name
+  }
+  timeout { fail "$test_name (timeout)" }
+}
+set test_name "print intvlap, associated"
+gdb_test_multiple "print intvlap" $test_name {
+  -re "= \\(2, 2, 2, 4(, 2){6}\\)\r\n$gdb_prompt $" {
+    pass $test_name
+  }
+  -re "= \\(PTR TO -> \\( $int \\(10\\)\\)\\) $hex\( <.*>\)?\r\n$gdb_prompt $" {
+    pass $test_name
+  }
+  timeout { fail "$test_name (timeout)" }
+}
 gdb_test "print realp" "= \\(PTR TO -> \\( $real \\)\\) $hex\( <.*>\)?"  "print realp, associated"
+gdb_test "print twop" "= \\(PTR TO -> \\( Type two \\)\\) $hex\( <.*>\)?"
+gdb_test "print arrayOfPtr(2)%p" "= \\(PTR TO -> \\( Type two \\)\\) $hex\( <.*>\)?"
+gdb_test "print arrayOfPtr(3)%p" "= <not associated>"
 gdb_test "print *((integer*) &inta + 2)" "= 3" "print temporary pointer, array"
+gdb_test "print *((integer*) &intvla + 3)" "= 4" "print temporary pointer, allocated vla"
+gdb_test "print \$pc" "= \\(PTR TO -> \\( void \\(\\)\\(\\)\\)\\) $hex <pointers\\+\\d+>" "Print program counter"
+
diff --git a/gdb/testsuite/gdb.fortran/pointers.f90 b/gdb/testsuite/gdb.fortran/pointers.f90
index fbfaed6..8b26959 100644
--- a/gdb/testsuite/gdb.fortran/pointers.f90
+++ b/gdb/testsuite/gdb.fortran/pointers.f90
@@ -15,13 +15,25 @@
 
 program pointers
 
+  type :: two
+    integer, allocatable :: ivla1 (:)
+    integer, allocatable :: ivla2 (:, :)
+  end type two
+
+  type :: twoPtr
+    type (two), pointer :: p
+  end type twoPtr
+
   logical, target :: logv
   complex, target :: comv
   character, target :: charv
   character (len=3), target :: chara
   integer, target :: intv
   integer, target :: inta (10)
+  integer, allocatable, target :: intvla (:)
   real, target    :: realv
+  type(two), target  :: twov
+  type(twoPtr) :: arrayOfPtr (3)
 
   logical, pointer :: logp
   complex, pointer :: comp
@@ -29,7 +41,9 @@ program pointers
   character (len=3), pointer:: charap
   integer, pointer :: intp
   integer, pointer :: intap (:)
+  integer, pointer :: intvlap (:)
   real, pointer :: realp
+  type(two), pointer :: twop
 
   nullify (logp)
   nullify (comp)
@@ -37,7 +51,12 @@ program pointers
   nullify (charap)
   nullify (intp)
   nullify (intap)
+  nullify (intvlap)
   nullify (realp)
+  nullify (twop)
+  nullify (arrayOfPtr(1)%p)
+  nullify (arrayOfPtr(2)%p)
+  nullify (arrayOfPtr(3)%p)
 
   logp => logv    ! Before pointer assignment
   comp => comv
@@ -45,7 +64,10 @@ program pointers
   charap => chara
   intp => intv
   intap => inta
+  intvlap => intvla
   realp => realv
+  twop => twov
+  arrayOfPtr(2)%p => twov
 
   logv = associated(logp)     ! Before value assignment
   comv = cmplx(1,2)
@@ -54,8 +76,22 @@ program pointers
   intv = 10
   inta(:) = 1
   inta(3) = 3
+  allocate (intvla(10))
+  intvla(:) = 2
+  intvla(4) = 4
+  intvlap => intvla
   realv = 3.14
- 
+
+  allocate (twov%ivla1(3))
+  allocate (twov%ivla2(2,2))
+  twov%ivla1(1) = 11
+  twov%ivla1(2) = 12
+  twov%ivla1(3) = 13
+  twov%ivla2(1,1) = 211
+  twov%ivla2(2,1) = 221
+  twov%ivla2(1,2) = 212
+  twov%ivla2(2,2) = 222
+
   intv = intv + 1 ! After value assignment
 
 end program pointers
diff --git a/gdb/testsuite/gdb.fortran/print_type.exp b/gdb/testsuite/gdb.fortran/print_type.exp
index 283cb24..e97fb42 100755
--- a/gdb/testsuite/gdb.fortran/print_type.exp
+++ b/gdb/testsuite/gdb.fortran/print_type.exp
@@ -41,7 +41,18 @@ gdb_test "ptype charp" "= <not associated>" "ptype charp, not associated"
 gdb_test "ptype charap" "= <not associated>" "ptype charap, not associated"
 gdb_test "ptype intp" "= <not associated>" "ptype intp, not associated"
 gdb_test "ptype intap" "= <not associated>" "ptype intap, not associated"
+gdb_test "ptype intvlap" "= <not associated>" "ptype intvlap, not associated"
 gdb_test "ptype realp" "= <not associated>" "ptype realp, not associated"
+gdb_test "ptype twop" "= <not associated>" "ptype twop, not associated"
+
+gdb_breakpoint [gdb_get_line_number "Before value assignment"]
+gdb_continue_to_breakpoint "Before value assignment"
+gdb_test "ptype twop" \
+    [multi_line "type = PTR TO -> \\( Type two" \
+    "    $int :: ivla1\\(<not allocated>\\)" \
+    "    $int :: ivla2\\(<not allocated>\\)" \
+    "End Type two \\)"] \
+    "ptype twop, members not allocated"
 
 gdb_breakpoint [gdb_get_line_number "After value assignment"]
 gdb_continue_to_breakpoint "After value assignment"
@@ -51,6 +62,7 @@ gdb_test "ptype charv" "type = character\\*1"
 gdb_test "ptype chara" "type = character\\*3"
 gdb_test "ptype intv" "type = $int"
 gdb_test "ptype inta" "type = $int \\(10\\)"
+gdb_test "ptype intvla" "type = $int \\(10\\)"
 gdb_test "ptype realv" "type = $real"
 
 gdb_test "ptype logp" "type = PTR TO -> \\( $logical \\)"
@@ -58,5 +70,29 @@ gdb_test "ptype comp" "type = PTR TO -> \\( $complex \\)"
 gdb_test "ptype charp" "type = PTR TO -> \\( character\\*1 \\)"
 gdb_test "ptype charap" "type = PTR TO -> \\( character\\*3 \\)"
 gdb_test "ptype intp" "type = PTR TO -> \\( $int \\)"
+set test "ptype intap"
+gdb_test_multiple $test $test {
+  -re "type = $int \\(10\\)\r\n$gdb_prompt $" {
+    pass $test
+  }
+  -re "type = PTR TO -> \\( $int \\(10\\)\\)\r\n$gdb_prompt $" {
+    pass $test
+  }
+  timeout { fail "$test (timeout)" }
+}
+set test "ptype intvlap"
+gdb_test_multiple $test $test {
+  -re "type = $int \\(10\\)\r\n$gdb_prompt $" {
+    pass $test
+  }
+  -re "type = PTR TO -> \\( $int \\(10\\)\\)\r\n$gdb_prompt $" {
+    pass $test
+  }
+  timeout { fail "$test (timeout)" }
+}
 gdb_test "ptype realp" "type = PTR TO -> \\( $real \\)"
-
+gdb_test "ptype twop" \
+    [multi_line "type = PTR TO -> \\( Type two" \
+    "    $int :: ivla1\\(3\\)" \
+    "    $int :: ivla2\\(2,2\\)" \
+    "End Type two \\)"]
diff --git a/gdb/testsuite/gdb.fortran/vla-value.exp b/gdb/testsuite/gdb.fortran/vla-value.exp
index 0945181..d12a335 100644
--- a/gdb/testsuite/gdb.fortran/vla-value.exp
+++ b/gdb/testsuite/gdb.fortran/vla-value.exp
@@ -30,7 +30,7 @@ gdb_breakpoint [gdb_get_line_number "vla1-init"]
 gdb_continue_to_breakpoint "vla1-init"
 gdb_test "print vla1" " = <not allocated>" "print non-allocated vla1"
 gdb_test "print &vla1" \
-  " = \\\(PTR TO -> \\\( real\\\(kind=4\\\) \\\(<not allocated>\\\)\\\)\\\) $hex" \
+  "Array \"vla1\" is not allocated." \
   "print non-allocated &vla1"
 gdb_test "print vla1(1,1,1)" "no such vector element \\\(vector not allocated\\\)" \
   "print member in non-allocated vla1 (1)"
diff --git a/gdb/valops.c b/gdb/valops.c
index 5ef0c65..5efe9b1 100644
--- a/gdb/valops.c
+++ b/gdb/valops.c
@@ -1314,6 +1314,9 @@ address_of_variable (struct symbol *var, const struct block *b)
   val = value_of_variable (var, b);
   type = value_type (val);
 
+  if (type_not_allocated (type))
+    error (_("Array \"%s\" is not allocated."), SYMBOL_PRINT_NAME (var));
+
   if ((VALUE_LVAL (val) == lval_memory && value_lazy (val))
       || TYPE_CODE (type) == TYPE_CODE_FUNC)
     {
-- 
2.7.1.339.g0233b80