This patch is a bit more complicated than some of the previous posts.
However, the ChangeLog explains the story pretty clearly.
Bootstraps and regtests on FC21/x86_64 - OK for trunk and 8-branch?
Again, better names for the testcases will be determined before committing.
Paul
2018-09-25 Paul Thomas <pa...@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.
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-25 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/70752
* gfortran.dg/pr70752.f90 : New test.
PR fortran/72709
* gfortran.dg/pr72709.f90 : New test.
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 9e00eb0..1feba5e 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,12 @@ 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;
+ else
+ decl = sym->backend_decl;
+ }
else if (sym->ts.type == BT_CLASS)
decl = NULL_TREE;
@@ -5761,6 +5768,12 @@ 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)
+ 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 +5863,25 @@ 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,
+ se->string_length, tmp);
+ }
+ 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 +7114,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 153bab6..ac583a0 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -327,6 +327,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)
! { 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.sc...@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
! { 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' <zmi...@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
