[Bug fortran/85942] New: ICE with PDTs

[juergen.reuter at desy dot de]

https://gcc.gnu.org/bugzilla/show_bug.cgi?id=85942

            Bug ID: 85942
           Summary: ICE with PDTs
           Product: gcc
           Version: 9.0
            Status: UNCONFIRMED
          Severity: normal
          Priority: P3
         Component: fortran
          Assignee: unassigned at gcc dot gnu.org
          Reporter: juergen.reuter at desy dot de
  Target Milestone: ---

The following code from c.l.f. thread from Sep 28, 2015. ("Vectors on everyday
physics") leads to an ICE with gfortran 9.0, but works without problems with
ifort 18 and 19, cf. code below.
The expected output would be:
  matrix mat_r4: kind =            4
  matrix mat_r4: num cols =            2
  matrix mat_r4: num rows =            3
  a_r4 =    1.000000       2.000000       3.000000       4.000000    
   5.000000       6.000000    
  matrix mat_r8: kind =            8
  matrix mat_r8: num cols =            4
  matrix mat_r8: num rows =            4
  a_r8 =    1.00000000000000        2.00000000000000     
   3.00000000000000        4.00000000000000        5.00000000000000     
   6.00000000000000        7.00000000000000        8.00000000000000     
   9.00000000000000        10.0000000000000        11.0000000000000     
   12.0000000000000        13.0000000000000        14.0000000000000     
   15.0000000000000        16.0000000000000     


Code leading to the segfault:


module mykinds 
  use, intrinsic :: iso_fortran_env, only : i4 => int32, r4 => real32, r8 =>
real64 
  implicit none 
  private
  public :: i4, r4, r8
end module mykinds

module matrix
  use mykinds, only : r4, r8
  implicit none
  private

  type, public :: mat_t(k,c,r)
     private
     !.. type parameters
     integer, kind :: k = r4
     integer, len :: c = 1
     integer, len :: r = 1     
     !.. private by default
     !.. type data
     real(kind=k) :: m_a(c,r)     
  end type mat_t

  interface assignment(=)
     module procedure geta_r4
     module procedure seta_r4
     module procedure geta_r8
     module procedure seta_r8
     !.. additional bindings elided
  end interface assignment(=)

  public :: assignment(=)

contains

  subroutine geta_r4(a_lhs, t_rhs)   
    real(r4), allocatable, intent(out) :: a_lhs(:,:)
    class(mat_t(k=r4,c=*,r=*)), intent(in) :: t_rhs   
    a_lhs = t_rhs%m_a    
    return 
  end subroutine geta_r4

  subroutine geta_r8(a_lhs, t_rhs) 
    real(r8), allocatable, intent(out) :: a_lhs(:,:)
    class(mat_t(k=r8,c=*,r=*)), intent(in) :: t_rhs    
    a_lhs = t_rhs%m_a    
    return 
  end subroutine geta_r8

  subroutine seta_r4(t_lhs, a_rhs) 
    class(mat_t(k=r4,c=*,r=*)), intent(inout) :: t_lhs
    real(r4), intent(in) :: a_rhs(:,:)    
    !.. checks on size elided
    t_lhs%m_a = a_rhs    
    return 
  end subroutine seta_r4

  subroutine seta_r8(t_lhs, a_rhs) 
    class(mat_t(k=r8,c=*,r=*)), intent(inout) :: t_lhs
    real(r8), intent(in) :: a_rhs(:,:)    
    !.. checks on size elided
    t_lhs%m_a = a_rhs    
    return 
  end subroutine seta_r8

end module matrix

program p  
  use mykinds, only : r4, r8
  use matrix, only : mat_t, assignment(=)  
  implicit none  
  type(mat_t(k=r4,c=:,r=:)), allocatable :: mat_r4
  type(mat_t(k=r8,c=:,r=:)), allocatable :: mat_r8  
  real(r4), allocatable :: a_r4(:,:)
  real(r8), allocatable :: a_r8(:,:)  
  integer :: N
  integer :: M
  integer :: i
  integer :: istat  
  N = 2
  M = 3
  allocate( mat_t(k=r4,c=N,r=M) :: mat_r4, stat=istat )
  if ( istat /= 0 ) then
     print *, " error allocating mat_r4: stat = ", istat
     stop
  end if  
  print *, " matrix mat_r4: kind = ", mat_r4%k
  print *, " matrix mat_r4: num cols = ", mat_r4%c
  print *, " matrix mat_r4: num rows = ", mat_r4%r  
  mat_r4 = reshape( [ (real(i, kind=mat_r4%k), i=1,N*M) ], [ N, M ] )  
  a_r4 = mat_r4
  print *, " a_r4 = ", a_r4  
  N = 4
  M = 4
  allocate( mat_t(k=r8,c=N,r=M) :: mat_r8, stat=istat )
  if ( istat /= 0 ) then
     print *, " error allocating mat_r4: stat = ", istat
     stop
  end if  
  print *, " matrix mat_r8: kind = ", mat_r8%k
  print *, " matrix mat_r8: num cols = ", mat_r8%c
  print *, " matrix mat_r8: num rows = ", mat_r8%r  
  mat_r8 = reshape( [ (real(i, kind=mat_r8%k), i=1,N*M) ], [ N, M ] )  
  a_r8 = mat_r8
  print *, " a_r8 = ", a_r8  
  deallocate( mat_r4, stat=istat )
  if ( istat /= 0 ) then
     print *, " error deallocating mat_r4: stat = ", istat
     stop
  end if  
  deallocate( mat_r8, stat=istat )
  if ( istat /= 0 ) then
     print *, " error deallocating mat_r4: stat = ", istat
     stop
  end if  
  stop  
end program p