aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/doc/gfortran/naming-and-argument-passing-conventions.rst3
-rw-r--r--gcc/fortran/trans-decl.cc10
-rw-r--r--gcc/fortran/trans-expr.cc25
-rw-r--r--gcc/fortran/trans-types.cc14
-rw-r--r--gcc/testsuite/gfortran.dg/optional_absent_7.f902
-rw-r--r--gcc/testsuite/gfortran.dg/optional_absent_8.f9053
6 files changed, 84 insertions, 23 deletions
diff --git a/gcc/fortran/doc/gfortran/naming-and-argument-passing-conventions.rst b/gcc/fortran/doc/gfortran/naming-and-argument-passing-conventions.rst
index 4baaee9..fa999fa 100644
--- a/gcc/fortran/doc/gfortran/naming-and-argument-passing-conventions.rst
+++ b/gcc/fortran/doc/gfortran/naming-and-argument-passing-conventions.rst
@@ -142,8 +142,7 @@ is used for dummy arguments; with ``VALUE``, those variables are
passed by value.
For ``OPTIONAL`` dummy arguments, an absent argument is denoted
-by a NULL pointer, except for scalar dummy arguments of type
-``INTEGER``, ``LOGICAL``, ``REAL`` and ``COMPLEX``
+by a NULL pointer, except for scalar dummy arguments of intrinsic type
which have the ``VALUE`` attribute. For those, a hidden Boolean
argument (``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 94988b8..217de6b 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -2708,16 +2708,16 @@ create_function_arglist (gfc_symbol * sym)
type = gfc_sym_type (f->sym);
}
}
- /* For noncharacter scalar intrinsic types, VALUE passes the value,
+ /* For scalar intrinsic 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. */
- else 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))
+ 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))
{
tree tmp;
strcpy (&name[1], f->sym->name);
- name[0] = '_';
+ name[0] = '.';
tmp = build_decl (input_location,
PARM_DECL, get_identifier (name),
boolean_type_node);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index f3fbb52..b95c5cf 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1985,15 +1985,14 @@ gfc_conv_expr_present (gfc_symbol * sym, bool use_saved_desc)
/* Intrinsic scalars with VALUE attribute which are passed by value
use a hidden argument to denote the present status. */
- if (sym->attr.value && sym->ts.type != BT_CHARACTER
- && sym->ts.type != BT_CLASS && sym->ts.type != BT_DERIVED
- && !sym->attr.dimension)
+ if (sym->attr.value && !sym->attr.dimension
+ && sym->ts.type != BT_CLASS && !gfc_bt_struct (sym->ts.type))
{
char name[GFC_MAX_SYMBOL_LEN + 2];
tree tree_name;
gcc_assert (TREE_CODE (decl) == PARM_DECL);
- name[0] = '_';
+ name[0] = '.';
strcpy (&name[1], sym->name);
tree_name = get_identifier (name);
@@ -6162,11 +6161,21 @@ 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_CHARACTER
- && fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED)
+ && !fsym->attr.dimension && fsym->ts.type != BT_CLASS
+ && !gfc_bt_struct (sym->ts.type))
{
- parmse.expr = fold_convert (gfc_sym_type (fsym),
- integer_zero_node);
+ if (fsym->ts.type == BT_CHARACTER)
+ {
+ /* Pass a NULL pointer for an absent CHARACTER arg
+ and a length of zero. */
+ parmse.expr = null_pointer_node;
+ parmse.string_length
+ = build_int_cst (gfc_charlen_type_node,
+ 0);
+ }
+ else
+ parmse.expr = fold_convert (gfc_sym_type (fsym),
+ integer_zero_node);
vec_safe_push (optionalargs, boolean_false_node);
}
else
diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index 42907be..196f2ce 100644
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -3225,15 +3225,15 @@ gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args,
vec_safe_push (hidden_typelist, type);
}
- /* For noncharacter scalar intrinsic types, VALUE passes the value,
+ /* For scalar intrinsic 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. */
- else if (arg
- && arg->attr.optional
- && arg->attr.value
- && !arg->attr.dimension
- && arg->ts.type != BT_CLASS
- && !gfc_bt_struct (arg->ts.type))
+ if (arg
+ && arg->attr.optional
+ && arg->attr.value
+ && !arg->attr.dimension
+ && arg->ts.type != BT_CLASS
+ && !gfc_bt_struct (arg->ts.type))
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/optional_absent_7.f90 b/gcc/testsuite/gfortran.dg/optional_absent_7.f90
index 1be981c..163d0b6 100644
--- a/gcc/testsuite/gfortran.dg/optional_absent_7.f90
+++ b/gcc/testsuite/gfortran.dg/optional_absent_7.f90
@@ -27,5 +27,5 @@ contains
end subroutine s
end program p
-! { dg-final { scan-tree-dump "void s .* c, .* o, logical.* _o, integer.* _c" "original" } }
+! { dg-final { scan-tree-dump "void s .* c, .* o, logical.* \.o, integer.* _c" "original" } }
! { dg-final { scan-tree-dump ", integer.*, logical.*, integer.* pp" "original" } }
diff --git a/gcc/testsuite/gfortran.dg/optional_absent_8.f90 b/gcc/testsuite/gfortran.dg/optional_absent_8.f90
new file mode 100644
index 0000000..e3c0445
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/optional_absent_8.f90
@@ -0,0 +1,53 @@
+! { dg-do run }
+! PR fortran/107444
+!
+! Check that procedures with optional arguments that have the value attribute
+! work for intrinsic types including character, and that the presence check
+! works.
+!
+! Co-contributed by M.Morin
+
+program p
+ implicit none
+ interface
+ subroutine i(c, o)
+ character(*) :: c
+ character(3), optional, value :: o
+ end subroutine i
+ end interface
+ procedure(i), pointer :: pp
+ call s([.false.,.false.,.false.], 0)
+ call s([.true., .false.,.false.], 10, i=7)
+ call s([.false.,.true. ,.false.], 20, c='abc')
+ call s([.false.,.false.,.true. ], 30, r=3.0)
+ pp => f
+ call pp ("abcd", "xyz")
+contains
+ subroutine s (expect,code,i,c,r)
+ logical, intent(in) :: expect(:)
+ integer, intent(in) :: code
+ integer , value, optional :: i
+ character(3), value, optional :: c
+ real , value, optional :: r
+ if (expect(1) .neqv. present (i)) stop 1+code
+ if (expect(2) .neqv. present (c)) stop 2+code
+ if (expect(3) .neqv. present (r)) stop 3+code
+ if (present (i)) then
+ if (i /= 7) stop 4+code
+ end if
+ if (present (c)) then
+ if (c /= "abc") stop 5+code
+ end if
+ if (present (r)) then
+ if (r /= 3.0) stop 6+code
+ end if
+ end subroutine s
+ subroutine f (c, o)
+ character(*) :: c
+ character(3), optional, value :: o
+ if (c /= "abcd") stop 41
+ if (len (c) /= 4) stop 42
+ if (.not. present (o)) stop 43
+ if (o /= "xyz") stop 44
+ end subroutine f
+end
generated by cgit v1.1 at 2025-08-10 15:25:14 +0000