public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc(refs/users/aoliva/heads/testme)] This patch fixes PR96737. See the explanatory comment in the testcase.
@ 2020-08-25 10:15 Alexandre Oliva
0 siblings, 0 replies; only message in thread
From: Alexandre Oliva @ 2020-08-25 10:15 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:c4565031c8dc6b5289e36553e5cd937a91825953
commit c4565031c8dc6b5289e36553e5cd937a91825953
Author: Paul Thomas <pault@gcc.gnu.org>
Date: Sun Aug 23 15:34:27 2020 +0100
This patch fixes PR96737. See the explanatory comment in the testcase.
2020-08-23 Paul Thomas <pault@gcc.gnu.org>
gcc/fortran
PR fortran/96737
* trans-types.c (gfc_get_derived_type): Derived types that are
used in submodules are not compatible with TYPE_CANONICAL from
any of the global namespaces.
gcc/testsuite/
PR fortran/96737
* gfortran.dg/pr96737.f90: New test.
Diff:
---
gcc/fortran/trans-types.c | 6 +-
gcc/testsuite/gfortran.dg/pr96737.f90 | 103 ++++++++++++++++++++++++++++++++++
2 files changed, 107 insertions(+), 2 deletions(-)
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 99844812505..d38aa2865ae 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -2559,14 +2559,16 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
/* If use associated, use the module type for this one. */
if (derived->backend_decl == NULL
- && derived->attr.use_assoc
+ && (derived->attr.use_assoc || derived->attr.used_in_submodule)
&& derived->module
&& gfc_get_module_backend_decl (derived))
goto copy_derived_types;
/* The derived types from an earlier namespace can be used as the
canonical type. */
- if (derived->backend_decl == NULL && !derived->attr.use_assoc
+ if (derived->backend_decl == NULL
+ && !derived->attr.use_assoc
+ && !derived->attr.used_in_submodule
&& gfc_global_ns_list)
{
for (ns = gfc_global_ns_list;
diff --git a/gcc/testsuite/gfortran.dg/pr96737.f90 b/gcc/testsuite/gfortran.dg/pr96737.f90
new file mode 100644
index 00000000000..c92085cc148
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr96737.f90
@@ -0,0 +1,103 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! Test the fix for PR96737 in which the 'TYPE_CANONICAL' was not campatible
+! in the submodule.
+!
+! Contributed by Andre Vehreschild <vehre@gcc.gnu.org>
+!
+module surface_packages
+ implicit none
+
+ type flux_planes
+ integer, allocatable :: normals(:,:)
+ end type
+
+ type package
+ integer id
+ type(flux_planes), allocatable :: surface_fluxes(:)
+ integer, allocatable :: positions(:,:,:,:)
+ end type
+
+ type surfaces
+ type(package), allocatable :: halo_outbox(:,:,:)
+ contains
+ procedure, nopass :: set_halo_outbox
+ procedure, nopass :: get_surface_normal_spacing
+ end type
+
+ type problem_discretization
+ type(surfaces) block_surfaces
+ end type
+
+ interface
+ module subroutine set_halo_outbox(my_halo_outbox)
+ implicit none
+ type(package), intent(in) :: my_halo_outbox(:,:,:)
+ end subroutine
+
+ module subroutine get_surface_normal_spacing
+ end subroutine
+ end interface
+
+end module
+
+submodule(surface_packages) implementation
+ implicit none
+ type(surfaces), save :: singleton[*]
+contains
+
+ module procedure get_surface_normal_spacing
+ integer i, b, d, f
+
+ do i=1,num_images()
+ associate( positions => reshape(i*[5,4,3,2], [2,1,1,2]), normals => reshape(i*[6,6,6], [3,1]) )
+ do b=1,size(singleton[i]%halo_outbox,1)
+ do d=1,size(singleton[i]%halo_outbox,2)
+ do f=1,size(singleton[i]%halo_outbox,3)
+ if ( .not. all([singleton[i]%halo_outbox(b,d,f)%positions == positions]) ) error stop "positions"
+ if ( .not. all([singleton[i]%halo_outbox(b,d,f)%surface_fluxes(1)%normals == normals] ) ) error stop "normals"
+ end do
+ end do
+ end do
+ end associate
+ end do
+ end procedure
+
+ module procedure set_halo_outbox
+ singleton%halo_outbox = my_halo_outbox
+ sync all
+ end procedure
+
+end submodule
+
+program main
+ use surface_packages, only : problem_discretization, package
+ implicit none
+ type(problem_discretization) global_grid
+ type(package), allocatable :: bare(:,:,:)
+ integer i, j, k
+
+ associate( me=>this_image() )
+
+ allocate( bare(me,3,2) )
+
+ do i=1, size(bare,1)
+ bare(i,:,:)%id = i
+ do j=1, size(bare,2)
+ do k=1, size(bare,3)
+ bare(i,j,k)%positions = reshape(me*[5,4,3,2], [2,1,1,2])
+ allocate( bare(i,j,k)%surface_fluxes(1) )
+ bare(i,j,k)%surface_fluxes(1)%normals = reshape(me*[6,6,6], [3,1])
+ end do
+ end do
+ end do
+
+ call global_grid%block_surfaces%set_halo_outbox(bare)
+ call global_grid%block_surfaces%get_surface_normal_spacing
+
+ end associate
+
+ sync all
+ if (this_image()==1) print *,"Test passed"
+end program main
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2020-08-25 10:15 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2020-08-25 10:15 [gcc(refs/users/aoliva/heads/testme)] This patch fixes PR96737. See the explanatory comment in the testcase Alexandre Oliva
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).