1! { dg-do run } 2! { dg-options "-fdump-tree-original" } 3! 4! Tests the fixes for three bugs with the same underlying cause. All are regressions 5! that come about because class array elements end up with a different tree type 6! to the class array. In addition, the language specific flag that marks a class 7! container is not being set. 8! 9! PR53876 contributed by Prince Ogunbade <pogos77@hotmail.com> 10! PR54990 contributed by Janus Weil <janus@gcc.gnu.org> 11! PR54992 contributed by Tobias Burnus <burnus@gcc.gnu.org> 12! The two latter bugs were reported by Andrew Benson 13! starting at http://gcc.gnu.org/ml/fortran/2012-10/msg00087.html 14! 15module G_Nodes 16 type :: nc 17 type(tn), pointer :: hostNode 18 end type nc 19 type, extends(nc) :: ncBh 20 end type ncBh 21 type, public, extends(ncBh) :: ncBhStd 22 double precision :: massSeedData 23 end type ncBhStd 24 type, public :: tn 25 class (ncBh), allocatable, dimension(:) :: cBh 26 end type tn 27 type(ncBhStd) :: defaultBhC 28contains 29 subroutine Node_C_Bh_Move(targetNode) 30 implicit none 31 type (tn ), intent(inout) , target :: targetNode 32 class(ncBh), allocatable , dimension(:) :: instancesTemporary 33! These two lines resulted in the wrong result: 34 allocate(instancesTemporary(2),source=defaultBhC) 35 call Move_Alloc(instancesTemporary,targetNode%cBh) 36! These two lines gave the correct result: 37!!deallocate(targetNode%cBh) 38!!allocate(targetNode%cBh(2)) 39 targetNode%cBh(1)%hostNode => targetNode 40 targetNode%cBh(2)%hostNode => targetNode 41 return 42 end subroutine Node_C_Bh_Move 43 function bhGet(self,instance) 44 implicit none 45 class (ncBh), pointer :: bhGet 46 class (tn ), intent(inout), target :: self 47 integer , intent(in ) :: instance 48 bhGet => self%cBh(instance) 49 return 50 end function bhGet 51end module G_Nodes 52 53 call pr53876 54 call pr54990 55 call pr54992 56end 57 58subroutine pr53876 59 IMPLICIT NONE 60 TYPE :: individual 61 integer :: icomp ! Add an extra component to test offset 62 REAL, DIMENSION(:), ALLOCATABLE :: genes 63 END TYPE 64 CLASS(individual), DIMENSION(:), ALLOCATABLE :: indv 65 allocate (indv(2), source = [individual(1, [99,999]), & 66 individual(2, [999,9999])]) 67 CALL display_indv(indv(2)) ! Similarly, reference 2nd element to test offset 68CONTAINS 69 SUBROUTINE display_indv(self) 70 CLASS(individual), INTENT(IN) :: self 71 if (any(self%genes .ne. [999,9999]) )STOP 1 72 END SUBROUTINE 73END 74 75subroutine pr54990 76 implicit none 77 type :: ncBhStd 78 integer :: i 79 end type 80 type, extends(ncBhStd) :: ncBhStde 81 integer :: i2(2) 82 end type 83 type :: tn 84 integer :: i ! Add an extra component to test offset 85 class (ncBhStd), allocatable, dimension(:) :: cBh 86 end type 87 integer :: i 88 type(tn), target :: a 89 allocate (a%cBh(2), source = [(ncBhStde(i*99, [1,2]), i = 1,2)]) 90 select type (q => a%cBh(2)) ! Similarly, reference 2nd element to test offset 91 type is (ncBhStd) 92 STOP 2 93 type is (ncBhStde) 94 if (q%i .ne. 198) STOP 3! This tests that the component really gets the 95 end select ! language specific flag denoting a class type 96end 97 98subroutine pr54992 ! This test remains as the original. 99 use G_Nodes 100 implicit none 101 type (tn), target :: b 102 class(ncBh), pointer :: bh 103 class(ncBh), allocatable, dimension(:) :: t 104 allocate(b%cBh(1),source=defaultBhC) 105 b%cBh(1)%hostNode => b 106! #1 this worked 107 if (loc(b) .ne. loc(b%cBh(1)%hostNode)) STOP 4 108 call Node_C_Bh_Move(b) 109! #2 this worked 110 if (loc(b) .ne. loc(b%cBh(1)%hostNode)) STOP 5 111 if (loc(b) .ne. loc(b%cBh(2)%hostNode)) STOP 6 112! #3 this did not 113 bh => bhGet(b,instance=1) 114 if (loc (b) .ne. loc(bh%hostNode)) STOP 7 115 bh => bhGet(b,instance=2) 116 if (loc (b) .ne. loc(bh%hostNode)) STOP 8 117end 118! { dg-final { scan-tree-dump-times "builtin_free" 12 "original" } } 119