From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001
From: upstream source tree <ports@midipix.org>
Date: Sun, 15 Mar 2015 20:14:05 -0400
Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified
 gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream
 tarball.

downloading a git-generated archive based on the 'upstream' tag
should provide you with a source tree that is binary identical
to the one extracted from the above tarball.

if you have obtained the source via the command 'git clone',
however, do note that line-endings of files in your working
directory might differ from line-endings of the respective
files in the upstream repository.
---
 gcc/testsuite/gfortran.dg/proc_ptr_comp_4.f90 | 120 ++++++++++++++++++++++++++
 1 file changed, 120 insertions(+)
 create mode 100644 gcc/testsuite/gfortran.dg/proc_ptr_comp_4.f90

(limited to 'gcc/testsuite/gfortran.dg/proc_ptr_comp_4.f90')

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_4.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_4.f90
new file mode 100644
index 000000000..b904a2f86
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_4.f90
@@ -0,0 +1,120 @@
+! { 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" } }
+
-- 
cgit v1.2.3