re PR fortran/88929 (ICE on building MPICH 3.2 with GCC 9 with ISO_Fortran_binding)

2019-01-24  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/88929
	* trans-array.c (gfc_conv_descriptor_elem_len): New function.
	* trans-array.h : Add prototype for above.
	* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Take account of
	assumed rank arrays being flagged by rank = -1 in expressions.
	Intent in arrays need a pointer to a copy of the data to be
	assigned to the descriptor passed for conversion. This should
	then be freed, together with the CFI descriptor on return from
	the C call.

2019-01-24  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/88929
	* gfortran.dg/ISO_Fortran_binding_3.f90 : New test
	* gfortran.dg/ISO_Fortran_binding_3.c : Subsidiary source.

From-SVN: r268231

gcc/fortran/ChangeLog

+2019-01-24  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/88929
+	* trans-array.c (gfc_conv_descriptor_elem_len): New function.
+	* trans-array.h : Add prototype for above.
+	* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Take account of
+	assumed rank arrays being flagged by rank = -1 in expressions.
+	Intent in arrays need a pointer to a copy of the data to be
+	assigned to the descriptor passed for conversion. This should
+	then be freed, together with the CFI descriptor on return from
+	the C call.
+
 2019-01-22  Harald Anlauf  <anlauf@gmx.de>
 
 	PR fortran/88579

gcc/fortran/trans-array.c

@@ -285,13 +285,31 @@ gfc_conv_descriptor_rank (tree desc)
 
   dtype = gfc_conv_descriptor_dtype (desc);
   tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_RANK);
-  gcc_assert (tmp!= NULL_TREE
+  gcc_assert (tmp != NULL_TREE
 	      && TREE_TYPE (tmp) == signed_char_type_node);
   return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
 			  dtype, tmp, NULL_TREE);
 }
 
 
+/* Return the element length from the descriptor dtype field.  */
+
+tree
+gfc_conv_descriptor_elem_len (tree desc)
+{
+  tree tmp;
+  tree dtype;
+
+  dtype = gfc_conv_descriptor_dtype (desc);
+  tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)),
+			   GFC_DTYPE_ELEM_LEN);
+  gcc_assert (tmp != NULL_TREE
+	      && TREE_TYPE (tmp) == size_type_node);
+  return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
+			  dtype, tmp, NULL_TREE);
+}
+
+
 tree
 gfc_conv_descriptor_attribute (tree desc)
 {

gcc/fortran/trans-array.h

@@ -169,6 +169,7 @@ tree gfc_conv_descriptor_offset_get (tree);
 tree gfc_conv_descriptor_span_get (tree);
 tree gfc_conv_descriptor_dtype (tree);
 tree gfc_conv_descriptor_rank (tree);
+tree gfc_conv_descriptor_elem_len (tree);
 tree gfc_conv_descriptor_attribute (tree);
 tree gfc_get_descriptor_dimension (tree);
 tree gfc_conv_descriptor_stride_get (tree, tree);

gcc/fortran/trans-expr.c

@@ -4924,6 +4924,8 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
   tree tmp;
   tree cfi_desc_ptr;
   tree gfc_desc_ptr;
+  tree ptr = NULL_TREE;
+  tree size;
   tree type;
   int attribute;
   symbol_attribute attr = gfc_expr_attr (e);
@@ -4939,7 +4941,7 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
 	attribute = 1;
     }
 
-  if (e->rank)
+  if (e->rank != 0)
     {
       gfc_conv_expr_descriptor (parmse, e);
 
@@ -4950,9 +4952,14 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
       /* All the temporary descriptors are marked as DECL_ARTIFICIAL. If
 	 the expression type is different from the descriptor type, then
 	 the offset must be found (eg. to a component ref or substring)
-	 and the dtype updated.  */
-      type = gfc_typenode_for_spec (&e->ts);
-      if (DECL_ARTIFICIAL (parmse->expr)
+	 and the dtype updated.  Assumed type entities are only allowed
+	 to be dummies in Fortran. They therefore lack the decl specific
+	 appendiges and so must be treated differently from other fortran
+	 entities passed to CFI descriptors in the interface decl.  */
+      type = e->ts.type != BT_ASSUMED ? gfc_typenode_for_spec (&e->ts) :
+					NULL_TREE;
+
+      if (type && DECL_ARTIFICIAL (parmse->expr)
 	  && type != gfc_get_element_type (TREE_TYPE (parmse->expr)))
 	{
 	  /* Obtain the offset to the data.  */
@@ -4964,15 +4971,44 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
 			  gfc_conv_descriptor_dtype (parmse->expr),
 			  gfc_get_dtype_rank_type (e->rank, type));
 	}
-      else if (!is_subref_array (e) && !DECL_ARTIFICIAL (parmse->expr))
+      else if (type == NULL_TREE
+	       || (!is_subref_array (e) && !DECL_ARTIFICIAL (parmse->expr)))
 	{
 	  /* Make sure that the span is set for expressions where it
 	     might not have been done already.  */
-	  tmp = TREE_TYPE (parmse->expr);
-	  tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
+	  tmp = gfc_conv_descriptor_elem_len (parmse->expr);
 	  tmp = fold_convert (gfc_array_index_type, tmp);
 	  gfc_conv_descriptor_span_set (&parmse->pre, parmse->expr, tmp);
 	}
+
+      /* INTENT(IN) requires a temporary for the data. Assumed types do not
+	 work with the standard temporary generation schemes. */
+      if (e->expr_type == EXPR_VARIABLE && fsym->attr.intent == INTENT_IN)
+	{
+	  /* Fix the descriptor and determine the size of the data.  */
+	  parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
+	  size = build_call_expr_loc (input_location,
+				gfor_fndecl_size0, 1,
+				gfc_build_addr_expr (NULL, parmse->expr));
+	  size = fold_convert (size_type_node, size);
+	  tmp = gfc_conv_descriptor_span_get (parmse->expr);
+	  tmp = fold_convert (size_type_node, tmp);
+	  size = fold_build2_loc (input_location, MULT_EXPR,
+				  size_type_node, size, tmp);
+	  /* Fix the size and allocate.  */
+	  size = gfc_evaluate_now (size, &parmse->pre);
+	  tmp = builtin_decl_explicit (BUILT_IN_MALLOC);
+	  ptr = build_call_expr_loc (input_location, tmp, 1, size);
+	  ptr = gfc_evaluate_now (ptr, &parmse->pre);
+	  /* Copy the data to the temporary descriptor.  */
+	  tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
+	  tmp = build_call_expr_loc (input_location, tmp, 3, ptr,
+				gfc_conv_descriptor_data_get (parmse->expr),
+				size);
+	  gfc_add_expr_to_block (&parmse->pre, tmp);
+	  gfc_conv_descriptor_data_set (&parmse->pre, parmse->expr, ptr);
+	}
+
     }
   else
     {
@@ -4982,7 +5018,7 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
 	parmse->expr = build_fold_indirect_ref_loc (input_location,
 						    parmse->expr);
 
-      /* Copy the scalar for INTENT_IN.  */
+      /* Copy the scalar for INTENT(IN).  */
       if (e->expr_type == EXPR_VARIABLE && fsym->attr.intent == INTENT_IN)
 	parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
       parmse->expr = gfc_conv_scalar_to_descriptor (parmse,
@@ -5012,6 +5048,17 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
   /* The CFI descriptor is passed to the bind_C procedure.  */
   parmse->expr = cfi_desc_ptr;
 
+  if (ptr)
+    {
+      /* Free both the temporary data and the CFI descriptor for
+	 INTENT(IN) arrays.  */
+      tmp = gfc_call_free (ptr);
+      gfc_prepend_expr_to_block (&parmse->post, tmp);
+      tmp = gfc_call_free (cfi_desc_ptr);
+      gfc_prepend_expr_to_block (&parmse->post, tmp);
+      return;
+    }
+
   /* Transfer values back to gfc descriptor and free the CFI descriptor.  */
   tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr);
   tmp = build_call_expr_loc (input_location,

gcc/testsuite/ChangeLog

+2019-01-24  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/88929
+	* gfortran.dg/ISO_Fortran_binding_3.f90 : New test
+	* gfortran.dg/ISO_Fortran_binding_3.c : Subsidiary source.
+
 2019-01-23  H.J. Lu  <hongjiu.lu@intel.com>
 
 	PR libgcc/88931
@@ -218,7 +224,7 @@
 
 2019-01-20  Kewen Lin  <linkw@gcc.gnu.org>
 
-	* gcc.target/powerpc/altivec_vld_vst_addr.c: Remove, split into 
+	* gcc.target/powerpc/altivec_vld_vst_addr.c: Remove, split into
 	altivec_vld_vst_addr-1.c and altivec_vld_vst_addr-2.c.
 	* gcc.target/powerpc/altivec_vld_vst_addr-1.c: New test.
 	* gcc.target/powerpc/altivec_vld_vst_addr-2.c: Ditto.

gcc/testsuite/gfortran.dg/ISO_Fortran_binding_3.c

+#include "../../../libgfortran/ISO_Fortran_binding.h"
+#include <stdio.h>
+#include <stdlib.h>
+
+/* Part of the test for the fix of PR88929 - see ISO_Fortran_binding_3.f90. */
+
+int c_test (CFI_cdesc_t * a_desc)
+{
+  CFI_index_t idx[2];
+  int *res_addr;
+  int err = 1; /* this error code represents all errors */
+
+  if (a_desc->rank != 2)
+    return err;
+
+  if (a_desc->type != CFI_type_int)
+    return err;
+
+  err = 0;
+  for (idx[0] = 0; idx[0] < a_desc->dim[0].extent; idx[0]++)
+    for (idx[1] = 0; idx[1] < a_desc->dim[1].extent; idx[1]++)
+      {
+	res_addr = CFI_address (a_desc, idx);
+	err += *res_addr;
+	*res_addr = *res_addr + 1;
+      }
+
+  if (err != 10) return 1;
+
+  return 0;
+}
+

gcc/testsuite/gfortran.dg/ISO_Fortran_binding_3.f90

+! { dg-do run }
+! { dg-additional-sources ISO_Fortran_binding_3.c }
+!
+! Test the fix for PR88929.
+!
+  integer, dimension (:,:), allocatable :: actual
+  integer, dimension(2,2) :: src = reshape ([1,2,3,4], [2,2])
+
+  allocate (actual, source = src)
+  ier = test1 (actual)
+  if (ier .ne. 0) stop 1
+! C call is INTENT(IN). 'c_test' increments elements of 'src'.
+  if (any (actual .ne. src)) stop 2
+
+  ier = test2 (actual)
+  if (ier .ne. 0) stop 1
+! C call is INTENT(INOUT) 'c_test' increments elements of 'src'.
+  if (any (actual .ne. src + 1)) stop 2
+
+contains
+
+  function test1 (arg) RESULT(err)
+    USE, INTRINSIC :: ISO_C_BINDING
+    INTEGER(C_INT) :: err
+    type(*), dimension(..), intent(inOUT) :: arg
+    interface
+      function test_c (a) BIND(C, NAME="c_test") RESULT(err)
+          USE, INTRINSIC :: ISO_C_BINDING
+          type(*), dimension(..), intent(in) :: a
+          INTEGER(C_INT) :: err
+      end function
+    end interface
+
+    err = test_c (arg) ! This used to ICE
+
+  end function test1
+
+  function test2 (arg) RESULT(err)
+    USE, INTRINSIC :: ISO_C_BINDING
+    INTEGER(C_INT) :: err
+    type(*), dimension(..), intent(inout) :: arg
+    interface
+      function test_c (a) BIND(C, NAME="c_test") RESULT(err)
+          USE, INTRINSIC :: ISO_C_BINDING
+          type(*), dimension(..), intent(inout) :: a
+          INTEGER(C_INT) :: err
+      end function
+    end interface
+
+    err = test_c (arg) ! This used to ICE
+
+  end function test2
+end
\ No newline at end of file