1! { dg-do run } 2! Tests the fix for PR59414, comment #3, in which the allocate 3! expressions were not correctly being stripped to provide the 4! vpointer as an lhs to the pointer assignment of the vptr from 5! the SOURCE expression. 6! 7! Contributed by Antony Lewis <antony@cosmologist.info> 8! 9module ObjectLists 10 implicit none 11 12 type :: t 13 integer :: i 14 end type 15 16 type Object_array_pointer 17 class(t), pointer :: p(:) 18 end type 19 20contains 21 22 subroutine AddArray1 (P, Pt) 23 class(t) :: P(:) 24 class(Object_array_pointer) :: Pt 25 26 select type (Pt) 27 class is (Object_array_pointer) 28 if (associated (Pt%P)) deallocate (Pt%P) 29 allocate(Pt%P(1:SIZE(P)), source=P) 30 end select 31 end subroutine 32 33 subroutine AddArray2 (P, Pt) 34 class(t) :: P(:) 35 class(Object_array_pointer) :: Pt 36 37 select type (Pt) 38 type is (Object_array_pointer) 39 if (associated (Pt%P)) deallocate (Pt%P) 40 allocate(Pt%P(1:SIZE(P)), source=P) 41 end select 42 end subroutine 43 44 subroutine AddArray3 (P, Pt) 45 class(t) :: P 46 class(Object_array_pointer) :: Pt 47 48 select type (Pt) 49 class is (Object_array_pointer) 50 if (associated (Pt%P)) deallocate (Pt%P) 51 allocate(Pt%P(1:4), source=P) 52 end select 53 end subroutine 54 55 subroutine AddArray4 (P, Pt) 56 type(t) :: P(:) 57 class(Object_array_pointer) :: Pt 58 59 select type (Pt) 60 class is (Object_array_pointer) 61 if (associated (Pt%P)) deallocate (Pt%P) 62 allocate(Pt%P(1:SIZE(P)), source=P) 63 end select 64 end subroutine 65end module 66 67 use ObjectLists 68 type(Object_array_pointer), pointer :: Pt 69 class(t), pointer :: P(:) 70 71 allocate (P(2), source = [t(1),t(2)]) 72 allocate (Pt, source = Object_array_pointer(NULL())) 73 call AddArray1 (P, Pt) 74 select type (x => Pt%p) 75 type is (t) 76 if (any (x%i .ne. [1,2])) call abort 77 end select 78 deallocate (P) 79 deallocate (pt) 80 81 allocate (P(3), source = [t(3),t(4),t(5)]) 82 allocate (Pt, source = Object_array_pointer(NULL())) 83 call AddArray2 (P, Pt) 84 select type (x => Pt%p) 85 type is (t) 86 if (any (x%i .ne. [3,4,5])) call abort 87 end select 88 deallocate (P) 89 deallocate (pt) 90 91 allocate (Pt, source = Object_array_pointer(NULL())) 92 call AddArray3 (t(6), Pt) 93 select type (x => Pt%p) 94 type is (t) 95 if (any (x%i .ne. [6,6,6,6])) call abort 96 end select 97 deallocate (pt) 98 99 allocate (Pt, source = Object_array_pointer(NULL())) 100 call AddArray4 ([t(7), t(8)], Pt) 101 select type (x => Pt%p) 102 type is (t) 103 if (any (x%i .ne. [7,8])) call abort 104 end select 105 deallocate (pt) 106 end 107 108