mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-05 16:51:13 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/89843 (CFI_section delivers incorrect result descriptor)

Browse Source 
2019-04-14  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/89843
	* trans-decl.c (gfc_get_symbol_decl): Assumed shape and assumed
	rank dummies of bind C procs require deferred initialization.
	(convert_CFI_desc): New procedure to convert incoming CFI
	descriptors to gfc types and back again.
	(gfc_trans_deferred_vars): Call it.
	* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Null the CFI
	descriptor pointer. Free the descriptor in all cases.

	PR fortran/89846
	* expr.c (is_CFI_desc): New function.
	(is_subref_array): Tidy up by referencing the symbol directly.
	* gfortran.h : Prototype for is_CFI_desc.
	* trans_array.c (get_CFI_desc): New function.
	(gfc_get_array_span, gfc_conv_scalarized_array_ref,
	gfc_conv_array_ref): Use it.
	* trans.c (get_array_span): Extract the span from descriptors
	that are indirect references.

	PR fortran/90022
	* trans-decl.c (gfc_get_symbol_decl): Make sure that the se
	expression is a pointer type before converting it to the symbol
	backend_decl type.
	* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Eliminate
	temporary creation for intent(in).

2019-04-14  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/89843
	* gfortran.dg/ISO_Fortran_binding_4.f90: Modify the value of x
	in ctg. Test the conversion of the descriptor types in the main
	program.
	* gfortran.dg/ISO_Fortran_binding_10.f90: New test.
	* gfortran.dg/ISO_Fortran_binding_10.c: Called by it.

	PR fortran/89846
	* gfortran.dg/ISO_Fortran_binding_11.f90: New test.
	* gfortran.dg/ISO_Fortran_binding_11.c: Called by it.

	PR fortran/90022
	* gfortran.dg/ISO_Fortran_binding_1.c: Correct the indexing for
	the computation of 'ans'. Also, change the expected results for
	CFI_is_contiguous to comply with standard.
	* gfortran.dg/ISO_Fortran_binding_1.f90: Correct the expected
	results for CFI_is_contiguous to comply with standard.
	* gfortran.dg/ISO_Fortran_binding_9.f90: New test.
	* gfortran.dg/ISO_Fortran_binding_9.c: Called by it.

2019-04-14  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/89843
	* runtime/ISO_Fortran_binding.c (cfi_desc_to_gfc_desc): Only
	return immediately if the source pointer is null. Bring
	forward the extraction of the gfc type. Extract the kind so
	that the element size can be correctly computed for sections
	and components of derived type arrays. Remove the free of the
	CFI descriptor since this is now done in trans-expr.c.
	(gfc_desc_to_cfi_desc): Only allocate the CFI descriptor if it
	is not null.
	(CFI_section): Normalise the difference between the upper and
	lower bounds by the stride to correctly calculate the extents
	of the section.

	PR fortran/89846
	* runtime/ISO_Fortran_binding.c (cfi_desc_to_gfc_desc): Use
	the stride measure for the gfc span if it is not a multiple
	of the element length. Otherwise use the element length.

	PR fortran/90022
	* runtime/ISO_Fortran_binding.c (CFI_is_contiguous) : Return
	1 for true and 0 otherwise to comply with the standard. Correct
	the contiguity check for rank 3 and greater by using the stride
	measure of the lower dimension rather than the element length.

From-SVN: r270353
This commit is contained in:
Paul Thomas 2019-04-14 18:14:58 +00:00
parent 4d024c3269
commit 0d78e4aa06
20 changed files with 680 additions and 159 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
gcc/fortran/ChangeLog
View File

@ -1,3 +1,31 @@
2019-04-14 Paul Thomas <pault@gcc.gnu.org>
PR fortran/89843
* trans-decl.c (gfc_get_symbol_decl): Assumed shape and assumed
rank dummies of bind C procs require deferred initialization.
(convert_CFI_desc): New procedure to convert incoming CFI
descriptors to gfc types and back again.
(gfc_trans_deferred_vars): Call it.
* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Null the CFI
descriptor pointer. Free the descriptor in all cases.
PR fortran/89846
* expr.c (is_CFI_desc): New function.
(is_subref_array): Tidy up by referencing the symbol directly.
* gfortran.h : Prototype for is_CFI_desc.
* trans_array.c (get_CFI_desc): New function.
(gfc_get_array_span, gfc_conv_scalarized_array_ref,
gfc_conv_array_ref): Use it.
* trans.c (get_array_span): Extract the span from descriptors
that are indirect references.
PR fortran/90022
* trans-decl.c (gfc_get_symbol_decl): Make sure that the se
expression is a pointer type before converting it to the symbol
backend_decl type.
* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Eliminate
temporary creation for intent(in).
2019-04-13 Dominique d'Humieres <dominiq@gcc.gnu.org>
PR fortran/79842

34
gcc/fortran/expr.c
View File

@ -1061,6 +1061,27 @@ gfc_is_constant_expr (gfc_expr *e)
}
/* Is true if the expression or symbol is a passed CFI descriptor. */
bool
is_CFI_desc (gfc_symbol *sym, gfc_expr *e)
{
if (sym == NULL
&& e && e->expr_type == EXPR_VARIABLE)
sym = e->symtree->n.sym;
if (sym && sym->attr.dummy
&& sym->ns->proc_name->attr.is_bind_c
&& sym->attr.dimension
&& (sym->attr.pointer
|| sym->attr.allocatable
|| sym->as->type == AS_ASSUMED_SHAPE
|| sym->as->type == AS_ASSUMED_RANK))
return true;
return false;
}
/* Is true if an array reference is followed by a component or substring
reference. */
bool
@ -1068,11 +1089,14 @@ is_subref_array (gfc_expr * e)
{
gfc_ref * ref;
bool seen_array;
gfc_symbol *sym;
if (e->expr_type != EXPR_VARIABLE)
return false;
if (e->symtree->n.sym->attr.subref_array_pointer)
sym = e->symtree->n.sym;
if (sym->attr.subref_array_pointer)
return true;
seen_array = false;
@ -1097,10 +1121,10 @@ is_subref_array (gfc_expr * e)
return seen_array;
}
if (e->symtree->n.sym->ts.type == BT_CLASS
&& e->symtree->n.sym->attr.dummy
&& CLASS_DATA (e->symtree->n.sym)->attr.dimension
&& CLASS_DATA (e->symtree->n.sym)->attr.class_pointer)
if (sym->ts.type == BT_CLASS
&& sym->attr.dummy
&& CLASS_DATA (sym)->attr.dimension
&& CLASS_DATA (sym)->attr.class_pointer)
return true;
return false;

1
gcc/fortran/gfortran.h
View File

@ -3221,6 +3221,7 @@ gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
bool gfc_extract_int (gfc_expr *, int *, int = 0);
bool gfc_extract_hwi (gfc_expr *, HOST_WIDE_INT *, int = 0);
bool is_CFI_desc (gfc_symbol *, gfc_expr *);
bool is_subref_array (gfc_expr *);
bool gfc_is_simply_contiguous (gfc_expr *, bool, bool);
bool gfc_is_not_contiguous (gfc_expr *);

54
gcc/fortran/trans-array.c
View File

@ -849,6 +849,41 @@ is_pointer_array (tree expr)
}
/* If the symbol or expression reference a CFI descriptor, return the
pointer to the converted gfc descriptor. If an array reference is
present as the last argument, check that it is the one applied to
the CFI descriptor in the expression. Note that the CFI object is
always the symbol in the expression! */
static bool
get_CFI_desc (gfc_symbol *sym, gfc_expr *expr,
tree *desc, gfc_array_ref *ar)
{
tree tmp;
if (!is_CFI_desc (sym, expr))
return false;
if (expr && ar)
{
if (!(expr->ref && expr->ref->type == REF_ARRAY)
|| (&expr->ref->u.ar != ar))
return false;
}
if (sym == NULL)
tmp = expr->symtree->n.sym->backend_decl;
else
tmp = sym->backend_decl;
if (tmp && DECL_LANG_SPECIFIC (tmp))
tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
*desc = tmp;
return true;
}
/* Return the span of an array. */
tree
@ -856,9 +891,14 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
{
tree tmp;
if (is_pointer_array (desc))
/* This will have the span field set. */
tmp = gfc_conv_descriptor_span_get (desc);
if (is_pointer_array (desc) || get_CFI_desc (NULL, expr, &desc, NULL))
{
if (POINTER_TYPE_P (TREE_TYPE (desc)))
desc = build_fold_indirect_ref_loc (input_location, desc);
/* This will have the span field set. */
tmp = gfc_conv_descriptor_span_get (desc);
}
else if (TREE_CODE (desc) == COMPONENT_REF
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
&& GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0))))
@ -3466,6 +3506,12 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
if (build_class_array_ref (se, base, index))
return;
if (get_CFI_desc (NULL, expr, &decl, ar))
{
decl = build_fold_indirect_ref_loc (input_location, decl);
goto done;
}
if (expr && ((is_subref_array (expr)
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor)))
|| (expr->ts.deferred && (expr->expr_type == EXPR_VARIABLE
@ -3721,6 +3767,8 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
/* A pointer array component can be detected from its field decl. Fix
the descriptor, mark the resulting variable decl and pass it to
build_array_ref. */
if (get_CFI_desc (sym, expr, &decl, ar))
decl = build_fold_indirect_ref_loc (input_location, decl);
if (!expr->ts.deferred && !sym->attr.codimension
&& is_pointer_array (se->expr))
{

73
gcc/fortran/trans-decl.c
View File

@ -4268,6 +4268,72 @@ gfc_null_and_pass_deferred_len (gfc_symbol *sym, stmtblock_t *init,
}
/* Convert CFI descriptor dummies into gfc types and back again. */
static void
convert_CFI_desc (gfc_wrapped_block * block, gfc_symbol *sym)
{
tree gfc_desc;
tree gfc_desc_ptr;
tree CFI_desc;
tree CFI_desc_ptr;
tree dummy_ptr;
tree tmp;
tree incoming;
tree outgoing;
stmtblock_t tmpblock;
/* dummy_ptr will be the pointer to the passed array descriptor,
while CFI_desc is the descriptor itself. */
if (DECL_LANG_SPECIFIC (sym->backend_decl))
CFI_desc = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
else
CFI_desc = NULL;
dummy_ptr = CFI_desc;
if (CFI_desc)
{
CFI_desc = build_fold_indirect_ref_loc (input_location, CFI_desc);
/* The compiler will have given CFI_desc the correct gfortran
type. Use this new variable to store the converted
descriptor. */
gfc_desc = gfc_create_var (TREE_TYPE (CFI_desc), "gfc_desc");
tmp = build_pointer_type (TREE_TYPE (gfc_desc));
gfc_desc_ptr = gfc_create_var (tmp, "gfc_desc_ptr");
CFI_desc_ptr = gfc_create_var (pvoid_type_node, "CFI_desc_ptr");
gfc_init_block (&tmpblock);
/* Pointer to the gfc descriptor. */
gfc_add_modify (&tmpblock, gfc_desc_ptr,
gfc_build_addr_expr (NULL, gfc_desc));
/* Store the pointer to the CFI descriptor. */
gfc_add_modify (&tmpblock, CFI_desc_ptr,
fold_convert (pvoid_type_node, dummy_ptr));
tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr);
/* Convert the CFI descriptor. */
incoming = build_call_expr_loc (input_location,
gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp);
gfc_add_expr_to_block (&tmpblock, incoming);
/* Set the dummy pointer to point to the gfc_descriptor. */
gfc_add_modify (&tmpblock, dummy_ptr,
fold_convert (TREE_TYPE (dummy_ptr), gfc_desc_ptr));
incoming = gfc_finish_block (&tmpblock);
gfc_init_block (&tmpblock);
/* Convert the gfc descriptor back to the CFI type before going
out of scope. */
tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr);
outgoing = build_call_expr_loc (input_location,
gfor_fndecl_gfc_to_cfi, 2, tmp, gfc_desc_ptr);
gfc_add_expr_to_block (&tmpblock, outgoing);
outgoing = gfc_finish_block (&tmpblock);
/* Add the lot to the procedure init and finally blocks. */
gfc_add_init_cleanup (block, incoming, outgoing);
}
}
/* Get the result expression for a procedure. */
static tree
@ -4844,6 +4910,13 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
}
else if (!(UNLIMITED_POLY(sym)) && !is_pdt_type)
gcc_unreachable ();
/* Assumed shape and assumed rank arrays are passed to BIND(C) procedures
as ISO Fortran Interop descriptors. These have to be converted to
gfortran descriptors and back again. This has to be done here so that
the conversion occurs at the start of the init block. */
if (is_CFI_desc (sym, NULL))
convert_CFI_desc (block, sym);
}
gfc_init_block (&tmpblock);

95
gcc/fortran/trans-expr.c
View File

@ -4987,11 +4987,11 @@ 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 ptr = NULL_TREE;
tree size;
tree type;
tree cond;
int attribute;
symbol_attribute attr = gfc_expr_attr (e);
stmtblock_t block;
/* If this is a full array or a scalar, the allocatable and pointer
attributes can be passed. Otherwise it is 'CFI_attribute_other'*/
@ -5056,37 +5056,6 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
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);
/* The temporary 'ptr' is freed below. */
gfc_conv_descriptor_data_set (&parmse->pre, parmse->expr, ptr);
}
}
else
{
@ -5096,28 +5065,6 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
parmse->expr = build_fold_indirect_ref_loc (input_location,
parmse->expr);
/* Copy the scalar for INTENT(IN). */
if (e->expr_type == EXPR_VARIABLE && fsym->attr.intent == INTENT_IN)
{
if (e->ts.type != BT_CHARACTER)
parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
else
{
/* The temporary string 'ptr' is freed below. */
tmp = build_pointer_type (TREE_TYPE (parmse->expr));
ptr = gfc_create_var (tmp, "str");
tmp = build_call_expr_loc (input_location,
builtin_decl_explicit (BUILT_IN_MALLOC),
1, parmse->string_length);
tmp = fold_convert (TREE_TYPE (ptr), tmp);
gfc_add_modify (&parmse->pre, ptr, tmp);
tmp = gfc_build_memcpy_call (ptr, parmse->expr,
parmse->string_length);
gfc_add_expr_to_block (&parmse->pre, tmp);
parmse->expr = ptr;
}
}
parmse->expr = gfc_conv_scalar_to_descriptor (parmse,
parmse->expr, attr);
}
@ -5135,6 +5082,8 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
/* Variables to point to the gfc and CFI descriptors. */
gfc_desc_ptr = parmse->expr;
cfi_desc_ptr = gfc_create_var (pvoid_type_node, "cfi");
gfc_add_modify (&parmse->pre, cfi_desc_ptr,
build_int_cst (pvoid_type_node, 0));
/* Allocate the CFI descriptor and fill the fields. */
tmp = gfc_build_addr_expr (NULL_TREE, cfi_desc_ptr);
@ -5145,18 +5094,19 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
/* 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;
}
/* Free the CFI descriptor. */
gfc_init_block (&block);
cond = fold_build2_loc (input_location, NE_EXPR,
logical_type_node, cfi_desc_ptr,
build_int_cst (TREE_TYPE (cfi_desc_ptr), 0));
tmp = gfc_call_free (cfi_desc_ptr);
gfc_add_expr_to_block (&block, tmp);
tmp = build3_v (COND_EXPR, cond,
gfc_finish_block (&block),
build_empty_stmt (input_location));
gfc_prepend_expr_to_block (&parmse->post, tmp);
/* Transfer values back to gfc descriptor and free the CFI descriptor. */
/* Transfer values back to gfc 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);
@ -5516,11 +5466,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
else if (sym->attr.is_bind_c && e
&& ((fsym && fsym->attr.dimension
&& (fsym->attr.pointer
|| fsym->attr.allocatable
|| fsym->as->type == AS_ASSUMED_RANK
|| fsym->as->type == AS_ASSUMED_SHAPE))
&& (is_CFI_desc (fsym, NULL)
|| non_unity_length_string))
/* Implement F2018, C.12.6.1: paragraph (2). */
gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
@ -5965,12 +5911,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
if (sym->attr.is_bind_c && e
&& fsym && fsym->attr.dimension
&& (fsym->attr.pointer
|| fsym->attr.allocatable
|| fsym->as->type == AS_ASSUMED_RANK
|| fsym->as->type == AS_ASSUMED_SHAPE
|| non_unity_length_string))
&& (is_CFI_desc (fsym, NULL) || non_unity_length_string))
/* Implement F2018, C.12.6.1: paragraph (2). */
gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);

3
gcc/fortran/trans.c
View File

@ -352,6 +352,9 @@ get_array_span (tree type, tree decl)
else
span = NULL_TREE;
}
else if (TREE_CODE (decl) == INDIRECT_REF
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
span = gfc_conv_descriptor_span_get (decl);
else
span = NULL_TREE;

22
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,25 @@
2019-04-14 Paul Thomas <pault@gcc.gnu.org>
PR fortran/89843
* gfortran.dg/ISO_Fortran_binding_4.f90: Modify the value of x
in ctg. Test the conversion of the descriptor types in the main
program.
* gfortran.dg/ISO_Fortran_binding_10.f90: New test.
* gfortran.dg/ISO_Fortran_binding_10.c: Called by it.
PR fortran/89846
* gfortran.dg/ISO_Fortran_binding_11.f90: New test.
* gfortran.dg/ISO_Fortran_binding_11.c: Called by it.
PR fortran/90022
* gfortran.dg/ISO_Fortran_binding_1.c: Correct the indexing for
the computation of 'ans'. Also, change the expected results for
CFI_is_contiguous to comply with standard.
* gfortran.dg/ISO_Fortran_binding_1.f90: Correct the expected
results for CFI_is_contiguous to comply with standard.
* gfortran.dg/ISO_Fortran_binding_9.f90: New test.
* gfortran.dg/ISO_Fortran_binding_9.c: Called by it.
2019-04-13 Jakub Jelinek <jakub@redhat.com>
PR target/89093

22
gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c
View File

@ -105,7 +105,7 @@ 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;
int ind;
float *ret_addr;
float ans = 0.0;
@ -121,9 +121,7 @@ float section_c(int *std_case, CFI_cdesc_t * source, int *low, int *str)
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]++)
for (idx[0] = 0; idx[0] < section.dim[0].extent; idx[0]++)
ans += *(float*)CFI_address ((CFI_cdesc_t*)&section, idx);
return ans;
}
@ -143,9 +141,7 @@ float section_c(int *std_case, CFI_cdesc_t * source, int *low, int *str)
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]++)
for (idx[0] = 0; idx[0] < section.dim[0].extent; idx[0]++)
ans += *(float*)CFI_address ((CFI_cdesc_t*)&section, idx);
return ans;
}
@ -191,15 +187,15 @@ int setpointer_c(CFI_cdesc_t * ptr, int lbounds[])
int assumed_size_c(CFI_cdesc_t * desc)
{
int ierr;
int res;
ierr = CFI_is_contiguous(desc);
if (ierr)
res = CFI_is_contiguous(desc);
if (!res)
return 1;
if (desc->rank)
ierr = 2 * (desc->dim[desc->rank-1].extent
res = 2 * (desc->dim[desc->rank-1].extent
!= (CFI_index_t)(long long)(-1));
else
ierr = 3;
return ierr;
res = 3;
return res;
}

14
gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90
View File

@ -170,16 +170,16 @@ end subroutine test_CFI_address
integer, dimension (2,*) :: arg
character(4), dimension(2) :: chr
! These are contiguous
if (c_contiguous (arg) .ne. 0) stop 20
if (c_contiguous (arg) .ne. 1) stop 20
if (.not.allocated (x)) allocate (x(2, 2))
if (c_contiguous (x) .ne. 0) stop 22
if (c_contiguous (x) .ne. 1) stop 22
deallocate (x)
if (c_contiguous (chr) .ne. 0) stop 23
if (c_contiguous (chr) .ne. 1) 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
if (c_contiguous (der%i) .eq. 1) stop 24
if (c_contiguous (arg(1:1,1:2)) .eq. 1) stop 25
if (c_contiguous (d(4:2:-2, 1:3:2)) .eq. 1) stop 26
if (c_contiguous (chr(:)(2:3)) .eq. 1) stop 27
end subroutine test_CFI_contiguous
subroutine test_CFI_section (arg)

73
gcc/testsuite/gfortran.dg/ISO_Fortran_binding_10.c Normal file
View File

@ -0,0 +1,73 @@
/* Test the fix of PR89843. */
/* Contributed by Reinhold Bader <Bader@lrz.de> */
#include "../../../libgfortran/ISO_Fortran_binding.h"
#include <stdlib.h>
#include <stdio.h>
#include <stdbool.h>
void sa(CFI_cdesc_t *, int, int *);
void si(CFI_cdesc_t *this, int flag, int *status)
{
int value, sum;
bool err;
CFI_CDESC_T(1) that;
CFI_index_t lb[] = { 0, 0 };
CFI_index_t ub[] = { 4, 1 };
CFI_index_t st[] = { 2, 0 };
int chksum[] = { 9, 36, 38 };
if (flag == 1)
{
lb[0] = 0; lb[1] = 2;
ub[0] = 2; ub[1] = 2;
st[0] = 1; st[1] = 0;
}
else if (flag == 2)
{
lb[0] = 1; lb[1] = 0;
ub[0] = 1; ub[1] = 3;
st[0] = 0; st[1] = 1;
}
CFI_establish((CFI_cdesc_t *) &that, NULL, CFI_attribute_other,
CFI_type_float, 0, 1, NULL);
*status = CFI_section((CFI_cdesc_t *) &that, this, lb, ub, st);
if (*status != CFI_SUCCESS)
{
printf("FAIL C: status is %i\n",status);
return;
}
value = CFI_is_contiguous((CFI_cdesc_t *) &that);
err = ((flag == 0 && value != 0)
|| (flag == 1 && value != 1)
|| (flag == 2 && value != 0));
if (err)
{
printf("FAIL C: contiguity for flag value %i - is %i\n",flag, value);
*status = 10;
return;
}
sum = 0;
for (int i = 0; i < that.dim[0].extent; i++)
{
CFI_index_t idx[] = {i};
sum += (int)(*(float *)CFI_address ((CFI_cdesc_t *)&that, idx));
}
if (sum != chksum[flag])
{
printf ("FAIL C: check sum = %d(%d)\n", sum, chksum[flag]);
*status = 11;
return;
}
sa((CFI_cdesc_t *) &that, flag, status);
}

99
gcc/testsuite/gfortran.dg/ISO_Fortran_binding_10.f90 Normal file
View File

@ -0,0 +1,99 @@
! { dg-do run { target c99_runtime } }
! { dg-additional-sources ISO_Fortran_binding_10.c }
!
! Test the fix of PR89843.
!
! Contributed by Reinhold Bader <Bader@lrz.de>
!
module mod_section_01
use, intrinsic :: iso_c_binding
implicit none
interface
subroutine si(this, flag, status) bind(c)
import :: c_float, c_int
real(c_float) :: this(:,:)
integer(c_int), value :: flag
integer(c_int) :: status
end subroutine si
end interface
contains
subroutine sa(this, flag, status) bind(c)
real(c_float) :: this(:)
integer(c_int), value :: flag
integer(c_int) :: status
status = 0
select case (flag)
case (0)
if (is_contiguous(this)) then
write(*,*) 'FAIL 1:'
status = status + 1
end if
if (size(this,1) /= 3) then
write(*,*) 'FAIL 2:',size(this)
status = status + 1
goto 10
end if
if (maxval(abs(this - [ 1.0, 3.0, 5.0 ])) > 1.0e-6) then
write(*,*) 'FAIL 3:',abs(this)
status = status + 1
end if
10 continue
case (1)
if (size(this,1) /= 3) then
write(*,*) 'FAIL 4:',size(this)
status = status + 1
goto 20
end if
if (maxval(abs(this - [ 11.0, 12.0, 13.0 ])) > 1.0e-6) then
write(*,*) 'FAIL 5:',this
status = status + 1
end if
20 continue
case (2)
if (size(this,1) /= 4) then
write(*,*) 'FAIL 6:',size(this)
status = status + 1
goto 30
end if
if (maxval(abs(this - [ 2.0, 7.0, 12.0, 17.0 ])) > 1.0e-6) then
write(*,*) 'FAIL 7:',this
status = status + 1
end if
30 continue
end select
! if (status == 0) then
! write(*,*) 'OK'
! end if
end subroutine sa
end module mod_section_01
program section_01
use mod_section_01
implicit none
real(c_float) :: v(5,4)
integer :: i
integer :: status
v = reshape( [ (real(i), i = 1, 20) ], [ 5, 4 ] )
call si(v, 0, status)
if (status .ne. 0) stop 1
call sa(v(1:5:2, 1), 0, status)
if (status .ne. 0) stop 2
call si(v, 1, status)
if (status .ne. 0) stop 3
call sa(v(1:3, 3), 1, status)
if (status .ne. 0) stop 4
call si(v, 2, status)
if (status .ne. 0) stop 5
call sa(v(2,1:4), 2, status)
if (status .ne. 0) stop 6
end program section_01

78
gcc/testsuite/gfortran.dg/ISO_Fortran_binding_11.c Normal file
View File

@ -0,0 +1,78 @@
/* Test the fix of PR89846.
Contributed by Reinhold Bader <Bader@lrz.de>#include <stdio.h> */
#include <stdlib.h>
#include <stddef.h>
#include <stdio.h>
#include "../../../libgfortran/ISO_Fortran_binding.h"
typedef struct
{
char n;
float r[2];
} t1;
typedef struct
{
long int i;
t1 t1;
} t2;
void ta0(CFI_cdesc_t *);
void ta1(CFI_cdesc_t *);
void ti(CFI_cdesc_t *this, int flag)
{
int status;
size_t dis;
CFI_CDESC_T(1) that;
t1 *ans;
switch (flag)
{
case 0:
dis = offsetof(t2, t1);
status = CFI_establish((CFI_cdesc_t *) &that, NULL, CFI_attribute_other,
CFI_type_struct, sizeof(t1), 1, NULL);
if (status != CFI_SUCCESS)
{
printf("FAIL 1 establish: nonzero status %i\n",status);
exit(1);
}
status = CFI_select_part((CFI_cdesc_t *) &that, this, dis, 0);
if (status != CFI_SUCCESS)
{
printf("FAIL C1: nonzero status %i\n",status);
exit(1);
}
break;
case 1:
dis = offsetof(t2, i);
status = CFI_establish((CFI_cdesc_t *) &that, NULL, CFI_attribute_other,
CFI_type_long, 0, 1, NULL);
if (status != CFI_SUCCESS)
{
printf("FAIL 2 establish: nonzero status %i\n",status);
exit(1);
}
status = CFI_select_part((CFI_cdesc_t *) &that, this, dis, 0);
if (status != CFI_SUCCESS)
{
printf("FAIL C2: nonzero status %i\n",status);
exit(1);
}
}
if (CFI_is_contiguous((CFI_cdesc_t *) &that))
{
printf("FAIL C: contiguity for flag value %i - is %i\n",flag,
CFI_is_contiguous((CFI_cdesc_t *) &that));
}
if (flag == 0) ta0((CFI_cdesc_t *) &that);
if (flag == 1) ta1((CFI_cdesc_t *) &that);
}

81
gcc/testsuite/gfortran.dg/ISO_Fortran_binding_11.f90 Normal file
View File

@ -0,0 +1,81 @@
! { dg-do run { target c99_runtime } }
! { dg-additional-sources ISO_Fortran_binding_11.c }
!
! Test the fix of PR89846.
!
! Contributed by Reinhold Bader <Bader@lrz.de>
!
module mod_subobj_01
use, intrinsic :: iso_c_binding
implicit none
integer, parameter :: nelem = 5
type, bind(c) :: t1
character(c_char) :: n
real(c_float) :: r(2)
end type t1
type, bind(c) :: t2
integer(c_long) :: i
type(t1) :: t1
end type t2
interface
subroutine ti(this, flag) bind(c)
import :: t2, c_int
type(t2) :: this(:)
integer(c_int), value :: flag
end subroutine ti
end interface
contains
subroutine ta0(this) bind(c)
type(t1) :: this(:)
integer :: i, iw, status
status = 0
if (size(this) /= nelem) then
write(*,*) 'FAIL 1: ',size(this)
status = status + 1
end if
iw = 0
do i=1, nelem
if (this(i)%n /= char(i,c_char) .or. this(i)%r(1) /= real(i,c_float) .or. &
this(i)%r(2) /= real(i+1,c_float)) then
iw = iw + 1
end if
end do
if (iw > 0) then
write(*,*) 'FAIL 2: ' ,this
status = status + 1
end if
if (status /= 0) stop 1
end subroutine ta0
subroutine ta1(this) bind(c)
integer(c_long) :: this(:)
integer :: i, status
status = 0
if (size(this) /= nelem) then
write(*,*) 'FAIL 3: ',size(this)
status = status + 1
end if
if (maxval(abs(this - [ (int(i,c_long),i=1,nelem) ])) > 0) then
write(*,*) 'FAIL 4: ' ,this
status = status + 1
end if
if (status /= 0) stop 2
end subroutine ta1
end module mod_subobj_01
program subobj_01
use mod_subobj_01
implicit none
integer :: i
type(t2), allocatable :: o_t2(:)
allocate(o_t2(nelem))
do i=1, nelem
o_t2(i)%t1 = t1( char(i,c_char), [ real(i,c_float), real(i+1,c_float) ] )
o_t2(i)%i = int(i,c_long)
end do
call ti(o_t2,0)
call ti(o_t2,1)
end program subobj_01

25
gcc/testsuite/gfortran.dg/ISO_Fortran_binding_3.f90
View File

@ -7,35 +7,14 @@
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
@ -49,5 +28,5 @@ contains
err = test_c (arg) ! This used to ICE
end function test2
end function test1
end

4
gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90
View File

@ -10,9 +10,11 @@ contains
if (any(abs(x - [2.,4.,6.]) > 1.e-6)) then
write(*,*) 'FAIL'
stop 1
else
write(*,*) 'OK'
end if
x = [2.,4.,6.]*10.0
end subroutine
end module
program p
@ -23,5 +25,5 @@ program p
x = [ (real(i), i=1, size(x)) ]
call ctg(x(2::2))
if (any (abs (x - [1.,20.,3.,40.,5.,60.]) > 1.e-6)) stop 2
end program

14
gcc/testsuite/gfortran.dg/ISO_Fortran_binding_9.c Normal file
View File

@ -0,0 +1,14 @@
/* Test fix of a problem with CFI_is_contiguous. */
/* Contributed by Gilles Gouaillardet <gilles@rist.or.jp> */
#include "../../../libgfortran/ISO_Fortran_binding.h"
#include <stdlib.h>
int cdesc_c(CFI_cdesc_t* x, long *expected)
{
int res;
res = CFI_is_contiguous (x);
if (x->base_addr != (void *)*expected) res = 0;
return res;
}

28
gcc/testsuite/gfortran.dg/ISO_Fortran_binding_9.f90 Normal file
View File

@ -0,0 +1,28 @@
! { dg-do run { target c99_runtime } }
! { dg-additional-sources ISO_Fortran_binding_9.c }
!
! Fix a problem with CFI_is_contiguous
!
! Contributed by Gilles Gouaillardet <gilles@rist.or.jp>
!
module cdesc
interface
function cdesc_f08(buf, expected) result (res) BIND(C, name="cdesc_c")
USE, INTRINSIC :: ISO_C_BINDING
implicit none
INTEGER(C_INT) :: res
type(*), dimension(..), INTENT(IN) :: buf
integer(kind=kind(loc(res))),INTENT(IN) :: expected
end function cdesc_f08
end interface
end module
program cdesc_test
use cdesc
implicit none
integer :: a0, a1(10), a2(10,10), a3(10,10,10)
if (cdesc_f08(a0, LOC(a0)) .ne. 1) stop 1
if (cdesc_f08(a1, LOC(a1(1))) .ne. 1) stop 2
if (cdesc_f08(a2, LOC(a2(1,1))) .ne. 1) stop 3
if (cdesc_f08(a3, LOC(a3(1,1,1))) .ne. 1) stop 4
end program

26
libgfortran/ChangeLog
View File

@ -1,3 +1,29 @@
2019-04-14 Paul Thomas <pault@gcc.gnu.org>
PR fortran/89843
* runtime/ISO_Fortran_binding.c (cfi_desc_to_gfc_desc): Only
return immediately if the source pointer is null. Bring
forward the extraction of the gfc type. Extract the kind so
that the element size can be correctly computed for sections
and components of derived type arrays. Remove the free of the
CFI descriptor since this is now done in trans-expr.c.
(gfc_desc_to_cfi_desc): Only allocate the CFI descriptor if it
is not null.
(CFI_section): Normalise the difference between the upper and
lower bounds by the stride to correctly calculate the extents
of the section.
PR fortran/89846
* runtime/ISO_Fortran_binding.c (cfi_desc_to_gfc_desc): Use
the stride measure for the gfc span if it is not a multiple
of the element length. Otherwise use the element length.
PR fortran/90022
* runtime/ISO_Fortran_binding.c (CFI_is_contiguous) : Return
1 for true and 0 otherwise to comply with the standard. Correct
the contiguity check for rank 3 and greater by using the stride
measure of the lower dimension rather than the element length.
2019-03-25 John David Anglin <danglin@gcc.gnu.org>
PR libgfortran/79540

65
libgfortran/runtime/ISO_Fortran_binding.c
View File

@ -37,23 +37,15 @@ void
cfi_desc_to_gfc_desc (gfc_array_void *d, CFI_cdesc_t **s_ptr)
{
int n;
index_type kind;
CFI_cdesc_t *s = *s_ptr;
/* If not a full pointer or allocatable array free the descriptor
and return. */
if (!s || s->attribute == CFI_attribute_other)
goto finish;
if (!s)
return;
GFC_DESCRIPTOR_DATA (d) = s->base_addr;
if (!s->rank || s->dim[0].sm == (CFI_index_t)s->elem_len)
GFC_DESCRIPTOR_SIZE (d) = s->elem_len;
else
GFC_DESCRIPTOR_SIZE (d) = (index_type)s->dim[0].sm;
d->dtype.version = s->version;
GFC_DESCRIPTOR_RANK (d) = (signed char)s->rank;
GFC_DESCRIPTOR_TYPE (d) = (signed char)(s->type & CFI_type_mask);
kind = (index_type)((s->type - (s->type & CFI_type_mask)) >> CFI_type_kind_shift);
/* Correct the unfortunate difference in order with types. */
if (GFC_DESCRIPTOR_TYPE (d) == BT_CHARACTER)
@ -61,12 +53,26 @@ cfi_desc_to_gfc_desc (gfc_array_void *d, CFI_cdesc_t **s_ptr)
else if (GFC_DESCRIPTOR_TYPE (d) == BT_DERIVED)
GFC_DESCRIPTOR_TYPE (d) = BT_CHARACTER;
if (!s->rank || s->dim[0].sm == (CFI_index_t)s->elem_len)
GFC_DESCRIPTOR_SIZE (d) = s->elem_len;
else if (GFC_DESCRIPTOR_TYPE (d) != BT_DERIVED)
GFC_DESCRIPTOR_SIZE (d) = kind;
else
GFC_DESCRIPTOR_SIZE (d) = s->elem_len;
d->dtype.version = s->version;
GFC_DESCRIPTOR_RANK (d) = (signed char)s->rank;
d->dtype.attribute = (signed short)s->attribute;
if (s->rank)
d->span = (index_type)s->dim[0].sm;
{
if ((size_t)s->dim[0].sm % s->elem_len)
d->span = (index_type)s->dim[0].sm;
else
d->span = (index_type)s->elem_len;
}
/* On the other hand, CFI_establish can change the bounds. */
d->offset = 0;
for (n = 0; n < GFC_DESCRIPTOR_RANK (d); n++)
{
@ -76,11 +82,6 @@ cfi_desc_to_gfc_desc (gfc_array_void *d, CFI_cdesc_t **s_ptr)
GFC_DESCRIPTOR_STRIDE(d, n) = (index_type)(s->dim[n].sm / s->elem_len);
d->offset -= GFC_DESCRIPTOR_STRIDE(d, n) * GFC_DESCRIPTOR_LBOUND(d, n);
}
finish:
if (s)
free (s);
s = NULL;
}
extern void gfc_desc_to_cfi_desc (CFI_cdesc_t **, const gfc_array_void *);
@ -95,8 +96,11 @@ gfc_desc_to_cfi_desc (CFI_cdesc_t **d_ptr, const gfc_array_void *s)
/* Play it safe with allocation of the flexible array member 'dim'
by setting the length to CFI_MAX_RANK. This should not be necessary
but valgrind complains accesses after the allocated block. */
d = malloc (sizeof (CFI_cdesc_t)
if (*d_ptr == NULL)
d = malloc (sizeof (CFI_cdesc_t)
+ (CFI_type_t)(CFI_MAX_RANK * sizeof (CFI_dim_t)));
else
d = *d_ptr;
d->base_addr = GFC_DESCRIPTOR_DATA (s);
d->elem_len = GFC_DESCRIPTOR_SIZE (s);
@ -115,7 +119,7 @@ gfc_desc_to_cfi_desc (CFI_cdesc_t **d_ptr, const gfc_array_void *s)
d->type = (CFI_type_t)(d->type
+ ((CFI_type_t)d->elem_len << CFI_type_kind_shift));
/* Full pointer or allocatable arrays have zero lower_bound. */
/* Full pointer or allocatable arrays retain their lower_bounds. */
for (n = 0; n < GFC_DESCRIPTOR_RANK (s); n++)
{
if (d->attribute != CFI_attribute_other)
@ -134,7 +138,8 @@ gfc_desc_to_cfi_desc (CFI_cdesc_t **d_ptr, const gfc_array_void *s)
d->dim[n].sm = (CFI_index_t)(GFC_DESCRIPTOR_STRIDE(s, n) * s->span);
}
*d_ptr = d;
if (*d_ptr == NULL)
*d_ptr = d;
}
void *CFI_address (const CFI_cdesc_t *dv, const CFI_index_t subscripts[])
@ -416,7 +421,7 @@ int CFI_is_contiguous (const CFI_cdesc_t *dv)
if (dv == NULL)
{
fprintf (stderr, "CFI_is_contiguous: C descriptor is NULL.\n");
return CFI_INVALID_DESCRIPTOR;
return 0;
}
/* Base address must not be NULL. */
@ -424,7 +429,7 @@ int CFI_is_contiguous (const CFI_cdesc_t *dv)
{
fprintf (stderr, "CFI_is_contiguous: Base address of C Descriptor "
"is already NULL.\n");
return CFI_ERROR_BASE_ADDR_NULL;
return 0;
}
/* Must be an array. */
@ -432,13 +437,13 @@ int CFI_is_contiguous (const CFI_cdesc_t *dv)
{
fprintf (stderr, "CFI_is_contiguous: C Descriptor must describe an "
"array (0 < dv->rank = %d).\n", dv->rank);
return CFI_INVALID_RANK;
return 0;
}
}
/* Assumed size arrays are always contiguous. */
if (dv->rank > 0 && dv->dim[dv->rank - 1].extent == -1)
return CFI_SUCCESS;
return 1;
/* If an array is not contiguous the memory stride is different to the element
* length. */
@ -447,15 +452,15 @@ int CFI_is_contiguous (const CFI_cdesc_t *dv)
if (i == 0 && dv->dim[i].sm == (CFI_index_t)dv->elem_len)
continue;
else if (i > 0
&& dv->dim[i].sm == (CFI_index_t)(dv->elem_len
&& dv->dim[i].sm == (CFI_index_t)(dv->dim[i - 1].sm
* dv->dim[i - 1].extent))
continue;
return CFI_FAILURE;
return 0;
}
/* Array sections are guaranteed to be contiguous by the previous test. */
return CFI_SUCCESS;
return 1;
}
@ -670,7 +675,7 @@ int CFI_section (CFI_cdesc_t *result, const CFI_cdesc_t *source,
}
int idx = i - aux;
result->dim[idx].lower_bound = lower[i];
result->dim[idx].extent = upper[i] - lower[i] + 1;
result->dim[idx].extent = 1 + (upper[i] - lower[i])/stride[i];
result->dim[idx].sm = stride[i] * source->dim[i].sm;
/* Adjust 'lower' for the base address offset. */
lower[idx] = lower[idx] - source->dim[i].lower_bound;