From patchwork Sat Mar 30 09:06:42 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Paul Richard Thomas X-Patchwork-Id: 87842 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 936ED3858C55 for ; Sat, 30 Mar 2024 09:09:54 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-pl1-x636.google.com (mail-pl1-x636.google.com [IPv6:2607:f8b0:4864:20::636]) by sourceware.org (Postfix) with ESMTPS id B8D1A385E45C; Sat, 30 Mar 2024 09:06:57 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org B8D1A385E45C Authentication-Results: sourceware.org; dmarc=pass (p=none dis=none) header.from=gmail.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=gmail.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org B8D1A385E45C Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2607:f8b0:4864:20::636 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1711789683; cv=none; b=QPn5wlur+s1wzfwX4OoUnR6vPYT5GonOeSmMMeFmTNv55331XxFnY3o6ApwCEpz2RGYuKYDE9D5kO4xu46h0MDuF9Imx+uMtGrJPRX9WMIuONmdxBNx38/40SCtWGkntWtCFFvz+SnErBg+jqcJc8ipqd3X0gMsJzUXCvDcL6to= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1711789683; c=relaxed/simple; bh=q7pEsZq78KEUHmUd1QotIWzQYptvI8xmVRNRe22zcVc=; h=DKIM-Signature:MIME-Version:From:Date:Message-ID:Subject:To; b=aHK56jA3vqZi4fe9O330CoH7Ts7y1VR47wts0sUJCLKHAjAHJ7vROUlNUjNa7yrRpwzsHei+VFp1nl4chNrZJxy6d0nS4++FR9M3jZXA/jtYxzq6kByS5VzJbFkGswtw6pNRjBQDAyBBIIVuDYk7oBXxTf0D5EqvhHlWZ1DNy8k= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-pl1-x636.google.com with SMTP id d9443c01a7336-1de0f92e649so18828465ad.0; Sat, 30 Mar 2024 02:06:57 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20230601; t=1711789614; x=1712394414; darn=gcc.gnu.org; h=cc:to:subject:message-id:date:from:mime-version:from:to:cc:subject :date:message-id:reply-to; bh=esQkKh4ZNOwn7FhdS8biRoeN86C8wmgwp3o2Idh5Q6U=; b=WREFrKELCqp9HX7jGeywLDpHm4wUZFEPnoiSC063GSbDAvmMhKuwrHS/rrbu+LoucP pqPzwcnYUx1uRQKoqSgmnyzCcwJ205GO8G3YG8SIfiNXk64F71qNnV1JPJCS5iIv/64b XnQFBM1MRjrBoxJ0dsSjq4eMHS+G6E0KOTS18VgKOOwrVHt93+r2P2Kw5rfiglj6e4r0 1QZPxm+T2C2DbOfBjarUkslZMAH+dD8Xixoqr3uxkK5mOZOhWI5tWHmNO6Gross0pEuX EG8X4UQbuIf+yO2Y+C6LntDX9PB7gWZ2N3eaIrgCIuNlP3TC82tDdRw3Rl7hcPHs/fw4 v0ug== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1711789614; x=1712394414; h=cc:to:subject:message-id:date:from:mime-version:x-gm-message-state :from:to:cc:subject:date:message-id:reply-to; bh=esQkKh4ZNOwn7FhdS8biRoeN86C8wmgwp3o2Idh5Q6U=; b=EZZdiZAds+BgJZIUGNg/O6dpe9KwRXJ2r+01L50yWLV+CH1C6ddwzr2/cGF6Wu18eG z8zQA9Ax3vpfiKjNFwDIgRWm8aLVFirb9cqfcymRcVwGOxH1IkmITnhI9AqCe5+I/lJe Yw2UF7gcXdjrZ57I7icwcm9WJZ2X0/xY0A/1HQbs4PjA4lLC7fWlV9wmWN/0Y2I71G+U 6szKiXpC+ziMWhvXOnOHaghdo+Wv8y3l64B8+7GEjVFM7OWQggOJ8Y++30afIaD6FTmF 0Ssvi7sLc8GOelEcRYVeBTdFNaHFVqp4qnpcBrzIwB5nuOanOZhAgE2tC9jsmCEr6w57 o7MA== X-Forwarded-Encrypted: i=1; AJvYcCX3fqq0ZSnKMnoEVDmJ+DSydp/+flgMGyTWX3UiIkx0reluiqUh2oz/nhFFChzHKwH/PHQZWF9yR1j8WWonxgZqXGg9ZlZcQA== X-Gm-Message-State: AOJu0Yzgj9BfDXe0/4Cx18Kr8HMm67sNGwc2IrzOq2b+7tZR6xd+rjIU MSjxVTV99hsiVIL+nn9KSIYrtG+jWCr+RStSpl/kK+FAJHhAiKu9Bg1Yjs12FxbMkBvGTtGoYpw sEkrUx4O8564CsZdB5LxbSLxRnmYepKZiULE= X-Google-Smtp-Source: AGHT+IFK2532+bj3ieLMppXYr0vH/HlxWJKE4dA2lBBpGmaswEKOQN9eUmPjRQZSq+45ODe7GwriwO1AvRXi6T8iIRQ= X-Received: by 2002:a17:903:1206:b0:1de:ff9f:aee9 with SMTP id l6-20020a170903120600b001deff9faee9mr5644204plh.11.1711789614247; Sat, 30 Mar 2024 02:06:54 -0700 (PDT) MIME-Version: 1.0 From: Paul Richard Thomas Date: Sat, 30 Mar 2024 09:06:42 +0000 Message-ID: Subject: [Patch, fortran] PR112407 - [13/14 Regression] Fix for PR37336 triggers an ICE in gfc_format_decoder while constructing a vtab To: "fortran@gcc.gnu.org" , gcc-patches Cc: trnka@scm.com X-Spam-Status: No, score=-7.4 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, HTML_MESSAGE, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Hi All, This bug emerged in a large code and involves possible recursion with a "hidden" module procedure; ie. where the symtree name starts with '@'. This throws the format decoder. As the last message in the PR shows, I have vacillated between silently passing on the possible recursion or adding an alternative warning message. In the end, as a conservative choice I went for emitting the message. In the course of trying to develop a compact test case, I found that type bound procedures were not being tested for recursion and that class dummies, with intent out, were being incorrectly initialized with an empty default initializer. Both of these have been fixed. Unfortunately, the most compact reproducer that Tomas was able to come up with required more than 100kbytes of module files. I tried from the bottom up but failed. Both the tests check the fixes for the other bugs. Regtests on x86_64 - OK for mainline and, in a couple of weeks, 13-branch? Paul Fortran: Fix wrong recursive errors and class initialization [PR112407] 2024-03-30 Paul Thomas gcc/fortran PR fortran/112407 *resolve.cc (resolve_procedure_expression): Change the test for for recursion in the case of hidden procedures from modules. (resolve_typebound_static): Add warning for possible recursive calls to typebound procedures. * trans-expr.cc (gfc_trans_class_init_assign): Do not apply default initializer to class dummy where component initializers are all null. gcc/testsuite/ PR fortran/112407 * gfortran.dg/pr112407a.f90: New test. * gfortran.dg/pr112407b.f90: New test. 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