Re: [PATCHv6] gdb/fortran: Add support for Fortran array slices at the GDB prompt

Andrew Burgess
2020-11-19T11:56:36Z

I've now pushed this patch. Let me know if you see any problems.

Thanks,
Andrew

* Andrew Burgess <andrew.burgess@embecosm.com> [2020-10-31 22:16:21 +0000]:

> The changes in v6 are:
>
> - Rebase on current master,
> - Have addressed the typos and minor issues pointed out by Simon and
> Tom,
> - The f-array-walker.h logic has been rewritten slightly after
> Simon's feedback. Hopefully the logic is slightly clearer now.
> This did actually improve the code a little, the outer parenthesis
> are now printed as part of the fortran_print_array logic, rather
> than being printed elsewhere.
>
> There's still a pending question from Tom
> w.r.t. fortran_array_walker_base_impl, but this is what I have for
> now.
>
> Thanks,
> Andrew
>
> ---
>
> [PATCH] gdb/fortran: Add support for Fortran array slices at the GDB prompt
>
> This commit brings array slice support to GDB.
>
> WARNING: This patch contains a rather big hack which is limited to
> Fortran arrays, this can be seen in gdbtypes.c and f-lang.c. More
> details on this below.
>
> This patch rewrites two areas of GDB's Fortran support, the code to
> extract an array slice, and the code to print an array.
>
> After this commit a user can, from the GDB prompt, ask for a slice of
> a Fortran array and should get the correct result back. Slices can
> (optionally) have the lower bound, upper bound, and a stride
> specified. Slices can also have a negative stride.
>
> Fortran has the concept of repacking array slices. Within a compiled
> Fortran program if a user passes a non-contiguous array slice to a
> function then the compiler may have to repack the slice, this involves
> copying the elements of the slice to a new area of memory before the
> call, and copying the elements back to the original array after the
> call. Whether repacking occurs will depend on which version of
> Fortran is being used, and what type of function is being called.
>
> This commit adds support for both packed, and unpacked array slicing,
> with the default being unpacked.
>
> With an unpacked array slice, when the user asks for a slice of an
> array GDB creates a new type that accurately describes where the
> elements of the slice can be found within the original array, a
> value of this type is then returned to the user. The address of an
> element within the slice will be equal to the address of an element
> within the original array.
>
> A user can choose to select packed array slices instead using:
>
> (gdb) set fortran repack-array-slices on|off
> (gdb) show fortran repack-array-slices
>
> With packed array slices GDB creates a new type that reflects how the
> elements of the slice would look if they were laid out in contiguous
> memory, allocates a value of this type, and then fetches the elements
> from the original array and places then into the contents buffer of
> the new value.
>
> One benefit of using packed slices over unpacked slices is the memory
> usage, taking a small slice of N elements from a large array will
> require (in GDB) N * ELEMENT_SIZE bytes of memory, while an unpacked
> array will also include all of the "padding" between the
> non-contiguous elements. There are new tests added that highlight
> this difference.
>
> There is also a new debugging flag added with this commit that
> introduces these commands:
>
> (gdb) set debug fortran-array-slicing on|off
> (gdb) show debug fortran-array-slicing
>
> This prints information about how the array slices are being built.
>
> As both the repacking, and the array printing requires GDB to walk
> through a multi-dimensional Fortran array visiting each element, this
> commit adds the file f-array-walk.h, which introduces some
> infrastructure to support this process. This means the array printing
> code in f-valprint.c is significantly reduced.
>
> The only slight issue with this commit is the "rather big hack" that I
> mentioned above. This hack allows us to handle one specific case,
> array slices with negative strides. This is something that I don't
> believe the current GDB value contents model will allow us to
> correctly handle, and rather than rewrite the value contents code
> right now, I'm hoping to slip this hack in as a work around.
>
> The problem is that, as I see it, the current value contents model
> assumes that an object base address will be the lowest address within
> that object, and that the contents of the object start at this base
> address and occupy the TYPE_LENGTH bytes after that.
>
> ( We do have the embedded_offset, which is used for C++ sub-classes,
> such that an object can start at some offset from the content buffer,
> however, the assumption that the object then occupies the next
> TYPE_LENGTH bytes is still true within GDB. )
>
> The problem is that Fortran arrays with a negative stride don't follow
> this pattern. In this case the base address of the object points to
> the element with the highest address, the contents of the array then
> start at some offset _before_ the base address, and proceed for one
> element _past_ the base address.
>
> As the stride for such an array would be negative then, in theory the
> TYPE_LENGTH for this type would also be negative. However, in many
> places a value in GDB will degrade to a pointer + length, and the
> length almost always comes from the TYPE_LENGTH.
>
> It is my belief that in order to correctly model this case the value
> content handling of GDB will need to be reworked to split apart the
> value's content buffer (which is a block of memory with a length), and
> the object's in memory base address and length, which could be
> negative.
>
> Things are further complicated because arrays with negative strides
> like this are always dynamic types. When a value has a dynamic type
> and its base address needs resolving we actually store the address of
> the object within the resolved dynamic type, not within the value
> object itself.
>
> In short I don't currently see an easy path to cleanly support this
> situation within GDB. And so I believe that leaves two options,
> either add a work around, or catch cases where the user tries to make
> use of a negative stride, or access an array with a negative stride,
> and throw an error.
>
> This patch currently goes with adding a work around, which is that
> when we resolve a dynamic Fortran array type, if the stride is
> negative, then we adjust the base address to point to the lowest
> address required by the array. The printing and slicing code is aware
> of this adjustment and will correctly slice and print Fortran arrays.
>
> Where this hack will show through to the user is if they ask for the
> address of an array in their program with a negative array stride, the
> address they get from GDB will not match the address that would be
> computed within the Fortran program.
>
> gdb/ChangeLog:
>
> * 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.
>
> gdb/testsuite/ChangeLog:
>
> * 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.
>
> gdb/doc/ChangeLog:
>
> * gdb.texinfo (Debugging Output): Document 'set/show debug
> fortran-array-slicing'.
> (Special Fortran Commands): Document 'set/show fortran
> repack-array-slices'.
> ---
> gdb/ChangeLog | 32 +
> gdb/Makefile.in | 1 +
> gdb/NEWS | 13 +
> gdb/doc/ChangeLog | 7 +
> gdb/doc/gdb.texinfo | 32 +
> gdb/f-array-walker.h | 265 +++++++
> gdb/f-lang.c | 712 ++++++++++++++++--
> gdb/f-lang.h | 19 +-
> gdb/f-valprint.c | 187 +++--
> gdb/gdbtypes.c | 12 +-
> gdb/testsuite/ChangeLog | 10 +
> .../gdb.fortran/array-slices-bad.exp | 69 ++
> .../gdb.fortran/array-slices-bad.f90 | 42 ++
> .../gdb.fortran/array-slices-sub-slices.exp | 111 +++
> .../gdb.fortran/array-slices-sub-slices.f90 | 96 +++
> gdb/testsuite/gdb.fortran/array-slices.exp | 277 +++++--
> gdb/testsuite/gdb.fortran/array-slices.f90 | 364 ++++++++-
> gdb/testsuite/gdb.fortran/vla-sizeof.exp | 4 +-
> 18 files changed, 1998 insertions(+), 255 deletions(-)
> create mode 100644 gdb/f-array-walker.h
> create mode 100644 gdb/testsuite/gdb.fortran/array-slices-bad.exp
> create mode 100644 gdb/testsuite/gdb.fortran/array-slices-bad.f90
> create mode 100644 gdb/testsuite/gdb.fortran/array-slices-sub-slices.exp
> create mode 100644 gdb/testsuite/gdb.fortran/array-slices-sub-slices.f90
>
> diff --git a/gdb/Makefile.in b/gdb/Makefile.in
> index 8a160896e2c..1838743a883 100644
> --- a/gdb/Makefile.in
> +++ b/gdb/Makefile.in
> @@ -1273,6 +1273,7 @@ HFILES_NO_SRCDIR = \
> expression.h \
> extension.h \
> extension-priv.h \
> + f-array-walker.h \
> f-lang.h \
> fbsd-nat.h \
> fbsd-tdep.h \
> diff --git a/gdb/NEWS b/gdb/NEWS
> index c99d3181a8b..be4b2956f17 100644
> --- a/gdb/NEWS
> +++ b/gdb/NEWS
> @@ -153,6 +153,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/gdb.texinfo b/gdb/doc/gdb.texinfo
> index d779d4a84f1..9e21d65c650 100644
> --- a/gdb/doc/gdb.texinfo
> +++ b/gdb/doc/gdb.texinfo
> @@ -16989,6 +16989,29 @@
> 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
> @@ -26581,6 +26604,15 @@
> @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 00000000000..417f9f07980
> --- /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 52493743031..d9b2e715442 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 */
>
> /* Return the encoding that should be used for the character type
> @@ -114,57 +141,6 @@ enum f_primitive_types {
> nr_f_primitive_types
> };
>
> -/* 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
> @@ -189,6 +165,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.
> @@ -200,51 +315,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;
> +
> + /* The high bound for this dimension of the slice. */
> + LONGEST high;
> +
> + /* The byte stride for this dimension of the slice. */
> + LONGEST stride;
> +
> + 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;
>
> - if (nargs > MAX_FORTRAN_DIMS)
> - error (_("Too many subscripts for F77 (%d Max)"), MAX_FORTRAN_DIMS);
> + 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"));
> + }
>
> - ndimensions = calc_f77_array_dims (type);
> + /* 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);
>
> - if (nargs != ndimensions)
> - error (_("Wrong number of subscripts"));
> + 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);
> + }
>
> - gdb_assert (nargs > 0);
> + /* 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;
> + }
> + }
>
> - /* Now that we know we have a legal array subscript expression let us
> - actually find out where this element exists in the array. */
> + 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;
> @@ -862,11 +1320,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);
> }
>
> /* See f-lang.h. */
> @@ -905,3 +1402,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 e59fdef1b19..880c07e4473 100644
> --- a/gdb/f-lang.h
> +++ b/gdb/f-lang.h
> @@ -316,7 +316,6 @@ extern void f77_get_dynamic_array_length (struct type *);
>
> extern int calc_f77_array_dims (struct type *);
>
> -
> /* Fortran (F77) types */
>
> struct builtin_f_type
> @@ -374,4 +373,22 @@ extern struct value *fortran_argument_convert (struct value *value,
> 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 95630a76d7d..83242f5ed47 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 ();
> }
> \f
>
> @@ -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 0940fa597fb..6a4037dd077 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>
>
> /* Initialize BADNESS constants. */
> @@ -2627,7 +2628,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/gdb.fortran/array-slices-bad.exp b/gdb/testsuite/gdb.fortran/array-slices-bad.exp
> new file mode 100644
> index 00000000000..2583cdecc94
> --- /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 00000000000..0f3d45ab8cd
> --- /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 00000000000..05b4802c678
> --- /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 00000000000..c3530f567d4
> --- /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 aa6bc6327eb..ff00fae886f 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 a66fa6ba784..6d75a385699 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 04296ac80c9..0ab74fbbe90 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"
> --
> 2.25.4
>