https://gcc.gnu.org/g:351fc7565610574f7677972b0d9c4559eaff32f0
commit r13-9223-g351fc7565610574f7677972b0d9c4559eaff32f0
Author: Paul Thomas <pa...@gcc.gnu.org>
Date: Wed Nov 13 08:57:55 2024 +0000
Fortran: Fix failing character pointer fcn assignment [PR105054]
2024-11-14 Paul Thomas <pa...@gcc.gnu.org>
gcc/fortran
PR fortran/105054
* resolve.cc (get_temp_from_expr): If the pointer function has
a deferred character length, generate a new deferred charlen
for the temporary.
gcc/testsuite/
PR fortran/105054
* gfortran.dg/ptr_func_assign_6.f08: New test.
(cherry picked from commit f530a8c61383b174a476b64f46d56adeedf49dc4)
Diff:
---
gcc/fortran/resolve.cc | 11 +++
gcc/testsuite/gfortran.dg/ptr_func_assign_6.f08 | 89 +++++++++++++++++++++++++
2 files changed, 100 insertions(+)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index adfde61bbdb1..6f13725cac57 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -12120,6 +12120,17 @@ resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace
*ns)
tmp_ptr_expr->symtree->n.sym->attr.allocatable = 0;
tmp_ptr_expr->where = (*code)->loc;
+ /* A new charlen is required to ensure that the variable string length
+ is different to that of the original lhs for deferred results. */
+ if (s->result->ts.deferred && tmp_ptr_expr->ts.type == BT_CHARACTER)
+ {
+ tmp_ptr_expr->ts.u.cl = gfc_get_charlen();
+ tmp_ptr_expr->ts.deferred = 1;
+ tmp_ptr_expr->ts.u.cl->next = gfc_current_ns->cl_list;
+ gfc_current_ns->cl_list = tmp_ptr_expr->ts.u.cl;
+ tmp_ptr_expr->symtree->n.sym->ts.u.cl = tmp_ptr_expr->ts.u.cl;
+ }
+
this_code = build_assignment (EXEC_ASSIGN,
tmp_ptr_expr, (*code)->expr2,
NULL, NULL, (*code)->loc);
diff --git a/gcc/testsuite/gfortran.dg/ptr_func_assign_6.f08
b/gcc/testsuite/gfortran.dg/ptr_func_assign_6.f08
new file mode 100644
index 000000000000..d62815d7afad
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ptr_func_assign_6.f08
@@ -0,0 +1,89 @@
+! { dg-do run }
+!
+! Test the fix for PR105054.
+!
+! Contributed by Arjen Markus <arjen.markus...@gmail.com>
+!
+module string_pointers
+ implicit none
+ character(len=20), dimension(10), target :: array_strings
+ character(len=:), dimension(:), target, allocatable :: array_strings2
+
+contains
+
+function pointer_to_string( i , flag)
+ integer, intent(in) :: i, flag
+
+ character(len=:), pointer :: pointer_to_string
+
+ if (flag == 1) then
+ pointer_to_string => array_strings(i)
+ return
+ endif
+
+ if (.not.allocated (array_strings2)) allocate (array_strings2(4), &
+ mold = ' ')
+ pointer_to_string => array_strings2(i)
+end function pointer_to_string
+
+function pointer_to_string2( i , flag) result (res)
+ integer, intent(in) :: i, flag
+
+ character(len=:), pointer :: res
+
+ if (flag == 1) then
+ res => array_strings(i)
+ return
+ endif
+
+ if (.not.allocated (array_strings2)) allocate (array_strings2(4), &
+ mold = ' ')
+ res => array_strings2(i)
+end function pointer_to_string2
+
+end module string_pointers
+
+program chk_string_pointer
+ use string_pointers
+ implicit none
+ integer :: i
+ character(*), parameter :: chr(4) = ['1234 ','ABCDefgh ', &
+ '12345678 ',' ']
+
+ pointer_to_string(1, 1) = '1234567890'
+ pointer_to_string(2, 1) = '12345678901234567890'
+
+ if (len(pointer_to_string(3, 1)) /= 20) stop 1
+
+ array_strings(1) = array_strings(1)(1:4) // 'ABC'
+ if (pointer_to_string(1, 1) /= '1234ABC') stop 2
+
+ pointer_to_string(1, 2) = '1234'
+ pointer_to_string(2, 2) = 'ABCDefgh'
+ pointer_to_string(3, 2) = '12345678'
+
+ do i = 1, 3
+ if (trim (array_strings2(i)) /= trim(chr(i))) stop 3
+ enddo
+
+! Clear the target arrays
+ array_strings = repeat (' ', 20)
+ deallocate (array_strings2)
+
+! Repeat with an explicit result.
+ pointer_to_string2(1, 1) = '1234567890'
+ pointer_to_string2(2, 1) = '12345678901234567890'
+
+ if (len(pointer_to_string(3, 1)) /= 20) stop 4
+
+ array_strings(1) = array_strings(1)(1:4) // 'ABC'
+ if (pointer_to_string(1, 1) /= '1234ABC') stop 5
+
+ pointer_to_string2(1, 2) = '1234'
+ pointer_to_string2(2, 2) = 'ABCDefgh'
+ pointer_to_string2(3, 2) = '12345678'
+
+ do i = 1, 3
+ if (trim (array_strings2(i)) /= trim(chr(i))) stop 6
+ enddo
+end program chk_string_pointer
