[Patch/gfortran] PR16939, 17192,17193,17202,18689,18890 &21297
Paul Thomas
paulthomas2@wanadoo.fr
Wed May 25 06:38:00 GMT 2005
This patch deals with all the issues concerning character pointers,
assignments of characters and passing array pointers as procedure arguments.
I believe that the meta-bug 17193 is resolved.
Fortran changelog entry.
2005-05-25 Paul Thomas <pault@gcc.gnu.org>
PR fortran/16939
PR fortran/17192
PR fortran/17193
PR fortran/17202
PR fortran/18689
PR fortran/18890
PR fortran/21297
* fortran/trans-array.c (gfc_conv_resolve_dependencies): Add string
length to temp_ss for character pointer array assignments.
* fortran/trans-expr.c (gfc_conv_variable): Correct errors in
dereferencing of characters and character pointers.
* fortran/trans-expr.c (gfc_conv_function_call): Provide string
length as return argument for various kinds of handling of return.
Return a char[]* temporary for character pointer functions and
dereference the temporary upon return.
Bootstrapped and regtested on i686/RH9. OK for 4.1?
I have realised that one more test case is needed to check that dependencies
are indeed resolved. This will follow with the testsuite changelog entry.
In fact, might it be an idea to extend these tests to cover the intrinsic
and derived types? It might be nice, for a change, to have testsuite
entries for the things that work, rather than those that are broken!
Paul Thomas
Enclosures: patch, character_pointer_assign.f90, character_pointer_dummy.f90
and character_pointer_func.f90.
Index: gcc/gcc/fortran/trans-array.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-array.c,v
retrieving revision 1.43
diff -c -3 -p -r1.43 trans-array.c
*** gcc/gcc/fortran/trans-array.c 29 Apr 2005 15:31:38 -0000 1.43
--- gcc/gcc/fortran/trans-array.c 25 May 2005 06:12:25 -0000
*************** gfc_conv_resolve_dependencies (gfc_loopi
*** 2342,2348 ****
loop->temp_ss->type = GFC_SS_TEMP;
loop->temp_ss->data.temp.type =
gfc_get_element_type (TREE_TYPE (dest->data.info.descriptor));
! loop->temp_ss->string_length = NULL_TREE;
loop->temp_ss->data.temp.dimen = loop->dimen;
loop->temp_ss->next = gfc_ss_terminator;
gfc_add_ss_to_loop (loop, loop->temp_ss);
--- 2342,2348 ----
loop->temp_ss->type = GFC_SS_TEMP;
loop->temp_ss->data.temp.type =
gfc_get_element_type (TREE_TYPE (dest->data.info.descriptor));
! loop->temp_ss->string_length = dest->string_length;
loop->temp_ss->data.temp.dimen = loop->dimen;
loop->temp_ss->next = gfc_ss_terminator;
gfc_add_ss_to_loop (loop, loop->temp_ss);
Index: gcc/gcc/fortran/trans-expr.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-expr.c,v
retrieving revision 1.44
diff -c -3 -p -r1.44 trans-expr.c
*** gcc/gcc/fortran/trans-expr.c 11 May 2005 14:52:27 -0000 1.44
--- gcc/gcc/fortran/trans-expr.c 25 May 2005 06:12:28 -0000
*************** gfc_conv_variable (gfc_se * se, gfc_expr
*** 354,383 ****
se->expr = gfc_build_addr_expr (NULL, se->expr);
}
return;
! }
!
! /* Dereference scalar dummy variables. */
! if (sym->attr.dummy
! && sym->ts.type != BT_CHARACTER
! && !sym->attr.dimension)
! se->expr = gfc_build_indirect_ref (se->expr);
!
! /* Dereference scalar hidden result. */
! if (gfc_option.flag_f2c
! && (sym->attr.function || sym->attr.result)
! && sym->ts.type == BT_COMPLEX
! && !sym->attr.dimension)
! se->expr = gfc_build_indirect_ref (se->expr);
!
! /* Dereference pointer variables. */
! if ((sym->attr.pointer || sym->attr.allocatable)
! && (sym->attr.dummy
! || sym->attr.result
! || sym->attr.function
! || !sym->attr.dimension)
! && sym->ts.type != BT_CHARACTER)
! se->expr = gfc_build_indirect_ref (se->expr);
ref = expr->ref;
}
--- 354,396 ----
se->expr = gfc_build_addr_expr (NULL, se->expr);
}
return;
! }
+
+ /* Dereference the expression, where needed. Since characters
+ are entirely different from other types, they are treated
+ separately. */
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ /* Dereference character pointer dummy arguments
+ or results. */
+ if ((sym->attr.pointer || sym->attr.allocatable)
+ && ((sym->attr.dummy)
+ || (sym->attr.function
+ || sym->attr.result)))
+ se->expr = gfc_build_indirect_ref (se->expr);
+ }
+ else
+ {
+ /* Dereference non-charcter scalar dummy arguments. */
+ if ((sym->attr.dummy) && (!sym->attr.dimension))
+ se->expr = gfc_build_indirect_ref (se->expr);
+
+ /* Dereference scalar hidden result. */
+ if ((gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX)
+ && (sym->attr.function || sym->attr.result)
+ && (!sym->attr.dimension))
+ se->expr = gfc_build_indirect_ref (se->expr);
+
+ /* Dereference non-character pointer variables.
+ These must be dummys or results or scalars. */
+ if ((sym->attr.pointer || sym->attr.allocatable)
+ && ((sym->attr.dummy)
+ || (sym->attr.function || sym->attr.result)
+ || (!sym->attr.dimension)))
+ se->expr = gfc_build_indirect_ref (se->expr);
+ }
+
ref = expr->ref;
}
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1083,1088 ****
--- 1096,1110 ----
var = NULL_TREE;
len = NULL_TREE;
+ /* Obtain the string length now because it is needed often below. */
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ gcc_assert (sym->ts.cl && sym->ts.cl->length
+ && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
+ len = gfc_conv_mpz_to_tree
+ (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
+ }
+
if (se->ss != NULL)
{
if (!sym->attr.elemental)
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1097,1102 ****
--- 1119,1127 ----
/* Access the previously obtained result. */
gfc_conv_tmp_array_ref (se);
gfc_advance_se_ss_chain (se);
+
+ /* Bundle in the string length. */
+ se->string_length=len;
return;
}
}
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1108,1121 ****
byref = gfc_return_by_reference (sym);
if (byref)
{
! if (se->direct_byref)
! arglist = gfc_chainon_list (arglist, se->expr);
else if (sym->result->attr.dimension)
{
! gcc_assert (se->loop && se->ss);
/* Set the type of the array. */
tmp = gfc_typenode_for_spec (&sym->ts);
! info->dimen = se->loop->dimen;
/* Allocate a temporary to store the result. */
gfc_trans_allocate_temp_array (se->loop, info, tmp);
--- 1133,1158 ----
byref = gfc_return_by_reference (sym);
if (byref)
{
! if (se->direct_byref)
! {
! arglist = gfc_chainon_list (arglist, se->expr);
!
! /* Add string length to argument list. */
! if (sym->ts.type == BT_CHARACTER)
! {
! sym->ts.cl->backend_decl = len;
! arglist = gfc_chainon_list (arglist,
! convert (gfc_charlen_type_node, len));
! }
! }
else if (sym->result->attr.dimension)
{
! gcc_assert (se->loop && se->ss);
!
/* Set the type of the array. */
tmp = gfc_typenode_for_spec (&sym->ts);
! info->dimen = se->loop->dimen;
!
/* Allocate a temporary to store the result. */
gfc_trans_allocate_temp_array (se->loop, info, tmp);
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1124,1145 ****
gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
gfc_add_modify_expr (&se->pre, tmp,
convert (TREE_TYPE (tmp), integer_zero_node));
/* Pass the temporary as the first argument. */
tmp = info->descriptor;
tmp = gfc_build_addr_expr (NULL, tmp);
arglist = gfc_chainon_list (arglist, tmp);
}
else if (sym->ts.type == BT_CHARACTER)
{
! gcc_assert (sym->ts.cl && sym->ts.cl->length
! && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
! len = gfc_conv_mpz_to_tree
! (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
sym->ts.cl->backend_decl = len;
type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
type = build_pointer_type (type);
! var = gfc_conv_string_tmp (se, type, len);
arglist = gfc_chainon_list (arglist, var);
arglist = gfc_chainon_list (arglist,
convert (gfc_charlen_type_node, len));
--- 1161,1206 ----
gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
gfc_add_modify_expr (&se->pre, tmp,
convert (TREE_TYPE (tmp), integer_zero_node));
+
/* Pass the temporary as the first argument. */
tmp = info->descriptor;
tmp = gfc_build_addr_expr (NULL, tmp);
arglist = gfc_chainon_list (arglist, tmp);
+
+ /* Add string length to argument list. */
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ sym->ts.cl->backend_decl = len;
+ arglist = gfc_chainon_list (arglist,
+ convert (gfc_charlen_type_node, len));
+ }
+
}
else if (sym->ts.type == BT_CHARACTER)
{
!
! /* Pass the string length. */
sym->ts.cl->backend_decl = len;
type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
type = build_pointer_type (type);
! /* Return an address to a char[4]* temporary for character pointers.
*/
! if (sym->attr.pointer || sym->attr.allocatable)
! {
! /* Build char[4] * pstr. */
! tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
! convert (gfc_charlen_type_node, integer_one_node));
! tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
tmp);
! tmp = build_array_type (gfc_character1_type_node, tmp);
! var = gfc_create_var (build_pointer_type (tmp), "pstr");
!
! /* Provide an address expression for the function arguments. */
! var = gfc_build_addr_expr (NULL, var);
! }
! else
! {
! var = gfc_conv_string_tmp (se, type, len);
! }
arglist = gfc_chainon_list (arglist, var);
arglist = gfc_chainon_list (arglist,
convert (gfc_charlen_type_node, len));
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1199,1215 ****
argss = gfc_walk_expr (arg->expr);
if (argss == gfc_ss_terminator)
! {
gfc_conv_expr_reference (&parmse, arg->expr);
! if (formal && formal->sym->attr.pointer
&& arg->expr->expr_type != EXPR_NULL)
! {
! /* Scalar pointer dummy args require an extra level of
! indirection. The null pointer already contains
! this level of indirection. */
! parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
! }
! }
else
{
/* If the procedure requires an explicit interface, the
--- 1260,1276 ----
argss = gfc_walk_expr (arg->expr);
if (argss == gfc_ss_terminator)
! {
gfc_conv_expr_reference (&parmse, arg->expr);
! if (formal && formal->sym->attr.pointer
&& arg->expr->expr_type != EXPR_NULL)
! {
! /* Scalar pointer dummy args require an extra level of
! indirection. The null pointer already contains
! this level of indirection. */
! parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
! }
! }
else
{
/* If the procedure requires an explicit interface, the
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1299,1308 ****
gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
}
se->expr = info->descriptor;
}
else if (sym->ts.type == BT_CHARACTER)
! {
! se->expr = var;
se->string_length = len;
}
else
--- 1360,1376 ----
gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
}
se->expr = info->descriptor;
+ /* Bundle in the string length. */
+ se->string_length = len;
}
else if (sym->ts.type == BT_CHARACTER)
! {
! /* Dereference for character pointer results. */
! if (sym->attr.pointer || sym->attr.allocatable)
! se->expr = gfc_build_indirect_ref (var);
! else
! se->expr = var;
!
se->string_length = len;
}
else
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1312,1317 ****
--- 1380,1386 ----
}
}
}
+
}
*************** gfc_trans_assignment (gfc_expr * expr1,
*** 2229,2235 ****
}
else
gfc_conv_expr (&lse, expr1);
!
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
gfc_add_expr_to_block (&body, tmp);
--- 2298,2304 ----
}
else
gfc_conv_expr (&lse, expr1);
!
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
gfc_add_expr_to_block (&body, tmp);
! { dg-do run }
program char_pointer_assign
! Test character pointer assignments, required
! to fix PR18890
! Provided by Paul Thomas pault@gcc.gnu.org
implicit none
character*4, target :: t1
character*4, target :: t2(4) =(/"lmno","lmno","lmno","lmno"/)
character*4 :: const
character*4, pointer :: c1, c3
character*4, pointer :: c2(:), c4(:)
allocate (c3, c4(4))
! Scalars first.
c3 = "lmno" ! pointer = constant
t1 = c3 ! target = pointer
c1 => t1 ! pointer =>target
c1(2:3) = "nm"
c3 = c1 ! pointer = pointer
c3(1:1) = "o"
c3(4:4) = "l"
c1 => c3 ! pointer => pointer
if (t1 /= "lnmo") call abort ()
if (c1 /= "onml") call abort ()
! Now arrays.
c4 = "lmno" ! pointer = constant
t2 = c4 ! target = pointer
c2 => t2 ! pointer =>target
const = c2(1)
const(2:3) ="nm" ! c2(:)(2:3) = "nm" is still broken
c2 = const
c4 = c2 ! pointer = pointer
const = c4(1)
const(1:1) ="o" ! c4(:)(1:1) = "o" is still broken
const(4:4) ="l" ! c4(:)(4:4) = "l" is still broken
c4 = const
c2 => c4 ! pointer => pointer
if (any (t2 /= "lnmo")) call abort ()
if (any (c2 /= "onml")) call abort ()
deallocate (c3, c4)
end program char_pointer_assign
! { dg-do run }
program char_pointer_dummy
! Test character pointer dummy arguments, required
! to fix PR16939 and PR18689
! Provided by Paul Thomas pault@gcc.gnu.org
implicit none
character*4 :: c0
character*4, pointer :: c1
character*4, pointer :: c2(:)
allocate (c1, c2(1))
! Check that we have not broken non-pointer characters.
c0 = "wxyz"
call foo (c0)
! Now the pointers
c1 = "wxyz"
call sfoo (c1)
c2 = "wxyz"
call afoo (c2)
deallocate (c1, c2)
contains
subroutine foo (cc1)
character*4 :: cc1
if (cc1 /= "wxyz") call abort ()
end subroutine foo
subroutine sfoo (sc1)
character*4, pointer :: sc1
if (sc1 /= "wxyz") call abort ()
end subroutine sfoo
subroutine afoo (ac1)
character*4, pointer :: ac1(:)
if (ac1(1) /= "wxyz") call abort ()
end subroutine afoo
end program char_pointer_dummy
! { dg-do run }
program char_pointer_func
! Test assignments from character pointer functions, required
! to fix PR17192 and PR17202
! Provided by Paul Thomas pault@gcc.gnu.org
implicit none
character*4 :: c0
character*4, pointer :: c1
character*4, pointer :: c2(:)
allocate (c1, c2(1))
! Check that we have not broken non-pointer characters.
c0 = foo ()
if (c0 /= "abcd") call abort ()
! Value assignments
c1 = sfoo ()
if (c1 /= "abcd") call abort ()
c2 = afoo (c0)
if (c2(1) /= "abcd") call abort ()
deallocate (c1, c2)
! Pointer assignments
c1 => sfoo ()
if (c1 /= "abcd") call abort ()
c2 => afoo (c0)
if (c2(1) /= "abcd") call abort ()
deallocate (c1, c2)
contains
function foo () result (cc1)
character*4 :: cc1
cc1 = "abcd"
end function foo
function sfoo () result (sc1)
character*4, pointer :: sc1
allocate (sc1)
sc1 = "abcd"
end function sfoo
function afoo (c0) result (ac1)
character*4 :: c0
character*4, pointer :: ac1(:)
allocate (ac1(1))
ac1 = "abcd"
end function afoo
end program char_pointer_func
More information about the Gcc-patches
mailing list