From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from rock.gnat.com (rock.gnat.com [IPv6:2620:20:4000:0:a9e:1ff:fe9b:1d1]) by sourceware.org (Postfix) with ESMTP id 174CB3A7643D for ; Wed, 28 Apr 2021 09:41:41 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.3.2 sourceware.org 174CB3A7643D Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=derodat@adacore.com Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id C7B1D56148; Wed, 28 Apr 2021 05:41:39 -0400 (EDT) X-Virus-Scanned: Debian amavisd-new at gnat.com Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id 9oDuVmmDmbqK; Wed, 28 Apr 2021 05:41:39 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [IPv6:2620:20:4000:0:46a8:42ff:fe0e:e294]) by rock.gnat.com (Postfix) with ESMTP id 9CD905613D; Wed, 28 Apr 2021 05:41:39 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id 9C2D012D; Wed, 28 Apr 2021 05:41:39 -0400 (EDT) Date: Wed, 28 Apr 2021 05:41:39 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Arnaud Charlet Subject: [Ada] Incorrect discriminant check on call to access to subprogram Message-ID: <20210428094139.GA139732@adacore.com> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="ZGiS0Q5IWpPtfppv" Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-Spam-Status: No, score=-12.2 required=5.0 tests=BAYES_00, GIT_PATCH_0, KAM_DMARC_STATUS, 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-List-Received-Date: Wed, 28 Apr 2021 09:41:44 -0000 --ZGiS0Q5IWpPtfppv Content-Type: text/plain; charset=us-ascii Content-Disposition: inline When calling an access to a subprogram taking an unconstrained discriminated record as parameter, we fail to pass the extra constrained actual parameter, which would lead to spurious or missed discriminant checks. At the same time we noticed that GNAT sometimes generates trees of the form: (Field1 => 1, Field2 => 2).Field1 we now recognize these in Sem_Eval and rewrite the tree as simply the value given for the field (1 in the example above). Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * exp_ch6.adb: Fix typo in comment. * sem_ch3.adb (Access_Subprogram_Declaration): Add missing call to Create_Extra_Formals. Remove obsolete bootstrap check. * sem_eval.adb (Eval_Selected_Component): Simplify a selected_component on an aggregate. --ZGiS0Q5IWpPtfppv Content-Type: text/x-diff; charset=us-ascii Content-Disposition: attachment; filename="patch.diff" diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -3801,7 +3801,7 @@ package body Exp_Ch6 is -- is internally generated code that manipulates addresses, -- e.g. when building interface tables. No check should -- occur in this case, and the discriminated object is not - -- directly a hand. + -- directly at hand. if not Comes_From_Source (Actual) and then Nkind (Actual) = N_Unchecked_Type_Conversion diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -840,13 +840,6 @@ package body Sem_Ch3 is -- the corresponding semantic routine if Present (Access_To_Subprogram_Definition (N)) then - - -- Compiler runtime units are compiled in Ada 2005 mode when building - -- the runtime library but must also be compilable in Ada 95 mode - -- (when bootstrapping the compiler). - - Check_Compiler_Unit ("anonymous access to subprogram", N); - Access_Subprogram_Declaration (T_Name => Anon_Type, T_Def => Access_To_Subprogram_Definition (N)); @@ -1312,6 +1305,8 @@ package body Sem_Ch3 is Set_Can_Never_Be_Null (T_Name, Null_Exclusion_Present (T_Def)); Check_Restriction (No_Access_Subprograms, T_Def); + + Create_Extra_Formals (Desig_Type); end Access_Subprogram_Declaration; ---------------------------- diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -3830,6 +3830,11 @@ package body Sem_Eval is ----------------------------- procedure Eval_Selected_Component (N : Node_Id) is + Node : Node_Id; + Comp : Node_Id; + C : Node_Id; + Nam : Name_Id; + begin -- If an attribute reference or a LHS, nothing to do. -- Also do not fold if N is an [in] out subprogram parameter. @@ -3839,7 +3844,36 @@ package body Sem_Eval is and then Is_LHS (N) = No and then not Is_Actual_Out_Or_In_Out_Parameter (N) then - Fold (N); + -- Simplify a selected_component on an aggregate by extracting + -- the field directly. + + Node := Prefix (N); + + while Nkind (Node) = N_Qualified_Expression loop + Node := Expression (Node); + end loop; + + if Nkind (Node) = N_Aggregate then + Comp := First (Component_Associations (Node)); + Nam := Chars (Selector_Name (N)); + + while Present (Comp) loop + C := First (Choices (Comp)); + + while Present (C) loop + if Chars (C) = Nam then + Rewrite (N, Relocate_Node (Expression (Comp))); + return; + end if; + + Next (C); + end loop; + + Next (Comp); + end loop; + else + Fold (N); + end if; end if; end Eval_Selected_Component; --ZGiS0Q5IWpPtfppv--