diff options
| -rw-r--r-- | gdb/ChangeLog | 32 | ||||
| -rw-r--r-- | gdb/Makefile.in | 1 | ||||
| -rw-r--r-- | gdb/NEWS | 13 | ||||
| -rw-r--r-- | gdb/doc/ChangeLog | 7 | ||||
| -rw-r--r-- | gdb/doc/gdb.texinfo | 32 | ||||
| -rw-r--r-- | gdb/f-array-walker.h | 265 | ||||
| -rw-r--r-- | gdb/f-lang.c | 712 | ||||
| -rw-r--r-- | gdb/f-lang.h | 19 | ||||
| -rw-r--r-- | gdb/f-valprint.c | 187 | ||||
| -rw-r--r-- | gdb/gdbtypes.c | 12 | ||||
| -rw-r--r-- | gdb/testsuite/ChangeLog | 10 | ||||
| -rw-r--r-- | gdb/testsuite/gdb.fortran/array-slices-bad.exp | 69 | ||||
| -rw-r--r-- | gdb/testsuite/gdb.fortran/array-slices-bad.f90 | 42 | ||||
| -rw-r--r-- | gdb/testsuite/gdb.fortran/array-slices-sub-slices.exp | 111 | ||||
| -rw-r--r-- | gdb/testsuite/gdb.fortran/array-slices-sub-slices.f90 | 96 | ||||
| -rw-r--r-- | gdb/testsuite/gdb.fortran/array-slices.exp | 277 | ||||
| -rw-r--r-- | gdb/testsuite/gdb.fortran/array-slices.f90 | 364 | ||||
| -rw-r--r-- | gdb/testsuite/gdb.fortran/vla-sizeof.exp | 4 |
18 files changed, 1998 insertions, 255 deletions
diff --git a/gdb/ChangeLog b/gdb/ChangeLog index afff5d5..b839159 100644 --- a/gdb/ChangeLog +++ b/gdb/ChangeLog @@ -1,5 +1,37 @@ 2020-11-19 Andrew Burgess <andrew.burgess@embecosm.com> + * Makefile.in (HFILES_NO_SRCDIR): Add f-array-walker.h. + * NEWS: Mention new options. + * f-array-walker.h: New file. + * f-lang.c: Include 'gdbcmd.h' and 'f-array-walker.h'. + (repack_array_slices): New static global. + (show_repack_array_slices): New function. + (fortran_array_slicing_debug): New static global. + (show_fortran_array_slicing_debug): New function. + (value_f90_subarray): Delete. + (skip_undetermined_arglist): Delete. + (class fortran_array_repacker_base_impl): New class. + (class fortran_lazy_array_repacker_impl): New class. + (class fortran_array_repacker_impl): New class. + (fortran_value_subarray): Complete rewrite. + (set_fortran_list): New static global. + (show_fortran_list): Likewise. + (_initialize_f_language): Register new commands. + (fortran_adjust_dynamic_array_base_address_hack): New function. + * f-lang.h (fortran_adjust_dynamic_array_base_address_hack): + Declare. + * f-valprint.c: Include 'f-array-walker.h'. + (class fortran_array_printer_impl): New class. + (f77_print_array_1): Delete. + (f77_print_array): Delete. + (fortran_print_array): New. + (f_value_print_inner): Update to call fortran_print_array. + * gdbtypes.c: Include 'f-lang.h'. + (resolve_dynamic_type_internal): Call + fortran_adjust_dynamic_array_base_address_hack. + +2020-11-19 Andrew Burgess <andrew.burgess@embecosm.com> + * breakpoint.c (struct watch_options): New struct. (watch_option_defs): New static global. (make_watch_options_def_group): New function. diff --git a/gdb/Makefile.in b/gdb/Makefile.in index 9b48f73..a86e8d6 100644 --- a/gdb/Makefile.in +++ b/gdb/Makefile.in @@ -1280,6 +1280,7 @@ HFILES_NO_SRCDIR = \ expression.h \ extension.h \ extension-priv.h \ + f-array-walker.h \ f-lang.h \ fbsd-nat.h \ fbsd-tdep.h \ @@ -159,6 +159,19 @@ maintenance print core-file-backed-mappings Prints file-backed mappings loaded from a core file's note section. Output is expected to be similar to that of "info proc mappings". +set debug fortran-array-slicing on|off +show debug fortran-array-slicing + Print debugging when taking slices of Fortran arrays. + +set fortran repack-array-slices on|off +show fortran repack-array-slices + When taking slices from Fortran arrays and strings, if the slice is + non-contiguous within the original value then, when this option is + on, the new value will be repacked into a single contiguous value. + When this option is off, then the value returned will consist of a + descriptor that describes the slice within the memory of the + original parent value. + * Changed commands alias [-a] [--] ALIAS = COMMAND [DEFAULT-ARGS...] diff --git a/gdb/doc/ChangeLog b/gdb/doc/ChangeLog index e7cec1a..69b079b 100644 --- a/gdb/doc/ChangeLog +++ b/gdb/doc/ChangeLog @@ -1,3 +1,10 @@ +2020-11-19 Andrew Burgess <andrew.burgess@embecosm.com> + + * gdb.texinfo (Debugging Output): Document 'set/show debug + fortran-array-slicing'. + (Special Fortran Commands): Document 'set/show fortran + repack-array-slices'. + 2020-11-12 Andrew Burgess <andrew.burgess@embecosm.com> * gdb.texinfo (Maintenance Commands): Update description of 'maint diff --git a/gdb/doc/gdb.texinfo b/gdb/doc/gdb.texinfo index 7092331..01dcac9 100644 --- a/gdb/doc/gdb.texinfo +++ b/gdb/doc/gdb.texinfo @@ -17041,6 +17041,29 @@ This command prints the values contained in the Fortran @code{COMMON} block whose name is @var{common-name}. With no argument, the names of all @code{COMMON} blocks visible at the current program location are printed. +@cindex arrays slices (Fortran) +@kindex set fortran repack-array-slices +@kindex show fortran repack-array-slices +@item set fortran repack-array-slices [on|off] +@item show fortran repack-array-slices +When taking a slice from an array, a Fortran compiler can choose to +either produce an array descriptor that describes the slice in place, +or it may repack the slice, copying the elements of the slice into a +new region of memory. + +When this setting is on, then @value{GDBN} will also repack array +slices in some situations. When this setting is off, then +@value{GDBN} will create array descriptors for slices that reference +the original data in place. + +@value{GDBN} will never repack an array slice if the data for the +slice is contiguous within the original array. + +@value{GDBN} will always repack string slices if the data for the +slice is non-contiguous within the original string as @value{GDBN} +does not support printing non-contiguous strings. + +The default for this setting is @code{off}. @end table @node Pascal @@ -26633,6 +26656,15 @@ Turns on or off debugging messages from the FreeBSD native target. @item show debug fbsd-nat Show the current state of FreeBSD native target debugging messages. +@item set debug fortran-array-slicing +@cindex fortran array slicing debugging info +Turns on or off display of @value{GDBN} Fortran array slicing +debugging info. The default is off. + +@item show debug fortran-array-slicing +Displays the current state of displaying @value{GDBN} Fortran array +slicing debugging info. + @item set debug frame @cindex frame debugging info Turns on or off display of @value{GDBN} frame debugging info. The diff --git a/gdb/f-array-walker.h b/gdb/f-array-walker.h new file mode 100644 index 0000000..417f9f0 --- /dev/null +++ b/gdb/f-array-walker.h @@ -0,0 +1,265 @@ +/* Copyright (C) 2020 Free Software Foundation, Inc. + + This file is part of GDB. + + 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/>. */ + +/* Support classes to wrap up the process of iterating over a + multi-dimensional Fortran array. */ + +#ifndef F_ARRAY_WALKER_H +#define F_ARRAY_WALKER_H + +#include "defs.h" +#include "gdbtypes.h" +#include "f-lang.h" + +/* Class for calculating the byte offset for elements within a single + dimension of a Fortran array. */ +class fortran_array_offset_calculator +{ +public: + /* Create a new offset calculator for TYPE, which is either an array or a + string. */ + explicit fortran_array_offset_calculator (struct type *type) + { + /* Validate the type. */ + type = check_typedef (type); + if (type->code () != TYPE_CODE_ARRAY + && (type->code () != TYPE_CODE_STRING)) + error (_("can only compute offsets for arrays and strings")); + + /* Get the range, and extract the bounds. */ + struct type *range_type = type->index_type (); + if (get_discrete_bounds (range_type, &m_lowerbound, &m_upperbound) < 0) + error ("unable to read array bounds"); + + /* Figure out the stride for this array. */ + struct type *elt_type = check_typedef (TYPE_TARGET_TYPE (type)); + m_stride = type->index_type ()->bounds ()->bit_stride (); + if (m_stride == 0) + m_stride = type_length_units (elt_type); + else + { + struct gdbarch *arch = get_type_arch (elt_type); + int unit_size = gdbarch_addressable_memory_unit_size (arch); + m_stride /= (unit_size * 8); + } + }; + + /* Get the byte offset for element INDEX within the type we are working + on. There is no bounds checking done on INDEX. If the stride is + negative then we still assume that the base address (for the array + object) points to the element with the lowest memory address, we then + calculate an offset assuming that index 0 will be the element at the + highest address, index 1 the next highest, and so on. This is not + quite how Fortran works in reality; in reality the base address of + the object would point at the element with the highest address, and + we would index backwards from there in the "normal" way, however, + GDB's current value contents model doesn't support having the base + address be near to the end of the value contents, so we currently + adjust the base address of Fortran arrays with negative strides so + their base address points at the lowest memory address. This code + here is part of working around this weirdness. */ + LONGEST index_offset (LONGEST index) + { + LONGEST offset; + if (m_stride < 0) + offset = std::abs (m_stride) * (m_upperbound - index); + else + offset = std::abs (m_stride) * (index - m_lowerbound); + return offset; + } + +private: + + /* The stride for the type we are working with. */ + LONGEST m_stride; + + /* The upper bound for the type we are working with. */ + LONGEST m_upperbound; + + /* The lower bound for the type we are working with. */ + LONGEST m_lowerbound; +}; + +/* A base class used by fortran_array_walker. There's no virtual methods + here, sub-classes should just override the functions they want in order + to specialise the behaviour to their needs. The functionality + provided in these default implementations will visit every array + element, but do nothing for each element. */ + +struct fortran_array_walker_base_impl +{ + /* Called when iterating between the lower and upper bounds of each + dimension of the array. Return true if GDB should continue iterating, + otherwise, return false. + + SHOULD_CONTINUE indicates if GDB is going to stop anyway, and should + be taken into consideration when deciding what to return. If + SHOULD_CONTINUE is false then this function must also return false, + the function is still called though in case extra work needs to be + done as part of the stopping process. */ + bool continue_walking (bool should_continue) + { return should_continue; } + + /* Called when GDB starts iterating over a dimension of the array. The + argument INNER_P is true for the inner most dimension (the dimension + containing the actual elements of the array), and false for more outer + dimensions. For a concrete example of how this function is called + see the comment on process_element below. */ + void start_dimension (bool inner_p) + { /* Nothing. */ } + + /* Called when GDB finishes iterating over a dimension of the array. The + argument INNER_P is true for the inner most dimension (the dimension + containing the actual elements of the array), and false for more outer + dimensions. LAST_P is true for the last call at a particular + dimension. For a concrete example of how this function is called + see the comment on process_element below. */ + void finish_dimension (bool inner_p, bool last_p) + { /* Nothing. */ } + + /* Called when processing the inner most dimension of the array, for + every element in the array. ELT_TYPE is the type of the element being + extracted, and ELT_OFF is the offset of the element from the start of + array being walked, and LAST_P is true only when this is the last + element that will be processed in this dimension. + + Given this two dimensional array ((1, 2) (3, 4)), the calls to + start_dimension, process_element, and finish_dimension look like this: + + start_dimension (false); + start_dimension (true); + process_element (TYPE, OFFSET, false); + process_element (TYPE, OFFSET, true); + finish_dimension (true, false); + start_dimension (true); + process_element (TYPE, OFFSET, false); + process_element (TYPE, OFFSET, true); + finish_dimension (true, true); + finish_dimension (false, true); */ + void process_element (struct type *elt_type, LONGEST elt_off, bool last_p) + { /* Nothing. */ } +}; + +/* A class to wrap up the process of iterating over a multi-dimensional + Fortran array. IMPL is used to specialise what happens as we walk over + the array. See class FORTRAN_ARRAY_WALKER_BASE_IMPL (above) for the + methods than can be used to customise the array walk. */ +template<typename Impl> +class fortran_array_walker +{ + /* Ensure that Impl is derived from the required base class. This just + ensures that all of the required API methods are available and have a + sensible default implementation. */ + gdb_static_assert ((std::is_base_of<fortran_array_walker_base_impl,Impl>::value)); + +public: + /* Create a new array walker. TYPE is the type of the array being walked + over, and ADDRESS is the base address for the object of TYPE in + memory. All other arguments are forwarded to the constructor of the + template parameter class IMPL. */ + template <typename ...Args> + fortran_array_walker (struct type *type, CORE_ADDR address, + Args... args) + : m_type (type), + m_address (address), + m_impl (type, address, args...) + { + m_ndimensions = calc_f77_array_dims (m_type); + } + + /* Walk the array. */ + void + walk () + { + walk_1 (1, m_type, 0, false); + } + +private: + /* The core of the array walking algorithm. NSS is the current + dimension number being processed, TYPE is the type of this dimension, + and OFFSET is the offset (in bytes) for the start of this dimension. */ + void + walk_1 (int nss, struct type *type, int offset, bool last_p) + { + /* Extract the range, and get lower and upper bounds. */ + struct type *range_type = check_typedef (type)->index_type (); + LONGEST lowerbound, upperbound; + if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0) + error ("failed to get range bounds"); + + /* CALC is used to calculate the offsets for each element in this + dimension. */ + fortran_array_offset_calculator calc (type); + + m_impl.start_dimension (nss == m_ndimensions); + + if (nss != m_ndimensions) + { + /* For dimensions other than the inner most, walk each element and + recurse while peeling off one more dimension of the array. */ + for (LONGEST i = lowerbound; + m_impl.continue_walking (i < upperbound + 1); + i++) + { + /* Use the index and the stride to work out a new offset. */ + LONGEST new_offset = offset + calc.index_offset (i); + + /* Now print the lower dimension. */ + struct type *subarray_type + = TYPE_TARGET_TYPE (check_typedef (type)); + walk_1 (nss + 1, subarray_type, new_offset, (i == upperbound)); + } + } + else + { + /* For the inner most dimension of the array, process each element + within this dimension. */ + for (LONGEST i = lowerbound; + m_impl.continue_walking (i < upperbound + 1); + i++) + { + LONGEST elt_off = offset + calc.index_offset (i); + + struct type *elt_type = check_typedef (TYPE_TARGET_TYPE (type)); + if (is_dynamic_type (elt_type)) + { + CORE_ADDR e_address = m_address + elt_off; + elt_type = resolve_dynamic_type (elt_type, {}, e_address); + } + + m_impl.process_element (elt_type, elt_off, (i == upperbound)); + } + } + + m_impl.finish_dimension (nss == m_ndimensions, last_p || nss == 1); + } + + /* The array type being processed. */ + struct type *m_type; + + /* The address in target memory for the object of M_TYPE being + processed. This is required in order to resolve dynamic types. */ + CORE_ADDR m_address; + + /* An instance of the template specialisation class. */ + Impl m_impl; + + /* The total number of dimensions in M_TYPE. */ + int m_ndimensions; +}; + +#endif /* F_ARRAY_WALKER_H */ diff --git a/gdb/f-lang.c b/gdb/f-lang.c index ec5d6d1..3c6d5a5 100644 --- a/gdb/f-lang.c +++ b/gdb/f-lang.c @@ -36,9 +36,36 @@ #include "c-lang.h" #include "target-float.h" #include "gdbarch.h" +#include "gdbcmd.h" +#include "f-array-walker.h" #include <math.h> +/* Whether GDB should repack array slices created by the user. */ +static bool repack_array_slices = false; + +/* Implement 'show fortran repack-array-slices'. */ +static void +show_repack_array_slices (struct ui_file *file, int from_tty, + struct cmd_list_element *c, const char *value) +{ + fprintf_filtered (file, _("Repacking of Fortran array slices is %s.\n"), + value); +} + +/* Debugging of Fortran's array slicing. */ +static bool fortran_array_slicing_debug = false; + +/* Implement 'show debug fortran-array-slicing'. */ +static void +show_fortran_array_slicing_debug (struct ui_file *file, int from_tty, + struct cmd_list_element *c, + const char *value) +{ + fprintf_filtered (file, _("Debugging of Fortran array slicing is %s.\n"), + value); +} + /* Local functions */ static struct value *fortran_argument_convert (struct value *value, @@ -101,57 +128,6 @@ const struct op_print f_language::op_print_tab[] = }; -/* Called from fortran_value_subarray to take a slice of an array or a - string. ARRAY is the array or string to be accessed. EXP, POS, and - NOSIDE are as for evaluate_subexp_standard. Return a value that is a - slice of the array. */ - -static struct value * -value_f90_subarray (struct value *array, - struct expression *exp, int *pos, enum noside noside) -{ - int pc = (*pos) + 1; - LONGEST low_bound, high_bound, stride; - struct type *range = check_typedef (value_type (array)->index_type ()); - enum range_flag range_flag - = (enum range_flag) longest_to_int (exp->elts[pc].longconst); - - *pos += 3; - - if (range_flag & RANGE_LOW_BOUND_DEFAULT) - low_bound = range->bounds ()->low.const_val (); - else - low_bound = value_as_long (evaluate_subexp (nullptr, exp, pos, noside)); - - if (range_flag & RANGE_HIGH_BOUND_DEFAULT) - high_bound = range->bounds ()->high.const_val (); - else - high_bound = value_as_long (evaluate_subexp (nullptr, exp, pos, noside)); - - if (range_flag & RANGE_HAS_STRIDE) - stride = value_as_long (evaluate_subexp (nullptr, exp, pos, noside)); - else - stride = 1; - - if (stride != 1) - error (_("Fortran array strides are not currently supported")); - - return value_slice (array, low_bound, high_bound - low_bound + 1); -} - -/* Helper for skipping all the arguments in an undetermined argument list. - This function was designed for use in the OP_F77_UNDETERMINED_ARGLIST - case of evaluate_subexp_standard as multiple, but not all, code paths - require a generic skip. */ - -static void -skip_undetermined_arglist (int nargs, struct expression *exp, int *pos, - enum noside noside) -{ - for (int i = 0; i < nargs; ++i) - evaluate_subexp (nullptr, exp, pos, noside); -} - /* Return the number of dimensions for a Fortran array or string. */ int @@ -176,6 +152,145 @@ calc_f77_array_dims (struct type *array_type) return ndimen; } +/* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array + slices. This is a base class for two alternative repacking mechanisms, + one for when repacking from a lazy value, and one for repacking from a + non-lazy (already loaded) value. */ +class fortran_array_repacker_base_impl + : public fortran_array_walker_base_impl +{ +public: + /* Constructor, DEST is the value we are repacking into. */ + fortran_array_repacker_base_impl (struct value *dest) + : m_dest (dest), + m_dest_offset (0) + { /* Nothing. */ } + + /* When we start processing the inner most dimension, this is where we + will be creating values for each element as we load them and then copy + them into the M_DEST value. Set a value mark so we can free these + temporary values. */ + void start_dimension (bool inner_p) + { + if (inner_p) + { + gdb_assert (m_mark == nullptr); + m_mark = value_mark (); + } + } + + /* When we finish processing the inner most dimension free all temporary + value that were created. */ + void finish_dimension (bool inner_p, bool last_p) + { + if (inner_p) + { + gdb_assert (m_mark != nullptr); + value_free_to_mark (m_mark); + m_mark = nullptr; + } + } + +protected: + /* Copy the contents of array element ELT into M_DEST at the next + available offset. */ + void copy_element_to_dest (struct value *elt) + { + value_contents_copy (m_dest, m_dest_offset, elt, 0, + TYPE_LENGTH (value_type (elt))); + m_dest_offset += TYPE_LENGTH (value_type (elt)); + } + + /* The value being written to. */ + struct value *m_dest; + + /* The byte offset in M_DEST at which the next element should be + written. */ + LONGEST m_dest_offset; + + /* Set with a call to VALUE_MARK, and then reset after calling + VALUE_FREE_TO_MARK. */ + struct value *m_mark = nullptr; +}; + +/* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array + slices. This class is specialised for repacking an array slice from a + lazy array value, as such it does not require the parent array value to + be loaded into GDB's memory; the parent value could be huge, while the + slice could be tiny. */ +class fortran_lazy_array_repacker_impl + : public fortran_array_repacker_base_impl +{ +public: + /* Constructor. TYPE is the type of the slice being loaded from the + parent value, so this type will correctly reflect the strides required + to find all of the elements from the parent value. ADDRESS is the + address in target memory of value matching TYPE, and DEST is the value + we are repacking into. */ + explicit fortran_lazy_array_repacker_impl (struct type *type, + CORE_ADDR address, + struct value *dest) + : fortran_array_repacker_base_impl (dest), + m_addr (address) + { /* Nothing. */ } + + /* Create a lazy value in target memory representing a single element, + then load the element into GDB's memory and copy the contents into the + destination value. */ + void process_element (struct type *elt_type, LONGEST elt_off, bool last_p) + { + copy_element_to_dest (value_at_lazy (elt_type, m_addr + elt_off)); + } + +private: + /* The address in target memory where the parent value starts. */ + CORE_ADDR m_addr; +}; + +/* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array + slices. This class is specialised for repacking an array slice from a + previously loaded (non-lazy) array value, as such it fetches the + element values from the contents of the parent value. */ +class fortran_array_repacker_impl + : public fortran_array_repacker_base_impl +{ +public: + /* Constructor. TYPE is the type for the array slice within the parent + value, as such it has stride values as required to find the elements + within the original parent value. ADDRESS is the address in target + memory of the value matching TYPE. BASE_OFFSET is the offset from + the start of VAL's content buffer to the start of the object of TYPE, + VAL is the parent object from which we are loading the value, and + DEST is the value into which we are repacking. */ + explicit fortran_array_repacker_impl (struct type *type, CORE_ADDR address, + LONGEST base_offset, + struct value *val, struct value *dest) + : fortran_array_repacker_base_impl (dest), + m_base_offset (base_offset), + m_val (val) + { + gdb_assert (!value_lazy (val)); + } + + /* Extract an element of ELT_TYPE at offset (M_BASE_OFFSET + ELT_OFF) + from the content buffer of M_VAL then copy this extracted value into + the repacked destination value. */ + void process_element (struct type *elt_type, LONGEST elt_off, bool last_p) + { + struct value *elt + = value_from_component (m_val, elt_type, (elt_off + m_base_offset)); + copy_element_to_dest (elt); + } + +private: + /* The offset into the content buffer of M_VAL to the start of the slice + being extracted. */ + LONGEST m_base_offset; + + /* The parent value from which we are extracting a slice. */ + struct value *m_val; +}; + /* Called from evaluate_subexp_standard to perform array indexing, and sub-range extraction, for Fortran. As well as arrays this function also handles strings as they can be treated like arrays of characters. @@ -187,51 +302,394 @@ static struct value * fortran_value_subarray (struct value *array, struct expression *exp, int *pos, int nargs, enum noside noside) { - if (exp->elts[*pos].opcode == OP_RANGE) - return value_f90_subarray (array, exp, pos, noside); - - if (noside == EVAL_SKIP) + type *original_array_type = check_typedef (value_type (array)); + bool is_string_p = original_array_type->code () == TYPE_CODE_STRING; + + /* Perform checks for ARRAY not being available. The somewhat overly + complex logic here is just to keep backward compatibility with the + errors that we used to get before FORTRAN_VALUE_SUBARRAY was + rewritten. Maybe a future task would streamline the error messages we + get here, and update all the expected test results. */ + if (exp->elts[*pos].opcode != OP_RANGE) + { + if (type_not_associated (original_array_type)) + error (_("no such vector element (vector not associated)")); + else if (type_not_allocated (original_array_type)) + error (_("no such vector element (vector not allocated)")); + } + else { - skip_undetermined_arglist (nargs, exp, pos, noside); - /* Return the dummy value with the correct type. */ - return array; + if (type_not_associated (original_array_type)) + error (_("array not associated")); + else if (type_not_allocated (original_array_type)) + error (_("array not allocated")); } - LONGEST subscript_array[MAX_FORTRAN_DIMS]; - int ndimensions = 1; - struct type *type = check_typedef (value_type (array)); + /* First check that the number of dimensions in the type we are slicing + matches the number of arguments we were passed. */ + int ndimensions = calc_f77_array_dims (original_array_type); + if (nargs != ndimensions) + error (_("Wrong number of subscripts")); + + /* This will be initialised below with the type of the elements held in + ARRAY. */ + struct type *inner_element_type; + + /* Extract the types of each array dimension from the original array + type. We need these available so we can fill in the default upper and + lower bounds if the user requested slice doesn't provide that + information. Additionally unpacking the dimensions like this gives us + the inner element type. */ + std::vector<struct type *> dim_types; + { + dim_types.reserve (ndimensions); + struct type *type = original_array_type; + for (int i = 0; i < ndimensions; ++i) + { + dim_types.push_back (type); + type = TYPE_TARGET_TYPE (type); + } + /* TYPE is now the inner element type of the array, we start the new + array slice off as this type, then as we process the requested slice + (from the user) we wrap new types around this to build up the final + slice type. */ + inner_element_type = type; + } + + /* As we analyse the new slice type we need to understand if the data + being referenced is contiguous. Do decide this we must track the size + of an element at each dimension of the new slice array. Initially the + elements of the inner most dimension of the array are the same inner + most elements as the original ARRAY. */ + LONGEST slice_element_size = TYPE_LENGTH (inner_element_type); + + /* Start off assuming all data is contiguous, this will be set to false + if access to any dimension results in non-contiguous data. */ + bool is_all_contiguous = true; + + /* The TOTAL_OFFSET is the distance in bytes from the start of the + original ARRAY to the start of the new slice. This is calculated as + we process the information from the user. */ + LONGEST total_offset = 0; + + /* A structure representing information about each dimension of the + resulting slice. */ + struct slice_dim + { + /* Constructor. */ + slice_dim (LONGEST l, LONGEST h, LONGEST s, struct type *idx) + : low (l), + high (h), + stride (s), + index (idx) + { /* Nothing. */ } + + /* The low bound for this dimension of the slice. */ + LONGEST low; - if (nargs > MAX_FORTRAN_DIMS) - error (_("Too many subscripts for F77 (%d Max)"), MAX_FORTRAN_DIMS); + /* The high bound for this dimension of the slice. */ + LONGEST high; - ndimensions = calc_f77_array_dims (type); + /* The byte stride for this dimension of the slice. */ + LONGEST stride; - if (nargs != ndimensions) - error (_("Wrong number of subscripts")); + struct type *index; + }; + + /* The dimensions of the resulting slice. */ + std::vector<slice_dim> slice_dims; + + /* Process the incoming arguments. These arguments are in the reverse + order to the array dimensions, that is the first argument refers to + the last array dimension. */ + if (fortran_array_slicing_debug) + debug_printf ("Processing array access:\n"); + for (int i = 0; i < nargs; ++i) + { + /* For each dimension of the array the user will have either provided + a ranged access with optional lower bound, upper bound, and + stride, or the user will have supplied a single index. */ + struct type *dim_type = dim_types[ndimensions - (i + 1)]; + if (exp->elts[*pos].opcode == OP_RANGE) + { + int pc = (*pos) + 1; + enum range_flag range_flag = (enum range_flag) exp->elts[pc].longconst; + *pos += 3; + + LONGEST low, high, stride; + low = high = stride = 0; + + if ((range_flag & RANGE_LOW_BOUND_DEFAULT) == 0) + low = value_as_long (evaluate_subexp (nullptr, exp, pos, noside)); + else + low = f77_get_lowerbound (dim_type); + if ((range_flag & RANGE_HIGH_BOUND_DEFAULT) == 0) + high = value_as_long (evaluate_subexp (nullptr, exp, pos, noside)); + else + high = f77_get_upperbound (dim_type); + if ((range_flag & RANGE_HAS_STRIDE) == RANGE_HAS_STRIDE) + stride = value_as_long (evaluate_subexp (nullptr, exp, pos, noside)); + else + stride = 1; + + if (stride == 0) + error (_("stride must not be 0")); + + /* Get information about this dimension in the original ARRAY. */ + struct type *target_type = TYPE_TARGET_TYPE (dim_type); + struct type *index_type = dim_type->index_type (); + LONGEST lb = f77_get_lowerbound (dim_type); + LONGEST ub = f77_get_upperbound (dim_type); + LONGEST sd = index_type->bit_stride (); + if (sd == 0) + sd = TYPE_LENGTH (target_type) * 8; + + if (fortran_array_slicing_debug) + { + debug_printf ("|-> Range access\n"); + std::string str = type_to_string (dim_type); + debug_printf ("| |-> Type: %s\n", str.c_str ()); + debug_printf ("| |-> Array:\n"); + debug_printf ("| | |-> Low bound: %ld\n", lb); + debug_printf ("| | |-> High bound: %ld\n", ub); + debug_printf ("| | |-> Bit stride: %ld\n", sd); + debug_printf ("| | |-> Byte stride: %ld\n", sd / 8); + debug_printf ("| | |-> Type size: %ld\n", + TYPE_LENGTH (dim_type)); + debug_printf ("| | '-> Target type size: %ld\n", + TYPE_LENGTH (target_type)); + debug_printf ("| |-> Accessing:\n"); + debug_printf ("| | |-> Low bound: %ld\n", + low); + debug_printf ("| | |-> High bound: %ld\n", + high); + debug_printf ("| | '-> Element stride: %ld\n", + stride); + } + + /* Check the user hasn't asked for something invalid. */ + if (high > ub || low < lb) + error (_("array subscript out of bounds")); + + /* Calculate what this dimension of the new slice array will look + like. OFFSET is the byte offset from the start of the + previous (more outer) dimension to the start of this + dimension. E_COUNT is the number of elements in this + dimension. REMAINDER is the number of elements remaining + between the last included element and the upper bound. For + example an access '1:6:2' will include elements 1, 3, 5 and + have a remainder of 1 (element #6). */ + LONGEST lowest = std::min (low, high); + LONGEST offset = (sd / 8) * (lowest - lb); + LONGEST e_count = std::abs (high - low) + 1; + e_count = (e_count + (std::abs (stride) - 1)) / std::abs (stride); + LONGEST new_low = 1; + LONGEST new_high = new_low + e_count - 1; + LONGEST new_stride = (sd * stride) / 8; + LONGEST last_elem = low + ((e_count - 1) * stride); + LONGEST remainder = high - last_elem; + if (low > high) + { + offset += std::abs (remainder) * TYPE_LENGTH (target_type); + if (stride > 0) + error (_("incorrect stride and boundary combination")); + } + else if (stride < 0) + error (_("incorrect stride and boundary combination")); + + /* Is the data within this dimension contiguous? It is if the + newly computed stride is the same size as a single element of + this dimension. */ + bool is_dim_contiguous = (new_stride == slice_element_size); + is_all_contiguous &= is_dim_contiguous; - gdb_assert (nargs > 0); + if (fortran_array_slicing_debug) + { + debug_printf ("| '-> Results:\n"); + debug_printf ("| |-> Offset = %ld\n", offset); + debug_printf ("| |-> Elements = %ld\n", e_count); + debug_printf ("| |-> Low bound = %ld\n", new_low); + debug_printf ("| |-> High bound = %ld\n", new_high); + debug_printf ("| |-> Byte stride = %ld\n", new_stride); + debug_printf ("| |-> Last element = %ld\n", last_elem); + debug_printf ("| |-> Remainder = %ld\n", remainder); + debug_printf ("| '-> Contiguous = %s\n", + (is_dim_contiguous ? "Yes" : "No")); + } + + /* Figure out how big (in bytes) an element of this dimension of + the new array slice will be. */ + slice_element_size = std::abs (new_stride * e_count); - /* Now that we know we have a legal array subscript expression let us - actually find out where this element exists in the array. */ + slice_dims.emplace_back (new_low, new_high, new_stride, + index_type); + + /* Update the total offset. */ + total_offset += offset; + } + else + { + /* There is a single index for this dimension. */ + LONGEST index + = value_as_long (evaluate_subexp_with_coercion (exp, pos, noside)); + + /* Get information about this dimension in the original ARRAY. */ + struct type *target_type = TYPE_TARGET_TYPE (dim_type); + struct type *index_type = dim_type->index_type (); + LONGEST lb = f77_get_lowerbound (dim_type); + LONGEST ub = f77_get_upperbound (dim_type); + LONGEST sd = index_type->bit_stride () / 8; + if (sd == 0) + sd = TYPE_LENGTH (target_type); + + if (fortran_array_slicing_debug) + { + debug_printf ("|-> Index access\n"); + std::string str = type_to_string (dim_type); + debug_printf ("| |-> Type: %s\n", str.c_str ()); + debug_printf ("| |-> Array:\n"); + debug_printf ("| | |-> Low bound: %ld\n", lb); + debug_printf ("| | |-> High bound: %ld\n", ub); + debug_printf ("| | |-> Byte stride: %ld\n", sd); + debug_printf ("| | |-> Type size: %ld\n", TYPE_LENGTH (dim_type)); + debug_printf ("| | '-> Target type size: %ld\n", + TYPE_LENGTH (target_type)); + debug_printf ("| '-> Accessing:\n"); + debug_printf ("| '-> Index: %ld\n", index); + } + + /* If the array has actual content then check the index is in + bounds. An array without content (an unbound array) doesn't + have a known upper bound, so don't error check in that + situation. */ + if (index < lb + || (dim_type->index_type ()->bounds ()->high.kind () != PROP_UNDEFINED + && index > ub) + || (VALUE_LVAL (array) != lval_memory + && dim_type->index_type ()->bounds ()->high.kind () == PROP_UNDEFINED)) + { + if (type_not_associated (dim_type)) + error (_("no such vector element (vector not associated)")); + else if (type_not_allocated (dim_type)) + error (_("no such vector element (vector not allocated)")); + else + error (_("no such vector element")); + } + + /* Calculate using the type stride, not the target type size. */ + LONGEST offset = sd * (index - lb); + total_offset += offset; + } + } + + if (noside == EVAL_SKIP) + return array; - /* Take array indices left to right. */ - for (int i = 0; i < nargs; i++) + /* Build a type that represents the new array slice in the target memory + of the original ARRAY, this type makes use of strides to correctly + find only those elements that are part of the new slice. */ + struct type *array_slice_type = inner_element_type; + for (const auto &d : slice_dims) { - /* Evaluate each subscript; it must be a legal integer in F77. */ - value *arg2 = evaluate_subexp_with_coercion (exp, pos, noside); + /* Create the range. */ + dynamic_prop p_low, p_high, p_stride; + + p_low.set_const_val (d.low); + p_high.set_const_val (d.high); + p_stride.set_const_val (d.stride); + + struct type *new_range + = create_range_type_with_stride ((struct type *) NULL, + TYPE_TARGET_TYPE (d.index), + &p_low, &p_high, 0, &p_stride, + true); + array_slice_type + = create_array_type (nullptr, array_slice_type, new_range); + } - /* Fill in the subscript array. */ - subscript_array[i] = value_as_long (arg2); + if (fortran_array_slicing_debug) + { + debug_printf ("'-> Final result:\n"); + debug_printf (" |-> Type: %s\n", + type_to_string (array_slice_type).c_str ()); + debug_printf (" |-> Total offset: %ld\n", total_offset); + debug_printf (" |-> Base address: %s\n", + core_addr_to_string (value_address (array))); + debug_printf (" '-> Contiguous = %s\n", + (is_all_contiguous ? "Yes" : "No")); } - /* Internal type of array is arranged right to left. */ - for (int i = nargs; i > 0; i--) + /* Should we repack this array slice? */ + if (!is_all_contiguous && (repack_array_slices || is_string_p)) { - struct type *array_type = check_typedef (value_type (array)); - LONGEST index = subscript_array[i - 1]; + /* Build a type for the repacked slice. */ + struct type *repacked_array_type = inner_element_type; + for (const auto &d : slice_dims) + { + /* Create the range. */ + dynamic_prop p_low, p_high, p_stride; + + p_low.set_const_val (d.low); + p_high.set_const_val (d.high); + p_stride.set_const_val (TYPE_LENGTH (repacked_array_type)); + + struct type *new_range + = create_range_type_with_stride ((struct type *) NULL, + TYPE_TARGET_TYPE (d.index), + &p_low, &p_high, 0, &p_stride, + true); + repacked_array_type + = create_array_type (nullptr, repacked_array_type, new_range); + } - array = value_subscripted_rvalue (array, index, - f77_get_lowerbound (array_type)); + /* Now copy the elements from the original ARRAY into the packed + array value DEST. */ + struct value *dest = allocate_value (repacked_array_type); + if (value_lazy (array) + || (total_offset + TYPE_LENGTH (array_slice_type) + > TYPE_LENGTH (check_typedef (value_type (array))))) + { + fortran_array_walker<fortran_lazy_array_repacker_impl> p + (array_slice_type, value_address (array) + total_offset, dest); + p.walk (); + } + else + { + fortran_array_walker<fortran_array_repacker_impl> p + (array_slice_type, value_address (array) + total_offset, + total_offset, array, dest); + p.walk (); + } + array = dest; + } + else + { + if (VALUE_LVAL (array) == lval_memory) + { + /* If the value we're taking a slice from is not yet loaded, or + the requested slice is outside the values content range then + just create a new lazy value pointing at the memory where the + contents we're looking for exist. */ + if (value_lazy (array) + || (total_offset + TYPE_LENGTH (array_slice_type) + > TYPE_LENGTH (check_typedef (value_type (array))))) + array = value_at_lazy (array_slice_type, + value_address (array) + total_offset); + else + array = value_from_contents_and_address (array_slice_type, + (value_contents (array) + + total_offset), + (value_address (array) + + total_offset)); + } + else if (!value_lazy (array)) + { + const void *valaddr = value_contents (array) + total_offset; + array = allocate_value (array_slice_type); + memcpy (value_contents_raw (array), valaddr, TYPE_LENGTH (array_slice_type)); + } + else + error (_("cannot subscript arrays that are not in memory")); } return array; @@ -840,11 +1298,50 @@ builtin_f_type (struct gdbarch *gdbarch) return (const struct builtin_f_type *) gdbarch_data (gdbarch, f_type_data); } +/* Command-list for the "set/show fortran" prefix command. */ +static struct cmd_list_element *set_fortran_list; +static struct cmd_list_element *show_fortran_list; + void _initialize_f_language (); void _initialize_f_language () { f_type_data = gdbarch_data_register_post_init (build_fortran_types); + + add_basic_prefix_cmd ("fortran", no_class, + _("Prefix command for changing Fortran-specific settings."), + &set_fortran_list, "set fortran ", 0, &setlist); + + add_show_prefix_cmd ("fortran", no_class, + _("Generic command for showing Fortran-specific settings."), + &show_fortran_list, "show fortran ", 0, &showlist); + + add_setshow_boolean_cmd ("repack-array-slices", class_vars, + &repack_array_slices, _("\ +Enable or disable repacking of non-contiguous array slices."), _("\ +Show whether non-contiguous array slices are repacked."), _("\ +When the user requests a slice of a Fortran array then we can either return\n\ +a descriptor that describes the array in place (using the original array data\n\ +in its existing location) or the original data can be repacked (copied) to a\n\ +new location.\n\ +\n\ +When the content of the array slice is contiguous within the original array\n\ +then the result will never be repacked, but when the data for the new array\n\ +is non-contiguous within the original array repacking will only be performed\n\ +when this setting is on."), + NULL, + show_repack_array_slices, + &set_fortran_list, &show_fortran_list); + + /* Debug Fortran's array slicing logic. */ + add_setshow_boolean_cmd ("fortran-array-slicing", class_maintenance, + &fortran_array_slicing_debug, _("\ +Set debugging of Fortran array slicing."), _("\ +Show debugging of Fortran array slicing."), _("\ +When on, debugging of Fortran array slicing is enabled."), + NULL, + show_fortran_array_slicing_debug, + &setdebuglist, &showdebuglist); } /* Ensures that function argument VALUE is in the appropriate form to @@ -895,3 +1392,56 @@ fortran_preserve_arg_pointer (struct value *arg, struct type *type) return value_type (arg); return type; } + +/* See f-lang.h. */ + +CORE_ADDR +fortran_adjust_dynamic_array_base_address_hack (struct type *type, + CORE_ADDR address) +{ + gdb_assert (type->code () == TYPE_CODE_ARRAY); + + int ndimensions = calc_f77_array_dims (type); + LONGEST total_offset = 0; + + /* Walk through each of the dimensions of this array type and figure out + if any of the dimensions are "backwards", that is the base address + for this dimension points to the element at the highest memory + address and the stride is negative. */ + struct type *tmp_type = type; + for (int i = 0 ; i < ndimensions; ++i) + { + /* Grab the range for this dimension and extract the lower and upper + bounds. */ + tmp_type = check_typedef (tmp_type); + struct type *range_type = tmp_type->index_type (); + LONGEST lowerbound, upperbound, stride; + if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0) + error ("failed to get range bounds"); + + /* Figure out the stride for this dimension. */ + struct type *elt_type = check_typedef (TYPE_TARGET_TYPE (tmp_type)); + stride = tmp_type->index_type ()->bounds ()->bit_stride (); + if (stride == 0) + stride = type_length_units (elt_type); + else + { + struct gdbarch *arch = get_type_arch (elt_type); + int unit_size = gdbarch_addressable_memory_unit_size (arch); + stride /= (unit_size * 8); + } + + /* If this dimension is "backward" then figure out the offset + adjustment required to point to the element at the lowest memory + address, and add this to the total offset. */ + LONGEST offset = 0; + if (stride < 0 && lowerbound < upperbound) + offset = (upperbound - lowerbound) * stride; + total_offset += offset; + tmp_type = TYPE_TARGET_TYPE (tmp_type); + } + + /* Adjust the address of this object and return it. */ + address += total_offset; + return address; +} diff --git a/gdb/f-lang.h b/gdb/f-lang.h index 8e693eb..351f219 100644 --- a/gdb/f-lang.h +++ b/gdb/f-lang.h @@ -314,7 +314,6 @@ extern LONGEST f77_get_lowerbound (struct type *); extern int calc_f77_array_dims (struct type *); - /* Fortran (F77) types */ struct builtin_f_type @@ -355,4 +354,22 @@ extern const struct builtin_f_type *builtin_f_type (struct gdbarch *gdbarch); extern struct type *fortran_preserve_arg_pointer (struct value *arg, struct type *type); +/* Fortran arrays can have a negative stride. When this happens it is + often the case that the base address for an object is not the lowest + address occupied by that object. For example, an array slice (10:1:-1) + will be encoded with lower bound 1, upper bound 10, a stride of + -ELEMENT_SIZE, and have a base address pointer that points at the + element with the highest address in memory. + + This really doesn't play well with our current model of value contents, + but could easily require a significant update in order to be supported + "correctly". + + For now, we manually force the base address to be the lowest addressed + element here. Yes, this will break some things, but it fixes other + things. The hope is that it fixes more than it breaks. */ + +extern CORE_ADDR fortran_adjust_dynamic_array_base_address_hack + (struct type *type, CORE_ADDR address); + #endif /* F_LANG_H */ diff --git a/gdb/f-valprint.c b/gdb/f-valprint.c index 33ac761..d147caa 100644 --- a/gdb/f-valprint.c +++ b/gdb/f-valprint.c @@ -35,6 +35,7 @@ #include "dictionary.h" #include "cli/cli-style.h" #include "gdbarch.h" +#include "f-array-walker.h" static void f77_get_dynamic_length_of_aggregate (struct type *); @@ -100,100 +101,103 @@ f77_get_dynamic_length_of_aggregate (struct type *type) * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type))); } -/* Actual function which prints out F77 arrays, Valaddr == address in - the superior. Address == the address in the inferior. */ +/* A class used by FORTRAN_PRINT_ARRAY as a specialisation of the array + walking template. This specialisation prints Fortran arrays. */ -static void -f77_print_array_1 (int nss, int ndimensions, struct type *type, - const gdb_byte *valaddr, - int embedded_offset, CORE_ADDR address, - struct ui_file *stream, int recurse, - const struct value *val, - const struct value_print_options *options, - int *elts) +class fortran_array_printer_impl : public fortran_array_walker_base_impl { - struct type *range_type = check_typedef (type)->index_type (); - CORE_ADDR addr = address + embedded_offset; - LONGEST lowerbound, upperbound; - LONGEST i; - - get_discrete_bounds (range_type, &lowerbound, &upperbound); - - if (nss != ndimensions) - { - struct gdbarch *gdbarch = get_type_arch (type); - size_t dim_size = type_length_units (TYPE_TARGET_TYPE (type)); - int unit_size = gdbarch_addressable_memory_unit_size (gdbarch); - size_t byte_stride = type->bit_stride () / (unit_size * 8); - if (byte_stride == 0) - byte_stride = dim_size; - size_t offs = 0; - - for (i = lowerbound; - (i < upperbound + 1 && (*elts) < options->print_max); - i++) - { - struct value *subarray = value_from_contents_and_address - (TYPE_TARGET_TYPE (type), value_contents_for_printing_const (val) - + offs, addr + offs); - - fprintf_filtered (stream, "("); - f77_print_array_1 (nss + 1, ndimensions, value_type (subarray), - value_contents_for_printing (subarray), - value_embedded_offset (subarray), - value_address (subarray), - stream, recurse, subarray, options, elts); - offs += byte_stride; - fprintf_filtered (stream, ")"); - - if (i < upperbound) - fprintf_filtered (stream, " "); - } - if (*elts >= options->print_max && i < upperbound) - fprintf_filtered (stream, "..."); - } - else - { - for (i = lowerbound; i < upperbound + 1 && (*elts) < options->print_max; - i++, (*elts)++) - { - struct value *elt = value_subscript ((struct value *)val, i); - - common_val_print (elt, stream, recurse, options, current_language); - - if (i != upperbound) - fprintf_filtered (stream, ", "); - - if ((*elts == options->print_max - 1) - && (i != upperbound)) - fprintf_filtered (stream, "..."); - } - } -} +public: + /* Constructor. TYPE is the array type being printed, ADDRESS is the + address in target memory for the object of TYPE being printed. VAL is + the GDB value (of TYPE) being printed. STREAM is where to print to, + RECOURSE is passed through (and prevents infinite recursion), and + OPTIONS are the printing control options. */ + explicit fortran_array_printer_impl (struct type *type, + CORE_ADDR address, + struct value *val, + struct ui_file *stream, + int recurse, + const struct value_print_options *options) + : m_elts (0), + m_val (val), + m_stream (stream), + m_recurse (recurse), + m_options (options) + { /* Nothing. */ } + + /* Called while iterating over the array bounds. When SHOULD_CONTINUE is + false then we must return false, as we have reached the end of the + array bounds for this dimension. However, we also return false if we + have printed too many elements (after printing '...'). In all other + cases, return true. */ + bool continue_walking (bool should_continue) + { + bool cont = should_continue && (m_elts < m_options->print_max); + if (!cont && should_continue) + fputs_filtered ("...", m_stream); + return cont; + } + + /* Called when we start iterating over a dimension. If it's not the + inner most dimension then print an opening '(' character. */ + void start_dimension (bool inner_p) + { + fputs_filtered ("(", m_stream); + } + + /* Called when we finish processing a batch of items within a dimension + of the array. Depending on whether this is the inner most dimension + or not we print different things, but this is all about adding + separators between elements, and dimensions of the array. */ + void finish_dimension (bool inner_p, bool last_p) + { + fputs_filtered (")", m_stream); + if (!last_p) + fputs_filtered (" ", m_stream); + } + + /* Called to process an element of ELT_TYPE at offset ELT_OFF from the + start of the parent object. */ + void process_element (struct type *elt_type, LONGEST elt_off, bool last_p) + { + /* Extract the element value from the parent value. */ + struct value *e_val + = value_from_component (m_val, elt_type, elt_off); + common_val_print (e_val, m_stream, m_recurse, m_options, current_language); + if (!last_p) + fputs_filtered (", ", m_stream); + ++m_elts; + } + +private: + /* The number of elements printed so far. */ + int m_elts; + + /* The value from which we are printing elements. */ + struct value *m_val; + + /* The stream we should print too. */ + struct ui_file *m_stream; + + /* The recursion counter, passed through when we print each element. */ + int m_recurse; + + /* The print control options. Gives us the maximum number of elements to + print, and is passed through to each element that we print. */ + const struct value_print_options *m_options = nullptr; +}; -/* This function gets called to print an F77 array, we set up some - stuff and then immediately call f77_print_array_1(). */ +/* This function gets called to print a Fortran array. */ static void -f77_print_array (struct type *type, const gdb_byte *valaddr, - int embedded_offset, - CORE_ADDR address, struct ui_file *stream, - int recurse, - const struct value *val, - const struct value_print_options *options) +fortran_print_array (struct type *type, CORE_ADDR address, + struct ui_file *stream, int recurse, + const struct value *val, + const struct value_print_options *options) { - int ndimensions; - int elts = 0; - - ndimensions = calc_f77_array_dims (type); - - if (ndimensions > MAX_FORTRAN_DIMS || ndimensions < 0) - error (_("\ -Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"), - ndimensions, MAX_FORTRAN_DIMS); - - f77_print_array_1 (1, ndimensions, type, valaddr, embedded_offset, - address, stream, recurse, val, options, &elts); + fortran_array_walker<fortran_array_printer_impl> p + (type, address, (struct value *) val, stream, recurse, options); + p.walk (); } @@ -237,12 +241,7 @@ f_language::value_print_inner (struct value *val, struct ui_file *stream, case TYPE_CODE_ARRAY: if (TYPE_TARGET_TYPE (type)->code () != TYPE_CODE_CHAR) - { - fprintf_filtered (stream, "("); - f77_print_array (type, valaddr, 0, - address, stream, recurse, val, options); - fprintf_filtered (stream, ")"); - } + fortran_print_array (type, address, stream, recurse, val, options); else { struct type *ch_type = TYPE_TARGET_TYPE (type); diff --git a/gdb/gdbtypes.c b/gdb/gdbtypes.c index b822a36..e6f70bb 100644 --- a/gdb/gdbtypes.c +++ b/gdb/gdbtypes.c @@ -39,6 +39,7 @@ #include "dwarf2/loc.h" #include "gdbcore.h" #include "floatformat.h" +#include "f-lang.h" #include <algorithm> #include "gmp-utils.h" @@ -2639,7 +2640,16 @@ resolve_dynamic_type_internal (struct type *type, prop = TYPE_DATA_LOCATION (resolved_type); if (prop != NULL && dwarf2_evaluate_property (prop, NULL, addr_stack, &value)) - prop->set_const_val (value); + { + /* Start of Fortran hack. See comment in f-lang.h for what is going + on here.*/ + if (current_language->la_language == language_fortran + && resolved_type->code () == TYPE_CODE_ARRAY) + value = fortran_adjust_dynamic_array_base_address_hack (resolved_type, + value); + /* End of Fortran hack. */ + prop->set_const_val (value); + } return resolved_type; } diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog index 7b01010..eed9e44 100644 --- a/gdb/testsuite/ChangeLog +++ b/gdb/testsuite/ChangeLog @@ -1,5 +1,15 @@ 2020-11-19 Andrew Burgess <andrew.burgess@embecosm.com> + * gdb.fortran/array-slices-bad.exp: New file. + * gdb.fortran/array-slices-bad.f90: New file. + * gdb.fortran/array-slices-sub-slices.exp: New file. + * gdb.fortran/array-slices-sub-slices.f90: New file. + * gdb.fortran/array-slices.exp: Rewrite tests. + * gdb.fortran/array-slices.f90: Rewrite tests. + * gdb.fortran/vla-sizeof.exp: Correct expected results. + +2020-11-19 Andrew Burgess <andrew.burgess@embecosm.com> + * gdb.base/completion.exp: Add new completion tests. 2020-11-18 Simon Marchi <simon.marchi@polymtl.ca> diff --git a/gdb/testsuite/gdb.fortran/array-slices-bad.exp b/gdb/testsuite/gdb.fortran/array-slices-bad.exp new file mode 100644 index 0000000..2583cde --- /dev/null +++ b/gdb/testsuite/gdb.fortran/array-slices-bad.exp @@ -0,0 +1,69 @@ +# Copyright 2020 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/> . + +# Test invalid element and slice array accesses. + +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 "Display Message Breakpoint"] +gdb_breakpoint [gdb_get_line_number "First Breakpoint"] +gdb_breakpoint [gdb_get_line_number "Second Breakpoint"] +gdb_breakpoint [gdb_get_line_number "Final Breakpoint"] + +gdb_continue_to_breakpoint "First Breakpoint" + +# Access not yet allocated array. +gdb_test "print other" " = <not allocated>" +gdb_test "print other(0:4,2:3)" "array not allocated" +gdb_test "print other(1,1)" "no such vector element \\(vector not allocated\\)" + +# Access not yet associated pointer. +gdb_test "print pointer2d" " = <not associated>" +gdb_test "print pointer2d(1:2,1:2)" "array not associated" +gdb_test "print pointer2d(1,1)" "no such vector element \\(vector not associated\\)" + +gdb_continue_to_breakpoint "Second Breakpoint" + +# Accessing just outside the arrays. +foreach name {array pointer2d other} { + gdb_test "print $name (0:,:)" "array subscript out of bounds" + gdb_test "print $name (:11,:)" "array subscript out of bounds" + gdb_test "print $name (:,0:)" "array subscript out of bounds" + gdb_test "print $name (:,:11)" "array subscript out of bounds" + + gdb_test "print $name (0,:)" "no such vector element" + gdb_test "print $name (11,:)" "no such vector element" + gdb_test "print $name (:,0)" "no such vector element" + gdb_test "print $name (:,11)" "no such vector element" +} + +# Stride in the wrong direction. +gdb_test "print array (1:10:-1,:)" "incorrect stride and boundary combination" +gdb_test "print array (:,1:10:-1)" "incorrect stride and boundary combination" +gdb_test "print array (10:1:1,:)" "incorrect stride and boundary combination" +gdb_test "print array (:,10:1:1)" "incorrect stride and boundary combination" diff --git a/gdb/testsuite/gdb.fortran/array-slices-bad.f90 b/gdb/testsuite/gdb.fortran/array-slices-bad.f90 new file mode 100644 index 0000000..0f3d45a --- /dev/null +++ b/gdb/testsuite/gdb.fortran/array-slices-bad.f90 @@ -0,0 +1,42 @@ +! Copyright 2020 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 test + + ! Declare variables used in this test. + integer, dimension (1:10,1:10) :: array + integer, allocatable :: other (:, :) + integer, dimension(:,:), pointer :: pointer2d => null() + integer, dimension(1:10,1:10), target :: tarray + + print *, "" ! First Breakpoint. + + ! Allocate or associate any variables as needed. + allocate (other (1:10, 1:10)) + pointer2d => tarray + array = 0 + + print *, "" ! Second Breakpoint. + + ! All done. Deallocate. + deallocate (other) + + ! GDB catches this final breakpoint to indicate the end of the test. + print *, "" ! Final Breakpoint. + +end program test diff --git a/gdb/testsuite/gdb.fortran/array-slices-sub-slices.exp b/gdb/testsuite/gdb.fortran/array-slices-sub-slices.exp new file mode 100644 index 0000000..05b4802 --- /dev/null +++ b/gdb/testsuite/gdb.fortran/array-slices-sub-slices.exp @@ -0,0 +1,111 @@ +# Copyright 2020 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/> . + +# Create a slice of an array, then take a slice of that slice. + +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 "Display Message Breakpoint"] +gdb_breakpoint [gdb_get_line_number "Stop Here"] +gdb_breakpoint [gdb_get_line_number "Final Breakpoint"] + +# We're going to print some reasonably large arrays. +gdb_test_no_output "set print elements unlimited" + +gdb_continue_to_breakpoint "Stop Here" + +# Print a slice, capture the convenience variable name created. +set cmd "print array (1:10:2, 1:10:2)" +gdb_test_multiple $cmd $cmd { + -re "\r\n\\\$(\\d+) = .*\r\n$gdb_prompt $" { + set varname "\$$expect_out(1,string)" + } +} + +# Now check that we can correctly extract all the elements from this +# slice. +for { set j 1 } { $j < 6 } { incr j } { + for { set i 1 } { $i < 6 } { incr i } { + set val [expr ((($i - 1) * 2) + (($j - 1) * 20)) + 1] + gdb_test "print ${varname} ($i,$j)" " = $val" + } +} + +# Now take a slice of the slice. +gdb_test "print ${varname} (3:5, 3:5)" \ + " = \\(\\(45, 47, 49\\) \\(65, 67, 69\\) \\(85, 87, 89\\)\\)" + +# Now take a different slice of a slice. +set cmd "print ${varname} (1:5:2, 1:5:2)" +gdb_test_multiple $cmd $cmd { + -re "\r\n\\\$(\\d+) = \\(\\(1, 5, 9\\) \\(41, 45, 49\\) \\(81, 85, 89\\)\\)\r\n$gdb_prompt $" { + set varname "\$$expect_out(1,string)" + pass $gdb_test_name + } +} + +# Now take a slice from the slice, of a slice! +set cmd "print ${varname} (1:3:2, 1:3:2)" +gdb_test_multiple $cmd $cmd { + -re "\r\n\\\$(\\d+) = \\(\\(1, 9\\) \\(81, 89\\)\\)\r\n$gdb_prompt $" { + set varname "\$$expect_out(1,string)" + pass $gdb_test_name + } +} + +# And again! +set cmd "print ${varname} (1:2:2, 1:2:2)" +gdb_test_multiple $cmd $cmd { + -re "\r\n\\\$(\\d+) = \\(\\(1\\)\\)\r\n$gdb_prompt $" { + set varname "\$$expect_out(1,string)" + pass $gdb_test_name + } +} + +# Test taking a slice with stride of a string. This isn't actually +# supported within gfortran (at least), but naturally drops out of how +# GDB models arrays and strings in a similar way, so we may as well +# test that this is still working. +gdb_test "print str (1:26:2)" " = 'acegikmoqsuwy'" +gdb_test "print str (26:1:-1)" " = 'zyxwvutsrqponmlkjihgfedcba'" +gdb_test "print str (26:1:-2)" " = 'zxvtrpnljhfdb'" + +# Now test the memory requirements of taking a slice from an array. +# The idea is that we shouldn't require more memory to extract a slice +# than the size of the slice. +# +# This will only work if array repacking is turned on, otherwise GDB +# will create the slice by generating a new type that sits over the +# existing value in memory. +gdb_test_no_output "set fortran repack-array-slices on" +set element_size [get_integer_valueof "sizeof (array (1,1))" "unknown"] +set slice_size [expr $element_size * 4] +gdb_test_no_output "set max-value-size $slice_size" +gdb_test "print array (1:2, 1:2)" "= \\(\\(1, 2\\) \\(11, 12\\)\\)" +gdb_test "print array (2:3, 2:3)" "= \\(\\(12, 13\\) \\(22, 23\\)\\)" +gdb_test "print array (2:5:2, 2:5:2)" "= \\(\\(12, 14\\) \\(32, 34\\)\\)" diff --git a/gdb/testsuite/gdb.fortran/array-slices-sub-slices.f90 b/gdb/testsuite/gdb.fortran/array-slices-sub-slices.f90 new file mode 100644 index 0000000..c3530f5 --- /dev/null +++ b/gdb/testsuite/gdb.fortran/array-slices-sub-slices.f90 @@ -0,0 +1,96 @@ +! Copyright 2020 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 test + integer, dimension (1:10,1:11) :: array + character (len=26) :: str = "abcdefghijklmnopqrstuvwxyz" + + call fill_array_2d (array) + + ! GDB catches this final breakpoint to indicate the end of the test. + print *, "" ! Stop Here + + print *, array + print *, str + + ! GDB catches this final breakpoint to indicate the end of the test. + print *, "" ! Final Breakpoint. + +contains + + ! Fill a 1D array with a unique positive integer in each element. + subroutine fill_array_1d (array) + integer, dimension (:) :: array + integer :: counter + + counter = 1 + do j=LBOUND (array, 1), UBOUND (array, 1), 1 + array (j) = counter + counter = counter + 1 + end do + end subroutine fill_array_1d + + ! Fill a 2D array with a unique positive integer in each element. + subroutine fill_array_2d (array) + integer, dimension (:,:) :: array + integer :: counter + + counter = 1 + do i=LBOUND (array, 2), UBOUND (array, 2), 1 + do j=LBOUND (array, 1), UBOUND (array, 1), 1 + array (j,i) = counter + counter = counter + 1 + end do + end do + end subroutine fill_array_2d + + ! Fill a 3D array with a unique positive integer in each element. + subroutine fill_array_3d (array) + integer, dimension (:,:,:) :: array + integer :: counter + + counter = 1 + do i=LBOUND (array, 3), UBOUND (array, 3), 1 + do j=LBOUND (array, 2), UBOUND (array, 2), 1 + do k=LBOUND (array, 1), UBOUND (array, 1), 1 + array (k, j,i) = counter + counter = counter + 1 + end do + end do + end do + end subroutine fill_array_3d + + ! Fill a 4D array with a unique positive integer in each element. + subroutine fill_array_4d (array) + integer, dimension (:,:,:,:) :: array + integer :: counter + + counter = 1 + do i=LBOUND (array, 4), UBOUND (array, 4), 1 + do j=LBOUND (array, 3), UBOUND (array, 3), 1 + do k=LBOUND (array, 2), UBOUND (array, 2), 1 + do l=LBOUND (array, 1), UBOUND (array, 1), 1 + array (l, k, j,i) = counter + counter = counter + 1 + end do + end do + end do + end do + print *, "" + end subroutine fill_array_4d +end program test diff --git a/gdb/testsuite/gdb.fortran/array-slices.exp b/gdb/testsuite/gdb.fortran/array-slices.exp index aa6bc63..ff00fae 100644 --- a/gdb/testsuite/gdb.fortran/array-slices.exp +++ b/gdb/testsuite/gdb.fortran/array-slices.exp @@ -18,6 +18,21 @@ # the subroutine. This should exercise GDB's ability to handle # different strides for the different dimensions. +# Testing GDB's ability to print array (and string) slices, including +# slices that make use of array strides. +# +# In the Fortran code various arrays of different ranks are filled +# with data, and slices are passed to a series of show functions. +# +# In this test script we break in each of the show functions, print +# the array slice that was passed in, and then move up the stack to +# the parent frame and check GDB can manually extract the same slice. +# +# This test also checks that the size of the array slice passed to the +# function (so as extracted and described by the compiler and the +# debug information) matches the size of the slice manually extracted +# by GDB. + if {[skip_fortran_tests]} { return -1 } standard_testfile ".f90" @@ -28,60 +43,224 @@ if {[prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \ return -1 } -if ![fortran_runto_main] { - untested "could not run to main" - return -1 +# Takes the name of an array slice as used in the test source, and extracts +# the base array name. For example: 'array (1,2)' becomes 'array'. +proc array_slice_to_var { slice_str } { + regexp "^(?:\\s*\\()*(\[^( \t\]+)" $slice_str matchvar varname + return $varname } -gdb_breakpoint "show" -gdb_breakpoint [gdb_get_line_number "Final Breakpoint"] - -set array_contents \ - [list \ - " = \\(\\(1, 2, 3, 4, 5, 6, 7, 8, 9, 10\\) \\(11, 12, 13, 14, 15, 16, 17, 18, 19, 20\\) \\(21, 22, 23, 24, 25, 26, 27, 28, 29, 30\\) \\(31, 32, 33, 34, 35, 36, 37, 38, 39, 40\\) \\(41, 42, 43, 44, 45, 46, 47, 48, 49, 50\\) \\(51, 52, 53, 54, 55, 56, 57, 58, 59, 60\\) \\(61, 62, 63, 64, 65, 66, 67, 68, 69, 70\\) \\(71, 72, 73, 74, 75, 76, 77, 78, 79, 80\\) \\(81, 82, 83, 84, 85, 86, 87, 88, 89, 90\\) \\(91, 92, 93, 94, 95, 96, 97, 98, 99, 100\\)\\)" \ - " = \\(\\(1, 2, 3, 4, 5\\) \\(11, 12, 13, 14, 15\\) \\(21, 22, 23, 24, 25\\) \\(31, 32, 33, 34, 35\\) \\(41, 42, 43, 44, 45\\)\\)" \ - " = \\(\\(1, 3, 5, 7, 9\\) \\(21, 23, 25, 27, 29\\) \\(41, 43, 45, 47, 49\\) \\(61, 63, 65, 67, 69\\) \\(81, 83, 85, 87, 89\\)\\)" \ - " = \\(\\(1, 4, 7, 10\\) \\(21, 24, 27, 30\\) \\(41, 44, 47, 50\\) \\(61, 64, 67, 70\\) \\(81, 84, 87, 90\\)\\)" \ - " = \\(\\(1, 5, 9\\) \\(31, 35, 39\\) \\(61, 65, 69\\) \\(91, 95, 99\\)\\)" \ - " = \\(\\(-26, -25, -24, -23, -22, -21, -20, -19, -18, -17\\) \\(-19, -18, -17, -16, -15, -14, -13, -12, -11, -10\\) \\(-12, -11, -10, -9, -8, -7, -6, -5, -4, -3\\) \\(-5, -4, -3, -2, -1, 0, 1, 2, 3, 4\\) \\(2, 3, 4, 5, 6, 7, 8, 9, 10, 11\\) \\(9, 10, 11, 12, 13, 14, 15, 16, 17, 18\\) \\(16, 17, 18, 19, 20, 21, 22, 23, 24, 25\\) \\(23, 24, 25, 26, 27, 28, 29, 30, 31, 32\\) \\(30, 31, 32, 33, 34, 35, 36, 37, 38, 39\\) \\(37, 38, 39, 40, 41, 42, 43, 44, 45, 46\\)\\)" \ - " = \\(\\(-26, -25, -24, -23, -22, -21\\) \\(-19, -18, -17, -16, -15, -14\\) \\(-12, -11, -10, -9, -8, -7\\)\\)" \ - " = \\(\\(-26, -24, -22, -20, -18\\) \\(-5, -3, -1, 1, 3\\) \\(16, 18, 20, 22, 24\\) \\(37, 39, 41, 43, 45\\)\\)" ] - -set message_strings \ - [list \ - " = 'array'" \ - " = 'array \\(1:5,1:5\\)'" \ - " = 'array \\(1:10:2,1:10:2\\)'" \ - " = 'array \\(1:10:3,1:10:2\\)'" \ - " = 'array \\(1:10:5,1:10:3\\)'" \ - " = 'other'" \ - " = 'other \\(-5:0, -2:0\\)'" \ - " = 'other \\(-5:4:2, -2:7:3\\)'" ] - -set i 0 -foreach result $array_contents msg $message_strings { - incr i - with_test_prefix "test $i" { - gdb_continue_to_breakpoint "show" - gdb_test "p array" $result - gdb_test "p message" "$msg" +proc run_test { repack } { + global binfile gdb_prompt + + clean_restart ${binfile} + + if ![fortran_runto_main] { + untested "could not run to main" + return -1 } -} -gdb_continue_to_breakpoint "continue to Final Breakpoint" + gdb_test_no_output "set fortran repack-array-slices $repack" + + # gdb_breakpoint [gdb_get_line_number "Display Message Breakpoint"] + gdb_breakpoint [gdb_get_line_number "Display Element"] + gdb_breakpoint [gdb_get_line_number "Display String"] + gdb_breakpoint [gdb_get_line_number "Display Array Slice 1D"] + gdb_breakpoint [gdb_get_line_number "Display Array Slice 2D"] + gdb_breakpoint [gdb_get_line_number "Display Array Slice 3D"] + gdb_breakpoint [gdb_get_line_number "Display Array Slice 4D"] + gdb_breakpoint [gdb_get_line_number "Final Breakpoint"] + + # We're going to print some reasonably large arrays. + gdb_test_no_output "set print elements unlimited" + + set found_final_breakpoint false + + # 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 test_count 0 + while { $test_count < 500 } { + with_test_prefix "test $test_count" { + incr test_count + + set found_final_breakpoint false + set expected_result "" + set func_name "" + gdb_test_multiple "continue" "continue" { + -re ".*GDB = (\[^\r\n\]+)\r\n" { + set expected_result $expect_out(1,string) + exp_continue + } + -re "! Display Element" { + set func_name "show_elem" + exp_continue + } + -re "! Display String" { + set func_name "show_str" + exp_continue + } + -re "! Display Array Slice (.)D" { + set func_name "show_$expect_out(1,string)d" + exp_continue + } + -re "! Final Breakpoint" { + set found_final_breakpoint true + exp_continue + } + -re "$gdb_prompt $" { + # We're done. + } + } -# Next test that asking for an array with stride at the CLI gives an -# error. -clean_restart ${testfile} + if ($found_final_breakpoint) { + break + } -if ![fortran_runto_main] then { - perror "couldn't run to main" - continue + # We want to take a look at the line in the previous frame that + # called the current function. I couldn't find a better way of + # doing this than 'up', which will print the line, then 'down' + # again. + # + # I don't want to fill the log with passes for these up/down + # commands, so we don't report any. If something goes wrong then we + # should get a fail from gdb_test_multiple. + set array_slice_name "" + set unique_id "" + array unset replacement_vars + array set replacement_vars {} + gdb_test_multiple "up" "up" { + -re "\r\n\[0-9\]+\[ \t\]+call ${func_name} \\((\[^\r\n\]+)\\)\r\n$gdb_prompt $" { + set array_slice_name $expect_out(1,string) + } + -re "\r\n\[0-9\]+\[ \t\]+call ${func_name} \\((\[^\r\n\]+)\\)\[ \t\]+! VARS=(\[^ \t\r\n\]+)\r\n$gdb_prompt $" { + set array_slice_name $expect_out(1,string) + set unique_id $expect_out(2,string) + } + } + if {$unique_id != ""} { + set str "" + foreach v [split $unique_id ,] { + set val [get_integer_valueof "${v}" "??"\ + "get variable '$v' for '$array_slice_name'"] + set replacement_vars($v) $val + if {$str != ""} { + set str "Str," + } + set str "$str$v=$val" + } + set unique_id " $str" + } + gdb_test_multiple "down" "down" { + -re "\r\n$gdb_prompt $" { + # Don't issue a pass here. + } + } + + # Check we have all the information we need to successfully run one + # of these tests. + if { $expected_result == "" } { + perror "failed to extract expected results" + return 0 + } + if { $array_slice_name == "" } { + perror "failed to extract array slice name" + return 0 + } + + # Check GDB can correctly print the array slice that was passed into + # the current frame. + set pattern [string_to_regexp " = $expected_result"] + gdb_test "p array" "$pattern" \ + "check value of '$array_slice_name'$unique_id" + + # Get the size of the slice. + set size_in_show \ + [get_integer_valueof "sizeof (array)" "show_unknown" \ + "get sizeof '$array_slice_name'$unique_id in show"] + set addr_in_show \ + [get_hexadecimal_valueof "&array" "show_unknown" \ + "get address '$array_slice_name'$unique_id in show"] + + # Now move into the previous frame, and see if GDB can extract the + # array slice from the original parent object. Again, use of + # gdb_test_multiple to avoid filling the logs with unnecessary + # passes. + gdb_test_multiple "up" "up" { + -re "\r\n$gdb_prompt $" { + # Do nothing. + } + } + + # Print the array slice, this will force GDB to manually extract the + # slice from the parent array. + gdb_test "p $array_slice_name" "$pattern" \ + "check array slice '$array_slice_name'$unique_id can be extracted" + + # Get the size of the slice in the calling frame. + set size_in_parent \ + [get_integer_valueof "sizeof ($array_slice_name)" \ + "parent_unknown" \ + "get sizeof '$array_slice_name'$unique_id in parent"] + + # Figure out the start and end addresses of the full array in the + # parent frame. + set full_var_name [array_slice_to_var $array_slice_name] + set start_addr [get_hexadecimal_valueof "&${full_var_name}" \ + "start unknown"] + set end_addr [get_hexadecimal_valueof \ + "(&${full_var_name}) + sizeof (${full_var_name})" \ + "end unknown"] + + # The Fortran compiler can choose to either send a descriptor that + # describes the array slice to the subroutine, or it can repack the + # slice into an array section and send that. + # + # We find the address range of the original array in the parent, + # and the address of the slice in the show function, if the + # address of the slice (from show) is in the range of the original + # array then repacking has not occurred, otherwise, the slice is + # outside of the parent, and repacking must have occurred. + # + # The goal here is to compare the sizes of the slice in show with + # the size of the slice extracted by GDB. So we can only compare + # sizes when GDB's repacking setting matches the repacking + # behaviour we got from the compiler. + if { ($addr_in_show < $start_addr || $addr_in_show >= $end_addr) \ + == ($repack == "on") } { + gdb_assert {$size_in_show == $size_in_parent} \ + "check sizes match" + } elseif { $repack == "off" } { + # GDB's repacking is off (so slices are left unpacked), but + # the compiler did pack this one. As a result we can't + # compare the sizes between the compiler's slice and GDB's + # slice. + verbose -log "slice '$array_slice_name' was repacked, sizes can't be compared" + } else { + # Like the above, but the reverse, GDB's repacking is on, but + # the compiler didn't repack this slice. + verbose -log "slice '$array_slice_name' was not repacked, sizes can't be compared" + } + + # If the array name we just tested included variable names, then + # test again with all the variables expanded. + if {$unique_id != ""} { + foreach v [array names replacement_vars] { + set val $replacement_vars($v) + set array_slice_name \ + [regsub "\\y${v}\\y" $array_slice_name $val] + } + gdb_test "p $array_slice_name" "$pattern" \ + "check array slice '$array_slice_name'$unique_id can be extracted, with variables expanded" + } + } + } + + # 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 tests" } -gdb_breakpoint "show" -gdb_continue_to_breakpoint "show" -gdb_test "up" ".*" -gdb_test "p array (1:10:2, 1:10:2)" \ - "Fortran array strides are not currently supported" \ - "using array stride gives an error" +foreach_with_prefix repack { on off } { + run_test $repack +} diff --git a/gdb/testsuite/gdb.fortran/array-slices.f90 b/gdb/testsuite/gdb.fortran/array-slices.f90 index a66fa6b..6d75a38 100644 --- a/gdb/testsuite/gdb.fortran/array-slices.f90 +++ b/gdb/testsuite/gdb.fortran/array-slices.f90 @@ -13,58 +13,368 @@ ! You should have received a copy of the GNU General Public License ! along with this program. If not, see <http://www.gnu.org/licenses/>. -subroutine show (message, array) - character (len=*) :: message +subroutine show_elem (array) + integer :: array + + print *, "" + print *, "Expected GDB Output:" + print *, "" + + write(*, fmt="(A)", advance="no") "GDB = " + write(*, fmt="(I0)", advance="no") array + write(*, fmt="(A)", advance="yes") "" + + print *, "" ! Display Element +end subroutine show_elem + +subroutine show_str (array) + character (len=*) :: array + + print *, "" + print *, "Expected GDB Output:" + print *, "" + write (*, fmt="(A)", advance="no") "GDB = '" + write (*, fmt="(A)", advance="no") array + write (*, fmt="(A)", advance="yes") "'" + + print *, "" ! Display String +end subroutine show_str + +subroutine show_1d (array) + integer, dimension (:) :: array + + print *, "Array Contents:" + print *, "" + + do i=LBOUND (array, 1), UBOUND (array, 1), 1 + write(*, fmt="(i4)", advance="no") array (i) + end do + + print *, "" + print *, "Expected GDB Output:" + print *, "" + + write(*, fmt="(A)", advance="no") "GDB = (" + do i=LBOUND (array, 1), UBOUND (array, 1), 1 + if (i > LBOUND (array, 1)) then + write(*, fmt="(A)", advance="no") ", " + end if + write(*, fmt="(I0)", advance="no") array (i) + end do + write(*, fmt="(A)", advance="no") ")" + + print *, "" ! Display Array Slice 1D +end subroutine show_1d + +subroutine show_2d (array) integer, dimension (:,:) :: array - print *, message + print *, "Array Contents:" + print *, "" + do i=LBOUND (array, 2), UBOUND (array, 2), 1 do j=LBOUND (array, 1), UBOUND (array, 1), 1 write(*, fmt="(i4)", advance="no") array (j, i) end do print *, "" - end do - print *, array - print *, "" + end do -end subroutine show + print *, "" + print *, "Expected GDB Output:" + print *, "" -program test + write(*, fmt="(A)", advance="no") "GDB = (" + do i=LBOUND (array, 2), UBOUND (array, 2), 1 + if (i > LBOUND (array, 2)) then + write(*, fmt="(A)", advance="no") " " + end if + write(*, fmt="(A)", advance="no") "(" + do j=LBOUND (array, 1), UBOUND (array, 1), 1 + if (j > LBOUND (array, 1)) then + write(*, fmt="(A)", advance="no") ", " + end if + write(*, fmt="(I0)", advance="no") array (j, i) + end do + write(*, fmt="(A)", advance="no") ")" + end do + write(*, fmt="(A)", advance="yes") ")" + + print *, "" ! Display Array Slice 2D +end subroutine show_2d + +subroutine show_3d (array) + integer, dimension (:,:,:) :: array + + print *, "" + print *, "Expected GDB Output:" + print *, "" + + write(*, fmt="(A)", advance="no") "GDB = (" + do i=LBOUND (array, 3), UBOUND (array, 3), 1 + if (i > LBOUND (array, 3)) then + write(*, fmt="(A)", advance="no") " " + end if + write(*, fmt="(A)", advance="no") "(" + do j=LBOUND (array, 2), UBOUND (array, 2), 1 + if (j > LBOUND (array, 2)) then + write(*, fmt="(A)", advance="no") " " + end if + write(*, fmt="(A)", advance="no") "(" + do k=LBOUND (array, 1), UBOUND (array, 1), 1 + if (k > LBOUND (array, 1)) then + write(*, fmt="(A)", advance="no") ", " + end if + write(*, fmt="(I0)", advance="no") array (k, j, i) + end do + write(*, fmt="(A)", advance="no") ")" + end do + write(*, fmt="(A)", advance="no") ")" + end do + write(*, fmt="(A)", advance="yes") ")" + + print *, "" ! Display Array Slice 3D +end subroutine show_3d + +subroutine show_4d (array) + integer, dimension (:,:,:,:) :: array + + print *, "" + print *, "Expected GDB Output:" + print *, "" + + write(*, fmt="(A)", advance="no") "GDB = (" + do i=LBOUND (array, 4), UBOUND (array, 4), 1 + if (i > LBOUND (array, 4)) then + write(*, fmt="(A)", advance="no") " " + end if + write(*, fmt="(A)", advance="no") "(" + do j=LBOUND (array, 3), UBOUND (array, 3), 1 + if (j > LBOUND (array, 3)) then + write(*, fmt="(A)", advance="no") " " + end if + write(*, fmt="(A)", advance="no") "(" + + do k=LBOUND (array, 2), UBOUND (array, 2), 1 + if (k > LBOUND (array, 2)) then + write(*, fmt="(A)", advance="no") " " + end if + write(*, fmt="(A)", advance="no") "(" + do l=LBOUND (array, 1), UBOUND (array, 1), 1 + if (l > LBOUND (array, 1)) then + write(*, fmt="(A)", advance="no") ", " + end if + write(*, fmt="(I0)", advance="no") array (l, k, j, i) + end do + write(*, fmt="(A)", advance="no") ")" + end do + write(*, fmt="(A)", advance="no") ")" + end do + write(*, fmt="(A)", advance="no") ")" + end do + write(*, fmt="(A)", advance="yes") ")" + + print *, "" ! Display Array Slice 4D +end subroutine show_4d +! +! Start of test program. +! +program test interface - subroutine show (message, array) - character (len=*) :: message + subroutine show_str (array) + character (len=*) :: array + end subroutine show_str + + subroutine show_1d (array) + integer, dimension (:) :: array + end subroutine show_1d + + subroutine show_2d (array) integer, dimension(:,:) :: array - end subroutine show + end subroutine show_2d + + subroutine show_3d (array) + integer, dimension(:,:,:) :: array + end subroutine show_3d + + subroutine show_4d (array) + integer, dimension(:,:,:,:) :: array + end subroutine show_4d end interface + ! Declare variables used in this test. + integer, dimension (-10:-1,-10:-2) :: neg_array integer, dimension (1:10,1:10) :: array integer, allocatable :: other (:, :) + character (len=26) :: str_1 = "abcdefghijklmnopqrstuvwxyz" + integer, dimension (-2:2,-2:2,-2:2) :: array3d + integer, dimension (-3:3,7:10,-3:3,-10:-7) :: array4d + integer, dimension (10:20) :: array1d + integer, dimension(:,:), pointer :: pointer2d => null() + integer, dimension(-1:9,-1:9), target :: tarray + ! Allocate or associate any variables as needed. allocate (other (-5:4, -2:7)) + pointer2d => tarray - do i=LBOUND (array, 2), UBOUND (array, 2), 1 - do j=LBOUND (array, 1), UBOUND (array, 1), 1 - array (j,i) = ((i - 1) * UBOUND (array, 2)) + j - end do - end do + ! Fill arrays with contents ready for testing. + call fill_array_1d (array1d) + + call fill_array_2d (neg_array) + call fill_array_2d (array) + call fill_array_2d (other) + call fill_array_2d (tarray) + + call fill_array_3d (array3d) + call fill_array_4d (array4d) + + ! The tests. Each call to a show_* function must have a unique set + ! of arguments as GDB uses the arguments are part of the test name + ! string, so duplicate arguments will result in duplicate test + ! names. + ! + ! If a show_* line ends with VARS=... where '...' is a comma + ! separated list of variable names, these variables are assumed to + ! be part of the call line, and will be expanded by the test script, + ! for example: + ! + ! do x=1,9,1 + ! do y=x,10,1 + ! call show_1d (some_array (x,y)) ! VARS=x,y + ! end do + ! end do + ! + ! In this example the test script will automatically expand 'x' and + ! 'y' in order to better test different aspects of GDB. Do take + ! care, the expansion is not very "smart", so try to avoid clashing + ! with other text on the line, in the example above, avoid variables + ! named 'some' or 'array', as these will likely clash with + ! 'some_array'. + call show_str (str_1) + call show_str (str_1 (1:20)) + call show_str (str_1 (10:20)) - do i=LBOUND (other, 2), UBOUND (other, 2), 1 - do j=LBOUND (other, 1), UBOUND (other, 1), 1 - other (j,i) = ((i - 1) * UBOUND (other, 2)) + j + call show_elem (array1d (11)) + call show_elem (pointer2d (2,3)) + + call show_1d (array1d) + call show_1d (array1d (13:17)) + call show_1d (array1d (17:13:-1)) + call show_1d (array (1:5,1)) + call show_1d (array4d (1,7,3,:)) + call show_1d (pointer2d (-1:3, 2)) + call show_1d (pointer2d (-1, 2:4)) + + ! Enclosing the array slice argument in (...) causess gfortran to + ! repack the array. + call show_1d ((array (1:5,1))) + + call show_2d (pointer2d) + call show_2d (array) + call show_2d (array (1:5,1:5)) + do i=1,10,2 + do j=1,10,3 + call show_2d (array (1:10:i,1:10:j)) ! VARS=i,j + call show_2d (array (10:1:-i,1:10:j)) ! VARS=i,j + call show_2d (array (10:1:-i,10:1:-j)) ! VARS=i,j + call show_2d (array (1:10:i,10:1:-j)) ! VARS=i,j end do end do + call show_2d (array (6:2:-1,3:9)) + call show_2d (array (1:10:2, 1:10:2)) + call show_2d (other) + call show_2d (other (-5:0, -2:0)) + call show_2d (other (-5:4:2, -2:7:3)) + call show_2d (neg_array) + call show_2d (neg_array (-10:-3,-8:-4:2)) + + ! Enclosing the array slice argument in (...) causess gfortran to + ! repack the array. + call show_2d ((array (1:10:3, 1:10:2))) + call show_2d ((neg_array (-10:-3,-8:-4:2))) - call show ("array", array) - call show ("array (1:5,1:5)", array (1:5,1:5)) - call show ("array (1:10:2,1:10:2)", array (1:10:2,1:10:2)) - call show ("array (1:10:3,1:10:2)", array (1:10:3,1:10:2)) - call show ("array (1:10:5,1:10:3)", array (1:10:4,1:10:3)) + call show_3d (array3d) + call show_3d (array3d(-1:1,-1:1,-1:1)) + call show_3d (array3d(1:-1:-1,1:-1:-1,1:-1:-1)) - call show ("other", other) - call show ("other (-5:0, -2:0)", other (-5:0, -2:0)) - call show ("other (-5:4:2, -2:7:3)", other (-5:4:2, -2:7:3)) + ! Enclosing the array slice argument in (...) causess gfortran to + ! repack the array. + call show_3d ((array3d(1:-1:-1,1:-1:-1,1:-1:-1))) + call show_4d (array4d) + call show_4d (array4d (-3:0,10:7:-1,0:3,-7:-10:-1)) + call show_4d (array4d (3:0:-1, 10:7:-1, :, -7:-10:-1)) + + ! Enclosing the array slice argument in (...) causess gfortran to + ! repack the array. + call show_4d ((array4d (3:-2:-2, 10:7:-2, :, -7:-10:-1))) + + ! All done. Deallocate. deallocate (other) + + ! GDB catches this final breakpoint to indicate the end of the test. print *, "" ! Final Breakpoint. + +contains + + ! Fill a 1D array with a unique positive integer in each element. + subroutine fill_array_1d (array) + integer, dimension (:) :: array + integer :: counter + + counter = 1 + do j=LBOUND (array, 1), UBOUND (array, 1), 1 + array (j) = counter + counter = counter + 1 + end do + end subroutine fill_array_1d + + ! Fill a 2D array with a unique positive integer in each element. + subroutine fill_array_2d (array) + integer, dimension (:,:) :: array + integer :: counter + + counter = 1 + do i=LBOUND (array, 2), UBOUND (array, 2), 1 + do j=LBOUND (array, 1), UBOUND (array, 1), 1 + array (j,i) = counter + counter = counter + 1 + end do + end do + end subroutine fill_array_2d + + ! Fill a 3D array with a unique positive integer in each element. + subroutine fill_array_3d (array) + integer, dimension (:,:,:) :: array + integer :: counter + + counter = 1 + do i=LBOUND (array, 3), UBOUND (array, 3), 1 + do j=LBOUND (array, 2), UBOUND (array, 2), 1 + do k=LBOUND (array, 1), UBOUND (array, 1), 1 + array (k, j,i) = counter + counter = counter + 1 + end do + end do + end do + end subroutine fill_array_3d + + ! Fill a 4D array with a unique positive integer in each element. + subroutine fill_array_4d (array) + integer, dimension (:,:,:,:) :: array + integer :: counter + + counter = 1 + do i=LBOUND (array, 4), UBOUND (array, 4), 1 + do j=LBOUND (array, 3), UBOUND (array, 3), 1 + do k=LBOUND (array, 2), UBOUND (array, 2), 1 + do l=LBOUND (array, 1), UBOUND (array, 1), 1 + array (l, k, j,i) = counter + counter = counter + 1 + end do + end do + end do + end do + print *, "" + end subroutine fill_array_4d end program test diff --git a/gdb/testsuite/gdb.fortran/vla-sizeof.exp b/gdb/testsuite/gdb.fortran/vla-sizeof.exp index 04296ac..0ab74fb 100644 --- a/gdb/testsuite/gdb.fortran/vla-sizeof.exp +++ b/gdb/testsuite/gdb.fortran/vla-sizeof.exp @@ -44,7 +44,7 @@ gdb_continue_to_breakpoint "vla1-allocated" gdb_test "print sizeof(vla1)" " = 4000" "print sizeof allocated vla1" gdb_test "print sizeof(vla1(3,2,1))" "4" \ "print sizeof element from allocated vla1" -gdb_test "print sizeof(vla1(3:4,2,1))" "800" \ +gdb_test "print sizeof(vla1(3:4,2,1))" "8" \ "print sizeof sliced vla1" # Try to access values in undefined pointer to VLA (dangling) @@ -61,7 +61,7 @@ gdb_continue_to_breakpoint "pvla-associated" gdb_test "print sizeof(pvla)" " = 4000" "print sizeof associated pvla" gdb_test "print sizeof(pvla(3,2,1))" "4" \ "print sizeof element from associated pvla" -gdb_test "print sizeof(pvla(3:4,2,1))" "800" "print sizeof sliced pvla" +gdb_test "print sizeof(pvla(3:4,2,1))" "8" "print sizeof sliced pvla" gdb_breakpoint [gdb_get_line_number "vla1-neg-bounds-v1"] gdb_continue_to_breakpoint "vla1-neg-bounds-v1" |