Fortran: Fix Bind(C) Array-Descriptor Conversion

gfortran uses internally a different array descriptor ("gfc") as
Fortran 2018 alias TS291113 defines for C interoperability via
ISO_Fortran_binding.h ("CFI").  Hence, when calling a C function
from Fortran, it has to be converted in the callee - and if a
BIND(C) procedure is written in Fortran, the CFI argument has
to be converted to gfc in order work with the rest of the FE
code and the library calls.

Before this patch, part was handled in the FE generated code and
other parts in libgfortran.  With this patch, all code is generated
and CFI is defined as proper type - visible in the debugger and to
the middle end - avoiding both alias issues and missed optimization
issues.

This patch also fixes issues like: intent(out) deallocation in
the bind(C) callee, using the CFI descriptor also for allocatable
and pointer scalars and for len=* character strings.
For 'select rank', it also optimizes the code + avoid accessing
uninitialized memory if the dummy argument is allocatable/a pointer.
It additionally rejects passing a descriptorless type(*) to an
assumed-rank dummy argument. [F2018:C711]

	PR fortran/102086
	PR fortran/92189
	PR fortran/92621
	PR fortran/101308
	PR fortran/101309
	PR fortran/101635
	PR fortran/92482

gcc/fortran/ChangeLog:

	* decl.c (gfc_verify_c_interop_param): Remove 'sorry' for
	scalar allocatable/pointer and len=*.
	* expr.c (is_CFI_desc): Return true for for those.
	* gfortran.h (CFI_type_kind_shift, CFI_type_mask,
	CFI_type_from_type_kind, CFI_VERSION, CFI_MAX_RANK,
	CFI_attribute_pointer, CFI_attribute_allocatable,
	CFI_attribute_other, CFI_type_Integer, CFI_type_Logical,
	CFI_type_Real, CFI_type_Complex, CFI_type_Character,
	CFI_type_ucs4_char, CFI_type_struct, CFI_type_cptr,
	CFI_type_cfunptr, CFI_type_other): New #define.
	* trans-array.c (CFI_FIELD_BASE_ADDR, CFI_FIELD_ELEM_LEN,
	CFI_FIELD_VERSION, CFI_FIELD_RANK, CFI_FIELD_ATTRIBUTE,
	CFI_FIELD_TYPE, CFI_FIELD_DIM, CFI_DIM_FIELD_LOWER_BOUND,
	CFI_DIM_FIELD_EXTENT, CFI_DIM_FIELD_SM,
	gfc_get_cfi_descriptor_field, gfc_get_cfi_desc_base_addr,
	gfc_get_cfi_desc_elem_len, gfc_get_cfi_desc_version,
	gfc_get_cfi_desc_rank, gfc_get_cfi_desc_type,
	gfc_get_cfi_desc_attribute, gfc_get_cfi_dim_item,
	gfc_get_cfi_dim_lbound, gfc_get_cfi_dim_extent, gfc_get_cfi_dim_sm):
	New define/functions to access the CFI array descriptor.
	(gfc_conv_descriptor_type): New function for the GFC descriptor.
	(gfc_get_array_span): Handle expr of CFI descriptors and
	assumed-type descriptors.
	(gfc_trans_array_bounds): Remove 'static'.
	(gfc_conv_expr_descriptor): For assumed type, use the dtype of
	the actual argument.
	(structure_alloc_comps): Remove ' ' inside tabs.
	* trans-array.h (gfc_trans_array_bounds, gfc_conv_descriptor_type,
	gfc_get_cfi_desc_base_addr, gfc_get_cfi_desc_elem_len,
	gfc_get_cfi_desc_version, gfc_get_cfi_desc_rank,
	gfc_get_cfi_desc_type, gfc_get_cfi_desc_attribute,
	gfc_get_cfi_dim_lbound, gfc_get_cfi_dim_extent, gfc_get_cfi_dim_sm):
	New prototypes.
	* trans-decl.c (gfor_fndecl_cfi_to_gfc, gfor_fndecl_gfc_to_cfi):
	Remove global vars.
	(gfc_build_builtin_function_decls): Remove their initialization.
	(gfc_get_symbol_decl, create_function_arglist,
	gfc_trans_deferred_vars): Update for CFI.
	(convert_CFI_desc): Remove and replace by ...
	(gfc_conv_cfi_to_gfc): ... this function
	(gfc_generate_function_code): Call it; create local GFC var for CFI.
	* trans-expr.c (gfc_maybe_dereference_var): Handle CFI.
	(gfc_conv_subref_array_arg): Handle the if-noncontigous-only copy in
	when the result should be a descriptor.
	(gfc_conv_gfc_desc_to_cfi_desc): Completely rewritten.
	(gfc_conv_procedure_call): CFI fixes.
	* trans-openmp.c (gfc_omp_is_optional_argument,
	gfc_omp_check_optional_argument): Handle optional
	CFI.
	* trans-stmt.c (gfc_trans_select_rank_cases): Cleanup, avoid invalid
	code for allocatable/pointer dummies, which cannot be assumed size.
	* trans-types.c (gfc_cfi_descriptor_base): New global var.
	(gfc_get_dtype_rank_type): Skip rank init for rank < 0.
	(gfc_sym_type): Handle CFI dummies.
	(gfc_get_function_type): Update call.
	(gfc_get_cfi_dim_type, gfc_get_cfi_type): New.
	* trans-types.h (gfc_sym_type): Update prototype.
	(gfc_get_cfi_type): New prototype.
	* trans.c (gfc_trans_runtime_check): Make conditions more consistent
	to avoid '<logical> AND_THEN <long int>' in conditions.
	* trans.h (gfor_fndecl_cfi_to_gfc, gfor_fndecl_gfc_to_cfi): Remove
	global-var declaration.

libgfortran/ChangeLog:

	* ISO_Fortran_binding.h (CFI_type_cfunptr): Make unique type again.
	* runtime/ISO_Fortran_binding.c (cfi_desc_to_gfc_desc,
	gfc_desc_to_cfi_desc): Add comment that those are no longer called
	by new code.

libgomp/ChangeLog:

	* testsuite/libgomp.fortran/optional-bind-c.f90: New test.

gcc/testsuite/ChangeLog:

	* gfortran.dg/ISO_Fortran_binding_4.f90: Extend testcase.
	* gfortran.dg/PR100914.f90: Remove xfail.
	* gfortran.dg/PR100915.c: Expect CFI_type_cfunptr.
	* gfortran.dg/PR100915.f90: Handle CFI_type_cfunptr != CFI_type_cptr.
	* gfortran.dg/PR93963.f90: Extend select-rank tests.
	* gfortran.dg/bind-c-intent-out.f90: Change to dg-do run,
	update scan-dump.
	* gfortran.dg/bind_c_array_params_2.f90: Update/extend scan-dump.
	* gfortran.dg/bind_c_char_10.f90: Update scan-dump.
	* gfortran.dg/bind_c_char_8.f90: Remove dg-error "sorry".
	* gfortran.dg/c-interop/allocatable-dummy.f90: Remove xfail.
	* gfortran.dg/c-interop/c1255-1.f90: Likewise.
	* gfortran.dg/c-interop/c407c-1.f90: Update dg-error.
	* gfortran.dg/c-interop/cf-descriptor-5.f90: Remove xfail.
	* gfortran.dg/c-interop/cf-out-descriptor-3.f90: Likewise.
	* gfortran.dg/c-interop/cf-out-descriptor-4.f90: Likewise.
	* gfortran.dg/c-interop/cf-out-descriptor-5.f90: Likewise.
	* gfortran.dg/c-interop/contiguous-2.f90: Likewise.
	* gfortran.dg/c-interop/contiguous-3.f90: Likewise.
	* gfortran.dg/c-interop/deferred-character-1.f90: Likewise.
	* gfortran.dg/c-interop/deferred-character-2.f90: Likewise.
	* gfortran.dg/c-interop/fc-descriptor-3.f90: Likewise.
	* gfortran.dg/c-interop/fc-descriptor-5.f90: Likewise.
	* gfortran.dg/c-interop/fc-descriptor-6.f90: Likewise.
	* gfortran.dg/c-interop/fc-out-descriptor-3.f90: Likewise.
	* gfortran.dg/c-interop/fc-out-descriptor-4.f90: Likewise.
	* gfortran.dg/c-interop/fc-out-descriptor-5.f90: Likewise.
	* gfortran.dg/c-interop/fc-out-descriptor-6.f90: Likewise.
	* gfortran.dg/c-interop/ff-descriptor-5.f90: Likewise.
	* gfortran.dg/c-interop/ff-descriptor-6.f90: Likewise.
	* gfortran.dg/c-interop/fc-descriptor-7.f90: Remove xfail + extend.
	* gfortran.dg/c-interop/fc-descriptor-7-c.c: Update for changes.
	* gfortran.dg/c-interop/shape.f90: Add implicit none.
	* gfortran.dg/c-interop/typecodes-array-char-c.c: Add kind=4 char.
	* gfortran.dg/c-interop/typecodes-array-char.f90: Likewise.
	* gfortran.dg/c-interop/typecodes-array-float128.f90: Remove xfail.
	* gfortran.dg/c-interop/typecodes-scalar-basic.f90: Likewise.
	* gfortran.dg/c-interop/typecodes-scalar-float128.f90: Likewise.
	* gfortran.dg/c-interop/typecodes-scalar-int128.f90: Likewise.
	* gfortran.dg/c-interop/typecodes-scalar-longdouble.f90: Likewise.
	* gfortran.dg/iso_c_binding_char_1.f90: Remove dg-error "sorry".
	* gfortran.dg/pr93792.f90: Turn XFAIL into PASS.
	* gfortran.dg/ISO_Fortran_binding_19.f90: New test.
	* gfortran.dg/assumed_type_12.f90: New test.
	* gfortran.dg/assumed_type_13.c: New test.
	* gfortran.dg/assumed_type_13.f90: New test.
	* gfortran.dg/bind-c-char-descr.f90: New test.
	* gfortran.dg/bind-c-contiguous-1.c: New test.
	* gfortran.dg/bind-c-contiguous-1.f90: New test.
	* gfortran.dg/bind-c-contiguous-2.f90: New test.
	* gfortran.dg/bind-c-contiguous-3.c: New test.
	* gfortran.dg/bind-c-contiguous-3.f90: New test.
	* gfortran.dg/bind-c-contiguous-4.c: New test.
	* gfortran.dg/bind-c-contiguous-4.f90: New test.
	* gfortran.dg/bind-c-contiguous-5.c: New test.
	* gfortran.dg/bind-c-contiguous-5.f90: New test.

1 files changed, 472 insertions, 153 deletions

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index afca3a6..0138937 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2866,6 +2866,9 @@ tree
 gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p,
 			   bool is_classarray)
 {
+  if (is_CFI_desc (sym, NULL))
+    return build_fold_indirect_ref_loc (input_location, var);
+
   /* Characters are entirely different from other types, they are treated
      separately.  */
   if (sym->ts.type == BT_CHARACTER)
@@ -4922,7 +4925,7 @@ gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
 
       if (fsym && proc_name)
 	msg = xasprintf ("An array temporary was created for argument "
-			     "'%s' of procedure '%s'", fsym->name, proc_name);
+			 "'%s' of procedure '%s'", fsym->name, proc_name);
       else
 	msg = xasprintf ("An array temporary was created");
 
@@ -5220,6 +5223,8 @@ class_array_fcn:
       tree post_cond;
 
       type = TREE_TYPE (parmse->expr);
+      if (POINTER_TYPE_P (type) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
+	type = TREE_TYPE (type);
       pointer = gfc_create_var (type, "arg_ptr");
 
       if (check_contiguous)
@@ -5263,17 +5268,25 @@ class_array_fcn:
 	  gfc_add_block_to_block (&se->pre, &(&array_se)->pre);
 	  gfc_add_block_to_block (&se->pre, &(&array_se)->post);
 
-	  /* if_stmt = { pointer = &a[0]; } .  */
+	  /* if_stmt = { descriptor ? pointer = a : pointer = &a[0]; } .  */
 	  gfc_init_block (&if_block);
-	  tmp = gfc_conv_array_data (array_se.expr);
-	  tmp = fold_convert (type, tmp);
-	  gfc_add_modify (&if_block, pointer, tmp);
+	  if (GFC_DESCRIPTOR_TYPE_P (type))
+	    gfc_add_modify (&if_block, pointer, array_se.expr);
+	  else
+	    {
+	      tmp = gfc_conv_array_data (array_se.expr);
+	      tmp = fold_convert (type, tmp);
+	      gfc_add_modify (&if_block, pointer, tmp);
+	    }
 	  if_stmt = gfc_finish_block (&if_block);
 
 	  /* else_stmt = { parmse->pre(); pointer = parmse->expr; } .  */
 	  gfc_init_block (&else_block);
 	  gfc_add_block_to_block (&else_block, &parmse->pre);
-	  gfc_add_modify (&else_block, pointer, parmse->expr);
+	  tmp = (GFC_DESCRIPTOR_TYPE_P (type)
+		 ? build_fold_indirect_ref_loc (input_location, parmse->expr)
+		 : parmse->expr);
+	  gfc_add_modify (&else_block, pointer, tmp);
 	  else_stmt = gfc_finish_block (&else_block);
 
 	  /* And put the above into an if statement.  */
@@ -5300,7 +5313,11 @@ class_array_fcn:
 
 	  /* else_stmt = { pointer = NULL; } .  */
 	  gfc_init_block (&else_block);
-	  gfc_add_modify (&else_block, pointer, build_int_cst (type, 0));
+	  if (GFC_DESCRIPTOR_TYPE_P (type))
+	    gfc_conv_descriptor_data_set (&else_block, pointer,
+					  null_pointer_node);
+	  else
+	    gfc_add_modify (&else_block, pointer, build_int_cst (type, 0));
 	  else_stmt = gfc_finish_block (&else_block);
 
 	  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
@@ -5344,6 +5361,24 @@ class_array_fcn:
       tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, post_cond,
 			     post_stmts, build_empty_stmt (input_location));
       gfc_add_expr_to_block (&se->post, tmp);
+      if (GFC_DESCRIPTOR_TYPE_P (type))
+	{
+	  type = TREE_TYPE (parmse->expr);
+	  if (POINTER_TYPE_P (type))
+	    {
+	      pointer = gfc_build_addr_expr (type, pointer);
+	      if (pass_optional)
+		{
+		  tmp = gfc_likely (present_var, PRED_FORTRAN_ABSENT_DUMMY);
+		  pointer = fold_build3_loc (input_location, COND_EXPR, type,
+					     tmp, pointer,
+					     fold_convert (type,
+							   null_pointer_node));
+		}
+	    }
+	  else
+	    gcc_assert (!pass_optional);
+	}
       se->expr = pointer;
     }
 
@@ -5484,168 +5519,457 @@ set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
 static void
 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 type;
-  tree cond;
-  tree desc_attr;
-  int attribute;
-  int cfi_attribute;
-  symbol_attribute attr = gfc_expr_attr (e);
+  stmtblock_t block, block2;
+  tree cfi, gfc, tmp, tmp2;
+  tree present = NULL;
+  tree gfc_strlen = NULL;
+  tree rank;
+  gfc_se se;
+
+  if (fsym->attr.optional
+      && e->expr_type == EXPR_VARIABLE
+      && e->symtree->n.sym->attr.optional)
+    present = gfc_conv_expr_present (e->symtree->n.sym);
+
+  gfc_init_block (&block);
 
-  /* If this is a full array or a scalar, the allocatable and pointer
-     attributes can be passed. Otherwise it is 'CFI_attribute_other'*/
-  attribute = 2;
-  if (!e->rank || gfc_get_full_arrayspec_from_expr (e))
+  /* Convert original argument to a tree. */
+  gfc_init_se (&se, NULL);
+  if (e->rank == 0)
     {
-      if (attr.pointer)
-	attribute = 0;
-      else if (attr.allocatable)
-	attribute = 1;
+      se.want_pointer = 1;
+      gfc_conv_expr (&se, e);
+      gfc = se.expr;
+      /* gfc_conv_constant ignores se.want_poiner, e.g. for string_cst.  */
+      if (!POINTER_TYPE_P (TREE_TYPE (gfc)))
+	gfc = gfc_build_addr_expr (NULL, gfc);
+    }
+  else
+    {
+      /* If the actual argument can be noncontiguous, copy-in/out is required,
+	 if the dummy has either the CONTIGUOUS attribute or is an assumed-
+	 length assumed-length/assumed-size CHARACTER array.  */
+      se.force_no_tmp = 1;
+      if ((fsym->attr.contiguous
+	   || (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length
+	       && (fsym->as->type == AS_ASSUMED_SIZE
+		   || fsym->as->type == AS_EXPLICIT)))
+	  && !gfc_is_simply_contiguous (e, false, true))
+	{
+	  bool optional = fsym->attr.optional;
+	  fsym->attr.optional = 0;
+	  gfc_conv_subref_array_arg (&se, e, false, fsym->attr.intent,
+				     fsym->attr.pointer, fsym,
+				     fsym->ns->proc_name->name, NULL,
+				     /* check_contiguous= */ true);
+	  fsym->attr.optional = optional;
+	}
+      else
+	gfc_conv_expr_descriptor (&se, e);
+      gfc = se.expr;
+      /* For dt(:)%var the elem_len*stride != sm, hence, GFC uses
+	 elem_len = sizeof(dt) and base_addr = dt(lb) instead.
+	 gfc_get_dataptr_offset fixes the base_addr; for elem_len, see below.
+	 While sm is fine as it uses span*stride and not elem_len.  */
+      if (POINTER_TYPE_P (TREE_TYPE (gfc)))
+	gfc = build_fold_indirect_ref_loc (input_location, gfc);
+      else if (is_subref_array (e) && e->ts.type != BT_CHARACTER)
+	 gfc_get_dataptr_offset (&se.pre, gfc, gfc, NULL, true, e);
+    }
+  if (e->ts.type == BT_CHARACTER)
+    {
+      if (se.string_length)
+	gfc_strlen = se.string_length;
+      else if (e->ts.u.cl->backend_decl)
+	gfc_strlen = e->ts.u.cl->backend_decl;
+      else
+	gcc_unreachable ();
     }
+  gfc_add_block_to_block (&block, &se.pre);
+
+  /* Create array decriptor and set version, rank, attribute, type. */
+  cfi = gfc_create_var (gfc_get_cfi_type (e->rank < 0
+					  ? GFC_MAX_DIMENSIONS : e->rank,
+					  false), "cfi");
+  /* Convert to CFI_cdesc_t, which has dim[] to avoid TBAA issues,*/
+  if (fsym->attr.dimension && fsym->as->type == AS_ASSUMED_RANK)
+    {
+      tmp = gfc_get_cfi_type (-1, !fsym->attr.pointer && !fsym->attr.target);
+      tmp = build_pointer_type (tmp);
+      parmse->expr = cfi = gfc_build_addr_expr (tmp, cfi);
+      cfi = build_fold_indirect_ref_loc (input_location, cfi);
+    }
+  else
+    parmse->expr = gfc_build_addr_expr (NULL, cfi);
+
+  tmp = gfc_get_cfi_desc_version (cfi);
+  gfc_add_modify (&block, tmp,
+		  build_int_cst (TREE_TYPE (tmp), CFI_VERSION));
+  if (e->rank < 0)
+    rank = fold_convert (signed_char_type_node, gfc_conv_descriptor_rank (gfc));
+  else
+    rank = build_int_cst (signed_char_type_node, e->rank);
+  tmp = gfc_get_cfi_desc_rank (cfi);
+  gfc_add_modify (&block, tmp, rank);
+  int itype = CFI_type_other;
+  if (e->ts.f90_type == BT_VOID)
+    itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
+	     ? CFI_type_cfunptr : CFI_type_cptr);
+  else
+    switch (e->ts.type)
+      {
+	case BT_INTEGER:
+	case BT_LOGICAL:
+	case BT_REAL:
+	case BT_COMPLEX:
+	  itype = CFI_type_from_type_kind (e->ts.type, e->ts.kind);
+	  break;
+	case BT_CHARACTER:
+	  itype = CFI_type_from_type_kind (CFI_type_Character, e->ts.kind);
+	  break;
+	case BT_DERIVED:
+	  itype = CFI_type_struct;
+	  break;
+	case BT_VOID:
+	  itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
+		   ? CFI_type_cfunptr : CFI_type_cptr);
+	  break;
+	case BT_ASSUMED:
+	  itype = CFI_type_other;  // FIXME: Or CFI_type_cptr ?
+	  break;
+	case BT_CLASS:
+	case BT_PROCEDURE:
+	case BT_HOLLERITH:
+	case BT_UNION:
+	case BT_BOZ:
+	case BT_UNKNOWN:
+	  // FIXME: Really unreachable? Or reachable for type(*) ? If so, CFI_type_other?
+	  gcc_unreachable ();
+      }
+
+  tmp = gfc_get_cfi_desc_type (cfi);
+  gfc_add_modify (&block, tmp,
+		  build_int_cst (TREE_TYPE (tmp), itype));
 
+  int attr = CFI_attribute_other;
   if (fsym->attr.pointer)
-    cfi_attribute = 0;
+    attr = CFI_attribute_pointer;
   else if (fsym->attr.allocatable)
-    cfi_attribute = 1;
-  else
-    cfi_attribute = 2;
+    attr = CFI_attribute_allocatable;
+  tmp = gfc_get_cfi_desc_attribute (cfi);
+  gfc_add_modify (&block, tmp,
+		  build_int_cst (TREE_TYPE (tmp), attr));
 
-  if (e->rank != 0)
+  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,
-				   fsym->attr.pointer);
-      else
-	gfc_conv_expr_descriptor (parmse, e);
-
-      if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
-	parmse->expr = build_fold_indirect_ref_loc (input_location,
-						    parmse->expr);
-      bool is_artificial = (INDIRECT_REF_P (parmse->expr)
-			    ? DECL_ARTIFICIAL (TREE_OPERAND (parmse->expr, 0))
-			    : DECL_ARTIFICIAL (parmse->expr));
-
-      /* Unallocated allocatable arrays and unassociated pointer arrays
-	 need their dtype setting if they are argument associated with
-	 assumed rank dummies.  */
-      if (fsym && fsym->as
-	  && (gfc_expr_attr (e).pointer
-	      || gfc_expr_attr (e).allocatable))
-	set_dtype_for_unallocated (parmse, e);
-
-      /* 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.  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 && is_artificial
-	  && type != gfc_get_element_type (TREE_TYPE (parmse->expr)))
-	{
-	  /* Obtain the offset to the data.  */
-	  gfc_get_dataptr_offset (&parmse->pre, parmse->expr, parmse->expr,
-				  gfc_index_zero_node, true, e);
-
-	  /* Update the dtype.  */
-	  gfc_add_modify (&parmse->pre,
-			  gfc_conv_descriptor_dtype (parmse->expr),
-			  gfc_get_dtype_rank_type (e->rank, type));
-	}
-      else if (type == NULL_TREE
-	       || (!is_subref_array (e) && !is_artificial))
-	{
-	  /* Make sure that the span is set for expressions where it
-	     might not have been done already.  */
-	  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);
-	}
+      tmp = gfc_get_cfi_desc_base_addr (cfi);
+      gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), gfc));
     }
   else
     {
-      gfc_conv_expr (parmse, e);
-
-      if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
-	parmse->expr = build_fold_indirect_ref_loc (input_location,
-						    parmse->expr);
+      tmp = gfc_get_cfi_desc_base_addr (cfi);
+      tmp2 = gfc_conv_descriptor_data_get (gfc);
+      gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
+    }
 
-      parmse->expr = gfc_conv_scalar_to_descriptor (parmse,
-						    parmse->expr, attr);
+  /* Set elem_len if known - must be before the next if block.
+     Note that allocatable implies 'len=:'.  */
+  if (e->ts.type != BT_ASSUMED && e->ts.type != BT_CHARACTER )
+    {
+      /* Length is known at compile time; use use 'block' for it.  */
+      tmp = size_in_bytes (gfc_typenode_for_spec (&e->ts));
+      tmp2 = gfc_get_cfi_desc_elem_len (cfi);
+      gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
     }
 
-  /* Set the CFI attribute field through a temporary value for the
-     gfc attribute.  */
-  desc_attr = gfc_conv_descriptor_attribute (parmse->expr);
-  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
-			 void_type_node, desc_attr,
-			 build_int_cst (TREE_TYPE (desc_attr), cfi_attribute));
-  gfc_add_expr_to_block (&parmse->pre, tmp);
+  /* When allocatable + intent out, free the cfi descriptor.  */
+  if (fsym->attr.allocatable && fsym->attr.intent == INTENT_OUT)
+    {
+      tmp = gfc_get_cfi_desc_base_addr (cfi);
+      tree call = builtin_decl_explicit (BUILT_IN_FREE);
+      call = build_call_expr_loc (input_location, call, 1, tmp);
+      gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
+      gfc_add_modify (&block, tmp,
+		      fold_convert (TREE_TYPE (tmp), null_pointer_node));
+      goto done;
+    }
 
-  /* Now pass the gfc_descriptor by reference.  */
-  parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
+  /* If not unallocated/unassociated. */
+  gfc_init_block (&block2);
 
-  /* Variables to point to the gfc and CFI descriptors; cfi = NULL implies
-     that the CFI descriptor is allocated by the gfor_fndecl_gfc_to_cfi call.  */
-  gfc_desc_ptr = parmse->expr;
-  cfi_desc_ptr = gfc_create_var (pvoid_type_node, "cfi");
-  gfc_add_modify (&parmse->pre, cfi_desc_ptr, null_pointer_node);
+  /* Set elem_len, which may be only known at run time. */
+  if (e->ts.type == BT_CHARACTER)
+    {
+      gcc_assert (gfc_strlen);
+      tmp = gfc_strlen;
+      if (e->ts.kind != 1)
+	tmp = fold_build2_loc (input_location, MULT_EXPR,
+			       gfc_charlen_type_node, tmp,
+			       build_int_cst (gfc_charlen_type_node,
+					      e->ts.kind));
+      tmp2 = gfc_get_cfi_desc_elem_len (cfi);
+      gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
+    }
+  else if (e->ts.type == BT_ASSUMED)
+    {
+      tmp = gfc_conv_descriptor_elem_len (gfc);
+      tmp2 = gfc_get_cfi_desc_elem_len (cfi);
+      gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
+    }
 
-  /* Allocate the CFI descriptor itself and fill the fields.  */
-  tmp = gfc_build_addr_expr (NULL_TREE, cfi_desc_ptr);
-  tmp = build_call_expr_loc (input_location,
-			     gfor_fndecl_gfc_to_cfi, 2, tmp, gfc_desc_ptr);
-  gfc_add_expr_to_block (&parmse->pre, tmp);
+  if (e->ts.type == BT_ASSUMED)
+    {
+      /* Note: type(*) implies assumed-shape/assumed-rank if fsym requires
+	 an CFI descriptor.  Use the type in the descritor as it provide
+	 mode information. (Quality of implementation feature.)  */
+      tree cond;
+      tree ctype = gfc_get_cfi_desc_type (cfi);
+      tree type = fold_convert (TREE_TYPE (ctype),
+				gfc_conv_descriptor_type (gfc));
+      tree kind = fold_convert (TREE_TYPE (ctype),
+				gfc_conv_descriptor_elem_len (gfc));
+      kind = fold_build2_loc (input_location, LSHIFT_EXPR, TREE_TYPE (type),
+			      kind, build_int_cst (TREE_TYPE (type),
+						   CFI_type_kind_shift));
+
+      /* if (BT_VOID) CFI_type_cptr else CFI_type_other  */
+      /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+			      build_int_cst (TREE_TYPE (type), BT_VOID));
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
+			     build_int_cst (TREE_TYPE (type), CFI_type_cptr));
+      tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+			      ctype,
+			      build_int_cst (TREE_TYPE (type), CFI_type_other));
+      tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+			      tmp, tmp2);
+      /* if (BT_DERIVED) CFI_type_struct else  < tmp2 >  */
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+			      build_int_cst (TREE_TYPE (type), BT_DERIVED));
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
+			     build_int_cst (TREE_TYPE (type), CFI_type_struct));
+      tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+			      tmp, tmp2);
+      /* if (BT_CHARACTER) CFI_type_Character + kind=1 else  < tmp2 >  */
+      /* Note: could also be kind=4, with cfi->elem_len = gfc->elem_len*4.  */
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+			      build_int_cst (TREE_TYPE (type), BT_CHARACTER));
+      tmp = build_int_cst (TREE_TYPE (type),
+			   CFI_type_from_type_kind (CFI_type_Character, 1));
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+			     ctype, tmp);
+      tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+			      tmp, tmp2);
+      /* if (BT_COMPLEX) CFI_type_Complex + kind/2 else  < tmp2 >  */
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+			      build_int_cst (TREE_TYPE (type), BT_COMPLEX));
+      tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (type),
+			     kind, build_int_cst (TREE_TYPE (type), 2));
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type), tmp,
+			     build_int_cst (TREE_TYPE (type),
+					    CFI_type_Complex));
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+			     ctype, tmp);
+      tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+			      tmp, tmp2);
+      /* if (BT_INTEGER || BT_LOGICAL || BT_REAL) type + kind else  <tmp2>  */
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+			      build_int_cst (TREE_TYPE (type), BT_INTEGER));
+      tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+			      build_int_cst (TREE_TYPE (type), BT_LOGICAL));
+      cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
+			      cond, tmp);
+      tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+			      build_int_cst (TREE_TYPE (type), BT_REAL));
+      cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
+			      cond, tmp);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type),
+			     type, kind);
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+			     ctype, tmp);
+      tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+			      tmp, tmp2);
+      gfc_add_expr_to_block (&block2, tmp2);
+    }
 
-  /* Now set the gfc descriptor attribute.  */
-  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
-			 void_type_node, desc_attr,
-			 build_int_cst (TREE_TYPE (desc_attr), attribute));
-  gfc_add_expr_to_block (&parmse->pre, tmp);
+  if (e->rank != 0)
+    {
+      /* Loop: for (i = 0; i < rank; ++i).  */
+      tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
+      /* Loop body.  */
+      stmtblock_t loop_body;
+      gfc_init_block (&loop_body);
+      /* cfi->dim[i].lower_bound = (allocatable/pointer)
+				   ? gfc->dim[i].lbound : 0 */
+      if (fsym->attr.pointer || fsym->attr.allocatable)
+	tmp = gfc_conv_descriptor_lbound_get (gfc, idx);
+      else
+	tmp = gfc_index_zero_node;
+      gfc_add_modify (&loop_body, gfc_get_cfi_dim_lbound (cfi, idx), tmp);
+      /* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1.  */
+      tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			     gfc_conv_descriptor_ubound_get (gfc, idx),
+			     gfc_conv_descriptor_lbound_get (gfc, idx));
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			     tmp, gfc_index_one_node);
+      gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp);
+      /* d->dim[n].sm = gfc->dim[i].stride  * gfc->span); */
+      tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			     gfc_conv_descriptor_stride_get (gfc, idx),
+			     gfc_conv_descriptor_span_get (gfc));
+      gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
 
-  /* The CFI descriptor is passed to the bind_C procedure.  */
-  parmse->expr = cfi_desc_ptr;
+      /* Generate loop.  */
+      gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
+			   rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
+			   gfc_finish_block (&loop_body));
 
-  /* Free the CFI descriptor.  */
-  tmp = gfc_call_free (cfi_desc_ptr);
-  gfc_prepend_expr_to_block (&parmse->post, tmp);
+      if (e->expr_type == EXPR_VARIABLE
+	  && e->ref
+	  && e->ref->u.ar.type == AR_FULL
+	  && e->symtree->n.sym->attr.dummy
+	  && e->symtree->n.sym->as
+	  && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
+	{
+	  tmp = gfc_get_cfi_dim_extent (cfi, gfc_rank_cst[e->rank-1]),
+	  gfc_add_modify (&block2, tmp, build_int_cst (TREE_TYPE (tmp), -1));
+	}
+    }
 
-  /* Transfer values back to gfc descriptor.  */
-  if (cfi_attribute != 2  /* CFI_attribute_other.  */
-      && !fsym->attr.value
-      && fsym->attr.intent != INTENT_IN)
+  if (fsym->attr.allocatable || fsym->attr.pointer)
     {
-      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);
-      gfc_prepend_expr_to_block (&parmse->post, tmp);
+      tmp = gfc_get_cfi_desc_base_addr (cfi),
+      tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			     tmp, null_pointer_node);
+      tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
+		      build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&block, tmp);
     }
+  else
+    gfc_add_block_to_block (&block, &block2);
 
-  /* Deal with an optional dummy being passed to an optional formal arg
-     by finishing the pre and post blocks and making their execution
-     conditional on the dummy being present.  */
-  if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
-      && e->symtree->n.sym->attr.optional)
+
+done:
+  if (present)
     {
-      cond = gfc_conv_expr_present (e->symtree->n.sym);
-      tmp = fold_build2 (MODIFY_EXPR, void_type_node,
-			 cfi_desc_ptr,
-			 build_int_cst (pvoid_type_node, 0));
-      tmp = build3_v (COND_EXPR, cond,
-		      gfc_finish_block (&parmse->pre), tmp);
+      parmse->expr = build3_loc (input_location, COND_EXPR,
+				 TREE_TYPE (parmse->expr),
+				 present, parmse->expr, null_pointer_node);
+      tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
+		      build_empty_stmt (input_location));
       gfc_add_expr_to_block (&parmse->pre, tmp);
-      tmp = build3_v (COND_EXPR, cond,
-		      gfc_finish_block (&parmse->post),
+    }
+  else
+    gfc_add_block_to_block (&parmse->pre, &block);
+
+  gfc_init_block (&block);
+
+  if ((!fsym->attr.allocatable && !fsym->attr.pointer)
+      || fsym->attr.intent == INTENT_IN)
+    goto post_call;
+
+  gfc_init_block (&block2);
+  if (e->rank == 0)
+    {
+      tmp = gfc_get_cfi_desc_base_addr (cfi);
+      gfc_add_modify (&block, gfc, fold_convert (TREE_TYPE (gfc), tmp));
+    }
+  else
+    {
+      tmp = gfc_get_cfi_desc_base_addr (cfi);
+      gfc_conv_descriptor_data_set (&block, gfc, tmp);
+
+      if (fsym->attr.allocatable)
+	{
+	  /* gfc->span = cfi->elem_len.  */
+	  tmp = fold_convert (gfc_array_index_type,
+			      gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
+	}
+      else
+	{
+	  /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
+			  ? cfi->dim[0].sm : cfi->elem_len).  */
+	  tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
+	  tmp2 = fold_convert (gfc_array_index_type,
+			       gfc_get_cfi_desc_elem_len (cfi));
+	  tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
+				 gfc_array_index_type, tmp, tmp2);
+	  tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			     tmp, gfc_index_zero_node);
+	  tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
+			    gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]), tmp2);
+	}
+      gfc_conv_descriptor_span_set (&block2, gfc, tmp);
+
+      /* Calculate offset + set lbound, ubound and stride.  */
+      gfc_conv_descriptor_offset_set (&block2, gfc, gfc_index_zero_node);
+      /* Loop: for (i = 0; i < rank; ++i).  */
+      tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
+      /* Loop body.  */
+      stmtblock_t loop_body;
+      gfc_init_block (&loop_body);
+      /* gfc->dim[i].lbound = ... */
+      tmp = gfc_get_cfi_dim_lbound (cfi, idx);
+      gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp);
+
+      /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
+      tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			     gfc_conv_descriptor_lbound_get (gfc, idx),
+			     gfc_index_one_node);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			     gfc_get_cfi_dim_extent (cfi, idx), tmp);
+      gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp);
+
+      /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
+      tmp = gfc_get_cfi_dim_sm (cfi, idx);
+      tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+			     gfc_array_index_type, tmp,
+			     fold_convert (gfc_array_index_type,
+					   gfc_get_cfi_desc_elem_len (cfi)));
+      gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp);
+
+      /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
+      tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			     gfc_conv_descriptor_stride_get (gfc, idx),
+			     gfc_conv_descriptor_lbound_get (gfc, idx));
+      tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			     gfc_conv_descriptor_offset_get (gfc), tmp);
+      gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp);
+      /* Generate loop.  */
+      gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
+			   rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
+			   gfc_finish_block (&loop_body));
+    }
+
+  if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
+    {
+      tmp = fold_convert (gfc_charlen_type_node,
+			  gfc_get_cfi_desc_elem_len (cfi));
+      if (e->ts.kind != 1)
+	tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+			       gfc_charlen_type_node, tmp,
+			       build_int_cst (gfc_charlen_type_node,
+					      e->ts.kind));
+      gfc_add_modify (&block2, gfc_strlen, tmp);
+    }
+
+  tmp = gfc_get_cfi_desc_base_addr (cfi),
+  tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			 tmp, null_pointer_node);
+  tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
+		  build_empty_stmt (input_location));
+  gfc_add_expr_to_block (&block, tmp);
+
+post_call:
+  gfc_add_block_to_block (&block, &se.post);
+  if (present && block.head)
+    {
+      tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
 		      build_empty_stmt (input_location));
       gfc_add_expr_to_block (&parmse->post, tmp);
     }
+  else if (block.head)
+    gfc_add_block_to_block (&parmse->post, &block);
 }
 
 
@@ -5764,17 +6088,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
        arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
     {
       bool finalized = false;
-      bool assumed_length_string = false;
       tree derived_array = NULL_TREE;
 
       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))
-	assumed_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,
@@ -6005,9 +6324,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		    parmse.expr = convert (type, tmp);
 		}
 
-	      else if (sym->attr.is_bind_c && e
-		       && (is_CFI_desc (fsym, NULL)
-			   || assumed_length_string))
+	      else if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
 		/* Implement F2018, 18.3.6, list item (5), bullet point 2.  */
 		gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
 
@@ -6217,7 +6534,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		  if (fsym && fsym->attr.intent == INTENT_OUT
 		      && (fsym->attr.allocatable
 			  || (fsym->ts.type == BT_CLASS
-			      && CLASS_DATA (fsym)->attr.allocatable)))
+			      && CLASS_DATA (fsym)->attr.allocatable))
+		      && !is_CFI_desc (fsym, NULL))
 		    {
 		      stmtblock_t block;
 		      tree ptr;
@@ -6474,8 +6792,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		    ref->u.ar.type = AR_SECTION;
 		}
 
-	      if (sym->attr.is_bind_c && e
-		  && (is_CFI_desc (fsym, NULL) || assumed_length_string))
+	      if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
 		/* Implement F2018, 18.3.6, list item (5), bullet point 2.  */
 		gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
 
@@ -6535,9 +6852,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 					  sym->name, NULL);
 
 	      /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
-		 allocated on entry, it must be deallocated.  */
+		 allocated on entry, it must be deallocated.
+		 CFI descriptors are handled elsewhere.  */
 	      if (fsym && fsym->attr.allocatable
-		  && fsym->attr.intent == INTENT_OUT)
+		  && fsym->attr.intent == INTENT_OUT
+		  && !is_CFI_desc (fsym, NULL))
 		{
 		  if (fsym->ts.type == BT_DERIVED
 		      && fsym->ts.u.derived->attr.alloc_comp)