From: Andre Vehreschild <vehre@gmx.de>
To: fortran@gcc.gnu.org, gcc-patches <gcc-patches@gcc.gnu.org>
Subject: [Patch, Fortran, pr70397, v1] [5/6 Regression] ice while allocating ultimate polymorphic
Date: Tue, 29 Mar 2016 12:55:00 -0000 [thread overview]
Message-ID: <20160329145524.42d070d4@vepi2> (raw)
In-Reply-To: <8CC3461C-413F-400D-AD3C-341F5D20AE95@lps.ens.fr>
[-- Attachment #1: Type: text/plain, Size: 982 bytes --]
Hi all,
here is the trunk version of the patch for the regression reported in
pr70397. Applying the gcc-5 patch to trunk lead to a regression, which
the modified patch resolves now. The technique to solve the ice is
the same as for gcc-5:
> The routine gfc_copy_class_to_class() assumed that both the source
> and destination object's type is unlimited polymorphic, but in this
> case it is true for the destination only, which made gfortran look
> for a non-existent _len component in the source object and therefore
> ICE. This is fixed by the patch by adding a function to return either
> the _len component, when it exists, or a constant zero node to init
> the destination object's _len component with.
Bootstrapped and regtested on x86_64-linux-gnu/F23. Ok for trunk?
Regards,
Andre
PS: Yes, Paul, I know you accepted the patch for gcc-5 for trunk
also, but I feel safer when the changes made get additional approval.
--
Andre Vehreschild * Email: vehre ad gmx dot de
[-- Attachment #2: pr70397_1.clog --]
[-- Type: text/plain, Size: 592 bytes --]
gcc/fortran/ChangeLog:
2016-03-27 Andre Vehreschild <vehre@gcc.gnu.org>
PR fortran/70397
* trans-expr.c (gfc_class_len_or_zero_get): Add function to return a
constant zero tree, when the class to get the _len component from is
not unlimited polymorphic.
(gfc_copy_class_to_class): Use the new function.
* trans.h: Added interface of new function gfc_class_len_or_zero_get.
gcc/testsuite/ChangeLog:
2016-03-27 Andre Vehreschild <vehre@gcc.gnu.org>
PR fortran/70397
* gfortran.dg/unlimited_polymorphic_25.f90: New test.
* gfortran.dg/unlimited_polymorphic_26.f90: New test.
[-- Attachment #3: pr70397_gcc6_1.patch --]
[-- Type: text/x-patch, Size: 4681 bytes --]
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 4baadc8..8d039a6 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -173,6 +173,29 @@ gfc_class_len_get (tree decl)
}
+/* Try to get the _len component of a class. When the class is not unlimited
+ poly, i.e. no _len field exists, then return a zero node. */
+
+tree
+gfc_class_len_or_zero_get (tree decl)
+{
+ tree len;
+ /* For class arrays decl may be a temporary descriptor handle, the vptr is
+ then available through the saved descriptor. */
+ if (TREE_CODE (decl) == VAR_DECL && DECL_LANG_SPECIFIC (decl)
+ && GFC_DECL_SAVED_DESCRIPTOR (decl))
+ decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
+ if (POINTER_TYPE_P (TREE_TYPE (decl)))
+ decl = build_fold_indirect_ref_loc (input_location, decl);
+ len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
+ CLASS_LEN_FIELD);
+ return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (len), decl, len,
+ NULL_TREE)
+ : integer_zero_node;
+}
+
+
/* Get the specified FIELD from the VPTR. */
static tree
@@ -250,6 +273,7 @@ gfc_vptr_size_get (tree vptr)
#undef CLASS_DATA_FIELD
#undef CLASS_VPTR_FIELD
+#undef CLASS_LEN_FIELD
#undef VTABLE_HASH_FIELD
#undef VTABLE_SIZE_FIELD
#undef VTABLE_EXTENDS_FIELD
@@ -1120,7 +1144,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
if (unlimited)
{
if (from != NULL_TREE && unlimited)
- from_len = gfc_class_len_get (from);
+ from_len = gfc_class_len_or_zero_get (from);
else
from_len = integer_zero_node;
}
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index add0cea..512615a 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -365,6 +365,7 @@ tree gfc_class_set_static_fields (tree, tree, tree);
tree gfc_class_data_get (tree);
tree gfc_class_vptr_get (tree);
tree gfc_class_len_get (tree);
+tree gfc_class_len_or_zero_get (tree);
gfc_expr * gfc_find_and_cut_at_last_class_ref (gfc_expr *);
/* Get an accessor to the class' vtab's * field, when a class handle is
available. */
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_25.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_25.f90
new file mode 100644
index 0000000..d0b2a2e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_25.f90
@@ -0,0 +1,40 @@
+! { dg-do run }
+!
+! Test contributed by Valery Weber <valeryweber@hotmail.com>
+
+module mod
+
+ TYPE, PUBLIC :: base_type
+ END TYPE base_type
+
+ TYPE, PUBLIC :: dict_entry_type
+ CLASS( * ), ALLOCATABLE :: key
+ CLASS( * ), ALLOCATABLE :: val
+ END TYPE dict_entry_type
+
+
+contains
+
+ SUBROUTINE dict_put ( this, key, val )
+ CLASS(dict_entry_type), INTENT(INOUT) :: this
+ CLASS(base_type), INTENT(IN) :: key, val
+ INTEGER :: istat
+ ALLOCATE( this%key, SOURCE=key, STAT=istat )
+ end SUBROUTINE dict_put
+end module mod
+
+program test
+ use mod
+ type(dict_entry_type) :: t
+ type(base_type) :: a, b
+ call dict_put(t, a, b)
+
+ if (.NOT. allocated(t%key)) call abort()
+ select type (x => t%key)
+ type is (base_type)
+ class default
+ call abort()
+ end select
+ deallocate(t%key)
+end
+
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_26.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_26.f90
new file mode 100644
index 0000000..1300069
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_26.f90
@@ -0,0 +1,47 @@
+! { dg-do run }
+!
+! Test contributed by Valery Weber <valeryweber@hotmail.com>
+
+module mod
+
+ TYPE, PUBLIC :: dict_entry_type
+ CLASS( * ), ALLOCATABLE :: key
+ CLASS( * ), ALLOCATABLE :: val
+ END TYPE dict_entry_type
+
+
+contains
+
+ SUBROUTINE dict_put ( this, key, val )
+ CLASS(dict_entry_type), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: key, val
+ INTEGER :: istat
+ ALLOCATE( this%key, SOURCE=key, STAT=istat )
+ ALLOCATE( this%val, SOURCE=val, STAT=istat )
+ end SUBROUTINE dict_put
+end module mod
+
+program test
+ use mod
+ type(dict_entry_type) :: t
+ call dict_put(t, "foo", 42)
+
+ if (.NOT. allocated(t%key)) call abort()
+ select type (x => t%key)
+ type is (CHARACTER(*))
+ if (x /= "foo") call abort()
+ class default
+ call abort()
+ end select
+ deallocate(t%key)
+
+ if (.NOT. allocated(t%val)) call abort()
+ select type (x => t%val)
+ type is (INTEGER)
+ if (x /= 42) call abort()
+ class default
+ call abort()
+ end select
+ deallocate(t%val)
+end
+
next prev parent reply other threads:[~2016-03-29 12:55 UTC|newest]
Thread overview: 4+ messages / expand[flat|nested] mbox.gz Atom feed top
2016-03-27 19:42 [Patch, Fortran, pr70397, gcc-5, " Dominique d'Humières
2016-03-29 12:55 ` Andre Vehreschild [this message]
2016-03-29 13:34 ` [Patch, Fortran, pr70397, " Paul Richard Thomas
2016-03-29 16:56 ` Andre Vehreschild
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=20160329145524.42d070d4@vepi2 \
--to=vehre@gmx.de \
--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).