@@ -4919,6 +4919,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");
@@ -4934,8 +4935,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 ();
@@ -4952,6 +4952,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,
@@ -4971,31 +4972,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))
{
@@ -5006,8 +5013,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)
@@ -5042,7 +5049,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)
@@ -16087,7 +16087,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",
@@ -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
new file mode 100644
@@ -0,0 +1,20 @@
+! { dg-do run }
+!
+! 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
new file mode 100644
@@ -0,0 +1,23 @@
+! { dg-do run }
+!
+! 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
new file mode 100644
@@ -0,0 +1,74 @@
+! { dg-do run }
+!
+! 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
new file mode 100644
@@ -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
new file mode 100644
@@ -0,0 +1,114 @@
+! { dg-do run }
+!
+! 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
+
new file mode 100644
@@ -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
Hi All, This started out as the search for a fix to pr109948 and evolved to roll in 5 other prs. Basically parse_associate was far too clunky and, in anycase, existing functions in resolve.cc were well capable of doing the determination of the target expression rank. While I was checking the comments, the lightbulb flashed with respect to prs 102109/112/190 and the chunk dealing with function results of unknown type was born. Thanks to the changes in parse.cc, the problem in pr99326 migrated upstream to the resolution and the chunklet in resolve.cc was an obvious fix. I am minded to s/{ dg-do run}/{ dg-do compile } for all six testcases. At the testing stage, I wanted to check that the testcases actually did what they are supposed to do :-) Bootstraps and regtests OK - good for head? Paul PS I need to do some housekeeping on pr87477 now. Some of the blockers have "fixed themselves" and others are awaiting backporting. I think that there are only 4 or so left, of which 89645 and 99065 are the most difficult to deal with.