re PR fortran/42045 ([F03] passing a procedure pointer component to a procedure point...

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 64061e7..862fffa 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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\r
     procedure(fcn), pointer, nopass :: ppc\r
     procedure(abstr), pointer, nopass :: ppc1
-    procedure(), nopass, pointer:: iptr3\r
     integer :: i\r
   end type\r
 \r
@@ -43,11 +42,6 @@
   if (base/=12) call abort\r
   call foo (f,7)
 
-! Check with implicit interface
-  obj%iptr3 => iabs
-  base=obj%iptr3(-9)
-  if (base/=9) call abort\r
-\r
 contains\r
 \r
   integer function fcn(x)\r

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 (file)
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 (file)
--- 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" }