re PR fortran/89843 (CFI_section delivers incorrect result descriptor)

2019-04-14  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/89843
	* trans-decl.c (gfc_get_symbol_decl): Assumed shape and assumed
	rank dummies of bind C procs require deferred initialization.
	(convert_CFI_desc): New procedure to convert incoming CFI
	descriptors to gfc types and back again.
	(gfc_trans_deferred_vars): Call it.
	* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Null the CFI
	descriptor pointer. Free the descriptor in all cases.

	PR fortran/89846
	* expr.c (is_CFI_desc): New function.
	(is_subref_array): Tidy up by referencing the symbol directly.
	* gfortran.h : Prototype for is_CFI_desc.
	* trans_array.c (get_CFI_desc): New function.
	(gfc_get_array_span, gfc_conv_scalarized_array_ref,
	gfc_conv_array_ref): Use it.
	* trans.c (get_array_span): Extract the span from descriptors
	that are indirect references.

	PR fortran/90022
	* trans-decl.c (gfc_get_symbol_decl): Make sure that the se
	expression is a pointer type before converting it to the symbol
	backend_decl type.
	* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Eliminate
	temporary creation for intent(in).

2019-04-14  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/89843
	* gfortran.dg/ISO_Fortran_binding_4.f90: Modify the value of x
	in ctg. Test the conversion of the descriptor types in the main
	program.
	* gfortran.dg/ISO_Fortran_binding_10.f90: New test.
	* gfortran.dg/ISO_Fortran_binding_10.c: Called by it.

	PR fortran/89846
	* gfortran.dg/ISO_Fortran_binding_11.f90: New test.
	* gfortran.dg/ISO_Fortran_binding_11.c: Called by it.

	PR fortran/90022
	* gfortran.dg/ISO_Fortran_binding_1.c: Correct the indexing for
	the computation of 'ans'. Also, change the expected results for
	CFI_is_contiguous to comply with standard.
	* gfortran.dg/ISO_Fortran_binding_1.f90: Correct the expected
	results for CFI_is_contiguous to comply with standard.
	* gfortran.dg/ISO_Fortran_binding_9.f90: New test.
	* gfortran.dg/ISO_Fortran_binding_9.c: Called by it.

2019-04-14  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/89843
	* runtime/ISO_Fortran_binding.c (cfi_desc_to_gfc_desc): Only
	return immediately if the source pointer is null. Bring
	forward the extraction of the gfc type. Extract the kind so
	that the element size can be correctly computed for sections
	and components of derived type arrays. Remove the free of the
	CFI descriptor since this is now done in trans-expr.c.
	(gfc_desc_to_cfi_desc): Only allocate the CFI descriptor if it
	is not null.
	(CFI_section): Normalise the difference between the upper and
	lower bounds by the stride to correctly calculate the extents
	of the section.

	PR fortran/89846
	* runtime/ISO_Fortran_binding.c (cfi_desc_to_gfc_desc): Use
	the stride measure for the gfc span if it is not a multiple
	of the element length. Otherwise use the element length.

	PR fortran/90022
	* runtime/ISO_Fortran_binding.c (CFI_is_contiguous) : Return
	1 for true and 0 otherwise to comply with the standard. Correct
	the contiguity check for rank 3 and greater by using the stride
	measure of the lower dimension rather than the element length.

From-SVN: r270353

18 files changed, 619 insertions, 129 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index ef6200c..e27743c 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,31 @@
+2019-04-14  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/89843
+	* trans-decl.c (gfc_get_symbol_decl): Assumed shape and assumed
+	rank dummies of bind C procs require deferred initialization.
+	(convert_CFI_desc): New procedure to convert incoming CFI
+	descriptors to gfc types and back again.
+	(gfc_trans_deferred_vars): Call it.
+	* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Null the CFI
+	descriptor pointer. Free the descriptor in all cases.
+
+	PR fortran/89846
+	* expr.c (is_CFI_desc): New function.
+	(is_subref_array): Tidy up by referencing the symbol directly.
+	* gfortran.h : Prototype for is_CFI_desc.
+	* trans_array.c (get_CFI_desc): New function.
+	(gfc_get_array_span, gfc_conv_scalarized_array_ref,
+	gfc_conv_array_ref): Use it.
+	* trans.c (get_array_span): Extract the span from descriptors
+	that are indirect references.
+
+	PR fortran/90022
+	* trans-decl.c (gfc_get_symbol_decl): Make sure that the se
+	expression is a pointer type before converting it to the symbol
+	backend_decl type.
+	* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Eliminate
+	temporary creation for intent(in).
+
 2019-04-13  Dominique d'Humieres  <dominiq@gcc.gnu.org>
 
 	PR fortran/79842
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 3b46b4e..474e9ec 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -1061,6 +1061,27 @@ gfc_is_constant_expr (gfc_expr *e)
 }
 
 
+/* Is true if the expression or symbol is a passed CFI descriptor.  */
+bool
+is_CFI_desc (gfc_symbol *sym, gfc_expr *e)
+{
+  if (sym == NULL
+      && e && e->expr_type == EXPR_VARIABLE)
+    sym = e->symtree->n.sym;
+
+  if (sym && sym->attr.dummy
+      && sym->ns->proc_name->attr.is_bind_c
+      && sym->attr.dimension
+      && (sym->attr.pointer
+	  || sym->attr.allocatable
+	  || sym->as->type == AS_ASSUMED_SHAPE
+	  || sym->as->type == AS_ASSUMED_RANK))
+    return true;
+
+return false;
+}
+
+
 /* Is true if an array reference is followed by a component or substring
    reference.  */
 bool
@@ -1068,11 +1089,14 @@ is_subref_array (gfc_expr * e)
 {
   gfc_ref * ref;
   bool seen_array;
+  gfc_symbol *sym;
 
   if (e->expr_type != EXPR_VARIABLE)
     return false;
 
-  if (e->symtree->n.sym->attr.subref_array_pointer)
+  sym = e->symtree->n.sym;
+
+  if (sym->attr.subref_array_pointer)
     return true;
 
   seen_array = false;
@@ -1097,10 +1121,10 @@ is_subref_array (gfc_expr * e)
 	return seen_array;
     }
 
-  if (e->symtree->n.sym->ts.type == BT_CLASS
-      && e->symtree->n.sym->attr.dummy
-      && CLASS_DATA (e->symtree->n.sym)->attr.dimension
-      && CLASS_DATA (e->symtree->n.sym)->attr.class_pointer)
+  if (sym->ts.type == BT_CLASS
+      && sym->attr.dummy
+      && CLASS_DATA (sym)->attr.dimension
+      && CLASS_DATA (sym)->attr.class_pointer)
     return true;
 
   return false;
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index be975cd..23d01b1 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3221,6 +3221,7 @@ gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
 bool gfc_extract_int (gfc_expr *, int *, int = 0);
 bool gfc_extract_hwi (gfc_expr *, HOST_WIDE_INT *, int = 0);
 
+bool is_CFI_desc (gfc_symbol *, gfc_expr *);
 bool is_subref_array (gfc_expr *);
 bool gfc_is_simply_contiguous (gfc_expr *, bool, bool);
 bool gfc_is_not_contiguous (gfc_expr *);
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 2bc24d9..55879af 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -849,6 +849,41 @@ is_pointer_array (tree expr)
 }
 
 
+/* If the symbol or expression reference a CFI descriptor, return the
+   pointer to the converted gfc descriptor. If an array reference is
+   present as the last argument, check that it is the one applied to
+   the CFI descriptor in the expression. Note that the CFI object is
+   always the symbol in the expression!  */
+
+static bool
+get_CFI_desc (gfc_symbol *sym, gfc_expr *expr,
+	      tree *desc, gfc_array_ref *ar)
+{
+  tree tmp;
+
+  if (!is_CFI_desc (sym, expr))
+    return false;
+
+  if (expr && ar)
+    {
+      if (!(expr->ref && expr->ref->type == REF_ARRAY)
+	  || (&expr->ref->u.ar != ar))
+	return false;
+    }
+
+  if (sym == NULL)
+    tmp = expr->symtree->n.sym->backend_decl;
+  else
+    tmp = sym->backend_decl;
+
+  if (tmp && DECL_LANG_SPECIFIC (tmp))
+    tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
+
+  *desc = tmp;
+  return true;
+}
+
+
 /* Return the span of an array.  */
 
 tree
@@ -856,9 +891,14 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
 {
   tree tmp;
 
-  if (is_pointer_array (desc))
-    /* This will have the span field set.  */
-    tmp = gfc_conv_descriptor_span_get (desc);
+  if (is_pointer_array (desc) || get_CFI_desc (NULL, expr, &desc, NULL))
+    {
+      if (POINTER_TYPE_P (TREE_TYPE (desc)))
+	desc = build_fold_indirect_ref_loc (input_location, desc);
+
+      /* This will have the span field set.  */
+      tmp = gfc_conv_descriptor_span_get (desc);
+    }
   else if (TREE_CODE (desc) == COMPONENT_REF
 	   && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
 	   && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0))))
@@ -3466,6 +3506,12 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
   if (build_class_array_ref (se, base, index))
     return;
 
+  if (get_CFI_desc (NULL, expr, &decl, ar))
+    {
+      decl = build_fold_indirect_ref_loc (input_location, decl);
+      goto done;
+    }
+
   if (expr && ((is_subref_array (expr)
 		&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor)))
 	       || (expr->ts.deferred && (expr->expr_type == EXPR_VARIABLE
@@ -3721,6 +3767,8 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
   /* A pointer array component can be detected from its field decl. Fix
      the descriptor, mark the resulting variable decl and pass it to
      build_array_ref.  */
+  if (get_CFI_desc (sym, expr, &decl, ar))
+    decl = build_fold_indirect_ref_loc (input_location, decl);
   if (!expr->ts.deferred && !sym->attr.codimension
       && is_pointer_array (se->expr))
     {
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index ada6370..a0e1f6a 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -4268,6 +4268,72 @@ gfc_null_and_pass_deferred_len (gfc_symbol *sym, stmtblock_t *init,
 }
 
 
+/* Convert CFI descriptor dummies into gfc types and back again.  */
+static void
+convert_CFI_desc (gfc_wrapped_block * block, gfc_symbol *sym)
+{
+  tree gfc_desc;
+  tree gfc_desc_ptr;
+  tree CFI_desc;
+  tree CFI_desc_ptr;
+  tree dummy_ptr;
+  tree tmp;
+  tree incoming;
+  tree outgoing;
+  stmtblock_t tmpblock;
+
+  /* dummy_ptr will be the pointer to the passed array descriptor,
+     while CFI_desc is the descriptor itself.  */
+  if (DECL_LANG_SPECIFIC (sym->backend_decl))
+    CFI_desc = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
+  else
+    CFI_desc = NULL;
+
+  dummy_ptr = CFI_desc;
+
+  if (CFI_desc)
+    {
+      CFI_desc = build_fold_indirect_ref_loc (input_location, CFI_desc);
+
+      /* The compiler will have given CFI_desc the correct gfortran
+	 type. Use this new variable to store the converted
+	 descriptor.  */
+      gfc_desc = gfc_create_var (TREE_TYPE (CFI_desc), "gfc_desc");
+      tmp = build_pointer_type (TREE_TYPE (gfc_desc));
+      gfc_desc_ptr = gfc_create_var (tmp, "gfc_desc_ptr");
+      CFI_desc_ptr = gfc_create_var (pvoid_type_node, "CFI_desc_ptr");
+
+      gfc_init_block (&tmpblock);
+      /* Pointer to the gfc descriptor.  */
+      gfc_add_modify (&tmpblock, gfc_desc_ptr,
+		      gfc_build_addr_expr (NULL, gfc_desc));
+      /* Store the pointer to the CFI descriptor.  */
+      gfc_add_modify (&tmpblock, CFI_desc_ptr,
+		      fold_convert (pvoid_type_node, dummy_ptr));
+      tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr);
+      /* Convert the CFI descriptor.  */
+      incoming = build_call_expr_loc (input_location,
+			gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp);
+      gfc_add_expr_to_block (&tmpblock, incoming);
+      /* Set the dummy pointer to point to the gfc_descriptor.  */
+      gfc_add_modify (&tmpblock, dummy_ptr,
+		      fold_convert (TREE_TYPE (dummy_ptr), gfc_desc_ptr));
+      incoming = gfc_finish_block (&tmpblock);
+
+      gfc_init_block (&tmpblock);
+      /* Convert the gfc descriptor back to the CFI type before going
+	 out of scope.  */
+      tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr);
+      outgoing = build_call_expr_loc (input_location,
+			gfor_fndecl_gfc_to_cfi, 2, tmp, gfc_desc_ptr);
+      gfc_add_expr_to_block (&tmpblock, outgoing);
+      outgoing = gfc_finish_block (&tmpblock);
+
+      /* Add the lot to the procedure init and finally blocks.  */
+      gfc_add_init_cleanup (block, incoming, outgoing);
+    }
+}
+
 /* Get the result expression for a procedure.  */
 
 static tree
@@ -4844,6 +4910,13 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	}
       else if (!(UNLIMITED_POLY(sym)) && !is_pdt_type)
 	gcc_unreachable ();
+
+      /* Assumed shape and assumed rank arrays are passed to BIND(C) procedures
+	 as ISO Fortran Interop descriptors. These have to be converted to
+	 gfortran descriptors and back again.  This has to be done here so that
+	 the conversion occurs at the start of the init block.  */
+      if (is_CFI_desc (sym, NULL))
+	convert_CFI_desc (block, sym);
     }
 
   gfc_init_block (&tmpblock);
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 434c989..21535ac 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -4987,11 +4987,11 @@ 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;
+  tree cond;
   int attribute;
   symbol_attribute attr = gfc_expr_attr (e);
+  stmtblock_t block;
 
   /* If this is a full array or a scalar, the allocatable and pointer
      attributes can be passed. Otherwise it is 'CFI_attribute_other'*/
@@ -5056,37 +5056,6 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
 	  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);
-
-	  /* The temporary 'ptr' is freed below.  */
-	  gfc_conv_descriptor_data_set (&parmse->pre, parmse->expr, ptr);
-	}
-
     }
   else
     {
@@ -5096,28 +5065,6 @@ 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).  */
-      if (e->expr_type == EXPR_VARIABLE && fsym->attr.intent == INTENT_IN)
-	{
-	  if (e->ts.type != BT_CHARACTER)
-	    parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
-	  else
-	    {
-	      /* The temporary string 'ptr' is freed below.  */
-	      tmp = build_pointer_type (TREE_TYPE (parmse->expr));
-	      ptr = gfc_create_var (tmp, "str");
-	      tmp = build_call_expr_loc (input_location,
-				 builtin_decl_explicit (BUILT_IN_MALLOC),
-				 1, parmse->string_length);
-	      tmp = fold_convert (TREE_TYPE (ptr), tmp);
-	      gfc_add_modify (&parmse->pre, ptr, tmp);
-	      tmp = gfc_build_memcpy_call (ptr, parmse->expr,
-					   parmse->string_length);
-	      gfc_add_expr_to_block (&parmse->pre, tmp);
-	      parmse->expr = ptr;
-	    }
-	}
-
       parmse->expr = gfc_conv_scalar_to_descriptor (parmse,
 						    parmse->expr, attr);
     }
@@ -5135,6 +5082,8 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
   /* Variables to point to the gfc and CFI descriptors.  */
   gfc_desc_ptr = parmse->expr;
   cfi_desc_ptr = gfc_create_var (pvoid_type_node, "cfi");
+  gfc_add_modify (&parmse->pre, cfi_desc_ptr,
+		  build_int_cst (pvoid_type_node, 0));
 
   /* Allocate the CFI descriptor and fill the fields.  */
   tmp = gfc_build_addr_expr (NULL_TREE, cfi_desc_ptr);
@@ -5145,18 +5094,19 @@ 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;
-    }
+  /* Free the CFI descriptor.  */
+  gfc_init_block (&block);
+  cond = fold_build2_loc (input_location, NE_EXPR,
+			  logical_type_node, cfi_desc_ptr,
+			  build_int_cst (TREE_TYPE (cfi_desc_ptr), 0));
+  tmp = gfc_call_free (cfi_desc_ptr);
+  gfc_add_expr_to_block (&block, tmp);
+  tmp = build3_v (COND_EXPR, cond,
+		  gfc_finish_block (&block),
+		  build_empty_stmt (input_location));
+  gfc_prepend_expr_to_block (&parmse->post, tmp);
 
-  /* Transfer values back to gfc descriptor and free the CFI descriptor.  */
+  /* Transfer values back to gfc descriptor.  */
   tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr);
   tmp = build_call_expr_loc (input_location,
 			     gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp);
@@ -5516,11 +5466,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		}
 
 	      else if (sym->attr.is_bind_c && e
-		       && ((fsym && fsym->attr.dimension
-			    && (fsym->attr.pointer
-				|| fsym->attr.allocatable
-				|| fsym->as->type == AS_ASSUMED_RANK
-				|| fsym->as->type == AS_ASSUMED_SHAPE))
+		       && (is_CFI_desc (fsym, NULL)
 			   || non_unity_length_string))
 		/* Implement F2018, C.12.6.1: paragraph (2).  */
 		gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
@@ -5965,12 +5911,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		}
 
 	      if (sym->attr.is_bind_c && e
-		  && fsym && fsym->attr.dimension
-		  && (fsym->attr.pointer
-		      || fsym->attr.allocatable
-		      || fsym->as->type == AS_ASSUMED_RANK
-		      || fsym->as->type == AS_ASSUMED_SHAPE
-		      || non_unity_length_string))
+		  && (is_CFI_desc (fsym, NULL) || non_unity_length_string))
 		/* Implement F2018, C.12.6.1: paragraph (2).  */
 		gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
 
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 29a4d00..022ceb9 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -352,6 +352,9 @@ get_array_span (tree type, tree decl)
       else
 	span = NULL_TREE;
     }
+  else if (TREE_CODE (decl) == INDIRECT_REF
+	   && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
+    span = gfc_conv_descriptor_span_get (decl);
   else
     span = NULL_TREE;
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 1f3dd43..4ede1de 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,25 @@
+2019-04-14  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/89843
+	* gfortran.dg/ISO_Fortran_binding_4.f90: Modify the value of x
+	in ctg. Test the conversion of the descriptor types in the main
+	program.
+	* gfortran.dg/ISO_Fortran_binding_10.f90: New test.
+	* gfortran.dg/ISO_Fortran_binding_10.c: Called by it.
+
+	PR fortran/89846
+	* gfortran.dg/ISO_Fortran_binding_11.f90: New test.
+	* gfortran.dg/ISO_Fortran_binding_11.c: Called by it.
+
+	PR fortran/90022
+	* gfortran.dg/ISO_Fortran_binding_1.c: Correct the indexing for
+	the computation of 'ans'. Also, change the expected results for
+	CFI_is_contiguous to comply with standard.
+	* gfortran.dg/ISO_Fortran_binding_1.f90: Correct the expected
+	results for CFI_is_contiguous to comply with standard.
+	* gfortran.dg/ISO_Fortran_binding_9.f90: New test.
+	* gfortran.dg/ISO_Fortran_binding_9.c: Called by it.
+
 2019-04-13  Jakub Jelinek  <jakub@redhat.com>
 
 	PR target/89093
diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c
index d3eb9a4..a6353c7 100644
--- a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c
+++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c
@@ -105,7 +105,7 @@ float section_c(int *std_case, CFI_cdesc_t * source, int *low, int *str)
   CFI_index_t idx[CFI_MAX_RANK], lower[CFI_MAX_RANK],
 		  strides[CFI_MAX_RANK], upper[CFI_MAX_RANK];
   CFI_CDESC_T(1) section;
-  int ind, size;
+  int ind;
   float *ret_addr;
   float ans = 0.0;
 
@@ -121,9 +121,7 @@ float section_c(int *std_case, CFI_cdesc_t * source, int *low, int *str)
       if (ind) return -2.0;
 
       /* Sum over the section  */
-      size = (section.dim[0].extent - 1)
-		* section.elem_len/section.dim[0].sm + 1;
-      for (idx[0] = 0; idx[0] < size; idx[0]++)
+      for (idx[0] = 0; idx[0] < section.dim[0].extent; idx[0]++)
         ans += *(float*)CFI_address ((CFI_cdesc_t*)&section, idx);
       return ans;
     }
@@ -143,9 +141,7 @@ float section_c(int *std_case, CFI_cdesc_t * source, int *low, int *str)
       if (ind) return -2.0;
 
       /* Sum over the section  */
-      size = (section.dim[0].extent - 1)
-		* section.elem_len/section.dim[0].sm + 1;
-      for (idx[0] = 0; idx[0] < size; idx[0]++)
+      for (idx[0] = 0; idx[0] < section.dim[0].extent; idx[0]++)
         ans += *(float*)CFI_address ((CFI_cdesc_t*)&section, idx);
       return ans;
     }
@@ -191,15 +187,15 @@ int setpointer_c(CFI_cdesc_t * ptr, int lbounds[])
 
 int assumed_size_c(CFI_cdesc_t * desc)
 {
-  int ierr;
+  int res;
 
-  ierr = CFI_is_contiguous(desc);
-  if (ierr)
+  res = CFI_is_contiguous(desc);
+  if (!res)
     return 1;
   if (desc->rank)
-    ierr = 2 * (desc->dim[desc->rank-1].extent
+    res = 2 * (desc->dim[desc->rank-1].extent
 				!= (CFI_index_t)(long long)(-1));
   else
-    ierr = 3;
-  return ierr;
+    res = 3;
+  return res;
 }
diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90
index d3a7b2b..102bc60 100644
--- a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90
+++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90
@@ -170,16 +170,16 @@ end subroutine test_CFI_address
     integer, dimension (2,*) :: arg
     character(4), dimension(2) :: chr
 ! These are contiguous
-    if (c_contiguous (arg) .ne. 0) stop 20
+    if (c_contiguous (arg) .ne. 1) stop 20
     if (.not.allocated (x)) allocate (x(2, 2))
-    if (c_contiguous (x) .ne. 0) stop 22
+    if (c_contiguous (x) .ne. 1) stop 22
     deallocate (x)
-    if (c_contiguous (chr) .ne. 0) stop 23
+    if (c_contiguous (chr) .ne. 1) stop 23
 ! These are not contiguous
-    if (c_contiguous (der%i) .eq. 0) stop 24
-    if (c_contiguous (arg(1:1,1:2)) .eq. 0) stop 25
-    if (c_contiguous (d(4:2:-2, 1:3:2)) .eq. 0) stop 26
-    if (c_contiguous (chr(:)(2:3)) .eq. 0) stop 27
+    if (c_contiguous (der%i) .eq. 1) stop 24
+    if (c_contiguous (arg(1:1,1:2)) .eq. 1) stop 25
+    if (c_contiguous (d(4:2:-2, 1:3:2)) .eq. 1) stop 26
+    if (c_contiguous (chr(:)(2:3)) .eq. 1) stop 27
   end subroutine test_CFI_contiguous
 
   subroutine test_CFI_section (arg)
diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_10.c b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_10.c
new file mode 100644
index 0000000..adda3b3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_10.c
@@ -0,0 +1,73 @@
+/* Test the fix of PR89843.  */
+
+/* Contributed by Reinhold Bader  <Bader@lrz.de> */
+
+#include "../../../libgfortran/ISO_Fortran_binding.h"
+#include <stdlib.h>
+#include <stdio.h>
+#include <stdbool.h>
+
+void sa(CFI_cdesc_t *, int, int *);
+
+void si(CFI_cdesc_t *this, int flag, int *status)
+{
+  int value, sum;
+  bool err;
+  CFI_CDESC_T(1) that;
+  CFI_index_t lb[] = { 0, 0 };
+  CFI_index_t ub[] = { 4, 1 };
+  CFI_index_t st[] = { 2, 0 };
+  int chksum[] = { 9, 36, 38 };
+
+  if (flag == 1)
+    {
+      lb[0] = 0; lb[1] = 2;
+      ub[0] = 2; ub[1] = 2;
+      st[0] = 1; st[1] = 0;
+    }
+  else if (flag == 2)
+    {
+      lb[0] = 1; lb[1] = 0;
+      ub[0] = 1; ub[1] = 3;
+      st[0] = 0; st[1] = 1;
+    }
+
+  CFI_establish((CFI_cdesc_t *) &that, NULL, CFI_attribute_other,
+		CFI_type_float, 0, 1, NULL);
+
+  *status = CFI_section((CFI_cdesc_t *) &that, this, lb, ub, st);
+
+  if (*status != CFI_SUCCESS)
+    {
+      printf("FAIL C: status is %i\n",status);
+      return;
+    }
+
+  value = CFI_is_contiguous((CFI_cdesc_t *) &that);
+  err = ((flag == 0 && value != 0)
+	 || (flag == 1 && value != 1)
+	 || (flag == 2 && value != 0));
+
+  if (err)
+    {
+      printf("FAIL C: contiguity for flag value %i - is %i\n",flag, value);
+      *status = 10;
+      return;
+    }
+
+  sum = 0;
+  for (int i = 0; i < that.dim[0].extent; i++)
+    {
+      CFI_index_t idx[] = {i};
+      sum += (int)(*(float *)CFI_address ((CFI_cdesc_t *)&that, idx));
+    }
+
+  if (sum != chksum[flag])
+    {
+      printf ("FAIL C: check sum = %d(%d)\n", sum, chksum[flag]);
+      *status = 11;
+      return;
+    }
+
+    sa((CFI_cdesc_t *) &that, flag, status);
+}
diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_10.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_10.f90
new file mode 100644
index 0000000..602d8f7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_10.f90
@@ -0,0 +1,99 @@
+! { dg-do run { target c99_runtime } }
+! { dg-additional-sources ISO_Fortran_binding_10.c }
+!
+! Test the fix of PR89843.
+!
+! Contributed by Reinhold Bader  <Bader@lrz.de>
+!
+module mod_section_01
+  use, intrinsic :: iso_c_binding
+  implicit none
+  interface
+     subroutine si(this, flag, status) bind(c)
+       import :: c_float, c_int
+       real(c_float) :: this(:,:)
+       integer(c_int), value :: flag
+       integer(c_int) :: status
+     end subroutine si
+  end interface
+contains
+  subroutine sa(this, flag, status) bind(c)
+    real(c_float) :: this(:)
+    integer(c_int), value :: flag
+    integer(c_int) :: status
+
+    status = 0
+
+    select case (flag)
+    case (0)
+       if (is_contiguous(this)) then
+          write(*,*) 'FAIL 1:'
+          status = status + 1
+       end if
+       if (size(this,1) /= 3) then
+          write(*,*) 'FAIL 2:',size(this)
+          status = status + 1
+          goto 10
+       end if
+       if (maxval(abs(this - [ 1.0, 3.0, 5.0 ])) > 1.0e-6) then
+          write(*,*) 'FAIL 3:',abs(this)
+          status = status + 1
+       end if
+  10   continue
+   case (1)
+      if (size(this,1) /= 3) then
+          write(*,*) 'FAIL 4:',size(this)
+          status = status + 1
+          goto 20
+       end if
+       if (maxval(abs(this - [ 11.0, 12.0, 13.0 ])) > 1.0e-6) then
+          write(*,*) 'FAIL 5:',this
+          status = status + 1
+       end if
+  20   continue
+   case (2)
+      if (size(this,1) /= 4) then
+          write(*,*) 'FAIL 6:',size(this)
+          status = status + 1
+          goto 30
+       end if
+      if (maxval(abs(this - [ 2.0, 7.0, 12.0, 17.0 ])) > 1.0e-6) then
+          write(*,*) 'FAIL 7:',this
+          status = status + 1
+       end if
+  30   continue
+    end select
+
+!    if (status == 0) then
+!       write(*,*) 'OK'
+!    end if
+  end subroutine sa
+end module mod_section_01
+
+program section_01
+  use mod_section_01
+  implicit none
+  real(c_float) :: v(5,4)
+  integer :: i
+  integer :: status
+
+  v = reshape( [ (real(i), i = 1, 20) ], [ 5, 4 ] )
+  call si(v, 0, status)
+  if (status .ne. 0) stop 1
+
+  call sa(v(1:5:2, 1), 0, status)
+  if (status .ne. 0) stop 2
+
+  call si(v, 1, status)
+  if (status .ne. 0) stop 3
+
+  call sa(v(1:3, 3), 1, status)
+  if (status .ne. 0) stop 4
+
+  call si(v, 2, status)
+  if (status .ne. 0) stop 5
+
+  call sa(v(2,1:4), 2, status)
+  if (status .ne. 0) stop 6
+
+end program section_01
diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_11.c b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_11.c
new file mode 100644
index 0000000..ac17690
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_11.c
@@ -0,0 +1,78 @@
+/* Test the fix of PR89846.
+
+Contributed by Reinhold Bader  <Bader@lrz.de>#include <stdio.h> */
+
+#include <stdlib.h>
+#include <stddef.h>
+#include <stdio.h>
+#include "../../../libgfortran/ISO_Fortran_binding.h"
+
+typedef struct
+{
+  char n;
+  float r[2];
+} t1;
+
+typedef struct
+{
+  long int i;
+  t1 t1;
+} t2;
+
+
+
+void ta0(CFI_cdesc_t *);
+void ta1(CFI_cdesc_t *);
+
+void ti(CFI_cdesc_t *this, int flag)
+{
+  int status;
+  size_t dis;
+  CFI_CDESC_T(1) that;
+  t1 *ans;
+
+  switch (flag)
+    {
+    case 0:
+      dis = offsetof(t2, t1);
+      status = CFI_establish((CFI_cdesc_t *) &that, NULL, CFI_attribute_other,
+			     CFI_type_struct, sizeof(t1), 1, NULL);
+      if (status != CFI_SUCCESS)
+	{
+	  printf("FAIL 1 establish: nonzero status %i\n",status);
+          exit(1);
+	}
+      status = CFI_select_part((CFI_cdesc_t *) &that, this, dis, 0);
+      if (status != CFI_SUCCESS)
+	{
+	  printf("FAIL C1: nonzero status %i\n",status);
+	  exit(1);
+	}
+     break;
+
+    case 1:
+      dis = offsetof(t2, i);
+      status = CFI_establish((CFI_cdesc_t *) &that, NULL, CFI_attribute_other,
+			     CFI_type_long, 0, 1, NULL);
+      if (status != CFI_SUCCESS)
+	{
+	  printf("FAIL 2 establish: nonzero status %i\n",status);
+	  exit(1);
+	}
+      status = CFI_select_part((CFI_cdesc_t *) &that, this, dis, 0);
+      if (status != CFI_SUCCESS)
+	{
+	  printf("FAIL C2: nonzero status %i\n",status);
+	  exit(1);
+	}
+    }
+
+  if (CFI_is_contiguous((CFI_cdesc_t *) &that))
+    {
+      printf("FAIL C: contiguity for flag value %i - is %i\n",flag,
+	     CFI_is_contiguous((CFI_cdesc_t *) &that));
+    }
+
+  if (flag == 0) ta0((CFI_cdesc_t *) &that);
+  if (flag == 1) ta1((CFI_cdesc_t *) &that);
+}
diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_11.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_11.f90
new file mode 100644
index 0000000..e509425
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_11.f90
@@ -0,0 +1,81 @@
+! { dg-do run { target c99_runtime } }
+! { dg-additional-sources ISO_Fortran_binding_11.c }
+!
+! Test the fix of PR89846.
+!
+! Contributed by Reinhold Bader  <Bader@lrz.de>
+!
+module mod_subobj_01
+  use, intrinsic :: iso_c_binding
+  implicit none
+  integer, parameter :: nelem = 5
+  type, bind(c) :: t1
+     character(c_char) :: n
+     real(c_float) :: r(2)
+  end type t1
+  type, bind(c) :: t2
+     integer(c_long) :: i
+     type(t1) :: t1
+  end type t2
+  interface
+     subroutine ti(this, flag) bind(c)
+       import :: t2, c_int
+       type(t2) :: this(:)
+       integer(c_int), value :: flag
+     end subroutine ti
+  end interface
+contains
+  subroutine ta0(this) bind(c)
+    type(t1) :: this(:)
+    integer :: i, iw, status
+    status = 0
+    if (size(this) /= nelem) then
+       write(*,*) 'FAIL 1: ',size(this)
+       status = status + 1
+    end if
+    iw = 0
+    do i=1, nelem
+       if (this(i)%n /= char(i,c_char) .or. this(i)%r(1) /= real(i,c_float) .or. &
+            this(i)%r(2) /= real(i+1,c_float)) then
+          iw = iw + 1
+       end if
+    end do
+    if (iw > 0) then
+       write(*,*) 'FAIL 2: ' ,this
+       status = status + 1
+    end if
+    if (status /= 0) stop 1
+  end subroutine ta0
+  subroutine ta1(this) bind(c)
+    integer(c_long) :: this(:)
+    integer :: i, status
+    status = 0
+    if (size(this) /= nelem) then
+       write(*,*) 'FAIL 3: ',size(this)
+       status = status + 1
+    end if
+    if (maxval(abs(this - [ (int(i,c_long),i=1,nelem) ])) > 0) then
+       write(*,*) 'FAIL 4: ' ,this
+       status = status + 1
+    end if
+    if (status /= 0) stop 2
+  end subroutine ta1
+end module mod_subobj_01
+program subobj_01
+  use mod_subobj_01
+  implicit none
+  integer :: i
+
+  type(t2), allocatable :: o_t2(:)
+
+  allocate(o_t2(nelem))
+  do i=1, nelem
+     o_t2(i)%t1 = t1( char(i,c_char), [ real(i,c_float), real(i+1,c_float) ] )
+     o_t2(i)%i = int(i,c_long)
+  end do
+
+  call ti(o_t2,0)
+  call ti(o_t2,1)
+
+end program subobj_01
+
diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_3.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_3.f90
index c4cdbf0..20a1e19 100644
--- a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_3.f90
+++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_3.f90
@@ -7,14 +7,9 @@
   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)
+  ier = test1 (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
@@ -22,22 +17,6 @@ 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)
@@ -49,5 +28,5 @@ contains
 
     err = test_c (arg) ! This used to ICE
 
-  end function test2
+  end function test1
 end
diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90
index 2c6c81b..09410b7 100644
--- a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90
+++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90
@@ -10,9 +10,11 @@ contains
 
     if (any(abs(x - [2.,4.,6.]) > 1.e-6)) then
        write(*,*) 'FAIL'
+       stop 1
     else
        write(*,*) 'OK'
     end if
+    x = [2.,4.,6.]*10.0
   end subroutine
 end module
 program p
@@ -23,5 +25,5 @@ program p
 
   x = [ (real(i), i=1, size(x)) ]
   call ctg(x(2::2))
-
+  if (any (abs (x - [1.,20.,3.,40.,5.,60.]) > 1.e-6)) stop 2
 end program
diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_9.c b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_9.c
new file mode 100644
index 0000000..cb5b91d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_9.c
@@ -0,0 +1,14 @@
+/* Test fix of a problem with CFI_is_contiguous.  */
+
+/* Contributed by Gilles Gouaillardet  <gilles@rist.or.jp> */
+
+#include "../../../libgfortran/ISO_Fortran_binding.h"
+#include <stdlib.h>
+
+int cdesc_c(CFI_cdesc_t* x, long *expected)
+{
+  int res;
+  res = CFI_is_contiguous (x);
+  if (x->base_addr != (void *)*expected) res = 0;
+  return res;
+}
\ No newline at end of file
diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_9.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_9.f90
new file mode 100644
index 0000000..def5116
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_9.f90
@@ -0,0 +1,28 @@
+! { dg-do run { target c99_runtime } }
+! { dg-additional-sources ISO_Fortran_binding_9.c }
+!
+! Fix a problem with CFI_is_contiguous
+!
+! Contributed by Gilles Gouaillardet  <gilles@rist.or.jp>
+!
+module cdesc
+  interface
+  function cdesc_f08(buf, expected) result (res) BIND(C, name="cdesc_c")
+      USE, INTRINSIC :: ISO_C_BINDING
+      implicit none
+      INTEGER(C_INT) :: res
+      type(*), dimension(..), INTENT(IN) :: buf
+      integer(kind=kind(loc(res))),INTENT(IN) :: expected
+    end function cdesc_f08
+  end interface
+end module
+
+program cdesc_test
+  use cdesc
+  implicit none
+  integer :: a0, a1(10), a2(10,10), a3(10,10,10)
+  if (cdesc_f08(a0, LOC(a0)) .ne. 1) stop 1
+  if (cdesc_f08(a1, LOC(a1(1))) .ne. 1) stop 2
+  if (cdesc_f08(a2, LOC(a2(1,1))) .ne. 1) stop 3
+  if (cdesc_f08(a3, LOC(a3(1,1,1))) .ne. 1) stop 4
+end program