URL
https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk
Subversion Repositories openrisc_2011-10-31
[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [gfortran.dg/] [proc_ptr_comp_4.f90] - Rev 316
Go to most recent revision | Compare with Previous | Blame | View Log
! { dg-do compile }
!
! PR39630: Fortran 2003: Procedure pointer components.
!
! Original code by Juergen Reuter <juergen.reuter@physik.uni-freiburg.de>
!
! Adapted by Janus Weil <janus@gcc.gnu.org>
! Test for infinte recursion in trans-types.c when a PPC interface
! refers to the original type.
module expressions
type :: eval_node_t
logical, pointer :: lval => null ()
type(eval_node_t), pointer :: arg1 => null ()
procedure(unary_log), nopass, pointer :: op1_log => null ()
end type eval_node_t
abstract interface
logical function unary_log (arg)
import eval_node_t
type(eval_node_t), intent(in) :: arg
end function unary_log
end interface
contains
subroutine eval_node_set_op1_log (en, op)
type(eval_node_t), intent(inout) :: en
procedure(unary_log) :: op
en%op1_log => op
end subroutine eval_node_set_op1_log
subroutine eval_node_evaluate (en)
type(eval_node_t), intent(inout) :: en
en%lval = en%op1_log (en%arg1)
end subroutine
end module
! Test for C_F_PROCPOINTER and pointers to derived types
module process_libraries
implicit none
type :: process_library_t
procedure(), nopass, pointer :: write_list
end type process_library_t
contains
subroutine process_library_load (prc_lib)
use iso_c_binding
type(process_library_t) :: prc_lib
type(c_funptr) :: c_fptr
call c_f_procpointer (c_fptr, prc_lib%write_list)
end subroutine process_library_load
subroutine process_libraries_test ()
type(process_library_t), pointer :: prc_lib
call prc_lib%write_list ()
end subroutine process_libraries_test
end module process_libraries
! Test for argument resolution
module hard_interactions
implicit none
type :: hard_interaction_t
procedure(), nopass, pointer :: new_event
end type hard_interaction_t
interface afv
module procedure afv_1
end interface
contains
function afv_1 () result (a)
real, dimension(0:3) :: a
end function
subroutine hard_interaction_evaluate (hi)
type(hard_interaction_t) :: hi
call hi%new_event (afv ())
end subroutine
end module hard_interactions
! Test for derived types with PPC working properly as function result.
implicit none
type :: var_entry_t
procedure(), nopass, pointer :: obs1_int
end type var_entry_t
type(var_entry_t), pointer :: var
var => var_list_get_var_ptr ()
contains
function var_list_get_var_ptr ()
type(var_entry_t), pointer :: var_list_get_var_ptr
end function var_list_get_var_ptr
end
! { dg-final { cleanup-modules "expressions process_libraries hard_interactions" } }
Go to most recent revision | Compare with Previous | Blame | View Log