From c4565031c8dc6b5289e36553e5cd937a91825953 Mon Sep 17 00:00:00 2001
From: Paul Thomas <pault@gcc.gnu.org>
Date: Sun, 23 Aug 2020 15:34:27 +0100
Subject: [PATCH] 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.
---
 gcc/fortran/trans-types.c             |   6 +-
 gcc/testsuite/gfortran.dg/pr96737.f90 | 103 ++++++++++++++++++++++++++
 2 files changed, 107 insertions(+), 2 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/pr96737.f90

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