diff options
| -rw-r--r-- | gdb/dwarf2/read.c | 19 | ||||
| -rw-r--r-- | gdb/gdbtypes.c | 125 | ||||
| -rw-r--r-- | gdb/gdbtypes.h | 7 | ||||
| -rw-r--r-- | gdb/testsuite/gdb.fortran/assumedrank.exp | 86 | ||||
| -rw-r--r-- | 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 5c02d56..68c73c6 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 ae3b4cd..2623278 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 24e64e3..769328c 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 0000000..ac5159c --- /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 0000000..16f2ee7 --- /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 |