diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 5fdb86687df..1e6f404cb53 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,42 @@ +2015-11-15 Paul Thomas + + 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 PR fortran/67803 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index bf2837c5b72..90bc6d49b4b 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -10222,6 +10222,50 @@ resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace *ns) } +/* 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. */ @@ -10427,6 +10471,11 @@ start: 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 @@ -10801,7 +10850,7 @@ gfc_verify_binding_labels (gfc_symbol *sym) 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)) { diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index c294516c74c..69f6e19f922 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -3164,7 +3164,8 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar) 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); @@ -8499,6 +8500,75 @@ gfc_is_reallocatable_lhs (gfc_expr *expr) } +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. */ @@ -8596,6 +8666,12 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, /* 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)); @@ -8684,7 +8760,13 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, 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. */ @@ -8789,6 +8871,12 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, 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); } @@ -8816,6 +8904,22 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, 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); @@ -8858,8 +8962,16 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, 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) { diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 8515315a1d9..6647a4ec404 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -5599,7 +5599,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, 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); } @@ -9250,8 +9251,10 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, } /* 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; @@ -9285,8 +9288,14 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, 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 diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 1af2ad11c02..86548c00731 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5086,6 +5086,7 @@ gfc_trans_allocate (gfc_code * code) 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 @@ -5463,6 +5464,7 @@ gfc_trans_allocate (gfc_code * code) 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); } } @@ -5514,6 +5516,17 @@ gfc_trans_allocate (gfc_code * code) 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 diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index d9ab346a689..9b44b7109f2 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -331,6 +331,18 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr) 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; @@ -345,8 +357,9 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr) || 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) { @@ -376,6 +389,8 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr) } 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 (); } @@ -1620,6 +1635,7 @@ trans_code (gfc_code * code, tree cond) gfc_add_expr_to_block (&block, res); } + gfc_current_locus = code->loc; gfc_set_backend_locus (&code->loc); switch (code->op) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index bed12411f36..5a1997e5d68 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,5 +1,27 @@ +2015-11-15 Paul Thomas + + 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 - + PR fortran/67803 * gfortran.dg/pr67803.f90: New test. diff --git a/gcc/testsuite/gfortran.dg/deferred_character_1.f90 b/gcc/testsuite/gfortran.dg/deferred_character_1.f90 new file mode 100644 index 00000000000..0772c70537f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_character_1.f90 @@ -0,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 diff --git a/gcc/testsuite/gfortran.dg/deferred_character_2.f90 b/gcc/testsuite/gfortran.dg/deferred_character_2.f90 new file mode 100644 index 00000000000..3e6535c7624 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_character_2.f90 @@ -0,0 +1,85 @@ +! { 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 diff --git a/gcc/testsuite/gfortran.dg/deferred_character_3.f90 b/gcc/testsuite/gfortran.dg/deferred_character_3.f90 new file mode 100644 index 00000000000..8f2933713c3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_character_3.f90 @@ -0,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 diff --git a/gcc/testsuite/gfortran.dg/deferred_character_4.f90 b/gcc/testsuite/gfortran.dg/deferred_character_4.f90 new file mode 100644 index 00000000000..5bb865810c1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_character_4.f90 @@ -0,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 diff --git a/gcc/testsuite/gfortran.dg/deferred_character_5.f90 b/gcc/testsuite/gfortran.dg/deferred_character_5.f90 new file mode 100644 index 00000000000..b5d64b43840 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_character_5.f90 @@ -0,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 diff --git a/gcc/testsuite/gfortran.dg/deferred_character_6.f90 b/gcc/testsuite/gfortran.dg/deferred_character_6.f90 new file mode 100644 index 00000000000..94afa0c0f28 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_character_6.f90 @@ -0,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 diff --git a/gcc/testsuite/gfortran.dg/deferred_character_7.f90 b/gcc/testsuite/gfortran.dg/deferred_character_7.f90 new file mode 100644 index 00000000000..64b03aba0bd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_character_7.f90 @@ -0,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