[v3,3/4] gdb, intel-classic-compilers, testsuite: workaround icc/icpc/ifort pointer/reference DWARF

diff --git a/gdb/gdbtypes.c b/gdb/gdbtypes.c
index 4b1787b62e6..c2fabbcb2c2 100644
--- a/gdb/gdbtypes.c
+++ b/gdb/gdbtypes.c
@@ -43,6 +43,7 @@ 
 #include "f-lang.h"
 #include <algorithm>
 #include "gmp-utils.h"
+#include "producer.h"
 
 /* The value of an invalid conversion badness.  */
 #define INVALID_CONVERSION 100
@@ -2043,6 +2044,14 @@  is_dynamic_type_internal (struct type *type, int top_level)
   if (top_level
       && (type->code () == TYPE_CODE_REF || type->code () == TYPE_CODE_PTR))
     type = check_typedef (type->target_type ());
+  if (!top_level && icc_pointer_or_reference_type (type))
+    {
+      /* Icc/ifort emit the DW_AT_associated for pointers and references.  To
+	 not mark such types as dynamic further down, which would lead to
+	 infinite resolution loops for, e.g., cyclic dynamic pointers, we
+	 return here already.  */
+      return 0;
+    }
 
   /* Types that have a dynamic TYPE_DATA_LOCATION are considered
      dynamic, even if the type itself is statically defined.
@@ -2740,6 +2749,79 @@  resolve_dynamic_struct (struct type *type,
   return resolved_type;
 }
 
+/* See gdbtypes.h.  */
+
+bool
+icc_pointer_or_reference_type (const struct type *type)
+{
+  return (type->code () == TYPE_CODE_PTR || type->code () == TYPE_CODE_REF)
+	 && type->is_objfile_owned ()
+	 && std::any_of (type->objfile_owner ()->compunits ().begin (),
+			 type->objfile_owner ()->compunits ().end (),
+			 [] (const compunit_symtab *cu)
+			 {
+			   return producer_is_icc (cu->producer (), nullptr,
+						   nullptr);
+			 });
+}
+
+/* Resolve the special icc/icpc/ifort DWARF for pointers and references
+   and update resolved_type accordingly.  */
+
+static void
+resolve_dynamic_icc_pointer_or_reference (type *orig_type, type* resolved_type,
+					  property_addr_info *addr_stack,
+					  property_addr_info *pinfo,
+					  const frame_info_ptr &frame,
+					  int top_level)
+{
+  if (TYPE_DATA_LOCATION (orig_type->target_type ()) != nullptr)
+    {
+      /* Icc/ifort emit some wrong DWARF for pointers and references
+	 with underlying arrays.  They emit DWARF like
+	 <2><11>: Abbrev Number: 22 (DW_TAG_variable)
+	    <12>   DW_AT_name      : ...
+	    <13>   DW_AT_type      : <0x214>
+	    <14>   DW_AT_location  : ...
+	 ...
+	 <1><111>: Abbrev Number: 12 (DW_TAG_reference_type)
+	    <112>   DW_AT_type     : <0x219>
+	 <1><113>: Abbrev Number: 27 (DW_TAG_array_type)
+	    <114>   DW_AT_type     : <0x10e>
+	    <115>   DW_AT_data_location: 2 byte block: 97 6
+	(DW_OP_push_object_address; DW_OP_deref)
+	 <2><116>: Abbrev Number: 28 (DW_TAG_subrange_type)
+	    <117>   DW_AT_upper_bound : <0x154>
+	 <2><118>: Abbrev Number: 0
+
+	 For icc/ifort the DW_AT_data_location requires the address
+	 of the original DW_TAG_variable for the evaluation of
+	 DW_OP_push_object_address instead of the address of
+	 the DW_TAG_array_type typically obtained by resolving
+	 dereferencing the DW_TAG_reference_type/DW_TAG_pointer_type
+	 once.  If icc/ifort are detected as producers here and if
+	 the type underlying the current pointer/reference variable
+	 has a DW_AT_data_location, we thus pass the address of
+	 the variable to resolve the target type instead of the
+	 dereferenced address of the pointer/reference.  */
+      pinfo->addr = addr_stack->addr;
+    }
+
+    /* Another peculiarity of icc's/ifort's dwarf is the usage of
+       DW_AT_associated for pointers/references.  */
+    CORE_ADDR value;
+    dynamic_prop *prop = TYPE_ASSOCIATED_PROP (resolved_type);
+    if (prop != nullptr
+	&& dwarf2_evaluate_property (prop, nullptr, addr_stack, &value))
+    prop->set_const_val (value);
+
+    /* As we have the associated property here, we need to check it.  */
+    if (!type_not_associated (resolved_type))
+      resolved_type->set_target_type
+	(resolve_dynamic_type_internal (orig_type->target_type (), pinfo,
+					frame, top_level));
+}
+
 /* Worker for resolved_dynamic_type.  */
 
 static struct type *
@@ -2791,9 +2873,15 @@  resolve_dynamic_type_internal (struct type *type,
 	    pinfo.next = addr_stack;
 
 	    resolved_type = copy_type (type);
-	    resolved_type->set_target_type
-	      (resolve_dynamic_type_internal (type->target_type (),
-					      &pinfo, frame, top_level));
+
+	    if (icc_pointer_or_reference_type (type))
+	      resolve_dynamic_icc_pointer_or_reference (type, resolved_type,
+							addr_stack, &pinfo,
+							frame, top_level);
+	    else
+	      resolved_type->set_target_type
+		(resolve_dynamic_type_internal (type->target_type (),
+						&pinfo, frame, top_level));
 	    break;
 	  }
 
diff --git a/gdb/gdbtypes.h b/gdb/gdbtypes.h
index f45a957f344..fd149f2ce8e 100644
--- a/gdb/gdbtypes.h
+++ b/gdb/gdbtypes.h
@@ -2801,4 +2801,9 @@  extern unsigned int overload_debug;
 
 extern bool is_nocall_function (const struct type *type);
 
+/* Check whether icc/ifort could have been the producers of the TYPE_CODE_REF
+   or TYPE_CODE_PTR type.  */
+
+extern bool icc_pointer_or_reference_type (const struct type *type);
+
 #endif /* GDBTYPES_H */
diff --git a/gdb/testsuite/gdb.dwarf2/icc-ifort-pointers-and-references.c b/gdb/testsuite/gdb.dwarf2/icc-ifort-pointers-and-references.c
new file mode 100644
index 00000000000..0c0be751833
--- /dev/null
+++ b/gdb/testsuite/gdb.dwarf2/icc-ifort-pointers-and-references.c
@@ -0,0 +1,38 @@ 
+/* This testcase is part of GDB, the GNU debugger.
+
+   Copyright 2021-2023 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/>.  */
+
+struct fat_pointer
+{
+  int *data;
+  int *associated;
+  int *size;
+};
+
+int one[] = {1};
+int zero1[] = {0};
+int zero2[] = {0};
+int four[] = {4};
+int data[] = {11, 22, 33, 44};
+
+struct fat_pointer fp_associated = {data, one, four};
+struct fat_pointer fp_not_associated = {0, zero1, zero2};
+
+int
+main ()
+{
+  return 0;
+}
diff --git a/gdb/testsuite/gdb.dwarf2/icc-ifort-pointers-and-references.exp b/gdb/testsuite/gdb.dwarf2/icc-ifort-pointers-and-references.exp
new file mode 100644
index 00000000000..278124bbdde
--- /dev/null
+++ b/gdb/testsuite/gdb.dwarf2/icc-ifort-pointers-and-references.exp
@@ -0,0 +1,169 @@ 
+# Copyright 2023 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 test checks that GDB can handle some slightly wrong DWARF that is being
+# produces by icc/icpc/ifort for pointers and references.  Namely the DWARF
+# looks like
+#
+# <2><17d>: Abbrev Number: 22 (DW_TAG_variable)
+#    <17e>   DW_AT_decl_line : 41
+#    <17f>   DW_AT_decl_file : 1
+#    <180>   DW_AT_name      : (indirect string, offset: 0x1f1): vlaref
+#    <184>   DW_AT_type      : <0x214>
+#    <188>   DW_AT_location  : 2 byte block: 76 50
+#      (DW_OP_breg6 (rbp): -48)
+# ...
+# <1><214>: Abbrev Number: 12 (DW_TAG_reference/pointer_type)
+#    <215>   DW_AT_type      : <0x219>
+#    <216>   DW_AT_associated: ...     <- for Fortran pointers
+# <1><219>: Abbrev Number: 27 (DW_TAG_array_type)
+#    <21a>   DW_AT_type      : <0x10e>
+#    <21e>   DW_AT_data_location: 2 byte block: 97 6
+#      (DW_OP_push_object_address; DW_OP_deref)
+# <2><221>: Abbrev Number: 28 (DW_TAG_subrange_type)
+#    <222>   DW_AT_upper_bound : <0x154>
+# <2><226>: Abbrev Number: 0
+#
+# With a) DW_OP_push_object_address expecting the address of the
+# DW_TAG_variable used for its resolution instead of the address of the
+# underlying array and b) some Fortran pointers exhibiting the DW_AT_associated
+# attribute on DW_TAG_pointer_types.
+# To test a) this test constructs a pointer and a reference type to an array
+# with the above usage of DW_AT_data_location and DW_OP_push_object_address.
+# To test b) we simply create a pointer with the DW_AT_associated attribute
+# and check whether this is being resolved or not.
+
+load_lib dwarf.exp
+
+# This test can only be run on targets which support DWARF-2 and use gas.
+if {![dwarf2_support]} {
+    return 0
+}
+
+standard_testfile .c -dw.S
+
+if { [prepare_for_testing "failed to prepare" ${testfile} ${srcfile}] } {
+    return -1
+}
+
+# Make some DWARF for the test.
+set asm_file [standard_output_file $srcfile2]
+
+Dwarf::assemble $asm_file {
+    global srcfile
+    set int_size [get_sizeof "int" 4]
+    set voidp_size [get_sizeof "void *" 96]
+    declare_labels integer_label array_label pointer_label reference_label
+
+    cu {} {
+	compile_unit {
+	    {DW_AT_language @DW_LANG_Fortran90}
+	    {DW_AT_name $srcfile}
+	    {DW_AT_producer "Intel(R) compiler VERSION 123.456"}
+	    {DW_AT_comp_dir /tmp}
+	} {
+	    integer_label: DW_TAG_base_type {
+		{name "int"}
+		{byte_size $int_size sdata}
+		{encoding @DW_ATE_signed}
+	    }
+
+	    array_label: DW_TAG_array_type {
+		{DW_AT_type :$integer_label}
+		{DW_AT_data_location {
+		    DW_OP_push_object_address
+		    DW_OP_deref
+		} SPECIAL_expr}
+	    } {
+		DW_TAG_subrange_type {
+		    {DW_AT_type :$integer_label}
+		    {DW_AT_upper_bound {
+			DW_OP_push_object_address
+			DW_OP_plus_uconst $voidp_size
+			DW_OP_plus_uconst $voidp_size
+			DW_OP_deref
+			DW_OP_deref_size $int_size
+		     } SPECIAL_expr }
+		}
+	    }
+
+	    pointer_label: DW_TAG_pointer_type {
+		{DW_AT_type :$array_label}
+		{DW_AT_associated {
+		    DW_OP_push_object_address
+		    DW_OP_plus_uconst $voidp_size
+		    DW_OP_deref
+		    DW_OP_deref_size $int_size
+		    DW_OP_constu 0
+		    DW_OP_ne
+		} SPECIAL_expr }
+	    }
+
+	    reference_label: DW_TAG_reference_type {
+		{DW_AT_type :$array_label}
+	    }
+
+	    DW_TAG_variable {
+		{DW_AT_name "fp_associated"}
+		{DW_AT_type :$pointer_label}
+		{DW_AT_location {
+		    DW_OP_addr [gdb_target_symbol fp_associated]
+		} SPECIAL_expr}
+	    }
+
+	    DW_TAG_variable {
+		{DW_AT_name "fp_not_associated"}
+		{DW_AT_type :$pointer_label}
+		{DW_AT_location {
+		    DW_OP_addr [gdb_target_symbol fp_not_associated]
+		} SPECIAL_expr}
+	    }
+
+	    DW_TAG_variable {
+		{DW_AT_name "array_ref"}
+		{DW_AT_type :$reference_label}
+		{DW_AT_location {
+		    DW_OP_addr [gdb_target_symbol fp_associated]
+		} SPECIAL_expr}
+	    }
+	}
+    }
+}
+
+if { [prepare_for_testing "failed to prepare" ${testfile} \
+	  [list $srcfile $asm_file] {nodebug}] } {
+    return -1
+}
+
+if ![runto_main] {
+    return -1
+}
+
+# Test whether GDB can handle ifort's DWARF for Fortran pointers.
+gdb_test_no_output "set language fortran"
+gdb_test "p associated(fp_associated)" "\\.TRUE\\."
+gdb_test "p associated(fp_not_associated)" "\\.FALSE\\."
+gdb_test "p fp_not_associated" \
+    " = \\(PTR TO -> \\( int \\(:\\) \\)\\) <not associated>"
+gdb_test "p *fp_not_associated" "Location address is not set\."
+
+gdb_test "p fp_associated" "= \\(PTR TO -> \\( int \\(4\\) \\)\\) $hex <.*>"
+gdb_test "p *fp_associated" "= \\(11, 22, 33, 44\\)"
+
+# Test whether GDB can handle icc's DWARF for c++ references.
+gdb_test_no_output "set language c++"
+
+gdb_test "print array_ref" \
+    " = \\(int \\(&\\)\\\[4\\\]\\) @$hex: \\{11, 22, 33, 44\\}"
diff --git a/gdb/testsuite/gdb.fortran/pointers.exp b/gdb/testsuite/gdb.fortran/pointers.exp
index ca2195bbfe6..e340c78de6d 100644
--- a/gdb/testsuite/gdb.fortran/pointers.exp
+++ b/gdb/testsuite/gdb.fortran/pointers.exp
@@ -55,17 +55,45 @@  gdb_test "print intp" "= \\(PTR TO -> \\( $int \\)\\) 0x0" \
     "print intp, not associated"
 gdb_test "print *intp" "Cannot access memory at address 0x0" \
     "print *intp, not associated"
-gdb_test "print intap" " = <not associated>" "print intap, not associated"
+
+gdb_test_multiple "print intap" "print intap, not associated" {
+    # gfortran/ifx.
+    -re -wrap " = <not associated>" {
+	pass $gdb_test_name
+    }
+    # ifort.
+    -re -wrap " = \\(PTR TO -> \\( $int \\(:,:\\) \\)\\) <not associated>" {
+	pass $gdb_test_name
+    }
+}
+
 gdb_test "print realp" "= \\(PTR TO -> \\( $real \\)\\) 0x0" \
     "print realp, not associated"
 gdb_test "print *realp" "Cannot access memory at address 0x0" \
     "print *realp, not associated"
 gdb_test "print \$my_var = intp" "= \\(PTR TO -> \\( $int \\)\\) 0x0"
-gdb_test "print cyclicp1" "= \\( i = -?\\d+, p = 0x0 \\)" \
-    "print cyclicp1, not associated"
-gdb_test "print cyclicp1%p" \
-    "= \\(PTR TO -> \\( Type typewithpointer \\)\\) 0x0" \
-    "print cyclicp1%p, not associated"
+
+gdb_test_multiple "print cyclicp1" "print cyclicp1, not associated" {
+    # gfortran/ifx.
+    -re -wrap "= \\( i = -?\\d+, p = 0x0 \\)" {
+	pass $gdb_test_name
+    }
+    # ifort.
+    -re -wrap "= \\( i = -?\\d+, p = <not associated> \\)" {
+	pass $gdb_test_name
+    }
+}
+
+gdb_test_multiple "print cyclicp1%p" "print cyclicp1%p, not associated" {
+    # gfortran/ifx.
+    -re -wrap "= \\(PTR TO -> \\( Type typewithpointer \\)\\) 0x0" {
+	pass $gdb_test_name
+    }
+    # ifort.
+    -re -wrap "= \\(PTR TO -> \\( Type typewithpointer \\)\\) <not associated>" {
+	pass $gdb_test_name
+    }
+}
 
 gdb_breakpoint [gdb_get_line_number "Before value assignment"]
 gdb_continue_to_breakpoint "Before value assignment"
@@ -83,25 +111,55 @@  gdb_test "print charap" "= \\(PTR TO -> \\( character\\*3 \\)\\) $hex\( <.*>\)?"
 gdb_test "print *charap" "= 'abc'"
 gdb_test "print intp" "= \\(PTR TO -> \\( $int \\)\\) $hex\( <.*>\)?"
 gdb_test "print *intp" "= 10"
-gdb_test "print intap" "= \\(\\(1, 1, 3(, 1){7}\\) \\(1(, 1){9}\\)\\)" \
-    "print intap, associated"
-gdb_test "print intvlap" "= \\(2, 2, 2, 4(, 2){6}\\)" \
-    "print intvlap, associated"
+
+gdb_test_multiple "print intap" "print intap, associated" {
+    # gfortran/ifx.
+    -re -wrap "= \\(\\(1, 1, 3(, 1){7}\\) \\(1(, 1){9}\\)\\)" {
+	pass $gdb_test_name
+    }
+    # ifort.
+    -re -wrap "= \\(PTR TO -> \\( $int \\(10,2\\) \\)\\) $hex\( <.*>\)?" {
+	gdb_test "print *intap" "= \\(\\(1, 1, 3(, 1){7}\\) \\(1(, 1){9}\\)\\)"
+	pass $gdb_test_name
+    }
+}
+
+gdb_test_multiple "print intvlap" "print intvlap, associated" {
+    # gfortran/ifx.
+    -re -wrap "= \\(2, 2, 2, 4(, 2){6}\\)" {
+	pass $gdb_test_name
+    }
+    # ifort.
+    -re -wrap "= \\(PTR TO -> \\( $int \\(10\\) \\)\\) $hex\( <.*>\)?" {
+	gdb_test "print *intvlap" "= \\(2, 2, 2, 4(, 2){6}\\)"
+	pass $gdb_test_name
+    }
+}
+
 gdb_test "print realp" "= \\(PTR TO -> \\( $real \\)\\) $hex\( <.*>\)?"
 gdb_test "print *realp" "= 3\\.14000\\d+"
 gdb_test "print arrayOfPtr(2)%p" "= \\(PTR TO -> \\( Type two \\)\\) $hex\( <.*>\)?"
 gdb_test "print *(arrayOfPtr(2)%p)" \
     "= \\( ivla1 = \\(11, 12, 13\\), ivla2 = \\(\\(211, 221\\) \\(212, 222\\)\\) \\)"
-gdb_test "print arrayOfPtr(3)%p" "= \\(PTR TO -> \\( Type two \\)\\) 0x0" \
-    "print arrayOfPtr(3)%p"
+
+gdb_test_multiple "print arrayOfPtr(3)%p" "print arrayOfPtr(3)%p" {
+    # gfortran/ifx
+    -re -wrap "= \\(PTR TO -> \\( Type two \\)\\) 0x0" {
+	pass $gdb_test_name
+    }
+    # ifort
+     -re -wrap "= \\(PTR TO -> \\( Type two \\)\\) <not associated>" {
+	pass $gdb_test_name
+    }
+}
 
 gdb_test_multiple "print *(arrayOfPtr(3)%p)" \
     "print *(arrayOfPtr(3)%p), associated" {
-    # gfortran
+    # gfortran.
     -re -wrap "Cannot access memory at address 0x0" {
 	pass $gdb_test_name
     }
-    # ifx
+    # ifx/ifort.
     -re -wrap "Location address is not set." {
 	pass $gdb_test_name
     }
diff --git a/gdb/valprint.c b/gdb/valprint.c
index c71ae089f46..ccd3c435ac9 100644
--- a/gdb/valprint.c
+++ b/gdb/valprint.c
@@ -583,6 +583,40 @@  generic_val_print_ref (struct type *type,
 	  /* More complicated computed references are not supported.  */
 	  gdb_assert (embedded_offset == 0);
 	}
+      else if (icc_pointer_or_reference_type (type)
+	       && TYPE_DATA_LOCATION (type->target_type ()) != nullptr)
+	{
+	  /* Icc/ifort emit some wrong DWARF for pointers and references
+	     with underlying arrays.  They emit DWARF like
+
+	     <2><11>: Abbrev Number: 22 (DW_TAG_variable)
+		<12>   DW_AT_name      : ...
+		<13>   DW_AT_type      : <0x214>
+		<14>   DW_AT_location  : ...
+	     ...
+	     <1><111>: Abbrev Number: 12 (DW_TAG_reference_type)
+		<112>   DW_AT_type     : <0x219>
+	     <1><113>: Abbrev Number: 27 (DW_TAG_array_type)
+		<114>   DW_AT_type     : <0x10e>
+		<115>   DW_AT_data_location: 2 byte block: 97 6
+		(DW_OP_push_object_address; DW_OP_deref)
+	     <2><116>: Abbrev Number: 28 (DW_TAG_subrange_type)
+		<117>   DW_AT_upper_bound : <0x154>
+	     <2><118>: Abbrev Number: 0
+
+	     For icc/ifort the DW_AT_data_location requires the address
+	     of the original DW_TAG_variable for the evaluation of
+	     DW_OP_push_object_address instead of the address of
+	     the DW_TAG_array_type typically obtained by resolving
+	     dereferencing the DW_TAG_reference_type/DW_TAG_pointer_type
+	     once.  If icc/ifort are detected as producers here and if
+	     the type underlying the current pointer/reference variable
+	     has a DW_AT_data_location, we thus pass the address of
+	     the variable to resolve the target type instead of the
+	     dereferenced address of the pointer/reference.  */
+	  deref_val = value_at (type->target_type (),
+				original_value->address ());
+	}
       else
 	deref_val = value_at (type->target_type (),
 			      unpack_pointer (type, valaddr + embedded_offset));