re PR fortran/39630 ([F03] Procedure Pointer Components)

2009-07-25  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/39630
	* decl.c (match_ppc_decl): Implement the PASS attribute for procedure
	pointer components.
	(match_binding_attributes): Ditto.
	* gfortran.h (gfc_component): Add member 'tb'.
	(gfc_typebound_proc): Add member 'ppc' and make 'pass_arg' const.
	* module.c (MOD_VERSION): Bump module version.
	(binding_ppc): New string constants.
	(mio_component): Only use formal args if component is a procedure
	pointer and add 'tb' member.
	(mio_typebound_proc): Include pass_arg and take care of procedure
	pointer components.
	* resolve.c (update_arglist_pass): Add argument 'name' and take care of
	optional arguments.
	(extract_ppc_passed_object): New function, analogous to
	extract_compcall_passed_object, but for procedure pointer components.
	(update_ppc_arglist): New function, analogous to
	update_compcall_arglist, but for procedure pointer components.
	(resolve_typebound_generic_call): Added argument to update_arglist_pass.
	(resolve_ppc_call, resolve_expr_ppc): Take care of PASS attribute.
	(resolve_fl_derived): Check the PASS argument for procedure pointer
	components.
	* symbol.c (verify_bind_c_derived_type): Reject procedure pointer
	components in BIND(C) types.

2009-07-25  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/39630
	* gfortran.dg/proc_ptr_comp_3.f90: Modified.
	* gfortran.dg/proc_ptr_comp_pass_1.f90: New.
	* gfortran.dg/proc_ptr_comp_pass_2.f90: New.
	* gfortran.dg/proc_ptr_comp_pass_3.f90: New.
	* gfortran.dg/proc_ptr_comp_pass_4.f90: New.
	* gfortran.dg/proc_ptr_comp_pass_5.f90: New.
	* gfortran.dg/typebound_call_10.f03: New.

From-SVN: r150078

8 files changed, 312 insertions, 1 deletions

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 00dbba7..71f3ad9 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,14 @@
+2009-07-25  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/39630
+	* gfortran.dg/proc_ptr_comp_3.f90: Modified.
+	* gfortran.dg/proc_ptr_comp_pass_1.f90: New.
+	* gfortran.dg/proc_ptr_comp_pass_2.f90: New.
+	* gfortran.dg/proc_ptr_comp_pass_3.f90: New.
+	* gfortran.dg/proc_ptr_comp_pass_4.f90: New.
+	* gfortran.dg/proc_ptr_comp_pass_5.f90: New.
+	* gfortran.dg/typebound_call_10.f03: New.
+
 2009-07-24  Jason Merrill  <jason@redhat.com>
 
 	* g++.dg/cpp0x/defaulted11.C: New.
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90
index 34c27f3..74dd4b8 100644
--- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90
@@ -16,7 +16,6 @@ end interface
 external :: aaargh
 
 type :: t
-  procedure(sub), pointer :: ptr1                ! { dg-error "not yet implemented" }
   procedure(real), pointer, nopass :: ptr2
   procedure(sub), pointer, nopass :: ptr3
   procedure(), pointer, nopass ptr4              ! { dg-error "Expected '::'" }
@@ -29,6 +28,10 @@ type :: t
   real :: y
 end type t
 
+type,bind(c) :: bct                   ! { dg-error "BIND.C. derived type" }
+  procedure(), pointer,nopass :: ptr  ! { dg-error "cannot be a member of|may not be C interoperable" }
+end type bct
+
 procedure(sub), pointer :: pp
 
 type(t) :: x
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_1.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_1.f90
new file mode 100644
index 0000000..14a21ec
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_1.f90
@@ -0,0 +1,51 @@
+! { dg-do run }
+!
+! FIXME: Remove -w after polymorphic entities are supported.
+! { dg-options "-w" }
+!
+! PR 39630: [F03] Procedure Pointer Components with PASS
+!
+! found at http://groups.google.com/group/comp.lang.fortran/browse_thread/thread/4a827e8ced6efb0f/884b9eca6d7e6742
+
+module mymod
+
+    type :: mytype
+        integer :: i
+        procedure(set_int_value), pointer :: seti
+    end type
+
+    abstract interface
+        subroutine set_int_value(this,i)
+            import
+            type(mytype), intent(inout) :: this
+            integer, intent(in) :: i
+        end subroutine set_int_value
+    end interface
+
+    contains
+
+    subroutine seti_proc(this,i)
+        type(mytype), intent(inout) :: this
+        integer, intent(in) :: i
+        this%i=i
+    end subroutine seti_proc
+
+end module mymod
+
+program Test_03
+    use mymod
+    implicit none
+
+    type(mytype) :: m
+
+    m%i = 44
+    m%seti => seti_proc
+
+    call m%seti(6)
+
+    if (m%i/=6) call abort()
+
+end program Test_03
+
+! { dg-final { cleanup-modules "mymod" } }
+
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_2.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_2.f90
new file mode 100644
index 0000000..c6671a6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_2.f90
@@ -0,0 +1,51 @@
+! { dg-do run }
+!
+! FIXME: Remove -w after polymorphic entities are supported.
+! { dg-options "-w" }
+!
+! PR 39630: [F03] Procedure Pointer Components with PASS
+!
+! taken from "The Fortran 2003 Handbook" (Adams et al., 2009)
+
+module passed_object_example
+
+  type t
+    real :: a
+    procedure(print_me), pointer, pass(arg) :: proc
+  end type t
+
+contains
+
+  subroutine print_me (arg, lun)
+    type(t), intent(in) :: arg
+    integer, intent(in) :: lun
+    if (abs(arg%a-2.718)>1E-6) call abort()
+    write (lun,*) arg%a
+  end subroutine print_me
+
+  subroutine print_my_square (arg, lun)
+    type(t), intent(in) :: arg
+    integer, intent(in) :: lun
+    if (abs(arg%a-2.718)>1E-6) call abort()
+    write (lun,*) arg%a**2
+  end subroutine print_my_square
+
+end module passed_object_example
+
+
+program main
+  use passed_object_example
+  use iso_fortran_env, only: output_unit
+
+  type(t) :: x
+
+  x%a = 2.718
+  x%proc => print_me
+  call x%proc (output_unit)
+  x%proc => print_my_square
+  call x%proc (output_unit)
+
+end program main
+
+! { dg-final { cleanup-modules "passed_object_example" } }
+
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_3.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_3.f90
new file mode 100644
index 0000000..15a0904
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_3.f90
@@ -0,0 +1,39 @@
+! { dg-do run }
+!
+! FIXME: Remove -w after polymorphic entities are supported.
+! { dg-options "-w" }
+!
+! PR 39630: [F03] Procedure Pointer Components with PASS
+!
+! taken from "Fortran 95/2003 explained" (Metcalf, Reid, Cohen, 2004)
+
+type t
+  procedure(obp), pointer, pass(x) :: p
+  character(100) :: name
+end type
+
+abstract interface
+  subroutine obp(w,x)
+    import :: t
+    integer :: w
+    type(t) :: x
+  end subroutine
+end interface
+
+type(t) :: a
+a%p => my_obp_sub
+a%name = "doodoo"
+
+call a%p(32)
+
+contains
+
+  subroutine my_obp_sub(w,x)
+    integer :: w
+    type(t) :: x
+    if (x%name/="doodoo") call abort()
+    if (w/=32) call abort()
+  end subroutine
+
+end
+
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_4.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_4.f90
new file mode 100644
index 0000000..b52c810
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_4.f90
@@ -0,0 +1,75 @@
+! { dg-do compile }
+!
+! PR 39630: [F03] Procedure Pointer Components with PASS
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+module m
+
+ type :: t0
+  procedure() :: p0  ! { dg-error "POINTER attribute is required for procedure pointer component" }
+ end type
+
+ type :: t1
+  integer :: i
+  procedure(foo1), pointer :: f1  ! { dg-error "must be scalar" }
+ end type
+
+ type :: t2
+  integer :: i
+  procedure(foo2), pointer :: f2  ! { dg-error "may not have the POINTER attribute" }
+ end type
+
+ type :: t3
+  integer :: i
+  procedure(foo3), pointer :: f3  ! { dg-error "may not be ALLOCATABLE" }
+ end type
+
+ type :: t4
+   procedure(),     pass(x), pointer :: f4  ! { dg-error "NOPASS or explicit interface required" }
+   procedure(real), pass(y), pointer :: f5  ! { dg-error "NOPASS or explicit interface required" }
+   procedure(foo6), pass(c), pointer :: f6  ! { dg-error "has no argument" }
+ end type
+
+ type :: t7
+   procedure(foo7), pass, pointer :: f7  ! { dg-error "must have at least one argument" }
+ end type
+
+ type :: t8
+   procedure(foo8), pass, pointer :: f8  ! { dg-error "must be of the derived type" }
+ end type
+
+contains
+
+ subroutine foo1 (x1,y1)
+  type(t1) :: x1(:)
+  type(t1) :: y1
+ end subroutine
+
+ subroutine foo2 (x2,y2)
+  type(t2),pointer :: x2
+  type(t2) :: y2
+ end subroutine
+
+ subroutine foo3 (x3,y3)  ! { dg-error "may not be ALLOCATABLE" }
+  type(t3),allocatable :: x3
+  type(t3) :: y3
+ end subroutine
+
+ real function foo6 (a,b)
+   real :: a,b
+   foo6 = 1.
+ end function
+
+ integer function foo7 ()
+   foo7 = 2
+ end function
+
+ character function foo8 (i)
+   integer :: i
+ end function
+
+end module m
+
+! { dg-final { cleanup-modules "m" } }
+
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_5.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_5.f90
new file mode 100644
index 0000000..216a554
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_5.f90
@@ -0,0 +1,39 @@
+! { dg-do run }
+!
+! PR 39630: [F03] Procedure Pointer Components with PASS
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+module m
+ type :: t
+  sequence
+  integer :: i
+  procedure(foo), pointer,pass(y) :: foo
+ end type t
+contains
+ subroutine foo(x,y)
+  type(t),optional :: x
+  type(t) :: y
+  if(present(x)) then
+    print *, 'foo', x%i, y%i
+    if (mod(x%i+y%i,3)/=2) call abort()
+  else
+    print *, 'foo', y%i
+    if (mod(y%i,3)/=1) call abort()
+  end if
+ end subroutine foo
+end module m
+
+use m
+type(t) :: t1, t2
+t1%i = 4
+t2%i = 7
+t1%foo => foo
+t2%foo => t1%foo
+call t1%foo()
+call t2%foo()
+call t2%foo(t1)
+end
+
+! { dg-final { cleanup-modules "m" } }
+
diff --git a/gcc/testsuite/gfortran.dg/typebound_call_10.f03 b/gcc/testsuite/gfortran.dg/typebound_call_10.f03
new file mode 100644
index 0000000..29b6401
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/typebound_call_10.f03
@@ -0,0 +1,42 @@
+! { dg-do run }
+!
+! FIXME: Remove -w after polymorphic entities are supported.
+! { dg-options "-w" }
+!
+! PR 39630: [F03] Procedure Pointer Components with PASS
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+module m
+
+ type :: t
+  integer :: i
+ contains
+  procedure, pass(y) :: foo
+ end type t
+
+contains
+
+ subroutine foo(x,y)
+  type(t),optional :: x
+  type(t) :: y
+  if(present(x)) then
+    print *, 'foo', x%i, y%i
+  else
+    print *, 'foo', y%i
+  end if
+ end subroutine foo
+
+end module m
+
+use m
+type(t) :: t1, t2
+t1%i = 3
+t2%i = 4
+call t1%foo()
+call t2%foo()
+call t1%foo(t2)
+end
+
+! { dg-final { cleanup-modules "m" } }
+