procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fortran: Fix some problems blocking associate meta-bug [PR87477]

Browse source 
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.
This commit is contained in:
Paul Thomas 2023-06-02 08:41:45 +01:00
parent a06b9435b9
commit 3c2eba4b7a
9 changed files with 310 additions and 29 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

61
gcc/fortran/parse.cc
View file

@ -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)

3
gcc/fortran/resolve.cc
View file

@ -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",

2
gcc/testsuite/gfortran.dg/associate_54.f90
View file

@ -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

20
gcc/testsuite/gfortran.dg/pr102109.f90 Normal file
View file

@ -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

23
gcc/testsuite/gfortran.dg/pr102112.f90 Normal file
View file

@ -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

74
gcc/testsuite/gfortran.dg/pr102190.f90 Normal file
View file

@ -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

16
gcc/testsuite/gfortran.dg/pr102532.f90 Normal file
View file

@ -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

114
gcc/testsuite/gfortran.dg/pr109948.f90 Normal file
View file

@ -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

26
gcc/testsuite/gfortran.dg/pr99326.f90 Normal file
View file

@ -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