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;
/* 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;
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);
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. */
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),
&& fsym->attr.value
&& fsym->attr.optional
&& !fsym->attr.dimension
- && fsym->ts.type != BT_DERIVED
&& fsym->ts.type != BT_CLASS))
{
if (se->ignore_optional)
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);
}
}
}
- /* 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);
--- /dev/null
+! { 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
projects / thirdparty / gcc.git / commitdiff
