From: "Potharla, Rupesh" <Rupesh.Potharla@amd.com>
To: "gdb-patches@sourceware.org" <gdb-patches@sourceware.org>
Cc: "George, Jini Susan" <JiniSusan.George@amd.com>,
"Parasuraman, Hariharan" <Hariharan.Parasuraman@amd.com>,
"Sharma, Alok Kumar" <AlokKumar.Sharma@amd.com>,
"Achra, Nitika" <Nitika.Achra@amd.com>,
"Kumar N, Bhuvanendra" <Bhuvanendra.KumarN@amd.com>,
"Natarajan, Kavitha" <Kavitha.Natarajan@amd.com>,
"Balasubrmanian, Vignesh" <Vignesh.Balasubrmanian@amd.com>,
"E, Nagajyothi" <Nagajyothi.E@amd.com>,
"Kaushik, Sharang" <Sharang.Kaushik@amd.com>
Subject: [PATCH] Support for Fortran's ASSUMED RANK
Date: Wed, 19 Jan 2022 17:57:53 +0000 [thread overview]
Message-ID: <DM6PR12MB4219AEC5C71FC0F22300594DE7599@DM6PR12MB4219.namprd12.prod.outlook.com> (raw)
[-- 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
next reply other threads:[~2022-01-19 17:57 UTC|newest]
Thread overview: 15+ messages / expand[flat|nested] mbox.gz Atom feed top
2022-01-19 17:57 Potharla, Rupesh [this message]
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
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=DM6PR12MB4219AEC5C71FC0F22300594DE7599@DM6PR12MB4219.namprd12.prod.outlook.com \
--to=rupesh.potharla@amd.com \
--cc=AlokKumar.Sharma@amd.com \
--cc=Bhuvanendra.KumarN@amd.com \
--cc=Hariharan.Parasuraman@amd.com \
--cc=JiniSusan.George@amd.com \
--cc=Kavitha.Natarajan@amd.com \
--cc=Nagajyothi.E@amd.com \
--cc=Nitika.Achra@amd.com \
--cc=Sharang.Kaushik@amd.com \
--cc=Vignesh.Balasubrmanian@amd.com \
--cc=gdb-patches@sourceware.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
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).