[PATCH 1/3] Fortran: Handle associated property of pointer types.

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

Some fortran compiler don't create the associated property but
set the pointers content to zero. In order to have a common
way to handle not associated pointers, the missing associated
property is added.

Before:
(gdb) print *intp
Cannot access memory address 0x0

After:
(gdb) print *intp
$1 = <not associated>

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

gdb/Changelog:
	* gdbtypes.c (is_dynamic_type_internal): Handle fortran pointers.
	  (resolve_dynamic_type_internal): Add pointer case.
          (resolve_dynamic_pointer_type): New.

gdb/Testsuite/Changelog:
	* gdb.fortran/pointers.f90: New.
	* gdb.fortran/pointers.exp: New.
	* gdb.fortran/print_type.exp: New.

---
 gdb/gdbtypes.c                           | 67 ++++++++++++++++++++++++++++++++
 gdb/testsuite/gdb.fortran/pointers.exp   | 54 +++++++++++++++++++++++++
 gdb/testsuite/gdb.fortran/pointers.f90   | 61 +++++++++++++++++++++++++++++
 gdb/testsuite/gdb.fortran/print_type.exp | 62 +++++++++++++++++++++++++++++
 gdb/valops.c                             |  3 ++
 5 files changed, 247 insertions(+)
 create mode 100644 gdb/testsuite/gdb.fortran/pointers.exp
 create mode 100644 gdb/testsuite/gdb.fortran/pointers.f90
 create mode 100755 gdb/testsuite/gdb.fortran/print_type.exp

diff --git a/gdb/gdbtypes.c b/gdb/gdbtypes.c
index 9e1759b..ae5b69a 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,57 @@ 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;
+
+  /* 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;
+	}
+      else
+	{
+	  /* Compiler doesn't create associated property for this pointer
+	     therefore we have to check wheater it is still null.  */
+	  struct dynamic_prop prop_asso;
+
+	  if (0 != read_memory_typed_address (addr_stack->addr, type))
+	    prop_asso.data.const_val = 1;
+	  else
+	    prop_asso.data.const_val = 0;
+
+	  prop_asso.kind = PROP_CONST;
+	  add_dyn_prop (DYN_PROP_ASSOCIATED, prop_asso, type, TYPE_OBJFILE(type));
+	}
+    }
+  else
+    {
+      /* Do nothing, as this pointer is created on the fly and therefore
+	 associated.  For example "print *((integer*) &intvla)".  */
+    }
+
+  return type;
+}
+
 /* Worker for resolved_dynamic_type.  */
 
 static struct type *
@@ -2153,6 +2216,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
new file mode 100644
index 0000000..0ab08c0
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/pointers.exp
@@ -0,0 +1,54 @@
+# Copyright 2016 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 "pointers.f90"
+load_lib fortran.exp
+
+if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
+    {debug f90 quiet}] } {
+    return -1
+}
+
+if ![runto_main] {
+    untested "could not run to main"
+    return -1
+}
+
+# Depending on the compiler being used, the type names can be printed differently.
+set logical [fortran_logical4]
+set real [fortran_real4]
+set int [fortran_int4]
+set complex [fortran_complex4]
+
+gdb_breakpoint [gdb_get_line_number "Before pointer assignment"]
+gdb_continue_to_breakpoint "Before pointer assignment"
+gdb_test "print logp" "= <not associated>" "print logp, not associated"
+gdb_test "print comp" "= <not associated>" "print comp, not associated"
+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 realp" "= <not associated>" "print realp, not associated"
+gdb_test "print \$my_var = intp" "= <not associated>"
+
+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"
+gdb_test "print comp" "= \\(PTR TO -> \\( $complex \\)\\) $hex\( <.*>\)?"  "print comp, associated"
+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"
+gdb_test "print realp" "= \\(PTR TO -> \\( $real \\)\\) $hex\( <.*>\)?"  "print realp, associated"
+gdb_test "print *((integer*) &inta + 2)" "= 3" "print temporary pointer, array"
diff --git a/gdb/testsuite/gdb.fortran/pointers.f90 b/gdb/testsuite/gdb.fortran/pointers.f90
new file mode 100644
index 0000000..fbfaed6
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/pointers.f90
@@ -0,0 +1,61 @@
+! Copyright 2016 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/>.
+
+program pointers
+
+  logical, target :: logv
+  complex, target :: comv
+  character, target :: charv
+  character (len=3), target :: chara
+  integer, target :: intv
+  integer, target :: inta (10)
+  real, target    :: realv
+
+  logical, pointer :: logp
+  complex, pointer :: comp
+  character, pointer:: charp
+  character (len=3), pointer:: charap
+  integer, pointer :: intp
+  integer, pointer :: intap (:)
+  real, pointer :: realp
+
+  nullify (logp)
+  nullify (comp)
+  nullify (charp)
+  nullify (charap)
+  nullify (intp)
+  nullify (intap)
+  nullify (realp)
+
+  logp => logv    ! Before pointer assignment
+  comp => comv
+  charp => charv
+  charap => chara
+  intp => intv
+  intap => inta
+  realp => realv
+
+  logv = associated(logp)     ! Before value assignment
+  comv = cmplx(1,2)
+  charv = "a"
+  chara = "abc"
+  intv = 10
+  inta(:) = 1
+  inta(3) = 3
+  realv = 3.14
+ 
+  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
new file mode 100755
index 0000000..283cb24
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/print_type.exp
@@ -0,0 +1,62 @@
+# Copyright 2016 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 "pointers.f90"
+load_lib fortran.exp
+
+if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
+    {debug f90 quiet}] } {
+    return -1
+}
+
+
+if ![runto_main] {
+    untested "could not run to main"
+    return -1
+}
+
+# Depending on the compiler being used, the type names can be printed differently.
+set logical [fortran_logical4]
+set real [fortran_real4]
+set int [fortran_int4]
+set complex [fortran_complex4]
+
+gdb_breakpoint [gdb_get_line_number "Before pointer assignment"]
+gdb_continue_to_breakpoint "Before pointer assignment"
+gdb_test "ptype logp" "= <not associated>" "ptype logp, not associated"
+gdb_test "ptype comp" "= <not associated>" "ptype comp, not associated"
+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 realp" "= <not associated>" "ptype realp, not associated"
+
+gdb_breakpoint [gdb_get_line_number "After value assignment"]
+gdb_continue_to_breakpoint "After value assignment"
+gdb_test "ptype logv" "type = $logical"
+gdb_test "ptype comv" "type = $complex"
+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 realv" "type = $real"
+
+gdb_test "ptype logp" "type = PTR TO -> \\( $logical \\)"
+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 \\)"
+gdb_test "ptype realp" "type = PTR TO -> \\( $real \\)"
+
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