public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r14-1487] Fortran: Fix some problems blocking associate meta-bug [PR87477]
@ 2023-06-02 7:41 Paul Thomas
0 siblings, 0 replies; only message in thread
From: Paul Thomas @ 2023-06-02 7:41 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:3c2eba4b7a2355ed5099e35332388206c484744d
commit r14-1487-g3c2eba4b7a2355ed5099e35332388206c484744d
Author: Paul Thomas <pault@gcc.gnu.org>
Date: Fri Jun 2 08:41:45 2023 +0100
Fortran: Fix some problems blocking associate meta-bug [PR87477]
2023-06-02 Paul Thomas <pault@gcc.gnu.org>
gcc/fortran
PR fortran/87477
* parse.cc (parse_associate): Replace the existing evaluation
of the target rank with calls to gfc_resolve_ref and
gfc_expression_rank. Identify untyped target function results
with structure constructors by finding the appropriate derived
type.
* resolve.cc (resolve_symbol): Allow associate variables to be
assumed shape.
gcc/testsuite/
PR fortran/87477
* gfortran.dg/associate_54.f90 : Cope with extra error.
PR fortran/102109
* gfortran.dg/pr102109.f90 : New test.
PR fortran/102112
* gfortran.dg/pr102112.f90 : New test.
PR fortran/102190
* gfortran.dg/pr102190.f90 : New test.
PR fortran/102532
* gfortran.dg/pr102532.f90 : New test.
PR fortran/109948
* gfortran.dg/pr109948.f90 : New test.
PR fortran/99326
* gfortran.dg/pr99326.f90 : New test.
Diff:
---
gcc/fortran/parse.cc | 61 ++++++++-------
gcc/fortran/resolve.cc | 3 +-
gcc/testsuite/gfortran.dg/associate_54.f90 | 2 +-
gcc/testsuite/gfortran.dg/pr102109.f90 | 20 +++++
gcc/testsuite/gfortran.dg/pr102112.f90 | 23 ++++++
gcc/testsuite/gfortran.dg/pr102190.f90 | 74 +++++++++++++++++++
gcc/testsuite/gfortran.dg/pr102532.f90 | 16 ++++
gcc/testsuite/gfortran.dg/pr109948.f90 | 114 +++++++++++++++++++++++++++++
gcc/testsuite/gfortran.dg/pr99326.f90 | 26 +++++++
9 files changed, 310 insertions(+), 29 deletions(-)
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index 733294c8cfa..e53b7a42e92 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -5037,6 +5037,7 @@ parse_associate (void)
gfc_state_data s;
gfc_statement st;
gfc_association_list* a;
+ gfc_array_spec *as;
gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C");
@@ -5052,8 +5053,7 @@ parse_associate (void)
for (a = new_st.ext.block.assoc; a; a = a->next)
{
gfc_symbol* sym;
- gfc_ref *ref;
- gfc_array_ref *array_ref;
+ gfc_expr *target;
if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
gcc_unreachable ();
@@ -5070,6 +5070,7 @@ parse_associate (void)
for parsing component references on the associate-name
in case of association to a derived-type. */
sym->ts = a->target->ts;
+ target = a->target;
/* Don’t share the character length information between associate
variable and target if the length is not a compile-time constant,
@@ -5089,31 +5090,37 @@ parse_associate (void)
&& sym->ts.u.cl->length->expr_type == EXPR_CONSTANT))
sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
- /* Check if the target expression is array valued. This cannot always
- be done by looking at target.rank, because that might not have been
- set yet. Therefore traverse the chain of refs, looking for the last
- array ref and evaluate that. */
- array_ref = NULL;
- for (ref = a->target->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY)
- array_ref = &ref->u.ar;
- if (array_ref || a->target->rank)
+ /* Check if the target expression is array valued. This cannot be done
+ by calling gfc_resolve_expr because the context is unavailable.
+ However, the references can be resolved and the rank of the target
+ expression set. */
+ if (target->ref && gfc_resolve_ref (target)
+ && target->expr_type != EXPR_ARRAY
+ && target->expr_type != EXPR_COMPCALL)
+ gfc_expression_rank (target);
+
+ /* Determine whether or not function expressions with unknown type are
+ structure constructors. If so, the function result can be converted
+ to be a derived type.
+ TODO: Deal with references to sibling functions that have not yet been
+ parsed (PRs 89645 and 99065). */
+ if (target->expr_type == EXPR_FUNCTION && target->ts.type == BT_UNKNOWN)
{
- gfc_array_spec *as;
- int dim, rank = 0;
- if (array_ref)
+ gfc_symbol *derived;
+ /* The derived type has a leading uppercase character. */
+ gfc_find_symbol (gfc_dt_upper_string (target->symtree->name),
+ my_ns->parent, 1, &derived);
+ if (derived && derived->attr.flavor == FL_DERIVED)
{
- a->rankguessed = 1;
- /* Count the dimension, that have a non-scalar extend. */
- for (dim = 0; dim < array_ref->dimen; ++dim)
- if (array_ref->dimen_type[dim] != DIMEN_ELEMENT
- && !(array_ref->dimen_type[dim] == DIMEN_UNKNOWN
- && array_ref->end[dim] == NULL
- && array_ref->start[dim] != NULL))
- ++rank;
+ sym->ts.type = BT_DERIVED;
+ sym->ts.u.derived = derived;
}
- else
- rank = a->target->rank;
+ }
+
+ if (target->rank)
+ {
+ int rank = 0;
+ rank = target->rank;
/* When the rank is greater than zero then sym will be an array. */
if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
{
@@ -5124,8 +5131,8 @@ parse_associate (void)
/* Don't just (re-)set the attr and as in the sym.ts,
because this modifies the target's attr and as. Copy the
data and do a build_class_symbol. */
- symbol_attribute attr = CLASS_DATA (a->target)->attr;
- int corank = gfc_get_corank (a->target);
+ symbol_attribute attr = CLASS_DATA (target)->attr;
+ int corank = gfc_get_corank (target);
gfc_typespec type;
if (rank || corank)
@@ -5160,7 +5167,7 @@ parse_associate (void)
as = gfc_get_array_spec ();
as->type = AS_DEFERRED;
as->rank = rank;
- as->corank = gfc_get_corank (a->target);
+ as->corank = gfc_get_corank (target);
sym->as = as;
sym->attr.dimension = 1;
if (as->corank)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 75d61a18856..2ba3101f1fe 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -16091,7 +16091,8 @@ resolve_symbol (gfc_symbol *sym)
if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
|| as->type == AS_ASSUMED_SHAPE)
- && !sym->attr.dummy && !sym->attr.select_type_temporary)
+ && !sym->attr.dummy && !sym->attr.select_type_temporary
+ && !sym->attr.associate_var)
{
if (as->type == AS_ASSUMED_SIZE)
gfc_error ("Assumed size array at %L must be a dummy argument",
diff --git a/gcc/testsuite/gfortran.dg/associate_54.f90 b/gcc/testsuite/gfortran.dg/associate_54.f90
index 680ad5d14a2..8eb95a710b6 100644
--- a/gcc/testsuite/gfortran.dg/associate_54.f90
+++ b/gcc/testsuite/gfortran.dg/associate_54.f90
@@ -24,7 +24,7 @@ contains
subroutine test_alter_state1 (obj, a)
class(test_t), intent(inout) :: obj
integer, intent(in) :: a
- associate (state => obj%state(TEST_STATES)) ! { dg-error "is used as array" }
+ associate (state => obj%state(TEST_STATES)) ! { dg-error "as array|no IMPLICIT type" }
! state = a
state(TEST_STATE) = a ! { dg-error "array reference of a non-array" }
end associate
diff --git a/gcc/testsuite/gfortran.dg/pr102109.f90 b/gcc/testsuite/gfortran.dg/pr102109.f90
new file mode 100644
index 00000000000..2155a45599e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr102109.f90
@@ -0,0 +1,20 @@
+! { dg-do compile }
+!
+! Contributed by Brad Richardson <everythingfunctional@protonmail.com>
+!
+program main
+ type :: sub_obj_t
+ integer :: val
+ end type
+
+ type :: compound_obj_t
+ type(sub_obj_t) :: sub_obj
+ end type
+
+ associate(initial_sub_obj => sub_obj_t(42))
+! print *, initial_sub_obj%val ! Used to work with this uncommented
+ associate(obj => compound_obj_t(initial_sub_obj))
+ if (obj%sub_obj%val .ne. 42) stop 1
+ end associate
+ end associate
+end program
diff --git a/gcc/testsuite/gfortran.dg/pr102112.f90 b/gcc/testsuite/gfortran.dg/pr102112.f90
new file mode 100644
index 00000000000..72057907297
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr102112.f90
@@ -0,0 +1,23 @@
+! { dg-do compile }
+!
+! Contributed by Brad Richardson <everythingfunctional@protonmail.com>
+!
+program main
+ implicit none
+
+ type :: sub_t
+ integer :: val
+ end type
+
+ type :: obj_t
+ type(sub_t) :: sub_obj
+ end type
+
+ associate(initial_sub => sub_t(42))
+ associate(obj => obj_t(initial_sub))
+ associate(sub_obj => obj%sub_obj)
+ if (sub_obj%val .ne. 42) stop 1
+ end associate
+ end associate
+ end associate
+end program
diff --git a/gcc/testsuite/gfortran.dg/pr102190.f90 b/gcc/testsuite/gfortran.dg/pr102190.f90
new file mode 100644
index 00000000000..dd6d953b40c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr102190.f90
@@ -0,0 +1,74 @@
+! { dg-do compile }
+!
+! Contributed by Brad Richardson <everythingfunctional@protonmail.com>
+!
+module sub_m
+ type :: sub_t
+ private
+ integer :: val
+ end type
+
+ interface sub_t
+ module procedure constructor
+ end interface
+
+ interface sub_t_val
+ module procedure t_val
+ end interface
+contains
+ function constructor(val) result(sub)
+ integer, intent(in) :: val
+ type(sub_t) :: sub
+
+ sub%val = val
+ end function
+
+ function t_val(val) result(res)
+ integer :: res
+ type(sub_t), intent(in) :: val
+ res = val%val
+ end function
+end module
+
+module obj_m
+ use sub_m, only: sub_t
+ type :: obj_t
+ private
+ type(sub_t) :: sub_obj_
+ contains
+ procedure :: sub_obj
+ end type
+
+ interface obj_t
+ module procedure constructor
+ end interface
+contains
+ function constructor(sub_obj) result(obj)
+ type(sub_t), intent(in) :: sub_obj
+ type(obj_t) :: obj
+
+ obj%sub_obj_ = sub_obj
+ end function
+
+ function sub_obj(self)
+ class(obj_t), intent(in) :: self
+ type(sub_t) :: sub_obj
+
+ sub_obj = self%sub_obj_
+ end function
+end module
+
+program main
+ use sub_m, only: sub_t, sub_t_val
+ use obj_m, only: obj_t
+ type(sub_t), allocatable :: z
+
+ associate(initial_sub => sub_t(42))
+ associate(obj => obj_t(initial_sub))
+ associate(sub_obj => obj%sub_obj())
+ allocate (z, source = obj%sub_obj())
+ end associate
+ end associate
+ end associate
+ if (sub_t_val (z) .ne. 42) stop 1
+end program
diff --git a/gcc/testsuite/gfortran.dg/pr102532.f90 b/gcc/testsuite/gfortran.dg/pr102532.f90
new file mode 100644
index 00000000000..714379a6ac2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr102532.f90
@@ -0,0 +1,16 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! Contributed by Gerhard Steinmetz <gscfq@t-online.de>
+!
+subroutine foo
+ character(:), allocatable :: x[:]
+ associate (y => x(:)(2:)) ! { dg-error "Rank mismatch|deferred type parameter" }
+ end associate
+end
+
+subroutine bar
+ character(:), allocatable :: x[:]
+ associate (y => x(:)(:)) ! { dg-error "Rank mismatch|deferred type parameter" }
+ end associate
+end
\ No newline at end of file
diff --git a/gcc/testsuite/gfortran.dg/pr109948.f90 b/gcc/testsuite/gfortran.dg/pr109948.f90
new file mode 100644
index 00000000000..41d54d8c76c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr109948.f90
@@ -0,0 +1,114 @@
+! { dg-do compile }
+!
+! Tests the fix for PR109948
+!
+! Contributed by Rimvydas Jasinskas <rimvydas.jas@gmail.com>
+!
+module mm
+ implicit none
+ interface operator(==)
+ module procedure eq_1_2
+ end interface operator(==)
+ private :: eq_1_2
+contains
+ logical function eq_1_2 (x, y)
+ integer, intent(in) :: x(:)
+ real, intent(in) :: y(:,:)
+ eq_1_2 = .true.
+ end function eq_1_2
+end module mm
+
+program pr109948
+ use mm
+ implicit none
+ type tlap
+ integer, allocatable :: z(:)
+ end type tlap
+ type ulap
+ type(tlap) :: u(2)
+ end type ulap
+ integer :: pid = 1
+ call comment0 ! Original problem
+ call comment1
+ call comment3 ([5,4,3,2,1])
+ call comment10
+ call comment11 ([5,4,3,2,1])
+contains
+ subroutine comment0
+ type(tlap) :: y_in
+ integer :: x_out(3) =[0.0,0.0,0.0]
+ y_in%z = [1,-2,3]
+ call foo(y_in, x_out)
+ if (any (x_out .ne. [0, -2, 0])) stop 1
+ call foo(y_in, x_out)
+ if (any (x_out .ne. [1, -2, 3])) stop 2
+ end subroutine comment0
+
+ subroutine foo(y, x)
+ type(tlap) :: y
+ integer :: x(:)
+ associate(z=>y%z)
+ if (pid == 1) then
+ where ( z < 0 ) x(:) = z(:)
+ else
+ where ( z > 0 ) x(:) = z(:)
+ endif
+ pid = pid + 1
+ end associate
+ end subroutine foo
+
+ subroutine comment1
+ type(tlap) :: grib
+ integer :: i
+ grib%z = [3,2,1]
+ associate(k=>grib%z)
+ i = k(1)
+ if (any(k==1)) i = 1
+ end associate
+ if (i .eq. 3) stop 3
+ end subroutine comment1
+
+ subroutine comment3(k_2d)
+ implicit none
+ integer :: k_2d(:)
+ integer :: i
+ associate(k=>k_2d)
+ i = k(1)
+ if (any(k==1)) i = 1
+ end associate
+ if (i .eq. 3) stop 4
+ end subroutine comment3
+
+ subroutine comment11(k_2d)
+ implicit none
+ integer :: k_2d(:)
+ integer :: m(1) = 42
+ real :: r(1,1) = 3.0
+ if ((m == r) .neqv. .true.) stop 5
+ associate (k=>k_2d)
+ if ((k == r) .neqv. .true.) stop 6 ! failed to find user defined operator
+ end associate
+ associate (k=>k_2d(:))
+ if ((k == r) .neqv. .true.) stop 7
+ end associate
+ end subroutine comment11
+
+ subroutine comment10
+ implicit none
+ type(ulap) :: z(2)
+ integer :: i
+ real :: r(1,1) = 3.0
+ z(1)%u = [tlap([1,2,3]),tlap([4,5,6])]
+ z(2)%u = [tlap([7,8,9]),tlap([10,11,12])]
+ associate (k=>z(2)%u(1)%z)
+ i = k(1)
+ if (any(k==8)) i = 1
+ end associate
+ if (i .ne. 1) stop 8
+ associate (k=>z(1)%u(2)%z)
+ if ((k == r) .neqv. .true.) stop 9
+ if (any (k .ne. [4,5,6])) stop 10
+ end associate
+ end subroutine comment10
+end program pr109948
+
diff --git a/gcc/testsuite/gfortran.dg/pr99326.f90 b/gcc/testsuite/gfortran.dg/pr99326.f90
new file mode 100644
index 00000000000..75d1f50c238
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr99326.f90
@@ -0,0 +1,26 @@
+! { dg-do compile }
+! internal compiler error: in gfc_build_dummy_array_decl, at
+! fortran/trans-decl.cc:1317
+!
+! Contributed by Gerhard Steinmetz <gscfq@t-online.de>
+!
+program p
+ type t0
+ integer :: i
+ end type
+ type t
+ class(t0), allocatable :: a(:)
+ end type
+ class(t0), allocatable :: arg(:)
+ allocate (arg, source = [t0(1), t0(2)])
+ call s(arg)
+contains
+ subroutine s(x)
+ class(t0) :: x(:)
+ type(t) :: z
+ associate (y => x)
+ z%a = y
+ end associate
+ if (size(z%a) .ne. 2) stop 1
+ end
+end
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2023-06-02 7:41 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-06-02 7:41 [gcc r14-1487] Fortran: Fix some problems blocking associate meta-bug [PR87477] Paul Thomas
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).