mirror of
https://github.com/autc04/Retro68.git
synced 2024-09-28 18:56:06 +00:00
54 lines
1.1 KiB
Fortran
54 lines
1.1 KiB
Fortran
! { dg-do run }
|
|
!
|
|
! Check that pointer assignments allowed by F2003:C717
|
|
! work and check null initialization of CLASS(*) pointers.
|
|
!
|
|
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
|
|
!
|
|
program main
|
|
interface
|
|
subroutine foo(z)
|
|
class(*), pointer, intent(in) :: z
|
|
end subroutine foo
|
|
end interface
|
|
type sq
|
|
sequence
|
|
integer :: i
|
|
end type sq
|
|
type(sq), target :: x
|
|
class(*), pointer :: y, z
|
|
x%i = 42
|
|
y => x
|
|
z => y ! unlimited => unlimited allowed
|
|
call foo (z)
|
|
call bar
|
|
contains
|
|
subroutine bar
|
|
type t
|
|
end type t
|
|
type(t), pointer :: x
|
|
class(*), pointer :: ptr1 => null() ! pointer initialization
|
|
if (same_type_as (ptr1, x) .neqv. .FALSE.) STOP 1
|
|
end subroutine bar
|
|
|
|
end program main
|
|
|
|
|
|
subroutine foo(tgt)
|
|
use iso_c_binding
|
|
class(*), pointer, intent(in) :: tgt
|
|
type, bind(c) :: s
|
|
integer (c_int) :: k
|
|
end type s
|
|
type t
|
|
sequence
|
|
integer :: k
|
|
end type t
|
|
type(s), pointer :: ptr1
|
|
type(t), pointer :: ptr2
|
|
ptr1 => tgt ! bind(c) => unlimited allowed
|
|
if (ptr1%k .ne. 42) STOP 2
|
|
ptr2 => tgt ! sequence type => unlimited allowed
|
|
if (ptr2%k .ne. 42) STOP 3
|
|
end subroutine foo
|