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'.
This commit is contained in:
Andrew Burgess
parent
a15a5258b5
commit
a5c641b57b
18 changed files with 2002 additions and 259 deletions
|
|
@ -1,3 +1,35 @@
|
||||||
|
2020-11-19 Andrew Burgess <andrew.burgess@embecosm.com>
|
||||||
|
|
||||||
|
* Makefile.in (HFILES_NO_SRCDIR): Add f-array-walker.h.
|
||||||
|
* NEWS: Mention new options.
|
||||||
|
* f-array-walker.h: New file.
|
||||||
|
* f-lang.c: Include 'gdbcmd.h' and 'f-array-walker.h'.
|
||||||
|
(repack_array_slices): New static global.
|
||||||
|
(show_repack_array_slices): New function.
|
||||||
|
(fortran_array_slicing_debug): New static global.
|
||||||
|
(show_fortran_array_slicing_debug): New function.
|
||||||
|
(value_f90_subarray): Delete.
|
||||||
|
(skip_undetermined_arglist): Delete.
|
||||||
|
(class fortran_array_repacker_base_impl): New class.
|
||||||
|
(class fortran_lazy_array_repacker_impl): New class.
|
||||||
|
(class fortran_array_repacker_impl): New class.
|
||||||
|
(fortran_value_subarray): Complete rewrite.
|
||||||
|
(set_fortran_list): New static global.
|
||||||
|
(show_fortran_list): Likewise.
|
||||||
|
(_initialize_f_language): Register new commands.
|
||||||
|
(fortran_adjust_dynamic_array_base_address_hack): New function.
|
||||||
|
* f-lang.h (fortran_adjust_dynamic_array_base_address_hack):
|
||||||
|
Declare.
|
||||||
|
* f-valprint.c: Include 'f-array-walker.h'.
|
||||||
|
(class fortran_array_printer_impl): New class.
|
||||||
|
(f77_print_array_1): Delete.
|
||||||
|
(f77_print_array): Delete.
|
||||||
|
(fortran_print_array): New.
|
||||||
|
(f_value_print_inner): Update to call fortran_print_array.
|
||||||
|
* gdbtypes.c: Include 'f-lang.h'.
|
||||||
|
(resolve_dynamic_type_internal): Call
|
||||||
|
fortran_adjust_dynamic_array_base_address_hack.
|
||||||
|
|
||||||
2020-11-19 Andrew Burgess <andrew.burgess@embecosm.com>
|
2020-11-19 Andrew Burgess <andrew.burgess@embecosm.com>
|
||||||
|
|
||||||
* breakpoint.c (struct watch_options): New struct.
|
* breakpoint.c (struct watch_options): New struct.
|
||||||
|
|
|
||||||
|
|
@ -1280,6 +1280,7 @@ HFILES_NO_SRCDIR = \
|
||||||
expression.h \
|
expression.h \
|
||||||
extension.h \
|
extension.h \
|
||||||
extension-priv.h \
|
extension-priv.h \
|
||||||
|
f-array-walker.h \
|
||||||
f-lang.h \
|
f-lang.h \
|
||||||
fbsd-nat.h \
|
fbsd-nat.h \
|
||||||
fbsd-tdep.h \
|
fbsd-tdep.h \
|
||||||
|
|
|
||||||
13
gdb/NEWS
13
gdb/NEWS
|
|
@ -159,6 +159,19 @@ maintenance print core-file-backed-mappings
|
||||||
Prints file-backed mappings loaded from a core file's note section.
|
Prints file-backed mappings loaded from a core file's note section.
|
||||||
Output is expected to be similar to that of "info proc mappings".
|
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
|
* Changed commands
|
||||||
|
|
||||||
alias [-a] [--] ALIAS = COMMAND [DEFAULT-ARGS...]
|
alias [-a] [--] ALIAS = COMMAND [DEFAULT-ARGS...]
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,10 @@
|
||||||
|
2020-11-19 Andrew Burgess <andrew.burgess@embecosm.com>
|
||||||
|
|
||||||
|
* gdb.texinfo (Debugging Output): Document 'set/show debug
|
||||||
|
fortran-array-slicing'.
|
||||||
|
(Special Fortran Commands): Document 'set/show fortran
|
||||||
|
repack-array-slices'.
|
||||||
|
|
||||||
2020-11-12 Andrew Burgess <andrew.burgess@embecosm.com>
|
2020-11-12 Andrew Burgess <andrew.burgess@embecosm.com>
|
||||||
|
|
||||||
* gdb.texinfo (Maintenance Commands): Update description of 'maint
|
* gdb.texinfo (Maintenance Commands): Update description of 'maint
|
||||||
|
|
|
||||||
|
|
@ -17041,6 +17041,29 @@ This command prints the values contained in the Fortran @code{COMMON}
|
||||||
block whose name is @var{common-name}. With no argument, the names of
|
block whose name is @var{common-name}. With no argument, the names of
|
||||||
all @code{COMMON} blocks visible at the current program location are
|
all @code{COMMON} blocks visible at the current program location are
|
||||||
printed.
|
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
|
@end table
|
||||||
|
|
||||||
@node Pascal
|
@node Pascal
|
||||||
|
|
@ -26633,6 +26656,15 @@ Turns on or off debugging messages from the FreeBSD native target.
|
||||||
@item show debug fbsd-nat
|
@item show debug fbsd-nat
|
||||||
Show the current state of FreeBSD native target debugging messages.
|
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
|
@item set debug frame
|
||||||
@cindex frame debugging info
|
@cindex frame debugging info
|
||||||
Turns on or off display of @value{GDBN} frame debugging info. The
|
Turns on or off display of @value{GDBN} frame debugging info. The
|
||||||
|
|
|
||||||
265
gdb/f-array-walker.h
Normal file
265
gdb/f-array-walker.h
Normal file
|
|
@ -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 */
|
||||||
714
gdb/f-lang.c
714
gdb/f-lang.c
|
|
@ -36,9 +36,36 @@
|
||||||
#include "c-lang.h"
|
#include "c-lang.h"
|
||||||
#include "target-float.h"
|
#include "target-float.h"
|
||||||
#include "gdbarch.h"
|
#include "gdbarch.h"
|
||||||
|
#include "gdbcmd.h"
|
||||||
|
#include "f-array-walker.h"
|
||||||
|
|
||||||
#include <math.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 */
|
/* Local functions */
|
||||||
|
|
||||||
static struct value *fortran_argument_convert (struct value *value,
|
static struct value *fortran_argument_convert (struct value *value,
|
||||||
|
|
@ -101,57 +128,6 @@ const struct op_print f_language::op_print_tab[] =
|
||||||
};
|
};
|
||||||
|
|
||||||
|
|
||||||
/* Called from fortran_value_subarray to take a slice of an array or a
|
|
||||||
string. ARRAY is the array or string to be accessed. EXP, POS, and
|
|
||||||
NOSIDE are as for evaluate_subexp_standard. Return a value that is a
|
|
||||||
slice of the array. */
|
|
||||||
|
|
||||||
static struct value *
|
|
||||||
value_f90_subarray (struct value *array,
|
|
||||||
struct expression *exp, int *pos, enum noside noside)
|
|
||||||
{
|
|
||||||
int pc = (*pos) + 1;
|
|
||||||
LONGEST low_bound, high_bound, stride;
|
|
||||||
struct type *range = check_typedef (value_type (array)->index_type ());
|
|
||||||
enum range_flag range_flag
|
|
||||||
= (enum range_flag) longest_to_int (exp->elts[pc].longconst);
|
|
||||||
|
|
||||||
*pos += 3;
|
|
||||||
|
|
||||||
if (range_flag & RANGE_LOW_BOUND_DEFAULT)
|
|
||||||
low_bound = range->bounds ()->low.const_val ();
|
|
||||||
else
|
|
||||||
low_bound = value_as_long (evaluate_subexp (nullptr, exp, pos, noside));
|
|
||||||
|
|
||||||
if (range_flag & RANGE_HIGH_BOUND_DEFAULT)
|
|
||||||
high_bound = range->bounds ()->high.const_val ();
|
|
||||||
else
|
|
||||||
high_bound = value_as_long (evaluate_subexp (nullptr, exp, pos, noside));
|
|
||||||
|
|
||||||
if (range_flag & RANGE_HAS_STRIDE)
|
|
||||||
stride = value_as_long (evaluate_subexp (nullptr, exp, pos, noside));
|
|
||||||
else
|
|
||||||
stride = 1;
|
|
||||||
|
|
||||||
if (stride != 1)
|
|
||||||
error (_("Fortran array strides are not currently supported"));
|
|
||||||
|
|
||||||
return value_slice (array, low_bound, high_bound - low_bound + 1);
|
|
||||||
}
|
|
||||||
|
|
||||||
/* Helper for skipping all the arguments in an undetermined argument list.
|
|
||||||
This function was designed for use in the OP_F77_UNDETERMINED_ARGLIST
|
|
||||||
case of evaluate_subexp_standard as multiple, but not all, code paths
|
|
||||||
require a generic skip. */
|
|
||||||
|
|
||||||
static void
|
|
||||||
skip_undetermined_arglist (int nargs, struct expression *exp, int *pos,
|
|
||||||
enum noside noside)
|
|
||||||
{
|
|
||||||
for (int i = 0; i < nargs; ++i)
|
|
||||||
evaluate_subexp (nullptr, exp, pos, noside);
|
|
||||||
}
|
|
||||||
|
|
||||||
/* Return the number of dimensions for a Fortran array or string. */
|
/* Return the number of dimensions for a Fortran array or string. */
|
||||||
|
|
||||||
int
|
int
|
||||||
|
|
@ -176,6 +152,145 @@ calc_f77_array_dims (struct type *array_type)
|
||||||
return ndimen;
|
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
|
/* Called from evaluate_subexp_standard to perform array indexing, and
|
||||||
sub-range extraction, for Fortran. As well as arrays this function
|
sub-range extraction, for Fortran. As well as arrays this function
|
||||||
also handles strings as they can be treated like arrays of characters.
|
also handles strings as they can be treated like arrays of characters.
|
||||||
|
|
@ -187,51 +302,394 @@ static struct value *
|
||||||
fortran_value_subarray (struct value *array, struct expression *exp,
|
fortran_value_subarray (struct value *array, struct expression *exp,
|
||||||
int *pos, int nargs, enum noside noside)
|
int *pos, int nargs, enum noside noside)
|
||||||
{
|
{
|
||||||
if (exp->elts[*pos].opcode == OP_RANGE)
|
type *original_array_type = check_typedef (value_type (array));
|
||||||
return value_f90_subarray (array, exp, pos, noside);
|
bool is_string_p = original_array_type->code () == TYPE_CODE_STRING;
|
||||||
|
|
||||||
if (noside == EVAL_SKIP)
|
/* 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)
|
||||||
{
|
{
|
||||||
skip_undetermined_arglist (nargs, exp, pos, noside);
|
if (type_not_associated (original_array_type))
|
||||||
/* Return the dummy value with the correct type. */
|
error (_("no such vector element (vector not associated)"));
|
||||||
return array;
|
else if (type_not_allocated (original_array_type))
|
||||||
|
error (_("no such vector element (vector not allocated)"));
|
||||||
|
}
|
||||||
|
else
|
||||||
|
{
|
||||||
|
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];
|
/* First check that the number of dimensions in the type we are slicing
|
||||||
int ndimensions = 1;
|
matches the number of arguments we were passed. */
|
||||||
struct type *type = check_typedef (value_type (array));
|
int ndimensions = calc_f77_array_dims (original_array_type);
|
||||||
|
|
||||||
if (nargs > MAX_FORTRAN_DIMS)
|
|
||||||
error (_("Too many subscripts for F77 (%d Max)"), MAX_FORTRAN_DIMS);
|
|
||||||
|
|
||||||
ndimensions = calc_f77_array_dims (type);
|
|
||||||
|
|
||||||
if (nargs != ndimensions)
|
if (nargs != ndimensions)
|
||||||
error (_("Wrong number of subscripts"));
|
error (_("Wrong number of subscripts"));
|
||||||
|
|
||||||
gdb_assert (nargs > 0);
|
/* This will be initialised below with the type of the elements held in
|
||||||
|
ARRAY. */
|
||||||
|
struct type *inner_element_type;
|
||||||
|
|
||||||
/* Now that we know we have a legal array subscript expression let us
|
/* Extract the types of each array dimension from the original array
|
||||||
actually find out where this element exists in the 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;
|
||||||
|
}
|
||||||
|
|
||||||
/* Take array indices left to right. */
|
/* As we analyse the new slice type we need to understand if the data
|
||||||
for (int i = 0; i < nargs; i++)
|
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)
|
||||||
{
|
{
|
||||||
/* Evaluate each subscript; it must be a legal integer in F77. */
|
/* For each dimension of the array the user will have either provided
|
||||||
value *arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
|
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;
|
||||||
|
|
||||||
/* Fill in the subscript array. */
|
LONGEST low, high, stride;
|
||||||
subscript_array[i] = value_as_long (arg2);
|
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 (fortran_array_slicing_debug)
|
||||||
|
{
|
||||||
|
debug_printf ("| '-> Results:\n");
|
||||||
|
debug_printf ("| |-> Offset = %ld\n", offset);
|
||||||
|
debug_printf ("| |-> Elements = %ld\n", e_count);
|
||||||
|
debug_printf ("| |-> Low bound = %ld\n", new_low);
|
||||||
|
debug_printf ("| |-> High bound = %ld\n", new_high);
|
||||||
|
debug_printf ("| |-> Byte stride = %ld\n", new_stride);
|
||||||
|
debug_printf ("| |-> Last element = %ld\n", last_elem);
|
||||||
|
debug_printf ("| |-> Remainder = %ld\n", remainder);
|
||||||
|
debug_printf ("| '-> Contiguous = %s\n",
|
||||||
|
(is_dim_contiguous ? "Yes" : "No"));
|
||||||
|
}
|
||||||
|
|
||||||
|
/* Figure out how big (in bytes) an element of this dimension of
|
||||||
|
the new array slice will be. */
|
||||||
|
slice_element_size = std::abs (new_stride * e_count);
|
||||||
|
|
||||||
|
slice_dims.emplace_back (new_low, new_high, new_stride,
|
||||||
|
index_type);
|
||||||
|
|
||||||
|
/* Update the total offset. */
|
||||||
|
total_offset += offset;
|
||||||
|
}
|
||||||
|
else
|
||||||
|
{
|
||||||
|
/* There is a single index for this dimension. */
|
||||||
|
LONGEST index
|
||||||
|
= value_as_long (evaluate_subexp_with_coercion (exp, pos, noside));
|
||||||
|
|
||||||
|
/* Get information about this dimension in the original ARRAY. */
|
||||||
|
struct type *target_type = TYPE_TARGET_TYPE (dim_type);
|
||||||
|
struct type *index_type = dim_type->index_type ();
|
||||||
|
LONGEST lb = f77_get_lowerbound (dim_type);
|
||||||
|
LONGEST ub = f77_get_upperbound (dim_type);
|
||||||
|
LONGEST sd = index_type->bit_stride () / 8;
|
||||||
|
if (sd == 0)
|
||||||
|
sd = TYPE_LENGTH (target_type);
|
||||||
|
|
||||||
|
if (fortran_array_slicing_debug)
|
||||||
|
{
|
||||||
|
debug_printf ("|-> Index access\n");
|
||||||
|
std::string str = type_to_string (dim_type);
|
||||||
|
debug_printf ("| |-> Type: %s\n", str.c_str ());
|
||||||
|
debug_printf ("| |-> Array:\n");
|
||||||
|
debug_printf ("| | |-> Low bound: %ld\n", lb);
|
||||||
|
debug_printf ("| | |-> High bound: %ld\n", ub);
|
||||||
|
debug_printf ("| | |-> Byte stride: %ld\n", sd);
|
||||||
|
debug_printf ("| | |-> Type size: %ld\n", TYPE_LENGTH (dim_type));
|
||||||
|
debug_printf ("| | '-> Target type size: %ld\n",
|
||||||
|
TYPE_LENGTH (target_type));
|
||||||
|
debug_printf ("| '-> Accessing:\n");
|
||||||
|
debug_printf ("| '-> Index: %ld\n", index);
|
||||||
|
}
|
||||||
|
|
||||||
|
/* If the array has actual content then check the index is in
|
||||||
|
bounds. An array without content (an unbound array) doesn't
|
||||||
|
have a known upper bound, so don't error check in that
|
||||||
|
situation. */
|
||||||
|
if (index < lb
|
||||||
|
|| (dim_type->index_type ()->bounds ()->high.kind () != PROP_UNDEFINED
|
||||||
|
&& index > ub)
|
||||||
|
|| (VALUE_LVAL (array) != lval_memory
|
||||||
|
&& dim_type->index_type ()->bounds ()->high.kind () == PROP_UNDEFINED))
|
||||||
|
{
|
||||||
|
if (type_not_associated (dim_type))
|
||||||
|
error (_("no such vector element (vector not associated)"));
|
||||||
|
else if (type_not_allocated (dim_type))
|
||||||
|
error (_("no such vector element (vector not allocated)"));
|
||||||
|
else
|
||||||
|
error (_("no such vector element"));
|
||||||
|
}
|
||||||
|
|
||||||
|
/* Calculate using the type stride, not the target type size. */
|
||||||
|
LONGEST offset = sd * (index - lb);
|
||||||
|
total_offset += offset;
|
||||||
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
/* Internal type of array is arranged right to left. */
|
if (noside == EVAL_SKIP)
|
||||||
for (int i = nargs; i > 0; i--)
|
return array;
|
||||||
{
|
|
||||||
struct type *array_type = check_typedef (value_type (array));
|
|
||||||
LONGEST index = subscript_array[i - 1];
|
|
||||||
|
|
||||||
array = value_subscripted_rvalue (array, index,
|
/* Build a type that represents the new array slice in the target memory
|
||||||
f77_get_lowerbound (array_type));
|
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)
|
||||||
|
{
|
||||||
|
/* 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);
|
||||||
|
}
|
||||||
|
|
||||||
|
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"));
|
||||||
|
}
|
||||||
|
|
||||||
|
/* Should we repack this array slice? */
|
||||||
|
if (!is_all_contiguous && (repack_array_slices || is_string_p))
|
||||||
|
{
|
||||||
|
/* 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);
|
||||||
|
}
|
||||||
|
|
||||||
|
/* 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;
|
return array;
|
||||||
|
|
@ -840,11 +1298,50 @@ builtin_f_type (struct gdbarch *gdbarch)
|
||||||
return (const struct builtin_f_type *) gdbarch_data (gdbarch, f_type_data);
|
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 ();
|
||||||
void
|
void
|
||||||
_initialize_f_language ()
|
_initialize_f_language ()
|
||||||
{
|
{
|
||||||
f_type_data = gdbarch_data_register_post_init (build_fortran_types);
|
f_type_data = gdbarch_data_register_post_init (build_fortran_types);
|
||||||
|
|
||||||
|
add_basic_prefix_cmd ("fortran", no_class,
|
||||||
|
_("Prefix command for changing Fortran-specific settings."),
|
||||||
|
&set_fortran_list, "set fortran ", 0, &setlist);
|
||||||
|
|
||||||
|
add_show_prefix_cmd ("fortran", no_class,
|
||||||
|
_("Generic command for showing Fortran-specific settings."),
|
||||||
|
&show_fortran_list, "show fortran ", 0, &showlist);
|
||||||
|
|
||||||
|
add_setshow_boolean_cmd ("repack-array-slices", class_vars,
|
||||||
|
&repack_array_slices, _("\
|
||||||
|
Enable or disable repacking of non-contiguous array slices."), _("\
|
||||||
|
Show whether non-contiguous array slices are repacked."), _("\
|
||||||
|
When the user requests a slice of a Fortran array then we can either return\n\
|
||||||
|
a descriptor that describes the array in place (using the original array data\n\
|
||||||
|
in its existing location) or the original data can be repacked (copied) to a\n\
|
||||||
|
new location.\n\
|
||||||
|
\n\
|
||||||
|
When the content of the array slice is contiguous within the original array\n\
|
||||||
|
then the result will never be repacked, but when the data for the new array\n\
|
||||||
|
is non-contiguous within the original array repacking will only be performed\n\
|
||||||
|
when this setting is on."),
|
||||||
|
NULL,
|
||||||
|
show_repack_array_slices,
|
||||||
|
&set_fortran_list, &show_fortran_list);
|
||||||
|
|
||||||
|
/* Debug Fortran's array slicing logic. */
|
||||||
|
add_setshow_boolean_cmd ("fortran-array-slicing", class_maintenance,
|
||||||
|
&fortran_array_slicing_debug, _("\
|
||||||
|
Set debugging of Fortran array slicing."), _("\
|
||||||
|
Show debugging of Fortran array slicing."), _("\
|
||||||
|
When on, debugging of Fortran array slicing is enabled."),
|
||||||
|
NULL,
|
||||||
|
show_fortran_array_slicing_debug,
|
||||||
|
&setdebuglist, &showdebuglist);
|
||||||
}
|
}
|
||||||
|
|
||||||
/* Ensures that function argument VALUE is in the appropriate form to
|
/* Ensures that function argument VALUE is in the appropriate form to
|
||||||
|
|
@ -895,3 +1392,56 @@ fortran_preserve_arg_pointer (struct value *arg, struct type *type)
|
||||||
return value_type (arg);
|
return value_type (arg);
|
||||||
return type;
|
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;
|
||||||
|
}
|
||||||
|
|
|
||||||
19
gdb/f-lang.h
19
gdb/f-lang.h
|
|
@ -314,7 +314,6 @@ extern LONGEST f77_get_lowerbound (struct type *);
|
||||||
|
|
||||||
extern int calc_f77_array_dims (struct type *);
|
extern int calc_f77_array_dims (struct type *);
|
||||||
|
|
||||||
|
|
||||||
/* Fortran (F77) types */
|
/* Fortran (F77) types */
|
||||||
|
|
||||||
struct builtin_f_type
|
struct builtin_f_type
|
||||||
|
|
@ -355,4 +354,22 @@ extern const struct builtin_f_type *builtin_f_type (struct gdbarch *gdbarch);
|
||||||
extern struct type *fortran_preserve_arg_pointer (struct value *arg,
|
extern struct type *fortran_preserve_arg_pointer (struct value *arg,
|
||||||
struct type *type);
|
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 */
|
#endif /* F_LANG_H */
|
||||||
|
|
|
||||||
193
gdb/f-valprint.c
193
gdb/f-valprint.c
|
|
@ -35,6 +35,7 @@
|
||||||
#include "dictionary.h"
|
#include "dictionary.h"
|
||||||
#include "cli/cli-style.h"
|
#include "cli/cli-style.h"
|
||||||
#include "gdbarch.h"
|
#include "gdbarch.h"
|
||||||
|
#include "f-array-walker.h"
|
||||||
|
|
||||||
static void f77_get_dynamic_length_of_aggregate (struct type *);
|
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)));
|
* TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type)));
|
||||||
}
|
}
|
||||||
|
|
||||||
/* Actual function which prints out F77 arrays, Valaddr == address in
|
/* A class used by FORTRAN_PRINT_ARRAY as a specialisation of the array
|
||||||
the superior. Address == the address in the inferior. */
|
walking template. This specialisation prints Fortran arrays. */
|
||||||
|
|
||||||
|
class fortran_array_printer_impl : public fortran_array_walker_base_impl
|
||||||
|
{
|
||||||
|
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 a Fortran array. */
|
||||||
|
|
||||||
static void
|
static void
|
||||||
f77_print_array_1 (int nss, int ndimensions, struct type *type,
|
fortran_print_array (struct type *type, CORE_ADDR address,
|
||||||
const gdb_byte *valaddr,
|
struct ui_file *stream, int recurse,
|
||||||
int embedded_offset, CORE_ADDR address,
|
const struct value *val,
|
||||||
struct ui_file *stream, int recurse,
|
const struct value_print_options *options)
|
||||||
const struct value *val,
|
|
||||||
const struct value_print_options *options,
|
|
||||||
int *elts)
|
|
||||||
{
|
{
|
||||||
struct type *range_type = check_typedef (type)->index_type ();
|
fortran_array_walker<fortran_array_printer_impl> p
|
||||||
CORE_ADDR addr = address + embedded_offset;
|
(type, address, (struct value *) val, stream, recurse, options);
|
||||||
LONGEST lowerbound, upperbound;
|
p.walk ();
|
||||||
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, "...");
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
/* This function gets called to print an F77 array, we set up some
|
|
||||||
stuff and then immediately call f77_print_array_1(). */
|
|
||||||
|
|
||||||
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)
|
|
||||||
{
|
|
||||||
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);
|
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -237,12 +241,7 @@ f_language::value_print_inner (struct value *val, struct ui_file *stream,
|
||||||
|
|
||||||
case TYPE_CODE_ARRAY:
|
case TYPE_CODE_ARRAY:
|
||||||
if (TYPE_TARGET_TYPE (type)->code () != TYPE_CODE_CHAR)
|
if (TYPE_TARGET_TYPE (type)->code () != TYPE_CODE_CHAR)
|
||||||
{
|
fortran_print_array (type, address, stream, recurse, val, options);
|
||||||
fprintf_filtered (stream, "(");
|
|
||||||
f77_print_array (type, valaddr, 0,
|
|
||||||
address, stream, recurse, val, options);
|
|
||||||
fprintf_filtered (stream, ")");
|
|
||||||
}
|
|
||||||
else
|
else
|
||||||
{
|
{
|
||||||
struct type *ch_type = TYPE_TARGET_TYPE (type);
|
struct type *ch_type = TYPE_TARGET_TYPE (type);
|
||||||
|
|
|
||||||
|
|
@ -39,6 +39,7 @@
|
||||||
#include "dwarf2/loc.h"
|
#include "dwarf2/loc.h"
|
||||||
#include "gdbcore.h"
|
#include "gdbcore.h"
|
||||||
#include "floatformat.h"
|
#include "floatformat.h"
|
||||||
|
#include "f-lang.h"
|
||||||
#include <algorithm>
|
#include <algorithm>
|
||||||
#include "gmp-utils.h"
|
#include "gmp-utils.h"
|
||||||
|
|
||||||
|
|
@ -2639,7 +2640,16 @@ resolve_dynamic_type_internal (struct type *type,
|
||||||
prop = TYPE_DATA_LOCATION (resolved_type);
|
prop = TYPE_DATA_LOCATION (resolved_type);
|
||||||
if (prop != NULL
|
if (prop != NULL
|
||||||
&& dwarf2_evaluate_property (prop, NULL, addr_stack, &value))
|
&& 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;
|
return resolved_type;
|
||||||
}
|
}
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,13 @@
|
||||||
|
2020-11-19 Andrew Burgess <andrew.burgess@embecosm.com>
|
||||||
|
|
||||||
|
* gdb.fortran/array-slices-bad.exp: New file.
|
||||||
|
* gdb.fortran/array-slices-bad.f90: New file.
|
||||||
|
* gdb.fortran/array-slices-sub-slices.exp: New file.
|
||||||
|
* gdb.fortran/array-slices-sub-slices.f90: New file.
|
||||||
|
* gdb.fortran/array-slices.exp: Rewrite tests.
|
||||||
|
* gdb.fortran/array-slices.f90: Rewrite tests.
|
||||||
|
* gdb.fortran/vla-sizeof.exp: Correct expected results.
|
||||||
|
|
||||||
2020-11-19 Andrew Burgess <andrew.burgess@embecosm.com>
|
2020-11-19 Andrew Burgess <andrew.burgess@embecosm.com>
|
||||||
|
|
||||||
* gdb.base/completion.exp: Add new completion tests.
|
* gdb.base/completion.exp: Add new completion tests.
|
||||||
|
|
|
||||||
69
gdb/testsuite/gdb.fortran/array-slices-bad.exp
Normal file
69
gdb/testsuite/gdb.fortran/array-slices-bad.exp
Normal file
|
|
@ -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"
|
||||||
42
gdb/testsuite/gdb.fortran/array-slices-bad.f90
Normal file
42
gdb/testsuite/gdb.fortran/array-slices-bad.f90
Normal file
|
|
@ -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
|
||||||
111
gdb/testsuite/gdb.fortran/array-slices-sub-slices.exp
Normal file
111
gdb/testsuite/gdb.fortran/array-slices-sub-slices.exp
Normal file
|
|
@ -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\\)\\)"
|
||||||
96
gdb/testsuite/gdb.fortran/array-slices-sub-slices.f90
Normal file
96
gdb/testsuite/gdb.fortran/array-slices-sub-slices.f90
Normal file
|
|
@ -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
|
||||||
|
|
@ -18,6 +18,21 @@
|
||||||
# the subroutine. This should exercise GDB's ability to handle
|
# the subroutine. This should exercise GDB's ability to handle
|
||||||
# different strides for the different dimensions.
|
# 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 }
|
if {[skip_fortran_tests]} { return -1 }
|
||||||
|
|
||||||
standard_testfile ".f90"
|
standard_testfile ".f90"
|
||||||
|
|
@ -28,60 +43,224 @@ if {[prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
|
||||||
return -1
|
return -1
|
||||||
}
|
}
|
||||||
|
|
||||||
if ![fortran_runto_main] {
|
# Takes the name of an array slice as used in the test source, and extracts
|
||||||
untested "could not run to main"
|
# the base array name. For example: 'array (1,2)' becomes 'array'.
|
||||||
return -1
|
proc array_slice_to_var { slice_str } {
|
||||||
|
regexp "^(?:\\s*\\()*(\[^( \t\]+)" $slice_str matchvar varname
|
||||||
|
return $varname
|
||||||
}
|
}
|
||||||
|
|
||||||
gdb_breakpoint "show"
|
proc run_test { repack } {
|
||||||
gdb_breakpoint [gdb_get_line_number "Final Breakpoint"]
|
global binfile gdb_prompt
|
||||||
|
|
||||||
set array_contents \
|
clean_restart ${binfile}
|
||||||
[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 \
|
if ![fortran_runto_main] {
|
||||||
[list \
|
untested "could not run to main"
|
||||||
" = 'array'" \
|
return -1
|
||||||
" = '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"
|
|
||||||
}
|
}
|
||||||
|
|
||||||
|
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.
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
if ($found_final_breakpoint) {
|
||||||
|
break
|
||||||
|
}
|
||||||
|
|
||||||
|
# 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_continue_to_breakpoint "continue to Final Breakpoint"
|
foreach_with_prefix repack { on off } {
|
||||||
|
run_test $repack
|
||||||
# Next test that asking for an array with stride at the CLI gives an
|
|
||||||
# error.
|
|
||||||
clean_restart ${testfile}
|
|
||||||
|
|
||||||
if ![fortran_runto_main] then {
|
|
||||||
perror "couldn't run to main"
|
|
||||||
continue
|
|
||||||
}
|
}
|
||||||
|
|
||||||
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"
|
|
||||||
|
|
|
||||||
|
|
@ -13,58 +13,368 @@
|
||||||
! You should have received a copy of the GNU General Public License
|
! You should have received a copy of the GNU General Public License
|
||||||
! along with this program. If not, see <http://www.gnu.org/licenses/>.
|
! along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
subroutine show (message, array)
|
subroutine show_elem (array)
|
||||||
character (len=*) :: message
|
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
|
integer, dimension (:,:) :: array
|
||||||
|
|
||||||
print *, message
|
print *, "Array Contents:"
|
||||||
|
print *, ""
|
||||||
|
|
||||||
do i=LBOUND (array, 2), UBOUND (array, 2), 1
|
do i=LBOUND (array, 2), UBOUND (array, 2), 1
|
||||||
do j=LBOUND (array, 1), UBOUND (array, 1), 1
|
do j=LBOUND (array, 1), UBOUND (array, 1), 1
|
||||||
write(*, fmt="(i4)", advance="no") array (j, i)
|
write(*, fmt="(i4)", advance="no") array (j, i)
|
||||||
end do
|
end do
|
||||||
print *, ""
|
print *, ""
|
||||||
end do
|
end do
|
||||||
print *, array
|
|
||||||
print *, ""
|
|
||||||
|
|
||||||
end subroutine show
|
print *, ""
|
||||||
|
print *, "Expected GDB Output:"
|
||||||
|
print *, ""
|
||||||
|
|
||||||
|
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
|
program test
|
||||||
|
|
||||||
interface
|
interface
|
||||||
subroutine show (message, array)
|
subroutine show_str (array)
|
||||||
character (len=*) :: message
|
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
|
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
|
end interface
|
||||||
|
|
||||||
|
! Declare variables used in this test.
|
||||||
|
integer, dimension (-10:-1,-10:-2) :: neg_array
|
||||||
integer, dimension (1:10,1:10) :: array
|
integer, dimension (1:10,1:10) :: array
|
||||||
integer, allocatable :: other (:, :)
|
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))
|
allocate (other (-5:4, -2:7))
|
||||||
|
pointer2d => tarray
|
||||||
|
|
||||||
do i=LBOUND (array, 2), UBOUND (array, 2), 1
|
! Fill arrays with contents ready for testing.
|
||||||
do j=LBOUND (array, 1), UBOUND (array, 1), 1
|
call fill_array_1d (array1d)
|
||||||
array (j,i) = ((i - 1) * UBOUND (array, 2)) + j
|
|
||||||
|
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))
|
||||||
|
|
||||||
|
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
|
||||||
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))
|
||||||
|
|
||||||
do i=LBOUND (other, 2), UBOUND (other, 2), 1
|
! Enclosing the array slice argument in (...) causess gfortran to
|
||||||
do j=LBOUND (other, 1), UBOUND (other, 1), 1
|
! repack the array.
|
||||||
other (j,i) = ((i - 1) * UBOUND (other, 2)) + j
|
call show_2d ((array (1:10:3, 1:10:2)))
|
||||||
end do
|
call show_2d ((neg_array (-10:-3,-8:-4:2)))
|
||||||
end do
|
|
||||||
|
|
||||||
call show ("array", array)
|
call show_3d (array3d)
|
||||||
call show ("array (1:5,1:5)", array (1:5,1:5))
|
call show_3d (array3d(-1:1,-1:1,-1:1))
|
||||||
call show ("array (1:10:2,1:10:2)", array (1:10:2,1:10:2))
|
call show_3d (array3d(1:-1:-1,1:-1:-1,1:-1:-1))
|
||||||
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 ("other", other)
|
! Enclosing the array slice argument in (...) causess gfortran to
|
||||||
call show ("other (-5:0, -2:0)", other (-5:0, -2:0))
|
! repack the array.
|
||||||
call show ("other (-5:4:2, -2:7:3)", other (-5:4:2, -2:7:3))
|
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)
|
deallocate (other)
|
||||||
|
|
||||||
|
! GDB catches this final breakpoint to indicate the end of the test.
|
||||||
print *, "" ! Final Breakpoint.
|
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
|
end program test
|
||||||
|
|
|
||||||
|
|
@ -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)" " = 4000" "print sizeof allocated vla1"
|
||||||
gdb_test "print sizeof(vla1(3,2,1))" "4" \
|
gdb_test "print sizeof(vla1(3,2,1))" "4" \
|
||||||
"print sizeof element from allocated vla1"
|
"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"
|
"print sizeof sliced vla1"
|
||||||
|
|
||||||
# Try to access values in undefined pointer to VLA (dangling)
|
# 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)" " = 4000" "print sizeof associated pvla"
|
||||||
gdb_test "print sizeof(pvla(3,2,1))" "4" \
|
gdb_test "print sizeof(pvla(3,2,1))" "4" \
|
||||||
"print sizeof element from associated pvla"
|
"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_breakpoint [gdb_get_line_number "vla1-neg-bounds-v1"]
|
||||||
gdb_continue_to_breakpoint "vla1-neg-bounds-v1"
|
gdb_continue_to_breakpoint "vla1-neg-bounds-v1"
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue