[binutils-gdb] gdb: add support for Fortran's ASSUMED RANK arrays

[binutils-gdb] gdb: add support for Fortran's ASSUMED RANK arrays

[Andrew Burgess]

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

commit df7a7bdd9766adebc6b117c31bc617d81c1efd43
Author: rupothar <rupesh.potharla@amd.com>
Date:   Thu Mar 17 18:56:23 2022 +0000

    gdb: add support for Fortran's ASSUMED RANK arrays
    
    This patch adds a new dynamic property DYN_PROP_RANK, this property is
    read from the DW_AT_rank attribute and stored within the type just
    like other dynamic properties.
    
    As arrays with dynamic ranks make use of a single
    DW_TAG_generic_subrange to represent all ranks of the array, support
    for this tag has been added to dwarf2/read.c.
    
    The final piece of this puzzle is to add support in gdbtypes.c so that
    we can resolve an array type with dynamic rank.  To do this the
    existing resolve_dynamic_array_or_string function is split into two,
    there's a new resolve_dynamic_array_or_string_1 core that is
    responsible for resolving each rank of the array, while the now outer
    resolve_dynamic_array_or_string is responsible for figuring out the
    array rank (which might require resolving a dynamic property) and then
    calling the inner core.
    
    The resolve_dynamic_range function now takes a rank, which is passed
    on to the dwarf expression evaluator.  This rank will only be used in
    the case where the array itself has dynamic rank, but we now pass the
    rank in all cases, this should be harmless if the rank is not needed.
    
    The only small nit is that resolve_dynamic_type_internal actually
    handles resolving dynamic ranges itself, which now obviously requires
    us to pass a rank value.  But what rank value to use?  In the end I
    just passed '1' through here as a sane default, my thinking is that if
    we are in resolve_dynamic_type_internal to resolve a range, then the
    range isn't part of an array with dynamic rank, and so the range
    should actually be using the rank value at all.
    
    An alternative approach would be to make the rank value a
    gdb::optional, however, this ends up adding a bunch of complexity to
    the code (e.g. having to conditionally build the array to pass to
    dwarf2_evaluate_property, and handling the 'rank - 1' in
    resolve_dynamic_array_or_string_1) so I haven't done that, but could,
    if people think that would be a better approach.
    
    Finally, support for assumed rank arrays was only fixed very recently
    in gcc, so you'll need the latest gcc in order to run the tests for
    this.
    
    Here's an example test program:
    
      PROGRAM arank
        REAL :: a1(10)
        CALL sub1(a1)
    
      CONTAINS
    
        SUBROUTINE sub1(a)
          REAL :: a(..)
          PRINT *, RANK(a)
        END SUBROUTINE sub1
      END PROGRAM arank
    
    Compiler Version:
    gcc (GCC) 12.0.0 20211122 (experimental)
    
    Compilation command:
    gfortran assumedrank.f90 -gdwarf-5 -o assumedrank
    
    Without Patch:
    
      gdb -q assumedrank
      Reading symbols from assumedrank...
      (gdb) break sub1
      Breakpoint 1 at 0x4006ff: file assumedrank.f90, line 10.
      (gdb) run
      Starting program: /home/rupesh/STAGING-BUILD-2787/bin/assumedrank
    
      Breakpoint 1, arank::sub1 (a=<unknown type in /home/rupesh/STAGING-BUILD-2787
      /bin/assumedrank, CU 0x0, DIE 0xd5>) at assumedrank.f90:10
      10       PRINT *, RANK(a)
      (gdb) print RANK(a)
      'a' has unknown type; cast it to its declared type
    
    With patch:
    
      gdb -q assumedrank
      Reading symbols from assumedrank...
      (gdb) break sub1
      Breakpoint 1 at 0x4006ff: file assumedrank.f90, line 10.
      (gdb) run
      Starting program: /home/rupesh/STAGING-BUILD-2787/bin/assumedrank
    
      Breakpoint 1, arank::sub1 (a=...) at assumedrank.f90:10
      10       PRINT *, RANK(a)
      (gdb) print RANK(a)
      $1 = 1
      (gdb) ptype a
      type = real(kind=4) (10)
      (gdb)
    
    Co-Authored-By: Andrew Burgess <aburgess@redhat.com>

Diff:
---
 gdb/dwarf2/read.c                         |  19 ++++-
 gdb/gdbtypes.c                            | 125 ++++++++++++++++++++++++++----
 gdb/gdbtypes.h                            |   7 ++
 gdb/testsuite/gdb.fortran/assumedrank.exp |  86 ++++++++++++++++++++
 gdb/testsuite/gdb.fortran/assumedrank.f90 |  41 ++++++++++
 5 files changed, 263 insertions(+), 15 deletions(-)

diff --git a/gdb/dwarf2/read.c b/gdb/dwarf2/read.c
index 5c02d5660a0..68c73c643bf 100644
--- a/gdb/dwarf2/read.c
+++ b/gdb/dwarf2/read.c
@@ -7694,6 +7694,7 @@ scan_partial_symbols (struct partial_die_info *first_die, CORE_ADDR *lowpc,
 		add_partial_enumeration (pdi, cu);
 	      break;
 	    case DW_TAG_base_type:
+	    case DW_TAG_generic_subrange:
 	    case DW_TAG_subrange_type:
 	      /* File scope base type definitions are added to the partial
 		 symbol table.  */
@@ -8020,6 +8021,7 @@ add_partial_symbol (struct partial_die_info *pdi, struct dwarf2_cu *cu)
     case DW_TAG_typedef:
     case DW_TAG_base_type:
     case DW_TAG_subrange_type:
+    case DW_TAG_generic_subrange:
       psymbol.domain = VAR_DOMAIN;
       psymbol.aclass = LOC_TYPEDEF;
       where = psymbol_placement::STATIC;
@@ -9722,6 +9724,7 @@ process_die (struct die_info *die, struct dwarf2_cu *cu)
       /* FALLTHROUGH */
     case DW_TAG_base_type:
     case DW_TAG_subrange_type:
+    case DW_TAG_generic_subrange:
     case DW_TAG_typedef:
       /* Add a typedef symbol for the type definition, if it has a
 	 DW_AT_name.  */
@@ -16687,7 +16690,8 @@ read_array_type (struct die_info *die, struct dwarf2_cu *cu)
   child_die = die->child;
   while (child_die && child_die->tag)
     {
-      if (child_die->tag == DW_TAG_subrange_type)
+      if (child_die->tag == DW_TAG_subrange_type
+	  || child_die->tag == DW_TAG_generic_subrange)
 	{
 	  struct type *child_type = read_type_die (child_die, cu);
 
@@ -19009,6 +19013,7 @@ is_type_tag_for_partial (int tag, enum language lang)
     case DW_TAG_enumeration_type:
     case DW_TAG_structure_type:
     case DW_TAG_subrange_type:
+    case DW_TAG_generic_subrange:
     case DW_TAG_typedef:
     case DW_TAG_union_type:
       return 1;
@@ -19142,6 +19147,7 @@ load_partial_dies (const struct die_reader_specs *reader,
 	  && ((pdi.tag == DW_TAG_typedef && !pdi.has_children)
 	      || pdi.tag == DW_TAG_base_type
 	      || pdi.tag == DW_TAG_array_type
+	      || pdi.tag == DW_TAG_generic_subrange
 	      || pdi.tag == DW_TAG_subrange_type))
 	{
 	  if (building_psymtab && pdi.raw_name != NULL)
@@ -22072,6 +22078,7 @@ new_symbol (struct die_info *die, struct type *type, struct dwarf2_cu *cu,
 	case DW_TAG_array_type:
 	case DW_TAG_base_type:
 	case DW_TAG_subrange_type:
+	case DW_TAG_generic_subrange:
 	  sym->set_aclass_index (LOC_TYPEDEF);
 	  sym->set_domain (VAR_DOMAIN);
 	  list_to_add = cu->list_in_scope;
@@ -22565,6 +22572,7 @@ read_type_die_1 (struct die_info *die, struct dwarf2_cu *cu)
     case DW_TAG_typedef:
       this_type = read_typedef (die, cu);
       break;
+    case DW_TAG_generic_subrange:
     case DW_TAG_subrange_type:
       this_type = read_subrange_type (die, cu);
       break;
@@ -24848,6 +24856,15 @@ set_die_type (struct die_info *die, struct type *type, struct dwarf2_cu *cu,
 	type->add_dyn_prop (DYN_PROP_ASSOCIATED, prop);
     }
 
+  /* Read DW_AT_rank and set in type.  */
+  attr = dwarf2_attr (die, DW_AT_rank, cu);
+  if (attr != NULL)
+    {
+      struct type *prop_type = cu->addr_sized_int_type (false);
+      if (attr_to_dynamic_prop (attr, die, cu, &prop, prop_type))
+	type->add_dyn_prop (DYN_PROP_RANK, prop);
+    }
+
   /* Read DW_AT_data_location and set in type.  */
   if (!skip_data_location)
     {
diff --git a/gdb/gdbtypes.c b/gdb/gdbtypes.c
index ae3b4cdaa56..26232787da3 100644
--- a/gdb/gdbtypes.c
+++ b/gdb/gdbtypes.c
@@ -2199,7 +2199,7 @@ static struct type *resolve_dynamic_type_internal
 static struct type *
 resolve_dynamic_range (struct type *dyn_range_type,
 		       struct property_addr_info *addr_stack,
-		       bool resolve_p = true)
+		       int rank, bool resolve_p = true)
 {
   CORE_ADDR value;
   struct type *static_range_type, *static_target_type;
@@ -2208,13 +2208,15 @@ resolve_dynamic_range (struct type *dyn_range_type,
   gdb_assert (dyn_range_type->code () == TYPE_CODE_RANGE);
 
   const struct dynamic_prop *prop = &dyn_range_type->bounds ()->low;
-  if (resolve_p && dwarf2_evaluate_property (prop, NULL, addr_stack, &value))
+  if (resolve_p && dwarf2_evaluate_property (prop, NULL, addr_stack, &value,
+					     { (CORE_ADDR) rank }))
     low_bound.set_const_val (value);
   else
     low_bound.set_undefined ();
 
   prop = &dyn_range_type->bounds ()->high;
-  if (resolve_p && dwarf2_evaluate_property (prop, NULL, addr_stack, &value))
+  if (resolve_p && dwarf2_evaluate_property (prop, NULL, addr_stack, &value,
+					     { (CORE_ADDR) rank }))
     {
       high_bound.set_const_val (value);
 
@@ -2227,7 +2229,8 @@ resolve_dynamic_range (struct type *dyn_range_type,
 
   bool byte_stride_p = dyn_range_type->bounds ()->flag_is_byte_stride;
   prop = &dyn_range_type->bounds ()->stride;
-  if (resolve_p && dwarf2_evaluate_property (prop, NULL, addr_stack, &value))
+  if (resolve_p && dwarf2_evaluate_property (prop, NULL, addr_stack, &value,
+					     { (CORE_ADDR) rank }))
     {
       stride.set_const_val (value);
 
@@ -2258,18 +2261,29 @@ resolve_dynamic_range (struct type *dyn_range_type,
   return static_range_type;
 }
 
-/* Resolves dynamic bound values of an array or string type TYPE to static
-   ones.  ADDR_STACK is a stack of struct property_addr_info to be used if
-   needed during the dynamic resolution.
+/* Helper function for resolve_dynamic_array_or_string.  This function
+   resolves the properties for a single array at RANK within a nested array
+   of arrays structure.  The RANK value is always greater than 0, and
+   starts at it's maximum value and goes down by 1 for each recursive call
+   to this function.  So, for a 3-dimensional array, the first call to this
+   function has RANK == 3, then we call ourselves recursively with RANK ==
+   2, than again with RANK == 1, and at that point we should return.
+
+   TYPE is updated as the dynamic properties are resolved, and so, should
+   be a copy of the dynamic type, rather than the original dynamic type
+   itself.
+
+   ADDR_STACK is a stack of struct property_addr_info to be used if needed
+   during the dynamic resolution.
 
    When RESOLVE_P is true then the dynamic properties of TYPE are
    evaluated, otherwise the dynamic properties of TYPE are not evaluated,
    instead we assume the array is not allocated/associated yet.  */
 
 static struct type *
-resolve_dynamic_array_or_string (struct type *type,
-				 struct property_addr_info *addr_stack,
-				 bool resolve_p = true)
+resolve_dynamic_array_or_string_1 (struct type *type,
+				   struct property_addr_info *addr_stack,
+				   int rank, bool resolve_p)
 {
   CORE_ADDR value;
   struct type *elt_type;
@@ -2283,7 +2297,9 @@ resolve_dynamic_array_or_string (struct type *type,
   gdb_assert (type->code () == TYPE_CODE_ARRAY
 	      || type->code () == TYPE_CODE_STRING);
 
-  type = copy_type (type);
+  /* The outer resolve_dynamic_array_or_string should ensure we always have
+     a rank of at least 1 when we get here.  */
+  gdb_assert (rank > 0);
 
   /* Resolve the allocated and associated properties before doing anything
      else.  If an array is not allocated or not associated then (at least
@@ -2313,11 +2329,16 @@ resolve_dynamic_array_or_string (struct type *type,
     }
 
   range_type = check_typedef (type->index_type ());
-  range_type = resolve_dynamic_range (range_type, addr_stack, resolve_p);
+  range_type
+    = resolve_dynamic_range (range_type, addr_stack, rank, resolve_p);
 
   ary_dim = check_typedef (TYPE_TARGET_TYPE (type));
   if (ary_dim != NULL && ary_dim->code () == TYPE_CODE_ARRAY)
-    elt_type = resolve_dynamic_array_or_string (ary_dim, addr_stack, resolve_p);
+    {
+      ary_dim = copy_type (ary_dim);
+      elt_type = resolve_dynamic_array_or_string_1 (ary_dim, addr_stack,
+						    rank - 1, resolve_p);
+    }
   else
     elt_type = TYPE_TARGET_TYPE (type);
 
@@ -2345,6 +2366,78 @@ resolve_dynamic_array_or_string (struct type *type,
 					bit_stride);
 }
 
+/* Resolve an array or string type with dynamic properties, return a new
+   type with the dynamic properties resolved to actual values.  The
+   ADDR_STACK represents the location of the object being resolved.  */
+
+static struct type *
+resolve_dynamic_array_or_string (struct type *type,
+				 struct property_addr_info *addr_stack)
+{
+  CORE_ADDR value;
+  int rank = 0;
+
+  /* For dynamic type resolution strings can be treated like arrays of
+     characters.  */
+  gdb_assert (type->code () == TYPE_CODE_ARRAY
+	      || type->code () == TYPE_CODE_STRING);
+
+  type = copy_type (type);
+
+  /* Resolve the rank property to get rank value.  */
+  struct dynamic_prop *prop = TYPE_RANK_PROP (type);
+  if (dwarf2_evaluate_property (prop, nullptr, addr_stack, &value))
+    {
+      prop->set_const_val (value);
+      rank = value;
+
+      if (rank == 0)
+	{
+	  /* The dynamic property list juggling below was from the original
+	     patch.  I don't understand what this is all about, so I've
+	     commented it out for now and added the following error.  */
+	  error (_("failed to resolve dynamic array rank"));
+	}
+      else if (type->code () == TYPE_CODE_STRING && rank != 1)
+	{
+	  /* What would this even mean?  A string with a dynamic rank
+	     greater than 1.  */
+	  error (_("unable to handle string with dynamic rank greater than 1"));
+	}
+      else if (rank > 1)
+	{
+	  /* Arrays with dynamic rank are initially just an array type
+	     with a target type that is the array element.
+
+	     However, now we know the rank of the array we need to build
+	     the array of arrays structure that GDB expects, that is we
+	     need an array type that has a target which is an array type,
+	     and so on, until eventually, we have the element type at the
+	     end of the chain.  Create all the additional array types here
+	     by copying the top level array type.  */
+	  struct type *element_type = TYPE_TARGET_TYPE (type);
+	  struct type *rank_type = type;
+	  for (int i = 1; i < rank; i++)
+	    {
+	      TYPE_TARGET_TYPE (rank_type) = copy_type (rank_type);
+	      rank_type = TYPE_TARGET_TYPE (rank_type);
+	    }
+	  TYPE_TARGET_TYPE (rank_type) = element_type;
+	}
+    }
+  else
+    {
+      rank = 1;
+
+      for (struct type *tmp_type = check_typedef (TYPE_TARGET_TYPE (type));
+	   tmp_type->code () == TYPE_CODE_ARRAY;
+	   tmp_type = check_typedef (TYPE_TARGET_TYPE (tmp_type)))
+	++rank;
+    }
+
+  return resolve_dynamic_array_or_string_1 (type, addr_stack, rank, true);
+}
+
 /* Resolve dynamic bounds of members of the union TYPE to static
    bounds.  ADDR_STACK is a stack of struct property_addr_info
    to be used if needed during the dynamic resolution.  */
@@ -2730,7 +2823,11 @@ resolve_dynamic_type_internal (struct type *type,
 	  break;
 
 	case TYPE_CODE_RANGE:
-	  resolved_type = resolve_dynamic_range (type, addr_stack);
+	  /* Pass 1 for the rank value here.  The assumption is that this
+	     rank value is not actually required for the resolution of the
+	     dynamic range, otherwise, we'd be resolving this range within
+	     the context of a dynamic array.  */
+	  resolved_type = resolve_dynamic_range (type, addr_stack, 1);
 	  break;
 
 	case TYPE_CODE_UNION:
diff --git a/gdb/gdbtypes.h b/gdb/gdbtypes.h
index 24e64e343fa..769328cc9cd 100644
--- a/gdb/gdbtypes.h
+++ b/gdb/gdbtypes.h
@@ -571,6 +571,10 @@ enum dynamic_prop_node_kind
   /* A property holding variant parts.  */
   DYN_PROP_VARIANT_PARTS,
 
+  /* A property representing DW_AT_rank. The presence of this attribute
+     indicates that the object is of assumed rank array type.  */
+  DYN_PROP_RANK,
+
   /* A property holding the size of the type.  */
   DYN_PROP_BYTE_SIZE,
 };
@@ -2088,6 +2092,7 @@ extern void allocate_gnat_aux_type (struct type *);
 #define TYPE_REFERENCE_TYPE(thistype) (thistype)->reference_type
 #define TYPE_RVALUE_REFERENCE_TYPE(thistype) (thistype)->rvalue_reference_type
 #define TYPE_CHAIN(thistype) (thistype)->chain
+#define TYPE_DYN_PROP(thistype)  TYPE_MAIN_TYPE(thistype)->dyn_prop_list
 /* * Note that if thistype is a TYPEDEF type, you have to call check_typedef.
    But check_typedef does set the TYPE_LENGTH of the TYPEDEF type,
    so you only have to call check_typedef once.  Since allocate_value
@@ -2130,6 +2135,8 @@ extern bool set_type_align (struct type *, ULONGEST);
   ((thistype)->dyn_prop (DYN_PROP_ALLOCATED))
 #define TYPE_ASSOCIATED_PROP(thistype) \
   ((thistype)->dyn_prop (DYN_PROP_ASSOCIATED))
+#define TYPE_RANK_PROP(thistype) \
+  ((thistype)->dyn_prop (DYN_PROP_RANK))
 
 /* C++ */
 
diff --git a/gdb/testsuite/gdb.fortran/assumedrank.exp b/gdb/testsuite/gdb.fortran/assumedrank.exp
new file mode 100644
index 00000000000..ac5159cb90c
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/assumedrank.exp
@@ -0,0 +1,86 @@
+# Copyright 2021-2022 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/> .
+
+# Testing GDB's implementation of ASSUMED RANK arrays.
+
+if {[skip_fortran_tests]} { return -1 }
+
+standard_testfile ".f90"
+load_lib fortran.exp
+
+# Only gcc version >=11 supports assumed rank arrays.
+if { [test_compiler_info gcc*] &&
+   ![test_compiler_info {gcc-1[1-9]-*}]} {
+    untested "compiler does not support assumed rank"
+    return -1
+}
+
+if {[prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
+	 {debug f90 additional_flags=-gdwarf-5}]} {
+    return -1
+}
+
+if ![fortran_runto_main] {
+    untested "could not run to main"
+    return -1
+}
+
+gdb_breakpoint [gdb_get_line_number "Test Breakpoint"]
+gdb_breakpoint [gdb_get_line_number "Final Breakpoint"]
+
+# We place a limit on the number of tests that can be run, just in
+# case something goes wrong, and GDB gets stuck in an loop here.
+set found_final_breakpoint false
+set test_count 0
+while { $test_count < 500 } {
+    with_test_prefix "test $test_count" {
+	incr test_count
+
+	gdb_test_multiple "continue" "continue" {
+	    -re -wrap "! Test Breakpoint" {
+		# We can run a test from here.
+	    }
+	    -re "! Final Breakpoint" {
+		# We're done with the tests.
+		set found_final_breakpoint true
+	    }
+	}
+
+	if ($found_final_breakpoint) {
+	    break
+	}
+
+	# First grab the expected answer.
+	set answer [get_valueof "" "rank(answer)" "**unknown**"]
+
+	# Now move up a frame and figure out a command for us to run
+	# as a test.
+	set command ""
+	gdb_test_multiple "up" "up" {
+	-re -wrap "\r\n\[0-9\]+\[ \t\]+call test_rank (\[^\r\n\]+)" {
+		set command $expect_out(1,string)
+	    }
+	}
+
+	gdb_assert { ![string equal $command ""] } "found a command to run"
+
+	gdb_test "p rank($command)" " = ($answer)"
+    }
+}
+
+# Ensure we reached the final breakpoint.  If more tests have been added
+# to the test script, and this starts failing, then the safety 'while'
+# loop above might need to be increased.
+gdb_assert {$found_final_breakpoint} "ran all compiled in tests"
diff --git a/gdb/testsuite/gdb.fortran/assumedrank.f90 b/gdb/testsuite/gdb.fortran/assumedrank.f90
new file mode 100644
index 00000000000..16f2ee718ca
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/assumedrank.f90
@@ -0,0 +1,41 @@
+! Copyright 2021-2022 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/>.
+
+!
+! Start of test program.
+!
+
+PROGRAM  arank
+
+  REAL :: array1(10)
+  REAL :: array2(1, 2)
+  REAL :: array3(3, 4, 5)
+  REAL :: array4(4, 5, 6, 7)
+
+  call test_rank (array1)
+  call test_rank (array2)
+  call test_rank (array3)
+  call test_rank (array4)
+
+  print *, "" ! Final Breakpoint
+
+CONTAINS
+
+  SUBROUTINE test_rank(answer)
+    REAL :: answer(..)
+    print *, RANK(answer)     ! Test Breakpoint
+  END SUBROUTINE test_rank
+
+END PROGRAM arank