diff mbox series

[v3] Fortran: deferred-length character optional dummy arguments [PR93762,PR100651]

Message ID 113f01fc-c9de-48aa-a936-6b3acb906a4c@gmx.de
State New
Headers show
Series [v3] Fortran: deferred-length character optional dummy arguments [PR93762,PR100651] | expand

Commit Message

Harald Anlauf Dec. 1, 2023, 9:53 p.m. UTC 
Dear all,

this patch extends the previous version by adding further code testing
the presence of an optional deferred-length character argument also
in the function initialization code.  This allows to re-enable a
commented-out test in v2.

Regtested on x86_64-pc-linux-gnu.  OK for mainline?

Thanks,
Harald


On 11/28/23 20:56, Harald Anlauf wrote:
> Hi FX,
>
> On 11/28/23 18:07, FX Coudert wrote:
>> Hi Harald,
>>
>> The patch looks OK to me. Probably wait a bit for another opinion,
>> since I’m not that active and I may have missed something.
>>
>> Thanks,
>> FX
>
> thanks for having a look.
>
> In the meantime I got an automated mail from the Linaro testers.
> According to it there is a runtime failure of the testcase on
> aarch64.  I couldn't see any useful traceback or else.
>
> I tried the testcase on x86 with different options and found
> an unexpected result only with -fsanitize=undefined and only
> for the case of a rank-1 dummy when there is no actual argument
> and the passed to another subroutine.  (valgrind is happy.)
>
> Reduced reproducer:
>
> ! this fails with -fsanitize=undefined
> program main
>    call test_rank1 ()
> contains
>    subroutine test_rank1 (msg1)
>      character(:), optional, allocatable :: msg1(:)
>      if (present (msg1)) stop 77
>      call assert_rank1 ()        ! <- no problem here
>      call assert_rank1 (msg1)    ! <- problematic code path
>    end
>
>    subroutine assert_rank1 (msg2)
>      character(:), optional, allocatable :: msg2(:)
>      if (present (msg2)) stop 99 ! <- no problem if commented
>    end
> end
>
>
> As far as I can tell, this could be a pre-existing (latent)
> issue.  By looking at the tree-dump, the only thing that
> appears fishy has been there before.  But then I am only
> guessing that this is the problem observed on aarch64.
>
> I have disabled the related call in the testcase of the
> attached revised version.  As I do not see anything else,
> I wonder if one could proceed with the current version
> but open a PR for the reduced case above, unless someone
> can pinpoint the place that is responsible for the above
> failure.  (Is it the caller, or rather the function entry
> code in the callee?)
>
> Cheers,
> Harald
>

Comments

FX Coudert Dec. 2, 2023, 10:10 a.m. UTC | #1 
Hi,

> this patch extends the previous version by adding further code testing
> the presence of an optional deferred-length character argument also
> in the function initialization code.  This allows to re-enable a
> commented-out test in v2.

Nice, that sounds logical.

> Regtested on x86_64-pc-linux-gnu.  OK for mainline?

OK.

FX
diff mbox series

Patch

From b0a169bd70c9cd175c25b4a9543b24058596bf5e Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Fri, 1 Dec 2023 22:44:30 +0100
Subject: [PATCH] Fortran: deferred-length character optional dummy arguments
 [PR93762,PR100651]

gcc/fortran/ChangeLog:

	PR fortran/93762
	PR fortran/100651
	* trans-array.cc (gfc_trans_deferred_array): Add presence check
	for optional deferred-length character dummy arguments.
	* trans-expr.cc (gfc_conv_missing_dummy): The character length for
	deferred-length dummy arguments is passed by reference, so that
	its value can be returned.  Adjust handling for optional dummies.

gcc/testsuite/ChangeLog:

	PR fortran/93762
	PR fortran/100651
	* gfortran.dg/optional_deferred_char_1.f90: New test.
---
 gcc/fortran/trans-array.cc                    |   9 ++
 gcc/fortran/trans-expr.cc                     |  22 +++-
 .../gfortran.dg/optional_deferred_char_1.f90  | 100 ++++++++++++++++++
 3 files changed, 127 insertions(+), 4 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/optional_deferred_char_1.f90

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index bbb81f40aa9..82f60a656f3 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -11430,6 +11430,15 @@  gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
     {
       gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
       gfc_trans_vla_type_sizes (sym, &init);
+
+      /* Presence check of optional deferred-length character dummy.  */
+      if (sym->ts.deferred && sym->attr.dummy && sym->attr.optional)
+	{
+	  tmp = gfc_finish_block (&init);
+	  tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym),
+			  tmp, build_empty_stmt (input_location));
+	  gfc_add_expr_to_block (&init, tmp);
+	}
     }
 
   /* Dummy, use associated and result variables don't need anything special.  */
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 6a47af39c57..ea087294249 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -2125,10 +2125,24 @@  gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
 
   if (ts.type == BT_CHARACTER)
     {
-      tmp = build_int_cst (gfc_charlen_type_node, 0);
-      tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
-			     present, se->string_length, tmp);
-      tmp = gfc_evaluate_now (tmp, &se->pre);
+      /* Handle deferred-length dummies that pass the character length by
+	 reference so that the value can be returned.  */
+      if (ts.deferred && INDIRECT_REF_P (se->string_length))
+	{
+	  tmp = gfc_build_addr_expr (NULL_TREE, se->string_length);
+	  tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+				 present, tmp, null_pointer_node);
+	  tmp = gfc_evaluate_now (tmp, &se->pre);
+	  tmp = build_fold_indirect_ref_loc (input_location, tmp);
+	}
+      else
+	{
+	  tmp = build_int_cst (gfc_charlen_type_node, 0);
+	  tmp = fold_build3_loc (input_location, COND_EXPR,
+				 gfc_charlen_type_node,
+				 present, se->string_length, tmp);
+	  tmp = gfc_evaluate_now (tmp, &se->pre);
+	}
       se->string_length = tmp;
     }
   return;
diff --git a/gcc/testsuite/gfortran.dg/optional_deferred_char_1.f90 b/gcc/testsuite/gfortran.dg/optional_deferred_char_1.f90
new file mode 100644
index 00000000000..d399dd11ca2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/optional_deferred_char_1.f90
@@ -0,0 +1,100 @@ 
+! { dg-do run }
+! PR fortran/93762
+! PR fortran/100651 - deferred-length character as optional dummy argument
+
+program main
+  implicit none
+  character(:), allocatable :: err_msg, msg3(:)
+  character(:), pointer     :: err_msg2 => NULL()
+
+  ! Subroutines with optional arguments
+  call to_int ()
+  call to_int_p ()
+  call test_rank1 ()
+  call assert_code ()
+  call assert_p ()
+  call assert_rank1 ()
+
+  ! Test passing of optional arguments
+  call to_int (err_msg)
+  if (.not. allocated (err_msg)) stop 1
+  if (len (err_msg) /= 7)        stop 2
+  if (err_msg(1:7) /= "foo bar") stop 3
+
+  call to_int2 (err_msg)
+  if (.not. allocated (err_msg)) stop 4
+  if (len (err_msg) /= 7)        stop 5
+  if (err_msg(1:7) /= "foo bar") stop 6
+  deallocate (err_msg)
+
+  call to_int_p (err_msg2)
+  if (.not. associated (err_msg2)) stop 11
+  if (len (err_msg2) /= 8)         stop 12
+  if (err_msg2(1:8) /= "poo bla ") stop 13
+  deallocate (err_msg2)
+
+  call to_int2_p (err_msg2)
+  if (.not. associated (err_msg2)) stop 14
+  if (len (err_msg2) /= 8)         stop 15
+  if (err_msg2(1:8) /= "poo bla ") stop 16
+  deallocate (err_msg2)
+
+  call test_rank1 (msg3)
+  if (.not. allocated (msg3)) stop 21
+  if (len (msg3) /= 2)        stop 22
+  if (size (msg3) /= 42)      stop 23
+  if (any (msg3 /= "ok"))     stop 24
+  deallocate (msg3)
+
+contains
+
+  ! Deferred-length character, allocatable:
+  subroutine assert_code (err_msg0)
+    character(:), optional, allocatable :: err_msg0
+    if (present (err_msg0)) err_msg0 = 'foo bar'
+  end
+  ! Test: optional argument
+  subroutine to_int (err_msg1)
+    character(:), optional, allocatable :: err_msg1
+    call assert_code (err_msg1)
+  end
+  ! Control: non-optional argument
+  subroutine to_int2 (err_msg2)
+    character(:), allocatable :: err_msg2
+    call assert_code (err_msg2)
+  end
+
+  ! Rank-1:
+  subroutine assert_rank1 (msg)
+    character(:), optional, allocatable, intent(out) :: msg(:)
+    if (present (msg)) then
+       allocate (character(2) :: msg(42))
+       msg(:) = "ok"
+    end if
+  end
+
+  subroutine test_rank1 (msg1)
+    character(:), optional, allocatable, intent(out) :: msg1(:)
+    call assert_rank1 (msg1)
+  end
+
+  ! Deferred-length character, pointer:
+  subroutine assert_p (err_msg0)
+    character(:), optional, pointer :: err_msg0
+    if (present (err_msg0)) then
+       if (associated (err_msg0)) deallocate (err_msg0)
+       allocate (character(8) :: err_msg0)
+       err_msg0 = 'poo bla'
+    end if
+  end
+
+  subroutine to_int_p (err_msg1)
+    character(:), optional, pointer :: err_msg1
+    call assert_p (err_msg1)
+  end
+
+  subroutine to_int2_p (err_msg2)
+    character(:), pointer :: err_msg2
+    call assert_p (err_msg2)
+  end
+end
-- 
2.35.3