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