2009-05-25 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-25  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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@147850 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 61278ba..32c3192 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,20 @@
+2009-05-25  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  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
            Dominique Dhumieres
 

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 4d39c1a..1a03165 100644 (file)
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -1726,7 +1726,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
   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, int equiv_flag, bool sub_flag,
           break;
        }
 
-      if (component->as != NULL)
+      if (component->as != NULL && !component->attr.proc_pointer)
        {
          tail = extend_ref (primary, tail);
          tail->type = REF_ARRAY;

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 39eb043..8158b71 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -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);

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 36a99a4..7dea222 100644 (file)
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -6295,6 +6295,7 @@ gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
   gfc_ss *newss;
   gfc_intrinsic_sym *isym;
   gfc_symbol *sym;
+  gfc_component *comp = NULL;
 
   isym = expr->value.function.isym;
 
@@ -6307,7 +6308,9 @@ gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
       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;

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index a20d3ae..f1f0091 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -476,8 +476,8 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
       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, gfc_symbol * sym,
   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, gfc_symbol * sym,
 
   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, gfc_symbol * sym,
       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, gfc_expr * expr2)
          && 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 * expr1, gfc_expr * expr2)
   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 * expr1, gfc_expr * expr2)
 
   /* 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);

diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index b40af41..e945fcb 100644 (file)
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -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 * derived)
 
       /* 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)
            {

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 097317c..a5025a3 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,11 @@
+2009-05-25  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.
+
 2009-05-25  Richard Guenther  <rguenther@suse.de>
 
        * gcc.dg/tree-ssa/ssa-fre-14.c: Adjust.

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_18.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_18.f90
new file mode 100644 (file)
index 0000000..79cd68a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_18.f90
@@ -0,0 +1,25 @@
+! { 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
+

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_19.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_19.f90
new file mode 100644 (file)
index 0000000..a78a8d4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_19.f90
@@ -0,0 +1,35 @@
+! { 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
+

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_10.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_10.f90
new file mode 100644 (file)
index 0000000..382f412
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_10.f90
@@ -0,0 +1,31 @@
+! { 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" } }
+

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_9.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_9.f90
new file mode 100644 (file)
index 0000000..951db48
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_9.f90
@@ -0,0 +1,37 @@
+! { 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
+