OSDN Git Service

2010-12-18 Tobias Burnus <burnus@net-b.de>
[pf3gnuchains/gcc-fork.git] / 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   if (1162035777 /= a) call i_do_not_exist()
14 end program test
15
16 ! Examples contributed by Steve Kargl and James Van Buskirk
17
18 subroutine bug1
19    use ISO_C_BINDING
20    implicit none
21    type(c_ptr) :: m
22    type mytype
23      integer a, b, c
24    end type mytype
25    type(mytype) x
26    print *, transfer(32512, x)  ! Works.
27    print *, transfer(32512, m)  ! Caused ICE.
28 end subroutine bug1 
29
30 subroutine bug6
31    use ISO_C_BINDING
32    implicit none
33    interface
34       function fun()
35          use ISO_C_BINDING
36          implicit none
37          type(C_FUNPTR) fun
38       end function fun
39    end interface
40    type(C_PTR) array(2)
41    type(C_FUNPTR) result
42    integer(C_INTPTR_T), parameter :: const(*) = [32512,32520]
43
44    result = fun()
45    array = transfer([integer(C_INTPTR_T)::32512,32520],array)
46 !   write(*,*) transfer(result,const)
47 !   write(*,*) transfer(array,const)
48 end subroutine bug6
49
50 function fun()
51    use ISO_C_BINDING
52    implicit none
53    type(C_FUNPTR) fun
54    fun = transfer(32512_C_INTPTR_T,fun)
55 end function fun 
56
57 ! { dg-final { scan-tree-dump-times "i_do_not_exist" 0 "optimized" } }
58 ! { dg-final { cleanup-tree-dump "optimized" } }