gfortran.texi: Add description in sections on TS 29113 and further interoperability with C.

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

	* gfortran.texi : Add description in sections on TS 29113 and
	further interoperability with C.
	* trans-array.c (gfc_conv_descriptor_attribute): New function.
	(gfc_get_dataptr_offset): Remove static function attribute.
	* trans-array.h : Add prototypes for above functions.
	* trans-decl.c : Add declarations for the library functions
	cfi_desc_to_gfc_desc and gfc_desc_to_cfi_desc.
	* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): New function.
	(gfc_conv_procedure_call): Call it for scalar and array actual
	arguments, when the formal arguments are bind_c with assumed
	shape or assumed rank.
	* trans.h : External declarations for gfor_fndecl_cfi_to_gfc
	and gfor_fndecl_gfc_to_cfi.

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

	* gfortran.dg/ISO_Fortran_binding_1.f90 : New test.
	* gfortran.dg/ISO_Fortran_binding_1.c : Auxilliary file for test.
	* gfortran.dg/ISO_Fortran_binding_2.f90 : New test.
	* gfortran.dg/ISO_Fortran_binding_2.c : Auxilliary file for test.
	* gfortran.dg/bind_c_array_params_2.f90 : Change search string
	for dump tree scan.

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

	* ISO_Fortran_binding.h : New file.
	* Makefile.am : Include ISO_Fortran_binding.c in the list of
	files to compile.
	* Makefile.in : Regenerated.
	* gfortran.map : Add _gfortran_cfi_desc_to_gfc_desc,
	_gfortran_gfc_desc_to_cfi_desc and the CFI API functions.
	* runtime/ISO_Fortran_binding.c : New file containing the new
	functions added to the map.

From-SVN: r267881

gcc/fortran/ChangeLog

+2019-01-12  Paul Thomas  <pault@gcc.gnu.org>
+
+	* gfortran.texi : Add description in sections on TS 29113 and
+	further interoperability with C.
+	* trans-array.c (gfc_conv_descriptor_attribute): New function.
+	(gfc_get_dataptr_offset): Remove static function attribute.
+	* trans-array.h : Add prototypes for above functions.
+	* trans-decl.c : Add declarations for the library functions
+	cfi_desc_to_gfc_desc and gfc_desc_to_cfi_desc.
+	* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): New function.
+	(gfc_conv_procedure_call): Call it for scalar and array actual
+	arguments, when the formal arguments are bind_c with assumed
+	shape or assumed rank.
+	* trans.h : External declarations for gfor_fndecl_cfi_to_gfc
+	and gfor_fndecl_gfc_to_cfi.
+
 2019-01-11  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	PR fortran/35031

gcc/fortran/trans-array.c

@@ -293,6 +293,22 @@ gfc_conv_descriptor_rank (tree desc)
 
 
 tree
+gfc_conv_descriptor_attribute (tree desc)
+{
+  tree tmp;
+  tree dtype;
+
+  dtype = gfc_conv_descriptor_dtype (desc);
+  tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)),
+			   GFC_DTYPE_ATTRIBUTE);
+  gcc_assert (tmp!= NULL_TREE
+	      && TREE_TYPE (tmp) == short_integer_type_node);
+  return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
+			  dtype, tmp, NULL_TREE);
+}
+
+
+tree
 gfc_get_descriptor_dimension (tree desc)
 {
   tree type, field;
@@ -6767,7 +6783,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
 
 
 /* Calculate the overall offset, including subreferences.  */
-static void
+void
 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
 			bool subref, gfc_expr *expr)
 {

gcc/fortran/trans-array.h

@@ -136,6 +136,8 @@ void gfc_conv_tmp_array_ref (gfc_se * se);
 /* Translate a reference to an array temporary.  */
 void gfc_conv_tmp_ref (gfc_se *);
 
+/* Calculate the overall offset, including subreferences.  */
+void gfc_get_dataptr_offset (stmtblock_t*, tree, tree, tree, bool, gfc_expr*);
 /* Obtain the span of an array.  */
 tree gfc_get_array_span (tree, gfc_expr *);
 /* Evaluate an array expression.  */
@@ -167,6 +169,7 @@ tree gfc_conv_descriptor_offset_get (tree);
 tree gfc_conv_descriptor_span_get (tree);
 tree gfc_conv_descriptor_dtype (tree);
 tree gfc_conv_descriptor_rank (tree);
+tree gfc_conv_descriptor_attribute (tree);
 tree gfc_get_descriptor_dimension (tree);
 tree gfc_conv_descriptor_stride_get (tree, tree);
 tree gfc_conv_descriptor_lbound_get (tree, tree);

gcc/fortran/trans-decl.c

@@ -114,6 +114,8 @@ tree gfor_fndecl_fdate;
 tree gfor_fndecl_ttynam;
 tree gfor_fndecl_in_pack;
 tree gfor_fndecl_in_unpack;
+tree gfor_fndecl_cfi_to_gfc;
+tree gfor_fndecl_gfc_to_cfi;
 tree gfor_fndecl_associated;
 tree gfor_fndecl_system_clock4;
 tree gfor_fndecl_system_clock8;
@@ -3619,6 +3621,14 @@ gfc_build_builtin_function_decls (void)
 	get_identifier (PREFIX("internal_unpack")), ".wR",
 	void_type_node, 2, pvoid_type_node, pvoid_type_node);
 
+  gfor_fndecl_cfi_to_gfc = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("cfi_desc_to_gfc_desc")), ".ww",
+	void_type_node, 2, pvoid_type_node, ppvoid_type_node);
+
+  gfor_fndecl_gfc_to_cfi = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("gfc_desc_to_cfi_desc")), ".wR",
+	void_type_node, 2, ppvoid_type_node, pvoid_type_node);
+
   gfor_fndecl_associated = gfc_build_library_function_decl_with_spec (
 	get_identifier (PREFIX("associated")), ".RR",
 	integer_type_node, 2, ppvoid_type_node, ppvoid_type_node);

gcc/fortran/trans-expr.c

@@ -4891,6 +4891,102 @@ expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
 }
 
 
+/* Provide an interface between gfortran array descriptors and the F2018:18.4
+   ISO_Fortran_binding array descriptors. */
+
+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;
+  int attribute;
+  symbol_attribute attr = gfc_expr_attr (e);
+
+  /* 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))
+    {
+      if (attr.pointer)
+	attribute = 0;
+      else if (attr.allocatable)
+	attribute = 1;
+    }
+
+  if (e->rank)
+    {
+      gfc_conv_expr_descriptor (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.  */
+      type = gfc_typenode_for_spec (&e->ts);
+      if (DECL_ARTIFICIAL (parmse->expr)
+	  && 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 (!is_subref_array (e) && !DECL_ARTIFICIAL (parmse->expr))
+	{
+	  /* Make sure that the span is set for expressions where it
+	     might not have been done already.  */
+	  tmp = TREE_TYPE (parmse->expr);
+	  tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
+	  tmp = fold_convert (gfc_array_index_type, tmp);
+	  gfc_conv_descriptor_span_set (&parmse->pre, parmse->expr, tmp);
+	}
+    }
+  else
+    {
+      gfc_conv_expr (parmse, e);
+      /* Copy the scalar for INTENT_IN.  */
+      if (e->expr_type == EXPR_VARIABLE && fsym->attr.intent == INTENT_IN)
+	parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
+      parmse->expr = gfc_conv_scalar_to_descriptor (parmse,
+						    parmse->expr, attr);
+    }
+
+  /* Set the CFI attribute field.  */
+  tmp = gfc_conv_descriptor_attribute (parmse->expr);
+  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+			 void_type_node, tmp,
+			 build_int_cst (TREE_TYPE (tmp), attribute));
+  gfc_add_expr_to_block (&parmse->pre, tmp);
+
+  /* Now pass the gfc_descriptor by reference.  */
+  parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
+
+  /* Variables to point to the gfc and CFI descriptors.  */
+  gfc_desc_ptr = parmse->expr;
+  cfi_desc_ptr = gfc_create_var (pvoid_type_node, "cfi");
+
+  /* Allocate the CFI descriptor 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);
+
+  /* The CFI descriptor is passed to the bind_C procedure.  */
+  parmse->expr = cfi_desc_ptr;
+
+  /* Transfer values back to gfc descriptor and free the CFI descriptor.  */
+  tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr);
+  tmp = build_call_expr_loc (input_location,
+			     gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp);
+  gfc_prepend_expr_to_block (&parmse->post, tmp);
+}
+
+
 /* Generate code for a procedure call.  Note can return se->post != NULL.
    If se->direct_byref is set then se->expr contains the return parameter.
    Return nonzero, if the call has alternate specifiers.
@@ -5234,7 +5330,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		    tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
 		    parmse.expr = convert (type, tmp);
 		}
- 	      else if (fsym && fsym->attr.value)
+
+	      else if (sym->attr.is_bind_c && e
+		       && fsym && fsym->attr.dimension
+		       && (fsym->as->type == AS_ASSUMED_RANK
+			   || fsym->as->type == AS_ASSUMED_SHAPE))
+		/* Implement F2018, C.12.6.1: paragraph (2).  */
+		gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
+
+	      else if (fsym && fsym->attr.value)
 		{
 		  if (fsym->ts.type == BT_CHARACTER
 		      && fsym->ts.is_c_interop
@@ -5273,6 +5377,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		      }
 		    }
 		}
+
 	      else if (arg->name && arg->name[0] == '%')
 		/* Argument list functions %VAL, %LOC and %REF are signalled
 		   through arg->name.  */
@@ -5287,6 +5392,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		  gfc_conv_expr (&parmse, e);
 		  parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
 		}
+
 	      else if (e->expr_type == EXPR_FUNCTION
 		       && e->symtree->n.sym->result
 		       && e->symtree->n.sym->result != e->symtree->n.sym
@@ -5297,6 +5403,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		  if (fsym && fsym->attr.proc_pointer)
 		    parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
 		}
+
 	      else
 		{
 		  if (e->ts.type == BT_CLASS && fsym
@@ -5670,7 +5777,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		    parmse.force_tmp = 1;
 		}
 
-	      if (e->expr_type == EXPR_VARIABLE
+	      if (sym->attr.is_bind_c && e
+		  && fsym && fsym->attr.dimension
+		  && (fsym->as->type == AS_ASSUMED_RANK
+		      || fsym->as->type == AS_ASSUMED_SHAPE))
+		/* Implement F2018, C.12.6.1: paragraph (2).  */
+		gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
+
+	      else if (e->expr_type == EXPR_VARIABLE
 		    && is_subref_array (e)
 		    && !(fsym && fsym->attr.pointer))
 		/* The actual argument is a component reference to an
@@ -5680,6 +5794,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
 				fsym ? fsym->attr.intent : INTENT_INOUT,
 				fsym && fsym->attr.pointer);
+
 	      else if (gfc_is_class_array_ref (e, NULL)
 			 && fsym && fsym->ts.type == BT_DERIVED)
 		/* The actual argument is a component reference to an

gcc/fortran/trans.h

@@ -801,6 +801,8 @@ extern GTY(()) tree gfor_fndecl_ctime;
 extern GTY(()) tree gfor_fndecl_fdate;
 extern GTY(()) tree gfor_fndecl_in_pack;
 extern GTY(()) tree gfor_fndecl_in_unpack;
+extern GTY(()) tree gfor_fndecl_cfi_to_gfc;
+extern GTY(()) tree gfor_fndecl_gfc_to_cfi;
 extern GTY(()) tree gfor_fndecl_associated;
 extern GTY(()) tree gfor_fndecl_system_clock4;
 extern GTY(()) tree gfor_fndecl_system_clock8;

gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c

+/* Test F2008 18.5: ISO_Fortran_binding.h functions.  */
+
+#include <ISO_Fortran_binding.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <complex.h>
+
+/* Test the example in F2008 C.12.9: Processing assumed-shape arrays in C,
+   modified to use CFI_address instead of pointer arithmetic.  */
+
+int elemental_mult_c(CFI_cdesc_t * a_desc, CFI_cdesc_t * b_desc,
+		     CFI_cdesc_t * c_desc)
+{
+  CFI_index_t idx[2];
+  int *res_addr;
+  int err = 1; /* this error code represents all errors */
+
+  if (a_desc->rank == 0)
+    {
+      err = *(int*)a_desc->base_addr;
+      *(int*)a_desc->base_addr = 0;
+      return err;
+    }
+
+  if (a_desc->type != CFI_type_int
+      || b_desc->type != CFI_type_int
+      || c_desc->type != CFI_type_int)
+    return err;
+
+  /* Only support two dimensions. */
+  if (a_desc->rank != 2
+      || b_desc->rank != 2
+      || c_desc->rank != 2)
+    return err;
+
+  for (idx[0] = 0; idx[0] < a_desc->dim[0].extent; idx[0]++)
+    for (idx[1] = 0; idx[1] < a_desc->dim[1].extent; idx[1]++)
+      {
+	res_addr = CFI_address (a_desc, idx);
+	*res_addr = *(int*)CFI_address (b_desc, idx)
+		    * *(int*)CFI_address (c_desc, idx);
+      }
+
+  return 0;
+}
+
+
+int deallocate_c(CFI_cdesc_t * dd)
+{
+  return CFI_deallocate(dd);
+}
+
+
+int allocate_c(CFI_cdesc_t * da, CFI_index_t lower[], CFI_index_t upper[])
+{
+  int err = 1;
+  CFI_index_t idx[2];
+  int *res_addr;
+
+  if (CFI_allocate(da, lower, upper, 0)) return err;
+
+
+  for (idx[0] = 0; idx[0] < da->dim[0].extent; idx[0]++)
+    for (idx[1] = 0; idx[1] < da->dim[1].extent; idx[1]++)
+      {
+	res_addr = CFI_address (da, idx);
+	*res_addr = (int)((idx[0] + da->dim[0].lower_bound)
+			  * (idx[1] + da->dim[1].lower_bound));
+      }
+
+  return 0;
+}
+
+int establish_c(CFI_cdesc_t * desc)
+{
+  typedef struct {double x; double _Complex y;} t;
+  int err;
+  CFI_index_t idx[1], extent[1];
+  t *res_addr;
+  double value = 1.0;
+  double complex z_value = 0.0 + 2.0 * I;
+
+  extent[0] = 10;
+  err = CFI_establish((CFI_cdesc_t *)desc,
+		      malloc ((size_t)(extent[0] * sizeof(t))),
+		      CFI_attribute_pointer,
+		      CFI_type_struct,
+		      sizeof(t), 1, extent);
+  for (idx[0] = 0; idx[0] < extent[0]; idx[0]++)
+    {
+      res_addr = (t*)CFI_address (desc, idx);
+      res_addr->x = value++;
+      res_addr->y = z_value * (idx[0] + 1);
+    }
+  return err;
+}
+
+int contiguous_c(CFI_cdesc_t * desc)
+{
+  return CFI_is_contiguous(desc);
+}
+
+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;
+  float *ret_addr;
+  float ans = 0.0;
+
+  /* Case (i) from F2018:18.5.5.7. */
+  if (*std_case == 1)
+    {
+      lower[0] = (CFI_index_t)low[0];
+      strides[0] = (CFI_index_t)str[0];
+      ind = CFI_establish((CFI_cdesc_t *)&section, NULL, CFI_attribute_other,
+			  CFI_type_float, 0, 1, NULL);
+      if (ind) return -1.0;
+      ind = CFI_section((CFI_cdesc_t *)&section, source, lower, NULL, strides);
+      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]++)
+        ans += *(float*)CFI_address ((CFI_cdesc_t*)&section, idx);
+      return ans;
+    }
+  else if (*std_case == 2)
+    {
+      int ind;
+      lower[0] = source->dim[0].lower_bound;
+      upper[0] = source->dim[0].lower_bound + source->dim[0].extent - 1;
+      strides[0] = str[0];
+      lower[1] = upper[1] = source->dim[1].lower_bound + low[1] - 1;
+      strides[1] = 0;
+      ind = CFI_establish((CFI_cdesc_t *)&section, NULL, CFI_attribute_other,
+			  CFI_type_float, 0, 1, NULL);
+      if (ind) return -1.0;
+      ind = CFI_section((CFI_cdesc_t *)&section, source,
+			lower, upper, strides);
+      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]++)
+        ans += *(float*)CFI_address ((CFI_cdesc_t*)&section, idx);
+      return ans;
+    }
+
+  return 0.0;
+}
+
+
+double select_part_c (CFI_cdesc_t * source)
+{
+  typedef struct {
+    double x; double _Complex y;
+    } t;
+  CFI_CDESC_T(2) component;
+  CFI_cdesc_t * comp_cdesc = (CFI_cdesc_t *)&component;
+  CFI_index_t extent[] = {10,10};
+  CFI_index_t idx[] = {4,0};
+  double ans = 0.0;
+  int size;
+
+  (void)CFI_establish(comp_cdesc, NULL, CFI_attribute_other,
+		      CFI_type_double_Complex, sizeof(double _Complex),
+		      2, extent);
+  (void)CFI_select_part(comp_cdesc, source, offsetof(t,y), 0);
+
+  /* Sum over comp_cdesc[4,:]  */
+  size = comp_cdesc->dim[1].extent;
+  for (idx[1] = 0; idx[1] < size; idx[1]++)
+    ans += cimag (*(double _Complex*)CFI_address ((CFI_cdesc_t*)comp_cdesc,
+						  idx));
+  return ans;
+}
+
+
+int setpointer_c(CFI_cdesc_t * ptr, int lbounds[])
+{
+  CFI_index_t lower_bounds[] = {lbounds[0],lbounds[1]};
+  int ind;
+  ind = CFI_setpointer(ptr, ptr, lower_bounds);
+  return ind;
+}
+
+
+int assumed_size_c(CFI_cdesc_t * desc)
+{
+  int ierr;
+
+  ierr = CFI_is_contiguous(desc);
+  if (ierr)
+    return 1;
+  if (desc->rank)
+    ierr = 2 * (desc->dim[desc->rank-1].extent
+				!= (CFI_index_t)(long long)(-1));
+  else
+    ierr = 3;
+  return ierr;
+}

gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90

+! { dg-do run }
+! { dg-additional-sources ISO_Fortran_binding_1.c }
+!
+! Test F2008 18.5: ISO_Fortran_binding.h functions.
+!
+  USE, INTRINSIC :: ISO_C_BINDING
+
+  TYPE, BIND(C) :: T
+    REAL(C_DOUBLE) :: X
+    complex(C_DOUBLE_COMPLEX) :: Y
+  END TYPE
+
+  type :: mytype
+    integer :: i
+    integer :: j
+  end type
+
+  INTERFACE
+    FUNCTION elemental_mult(a, b, c) BIND(C, NAME="elemental_mult_c") RESULT(err)
+      USE, INTRINSIC :: ISO_C_BINDING
+      INTEGER(C_INT) :: err
+      type(*), DIMENSION(..) :: a, b, c
+    END FUNCTION elemental_mult
+
+    FUNCTION c_deallocate(a) BIND(C, NAME="deallocate_c") RESULT(err)
+      USE, INTRINSIC :: ISO_C_BINDING
+      INTEGER(C_INT) :: err
+      type(*), DIMENSION(..) :: a
+    END FUNCTION c_deallocate
+
+    FUNCTION c_allocate(a, lower, upper) BIND(C, NAME="allocate_c") RESULT(err)
+      USE, INTRINSIC :: ISO_C_BINDING
+      INTEGER(C_INT) :: err
+      type(*), DIMENSION(..) :: a
+      integer(C_INTPTR_T), DIMENSION(15) :: lower, upper
+    END FUNCTION c_allocate
+
+    FUNCTION c_establish(a) BIND(C, NAME="establish_c") RESULT(err)
+      USE, INTRINSIC :: ISO_C_BINDING
+      import
+      INTEGER(C_INT) :: err
+      type (T), DIMENSION(..), intent(out) :: a
+    END FUNCTION c_establish
+
+    FUNCTION c_contiguous(a) BIND(C, NAME="contiguous_c") RESULT(err)
+      USE, INTRINSIC :: ISO_C_BINDING
+      INTEGER(C_INT) :: err
+      type(*), DIMENSION(..) :: a
+    END FUNCTION c_contiguous
+
+    FUNCTION c_section(std_case, a, lower, strides) BIND(C, NAME="section_c") RESULT(ans)
+      USE, INTRINSIC :: ISO_C_BINDING
+      real(C_FLOAT) :: ans
+      INTEGER(C_INT) :: std_case
+      INTEGER(C_INT), dimension(15) :: lower
+      INTEGER(C_INT), dimension(15) :: strides
+      type(*), DIMENSION(..) :: a
+    END FUNCTION c_section
+
+    FUNCTION c_select_part(a) BIND(C, NAME="select_part_c") RESULT(ans)
+      USE, INTRINSIC :: ISO_C_BINDING
+      real(C_DOUBLE) :: ans
+      type(*), DIMENSION(..) :: a
+    END FUNCTION c_select_part
+
+    FUNCTION c_setpointer(a, lbounds) BIND(C, NAME="setpointer_c") RESULT(err)
+      USE, INTRINSIC :: ISO_C_BINDING
+      INTEGER(C_INT) :: err
+      INTEGER(C_INT), dimension(2) :: lbounds
+      type(*), DIMENSION(..) :: a
+    END FUNCTION c_setpointer
+
+    FUNCTION c_assumed_size(a) BIND(C, NAME="assumed_size_c") RESULT(err)
+      USE, INTRINSIC :: ISO_C_BINDING
+      INTEGER(C_INT) :: err
+      type(*), DIMENSION(..) :: a
+    END FUNCTION c_assumed_size
+
+  END INTERFACE
+
+  integer, dimension(:,:), allocatable :: x, y, z
+  integer, dimension(2,2) :: a, b, c
+  integer, dimension(4,4) :: d
+  integer :: i = 42, j, k
+  integer(C_INTPTR_T), dimension(15) :: lower, upper
+  real, dimension(10,10) :: arg
+  type (mytype), dimension(2,2) :: der
+
+  allocate (x, source = reshape ([4,3,2,1], [2,2]))
+  allocate (y, source = reshape ([2,3,4,5], [2,2]))
+  allocate (z, source = reshape ([0,0,0,0], [2,2]))
+
+  call test_CFI_address
+  call test_CFI_deallocate
+  call test_CFI_allocate
+  call test_CFI_establish
+  call test_CFI_contiguous (a)
+  call test_CFI_section (arg)
+  call test_CFI_select_part
+  call test_CFI_setpointer
+  call test_assumed_size (a)
+contains
+  subroutine test_CFI_address
+! Basic test that CFI_desc_t can be passed and that CFI_address works
+    if (elemental_mult (z, x, y) .ne. 0) stop 1
+    if (any (z .ne. reshape ([8,9,8,5], [2,2]))) stop 2
+
+    a = reshape ([4,3,2,1], [2,2])
+    b = reshape ([2,3,4,5], [2,2])
+    c = 0
+! Verify that components of arrays of derived types are OK.
+    der%j = a
+! Check that non-pointer/non-allocatable arguments are OK
+    if (elemental_mult (c, der%j, b) .ne. 0) stop 3
+    if (any (c .ne. reshape ([8,9,8,5], [2,2]))) stop 4
+
+! Check array sections
+    d = 0
+    d(4:2:-2, 1:3:2) = b
+    if (elemental_mult (c, a, d(4:2:-2, 1:3:2)) .ne. 0) stop 5
+    if (any (c .ne. reshape ([8,9,8,5], [2,2]))) stop 6
+
+! If a scalar result is passed to 'elemental_mult' it is returned
+! as the function result and then zeroed. This tests that scalars
+! are correctly converted to CF_desc_t.
+    if ((elemental_mult (i, a, b) .ne. 42) &
+        .or. (i .ne. 0)) stop 7
+    deallocate (y,z)
+end subroutine test_CFI_address
+
+  subroutine test_CFI_deallocate
+! Test CFI_deallocate.
+    if (c_deallocate (x) .ne. 0) stop 8
+    if (allocated (x)) stop 9
+  end subroutine test_CFI_deallocate
+
+  subroutine test_CFI_allocate
+! Test CFI_allocate.
+    lower(1:2) = [2,2]
+    upper(1:2) = [10,10]
+
+    if (c_allocate (x, lower, upper) .ne. 0) stop 10
+    if (.not.allocated (x)) stop 11
+    if (any (lbound (x) .ne. lower(1:2))) stop 12
+    if (any (ubound (x) .ne. upper(1:2))) stop 13
+
+! Elements are filled by 'c_allocate' with the product of the fortran indices
+    do j = lower(1) , upper(1)
+      do k = lower(2) , upper(2)
+        x(j,k) = x(j,k) - j * k
+      end do
+    end do
+    if (any (x .ne. 0)) stop 14
+    deallocate (x)
+  end subroutine test_CFI_allocate
+
+  subroutine test_CFI_establish
+! Test CFI_establish.
+    type(T), pointer :: case2(:) => null()
+    if (c_establish(case2) .ne. 0) stop 14
+    if (ubound(case2, 1) .ne. 9) stop 15
+    if (.not.associated(case2)) stop 16
+    if (sizeof(case2) .ne. 240) stop 17
+    if (int (sum (case2%x)) .ne. 55) stop 18
+    if (int (sum (imag (case2%y))) .ne. 110) stop 19
+    deallocate (case2)
+  end subroutine test_CFI_establish
+
+  subroutine test_CFI_contiguous (arg)
+    integer, dimension (2,*) :: arg
+    character(4), dimension(2) :: chr
+! These are contiguous
+    if (c_contiguous (arg) .ne. 0) stop 20
+    if (.not.allocated (x)) allocate (x(2, 2))
+    if (c_contiguous (x) .ne. 0) stop 22
+    deallocate (x)
+    if (c_contiguous (chr) .ne. 0) 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
+  end subroutine test_CFI_contiguous
+
+  subroutine test_CFI_section (arg)
+    real, dimension (100) :: a
+    real, dimension (10,*) :: arg
+    integer, dimension(15) :: lower, strides
+    integer :: i
+
+! Case (i) from F2018:18.5.5.7.
+    a = [(real(i), i = 1, 100)]
+    lower(1) = 10
+    strides(1) = 5
+    if (int (sum(a(lower(1)::strides(1))) &
+             - c_section(1, a, lower, strides)) .ne. 0) stop 28
+! Case (ii) from F2018:18.5.5.7.
+    arg(:,1:10) = reshape ([(real(i), i = 1, 100)], [10,10])
+    lower(1) = 1
+    lower(2) = 5
+    strides(1) = 1
+    strides(2) = 0
+    if (int (sum(arg(:,5)) &
+             - c_section (2, arg, lower, strides)) .ne. 0) stop 29
+  end subroutine test_CFI_section
+
+  subroutine test_CFI_select_part
+! Test the example from F2018:18.5.5.8.
+! Modify to take rank 2 and sum the section type_t(5, :)%y%im
+! Note that sum_z_5 = sum (type_t(5, :)%y%im) is broken on Darwin.
+!
+    type (t), dimension(10, 10) :: type_t
+    real(kind(type_t%x)) :: v, sum_z_5 = 0.0
+    complex(kind(type_t%y)) :: z
+! Set the array 'type_t'.
+    do j = 1, 10
+      do k = 1, 10
+        v = dble (j * k)
+        z = cmplx (2 * v, 3 * v)
+        type_t(j, k) = t (v, z)
+        if (j .eq. 5) sum_z_5 = sum_z_5 + imag (z)
+      end do
+    end do
+! Now do the test.
+    if (int (c_select_part (type_t) - sum_z_5) .ne. 0) stop 28
+  end subroutine test_CFI_select_part
+
+  subroutine test_CFI_setpointer
+! Test the example from F2018:18.5.5.9.
+    integer, dimension(:,:), pointer :: ptr => NULL ()
+    integer, dimension(2,2), target :: tgt
+    integer, dimension(2) :: lbounds = [-1, -2]
+! The C-function resets the lbounds
+    ptr(1:, 1:) => tgt
+    if (c_setpointer (ptr, lbounds) .ne. 0) stop 30
+    if (any (lbound(ptr) .ne. lbounds)) stop 31
+  end subroutine test_CFI_setpointer
+
+  subroutine test_assumed_size (arg)
+    integer, dimension(2,*) :: arg
+! The C-function checks contiguousness and that extent[1] == -1.
+    if (c_assumed_size (arg) .ne. 0) stop 32
+  end subroutine
+end

gcc/testsuite/gfortran.dg/ISO_Fortran_binding_2.c

+/* Test F2018 18.5: ISO_Fortran_binding.h functions.  */
+
+#include <ISO_Fortran_binding.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <complex.h>
+
+/* Test the example in F2018 C.12.9: Processing assumed-shape arrays in C,
+   modified to use CFI_address instead of pointer arithmetic.  */
+
+int address_c(CFI_cdesc_t * a_desc, const int idx[])
+{
+  int *res_addr;
+  CFI_index_t CFI_idx[1];
+
+  CFI_idx[0] = (CFI_index_t)idx[0];
+
+  res_addr = CFI_address (a_desc, CFI_idx);
+  if (res_addr == NULL)
+    return -1;
+  return *res_addr;
+}
+
+
+int deallocate_c(CFI_cdesc_t * dd)
+{
+  return CFI_deallocate(dd);
+}
+
+
+int allocate_c(CFI_cdesc_t * da, CFI_index_t lower[], CFI_index_t upper[])
+{
+  return CFI_allocate(da, lower, upper, 0);
+}
+
+int establish_c(CFI_cdesc_t * desc, int *rank, int *attr)
+{
+  typedef struct {double x; double _Complex y;} t;
+  int err;
+  CFI_index_t idx[1], extent[1];
+  void *ptr;
+
+  extent[0] = 1;
+  ptr = malloc ((size_t)(extent[0] * sizeof(t)));
+  err = CFI_establish((CFI_cdesc_t *)desc,
+		      ptr,
+		      (CFI_attribute_t)*attr,
+		      CFI_type_struct,
+		      sizeof(t), (CFI_rank_t)*rank, extent);
+  free (ptr);
+  return err;
+}
+
+int contiguous_c(CFI_cdesc_t * desc)
+{
+  return CFI_is_contiguous(desc);
+}
+
+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;
+  float *ret_addr;
+  float ans = 0.0;
+
+  if (*std_case == 1)
+    {
+      lower[0] = (CFI_index_t)low[0];
+      strides[0] = (CFI_index_t)str[0];
+      ind = CFI_establish((CFI_cdesc_t *)&section, NULL, CFI_attribute_other,
+			  CFI_type_float, 0, 1, NULL);
+      if (ind) return -1.0;
+      ind = CFI_section((CFI_cdesc_t *)&section, source, lower, NULL, strides);
+      if (ind) return (float)ind;
+    }
+
+  return 0.0;
+}
+
+
+int select_part_c (CFI_cdesc_t * source)
+{
+  typedef struct
+  {
+    double x;
+    double _Complex y;
+  } t;
+  CFI_CDESC_T(2) component;
+  CFI_cdesc_t * comp_cdesc = (CFI_cdesc_t *)&component;
+  CFI_index_t extent[] = {10,10};
+  CFI_index_t idx[] = {4,0};
+  int res;
+
+  res = CFI_establish(comp_cdesc, NULL, CFI_attribute_other,
+		      CFI_type_double_Complex, sizeof(double _Complex),
+		      2, extent);
+  if (res)
+    return res;
+
+  res = CFI_select_part(comp_cdesc, source, offsetof(t,y), 0);
+
+  return res;
+}
+
+
+int setpointer_c(CFI_cdesc_t * ptr1, CFI_cdesc_t * ptr2, int lbounds[])
+{
+  CFI_index_t lower_bounds[] = {lbounds[0],lbounds[1]};
+  int ind;
+
+  ind = CFI_setpointer(ptr1, ptr2, lower_bounds);
+  return ind;
+}

gcc/testsuite/gfortran.dg/ISO_Fortran_binding_2.f90

+! { dg-do run }
+! { dg-additional-sources ISO_Fortran_binding_2.c }
+! { dg-options "-fbounds-check" }
+!
+! Test F2018 18.5: ISO_Fortran_binding.h function errors.
+!
+  USE, INTRINSIC :: ISO_C_BINDING
+
+  TYPE, BIND(C) :: T
+    REAL(C_DOUBLE) :: X
+    complex(C_DOUBLE_COMPLEX) :: Y
+  END TYPE
+
+  type :: mytype
+    integer :: i
+    integer :: j
+  end type
+
+  INTERFACE
+    FUNCTION c_address(a, idx) BIND(C, NAME="address_c") RESULT(err)
+      USE, INTRINSIC :: ISO_C_BINDING
+      INTEGER(C_INT) :: err
+      INTEGER(C_INT), dimension(1) :: idx
+      type(*), DIMENSION(..) :: a
+    END FUNCTION c_address
+
+    FUNCTION c_deallocate(a) BIND(C, NAME="deallocate_c") RESULT(err)
+      USE, INTRINSIC :: ISO_C_BINDING
+      INTEGER(C_INT) :: err
+      type(*), DIMENSION(..) :: a
+    END FUNCTION c_deallocate
+
+    FUNCTION c_allocate(a, lower, upper) BIND(C, NAME="allocate_c") RESULT(err)
+      USE, INTRINSIC :: ISO_C_BINDING
+      INTEGER(C_INT) :: err
+      type(*), DIMENSION(..) :: a
+      integer(C_INTPTR_T), DIMENSION(15) :: lower, upper
+    END FUNCTION c_allocate
+
+    FUNCTION c_establish(a, rank, attr) BIND(C, NAME="establish_c") RESULT(err)
+      USE, INTRINSIC :: ISO_C_BINDING
+      import
+      INTEGER(C_INT) :: err
+      INTEGER(C_INT) :: rank, attr
+      type (T), DIMENSION(..), intent(out) :: a
+    END FUNCTION c_establish
+
+    FUNCTION c_contiguous(a) BIND(C, NAME="contiguous_c") RESULT(err)
+      USE, INTRINSIC :: ISO_C_BINDING
+      INTEGER(C_INT) :: err
+      type(*), DIMENSION(..) :: a
+    END FUNCTION c_contiguous
+
+    FUNCTION c_section(std_case, a, lower, strides) BIND(C, NAME="section_c") RESULT(ans)
+      USE, INTRINSIC :: ISO_C_BINDING
+      real(C_FLOAT) :: ans
+      INTEGER(C_INT) :: std_case
+      INTEGER(C_INT), dimension(15) :: lower
+      INTEGER(C_INT), dimension(15) :: strides
+      type(*), DIMENSION(..) :: a
+    END FUNCTION c_section
+
+    FUNCTION c_select_part(a) BIND(C, NAME="select_part_c") RESULT(ans)
+      USE, INTRINSIC :: ISO_C_BINDING
+      INTEGER(C_INT) :: ans
+      type(*), DIMENSION(..) :: a
+    END FUNCTION c_select_part
+
+    FUNCTION c_setpointer(a, b, lbounds) BIND(C, NAME="setpointer_c") RESULT(err)
+      USE, INTRINSIC :: ISO_C_BINDING
+      INTEGER(C_INT) :: err
+      INTEGER(C_INT), dimension(2) :: lbounds
+      type(*), DIMENSION(..) :: a, b
+    END FUNCTION c_setpointer
+  END INTERFACE
+
+  integer(C_INTPTR_T), dimension(15) :: lower, upper
+
+  call test_CFI_address
+  call test_CFI_deallocate
+  call test_CFI_allocate
+  call test_CFI_establish
+  call test_CFI_contiguous
+  call test_CFI_section
+  call test_CFI_select_part
+  call test_CFI_setpointer
+
+contains
+  subroutine test_CFI_address
+    integer, dimension(:), allocatable :: a
+    allocate (a, source = [1,2,3])
+    if (c_address (a, [2]) .ne. 3) stop 1   ! OK
+    if (c_address (a, [3]) .ne. -1) stop 2  ! "subscripts[0], is out of bounds"
+    if (c_address (a, [-1]) .ne. -1) stop 3 ! "subscripts[0], is out of bounds"
+    deallocate (a)
+    if (c_address (a, [2]) .ne. -1) stop 4  ! "C Descriptor must not be NULL"
+  end subroutine test_CFI_address
+
+  subroutine test_CFI_deallocate
+    integer, dimension(:), allocatable :: a
+    integer, dimension(2,2) :: b
+    if (c_deallocate (a) .ne. 2) stop 5     ! "Base address is already NULL"
+    allocate (a(2))
+    if (c_deallocate (a) .ne. 0) stop 6     ! OK
+    if (c_deallocate (b) .ne. 7) stop 7     ! "must describe a pointer or allocatable"
+  end subroutine test_CFI_deallocate
+
+  subroutine test_CFI_allocate
+    integer, dimension(:,:), allocatable :: a
+    integer, dimension(2,2) :: b
+    lower(1:2) = [2,2]
+    upper(1:2) = [10,10]
+    allocate (a(1,1))
+    if (c_allocate (a, lower, upper) .ne. 3) stop 8  ! "C descriptor must be NULL"
+    if (allocated (a)) deallocate (a)
+    if (c_allocate (a, lower, upper) .ne. 0) stop 9  ! OK
+    if (c_allocate (b, lower, upper) .ne. 7) STOP 10 ! "must describe a pointer or allocatable"
+  end subroutine test_CFI_allocate
+
+  subroutine test_CFI_establish
+    type(T), allocatable :: a(:)
+    INTEGER(C_INT) :: rank
+    INTEGER(C_INT) :: attr
+    attr = 0                                         ! establish a pointer
+    rank = 16
+    if (c_establish (a, rank, attr) .ne. 5) stop 11  ! "Rank must be between 0 and 15"
+    rank = 1
+    if (c_establish (a, rank, attr) .ne. 0) stop 12  ! OK
+    if (allocated (a)) deallocate (a)
+    if (c_establish (a, rank, attr) .ne. 0) Stop 13  ! OK the first time
+    if (c_establish (a, rank, attr) .ne. 10) Stop 14 ! "its base address must be NULL"
+    if (allocated (a)) deallocate (a)
+    attr = 1                                         ! establish an allocatable
+    if (c_establish (a, rank, attr) .ne. 7) Stop 15  ! "is for a nonallocatable entity"
+  end subroutine test_CFI_establish
+
+  subroutine test_CFI_contiguous
+    integer, allocatable :: a
+    if (c_contiguous (a) .ne. 2) stop 16  ! "Descriptor is already NULL"
+    allocate (a)
+    if (c_contiguous (a) .ne. 5) stop 17  ! "must describe an array"
+  end subroutine test_CFI_contiguous
+
+  subroutine test_CFI_section
+    real, allocatable, dimension (:) :: a
+    integer, dimension(15) :: lower, strides
+    integer :: i
+    real :: b
+    lower(1) = 10
+    strides(1) = 5
+    if (int (c_section (1, a, lower, strides)) .ne. 2) &
+        stop 18 ! "Base address of source must not be NULL"
+    allocate (a(100))
+    if (int (c_section (1, a, lower, strides)) .ne. 0) &
+        stop 19 ! OK
+    if (int (c_section (1, b, lower, strides)) .ne. 5) &
+        stop 20 ! "Source must describe an array"
+    strides(1) = 0
+    if (int (c_section (1, a, lower, strides)) .ne. 5) &
+        stop 21 ! "Rank of result must be equal to the rank of source"
+    strides(1) = 5
+    lower(1) = -1
+    if (int (c_section (1, a, lower, strides)) .ne. 12) &
+        stop 22 ! "Lower bounds must be within the bounds of the fortran array"
+    lower(1) = 100
+    if (int (c_section (1, a, lower, strides)) .ne. 12) &
+        stop 23 ! "Lower bounds must be within the bounds of the fortran array"
+  end subroutine test_CFI_section
+
+  subroutine test_CFI_select_part
+    type(t), allocatable, dimension(:) :: a
+    type(t) :: src
+    allocate (a(1), source = src)
+    if (c_select_part (a) .ne. 5) stop 24 ! "Source and result must have the same rank"
+    deallocate (a)
+    if (c_select_part (a) .ne. 2) stop 25 ! "source must not be NULL"
+  end subroutine test_CFI_select_part
+
+  subroutine test_CFI_setpointer
+    integer, dimension(2,2), target :: tgt1
+    integer, dimension(:,:), pointer :: src
+    type (t), dimension(2), target :: tgt2
+    type (t), dimension(:), pointer :: res
+    type (t), dimension(2, 2), target, save :: tgt3
+    type (t), dimension(:, :), pointer :: src1
+    integer, dimension(2) :: lbounds = [-1, -2]
+    src => tgt1
+    res => tgt2
+    if (c_setpointer (res, src, lbounds) .ne. 4) stop 26 ! "Element lengths"
+    src1 => tgt3
+    if (c_setpointer (res, src1, lbounds) .ne. 5) stop 27 ! "Ranks of result"
+  end subroutine test_CFI_setpointer
+end

gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90

@@ -5,7 +5,7 @@
 !
 ! Check that assumed-shape variables are correctly passed to BIND(C)
 ! as defined in TS 29913
-! 
+!
 interface
   subroutine test (xx) bind(C, name="myBindC")
     type(*), dimension(:,:) :: xx
@@ -20,4 +20,4 @@ end
 ! { dg-final { scan-assembler-times "myBindC,%r2" 1 { target { hppa*-*-* } } } }
 ! { dg-final { scan-assembler-times "call\tmyBindC" 1 { target { *-*-cygwin* } } } }
 ! { dg-final { scan-assembler-times "brasl\t%r\[0-9\]*,myBindC" 1 { target { s390*-*-* } } } }
-! { dg-final { scan-tree-dump-times "test \\\(&parm\\." 1 "original" } }
+! { dg-final { scan-tree-dump-times "cfi_desc_to_gfc_desc \\\(&parm\\." 1 "original" } }

libgfortran/ChangeLog

+2019-01-12  Paul Thomas  <pault@gcc.gnu.org>
+
+	* ISO_Fortran_binding.h : New file.
+	* Makefile.am : Include ISO_Fortran_binding.c in the list of
+	files to compile.
+	* Makefile.in : Regenerated.
+	* gfortran.map : Add _gfortran_cfi_desc_to_gfc_desc,
+	_gfortran_gfc_desc_to_cfi_desc and the CFI API functions.
+	* runtime/ISO_Fortran_binding.c : New file containing the new
+	functions added to the map.
+
 2019-01-12  Jakub Jelinek  <jakub@redhat.com>
 
 	PR libfortran/88807

libgfortran/ISO_Fortran_binding.h

+/* Declarations for ISO Fortran binding.
+   Copyright (C) 2018 Free Software Foundation, Inc.
+   Contributed by Daniel Celis Garza  <celisdanieljr@gmail.com>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#ifndef ISO_FORTRAN_BINDING_H
+#define ISO_FORTRAN_BINDING_H
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#include <stddef.h>  /* Standard ptrdiff_t tand size_t. */
+#include <stdint.h>  /* Integer types. */
+
+/* Constants, defined as macros. */
+#define CFI_VERSION 1
+#define CFI_MAX_RANK 15
+
+/* Attributes. */
+#define CFI_attribute_pointer 0
+#define CFI_attribute_allocatable 1
+#define CFI_attribute_other 2
+
+/* Error codes.
+   CFI_INVALID_STRIDE should be defined in the standard because they are useful to the implementation of the functions.
+ */
+#define CFI_SUCCESS 0
+#define CFI_FAILURE 1
+#define CFI_ERROR_BASE_ADDR_NULL 2
+#define CFI_ERROR_BASE_ADDR_NOT_NULL 3
+#define CFI_INVALID_ELEM_LEN 4
+#define CFI_INVALID_RANK 5
+#define CFI_INVALID_TYPE 6
+#define CFI_INVALID_ATTRIBUTE 7
+#define CFI_INVALID_EXTENT 8
+#define CFI_INVALID_STRIDE 9
+#define CFI_INVALID_DESCRIPTOR 10
+#define CFI_ERROR_MEM_ALLOCATION 11
+#define CFI_ERROR_OUT_OF_BOUNDS 12
+
+/* CFI type definitions. */
+typedef ptrdiff_t CFI_index_t;
+typedef int8_t CFI_rank_t;
+typedef int8_t CFI_attribute_t;
+typedef int16_t CFI_type_t;
+
+/* CFI_dim_t. */
+typedef struct CFI_dim_t
+  {
+    CFI_index_t lower_bound;
+    CFI_index_t extent;
+    CFI_index_t sm;
+  }
+CFI_dim_t;
+
+/* CFI_cdesc_t, C descriptors are cast to this structure as follows:
+   CFI_CDESC_T(CFI_MAX_RANK) foo;
+   CFI_cdesc_t * bar = (CFI_cdesc_t *) &foo;
+ */
+typedef struct CFI_cdesc_t
+ {
+    void *base_addr;
+    size_t elem_len;
+    int version;
+    CFI_rank_t rank;
+    CFI_attribute_t attribute;
+    CFI_type_t type;
+    CFI_dim_t dim[];
+ }
+CFI_cdesc_t;
+
+/* CFI_CDESC_T with an explicit type. */
+#define CFI_CDESC_TYPE_T(r, base_type) \
+	struct { \
+		base_type *base_addr; \
+		size_t elem_len; \
+		int version; \
+		CFI_rank_t rank; \
+		CFI_attribute_t attribute; \
+		CFI_type_t type; \
+		CFI_dim_t dim[r]; \
+	}
+#define CFI_CDESC_T(r) CFI_CDESC_TYPE_T (r, void)
+
+/* CFI function declarations. */
+extern void *CFI_address (const CFI_cdesc_t *, const CFI_index_t []);
+extern int CFI_allocate (CFI_cdesc_t *, const CFI_index_t [], const CFI_index_t [],
+			 size_t);
+extern int CFI_deallocate (CFI_cdesc_t *);
+extern int CFI_establish (CFI_cdesc_t *, void *, CFI_attribute_t, CFI_type_t, size_t,
+			  CFI_rank_t, const CFI_index_t []);
+extern int CFI_is_contiguous (const CFI_cdesc_t *);
+extern int CFI_section (CFI_cdesc_t *, const CFI_cdesc_t *, const CFI_index_t [],
+			const CFI_index_t [], const CFI_index_t []);
+extern int CFI_select_part (CFI_cdesc_t *, const CFI_cdesc_t *, size_t, size_t);
+extern int CFI_setpointer (CFI_cdesc_t *, CFI_cdesc_t *, const CFI_index_t []);
+
+/* Types and kind numbers. Allows bitwise and to reveal the intrinsic type of a kind type. It also allows us to find the kind parameter by inverting the bit-shift equation.
+   CFI_type_kind_shift = 8
+   CFI_intrinsic_type  = 0 0 0 0 0 0 0 0 0 0 1 0
+   CFI_type_kind       = 0 0 0 0 0 0 0 0 1 0 0 0
+   CFI_type_example    = CFI_intrinsic_type + (CFI_type_kind << CFI_type_kind_shift)
+   Defining the CFI_type_example.
+   CFI_type_kind       = 0 0 0 0 0 0 0 0 1 0 0 0  << CFI_type_kind_shift
+			-------------------------
+			 1 0 0 0 0 0 0 0 0 0 0 0  +
+   CFI_intrinsic_type  = 0 0 0 0 0 0 0 0 0 0 1 0
+			-------------------------
+   CFI_type_example    = 1 0 0 0 0 0 0 0 0 0 1 0
+   Finding the intrinsic type with the logical mask.
+   CFI_type_example    = 1 0 0 0 0 0 0 0 0 0 1 0  &
+   CFI_type_mask       = 0 0 0 0 1 1 1 1 1 1 1 1
+			-------------------------
+   CFI_intrinsic_type  = 0 0 0 0 0 0 0 0 0 0 1 0
+   Using the intrinsic type and kind shift to find the kind value of the type.
+   CFI_type_kind = (CFI_type_example - CFI_intrinsic_type) >> CFI_type_kind_shift
+   CFI_type_example   = 1 0 0 0 0 0 0 0 0 0 1 0  -
+   CFI_intrinsic_type = 0 0 0 0 0 0 0 0 0 0 1 0
+			-------------------------
+			1 0 0 0 0 0 0 0 0 0 0 0  >> CFI_type_kind_shift
+			-------------------------
+   CFI_type_kind      = 0 0 0 0 0 0 0 0 1 0 0 0
+ */
+#define CFI_type_mask 0xFF
+#define CFI_type_kind_shift 8
+
+/* Intrinsic types. Their kind number defines their storage size. */
+#define CFI_type_Integer 1
+#define CFI_type_Logical 2
+#define CFI_type_Real 3
+#define CFI_type_Complex 4
+#define CFI_type_Character 5
+
+/* Types with no kind. */
+#define CFI_type_struct 6
+#define CFI_type_cptr 7
+#define CFI_type_cfunptr 8
+#define CFI_type_other -1
+
+/* Types with kind parameter.
+   The kind parameter represents the type's byte size. The exception is kind = 10, which has byte size of 64 but 80 bit precision. Complex variables are double the byte size of their real counterparts. The ucs4_char matches wchar_t if sizeof (wchar_t) == 4.
+ */
+#define CFI_type_char (CFI_type_Character + (1 << CFI_type_kind_shift))
+#define CFI_type_ucs4_char (CFI_type_Character + (4 << CFI_type_kind_shift))
+
+/* C-Fortran Interoperability types. */
+#define CFI_type_signed_char (CFI_type_Integer + (1 << CFI_type_kind_shift))
+#define CFI_type_short (CFI_type_Integer + (2 << CFI_type_kind_shift))
+#define CFI_type_int (CFI_type_Integer + (4 << CFI_type_kind_shift))
+#define CFI_type_long (CFI_type_Integer + (8 << CFI_type_kind_shift))
+#define CFI_type_long_long (CFI_type_Integer + (8 << CFI_type_kind_shift))
+#define CFI_type_size_t (CFI_type_Integer + (8 << CFI_type_kind_shift))
+#define CFI_type_int8_t (CFI_type_Integer + (1 << CFI_type_kind_shift))
+#define CFI_type_int16_t (CFI_type_Integer + (2 << CFI_type_kind_shift))
+#define CFI_type_int32_t (CFI_type_Integer + (4 << CFI_type_kind_shift))
+#define CFI_type_int64_t (CFI_type_Integer + (8 << CFI_type_kind_shift))
+#define CFI_type_int_least8_t (CFI_type_Integer + (1 << CFI_type_kind_shift))
+#define CFI_type_int_least16_t (CFI_type_Integer + (2 << CFI_type_kind_shift))
+#define CFI_type_int_least32_t (CFI_type_Integer + (4 << CFI_type_kind_shift))
+#define CFI_type_int_least64_t (CFI_type_Integer + (8 << CFI_type_kind_shift))
+#define CFI_type_int_fast8_t (CFI_type_Integer + (1 << CFI_type_kind_shift))
+#define CFI_type_int_fast16_t (CFI_type_Integer + (2 << CFI_type_kind_shift))
+#define CFI_type_int_fast32_t (CFI_type_Integer + (4 << CFI_type_kind_shift))
+#define CFI_type_int_fast64_t (CFI_type_Integer + (8 << CFI_type_kind_shift))
+#define CFI_type_intmax_t (CFI_type_Integer + (8 << CFI_type_kind_shift))
+#define CFI_type_intptr_t (CFI_type_Integer + (8 << CFI_type_kind_shift))
+#define CFI_type_ptrdiff_t (CFI_type_Integer + (8 << CFI_type_kind_shift))
+#define CFI_type_int128_t (CFI_type_Integer + (16 << CFI_type_kind_shift))
+#define CFI_type_int_least128_t (CFI_type_Integer + (16 << CFI_type_kind_shift))
+#define CFI_type_int_fast128_t (CFI_type_Integer + (16 << CFI_type_kind_shift))
+#define CFI_type_Bool (CFI_type_Logical + (1 << CFI_type_kind_shift))
+#define CFI_type_float (CFI_type_Real + (4 << CFI_type_kind_shift))
+#define CFI_type_double (CFI_type_Real + (8 << CFI_type_kind_shift))
+#define CFI_type_long_double (CFI_type_Real + (10 << CFI_type_kind_shift))
+#define CFI_type_float128 (CFI_type_Real + (16 << CFI_type_kind_shift))
+#define CFI_type_float_Complex (CFI_type_Complex + (4 << CFI_type_kind_shift))
+#define CFI_type_double_Complex (CFI_type_Complex + (8 << CFI_type_kind_shift))
+#define CFI_type_long_double_Complex (CFI_type_Complex + (10 << CFI_type_kind_shift))
+#define CFI_type_float128_Complex (CFI_type_Complex + (16 << CFI_type_kind_shift))
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* ISO_FORTRAN_BINDING_H */

libgfortran/Makefile.am

@@ -30,6 +30,9 @@ version_arg =
 version_dep =
 endif
 
+gfor_c_HEADERS = $(srcdir)/ISO_Fortran_binding.h
+gfor_cdir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR)/include
+
 LTLDFLAGS = $(shell $(SHELL) $(top_srcdir)/../libtool-ldflags $(LDFLAGS)) \
 	    $(lt_host_flags)
 
@@ -783,6 +786,9 @@ $(srcdir)/generated/spread_c8.c \
 $(srcdir)/generated/spread_c10.c \
 $(srcdir)/generated/spread_c16.c 
 
+i_isobinding_c = \
+$(srcdir)/runtime/ISO_Fortran_binding.c
+
 m4_files= m4/iparm.m4 m4/ifunction.m4 m4/iforeach.m4 m4/all.m4 \
     m4/any.m4 m4/count.m4 m4/maxloc0.m4 m4/maxloc1.m4 m4/maxval.m4 \
     m4/minloc0.m4 m4/minloc1.m4 m4/minval.m4 m4/product.m4 m4/sum.m4 \
@@ -810,7 +816,7 @@ gfor_built_src= $(i_all_c) $(i_any_c) $(i_count_c) $(i_maxloc0_c) \
     $(i_minloc1s_c) $(i_maxloc2s_c) $(i_minloc2s_c) $(i_maxvals_c) \
     $(i_maxval0s_c) $(i_minval0s_c) $(i_maxval1s_c) $(i_minval1s_c) \
     $(i_findloc0_c) $(i_findloc0s_c) $(i_findloc1_c) $(i_findloc1s_c) \
-    $(i_findloc2s_c)
+    $(i_findloc2s_c) $(i_isobinding_c)
 
 # Machine generated specifics
 gfor_built_specific_src= \

libgfortran/configure

@@ -780,7 +780,6 @@ infodir
 docdir
 oldincludedir
 includedir
-runstatedir
 localstatedir
 sharedstatedir
 sysconfdir
@@ -871,7 +870,6 @@ datadir='${datarootdir}'
 sysconfdir='${prefix}/etc'
 sharedstatedir='${prefix}/com'
 localstatedir='${prefix}/var'
-runstatedir='${localstatedir}/run'
 includedir='${prefix}/include'
 oldincludedir='/usr/include'
 docdir='${datarootdir}/doc/${PACKAGE_TARNAME}'
@@ -1124,15 +1122,6 @@ do
   | -silent | --silent | --silen | --sile | --sil)
     silent=yes ;;
 
-  -runstatedir | --runstatedir | --runstatedi | --runstated \
-  | --runstate | --runstat | --runsta | --runst | --runs \
-  | --run | --ru | --r)
-    ac_prev=runstatedir ;;
-  -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \
-  | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \
-  | --run=* | --ru=* | --r=*)
-    runstatedir=$ac_optarg ;;
-
   -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
     ac_prev=sbindir ;;
   -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \
@@ -1270,7 +1259,7 @@ fi
 for ac_var in	exec_prefix prefix bindir sbindir libexecdir datarootdir \
 		datadir sysconfdir sharedstatedir localstatedir includedir \
 		oldincludedir docdir infodir htmldir dvidir pdfdir psdir \
-		libdir localedir mandir runstatedir
+		libdir localedir mandir
 do
   eval ac_val=\$$ac_var
   # Remove trailing slashes.
@@ -1423,7 +1412,6 @@ Fine tuning of the installation directories:
   --sysconfdir=DIR        read-only single-machine data [PREFIX/etc]
   --sharedstatedir=DIR    modifiable architecture-independent data [PREFIX/com]
   --localstatedir=DIR     modifiable single-machine data [PREFIX/var]
-  --runstatedir=DIR       modifiable per-process data [LOCALSTATEDIR/run]
   --libdir=DIR            object code libraries [EPREFIX/lib]
   --includedir=DIR        C header files [PREFIX/include]
   --oldincludedir=DIR     C header files for non-gcc [/usr/include]
@@ -12696,7 +12684,7 @@ else
   lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
   lt_status=$lt_dlunknown
   cat > conftest.$ac_ext <<_LT_EOF
-#line 12699 "configure"
+#line 12687 "configure"
 #include "confdefs.h"
 
 #if HAVE_DLFCN_H
@@ -12802,7 +12790,7 @@ else
   lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
   lt_status=$lt_dlunknown
   cat > conftest.$ac_ext <<_LT_EOF
-#line 12805 "configure"
+#line 12793 "configure"
 #include "confdefs.h"
 
 #if HAVE_DLFCN_H
@@ -16051,7 +16039,7 @@ else
     We can't simply define LARGE_OFF_T to be 9223372036854775807,
     since some C++ compilers masquerading as C compilers
     incorrectly reject 9223372036854775807.  */
-#define LARGE_OFF_T ((((off_t) 1 << 31) << 31) - 1 + (((off_t) 1 << 31) << 31))
+#define LARGE_OFF_T (((off_t) 1 << 62) - 1 + ((off_t) 1 << 62))
   int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721
 		       && LARGE_OFF_T % 2147483647 == 1)
 		      ? 1 : -1];
@@ -16097,7 +16085,7 @@ else
     We can't simply define LARGE_OFF_T to be 9223372036854775807,
     since some C++ compilers masquerading as C compilers
     incorrectly reject 9223372036854775807.  */
-#define LARGE_OFF_T ((((off_t) 1 << 31) << 31) - 1 + (((off_t) 1 << 31) << 31))
+#define LARGE_OFF_T (((off_t) 1 << 62) - 1 + ((off_t) 1 << 62))
   int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721
 		       && LARGE_OFF_T % 2147483647 == 1)
 		      ? 1 : -1];
@@ -16121,7 +16109,7 @@ rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
     We can't simply define LARGE_OFF_T to be 9223372036854775807,
     since some C++ compilers masquerading as C compilers
     incorrectly reject 9223372036854775807.  */
-#define LARGE_OFF_T ((((off_t) 1 << 31) << 31) - 1 + (((off_t) 1 << 31) << 31))
+#define LARGE_OFF_T (((off_t) 1 << 62) - 1 + ((off_t) 1 << 62))
   int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721
 		       && LARGE_OFF_T % 2147483647 == 1)
 		      ? 1 : -1];
@@ -16166,7 +16154,7 @@ else
     We can't simply define LARGE_OFF_T to be 9223372036854775807,
     since some C++ compilers masquerading as C compilers
     incorrectly reject 9223372036854775807.  */
-#define LARGE_OFF_T ((((off_t) 1 << 31) << 31) - 1 + (((off_t) 1 << 31) << 31))
+#define LARGE_OFF_T (((off_t) 1 << 62) - 1 + ((off_t) 1 << 62))
   int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721
 		       && LARGE_OFF_T % 2147483647 == 1)
 		      ? 1 : -1];
@@ -16190,7 +16178,7 @@ rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
     We can't simply define LARGE_OFF_T to be 9223372036854775807,
     since some C++ compilers masquerading as C compilers
     incorrectly reject 9223372036854775807.  */
-#define LARGE_OFF_T ((((off_t) 1 << 31) << 31) - 1 + (((off_t) 1 << 31) << 31))
+#define LARGE_OFF_T (((off_t) 1 << 62) - 1 + ((off_t) 1 << 62))
   int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721
 		       && LARGE_OFF_T % 2147483647 == 1)
 		      ? 1 : -1];

libgfortran/gfortran.map

@@ -1486,6 +1486,16 @@ GFORTRAN_C99_8 {
 
 GFORTRAN_9 {
   global:
+  CFI_address;
+  CFI_allocate;
+  CFI_deallocate;
+  CFI_establish;
+  CFI_is_contiguous;
+  CFI_section;
+  CFI_select_part;
+  CFI_setpointer;
+  _gfortran_gfc_desc_to_cfi_desc;
+  _gfortran_cfi_desc_to_gfc_desc;
   _gfortran_findloc0_c16;
   _gfortran_findloc0_c4;
   _gfortran_findloc0_c8;