view gcc/testsuite/gfortran.dg/ISO_Fortran_binding_11.f90 @ 152:2b5abeee2509

update gcc11
author anatofuz
date Mon, 25 May 2020 07:50:57 +0900
parents 1830386684a0
children
line wrap: on
line source

! { dg-do run { target c99_runtime } }
! { dg-additional-sources ISO_Fortran_binding_11.c }
!
! Test the fix of PR89846.
!
! Contributed by Reinhold Bader  <Bader@lrz.de>
!
module mod_subobj_01
  use, intrinsic :: iso_c_binding
  implicit none
  integer, parameter :: nelem = 5
  type, bind(c) :: t1
     character(c_char) :: n
     real(c_float) :: r(2)
  end type t1
  type, bind(c) :: t2
     integer(c_long) :: i
     type(t1) :: t1
  end type t2
  interface
     subroutine ti(this, flag) bind(c)
       import :: t2, c_int
       type(t2) :: this(:)
       integer(c_int), value :: flag
     end subroutine ti
  end interface
contains
  subroutine ta0(this) bind(c)
    type(t1) :: this(:)
    integer :: i, iw, status
    status = 0
    if (size(this) /= nelem) then
       write(*,*) 'FAIL 1: ',size(this)
       status = status + 1
    end if
    iw = 0
    do i=1, nelem
       if (this(i)%n /= char(i,c_char) .or. this(i)%r(1) /= real(i,c_float) .or. &
            this(i)%r(2) /= real(i+1,c_float)) then
          iw = iw + 1
       end if
    end do
    if (iw > 0) then
       write(*,*) 'FAIL 2: ' ,this
       status = status + 1
    end if
    if (status /= 0) stop 1
  end subroutine ta0
  subroutine ta1(this) bind(c)
    integer(c_long) :: this(:)
    integer :: i, status
    status = 0
    if (size(this) /= nelem) then
       write(*,*) 'FAIL 3: ',size(this)
       status = status + 1
    end if
    if (maxval(abs(this - [ (int(i,c_long),i=1,nelem) ])) > 0) then
       write(*,*) 'FAIL 4: ' ,this
       status = status + 1
    end if
    if (status /= 0) stop 2
  end subroutine ta1
end module mod_subobj_01
program subobj_01
  use mod_subobj_01
  implicit none
  integer :: i

  type(t2), allocatable :: o_t2(:)

  allocate(o_t2(nelem))
  do i=1, nelem
     o_t2(i)%t1 = t1( char(i,c_char), [ real(i,c_float), real(i+1,c_float) ] )
     o_t2(i)%i = int(i,c_long)
  end do

  call ti(o_t2,0)
  call ti(o_t2,1)

end program subobj_01