gcc/testsuite/gfortran.dg/ISO_Fortran_binding_11.f90

   1 ! { dg-do run { target c99_runtime } }
   2 ! { dg-additional-sources ISO_Fortran_binding_11.c }
   3 !
   4 ! Test the fix of PR89846.
   5 !
   6 ! Contributed by Reinhold Bader  <Bader@lrz.de>
   7 !
   8 module mod_subobj_01
   9   use, intrinsic :: iso_c_binding
  10   implicit none
  11   integer, parameter :: nelem = 5
  12   type, bind(c) :: t1
  13      character(c_char) :: n
  14      real(c_float) :: r(2)
  15   end type t1
  16   type, bind(c) :: t2
  17      integer(c_long) :: i
  18      type(t1) :: t1
  19   end type t2
  20   interface
  21      subroutine ti(this, flag) bind(c)
  22        import :: t2, c_int
  23        type(t2) :: this(:)
  24        integer(c_int), value :: flag
  25      end subroutine ti
  26   end interface
  27 contains
  28   subroutine ta0(this) bind(c)
  29     type(t1) :: this(:)
  30     integer :: i, iw, status
  31     status = 0
  32     if (size(this) /= nelem) then
  33        write(*,*) 'FAIL 1: ',size(this)
  34        status = status + 1
  35     end if
  36     iw = 0
  37     do i=1, nelem
  38        if (this(i)%n /= char(i,c_char) .or. this(i)%r(1) /= real(i,c_float) .or. &
  39             this(i)%r(2) /= real(i+1,c_float)) then
  40           iw = iw + 1
  41        end if
  42     end do
  43     if (iw > 0) then
  44        write(*,*) 'FAIL 2: ' ,this
  45        status = status + 1
  46     end if
  47     if (status /= 0) stop 1
  48   end subroutine ta0
  49   subroutine ta1(this) bind(c)
  50     integer(c_long) :: this(:)
  51     integer :: i, status
  52     status = 0
  53     if (size(this) /= nelem) then
  54        write(*,*) 'FAIL 3: ',size(this)
  55        status = status + 1
  56     end if
  57     if (maxval(abs(this - [ (int(i,c_long),i=1,nelem) ])) > 0) then
  58        write(*,*) 'FAIL 4: ' ,this
  59        status = status + 1
  60     end if
  61     if (status /= 0) stop 2
  62   end subroutine ta1
  63 end module mod_subobj_01
  64 program subobj_01
  65   use mod_subobj_01
  66   implicit none
  67   integer :: i
  68
  69   type(t2), allocatable :: o_t2(:)
  70
  71   allocate(o_t2(nelem))
  72   do i=1, nelem
  73      o_t2(i)%t1 = t1( char(i,c_char), [ real(i,c_float), real(i+1,c_float) ] )
  74      o_t2(i)%i = int(i,c_long)
  75   end do
  76
  77   call ti(o_t2,0)
  78   call ti(o_t2,1)
  79
  80 end program subobj_01
  81