+2015-11-15 Paul Thomas <pault@gcc.gnu.org>
+
+ 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-11-14 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/67803
}
+/* 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. */
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
sym->binding_label = NULL;
}
- else if (sym->attr.flavor == FL_VARIABLE && module
+ else if (sym->attr.flavor == FL_VARIABLE && module
&& (strcmp (module, gsym->mod_name) != 0
|| strcmp (sym->name, gsym->sym_name) != 0))
{
index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
index, info->offset);
- if (expr && is_subref_array (expr))
+ 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);
}
+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. */
/* 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));
cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
size1, size2);
- neq_size = gfc_evaluate_now (cond, &fblock);
+
+ /* 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. */
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);
}
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);
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)));
+
+ /* 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)
{
else
{
tmp = parmse.string_length;
- if (TREE_CODE (tmp) != VAR_DECL)
+ 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);
}
}
/* Stabilize a string length for temporaries. */
- if (expr2->ts.type == BT_CHARACTER)
+ 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;
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)
+ 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
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
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);
}
}
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
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;
|| TREE_CODE (decl) == PARM_DECL)
&& ((GFC_DECL_SUBREF_ARRAY_P (decl)
&& !integer_zerop (GFC_DECL_SPAN (decl)))
- || GFC_DECL_CLASS (decl)))
- || vptr)
+ || GFC_DECL_CLASS (decl)
+ || span != NULL_TREE))
+ || vptr != NULL_TREE)
{
if (decl)
{
}
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 ();
}
gfc_add_expr_to_block (&block, res);
}
+ gfc_current_locus = code->loc;
gfc_set_backend_locus (&code->loc);
switch (code->op)
+2015-11-15 Paul Thomas <pault@gcc.gnu.org>
+
+ 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.
+
2015-11-14 Steven G. Kargl <kargl@gcc.gnu.org>
-
+
PR fortran/67803
* gfortran.dg/pr67803.f90: New test.
--- /dev/null
+! { dg-do run }
+!
+! Tests the fix for PR50221
+!
+! Contributed by Clive Page <clivegpage@gmail.com>
+! and Tobias Burnus <burnus@gcc.gnu.org>
+!
+! 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
--- /dev/null
+! { 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.
+!
+! Check that allocation with source = another deferred length is OK
+ allocate (array_copia, source = array_lineas)
+ if (any (array_copia .ne. array_fijo)) call abort
+ deallocate (array_lineas, array_copia)
+
+! Check that allocation with source = a non-deferred length is OK
+ allocate (array_lineas, 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, mold = [array_fijo(:)(1:2), array_fijo(:)(1:2)])
+ if (size (array_copia, 1) .ne. 4) call abort
+ if (LEN (array_copia, 1) .ne. 2) call abort
+
+! Check that allocation with MOLD = another deferred length is OK
+ allocate (array_lineas, mold = array_copia)
+ if (size (array_copia, 1) .ne. 4) call abort
+ if (LEN (array_copia, 1) .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
--- /dev/null
+! {dg_do run }
+!
+! Tests the fix for PR67674
+!
+! Contributed by Kristopher Kuhlman <kristopher.kuhlman@gmail.com>
+!
+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
--- /dev/null
+! { dg-do run }
+!
+! Check that PR50221 comment #4 is fixed.
+!
+! Contributed by Arjen Makus <arjen.markus895@gmail.com>
+!
+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
--- /dev/null
+! { dg-do run }
+!
+! Tests that PR63932 stays fixed.
+!
+! Contributed by Valery Weber <valeryweber@hotmail.com>
+!
+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
--- /dev/null
+! { dg-do run }
+!
+! Tests that PR66408 stays fixed.
+!
+! Contributed by <werner.blokbuster@gmail.com>
+!
+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
--- /dev/null
+! { 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
projects / gcc.git / commitdiff