1! { dg-do compile } 2! { dg-options -std=f2003 } 3! 4! Is a copy of ptr_func_assign_1.f08 with checks for F2008 standard. 5! 6! Contributed by Paul Thomas <pault@gcc.gnu.org> 7! 8module fcn_bar 9contains 10 function bar (arg, idx) result (res) 11 integer, pointer :: res 12 integer, target :: arg(:) 13 integer :: idx 14 res => arg (idx) 15 res = 99 16 end function 17end module 18 19module fcn_mydt 20 type mydt 21 integer, allocatable, dimension (:) :: i 22 contains 23 procedure, pass :: create 24 procedure, pass :: delete 25 procedure, pass :: fill 26 procedure, pass :: elem_fill 27 end type 28contains 29 subroutine create (this, sz) 30 class(mydt) :: this 31 integer :: sz 32 if (allocated (this%i)) deallocate (this%i) 33 allocate (this%i(sz)) 34 this%i = 0 35 end subroutine 36 subroutine delete (this) 37 class(mydt) :: this 38 if (allocated (this%i)) deallocate (this%i) 39 end subroutine 40 function fill (this, idx) result (res) 41 integer, pointer :: res(:) 42 integer :: lb, ub 43 class(mydt), target :: this 44 integer :: idx 45 lb = idx 46 ub = lb + size(this%i) - 1 47 res => this%i(lb:ub) 48 end function 49 function elem_fill (this, idx) result (res) 50 integer, pointer :: res 51 class(mydt), target :: this 52 integer :: idx 53 res => this%i(idx) 54 end function 55end module 56 57 use fcn_bar 58 use fcn_mydt 59 integer, target :: a(3) = [1,2,3] 60 integer, pointer :: b 61 integer :: foobar, z, i, ifill(4) = [2, 7, 19, 61], ifill2(2) = [1,2] 62 type(mydt) :: dt 63 foobar (z) = z**2 ! { dg-warning "Obsolescent feature: Statement function" } 64 if (any (a .ne. [1,2,3])) STOP 1 65 66! Assignment to pointer result is after procedure call. 67 foo (a) = 77 ! { dg-error "Pointer procedure assignment" } 68 69! Assignment within procedure applies. 70 b => foo (a) 71 if (b .ne. 99) STOP 2 72 73! Use of index for assignment. 74 bar (a, 2) = 99 ! { dg-error "Pointer procedure assignment" } 75 if (any (a .ne. [99,99,3])) STOP 3 76 77! Make sure that statement function still works! 78 if (foobar (10) .ne. 100) STOP 4 79 80 bar (a, 3) = foobar (9)! { dg-error "Pointer procedure assignment" } 81 if (any (a .ne. [99,99,81])) STOP 5 82 83! Try typebound procedure 84 call dt%create (6) 85 dt%elem_fill (3) = 42 ! { dg-error "Pointer procedure assignment" } 86 if (dt%i(3) .ne. 42) STOP 6 87 dt%elem_fill (3) = 42 + dt%elem_fill (3)! { dg-error "Pointer procedure assignment" } 88 if (dt%i(3) .ne. 84) STOP 7 89 dt%elem_fill (3) = dt%elem_fill (3) - dt%elem_fill (3)! { dg-error "Pointer procedure assignment" } 90 if (dt%i(3) .ne. 0) STOP 8 91! Array is now reset 92 dt%fill (3) = ifill ! { dg-error "Pointer procedure assignment" } 93 dt%fill (1) = [2,1] ! { dg-error "Pointer procedure assignment" } 94 if (any (dt%i .ne. [2,1,ifill])) STOP 9 95 dt%fill (1) = footoo (size (dt%i, 1)) ! { dg-error "Pointer procedure assignment" } 96 if (any (dt%i .ne. [6,5,4,3,2,1])) STOP 10 97 dt%fill (3) = ifill + dt%fill (3) ! { dg-error "Pointer procedure assignment" } 98 if (any (dt%i .ne. [6,5,6,10,21,62])) STOP 11 99 call dt%delete 100 101contains 102 function foo (arg) 103 integer, pointer :: foo 104 integer, target :: arg(:) 105 foo => arg (1) 106 foo = 99 107 end function 108 function footoo (arg) result(res) 109 integer :: arg 110 integer :: res(arg) 111 res = [(arg - i, i = 0, arg - 1)] 112 end function 113end 114