aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/ChangeLog17
-rw-r--r--gcc/fortran/primary.c5
-rw-r--r--gcc/fortran/resolve.c3
-rw-r--r--gcc/fortran/trans-array.c5
-rw-r--r--gcc/fortran/trans-expr.c21
-rw-r--r--gcc/fortran/trans-types.c4
-rw-r--r--gcc/testsuite/ChangeLog8
-rw-r--r--gcc/testsuite/gfortran.dg/proc_ptr_18.f9025
-rw-r--r--gcc/testsuite/gfortran.dg/proc_ptr_19.f9035
-rw-r--r--gcc/testsuite/gfortran.dg/proc_ptr_comp_10.f9031
-rw-r--r--gcc/testsuite/gfortran.dg/proc_ptr_comp_9.f9037
11 files changed, 181 insertions, 10 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 61278ba..32c3192 100644
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
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
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
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
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
+
generated by cgit v1.1 at 2024-11-02 23:18:32 +0000