[binutils-gdb] gdb/fortran: print fortran extended types with ptype

[binutils-gdb] gdb/fortran: print fortran extended types with ptype

[Nils-Christian Kempke]

https://sourceware.org/git/gitweb.cgi?p=binutils-gdb.git;h=110aae55a8b7e19fa5f04998851968e48822605f

commit 110aae55a8b7e19fa5f04998851968e48822605f
Author: Bernhard Heckel <bernhard.heckel@intel.com>
Date:   Tue Apr 5 17:44:46 2022 +0200

    gdb/fortran: print fortran extended types with ptype
    
    Add the print of the base-class of an extended type to the output of
    ptype.  This requires the Fortran compiler to emit DW_AT_inheritance
    for the extended type.
    
    Co-authored-by: Nils-Christian Kempke <nils-christian.kempke@intel.com>

Diff:
---
 gdb/f-lang.h                                  | 11 +++++
 gdb/f-typeprint.c                             | 24 +++++++++-
 gdb/testsuite/gdb.fortran/oop_extend_type.exp | 65 ++++++++++++++++++++-------
 3 files changed, 81 insertions(+), 19 deletions(-)

diff --git a/gdb/f-lang.h b/gdb/f-lang.h
index 2a1f6c7e737..f92d3b01c78 100644
--- a/gdb/f-lang.h
+++ b/gdb/f-lang.h
@@ -266,6 +266,17 @@ private:
 				    int arrayprint_recurse_level,
 				    bool print_rank_only) const;
 
+  /* If TYPE is an extended type, then print out derivation information.
+
+     A typical output could look like this:
+     "Type, extends(point) :: waypoint"
+     "    Type point :: point"
+     "    real(kind=4) :: angle"
+     "End Type waypoint".  */
+
+  void f_type_print_derivation_info (struct type *type,
+				     struct ui_file *stream) const;
+
   /* Print the name of the type (or the ultimate pointer target, function
      value or array element), or the description of a structure or union.
 
diff --git a/gdb/f-typeprint.c b/gdb/f-typeprint.c
index 31786d4ea18..170187c6749 100644
--- a/gdb/f-typeprint.c
+++ b/gdb/f-typeprint.c
@@ -284,6 +284,19 @@ f_language::f_type_print_varspec_suffix (struct type *type,
 
 /* See f-lang.h.  */
 
+void
+f_language::f_type_print_derivation_info (struct type *type,
+					  struct ui_file *stream) const
+{
+  /* Fortran doesn't support multiple inheritance.  */
+  const int i = 0;
+
+  if (TYPE_N_BASECLASSES (type) > 0)
+    gdb_printf (stream, ", extends(%s) ::", TYPE_BASECLASS (type, i)->name ());
+}
+
+/* See f-lang.h.  */
+
 void
 f_language::f_type_print_base (struct type *type, struct ui_file *stream,
 			       int show, int level) const
@@ -396,10 +409,17 @@ f_language::f_type_print_base (struct type *type, struct ui_file *stream,
     case TYPE_CODE_UNION:
     case TYPE_CODE_NAMELIST:
       if (type->code () == TYPE_CODE_UNION)
-	gdb_printf (stream, "%*sType, C_Union :: ", level, "");
+	gdb_printf (stream, "%*sType, C_Union ::", level, "");
       else
-	gdb_printf (stream, "%*sType ", level, "");
+	gdb_printf (stream, "%*sType", level, "");
+
+      if (show > 0)
+	f_type_print_derivation_info (type, stream);
+
+      gdb_puts (" ", stream);
+
       gdb_puts (type->name (), stream);
+
       /* According to the definition,
 	 we only print structure elements in case show > 0.  */
       if (show > 0)
diff --git a/gdb/testsuite/gdb.fortran/oop_extend_type.exp b/gdb/testsuite/gdb.fortran/oop_extend_type.exp
index eefc66c9514..00cfffa0b63 100755
--- a/gdb/testsuite/gdb.fortran/oop_extend_type.exp
+++ b/gdb/testsuite/gdb.fortran/oop_extend_type.exp
@@ -60,12 +60,24 @@ gdb_test "p wp%point" " = \\( coo = \\(1, 2, 1\\) \\)"
 gdb_test "p wp" " = \\( point = \\( coo = \\(1, 2, 1\\) \\), angle = 100 \\)"
 
 gdb_test "whatis wp" "type = Type waypoint"
-gdb_test "ptype wp" \
-  [multi_line "type = Type waypoint" \
-	      "    Type point :: point" \
-	      "    $real :: angle" \
-	      "End Type waypoint"]
-
+set output_pass_wp [multi_line "type = Type, extends\\(point\\) :: waypoint" \
+			       "    Type point :: point" \
+			       "    $real :: angle" \
+			       "End Type waypoint(, allocatable)?"]
+set output_kfail_wp [multi_line "type = Type waypoint" \
+			        "    Type point :: point" \
+			        "    $real :: angle" \
+			        "End Type waypoint(, allocatable)?"]
+
+set test "ptype wp"
+gdb_test_multiple "$test" "$test" {
+    -re "$output_pass_wp\r\n$gdb_prompt $" {
+      pass "$test"
+    }
+    -re "$output_kfail_wp\r\n$gdb_prompt $" {
+      kfail "gcc/49475" "$test"
+    }
+}
 set test "ptype wp%coo"
 gdb_test_multiple "$test" "$test" {
     -re "$real \\(3\\)\r\n$gdb_prompt $" {
@@ -105,11 +117,27 @@ gdb_test_multiple "$test" "$test" {
 }
 
 gdb_test "whatis fwp" "type = Type fancywaypoint"
-gdb_test "ptype fwp" \
-  [multi_line "type = Type fancywaypoint" \
-	      "    Type waypoint :: waypoint" \
-	      "    $logical :: is_fancy" \
-	      "End Type fancywaypoint"]
+set test "ptype fwp"
+
+set output_pass_fwp \
+    [multi_line "type = Type, extends\\(waypoint\\) :: fancywaypoint" \
+		"    Type waypoint :: waypoint" \
+		"    $logical :: is_fancy" \
+		"End Type fancywaypoint"]
+set output_kfail_fwp \
+    [multi_line "type = Type fancywaypoint" \
+		"    Type waypoint :: waypoint" \
+		"    $logical :: is_fancy" \
+		"End Type fancywaypoint"]
+
+gdb_test_multiple "$test" "$test" {
+    -re "$output_pass_fwp\r\n$gdb_prompt $" {
+	pass  "$test"
+    }
+    -re "$output_kfail_fwp\r\n$gdb_prompt $" {
+	kfail "gcc/49475" "$test"
+    }
+}
 
 set test "ptype fwp%coo"
 gdb_test_multiple "$test" "$test" {
@@ -140,12 +168,15 @@ gdb_test "p wp_vla(1)" " = \\( point = \\( coo = \\(10, 12, 10\\) \\), angle = 1
 gdb_test "whatis wp_vla" "type = Type waypoint, allocatable \\(3\\)" \
     "whatis wp_vla after allocation"
 
-gdb_test "ptype wp_vla" \
-  [multi_line "type = Type waypoint" \
-	      "    Type point :: point" \
-	      "    $real :: angle" \
-	      "End Type waypoint, allocatable \\(3\\)"]
-
+set test "ptype wp_vla"
+gdb_test_multiple "$test" "$test" {
+    -re "$output_pass_wp \\(3\\)\r\n$gdb_prompt $" {
+      pass "$test"
+    }
+    -re "$output_kfail_wp \\(3\\)\r\n$gdb_prompt $" {
+      kfail "gcc/49475" "$test"
+    }
+}
 set test "ptype wp_vla(1)%coo"
 gdb_test_multiple "$test" "$test" {
     -re "$real \\(3\\)\r\n$gdb_prompt $" {