Re: [PATCH] Fortran: fix passing array component to polymorphic argument [PR105658]
Hi Peter,
thanks for your contribution to gfortran! You've found indeed
a solution for a potentially annoying bug.
Am 15.02.24 um 18:50 schrieb Peter Hill:
Dear all,
The attached patch fixes PR105658 by forcing an array temporary to be
created. This is required when passing an array component, but this
didn't happen if the dummy argument was an unlimited polymorphic type.
The problem bit of code is in `gfc_conv_expr_descriptor`, near L7828:
subref_array_target = (is_subref_array (expr)
&& (se->direct_byref
|| expr->ts.type == BT_CHARACTER));
need_tmp = (gfc_ref_needs_temporary_p (expr->ref)
&& !subref_array_target);
where `need_tmp` is being evaluated to 0. The logic here isn't clear
to me, and this function is used in several places, which is why I
went with setting `parmse.force_tmp = 1` in `gfc_conv_procedure_call`
and using the same conditional as the later branch for the
non-polymorphic case (near the call to `gfc_conv_subref_array_arg`)
If this patch is ok, please could someone commit it for me? This is my
first patch for GCC, so apologies in advance if the commit message is
missing something.
Your patch mostly does the right thing. Note that when fsym is
an unlimited polymorphic, some of its attributes are buried deep
within its internal representation. I would also prefer to move
the code to gfc_conv_intrinsic_to_class where it seems to fit better,
like:
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index a0593b76f18..db906caa52e 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1019,6 +1019,14 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse,
gfc_expr *e,
tmp = gfc_typenode_for_spec (&class_ts);
var = gfc_create_var (tmp, "class");
+ /* Force a temporary for component or substring references. */
+ if (unlimited_poly
+ && class_ts.u.derived->components->attr.dimension
+ && !class_ts.u.derived->components->attr.class_pointer
+ && !class_ts.u.derived->components->attr.allocatable
+ && is_subref_array (e))
+parmse->force_tmp = 1;
+
/* Set the vptr. */
ctree = gfc_class_vptr_get (var);
(I am not entirely sure whether we need to exclude pointer and
allocatable attributes here explicitly, given the constraints
in F2023:15.5.2.6, but other may have an opinion, too.
The above should be safe anyway.)
Tested on x86_64-pc-linux-gnu.
The bug is present in gfortran back to 4.9, so should it also be backported?
I think we'll target 14-mainline and might consider a backport to
13-branch.
Cheers,
Peter
PR fortran/105658
gcc/fortran/ChangeLog
* trans-expr.cc (gfc_conv_procedure_call): When passing an
array component reference of intrinsic type to a procedure
with an unlimited polymorphic dummy argument, a temporary
should be created.
gcc/testsuite/ChangeLog
* gfortran.dg/PR105658.f90: New test.
---
gcc/fortran/trans-expr.cc | 8
gcc/testsuite/gfortran.dg/PR105658.f90 | 25 +
2 files changed, 33 insertions(+)
create mode 100644 gcc/testsuite/gfortran.dg/PR105658.f90
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index a0593b76f18..7fd3047c4e9 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6439,6 +6439,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
CLASS object for the unlimited polymorphic formal. */
gfc_find_vtab (&e->ts);
gfc_init_se (&parmse, se);
+ /* The actual argument is a component reference to an array
+ of derived types, so we need to force creation of a
+ temporary */
+ if (e->expr_type == EXPR_VARIABLE
+ && is_subref_array (e)
+ && !(fsym && fsym->attr.pointer))
+ parmse.force_tmp = 1;
+
gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
}
diff --git a/gcc/testsuite/gfortran.dg/PR105658.f90
b/gcc/testsuite/gfortran.dg/PR105658.f90
new file mode 100644
index 000..407ee25f77c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/PR105658.f90
@@ -0,0 +1,25 @@
+! { dg-do compile }
+! { dg-options "-Warray-temporaries" }
+! Test fix for incorrectly passing array component to unlimited
polymorphic procedure
+
+module test_PR105658_mod
+ implicit none
+ type :: foo
+integer :: member1
+integer :: member2
+ end type foo
+contains
+ subroutine print_poly(array)
+class(*), dimension(:), intent(in) :: array
+select type(array)
+type is (integer)
+ print*, array
+end select
+ end subroutine print_poly
+
+ subroutine do_print(thing)
+type(foo), dimension(3), intent(in) :: thing
+call print_poly(thing%member1) ! { dg-warning "array temporary" }
+ end subroutine do_print
+
+end module test_PR105658_mod
One could extend this testcase to cover substrings as well:
module test_PR105658_mod
implicit none
type :: foo
integer :: member1
integer :: member2
end type foo
contains
subroutine print_poly(arra
[PATCH] Fortran: deferred length of character variables shall not get lost [PR113911]
Dear all,
this patch fixes a regression which was a side-effect of r14-8947,
losing the length of a deferred-length character variable when
passed as a dummy.
The new testcase provides a workout for deferred length to improve
coverage in the testsuite. Another temporarily disabled test was
re-enabled.
Regtested on x86_64-pc-linux-gnu. OK for mainline?
Thanks,
Harald
From 07fcdf7c9f9272d8e4752c23f04795d02d4ad440 Mon Sep 17 00:00:00 2001
From: Harald Anlauf
Date: Fri, 16 Feb 2024 22:33:16 +0100
Subject: [PATCH] Fortran: deferred length of character variables shall not get
lost [PR113911]
PR fortran/113911
gcc/fortran/ChangeLog:
* trans-array.cc (gfc_trans_deferred_array): Do not clobber
deferred length for a character variable passed as dummy argument.
gcc/testsuite/ChangeLog:
* gfortran.dg/allocatable_length_2.f90: New test.
* gfortran.dg/bind_c_optional-2.f90: Enable deferred-length test.
---
gcc/fortran/trans-array.cc| 2 +-
.../gfortran.dg/allocatable_length_2.f90 | 107 ++
.../gfortran.dg/bind_c_optional-2.f90 | 3 +-
3 files changed, 109 insertions(+), 3 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/allocatable_length_2.f90
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 2181990aa04..3673fa40720 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -11531,7 +11531,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
if (sym->ts.type == BT_CHARACTER
&& !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
{
- if (sym->ts.deferred && !sym->ts.u.cl->length)
+ if (sym->ts.deferred && !sym->ts.u.cl->length && !sym->attr.dummy)
gfc_add_modify (&init, sym->ts.u.cl->backend_decl,
build_zero_cst (TREE_TYPE (sym->ts.u.cl->backend_decl)));
gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
diff --git a/gcc/testsuite/gfortran.dg/allocatable_length_2.f90 b/gcc/testsuite/gfortran.dg/allocatable_length_2.f90
new file mode 100644
index 000..2fd64efdc25
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocatable_length_2.f90
@@ -0,0 +1,107 @@
+! { dg-do run }
+! PR fortran/113911
+!
+! Test that deferred length is not lost
+
+module m
+ integer, parameter:: n = 100, l = 10
+ character(l) :: a = 'a234567890', b(n) = 'bcdefghijk'
+ character(:), allocatable :: c1, c2(:)
+end
+
+program p
+ use m, only : l, n, a, b, x => c1, y => c2
+ implicit none
+ character(:), allocatable :: d, e(:)
+ allocate (d, source=a)
+ allocate (e, source=b)
+ if (len (d) /= l .or. len (e) /= l .or. size (e) /= n) stop 12
+ call plain_deferred (d, e)
+ call optional_deferred (d, e)
+ call optional_deferred_ar (d, e)
+ if (len (d) /= l .or. len (e) /= l .or. size (e) /= n) stop 13
+ deallocate (d, e)
+ call alloc (d, e)
+ if (len (d) /= l .or. len (e) /= l .or. size (e) /= n) stop 14
+ deallocate (d, e)
+ call alloc_host_assoc ()
+ if (len (d) /= l .or. len (e) /= l .or. size (e) /= n) stop 15
+ deallocate (d, e)
+ call alloc_use_assoc ()
+ if (len (x) /= l .or. len (y) /= l .or. size (y) /= n) stop 16
+ call indirect (x, y)
+ if (len (x) /= l .or. len (y) /= l .or. size (y) /= n) stop 17
+ deallocate (x, y)
+contains
+ subroutine plain_deferred (c1, c2)
+character(:), allocatable :: c1, c2(:)
+if (.not. allocated (c1) .or. .not. allocated (c2)) stop 1
+if (len (c1) /= l) stop 2
+if (len (c2) /= l) stop 3
+if (c1(1:3)/= "a23") stop 4
+if (c2(5)(1:3) /= "bcd") stop 5
+ end
+
+ subroutine optional_deferred (c1, c2)
+character(:), allocatable, optional :: c1, c2(:)
+if (.not. present (c1) .or. .not. present (c2)) stop 6
+if (.not. allocated (c1) .or. .not. allocated (c2)) stop 7
+if (len (c1) /= l) stop 8
+if (len (c2) /= l) stop 9
+if (c1(1:3)/= "a23") stop 10
+if (c2(5)(1:3) /= "bcd") stop 11
+ end
+
+ ! Assumed rank
+ subroutine optional_deferred_ar (c1, c2)
+character(:), allocatable, optional :: c1(..)
+character(:), allocatable, optional :: c2(..)
+if (.not. present (c1) .or. &
+.not. present (c2)) stop 21
+if (.not. allocated (c1) .or. &
+.not. allocated (c2)) stop 22
+
+select rank (c1)
+rank (0)
+if (len (c1) /= l) stop 23
+ if (c1(1:3) /= "a23") stop 24
+rank default
+ stop 25
+end select
+
+select rank (c2)
+rank (1)
+ if (len (c2) /= l) stop 26
+ if (c2(5)(1:3) /= "bcd") stop 27
+rank default
+ stop 28
+end select
+ end
+
+ ! Allocate dummy arguments
+ subroutine alloc (c1, c2)
+character(:), allocatable :: c1, c2(:)
+allocate (c1, source=a)
+allocate (c2, source=b)
+ end
+
+ ! Allocate host-associated variables
+ subroutine alloc_host_assoc ()
+allocate (d, source=a)
+allocate (e, source=b)
+ end
+
+ ! Allocate use-associated variables
+ subroutine alloc_use_assoc ()
+allocate (x, source=a)
Re: [PATCH] Fortran: deferred length of character variables shall not get lost [PR113911]
On 2/16/24 1:40 PM, Harald Anlauf wrote: Dear all, this patch fixes a regression which was a side-effect of r14-8947, losing the length of a deferred-length character variable when passed as a dummy. The new testcase provides a workout for deferred length to improve coverage in the testsuite. Another temporarily disabled test was re-enabled. Regtested on x86_64-pc-linux-gnu. OK for mainline? Thanks, Harald Yes OK for mainline. Thanks, Jerry
[patch, libgfortran] PR107068 Run-time error when reading logical arrays with a namelist
The attached patch fixes this one. Se the ChangeLog below for explanation.
OK for trunk?
I think simple enough to backport to 13 as well.
Regards,
Jerry
Author: Jerry DeLisle
Date: Fri Feb 16 17:06:37 2024 -0800
libgfortran: Fix namelist read.
PR libgfortran/107068
libgfortran/ChangeLog:
* io/list_read.c (read_logical): When looking for a possible
variable name, check for left paren, indicating a possible
array reference.
gcc/testsuite/ChangeLog:
* gfortran.dg/pr107068.f90: New test.
diff --git a/gcc/testsuite/gfortran.dg/pr107068.f90 b/gcc/testsuite/gfortran.dg/pr107068.f90
new file mode 100644
index 000..c5ea0c1d244
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr107068.f90
@@ -0,0 +1,22 @@
+! { dg-do run }
+program test
+ implicit none
+ integer :: error
+ logical, dimension(3,3) :: flc,flp
+ namelist/inputdata/flc, flp
+
+ flc = .false.
+ flp = .false.
+
+ open(10, file="inputfile")
+ write(10,*) "&INPUTDATA"
+ write(10,*) " FLC = T, "
+ write(10,*) " FLP(1,2) = T,"
+ write(10,*) "/"
+ rewind(10)
+ !write(*, nml=inputdata)
+ !open(10,file="inputfile")
+ read(10,inputdata,iostat=error)
+ close(10, status='delete')
+ if (error /= 0) stop 20
+end program test
diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c
index f8ca64422de..0b7884fdda7 100644
--- a/libgfortran/io/list_read.c
+++ b/libgfortran/io/list_read.c
@@ -888,6 +888,14 @@ read_logical (st_parameter_dt *dtp, int length)
for(i = 0; i < 63; i++)
{
c = next_char (dtp);
+ if (c == '(')
+ {
+ l_push_char (dtp, c);
+ dtp->u.p.nml_read_error = 1;
+ dtp->u.p.line_buffer_enabled = 1;
+ dtp->u.p.line_buffer_pos = 0;
+ return;
+ }
if (is_separator(c))
{
/* All done if this is not a namelist read. */
[patch, libgfortran] Bug 105473 - semicolon allowed when list-directed read integer with decimal='point'
Hello,
I posted the attached patch in bugzilla some time ago. This includes a
new test case. The patch adds additional checks in key places to catch
eroneous use of semicolons
Regression tested on x86_64,
OK for trunk and later backport to 13?
Jerrydiff --git a/gcc/testsuite/gfortran.dg/pr105473.f90 b/gcc/testsuite/gfortran.dg/pr105473.f90
new file mode 100644
index 000..b309217540d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr105473.f90
@@ -0,0 +1,46 @@
+! { dg-do run }
+! PR libgfortran/105473
+ implicit none
+ integer n,m,ios
+ real r
+ complex z
+ character(40):: testinput
+ n = 999; m = 777; r=1.2345
+ z = cmplx(0.0,0.0)
+
+! Check that semi-colon is not allowed as separator with decimal=point.
+ ios=0
+ testinput = '1;17;3.14159'
+ read(testinput,*,decimal='point',iostat=ios) n, m, r
+ if (ios /= 5010) print *, "stop 1"
+
+! Check that comma is not allowed as a separator with decimal=comma.
+ ios=0
+ testinput = '1,17,3,14159'
+ read(testinput,*,decimal='comma',iostat=ios) n, m, r
+ if (ios /= 5010) print *, "stop 2"
+
+! Check a good read.
+ ios=99
+ testinput = '1;17;3,14159'
+ read(testinput,*,decimal='comma',iostat=ios) n, m, r
+ if (ios /= 0) print *, "stop 3"
+
+! Check that comma is not allowed as a separator with decimal=comma.
+ ios=99; z = cmplx(0.0,0.0)
+ testinput = '1,17, (3,14159, 1,7182)'
+ read(testinput,*,decimal='comma', iostat=ios) n, m, z
+ if (ios /= 5010) stop 4
+
+! Check that semi-colon is not allowed as separator with decimal=point.
+ ios=99; z = cmplx(0.0,0.0)
+ testinput = '1,17; (3.14159; 1.7182)'
+ read(testinput,*,decimal='point', iostat=ios) n, m, z
+ if (ios /= 5010) stop 5
+
+! Check a good read.
+ ios=99;z = cmplx(0.0,0.0)
+ testinput = '1;17; (3,14159; 1,7182)'
+ read(testinput,*,decimal='comma', iostat=ios) n, m, z
+ if (ios /= 0) stop 6
+end program
diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c
index 0b7884fdda7..d2316ad6fe2 100644
--- a/libgfortran/io/list_read.c
+++ b/libgfortran/io/list_read.c
@@ -53,7 +53,6 @@ typedef unsigned char uchar;
#define CASE_SEPARATORS /* Fall through. */ \
case ' ': case ',': case '/': case '\n': \
case '\t': case '\r': case ';'
-
/* This macro assumes that we're operating on a variable. */
#define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
@@ -475,11 +474,23 @@ eat_separator (st_parameter_dt *dtp)
case ',':
if (dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
{
+ generate_error (&dtp->common, LIBERROR_READ_VALUE,
+ "Comma not allowed as separator with DECIMAL='comma'");
unget_char (dtp, c);
break;
}
- /* Fall through. */
+ dtp->u.p.comma_flag = 1;
+ eat_spaces (dtp);
+ break;
+
case ';':
+ if (dtp->u.p.current_unit->decimal_status == DECIMAL_POINT)
+ {
+ generate_error (&dtp->common, LIBERROR_READ_VALUE,
+ "Semicolon not allowed as separator with DECIMAL='point'");
+ unget_char (dtp, c);
+ break;
+ }
dtp->u.p.comma_flag = 1;
eat_spaces (dtp);
break;
@@ -1326,8 +1337,13 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length)
{
if ((c = next_char (dtp)) == EOF)
goto bad;
- if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
- c = '.';
+ if (dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
+ {
+ if (c == '.')
+ goto bad;
+ if (c == ',')
+ c = '.';
+ }
switch (c)
{
CASE_DIGITS:
@@ -1636,8 +1652,18 @@ read_real (st_parameter_dt *dtp, void *dest, int length)
seen_dp = 0;
c = next_char (dtp);
- if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
-c = '.';
+ if (dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
+{
+ if (c == '.')
+ goto bad_real;
+ if (c == ',')
+ c = '.';
+}
+ if (dtp->u.p.current_unit->decimal_status == DECIMAL_POINT)
+{
+ if (c == ';')
+ goto bad_real;
+}
switch (c)
{
CASE_DIGITS:
@@ -1677,8 +1703,13 @@ read_real (st_parameter_dt *dtp, void *dest, int length)
for (;;)
{
c = next_char (dtp);
- if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
- c = '.';
+ if (dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
+ {
+ if (c == '.')
+ goto bad_real;
+ if (c == ',')
+ c = '.';
+ }
switch (c)
{
CASE_DIGITS:
@@ -1718,7 +1749,7 @@ read_real (st_parameter_dt *dtp, void *dest, int length)
CASE_SEPARATORS:
case EOF:
- if (c != '\n' && c != ',' && c != '\r' && c != ';')
+ if (c != '\n' && c != ',' && c != ';' && c != '\r')
unget_char (dtp, c);
goto done;
diff --git a/libgfortran/io/read.c b/libgfortran/io/read.c
index e2d2f8be806..7a9e341d7d8 100644
--- a/libgfortran/io/read.c
+++ b/libgfortran/io/read.c
@@ -1062,8 +1062,17 @@ read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
case ',':
if (dtp->u.p.current_unit->decimal_status != DECIMAL_C
