gcc/testsuite/gfortran.dg/associate_40.f90

   1 ! { dg-do compile }
   2 ! { dg-options "-fdump-tree-original" }
   3 !
   4 ! Test the fix for the second part of PR87359 in which the reallocation on
   5 ! assignment for components of associate names was disallowed by r264358.
   6 ! -fcheck-all exposed the mismatch in array shapes. The deallocations at
   7 ! the end of the main program are there to make sure that valgrind does
   8 ! not report an memory leaks.
   9 !
  10 ! Contributed by Juergen Reuter  <juergen.reuter@desy.de>
  11 !
  12 module phs_fks
  13   implicit none
  14   private
  15   public :: phs_identifier_t
  16   public :: phs_fks_t
  17   type :: phs_identifier_t
  18      integer, dimension(:), allocatable :: contributors
  19   contains
  20     procedure :: init => phs_identifier_init
  21   end type phs_identifier_t
  22
  23   type :: phs_fks_t
  24      type(phs_identifier_t), dimension(:), allocatable :: phs_identifiers
  25   end type phs_fks_t
  26 contains
  27
  28   subroutine phs_identifier_init &
  29      (phs_id, contributors)
  30      class(phs_identifier_t), intent(out) :: phs_id
  31      integer, intent(in), dimension(:) :: contributors
  32      allocate (phs_id%contributors (size (contributors)))
  33      phs_id%contributors = contributors
  34    end subroutine phs_identifier_init
  35
  36 end module phs_fks
  37
  38 !!!!!
  39
  40 module instances
  41   use phs_fks
  42   implicit none
  43   private
  44   public :: process_instance_t
  45
  46   type :: nlo_event_deps_t
  47      type(phs_identifier_t), dimension(:), allocatable :: phs_identifiers
  48   end type nlo_event_deps_t
  49
  50   type :: process_instance_t
  51      type(phs_fks_t), pointer :: phs => null ()
  52      type(nlo_event_deps_t) :: event_deps
  53    contains
  54      procedure :: init => process_instance_init
  55      procedure :: setup_real_event_kinematics => pi_setup_real_event_kinematics
  56   end type process_instance_t
  57
  58 contains
  59
  60   subroutine process_instance_init (instance)
  61     class(process_instance_t), intent(out), target :: instance
  62     integer :: i
  63     integer :: i_born, i_real
  64     allocate (instance%phs)
  65   end subroutine process_instance_init
  66
  67   subroutine pi_setup_real_event_kinematics (process_instance)
  68     class(process_instance_t), intent(inout) :: process_instance
  69     integer :: i_real, i
  70     associate (event_deps => process_instance%event_deps)
  71        i_real = 2
  72        associate (phs => process_instance%phs)
  73           allocate (phs%phs_identifiers (3))
  74           call phs%phs_identifiers(1)%init ([1])
  75           call phs%phs_identifiers(2)%init ([1,2])
  76           call phs%phs_identifiers(3)%init ([1,2,3])
  77           process_instance%event_deps%phs_identifiers = phs%phs_identifiers  ! Error: mismatch in array shapes.
  78        end associate
  79     end associate
  80   end subroutine pi_setup_real_event_kinematics
  81
  82 end module instances
  83
  84 !!!!!
  85
  86 program main
  87   use instances, only: process_instance_t
  88   implicit none
  89   type(process_instance_t), allocatable, target :: process_instance
  90   allocate (process_instance)
  91   call process_instance%init ()
  92   call process_instance%setup_real_event_kinematics ()
  93   if (associated (process_instance%phs)) deallocate (process_instance%phs)
  94   if (allocated (process_instance)) deallocate (process_instance)
  95 end program main
  96 ! { dg-final { scan-tree-dump-times "__builtin_realloc" 2 "original" } }