From 89b7f847042ccea44633f714db07400fa6dd3617 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?=E2=80=9Cbhkumarn=E2=80=9D?= <Bhuvanendra.KumarN@amd.com>
Date: Fri, 8 Oct 2021 02:01:18 +0530
Subject: [PATCH] gdb/fortran: Fix ptype and print commands for namelist
 variables.

GCC/gfortran support namelist(a fortran feature), it emits DW_TAG_namelist
and DW_TAG_namelist_item dies. But gdb does not process these dies and
support namelist variables during print and ptype commands. When tried to
print, it bails out with the error message as shown below.
(gdb) print nml
No symbol "nml" in current context.
This commit is to make the print and ptype commands work for namelist
variables and its items. Sample output of these commands is shared below,
with fixed gdb.
(gdb) ptype nml
type = Type nml
    integer(kind=4) :: a
    integer(kind=4) :: b
End Type nml
(gdb) print nml
$1 = ( a = 10, b = 20 )
---
 gdb/dwarf2/read.c                      | 43 ++++++++++++++++++----
 gdb/f-typeprint.c                      |  6 +++-
 gdb/f-valprint.c                       | 11 ++++++
 gdb/gdbtypes.h                         |  2 ++
 gdb/testsuite/gdb.fortran/namelist.exp | 49 ++++++++++++++++++++++++++
 gdb/testsuite/gdb.fortran/namelist.f90 | 27 ++++++++++++++
 include/dwarf2.def                     |  2 +-
 7 files changed, 132 insertions(+), 8 deletions(-)
 create mode 100644 gdb/testsuite/gdb.fortran/namelist.exp
 create mode 100644 gdb/testsuite/gdb.fortran/namelist.f90

diff --git a/gdb/dwarf2/read.c b/gdb/dwarf2/read.c
index cbd9a3012eb..e6cd8ed48f0 100644
--- a/gdb/dwarf2/read.c
+++ b/gdb/dwarf2/read.c
@@ -9705,6 +9705,7 @@ process_die (struct die_info *die, struct dwarf2_cu *cu)
     case DW_TAG_interface_type:
     case DW_TAG_structure_type:
     case DW_TAG_union_type:
+    case DW_TAG_namelist:
       process_structure_scope (die, cu);
       break;
     case DW_TAG_enumeration_type:
@@ -14562,8 +14563,20 @@ dwarf2_add_field (struct field_info *fip, struct die_info *die,
 
   fp = &new_field->field;
 
-  if (die->tag == DW_TAG_member && ! die_is_declaration (die, cu))
-    {
+  if ((die->tag == DW_TAG_member || die->tag == DW_TAG_namelist_item)
+            && ! die_is_declaration (die, cu))
+    {
+      /* For the DW_TAG_namelist_item die, use the referenced die.  */
+      if (die->tag == DW_TAG_namelist_item)
+        {
+          struct attribute *attr1 = dwarf2_attr (die, DW_AT_namelist_item, cu);
+          struct die_info *item_die = nullptr;
+          struct dwarf2_cu *item_cu = cu;
+          if (attr1->form_is_ref ())
+            item_die = follow_die_ref (die, attr1, &item_cu);
+          if (item_die != nullptr)
+            die = item_die;
+        }
       /* Data member other than a C++ static data member.  */
 
       /* Get type of field.  */
@@ -15621,6 +15634,10 @@ read_structure_type (struct die_info *die, struct dwarf2_cu *cu)
     {
       type->set_code (TYPE_CODE_UNION);
     }
+  else if (die->tag == DW_TAG_namelist)
+    {
+      type->set_code (TYPE_CODE_NAMELIST);
+    }
   else
     {
       type->set_code (TYPE_CODE_STRUCT);
@@ -15823,7 +15840,8 @@ handle_struct_member_die (struct die_info *child_die, struct type *type,
 			  struct dwarf2_cu *cu)
 {
   if (child_die->tag == DW_TAG_member
-      || child_die->tag == DW_TAG_variable)
+      || child_die->tag == DW_TAG_variable
+      || child_die->tag == DW_TAG_namelist_item)
     {
       /* NOTE: carlton/2002-11-05: A C++ static data member
 	 should be a DW_TAG_member that is a declaration, but
@@ -15867,7 +15885,9 @@ handle_struct_member_die (struct die_info *child_die, struct type *type,
 }
 
 /* Finish creating a structure or union type, including filling in
-   its members and creating a symbol for it.  */
+   its members and creating a symbol for it. This function also
+   handles Fortran namelist variable, its items or members and
+   creating a symbol for it.  */
 
 static void
 process_structure_scope (struct die_info *die, struct dwarf2_cu *cu)
@@ -21971,8 +21991,17 @@ new_symbol (struct die_info *die, struct type *type, struct dwarf2_cu *cu,
 	case DW_TAG_union_type:
 	case DW_TAG_set_type:
 	case DW_TAG_enumeration_type:
-	  SYMBOL_ACLASS_INDEX (sym) = LOC_TYPEDEF;
-	  SYMBOL_DOMAIN (sym) = STRUCT_DOMAIN;
+	case DW_TAG_namelist:
+	  if (die->tag == DW_TAG_namelist)
+            {
+	      SYMBOL_ACLASS_INDEX (sym) = LOC_STATIC;
+	      SYMBOL_DOMAIN (sym) = VAR_DOMAIN;
+            }
+	  else
+            {
+	      SYMBOL_ACLASS_INDEX (sym) = LOC_TYPEDEF;
+	      SYMBOL_DOMAIN (sym) = STRUCT_DOMAIN;
+            }
 
 	  {
 	    /* NOTE: carlton/2003-11-10: C++ class symbols shouldn't
@@ -22909,6 +22938,7 @@ dwarf2_name (struct die_info *die, struct dwarf2_cu *cu)
       && die->tag != DW_TAG_class_type
       && die->tag != DW_TAG_interface_type
       && die->tag != DW_TAG_structure_type
+      && die->tag != DW_TAG_namelist
       && die->tag != DW_TAG_union_type)
     return NULL;
 
@@ -22933,6 +22963,7 @@ dwarf2_name (struct die_info *die, struct dwarf2_cu *cu)
     case DW_TAG_interface_type:
     case DW_TAG_structure_type:
     case DW_TAG_union_type:
+    case DW_TAG_namelist:
       /* Some GCC versions emit spurious DW_AT_name attributes for unnamed
 	 structures or unions.  These were of the form "._%d" in GCC 4.1,
 	 or simply "<anonymous struct>" or "<anonymous union>" in GCC 4.3
diff --git a/gdb/f-typeprint.c b/gdb/f-typeprint.c
index 1791cb29451..5b34622dacb 100644
--- a/gdb/f-typeprint.c
+++ b/gdb/f-typeprint.c
@@ -121,6 +121,7 @@ f_language::f_type_print_varspec_prefix (struct type *type,
     case TYPE_CODE_UNDEF:
     case TYPE_CODE_STRUCT:
     case TYPE_CODE_UNION:
+    case TYPE_CODE_NAMELIST:
     case TYPE_CODE_ENUM:
     case TYPE_CODE_INT:
     case TYPE_CODE_FLT:
@@ -261,6 +262,7 @@ f_language::f_type_print_varspec_suffix (struct type *type,
     case TYPE_CODE_UNDEF:
     case TYPE_CODE_STRUCT:
     case TYPE_CODE_UNION:
+    case TYPE_CODE_NAMELIST:
     case TYPE_CODE_ENUM:
     case TYPE_CODE_INT:
     case TYPE_CODE_FLT:
@@ -305,7 +307,8 @@ f_language::f_type_print_base (struct type *type, struct ui_file *stream,
       const char *prefix = "";
       if (type->code () == TYPE_CODE_UNION)
 	prefix = "Type, C_Union :: ";
-      else if (type->code () == TYPE_CODE_STRUCT)
+      else if (type->code () == TYPE_CODE_STRUCT
+               || type->code () == TYPE_CODE_NAMELIST)
 	prefix = "Type ";
       fprintf_filtered (stream, "%*s%s%s", level, "", prefix, type->name ());
       return;
@@ -391,6 +394,7 @@ f_language::f_type_print_base (struct type *type, struct ui_file *stream,
 
     case TYPE_CODE_STRUCT:
     case TYPE_CODE_UNION:
+    case TYPE_CODE_NAMELIST:
       if (type->code () == TYPE_CODE_UNION)
 	fprintf_filtered (stream, "%*sType, C_Union :: ", level, "");
       else
diff --git a/gdb/f-valprint.c b/gdb/f-valprint.c
index 27d9a730978..6f80b5a12ff 100644
--- a/gdb/f-valprint.c
+++ b/gdb/f-valprint.c
@@ -295,6 +295,7 @@ f_language::value_print_inner (struct value *val, struct ui_file *stream,
 
     case TYPE_CODE_STRUCT:
     case TYPE_CODE_UNION:
+    case TYPE_CODE_NAMELIST:
       /* Starting from the Fortran 90 standard, Fortran supports derived
 	 types.  */
       fprintf_filtered (stream, "( ");
@@ -320,6 +321,16 @@ f_language::value_print_inner (struct value *val, struct ui_file *stream,
 		  fputs_filtered (" = ", stream);
 		}
 
+	      /* While printing namelist items, fetch the appropriate value
+	         field before printing its value.  */
+	      if (type->code () == TYPE_CODE_NAMELIST)
+	        {
+	          struct block_symbol symni = lookup_symbol (field_name,
+			get_selected_block (0), VAR_DOMAIN, nullptr);
+	          if (symni.symbol != nullptr)
+	            field = value_of_variable (symni.symbol, symni.block);
+	        }
+
 	      common_val_print (field, stream, recurse + 1,
 				options, current_language);
 
diff --git a/gdb/gdbtypes.h b/gdb/gdbtypes.h
index dc575c42996..ba8a61987db 100644
--- a/gdb/gdbtypes.h
+++ b/gdb/gdbtypes.h
@@ -195,6 +195,8 @@ enum type_code
 
     /* * Fixed Point type.  */
     TYPE_CODE_FIXED_POINT,
+
+    TYPE_CODE_NAMELIST,         /**< Fortran namelist.  */
   };
 
 /* * Some bits for the type's instance_flags word.  See the macros
diff --git a/gdb/testsuite/gdb.fortran/namelist.exp b/gdb/testsuite/gdb.fortran/namelist.exp
new file mode 100644
index 00000000000..90762928455
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/namelist.exp
@@ -0,0 +1,49 @@
+# Copyright (C) 2021 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/>.
+
+# This file is part of the gdb testsuite.  It contains tests for fortran
+# namelist.
+
+if { [skip_fortran_tests] } { return -1 }
+
+standard_testfile .f90
+load_lib "fortran.exp"
+
+if {[prepare_for_testing "failed to prepare" $testfile $srcfile {debug f90}]} {
+    return -1
+}
+
+if ![fortran_runto_main] then {
+    perror "couldn't run to main"
+    continue
+}
+
+# Depending on the compiler being used, the type names can be printed differently.
+set int [fortran_int4]
+
+gdb_breakpoint [gdb_get_line_number "Display namelist"]
+gdb_continue_to_breakpoint "Display namelist"
+
+if {[test_compiler_info {gcc-*}]} {
+    gdb_test "ptype nml" \
+        "type = Type nml\r\n *$int :: a\r\n *$int :: b\r\n *End Type nml"
+    gdb_test "print nml" \
+        "\\$\[0-9\]+ = \\( a = 10, b = 20 \\)"
+} else {
+    gdb_test "ptype nml" \
+        "No symbol \"nml\" in current context\\."
+    gdb_test "print nml" \
+        "No symbol \"nml\" in current context\\."
+}
diff --git a/gdb/testsuite/gdb.fortran/namelist.f90 b/gdb/testsuite/gdb.fortran/namelist.f90
new file mode 100644
index 00000000000..fb36690d765
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/namelist.f90
@@ -0,0 +1,27 @@
+! Copyright (C) 2021 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/>.
+!
+! This file is the Fortran source file for namelist.exp.
+
+program main
+
+  integer :: a, b
+  namelist /nml/ a, b
+
+  a = 10
+  b = 20
+  Write(*,nml) ! Display namelist
+
+end program main
diff --git a/include/dwarf2.def b/include/dwarf2.def
index 1ae6e1df298..6b8be1f6a16 100644
--- a/include/dwarf2.def
+++ b/include/dwarf2.def
@@ -289,7 +289,7 @@ DW_AT (DW_AT_frame_base, 0x40)
 DW_AT (DW_AT_friend, 0x41)
 DW_AT (DW_AT_identifier_case, 0x42)
 DW_AT (DW_AT_macro_info, 0x43)
-DW_AT (DW_AT_namelist_items, 0x44)
+DW_AT (DW_AT_namelist_item, 0x44)
 DW_AT (DW_AT_priority, 0x45)
 DW_AT (DW_AT_segment, 0x46)
 DW_AT (DW_AT_specification, 0x47)
-- 
2.17.1

