From patchwork Mon Apr 12 01:13:29 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Jos=C3=A9_Rui_Faustino_de_Sousa?= X-Patchwork-Id: 1464926 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=sourceware.org; envelope-from=gcc-patches-bounces@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.a=rsa-sha256 header.s=default header.b=DMa/y3vV; dkim-atps=neutral Received: from sourceware.org (server2.sourceware.org [8.43.85.97]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature RSA-PSS (4096 bits) server-digest SHA256) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 4FJW2v1Y3sz9sW0 for ; Mon, 12 Apr 2021 11:13:41 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 42A78383541D; Mon, 12 Apr 2021 01:13:35 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 42A78383541D DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1618190015; bh=YlOyhqhZ92zqoF3ILbKWYmRjAPJB5Nm4aryYbcg2vG8=; h=To:Subject:Date:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:From; b=DMa/y3vV5HHxQv8Y+9G/Zbuj+0JxmcAG4mJ+RyFPDopYeeQeAvlSP8QDBHV4DWqlr ZXZdU0zB1orXTQOXqETMBGVNB3buQlGauyiaGWtWXExwUNlA2fxqXy/vg4diUcBbbu Myy6ZQO1LqEEjjlUvciMeGJ5PnEtWoYBxzHBLTYo= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x433.google.com (mail-wr1-x433.google.com [IPv6:2a00:1450:4864:20::433]) by sourceware.org (Postfix) with ESMTPS id D97CE385801A; Mon, 12 Apr 2021 01:13:31 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.3.2 sourceware.org D97CE385801A Received: by mail-wr1-x433.google.com with SMTP id a6so11163032wrw.8; Sun, 11 Apr 2021 18:13:31 -0700 (PDT) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20161025; h=x-gm-message-state:to:from:subject:message-id:date:user-agent :mime-version:content-language; bh=YlOyhqhZ92zqoF3ILbKWYmRjAPJB5Nm4aryYbcg2vG8=; b=ejENIrJTZ4ANWcXkfhvVZihNo9+/CJP8aHpMelDzSt2KBtdN/4q1O4qE8EtVMJLG1G sdu+z9hlIivvkLy3Dfqq8RENzYm57FZRqp5EZ8kHlsF3A09Wn3ahcSqIY6Aeh8x24Yoj qhRexuXB2gY5Ak6K1UgrCoalfpMJkaRrQON7pCaDo/5IWr6U+/CkG0tgY85VXsiOpViM fZcl/Om/66ZzFQjI/IGIc3jbUm+pMTz5hjQI/Dky0ViD+ldLSOT/JBiLNOPuwmhsyESY JFNF1k3oebBF8DWb8d2rhK+XFIv5dXxD6eSxf+UhvqmYKFAPWK9+ugizBK9cWZYDgIwK 3DjQ== X-Gm-Message-State: AOAM533IOnN97G1671EDRJn0FQeQFfaaKrnlwE9405xqiITKks0jTBQg G5rYlff0cuYMAI9NqSc4STQOniW9xH0= X-Google-Smtp-Source: ABdhPJwqB8kCdVlitiWFGoDoD30JKUFgPcmCNS/Em2Wg4SCatPf/bLt2hP8V6rdwy2e775mrwQHUOQ== X-Received: by 2002:adf:ea48:: with SMTP id j8mr20852358wrn.365.1618190010876; Sun, 11 Apr 2021 18:13:30 -0700 (PDT) Received: from ?IPv6:2001:8a0:7d5c:3000:2ed0:ded3:af84:6ff8? ([2001:8a0:7d5c:3000:2ed0:ded3:af84:6ff8]) by smtp.googlemail.com with ESMTPSA id j23sm12525472wmo.33.2021.04.11.18.13.29 (version=TLS1_3 cipher=TLS_AES_128_GCM_SHA256 bits=128/128); Sun, 11 Apr 2021 18:13:30 -0700 (PDT) To: fortran@gcc.gnu.org, gcc-patches@gcc.gnu.org Subject: [Patch, fortran] PR fortran/100029 - ICE on storage_size with polymorphic argument, PR fortran/100040 - Wrong code with intent out assumed-rank allocatable Message-ID: Date: Mon, 12 Apr 2021 01:13:29 +0000 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:68.0) Gecko/20100101 Thunderbird/68.10.0 MIME-Version: 1.0 Content-Language: en-US X-Spam-Status: No, score=-12.4 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.2 X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: =?utf-8?q?Jos=C3=A9_Rui_Faustino_de_Sousa_via_Gcc-patches?= From: =?utf-8?q?Jos=C3=A9_Rui_Faustino_de_Sousa?= Reply-To: =?utf-8?q?Jos=C3=A9_Rui_Faustino_de_Sousa?= Errors-To: gcc-patches-bounces@gcc.gnu.org Sender: "Gcc-patches" Hi All! Proposed patch to: PR100040 - Wrong code with intent out assumed-rank allocatable PR100029 - ICE on subroutine call with allocatable polymorphic assumed-rank argument Patch tested only on x86_64-pc-linux-gnu. Made sure the code also recognized assumed-rank arrays as full arrays. Changed the order of free and class to class conversion so that the free occurs first so that there are no problems with freeing an unexpected type of transformed class. Thank you very much. Best regards, José Rui Fortran: Fix ICE and wrong code emission [PR100029, PR100040] gcc/fortran/ChangeLog: PR fortran/100040 * trans-expr.c (gfc_conv_class_to_class): add code to have assumed-rank arrays recognized as full arrays and fix the type of the array assignment. PR fortran/100029 * trans-expr.c (gfc_conv_procedure_call): change order of code blocks, such that the free occurs first. gcc/testsuite/ChangeLog: PR fortran/100029 * gfortran.dg/PR100029.f90: New test. PR fortran/100040 * gfortran.dg/PR100040.f90: New test. diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 2fa17b36c03..35b784ab782 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1099,8 +1099,10 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, return; /* Test for FULL_ARRAY. */ - if (e->rank == 0 && gfc_expr_attr (e).codimension - && gfc_expr_attr (e).dimension) + if (e->rank == 0 + && ((gfc_expr_attr (e).codimension && gfc_expr_attr (e).dimension) + || (class_ts.u.derived->components->as + && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK))) full_array = true; else gfc_is_class_array_ref (e, &full_array); @@ -1148,8 +1150,12 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, && e->rank != class_ts.u.derived->components->as->rank) { if (e->rank == 0) - gfc_add_modify (&parmse->post, gfc_class_data_get (parmse->expr), - gfc_conv_descriptor_data_get (ctree)); + { + tmp = gfc_class_data_get (parmse->expr); + gfc_add_modify (&parmse->post, tmp, + fold_convert (TREE_TYPE (tmp), + gfc_conv_descriptor_data_get (ctree))); + } else class_array_data_assign (&parmse->post, parmse->expr, ctree, true); } @@ -6111,23 +6117,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, base_object = build_fold_indirect_ref_loc (input_location, parmse.expr); - /* A class array element needs converting back to be a - class object, if the formal argument is a class object. */ - if (fsym && fsym->ts.type == BT_CLASS - && e->ts.type == BT_CLASS - && ((CLASS_DATA (fsym)->as - && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK) - || CLASS_DATA (e)->attr.dimension)) - gfc_conv_class_to_class (&parmse, e, fsym->ts, false, - fsym->attr.intent != INTENT_IN - && (CLASS_DATA (fsym)->attr.class_pointer - || CLASS_DATA (fsym)->attr.allocatable), - fsym->attr.optional - && e->expr_type == EXPR_VARIABLE - && e->symtree->n.sym->attr.optional, - CLASS_DATA (fsym)->attr.class_pointer - || CLASS_DATA (fsym)->attr.allocatable); - /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is allocated on entry, it must be deallocated. */ if (fsym && fsym->attr.intent == INTENT_OUT @@ -6186,6 +6175,22 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_add_expr_to_block (&se->pre, tmp); } + /* A class array element needs converting back to be a + class object, if the formal argument is a class object. */ + if (fsym && fsym->ts.type == BT_CLASS + && e->ts.type == BT_CLASS + && ((CLASS_DATA (fsym)->as + && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK) + || CLASS_DATA (e)->attr.dimension)) + gfc_conv_class_to_class (&parmse, e, fsym->ts, false, + fsym->attr.intent != INTENT_IN + && (CLASS_DATA (fsym)->attr.class_pointer + || CLASS_DATA (fsym)->attr.allocatable), + fsym->attr.optional + && e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.optional, + CLASS_DATA (fsym)->attr.class_pointer + || CLASS_DATA (fsym)->attr.allocatable); if (fsym && (fsym->ts.type == BT_DERIVED || fsym->ts.type == BT_ASSUMED) diff --git a/gcc/testsuite/gfortran.dg/PR100029.f90 b/gcc/testsuite/gfortran.dg/PR100029.f90 new file mode 100644 index 00000000000..1fef06fd2d3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR100029.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! +! Test the fix for PR100029 +! + +program foo_p + + implicit none + + type :: foo_t + end type foo_t + + class(foo_t), allocatable :: pout + + call foo_s(pout) + stop + +contains + + subroutine foo_s(that) + class(foo_t), allocatable, intent(out) :: that(..) + + return + end subroutine foo_s + +end program foo_p diff --git a/gcc/testsuite/gfortran.dg/PR100040.f90 b/gcc/testsuite/gfortran.dg/PR100040.f90 new file mode 100644 index 00000000000..23128fa5328 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR100040.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! +! Test the fix for PR100040 +! + +program foo_p + + implicit none + + integer, parameter :: n = 11 + + type :: foo_t + integer :: i + end type foo_t + + type(foo_t), parameter :: a = foo_t(n) + + class(foo_t), allocatable :: pout + + call foo_s(pout) + if(.not.allocated(pout)) stop 1 + if(pout%i/=n) stop 2 + stop + +contains + + subroutine foo_s(that) + class(foo_t), allocatable, intent(out) :: that(..) + + select rank(that) + rank(0) + that = a + rank default + stop 3 + end select + return + end subroutine foo_s + +end program foo_p