diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index ef6200c6519..e27743cac28 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,31 @@ +2019-04-14 Paul Thomas + + 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 PR fortran/79842 diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 3b46b4e802e..474e9ecc401 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -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; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index be975cda074..23d01b10728 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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 *); diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 2bc24d95775..55879af9730 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -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)) { diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index ada6370899a..a0e1f6aeea5 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -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); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 434c9898d89..21535acb989 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 29a4d006740..022ceb9e197 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 1f3dd43cb88..4ede1de27cf 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,25 @@ +2019-04-14 Paul Thomas + + 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 PR target/89093 diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c index d3eb9a4938a..a6353c7cca6 100644 --- a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c @@ -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*)§ion, 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*)§ion, 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; } diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 index d3a7b2b34c2..102bc60310c 100644 --- a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 @@ -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) diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_10.c b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_10.c new file mode 100644 index 00000000000..adda3b3c18a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_10.c @@ -0,0 +1,73 @@ +/* Test the fix of PR89843. */ + +/* Contributed by Reinhold Bader */ + +#include "../../../libgfortran/ISO_Fortran_binding.h" +#include +#include +#include + +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); +} diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_10.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_10.f90 new file mode 100644 index 00000000000..602d8f78217 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_10.f90 @@ -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 +! +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 diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_11.c b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_11.c new file mode 100644 index 00000000000..ac176901bf2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_11.c @@ -0,0 +1,78 @@ +/* Test the fix of PR89846. + +Contributed by Reinhold Bader #include */ + +#include +#include +#include +#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); +} diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_11.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_11.f90 new file mode 100644 index 00000000000..e509425d9d2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_11.f90 @@ -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 +! +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 + diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_3.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_3.f90 index c4cdbf0e74d..20a1e19a1d3 100644 --- a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_3.f90 +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_3.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90 index 2c6c81b2557..09410b71601 100644 --- a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90 +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_9.c b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_9.c new file mode 100644 index 00000000000..cb5b91dc79b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_9.c @@ -0,0 +1,14 @@ +/* Test fix of a problem with CFI_is_contiguous. */ + +/* Contributed by Gilles Gouaillardet */ + +#include "../../../libgfortran/ISO_Fortran_binding.h" +#include + +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; +} \ No newline at end of file diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_9.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_9.f90 new file mode 100644 index 00000000000..def51165d5f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_9.f90 @@ -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 +! +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 diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 7e741b3b502..80a37fb28eb 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,29 @@ +2019-04-14 Paul Thomas + + 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 PR libgfortran/79540 diff --git a/libgfortran/runtime/ISO_Fortran_binding.c b/libgfortran/runtime/ISO_Fortran_binding.c index 6b7b10fb836..695ef57ac32 100644 --- a/libgfortran/runtime/ISO_Fortran_binding.c +++ b/libgfortran/runtime/ISO_Fortran_binding.c @@ -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;