re PR fortran/42045 ([F03] passing a procedure pointer component to a procedure pointer dummy)

2009-11-24  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42045
	* resolve.c (resolve_actual_arglist): Make sure procedure pointer
	actual arguments are resolved correctly.
	(resolve_function): An EXPR_FUNCTION which is a procedure pointer
	component, has already been resolved.
	(resolve_fl_derived): Procedure pointer components should not be
	implicitly typed.

2009-11-24  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42045
	* gfortran.dg/proc_ptr_comp_2.f90: Correct invalid test case.
	* gfortran.dg/proc_ptr_comp_3.f90: Extended test case.
	* gfortran.dg/proc_ptr_comp_24.f90: New.

From-SVN: r154492

6 files changed, 57 insertions, 8 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 64061e7..862fffa 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+2009-11-24  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42045
+	* resolve.c (resolve_actual_arglist): Make sure procedure pointer
+	actual arguments are resolved correctly.
+	(resolve_function): An EXPR_FUNCTION which is a procedure pointer
+	component, has already been resolved.
+	(resolve_fl_derived): Procedure pointer components should not be
+	implicitly typed.
+
 2009-11-21  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR fortran/41807
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index bd690a7..740679e 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1321,6 +1321,8 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
 		e->rank = comp->as->rank;
 	      e->expr_type = EXPR_FUNCTION;
 	    }
+	  if (gfc_resolve_expr (e) == FAILURE)                          
+	    return FAILURE; 
 	  goto argument_list;
 	}
 
@@ -2519,6 +2521,10 @@ resolve_function (gfc_expr *expr)
   if (expr->symtree)
     sym = expr->symtree->n.sym;
 
+  /* If this is a procedure pointer component, it has already been resolved.  */
+  if (gfc_is_proc_ptr_comp (expr, NULL))
+    return SUCCESS;
+  
   if (sym && sym->attr.intrinsic
       && resolve_intrinsic (sym, &expr->where) == FAILURE)
     return FAILURE;
@@ -10219,8 +10225,9 @@ resolve_fl_derived (gfc_symbol *sym)
 	}
       else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
 	{
-	  c->ts = *gfc_get_default_type (c->name, NULL);
-	  c->attr.implicit_type = 1;
+	  /* Since PPCs are not implicitly typed, a PPC without an explicit
+	     interface must be a subroutine.  */
+	  gfc_add_subroutine (&c->attr, c->name, &c->loc);
 	}
 
       /* Procedure pointer components: Check PASS arg.  */
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index ccaae0c..50c588c 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2009-11-24  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42045
+	* gfortran.dg/proc_ptr_comp_2.f90: Correct invalid test case.
+	* gfortran.dg/proc_ptr_comp_3.f90: Extended test case.
+	* gfortran.dg/proc_ptr_comp_24.f90: New.
+
 2009-11-23  Andy Hutchinson  <hutchinsonandy@gcc.gnu.org>
 
 	* gcc.c-torture/execute/pr40404.c: Use long for bitfield on 16bit
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_2.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_2.f90
index 886e8bf..33e32aa 100644
--- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_2.f90
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_2.f90
@@ -9,7 +9,6 @@
   type t

     procedure(fcn), pointer, nopass :: ppc

     procedure(abstr), pointer, nopass :: ppc1
-    procedure(), nopass, pointer:: iptr3

     integer :: i

   end type

 

@@ -43,11 +42,6 @@
   if (base/=12) call abort

   call foo (f,7)
 
-! Check with implicit interface
-  obj%iptr3 => iabs
-  base=obj%iptr3(-9)
-  if (base/=9) call abort

-

 contains

 

   integer function fcn(x)

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_24.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_24.f90
new file mode 100644
index 0000000..8c935c9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_24.f90
@@ -0,0 +1,29 @@
+! { dg-do compile }
+!
+! PR42045: [F03] passing a procedure pointer component to a procedure pointer dummy
+!
+! Contributed by John McFarland <john.mcfarland@swri.org>
+
+PROGRAM prog
+ TYPE object
+  PROCEDURE(), POINTER, NOPASS :: f
+ END TYPE object
+ TYPE container
+  TYPE (object), POINTER :: o(:)
+ END TYPE container
+ TYPE (container) :: c
+ TYPE (object) :: o1, o2
+ PROCEDURE(), POINTER :: f => NULL()
+ o1%f => f
+ CALL set_func(o2,f)
+ CALL set_func(o2,o1%f)
+ ALLOCATE( c%o(5) )
+ c%o(5)%f => f
+ CALL set_func(o2,c%o(5)%f)
+CONTAINS
+ SUBROUTINE set_func(o,f)
+  TYPE (object) :: o
+  PROCEDURE(), POINTER :: f
+  o%f => f
+ END SUBROUTINE set_func
+END PROGRAM prog
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90
index 74dd4b8..fc8c28d 100644
--- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90
@@ -16,6 +16,7 @@ end interface
 external :: aaargh
 
 type :: t
+  procedure(), pointer, nopass :: ptr1
   procedure(real), pointer, nopass :: ptr2
   procedure(sub), pointer, nopass :: ptr3
   procedure(), pointer, nopass ptr4              ! { dg-error "Expected '::'" }
@@ -40,6 +41,7 @@ x%ptr2 => x       ! { dg-error "Invalid procedure pointer assignment" }
 
 x => x%ptr2       ! { dg-error "Pointer assignment to non-POINTER" }
 
+print *, x%ptr1() ! { dg-error "attribute conflicts with" }
 call x%ptr2()     ! { dg-error "attribute conflicts with" }
 print *,x%ptr3()  ! { dg-error "attribute conflicts with" }