Fortran: Ptype, print type extension.

Print base-class of an extended type when doing a ptype.

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

gdb/Changelog:
	* gdb/f-typeprint.c (f_type_print_derivation_info): New.
	(f_type_print_base): Print baseclass info.

gdb/Testsuite/Changelog:
	* gdb.fortran/oop_extend_type.exp: Adapt expected results.

Change-Id: I95e91357137a7b5aa178ffd7bb6839feb6b436bb

gdb/f-exp.y

@@ -608,8 +608,11 @@ nonempty_typelist
 		}
 	;
 
-name	:	NAME
-		{  $$ = $1.stoken; }
+name
+	:	NAME
+		{ $$ = $1.stoken; }
+	|	TYPENAME
+		{ $$ = $1.stoken; }
 	;
 
 name_not_typename :	NAME

gdb/f-typeprint.c

@@ -254,6 +254,24 @@ f_type_print_varspec_suffix (struct type *type, struct ui_file *stream,
     }
 }
 
+/* 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"
+ */
+
+static void
+f_type_print_derivation_info (struct type *type, struct ui_file *stream)
+{
+  int i = 0;  // Fortran doesn't support multiple inheritance.
+
+  if (TYPE_N_BASECLASSES (type) > 0)
+    fprintf_filtered (stream, ", extends(%s) ::", type_name_no_tag (TYPE_BASECLASS (type, i)));
+}
+
 /* Print the name of the type (or the ultimate pointer target,
    function value or array element), or the description of a
    structure or union.
@@ -360,10 +378,15 @@ f_type_print_base (struct type *type, struct ui_file *stream, int show,
     case TYPE_CODE_STRUCT:
     case TYPE_CODE_UNION:
       if (TYPE_CODE (type) == TYPE_CODE_UNION)
-	fprintfi_filtered (level, stream, "Type, C_Union :: ");
+	fprintfi_filtered (level, stream, "Type, C_Union ::");
       else
-	fprintfi_filtered (level, stream, "Type ");
-      fputs_filtered (TYPE_TAG_NAME (type), stream);
+	fprintfi_filtered (level, stream, "Type");
+
+      if (show > 0)
+	f_type_print_derivation_info (type, stream);
+
+      fprintf_filtered (stream, " %s", TYPE_TAG_NAME (type));
+
       /* According to the definition,
          we only print structure elements in case show > 0.  */
       if (show > 0)

gdb/testsuite/gdb.fortran/oop_extend_type.exp

@@ -0,0 +1,112 @@
+# 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 ".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 real [fortran_real4]
+
+gdb_breakpoint [gdb_get_line_number "! Before vla allocation"]
+gdb_continue_to_breakpoint "! Before vla allocation" ".*! Before vla allocation"
+gdb_test "whatis wp_vla" "type = <not allocated>"
+
+gdb_breakpoint [gdb_get_line_number "! After value assignment"]
+gdb_continue_to_breakpoint "! After value assignment" ".*! After value assignment"
+set test "p wp%coo"
+gdb_test_multiple "$test" "$test" {
+    -re " = \\(1, 2, 1\\)\r\n$gdb_prompt $" {
+      pass "$test"
+    }
+    -re "There is no member named coo.\r\n$gdb_prompt $" {
+      kfail "gcc/49475" "$test"
+    }
+}
+gdb_test "p wp%point%coo" " = \\(1, 2, 1\\)"
+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"
+set output_pass [multi_line "type = Type, extends\\(point\\) :: waypoint" \
+              "    Type point :: point" \
+              "    $real :: angle" \
+              "End Type waypoint"]
+set output_kfail [multi_line "type = Type waypoint" \
+              "    Type point :: point" \
+              "    $real :: angle" \
+              "End Type waypoint"]
+set test "ptype wp"
+gdb_test_multiple $test %test {
+    -re "$output_pass\r\n$gdb_prompt $" {
+      pass "$test"
+    }
+    -re "$output_kfail\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 $" {
+      pass "$test"
+    }
+    -re "There is no member named coo.\r\n$gdb_prompt $" {
+      kfail "gcc/49475" "$test"
+    }
+}
+gdb_test "ptype wp%point%coo" "$real \\(3\\)"
+
+set test "p wp_vla(1)%coo"
+gdb_test_multiple "$test" "$test" {
+    -re " = \\(10, 12, 10\\)\r\n$gdb_prompt $" {
+      pass "$test"
+    }
+    -re "There is no member named coo.\r\n$gdb_prompt $" {
+      kfail "gcc/49475" "$test"
+    }
+}
+gdb_test "p wp_vla(1)%point%coo" " = \\(10, 12, 10\\)"
+gdb_test "p wp_vla(1)%point" " = \\( coo = \\(10, 12, 10\\) \\)"
+gdb_test "p wp_vla(1)" " = \\( point = \\( coo = \\(10, 12, 10\\) \\), angle = 101 \\)"
+
+gdb_test "whatis wp_vla" "type = Type waypoint \\(3\\)"
+set test "ptype wp_vla"
+gdb_test_multiple $test %test {
+    -re "$output_pass \\(3\\)\r\n$gdb_prompt $" {
+      pass "$test"
+    }
+    -re "$output_kfail \\(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 $" {
+      pass "$test"
+    }
+    -re "There is no member named coo.\r\n$gdb_prompt $" {
+      kfail "gcc/49475" "$test"
+    }
+}
+gdb_test "ptype wp_vla(1)%point%coo" "$real \\(3\\)"

gdb/testsuite/gdb.fortran/oop_extend_type.f90

@@ -0,0 +1,56 @@
+! 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/>.
+
+module testmod
+    implicit none
+    type :: point
+        real :: coo(3)
+    end type
+
+    type, extends(point) :: waypoint
+        real :: angle
+    end type
+
+end module
+
+program testprog
+    use testmod
+    implicit none
+
+    logical l
+    type(waypoint) :: wp
+    type(waypoint), allocatable :: wp_vla(:)
+
+    l = allocated(wp_vla)
+    allocate(wp_vla(3))               ! Before vla allocation
+
+    l = allocated(wp_vla)             ! After vla allocation
+    wp%angle = 100.00
+    wp%point%coo(:) = 1.00
+    wp%point%coo(2) = 2.00
+
+    wp_vla(1)%angle = 101.00
+    wp_vla(1)%point%coo(:) = 10.00
+    wp_vla(1)%point%coo(2) = 12.00
+    wp_vla(2)%angle = 102.00
+    wp_vla(2)%point%coo(:) = 20.00
+    wp_vla(2)%point%coo(2) = 22.00
+    wp_vla(3)%angle = 103.00
+    wp_vla(3)%point%coo(:) = 30.00
+    wp_vla(3)%point%coo(2) = 32.00
+
+    print *, wp, wp_vla               ! After value assignment
+
+end program

gdb/valops.c

@@ -2180,6 +2180,12 @@ value_struct_elt (struct value **argp, struct value **args,
       if (v)
 	return v;
 
+      /* fortran: If it is not a field it is the
+         type name of an inherited structure */
+      v = search_struct_field (name, *argp, t, 1);
+      if (v)
+	return v;
+
       /* C++: If it was not found as a data field, then try to
          return it as a pointer to a method.  */
       v = search_struct_method (name, argp, args, 0,