Hi all,
attached patch fixes an reject-valid of an array constructor in an associate by
resolving the array constructor before parsing the associate-block. I am not
100% sure, if that is the right place to do this. But given, that there is
already a special casing before the patch, I just propose to do the resolve
there.
Regstests ok on x86_64-pc-linux-gnu / F41. Ok for mainline ?
Regards,
Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
From 0c5315e0d70da9dd107e6057716ff0d4ce89dc9b Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <ve...@gcc.gnu.org>
Date: Fri, 13 Dec 2024 09:06:11 +0100
Subject: [PATCH] Fortran: Fix associate with derived type array construtor
[PR117347]
gcc/fortran/ChangeLog:
PR fortran/117347
* primary.cc (gfc_match_varspec): Resolve array constructors in
associate before parsing the block of the associate.
gcc/testsuite/ChangeLog:
* gfortran.dg/associate_71.f90: New test.
---
gcc/fortran/primary.cc | 6 +++++
gcc/testsuite/gfortran.dg/associate_71.f90 | 28 ++++++++++++++++++++++
2 files changed, 34 insertions(+)
create mode 100644 gcc/testsuite/gfortran.dg/associate_71.f90
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 1db27929eeb..8d6195303a2 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2285,6 +2285,12 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
if (tgt_expr->rank)
sym->ts.u.derived = tgt_expr->ts.u.derived;
}
+ else if (sym->ts.type == BT_UNKNOWN && sym->assoc && !sym->assoc->dangling
+ && tgt_expr->expr_type == EXPR_ARRAY)
+ {
+ gcc_assert (gfc_resolve_expr (tgt_expr));
+ sym->ts = tgt_expr->ts;
+ }
peeked_char = gfc_peek_ascii_char ();
if ((inferred_type && !sym->as && peeked_char == '(')
diff --git a/gcc/testsuite/gfortran.dg/associate_71.f90 b/gcc/testsuite/gfortran.dg/associate_71.f90
new file mode 100644
index 00000000000..716d1b8ff61
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_71.f90
@@ -0,0 +1,28 @@
+! { dg-do run }
+!
+! Check that pr117347 is fixed.
+! Contributed by Ivan Pribec <ivan.pri...@gmail.com>
+
+program pr117347
+ implicit none
+
+ type :: point
+ real :: x = 42.
+ end type point
+
+ type(point) :: mypoint
+ real :: pi(1)
+ associate (points => mypoint ) ! accepted
+ pi(:) = points% x
+ end associate
+ if (any(pi /= 42)) stop 1
+ associate (points => (mypoint)) ! accepted
+ pi(:) = points% x
+ end associate
+ if (any(pi /= 42)) stop 2
+ associate (points => [mypoint]) ! REJECTED
+ pi(:) = points% x
+ end associate
+ if (any(pi /= 42)) stop 3
+end program
+
--
2.47.1
