Hi Harald,
thanks for the review. I totally agree, that this patch has gotten bigger than
I expected (and wanted). But things are as they are.
About the coding style: I have worked in so many projects, that I consider a
consistent coding style luxury. I esp. do not have my own one anymore. The
formating you are seeing in my patches is the result of clang-format with the
provided parameter file in contrib/clang-format. I was happy to have a tool
to do the formatting, that I could integrate into my IDE, because previously it
was hard to mimic the GNU style. I try to get to the GNU style as good as
possible, where I consider clang-format doing garbage.
I see that clang-format has a "very specific opinion" on how to format the
lines you mentioned, but it will "correct" them any time I change them and
touch them later. I now have forbidden clang-format to touch the code lines,
but this means to add formatter specific comments. Is this ok?
About the assumed size arrays, that was a small change and is added now.
Note, the runtime part of the patch (pr96992_3p1.patch) did not change and is
therefore not updated.
Regtests ok on x86_64-pc-linux-gnu/Fedora 39. Ok for mainline?
Regards,
Andre
On Fri, 5 Jul 2024 22:10:16 +0200
Harald Anlauf <anl...@gmx.de> wrote:
> Hi Andre,
>
> Am 03.07.24 um 12:58 schrieb Andre Vehreschild:
> > Hi Harald,
> >
> > I am sorry for the long delay, but fixing the negative stride lead from one
> > issue to the next. I finally got a version that does not regress. Please
> > have a look.
> >
> > This patch has two parts:
> > 1. The runtime library part in pr96992_3p1.patch and
> > 2. the compiler changes in pr96992_3p2.patch.
> >
> > In my branch also the two patches from Paul for pr59104 and pr102689 are
> > living, which might lead to small shifts during application of the patches.
> >
> > NOTE, this patch adds internal packing and unpacking of class arrays
> > similar to the regular pack and unpack. I think this is necessary, because
> > the regular un-/pack does not use the vptr's _copy routine for moving data
> > and therefore may produce bugs.
> >
> > The un-/pack_class routines are yet only used for converting a derived type
> > array to a class array. Extending their use when a UN-/PACK() is applied on
> > a class array is still to be done (as part of another PR).
> >
> > Regtests fine on x86_64-pc-linux-gnu/ Fedora 39.
>
> this is a really huge patch to review, and I am not sure that I can do
> this without help from others. Paul? Anybody else?
>
> As far as I can tell for now:
>
> - pr96992_3p1.patch (the libgfortran part) looks good to me.
>
> - git had some whitespace issues with pr96992_3p2.patch as attached,
> but I could fix that locally and do some testing parallel to reading.
>
> A few advance comments on the latter patch:
>
> - my understanding is that the PR at the end of a summary line should be
> like in:
>
> Fortran: Fix rejecting class arrays of different ranks as storage
> association argument [PR96992]
>
> I was told that this helps people explicitly scanning for the PR
> number in that place.
>
> - some rewrites of logical conditions change the coding style from
> what it recommended GNU coding style, and I find the more compact
> way used in some places harder to grok (but that may be just me).
> Example:
>
> @@ -8850,20 +8857,24 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr
> * expr, bool g77,
> /* There is no need to pack and unpack the array, if it is contiguous
> and not a deferred- or assumed-shape array, or if it is simply
> contiguous. */
> - no_pack = ((sym && sym->as
> - && !sym->attr.pointer
> - && sym->as->type != AS_DEFERRED
> - && sym->as->type != AS_ASSUMED_RANK
> - && sym->as->type != AS_ASSUMED_SHAPE)
> - ||
> - (ref && ref->u.ar.as
> - && ref->u.ar.as->type != AS_DEFERRED
> + no_pack = false;
> + gfc_array_spec *as;
> + if (sym)
> + {
> + symbol_attribute *attr
> + = &(IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->attr : sym->attr);
> + as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
> + no_pack
> + = (as && !attr->pointer && as->type != AS_DEFERRED
> + && as->type != AS_ASSUMED_RANK && as->type != AS_ASSUMED_SHAPE);
> + }
> + if (ref && ref->u.ar.as)
> + no_pack = no_pack
> + || (ref->u.ar.as->type != AS_DEFERRED
> && ref->u.ar.as->type != AS_ASSUMED_RANK
> - && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
> - ||
> - gfc_is_simply_contiguous (expr, false, true));
> -
> - no_pack = contiguous && no_pack;
> + && ref->u.ar.as->type != AS_ASSUMED_SHAPE);
> + no_pack
> + = contiguous && (no_pack || gfc_is_simply_contiguous (expr, false,
> true));
>
> /* If we have an EXPR_OP or a function returning an explicit-shaped
> or allocatable array, an array temporary will be generated which
>
>
> I understand that this may be your personal coding style, but you
> might keep in mind that reviewers have to understand the code, too...
>
> I have not fully understood your logic when packing is now invoked.
> We not only need to do it for explicit-size arrays, but also for
> assumed-size. This still fails for my slightly extended testcase
> (see attached) where I pass the class array via:
>
> subroutine d4(x,n)
> integer, intent(in) :: n
> ! class (foo), intent(inout) :: x(n) ! OK
> class (foo), intent(inout) :: x(*) ! not OK
> call d3(x,n) ! Simply pass assumed-size array
> end subroutine d4
>
> I am unable to point to the places in your patch where you need to
> handle that in addition.
>
> Otherwise I was unable to see any obvious, major problem with the
> patch, but then I am not fluent enough in class handling in the
> gfortran FE. So if e.g. Paul jumps in here within the next 72 hours,
> it would be great.
>
> So here comes the issue with the attached code variant.
> After your patch, this prints as last 4 relevant lines:
>
> full: -43 44 45 -46 47
> 48 -49 50
> d3_1: -43 44 45
> d3_2: 43 -44 -45
> full: 43 -44 -45 -46 47
> 48 -49 50
>
> while when switching the declaration of the dummy argument of d4:
>
> full: -43 44 45 -46 47
> 48 -49 50
> d3_1: -43 -46 -49
> d3_2: 43 46 49
> full: 43 44 45 46 47
> 48 49 50
>
> The latter one is correct, the former one isn't.
>
> Sorry for spoiling the show...
>
> Nevertheless, thanks for your great effort so far!
>
> Harald
>
>
> > Regards,
> > Andre
> >
> > PS: @Paul I could figure my test failures with -Ox with x e { 2, 3, s } to
> > be caused by initialization order. I.e. a member was set only after it was
> > read.
>
> [remaining part of mail removed]
--
Andre Vehreschild * Email: vehre ad gmx dot de
From d429783a8b5c9dc9b6004ea8bc89247d1da63127 Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <ve...@gcc.gnu.org>
Date: Fri, 28 Jun 2024 08:31:29 +0200
Subject: [PATCH 1/2] libgfortran: Add internal un/pack_class runtime
functions.
Packing class arrays was done using the regular internal pack
function in the past. But that does not use the vptr's copy
function and breaks OOP paradigms (e.g. deep copy). The new
un-/pack_class functions use the vptr's copy functionality to
implement OOP paradigms correctly.
libgfortran/ChangeLog:
* Makefile.am: Add in_un-/pack_class.c to build.
* Makefile.in: Regenerated from Makefile.am.
* gfortran.map: Added new functions and bumped ABI.
* libgfortran.h (GFC_CLASS_T): Added for generating class
representation at runtime.
* runtime/in_pack_class.c: New file.
* runtime/in_unpack_class.c: New file.
---
libgfortran/Makefile.am | 4 +-
libgfortran/Makefile.in | 13 ++-
libgfortran/gfortran.map | 6 +
libgfortran/libgfortran.h | 23 ++++
libgfortran/runtime/in_pack_class.c | 152 ++++++++++++++++++++++++++
libgfortran/runtime/in_unpack_class.c | 134 +++++++++++++++++++++++
6 files changed, 328 insertions(+), 4 deletions(-)
create mode 100644 libgfortran/runtime/in_pack_class.c
create mode 100644 libgfortran/runtime/in_unpack_class.c
diff --git a/libgfortran/Makefile.am b/libgfortran/Makefile.am
index ab605d49984..8524cc6ed03 100644
--- a/libgfortran/Makefile.am
+++ b/libgfortran/Makefile.am
@@ -156,7 +156,9 @@ intrinsics/selected_real_kind.f90 \
intrinsics/trigd.c \
intrinsics/unpack_generic.c \
runtime/in_pack_generic.c \
-runtime/in_unpack_generic.c
+runtime/in_unpack_generic.c \
+runtime/in_pack_class.c \
+runtime/in_unpack_class.c
if !LIBGFOR_MINIMAL
diff --git a/libgfortran/Makefile.in b/libgfortran/Makefile.in
index ced10e98aaa..6c6c89cc14e 100644
--- a/libgfortran/Makefile.in
+++ b/libgfortran/Makefile.in
@@ -569,8 +569,8 @@ am__objects_58 = intrinsics/associated.lo intrinsics/abort.lo \
intrinsics/selected_int_kind.lo \
intrinsics/selected_real_kind.lo intrinsics/trigd.lo \
intrinsics/unpack_generic.lo runtime/in_pack_generic.lo \
- runtime/in_unpack_generic.lo $(am__objects_56) \
- $(am__objects_57)
+ runtime/in_unpack_generic.lo runtime/in_pack_class.lo \
+ runtime/in_unpack_class.lo $(am__objects_56) $(am__objects_57)
@IEEE_SUPPORT_TRUE@am__objects_59 = ieee/ieee_arithmetic.lo \
@IEEE_SUPPORT_TRUE@ ieee/ieee_exceptions.lo \
@IEEE_SUPPORT_TRUE@ ieee/ieee_features.lo
@@ -985,7 +985,8 @@ gfor_helper_src = intrinsics/associated.c intrinsics/abort.c \
intrinsics/selected_int_kind.f90 \
intrinsics/selected_real_kind.f90 intrinsics/trigd.c \
intrinsics/unpack_generic.c runtime/in_pack_generic.c \
- runtime/in_unpack_generic.c $(am__append_4) $(am__append_5)
+ runtime/in_unpack_generic.c runtime/in_pack_class.c \
+ runtime/in_unpack_class.c $(am__append_4) $(am__append_5)
@IEEE_SUPPORT_TRUE@gfor_ieee_helper_src = ieee/ieee_helper.c
@IEEE_SUPPORT_FALSE@gfor_ieee_src =
@IEEE_SUPPORT_TRUE@gfor_ieee_src = \
@@ -3174,6 +3175,10 @@ runtime/in_pack_generic.lo: runtime/$(am__dirstamp) \
runtime/$(DEPDIR)/$(am__dirstamp)
runtime/in_unpack_generic.lo: runtime/$(am__dirstamp) \
runtime/$(DEPDIR)/$(am__dirstamp)
+runtime/in_pack_class.lo: runtime/$(am__dirstamp) \
+ runtime/$(DEPDIR)/$(am__dirstamp)
+runtime/in_unpack_class.lo: runtime/$(am__dirstamp) \
+ runtime/$(DEPDIR)/$(am__dirstamp)
intrinsics/access.lo: intrinsics/$(am__dirstamp) \
intrinsics/$(DEPDIR)/$(am__dirstamp)
intrinsics/c99_functions.lo: intrinsics/$(am__dirstamp) \
@@ -4223,7 +4228,9 @@ distclean-compile:
@AMDEP_TRUE@@am__include@ @am__quote@runtime/$(DEPDIR)/environ.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@runtime/$(DEPDIR)/error.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@runtime/$(DEPDIR)/fpu.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@runtime/$(DEPDIR)/in_pack_class.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@runtime/$(DEPDIR)/in_pack_generic.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@runtime/$(DEPDIR)/in_unpack_class.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@runtime/$(DEPDIR)/in_unpack_generic.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@runtime/$(DEPDIR)/main.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@runtime/$(DEPDIR)/memory.Plo@am__quote@
diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map
index 4a5a037a906..82f8f3c5e9c 100644
--- a/libgfortran/gfortran.map
+++ b/libgfortran/gfortran.map
@@ -1770,3 +1770,9 @@ GFORTRAN_14 {
global:
_gfortran_selected_logical_kind;
} GFORTRAN_13;
+
+GFORTRAN_15 {
+ global:
+ _gfortran_internal_pack_class;
+ _gfortran_internal_unpack_class;
+} GFORTRAN_14;
diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h
index 5c59ec26e16..a4526d97ce7 100644
--- a/libgfortran/libgfortran.h
+++ b/libgfortran/libgfortran.h
@@ -570,6 +570,29 @@ typedef GFC_FULL_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, GFC_INTEGER_4) gfc_full_a
#define GFC_UNALIGNED_C8(x) (((uintptr_t)(x)) & \
(__alignof__(GFC_COMPLEX_8) - 1))
+/* Generic vtab structure. */
+typedef struct
+{
+ GFC_INTEGER_4 _hash;
+ size_t _size;
+ struct gfc_vtype_generic_t *_extends;
+ void *_def_init;
+ void (*_copy) (const void *, void *);
+ void *(*_final);
+ void (*_deallocate) (void *);
+} gfc_vtype_generic_t;
+
+/* Generic class structure. */
+#define GFC_CLASS_T(type) \
+ struct \
+ { \
+ type _data; \
+ gfc_vtype_generic_t *_vptr; \
+ size_t _len; \
+ }
+
+typedef GFC_CLASS_T (GFC_ARRAY_DESCRIPTOR (void)) gfc_class_array_t;
+
/* Runtime library include. */
#define stringize(x) expand_macro(x)
#define expand_macro(x) # x
diff --git a/libgfortran/runtime/in_pack_class.c b/libgfortran/runtime/in_pack_class.c
new file mode 100644
index 00000000000..2bc96a15ab6
--- /dev/null
+++ b/libgfortran/runtime/in_pack_class.c
@@ -0,0 +1,152 @@
+/* Class specific helper function for repacking arrays.
+ Copyright (C) 2003-2024 Free Software Foundation, Inc.
+ Contributed by Paul Brook <p...@nowt.org>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <string.h>
+
+extern void
+internal_pack_class (gfc_class_array_t *, gfc_class_array_t *, const size_t,
+ const int);
+export_proto (internal_pack_class);
+
+/* attr is a bitfield. The bits in use are:
+ 0 - _len is present.
+ */
+void
+internal_pack_class (gfc_class_array_t *dest_class,
+ gfc_class_array_t *source_class, const size_t size_class,
+ const int attr)
+{
+#define BIT_TEST(mask, bit) (((mask) & (1U << (bit))) == (1U << (bit)))
+
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type stride[GFC_MAX_DIMENSIONS];
+ index_type stride0;
+ index_type dim;
+ index_type ssize;
+ index_type dest_stride;
+ index_type n;
+ const void *src;
+ void *dest;
+ int packed;
+ index_type size;
+ gfc_array_void *source_arr;
+ gfc_array_void *dest_arr;
+ size_t dest_offset;
+ bool len_present = BIT_TEST (attr, 0);
+ gfc_vtype_generic_t *vtab;
+ void (*copyfn) (const void *, void *);
+
+ /* Always make sure the dest is initialized. */
+ memcpy (dest_class, source_class, size_class);
+ if (source_class->_data.base_addr == NULL)
+ return;
+
+ source_arr = (gfc_array_void *) &(source_class->_data);
+ size = GFC_DESCRIPTOR_SIZE (source_arr);
+ dim = GFC_DESCRIPTOR_RANK (source_arr);
+ ssize = 1;
+ packed = 1;
+ for (n = 0; n < dim; n++)
+ {
+ count[n] = 0;
+ stride[n] = GFC_DESCRIPTOR_STRIDE (source_arr, n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT (source_arr, n);
+ if (extent[n] <= 0)
+ {
+ /* Do nothing. */
+ packed = 1;
+ break;
+ }
+
+ if (ssize != stride[n])
+ packed = 0;
+
+ ssize *= extent[n];
+ }
+
+ /* When the data is packed already, nothing needs to be done and unpack, will
+ quit immediately, because _data is identical and nothing needs to be done.
+ */
+ if (packed)
+ return;
+
+ /* Allocate storage for the destination. */
+ dest_arr = (gfc_array_void *) &dest_class->_data;
+ dest_stride = 1;
+ dest_offset = 0;
+ for (n = 0; n < dim; ++n)
+ {
+ GFC_DESCRIPTOR_LBOUND (dest_arr, n) = 1;
+ GFC_DESCRIPTOR_UBOUND (dest_arr, n) = extent[n];
+ GFC_DESCRIPTOR_STRIDE (dest_arr, n) = dest_stride;
+ dest_offset -= dest_stride * 1 /* GFC_DESCRIPTOR_LBOUND (dest_arr, n) */;
+ dest_stride *= GFC_DESCRIPTOR_EXTENT (dest_arr, n);
+ }
+ dest_arr->offset = dest_offset;
+ dest_arr->base_addr = xmallocarray (ssize, size);
+ dest = (void *) dest_arr->base_addr;
+ src = source_arr->base_addr;
+ stride0 = stride[0] * size;
+ /* Can not use the dimension here, because the class may be allocated for
+ a higher dimensional array, but only a smaller amount is present. */
+ vtab = *(gfc_vtype_generic_t **) (((void *) source_class) + size_class
+ - (len_present ? sizeof (size_t) : 0)
+ - sizeof (void *)); /* _vptr */
+ copyfn = vtab->_copy;
+
+ while (src)
+ {
+ /* Copy the data. */
+ copyfn (src, dest);
+ /* Advance to the next element. */
+ dest += size;
+ src += stride0;
+ count[0]++;
+ /* Advance to the next source element. */
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ src -= stride[n] * extent[n] * size;
+ n++;
+ if (n == dim)
+ {
+ src = NULL;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ src += stride[n] * size;
+ }
+ }
+ }
+}
diff --git a/libgfortran/runtime/in_unpack_class.c b/libgfortran/runtime/in_unpack_class.c
new file mode 100644
index 00000000000..068c604ff15
--- /dev/null
+++ b/libgfortran/runtime/in_unpack_class.c
@@ -0,0 +1,134 @@
+/* Class helper function for repacking arrays.
+ Copyright (C) 2003-2024 Free Software Foundation, Inc.
+ Contributed by Paul Brook <p...@nowt.org>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <string.h>
+
+extern void
+internal_unpack_class (gfc_class_array_t *, gfc_class_array_t *, const size_t,
+ const int);
+export_proto (internal_unpack_class);
+
+void
+internal_unpack_class (gfc_class_array_t *dest_class,
+ gfc_class_array_t *source_class, const size_t size_class,
+ const int attr)
+{
+#define BIT_TEST(mask, bit) (((mask) & (1U << (bit))) == (1U << (bit)))
+
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type stride[GFC_MAX_DIMENSIONS];
+ index_type stride0;
+ index_type dim;
+ index_type dsize;
+ void *dest;
+ const void *src;
+ index_type size;
+ const gfc_array_void *src_arr;
+ gfc_array_void *dest_arr;
+ bool len_present = BIT_TEST (attr, 0);
+ gfc_vtype_generic_t *vtab;
+ void (*copyfn) (const void *, void *);
+
+ /* This check may be redundant, but do it anyway. */
+ if (!source_class || !dest_class || !source_class->_data.base_addr
+ || !dest_class->_data.base_addr)
+ return;
+
+ dest_arr = (gfc_array_void *) &(dest_class->_data);
+ dest = dest_arr->base_addr;
+ size = GFC_DESCRIPTOR_SIZE (dest_arr);
+ dim = GFC_DESCRIPTOR_RANK (dest_arr);
+ dsize = 1;
+ for (index_type n = 0; n < dim; n++)
+ {
+ count[n] = 0;
+ stride[n] = GFC_DESCRIPTOR_STRIDE (dest_arr, n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT (dest_arr, n);
+ if (extent[n] <= 0)
+ return;
+
+ if (dsize == stride[n])
+ dsize *= extent[n];
+ else
+ dsize = 0;
+ }
+
+ src_arr = (gfc_array_void *) &source_class->_data;
+ src = src_arr->base_addr;
+
+ vtab = *(gfc_vtype_generic_t **) (((void *) source_class) + size_class
+ - (len_present ? sizeof (size_t) : 0)
+ - sizeof (void *)); /* _vptr */
+ copyfn = vtab->_copy;
+
+ if (dsize != 0)
+ {
+ for (index_type n = 0; n < dsize; ++n)
+ {
+ copyfn (src, dest);
+ src += size;
+ dest += size;
+ }
+ free (src_arr->base_addr);
+ return;
+ }
+
+ stride0 = stride[0] * size;
+
+ while (dest)
+ {
+ /* Copy the data. */
+ copyfn (src, dest);
+ /* Advance to the next element. */
+ src += size;
+ dest += stride0;
+ count[0]++;
+ /* Advance to the next source element. */
+ index_type n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ dest -= stride[n] * extent[n] * size;
+ n++;
+ if (n == dim)
+ {
+ dest = NULL;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ dest += stride[n] * size;
+ }
+ }
+ }
+ free (src_arr->base_addr);
+}
--
2.45.2
From ac105d78df76d0e7aeb0e61411bd2fd7f9f2e563 Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <ve...@gcc.gnu.org>
Date: Fri, 14 Jun 2024 16:54:37 +0200
Subject: [PATCH] Fortran: Fix rejecting class arrays of different ranks as
storage association argument. [PR96992]
Removing the assert in trans-expr, lead to initial strides not set
which is not fixed. When the array needs repacking, this is done for
class arrays now, too.
PR fortran/96992
gcc/fortran/ChangeLog:
* trans-array.cc (gfc_trans_array_bounds): Set a starting
stride, when descriptor expects a variable for the stride.
(gfc_trans_dummy_array_bias): Allow storage association for
dummy class arrays, when they are not elemental.
(gfc_conv_array_parameter): Add more general class support
and packing for classes, too.
* trans-array.h (gfc_conv_array_parameter): Add lbound shift
for class arrays.
* trans-decl.cc (gfc_build_builtin_function_decls): Add decls
for internal_un-/pack_class.
* trans-expr.cc (gfc_reset_vptr): Allow supplying a type-tree
to generate the vtab from.
(gfc_class_set_vptr): Allow supplying a class-tree to take the
vptr from.
(class_array_data_assign): Rename to gfc_class_array_data_assign
and make usable from other compile units.
(gfc_class_array_data_assign): Renamed from class_array_data_
assign.
(gfc_conv_derived_to_class): Remove assert to
allow converting derived to class type arrays with assumed
rank. Reduce code base and use gfc_conv_array_parameter also
for classes.
(gfc_conv_class_to_class): Use gfc_class_data_assign.
(gfc_conv_procedure_call): Adapt to new signature of
gfc_conv_derived_to_class.
* trans-io.cc (transfer_expr): Same.
* trans-stmt.cc (trans_associate_var): Same.
* trans.h (gfc_conv_derived_to_class): Signature changed.
(gfc_class_array_data_assign): Made public.
(gfor_fndecl_in_pack_class): Added declaration.
(gfor_fndecl_in_unpack_class): Same.
gcc/testsuite/ChangeLog:
* gfortran.dg/class_dummy_11.f90: New test.
---
gcc/fortran/trans-array.cc | 204 ++++++++++++----
gcc/fortran/trans-array.h | 5 +-
gcc/fortran/trans-decl.cc | 16 +-
gcc/fortran/trans-expr.cc | 242 +++++++++----------
gcc/fortran/trans-io.cc | 4 +-
gcc/fortran/trans-stmt.cc | 6 +-
gcc/fortran/trans.h | 7 +-
gcc/testsuite/gfortran.dg/class_dummy_11.f90 | 194 +++++++++++++++
8 files changed, 496 insertions(+), 182 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/class_dummy_11.f90
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index ab1647952d2..0fffa07495c 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -6891,6 +6891,9 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
size = gfc_index_one_node;
offset = gfc_index_zero_node;
+ stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
+ if (stride && VAR_P (stride))
+ gfc_add_modify (pblock, stride, gfc_index_one_node);
for (dim = 0; dim < as->rank; dim++)
{
/* Evaluate non-constant array bound expressions.
@@ -7236,7 +7239,9 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
|| (is_classarray && CLASS_DATA (sym)->attr.allocatable))
return;
- if (!is_classarray && sym->attr.dummy && gfc_is_nodesc_array (sym))
+ if ((!is_classarray
+ || (is_classarray && CLASS_DATA (sym)->as->type == AS_EXPLICIT))
+ && sym->attr.dummy && !sym->attr.elemental && gfc_is_nodesc_array (sym))
{
gfc_trans_g77_array (sym, block);
return;
@@ -8735,15 +8740,17 @@ is_pointer (gfc_expr *e)
/* Convert an array for passing as an actual parameter. */
void
-gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
+gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77,
const gfc_symbol *fsym, const char *proc_name,
- tree *size)
+ tree *size, tree *lbshift, tree *packed)
{
tree ptr;
tree desc;
tree tmp = NULL_TREE;
tree stmt;
tree parent = DECL_CONTEXT (current_function_decl);
+ tree ctree;
+ tree pack_attr;
bool full_array_var;
bool this_array_result;
bool contiguous;
@@ -8855,20 +8862,28 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
/* There is no need to pack and unpack the array, if it is contiguous
and not a deferred- or assumed-shape array, or if it is simply
contiguous. */
- no_pack = ((sym && sym->as
- && !sym->attr.pointer
- && sym->as->type != AS_DEFERRED
- && sym->as->type != AS_ASSUMED_RANK
- && sym->as->type != AS_ASSUMED_SHAPE)
- ||
- (ref && ref->u.ar.as
- && ref->u.ar.as->type != AS_DEFERRED
+ no_pack = false;
+ // clang-format off
+ if (sym)
+ {
+ symbol_attribute *attr = &(IS_CLASS_ARRAY (sym)
+ ? CLASS_DATA (sym)->attr : sym->attr);
+ gfc_array_spec *as = IS_CLASS_ARRAY (sym)
+ ? CLASS_DATA (sym)->as : sym->as;
+ no_pack = (as
+ && !attr->pointer
+ && as->type != AS_DEFERRED
+ && as->type != AS_ASSUMED_RANK
+ && as->type != AS_ASSUMED_SHAPE);
+ }
+ if (ref && ref->u.ar.as)
+ no_pack = no_pack
+ || (ref->u.ar.as->type != AS_DEFERRED
&& ref->u.ar.as->type != AS_ASSUMED_RANK
- && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
- ||
- gfc_is_simply_contiguous (expr, false, true));
-
- no_pack = contiguous && no_pack;
+ && ref->u.ar.as->type != AS_ASSUMED_SHAPE);
+ no_pack = contiguous
+ && (no_pack || gfc_is_simply_contiguous (expr, false, true));
+ // clang-format on
/* If we have an EXPR_OP or a function returning an explicit-shaped
or allocatable array, an array temporary will be generated which
@@ -8923,6 +8938,14 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
return;
}
+ if (fsym && fsym->ts.type == BT_CLASS)
+ {
+ gcc_assert (se->expr);
+ ctree = se->expr;
+ }
+ else
+ ctree = NULL_TREE;
+
if (this_array_result)
{
/* Result of the enclosing function. */
@@ -8941,7 +8964,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
else
{
/* Every other type of array. */
- se->want_pointer = 1;
+ se->want_pointer = (ctree) ? 0 : 1;
gfc_conv_expr_descriptor (se, expr);
if (size)
@@ -8949,6 +8972,55 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
build_fold_indirect_ref_loc (input_location,
se->expr),
expr, size);
+ if (ctree)
+ {
+ stmtblock_t block;
+
+ gfc_init_block (&block);
+ if (lbshift && *lbshift)
+ {
+ /* Apply a shift of the lbound when supplied. */
+ for (int dim = 0; dim < expr->rank; ++dim)
+ gfc_conv_shift_descriptor_lbound (&block, se->expr, dim,
+ *lbshift);
+ }
+ tmp = gfc_class_data_get (ctree);
+ if (expr->rank > 1 && CLASS_DATA (fsym)->as->rank != expr->rank
+ && CLASS_DATA (fsym)->as->type == AS_EXPLICIT && !no_pack)
+ {
+ tree arr = gfc_create_var (TREE_TYPE (tmp), "parm");
+ gfc_conv_descriptor_data_set (&block, arr,
+ gfc_conv_descriptor_data_get (
+ se->expr));
+ gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
+ gfc_index_zero_node);
+ gfc_conv_descriptor_ubound_set (
+ &block, arr, gfc_index_zero_node,
+ gfc_conv_descriptor_size (se->expr, expr->rank));
+ gfc_conv_descriptor_stride_set (
+ &block, arr, gfc_index_zero_node,
+ gfc_conv_descriptor_stride_get (se->expr, gfc_index_zero_node));
+ gfc_add_modify (&block, gfc_conv_descriptor_dtype (arr),
+ gfc_conv_descriptor_dtype (se->expr));
+ gfc_add_modify (&block, gfc_conv_descriptor_rank (arr),
+ build_int_cst (signed_char_type_node, 1));
+ gfc_conv_descriptor_span_set (&block, arr,
+ gfc_conv_descriptor_span_get (arr));
+ gfc_conv_descriptor_offset_set (&block, arr, gfc_index_zero_node);
+ se->expr = arr;
+ }
+ gfc_class_array_data_assign (&block, tmp, se->expr, true);
+
+ /* Handle optional. */
+ if (fsym && fsym->attr.optional && sym && sym->attr.optional)
+ tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
+ gfc_finish_block (&block),
+ build_empty_stmt (input_location));
+ else
+ tmp = gfc_finish_block (&block);
+
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
}
/* Deallocate the allocatable components of structures that are
@@ -8968,12 +9040,12 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
if (g77 || (fsym && fsym->attr.contiguous
&& !gfc_is_simply_contiguous (expr, false, true)))
{
- tree origptr = NULL_TREE;
+ tree origptr = NULL_TREE, packedptr = NULL_TREE;
desc = se->expr;
/* For contiguous arrays, save the original value of the descriptor. */
- if (!g77)
+ if (!g77 && !ctree)
{
origptr = gfc_create_var (pvoid_type_node, "origptr");
tmp = build_fold_indirect_ref_loc (input_location, desc);
@@ -9012,18 +9084,51 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
return;
}
- ptr = build_call_expr_loc (input_location,
- gfor_fndecl_in_pack, 1, desc);
-
- if (fsym && fsym->attr.optional && sym && sym->attr.optional)
+ if (ctree)
{
- tmp = gfc_conv_expr_present (sym);
- ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
- tmp, fold_convert (TREE_TYPE (se->expr), ptr),
- fold_convert (TREE_TYPE (se->expr), null_pointer_node));
+ packedptr
+ = gfc_build_addr_expr (NULL_TREE, gfc_create_var (TREE_TYPE (ctree),
+ "packed"));
+ if (fsym)
+ {
+ int pack_mask = 0;
+
+ /* Set bit 0 to the mask, when this is an unlimited_poly
+ class. */
+ if (CLASS_DATA (fsym)->ts.u.derived->attr.unlimited_polymorphic)
+ pack_mask = 1 << 0;
+ pack_attr = build_int_cst (integer_type_node, pack_mask);
+ }
+ else
+ pack_attr = integer_zero_node;
+
+ gfc_add_expr_to_block (
+ &se->pre,
+ build_call_expr_loc (input_location, gfor_fndecl_in_pack_class, 4,
+ packedptr,
+ gfc_build_addr_expr (NULL_TREE, ctree),
+ size_in_bytes (TREE_TYPE (ctree)), pack_attr));
+ ptr = gfc_conv_array_data (gfc_class_data_get (packedptr));
+ se->expr = packedptr;
+ if (packed)
+ *packed = packedptr;
}
+ else
+ {
+ ptr = build_call_expr_loc (input_location, gfor_fndecl_in_pack, 1,
+ desc);
+
+ if (fsym && fsym->attr.optional && sym && sym->attr.optional)
+ {
+ tmp = gfc_conv_expr_present (sym);
+ ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
+ tmp, fold_convert (TREE_TYPE (se->expr), ptr),
+ fold_convert (TREE_TYPE (se->expr),
+ null_pointer_node));
+ }
- ptr = gfc_evaluate_now (ptr, &se->pre);
+ ptr = gfc_evaluate_now (ptr, &se->pre);
+ }
/* Use the packed data for the actual argument, except for contiguous arrays,
where the descriptor's data component is set. */
@@ -9035,8 +9140,11 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
gfc_ss * ss = gfc_walk_expr (expr);
if (!transposed_dims (ss))
- gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
- else
+ {
+ if (!ctree)
+ gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
+ }
+ else if (!ctree)
{
tree old_field, new_field;
@@ -9109,22 +9217,36 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
/* Copy the data back. */
if (fsym == NULL || fsym->attr.intent != INTENT_IN)
{
- tmp = build_call_expr_loc (input_location,
- gfor_fndecl_in_unpack, 2, desc, ptr);
+ if (ctree)
+ {
+ tmp = gfc_build_addr_expr (NULL_TREE, ctree);
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_in_unpack_class, 4, tmp,
+ packedptr,
+ size_in_bytes (TREE_TYPE (ctree)),
+ pack_attr);
+ }
+ else
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_in_unpack, 2,
+ desc, ptr);
gfc_add_expr_to_block (&block, tmp);
}
+ else if (ctree && fsym->attr.intent == INTENT_IN)
+ {
+ /* Need to free the memory for class arrays, that got packed. */
+ gfc_add_expr_to_block (&block, gfc_call_free (ptr));
+ }
/* Free the temporary. */
- tmp = gfc_call_free (ptr);
- gfc_add_expr_to_block (&block, tmp);
+ if (!ctree)
+ gfc_add_expr_to_block (&block, gfc_call_free (ptr));
stmt = gfc_finish_block (&block);
gfc_init_block (&block);
/* Only if it was repacked. This code needs to be executed before the
loop cleanup code. */
- tmp = build_fold_indirect_ref_loc (input_location,
- desc);
+ tmp = (ctree) ? desc : build_fold_indirect_ref_loc (input_location, desc);
tmp = gfc_conv_array_data (tmp);
tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
fold_convert (TREE_TYPE (tmp), ptr), tmp);
@@ -9142,11 +9264,11 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
gfc_init_block (&se->post);
/* Reset the descriptor pointer. */
- if (!g77)
- {
- tmp = build_fold_indirect_ref_loc (input_location, desc);
- gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
- }
+ if (!g77 && !ctree)
+ {
+ tmp = build_fold_indirect_ref_loc (input_location, desc);
+ gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
+ }
gfc_add_block_to_block (&se->post, &block);
}
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index a51e9a5256b..29499a337c2 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -152,8 +152,9 @@ tree gfc_get_array_span (tree, gfc_expr *);
/* Evaluate an array expression. */
void gfc_conv_expr_descriptor (gfc_se *, gfc_expr *);
/* Convert an array for passing as an actual function parameter. */
-void gfc_conv_array_parameter (gfc_se *, gfc_expr *, bool,
- const gfc_symbol *, const char *, tree *);
+void gfc_conv_array_parameter (gfc_se *, gfc_expr *, bool, const gfc_symbol *,
+ const char *, tree *, tree * = nullptr,
+ tree * = nullptr);
/* These work with both descriptors and descriptorless arrays. */
tree gfc_conv_array_data (tree);
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 11247ddc07a..54ab60b4935 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -118,6 +118,8 @@ tree gfor_fndecl_fdate;
tree gfor_fndecl_ttynam;
tree gfor_fndecl_in_pack;
tree gfor_fndecl_in_unpack;
+tree gfor_fndecl_in_pack_class;
+tree gfor_fndecl_in_unpack_class;
tree gfor_fndecl_associated;
tree gfor_fndecl_system_clock4;
tree gfor_fndecl_system_clock8;
@@ -3916,9 +3918,19 @@ gfc_build_builtin_function_decls (void)
get_identifier (PREFIX("internal_unpack")), ". w R ",
void_type_node, 2, pvoid_type_node, pvoid_type_node);
+ gfor_fndecl_in_pack_class = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX ("internal_pack_class")), ". w R r r ",
+ void_type_node, 4, pvoid_type_node, pvoid_type_node, size_type_node,
+ integer_type_node);
+
+ gfor_fndecl_in_unpack_class = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX ("internal_unpack_class")), ". w R r r ",
+ void_type_node, 4, pvoid_type_node, pvoid_type_node, size_type_node,
+ integer_type_node);
+
gfor_fndecl_associated = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("associated")), ". R R ",
- integer_type_node, 2, ppvoid_type_node, ppvoid_type_node);
+ get_identifier (PREFIX ("associated")), ". R R ", integer_type_node, 2,
+ ppvoid_type_node, ppvoid_type_node);
DECL_PURE_P (gfor_fndecl_associated) = 1;
TREE_NOTHROW (gfor_fndecl_associated) = 1;
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index c847ca8367d..21ec7033e40 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -598,7 +598,6 @@ gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container,
}
}
-
/* Set the vptr of a class in to from the type given in from. If from is NULL,
then reset the vptr to the default or to. */
@@ -606,6 +605,7 @@ void
gfc_class_set_vptr (stmtblock_t *block, tree to, tree from)
{
tree tmp, vptr_ref;
+ gfc_symbol *type;
vptr_ref = gfc_get_vptr_from_expr (to);
if (POINTER_TYPE_P (TREE_TYPE (from))
@@ -614,38 +614,44 @@ gfc_class_set_vptr (stmtblock_t *block, tree to, tree from)
gfc_add_modify (block, vptr_ref,
fold_convert (TREE_TYPE (vptr_ref),
gfc_get_vptr_from_expr (from)));
+ return;
}
- else if (VAR_P (from)
- && strncmp (IDENTIFIER_POINTER (DECL_NAME (from)), "__vtab", 6) == 0)
+ tmp = gfc_get_vptr_from_expr (from);
+ if (tmp)
+ {
+ gfc_add_modify (block, vptr_ref,
+ fold_convert (TREE_TYPE (vptr_ref), tmp));
+ return;
+ }
+ if (VAR_P (from)
+ && strncmp (IDENTIFIER_POINTER (DECL_NAME (from)), "__vtab", 6) == 0)
{
gfc_add_modify (block, vptr_ref,
gfc_build_addr_expr (TREE_TYPE (vptr_ref), from));
+ return;
}
- else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (from)))
- && GFC_CLASS_TYPE_P (
- TREE_TYPE (TREE_OPERAND (TREE_OPERAND (from, 0), 0))))
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (from)))
+ && GFC_CLASS_TYPE_P (
+ TREE_TYPE (TREE_OPERAND (TREE_OPERAND (from, 0), 0))))
{
gfc_add_modify (block, vptr_ref,
fold_convert (TREE_TYPE (vptr_ref),
gfc_get_vptr_from_expr (TREE_OPERAND (
TREE_OPERAND (from, 0), 0))));
+ return;
}
- else
- {
- tree vtab;
- gfc_symbol *type;
- tmp = TREE_TYPE (from);
- if (POINTER_TYPE_P (tmp))
- tmp = TREE_TYPE (tmp);
- gfc_find_symbol (IDENTIFIER_POINTER (TYPE_NAME (tmp)), gfc_current_ns, 1,
- &type);
- vtab = gfc_find_derived_vtab (type)->backend_decl;
- gcc_assert (vtab);
- gfc_add_modify (block, vptr_ref,
- gfc_build_addr_expr (TREE_TYPE (vptr_ref), vtab));
- }
-}
+ /* If nothing of the above matches, set the vtype according to the type. */
+ tmp = TREE_TYPE (from);
+ if (POINTER_TYPE_P (tmp))
+ tmp = TREE_TYPE (tmp);
+ gfc_find_symbol (IDENTIFIER_POINTER (TYPE_NAME (tmp)), gfc_current_ns, 1,
+ &type);
+ tmp = gfc_find_derived_vtab (type)->backend_decl;
+ gcc_assert (tmp);
+ gfc_add_modify (block, vptr_ref,
+ gfc_build_addr_expr (TREE_TYPE (vptr_ref), tmp));
+}
/* Reset the len for unlimited polymorphic objects. */
@@ -739,10 +745,9 @@ gfc_get_vptr_from_expr (tree expr)
return NULL_TREE;
}
-
-static void
-class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
- bool lhs_type)
+void
+gfc_class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
+ bool lhs_type)
{
tree tmp, tmp2, type;
@@ -766,9 +771,8 @@ class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
gfc_add_modify (block, tmp, tmp2);
}
-
/* Takes a derived type expression and returns the address of a temporary
- class object of the 'declared' type. If vptr is not NULL, this is
+ class object of the 'declared' type. If opt_vptr_src is not NULL, this is
used for the temporary class object.
optional_alloc_ptr is false when the dummy is neither allocatable
nor a pointer; that's only relevant for the optional handling.
@@ -776,49 +780,65 @@ class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
expression for deallocation of allocatable components. Assumed rank
formal arguments made this necessary. */
void
-gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
- gfc_typespec class_ts, tree vptr, bool optional,
- bool optional_alloc_ptr,
+gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym,
+ tree opt_vptr_src, bool optional,
+ bool optional_alloc_ptr, const char *proc_name,
tree *derived_array)
{
- gfc_symbol *vtab;
tree cond_optional = NULL_TREE;
gfc_ss *ss;
tree ctree;
tree var;
tree tmp;
- int dim;
+ tree packed = NULL_TREE;
- /* The derived type needs to be converted to a temporary
- CLASS object. */
- tmp = gfc_typenode_for_spec (&class_ts);
+ /* The derived type needs to be converted to a temporary CLASS object. */
+ tmp = gfc_typenode_for_spec (&fsym->ts);
var = gfc_create_var (tmp, "class");
/* Set the vptr. */
- ctree = gfc_class_vptr_get (var);
-
- if (vptr != NULL_TREE)
- {
- /* Use the dynamic vptr. */
- tmp = vptr;
- }
+ if (opt_vptr_src)
+ gfc_class_set_vptr (&parmse->pre, var, opt_vptr_src);
else
- {
- /* In this case the vtab corresponds to the derived type and the
- vptr must point to it. */
- vtab = gfc_find_derived_vtab (e->ts.u.derived);
- gcc_assert (vtab);
- tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
- }
- gfc_add_modify (&parmse->pre, ctree,
- fold_convert (TREE_TYPE (ctree), tmp));
+ gfc_reset_vptr (&parmse->pre, e, var);
/* Now set the data field. */
- ctree = gfc_class_data_get (var);
+ ctree = gfc_class_data_get (var);
if (optional)
cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
+ /* Set the _len as early as possible. */
+ if (fsym->ts.u.derived->components->ts.type == BT_DERIVED
+ && fsym->ts.u.derived->components->ts.u.derived->attr
+ .unlimited_polymorphic)
+ {
+ /* Take care about initializing the _len component correctly. */
+ tree len_tree = gfc_class_len_get (var);
+ if (UNLIMITED_POLY (e))
+ {
+ gfc_expr *len;
+ gfc_se se;
+
+ len = gfc_find_and_cut_at_last_class_ref (e);
+ gfc_add_len_component (len);
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, len);
+ if (optional)
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
+ cond_optional, se.expr,
+ fold_convert (TREE_TYPE (se.expr),
+ integer_zero_node));
+ else
+ tmp = se.expr;
+ gfc_free_expr (len);
+ }
+ else
+ tmp = integer_zero_node;
+ gfc_add_modify (&parmse->pre, len_tree,
+ fold_convert (TREE_TYPE (len_tree), tmp));
+ }
+
if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
{
/* If there is a ready made pointer to a derived type, use it
@@ -847,7 +867,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
gfc_conv_expr_reference (parmse, e);
/* Scalar to an assumed-rank array. */
- if (class_ts.u.derived->components->as)
+ if (fsym->ts.u.derived->components->as)
{
tree type;
type = get_scalar_to_descriptor_type (parmse->expr,
@@ -878,15 +898,23 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
stmtblock_t block;
gfc_init_block (&block);
gfc_ref *ref;
+ int dim;
+ tree lbshift = NULL_TREE;
- parmse->ss = ss;
- parmse->use_offset = 1;
- gfc_conv_expr_descriptor (parmse, e);
+ /* Array refs with sections indicate, that a for a formal argument
+ expecting contiguous repacking needs to be done. */
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
+ break;
+ if (IS_CLASS_ARRAY (fsym)
+ && (CLASS_DATA (fsym)->as->type == AS_EXPLICIT
+ || CLASS_DATA (fsym)->as->type == AS_ASSUMED_SIZE)
+ && (ref || e->rank != fsym->ts.u.derived->components->as->rank))
+ fsym->attr.contiguous = 1;
/* Detect any array references with vector subscripts. */
for (ref = e->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY
- && ref->u.ar.type != AR_ELEMENT
+ if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT
&& ref->u.ar.type != AR_FULL)
{
for (dim = 0; dim < ref->u.ar.dimen; dim++)
@@ -895,37 +923,20 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
if (dim < ref->u.ar.dimen)
break;
}
-
- /* Array references with vector subscripts and non-variable expressions
- need be converted to a one-based descriptor. */
+ /* Array references with vector subscripts and non-variable
+ expressions need be converted to a one-based descriptor. */
if (ref || e->expr_type != EXPR_VARIABLE)
- {
- for (dim = 0; dim < e->rank; ++dim)
- gfc_conv_shift_descriptor_lbound (&block, parmse->expr, dim,
- gfc_index_one_node);
- }
+ lbshift = gfc_index_one_node;
- if (e->rank != class_ts.u.derived->components->as->rank)
- {
- gcc_assert (class_ts.u.derived->components->as->type
- == AS_ASSUMED_RANK);
- if (derived_array
- && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr)))
- {
- *derived_array = gfc_create_var (TREE_TYPE (parmse->expr),
- "array");
- gfc_add_modify (&block, *derived_array , parmse->expr);
- }
- class_array_data_assign (&block, ctree, parmse->expr, false);
- }
- else
+ parmse->expr = var;
+ gfc_conv_array_parameter (parmse, e, false, fsym, proc_name, nullptr,
+ &lbshift, &packed);
+
+ if (derived_array && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr)))
{
- if (gfc_expr_attr (e).codimension)
- parmse->expr = fold_build1_loc (input_location,
- VIEW_CONVERT_EXPR,
- TREE_TYPE (ctree),
- parmse->expr);
- gfc_add_modify (&block, ctree, parmse->expr);
+ *derived_array
+ = gfc_create_var (TREE_TYPE (parmse->expr), "array");
+ gfc_add_modify (&block, *derived_array, parmse->expr);
}
if (optional)
@@ -947,47 +958,19 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
}
}
- if (class_ts.u.derived->components->ts.type == BT_DERIVED
- && class_ts.u.derived->components->ts.u.derived
- ->attr.unlimited_polymorphic)
- {
- /* Take care about initializing the _len component correctly. */
- ctree = gfc_class_len_get (var);
- if (UNLIMITED_POLY (e))
- {
- gfc_expr *len;
- gfc_se se;
-
- len = gfc_find_and_cut_at_last_class_ref (e);
- gfc_add_len_component (len);
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, len);
- if (optional)
- tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
- cond_optional, se.expr,
- fold_convert (TREE_TYPE (se.expr),
- integer_zero_node));
- else
- tmp = se.expr;
- gfc_free_expr (len);
- }
- else
- tmp = integer_zero_node;
- gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree),
- tmp));
- }
/* Pass the address of the class object. */
- parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
+ if (packed)
+ parmse->expr = packed;
+ else
+ parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
if (optional && optional_alloc_ptr)
- parmse->expr = build3_loc (input_location, COND_EXPR,
- TREE_TYPE (parmse->expr),
- cond_optional, parmse->expr,
- fold_convert (TREE_TYPE (parmse->expr),
- null_pointer_node));
+ parmse->expr
+ = build3_loc (input_location, COND_EXPR, TREE_TYPE (parmse->expr),
+ cond_optional, parmse->expr,
+ fold_convert (TREE_TYPE (parmse->expr), null_pointer_node));
}
-
/* Create a new class container, which is required as scalar coarrays
have an array descriptor while normal scalars haven't. Optionally,
NULL pointer checks are added if the argument is OPTIONAL. */
@@ -1307,7 +1290,7 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
gfc_conv_descriptor_data_set (&block, ctree, tmp);
}
else
- class_array_data_assign (&block, ctree, parmse->expr, false);
+ gfc_class_array_data_assign (&block, ctree, parmse->expr, false);
}
else
{
@@ -1333,7 +1316,8 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
gfc_conv_descriptor_data_get (ctree)));
}
else
- class_array_data_assign (&parmse->post, parmse->expr, ctree, true);
+ gfc_class_array_data_assign (&parmse->post, parmse->expr, ctree,
+ true);
}
else
gfc_add_modify (&parmse->post, parmse->expr, ctree);
@@ -6547,13 +6531,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* The derived type needs to be converted to a temporary
CLASS object. */
gfc_init_se (&parmse, se);
- gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL,
+ gfc_conv_derived_to_class (&parmse, e, fsym, NULL_TREE,
fsym->attr.optional
- && e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.optional,
+ && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional,
CLASS_DATA (fsym)->attr.class_pointer
- || CLASS_DATA (fsym)->attr.allocatable,
- &derived_array);
+ || CLASS_DATA (fsym)->attr.allocatable,
+ sym->name, &derived_array);
}
else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS
&& e->ts.type != BT_PROCEDURE
diff --git a/gcc/fortran/trans-io.cc b/gcc/fortran/trans-io.cc
index ee2cc560cdf..7ab82fa2f5b 100644
--- a/gcc/fortran/trans-io.cc
+++ b/gcc/fortran/trans-io.cc
@@ -2462,8 +2462,8 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
|| (ts->type == BT_CLASS
&& !GFC_CLASS_TYPE_P (TREE_TYPE (decl))))
gfc_conv_derived_to_class (se, code->expr1,
- dtio_sub->formal->sym->ts,
- vptr, false, false);
+ dtio_sub->formal->sym, vptr, false,
+ false, "transfer");
addr_expr = se->expr;
function = iocall[IOCALL_X_DERIVED];
break;
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 703a705e7ca..41740ab762e 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -2118,11 +2118,9 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
{
/* This is bound to be a class array element. */
gfc_conv_expr_reference (&se, e);
- /* Get the _vptr component of the class object. */
- tmp = gfc_get_vptr_from_expr (se.expr);
/* Obtain a temporary class container for the result. */
- gfc_conv_derived_to_class (&se, e, sym->ts, tmp, false, false);
- se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
+ gfc_conv_derived_to_class (&se, e, sym, se.expr, false, false,
+ e->symtree->name);
need_len_assign = false;
}
else
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index ec04aede0fd..fdcce206756 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -464,8 +464,9 @@ bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool);
void gfc_finalize_tree_expr (gfc_se *, gfc_symbol *, symbol_attribute, int);
bool gfc_assignment_finalizer_call (gfc_se *, gfc_expr *, bool);
-void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree, bool,
- bool, tree *derived_array = NULL);
+void gfc_class_array_data_assign (stmtblock_t *, tree, tree, bool);
+void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_symbol *fsym, tree,
+ bool, bool, const char *, tree * = nullptr);
void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool, bool,
bool, bool);
@@ -872,6 +873,8 @@ extern GTY(()) tree gfor_fndecl_ctime;
extern GTY(()) tree gfor_fndecl_fdate;
extern GTY(()) tree gfor_fndecl_in_pack;
extern GTY(()) tree gfor_fndecl_in_unpack;
+extern GTY(()) tree gfor_fndecl_in_pack_class;
+extern GTY(()) tree gfor_fndecl_in_unpack_class;
extern GTY(()) tree gfor_fndecl_associated;
extern GTY(()) tree gfor_fndecl_system_clock4;
extern GTY(()) tree gfor_fndecl_system_clock8;
diff --git a/gcc/testsuite/gfortran.dg/class_dummy_11.f90 b/gcc/testsuite/gfortran.dg/class_dummy_11.f90
new file mode 100644
index 00000000000..a5c0fa6d52b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_dummy_11.f90
@@ -0,0 +1,194 @@
+! { dg-do run }
+
+! PR fortran/96992
+
+! Contributed by Thomas Koenig <tkoe...@gcc.gnu.org>
+
+! From the standard:
+! An actual argument that represents an element sequence and
+! corresponds to a dummy argument that is an array is sequence
+! associated with the dummy argument. The rank and shape of the
+! actual argument need not agree with the rank and shape of the
+! dummy argument, but the number of elements in the dummy argument
+! shall not exceed the number of elements in the element sequence
+! of the actual argument. If the dummy argument is assumed-size,
+! the number of elements in the dummy argument is exactly
+! the number of elements in the element sequence.
+
+! Check that walking the sequence starts with an initialized stride
+! for dim == 0.
+
+module foo_mod
+
+ implicit none
+
+ type foo
+ integer :: i
+ end type foo
+
+contains
+
+ subroutine d1(x,n)
+ integer, intent(in) :: n
+ integer :: i
+ class (foo), intent(out), dimension(n) :: x
+
+ x(:)%i = (/ (42 + i, i = 1, n ) /)
+ end subroutine d1
+
+ subroutine d2(x,n,sb)
+ integer, intent(in) :: n
+ integer :: i, sb
+ class (foo), intent(in), dimension(n,n,n) :: x
+
+ if ( any( x%i /= reshape((/ (42 + i, i = 1, n ** 3 ) /), [n, n, n] ))) stop sb + 1
+ end subroutine d2
+
+ subroutine d3(x,n)
+ integer, intent(in) :: n
+ integer :: i
+ class (foo), intent(inout) :: x(n)
+
+ x%i = -x%i ! Simply negate elements
+ end subroutine d3
+
+ subroutine d4(a,n)
+ integer, intent(in) :: n
+ class (foo), intent(inout) :: a(*)
+
+ call d3(a,n)
+ end subroutine d4
+
+ subroutine d1s(x,n, sb)
+ integer, intent(in) :: n, sb
+ integer :: i
+ class (*), intent(out), dimension(n) :: x
+
+ select type(x)
+ class is(foo)
+ x(:)%i = (/ (42 + i, i = 1, n ) /)
+ class default
+ stop sb + 2
+ end select
+ end subroutine d1s
+
+ subroutine d2s(x,n,sb)
+ integer, intent(in) :: n,sb
+ integer :: i
+ class (*), intent(in), dimension(n,n,n) :: x
+
+ select type (x)
+ class is (foo)
+ if ( any( x%i /= reshape((/ (42 + i, i = 1, n ** 3 ) /), [n, n, n] ))) stop sb + 3
+ class default
+ stop sb + 4
+ end select
+ end subroutine d2s
+
+ subroutine d3s(x,n,sb)
+ integer, intent(in) :: n, sb
+ integer :: i
+ class (*), intent(inout) :: x(n)
+
+ select type (x)
+ class is (foo)
+ x%i = -x%i ! Simply negate elements
+ class default
+ stop sb + 5
+ end select
+ end subroutine d3s
+
+end module foo_mod
+
+program main
+
+ use foo_mod
+
+ implicit none
+
+ type (foo), dimension(:), allocatable :: f
+ type (foo), dimension(27) :: g
+ type (foo), dimension(3, 9) :: td
+ integer :: n,i,np3
+
+ n = 3
+ np3 = n **3
+ allocate (f(np3))
+ call d1(f, np3)
+ call d2(f, n, 0)
+
+ call d1s(f, np3, 0)
+ call d2s(f, n, 0)
+
+ ! Use negative stride
+ call d1(f(np3:1:-1), np3)
+ if ( any( f%i /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 6
+ call d2(f(np3:1:-1), n, 0)
+ call d3(f(1:np3:4), np3/4)
+ if ( any( f%i /= (/ (merge(-(42 + (np3 - i)), &
+ 42 + (np3 - i), &
+ MOD(i, 4) == 0 .AND. i < 21), &
+ i = 0, np3 - 1 ) /) )) &
+ stop 7
+ call d4(f(1:np3:4), np3/4)
+ if ( any( f%i /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 8
+
+ call d1s(f(np3:1:-1), np3, 0)
+ if ( any( f%i /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 9
+ call d2s(f(np3:1:-1), n, 0)
+ call d3s(f(1:np3:4), np3/4, 0)
+ if ( any( f%i /= (/ (merge(-(42 + (np3 - i)), &
+ 42 + (np3 - i), &
+ MOD(i, 4) == 0 .AND. i < 21), &
+ i = 0, np3 - 1 ) /) )) &
+ stop 10
+
+ deallocate (f)
+
+ call d1(g, np3)
+ call d2(g, n, 11)
+
+ call d1s(g, np3, 11)
+ call d2s(g, n, 11)
+
+ ! Use negative stride
+ call d1(g(np3:1:-1), np3)
+ if ( any( g%i /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 17
+ call d2(g(np3:1:-1), n, 11)
+ call d3(g(1:np3:4), np3/4)
+ if ( any( g%i /= (/ (merge(-(42 + (np3 - i)), &
+ 42 + (np3 - i), &
+ MOD(i, 4) == 0 .AND. i < 21), &
+ i = 0, np3 - 1 ) /) )) &
+ stop 18
+
+ call d1s(g(np3:1:-1), np3, 11)
+ if ( any( g%i /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 19
+ call d2s(g(np3:1:-1), n, 11)
+ call d3s(g(1:np3:4), np3/4, 11)
+ if ( any( g%i /= (/ (merge(-(42 + (np3 - i)), &
+ 42 + (np3 - i), &
+ MOD(i, 4) == 0 .AND. i < 21), &
+ i = 0, np3 - 1 ) /) )) &
+ stop 20
+
+ ! Check for 2D
+ call d1(td, np3)
+ call d2(td, n, 21)
+
+ call d1s(td, np3, 21)
+ call d2s(td, n, 21)
+
+ ! Use negative stride
+ call d1(td(3:1:-1,9:1:-1), np3)
+ if ( any( reshape(td%i, [np3]) /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 26
+ call d2(td(3:1:-1,9:1:-1), n, 21)
+ call d3(td(2,1:n), n)
+ if ( any( reshape(td%i, [np3]) /= (/ (merge(-(42 + (np3 - i)), &
+ 42 + (np3 - i), &
+ MOD(i, 3) == 1 .AND. i < 9), &
+ i = 0, np3 - 1 ) /) )) &
+ stop 27
+
+end program main
+
--
2.45.2
