OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

This patch fixes PR96737. See the explanatory comment in the testcase.

Browse Source 
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.
This commit is contained in:
Paul Thomas 2020-08-23 15:34:27 +01:00
parent e769f9707d
commit c4565031c8
2 changed files with 107 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/fortran/trans-types.c
View File

@ -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;

103
gcc/testsuite/gfortran.dg/pr96737.f90 Normal file
View File

@ -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