From: Paul Thomas Date: Tue, 9 Oct 2018 07:46:48 +0000 (+0000) Subject: re PR fortran/87151 (allocating array of character) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=9d44426f78d05a7c6bbf8327804c69e51e8de39b;p=gcc.git re PR fortran/87151 (allocating array of character) 2018-10-09 Paul Thomas PR fortran/87151 * trans-array.c (gfc_get_array_span): Deal with deferred char array components having a TYPE_MAX_VALUE of zero. (gfc_array_init_size): Use the hidden string length component to build the descriptor dtype. (gfc_array_allocate): Remove the erroneous replacement of the charlen backend decl with a temporary. (gfc_conv_expr_descriptor): Use the ss_info string length in the case of deferred character components. (gfc_alloc_allocatable_for_assignment): Actually compare the string lengths for deferred characters. Make sure that kind > 1 is handled correctly. Set the span field of the descriptor. * trans-intrinsic.c (gfc_conv_intrinsic_len): Remove the stupid comment. PR fortran/80931 * trans-array.c (gfc_array_allocate): Set the span field for variable length character arrays. 2018-10-09 Paul Thomas PR fortran/87151 * gfortran.dg/deferred_type_component_3.f90: New test. PR fortran/80931 * gfortran.dg/deferred_character_28.f90: New test. * gfortran.dg/deferred_character_29.f90: New test (note that this test appears in PR83196 comment #4 by mistake). From-SVN: r264949 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 6fc3857e246..d945e206d50 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,24 @@ +2018-10-09 Paul Thomas + + PR fortran/87151 + * trans-array.c (gfc_get_array_span): Deal with deferred char + array components having a TYPE_MAX_VALUE of zero. + (gfc_array_init_size): Use the hidden string length component + to build the descriptor dtype. + (gfc_array_allocate): Remove the erroneous replacement of the + charlen backend decl with a temporary. + (gfc_conv_expr_descriptor): Use the ss_info string length in + the case of deferred character components. + (gfc_alloc_allocatable_for_assignment): Actually compare the + string lengths for deferred characters. Make sure that kind > 1 + is handled correctly. Set the span field of the descriptor. + * trans-intrinsic.c (gfc_conv_intrinsic_len): Remove the stupid + comment. + + PR fortran/80931 + * trans-array.c (gfc_array_allocate): Set the span field for + variable length character arrays. + 2018-10-08 Cesar Philippidis * expr.c (gfc_check_pointer_assign): Demote "Assignment to diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 1e8f777211d..c4df4ebbc40 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -853,7 +853,8 @@ gfc_get_array_span (tree desc, gfc_expr *expr) 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) + && (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) @@ -5366,6 +5367,28 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, 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); @@ -5774,16 +5797,11 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, 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); - } + && 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 @@ -5871,17 +5889,19 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, 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) + /* 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 - && TREE_CODE (se->string_length) == COMPONENT_REF)) + && (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) + && (TREE_CODE (se->string_length) == COMPONENT_REF + || (expr->ts.type == BT_CHARACTER && expr->ts.deferred))) { if (expr->ts.kind != 1) { @@ -7053,6 +7073,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) tree offset; int full; bool subref_array_target = false; + bool deferred_array_component = false; gfc_expr *arg, *ss_expr; if (se->want_coarray) @@ -7092,6 +7113,14 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) 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; @@ -7140,8 +7169,12 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) se->expr = desc; } - if (expr->ts.type == BT_CHARACTER) + 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; @@ -9797,8 +9830,15 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, 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); + 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); @@ -10024,6 +10064,12 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, 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) { @@ -10037,6 +10083,10 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, 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); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 639175ade71..3bb32b564bc 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -6404,7 +6404,6 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr) /* 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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 1cfd3b733eb..6a8605b2c7a 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,13 @@ +2018-10-09 Paul Thomas + + PR fortran/87151 + * gfortran.dg/deferred_type_component_3.f90: New test. + + PR fortran/80931 + * gfortran.dg/deferred_character_28.f90: New test. + * gfortran.dg/deferred_character_29.f90: New test (note that + this test appears in PR83196 comment #4 by mistake). + 2018-10-08 Eric Botcazou * gcc.target/i386/vararg-loc.c: Accept a column number. diff --git a/gcc/testsuite/gfortran.dg/deferred_character_28.f90 b/gcc/testsuite/gfortran.dg/deferred_character_28.f90 new file mode 100644 index 00000000000..6cdf2afd693 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_character_28.f90 @@ -0,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 diff --git a/gcc/testsuite/gfortran.dg/deferred_character_29.f90 b/gcc/testsuite/gfortran.dg/deferred_character_29.f90 new file mode 100644 index 00000000000..2d8a4c2d018 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_character_29.f90 @@ -0,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 diff --git a/gcc/testsuite/gfortran.dg/deferred_type_component_3.f90 b/gcc/testsuite/gfortran.dg/deferred_type_component_3.f90 new file mode 100644 index 00000000000..ecbb3823806 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_type_component_3.f90 @@ -0,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