public inbox for gdb-patches@sourceware.org
 help / color / mirror / Atom feed
* [PATCH] Support for Fortran's ASSUMED RANK
@ 2022-01-19 17:57 Potharla, Rupesh
  2022-01-21 19:07 ` Andrew Burgess
  0 siblings, 1 reply; 15+ messages in thread
From: Potharla, Rupesh @ 2022-01-19 17:57 UTC (permalink / raw)
  To: gdb-patches
  Cc: George, Jini Susan, Parasuraman, Hariharan, Sharma, Alok Kumar,
	Achra, Nitika, Kumar N,  Bhuvanendra, Natarajan, Kavitha,
	Balasubrmanian, Vignesh, E, Nagajyothi, Kaushik, Sharang

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

[AMD Official Use Only]

Requesting to please review the attached patch.


This patch adds support for debugging assumed rank arrays of Fortran.

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)

Regards,
Rupesh P



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

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.

This patch adds support for debugging assumed rank arrays of Fortran.

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 | 79 +++++++++++++++++++++++
 gdb/testsuite/gdb.fortran/assumedrank.f90 | 42 ++++++++++++
 10 files changed, 209 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..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 <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
+
+if {[prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
+	 {debug f90}]} {
+    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


^ permalink raw reply	[flat|nested] 15+ messages in thread
end of thread, other threads:[~2022-04-03 16:21 UTC | newest]

Thread overview: 15+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-01-19 17:57 [PATCH] Support for Fortran's ASSUMED RANK Potharla, Rupesh
2022-01-21 19:07 ` Andrew Burgess
2022-01-22  7:17   ` Potharla, Rupesh
2022-01-28  7:49   ` Potharla, Rupesh
2022-02-06 13:39     ` Andrew Burgess
2022-03-16 11:54       ` Potharla, Rupesh
2022-03-23 11:58         ` Andrew Burgess
2022-03-23 11:59           ` [PATCH 0/3] Fortran assumed rank array support Andrew Burgess
2022-03-23 11:59             ` [PATCH 1/3] gdb: small simplification in dwarf2_locexpr_baton_eval Andrew Burgess
2022-04-01 19:11               ` Tom Tromey
2022-03-23 11:59             ` [PATCH 2/3] gdb/dwarf: pass an array of values to the dwarf evaluator Andrew Burgess
2022-04-01 19:16               ` Tom Tromey
2022-03-23 11:59             ` [PATCH 3/3] gdb: add support for Fortran's ASSUMED RANK arrays Andrew Burgess
2022-04-01 19:38               ` Tom Tromey
2022-04-03 16:21                 ` Andrew Burgess

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).