gcc/testsuite/gfortran.dg/ptr_func_assign_1.f08

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