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.

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 4baaee9bfec7f7a7327bdc0465fef45447eb8150..fa999fac3553bf8d26b6d30a93583523f5c0f0c1 100644 (file)
--- 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 94988b8690eda1127c70847434e47bce6a7012e2..217de6b8da04cba8fb1e2241e4f7bd63e73acd34 100644 (file)
--- 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 f3fbb52715703828f893e8d097fe079e53bd22d0..b95c5cf2f96114f052fcf1ed45ed78ebab59547a 100644 (file)
--- 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 42907becd277fe6f9ef6b2353ba37f4904b552c6..196f2cecbfc6592e15dab85c72e5c9d2e98d7e8b 100644 (file)
--- 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 1be981c88f624892cc57343c9a0f658e8d8154f5..163d0b67cb69853773b2a6dda9e8b8c052c66de2 100644 (file)
--- 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 (file)
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