yggdrasil/gcc
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

re PR fortran/41106 ([F03] Procedure Pointers with CHARACTER results)

Browse Source 
2009-08-21  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41106
	* primary.c (gfc_variable_attr): Make it work also on EXPR_FUNCTION.
	(gfc_expr_attr): Use gfc_variable_attr for procedure pointer components.
	* resolve.c (resolve_fl_derived): Handle CHARACTER-valued procedure
	pointer components.
	* trans-expr.c (gfc_conv_component_ref): Ditto.
	(gfc_conv_variable): Ditto.
	(gfc_conv_procedure_call): Ditto.
	(gfc_trans_pointer_assignment): Ditto.
	* trans-types.c (gfc_get_derived_type): Ditto.


2009-08-21  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41106
	* gfortran.dg/proc_ptr_23.f90: New.
	* gfortran.dg/proc_ptr_comp_15.f90: New.
	* gfortran.dg/proc_ptr_comp_16.f90: New.
	* gfortran.dg/proc_ptr_comp_17.f90: New.

From-SVN: r150987
This commit is contained in:
Janus Weil 2009-08-21 11:43:04 +02:00
parent 4b8c1a924a
commit 50dbf0b414
10 changed files with 178 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
gcc/fortran/ChangeLog
View File

@ -1,3 +1,16 @@
2009-08-21 Janus Weil <janus@gcc.gnu.org>
PR fortran/41106
* primary.c (gfc_variable_attr): Make it work also on EXPR_FUNCTION.
(gfc_expr_attr): Use gfc_variable_attr for procedure pointer components.
* resolve.c (resolve_fl_derived): Handle CHARACTER-valued procedure
pointer components.
* trans-expr.c (gfc_conv_component_ref): Ditto.
(gfc_conv_variable): Ditto.
(gfc_conv_procedure_call): Ditto.
(gfc_trans_pointer_assignment): Ditto.
* trans-types.c (gfc_get_derived_type): Ditto.
2009-08-20 Tobias Schlüter <tobi@gcc.gnu.org>
* trans-stmt.c (gfc_trans_do): Add a few missing folds.

4
gcc/fortran/primary.c
View File

@ -1938,7 +1938,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
symbol_attribute attr;
gfc_ref *ref;
if (expr->expr_type != EXPR_VARIABLE)
if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
ref = expr->ref;
@ -2032,6 +2032,8 @@ gfc_expr_attr (gfc_expr *e)
if (e->value.function.esym != NULL)
attr = e->value.function.esym->result->attr;
else
attr = gfc_variable_attr (e, NULL);
/* TODO: NULL() returns pointers. May have to take care of this
here. */

4
gcc/fortran/resolve.c
View File

@ -9476,7 +9476,7 @@ resolve_fl_derived (gfc_symbol *sym)
if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
{
c->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
/* TODO: gfc_expr_replace_symbols (c->ts.u.cl->length, c);*/
gfc_expr_replace_comp (c->ts.u.cl->length, c);
}
}
else if (c->ts.interface->name[0] != '\0')
@ -9604,7 +9604,7 @@ resolve_fl_derived (gfc_symbol *sym)
return FAILURE;
}
if (c->ts.type == BT_CHARACTER)
if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
{
if (c->ts.u.cl->length == NULL
|| (resolve_charlen (c->ts.u.cl) == FAILURE)

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

@ -474,7 +474,7 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
se->expr = tmp;
if (c->ts.type == BT_CHARACTER)
if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
{
tmp = c->ts.u.cl->backend_decl;
/* Components must always be constant length. */
@ -714,7 +714,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
separately. */
if (se->want_pointer)
{
if (expr->ts.type == BT_CHARACTER)
if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
gfc_conv_string_parameter (se);
else
se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
@ -2577,16 +2577,25 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_init_block (&post);
gfc_init_interface_mapping (&mapping);
need_interface_mapping = ((sym->ts.type == BT_CHARACTER
&& sym->ts.u.cl->length
&& sym->ts.u.cl->length->expr_type
!= EXPR_CONSTANT)
|| (comp && comp->attr.dimension)
|| (!comp && sym->attr.dimension));
if (comp)
formal = comp->formal;
if (!comp)
{
formal = sym->formal;
need_interface_mapping = sym->attr.dimension ||
(sym->ts.type == BT_CHARACTER
&& sym->ts.u.cl->length
&& sym->ts.u.cl->length->expr_type
!= EXPR_CONSTANT);
}
else
formal = sym->formal;
{
formal = comp->formal;
need_interface_mapping = comp->attr.dimension ||
(comp->ts.type == BT_CHARACTER
&& comp->ts.u.cl->length
&& comp->ts.u.cl->length->expr_type
!= EXPR_CONSTANT);
}
/* Evaluate the arguments. */
for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
{
@ -2913,12 +2922,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
ts = sym->ts;
if (comp)
ts = comp->ts;
else
ts = sym->ts;
if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
se->string_length = build_int_cst (gfc_charlen_type_node, 1);
else if (ts.type == BT_CHARACTER)
{
if (sym->ts.u.cl->length == NULL)
if (ts.u.cl->length == NULL)
{
/* Assumed character length results are not allowed by 5.1.1.5 of the
standard and are trapped in resolve.c; except in the case of SPREAD
@ -2943,9 +2956,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* Calculate the length of the returned string. */
gfc_init_se (&parmse, NULL);
if (need_interface_mapping)
gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.u.cl->length);
gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
else
gfc_conv_expr (&parmse, sym->ts.u.cl->length);
gfc_conv_expr (&parmse, ts.u.cl->length);
gfc_add_block_to_block (&se->pre, &parmse.pre);
gfc_add_block_to_block (&se->post, &parmse.post);
@ -2963,7 +2976,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
len = cl.backend_decl;
}
byref = (comp && comp->attr.dimension)
byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
|| (!comp && gfc_return_by_reference (sym));
if (byref)
{
@ -3004,7 +3017,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
tmp = gfc_build_addr_expr (NULL_TREE, tmp);
retargs = gfc_chainon_list (retargs, tmp);
}
else if (sym->result->attr.dimension)
else if (!comp && sym->result->attr.dimension)
{
gcc_assert (se->loop && info);
@ -3036,7 +3049,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* Return an address to a char[0:len-1]* temporary for
character pointers. */
if (sym->attr.pointer || sym->attr.allocatable)
if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
|| (comp && (comp->attr.pointer || comp->attr.allocatable)))
{
var = gfc_create_var (type, "pstr");
@ -3148,12 +3162,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* Bundle in the string length. */
se->string_length = len;
}
else if (sym->ts.type == BT_CHARACTER)
else if (ts.type == BT_CHARACTER)
{
/* Dereference for character pointer results. */
if (sym->attr.pointer || sym->attr.allocatable)
se->expr = build_fold_indirect_ref_loc (input_location,
var);
if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
|| (comp && (comp->attr.pointer || comp->attr.allocatable)))
se->expr = build_fold_indirect_ref_loc (input_location, var);
else
se->expr = var;
@ -3161,9 +3175,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
else
{
gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
se->expr = build_fold_indirect_ref_loc (input_location,
var);
gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
se->expr = build_fold_indirect_ref_loc (input_location, var);
}
}
}
@ -4237,7 +4250,9 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
/* Check character lengths if character expression. The test is only
really added if -fbounds-check is enabled. */
if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
&& !expr1->symtree->n.sym->attr.proc_pointer
&& !gfc_is_proc_ptr_comp (expr1, NULL))
{
gcc_assert (expr2->ts.type == BT_CHARACTER);
gcc_assert (lse.string_length && rse.string_length);

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

@ -2134,12 +2134,11 @@ gfc_get_derived_type (gfc_symbol * derived)
PACKED_STATIC,
!c->attr.target);
}
else if (c->attr.pointer)
else if (c->attr.pointer && !c->attr.proc_pointer)
field_type = build_pointer_type (field_type);
field = gfc_add_field_to_struct (&fieldlist, typenode,
get_identifier (c->name),
field_type);
get_identifier (c->name), field_type);
if (c->loc.lb)
gfc_set_decl_location (field, &c->loc);
else if (derived->declared_at.lb)

8
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,11 @@
2009-08-21 Janus Weil <janus@gcc.gnu.org>
PR fortran/41106
* gfortran.dg/proc_ptr_23.f90: New.
* gfortran.dg/proc_ptr_comp_15.f90: New.
* gfortran.dg/proc_ptr_comp_16.f90: New.
* gfortran.dg/proc_ptr_comp_17.f90: New.
2009-08-21 Jakub Jelinek <jakub@redhat.com>
PR c++/41131

19
gcc/testsuite/gfortran.dg/proc_ptr_23.f90 Normal file
View File

@ -0,0 +1,19 @@
! { dg-do run }
!
! PR 41106: [F03] Procedure Pointers with CHARACTER results
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
character(len=5) :: str
procedure(character(len=5)), pointer :: pp
pp => abc
print *,pp()
str = pp()
if (str/='abcde') call abort()
contains
function abc()
character(len=5) :: abc
abc = 'abcde'
end function abc
end

28
gcc/testsuite/gfortran.dg/proc_ptr_comp_15.f90 Normal file
View File

@ -0,0 +1,28 @@
! { dg-do run }
!
! PR 41106: [F03] Procedure Pointers with CHARACTER results
!
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
module m
type :: t
procedure(character(len=5)), pointer, nopass :: ptr
end type
contains
function abc()
character(len=5) :: abc
abc = 'abcde'
end function abc
end module m
use m
type(t) :: x
character(len=5) :: str
x%ptr => abc
print *,x%ptr()
str = x%ptr()
if (str/='abcde') call abort()
end
! { dg-final { cleanup-modules "m" } }

30
gcc/testsuite/gfortran.dg/proc_ptr_comp_16.f90 Normal file
View File

@ -0,0 +1,30 @@
! { dg-do run }
!
! PR 41106: [F03] Procedure Pointers with CHARACTER results
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
module m
type :: t
procedure(abc), pointer, nopass :: ptr
end type
contains
function abc(i)
integer :: i
character(len=i) :: abc
abc = 'abcde'
end function abc
end module m
use m
type(t) :: x
character(len=4) :: str
x%ptr => abc
print *,x%ptr(4)
if (x%ptr(4)/='abcd') call abort
str = x%ptr(3)
if (str/='abc') call abort()
end
! { dg-final { cleanup-modules "m" } }

32
gcc/testsuite/gfortran.dg/proc_ptr_comp_17.f90 Normal file
View File

@ -0,0 +1,32 @@
! { dg-do run }
!
! PR 41106: [F03] Procedure Pointers with CHARACTER results
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
module m
type :: t
procedure(abc), pointer, nopass :: ptr
end type
contains
function abc(arg)
character(len=5),pointer :: abc
character(len=5),target :: arg
abc => arg
end function abc
end module m
use m
type(t) :: x
character(len=5) :: str = 'abcde'
character(len=5), pointer :: strptr
x%ptr => abc
print *,x%ptr(str)
strptr => x%ptr(str)
if (strptr/='abcde') call abort()
str = 'fghij'
if (strptr/='fghij') call abort()
end
! { dg-final { cleanup-modules "m" } }