Re: [Patch, Fortran] PR 40176: Fortran 2003: Procedure pointers with array return value

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

> this patch fixes some problems related to procedure pointers with
> array return value, and a small one related to procedure pointer
> assignments with dummy arguments. Note that there are still some
> remaining issues regarding PPCs with array return values (i.e.
> actually calling them does not work yet).

Here goes another update: Since no one reviewed the patch yet, I
already fixed the problem with calling array-valued PPCs (and extended
the test case 'proc_ptr_comp_9.f90'). I also fixed another issue,
which was discovered in the meantime (cf. 'proc_ptr_comp_10.f90').

So, here is the new patch, complete with updated ChangeLog and test
cases, and still regression-free. Ok for trunk?

Cheers,
Janus


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

	PR fortran/40176
	* primary.c (gfc_match_varspec): Handle procedure pointer components
	with array return value.
	* resolve.c (resolve_expr_ppc): Ditto.
	(resolve_symbol): Make sure the interface of a procedure pointer has
	been resolved.
	* trans-array.c (gfc_walk_function_expr): Handle procedure pointer
	components with array return value.
	* trans-expr.c (gfc_conv_component_ref,gfc_conv_procedure_call,
	gfc_trans_arrayfunc_assign): Ditto.
	(gfc_trans_pointer_assignment): Handle procedure pointer assignments,
	where the rhs is a dummy argument.
	* trans-types.c (gfc_get_ppc_type,gfc_get_derived_type): Handle
	procedure pointer components with array return value.


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

	PR fortran/40176
	* gfortran.dg/proc_ptr_18.f90: New.
	* gfortran.dg/proc_ptr_19.f90: New.
	* gfortran.dg/proc_ptr_comp_9.f90: New.
	* gfortran.dg/proc_ptr_comp_10.f90: New.

Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(revision 147830)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -476,8 +476,8 @@ gfc_conv_component_ref (gfc_se * se, gfc
       se->string_length = tmp;
     }
 
-  if ((c->attr.pointer || c->attr.proc_pointer) && c->attr.dimension == 0
-      && c->ts.type != BT_CHARACTER)
+  if ((c->attr.pointer && c->attr.dimension == 0 && c->ts.type != BT_CHARACTER)
+      || c->attr.proc_pointer)
     se->expr = build_fold_indirect_ref (se->expr);
 }
 
@@ -2396,6 +2396,7 @@ gfc_conv_procedure_call (gfc_se * se, gf
   gfc_symbol *fsym;
   stmtblock_t post;
   enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
+  gfc_component *comp = NULL;
 
   arglist = NULL_TREE;
   retargs = NULL_TREE;
@@ -2550,11 +2551,13 @@ gfc_conv_procedure_call (gfc_se * se, gf
 
   gfc_init_block (&post);
   gfc_init_interface_mapping (&mapping);
+  is_proc_ptr_comp (expr, &comp);
   need_interface_mapping = ((sym->ts.type == BT_CHARACTER
 				  && sym->ts.cl->length
 				  && sym->ts.cl->length->expr_type
 						!= EXPR_CONSTANT)
-			      || sym->attr.dimension);
+			      || (comp && comp->attr.dimension)
+			      || (!comp && sym->attr.dimension));
   formal = sym->formal;
   /* Evaluate the arguments.  */
   for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
@@ -2825,7 +2828,8 @@ gfc_conv_procedure_call (gfc_se * se, gf
       len = cl.backend_decl;
     }
 
-  byref = gfc_return_by_reference (sym);
+  byref = (comp && comp->attr.dimension)
+	  || (!comp && gfc_return_by_reference (sym));
   if (byref)
     {
       if (se->direct_byref)
@@ -4053,6 +4057,10 @@ gfc_trans_pointer_assignment (gfc_expr *
 	  && expr1->symtree->n.sym->attr.dummy)
 	lse.expr = build_fold_indirect_ref (lse.expr);
 
+      if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
+	  && expr2->symtree->n.sym->attr.dummy)
+	rse.expr = build_fold_indirect_ref (rse.expr);
+
       gfc_add_block_to_block (&block, &lse.pre);
       gfc_add_block_to_block (&block, &rse.pre);
 
@@ -4284,6 +4292,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * e
   gfc_ss *ss;
   gfc_ref * ref;
   bool seen_array_ref;
+  gfc_component *comp = NULL;
 
   /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION.  */
   if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
@@ -4343,8 +4352,10 @@ gfc_trans_arrayfunc_assign (gfc_expr * e
 
   /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
      functions.  */
+  is_proc_ptr_comp(expr2, &comp);
   gcc_assert (expr2->value.function.isym
-	      || (gfc_return_by_reference (expr2->value.function.esym)
+	      || (comp && comp->attr.dimension)
+	      || (!comp && gfc_return_by_reference (expr2->value.function.esym)
 	      && expr2->value.function.esym->result->attr.dimension));
 
   ss = gfc_walk_expr (expr1);
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c	(revision 147830)
+++ gcc/fortran/trans-array.c	(working copy)
@@ -6293,6 +6293,7 @@ gfc_walk_function_expr (gfc_ss * ss, gfc
   gfc_ss *newss;
   gfc_intrinsic_sym *isym;
   gfc_symbol *sym;
+  gfc_component *comp = NULL;
 
   isym = expr->value.function.isym;
 
@@ -6305,7 +6306,9 @@ gfc_walk_function_expr (gfc_ss * ss, gfc
       sym = expr->symtree->n.sym;
 
   /* A function that returns arrays.  */
-  if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
+  is_proc_ptr_comp (expr, &comp);
+  if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
+      || (comp && comp->attr.dimension))
     {
       newss = gfc_get_ss ();
       newss->type = GFC_SS_FUNCTION;
Index: gcc/fortran/trans-types.c
===================================================================
--- gcc/fortran/trans-types.c	(revision 147830)
+++ gcc/fortran/trans-types.c	(working copy)
@@ -1875,7 +1875,7 @@ tree
 gfc_get_ppc_type (gfc_component* c)
 {
   tree t;
-  if (c->attr.function)
+  if (c->attr.function && !c->attr.dimension)
     t = gfc_typenode_for_spec (&c->ts);
   else
     t = void_type_node;
@@ -1997,7 +1997,7 @@ gfc_get_derived_type (gfc_symbol * deriv
 
       /* This returns an array descriptor type.  Initialization may be
          required.  */
-      if (c->attr.dimension)
+      if (c->attr.dimension && !c->attr.proc_pointer)
 	{
 	  if (c->attr.pointer || c->attr.allocatable)
 	    {
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 147830)
+++ gcc/fortran/resolve.c	(working copy)
@@ -4868,6 +4868,8 @@ resolve_expr_ppc (gfc_expr* e)
   e->value.function.isym = NULL;
   e->value.function.actual = e->value.compcall.actual;
   e->ts = comp->ts;
+  if (comp->as != NULL)
+    e->rank = comp->as->rank;
 
   if (!comp->attr.function)
     gfc_add_function (&comp->attr, comp->name, &e->where);
@@ -9414,6 +9416,7 @@ resolve_symbol (gfc_symbol *sym)
 	  || sym->ts.interface->attr.intrinsic)
 	{
 	  gfc_symbol *ifc = sym->ts.interface;
+	  resolve_symbol (ifc);
 
 	  if (ifc->attr.intrinsic)
 	    resolve_intrinsic (ifc, &ifc->declared_at);
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(revision 147830)
+++ gcc/fortran/primary.c	(working copy)
@@ -1726,7 +1726,8 @@ gfc_match_varspec (gfc_expr *primary, in
   tail = NULL;
 
   gfc_gobble_whitespace ();
-  if ((equiv_flag && gfc_peek_ascii_char () == '(') || sym->attr.dimension)
+  if ((equiv_flag && gfc_peek_ascii_char () == '(')
+      || (sym->attr.dimension && !sym->attr.proc_pointer))
     {
       /* In EQUIVALENCE, we don't know yet whether we are seeing
 	 an array, character variable or array of character
@@ -1843,7 +1844,7 @@ gfc_match_varspec (gfc_expr *primary, in
           break;
 	}
 
-      if (component->as != NULL)
+      if (component->as != NULL && !component->attr.proc_pointer)
 	{
 	  tail = extend_ref (primary, tail);
 	  tail->type = REF_ARRAY;

! { dg-do run }
!
! PR 40176:  Fortran 2003: Procedure pointers with array return value
!
! Original test case by Barron Bichon <barron.bichon@swri.org>
! Modified by Janus Weil <janus@gcc.gnu.org>

PROGRAM test_prog

  PROCEDURE(triple), POINTER :: f

  f => triple
  if (sum(f(2.,4.)-triple(2.,4.))>1E-3) call abort()

CONTAINS

  FUNCTION triple(a,b) RESULT(tre)
    REAL, INTENT(in) :: a, b
    REAL :: tre(2)
    tre(1) = 3.*a
    tre(2) = 3.*b
  END FUNCTION triple

END PROGRAM test_prog

! { dg-do run }
!
! PR 40176:  Fortran 2003: Procedure pointers with array return value
!
! This example tests for a bug in procedure pointer assignments,
! where the rhs is a dummy.
!
! Original test case by Barron Bichon <barron.bichon@swri.org>
! Modified by Janus Weil <janus@gcc.gnu.org>

PROGRAM test_prog

  PROCEDURE(add), POINTER :: forig, fset

  forig => add

  CALL set_ptr(forig,fset)

  if (forig(1,2) /= fset(1,2)) call abort()

CONTAINS

  SUBROUTINE set_ptr(f1,f2)
    PROCEDURE(add), POINTER :: f1, f2
    f2 => f1
  END SUBROUTINE set_ptr

  FUNCTION add(a,b)
    INTEGER :: a,b,add
    add = a+b

  END FUNCTION add
 
END PROGRAM test_prog

! { dg-do run }
!
! PR 40176:  Fortran 2003: Procedure pointers with array return value
!
! Original test case by Barron Bichon <barron.bichon@swri.org>
! Modified by Janus Weil <janus@gcc.gnu.org>

PROGRAM test_prog

 TYPE ProcPointerType
   PROCEDURE(triple), POINTER, NOPASS :: f
 END TYPE ProcPointerType

 TYPE (ProcPointerType) :: ppt
 PROCEDURE(triple), POINTER :: f
 REAL :: tres(2)

 ppt%f => triple
 f => ppt%f
 tres = f(2,[2.,4.])
 if (abs(tres(1)-6.)>1E-3) call abort()
 if (abs(tres(2)-12.)>1E-3) call abort()
 tres = ppt%f(2,[3.,5.])
 if (abs(tres(1)-9.)>1E-3) call abort()
 if (abs(tres(2)-15.)>1E-3) call abort()

CONTAINS

 FUNCTION triple(n,x) RESULT(tre)
   INTEGER, INTENT(in) :: n
   REAL, INTENT(in) :: x(2)
   REAL :: tre(2)
   tre = 3.*x
 END FUNCTION triple

END PROGRAM test_prog

! { dg-do compile }
!
! PR 40176:  Fortran 2003: Procedure pointers with array return value
!
! Contributed by Janus Weil <janus@gcc.gnu.org>

module m

abstract interface
  function ai()
    real, dimension(3) :: ai
  end function
end interface

type t
  procedure(ai), pointer, nopass :: ppc
end type

procedure(ai), pointer :: pp

end module

program test
use m
type(t) :: obj
obj%ppc => pp
pp => obj%ppc
end

! { dg-final { cleanup-modules "m" } }