Index: gcc/fortran/trans-array.c =================================================================== *** gcc/fortran/trans-array.c (revision 264918) --- 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_array_allocate (gfc_se * se, gfc_exp *** 5871,5887 **** if (dimension) gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset); ! /* Pointer arrays need the span field to be set. */ ! if (is_pointer_array (se->expr) ! || (expr->ts.type == BT_CLASS ! && CLASS_DATA (expr)->attr.class_pointer) || (expr->ts.type == BT_CHARACTER ! && TREE_CODE (se->string_length) == COMPONENT_REF)) { if (expr3 && expr3_elem_size != NULL_TREE) tmp = expr3_elem_size; else if (se->string_length ! && TREE_CODE (se->string_length) == COMPONENT_REF) { if (expr->ts.kind != 1) { --- 5889,5907 ---- if (dimension) gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset); ! /* Set the span field for pointer and deferred length character arrays. */ ! if ((is_pointer_array (se->expr) ! || (expr->ts.type == BT_CLASS && CLASS_DATA (expr)->attr.class_pointer) ! || (expr->ts.type == BT_CHARACTER && TREE_CODE (se->string_length) ! == COMPONENT_REF)) || (expr->ts.type == BT_CHARACTER ! && (expr->ts.deferred || VAR_P (expr->ts.u.cl->backend_decl)))) { if (expr3 && expr3_elem_size != NULL_TREE) tmp = expr3_elem_size; else if (se->string_length ! && (TREE_CODE (se->string_length) == COMPONENT_REF ! || (expr->ts.type == BT_CHARACTER && expr->ts.deferred))) { if (expr->ts.kind != 1) { *************** gfc_conv_expr_descriptor (gfc_se *se, gf *** 7053,7058 **** --- 7073,7079 ---- 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 **** --- 7113,7126 ---- 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; --- 7169,7180 ---- 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); --- 9830,9844 ---- 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 **** --- 10064,10075 ---- 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 **** --- 10083,10092 ---- 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 264918) --- 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_character_28.f90 =================================================================== *** gcc/testsuite/gfortran.dg/deferred_character_28.f90 (nonexistent) --- gcc/testsuite/gfortran.dg/deferred_character_28.f90 (working copy) *************** *** 0 **** --- 1,60 ---- + ! { dg-do run } + ! + ! Test the fix for PR80931, which was nearly fix by the patch for PR87151. + ! However, the 'span' for 'temp' was not being set and so a segfault + ! occurred in the assignment at line 39. + ! + ! Contributed by Tiziano Mueller + ! + module input_section_types + type :: section + character(len=:), allocatable :: keywords_(:) + + contains + procedure, pass :: add_keyword + end type + + interface section + procedure constructor + end interface + + contains + + type(section) function constructor () + allocate (character(len=255) :: constructor%keywords_(0)) + end function + + subroutine add_keyword (this, name) + class(section), intent(inout) :: this + character(*), intent(in) :: name + character(len=:), allocatable :: temp(:) + + integer :: n_elements + + n_elements = size (this%keywords_) + allocate (character(len=255) :: temp(n_elements+1)) + temp(:n_elements) = this%keywords_ + call move_alloc (temp, this%keywords_) + + this%keywords_(n_elements+1) = name + end subroutine + end module + + use input_section_types + type(section) :: s + character(*), parameter :: hello = "Hello World" + character(*), parameter :: bye = "Goodbye World" + + s = constructor () + + call s%add_keyword (hello) + if (len (s%keywords_) .ne. 255) stop 1 + if (size (s%keywords_, 1) .ne. 1) stop 2 + if (trim (s%keywords_(1)) .ne. hello) stop 3 + + call s%add_keyword (bye) + if (len (s%keywords_) .ne. 255) stop 4 + if (size (s%keywords_, 1) .ne. 2) stop 5 + if (trim (s%keywords_(1)) .ne. hello) stop 6 + if (trim (s%keywords_(2)) .ne. bye) stop 7 + end Index: gcc/testsuite/gfortran.dg/deferred_character_29.f90 =================================================================== *** gcc/testsuite/gfortran.dg/deferred_character_29.f90 (nonexistent) --- gcc/testsuite/gfortran.dg/deferred_character_29.f90 (working copy) *************** *** 0 **** --- 1,197 ---- + ! { dg-do compile } + ! + ! Test the fix for PR83196 comment #4 (there by mistake) + ! + ! Contributed by Arjen Markus + !____________________________________________________________ + ! keyindex.f90 -- + ! Class implementing a straightforward keyword/index list + ! The idea is to have a very simple implementation to + ! store keywords (strings) and return the position in the + ! list or vice versa. + !____________________________________________________________ + module keyindices + implicit none + + private + + integer, parameter :: default_keylength = 40 + + type keyindex + integer :: keylength + integer :: lastindex = 0 + character(len=:), dimension(:), allocatable :: keyword + contains + procedure :: init => init_keyindex + procedure :: get_index => get_index_from_list + procedure :: get_key => get_keyword_from_list + procedure :: has_key => has_keyword_in_list + end type keyindex + + public :: keyindex + contains + + ! init_keyindex -- + ! Initialise the object + ! + ! Arguments: + ! this Keyindex object + ! initial_size Initial size of the list (optimisation) + ! keylength Maximum length of a keyword (optional) + ! + subroutine init_keyindex( this, initial_size, keylength ) + class(keyindex), intent(inout) :: this + integer, intent(in) :: initial_size + integer, intent(in), optional :: keylength + + integer :: keylength_ + + if ( present(keylength) ) then + keylength_ = keylength + else + keylength_ = default_keylength + endif + + ! + ! Allocate the list of keywords + ! + if ( allocated(this%keyword) ) then + deallocate( this%keyword ) + endif + + + allocate( character(len=keylength_):: this%keyword(initial_size) ) + + this%lastindex = 0 + this%keylength = keylength_ + end subroutine init_keyindex + + ! get_index_from_list -- + ! Look up the keyword in the list and return its index + ! + ! Arguments: + ! this Keyindex object + ! keyword Keyword to be looked up + ! + ! Returns: + ! Index in the list + ! + ! Note: + ! If the keyword does not yet exist, add it to the list + ! + integer function get_index_from_list( this, keyword ) + class(keyindex), intent(inout) :: this + character(len=*), intent(in) :: keyword + + integer :: i + character(len=this%keylength), dimension(:), allocatable :: newlist + + if ( .not. allocated(this%keyword) ) then + call this%init( 50 ) + endif + + get_index_from_list = 0 + + do i = 1,this%lastindex + if ( this%keyword(i) == keyword ) then + get_index_from_list = i + exit + endif + enddo + + ! + ! Do we need to add it? + ! + if ( get_index_from_list == 0 ) then + if ( size(this%keyword) <= this%lastindex ) then + ! + ! Allocate a larger list + ! + allocate( character(len=this%keylength):: newlist(2*size(this%keyword)) ) + + newlist(1:size(this%keyword)) = this%keyword + call move_alloc( newlist, this%keyword ) + endif + + get_index_from_list = this%lastindex + 1 + this%lastindex = get_index_from_list + this%keyword(get_index_from_list) = keyword + endif + end function get_index_from_list + + ! get_keyword_from_list -- + ! Look up the keyword in the list by the given index + ! + ! Arguments: + ! this Keyindex object + ! idx Index of the keyword + ! + ! Returns: + ! Keyword as stored in the list + ! + ! Note: + ! If the index does not exist, an empty string is returned + ! + function get_keyword_from_list( this, idx ) + class(keyindex), intent(inout) :: this + integer, intent(in) :: idx + + character(len=this%keylength) :: get_keyword_from_list + + get_keyword_from_list = ' ' + + if ( idx >= 1 .and. idx <= this%lastindex ) then + get_keyword_from_list = this%keyword(idx) + endif + end function get_keyword_from_list + + ! has_keyword_in_list -- + ! Look up whether the keyword is stored in the list or not + ! + ! Arguments: + ! this Keyindex object + ! keyword Keyword to be looked up + ! + ! Returns: + ! True if the keyword is in the list or false if not + ! + logical function has_keyword_in_list( this, keyword ) + class(keyindex), intent(inout) :: this + character(len=*), intent(in) :: keyword + + integer :: i + + has_keyword_in_list = .false. + + do i = 1,this%lastindex + if ( this%keyword(i) == keyword ) then + has_keyword_in_list = .true. + exit + endif + enddo + end function has_keyword_in_list + + end module keyindices + + use keyindices + type(keyindex) :: idx + + call idx%init (3, 8) + + if (idx%get_index ("one") .ne. 1) stop 1 + if (idx%get_index ("two") .ne. 2) stop 2 + if (idx%get_index ("three") .ne. 3) stop 3 + + ! Check that new span is generated as list is extended. + if (idx%get_index ("four") .ne. 4) stop 4 + if (idx%get_index ("five") .ne. 5) stop 5 + if (idx%get_index ("six") .ne. 6) stop 6 + + ! Search by keyword + if (.not.idx%has_key ("four")) stop 7 + if (idx%has_key ("seven")) stop 8 + + ! Search by index + if (idx%get_key (4) .ne. "four") stop 9 + if (idx%get_key (10) .ne. "") stop 10 + end \ No newline at end of file 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