Re: [Ping, Fortran, Patch, v1] Three small patches for character arrays

[Andre Vehreschild <vehre at gmx dot de>]

Ping!

On Wed, 1 Nov 2017 12:27:11 +0100
Andre Vehreschild <vehre@gmx.de> wrote:

> Hi all,
> 
> during development on OpenCoarrays I found these three issues in gfortran:
> 
> - caf_send: Did not treat char arrays as arrays when calling caf_send.
> - gfc_trans_assignment_1: Conversion of character kind creates a loop variant
>   temporary which must not be put before the loop body, but within.
> - get_array_span: When doing pointer arithmetic on char arrays the character
>   kind was not applied.
> 
> The attached patch fixes all of these issues for trunk and gcc-7. Bootstrapped
> and regtested on x86_64-linux-gnu/f25. Ok for trunk and gcc-7?
> 
> Regards,
> 	Andre


-- 
Andre Vehreschild * Email: vehre ad gmx dot de

Attachment: fixes_1.clog
Description: Text document

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 1a3e3d4..57b62a6 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -10084,12 +10084,16 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
      NOTE: This relies on having the exact dependence of the length type
      parameter available to the caller; gfortran saves it in the .mod files.
      NOTE ALSO: The concatenation operation generates a temporary pointer,
-     whose allocation must go to the innermost loop.  */
+     whose allocation must go to the innermost loop.
+     NOTE ALSO (2): A character conversion may generate a temporary, too.  */
   if (flag_realloc_lhs
       && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
       && !(lss != gfc_ss_terminator
-	   && expr2->expr_type == EXPR_OP
-	   && expr2->value.op.op == INTRINSIC_CONCAT))
+	   && ((expr2->expr_type == EXPR_OP
+		&& expr2->value.op.op == INTRINSIC_CONCAT)
+	       || (expr2->expr_type == EXPR_FUNCTION
+		   && expr2->value.function.isym != NULL
+		   && expr2->value.function.isym->id == GFC_ISYM_CONVERSION))))
     gfc_add_block_to_block (&block, &rse.pre);
 
   /* Nullify the allocatable components corresponding to those of the lhs
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 532d3ab..b0f0ab2 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1871,12 +1871,21 @@ conv_caf_send (gfc_code *code) {
   gfc_init_se (&lhs_se, NULL);
   if (lhs_expr->rank == 0)
     {
-      symbol_attribute attr;
-      gfc_clear_attr (&attr);
-      gfc_conv_expr (&lhs_se, lhs_expr);
-      lhs_type = TREE_TYPE (lhs_se.expr);
-      lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr, attr);
-      lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
+      if (lhs_expr->ts.type == BT_CHARACTER && lhs_expr->ts.deferred)
+	{
+	  lhs_se.expr = gfc_get_tree_for_caf_expr (lhs_expr);
+	  lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
+	}
+      else
+	{
+	  symbol_attribute attr;
+	  gfc_clear_attr (&attr);
+	  gfc_conv_expr (&lhs_se, lhs_expr);
+	  lhs_type = TREE_TYPE (lhs_se.expr);
+	  lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr,
+						       attr);
+	  lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
+	}
     }
   else if ((lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
 	   && lhs_caf_attr.codimension)
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 53bc428..4115308 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -320,8 +320,12 @@ get_array_span (tree type, tree decl)
 	  || DECL_CONTEXT (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))
 					== DECL_CONTEXT (decl)))
     {
-      span = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
-      span = fold_convert (gfc_array_index_type, span);
+      span = fold_convert (gfc_array_index_type,
+			   TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
+      span = fold_build2 (MULT_EXPR, gfc_array_index_type,
+			  fold_convert (gfc_array_index_type,
+					TYPE_SIZE_UNIT (TREE_TYPE (type))),
+			  span);
     }
   /* Likewise for class array or pointer array references.  */
   else if (TREE_CODE (decl) == FIELD_DECL
diff --git a/gcc/testsuite/gfortran.dg/coarray/send_char_array_1.f90 b/gcc/testsuite/gfortran.dg/coarray/send_char_array_1.f90
new file mode 100644
index 0000000..800a8ac
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/send_char_array_1.f90
@@ -0,0 +1,54 @@
+!{ dg-do run }
+ 
+program send_convert_char_array
+
+  implicit none
+
+  character(kind=1, len=:), allocatable, codimension[:] :: co_str_k1_scal
+  character(kind=1, len=:), allocatable :: str_k1_scal
+  character(kind=4, len=:), allocatable, codimension[:] :: co_str_k4_scal
+  character(kind=4, len=:), allocatable :: str_k4_scal
+
+  character(kind=1, len=:), allocatable, codimension[:] :: co_str_k1_arr(:)
+  character(kind=1, len=:), allocatable :: str_k1_arr(:)
+  character(kind=4, len=:), allocatable, codimension[:] :: co_str_k4_arr(:)
+  character(kind=4, len=:), allocatable :: str_k4_arr(:)
+
+  allocate(str_k1_scal, SOURCE='abcdefghij')
+  allocate(str_k4_scal, SOURCE=4_'abcdefghij')
+  allocate(character(len=20)::co_str_k1_scal[*]) ! allocate syncs here
+  allocate(character(kind=4, len=20)::co_str_k4_scal[*]) ! allocate syncs here
+
+  allocate(str_k1_arr, SOURCE=['abc', 'EFG', 'klm', 'NOP'])
+  allocate(str_k4_arr, SOURCE=[4_'abc', 4_'EFG', 4_'klm', 4_'NOP'])
+  allocate(character(len=5)::co_str_k1_arr(4)[*])
+  allocate(character(kind=4, len=5)::co_str_k4_arr(4)[*])
+
+  ! First check send/copy to self
+  co_str_k1_scal[1] = str_k1_scal
+  if (co_str_k1_scal /= str_k1_scal // '          ') call abort()
+
+  co_str_k4_scal[1] = str_k4_scal
+  if (co_str_k4_scal /= str_k4_scal // 4_'          ') call abort()
+
+  co_str_k4_scal[1] = str_k1_scal
+  if (co_str_k4_scal /= str_k4_scal // 4_'          ') call abort()
+
+  co_str_k1_scal[1] = str_k4_scal
+  if (co_str_k1_scal /= str_k1_scal // '          ') call abort()
+
+  co_str_k1_arr(:)[1] = str_k1_arr
+  if (any(co_str_k1_arr /= ['abc  ', 'EFG  ', 'klm  ', 'NOP  '])) call abort()
+ 
+  co_str_k4_arr(:)[1] = [4_'abc', 4_'EFG', 4_'klm', 4_'NOP']! str_k4_arr
+  if (any(co_str_k4_arr /= [4_'abc  ', 4_'EFG  ', 4_'klm  ', 4_'NOP  '])) call abort()
+
+  co_str_k4_arr(:)[1] = str_k1_arr
+  if (any(co_str_k4_arr /= [ 4_'abc  ', 4_'EFG  ', 4_'klm  ', 4_'NOP  '])) call abort()
+
+  co_str_k1_arr(:)[1] = str_k4_arr
+  if (any(co_str_k1_arr /= ['abc  ', 'EFG  ', 'klm  ', 'NOP  '])) call abort()
+
+end program send_convert_char_array
+
+! vim:ts=2:sts=2:sw=2:

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index fa04ed4..1cd4627 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -10066,12 +10066,16 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
      NOTE: This relies on having the exact dependence of the length type
      parameter available to the caller; gfortran saves it in the .mod files.
      NOTE ALSO: The concatenation operation generates a temporary pointer,
-     whose allocation must go to the innermost loop.  */
+     whose allocation must go to the innermost loop.
+     NOTE ALSO (2): A character conversion may generate a temporary, too.  */
   if (flag_realloc_lhs
       && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
       && !(lss != gfc_ss_terminator
-	   && expr2->expr_type == EXPR_OP
-	   && expr2->value.op.op == INTRINSIC_CONCAT))
+	   && ((expr2->expr_type == EXPR_OP
+		&& expr2->value.op.op == INTRINSIC_CONCAT)
+	       || (expr2->expr_type == EXPR_FUNCTION
+		   && expr2->value.function.isym != NULL
+		   && expr2->value.function.isym->id == GFC_ISYM_CONVERSION))))
     gfc_add_block_to_block (&block, &rse.pre);
 
   /* Nullify the allocatable components corresponding to those of the lhs
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 3c9e1d5..6032727 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1872,12 +1872,21 @@ conv_caf_send (gfc_code *code) {
   gfc_init_se (&lhs_se, NULL);
   if (lhs_expr->rank == 0)
     {
-      symbol_attribute attr;
-      gfc_clear_attr (&attr);
-      gfc_conv_expr (&lhs_se, lhs_expr);
-      lhs_type = TREE_TYPE (lhs_se.expr);
-      lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr, attr);
-      lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
+      if (lhs_expr->ts.type == BT_CHARACTER && lhs_expr->ts.deferred)
+	{
+	  lhs_se.expr = gfc_get_tree_for_caf_expr (lhs_expr);
+	  lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
+	}
+      else
+	{
+	  symbol_attribute attr;
+	  gfc_clear_attr (&attr);
+	  gfc_conv_expr (&lhs_se, lhs_expr);
+	  lhs_type = TREE_TYPE (lhs_se.expr);
+	  lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr,
+						       attr);
+	  lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
+	}
     }
   else if ((lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
 	   && lhs_caf_attr.codimension)
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 2323e0a..6d698ba 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -342,7 +342,14 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr)
 	  || TREE_CODE (decl) == FUNCTION_DECL
 	  || DECL_CONTEXT (TYPE_MAXVAL (TYPE_DOMAIN (type)))
 					== DECL_CONTEXT (decl)))
-    span = TYPE_MAXVAL (TYPE_DOMAIN (type));
+    {
+      span = fold_convert (gfc_array_index_type,
+			   TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
+      span = fold_build2 (MULT_EXPR, gfc_array_index_type,
+			  fold_convert (gfc_array_index_type,
+					TYPE_SIZE_UNIT (TREE_TYPE (type))),
+			  span);
+    }
   else
     span = NULL_TREE;
 
diff --git a/gcc/testsuite/gfortran.dg/coarray/send_char_array_1.f90 b/gcc/testsuite/gfortran.dg/coarray/send_char_array_1.f90
new file mode 100644
index 0000000..800a8ac
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/send_char_array_1.f90
@@ -0,0 +1,54 @@
+!{ dg-do run }
+ 
+program send_convert_char_array
+
+  implicit none
+
+  character(kind=1, len=:), allocatable, codimension[:] :: co_str_k1_scal
+  character(kind=1, len=:), allocatable :: str_k1_scal
+  character(kind=4, len=:), allocatable, codimension[:] :: co_str_k4_scal
+  character(kind=4, len=:), allocatable :: str_k4_scal
+
+  character(kind=1, len=:), allocatable, codimension[:] :: co_str_k1_arr(:)
+  character(kind=1, len=:), allocatable :: str_k1_arr(:)
+  character(kind=4, len=:), allocatable, codimension[:] :: co_str_k4_arr(:)
+  character(kind=4, len=:), allocatable :: str_k4_arr(:)
+
+  allocate(str_k1_scal, SOURCE='abcdefghij')
+  allocate(str_k4_scal, SOURCE=4_'abcdefghij')
+  allocate(character(len=20)::co_str_k1_scal[*]) ! allocate syncs here
+  allocate(character(kind=4, len=20)::co_str_k4_scal[*]) ! allocate syncs here
+
+  allocate(str_k1_arr, SOURCE=['abc', 'EFG', 'klm', 'NOP'])
+  allocate(str_k4_arr, SOURCE=[4_'abc', 4_'EFG', 4_'klm', 4_'NOP'])
+  allocate(character(len=5)::co_str_k1_arr(4)[*])
+  allocate(character(kind=4, len=5)::co_str_k4_arr(4)[*])
+
+  ! First check send/copy to self
+  co_str_k1_scal[1] = str_k1_scal
+  if (co_str_k1_scal /= str_k1_scal // '          ') call abort()
+
+  co_str_k4_scal[1] = str_k4_scal
+  if (co_str_k4_scal /= str_k4_scal // 4_'          ') call abort()
+
+  co_str_k4_scal[1] = str_k1_scal
+  if (co_str_k4_scal /= str_k4_scal // 4_'          ') call abort()
+
+  co_str_k1_scal[1] = str_k4_scal
+  if (co_str_k1_scal /= str_k1_scal // '          ') call abort()
+
+  co_str_k1_arr(:)[1] = str_k1_arr
+  if (any(co_str_k1_arr /= ['abc  ', 'EFG  ', 'klm  ', 'NOP  '])) call abort()
+ 
+  co_str_k4_arr(:)[1] = [4_'abc', 4_'EFG', 4_'klm', 4_'NOP']! str_k4_arr
+  if (any(co_str_k4_arr /= [4_'abc  ', 4_'EFG  ', 4_'klm  ', 4_'NOP  '])) call abort()
+
+  co_str_k4_arr(:)[1] = str_k1_arr
+  if (any(co_str_k4_arr /= [ 4_'abc  ', 4_'EFG  ', 4_'klm  ', 4_'NOP  '])) call abort()
+
+  co_str_k1_arr(:)[1] = str_k4_arr
+  if (any(co_str_k1_arr /= ['abc  ', 'EFG  ', 'klm  ', 'NOP  '])) call abort()
+
+end program send_convert_char_array
+
+! vim:ts=2:sts=2:sw=2: