re PR fortran/91926 (assumed rank optional)

2019-10-28  Paul Thomas  <pault@gcc.gnu.org>

	Backport from trunk
	PR fortran/91926
	* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Correct the
	assignment of the attribute field to account correctly for an
	assumed shape dummy. Assign separately to the gfc and cfi
	descriptors since the atribute can be different. Add branch to
	correctly handle missing optional dummies.

2019-10-28  Paul Thomas  <pault@gcc.gnu.org>

	Backport from trunk
	PR fortran/91926
	* gfortran.dg/ISO_Fortran_binding_13.f90 : New test.
	* gfortran.dg/ISO_Fortran_binding_13.c : Additional source.
	* gfortran.dg/ISO_Fortran_binding_14.f90 : New test.

From-SVN: r277531

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 444a2d9a9bd9143cbcd56b61b98b7d8b8ec37bf9..759390f5832255d1cbe57415d9395aa55e639345 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+2019-10-28  Paul Thomas  <pault@gcc.gnu.org>
+
+       Backport from trunk
+       PR fortran/91926
+       * trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Correct the
+       assignment of the attribute field to account correctly for an
+       assumed shape dummy. Assign separately to the gfc and cfi
+       descriptors since the atribute can be different. Add branch to
+       correctly handle missing optional dummies.
+
 2019-10-28  Tobias Burnus  <tobias@codesourcery.com>
 
        Backport from mainline

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 18f389eeaa3bbd2d80f9ce4a11214d19beffebf1..71f298831738b62bb705e712b650f0cb00e89df2 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -4989,7 +4989,9 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
   tree gfc_desc_ptr;
   tree type;
   tree cond;
+  tree desc_attr;
   int attribute;
+  int cfi_attribute;
   symbol_attribute attr = gfc_expr_attr (e);
 
   /* If this is a full array or a scalar, the allocatable and pointer
@@ -4997,12 +4999,20 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
   attribute = 2;
   if (!e->rank || gfc_get_full_arrayspec_from_expr (e))
     {
-      if (fsym->attr.pointer)
+      if (attr.pointer)
        attribute = 0;
-      else if (fsym->attr.allocatable)
+      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;
@@ -5069,11 +5079,12 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
                                                    parmse->expr, attr);
     }
 
-  /* Set the CFI attribute field.  */
-  tmp = gfc_conv_descriptor_attribute (parmse->expr);
+  /* 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, tmp,
-                        build_int_cst (TREE_TYPE (tmp), attribute));
+                        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.  */
@@ -5091,6 +5102,12 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
                             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;
 
@@ -5099,6 +5116,25 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
   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);
+    }
 }
 
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 8b54b5457415737f67320232f9f5d290a483561a..c6b50a7bd9e09ff92d6fcd2508916a23f9d5b535 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,11 @@
+2019-10-28  Paul Thomas  <pault@gcc.gnu.org>
+
+       Backport from trunk
+       PR fortran/91926
+       * gfortran.dg/ISO_Fortran_binding_13.f90 : New test.
+       * gfortran.dg/ISO_Fortran_binding_13.c : Additional source.
+       * gfortran.dg/ISO_Fortran_binding_14.f90 : New test.
+
 2019-10-28  Jiufu Guo  <guojiufu@linux.ibm.com>
 
        Backport from mainline

diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_13.c b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_13.c
new file mode 100644 (file)
index 0000000..1ac9fc8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_13.c
@@ -0,0 +1,12 @@
+/* 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;
+}

diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_13.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_13.f90
new file mode 100644 (file)
index 0000000..132a97c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_13.f90
@@ -0,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  <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

diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_14.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_14.f90
new file mode 100644 (file)
index 0000000..388c543
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_14.f90
@@ -0,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  <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