From f63782d25ebd593c4c4669d4c394a2706f15e660 Mon Sep 17 00:00:00 2001

From: Bernhard Heckel <bernhard.heckel@intel.com>

Date: Tue, 12 Jul 2016 08:19:34 +0200

Subject: [PATCH 4/7] Fortran: Typeprint, fix dangling types.

Show the type of not-allocated and/or not-associated types

as this is known.  For array types and pointer to array types

we are going to print the number of ranks.

2016-06-30  Bernhard Heckel  <bernhard.heckel@intel.com>

gdb/ChangeLog:

	* f-typeprint.c (f_print_type): Don't bypass dangling types.

	  (f_type_print_varspec_suffix): Add print_rank parameter.

	  (f_type_print_varspec_suffix): Print ranks of array types

	  in case they dangling.

	  (f_type_print_base): Add print_rank parameter.

gdb/Testsuite/ChangeLog:

	* gdb.fortran/pointers.f90: New.

	* gdb.fortran/print_type.exp: New.

	* gdb.fortran/vla-ptype.exp: Adapt expected results.

	* gdb.fortran/vla-type.exp: Likewise.

	* gdb.fortran/vla-value.exp: Likewise.

	* gdb.mi/mi-vla-fortran.exp: Likewise.

Change-Id: Ib55f28b4092cf88e34918449a2ebb6e5daafe512

---

 gdb/f-typeprint.c                        |  95 +++++++++++++++--------------

 gdb/testsuite/gdb.fortran/pointers.f90   |  80 +++++++++++++++++++++++++

 gdb/testsuite/gdb.fortran/print_type.exp | 100 +++++++++++++++++++++++++++++++

 gdb/testsuite/gdb.fortran/vla-ptype.exp  |  12 ++--

 gdb/testsuite/gdb.fortran/vla-type.exp   |   7 ++-

 gdb/testsuite/gdb.fortran/vla-value.exp  |   4 +-

 gdb/testsuite/gdb.mi/mi-vla-fortran.exp  |   9 +--

 7 files changed, 248 insertions(+), 59 deletions(-)

 create mode 100644 gdb/testsuite/gdb.fortran/pointers.f90

 create mode 100755 gdb/testsuite/gdb.fortran/print_type.exp

Index: gdb-7.11.50.20160630/gdb/f-typeprint.c

===================================================================

--- gdb-7.11.50.20160630.orig/gdb/f-typeprint.c	2016-07-16 10:54:48.749099150 +0200

+++ gdb-7.11.50.20160630/gdb/f-typeprint.c	2016-07-16 10:55:59.763667355 +0200

@@ -37,7 +37,7 @@

 #endif

 static void f_type_print_varspec_suffix (struct type *, struct ui_file *, int,

-					 int, int, int);

+					 int, int, int, int);

 void f_type_print_varspec_prefix (struct type *, struct ui_file *,

 				  int, int);

@@ -54,18 +54,6 @@

   enum type_code code;

   int demangled_args;

-  if (type_not_associated (type))

-    {

-      val_print_not_associated (stream);

-      return;

-    }

-

-  if (type_not_allocated (type))

-    {

-      val_print_not_allocated (stream);

-      return;

-    }

-

   f_type_print_base (type, stream, show, level);

   code = TYPE_CODE (type);

   if ((varstring != NULL && *varstring != '\0')

@@ -87,7 +75,7 @@

          so don't print an additional pair of ()'s.  */

       demangled_args = varstring[strlen (varstring) - 1] == ')'; 

-      f_type_print_varspec_suffix (type, stream, show, 0, demangled_args, 0);

+      f_type_print_varspec_suffix (type, stream, show, 0, demangled_args, 0, 0);

    }

 }

@@ -157,7 +145,7 @@

 static void

 f_type_print_varspec_suffix (struct type *type, struct ui_file *stream,

 			     int show, int passed_a_ptr, int demangled_args,

-			     int arrayprint_recurse_level)

+			     int arrayprint_recurse_level, int print_rank_only)

 {

   int upper_bound, lower_bound;

@@ -181,34 +169,50 @@

 	fprintf_filtered (stream, "(");

       if (type_not_associated (type))

-        val_print_not_associated (stream);

+	print_rank_only = 1;

       else if (type_not_allocated (type))

-        val_print_not_allocated (stream);

+	print_rank_only = 1;

+      else if ((TYPE_ASSOCIATED_PROP (type)

+		&& PROP_CONST != TYPE_DYN_PROP_KIND (TYPE_ASSOCIATED_PROP (type)))

+	      || (TYPE_ALLOCATED_PROP (type)

+		&& PROP_CONST != TYPE_DYN_PROP_KIND (TYPE_ALLOCATED_PROP (type)))

+	      || (TYPE_DATA_LOCATION (type)

+		  && PROP_CONST != TYPE_DYN_PROP_KIND (TYPE_DATA_LOCATION (type))))

+	/* This case exist when we ptype a typename which has the

+	   dynamic properties but cannot be resolved as there is

+	   no object.  */

+	print_rank_only = 1;

+

+      if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY)

+	f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,

+				     0, 0, arrayprint_recurse_level,

+				     print_rank_only);

+

+      if (print_rank_only == 1)

+	fprintf_filtered (stream, ":");

       else

-        {

-          if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY)

-            f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,

-                                        0, 0, arrayprint_recurse_level);

-

-          lower_bound = f77_get_lowerbound (type);

-          if (lower_bound != 1)	/* Not the default.  */

-            fprintf_filtered (stream, "%d:", lower_bound);

-

-          /* Make sure that, if we have an assumed size array, we

-             print out a warning and print the upperbound as '*'.  */

-

-          if (TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (type))

-            fprintf_filtered (stream, "*");

-          else

-            {

-              upper_bound = f77_get_upperbound (type);

-              fprintf_filtered (stream, "%d", upper_bound);

-            }

-

-          if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_ARRAY)

-            f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,

-                                        0, 0, arrayprint_recurse_level);

-        }

+	{

+	  lower_bound = f77_get_lowerbound (type);

+	  if (lower_bound != 1)	/* Not the default.  */

+	    fprintf_filtered (stream, "%d:", lower_bound);

+

+	  /* Make sure that, if we have an assumed size array, we

+	     print out a warning and print the upperbound as '*'.  */

+

+	  if (TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (type))

+	    fprintf_filtered (stream, "*");

+	  else

+	    {

+	      upper_bound = f77_get_upperbound (type);

+	      fprintf_filtered (stream, "%d", upper_bound);

+	    }

+	}

+

+      if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_ARRAY)

+	f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,

+				     0, 0, arrayprint_recurse_level,

+				     print_rank_only);

+

       if (arrayprint_recurse_level == 1)

 	fprintf_filtered (stream, ")");

       else

@@ -219,13 +223,14 @@

     case TYPE_CODE_PTR:

     case TYPE_CODE_REF:

       f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 1, 0,

-				   arrayprint_recurse_level);

+				   arrayprint_recurse_level, 0);

       fprintf_filtered (stream, ")");

       break;

     case TYPE_CODE_FUNC:

       f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,

-				   passed_a_ptr, 0, arrayprint_recurse_level);

+				   passed_a_ptr, 0, arrayprint_recurse_level,

+				   0);

       if (passed_a_ptr)

 	fprintf_filtered (stream, ")");

@@ -376,7 +381,7 @@

 	      fputs_filtered (" :: ", stream);

 	      fputs_filtered (TYPE_FIELD_NAME (type, index), stream);

 	      f_type_print_varspec_suffix (TYPE_FIELD_TYPE (type, index),

-					   stream, show - 1, 0, 0, 0);

+					   stream, show - 1, 0, 0, 0, 0);

 	      fputs_filtered ("\n", stream);

 	    }

 	  fprintfi_filtered (level, stream, "End Type ");

Index: gdb-7.11.50.20160630/gdb/testsuite/gdb.fortran/pointers.f90

===================================================================

--- /dev/null	1970-01-01 00:00:00.000000000 +0000

+++ gdb-7.11.50.20160630/gdb/testsuite/gdb.fortran/pointers.f90	2016-07-16 10:55:42.079525860 +0200

@@ -0,0 +1,80 @@

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

+

+  type :: two

+    integer, allocatable :: ivla1 (:)

+    integer, allocatable :: ivla2 (:, :)

+  end type two

+

+  logical, target :: logv

+  complex, target :: comv

+  character, target :: charv

+  character (len=3), target :: chara

+  integer, target :: intv

+  integer, target, dimension (10,2) :: inta

+  real, target    :: realv

+  type(two), target  :: twov

+

+  logical, pointer :: logp

+  complex, pointer :: comp

+  character, pointer:: charp

+  character (len=3), pointer:: charap

+  integer, pointer :: intp

+  integer, pointer, dimension (:,:) :: intap

+  real, pointer :: realp

+  type(two), pointer :: twop

+

+  nullify (logp)

+  nullify (comp)

+  nullify (charp)

+  nullify (charap)

+  nullify (intp)

+  nullify (intap)

+  nullify (realp)

+  nullify (twop)

+

+  logp => logv    ! Before pointer assignment

+  comp => comv

+  charp => charv

+  charap => chara

+  intp => intv

+  intap => inta

+  realp => realv

+  twop => twov

+

+  logv = associated(logp)     ! Before value assignment

+  comv = cmplx(1,2)

+  charv = "a"

+  chara = "abc"

+  intv = 10

+  inta(:,:) = 1

+  inta(3,1) = 3

+  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

Index: gdb-7.11.50.20160630/gdb/testsuite/gdb.fortran/print_type.exp

===================================================================

--- /dev/null	1970-01-01 00:00:00.000000000 +0000

+++ gdb-7.11.50.20160630/gdb/testsuite/gdb.fortran/print_type.exp	2016-07-16 10:55:42.079525860 +0200

@@ -0,0 +1,100 @@

+# 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" "type = PTR TO -> \\( $logical \\)" "ptype logp, not associated"

+gdb_test "ptype comp" "type = PTR TO -> \\( $complex \\)" "ptype comp, not associated"

+gdb_test "ptype charp" "type = PTR TO -> \\( character\\*1 \\)" "ptype charp, not associated"

+gdb_test "ptype charap" "type = PTR TO -> \\( character\\*3 \\)" "ptype charap, not associated"

+gdb_test "ptype intp" "type = PTR TO -> \\( $int \\)" "ptype intp, not associated"

+set test "ptype intap, not associated"

+gdb_test_multiple "ptype intap" $test {

+    -re "type = PTR TO -> \\( $int \\(:,:\\)\\)\r\n$gdb_prompt $" {

+        pass $test

+    }

+    -re "type = $int \\(:,:\\)\r\n$gdb_prompt $" {

+        pass $test

+    }

+}

+gdb_test "ptype realp" "type = PTR TO -> \\( $real \\)" "ptype realp, not associated"

+gdb_test "ptype twop" \

+    [multi_line "type = PTR TO -> \\( Type two" \

+                "    $int :: ivla1\\(:\\)" \

+                "    $int :: ivla2\\(:,:\\)" \

+                "End Type two \\)"] \

+    "ptype twop, not associated"

+gdb_test "ptype two" \

+    [multi_line "type = Type two" \

+                "    $int :: ivla1\\(:\\)" \

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

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

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

+set test "ptype intap"

+gdb_test_multiple $test $test {

+    -re "type = $int \\(10,2\\)\r\n$gdb_prompt $" {

+        pass $test

+    }

+    -re "type = PTR TO -> \\( $int \\(10,2\\)\\)\r\n$gdb_prompt $" {

+        pass $test

+    }

+}

+gdb_test "ptype realp" "type = PTR TO -> \\( $real \\)"

Index: gdb-7.11.50.20160630/gdb/testsuite/gdb.fortran/vla-ptype.exp

===================================================================

--- gdb-7.11.50.20160630.orig/gdb/testsuite/gdb.fortran/vla-ptype.exp	2016-07-16 10:54:48.749099150 +0200

+++ gdb-7.11.50.20160630/gdb/testsuite/gdb.fortran/vla-ptype.exp	2016-07-16 10:55:42.079525860 +0200

@@ -32,9 +32,9 @@

 # Check the ptype of various VLA states and pointer to VLA's.

 gdb_breakpoint [gdb_get_line_number "vla1-init"]

 gdb_continue_to_breakpoint "vla1-init"

-gdb_test "ptype vla1" "type = <not allocated>" "ptype vla1 not initialized"

-gdb_test "ptype vla2" "type = <not allocated>" "ptype vla2 not initialized"

-gdb_test "ptype pvla" "type = <not associated>" "ptype pvla not initialized"

+gdb_test "ptype vla1" "type = $real \\(:,:,:\\)" "ptype vla1 not initialized"

+gdb_test "ptype vla2" "type = $real \\(:,:,:\\)" "ptype vla2 not initialized"

+gdb_test "ptype pvla" "type = $real \\(:,:,:\\)" "ptype pvla not initialized"

 gdb_test "ptype vla1(3, 6, 9)" "no such vector element \\\(vector not allocated\\\)" \

   "ptype vla1(3, 6, 9) not initialized"

 gdb_test "ptype vla2(5, 45, 20)" \

@@ -81,20 +81,20 @@

 gdb_breakpoint [gdb_get_line_number "pvla-deassociated"]

 gdb_continue_to_breakpoint "pvla-deassociated"

-gdb_test "ptype pvla" "type = <not associated>" "ptype pvla deassociated"

+gdb_test "ptype pvla" "type = $real \\(:,:,:\\)" "ptype pvla deassociated"

 gdb_test "ptype pvla(5, 45, 20)" \

   "no such vector element \\\(vector not associated\\\)" \

   "ptype pvla(5, 45, 20) not associated"

 gdb_breakpoint [gdb_get_line_number "vla1-deallocated"]

 gdb_continue_to_breakpoint "vla1-deallocated"

-gdb_test "ptype vla1" "type = <not allocated>" "ptype vla1 not allocated"

+gdb_test "ptype vla1" "type = $real \\(:,:,:\\)" "ptype vla1 not allocated"

 gdb_test "ptype vla1(3, 6, 9)" "no such vector element \\\(vector not allocated\\\)" \

   "ptype vla1(3, 6, 9) not allocated"

 gdb_breakpoint [gdb_get_line_number "vla2-deallocated"]

 gdb_continue_to_breakpoint "vla2-deallocated"

-gdb_test "ptype vla2" "type = <not allocated>" "ptype vla2 not allocated"

+gdb_test "ptype vla2" "type = $real \\(:,:,:\\)" "ptype vla2 not allocated"

 gdb_test "ptype vla2(5, 45, 20)" \

   "no such vector element \\\(vector not allocated\\\)" \

   "ptype vla2(5, 45, 20) not allocated"

Index: gdb-7.11.50.20160630/gdb/testsuite/gdb.fortran/vla-type.exp

===================================================================

--- gdb-7.11.50.20160630.orig/gdb/testsuite/gdb.fortran/vla-type.exp	2016-07-16 10:54:48.749099150 +0200

+++ gdb-7.11.50.20160630/gdb/testsuite/gdb.fortran/vla-type.exp	2016-07-16 10:55:42.080525868 +0200

@@ -132,7 +132,10 @@

                      "End Type one" ]

 # Check allocation status of dynamic array and it's dynamic members

-gdb_test "ptype fivedynarr" "type = <not allocated>"

+gdb_test "ptype fivedynarr" \

+         [multi_line "type = Type five" \

+                     "    Type one :: tone" \

+                     "End Type five \\(:\\)" ]

 gdb_test "next" ""

 gdb_test "ptype fivedynarr(2)" \

          [multi_line "type = Type five" \

@@ -141,7 +144,7 @@

          "ptype fivedynarr(2), tone is not allocated"

 gdb_test "ptype fivedynarr(2)%tone" \

          [multi_line "type = Type one" \

-                     "    $int :: ivla\\(<not allocated>\\)" \

+                     "    $int :: ivla\\(:,:,:\\)" \

                      "End Type one" ] \

          "ptype fivedynarr(2)%tone, not allocated"

Index: gdb-7.11.50.20160630/gdb/testsuite/gdb.fortran/vla-value.exp

===================================================================

--- gdb-7.11.50.20160630.orig/gdb/testsuite/gdb.fortran/vla-value.exp	2016-07-16 10:54:48.749099150 +0200

+++ gdb-7.11.50.20160630/gdb/testsuite/gdb.fortran/vla-value.exp	2016-07-16 10:55:42.080525868 +0200

@@ -34,7 +34,7 @@

 gdb_continue_to_breakpoint "vla1-init"

 gdb_test "print vla1" " = <not allocated>" "print non-allocated vla1"

 gdb_test "print &vla1" \

-  " = \\\(PTR TO -> \\\( $real \\\(<not allocated>\\\)\\\)\\\) $hex" \

+  " = \\\(PTR TO -> \\\( $real \\\(:,:,:\\\)\\\)\\\) $hex" \

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

@@ -75,7 +75,7 @@

 # Try to access values in undefined pointer to VLA (dangling)

 gdb_test "print pvla" " = <not associated>" "print undefined pvla"

 gdb_test "print &pvla" \

-  " = \\\(PTR TO -> \\\( $real \\\(<not associated>\\\)\\\)\\\) $hex" \

+  " = \\\(PTR TO -> \\\( $real \\\(:,:,:\\\)\\\)\\\) $hex" \

   "print non-associated &pvla"

 gdb_test "print pvla(1, 3, 8)" "no such vector element \\\(vector not associated\\\)" \

   "print undefined pvla(1,3,8)"

Index: gdb-7.11.50.20160630/gdb/testsuite/gdb.mi/mi-vla-fortran.exp

===================================================================

--- gdb-7.11.50.20160630.orig/gdb/testsuite/gdb.mi/mi-vla-fortran.exp	2016-07-16 10:54:48.749099150 +0200

+++ gdb-7.11.50.20160630/gdb/testsuite/gdb.mi/mi-vla-fortran.exp	2016-07-16 10:55:42.080525868 +0200

@@ -17,6 +17,7 @@

 # Array (VLA).

 load_lib mi-support.exp

+load_lib fortran.exp

 set MIFLAGS "-i=mi"

 load_lib "fortran.exp"

@@ -50,10 +51,10 @@

 mi_gdb_test "500-data-evaluate-expression vla1" \

   "500\\^done,value=\"<not allocated>\"" "evaluate not allocated vla"

-mi_create_varobj_checked vla1_not_allocated vla1 "<not allocated>" \

+mi_create_varobj_checked vla1_not_allocated vla1 "$real \\(:\\)" \

   "create local variable vla1_not_allocated"

 mi_gdb_test "501-var-info-type vla1_not_allocated" \

-  "501\\^done,type=\"<not allocated>\"" \

+  "501\\^done,type=\"$real \\(:\\)\"" \

   "info type variable vla1_not_allocated"

 mi_gdb_test "502-var-show-format vla1_not_allocated" \

   "502\\^done,format=\"natural\"" \

@@ -140,10 +141,10 @@

     -re "580\\^done,value=\"<not associated>\".*${mi_gdb_prompt}$" {

 	pass $test

-	mi_create_varobj_checked pvla2_not_associated pvla2 "<not associated>" \

+	mi_create_varobj_checked pvla2_not_associated pvla2 "$real \\(:,:\\)" \

 	    "create local variable pvla2_not_associated"

 	mi_gdb_test "581-var-info-type pvla2_not_associated" \

-	    "581\\^done,type=\"<not associated>\"" \

+	    "581\\^done,type=\"$real \\(:,:\\)\"" \

 	    "info type variable pvla2_not_associated"

 	mi_gdb_test "582-var-show-format pvla2_not_associated" \

 	    "582\\^done,format=\"natural\"" \