From patchwork Tue Jul 7 09:27:36 2020 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Pierre-Marie de Rodat X-Patchwork-Id: 1324230 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=2620:52:3:1:0:246e:9693:128c; helo=sourceware.org; envelope-from=gcc-patches-bounces@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=adacore.com Received: from sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (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 4B1HF84m6tz9sRR for ; Tue, 7 Jul 2020 19:29:00 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 98E383861830; Tue, 7 Jul 2020 09:27:46 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from rock.gnat.com (rock.gnat.com [205.232.38.15]) by sourceware.org (Postfix) with ESMTP id 978093861000 for ; Tue, 7 Jul 2020 09:27:38 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.3.2 sourceware.org 978093861000 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 9D4B2560FE; Tue, 7 Jul 2020 05:27:36 -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 jJgt-PxOh26N; Tue, 7 Jul 2020 05:27:36 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id 7CE5A560FA; Tue, 7 Jul 2020 05:27:36 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id 7C20A156; Tue, 7 Jul 2020 05:27:36 -0400 (EDT) Date: Tue, 7 Jul 2020 05:27:36 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Subject: [Ada] ACATS 4.1H - BC60005 - null exclusion matching for formal subprograms Message-ID: <20200707092736.GA41578@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-Spam-Status: No, score=-7.9 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: , Cc: Arnaud Charlet Errors-To: gcc-patches-bounces@gcc.gnu.org Sender: "Gcc-patches" This ACATS test shows that we had several inconsistencies in the checking of null exclusion matching. We also realized that some old code in sem_ch6.adb was wrong and no longer necessary, so removed it. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * sem_ch6.adb (Check_Conformance): Remove unnecessary (and wrong) code. * sem_ch8.adb (Check_Null_Exclusion): Post error at proper location. Introduce new helper Null_Exclusion_Mismatch and fix implementation wrt formal subprograms used in generic bodies. (Analyze_Subprogram_Renaming): Fix missing setting of Error_Msg_Sloc. (Analyze_Object_Renaming): Replace "in Anonymous_Access_Kind" by Is_Anonymous_Access_Type. * sem_util.adb (Has_Null_Exclusion): Fix handling of N_Parameter_Specification. * sem_ch12.adb (Instantiate_Object): Replace "in Anonymous_Access_Kind" by Is_Anonymous_Access_Type. diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -11339,9 +11339,8 @@ package body Sem_Ch12 is -- access type. if Ada_Version < Ada_2005 - or else Ekind (Base_Type (Ftyp)) not in Anonymous_Access_Kind - or else Ekind (Base_Type (Etype (Actual))) - not in Anonymous_Access_Kind + or else not Is_Anonymous_Access_Type (Base_Type (Ftyp)) + or else not Is_Anonymous_Access_Type (Base_Type (Etype (Actual))) then Error_Msg_NE ("type of actual does not match type of&", Actual, Gen_Obj); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -5668,7 +5668,6 @@ package body Sem_Ch6 is New_Type : constant Entity_Id := Etype (New_Id); Old_Formal : Entity_Id; New_Formal : Entity_Id; - Access_Types_Match : Boolean; Old_Formal_Base : Entity_Id; New_Formal_Base : Entity_Id; @@ -5869,57 +5868,6 @@ package body Sem_Ch6 is New_Formal_Base := Get_Instance_Of (New_Formal_Base); end if; - Access_Types_Match := Ada_Version >= Ada_2005 - - -- Ensure that this rule is only applied when New_Id is a - -- renaming of Old_Id. - - and then Nkind (Parent (Parent (New_Id))) = - N_Subprogram_Renaming_Declaration - and then Nkind (Name (Parent (Parent (New_Id)))) in N_Has_Entity - and then Present (Entity (Name (Parent (Parent (New_Id))))) - and then Entity (Name (Parent (Parent (New_Id)))) = Old_Id - - -- Now handle the allowed access-type case - - and then Is_Access_Type (Old_Formal_Base) - and then Is_Access_Type (New_Formal_Base) - - -- The type kinds must match. The only exception occurs with - -- multiple generics of the form: - - -- generic generic - -- type F is private; type A is private; - -- type F_Ptr is access F; type A_Ptr is access A; - -- with proc F_P (X : F_Ptr); with proc A_P (X : A_Ptr); - -- package F_Pack is ... package A_Pack is - -- package F_Inst is - -- new F_Pack (A, A_Ptr, A_P); - - -- When checking for conformance between the parameters of A_P - -- and F_P, the type kinds of F_Ptr and A_Ptr will not match - -- because the compiler has transformed A_Ptr into a subtype of - -- F_Ptr. We catch this case in the code below. - - and then (Ekind (Old_Formal_Base) = Ekind (New_Formal_Base) - or else - (Is_Generic_Type (Old_Formal_Base) - and then Is_Generic_Type (New_Formal_Base) - and then Is_Internal (New_Formal_Base) - and then Etype (Etype (New_Formal_Base)) = - Old_Formal_Base)) - and then Directly_Designated_Type (Old_Formal_Base) = - Directly_Designated_Type (New_Formal_Base) - and then ((Is_Itype (Old_Formal_Base) - and then (Can_Never_Be_Null (Old_Formal_Base) - or else Is_Access_Constant - (Old_Formal_Base))) - or else - (Is_Itype (New_Formal_Base) - and then (Can_Never_Be_Null (New_Formal_Base) - or else Is_Access_Constant - (New_Formal_Base)))); - -- Types must always match. In the visible part of an instance, -- usual overloading rules for dispatching operations apply, and -- we check base types (not the actual subtypes). @@ -5932,7 +5880,6 @@ package body Sem_Ch6 is T2 => Base_Type (Etype (New_Formal)), Ctype => Ctype, Get_Inst => Get_Inst) - and then not Access_Types_Match then Conformance_Error ("\type of & does not match!", New_Formal); return; @@ -5943,7 +5890,6 @@ package body Sem_Ch6 is T2 => New_Formal_Base, Ctype => Ctype, Get_Inst => Get_Inst) - and then not Access_Types_Match then -- Don't give error message if old type is Any_Type. This test -- avoids some cascaded errors, e.g. in case of a bad spec. @@ -5996,10 +5942,8 @@ package body Sem_Ch6 is return; - -- Part of mode conformance for access types is having the same - -- constant modifier. - - elsif Access_Types_Match + elsif Is_Access_Type (Old_Formal_Base) + and then Is_Access_Type (New_Formal_Base) and then Is_Access_Constant (Old_Formal_Base) /= Is_Access_Constant (New_Formal_Base) then @@ -6021,8 +5965,8 @@ package body Sem_Ch6 is -- (access formals in the bodies aren't marked Can_Never_Be_Null). if Ada_Version >= Ada_2005 - and then Ekind (Etype (Old_Formal)) = E_Anonymous_Access_Type - and then Ekind (Etype (New_Formal)) = E_Anonymous_Access_Type + and then Is_Anonymous_Access_Type (Etype (Old_Formal)) + and then Is_Anonymous_Access_Type (Etype (New_Formal)) and then ((Can_Never_Be_Null (Etype (Old_Formal)) /= Can_Never_Be_Null (Etype (New_Formal)) diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -1040,8 +1040,8 @@ package body Sem_Ch8 is if Nkind (Nam) = N_Type_Conversion and then not Comes_From_Source (Nam) - and then Ekind (Etype (Expression (Nam))) in Anonymous_Access_Kind - and then Ekind (T) not in Anonymous_Access_Kind + and then Is_Anonymous_Access_Type (Etype (Expression (Nam))) + and then not Is_Anonymous_Access_Type (T) then Wrong_Type (Expression (Nam), T); -- Should we give better error??? end if; @@ -2004,15 +2004,14 @@ package body Sem_Ch8 is -- Ada 2005 (AI-423): Given renaming Ren of subprogram Sub, check the -- following AI rules: -- - -- If Ren is a renaming of a formal subprogram and one of its - -- parameters has a null exclusion, then the corresponding formal - -- in Sub must also have one. Otherwise the subtype of the Sub's - -- formal parameter must exclude null. + -- If Ren denotes a generic formal object of a generic unit G, and the + -- renaming (or instantiation containing the actual) occurs within the + -- body of G or within the body of a generic unit declared within the + -- declarative region of G, then the corresponding parameter of G + -- shall have a null_exclusion; Otherwise the subtype of the Sub's + -- formal parameter shall exclude null. -- - -- If Ren is a renaming of a formal function and its return - -- profile has a null exclusion, then Sub's return profile must - -- have one. Otherwise the subtype of Sub's return profile must - -- exclude null. + -- Similarly for its return profile. procedure Check_SPARK_Primitive_Operation (Subp_Id : Entity_Id); -- Ensure that a SPARK renaming denoted by its entity Subp_Id does not @@ -2579,20 +2578,38 @@ package body Sem_Ch8 is Ren_Formal : Entity_Id; Sub_Formal : Entity_Id; + function Null_Exclusion_Mismatch + (Renaming : Entity_Id; Renamed : Entity_Id) return Boolean; + -- Return True if there is a null exclusion mismatch between + -- Renaming and Renamed, False otherwise. + + ----------------------------- + -- Null_Exclusion_Mismatch -- + ----------------------------- + + function Null_Exclusion_Mismatch + (Renaming : Entity_Id; Renamed : Entity_Id) return Boolean is + begin + return Has_Null_Exclusion (Parent (Renaming)) + and then + not (Has_Null_Exclusion (Parent (Renamed)) + or else (Can_Never_Be_Null (Etype (Renamed)) + and then not + (Is_Formal_Subprogram (Sub) + and then In_Generic_Body (Current_Scope)))); + end Null_Exclusion_Mismatch; + begin -- Parameter check Ren_Formal := First_Formal (Ren); Sub_Formal := First_Formal (Sub); while Present (Ren_Formal) and then Present (Sub_Formal) loop - if Has_Null_Exclusion (Parent (Ren_Formal)) - and then - not (Has_Null_Exclusion (Parent (Sub_Formal)) - or else Can_Never_Be_Null (Etype (Sub_Formal))) - then + if Null_Exclusion_Mismatch (Ren_Formal, Sub_Formal) then + Error_Msg_Sloc := Sloc (Sub_Formal); Error_Msg_NE - ("`NOT NULL` required for parameter &", - Parent (Sub_Formal), Sub_Formal); + ("`NOT NULL` required for parameter &#", + Ren_Formal, Sub_Formal); end if; Next_Formal (Ren_Formal); @@ -2603,13 +2620,10 @@ package body Sem_Ch8 is if Nkind (Parent (Ren)) = N_Function_Specification and then Nkind (Parent (Sub)) = N_Function_Specification - and then Has_Null_Exclusion (Parent (Ren)) - and then not (Has_Null_Exclusion (Parent (Sub)) - or else Can_Never_Be_Null (Etype (Sub))) + and then Null_Exclusion_Mismatch (Ren, Sub) then - Error_Msg_N - ("return must specify `NOT NULL`", - Result_Definition (Parent (Sub))); + Error_Msg_Sloc := Sloc (Sub); + Error_Msg_N ("return must specify `NOT NULL`#", Ren); end if; end Check_Null_Exclusion; @@ -3454,10 +3468,6 @@ package body Sem_Ch8 is then Check_Mode_Conformant (New_S, Old_S); end if; - - if Is_Actual and then Error_Posted (New_S) then - Error_Msg_NE ("invalid actual subprogram: & #!", N, Old_S); - end if; end if; if No (Rename_Spec) then diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -12066,7 +12066,8 @@ package body Sem_Util is when N_Parameter_Specification => if Nkind (Parameter_Type (N)) = N_Access_Definition then - return Null_Exclusion_Present (Parameter_Type (N)); + return Null_Exclusion_Present (Parameter_Type (N)) + or else Null_Exclusion_Present (N); else return Null_Exclusion_Present (N); end if;