Re: [PATCH, v3] Fortran: ordering of hidden procedure arguments [PR107441]

[Harald Anlauf <anlauf@gmx.de>]

[-- Attachment #1: Type: text/plain, Size: 3277 bytes --]

Hi Mikael,

Am 08.11.22 um 11:32 schrieb Mikael Morin:
> this is mostly good.
> There is one last corner case that is not properly handled:
>
>> diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
>> index 63515b9072a..94988b8690e 100644
>> --- a/gcc/fortran/trans-decl.cc
>> +++ b/gcc/fortran/trans-decl.cc
> (...)
>> @@ -2619,6 +2620,15 @@ create_function_arglist (gfc_symbol * sym)
>>      if (f->sym != NULL)    /* Ignore alternate returns.  */
>>        hidden_typelist = TREE_CHAIN (hidden_typelist);
>>
>> +  /* Advance hidden_typelist over optional+value argument presence
>> flags.  */
>> +  optval_typelist = hidden_typelist;
>> +  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))
>> +      hidden_typelist = TREE_CHAIN (hidden_typelist);
>> +
>
> This new loop copies the condition guarding the handling of optional
> value presence arguments, except that the condition is in an "else if",
> and the complement of the condition in the corresponding "if" is
> missing, to have strictly the same conditions.

I know, and I left that intentionally, as it is related to
PR107444, assuming that it doesn't lead to a new ICE.  Bad idea.

> Admittedly, it only makes a difference for character optional value
> arguments, which are hardly working.  At least they work as long as one
> doesn't try to query their presence.  Below is a case regressing with
> your patch.

> With that fixed, I think it's good for mainline.
> Thanks for your patience.
>
>
> ! { dg-do compile }
> !
> ! PR fortran/107441
> ! Check that procedure types and procedure decls match when the procedure
> ! has both character-typed and character-typed optional value args.
> !
> ! Contributed by M.Morin
>
> program p
>    interface
>      subroutine i(c, o)
>        character(*) :: c
>        character(3), optional, value :: o
>      end subroutine i
>    end interface
>    procedure(i), pointer :: pp
>    pp => s
>    call pp("abcd", "xyz")
> contains
>    subroutine s(c, o)
>      character(*) :: c
>      character(3), optional, value :: o
>      if (o /= "xyz") stop 1
>      if (c /= "abcd") stop 2
>    end subroutine s
> end program p

Well, that testcase may compile with 12-branch, but it gives
wrong code.  Furthermore, it is arguably invalid, as you are
currently unable to check the presence of the optional argument
due to PR107444.  I am therefore reluctant to have that testcase
now.

To fix that, we may have to bite the bullet and break the
documented ABI, or rather update it, as character,value,optional
is broken in all current gfortran versions, and the documentation
is not completely consistent.  I had planned to do this with the
fix for PR107444, which want to keep separate from the current
patch for good reasons.

I have modified my patch so that your testcase above compiles
and runs.  But as explained, I don't want to add it now.

Regtested again.  What do you think?

Thanks,
Harald


[-- Attachment #2: pr107441-v4.diff --]
[-- Type: text/x-patch, Size: 12188 bytes --]

From 8694d1d2cbd19b5148b5d1d891b182cc3e718f40 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Fri, 28 Oct 2022 21:58:08 +0200
Subject: [PATCH] Fortran: ordering of hidden procedure arguments [PR107441]

The gfortran argument passing conventions specify a certain order for
procedure arguments that should be followed consequently: the hidden
presence status flags of optional+value scalar arguments of intrinsic type
shall come before the hidden character length, coarray token and offset.
Clarify that in the documentation.

gcc/fortran/ChangeLog:

	PR fortran/107441
	* gfortran.texi (Argument passing conventions): Clarify the gfortran
	argument passing conventions with regard to OPTIONAL dummy arguments
	of intrinsic type.
	* trans-decl.cc (create_function_arglist): Adjust the ordering of
	automatically generated hidden procedure arguments to match the
	documented ABI for gfortran.
	* trans-types.cc (gfc_get_function_type): Separate hidden parameters
	so that the presence flag for optional+value arguments come before
	string length, coarray token and offset, as required.

gcc/testsuite/ChangeLog:

	PR fortran/107441
	* gfortran.dg/coarray/pr107441-caf.f90: New test.
	* gfortran.dg/optional_absent_6.f90: New test.
	* gfortran.dg/optional_absent_7.f90: New test.
---
 gcc/fortran/gfortran.texi                     |  3 +-
 gcc/fortran/trans-decl.cc                     | 31 +++++++---
 gcc/fortran/trans-types.cc                    | 25 ++++----
 .../gfortran.dg/coarray/pr107441-caf.f90      | 27 +++++++++
 .../gfortran.dg/optional_absent_6.f90         | 60 +++++++++++++++++++
 .../gfortran.dg/optional_absent_7.f90         | 31 ++++++++++
 6 files changed, 157 insertions(+), 20 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/coarray/pr107441-caf.f90
 create mode 100644 gcc/testsuite/gfortran.dg/optional_absent_6.f90
 create mode 100644 gcc/testsuite/gfortran.dg/optional_absent_7.f90

diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index 4b4ecd528a7..60fac2e0417 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -3763,8 +3763,7 @@ is used for dummy arguments; with @code{VALUE}, those variables are
 passed by value.
 
 For @code{OPTIONAL} dummy arguments, an absent argument is denoted
-by a NULL pointer, except for scalar dummy arguments of type
-@code{INTEGER}, @code{LOGICAL}, @code{REAL} and @code{COMPLEX}
+by a NULL pointer, except for scalar dummy arguments of intrinsic type
 which 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 63515b9072a..c6948e1d859 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -2507,8 +2507,8 @@ create_function_arglist (gfc_symbol * sym)
 {
   tree fndecl;
   gfc_formal_arglist *f;
-  tree typelist, hidden_typelist;
-  tree arglist, hidden_arglist;
+  tree typelist, hidden_typelist, optval_typelist;
+  tree arglist, hidden_arglist, optval_arglist;
   tree type;
   tree parm;
 
@@ -2518,6 +2518,7 @@ create_function_arglist (gfc_symbol * sym)
      the new FUNCTION_DECL node.  */
   arglist = NULL_TREE;
   hidden_arglist = NULL_TREE;
+  optval_arglist = NULL_TREE;
   typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
 
   if (sym->attr.entry_master)
@@ -2619,6 +2620,15 @@ create_function_arglist (gfc_symbol * sym)
     if (f->sym != NULL)	/* Ignore alternate returns.  */
       hidden_typelist = TREE_CHAIN (hidden_typelist);
 
+  /* Advance hidden_typelist over optional+value argument presence flags.  */
+  optval_typelist = hidden_typelist;
+  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))
+      hidden_typelist = TREE_CHAIN (hidden_typelist);
+
   for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
     {
       char name[GFC_MAX_SYMBOL_LEN + 2];
@@ -2698,12 +2708,12 @@ 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);
@@ -2712,14 +2722,16 @@ create_function_arglist (gfc_symbol * sym)
 			    PARM_DECL, get_identifier (name),
 			    boolean_type_node);
 
-          hidden_arglist = chainon (hidden_arglist, tmp);
+	  optval_arglist = chainon (optval_arglist, tmp);
           DECL_CONTEXT (tmp) = fndecl;
           DECL_ARTIFICIAL (tmp) = 1;
           DECL_ARG_TYPE (tmp) = boolean_type_node;
           TREE_READONLY (tmp) = 1;
           gfc_finish_decl (tmp);
 
-	  hidden_typelist = TREE_CHAIN (hidden_typelist);
+	  /* The presence flag must be boolean.  */
+	  gcc_assert (TREE_VALUE (optval_typelist) == boolean_type_node);
+	  optval_typelist = TREE_CHAIN (optval_typelist);
 	}
 
       /* For non-constant length array arguments, make sure they use
@@ -2863,6 +2875,9 @@ create_function_arglist (gfc_symbol * sym)
       typelist = TREE_CHAIN (typelist);
     }
 
+  /* Add hidden present status for optional+value arguments.  */
+  arglist = chainon (arglist, optval_arglist);
+
   /* Add the hidden string length parameters, unless the procedure
      is bind(C).  */
   if (!sym->attr.is_bind_c)
diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index def7552ac67..196f2cecbfc 100644
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -3105,6 +3105,7 @@ gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args,
 {
   tree type;
   vec<tree, va_gc> *typelist = NULL;
+  vec<tree, va_gc> *hidden_typelist = NULL;
   gfc_formal_arglist *f;
   gfc_symbol *arg;
   int alternate_return = 0;
@@ -3222,17 +3223,17 @@ gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args,
 	       so that the value can be returned.  */
 	    type = build_pointer_type (gfc_charlen_type_node);
 
-	  vec_safe_push (typelist, type);
+	  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.  */
@@ -3245,11 +3246,15 @@ gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args,
 		  && CLASS_DATA (arg)->attr.codimension
 		  && !CLASS_DATA (arg)->attr.allocatable)))
 	{
-	  vec_safe_push (typelist, pvoid_type_node);  /* caf_token.  */
-	  vec_safe_push (typelist, gfc_array_index_type);  /* caf_offset.  */
+	  vec_safe_push (hidden_typelist, pvoid_type_node);  /* caf_token.  */
+	  vec_safe_push (hidden_typelist, gfc_array_index_type);  /* caf_offset.  */
 	}
     }
 
+  /* Put hidden character length, caf_token, caf_offset at the end.  */
+  vec_safe_reserve (typelist, vec_safe_length (hidden_typelist));
+  vec_safe_splice (typelist, hidden_typelist);
+
   if (!vec_safe_is_empty (typelist)
       || sym->attr.is_main_program
       || sym->attr.if_source != IFSRC_UNKNOWN)
diff --git a/gcc/testsuite/gfortran.dg/coarray/pr107441-caf.f90 b/gcc/testsuite/gfortran.dg/coarray/pr107441-caf.f90
new file mode 100644
index 00000000000..23b2242e217
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/pr107441-caf.f90
@@ -0,0 +1,27 @@
+! { dg-do run }
+!
+! PR fortran/107441
+! Check that with -fcoarray=lib, coarray metadata arguments are passed
+! in the right order to procedures.
+!
+! Contributed by M.Morin
+
+program p
+  integer :: ci[*]
+  ci = 17
+  call s(1, ci, "abcd")
+contains
+  subroutine s(ra, ca, c)
+    integer :: ra, ca[*]
+    character(*) :: c
+    ca[1] = 13
+    if (ra /= 1) stop 1
+    if (this_image() == 1) then
+      if (ca /= 13) stop 2
+    else
+      if (ca /= 17) stop 3
+    end if
+    if (len(c) /= 4) stop 4
+    if (c /= "abcd") stop 5
+  end subroutine s
+end program p
diff --git a/gcc/testsuite/gfortran.dg/optional_absent_6.f90 b/gcc/testsuite/gfortran.dg/optional_absent_6.f90
new file mode 100644
index 00000000000..b8abb06980a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/optional_absent_6.f90
@@ -0,0 +1,60 @@
+! { dg-do run }
+! PR fortran/107441
+!
+! Test VALUE + OPTIONAL for integer/real/...
+! in the presence of non-optional character dummies
+
+program bugdemo
+  implicit none
+  character :: s = 'a'
+  integer   :: t
+
+  t = testoptional(s)
+  call test2 (s)
+  call test3 (s)
+  call test4 (w='123',x=42)
+
+contains
+
+  function testoptional (w, x) result(t)
+    character, intent(in)                  :: w
+    integer,   intent(in), value, optional :: x
+    integer :: t
+    print *, 'present(x) is', present(x)
+    t = 0
+    if (present (x)) stop 1
+  end function testoptional
+
+  subroutine test2 (w, x)
+    character, intent(in)                  :: w
+    integer,   intent(in), value, optional :: x
+    print*, 'present(x) is', present(x)
+    if (present (x)) stop 2
+  end subroutine test2
+
+  subroutine test3 (w, x)
+    character, intent(in),        optional :: w
+    integer,   intent(in), value, optional :: x
+    print *, 'present(w) is', present(w)
+    print *, 'present(x) is', present(x)
+    if (.not. present (w)) stop 3
+    if (present (x)) stop 4
+  end subroutine test3
+
+  subroutine test4 (r, w, x)
+    real,                     value, optional :: r
+    character(*), intent(in),        optional :: w
+    integer,                  value, optional :: x
+    print *, 'present(r) is', present(r)
+    print *, 'present(w) is', present(w)
+    print *, 'present(x) is', present(x)
+    if (present (r)) stop 5
+    if (.not. present (w)) stop 6
+    if (.not. present (x)) stop 7
+    print *, 'x=', x
+    print *, 'len(w)=', len(w)
+    if (len(w) /= 3) stop 8
+    if (x /= 42) stop 9
+  end subroutine test4
+
+end program bugdemo
diff --git a/gcc/testsuite/gfortran.dg/optional_absent_7.f90 b/gcc/testsuite/gfortran.dg/optional_absent_7.f90
new file mode 100644
index 00000000000..1be981c88f6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/optional_absent_7.f90
@@ -0,0 +1,31 @@
+! { dg-do run }
+! { dg-additional-options "-fdump-tree-original" }
+!
+! PR fortran/107441
+! Check that procedure types and procedure decls match when the procedure
+! has both character-typed and optional value args.
+!
+! Contributed by M.Morin
+
+program p
+  interface
+    subroutine i(c, o)
+      character(*) :: c
+      integer, optional, value :: o
+    end subroutine i
+  end interface
+  procedure(i), pointer :: pp
+  pp => s
+  call pp("abcd")
+contains
+  subroutine s(c, o)
+    character(*) :: c
+    integer, optional, value :: o
+    if (present(o)) stop 1
+    if (len(c) /= 4) stop 2
+    if (c /= "abcd") stop 3
+  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 ", integer.*, logical.*, integer.* pp" "original" } }
-- 
2.35.3