Dear all,
the attached patch fixes inconsistent handling of passing derived type
actual arguments to scalar dummies with VALUE,OPTIONAL attribute.
As suggested by Tobias, we should consistently pass a hidden boolean
flag that indicates the presence or absence of the actual, similar to
the case of intrinsic types. For more details see the attached.
Regtested on x86_64-pc-linux-gnu. OK for mainline?
Thanks,
Harald
From 3e20f044243dea8d7a873217c8836bcdfbdd90c3 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anl...@gmx.de>
Date: Fri, 14 Feb 2025 20:12:10 +0100
Subject: [PATCH] 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):
(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.
---
gcc/fortran/gfortran.texi | 1 +
gcc/fortran/trans-decl.cc | 8 +-
gcc/fortran/trans-expr.cc | 39 +-
gcc/fortran/trans-types.cc | 5 +-
.../gfortran.dg/value_optional_2.f90 | 338 ++++++++++++++++++
5 files changed, 368 insertions(+), 23 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/value_optional_2.f90
diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index ab8a4cb590f..fa7f563ba2a 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 83f8130afd8..0acf0e9adb7 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 1329efcd6eb..9d29fe75116 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 5ad0fe62654..0411400e0f2 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 00000000000..4f42f166e81
--- /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
--
2.43.0
