diff options
author | Ben Cheng <bccheng@google.com> | 2013-03-28 11:14:20 -0700 |
---|---|---|
committer | Ben Cheng <bccheng@google.com> | 2013-03-28 12:40:33 -0700 |
commit | af0c51ac87ab2a87caa03fa108f0d164987a2764 (patch) | |
tree | 4b8b470f7c5b69642fdab8d0aa1fbc148d02196b /gcc-4.8/gcc/testsuite/gfortran.dg/proc_ptr_comp_4.f90 | |
parent | d87cae247d39ebf4f5a6bf25c932a14d2fdb9384 (diff) | |
download | toolchain_gcc-af0c51ac87ab2a87caa03fa108f0d164987a2764.tar.gz toolchain_gcc-af0c51ac87ab2a87caa03fa108f0d164987a2764.tar.bz2 toolchain_gcc-af0c51ac87ab2a87caa03fa108f0d164987a2764.zip |
[GCC 4.8] Initial check-in of GCC 4.8.0
Change-Id: I0719d8a6d0f69b367a6ab6f10eb75622dbf12771
Diffstat (limited to 'gcc-4.8/gcc/testsuite/gfortran.dg/proc_ptr_comp_4.f90')
-rw-r--r-- | gcc-4.8/gcc/testsuite/gfortran.dg/proc_ptr_comp_4.f90 | 117 |
1 files changed, 117 insertions, 0 deletions
diff --git a/gcc-4.8/gcc/testsuite/gfortran.dg/proc_ptr_comp_4.f90 b/gcc-4.8/gcc/testsuite/gfortran.dg/proc_ptr_comp_4.f90 new file mode 100644 index 000000000..be36fda41 --- /dev/null +++ b/gcc-4.8/gcc/testsuite/gfortran.dg/proc_ptr_comp_4.f90 @@ -0,0 +1,117 @@ +! { 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 |