re PR fortran/89385 (Incorrect members of C descriptor for an allocatable object)

2019-02-23  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/89385
	PR fortran/89366
	* decl.c (gfc_verify_c_interop_param): Restriction on string
	length being one is lifted for F2018.
	* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): For scalar
	characters with intent in, make a temporary and copy the result
	of the expression evaluation into it.
	(gfc_conv_procedure_call): Set a flag for character formal args
	having a character length that is not unity. If the procedure
	is bind C, call gfc_conv_gfc_desc_to_cfi_desc in this case.
	Also, extend bind C calls to unconditionally convert both
	pointers and allocatable expressions.

2019-02-23  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/89385
	* gfortran.dg/ISO_Fortran_binding_1.f90 : Correct test for
	previously incorrect lbound for allocatable expressions. Also
	correct stop values to avoid repetition.
	* gfortran.dg/ISO_Fortran_binding_5.f90 : New test
	* gfortran.dg/ISO_Fortran_binding_5.c : Support previous test.

	PR fortran/89366
	* gfortran.dg/ISO_Fortran_binding_6.f90 : New test
	* gfortran.dg/ISO_Fortran_binding_6.c : Support previous test.
	* gfortran.dg/pr32599.f03 : Set standard to F2008.

2019-02-23  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/89385
	PR fortran/89366
	* runtime/ISO_Fortran_binding.c (cfi_desc_to_gfc_desc) : In the
	interchange between character and derived, the character type
	was being set incorrectly.
	(gfc_desc_to_cfi_desc) : Eliminate the interchange of types in
	this function. Do not add the kind and length information to
	the type field of structures. Lbounds were incorrectly being
	set to zero for allocatable and pointer descriptors. Should
	have been non-pointer, non-allocatables that received this
	treatment.

From-SVN: r269156

1 files changed, 40 insertions, 6 deletions

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 223fd14..cff3d7c 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5012,6 +5012,8 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
 				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);
 	}
 
@@ -5026,7 +5028,26 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
 
       /* 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);
+	{
+	  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);
     }
@@ -5188,11 +5209,18 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
        arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
     {
       bool finalized = false;
+      bool non_unity_length_string = false;
 
       e = arg->expr;
       fsym = formal ? formal->sym : NULL;
       parm_kind = MISSING;
 
+      if (fsym && fsym->ts.type == BT_CHARACTER && fsym->ts.u.cl
+	  && (!fsym->ts.u.cl->length
+	      || fsym->ts.u.cl->length->expr_type != EXPR_CONSTANT
+	      || mpz_cmp_si (fsym->ts.u.cl->length->value.integer, 1) != 0))
+	non_unity_length_string = true;
+
       /* If the procedure requires an explicit interface, the actual
 	 argument is passed according to the corresponding formal
 	 argument.  If the corresponding formal argument is a POINTER,
@@ -5418,9 +5446,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		}
 
 	      else if (sym->attr.is_bind_c && e
-		       && fsym && fsym->attr.dimension
-		       && (fsym->as->type == AS_ASSUMED_RANK
-			   || fsym->as->type == AS_ASSUMED_SHAPE))
+		       && ((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))
 		/* Implement F2018, C.12.6.1: paragraph (2).  */
 		gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
 
@@ -5865,8 +5896,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
 	      if (sym->attr.is_bind_c && e
 		  && fsym && fsym->attr.dimension
-		  && (fsym->as->type == AS_ASSUMED_RANK
-		      || fsym->as->type == AS_ASSUMED_SHAPE))
+		  && (fsym->attr.pointer
+		      || fsym->attr.allocatable
+		      || fsym->as->type == AS_ASSUMED_RANK
+		      || fsym->as->type == AS_ASSUMED_SHAPE
+		      || non_unity_length_string))
 		/* Implement F2018, C.12.6.1: paragraph (2).  */
 		gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);