view gcc/testsuite/gfortran.dg/ptr_func_assign_3.f08 @ 144:8f4e72ab4e11

fix segmentation fault caused by nothing next cur_op to end
author Takahiro SHIMIZU <anatofuz@cr.ie.u-ryukyu.ac.jp>
date Sun, 23 Dec 2018 21:23:56 +0900
parents 84e7813d76e9
children
line wrap: on
line source

! { dg-do run }
!
! Tests corrections to implementation of pointer function assignments.
!
! Contributed by Mikael Morin  <mikael.morin@sfr.fr>
!
module m
  implicit none
  type dt
    integer :: data
  contains
    procedure assign_dt
    generic :: assignment(=) => assign_dt
  end type
contains
  subroutine assign_dt(too, from)
    class(dt), intent(out) :: too
    type(dt), intent(in) :: from
    too%data = from%data + 1
  end subroutine
end module m

program p
  use m
  integer, parameter :: b = 3
  integer, target    :: a = 2
  type(dt), target :: tdt
  type(dt) :: sdt = dt(1)

  func (arg=b) = 1         ! This was rejected as an unclassifiable statement
  if (a /= 1) STOP 1

  func (b + b - 3) = -1
  if (a /= -1) STOP 2

  dtfunc () = sdt          ! Check that defined assignment is resolved
  if (tdt%data /= 2) STOP 3
contains
  function func(arg) result(r)
    integer, pointer :: r
    integer :: arg
    if (arg == 3) then
      r => a
    else
      r => null()
    end if
  end function func
  function dtfunc() result (r)
    type(dt), pointer :: r
    r => tdt
  end function
end program p