OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/40176 (Fortran 2003: Procedure pointers with array return value)

Browse Source 
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.

From-SVN: r147850
This commit is contained in:
Janus Weil 2009-05-25 16:48:24 +02:00
parent 6b8ed1452b
commit c74b74a8b2
11 changed files with 181 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
gcc/fortran/ChangeLog
View File

@ -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

5
gcc/fortran/primary.c
View File

@ -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;

3
gcc/fortran/resolve.c
View File

@ -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);

5
gcc/fortran/trans-array.c
View File

@ -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;

21
gcc/fortran/trans-expr.c
View File

@ -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);

4
gcc/fortran/trans-types.c
View File

@ -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)
{

8
gcc/testsuite/ChangeLog
View File

@ -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.

25
gcc/testsuite/gfortran.dg/proc_ptr_18.f90 Normal file
View File

@ -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

35
gcc/testsuite/gfortran.dg/proc_ptr_19.f90 Normal file
View File

@ -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

31
gcc/testsuite/gfortran.dg/proc_ptr_comp_10.f90 Normal file
View File

@ -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" } }

37
gcc/testsuite/gfortran.dg/proc_ptr_comp_9.f90 Normal file
View File

@ -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