[Patch, Fortran] PR42045: [F03] passing a procedure pointer component to a procedure pointer dummy

[Janus Weil <janus at gcc dot gnu dot org>]

Hi all,

this patch fixes some trouble with PPCs which have no interface [i.e.
"procedure()"]. Up to now, what we did with these was to apply
implicit typing. However, Malcolm Cohen's draft answer to an
interpretation request by Tobias
(http://www.j3-fortran.org/doc/year/09/09-236r1.txt) states that PPCs
should never be implicitly typed. Due to this reasoning, a PPC without
explicit interface specification can only be a subroutine pointer (and
not a function pointer).

The patch also fixes the problem that John McFarland reported (which
was caused by the implicit typing of PPCs). It was regtested
successfully on x86_64-unknown-linux-gnu. Ok for trunk?

Cheers,
Janus


2009-11-21  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  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.

Index: gcc/testsuite/gfortran.dg/proc_ptr_comp_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_comp_2.f90	(revision 154409)
+++ gcc/testsuite/gfortran.dg/proc_ptr_comp_2.f90	(working copy)
@@ -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)
Index: gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90	(revision 154409)
+++ gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90	(working copy)
@@ -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
 
 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" }
 
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 154409)
+++ gcc/fortran/resolve.c	(working copy)
@@ -1321,6 +1321,8 @@ resolve_actual_arglist (gfc_actual_arglist *arg, p
 		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.  */

Attachment: proc_ptr_comp_24.f90
Description: Binary data