The attached patch allows MPICH 3.2 to build correctly and to test successfully.
Two problems were addressed:
(i) The original implementation of ISO_Fortran_binding did not take
account of the possibility that assumed rank/assumed type arrays could
be passed as dummy arguments. This necessitated the e->rank condition
being changed to e->rank !=0 since assumed rank entities have rank ==
-1 in gfc_exprs.
(ii) Intent in requires that a copy be made of the data to be passed
to the C procedure. This is now implemented.
The testcase provides two interfaces to the C-procedure; one with
intent in and the other with intent inout. The C procedure changes the
data and so this is detected in the inout case but not in the intent
in case. For both, the C procedure checks that the sum over the array
is correct.
>From the point of view of the release, this is completely safe since
the patch is isolated to the ISO_Fortran_binding interface, which is
newly introduced and has no effect on the rest of the testsuite. I
have bumped the testcase number by 1 to allow for a corrected version
of the withdrawn patch for the test of the errors from the CFI API
functions. I will return to this as soon as I can.
Bootstrapped and regtested on FC28/x86_64 - OK for trunk?
Paul
2019-01-23 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/88929
* trans-array.c (gfc_conv_descriptor_elem_len): New function.
* trans-array.h : Add prototype for above.
* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Take account of
assumed rank arrays being flagged by rank = -1 in expressions.
Intent in arrays need a pointer to a copy of the data to be
assigned to the descriptor passed for conversion. This should
then be freed, together with the CFI descriptor on return from
the C call.
2019-01-23 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/88929
* gfortran.dg/ISO_Fortran_binding_3.f90 : New test
* gfortran.dg/ISO_Fortran_binding_3.c : Subsidiary source.
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 268193)
--- gcc/fortran/trans-array.c (working copy)
*************** gfc_conv_descriptor_rank (tree desc)
*** 293,298 ****
--- 293,314 ----
tree
+ gfc_conv_descriptor_elem_len (tree desc)
+ {
+ tree tmp;
+ tree dtype;
+
+ dtype = gfc_conv_descriptor_dtype (desc);
+ tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)),
+ GFC_DTYPE_ELEM_LEN);
+ gcc_assert (tmp!= NULL_TREE
+ && TREE_TYPE (tmp) == size_type_node);
+ return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
+ dtype, tmp, NULL_TREE);
+ }
+
+
+ tree
gfc_conv_descriptor_attribute (tree desc)
{
tree tmp;
Index: gcc/fortran/trans-array.h
===================================================================
*** gcc/fortran/trans-array.h (revision 268193)
--- gcc/fortran/trans-array.h (working copy)
*************** tree gfc_conv_descriptor_offset_get (tre
*** 169,174 ****
--- 169,175 ----
tree gfc_conv_descriptor_span_get (tree);
tree gfc_conv_descriptor_dtype (tree);
tree gfc_conv_descriptor_rank (tree);
+ tree gfc_conv_descriptor_elem_len (tree);
tree gfc_conv_descriptor_attribute (tree);
tree gfc_get_descriptor_dimension (tree);
tree gfc_conv_descriptor_stride_get (tree, tree);
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 268193)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_conv_gfc_desc_to_cfi_desc (gfc_se *p
*** 4924,4929 ****
--- 4924,4931 ----
tree tmp;
tree cfi_desc_ptr;
tree gfc_desc_ptr;
+ tree ptr = NULL_TREE;
+ tree size;
tree type;
int attribute;
symbol_attribute attr = gfc_expr_attr (e);
*************** gfc_conv_gfc_desc_to_cfi_desc (gfc_se *p
*** 4939,4945 ****
attribute = 1;
}
! if (e->rank)
{
gfc_conv_expr_descriptor (parmse, e);
--- 4941,4947 ----
attribute = 1;
}
! if (e->rank != 0)
{
gfc_conv_expr_descriptor (parmse, e);
*************** gfc_conv_gfc_desc_to_cfi_desc (gfc_se *p
*** 4950,4958 ****
/* 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. */
--- 4952,4965 ----
/* 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 && DECL_ARTIFICIAL (parmse->expr)
&& type != gfc_get_element_type (TREE_TYPE (parmse->expr)))
{
/* Obtain the offset to the data. */
*************** gfc_conv_gfc_desc_to_cfi_desc (gfc_se *p
*** 4964,4978 ****
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
{
--- 4971,5014 ----
gfc_conv_descriptor_dtype (parmse->expr),
gfc_get_dtype_rank_type (e->rank, type));
}
! else if (type == NULL_TREE
! || (!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 = 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);
}
+
+ /* Intent in requires a temporary for the data. Assumed types do not
+ work with the standard temporary generation schemes. */
+ if (e->expr_type == EXPR_VARIABLE && fsym->attr.intent == INTENT_IN)
+ {
+ /* Fix the descriptor and determine the size of the data. */
+ parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
+ size = build_call_expr_loc (input_location,
+ gfor_fndecl_size0, 1,
+ gfc_build_addr_expr (NULL, parmse->expr));
+ size = fold_convert (size_type_node, size);
+ tmp = gfc_conv_descriptor_span_get (parmse->expr);
+ tmp = fold_convert (size_type_node, tmp);
+ size = fold_build2_loc (input_location, MULT_EXPR,
+ size_type_node, size, tmp);
+ /* Fix the size and allocate. */
+ size = gfc_evaluate_now (size, &parmse->pre);
+ tmp = builtin_decl_explicit (BUILT_IN_MALLOC);
+ ptr = build_call_expr_loc (input_location, tmp, 1, size);
+ ptr = gfc_evaluate_now (ptr, &parmse->pre);
+ /* Copy the data to the temporary descriptor. */
+ tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
+ tmp = build_call_expr_loc (input_location, tmp, 3, ptr,
+ gfc_conv_descriptor_data_get (parmse->expr),
+ size);
+ gfc_add_expr_to_block (&parmse->pre, tmp);
+ gfc_conv_descriptor_data_set (&parmse->pre, parmse->expr, ptr);
+ }
+
}
else
{
*************** gfc_conv_gfc_desc_to_cfi_desc (gfc_se *p
*** 5012,5017 ****
--- 5048,5064 ----
/* The CFI descriptor is passed to the bind_C procedure. */
parmse->expr = cfi_desc_ptr;
+ if (ptr)
+ {
+ /* Free both the temporary data and the CFI descriptor for
+ intent in arrays. */
+ tmp = gfc_call_free (ptr);
+ gfc_prepend_expr_to_block (&parmse->post, tmp);
+ tmp = gfc_call_free (cfi_desc_ptr);
+ gfc_prepend_expr_to_block (&parmse->post, tmp);
+ return;
+ }
+
/* 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,
Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_3.c
===================================================================
*** gcc/testsuite/gfortran.dg/ISO_Fortran_binding_3.c (nonexistent)
--- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_3.c (working copy)
***************
*** 0 ****
--- 1,32 ----
+ #include "../../../libgfortran/ISO_Fortran_binding.h"
+ #include <stdio.h>
+ #include <stdlib.h>
+
+ /* Part of the test for the fix of PR88929 - see ISO_Fortran_binding_3.f90. */
+
+ int c_test (CFI_cdesc_t * a_desc)
+ {
+ CFI_index_t idx[2];
+ int *res_addr;
+ int err = 1; /* this error code represents all errors */
+
+ if (a_desc->rank != 2)
+ return err;
+
+ if (a_desc->type != CFI_type_int)
+ return err;
+
+ err = 0;
+ 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);
+ err += *res_addr;
+ *res_addr = *res_addr + 1;
+ }
+
+ if (err != 10) return 1;
+
+ return 0;
+ }
+
Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/ISO_Fortran_binding_3.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_3.f90 (working copy)
***************
*** 0 ****
--- 1,53 ----
+ ! { dg-do run }
+ ! { dg-additional-sources ISO_Fortran_binding_3.c }
+ !
+ ! Test the fix for PR88929.
+ !
+ integer, dimension (:,:), allocatable :: actual
+ integer, dimension(2,2) :: src = reshape ([1,2,3,4], [2,2])
+
+ allocate (actual, source = src)
+ ier = test1 (actual)
+ if (ier .ne. 0) stop 1
+ ! C call is INTENT(IN). 'c_test' increments elements of 'src'.
+ if (any (actual .ne. src)) stop 2
+
+ ier = test2 (actual)
+ if (ier .ne. 0) stop 1
+ ! C call is INTENT(INOUT) 'c_test' increments elements of 'src'.
+ if (any (actual .ne. src + 1)) stop 2
+
+ contains
+
+ function test1 (arg) RESULT(err)
+ USE, INTRINSIC :: ISO_C_BINDING
+ INTEGER(C_INT) :: err
+ type(*), dimension(..), intent(inOUT) :: arg
+ interface
+ function test_c (a) BIND(C, NAME="c_test") RESULT(err)
+ USE, INTRINSIC :: ISO_C_BINDING
+ type(*), dimension(..), intent(in) :: a
+ INTEGER(C_INT) :: err
+ end function
+ end interface
+
+ err = test_c (arg) ! This used to ICE
+
+ end function test1
+
+ function test2 (arg) RESULT(err)
+ USE, INTRINSIC :: ISO_C_BINDING
+ INTEGER(C_INT) :: err
+ type(*), dimension(..), intent(inout) :: arg
+ interface
+ function test_c (a) BIND(C, NAME="c_test") RESULT(err)
+ USE, INTRINSIC :: ISO_C_BINDING
+ type(*), dimension(..), intent(inout) :: a
+ INTEGER(C_INT) :: err
+ end function
+ end interface
+
+ err = test_c (arg) ! This used to ICE
+
+ end function test2
+ end
\ No newline at end of file
