From: Paul Thomas Date: Fri, 10 May 2019 07:59:42 +0000 (+0000) Subject: re PR fortran/90093 (Extended C interop: optional argument incorrectly identified... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=0a52429609a9570149af903c231c25f17da79b15;p=gcc.git re PR fortran/90093 (Extended C interop: optional argument incorrectly identified as PRESENT) 2019-05-10 Paul Thomas PR fortran/90093 * trans-decl.c (convert_CFI_desc): Test that the dummy is present before doing any of the conversions. PR fortran/90352 * decl.c (gfc_verify_c_interop_param): Restore the error for charlen > 1 actual arguments passed to bind(C) procs. Clean up trailing white space. PR fortran/90355 * trans-array.c (gfc_trans_create_temp_array): Set the 'span' field to the element length for all types. (gfc_conv_expr_descriptor): The force_no_tmp flag is used to prevent temporary creation, especially for substrings. * trans-decl.c (gfc_trans_deferred_vars): Rather than assert that the backend decl for the string length is non-null, use it as a condition before calling gfc_trans_vla_type_sizes. * trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): 'force_no_tmp' is set before calling gfc_conv_expr_descriptor. * trans.c (get_array_span): Move the code for extracting 'span' from gfc_build_array_ref to this function. This is specific to descriptors that are component and indirect references. * trans.h : Add the force_no_tmp flag bitfield to gfc_se. 2019-05-10 Paul Thomas PR fortran/90093 * gfortran.dg/ISO_Fortran_binding_12.f90: New test. * gfortran.dg/ISO_Fortran_binding_12.c: Supplementary code. PR fortran/90352 * gfortran.dg/iso_c_binding_char_1.f90: New test. PR fortran/90355 * gfortran.dg/ISO_Fortran_binding_4.f90: Add 'substr' to test the direct passing of substrings as descriptors to bind(C). * gfortran.dg/assign_10.f90: Increase the tree_dump count of 'atmp' to account for the setting of the 'span' field. * gfortran.dg/transpose_optimization_2.f90: Ditto. From-SVN: r271057 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index c910af439cf..cd73dd2971c 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,29 @@ +2019-05-10 Paul Thomas + + PR fortran/90093 + * trans-decl.c (convert_CFI_desc): Test that the dummy is + present before doing any of the conversions. + + PR fortran/90352 + * decl.c (gfc_verify_c_interop_param): Restore the error for + charlen > 1 actual arguments passed to bind(C) procs. + Clean up trailing white space. + + PR fortran/90355 + * trans-array.c (gfc_trans_create_temp_array): Set the 'span' + field to the element length for all types. + (gfc_conv_expr_descriptor): The force_no_tmp flag is used to + prevent temporary creation, especially for substrings. + * trans-decl.c (gfc_trans_deferred_vars): Rather than assert + that the backend decl for the string length is non-null, use it + as a condition before calling gfc_trans_vla_type_sizes. + * trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): 'force_no_tmp' + is set before calling gfc_conv_expr_descriptor. + * trans.c (get_array_span): Move the code for extracting 'span' + from gfc_build_array_ref to this function. This is specific to + descriptors that are component and indirect references. + * trans.h : Add the force_no_tmp flag bitfield to gfc_se. + 2019-05-08 Thomas Koenig PR fortran/90351 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 66f1094aa3d..1c785a4f74c 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -406,7 +406,7 @@ match_data_constant (gfc_expr **result) contains the right constant expression. Check here. */ if ((*result)->symtree == NULL && (*result)->expr_type == EXPR_CONSTANT - && ((*result)->ts.type == BT_INTEGER + && ((*result)->ts.type == BT_INTEGER || (*result)->ts.type == BT_REAL)) return m; @@ -1493,19 +1493,18 @@ gfc_verify_c_interop_param (gfc_symbol *sym) /* Character strings are only C interoperable if they have a length of 1. */ - if (sym->ts.type == BT_CHARACTER) + if (sym->ts.type == BT_CHARACTER && !sym->attr.dimension) { gfc_charlen *cl = sym->ts.u.cl; if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT || mpz_cmp_si (cl->length->value.integer, 1) != 0) { - if (!gfc_notify_std (GFC_STD_F2018, - "Character argument %qs at %L " - "must be length 1 because " - "procedure %qs is BIND(C)", - sym->name, &sym->declared_at, - sym->ns->proc_name->name)) - retval = false; + gfc_error ("Character argument %qs at %L " + "must be length 1 because " + "procedure %qs is BIND(C)", + sym->name, &sym->declared_at, + sym->ns->proc_name->name); + retval = false; } } @@ -6074,7 +6073,7 @@ static bool in_module_or_interface(void) { if (gfc_current_state () == COMP_MODULE - || gfc_current_state () == COMP_SUBMODULE + || gfc_current_state () == COMP_SUBMODULE || gfc_current_state () == COMP_INTERFACE) return true; @@ -6085,7 +6084,7 @@ in_module_or_interface(void) gfc_state_data *p; for (p = gfc_state_stack->previous; p ; p = p->previous) { - if (p->state == COMP_MODULE || p->state == COMP_SUBMODULE + if (p->state == COMP_MODULE || p->state == COMP_SUBMODULE || p->state == COMP_INTERFACE) return true; } @@ -6304,7 +6303,7 @@ gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, } if (gfc_match_char (')') == MATCH_YES) - { + { if (typeparam) { gfc_error_now ("A type parameter list is required at %C"); @@ -7489,7 +7488,7 @@ gfc_match_entry (void) if (!gfc_add_is_bind_c (&(entry->attr), entry->name, &(entry->declared_at), 1)) return MATCH_ERROR; - + } if (!gfc_current_ns->parent diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 55879af9730..8a0de6140ed 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -1239,6 +1239,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, tree nelem; tree cond; tree or_expr; + tree elemsize; tree class_expr = NULL_TREE; int n, dim, tmp_dim; int total_dim = 0; @@ -1333,15 +1334,6 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, tmp = gfc_conv_descriptor_dtype (desc); gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc))); - /* Also set the span for derived types, since they can be used in - component references to arrays of this type. */ - if (TREE_CODE (eltype) == RECORD_TYPE) - { - tmp = TYPE_SIZE_UNIT (eltype); - tmp = fold_convert (gfc_array_index_type, tmp); - gfc_conv_descriptor_span_set (pre, desc, tmp); - } - /* Fill in the bounds and stride. This is a packed array, so: @@ -1413,22 +1405,21 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, } } + if (class_expr == NULL_TREE) + elemsize = fold_convert (gfc_array_index_type, + TYPE_SIZE_UNIT (gfc_get_element_type (type))); + else + elemsize = gfc_class_vtab_size_get (class_expr); + /* Get the size of the array. */ if (size && !callee_alloc) { - tree elemsize; /* If or_expr is true, then the extent in at least one dimension is zero and the size is set to zero. */ size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, or_expr, gfc_index_zero_node, size); nelem = size; - if (class_expr == NULL_TREE) - elemsize = fold_convert (gfc_array_index_type, - TYPE_SIZE_UNIT (gfc_get_element_type (type))); - else - elemsize = gfc_class_vtab_size_get (class_expr); - size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, size, elemsize); } @@ -1438,6 +1429,10 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, size = NULL_TREE; } + /* Set the span. */ + tmp = fold_convert (gfc_array_index_type, elemsize); + gfc_conv_descriptor_span_set (pre, desc, tmp); + gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial, dynamic, dealloc); @@ -7248,6 +7243,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) if (se->force_tmp) need_tmp = 1; + else if (se->force_no_tmp) + need_tmp = 0; if (need_tmp) full = 0; diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index a0e1f6aeea5..c010956a7ef 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -4278,8 +4278,10 @@ convert_CFI_desc (gfc_wrapped_block * block, gfc_symbol *sym) tree CFI_desc_ptr; tree dummy_ptr; tree tmp; + tree present; tree incoming; tree outgoing; + stmtblock_t outer_block; stmtblock_t tmpblock; /* dummy_ptr will be the pointer to the passed array descriptor, @@ -4303,6 +4305,12 @@ convert_CFI_desc (gfc_wrapped_block * block, gfc_symbol *sym) gfc_desc_ptr = gfc_create_var (tmp, "gfc_desc_ptr"); CFI_desc_ptr = gfc_create_var (pvoid_type_node, "CFI_desc_ptr"); + /* Fix the condition for the presence of the argument. */ + gfc_init_block (&outer_block); + present = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, dummy_ptr, + build_int_cst (TREE_TYPE (dummy_ptr), 0)); + gfc_init_block (&tmpblock); /* Pointer to the gfc descriptor. */ gfc_add_modify (&tmpblock, gfc_desc_ptr, @@ -4318,16 +4326,43 @@ convert_CFI_desc (gfc_wrapped_block * block, gfc_symbol *sym) /* 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); + /* The hidden string length is not passed to bind(C) procedures so set + it from the descriptor element length. */ + if (sym->ts.type == BT_CHARACTER + && sym->ts.u.cl->backend_decl + && VAR_P (sym->ts.u.cl->backend_decl)) + { + tmp = build_fold_indirect_ref_loc (input_location, dummy_ptr); + tmp = gfc_conv_descriptor_elem_len (tmp); + gfc_add_modify (&tmpblock, sym->ts.u.cl->backend_decl, + fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl), + tmp)); + } + + /* Check that the argument is present before executing the above. */ + incoming = build3_v (COND_EXPR, present, + gfc_finish_block (&tmpblock), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&outer_block, incoming); + incoming = gfc_finish_block (&outer_block); + + /* Convert the gfc descriptor back to the CFI type before going - out of scope. */ + out of scope, if the CFI type was present at entry. */ + gfc_init_block (&outer_block); + gfc_init_block (&tmpblock); + 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); + + outgoing = build3_v (COND_EXPR, present, + gfc_finish_block (&tmpblock), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&outer_block, outgoing); + outgoing = gfc_finish_block (&outer_block); /* Add the lot to the procedure init and finally blocks. */ gfc_add_init_cleanup (block, incoming, outgoing); @@ -4923,9 +4958,9 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next) { - if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER) + if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER + && f->sym->ts.u.cl->backend_decl) { - gcc_assert (f->sym->ts.u.cl->backend_decl != NULL); if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL) gfc_trans_vla_type_sizes (f->sym, &tmpblock); } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 21535acb989..3711c38b2f2 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -5006,6 +5006,7 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) if (e->rank != 0) { + parmse->force_no_tmp = 1; if (fsym->attr.contiguous && !gfc_is_simply_contiguous (e, false, true)) gfc_conv_subref_array_arg (parmse, e, false, fsym->attr.intent, diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 022ceb9e197..e7844c9bf1f 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -290,6 +290,16 @@ get_array_span (tree type, tree decl) { tree span; + /* Component references are guaranteed to have a reliable value for + 'span'. Likewise indirect references since they emerge from the + conversion of a CFI descriptor or the hidden dummy descriptor. */ + if (TREE_CODE (decl) == COMPONENT_REF + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + return gfc_conv_descriptor_span_get (decl); + else if (TREE_CODE (decl) == INDIRECT_REF + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + return gfc_conv_descriptor_span_get (decl); + /* Return the span for deferred character length array references. */ if (type && TREE_CODE (type) == ARRAY_TYPE && TYPE_MAX_VALUE (TYPE_DOMAIN (type)) != NULL_TREE @@ -352,9 +362,6 @@ 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; @@ -399,12 +406,7 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr) if (vptr) span = gfc_vptr_size_get (vptr); else if (decl) - { - if (TREE_CODE (decl) == COMPONENT_REF) - span = gfc_conv_descriptor_span_get (decl); - else - span = get_array_span (type, decl); - } + span = get_array_span (type, decl); /* If a non-null span has been generated reference the element with pointer arithmetic. */ diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 9d9ac225b8d..273c75a422c 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -91,6 +91,9 @@ typedef struct gfc_se args alias. */ unsigned force_tmp:1; + /* If set, will pass subref descriptors without a temporary. */ + unsigned force_no_tmp:1; + /* Unconditionally calculate offset for array segments and constant arrays in gfc_conv_expr_descriptor. */ unsigned use_offset:1; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 17cc3dfe191..889c08dfce0 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,19 @@ +2019-05-10 Paul Thomas + + PR fortran/90093 + * gfortran.dg/ISO_Fortran_binding_12.f90: New test. + * gfortran.dg/ISO_Fortran_binding_12.c: Supplementary code. + + PR fortran/90352 + * gfortran.dg/iso_c_binding_char_1.f90: New test. + + PR fortran/90355 + * gfortran.dg/ISO_Fortran_binding_4.f90: Add 'substr' to test + the direct passing of substrings as descriptors to bind(C). + * gfortran.dg/assign_10.f90: Increase the tree_dump count of + 'atmp' to account for the setting of the 'span' field. + * gfortran.dg/transpose_optimization_2.f90: Ditto. + 2019-05-10 Jakub Jelinek PR tree-optimization/88709 @@ -305,7 +321,7 @@ PR fortran/60144 * gfortran.dg/block_name_2.f90: Adjust dg-error. * gfortran.dg/dec_type_print_3.f90.f90: Likewise - * gfortran.dg/pr60144.f90: New test. + * gfortran.dg/pr60144.f90: New test. 2019-05-01 Jeff Law diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_12.c b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_12.c new file mode 100644 index 00000000000..279d9f6d050 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_12.c @@ -0,0 +1,29 @@ +/* Test the fix for PR90093. */ + +#include +#include +#include "../../../libgfortran/ISO_Fortran_binding.h" + +/* Contributed by Reinhold Bader */ + +void foo_opt(CFI_cdesc_t *, float *, int *, int); +void write_res(); + +float x[34]; + +int main() { + CFI_CDESC_T(1) xd; + CFI_index_t ext[] = {34}; + int sz; + + CFI_establish((CFI_cdesc_t *) &xd, &x, CFI_attribute_other, + CFI_type_float, 0, 1, ext); + + foo_opt((CFI_cdesc_t *) &xd, NULL, NULL, 0); + sz = 12; + foo_opt(NULL, &x[11], &sz, 1); + + write_res(); + + return 0; +} diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_12.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_12.f90 new file mode 100644 index 00000000000..d71c67749ce --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_12.f90 @@ -0,0 +1,53 @@ +! { dg-do run { target c99_runtime } } +! { dg-additional-sources ISO_Fortran_binding_12.c } +! +! Test the fix for PR90093. The additional source is the main program. +! +! Contributed by Reinhold Bader +! +module mod_optional + use, intrinsic :: iso_c_binding + implicit none + integer :: status = 0 + +contains + + subroutine foo_opt(this, that, sz, flag) bind(c) + real(c_float), optional :: this(:) + real(c_float), optional :: that(*) + integer(c_int), optional :: sz + integer(c_int), value :: flag + if (flag == 0) then + if (.not. present(this) .or. present(that) .or. present(sz)) then + write(*,*) 'FAIL 1', present(this), present(that), present(sz) + status = status + 1 + end if + else if (flag == 1) then + if (present(this) .or. .not. present(that) .or. .not. present(sz)) then + write(*,*) 'FAIL 2', present(this), present(that), present(sz) + status = status + 1 + end if + if (sz /= 12) then + write(*,*) 'FAIL 3' + status = status + 1 + end if + else if (flag == 2) then + if (present(this) .or. present(that) .or. present(sz)) then + write(*,*) 'FAIL 4', present(this), present(that), present(sz) + status = status + 1 + end if + end if + end subroutine foo_opt + + subroutine write_res() BIND(C) +! Add a check that the fortran missing optional is accepted by the +! bind(C) procedure. + call foo_opt (flag = 2) + if (status == 0) then + write(*,*) 'OK' + else + stop 1 + end if + end subroutine + +end module mod_optional diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90 index 09410b71601..7731d1a6c88 100644 --- a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90 +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90 @@ -1,29 +1,41 @@ ! { dg-do run } ! PR fortran/89384 - this used to give a wrong results ! with contiguous. +! The subroutine substr is a test to check a problem found while +! debugging PR90355. +! ! Test case by Reinhold Bader. +! module mod_ctg implicit none + contains + subroutine ctg(x) BIND(C) real, contiguous :: x(:) - - if (any(abs(x - [2.,4.,6.]) > 1.e-6)) then - write(*,*) 'FAIL' - stop 1 - else - write(*,*) 'OK' - end if + if (any(abs(x - [2.,4.,6.]) > 1.e-6)) stop 1 x = [2.,4.,6.]*10.0 end subroutine + + subroutine substr(str) BIND(C) + character(*) :: str(:) + if (str(2) .ne. "ghi") stop 2 + str = ['uvw','xyz'] + end subroutine + end module + program p use mod_ctg implicit none real :: x(6) + character(5) :: str(2) = ['abcde','fghij'] integer :: i 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 + if (any (abs (x - [1.,20.,3.,40.,5.,60.]) > 1.e-6)) stop 3 + + call substr(str(:)(2:4)) + if (any (str .ne. ['auvwe','fxyzj'])) stop 4 end program diff --git a/gcc/testsuite/gfortran.dg/assign_10.f90 b/gcc/testsuite/gfortran.dg/assign_10.f90 index 6e57bef1650..c207f9e5e2b 100644 --- a/gcc/testsuite/gfortran.dg/assign_10.f90 +++ b/gcc/testsuite/gfortran.dg/assign_10.f90 @@ -24,4 +24,4 @@ end ! Note that it is the kind conversion that generates the temp. ! ! { dg-final { scan-tree-dump-times "parm" 20 "original" } } -! { dg-final { scan-tree-dump-times "atmp" 18 "original" } } +! { dg-final { scan-tree-dump-times "atmp" 20 "original" } } diff --git a/gcc/testsuite/gfortran.dg/iso_c_binding_char_1.f90 b/gcc/testsuite/gfortran.dg/iso_c_binding_char_1.f90 new file mode 100644 index 00000000000..ebf9a248dac --- /dev/null +++ b/gcc/testsuite/gfortran.dg/iso_c_binding_char_1.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! Test the fix for PR90352. +! +! Contributed by Thomas Koenig +! +subroutine bar(c,d) BIND(C) ! { dg-error "must be length 1" } + character (len=*) c + character (len=2) d +end diff --git a/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90 b/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90 index 4748da19547..c49cd421058 100644 --- a/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90 +++ b/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90 @@ -61,4 +61,4 @@ end ! The check below for temporaries gave 14 and 33 for "parm" and "atmp". ! ! { dg-final { scan-tree-dump-times "parm" 72 "original" } } -! { dg-final { scan-tree-dump-times "atmp" 12 "original" } } +! { dg-final { scan-tree-dump-times "atmp" 13 "original" } }