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");
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 ();
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,
&& 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))
{
/* 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)
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)
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",
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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
git://gcc.gnu.org / gcc.git / commitdiff