re PR fortran/90093 (Extended C interop: optional argument incorrectly identified as PRESENT)

2019-05-10  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/90093
	* trans-decl.c (convert_CFI_desc): Test that the dummy is
	present before doing any of the conversions.

	PR fortran/90352
	* decl.c (gfc_verify_c_interop_param): Restore the error for
	charlen > 1 actual arguments passed to bind(C) procs.
	Clean up trailing white space.

	PR fortran/90355
	* trans-array.c (gfc_trans_create_temp_array): Set the 'span'
	field to the element length for all types.
	(gfc_conv_expr_descriptor): The force_no_tmp flag is used to
	prevent temporary creation, especially for substrings.
	* trans-decl.c (gfc_trans_deferred_vars): Rather than assert
	that the backend decl for the string length is non-null, use it
	as a condition before calling gfc_trans_vla_type_sizes.
	* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): 'force_no_tmp'
	is set before calling gfc_conv_expr_descriptor.
	* trans.c (get_array_span): Move the code for extracting 'span'
	from gfc_build_array_ref to this function. This is specific to
	descriptors that are component and indirect references.
	* trans.h : Add the force_no_tmp flag bitfield to gfc_se.

2019-05-10  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/90093
	* gfortran.dg/ISO_Fortran_binding_12.f90: New test.
	* gfortran.dg/ISO_Fortran_binding_12.c: Supplementary code.

	PR fortran/90352
	* gfortran.dg/iso_c_binding_char_1.f90: New test.

	PR fortran/90355
	* gfortran.dg/ISO_Fortran_binding_4.f90: Add 'substr' to test
	the direct passing of substrings as descriptors to bind(C).
	* gfortran.dg/assign_10.f90: Increase the tree_dump count of
	'atmp' to account for the setting of the 'span' field.
	* gfortran.dg/transpose_optimization_2.f90: Ditto.

From-SVN: r271057

7 files changed, 107 insertions, 44 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index c910af4..cd73dd2 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,29 @@
+2019-05-10  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/90093
+	* trans-decl.c (convert_CFI_desc): Test that the dummy is
+	present before doing any of the conversions.
+
+	PR fortran/90352
+	* decl.c (gfc_verify_c_interop_param): Restore the error for
+	charlen > 1 actual arguments passed to bind(C) procs.
+	Clean up trailing white space.
+
+	PR fortran/90355
+	* trans-array.c (gfc_trans_create_temp_array): Set the 'span'
+	field to the element length for all types.
+	(gfc_conv_expr_descriptor): The force_no_tmp flag is used to
+	prevent temporary creation, especially for substrings.
+	* trans-decl.c (gfc_trans_deferred_vars): Rather than assert
+	that the backend decl for the string length is non-null, use it
+	as a condition before calling gfc_trans_vla_type_sizes.
+	* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): 'force_no_tmp'
+	is set before calling gfc_conv_expr_descriptor.
+	* trans.c (get_array_span): Move the code for extracting 'span'
+	from gfc_build_array_ref to this function. This is specific to
+	descriptors that are component and indirect references.
+	* trans.h : Add the force_no_tmp flag bitfield to gfc_se.
+
 2019-05-08  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	PR fortran/90351
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 66f1094..1c785a4 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -406,7 +406,7 @@ match_data_constant (gfc_expr **result)
 	 contains the right constant expression.  Check here.  */
       if ((*result)->symtree == NULL
 	  && (*result)->expr_type == EXPR_CONSTANT
-	  && ((*result)->ts.type == BT_INTEGER 
+	  && ((*result)->ts.type == BT_INTEGER
 	      || (*result)->ts.type == BT_REAL))
 	return m;
 
@@ -1493,19 +1493,18 @@ gfc_verify_c_interop_param (gfc_symbol *sym)
 
           /* Character strings are only C interoperable if they have a
              length of 1.  */
-          if (sym->ts.type == BT_CHARACTER)
+          if (sym->ts.type == BT_CHARACTER && !sym->attr.dimension)
 	    {
 	      gfc_charlen *cl = sym->ts.u.cl;
 	      if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT
                   || mpz_cmp_si (cl->length->value.integer, 1) != 0)
 		{
-		  if (!gfc_notify_std (GFC_STD_F2018,
-				       "Character argument %qs at %L "
-				       "must be length 1 because "
-				       "procedure %qs is BIND(C)",
-				       sym->name, &sym->declared_at,
-				       sym->ns->proc_name->name))
-		    retval = false;
+		  gfc_error ("Character argument %qs at %L "
+			     "must be length 1 because "
+			     "procedure %qs is BIND(C)",
+			     sym->name, &sym->declared_at,
+			     sym->ns->proc_name->name);
+		  retval = false;
 		}
 	    }
 
@@ -6074,7 +6073,7 @@ static bool
 in_module_or_interface(void)
 {
   if (gfc_current_state () == COMP_MODULE
-      || gfc_current_state () == COMP_SUBMODULE 
+      || gfc_current_state () == COMP_SUBMODULE
       || gfc_current_state () == COMP_INTERFACE)
     return true;
 
@@ -6085,7 +6084,7 @@ in_module_or_interface(void)
       gfc_state_data *p;
       for (p = gfc_state_stack->previous; p ; p = p->previous)
 	{
-	  if (p->state == COMP_MODULE || p->state == COMP_SUBMODULE 
+	  if (p->state == COMP_MODULE || p->state == COMP_SUBMODULE
 	      || p->state == COMP_INTERFACE)
 	    return true;
 	}
@@ -6304,7 +6303,7 @@ gfc_match_formal_arglist (gfc_symbol *progname, int st_flag,
     }
 
   if (gfc_match_char (')') == MATCH_YES)
-  {        
+  {
     if (typeparam)
       {
 	gfc_error_now ("A type parameter list is required at %C");
@@ -7489,7 +7488,7 @@ gfc_match_entry (void)
 	  if (!gfc_add_is_bind_c (&(entry->attr), entry->name,
 				  &(entry->declared_at), 1))
 	    return MATCH_ERROR;
-	
+
 	}
 
       if (!gfc_current_ns->parent
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 55879af..8a0de61 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -1239,6 +1239,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
   tree nelem;
   tree cond;
   tree or_expr;
+  tree elemsize;
   tree class_expr = NULL_TREE;
   int n, dim, tmp_dim;
   int total_dim = 0;
@@ -1333,15 +1334,6 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
   tmp = gfc_conv_descriptor_dtype (desc);
   gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
 
-  /* Also set the span for derived types, since they can be used in
-     component references to arrays of this type.  */
-  if (TREE_CODE (eltype) == RECORD_TYPE)
-    {
-      tmp = TYPE_SIZE_UNIT (eltype);
-      tmp = fold_convert (gfc_array_index_type, tmp);
-      gfc_conv_descriptor_span_set (pre, desc, tmp);
-    }
-
   /*
      Fill in the bounds and stride.  This is a packed array, so:
 
@@ -1413,22 +1405,21 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
 	}
     }
 
+  if (class_expr == NULL_TREE)
+    elemsize = fold_convert (gfc_array_index_type,
+			     TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+  else
+    elemsize = gfc_class_vtab_size_get (class_expr);
+
   /* Get the size of the array.  */
   if (size && !callee_alloc)
     {
-      tree elemsize;
       /* If or_expr is true, then the extent in at least one
 	 dimension is zero and the size is set to zero.  */
       size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
 			      or_expr, gfc_index_zero_node, size);
 
       nelem = size;
-      if (class_expr == NULL_TREE)
-	elemsize = fold_convert (gfc_array_index_type,
-			TYPE_SIZE_UNIT (gfc_get_element_type (type)));
-      else
-	elemsize = gfc_class_vtab_size_get (class_expr);
-
       size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
 			      size, elemsize);
     }
@@ -1438,6 +1429,10 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
       size = NULL_TREE;
     }
 
+  /* Set the span.  */
+  tmp = fold_convert (gfc_array_index_type, elemsize);
+  gfc_conv_descriptor_span_set (pre, desc, tmp);
+
   gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
 				    dynamic, dealloc);
 
@@ -7248,6 +7243,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 
       if (se->force_tmp)
 	need_tmp = 1;
+      else if (se->force_no_tmp)
+	need_tmp = 0;
 
       if (need_tmp)
 	full = 0;
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index a0e1f6a..c010956 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -4278,8 +4278,10 @@ convert_CFI_desc (gfc_wrapped_block * block, gfc_symbol *sym)
   tree CFI_desc_ptr;
   tree dummy_ptr;
   tree tmp;
+  tree present;
   tree incoming;
   tree outgoing;
+  stmtblock_t outer_block;
   stmtblock_t tmpblock;
 
   /* dummy_ptr will be the pointer to the passed array descriptor,
@@ -4303,6 +4305,12 @@ convert_CFI_desc (gfc_wrapped_block * block, gfc_symbol *sym)
       gfc_desc_ptr = gfc_create_var (tmp, "gfc_desc_ptr");
       CFI_desc_ptr = gfc_create_var (pvoid_type_node, "CFI_desc_ptr");
 
+      /* Fix the condition for the presence of the argument.  */
+      gfc_init_block (&outer_block);
+      present = fold_build2_loc (input_location, NE_EXPR,
+				 logical_type_node, dummy_ptr,
+				 build_int_cst (TREE_TYPE (dummy_ptr), 0));
+
       gfc_init_block (&tmpblock);
       /* Pointer to the gfc descriptor.  */
       gfc_add_modify (&tmpblock, gfc_desc_ptr,
@@ -4318,16 +4326,43 @@ convert_CFI_desc (gfc_wrapped_block * block, gfc_symbol *sym)
       /* 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);
+      /* The hidden string length is not passed to bind(C) procedures so set
+	 it from the descriptor element length.  */
+      if (sym->ts.type == BT_CHARACTER
+	  && sym->ts.u.cl->backend_decl
+	  && VAR_P (sym->ts.u.cl->backend_decl))
+	{
+	  tmp = build_fold_indirect_ref_loc (input_location, dummy_ptr);
+	  tmp = gfc_conv_descriptor_elem_len (tmp);
+	  gfc_add_modify (&tmpblock, sym->ts.u.cl->backend_decl,
+			  fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl),
+				        tmp));
+	}
+
+      /* Check that the argument is present before executing the above.  */
+      incoming = build3_v (COND_EXPR, present,
+			   gfc_finish_block (&tmpblock),
+			   build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&outer_block, incoming);
+      incoming = gfc_finish_block (&outer_block);
+
+
       /* Convert the gfc descriptor back to the CFI type before going
-	 out of scope.  */
+	 out of scope, if the CFI type was present at entry.  */
+      gfc_init_block (&outer_block);
+      gfc_init_block (&tmpblock);
+
       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);
+
+      outgoing = build3_v (COND_EXPR, present,
+			   gfc_finish_block (&tmpblock),
+			   build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&outer_block, outgoing);
+      outgoing = gfc_finish_block (&outer_block);
 
       /* Add the lot to the procedure init and finally blocks.  */
       gfc_add_init_cleanup (block, incoming, outgoing);
@@ -4923,9 +4958,9 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 
   for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
     {
-      if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
+      if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER
+	  && f->sym->ts.u.cl->backend_decl)
 	{
-	  gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
 	  if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
 	    gfc_trans_vla_type_sizes (f->sym, &tmpblock);
 	}
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 21535ac..3711c38 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5006,6 +5006,7 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
 
   if (e->rank != 0)
     {
+      parmse->force_no_tmp = 1;
       if (fsym->attr.contiguous
 	  && !gfc_is_simply_contiguous (e, false, true))
 	gfc_conv_subref_array_arg (parmse, e, false, fsym->attr.intent,
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 022ceb9..e7844c9 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -290,6 +290,16 @@ get_array_span (tree type, tree decl)
 {
   tree span;
 
+  /* Component references are guaranteed to have a reliable value for
+     'span'. Likewise indirect references since they emerge from the
+     conversion of a CFI descriptor or the hidden dummy descriptor.  */
+  if (TREE_CODE (decl) == COMPONENT_REF
+      && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
+    return gfc_conv_descriptor_span_get (decl);
+  else if (TREE_CODE (decl) == INDIRECT_REF
+	   && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
+    return gfc_conv_descriptor_span_get (decl);
+
   /* Return the span for deferred character length array references.  */
   if (type && TREE_CODE (type) == ARRAY_TYPE
       && TYPE_MAX_VALUE (TYPE_DOMAIN (type)) != NULL_TREE
@@ -352,9 +362,6 @@ 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;
 
@@ -399,12 +406,7 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr)
   if (vptr)
     span = gfc_vptr_size_get (vptr);
   else if (decl)
-    {
-      if (TREE_CODE (decl) == COMPONENT_REF)
-	span = gfc_conv_descriptor_span_get (decl);
-      else
-	span = get_array_span (type, decl);
-    }
+    span = get_array_span (type, decl);
 
   /* If a non-null span has been generated reference the element with
      pointer arithmetic.  */
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 9d9ac22..273c75a 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -91,6 +91,9 @@ typedef struct gfc_se
      args alias.  */
   unsigned force_tmp:1;
 
+  /* If set, will pass subref descriptors without a temporary.  */
+  unsigned force_no_tmp:1;
+
   /* Unconditionally calculate offset for array segments and constant
      arrays in gfc_conv_expr_descriptor.  */
   unsigned use_offset:1;