===================================================================
*************** gfc_conv_gfc_desc_to_cfi_desc (gfc_se *p
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
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;
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
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. */
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
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
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);
+ }
}
===================================================================
***************
+ /* Test the fix for PR91926. */
+
+ /* Contributed by José Rui Faustino de Sousa <jrfsousa@hotmail.com> */
+
+ #include <stdlib.h>
+
+ int ifb_echo(void*);
+
+ int ifb_echo(void *this)
+ {
+ return this == NULL ? 1 : 2;
+ }
===================================================================
***************
+ ! { 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 <jrfsousa@hotmail.com>
+ !
+ 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
===================================================================
***************
+ ! { 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 <gilles@rist.or.jp>
+ !
+ 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