re PR fortran/70752 (Incorrect LEN for ALLOCATABLE CHARACTER)

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

7 files changed, 244 insertions, 4 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index db17d97..318567b 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,24 @@
 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
 	* 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 0d699ed..035257a 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 03dc7a2..9297b2f 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 2257b17..e06098d 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,14 @@
 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
 	* 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 0000000..906df94
--- /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  <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
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 0000000..4f335d7
--- /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'  <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
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 0000000..7a5e4c6
--- /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  <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