From 26a5bf7f44fcedb801a1c2022b9ce539801d0f52 Mon Sep 17 00:00:00 2001 From: pault Date: Sun, 30 Sep 2018 12:22:07 +0000 Subject: [PATCH] 2018-09-30 Paul Thomas PR fortran/70752 PR fortran/72709 * trans-array.c (gfc_conv_scalarized_array_ref): If this is a deferred type and the info->descriptor is present, use the info->descriptor (gfc_conv_array_ref): Is the se expr is a descriptor type, pass it as 'decl' rather than the symbol backend_decl. (gfc_array_allocate): If the se string_length is a component reference, fix it and use it for the expression string length if the latter is not a variable type. If it is a variable do an assignment. Make use of component ref string lengths to set the descriptor 'span'. (gfc_conv_expr_descriptor): For pointer assignment, do not set the span field if gfc_get_array_span returns zero. * trans.c (get_array_span): If the upper bound a character type is zero, use the descriptor span if available. 2018-09-30 Paul Thomas PR fortran/70752 PR fortran/72709 * gfortran.dg/deferred_character_25.f90 : New test. * gfortran.dg/deferred_character_26.f90 : New test. * gfortran.dg/deferred_character_27.f90 : New test to verify that PR82617 remains fixed. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@264724 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 19 +++++ gcc/fortran/trans-array.c | 48 +++++++++++- gcc/fortran/trans.c | 9 +++ gcc/testsuite/ChangeLog | 9 +++ .../gfortran.dg/deferred_character_25.f90 | 34 +++++++++ .../gfortran.dg/deferred_character_26.f90 | 42 +++++++++++ .../gfortran.dg/deferred_character_27.f90 | 87 ++++++++++++++++++++++ 7 files changed, 244 insertions(+), 4 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/deferred_character_25.f90 create mode 100644 gcc/testsuite/gfortran.dg/deferred_character_26.f90 create mode 100644 gcc/testsuite/gfortran.dg/deferred_character_27.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index db17d97fe83..318567b6893 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,5 +1,24 @@ 2018-09-30 Paul Thomas + PR fortran/70752 + PR fortran/72709 + * trans-array.c (gfc_conv_scalarized_array_ref): If this is a + deferred type and the info->descriptor is present, use the + info->descriptor + (gfc_conv_array_ref): Is the se expr is a descriptor type, pass + it as 'decl' rather than the symbol backend_decl. + (gfc_array_allocate): If the se string_length is a component + reference, fix it and use it for the expression string length + if the latter is not a variable type. If it is a variable do + an assignment. Make use of component ref string lengths to set + the descriptor 'span'. + (gfc_conv_expr_descriptor): For pointer assignment, do not set + the span field if gfc_get_array_span returns zero. + * trans.c (get_array_span): If the upper bound a character type + is zero, use the descriptor span if available. + +2018-09-30 Paul Thomas + PR fortran/70149 * trans-decl.c (gfc_get_symbol_decl): A deferred character length pointer that is initialized needs the string length to diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 0d699edba93..035257aab12 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -3423,7 +3423,9 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar) /* A pointer array component can be detected from its field decl. Fix the descriptor, mark the resulting variable decl and pass it to gfc_build_array_ref. */ - if (is_pointer_array (info->descriptor)) + if (is_pointer_array (info->descriptor) + || (expr && expr->ts.deferred && info->descriptor + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor)))) { if (TREE_CODE (info->descriptor) == COMPONENT_REF) decl = info->descriptor; @@ -3676,7 +3678,16 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr, else if (expr->ts.deferred || (sym->ts.type == BT_CHARACTER && sym->attr.select_type_temporary)) - decl = sym->backend_decl; + { + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr))) + { + decl = se->expr; + if (TREE_CODE (decl) == INDIRECT_REF) + decl = TREE_OPERAND (decl, 0); + } + else + decl = sym->backend_decl; + } else if (sym->ts.type == BT_CLASS) decl = NULL_TREE; @@ -5761,6 +5772,19 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, overflow = integer_zero_node; + 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 later will mislead the generation of the array dimensions for allocatable/ @@ -5850,10 +5874,26 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, /* 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)) + && 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) + { + tmp = build_int_cst (gfc_array_index_type, expr->ts.kind); + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, tmp, + fold_convert (gfc_array_index_type, + se->string_length)); + } + else + tmp = se->string_length; + } else tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (se->expr))); tmp = fold_convert (gfc_array_index_type, tmp); @@ -7086,7 +7126,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) /* ....and set the span field. */ tmp = gfc_get_array_span (desc, expr); - if (tmp != NULL_TREE) + if (tmp != NULL_TREE && !integer_zerop (tmp)) gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp); } else if (se->want_pointer) diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 03dc7a284b5..9297b2ffd6a 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -307,6 +307,15 @@ get_array_span (tree type, tree decl) TYPE_SIZE_UNIT (TREE_TYPE (type))), span); } + else if (type && TREE_CODE (type) == ARRAY_TYPE + && TYPE_MAX_VALUE (TYPE_DOMAIN (type)) != NULL_TREE + && integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))) + { + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + span = gfc_conv_descriptor_span_get (decl); + else + span = NULL_TREE; + } /* Likewise for class array or pointer array references. */ else if (TREE_CODE (decl) == FIELD_DECL || VAR_OR_FUNCTION_DECL_P (decl) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 2257b179c77..e06098d0b6a 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,5 +1,14 @@ 2018-09-30 Paul Thomas + PR fortran/70752 + PR fortran/72709 + * gfortran.dg/deferred_character_25.f90 : New test. + * gfortran.dg/deferred_character_26.f90 : New test. + * gfortran.dg/deferred_character_27.f90 : New test to verify + that PR82617 remains fixed. + +2018-09-30 Paul Thomas + PR fortran/70149 * gfortran.dg/deferred_character_24.f90 : New test. diff --git a/gcc/testsuite/gfortran.dg/deferred_character_25.f90 b/gcc/testsuite/gfortran.dg/deferred_character_25.f90 new file mode 100644 index 00000000000..906df94bfa9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_character_25.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! +! Test the fix for PR70752 in which the type of the component 'c' is cast +! as character[1:0], which makes it slightly more difficult than usual to +! obtain the element length. This is one and the same bug as PR72709. +! +! Contributed by Gilbert Scott +! +PROGRAM TEST + IMPLICIT NONE + INTEGER, PARAMETER :: I = 3 + character (len = i), parameter :: str(5) = ['abc','cde','fgh','ijk','lmn'] + + TYPE T + CHARACTER(LEN=:), ALLOCATABLE :: C(:) + END TYPE T + TYPE(T), TARGET :: S + CHARACTER (LEN=I), POINTER :: P(:) + + ALLOCATE ( CHARACTER(LEN=I) :: S%C(5) ) + s%c = str + +! This PR uncovered several problems associated with determining the +! element length and indexing. Test fairly thoroughly! + if (SIZE(S%C, 1) .ne. 5) stop 1 + if (LEN(S%C) .ne. 3) stop 2 + if (any (s%c .ne. str)) stop 3 + if (s%c(3) .ne. str(3)) stop 4 + P => S%C + if (SIZE(p, 1) .ne. 5) stop 5 + if (LEN(p) .ne. 3) stop 6 + if (any (p .ne. str)) stop 7 + if (p(5) .ne. str(5)) stop 8 +END PROGRAM TEST diff --git a/gcc/testsuite/gfortran.dg/deferred_character_26.f90 b/gcc/testsuite/gfortran.dg/deferred_character_26.f90 new file mode 100644 index 00000000000..4f335d720d2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_character_26.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +! +! Test the fix for PR72709 in which the type of the component 'header' is cast +! as character[1:0], which makes it slightly more difficult than usual to +! obtain the element length. This is one and the same bug as PR70752. +! +! Contributed by 'zmi' +! +program read_exp_data + implicit none + + type experimental_data_t + integer :: nh = 0 + character(len=:), dimension(:), allocatable :: header + + end type experimental_data_t + + character(*), parameter :: str(3) = ["#Generated by X ", & + "#from file 'Y' ", & + "# Experimental 4 mg/g"] + type(experimental_data_t) :: ex + integer :: nh_len + integer :: i + + + nh_len = 255 + ex % nh = 3 + allocate(character(len=nh_len) :: ex % header(ex % nh)) + + ex % header(1) = str(1) + ex % header(2) = str(2) + ex % header(3) = str(3) + +! Test that the string length is OK + if (len (ex%header) .ne. nh_len) stop 1 + +! Test the array indexing + do i = 1, ex % nh + if (trim (ex%header(i)) .ne. trim (str(i))) stop i + 1 + enddo + +end program read_exp_data diff --git a/gcc/testsuite/gfortran.dg/deferred_character_27.f90 b/gcc/testsuite/gfortran.dg/deferred_character_27.f90 new file mode 100644 index 00000000000..7a5e4c6c30a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_character_27.f90 @@ -0,0 +1,87 @@ +! { dg-do compile } +! +! Make sure that PR82617 remains fixed. The first attempt at a +! fix for PR70752 cause this to ICE at the point indicated below. +! +! Contributed by Ogmundur Petersson +! +MODULE test + + IMPLICIT NONE + + PRIVATE + PUBLIC str_words + + !> Characters that are considered whitespace. + CHARACTER(len=*), PARAMETER :: strwhitespace = & + char(32)//& ! space + char(10)//& ! new line + char(13)//& ! carriage return + char( 9)//& ! horizontal tab + char(11)//& ! vertical tab + char(12) ! form feed (new page) + + CONTAINS + + ! ------------------------------------------------------------------- + !> Split string into words separated by arbitrary strings of whitespace + !> characters (space, tab, newline, return, formfeed). + FUNCTION str_words(str,white) RESULT(items) + CHARACTER(len=:), DIMENSION(:), ALLOCATABLE :: items + CHARACTER(len=*), INTENT(in) :: str !< String to split. + CHARACTER(len=*), INTENT(in) :: white ! Whitespace characters. + + items = strwords_impl(str,white) + + END FUNCTION str_words + + ! ------------------------------------------------------------------- + !>Implementation of str_words + !> characters (space, tab, newline, return, formfeed). + FUNCTION strwords_impl(str,white) RESULT(items) + CHARACTER(len=:), DIMENSION(:), ALLOCATABLE :: items + CHARACTER(len=*), INTENT(in) :: str !< String to split. + CHARACTER(len=*), INTENT(in) :: white ! Whitespace characters. + + INTEGER :: i0,i1,n + INTEGER :: l_item,i_item,n_item + + n = verify(str,white,.TRUE.) + IF (n>0) THEN + n_item = 0 + l_item = 0 + i1 = 0 + DO + i0 = verify(str(i1+1:n),white)+i1 + i1 = scan(str(i0+1:n),white) + n_item = n_item+1 + IF (i1>0) THEN + l_item = max(l_item,i1) + i1 = i0+i1 + ELSE + l_item = max(l_item,n-i0+1) + EXIT + END IF + END DO + ALLOCATE(CHARACTER(len=l_item)::items(n_item)) + i_item = 0 + i1 = 0 + DO + i0 = verify(str(i1+1:n),white)+i1 + i1 = scan(str(i0+1:n),white) + i_item = i_item+1 + IF (i1>0) THEN + i1 = i0+i1 + items(i_item) = str(i0:i1-1) + ELSE + items(i_item) = str(i0:n) + EXIT + END IF + END DO + ELSE + ALLOCATE(CHARACTER(len=0)::items(0)) + END IF + + END FUNCTION strwords_impl + +END MODULE test -- 2.11.4.GIT