view gcc/testsuite/gfortran.dg/ISO_Fortran_binding_10.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_10.c }
!
! Test the fix of PR89843.
!
! Contributed by Reinhold Bader  <Bader@lrz.de>
!
module mod_section_01
  use, intrinsic :: iso_c_binding
  implicit none
  interface
     subroutine si(this, flag, status) bind(c)
       import :: c_float, c_int
       real(c_float) :: this(:,:)
       integer(c_int), value :: flag
       integer(c_int) :: status
     end subroutine si
  end interface
contains
  subroutine sa(this, flag, status) bind(c)
    real(c_float) :: this(:)
    integer(c_int), value :: flag
    integer(c_int) :: status

    status = 0

    select case (flag)
    case (0)
       if (is_contiguous(this)) then
          write(*,*) 'FAIL 1:'
          status = status + 1
       end if
       if (size(this,1) /= 3) then
          write(*,*) 'FAIL 2:',size(this)
          status = status + 1
          goto 10
       end if
       if (maxval(abs(this - [ 1.0, 3.0, 5.0 ])) > 1.0e-6) then
          write(*,*) 'FAIL 3:',abs(this)
          status = status + 1
       end if
  10   continue
   case (1)
      if (size(this,1) /= 3) then
          write(*,*) 'FAIL 4:',size(this)
          status = status + 1
          goto 20
       end if
       if (maxval(abs(this - [ 11.0, 12.0, 13.0 ])) > 1.0e-6) then
          write(*,*) 'FAIL 5:',this
          status = status + 1
       end if
  20   continue
   case (2)
      if (size(this,1) /= 4) then
          write(*,*) 'FAIL 6:',size(this)
          status = status + 1
          goto 30
       end if
      if (maxval(abs(this - [ 2.0, 7.0, 12.0, 17.0 ])) > 1.0e-6) then
          write(*,*) 'FAIL 7:',this
          status = status + 1
       end if
  30   continue
    end select

!    if (status == 0) then
!       write(*,*) 'OK'
!    end if
  end subroutine sa
end module mod_section_01

program section_01
  use mod_section_01
  implicit none
  real(c_float) :: v(5,4)
  integer :: i
  integer :: status

  v = reshape( [ (real(i), i = 1, 20) ], [ 5, 4 ] )
  call si(v, 0, status)
  if (status .ne. 0) stop 1

  call sa(v(1:5:2, 1), 0, status)
  if (status .ne. 0) stop 2

  call si(v, 1, status)
  if (status .ne. 0) stop 3

  call sa(v(1:3, 3), 1, status)
  if (status .ne. 0) stop 4

  call si(v, 2, status)
  if (status .ne. 0) stop 5

  call sa(v(2,1:4), 2, status)
  if (status .ne. 0) stop 6

end program section_01