From d87e299dd2b7f4be6ca829e80cd94babc53fa12f Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Thu, 10 Nov 2022 22:30:27 +0100
Subject: [PATCH] Fortran: fix treatment of character, value, optional dummy
arguments [PR107444]
Fix handling of character dummy arguments that have the optional+value
attribute. Change name of internal symbols that carry the hidden presence
status of optional arguments to distinguish them from the internal hidden
character length. Update documentation to clarify the gfortran ABI.
gcc/fortran/ChangeLog:
PR fortran/107444
* trans-decl.cc (create_function_arglist): Extend presence status
to all intrinsic types, and change prefix of internal symbol to '.'.
* trans-expr.cc (gfc_conv_expr_present): Align to changes in
create_function_arglist.
(gfc_conv_procedure_call): Fix generation of procedure arguments for
the case of character dummy arguments with optional+value attribute.
* trans-types.cc (gfc_get_function_type): Synchronize with changes
to create_function_arglist.
* doc/gfortran/naming-and-argument-passing-conventions.rst: Clarify
the gfortran argument passing conventions with regard to OPTIONAL
dummy arguments of intrinsic type.
gcc/testsuite/ChangeLog:
PR fortran/107444
* gfortran.dg/optional_absent_7.f90: Adjust regex.
* gfortran.dg/optional_absent_8.f90: New test.
---
...aming-and-argument-passing-conventions.rst | 3 +-
gcc/fortran/trans-decl.cc | 10 ++--
gcc/fortran/trans-expr.cc | 25 ++++++---
gcc/fortran/trans-types.cc | 14 ++---
.../gfortran.dg/optional_absent_7.f90 | 2 +-
.../gfortran.dg/optional_absent_8.f90 | 53 +++++++++++++++++++
6 files changed, 84 insertions(+), 23 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/optional_absent_8.f90
@@ -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.
@@ -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);
@@ -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
@@ -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. */
@@ -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" } }
new file mode 100644
@@ -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
--
2.35.3