[PATCH V2 3/5] 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 wil show wrong
boundaries, size,... or even crash as it will access some
random memory.

2016-06-30  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 (value_ind): Throw error when pointer is
	  not associated.

gdb/Testsuite/Changelog:
	* gdb.fortran/pointers.f90: Add dynamic variables.
	* gdb.fortran/pointers.exp: Test dynamic variables.
	* gdb.fortran/print_type.exp: Test pointer to dynamic
	  types.

---
 gdb/NEWS                                 |  2 +
 gdb/gdbtypes.c                           | 83 ++++++++++++++++++++++++++++++++
 gdb/testsuite/gdb.fortran/pointers.exp   | 48 ++++++++++++++++++
 gdb/testsuite/gdb.fortran/pointers.f90   | 17 +++++++
 gdb/testsuite/gdb.fortran/print_type.exp | 10 ++++
 gdb/valops.c                             |  3 ++
 6 files changed, 163 insertions(+)

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 9e1759b..76ae406 100644
--- a/gdb/gdbtypes.c
+++ b/gdb/gdbtypes.c
@@ -1828,6 +1828,18 @@ is_dynamic_type_internal (struct type *type, int top_level)
 
   switch (TYPE_CODE (type))
     {
+    case TYPE_CODE_PTR:
+      {
+	/* Some Fortran compiler don't create the associated property which
+	   would cause a "return 1".
+	   For a correct value/type print we have to treat every pointer as
+	   dynamic type to cover nullified pointers as well as dynamic target
+	   types.  */
+	if (current_language->la_language == language_fortran)
+	  return 1;
+
+	return 0;
+      }
     case TYPE_CODE_RANGE:
       {
 	/* A range type is obviously dynamic if it has at least one
@@ -2105,6 +2117,73 @@ resolve_dynamic_struct (struct type *type,
   return resolved_type;
 }
 
+/* Worker for pointer types.  */
+
+static struct type *
+resolve_dynamic_pointer (struct type *type,
+			 struct property_addr_info *addr_stack)
+{
+  struct property_addr_info pinfo;
+  int is_associated;
+
+  /* If valaddr is set, the type was already resolved
+     and assigned to an value.  */
+  if (0 != addr_stack->valaddr)
+    return type;
+
+  if (TYPE_OBJFILE_OWNED (type))
+    {
+      struct dynamic_prop *prop;
+      CORE_ADDR value;
+
+      type = copy_type (type);
+
+      /* Resolve associated property.  */
+      prop = TYPE_ASSOCIATED_PROP (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;
+	  is_associated = value;
+	}
+      else
+	{
+	  /* Compiler doesn't create associated property for this pointer
+	     therefore we have to check whether it is still null.  */
+	  if (0 != read_memory_typed_address (addr_stack->addr, type))
+	    is_associated = 1;
+	  else
+	    is_associated = 0;
+	}
+    }
+  else
+    {
+      /* Do nothing, as this pointer is created on the fly and therefore
+	 associated.  For example "print *((integer*) &intvla)".  */
+      is_associated = 1;
+    }
+
+  /* Don't resolve not associated pointers.  */
+  if (0 == is_associated)
+    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;
+}
+
 /* Worker for resolved_dynamic_type.  */
 
 static struct type *
@@ -2153,6 +2232,10 @@ resolve_dynamic_type_internal (struct type *type,
 	    break;
 	  }
 
+        case TYPE_CODE_PTR:
+ 	  resolved_type = resolve_dynamic_pointer (type, addr_stack);
+ 	  break;
+
 	case TYPE_CODE_ARRAY:
 	  resolved_type = resolve_dynamic_array (type, addr_stack);
 	  break;
diff --git a/gdb/testsuite/gdb.fortran/pointers.exp b/gdb/testsuite/gdb.fortran/pointers.exp
index beecbe4..310544c 100644
--- a/gdb/testsuite/gdb.fortran/pointers.exp
+++ b/gdb/testsuite/gdb.fortran/pointers.exp
@@ -59,6 +59,11 @@ gdb_test "print *realp" "Cannot access memory at address 0x0" "print *realp, not
 gdb_test "print \$my_var = intp" "= \\(PTR TO -> \\( $int \\)\\) 0x0"
 
 
+gdb_breakpoint [gdb_get_line_number "Before value assignment"]
+gdb_continue_to_breakpoint "Before value assignment"
+gdb_test "print *(twop)%ivla2" "= <not allocated>"
+
+
 gdb_breakpoint [gdb_get_line_number "After value assignment"]
 gdb_continue_to_breakpoint "After value assignment"
 gdb_test "print logp" "= \\(PTR TO -> \\( $logical \\)\\) $hex\( <.*>\)?"
@@ -71,5 +76,48 @@ gdb_test "print charap" "= \\(PTR TO -> \\( character\\*3 \\)\\) $hex\( <.*>\)?"
 gdb_test "print *charap" "= 'abc'"
 gdb_test "print intp" "= \\(PTR TO -> \\( $int \\)\\) $hex\( <.*>\)?"
 gdb_test "print *intp" "= 10"
+set test_name "print intap, associated"
+gdb_test_multiple "print intap" $test_name {
+  -re "= \\(\\( 1, 1, 3(, 1){7}\\) \\( 1(, 1){9}\\) \\)\r\n$gdb_prompt $" {
+    pass $test_name
+  }
+  -re "= \\(PTR TO -> \\( $int \\(10,2\\)\\)\\) $hex\( <.*>\)?\r\n$gdb_prompt $" {
+    gdb_test "print *intap" "= \\(\\( 1, 1, 3(, 1){7}\\) \\( 1(, 1){9}\\) \\)"
+    pass $test_name
+  }
+}
+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 $" {
+    gdb_test "print *intvlap" "= \\(2, 2, 2, 4(, 2){6}\\)"
+    pass $test_name
+  }
+}
 gdb_test "print realp" "= \\(PTR TO -> \\( $real \\)\\) $hex\( <.*>\)?"
 gdb_test "print *realp" "= 3\\.14000\\d+"
+gdb_test "print arrayOfPtr(2)%p" "= \\(PTR TO -> \\( Type two \\)\\) $hex\( <.*>\)?"
+gdb_test "print *(arrayOfPtr(2)%p)" "= \\( \\(11, 12, 13\\), \\(\\( 211, 221\\) \\( 212, 222\\) \\) \\)"
+set test_name "print arrayOfPtr(3)%p"
+gdb_test_multiple $test_name $test_name {
+  -re "= <not associated>\r\n$gdb_prompt $" {
+    pass $test_name
+  }
+  -re "= \\(PTR TO -> \\( Type two \\)\\) 0x0\r\n$gdb_prompt $" {
+    pass $test_name
+  }
+}
+set test_name "print *(arrayOfPtr(3)%p), associated"
+gdb_test_multiple "print *(arrayOfPtr(3)%p)" $test_name {
+  -re "Location address is not set.\r\n$gdb_prompt $" {
+    pass $test_name
+  }
+  -re "Attempt to take contents of a not associated pointer.\r\n$gdb_prompt $" {
+    pass $test_name
+  }
+}
+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 9ebbaa9..000193c 100644
--- a/gdb/testsuite/gdb.fortran/pointers.f90
+++ b/gdb/testsuite/gdb.fortran/pointers.f90
@@ -20,14 +20,20 @@ program pointers
     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, dimension (10,2) :: inta
+  integer, target, allocatable, dimension (:) :: intvla
   real, target    :: realv
   type(two), target  :: twov
+  type(twoPtr) :: arrayOfPtr (3)
 
   logical, pointer :: logp
   complex, pointer :: comp
@@ -35,6 +41,7 @@ program pointers
   character (len=3), pointer:: charap
   integer, pointer :: intp
   integer, pointer, dimension (:,:) :: intap
+  integer, pointer, dimension (:) :: intvlap
   real, pointer :: realp
   type(two), pointer :: twop
 
@@ -44,8 +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
@@ -53,8 +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)
@@ -63,6 +76,10 @@ program pointers
   intv = 10
   inta(:,:) = 1
   inta(3,1) = 3
+  allocate (intvla(10))
+  intvla(:) = 2
+  intvla(4) = 4
+  intvlap => intvla
   realv = 3.14
 
   allocate (twov%ivla1(3))
diff --git a/gdb/testsuite/gdb.fortran/print_type.exp b/gdb/testsuite/gdb.fortran/print_type.exp
index 37e19ec..1b23af3 100755
--- a/gdb/testsuite/gdb.fortran/print_type.exp
+++ b/gdb/testsuite/gdb.fortran/print_type.exp
@@ -62,6 +62,16 @@ gdb_test "ptype two" \
                 "    $int :: ivla2\\(:,:\\)" \
                 "End Type two"]
 
+
+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\\(:\\)" \
+                "    $int :: ivla2\\(:,:\\)" \
+                "End Type two \\)"]
+
+
 gdb_breakpoint [gdb_get_line_number "After value assignment"]
 gdb_continue_to_breakpoint "After value assignment"
 gdb_test "ptype logv" "type = $logical"
diff --git a/gdb/valops.c b/gdb/valops.c
index 71fb1b3..5ef0c65 100644
--- a/gdb/valops.c
+++ b/gdb/valops.c
@@ -1554,6 +1554,9 @@ value_ind (struct value *arg1)
     {
       struct type *enc_type;
 
+      if (type_not_associated (base_type))
+        error (_("Attempt to take contents of a not associated pointer."));
+
       /* We may be pointing to something embedded in a larger object.
          Get the real type of the enclosing object.  */
       enc_type = check_typedef (value_enclosing_type (arg1));
-- 
2.7.1.339.g0233b80