Index: gcc/fortran/resolve.c =================================================================== *** gcc/fortran/resolve.c (revision 230837) --- gcc/fortran/resolve.c (working copy) *************** generate_component_assignments (gfc_code *** 9992,9997 **** --- 9992,10041 ---- } + /* 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 *** 10189,10194 **** --- 10233,10243 ---- 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) Index: gcc/fortran/trans-array.c =================================================================== *** gcc/fortran/trans-array.c (revision 230837) --- 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 *** 8267,8272 **** --- 8268,8342 ---- } + 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 *** 8364,8369 **** --- 8434,8445 ---- /* 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 *** 8452,8457 **** --- 8528,8539 ---- 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 *************** gfc_alloc_allocatable_for_assignment (gf *** 8557,8562 **** --- 8639,8650 ---- 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 *** 8584,8589 **** --- 8672,8693 ---- 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)[]. */ gfc_init_block (&realloc_block); *************** gfc_alloc_allocatable_for_assignment (gf *** 8626,8633 **** --- 8730,8745 ---- 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 230837) --- 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 230837) --- gcc/fortran/trans-stmt.c (working copy) *************** gfc_trans_allocate (gfc_code * code) *** 5073,5078 **** --- 5073,5079 ---- 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) *** 5335,5340 **** --- 5336,5342 ---- 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) *** 5386,5391 **** --- 5388,5404 ---- 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 230837) --- 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) *** 1647,1652 **** --- 1662,1668 ---- 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 + ! and Tobias Burnus + ! + ! 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 + ! + 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 + ! + 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 + ! + 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 + ! + 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