Index: gcc/fortran/trans-expr.c =================================================================== *** gcc/fortran/trans-expr.c (revision 276015) --- gcc/fortran/trans-expr.c (working copy) *************** gfc_conv_gfc_desc_to_cfi_desc (gfc_se *p *** 4989,4995 **** --- 5006,5014 ---- tree gfc_desc_ptr; tree type; tree cond; + tree desc_attr; int attribute; + int cfi_attribute; symbol_attribute attr = gfc_expr_attr (e); stmtblock_t block; *************** gfc_conv_gfc_desc_to_cfi_desc (gfc_se *p *** 4998,5009 **** attribute = 2; if (!e->rank || gfc_get_full_arrayspec_from_expr (e)) { ! if (fsym->attr.pointer) attribute = 0; ! else if (fsym->attr.allocatable) attribute = 1; } if (e->rank != 0) { parmse->force_no_tmp = 1; --- 5017,5036 ---- attribute = 2; if (!e->rank || gfc_get_full_arrayspec_from_expr (e)) { ! if (attr.pointer) attribute = 0; ! else if (attr.allocatable) attribute = 1; } + /* If the formal argument is assumed shape and neither a pointer nor + allocatable, it is unconditionally CFI_attribute_other. */ + if (fsym->as->type == AS_ASSUMED_SHAPE + && !fsym->attr.pointer && !fsym->attr.allocatable) + cfi_attribute = 2; + else + cfi_attribute = attribute; + if (e->rank != 0) { parmse->force_no_tmp = 1; *************** gfc_conv_gfc_desc_to_cfi_desc (gfc_se *p *** 5070,5080 **** parmse->expr, attr); } ! /* Set the CFI attribute field. */ ! tmp = gfc_conv_descriptor_attribute (parmse->expr); tmp = fold_build2_loc (input_location, MODIFY_EXPR, ! void_type_node, tmp, ! build_int_cst (TREE_TYPE (tmp), attribute)); gfc_add_expr_to_block (&parmse->pre, tmp); /* Now pass the gfc_descriptor by reference. */ --- 5097,5108 ---- parmse->expr, attr); } ! /* Set the CFI attribute field through a temporary value for the ! gfc attribute. */ ! desc_attr = gfc_conv_descriptor_attribute (parmse->expr); tmp = fold_build2_loc (input_location, MODIFY_EXPR, ! void_type_node, desc_attr, ! build_int_cst (TREE_TYPE (desc_attr), cfi_attribute)); gfc_add_expr_to_block (&parmse->pre, tmp); /* Now pass the gfc_descriptor by reference. */ *************** gfc_conv_gfc_desc_to_cfi_desc (gfc_se *p *** 5092,5097 **** --- 5120,5131 ---- gfor_fndecl_gfc_to_cfi, 2, tmp, gfc_desc_ptr); gfc_add_expr_to_block (&parmse->pre, tmp); + /* Now set the gfc descriptor attribute. */ + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + void_type_node, desc_attr, + build_int_cst (TREE_TYPE (desc_attr), attribute)); + gfc_add_expr_to_block (&parmse->pre, tmp); + /* The CFI descriptor is passed to the bind_C procedure. */ parmse->expr = cfi_desc_ptr; *************** gfc_conv_gfc_desc_to_cfi_desc (gfc_se *p *** 5112,5117 **** --- 5146,5170 ---- tmp = build_call_expr_loc (input_location, gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp); gfc_prepend_expr_to_block (&parmse->post, tmp); + + /* Deal with an optional dummy being passed to an optional formal arg + by finishing the pre and post blocks and making their execution + conditional on the dummy being present. */ + if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.optional) + { + cond = gfc_conv_expr_present (e->symtree->n.sym); + tmp = fold_build2 (MODIFY_EXPR, void_type_node, + cfi_desc_ptr, + build_int_cst (pvoid_type_node, 0)); + tmp = build3_v (COND_EXPR, cond, + gfc_finish_block (&parmse->pre), tmp); + gfc_add_expr_to_block (&parmse->pre, tmp); + tmp = build3_v (COND_EXPR, cond, + gfc_finish_block (&parmse->post), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&parmse->post, tmp); + } } Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_13.c =================================================================== *** gcc/testsuite/gfortran.dg/ISO_Fortran_binding_13.c (nonexistent) --- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_13.c (working copy) *************** *** 0 **** --- 1,12 ---- + /* Test the fix for PR91926. */ + + /* Contributed by José Rui Faustino de Sousa */ + + #include + + int ifb_echo(void*); + + int ifb_echo(void *this) + { + return this == NULL ? 1 : 2; + } Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_13.f90 =================================================================== *** gcc/testsuite/gfortran.dg/ISO_Fortran_binding_13.f90 (nonexistent) --- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_13.f90 (working copy) *************** *** 0 **** --- 1,39 ---- + ! { dg-do run { target c99_runtime } } + ! { dg-additional-sources ISO_Fortran_binding_13.c } + ! + ! Test the fix for PR91926. The additional source is the main program. + ! + ! Contributed by José Rui Faustino de Sousa + ! + program ifb_p + + implicit none + + integer :: i = 42 + + interface + integer function ifb_echo_aux(this) bind(c, name="ifb_echo") + implicit none + type(*), dimension(..), & ! removing assumed rank solves segmentation fault + optional, intent(in) :: this + end function ifb_echo_aux + end interface + + if (ifb_echo_aux() .ne. 1) STOP 1 ! worked + if (ifb_echo() .ne. 1) stop 2 ! segmentation fault + if (ifb_echo_aux(i) .ne. 2) stop 3 ! worked + if (ifb_echo(i) .ne. 2) stop 4 ! worked + + stop + + contains + + integer function ifb_echo(this) + type(*), dimension(..), & + optional, intent(in) :: this + + ifb_echo = ifb_echo_aux(this) + return + end function ifb_echo + + end program ifb_p Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_14.f90 =================================================================== *** gcc/testsuite/gfortran.dg/ISO_Fortran_binding_14.f90 (nonexistent) --- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_14.f90 (working copy) *************** *** 0 **** --- 1,41 ---- + ! { dg-do run } + ! + ! Correct an error in the eveluation of the CFI descriptor attribute for + ! the case where the bind_C formal argument is not an assumed shape array + ! and not allocatable or pointer. + ! + ! Contributed by Gilles Gouaillardet + ! + MODULE FOO + INTERFACE + SUBROUTINE dummy(buf) BIND(C, name="sync") + type(*), dimension(..) :: buf + END SUBROUTINE + END INTERFACE + END MODULE + + PROGRAM main + USE FOO + IMPLICIT NONE + integer(8) :: before, after + + INTEGER, parameter :: n = 1 + + INTEGER, ALLOCATABLE :: buf(:) + INTEGER :: buf2(n) + INTEGER :: i + + ALLOCATE(buf(n)) + before = LOC(buf(1)) + CALL dummy (buf) + after = LOC(buf(1)) + + if (before .NE. after) stop 1 + + before = LOC(buf2(1)) + CALL dummy (buf) + after = LOC(buf2(1)) + + if (before .NE. after) stop 2 + + END PROGRAM