2018-09-30 Paul Thomas <pault@gcc.gnu.org>
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 <pault@gcc.gnu.org>
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.
From-SVN: r264724
+2018-09-30 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <pault@gcc.gnu.org>
PR fortran/70149
/* 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;
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;
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/
/* 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);
/* ....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)
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)
+2018-09-30 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <pault@gcc.gnu.org>
PR fortran/70149
--- /dev/null
+! { 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 <gilbert.scott@easynet.co.uk>
+!
+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
--- /dev/null
+! { 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' <zmi007@gmail.com>
+!
+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
--- /dev/null
+! { 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 <uberprugelknabe@hotmail.com>
+!
+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
projects / gcc.git / commitdiff