! { dg-do run }
!
! PR fortran/99171
!
! Check dummy procedure arguments, especially optional ones
!
module m
  use iso_c_binding
  implicit none (type, external)
  integer :: cnt
  integer :: cnt2
contains
  subroutine proc()
    cnt = cnt + 1
  end subroutine

  subroutine proc2()
    cnt2 = cnt2 + 1
  end subroutine

  subroutine check(my_proc)
    procedure(proc) :: my_proc
    cnt = 42
    call my_proc()
    if (cnt /= 43) stop 1

    !$omp parallel
      call my_proc()
    !$omp end parallel
    if (cnt <= 43) stop 2 
  end

  subroutine check_opt(my_proc)
    procedure(proc), optional :: my_proc
    logical :: is_present
    is_present = present(my_proc)
    cnt = 55
    if (present (my_proc)) then
      call my_proc()
      if (cnt /= 56) stop 3
    endif

    !$omp parallel
      if (is_present .neqv. present (my_proc)) stop 4
      if (present (my_proc)) then
        call my_proc()
        if (cnt <= 56) stop 5
      end if
    !$omp end parallel
    if (is_present) then
      if (cnt <= 56) stop 6
    else if (cnt /= 55) then
      stop 7
    end if
  end

  subroutine check_ptr(my_proc)
    procedure(proc), pointer :: my_proc
    logical :: is_assoc
    integer :: mycnt
    is_assoc = associated (my_proc)

    cnt = 10
    cnt2 = 20
    if (associated (my_proc)) then
      call my_proc()
      if (cnt /= 11 .or. cnt2 /= 20) stop 8
    endif

    !$omp parallel
      if (is_assoc .neqv. associated (my_proc)) stop 9
      if (associated (my_proc)) then
        if (.not. associated (my_proc, proc)) stop 10
        call my_proc()
        if (cnt <= 11 .or. cnt2 /= 20) stop 11
      else if (cnt /= 10 .or. cnt2 /= 20) then
        stop 12
      end if
    !$omp end parallel
    if (is_assoc .neqv. associated (my_proc)) stop 13
    if (associated (my_proc)) then
      if (cnt <= 11 .or. cnt2 /= 20) stop 14
    else if (is_assoc .and. (cnt /= 11 .or. cnt2 /= 20)) then
      stop 15
    end if

    cnt = 30
    cnt2 = 40
    mycnt = 0
    !$omp parallel shared(mycnt)
      !$omp critical
         my_proc => proc2
         if (.not.associated (my_proc, proc2)) stop 17
         mycnt = mycnt + 1
         call my_proc()
         if (cnt2 /= 40 + mycnt .or. cnt /= 30) stop 18
      !$omp end critical
    !$omp end parallel
    if (.not.associated (my_proc, proc2)) stop 19
    if (cnt2 /= 40 + mycnt .or. cnt /= 30) stop 20
  end

  subroutine check_ptr_opt(my_proc)
    procedure(proc), pointer, optional :: my_proc
    logical :: is_assoc, is_present
    integer :: mycnt
    is_assoc = .false.
    is_present = present(my_proc)

    cnt = 10
    cnt2 = 20
    if (present (my_proc)) then
      is_assoc = associated (my_proc)
      if (associated (my_proc)) then
        call my_proc()
        if (cnt /= 11 .or. cnt2 /= 20) stop 21
      endif
   end if

    !$omp parallel
      if (is_present .neqv. present (my_proc)) stop 22
      if (present (my_proc)) then
        if (is_assoc .neqv. associated (my_proc)) stop 23
        if (associated (my_proc)) then
          if (.not. associated (my_proc, proc)) stop 24
          call my_proc()
          if (cnt <= 11 .or. cnt2 /= 20) stop 25
        else if (cnt /= 10 .or. cnt2 /= 20) then
          stop 26
        end if
      end if
    !$omp end parallel
    if (present (my_proc)) then
      if (is_assoc .neqv. associated (my_proc)) stop 27
      if (associated (my_proc)) then
        if (cnt <= 11 .or. cnt2 /= 20) stop 28
      else if (is_assoc .and. (cnt /= 11 .or. cnt2 /= 20)) then
        stop 29
      end if
    end if

    cnt = 30
    cnt2 = 40
    mycnt = 0
    !$omp parallel shared(mycnt)
      if (is_present .neqv. present (my_proc)) stop 30
      !$omp critical
         if (present (my_proc)) then
           my_proc => proc2
           if (.not.associated (my_proc, proc2)) stop 31
           mycnt = mycnt + 1
           call my_proc()
           if (cnt2 /= 40 + mycnt .or. cnt /= 30) stop 32
         end if
      !$omp end critical
    !$omp end parallel
    if (present (my_proc)) then
      if (.not.associated (my_proc, proc2)) stop 33
      if (cnt2 /= 40 + mycnt .or. cnt /= 30) stop 34
    end if
  end

  ! ----------------------

  subroutine cfun_check(my_cfun)
    type(c_funptr) :: my_cfun
    procedure(proc), pointer :: pptr
    logical :: has_cfun

    has_cfun = c_associated (my_cfun)
    pptr => null()
    cnt = 42
    call c_f_procpointer (my_cfun, pptr)
    if (has_cfun) then
      call pptr()
      if (cnt /= 43) stop 35
    end if

    pptr => null()
    !$omp parallel
      if (has_cfun .neqv. c_associated (my_cfun)) stop 36
      !$omp critical
        call c_f_procpointer (my_cfun, pptr)
      !$omp end critical
      if (has_cfun) then
        call pptr()
        if (cnt <= 43) stop 37
      else
        if (associated (pptr)) stop 38
      end if
    !$omp end parallel
  end

  subroutine cfun_check_opt(my_cfun)
    type(c_funptr), optional :: my_cfun
    procedure(proc), pointer :: pptr
    logical :: has_cfun, is_present

    has_cfun = .false.
    is_present = present (my_cfun)
    if (is_present) has_cfun = c_associated (my_cfun)

    cnt = 1
    pptr => null()
    !$omp parallel
      if (is_present .neqv. present (my_cfun)) stop 39
      if (is_present) then
        if (has_cfun .neqv. c_associated (my_cfun, c_funloc(proc))) stop 40
        !$omp critical
          call c_f_procpointer (my_cfun, pptr)
        !$omp end critical
        if (has_cfun) then
          call pptr()
          if (cnt <= 1) stop 41
        else
          if (associated (pptr)) stop 42
        end if
      end if
    !$omp end parallel
  end

  subroutine cfun_check_ptr(my_cfun)
    type(c_funptr), pointer :: my_cfun
    procedure(proc), pointer :: pptr
    logical :: has_cfun, is_assoc

    has_cfun = .false.
    is_assoc = associated (my_cfun)
    if (is_assoc) has_cfun = c_associated (my_cfun)

    cnt = 1
    pptr => null()
    !$omp parallel
      if (is_assoc .neqv. associated (my_cfun)) stop 43
      if (is_assoc) then
        if (has_cfun .neqv. c_associated (my_cfun, c_funloc(proc))) stop 44
        !$omp critical
          call c_f_procpointer (my_cfun, pptr)
        !$omp end critical
        if (has_cfun) then
          call pptr()
          if (cnt <= 1) stop 45
        else
          if (associated (pptr)) stop 46
        end if
      end if
    !$omp end parallel

    cnt = 42
    cnt2 = 1
    pptr => null()
    !$omp parallel
      if (is_assoc .neqv. associated (my_cfun)) stop 47
      if (is_assoc) then
        !$omp critical
          my_cfun = c_funloc (proc2)
          call c_f_procpointer (my_cfun, pptr)
        !$omp end critical
        if (.not. associated (pptr, proc2)) stop 48
        if (.not. c_associated (my_cfun, c_funloc(proc2))) stop 49
        call pptr()
        if (cnt /= 42 .or. cnt2 <= 1) stop 50
      end if
    !$omp end parallel
    if (is_assoc) then
      if (.not. associated (pptr, proc2)) stop 51
      if (.not. c_associated (my_cfun, c_funloc(proc2))) stop 52
    else
      if (associated (pptr)) stop 53
    end if
  end

  subroutine cfun_check_ptr_opt (my_cfun)
    type(c_funptr), pointer, optional :: my_cfun
    procedure(proc), pointer :: pptr
    logical :: is_present, has_cfun, is_assoc

    has_cfun = .false.
    is_assoc = .false.
    is_present = present (my_cfun)
    if (is_present) then
      is_assoc = associated (my_cfun)
      if (is_assoc) has_cfun = c_associated (my_cfun)
    end if

    cnt = 1
    pptr => null()
    !$omp parallel
      if (is_present .neqv. present (my_cfun)) stop 54
      if (is_present) then
        if (is_assoc .neqv. associated (my_cfun)) stop 55
        if (is_assoc) then
          if (has_cfun .neqv. c_associated (my_cfun, c_funloc(proc))) stop 56
          !$omp critical
            call c_f_procpointer (my_cfun, pptr)
          !$omp end critical
          if (has_cfun) then
            call pptr()
            if (cnt <= 1) stop 57
          else
            if (associated (pptr)) stop 58
          end if
        end if
      end if
    !$omp end parallel

    cnt = 42
    cnt2 = 1
    pptr => null()
    !$omp parallel
      if (is_present .neqv. present (my_cfun)) stop 59
      if (is_present) then
        if (is_assoc .neqv. associated (my_cfun)) stop 60
        if (is_assoc) then
          !$omp critical
            my_cfun = c_funloc (proc2)
            call c_f_procpointer (my_cfun, pptr)
          !$omp end critical
          if (.not. associated (pptr, proc2)) stop 61
          if (.not. c_associated (my_cfun, c_funloc(proc2))) stop 62
          call pptr()
          if (cnt /= 42 .or. cnt2 <= 1) stop 63
        end if
      end if
    !$omp end parallel
    if (is_present .and. is_assoc) then
      if (.not. associated (pptr, proc2)) stop 64
      if (.not. c_associated (my_cfun, c_funloc(proc2))) stop 65
    else
      if (associated (pptr)) stop 66
    end if
  end
end module m



program main
  use m
  implicit none (type, external)
  procedure(proc), pointer :: pptr
  type(c_funptr), target :: cfun
  type(c_funptr), pointer :: cfun_ptr

  call check(proc)
  call check_opt()
  call check_opt(proc)

  pptr => null()
  call check_ptr(pptr)
  pptr => proc
  call check_ptr(pptr)

  call check_ptr_opt()
  pptr => null()
  call check_ptr_opt(pptr)
  pptr => proc
  call check_ptr_opt(pptr)

  ! -------------------
  pptr => null()

  cfun = c_funloc (pptr)
  call cfun_check(cfun)

  cfun = c_funloc (proc)
  call cfun_check(cfun)

  call cfun_check_opt()

  cfun = c_funloc (pptr)
  call cfun_check_opt(cfun)

  cfun = c_funloc (proc)
  call cfun_check_opt(cfun)

  ! - - - -
  cfun_ptr => null()
  call cfun_check_ptr (cfun_ptr)

  cfun = c_funloc (proc)
  cfun_ptr => cfun
  call cfun_check_ptr (cfun_ptr)

  ! - - - -
  call cfun_check_ptr_opt ()

  cfun_ptr => null()
  call cfun_check_ptr_opt (cfun_ptr)

  cfun = c_funloc (proc)
  cfun_ptr => cfun
  call cfun_check_ptr_opt (cfun_ptr)
end program