Blame SOURCES/gdb-rhbz1964167-fortran-array-slices-at-prompt.patch

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