diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index 5e2a95688d2..3947444f17c 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -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) diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 83e45f1b693..c0515fd0c97 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -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", 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..8f3cecbe239 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr102109.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! +! Contributed by Brad Richardson +! +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..cde9cbf52e2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr102112.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! +! Contributed by Brad Richardson +! +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..48968430161 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr102190.f90 @@ -0,0 +1,74 @@ +! { dg-do run } +! +! Contributed by Brad Richardson +! +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 +! +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..4d963539396 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr109948.f90 @@ -0,0 +1,114 @@ +! { dg-do run } +! +! Tests the fix for PR109948 +! +! Contributed by Rimvydas Jasinskas +! +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 +! +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