From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: 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 From: =?UTF-8?Q?Jos=c3=a9_Rui_Faustino_de_Sousa?= 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-Type: multipart/mixed; boundary="------------F5ACA18CEA63839B675310AD" 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: fortran@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Fortran mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Mon, 12 Apr 2021 01:13:33 -0000 This is a multi-part message in MIME format. --------------F5ACA18CEA63839B675310AD Content-Type: text/plain; charset=utf-8; format=flowed Content-Transfer-Encoding: 8bit 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. --------------F5ACA18CEA63839B675310AD Content-Type: text/x-patch; charset=UTF-8; name="PR100040.patch" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename="PR100040.patch" 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 --------------F5ACA18CEA63839B675310AD--