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

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

[FX Coudert]

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

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

[Harald Anlauf]

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

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


[-- Attachment #2: pr100651-v2.diff --]
[-- Type: text/x-patch, Size: 5295 bytes --]

From 63879942b491e23eefc6da4d80c5492434e42ec8 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Tue, 28 Nov 2023 20:19:14 +0100
Subject: [PATCH] Fortran: deferred-length character optional dummy arguments
 [PR93762,PR100651]

gcc/fortran/ChangeLog:

	PR fortran/93762
	PR fortran/100651
	* 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-expr.cc                     |  22 +++-
 .../gfortran.dg/optional_deferred_char_1.f90  | 100 ++++++++++++++++++
 2 files changed, 118 insertions(+), 4 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/optional_deferred_char_1.f90

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index bfe9996ced6..c90c7bbf936 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -2116,10 +2116,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..0fb0fb5fea1
--- /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 ()    ! this fails with -fsanitize=undefined
+  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

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

[Harald Anlauf]

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

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
>

[-- Attachment #2: pr100651-v3.diff --]
[-- Type: text/x-patch, Size: 6239 bytes --]

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

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

[FX Coudert]

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

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

[Harald Anlauf]

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

Dear all,

the attached patch fixes the passing of deferred-length character
to optional dummy arguments: the character length shall be passed
by reference, not by value.

Original analysis of the issue by Steve in PR93762, independently
done by FX in PR100651.  The patch fixes both PRs.

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

As the fix is local and affects only deferred-length character,
would it be ok to backport to 13-branch?

Thanks,
Harald


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: pr100651.diff --]
[-- Type: text/x-patch, Size: 5418 bytes --]

From 8ce1c8e7d0390361a1507000b7abbf6509b2fee9 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Mon, 27 Nov 2023 20:19:11 +0100
Subject: [PATCH] Fortran: deferred-length character optional dummy arguments
 [PR93762,PR100651]

gcc/fortran/ChangeLog:

	PR fortran/93762
	PR fortran/100651
	* 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-expr.cc                     |  22 +++-
 .../gfortran.dg/optional_deferred_char_1.f90  | 100 ++++++++++++++++++
 2 files changed, 118 insertions(+), 4 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/optional_deferred_char_1.f90

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 50c4604a025..e992f60d8bb 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -2116,10 +2116,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