From: Paul Richard Thomas <paul.richard.thomas@gmail.com>
To: "fortran@gcc.gnu.org" <fortran@gcc.gnu.org>,
gcc-patches <gcc-patches@gcc.gnu.org>
Subject: [Patch, fortran] PR113363 - ICE on ASSOCIATE and unlimited polymorphic function
Date: Wed, 10 Apr 2024 09:25:39 +0100 [thread overview]
Message-ID: <CAGkQGiKLrys-Qj=f_Qq-+JaKymGO_DRceZqkpFfXMTcaePnhpw@mail.gmail.com> (raw)
[-- Attachment #1.1: Type: text/plain, Size: 1149 bytes --]
Hi All,
This patch corrects incorrect results from assignment of unlimited
polymorphic function results both in assignment statements and allocation
with source.
The first chunk in trans-array.cc ensures that the array dtype is set to
the source dtype. The second chunk ensures that the lhs _len field does not
default to zero and so is specific to dynamic types of character.
The addition to trans-stmt.cc transforms the source expression, aka expr3,
from a derived type of type "STAR" into a proper unlimited polymorphic
expression ready for assignment to the newly allocated entity.
OK for mainline?
Paul
Fortran: Fix wrong code in unlimited polymorphic assignment [PR113363]
2024-04-10 Paul Thomas <pault@gcc.gnu.org>
gcc/fortran
PR fortran/113363
* trans-array.cc (gfc_array_init_size): Use the expr3 dtype so
that the correct element size is used.
(gfc_alloc_allocatable_for_assignment): Set the _len field for
unlimited polymorphic assignments.
* trans-stmt.cc (gfc_trans_allocate): Build a correct rhs for
the assignment of an unlimited polymorphic 'source'.
gcc/testsuite/
PR fortran/113363
* gfortran.dg/pr113363.f90: New test.
[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 5706 bytes --]
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 30b84762346..2f9a32dda15 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -5957,6 +5957,11 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
tmp = gfc_conv_descriptor_dtype (descriptor);
gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
}
+ else if (expr3_desc && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr3_desc)))
+ {
+ tmp = gfc_conv_descriptor_dtype (descriptor);
+ gfc_add_modify (pblock, tmp, gfc_conv_descriptor_dtype (expr3_desc));
+ }
else
{
tmp = gfc_conv_descriptor_dtype (descriptor);
@@ -11324,6 +11329,9 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
gfc_add_modify (&fblock, tmp,
fold_convert (TREE_TYPE (tmp),
TYPE_SIZE_UNIT (type)));
+ else if (UNLIMITED_POLY (expr2))
+ gfc_add_modify (&fblock, tmp,
+ gfc_class_len_get (TREE_OPERAND (desc, 0)));
else
gfc_add_modify (&fblock, tmp,
build_int_cst (TREE_TYPE (tmp), 0));
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 7997c167bae..c6953033cf4 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -7187,6 +7187,45 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3);
flag_realloc_lhs = 0;
+ /* The handling of code->expr3 above produces a derived type of
+ type "STAR", whose size defaults to size(void*). In order to
+ have the right type information for the assignment, we must
+ reconstruct an unlimited polymorphic rhs. */
+ if (UNLIMITED_POLY (code->expr3)
+ && e3rhs && e3rhs->ts.type == BT_DERIVED
+ && !strcmp (e3rhs->ts.u.derived->name, "STAR"))
+ {
+ gfc_ref *ref;
+ gcc_assert (TREE_CODE (expr3_vptr) == COMPONENT_REF);
+ tmp = gfc_create_var (gfc_typenode_for_spec (&code->expr3->ts),
+ "e3");
+ gfc_add_modify (&block, tmp,
+ gfc_get_class_from_expr (expr3_vptr));
+ rhs->symtree->n.sym->backend_decl = tmp;
+ rhs->ts = code->expr3->ts;
+ rhs->symtree->n.sym->ts = rhs->ts;
+ for (ref = init_expr->ref; ref; ref = ref->next)
+ {
+ /* Copy over the lhs _data component ref followed by the
+ full array reference for source expressions with rank.
+ Otherwise, just copy the _data component ref. */
+ if (code->expr3->rank
+ && ref && ref->next && !ref->next->next)
+ {
+ rhs->ref = gfc_copy_ref (ref);
+ rhs->ref->next = gfc_copy_ref (ref->next);
+ break;
+ }
+ else if ((init_expr->rank && !code->expr3->rank
+ && ref && ref->next && !ref->next->next)
+ || (ref && !ref->next))
+ {
+ rhs->ref = gfc_copy_ref (ref);
+ break;
+ }
+ }
+ }
+
/* Set the symbol to be artificial so that the result is not finalized. */
init_expr->symtree->n.sym->attr.artificial = 1;
tmp = gfc_trans_assignment (init_expr, rhs, true, false, true,
diff --git a/gcc/testsuite/gfortran.dg/pr113363.f90 b/gcc/testsuite/gfortran.dg/pr113363.f90
new file mode 100644
index 00000000000..7701539fdff
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr113363.f90
@@ -0,0 +1,86 @@
+! { dg-do run }
+! Test the fix for comment 1 in PR113363, which failed as in comments below.
+! Contributed by Harald Anlauf <anlauf@gcc.gnu.org>
+program p
+ implicit none
+ class(*), allocatable :: x(:), y
+ character(*), parameter :: arr(2) = ["hello ","bye "], &
+ sca = "Have a nice day"
+
+! Bug was detected in polymorphic array function results
+ allocate(x, source = foo ())
+ call check1 (x, arr) ! Wrong output "6 hello e"
+ deallocate (x)
+ x = foo ()
+ call check1 (x, arr) ! Wrong output "0 "
+ associate (var => foo ()) ! OK after r14-9489-g3fd46d859cda10
+ call check1 (var, arr) ! Now OK - outputs: "6 hello bye "
+ end associate
+
+! Check scalar function results ! All OK
+ allocate (y, source = bar())
+ call check2 (y, sca)
+ deallocate (y)
+ y = bar ()
+ call check2 (y, sca)
+ deallocate (y)
+ associate (var => bar ())
+ call check2 (var, sca)
+ end associate
+
+! Finally variable expressions...
+ allocate (y, source = x(1)) ! Gave zero length here
+ call check2 (y, "hello")
+ y = x(2) ! Segfaulted here
+ call check2 (y, "bye ")
+ associate (var => x(2)) ! Gave zero length here
+ call check2 (var, "bye ")
+ end associate
+
+! ...and constant expressions ! All OK
+ deallocate(y)
+ allocate (y, source = "abcde")
+ call check2 (y, "abcde")
+ y = "hijklmnopq"
+ call check2 (y, "hijklmnopq")
+ associate (var => "mnopq")
+ call check2 (var, "mnopq")
+ end associate
+ deallocate (x, y)
+
+contains
+
+ function foo() result(res)
+ class(*), allocatable :: res(:)
+ res = arr
+ end function foo
+
+ function bar() result(res)
+ class(*), allocatable :: res
+ res = sca
+ end function bar
+
+ subroutine check1 (x, carg)
+ class(*), intent(in) :: x(:)
+ character(*) :: carg(:)
+ select type (x)
+ type is (character(*))
+! print *, len(x), x
+ if (any (x .ne. carg)) stop 1
+ class default
+ stop 2
+ end select
+ end subroutine check1
+
+ subroutine check2 (x, carg)
+ class(*), intent(in) :: x
+ character(*) :: carg
+ select type (x)
+ type is (character(*))
+! print *, len(x), x
+ if (x .ne. carg) stop 3
+ class default
+ stop 4
+ end select
+ end subroutine check2
+end
next reply other threads:[~2024-04-10 8:25 UTC|newest]
Thread overview: 6+ messages / expand[flat|nested] mbox.gz Atom feed top
2024-04-10 8:25 Paul Richard Thomas [this message]
2024-04-10 19:44 ` Harald Anlauf
2024-04-10 19:44 ` Harald Anlauf
2024-05-12 11:27 ` Paul Richard Thomas
2024-05-12 20:57 ` Harald Anlauf
2024-05-12 20:57 ` Harald Anlauf
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to='CAGkQGiKLrys-Qj=f_Qq-+JaKymGO_DRceZqkpFfXMTcaePnhpw@mail.gmail.com' \
--to=paul.richard.thomas@gmail.com \
--cc=fortran@gcc.gnu.org \
--cc=gcc-patches@gcc.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).