diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 50d51b06c92..43315a6a550 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -1963,12 +1963,20 @@ resolve_procedure_expression (gfc_expr* expr) || (sym->attr.function && sym->result == sym)) return true; - /* A non-RECURSIVE procedure that is used as procedure expression within its + /* A non-RECURSIVE procedure that is used as procedure expression within its own body is in danger of being called recursively. */ if (is_illegal_recursion (sym, gfc_current_ns)) - gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling" - " itself recursively. Declare it RECURSIVE or use" - " %<-frecursive%>", sym->name, &expr->where); + { + if (sym->attr.use_assoc && expr->symtree->name[0] == '@') + gfc_warning (0, "Non-RECURSIVE procedure %qs from module %qs is " + " possibly calling itself recursively in procedure %qs. " + " Declare it RECURSIVE or use %<-frecursive%>", + sym->name, sym->module, gfc_current_ns->proc_name->name); + else + gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling" + " itself recursively. Declare it RECURSIVE or use" + " %<-frecursive%>", sym->name, &expr->where); + } return true; } @@ -6820,6 +6828,13 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree** target, if (st) *target = st; } + + if (is_illegal_recursion ((*target)->n.sym, gfc_current_ns) + && !e->value.compcall.tbp->deferred) + gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling" + " itself recursively. Declare it RECURSIVE or use" + " %<-frecursive%>", (*target)->n.sym->name, &e->where); + return true; } diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 76bed9830c4..3b54874cf1f 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -1719,6 +1719,7 @@ gfc_trans_class_init_assign (gfc_code *code) tree tmp; gfc_se dst,src,memsz; gfc_expr *lhs, *rhs, *sz; + gfc_component *cmp; gfc_start_block (&block); @@ -1735,6 +1736,21 @@ gfc_trans_class_init_assign (gfc_code *code) /* The _def_init is always scalar. */ rhs->rank = 0; + /* Check def_init for initializers. If this is a dummy with all default + initializer components NULL, return NULL_TREE and use the passed value as + required by F2018(8.5.10). */ + if (!lhs->ref && lhs->symtree->n.sym->attr.dummy) + { + cmp = rhs->ref->next->u.c.component->ts.u.derived->components; + for (; cmp; cmp = cmp->next) + { + if (cmp->initializer) + break; + else if (!cmp->next) + return build_empty_stmt (input_location); + } + } + if (code->expr1->ts.type == BT_CLASS && CLASS_DATA (code->expr1)->attr.dimension) { @@ -12511,11 +12527,14 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, gfc_add_block_to_block (&body, &lse.pre); gfc_add_expr_to_block (&body, tmp); - /* Add the post blocks to the body. */ - if (!l_is_temp) + /* Add the post blocks to the body. Scalar finalization must appear before + the post block in case any dellocations are done. */ + if (rse.finalblock.head + && (!l_is_temp || (expr2->expr_type == EXPR_FUNCTION + && gfc_expr_attr (expr2).elemental))) { - gfc_add_block_to_block (&rse.finalblock, &rse.post); gfc_add_block_to_block (&body, &rse.finalblock); + gfc_add_block_to_block (&body, &rse.post); } else gfc_add_block_to_block (&body, &rse.post); diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc index 7f50b16aee9..badad6ae892 100644 --- a/gcc/fortran/trans.cc +++ b/gcc/fortran/trans.cc @@ -1624,7 +1624,7 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived, } else if (derived && gfc_is_finalizable (derived, NULL)) { - if (derived->attr.zero_comp && !rank) + if (!derived->components && (!rank || attr.elemental)) { /* Any attempt to assign zero length entities, causes the gimplifier all manner of problems. Instead, a variable is created to act as @@ -1675,7 +1675,7 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived, final_fndecl); if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) { - if (is_class) + if (is_class || attr.elemental) desc = gfc_conv_scalar_to_descriptor (se, desc, attr); else { @@ -1685,7 +1685,7 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived, } } - if (derived && derived->attr.zero_comp) + if (derived && !derived->components) { /* All the conditions below break down for zero length derived types. */ tmp = build_call_expr_loc (input_location, final_fndecl, 3, diff --git a/gcc/testsuite/gfortran.dg/finalize_54.f90 b/gcc/testsuite/gfortran.dg/finalize_54.f90 new file mode 100644 index 00000000000..73d32b1b333 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/finalize_54.f90 @@ -0,0 +1,47 @@ +! { dg-do compile } +! Test the fix for PR113885, where not only was there a gimplifier ICE +! for a derived type 't' with no components but, with a component, gfortran +! gave wrong results. +! Contributed by David Binderman +! +module types + type t + contains + final :: finalize + end type t +contains + pure subroutine finalize(x) + type(t), intent(inout) :: x + end subroutine finalize +end module types + +subroutine test1(x) + use types + interface + elemental function elem(x) + use types + type(t), intent(in) :: x + type(t) :: elem + end function elem + end interface + type(t) :: x(:) + x = elem(x) +end subroutine test1 + +subroutine test2(x) + use types + interface + elemental function elem(x) + use types + type(t), intent(in) :: x + type(t) :: elem + end function elem + elemental function elem2(x, y) + use types + type(t), intent(in) :: x, y + type(t) :: elem2 + end function elem2 + end interface + type(t) :: x(:) + x = elem2(elem(x), elem(x)) +end subroutine test2 diff --git a/gcc/testsuite/gfortran.dg/finalize_55.f90 b/gcc/testsuite/gfortran.dg/finalize_55.f90 new file mode 100644 index 00000000000..fa7e552eea5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/finalize_55.f90 @@ -0,0 +1,89 @@ +! { dg-do run } +! Test the fix for PR113885, where not only was there a gimplifier ICE +! for a derived type 't' with no components but this version gave wrong +! results. +! Contributed by David Binderman +! +module types + type t + integer :: i + contains + final :: finalize + end type t + integer :: ctr = 0 +contains + impure elemental subroutine finalize(x) + type(t), intent(inout) :: x + ctr = ctr + 1 + end subroutine finalize +end module types + +impure elemental function elem(x) + use types + type(t), intent(in) :: x + type(t) :: elem + elem%i = x%i + 1 +end function elem + +impure elemental function elem2(x, y) + use types + type(t), intent(in) :: x, y + type(t) :: elem2 + elem2%i = x%i + y%i +end function elem2 + +subroutine test1(x) + use types + interface + impure elemental function elem(x) + use types + type(t), intent(in) :: x + type(t) :: elem + end function elem + end interface + type(t) :: x(:) + type(t), allocatable :: y(:) + y = x + x = elem(y) +end subroutine test1 + +subroutine test2(x) + use types + interface + impure elemental function elem(x) + use types + type(t), intent(in) :: x + type(t) :: elem + end function elem + impure elemental function elem2(x, y) + use types + type(t), intent(in) :: x, y + type(t) :: elem2 + end function elem2 + end interface + type(t) :: x(:) + type(t), allocatable :: y(:) + y = x + x = elem2(elem(y), elem(y)) +end subroutine test2 + +program test113885 + use types + interface + subroutine test1(x) + use types + type(t) :: x(:) + end subroutine + subroutine test2(x) + use types + type(t) :: x(:) + end subroutine + end interface + type(t) :: x(2) = [t(1),t(2)] + call test1 (x) + if (any (x%i .ne. [2,3])) stop 1 + if (ctr .ne. 6) stop 2 + call test2 (x) + if (any (x%i .ne. [6,8])) stop 3 + if (ctr .ne. 16) stop 4 +end diff --git a/gcc/testsuite/gfortran.dg/finalize_56.f90 b/gcc/testsuite/gfortran.dg/finalize_56.f90 new file mode 100644 index 00000000000..bd350a3bc1c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/finalize_56.f90 @@ -0,0 +1,168 @@ +! { dg-do run } +! Test the fix for PR110987 +! Segfaulted in runtime, as shown below. +! Contributed by Kirill Chankin +! and John Haiducek (comment 5) +! +MODULE original_mod + IMPLICIT NONE + + TYPE T1_POINTER + CLASS(T1), POINTER :: T1 + END TYPE + + TYPE T1 + INTEGER N_NEXT + CLASS(T1_POINTER), ALLOCATABLE :: NEXT(:) + CONTAINS + FINAL :: T1_DESTRUCTOR + PROCEDURE :: SET_N_NEXT => T1_SET_N_NEXT + PROCEDURE :: GET_NEXT => T1_GET_NEXT + END TYPE + + INTERFACE T1 + PROCEDURE T1_CONSTRUCTOR + END INTERFACE + + TYPE, EXTENDS(T1) :: T2 + REAL X + CONTAINS + END TYPE + + INTERFACE T2 + PROCEDURE T2_CONSTRUCTOR + END INTERFACE + + TYPE, EXTENDS(T1) :: T3 + CONTAINS + FINAL :: T3_DESTRUCTOR + END TYPE + + INTERFACE T3 + PROCEDURE T3_CONSTRUCTOR + END INTERFACE + + INTEGER :: COUNTS = 0 + +CONTAINS + + TYPE(T1) FUNCTION T1_CONSTRUCTOR() RESULT(L) + IMPLICIT NONE + L%N_NEXT = 0 + END FUNCTION + + SUBROUTINE T1_DESTRUCTOR(SELF) + IMPLICIT NONE + TYPE(T1), INTENT(INOUT) :: SELF + IF (ALLOCATED(SELF%NEXT)) THEN + DEALLOCATE(SELF%NEXT) + ENDIF + END SUBROUTINE + + SUBROUTINE T3_DESTRUCTOR(SELF) + IMPLICIT NONE + TYPE(T3), INTENT(IN) :: SELF + if (.NOT.ALLOCATED (SELF%NEXT)) COUNTS = COUNTS + 1 + END SUBROUTINE + + SUBROUTINE T1_SET_N_NEXT(SELF, N_NEXT) + IMPLICIT NONE + CLASS(T1), INTENT(INOUT) :: SELF + INTEGER, INTENT(IN) :: N_NEXT + INTEGER I + SELF%N_NEXT = N_NEXT + ALLOCATE(SELF%NEXT(N_NEXT)) + DO I = 1, N_NEXT + NULLIFY(SELF%NEXT(I)%T1) + ENDDO + END SUBROUTINE + + FUNCTION T1_GET_NEXT(SELF) RESULT(NEXT) + IMPLICIT NONE + CLASS(T1), TARGET, INTENT(IN) :: SELF + CLASS(T1), POINTER :: NEXT + CLASS(T1), POINTER :: L + INTEGER I + IF (SELF%N_NEXT .GE. 1) THEN + NEXT => SELF%NEXT(1)%T1 + RETURN + ENDIF + NULLIFY(NEXT) + END FUNCTION + + TYPE(T2) FUNCTION T2_CONSTRUCTOR() RESULT(L) + IMPLICIT NONE + L%T1 = T1() + CALL L%T1%SET_N_NEXT(1) + END FUNCTION + + TYPE(T3) FUNCTION T3_CONSTRUCTOR() RESULT(L) + IMPLICIT NONE + L%T1 = T1() + END FUNCTION + +END MODULE original_mod + +module comment5_mod + type::parent + character(:), allocatable::name + end type parent + type, extends(parent)::child + contains + final::child_finalize + end type child + interface child + module procedure new_child + end interface child + integer :: counts = 0 + +contains + + type(child) function new_child(name) + character(*)::name + new_child%name=name + end function new_child + + subroutine child_finalize(this) + type(child), intent(in)::this + counts = counts + 1 + end subroutine child_finalize +end module comment5_mod + +PROGRAM TEST_PROGRAM + call original + call comment5 +contains + subroutine original + USE original_mod + IMPLICIT NONE + TYPE(T1), TARGET :: X1 + TYPE(T2), TARGET :: X2 + TYPE(T3), TARGET :: X3 + CLASS(T1), POINTER :: L + X1 = T1() + X2 = T2() + X2%NEXT(1)%T1 => X1 + X3 = T3() + CALL X3%SET_N_NEXT(1) + X3%NEXT(1)%T1 => X2 + L => X3 + DO WHILE (.TRUE.) + L => L%GET_NEXT() ! Used to segfault here in runtime + IF (.NOT. ASSOCIATED(L)) EXIT + COUNTS = COUNTS + 1 + ENDDO +! Two for T3 finalization and two for associated 'L's + IF (COUNTS .NE. 4) STOP 1 + end subroutine original + + subroutine comment5 + use comment5_mod, only: child, counts + implicit none + type(child)::kid + kid = child("Name") + if (.not.allocated (kid%name)) stop 2 + if (kid%name .ne. "Name") stop 3 + if (counts .ne. 2) stop 4 + end subroutine comment5 +END PROGRAM diff --git a/gcc/testsuite/gfortran.dg/pr112407a.f90 b/gcc/testsuite/gfortran.dg/pr112407a.f90 new file mode 100644 index 00000000000..81ef8bd55a4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr112407a.f90 @@ -0,0 +1,70 @@ +! { dg-do run } +! Test of an issue found in the investigation of PR112407 +! Contributed by Tomas Trnka +! +module m + private new_t + + type s + procedure(),pointer,nopass :: op + end type + + type :: t + integer :: i + type (s) :: s + contains + procedure :: new_t + procedure :: bar + procedure :: add_t + generic :: new => new_t, bar + generic, public :: assignment(=) => add_t + final :: final_t + end type + + integer :: i = 0, finals = 0 + +contains + recursive subroutine new_t (arg1, arg2) + class(t), intent(out) :: arg1 + type(t), intent(in) :: arg2 + i = i + 1 + + print "(a,2i4)", "new_t", arg1%i, arg2%i + if (i .ge. 10) return + +! According to F2018(8.5.10), arg1 should be undefined on invocation, unless +! any sub-components are default initialised. gfc used to set arg1%i = 0. + if (arg1%i .ne. arg2%i) then + arg1%i = arg2%i + call arg1%new(arg2) + endif + end + + subroutine bar(arg) + class(t), intent(out) :: arg + call arg%new(t(42, s(new_t))) + end + + subroutine add_t (arg1, arg2) + class(t), intent(out) :: arg1 + type(t), intent(in) :: arg2 + call arg1%new (arg2) + end + + impure elemental subroutine final_t (arg1) + type(t), intent(in) :: arg1 + finals = finals + 1 + end +end + + use m + class(t), allocatable :: x + allocate(x) + call x%new() ! gfortran used to output 10*'new_t' + print "(3i4)", x%i, i, finals ! -||- 0 10 11 +! +! The other brands output 2*'new_t' + 42 2 3 and now so does gfc :-) + if (x%i .ne. 42) stop 1 + if (i .ne. 2) stop 2 + if (finals .ne. 3) stop 3 +end diff --git a/gcc/testsuite/gfortran.dg/pr112407b.f90 b/gcc/testsuite/gfortran.dg/pr112407b.f90 new file mode 100644 index 00000000000..e541825d616 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr112407b.f90 @@ -0,0 +1,56 @@ +! { dg-do compile } +! Test of an issue found in the investigation of PR112407 +! Contributed by Tomas Trnka +! +module m + private new_t + + type s + procedure(),pointer,nopass :: op + end type + + type :: t + integer :: i + type (s) :: s + contains + procedure :: new_t + procedure :: bar + procedure :: add_t + generic :: new => new_t, bar + generic, public :: assignment(=) => add_t + final :: final_t + end type + + integer :: i = 0, finals = 0 + +contains + subroutine new_t (arg1, arg2) ! gfortran didn't detect the recursion + class(t), intent(out) :: arg1 + type(t), intent(in) :: arg2 + i = i + 1 + + print *, "new_t", arg1%i, arg2%i + if (i .ge. 10) return + + if (arg1%i .ne. arg2%i) then + arg1%i = arg2%i + call arg1%new(arg2) ! { dg-warning "possibly calling itself recursively" } + endif + end + + subroutine bar(arg) + class(t), intent(out) :: arg + call arg%new(t(42, s(new_t))) + end + + subroutine add_t (arg1, arg2) + class(t), intent(out) :: arg1 + type(t), intent(in) :: arg2 + call arg1%new (arg2) + end + + impure elemental subroutine final_t (arg1) + type(t), intent(in) :: arg1 + finals = finals + 1 + end +end