gcc/testsuite/gfortran.dg/gomp/class-firstprivate-3.f90

   1 ! { dg-do compile }
   2 ! { dg-prune-output "compilation terminated." }
   3 !
   4 ! FIRSTPRIVATE + class array
   5 !
   6 ! For now: Expected to give "Sorry" for polymorphic arrays.
   7 !
   8 ! Polymorphic arrays are tricky - at least if not allocatable, they become:
   9 !   var.0 = var._data.data
  10 ! which needs to be handled properly.
  11 !
  12 !
  13 program select_type_openmp
  14   use iso_c_binding
  15   !use omp_lib
  16   implicit none
  17   call sub
  18 contains
  19   subroutine sub
  20     integer :: i
  21     class(*), allocatable :: val1(:)
  22     type(c_ptr), allocatable :: val2(:)
  23
  24     allocate(val1, source=[1, 2, 3, 4])
  25     allocate(val2(2:5))
  26     val2 = c_null_ptr
  27
  28     !$OMP PARALLEL firstprivate(val2)
  29       do i = 2, 5
  30         if (c_associated (val2(i))) stop 123
  31       end do
  32     !$OMP END PARALLEL
  33
  34     !$OMP PARALLEL firstprivate(val1)  ! { dg-error "Sorry, polymorphic arrays not yet supported for firstprivate" }
  35       select type (val1)
  36         type is (integer)
  37           if (size(val1) /= 4) stop 33
  38           if (any (val1 /= [1, 2, 3, 4])) stop 4549
  39           val1 = [32,6,48,28]
  40         class default
  41           stop 99
  42       end select
  43       select type (val1)
  44         type is (integer)
  45           if (size(val1) /= 4) stop 33
  46           if (any (val1 /= [32,6,48,28])) stop 4512
  47         class default
  48           stop 99
  49       end select
  50     !$OMP END PARALLEL
  51
  52     select type (val1)
  53       type is (integer)
  54         if (size(val1) /= 4) stop 33
  55         if (any (val1 /= [1, 2, 3, 4])) stop 454
  56       class default
  57         stop 99
  58     end select
  59     print *, "PASS!"
  60   end subroutine
  61 end program select_type_openmp