gcc/testsuite/gfortran.dg/c_ptr_tests_16.f90

   1 ! { dg-do compile }
   2 ! { dg-options "-fdump-tree-optimized -O" }
   3 !
   4 ! PR fortran/46974
   5
   6 program test
   7   use ISO_C_BINDING
   8   implicit none
   9   type(c_ptr) :: m
  10   integer(c_intptr_t) :: a
  11   integer(transfer(transfer(4_c_intptr_t, c_null_ptr),1_c_intptr_t)) :: b
  12   a = transfer (transfer("ABCE", m), 1_c_intptr_t)
  13   print '(z8)', a
  14   if (     int(z'45434241') /= a  &
  15      .and. int(z'41424345') /= a  &
  16      .and. int(z'4142434500000000',kind=8) /= a) &
  17     call i_do_not_exist()
  18 end program test
  19
  20 ! Examples contributed by Steve Kargl and James Van Buskirk
  21
  22 subroutine bug1
  23    use ISO_C_BINDING
  24    implicit none
  25    type(c_ptr) :: m
  26    type mytype
  27      integer a, b, c
  28    end type mytype
  29    type(mytype) x
  30    print *, transfer(32512, x)  ! Works.
  31    print *, transfer(32512, m)  ! Caused ICE.
  32 end subroutine bug1
  33
  34 subroutine bug6
  35    use ISO_C_BINDING
  36    implicit none
  37    interface
  38       function fun()
  39          use ISO_C_BINDING
  40          implicit none
  41          type(C_FUNPTR) fun
  42       end function fun
  43    end interface
  44    type(C_PTR) array(2)
  45    type(C_FUNPTR) result
  46    integer(C_INTPTR_T), parameter :: const(*) = [32512,32520]
  47
  48    result = fun()
  49    array = transfer([integer(C_INTPTR_T)::32512,32520],array)
  50 !   write(*,*) transfer(result,const)
  51 !   write(*,*) transfer(array,const)
  52 end subroutine bug6
  53
  54 function fun()
  55    use ISO_C_BINDING
  56    implicit none
  57    type(C_FUNPTR) fun
  58    fun = transfer(32512_C_INTPTR_T,fun)
  59 end function fun
  60
  61 ! { dg-final { scan-tree-dump-times "i_do_not_exist" 0 "optimized" } }
  62 ! { dg-final { cleanup-tree-dump "optimized" } }