Fortran: passing of derived type to VALUE,OPTIONAL dummy argument [PR118080]

For scalar OPTIONAL dummy arguments with the VALUE attribute, gfortran
passes a hidden flag to denote presence or absence of the actual argument
for intrinsic types.  Extend this treatment to derived type (user-defined
as well as from intrinsic module ISO_C_BINDING).

	PR fortran/118080

gcc/fortran/ChangeLog:

	* gfortran.texi: Adjust documentation.
	* trans-decl.cc (create_function_arglist): Adjust to pass hidden
	presence flag also for derived type dummies with VALUE,OPTIONAL
	attribute.
	* trans-expr.cc (gfc_conv_expr_present): Expect hidden presence
	flag also for derived type dummies with VALUE,OPTIONAL attribute.
	(conv_cond_temp): Adjust to allow derived types.
	(conv_dummy_value): Extend to handle derived type dummies with
	VALUE,OPTIONAL attribute.
	(gfc_conv_procedure_call): Adjust for actual arguments passed to
	derived type dummies with VALUE,OPTIONAL attribute.
	* trans-types.cc (gfc_get_function_type): Adjust fndecl for
	hidden presence flag.

gcc/testsuite/ChangeLog:

	* gfortran.dg/value_optional_2.f90: New test.

5 files changed, 368 insertions, 23 deletions

diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index ab8a4cb..fa7f563 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -3960,6 +3960,7 @@ passed by value.
 
 For @code{OPTIONAL} dummy arguments, an absent argument is denoted
 by a NULL pointer, except for scalar dummy arguments of intrinsic type
+or derived type (but not @code{CLASS}) and
 that have the @code{VALUE} attribute.  For those, a hidden Boolean
 argument (@code{logical(kind=C_bool),value}) is used to indicate
 whether the argument is present.
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 83f8130..0acf0e9 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -2775,8 +2775,7 @@ create_function_arglist (gfc_symbol * sym)
   for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
     if (f->sym != NULL
 	&& f->sym->attr.optional && f->sym->attr.value
-	&& !f->sym->attr.dimension && f->sym->ts.type != BT_CLASS
-	&& !gfc_bt_struct (f->sym->ts.type))
+	&& !f->sym->attr.dimension && f->sym->ts.type != BT_CLASS)
       hidden_typelist = TREE_CHAIN (hidden_typelist);
 
   for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
@@ -2858,12 +2857,11 @@ create_function_arglist (gfc_symbol * sym)
 		type = gfc_sym_type (f->sym);
 	    }
 	}
-      /* For scalar intrinsic types, VALUE passes the value,
+      /* For scalar intrinsic types or derived types, VALUE passes the value,
 	 hence, the optional status cannot be transferred via a NULL pointer.
 	 Thus, we will use a hidden argument in that case.  */
       if (f->sym->attr.optional && f->sym->attr.value
-	  && !f->sym->attr.dimension && f->sym->ts.type != BT_CLASS
-	  && !gfc_bt_struct (f->sym->ts.type))
+	  && !f->sym->attr.dimension && f->sym->ts.type != BT_CLASS)
 	{
           tree tmp;
           strcpy (&name[1], f->sym->name);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 1329efc..9d29fe7 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -2132,10 +2132,9 @@ gfc_conv_expr_present (gfc_symbol * sym, bool use_saved_desc)
   gcc_assert (sym->attr.dummy);
   orig_decl = decl = gfc_get_symbol_decl (sym);
 
-  /* Intrinsic scalars with VALUE attribute which are passed by value
-     use a hidden argument to denote the present status.  */
-  if (sym->attr.value && !sym->attr.dimension
-      && sym->ts.type != BT_CLASS && !gfc_bt_struct (sym->ts.type))
+  /* Intrinsic scalars and derived types with VALUE attribute which are passed
+     by value use a hidden argument to denote the presence status.  */
+  if (sym->attr.value && !sym->attr.dimension && sym->ts.type != BT_CLASS)
     {
       char name[GFC_MAX_SYMBOL_LEN + 2];
       tree tree_name;
@@ -6458,13 +6457,13 @@ post_call:
 
 /* Create "conditional temporary" to handle scalar dummy variables with the
    OPTIONAL+VALUE attribute that shall not be dereferenced.  Use null value
-   as fallback.  Only instances of intrinsic basic type are supported.  */
+   as fallback.  Does not handle CLASS.  */
 
 static void
 conv_cond_temp (gfc_se * parmse, gfc_expr * e, tree cond)
 {
   tree temp;
-  gcc_assert (e->ts.type != BT_DERIVED && e->ts.type != BT_CLASS);
+  gcc_assert (e && e->ts.type != BT_CLASS);
   gcc_assert (e->rank == 0);
   temp = gfc_create_var (TREE_TYPE (parmse->expr), "condtemp");
   TREE_STATIC (temp) = 1;
@@ -6500,6 +6499,17 @@ conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym,
 	  parmse->expr = null_pointer_node;
 	  parmse->string_length = build_int_cst (gfc_charlen_type_node, 0);
 	}
+      else if (gfc_bt_struct (fsym->ts.type)
+	       && !(fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING))
+	{
+	  /* Pass null struct.  Types c_ptr and c_funptr from ISO_C_BINDING
+	     are pointers and passed as such below.  */
+	  tree temp = gfc_create_var (gfc_sym_type (fsym), "absent");
+	  TREE_CONSTANT (temp) = 1;
+	  TREE_READONLY (temp) = 1;
+	  DECL_INITIAL (temp) = build_zero_cst (TREE_TYPE (temp));
+	  parmse->expr = temp;
+	}
       else
 	parmse->expr = fold_convert (gfc_sym_type (fsym),
 				     integer_zero_node);
@@ -6529,9 +6539,7 @@ conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym,
       parmse->string_length = slen1;
     }
 
-  if (fsym->attr.optional
-      && fsym->ts.type != BT_CLASS
-      && fsym->ts.type != BT_DERIVED)
+  if (fsym->attr.optional && fsym->ts.type != BT_CLASS)
     {
       /* F2018:15.5.2.12 Argument presence and
 	 restrictions on arguments not present.  */
@@ -6561,7 +6569,10 @@ conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym,
       else
 	{
 	  tmp = gfc_conv_expr_present (e->symtree->n.sym);
-	  if (e->ts.type != BT_CHARACTER && !e->symtree->n.sym->attr.value)
+	  if (gfc_bt_struct (fsym->ts.type)
+	      && !(fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING))
+	    conv_cond_temp (parmse, e, tmp);
+	  else if (e->ts.type != BT_CHARACTER && !e->symtree->n.sym->attr.value)
 	    parmse->expr
 	      = fold_build3_loc (input_location, COND_EXPR,
 				 TREE_TYPE (parmse->expr),
@@ -6881,7 +6892,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	      && fsym->attr.value
 	      && fsym->attr.optional
 	      && !fsym->attr.dimension
-	      && fsym->ts.type != BT_DERIVED
 	      && fsym->ts.type != BT_CLASS))
 	{
 	  if (se->ignore_optional)
@@ -6903,8 +6913,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		 value, pass "0" and a hidden argument gives the optional
 		 status.  */
 	      if (fsym && fsym->attr.optional && fsym->attr.value
-		  && !fsym->attr.dimension && fsym->ts.type != BT_CLASS
-		  && !gfc_bt_struct (sym->ts.type))
+		  && !fsym->attr.dimension && fsym->ts.type != BT_CLASS)
 		{
 		  conv_dummy_value (&parmse, e, fsym, optionalargs);
 		}
@@ -7016,10 +7025,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		}
 	    }
 
-	  /* Scalar dummy arguments of intrinsic type with VALUE attribute.  */
+	  /* Scalar dummy arguments of intrinsic type or derived type with
+	     VALUE attribute.  */
 	  if (fsym
 	      && fsym->attr.value
-	      && fsym->ts.type != BT_DERIVED
 	      && fsym->ts.type != BT_CLASS)
 	    conv_dummy_value (&parmse, e, fsym, optionalargs);
 
diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index 5ad0fe6..0411400 100644
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -3475,15 +3475,14 @@ gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args,
 
 	  vec_safe_push (hidden_typelist, type);
 	}
-      /* For scalar intrinsic types, VALUE passes the value,
+      /* For scalar intrinsic types or derived types, VALUE passes the value,
 	 hence, the optional status cannot be transferred via a NULL pointer.
 	 Thus, we will use a hidden argument in that case.  */
       if (arg
 	  && arg->attr.optional
 	  && arg->attr.value
 	  && !arg->attr.dimension
-	  && arg->ts.type != BT_CLASS
-	  && !gfc_bt_struct (arg->ts.type))
+	  && arg->ts.type != BT_CLASS)
 	vec_safe_push (typelist, boolean_type_node);
       /* Coarrays which are descriptorless or assumed-shape pass with
 	 -fcoarray=lib the token and the offset as hidden arguments.  */
diff --git a/gcc/testsuite/gfortran.dg/value_optional_2.f90 b/gcc/testsuite/gfortran.dg/value_optional_2.f90
new file mode 100644
index 0000000..4f42f16
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/value_optional_2.f90
@@ -0,0 +1,338 @@
+! { dg-do run }
+! PR fortran/118080
+!
+! Test passing of scalar derived types (user-defined or ISO_C_BINDING)
+! to dummy argument with OPTIONAL + VALUE attribute
+!
+! Original/initial testcase by Tobias Burnus
+
+module m
+  use iso_c_binding
+  implicit none(type,external)
+  logical is_present
+contains
+  subroutine f(x)
+    ! void f (void * x, logical(kind=1) .x)  - 2nd arg = is-present flag
+    type(c_ptr), optional, value :: x
+    if (present(x) .neqv. is_present) stop 1
+    if (present(x)) then
+      block
+        integer, pointer :: ptr
+        call c_f_pointer(x,ptr)
+        if (ptr /= 55) stop 2
+      end block
+    endif
+  end
+end
+
+module m0
+  use m
+  implicit none(type,external)
+contains
+  subroutine test_pr118080
+    type(c_ptr) :: a
+    integer, target :: x
+    a = c_loc(x)
+    x = 55
+
+    is_present = .true.
+    call f(a)
+
+    is_present = .false.
+    call f()
+
+    ! Trying again after the absent call:
+    is_present = .true.
+    call f(a)
+
+    print *, "Passed original test"
+  end subroutine test_pr118080
+end
+
+! Exercise ISO_C_BINDING uses
+module m1
+  use iso_c_binding, only: c_ptr, c_funptr, C_NULL_PTR, C_NULL_FUNPTR
+  implicit none
+  logical :: is_present = .false.
+  integer :: base = 0
+contains
+  subroutine test_c ()
+    type(c_ptr)    :: x = C_NULL_PTR
+    type(c_funptr) :: y = C_NULL_FUNPTR
+
+    is_present = .true.
+    base = 10
+    ! Tests with c_ptr:
+    call f_c (x)
+    call f_c_opt (x)
+    call f_c_val (x)
+    call f_c_opt_val (x)
+    call f_c2_opt (x)
+    call f_c2_opt_val (x)
+
+    ! Tests with c_funptr:
+    call g_c (y)
+    call g_c_opt (y)
+    call g_c_val (y)
+    call g_c_opt_val (y)
+    call g_c2_opt (y)
+    call g_c2_opt_val (y)
+
+    ! Elemental subroutine calls:
+    base = 20
+    call f_c ([x])
+    call f_c_opt ([x])
+    call f_c_val ([x])
+    call f_c_opt_val ([x])
+    call f_c2_opt ([x])
+    call f_c2_opt_val ([x])
+
+    call g_c ([y])
+    call g_c_opt ([y])
+    call g_c_val ([y])
+    call g_c_opt_val ([y])
+    call g_c2_opt ([y])
+    call g_c2_opt_val ([y])
+
+    is_present = .false.
+    base = 30
+    call f_c_opt ()
+    call f_c_opt_val ()
+    call f_c2_opt ()
+    call f_c2_opt_val ()
+
+    call g_c_opt ()
+    call g_c_opt_val ()
+    call g_c2_opt ()
+    call g_c2_opt_val ()
+
+    print *, "Passed test_c"
+  end subroutine test_c
+
+  elemental subroutine f_c (x)
+    type(c_ptr), intent(in) :: x
+  end
+  !
+  elemental subroutine f_c_val (x)
+    type(c_ptr), value :: x
+    call f_c (x)
+  end
+  !
+  elemental subroutine f_c_opt (x)
+    type(c_ptr), intent(in), optional :: x
+    if (present (x) .neqv. is_present) error stop base+1
+  end
+  !
+  elemental subroutine f_c_opt_val (x)
+    type(c_ptr), value, optional :: x
+    if (present (x) .neqv. is_present) error stop base+2
+  end
+  !
+  elemental subroutine f_c2_opt_val (x)
+    type(c_ptr), value, optional :: x
+    if (present (x) .neqv. is_present) error stop base+3
+    call f_c_opt (x)
+    call f_c_opt_val (x)
+    if (present (x)) call f_c (x)
+    if (present (x)) call f_c_val (x)
+  end
+  !
+  elemental subroutine f_c2_opt (x)
+    type(c_ptr), intent(in), optional :: x
+    if (present (x) .neqv. is_present) error stop base+4
+    call f_c_opt_val (x)
+    call f_c2_opt_val (x)
+  end
+
+  elemental subroutine g_c (x)
+    type(c_funptr), intent(in) :: x
+  end
+  !
+  elemental subroutine g_c_val (x)
+    type(c_funptr), value :: x
+    call g_c (x)
+  end
+  !
+  elemental subroutine g_c_opt (x)
+    type(c_funptr), intent(in), optional :: x
+    if (present (x) .neqv. is_present) error stop base+6
+  end
+  !
+  elemental subroutine g_c_opt_val (x)
+    type(c_funptr), value, optional :: x
+    if (present (x) .neqv. is_present) error stop base+7
+  end
+  !
+  elemental subroutine g_c2_opt_val (x)
+    type(c_funptr), value, optional :: x
+    if (present (x) .neqv. is_present) error stop base+8
+    call g_c_opt (x)
+    call g_c_opt_val (x)
+    if (present (x)) call g_c (x)
+    if (present (x)) call g_c_val (x)
+  end
+  !
+  elemental subroutine g_c2_opt (x)
+    type(c_funptr), intent(in), optional :: x
+    if (present (x) .neqv. is_present) error stop base+9
+    call g_c_opt_val (x)
+    call g_c2_opt_val (x)
+  end
+  !
+end
+
+! Exercise simple user-defined types
+module m2
+  implicit none
+
+  type t1
+     character(42) :: c = ""
+     logical       :: l = .false.
+  end type t1
+
+  type, bind(c) :: t2
+     real    :: r(8) = 0.
+     complex :: c(4) = 0.
+     integer :: i    = 0
+  end type t2
+
+  logical :: is_present = .false.
+  integer :: base = 0
+contains
+  subroutine test_t ()
+    type(t1) :: x
+    type(t2) :: y
+
+    x% c = "foo"
+
+    is_present = .true.
+    base = 50
+    ! Tests with t1:
+    call f_c (x)
+    call f_c_opt (x)
+    call f_c_val (x)
+    call f_c_opt_val (x)
+    call f_c2_opt (x)
+    call f_c2_opt_val (x)
+
+    ! Tests with t2:
+    call g_c (y)
+    call g_c_opt (y)
+    call g_c_val (y)
+    call g_c_opt_val (y)
+    call g_c2_opt (y)
+    call g_c2_opt_val (y)
+
+    ! Elemental subroutine calls:
+    base = 60
+    call f_c ([x])
+    call f_c_opt ([x])
+    call f_c_val ([x])
+    call f_c_opt_val ([x])
+    call f_c2_opt ([x])
+    call f_c2_opt_val ([x])
+
+    call g_c ([y])
+    call g_c_opt ([y])
+    call g_c_val ([y])
+    call g_c_opt_val ([y])
+    call g_c2_opt ([y])
+    call g_c2_opt_val ([y])
+
+    is_present = .false.
+    base = 70
+    call f_c_opt ()
+    call f_c_opt_val ()
+    call f_c2_opt ()
+    call f_c2_opt_val ()
+
+    call g_c_opt ()
+    call g_c_opt_val ()
+    call g_c2_opt ()
+    call g_c2_opt_val ()
+
+    print *, "Passed test_t"
+  end subroutine test_t
+
+  elemental subroutine f_c (x)
+    type(t1), intent(in) :: x
+    if (x% c /= "foo") error stop base
+  end
+  !
+  elemental subroutine f_c_val (x)
+    type(t1), value :: x
+    if (x% c /= "foo") error stop base+5
+    call f_c (x)
+  end
+  !
+  elemental subroutine f_c_opt (x)
+    type(t1), intent(in), optional :: x
+    if (present (x) .neqv. is_present) error stop base+1
+  end
+  !
+  elemental subroutine f_c_opt_val (x)
+    type(t1), value, optional :: x
+    if (present (x) .neqv. is_present) error stop base+2
+  end
+  !
+  elemental subroutine f_c2_opt_val (x)
+    type(t1), value, optional :: x
+    if (present (x) .neqv. is_present) error stop base+3
+    call f_c_opt (x)
+    call f_c_opt_val (x)
+    if (present (x)) call f_c (x)
+    if (present (x)) call f_c_val (x)
+  end
+  !
+  elemental subroutine f_c2_opt (x)
+    type(t1), intent(in), optional :: x
+    if (present (x) .neqv. is_present) error stop base+4
+    call f_c_opt_val (x)
+    call f_c2_opt_val (x)
+  end
+
+  elemental subroutine g_c (x)
+    type(t2), intent(in) :: x
+  end
+  !
+  elemental subroutine g_c_val (x)
+    type(t2), value :: x
+    call g_c (x)
+  end
+  !
+  elemental subroutine g_c_opt (x)
+    type(t2), intent(in), optional :: x
+    if (present (x) .neqv. is_present) error stop base+6
+  end
+  !
+  elemental subroutine g_c_opt_val (x)
+    type(t2), value, optional :: x
+    if (present (x) .neqv. is_present) error stop base+7
+  end
+  !
+  elemental subroutine g_c2_opt_val (x)
+    type(t2), value, optional :: x
+    if (present (x) .neqv. is_present) error stop base+8
+    call g_c_opt (x)
+    call g_c_opt_val (x)
+    if (present (x)) call g_c (x)
+    if (present (x)) call g_c_val (x)
+  end
+  !
+  elemental subroutine g_c2_opt (x)
+    type(t2), intent(in), optional :: x
+    if (present (x) .neqv. is_present) error stop base+9
+    call g_c_opt_val (x)
+    call g_c2_opt_val (x)
+  end
+end
+
+program pr118080
+  use m0
+  use m1
+  use m2
+  implicit none
+  call test_pr118080 ()
+  call test_c()
+  call test_t()
+end