From: Paul Thomas Date: Sun, 14 Apr 2019 18:14:58 +0000 (+0000) Subject: re PR fortran/89843 (CFI_section delivers incorrect result descriptor) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=0d78e4aa06db041ef895c7153c1380baff53e434;p=gcc.git re PR fortran/89843 (CFI_section delivers incorrect result descriptor) 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-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-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. From-SVN: r270353 --- 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) + ier = test1 (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;