gcc/testsuite/gfortran.dg/implicit_pure_5.f90

   1 ! { dg-do run }
   2 ! { dg-additional-sources implicit_pure_5.c }
   3 ! PR fortran/96018 - a wrongly marked implicit_pure
   4 ! function caused wrong code.
   5 module wrapper
   6   use, intrinsic :: iso_c_binding, only : c_int
   7   implicit none
   8   integer(kind=c_int), bind(C) :: num_calls
   9 contains
  10
  11   integer function call_side_effect() result(ierr)
  12     call side_effect(ierr)
  13   end function call_side_effect
  14
  15   integer function inner_3d(array) result(ierr)
  16     real, intent(in) :: array(:,:,:)
  17     integer dimensions(3)
  18     dimensions = shape(array)
  19     ierr = call_side_effect()
  20   end function inner_3d
  21
  22   integer function inner_4d(array) result(ierr)
  23     real, intent(in) :: array(:,:,:,:)
  24     integer dimensions(4)
  25     dimensions = shape(array)
  26     ierr = call_side_effect()
  27   end function inner_4d
  28
  29   subroutine write_3d()
  30     real :: array(1,1,1)
  31     integer ierr
  32     ierr = inner_3d(array)
  33     ierr = call_side_effect()
  34   end subroutine write_3d
  35
  36   subroutine write_4d()
  37     real array(1,1,1,1)
  38     integer ierr
  39     ierr = inner_4d(array)
  40     ierr = call_side_effect()
  41   end subroutine write_4d
  42
  43   subroutine side_effect(ierr)
  44     integer, intent(out) :: ierr        ! Error code
  45     interface
  46        integer(c_int) function side_effect_c() bind(C,name='side_effect_c')
  47          use, intrinsic :: iso_c_binding, only: c_int
  48        end function side_effect_c
  49     end interface
  50     ierr = side_effect_c()
  51   end subroutine side_effect
  52
  53 end module wrapper
  54
  55 program self_contained
  56   use wrapper
  57   implicit none
  58   call write_3d()
  59   if (num_calls /= 2) stop 1
  60   call write_4d()
  61   if (num_calls /= 4) stop 2
  62 end program self_contained
  63