Index: gcc/fortran/trans-array.c =================================================================== *** gcc/fortran/trans-array.c (revision 264906) --- gcc/fortran/trans-array.c (working copy) *************** gfc_get_array_span (tree desc, gfc_expr *** 853,859 **** types if possible. Otherwise, return NULL_TREE. */ tmp = gfc_get_element_type (TREE_TYPE (desc)); if (tmp && TREE_CODE (tmp) == ARRAY_TYPE ! && TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) == NULL_TREE) { if (expr->expr_type == EXPR_VARIABLE && expr->ts.type == BT_CHARACTER) --- 853,860 ---- types if possible. Otherwise, return NULL_TREE. */ tmp = gfc_get_element_type (TREE_TYPE (desc)); if (tmp && TREE_CODE (tmp) == ARRAY_TYPE ! && (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) == NULL_TREE ! || integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp))))) { if (expr->expr_type == EXPR_VARIABLE && expr->ts.type == BT_CHARACTER) *************** gfc_array_init_size (tree descriptor, in *** 5366,5371 **** --- 5367,5394 ---- tmp = gfc_conv_descriptor_dtype (descriptor); gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type)); } + else if (expr->ts.type == BT_CHARACTER + && expr->ts.deferred + && TREE_CODE (descriptor) == COMPONENT_REF) + { + /* Deferred character components have their string length tucked away + in a hidden field of the derived type. Obtain that and use it to + set the dtype. The charlen backend decl is zero because the field + type is zero length. */ + gfc_ref *ref; + tmp = NULL_TREE; + for (ref = expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT + && gfc_deferred_strlen (ref->u.c.component, &tmp)) + break; + gcc_assert (tmp != NULL_TREE); + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), + TREE_OPERAND (descriptor, 0), tmp, NULL_TREE); + tmp = fold_convert (gfc_charlen_type_node, tmp); + type = gfc_get_character_type_len (expr->ts.kind, tmp); + tmp = gfc_conv_descriptor_dtype (descriptor); + gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type)); + } else { tmp = gfc_conv_descriptor_dtype (descriptor); *************** gfc_array_allocate (gfc_se * se, gfc_exp *** 5774,5789 **** if (expr->ts.type == BT_CHARACTER && TREE_CODE (se->string_length) == COMPONENT_REF ! && expr->ts.u.cl->backend_decl != se->string_length) ! { ! if (VAR_P (expr->ts.u.cl->backend_decl)) ! gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, ! fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl), ! se->string_length)); ! else ! expr->ts.u.cl->backend_decl = gfc_evaluate_now (se->string_length, ! &se->pre); ! } gfc_init_block (&set_descriptor_block); /* Take the corank only from the actual ref and not from the coref. The --- 5797,5807 ---- if (expr->ts.type == BT_CHARACTER && TREE_CODE (se->string_length) == COMPONENT_REF ! && expr->ts.u.cl->backend_decl != se->string_length ! && VAR_P (expr->ts.u.cl->backend_decl)) ! gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, ! fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl), ! se->string_length)); gfc_init_block (&set_descriptor_block); /* Take the corank only from the actual ref and not from the coref. The *************** gfc_conv_expr_descriptor (gfc_se *se, gf *** 7053,7058 **** --- 7071,7077 ---- tree offset; int full; bool subref_array_target = false; + bool deferred_array_component = false; gfc_expr *arg, *ss_expr; if (se->want_coarray) *************** gfc_conv_expr_descriptor (gfc_se *se, gf *** 7092,7097 **** --- 7111,7124 ---- gfc_conv_ss_descriptor (&se->pre, ss, 0); desc = info->descriptor; + /* The charlen backend decl for deferred character components cannot + be used because it is fixed at zero. Instead, the hidden string + length component is used. */ + if (expr->ts.type == BT_CHARACTER + && expr->ts.deferred + && TREE_CODE (desc) == COMPONENT_REF) + deferred_array_component = true; + subref_array_target = se->direct_byref && is_subref_array (expr); need_tmp = gfc_ref_needs_temporary_p (expr->ref) && !subref_array_target; *************** gfc_conv_expr_descriptor (gfc_se *se, gf *** 7140,7147 **** se->expr = desc; } ! if (expr->ts.type == BT_CHARACTER) se->string_length = gfc_get_expr_charlen (expr); gfc_free_ss_chain (ss); return; --- 7167,7178 ---- se->expr = desc; } ! if (expr->ts.type == BT_CHARACTER && !deferred_array_component) se->string_length = gfc_get_expr_charlen (expr); + /* The ss_info string length is returned set to the value of the + hidden string length component. */ + else if (deferred_array_component) + se->string_length = ss_info->string_length; gfc_free_ss_chain (ss); return; *************** gfc_alloc_allocatable_for_assignment (gf *** 9797,9804 **** cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, array1, build_int_cst (TREE_TYPE (array1), 0)); ! if (expr1->ts.deferred) ! cond_null = gfc_evaluate_now (logical_true_node, &fblock); else cond_null= gfc_evaluate_now (cond_null, &fblock); --- 9828,9842 ---- cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, array1, build_int_cst (TREE_TYPE (array1), 0)); ! if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) ! { ! tmp = fold_build2_loc (input_location, NE_EXPR, ! logical_type_node, ! lss->info->string_length, ! rss->info->string_length); ! cond_null = fold_build2_loc (input_location, TRUTH_OR_EXPR, ! logical_type_node, tmp, cond_null); ! } else cond_null= gfc_evaluate_now (cond_null, &fblock); *************** gfc_alloc_allocatable_for_assignment (gf *** 10024,10029 **** --- 10062,10073 ---- gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp); else gfc_add_modify (&fblock, lss->info->string_length, tmp); + + if (expr1->ts.kind > 1) + tmp = fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (tmp), + tmp, build_int_cst (TREE_TYPE (tmp), + expr1->ts.kind)); } else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl) { *************** gfc_alloc_allocatable_for_assignment (gf *** 10037,10042 **** --- 10081,10090 ---- else tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts)); tmp = fold_convert (gfc_array_index_type, tmp); + + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) + gfc_conv_descriptor_span_set (&fblock, desc, tmp); + size2 = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, tmp, size2); Index: gcc/fortran/trans-intrinsic.c =================================================================== *** gcc/fortran/trans-intrinsic.c (revision 264906) --- gcc/fortran/trans-intrinsic.c (working copy) *************** gfc_conv_intrinsic_len (gfc_se * se, gfc *** 6404,6410 **** /* Fall through. */ default: - /* Anybody stupid enough to do this deserves inefficient code. */ gfc_init_se (&argse, se); if (arg->rank == 0) gfc_conv_expr (&argse, arg); --- 6404,6409 ---- Index: gcc/testsuite/gfortran.dg/deferred_type_component_3.f90 =================================================================== *** gcc/testsuite/gfortran.dg/deferred_type_component_3.f90 (nonexistent) --- gcc/testsuite/gfortran.dg/deferred_type_component_3.f90 (working copy) *************** *** 0 **** --- 1,71 ---- + ! { dg-do run } + ! + ! Test the fix for PR87151 by exercising deferred length character + ! array components. + ! + ! Based on the contribution by Valery Weber + ! + module bvec + type, public :: bvec_t + private + character(:), dimension(:), allocatable :: vc + contains + PROCEDURE, PASS :: create + PROCEDURE, PASS :: test_bvec + PROCEDURE, PASS :: delete + end type bvec_t + contains + subroutine create (this, switch) + class(bvec_t), intent(inout) :: this + logical :: switch + if (switch) then + allocate (character(2)::this%vc(3)) + if (len (this%vc) .ne. 2) stop 1 ! The orignal problem. Gave 0. + + ! Check that reallocation on assign does what it should do as required by + ! F2003 7.4.1.3. ie. reallocation occurs because LEN has changed. + this%vc = ['abcd','efgh','ijkl'] + else + allocate (this%vc, source = ['abcd','efgh','ijkl']) + endif + end subroutine create + + subroutine test_bvec (this) + class(bvec_t), intent(inout) :: this + character(20) :: buffer + if (allocated (this%vc)) then + if (len (this%vc) .ne. 4) stop 2 + if (size (this%vc) .ne. 3) stop 3 + ! Check array referencing and scalarized array referencing + if (this%vc(2) .ne. 'efgh') stop 4 + if (any (this%vc .ne. ['abcd','efgh','ijkl'])) stop 5 + ! Check full array io + write (buffer, *) this%vc + if (trim (buffer(2:)) .ne. 'abcdefghijkl') stop 6 + ! Make sure that substrings work correctly + write (buffer, *) this%vc(:)(2:3) + if (trim (buffer(2:)) .ne. 'bcfgjk') stop 7 + write (buffer, *) this%vc(2:)(2:3) + if (trim (buffer(2:)) .ne. 'fgjk') stop 8 + endif + end subroutine test_bvec + + subroutine delete (this) + class(bvec_t), intent(inout) :: this + if (allocated (this%vc)) then + deallocate (this%vc) + endif + end subroutine delete + end module bvec + + program test + use bvec + type(bvec_t) :: a + call a%create (.false.) + call a%test_bvec + call a%delete + + call a%create (.true.) + call a%test_bvec + call a%delete + end program test