gcc/testsuite/gfortran.dg/ptr_func_assign_3.f08

   1 ! { dg-do run }
   2 !
   3 ! Tests corrections to implementation of pointer function assignments.
   4 !
   5 ! Contributed by Mikael Morin  <mikael.morin@sfr.fr>
   6 !
   7 module m
   8   implicit none
   9   type dt
  10     integer :: data
  11   contains
  12     procedure assign_dt
  13     generic :: assignment(=) => assign_dt
  14   end type
  15 contains
  16   subroutine assign_dt(too, from)
  17     class(dt), intent(out) :: too
  18     type(dt), intent(in) :: from
  19     too%data = from%data + 1
  20   end subroutine
  21 end module m
  22
  23 program p
  24   use m
  25   integer, parameter :: b = 3
  26   integer, target    :: a = 2
  27   type(dt), target :: tdt
  28   type(dt) :: sdt = dt(1)
  29
  30   func (arg=b) = 1         ! This was rejected as an unclassifiable statement
  31   if (a /= 1) call abort
  32
  33   func (b + b - 3) = -1
  34   if (a /= -1) call abort
  35
  36   dtfunc () = sdt          ! Check that defined assignment is resolved
  37   if (tdt%data /= 2) call abort
  38 contains
  39   function func(arg) result(r)
  40     integer, pointer :: r
  41     integer :: arg
  42     if (arg == 3) then
  43       r => a
  44     else
  45       r => null()
  46     end if
  47   end function func
  48   function dtfunc() result (r)
  49     type(dt), pointer :: r
  50     r => tdt
  51   end function
  52 end program p