re PR fortran/90093 (Extended C interop: optional argument incorrectly identified as PRESENT)

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

	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  <pault@gcc.gnu.org>

	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

gcc/fortran/ChangeLog

+2019-05-10  Paul Thomas  <pault@gcc.gnu.org>
+
+	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  <tkoenig@gcc.gnu.org>
 
 	PR fortran/90351

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

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;

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);
 	}

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,

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.  */

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;

gcc/testsuite/ChangeLog

+2019-05-10  Paul Thomas  <pault@gcc.gnu.org>
+
+	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  <jakub@redhat.com>
 
 	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  <law@redhat.com>
 

gcc/testsuite/gfortran.dg/ISO_Fortran_binding_12.c

+/* Test the fix for PR90093.  */
+
+#include <stdio.h>
+#include <math.h>
+#include "../../../libgfortran/ISO_Fortran_binding.h"
+
+/* Contributed by Reinhold Bader  <Bader@lrz.de>  */
+
+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;
+}

gcc/testsuite/gfortran.dg/ISO_Fortran_binding_12.f90

+! { 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  <Bader@lrz.de>
+!
+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

gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90

 ! { 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

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" } }

gcc/testsuite/gfortran.dg/iso_c_binding_char_1.f90

+! { dg-do compile }
+!
+! Test the fix for PR90352.
+!
+! Contributed by Thomas Koenig  <tkoenig@gcc.gnu.org>
+!
+subroutine bar(c,d) BIND(C) ! { dg-error "must be length 1" }
+  character (len=*) c
+  character (len=2) d
+end

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" } }