test/Semantics/collectives05.f90

! RUN: %python %S/test_errors.py %s %flang_fc1
! XFAIL: *
! This test checks for semantic errors in co_reduce subroutine calls based on
! the co_reduce interface defined in section 16.9.49 of the Fortran 2018 standard.
! To Do: add co_reduce to the list of intrinsics

module foo_m
  implicit none

  type foo_t
    integer :: n=0
  contains
    procedure :: derived_type_op
    generic :: operator(+) => derived_type_op
  end type

contains

  pure function derived_type_op(lhs, rhs) result(lhs_op_rhs)
    class(foo_t), intent(in) :: lhs, rhs
    type(foo_t) lhs_op_rhs
    lhs_op_rhs%n = lhs%n + rhs%n
  end function

end module foo_m

program main
  use foo_m, only : foo_t
  implicit none

  type(foo_t) foo
  class(foo_t), allocatable :: polymorphic
  integer i, status, integer_array(1)
  real x
  real vector(1)
  real array(1,1,1, 1,1,1, 1,1,1, 1,1,1, 1,1,1)
  character(len=1) string, message, character_array(1)
  integer coindexed[*]
  logical bool

  ! correct calls, should produce no errors
  call co_reduce(i,      int_op)
  call co_reduce(i,      int_op,                            status)
  call co_reduce(i,      int_op,                            stat=status)
  call co_reduce(i,      int_op,                                         errmsg=message)
  call co_reduce(i,      int_op,                            stat=status, errmsg=message)
  call co_reduce(i,      int_op,            result_image=1, stat=status, errmsg=message)
  call co_reduce(i,      operation=int_op,  result_image=1, stat=status, errmsg=message)
  call co_reduce(a=i,    operation=int_op,  result_image=1, stat=status, errmsg=message)
  call co_reduce(array,  operation=real_op, result_image=1, stat=status, errmsg=message)
  call co_reduce(vector, operation=real_op, result_image=1, stat=status, errmsg=message)
  call co_reduce(string, operation=char_op, result_image=1, stat=status, errmsg=message)
  call co_reduce(foo,    operation=left,    result_image=1, stat=status, errmsg=message)

  call co_reduce(result_image=1, operation=left,     a=foo, errmsg=message, stat=status)

  allocate(foo_t :: polymorphic)

  ! Test all statically verifiable semantic requirements on co_reduce arguments
  ! Note: We cannot check requirements that relate to "corresponding references." 
  ! References can correspond only if they execute on differing images.  A code that
  ! executes in a single image might be standard-conforming even if the same code
  ! executing in multiple images is not.

  ! argument 'a' cannot be polymorphic
  !ERROR: to be determined
  call co_reduce(polymorphic, derived_type_op)

  ! argument 'a' cannot be coindexed
  !ERROR: (message to be determined)
  call co_reduce(coindexed[1], int_op)

  ! argument 'a' is intent(inout)
  !ERROR: (message to be determined)
  call co_reduce(i + 1, int_op)

  ! operation must be a pure function
  !ERROR: (message to be determined)
  call co_reduce(i, operation=not_pure)

  ! operation must have exactly two arguments
  !ERROR: (message to be determined)
  call co_reduce(i, too_many_args)

  ! operation result must be a scalar
  !ERROR: (message to be determined)
  call co_reduce(i, array_result)

  ! operation result must be non-allocatable
  !ERROR: (message to be determined)
  call co_reduce(i, allocatable_result)

  ! operation result must be non-pointer
  !ERROR: (message to be determined)
  call co_reduce(i, pointer_result)

  ! operation's arguments must be scalars
  !ERROR: (message to be determined)
  call co_reduce(i, array_args)

  ! operation arguments must be non-allocatable
  !ERROR: (message to be determined)
  call co_reduce(i, allocatable_args)

  ! operation arguments must be non-pointer
  !ERROR: (message to be determined)
  call co_reduce(i, pointer_args)

  ! operation arguments must be non-polymorphic
  !ERROR: (message to be determined)
  call co_reduce(i, polymorphic_args)

  ! operation: type of 'operation' result and arguments must match type of argument 'a'
  !ERROR: (message to be determined)
  call co_reduce(i, real_op)

  ! operation: kind type parameter of 'operation' result and arguments must match kind type parameter of argument 'a'
  !ERROR: (message to be determined)
  call co_reduce(x, double_precision_op)

  ! arguments must be non-optional
  !ERROR: (message to be determined)
  call co_reduce(i, optional_args)

  ! if one argument is asynchronous, the other must be also
  !ERROR: (message to be determined)
  call co_reduce(i, asynchronous_mismatch)

  ! if one argument is a target, the other must be also
  !ERROR: (message to be determined)
  call co_reduce(i, target_mismatch)

  ! if one argument has the value attribute, the other must have it also
  !ERROR: (message to be determined)
  call co_reduce(i, value_mismatch)

  ! result_image argument must be an integer scalar
  !ERROR: to be determined
  call co_reduce(i, int_op, result_image=integer_array)

  ! result_image argument must be an integer
  !ERROR: to be determined
  call co_reduce(i, int_op, result_image=bool)

  ! stat not allowed to be coindexed
  !ERROR: to be determined
  call co_reduce(i, int_op, stat=coindexed[1])

  ! stat argument must be an integer scalar
  !ERROR: to be determined
  call co_reduce(i, int_op, result_image=1, stat=integer_array)

  ! stat argument has incorrect type
  !ERROR: Actual argument for 'stat=' has bad type 'CHARACTER(KIND=1,LEN=1_8)'
  call co_reduce(i, int_op, result_image=1, string)

  ! stat argument is intent(out)
  !ERROR: to be determined
  call co_reduce(i, int_op, result_image=1, stat=1+1)

  ! errmsg argument must not be coindexed
  !ERROR: to be determined
  call co_reduce(i, int_op, result_image=1, stat=status, errmsg=conindexed_string[1])

  ! errmsg argument must be a character scalar
  !ERROR: to be determined
  call co_reduce(i, int_op, result_image=1, stat=status, errmsg=character_array)

  ! errmsg argument must be a character
  !ERROR: to be determined
  call co_reduce(i, int_op, result_image=1, stat=status, errmsg=i)

  ! errmsg argument is intent(inout)
  !ERROR: to be determined
  call co_reduce(i, int_op, result_image=1, stat=status, errmsg="literal constant")

  ! too many arguments to the co_reduce() call
  !ERROR: too many actual arguments for intrinsic 'co_reduce'
  call co_reduce(i, int_op, result_image=1, stat=status, errmsg=message, 3.4)

  ! non-existent keyword argument
  !ERROR: unknown keyword argument to intrinsic 'co_reduce'
  call co_reduce(fake=3.4)

contains

  pure function left(lhs, rhs) result(lhs_op_rhs)
    type(foo_t), intent(in)  :: lhs, rhs
    type(foo_t) :: lhs_op_rhs
    lhs_op_rhs = lhs
  end function

  pure function char_op(lhs, rhs) result(lhs_op_rhs)
    character(len=1), intent(in)  :: lhs, rhs
    character(len=1) :: lhs_op_rhs
    lhs_op_rhs = min(lhs, rhs)
  end function

  pure function real_op(lhs, rhs) result(lhs_op_rhs)
    real, intent(in) :: lhs, rhs
    real :: lhs_op_rhs
    lhs_op_rhs = lhs + rhs
  end function

  pure function double_precision_op(lhs, rhs) result(lhs_op_rhs)
    integer, parameter :: double = kind(1.0D0)
    real(double), intent(in) :: lhs, rhs
    real(double) lhs_op_rhs
    lhs_op_rhs = lhs + rhs
  end function

  pure function int_op(lhs, rhs) result(lhs_op_rhs)
    integer, intent(in) :: lhs, rhs
    integer :: lhs_op_rhs
    lhs_op_rhs = lhs + rhs
  end function

  function not_pure(lhs, rhs) result(lhs_op_rhs)
    integer, intent(in) :: lhs, rhs
    integer :: lhs_op_rhs
    lhs_op_rhs = lhs + rhs
  end function

  pure function too_many_args(lhs, rhs, foo) result(lhs_op_rhs)
    integer, intent(in) :: lhs, rhs, foo
    integer lhs_op_rhs
    lhs_op_rhs = lhs + rhs
  end function

  pure function array_result(lhs, rhs)
    integer, intent(in) :: lhs, rhs
    integer array_result(1)
    array_result = lhs + rhs
  end function

  pure function allocatable_result(lhs, rhs)
    integer, intent(in) :: lhs, rhs
    integer, allocatable :: allocatable_result
    allocatable_result = lhs + rhs
  end function

  pure function pointer_result(lhs, rhs)
    integer, intent(in) :: lhs, rhs
    integer, pointer :: pointer_result
    allocate(pointer_result, source=lhs + rhs )
  end function

  pure function array_args(lhs, rhs)
    integer, intent(in) :: lhs(1), rhs(1)
    integer array_args
    array_args = lhs(1) + rhs(1)
  end function

  pure function allocatable_args(lhs, rhs) result(lhs_op_rhs)
    integer, intent(in), allocatable :: lhs, rhs
    integer lhs_op_rhs
    lhs_op_rhs = lhs + rhs
  end function

  pure function pointer_args(lhs, rhs) result(lhs_op_rhs)
    integer, intent(in), pointer :: lhs, rhs
    integer lhs_op_rhs
    lhs_op_rhs = lhs + rhs
  end function

  pure function polymorphic_args(lhs, rhs) result(lhs_op_rhs)
    class(foo_t), intent(in) :: lhs, rhs
    type(foo_t) lhs_op_rhs
    lhs_op_rhs%n = lhs%n + rhs%n
  end function

  pure function optional_args(lhs, rhs) result(lhs_op_rhs)
    integer, intent(in), optional :: lhs, rhs
    integer lhs_op_rhs
    if (present(lhs) .and. present(rhs)) then
      lhs_op_rhs = lhs + rhs
    else
      lhs_op_rhs = 0
    end if
  end function

  pure function target_mismatch(lhs, rhs) result(lhs_op_rhs)
    integer, intent(in), target  :: lhs
    integer, intent(in) :: rhs
    integer lhs_op_rhs
    lhs_op_rhs = lhs + rhs
  end function

  pure function value_mismatch(lhs, rhs) result(lhs_op_rhs)
    integer, intent(in), value:: lhs
    integer, intent(in) :: rhs
    integer lhs_op_rhs
    lhs_op_rhs = lhs + rhs
  end function

  pure function asynchronous_mismatch(lhs, rhs) result(lhs_op_rhs)
    integer, intent(in), asynchronous:: lhs
    integer, intent(in) :: rhs
    integer lhs_op_rhs
    lhs_op_rhs = lhs + rhs
  end function

end program