RE: [PATCH] Support for Fortran's ASSUMED RANK

["Potharla, Rupesh" <Rupesh.Potharla@amd.com>]

[-- Attachment #1: Type: text/plain, Size: 6827 bytes --]

[AMD Official Use Only]

Hi Andrew, 

Request to review the attached patch file and please find comments inline below ...


Regards,
Rupesh P

> -----Original Message-----
> From: Andrew Burgess <aburgess@redhat.com>
> Sent: Saturday, January 22, 2022 12:37 AM
> > Compiler Version:
> > gcc (GCC) 12.0.0 20211122 (experimental)
> 
> I guess this must be something that was fixed recently, I tried with the 9.3
> compiler I have locally and the tests failed.  I also tried with some random
> build from git from early last year, and that also failed.
> 
> Ideally the tests wont just fail when using older tools, but instead the test will
> detect that my compiler isn't good enough and just skip the tests, so you
> might need to try with some older compilers.
> 

The complete support for assumed rank is recently added in gcc. https://gcc.gnu.org/bugzilla/show_bug.cgi?id=103315 . Made changes in the testcase for skipping the testcase run for older compilers.  

> 
> > From 383c561a1e926b7b65a1d8ffb5d70a047a4d4559 Mon Sep 17 00:00:00
> 2001
> > From: rupesh <rupesh.potharla@amd.com>
> > Date: Fri, 29 Oct 2021 11:32:58 +0530
> > Subject: [PATCH] Support for Fortran's ASSUMED RANK.
> >
> > gdb/ChangeLog:
> >
> >       * dwarf2/loc.c: (dwarf2_locexpr_baton_eval): Push array dimension
> onto the stack.
> >       * dwarf2/loc.h: Added an additional parameter to the function
> dwarf2_evaluate_property.
> >       * dwarf2/read.c: (scan_partial_symbols): Process
> DW_TAG_generic_subrange.
> >       * (add_partial_symbol): Process DW_TAG_generic_subrange.
> >       * (process_die): Process DW_TAG_generic_subrange.
> >       * (is_type_tag_for_partial) : Check for DW_TAG_generic_subrange type.
> >       * (load_partial_dies): Load DW_TAG_generic_subrange.
> >       * (new_symbol): Create entry for DW_TAG_generic_subrange type.
> >       * (read_type_die_1): Read DW_TAG_generic_subrange type.
> >       * (set_die_type) : Add dynamic property type for DW_AT_rank.
> >       * f-typeprint.c: (f_type_print_varspec_suffix): Removed
> TYPE_DATA_LOCATION.
> >       * findvar.c: (follow_static_link): Passing new argument to the function
> call dwarf2_evaluate_property.
> >       * gdbtypes.c: (resolve_dynamic_range): Passing new argument to the
> function call dwarf2_evaluate_property.
> >       * (resolve_dynamic_array_or_string): Handle rank dynamic property by
> creating and removing types.
> >       * gdbtypes.h: (DYN_PROP_RANK, TYPE_DYN_PROP,  TYPE_RANK_PROP):
> New Macros
> >       * gnu-v3-abi.c: Passing new argument to the function call
> dwarf2_evaluate_property.
> >       * testsuite/gdb.fortran/assumedrank.exp: New Testcase
> >       * testsuite/gdb.fortran/assumedrank.f90: New Testcase
> 
> ChangeLog entries are no longer needed for GDB, though you are welcome
> to have content like this in the commit message if you like.  That said, the
> preference in GDB is to have the commit described within the main body of
> the commit message - a ChangeLog formatted block should be in addition.
> 
> You should still keep the lines under ~76ish characters though.

Added commit message describing the main body of the commit message. And also kept lines under ~76ish.  

> > diff --git a/gdb/dwarf2/loc.c b/gdb/dwarf2/loc.c index
> > 182f15e7077..60f831c2cff 100644
> > --- a/gdb/dwarf2/loc.c
> > +++ b/gdb/dwarf2/loc.c
> > @@ -1547,7 +1547,8 @@ dwarf2_locexpr_baton_eval (const struct
> dwarf2_locexpr_baton *dlbaton,
> >                          const struct property_addr_info *addr_stack,
> >                          CORE_ADDR *valp,
> >                          bool push_initial_value,
> > -                        bool *is_reference)
> > +                        bool *is_reference,
> > +                        int rank)
> >  {
> >    if (dlbaton == NULL || dlbaton->size == 0)
> >      return 0;
> > @@ -1559,6 +1560,10 @@ dwarf2_locexpr_baton_eval (const struct
> dwarf2_locexpr_baton *dlbaton,
> >    value *result;
> >    scoped_value_mark free_values;
> >
> > +  /* push rank value to the stack */
> > +  if (rank)
> > +     ctx.push_address((rank - 1), false);
> > +
> 
> I wonder, did you consider making use of the push_initial_value mechanism?
>
 I considered accommodating  changes using push_initial_value mechanism. The push_initial_value is pushing address to the stack the requirement is to push scalar value onto the stack. So I could not make use of this mechanism. 

 
> >    if (push_initial_value)
> >      {
> >        if (addr_stack != nullptr)
> > diff --git a/gdb/testsuite/gdb.fortran/assumedrank.exp
> > b/gdb/testsuite/gdb.fortran/assumedrank.exp
> > new file mode 100644
> > index 00000000000..e3961d00278
> > --- /dev/null
> > +++ b/gdb/testsuite/gdb.fortran/assumedrank.exp
> > @@ -0,0 +1,79 @@
> > +# Copyright 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
> <https://nam11.safelinks.protection.outlook.com/?url=http%3A%2F%2Fww
> w.gnu.org%2Flicenses%2F&amp;data=04%7C01%7Crupesh.potharla%40amd
> .com%7Cc481b41f3aa843656da008d9dd113ffe%7C3dd8961fe4884e608e11a
> 82d994e183d%7C0%7C0%7C637783888447831759%7CUnknown%7CTWFpbG
> Zsb3d8eyJWIjoiMC4wLjAwMDAiLCJQIjoiV2luMzIiLCJBTiI6Ik1haWwiLCJXVCI6
> Mn0%3D%7C3000&amp;sdata=qcvs2DAFdVDL3s7Evqm5v6cr8%2FzI1WZ%2B
> Htvf1Mq39XA%3D&amp;reserved=0> .
> > +
> > +# Testing GDB's implementation of ASSUMED RANK.
> > +
> > +if {[skip_fortran_tests]} { return -1 }
> > +
> > +standard_testfile ".f90"
> > +load_lib fortran.exp
> > +
> > +if {[prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
> > +      {debug f90}]} {
> 
> In your commit message you made use of the -dwarf-5 flag.  Is that required?
> I was surprised that this flag doesn't appear here.
> There's a couple of tests where we pass 'additional_flags=-gdwarf-5', but you
> might only need to do this if the compiler is gfortran, and maybe for
> particular versions?
> 

Added 'additional_flags=-gdwarf-5'  for gfortran for versions >=11 in the testcase.

> I'll try to take a detailed look through next week.
> 
> Thanks,
> Andrew

[-- Attachment #2: 0001-Support-for-Fortran-s-ASSUMED-RANK.patch --]
[-- Type: application/octet-stream, Size: 22518 bytes --]

From ca6a7e6fd09033ba4401eddd2991d025882e78b0 Mon Sep 17 00:00:00 2001
From: rupesh <rupesh.potharla@amd.com>
Date: Fri, 29 Oct 2021 11:32:58 +0530
Subject: [PATCH] Support for Fortran's ASSUMED RANK.

This patch reads assumed rank array rank value using rank attribute and
stores the dimensions in a dynamic property list of main_type. Creates
types based on the rank value stores and link them to the main_type.

The patch pushes array descriptor onto the stack and evaluates the generic
subrange tag to get array dimensions.

The purpose of the patch is to print rank, type and values of assumed rank arrays.

Testcase used:

PROGRAM arank

REAL :: a1(10)

CALL sub1(a1)

CONTAINS
SUBROUTINE sub1(a)
REAL :: a(..)
PRINT *, RANK(a)
END
END

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) br sub1
Breakpoint 1 at 0x4006ff: file assumedrank.f90, line 10.
(gdb) r
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) p RANK(a)
'a' has unknown type; cast it to its declared type

With patch :
gdb -q assumedrank
Reading symbols from assumedrank...
(gdb) br sub1
Breakpoint 1 at 0x4006ff: file assumedrank.f90, line 10.
(gdb) r
Starting program: /home/rupesh/STAGING-BUILD-2787/bin/assumedrank

Breakpoint 1, arank::sub1 (a=...) at assumedrank.f90:10
10       PRINT *, RANK(a)
(gdb) p RANK(a)
$1 = 1
(gdb) ptype a
type = real(kind=4) (10)
(gdb)

gdb/ChangeLog:

	* dwarf2/loc.c: (dwarf2_locexpr_baton_eval): Push array dimension
	  onto the stack.
	* dwarf2/loc.h: Added an additional parameter to the function
	  dwarf2_evaluate_property.
	* dwarf2/read.c: (scan_partial_symbols): Process
	  DW_TAG_generic_subrange.
	* (add_partial_symbol): Process DW_TAG_generic_subrange.
	* (process_die): Process DW_TAG_generic_subrange.
	* (is_type_tag_for_partial) : Check for DW_TAG_generic_subrange
	  type.
	* (load_partial_dies): Load DW_TAG_generic_subrange.
	* (new_symbol): Create entry for DW_TAG_generic_subrange type.
	* (read_type_die_1): Read DW_TAG_generic_subrange type.
	* (set_die_type) : Add dynamic property type for DW_AT_rank.
	* f-typeprint.c: (f_type_print_varspec_suffix): Removed
	  TYPE_DATA_LOCATION.
	* findvar.c: (follow_static_link): Passing new argument to the
	  function call dwarf2_evaluate_property.
	* gdbtypes.c: (resolve_dynamic_range): Passing new argument to the
	  function call dwarf2_evaluate_property.
	* (resolve_dynamic_array_or_string): Handle rank dynamic property
	  by creating and removing types.
	* gdbtypes.h: (DYN_PROP_RANK, TYPE_DYN_PROP, TYPE_RANK_PROP):
	  New Macros
	* gnu-v3-abi.c: Passing new argument to the function call
	  dwarf2_evaluate_property.
	* testsuite/gdb.fortran/assumedrank.exp: New Testcase
	* testsuite/gdb.fortran/assumedrank.f90: New Testcase
---
 gdb/dwarf2/loc.c                          | 10 ++-
 gdb/dwarf2/loc.h                          |  4 ++
 gdb/dwarf2/read.c                         | 19 ++++-
 gdb/f-typeprint.c                         |  4 +-
 gdb/findvar.c                             |  2 +-
 gdb/gdbtypes.c                            | 59 +++++++++++++---
 gdb/gdbtypes.h                            |  7 ++
 gdb/gnu-v3-abi.c                          |  2 +-
 gdb/testsuite/gdb.fortran/assumedrank.exp | 85 +++++++++++++++++++++++
 gdb/testsuite/gdb.fortran/assumedrank.f90 | 42 +++++++++++
 10 files changed, 215 insertions(+), 19 deletions(-)
 create mode 100644 gdb/testsuite/gdb.fortran/assumedrank.exp
 create mode 100644 gdb/testsuite/gdb.fortran/assumedrank.f90

diff --git a/gdb/dwarf2/loc.c b/gdb/dwarf2/loc.c
index 182f15e7077..60f831c2cff 100644
--- a/gdb/dwarf2/loc.c
+++ b/gdb/dwarf2/loc.c
@@ -1547,7 +1547,8 @@ dwarf2_locexpr_baton_eval (const struct dwarf2_locexpr_baton *dlbaton,
 			   const struct property_addr_info *addr_stack,
 			   CORE_ADDR *valp,
 			   bool push_initial_value,
-			   bool *is_reference)
+			   bool *is_reference,
+			   int rank)
 {
   if (dlbaton == NULL || dlbaton->size == 0)
     return 0;
@@ -1559,6 +1560,10 @@ dwarf2_locexpr_baton_eval (const struct dwarf2_locexpr_baton *dlbaton,
   value *result;
   scoped_value_mark free_values;
 
+  /* push rank value to the stack */
+  if (rank)
+     ctx.push_address((rank - 1), false);
+
   if (push_initial_value)
     {
       if (addr_stack != nullptr)
@@ -1611,6 +1616,7 @@ dwarf2_evaluate_property (const struct dynamic_prop *prop,
 			  struct frame_info *frame,
 			  const struct property_addr_info *addr_stack,
 			  CORE_ADDR *value,
+			  int rank,
 			  bool push_initial_value)
 {
   if (prop == NULL)
@@ -1629,7 +1635,7 @@ dwarf2_evaluate_property (const struct dynamic_prop *prop,
 
 	bool is_reference = baton->locexpr.is_reference;
 	if (dwarf2_locexpr_baton_eval (&baton->locexpr, frame, addr_stack,
-				       value, push_initial_value, &is_reference))
+				       value, push_initial_value, &is_reference, rank))
 	  {
 	    if (is_reference)
 	      {
diff --git a/gdb/dwarf2/loc.h b/gdb/dwarf2/loc.h
index 5ff061bb4b6..66b35876da1 100644
--- a/gdb/dwarf2/loc.h
+++ b/gdb/dwarf2/loc.h
@@ -114,6 +114,9 @@ struct property_addr_info
    Returns true if PROP could be converted and the static value is passed
    back into VALUE, otherwise returns false.
 
+   rank is pushed on to the stack before evaluating assumed rank array
+   dimensions.
+
    If PUSH_INITIAL_VALUE is true, then the top value of ADDR_STACK
    will be pushed before evaluating a location expression.  */
 
@@ -121,6 +124,7 @@ bool dwarf2_evaluate_property (const struct dynamic_prop *prop,
 			       struct frame_info *frame,
 			       const struct property_addr_info *addr_stack,
 			       CORE_ADDR *value,
+			       int rank,
 			       bool push_initial_value = false);
 
 /* A helper for the compiler interface that compiles a single dynamic
diff --git a/gdb/dwarf2/read.c b/gdb/dwarf2/read.c
index f2d7da7de52..05e1bc9c6c2 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;
@@ -9721,6 +9723,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.  */
@@ -16612,7 +16615,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);
 
@@ -18934,6 +18938,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;
@@ -19067,6 +19072,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)
@@ -21989,6 +21995,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:
 	  SYMBOL_ACLASS_INDEX (sym) = LOC_TYPEDEF;
 	  SYMBOL_DOMAIN (sym) = VAR_DOMAIN;
 	  list_to_add = cu->list_in_scope;
@@ -22482,6 +22489,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;
@@ -24767,6 +24775,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/f-typeprint.c b/gdb/f-typeprint.c
index 1791cb29451..95500e930ba 100644
--- a/gdb/f-typeprint.c
+++ b/gdb/f-typeprint.c
@@ -177,9 +177,7 @@ f_language::f_type_print_varspec_suffix (struct type *type,
       else if ((TYPE_ASSOCIATED_PROP (type)
 		&& PROP_CONST != TYPE_ASSOCIATED_PROP (type)->kind ())
 	       || (TYPE_ALLOCATED_PROP (type)
-		   && PROP_CONST != TYPE_ALLOCATED_PROP (type)->kind ())
-	       || (TYPE_DATA_LOCATION (type)
-		   && PROP_CONST != TYPE_DATA_LOCATION (type)->kind ()))
+		   && PROP_CONST != TYPE_ALLOCATED_PROP (type)->kind ()))
 	{
 	  /* This case exist when we ptype a typename which has the dynamic
 	     properties but cannot be resolved as there is no object.  */
diff --git a/gdb/findvar.c b/gdb/findvar.c
index a0031d2dadd..a1c25323bc6 100644
--- a/gdb/findvar.c
+++ b/gdb/findvar.c
@@ -440,7 +440,7 @@ follow_static_link (struct frame_info *frame,
 {
   CORE_ADDR upper_frame_base;
 
-  if (!dwarf2_evaluate_property (static_link, frame, NULL, &upper_frame_base))
+  if (!dwarf2_evaluate_property (static_link, frame, NULL,  &upper_frame_base, 0))
     return NULL;
 
   /* Now climb up the stack frame until we reach the frame we are interested
diff --git a/gdb/gdbtypes.c b/gdb/gdbtypes.c
index 00934d9a4bc..227b7af2c1b 100644
--- a/gdb/gdbtypes.c
+++ b/gdb/gdbtypes.c
@@ -2196,6 +2196,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,
+		       int curr_rank,
 		       bool resolve_p = true)
 {
   CORE_ADDR value;
@@ -2205,13 +2206,13 @@ 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, curr_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, curr_rank))
     {
       high_bound.set_const_val (value);
 
@@ -2224,7 +2225,7 @@ 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, curr_rank))
     {
       stride.set_const_val (value);
 
@@ -2272,8 +2273,12 @@ resolve_dynamic_array_or_string (struct type *type,
   struct type *elt_type;
   struct type *range_type;
   struct type *ary_dim;
+  struct type *tmp_type;
+  struct type *element_type;
   struct dynamic_prop *prop;
   unsigned int bit_stride = 0;
+  unsigned int i;
+  static int rank = 0;
 
   /* For dynamic type resolution strings can be treated like arrays of
      characters.  */
@@ -2293,7 +2298,7 @@ resolve_dynamic_array_or_string (struct type *type,
      dimension of the array.  */
   prop = TYPE_ALLOCATED_PROP (type);
   if (prop != NULL && resolve_p
-      && dwarf2_evaluate_property (prop, NULL, addr_stack, &value))
+      && dwarf2_evaluate_property (prop, NULL, addr_stack, &value, 0))
     {
       prop->set_const_val (value);
       if (value == 0)
@@ -2302,15 +2307,47 @@ resolve_dynamic_array_or_string (struct type *type,
 
   prop = TYPE_ASSOCIATED_PROP (type);
   if (prop != NULL && resolve_p
-      && dwarf2_evaluate_property (prop, NULL, addr_stack, &value))
+      && dwarf2_evaluate_property (prop, NULL, addr_stack, &value, 0))
     {
       prop->set_const_val (value);
       if (value == 0)
 	resolve_p = false;
     }
 
+  /* Resolve the rank property to get rank value. If rank is zero or is of
+     variable type remove the array type from the linked list. If the rank
+     is greater than 1 add more array types to the list based on rank value
+     to hold multi dimensional array information.   */
+  prop = TYPE_RANK_PROP (type);
+  if (!rank && prop != NULL && resolve_p
+     &&  dwarf2_evaluate_property (prop, NULL, addr_stack, &value, 0))
+    {
+      prop->set_const_val (value);
+      if (value == 0)
+      {
+	resolve_p = false;
+	TYPE_DYN_PROP(TYPE_TARGET_TYPE(type)) = TYPE_DYN_PROP(type);
+	type = TYPE_TARGET_TYPE(type);
+	return type;
+      }
+      else
+      {
+        rank = value;
+        tmp_type = type;
+        element_type = TYPE_TARGET_TYPE(tmp_type);
+        for (i = 1; i < rank; i++)
+        {
+          TYPE_TARGET_TYPE(tmp_type) = copy_type(tmp_type);
+          tmp_type = TYPE_TARGET_TYPE(tmp_type);
+        }
+        TYPE_TARGET_TYPE(tmp_type) = element_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);
+  if (rank)
+    rank--;
 
   ary_dim = check_typedef (TYPE_TARGET_TYPE (type));
   if (ary_dim != NULL && ary_dim->code () == TYPE_CODE_ARRAY)
@@ -2321,7 +2358,7 @@ resolve_dynamic_array_or_string (struct type *type,
   prop = type->dyn_prop (DYN_PROP_BYTE_STRIDE);
   if (prop != NULL && resolve_p)
     {
-      if (dwarf2_evaluate_property (prop, NULL, addr_stack, &value))
+      if (dwarf2_evaluate_property (prop, NULL, addr_stack,  &value, 0))
 	{
 	  type->remove_dyn_prop (DYN_PROP_BYTE_STRIDE);
 	  bit_stride = (unsigned int) (value * 8);
@@ -2597,7 +2634,7 @@ resolve_dynamic_struct (struct type *type,
 	  prop.set_locexpr (&baton);
 
 	  CORE_ADDR addr;
-	  if (dwarf2_evaluate_property (&prop, nullptr, addr_stack, &addr,
+	  if (dwarf2_evaluate_property (&prop, nullptr, addr_stack, &addr, 0,
 					true))
 	    resolved_type->field (i).set_loc_bitpos
 	      (TARGET_CHAR_BIT * (addr - addr_stack->addr));
@@ -2682,7 +2719,7 @@ resolve_dynamic_type_internal (struct type *type,
   gdb::optional<CORE_ADDR> type_length;
   prop = TYPE_DYNAMIC_LENGTH (type);
   if (prop != NULL
-      && dwarf2_evaluate_property (prop, NULL, addr_stack, &value))
+      && dwarf2_evaluate_property (prop, NULL, addr_stack, &value, 0))
     type_length = value;
 
   if (type->code () == TYPE_CODE_TYPEDEF)
@@ -2727,7 +2764,7 @@ resolve_dynamic_type_internal (struct type *type,
 	  break;
 
 	case TYPE_CODE_RANGE:
-	  resolved_type = resolve_dynamic_range (type, addr_stack);
+	  resolved_type = resolve_dynamic_range (type, addr_stack, 0);
 	  break;
 
 	case TYPE_CODE_UNION:
@@ -2752,7 +2789,7 @@ resolve_dynamic_type_internal (struct type *type,
   /* Resolve data_location attribute.  */
   prop = TYPE_DATA_LOCATION (resolved_type);
   if (prop != NULL
-      && dwarf2_evaluate_property (prop, NULL, addr_stack, &value))
+      && dwarf2_evaluate_property (prop, NULL, addr_stack,  &value, 0))
     {
       /* Start of Fortran hack.  See comment in f-lang.h for what is going
 	 on here.*/
diff --git a/gdb/gdbtypes.h b/gdb/gdbtypes.h
index 5284a4c3a03..374f7e9e1f6 100644
--- a/gdb/gdbtypes.h
+++ b/gdb/gdbtypes.h
@@ -556,6 +556,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,
 };
@@ -2035,6 +2039,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
@@ -2077,6 +2082,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/gnu-v3-abi.c b/gdb/gnu-v3-abi.c
index 187c10595ac..e42e20148f4 100644
--- a/gdb/gnu-v3-abi.c
+++ b/gdb/gnu-v3-abi.c
@@ -483,7 +483,7 @@ gnuv3_baseclass_offset (struct type *type, int index,
 
       CORE_ADDR result;
       if (dwarf2_evaluate_property (&prop, nullptr, &addr_stack, &result,
-				    true))
+				    0, true))
 	return (int) (result - addr_stack.addr);
     }
 
diff --git a/gdb/testsuite/gdb.fortran/assumedrank.exp b/gdb/testsuite/gdb.fortran/assumedrank.exp
new file mode 100644
index 00000000000..9337ccc4378
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/assumedrank.exp
@@ -0,0 +1,85 @@
+# Copyright 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/> .
+
+# Testing GDB's implementation of ASSUMED RANK.
+
+if {[skip_fortran_tests]} { return -1 }
+
+standard_testfile ".f90"
+load_lib fortran.exp
+
+#only gcc version >=11 supports assumed rank
+if {![test_compiler_info {gcc-1[1-9]-*}]} {
+    untested "compiler do 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..53b4d7fc35d
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/assumedrank.f90
@@ -0,0 +1,42 @@
+! Copyright 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/>.
+
+!
+! 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
+
+END PROGRAM arank
+
-- 
2.17.1