gcc/testsuite/gfortran.dg/ptr_func_assign_2.f08

   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 !
   8 module fcn_bar
   9 contains
  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
  17 end module
  18
  19 module 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
  28 contains
  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
  55 end 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
 101 contains
 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
 113 end