Dear All,
As promised, please find attached the version of this patch for
5-branch. The changes are small enough that I couldn't immediately see
any changes required in the text of the ChangeLog. I will look more
carefully tomorrow, add the "backported from trunk"s and the current
date. I intend to commit on Sunday evening, unless there is any
objection.
Bootstrapped and regtested in 5-branch on FC21/x86_64
Cheers
Paul
On 18 December 2015 at 19:12, Paul Richard Thomas
<[email protected]> wrote:
> Dear All,
>
> In running through the PRs assigned to me, I realised that I have not
> closed these PRs because I had promised to see if the patch would
> apply to 4.9 and 5 branch.
>
> I have just applied the patch to 5 branch and have found that, apart
> from two minor tweaks in trans.c, all was well. It bootstrapped
> and regtested fine, apart from deferred_character_2.f90. In this
> latter, deferred length SOURCE and MOLD do not work because the
> requisite patches in gfc_trans_allocate were not backported. In
> addition, I had to add explicit array specifications to the allocate
> statements.
>
> Should I get deferred length SOURCE and MOLD to work or apply the
> attached patch as it stands? Alternatively, I could forget about 4.9
> and 5 branches and close the PRs.
>
> I have added the ChangeLogs below.
>
> Cheers
>
> Paul
>
> 2015-12-18 Paul Thomas <[email protected]>
>
> PR fortran/50221
> PR fortran/68216
> PR fortran/63932
> PR fortran/66408
> * trans_array.c (gfc_conv_scalarized_array_ref): Pass the
> symbol decl for deferred character length array references.
> * trans-stmt.c (gfc_trans_allocate): Keep the string lengths
> to update deferred length character string lengths.
> * trans-types.c (gfc_get_dtype_rank_type); Use the string
> length of deferred character types for the dtype size.
> * trans.c (gfc_build_array_ref): For references to deferred
> character arrays, use the domain max value, if it is a variable
> to set the 'span' and use pointer arithmetic for acces to the
> element.
> (trans_code): Set gfc_current_locus for diagnostic purposes.
>
> PR fortran/67674
> * trans-expr.c (gfc_conv_procedure_call): Do not fix deferred
> string lengths of components.
>
> PR fortran/49954
> * resolve.c (deferred_op_assign): New function.
> (gfc_resolve_code): Call it.
> * trans-array.c (concat_str_length): New function.
> (gfc_alloc_allocatable_for_assignment): Jump directly to alloc/
> realloc blocks for deferred character length arrays because the
> string length might change, even if the shape is the same. Call
> concat_str_length to obtain the string length for concatenation
> since it is needed to compute the lhs string length.
> Set the descriptor dtype appropriately for the new string
> length.
> * trans-expr.c (gfc_trans_assignment_1): Use the rse string
> length for all characters, other than deferred types. For
> concatenation operators, push the rse.pre block to the inner
> most loop so that the temporary pointer and the assignments
> are properly placed.
>
> 2015-12-18 Paul Thomas <[email protected]>
>
> PR fortran/50221
> * gfortran.dg/deferred_character_1.f90: New test.
> * gfortran.dg/deferred_character_4.f90: New test for comment
> #4 of the PR.
>
> PR fortran/68216
> * gfortran.dg/deferred_character_2.f90: New test.
>
> PR fortran/67674
> * gfortran.dg/deferred_character_3.f90: New test.
>
> PR fortran/63932
> * gfortran.dg/deferred_character_5.f90: New test.
>
> PR fortran/66408
> * gfortran.dg/deferred_character_6.f90: New test.
>
> PR fortran/49954
> * gfortran.dg/deferred_character_7.f90: New test.
>
> On 15 November 2015 at 15:13, Paul Richard Thomas
> <[email protected]> wrote:
>> Dear Steve,
>>
>> Thanks for the review.
>>
>> Committed as revision 230396.
>>
>> My diagnosis of the last problem that Dominique found is correct.
>> However, I have not succeeded in fixing it and so the patch was
>> committed as review. I'll just have to return to the problem this
>> evening.
>>
>> Cheers
>>
>> Paul
>>
>> On 14 November 2015 at 21:10, Steve Kargl
>> <[email protected]> wrote:
>>> On Sat, Nov 14, 2015 at 07:25:29PM +0100, Paul Richard Thomas wrote:
>>>>
>>>> Following an email from Dominique to me, I think not. In the course of
>>>> fixing PR49954, I put right the setting of the descriptor dtype. Since
>>>> this gets passed to the IO runtime, I think that this is the reason
>>>> for the difference in behaviour.
>>>>
>>>> I think that another week of effort should put right gfortran's woes
>>>> with deferred characters. As well as concatenation problems that I
>>>> think I have fixed, parentheses cause instant death :-(
>>>>
>>>
>>> Hi Paul,
>>>
>>> I built and tested on both x86_64-*-freebsd and i386-*-freebsd.
>>> All tests passed.
>>>
>>> I read through the patch did not raise any red (or what
>>> the heck is he doing here) flags.
>>>
>>> OK to commit as this is a step in the right direction in
>>> dealing with deferred character issues.
>>>
>>> --
>>> Steve
>>
>>
>>
>> --
>> Outside of a dog, a book is a man's best friend. Inside of a dog it's
>> too dark to read.
>>
>> Groucho Marx
>
>
>
> --
> Outside of a dog, a book is a man's best friend. Inside of a dog it's
> too dark to read.
>
> Groucho Marx
--
The difference between genius and stupidity is; genius has its limits.
Albert Einstein
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 232163)
--- gcc/fortran/resolve.c (working copy)
*************** resolve_transfer (gfc_code *code)
*** 8494,8500 ****
return;
}
}
!
if (exp->expr_type == EXPR_STRUCTURE)
return;
--- 8494,8500 ----
return;
}
}
!
if (exp->expr_type == EXPR_STRUCTURE)
return;
*************** generate_component_assignments (gfc_code
*** 9993,9998 ****
--- 9993,10042 ----
}
+ /* Deferred character length assignments from an operator expression
+ require a temporary because the character length of the lhs can
+ change in the course of the assignment. */
+
+ static bool
+ deferred_op_assign (gfc_code **code, gfc_namespace *ns)
+ {
+ gfc_expr *tmp_expr;
+ gfc_code *this_code;
+
+ if (!((*code)->expr1->ts.type == BT_CHARACTER
+ && (*code)->expr1->ts.deferred && (*code)->expr1->rank
+ && (*code)->expr2->expr_type == EXPR_OP))
+ return false;
+
+ if (!gfc_check_dependency ((*code)->expr1, (*code)->expr2, 1))
+ return false;
+
+ tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
+ tmp_expr->where = (*code)->loc;
+
+ /* A new charlen is required to ensure that the variable string
+ length is different to that of the original lhs. */
+ tmp_expr->ts.u.cl = gfc_get_charlen();
+ tmp_expr->symtree->n.sym->ts.u.cl = tmp_expr->ts.u.cl;
+ tmp_expr->ts.u.cl->next = (*code)->expr2->ts.u.cl->next;
+ (*code)->expr2->ts.u.cl->next = tmp_expr->ts.u.cl;
+
+ tmp_expr->symtree->n.sym->ts.deferred = 1;
+
+ this_code = build_assignment (EXEC_ASSIGN,
+ (*code)->expr1,
+ gfc_copy_expr (tmp_expr),
+ NULL, NULL, (*code)->loc);
+
+ (*code)->expr1 = tmp_expr;
+
+ this_code->next = (*code)->next;
+ (*code)->next = this_code;
+
+ return true;
+ }
+
+
/* Given a block of code, recursively resolve everything pointed to by this
code block. */
*************** gfc_resolve_code (gfc_code *code, gfc_na
*** 10190,10195 ****
--- 10234,10244 ----
goto call;
}
+ /* Check for dependencies in deferred character length array
+ assignments and generate a temporary, if necessary. */
+ if (code->op == EXEC_ASSIGN && deferred_op_assign (&code, ns))
+ break;
+
/* F03 7.4.1.3 for non-allocatable, non-pointer components. */
if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED
&& code->expr1->ts.u.derived->attr.defined_assign_comp)
*************** gfc_verify_binding_labels (gfc_symbol *s
*** 10562,10568 ****
sym->binding_label = NULL;
}
! else if (sym->attr.flavor == FL_VARIABLE && module
&& (strcmp (module, gsym->mod_name) != 0
|| strcmp (sym->name, gsym->sym_name) != 0))
{
--- 10611,10617 ----
sym->binding_label = NULL;
}
! else if (sym->attr.flavor == FL_VARIABLE && module
&& (strcmp (module, gsym->mod_name) != 0
|| strcmp (sym->name, gsym->sym_name) != 0))
{
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 232163)
--- gcc/fortran/trans-array.c (working copy)
*************** gfc_conv_scalarized_array_ref (gfc_se *
*** 3112,3118 ****
index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
index, info->offset);
! if (expr && is_subref_array (expr))
decl = expr->symtree->n.sym->backend_decl;
tmp = build_fold_indirect_ref_loc (input_location, info->data);
--- 3112,3119 ----
index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
index, info->offset);
! if (expr && (is_subref_array (expr)
! || (expr->ts.deferred && expr->expr_type == EXPR_VARIABLE)))
decl = expr->symtree->n.sym->backend_decl;
tmp = build_fold_indirect_ref_loc (input_location, info->data);
*************** gfc_is_reallocatable_lhs (gfc_expr *expr
*** 8269,8274 ****
--- 8270,8344 ----
}
+ static tree
+ concat_str_length (gfc_expr* expr)
+ {
+ tree type;
+ tree len1;
+ tree len2;
+ gfc_se se;
+
+ type = gfc_typenode_for_spec (&expr->value.op.op1->ts);
+ len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+ if (len1 == NULL_TREE)
+ {
+ if (expr->value.op.op1->expr_type == EXPR_OP)
+ len1 = concat_str_length (expr->value.op.op1);
+ else if (expr->value.op.op1->expr_type == EXPR_CONSTANT)
+ len1 = build_int_cst (gfc_charlen_type_node,
+ expr->value.op.op1->value.character.length);
+ else if (expr->value.op.op1->ts.u.cl->length)
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, expr->value.op.op1->ts.u.cl->length);
+ len1 = se.expr;
+ }
+ else
+ {
+ /* Last resort! */
+ gfc_init_se (&se, NULL);
+ se.want_pointer = 1;
+ se.descriptor_only = 1;
+ gfc_conv_expr (&se, expr->value.op.op1);
+ len1 = se.string_length;
+ }
+ }
+
+ type = gfc_typenode_for_spec (&expr->value.op.op2->ts);
+ len2 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+ if (len2 == NULL_TREE)
+ {
+ if (expr->value.op.op2->expr_type == EXPR_OP)
+ len2 = concat_str_length (expr->value.op.op2);
+ else if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
+ len2 = build_int_cst (gfc_charlen_type_node,
+ expr->value.op.op2->value.character.length);
+ else if (expr->value.op.op2->ts.u.cl->length)
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, expr->value.op.op2->ts.u.cl->length);
+ len2 = se.expr;
+ }
+ else
+ {
+ /* Last resort! */
+ gfc_init_se (&se, NULL);
+ se.want_pointer = 1;
+ se.descriptor_only = 1;
+ gfc_conv_expr (&se, expr->value.op.op2);
+ len2 = se.string_length;
+ }
+ }
+
+ gcc_assert(len1 && len2);
+ len1 = fold_convert (gfc_charlen_type_node, len1);
+ len2 = fold_convert (gfc_charlen_type_node, len2);
+
+ return fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_charlen_type_node, len1, len2);
+ }
+
+
/* Allocate the lhs of an assignment to an allocatable array, otherwise
reallocate it. */
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8366,8371 ****
--- 8436,8447 ----
/* Allocate if data is NULL. */
cond_null = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
array1, build_int_cst (TREE_TYPE (array1), 0));
+
+ if (expr1->ts.deferred)
+ cond_null = gfc_evaluate_now (boolean_true_node, &fblock);
+ else
+ cond_null= gfc_evaluate_now (cond_null, &fblock);
+
tmp = build3_v (COND_EXPR, cond_null,
build1_v (GOTO_EXPR, jump_label1),
build_empty_stmt (input_location));
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8454,8460 ****
cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
size1, size2);
! neq_size = gfc_evaluate_now (cond, &fblock);
/* Deallocation of allocatable components will have to occur on
reallocation. Fix the old descriptor now. */
--- 8530,8542 ----
cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
size1, size2);
!
! /* If the lhs is deferred length, assume that the element size
! changes and force a reallocation. */
! if (expr1->ts.deferred)
! neq_size = gfc_evaluate_now (boolean_true_node, &fblock);
! else
! neq_size = gfc_evaluate_now (cond, &fblock);
/* Deallocation of allocatable components will have to occur on
reallocation. Fix the old descriptor now. */
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8559,8564 ****
--- 8641,8652 ----
else
{
tmp = expr2->ts.u.cl->backend_decl;
+ if (!tmp && expr2->expr_type == EXPR_OP
+ && expr2->value.op.op == INTRINSIC_CONCAT)
+ {
+ tmp = concat_str_length (expr2);
+ expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
+ }
tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
}
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8586,8591 ****
--- 8674,8695 ----
size2, size_one_node);
size2 = gfc_evaluate_now (size2, &fblock);
+ /* For deferred character length, the 'size' field of the dtype might
+ have changed so set the dtype. */
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
+ && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+ {
+ tree type;
+ tmp = gfc_conv_descriptor_dtype (desc);
+ if (expr2->ts.u.cl->backend_decl)
+ type = gfc_typenode_for_spec (&expr2->ts);
+ else
+ type = gfc_typenode_for_spec (&expr1->ts);
+
+ gfc_add_modify (&fblock, tmp,
+ gfc_get_dtype_rank_type (expr1->rank,type));
+ }
+
/* Realloc expression. Note that the scalarizer uses desc.data
in the array reference - (*desc.data)[<element>]. */
gfc_init_block (&realloc_block);
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8628,8635 ****
1, size2);
gfc_conv_descriptor_data_set (&alloc_block,
desc, tmp);
! tmp = gfc_conv_descriptor_dtype (desc);
! gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
if ((expr1->ts.type == BT_DERIVED)
&& expr1->ts.u.derived->attr.alloc_comp)
{
--- 8732,8747 ----
1, size2);
gfc_conv_descriptor_data_set (&alloc_block,
desc, tmp);
!
! /* We already set the dtype in the case of deferred character
! length arrays. */
! if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
! && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred))
! {
! tmp = gfc_conv_descriptor_dtype (desc);
! gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
! }
!
if ((expr1->ts.type == BT_DERIVED)
&& expr1->ts.u.derived->attr.alloc_comp)
{
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 232163)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5343,5349 ****
else
{
tmp = parmse.string_length;
! if (TREE_CODE (tmp) != VAR_DECL)
tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
}
--- 5343,5350 ----
else
{
tmp = parmse.string_length;
! if (TREE_CODE (tmp) != VAR_DECL
! && TREE_CODE (tmp) != COMPONENT_REF)
tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
}
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 8998,9005 ****
}
/* Stabilize a string length for temporaries. */
! if (expr2->ts.type == BT_CHARACTER)
string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
else
string_length = NULL_TREE;
--- 8999,9008 ----
}
/* Stabilize a string length for temporaries. */
! if (expr2->ts.type == BT_CHARACTER && !expr2->ts.deferred)
string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
+ else if (expr2->ts.type == BT_CHARACTER)
+ string_length = rse.string_length;
else
string_length = NULL_TREE;
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 9033,9040 ****
the function call must happen before the (re)allocation of the lhs -
otherwise the character length of the result is not known.
NOTE: This relies on having the exact dependence of the length type
! parameter available to the caller; gfortran saves it in the .mod files.
*/
! if (flag_realloc_lhs && expr2->ts.type == BT_CHARACTER &&
expr1->ts.deferred)
gfc_add_block_to_block (&block, &rse.pre);
/* Nullify the allocatable components corresponding to those of the lhs
--- 9036,9049 ----
the function call must happen before the (re)allocation of the lhs -
otherwise the character length of the result is not known.
NOTE: This relies on having the exact dependence of the length type
! parameter available to the caller; gfortran saves it in the .mod files.
! NOTE ALSO: The concatenation operation generates a temporary pointer,
! whose allocation must go to the innermost loop. */
! if (flag_realloc_lhs
! && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
! && !(lss != gfc_ss_terminator
! && expr2->expr_type == EXPR_OP
! && expr2->value.op.op == INTRINSIC_CONCAT))
gfc_add_block_to_block (&block, &rse.pre);
/* Nullify the allocatable components corresponding to those of the lhs
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 232163)
--- gcc/fortran/trans-stmt.c (working copy)
*************** gfc_trans_allocate (gfc_code * code)
*** 5119,5124 ****
--- 5119,5125 ----
tree label_finish;
tree memsz;
tree al_vptr, al_len;
+ tree def_str_len = NULL_TREE;
/* If an expr3 is present, then store the tree for accessing its
_vptr, and _len components in the variables, respectively. The
element size, i.e. _vptr%size, is stored in expr3_esize. Any of
*************** gfc_trans_allocate (gfc_code * code)
*** 5381,5386 ****
--- 5382,5388 ----
expr3_esize = fold_build2_loc (input_location, MULT_EXPR,
TREE_TYPE (se_sz.expr),
tmp, se_sz.expr);
+ def_str_len = gfc_evaluate_now (se_sz.expr, &block);
}
}
*************** gfc_trans_allocate (gfc_code * code)
*** 5432,5437 ****
--- 5434,5450 ----
se.want_pointer = 1;
se.descriptor_only = 1;
+
+ if (expr->ts.type == BT_CHARACTER
+ && expr->ts.deferred
+ && TREE_CODE (expr->ts.u.cl->backend_decl) == VAR_DECL
+ && def_str_len != NULL_TREE)
+ {
+ tmp = expr->ts.u.cl->backend_decl;
+ gfc_add_modify (&block, tmp,
+ fold_convert (TREE_TYPE (tmp), def_str_len));
+ }
+
gfc_conv_expr (&se, expr);
if (expr->ts.type == BT_CHARACTER && expr->ts.deferred)
/* se.string_length now stores the .string_length variable of expr
Index: gcc/fortran/trans.c
===================================================================
*** gcc/fortran/trans.c (revision 232163)
--- gcc/fortran/trans.c (working copy)
*************** gfc_build_array_ref (tree base, tree off
*** 344,349 ****
--- 344,361 ----
type = TREE_TYPE (type);
+ /* Use pointer arithmetic for deferred character length array
+ references. */
+ if (type && TREE_CODE (type) == ARRAY_TYPE
+ && TYPE_MAXVAL (TYPE_DOMAIN (type)) != NULL_TREE
+ && TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type))) == VAR_DECL
+ && decl
+ && DECL_CONTEXT (TYPE_MAXVAL (TYPE_DOMAIN (type)))
+ == DECL_CONTEXT (decl))
+ span = TYPE_MAXVAL (TYPE_DOMAIN (type));
+ else
+ span = NULL_TREE;
+
if (DECL_P (base))
TREE_ADDRESSABLE (base) = 1;
*************** gfc_build_array_ref (tree base, tree off
*** 358,364 ****
|| TREE_CODE (decl) == PARM_DECL)
&& ((GFC_DECL_SUBREF_ARRAY_P (decl)
&& !integer_zerop (GFC_DECL_SPAN(decl)))
! || GFC_DECL_CLASS (decl)))
{
if (GFC_DECL_CLASS (decl))
{
--- 370,377 ----
|| TREE_CODE (decl) == PARM_DECL)
&& ((GFC_DECL_SUBREF_ARRAY_P (decl)
&& !integer_zerop (GFC_DECL_SPAN(decl)))
! || GFC_DECL_CLASS (decl)
! || span != NULL_TREE))
{
if (GFC_DECL_CLASS (decl))
{
*************** gfc_build_array_ref (tree base, tree off
*** 377,382 ****
--- 390,397 ----
}
else if (GFC_DECL_SUBREF_ARRAY_P (decl))
span = GFC_DECL_SPAN(decl);
+ else if (span)
+ span = fold_convert (gfc_array_index_type, span);
else
gcc_unreachable ();
*************** trans_code (gfc_code * code, tree cond)
*** 1667,1672 ****
--- 1682,1688 ----
gfc_add_expr_to_block (&block, res);
}
+ gfc_current_locus = code->loc;
gfc_set_backend_locus (&code->loc);
switch (code->op)
Index: gcc/testsuite/gfortran.dg/deferred_character_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_1.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_1.f90 (working copy)
***************
*** 0 ****
--- 1,40 ----
+ ! { dg-do run }
+ !
+ ! Tests the fix for PR50221
+ !
+ ! Contributed by Clive Page <[email protected]>
+ ! and Tobias Burnus <[email protected]>
+ !
+ ! This is from comment #2 by Tobias Burnus.
+ !
+ module m
+ character(len=:), save, allocatable :: str(:)
+ character(len=2), parameter :: const(3) = ["a1", "b2", "c3"]
+ end
+
+ use m
+ call test()
+ if(allocated(str)) deallocate(str)
+ call foo
+ contains
+ subroutine test()
+ call doit()
+ ! print *, 'strlen=',len(str),' / array size =',size(str)
+ ! print '(3a)', '>',str(1),'<'
+ ! print '(3a)', '>',str(2),'<'
+ ! print '(3a)', '>',str(3),'<'
+ if (any (str .ne. const)) call abort
+ end subroutine test
+ subroutine doit()
+ str = const
+ end subroutine doit
+ subroutine foo
+ !
+ ! This is the original PR from Clive Page
+ !
+ character(:), allocatable, dimension(:) :: array
+ array = (/'xx', 'yy', 'zz'/)
+ ! print *, 'array=', array, len(array(1)), size(array)
+ if (any (array .ne. ["xx", "yy", "zz"])) call abort
+ end subroutine
+ end
Index: gcc/testsuite/gfortran.dg/deferred_character_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_2.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_2.f90 (working copy)
***************
*** 0 ****
--- 1,89 ----
+ ! { dg-do run }
+ !
+ ! Tests the fix for PR68216
+ !
+ ! Reported on clf:
https://groups.google.com/forum/#!topic/comp.lang.fortran/eWQTKfqKLZc
+ !
+ PROGRAM hello
+ !
+ ! This is based on the first testcase, from Francisco (Ayyy LMAO). Original
+ ! lines are commented out. The second testcase from this thread is acalled
+ ! at the end of the program.
+ !
+ IMPLICIT NONE
+
+ CHARACTER(LEN=:),DIMENSION(:),ALLOCATABLE :: array_lineas
+ CHARACTER(LEN=:),DIMENSION(:),ALLOCATABLE :: array_copia
+ character (3), dimension (2) :: array_fijo = ["abc","def"]
+ character (100) :: buffer
+ INTEGER :: largo , cant_lineas , i
+
+ write (buffer, "(2a3)") array_fijo
+
+ ! WRITE(*,*) ' Escriba un numero para el largo de cada linea'
+ ! READ(*,*) largo
+ largo = LEN (array_fijo)
+
+ ! WRITE(*,*) ' Escriba la cantidad de lineas'
+ ! READ(*,*) cant_lineas
+ cant_lineas = size (array_fijo, 1)
+
+ ALLOCATE(CHARACTER(LEN=largo) :: array_lineas(cant_lineas))
+
+ ! WRITE(*,*) 'Escriba el array', len(array_lineas), size(array_lineas)
+ READ(buffer,"(2a3)") (array_lineas(i),i=1,cant_lineas)
+
+ ! WRITE(*,*) 'Array guardado: '
+ ! DO i=1,cant_lineas
+ ! WRITE(*,*) array_lineas(i)
+ ! ENDDO
+ if (any (array_lineas .ne. array_fijo)) call abort
+
+ ! The following are additional tests beyond that of the original.
+ ! NOTE: These tests all work in 6 branch but those involving deferred length
+ ! SOURCE or MOLD do not work correctly in 5 branch because the requisite
+ ! patches to gfc_trans_allocate have not been backported.
+ !
+ ! Check that allocation with source = another deferred length is OK
+ ! allocate (array_copia(size (array_lineas, 1)), source = array_lineas)
+ ! if (any (array_copia .ne. array_fijo)) call abort
+ ! deallocate (array_lineas, array_copia)
+ deallocate (array_lineas)
+
+ ! Check that allocation with source = a non-deferred length is OK
+ allocate (array_lineas(size (array_fijo, 1)), source = array_fijo)
+ if (any (array_lineas .ne. array_fijo)) call abort
+ deallocate (array_lineas)
+
+ ! Check that allocation with MOLD = a non-deferred length is OK
+ allocate (array_copia(4), mold = [array_fijo(:)(1:2),
array_fijo(:)(1:2)])
+ if (size (array_copia, 1) .ne. 4) call abort
+ if (LEN (array_copia) .ne. 2) call abort
+
+ ! Check that allocation with MOLD = another deferred length is OK
+ ! allocate (array_lineas(4), mold = array_copia)
+ ! if (size (array_lineas, 1) .ne. 4) call abort
+ ! if (LEN (array_lineas) .ne. 2) call abort
+ ! deallocate (array_lineas, array_copia)
+
+ ! READ(*,*)
+ call testdefchar
+ contains
+ subroutine testdefchar
+ !
+ ! This is the testcase in the above thread from Blokbuster
+ !
+ implicit none
+ character(:), allocatable :: test(:)
+
+ allocate(character(3) :: test(2))
+ test(1) = 'abc'
+ test(2) = 'def'
+ if (any (test .ne. ['abc', 'def'])) call abort
+
+ test = ['aa','bb','cc']
+ if (any (test .ne. ['aa', 'bb', 'cc'])) call abort
+
+ end subroutine testdefchar
+
+ END PROGRAM
Index: gcc/testsuite/gfortran.dg/deferred_character_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_3.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_3.f90 (working copy)
***************
*** 0 ****
--- 1,46 ----
+ ! {dg_do run }
+ !
+ ! Tests the fix for PR67674
+ !
+ ! Contributed by Kristopher Kuhlman <[email protected]>
+ !
+ program test
+ implicit none
+
+ type string_type
+ character(len=:), allocatable :: name
+ end type string_type
+ type(string_type), allocatable :: my_string_type
+
+ allocate(my_string_type)
+ allocate(character(len=0) :: my_string_type%name)
+
+ ! print *, 'length main program before',len(my_string_type%name)
+
+ call inputreadword1(my_string_type%name)
+
+ ! print *, 'length main program after',len(my_string_type%name)
+ ! print *, 'final result:',my_string_type%name
+ if (my_string_type%name .ne. 'here the word is finally set') call abort
+
+ contains
+ subroutine inputreadword1(word_intermediate)
+ character(len=:), allocatable :: word_intermediate
+
+ ! print *, 'length intermediate before',len(word_intermediate)
+ call inputreadword2(word_intermediate)
+ ! print *, 'length intermediate after',len(word_intermediate)
+ ! print *, word_intermediate
+
+ end subroutine inputreadword1
+
+ subroutine inputreadword2(word)
+ character(len=:), allocatable :: word
+
+ ! print *, 'length inner before',len(word)
+ word = 'here the word is finally set' ! want automatic reallocation to
happen here
+ ! print *, 'length inner after',len(word)
+ ! print *, word
+
+ end subroutine inputreadword2
+ end program test
Index: gcc/testsuite/gfortran.dg/deferred_character_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_4.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_4.f90 (working copy)
***************
*** 0 ****
--- 1,30 ----
+ ! { dg-do run }
+ !
+ ! Check that PR50221 comment #4 is fixed.
+ !
+ ! Contributed by Arjen Makus <[email protected]>
+ !
+ program chk_alloc_string
+ implicit none
+
+ character(len=:), dimension(:), allocatable :: strings
+ character(20) :: buffer
+ integer :: i
+
+ allocate( character(10):: strings(1:3) )
+
+ strings = [ "A ", "C ", "ABCD", "V " ]
+
+ if (len(strings) .ne. 4) call abort
+ if (size(strings, 1) .ne. 4) call abort
+ if (any (strings .ne. [character(len=4) :: "A", "C", "ABCD", "V"])) call
abort
+
+ strings = [character(len=4) :: "A", "C", "ABCDE", "V", "zzzz"]
+
+ if (len(strings) .ne. 4) call abort
+ if (size(strings, 1) .ne. 5) call abort
+ if (any (strings .ne. [character(len=4) :: "A", "C", "ABCD", "V",
"zzzz"])) call abort
+
+ write (buffer, "(5a4)") strings
+ if (buffer .ne. "A C ABCDV zzzz") call abort
+ end program chk_alloc_string
Index: gcc/testsuite/gfortran.dg/deferred_character_5.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_5.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_5.f90 (working copy)
***************
*** 0 ****
--- 1,32 ----
+ ! { dg-do run }
+ !
+ ! Tests that PR63932 stays fixed.
+ !
+ ! Contributed by Valery Weber <[email protected]>
+ !
+ module mod
+ type :: t
+ character(:), allocatable :: c
+ integer :: i
+ contains
+ procedure, pass :: get
+ end type t
+ type :: u
+ character(:), allocatable :: c
+ end type u
+ contains
+ subroutine get(this, a)
+ class(t), intent(in) :: this
+ character(:), allocatable, intent(out), optional :: a
+ if (present (a)) a = this%c
+ end subroutine get
+ end module mod
+
+ program test
+ use mod
+ type(t) :: a
+ type(u) :: b
+ a%c = 'something'
+ call a%get (a = b%c)
+ if (b%c .ne. 'something') call abort
+ end program test
Index: gcc/testsuite/gfortran.dg/deferred_character_6.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_6.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_6.f90 (working copy)
***************
*** 0 ****
--- 1,54 ----
+ ! { dg-do run }
+ !
+ ! Tests that PR66408 stays fixed.
+ !
+ ! Contributed by <[email protected]>
+ !
+ module mytest
+
+ implicit none
+
+ type vary
+ character(:), allocatable :: string
+ end type vary
+
+ interface assignment(=)
+ module procedure char_eq_vary
+ end interface assignment(=)
+
+ contains
+
+ subroutine char_eq_vary(my_char,my_vary)
+ character(:), allocatable, intent(out) :: my_char
+ type(vary), intent(in) :: my_vary
+ my_char = my_vary%string
+ end subroutine char_eq_vary
+
+ end module mytest
+
+
+ program thistest
+
+ use mytest, only: vary, assignment(=)
+ implicit none
+
+ character(:), allocatable :: test_char
+ character(14), parameter :: str = 'example string'
+ type(vary) :: test_vary
+ type(vary) :: my_stuff
+
+
+ test_vary%string = str
+ if (test_vary%string .ne. str) call abort
+
+ ! This previously gave a blank string.
+ my_stuff%string = test_vary
+ if (my_stuff%string .ne. str) call abort
+
+ test_char = test_vary
+ if (test_char .ne. str) call abort
+
+ my_stuff = test_vary
+ if (my_stuff%string .ne. str) call abort
+
+ end program thistest
Index: gcc/testsuite/gfortran.dg/deferred_character_7.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_7.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_7.f90 (working copy)
***************
*** 0 ****
--- 1,39 ----
+ ! { dg-do run }
+ !
+ ! Tests the fix for pr49954, in which concatenation to deferred length
character
+ ! arrays, at best, did not work correctly.
+ !
+ !
+ !
+ implicit none
+ character(len=:), allocatable :: a1(:)
+ character(len=:), allocatable :: a2(:), a3(:)
+ character(len=:), allocatable :: b1
+ character(len=:), allocatable :: b2
+ character(8) :: chr = "IJKLMNOP"
+ character(48) :: buffer
+
+ a1 = ["ABCDEFGH","abcdefgh"]
+ a2 = "_"//a1//chr//"_"
+ if (any (a2 .ne. ["_ABCDEFGHIJKLMNOP_","_abcdefghIJKLMNOP_"])) call abort
+
+ ! Check that the descriptor dtype is OK - the array write needs it.
+ write (buffer, "(2a18)") a2
+ if (trim (buffer) .ne. "_ABCDEFGHIJKLMNOP__abcdefghIJKLMNOP_") call abort
+
+ ! Make sure scalars survived the fix!
+ b1 = "ABCDEFGH"
+ b2 = "_"//b1//chr//"_"
+ if (b2 .ne. "_ABCDEFGHIJKLMNOP_") call abort
+
+ ! Check the dependency is detected and dealt with by generation of a
temporary.
+ a1 = "?"//a1//"?"
+ if (any (a1 .ne. ["?ABCDEFGH?","?abcdefgh?"])) call abort
+ ! With an array reference...
+ a1 = "?"//a1(1:2)//"?"
+ if (any (a1 .ne. ["??ABCDEFGH??","??abcdefgh??"])) call abort
+ !... together with a substring.
+ a1 = "?"//a1(1:1)(2:4)//"?"
+ if (any (a1 .ne. ["??AB?"])) call abort
+ contains
+ end
