From e378df6d39e76bc5cdc56b3d7c8c57601fe8d6c0 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Sun, 10 May 2020 16:36:00 -0400 Subject: [PATCH] [Ada] ACATS 4.1H - BC60005 - null exclusion matching for formal subprograms 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. --- gcc/ada/sem_ch12.adb | 5 ++-- gcc/ada/sem_ch6.adb | 64 +++----------------------------------------- gcc/ada/sem_ch8.adb | 64 +++++++++++++++++++++++++------------------- gcc/ada/sem_util.adb | 3 ++- 4 files changed, 45 insertions(+), 91 deletions(-) diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 9865de4802e..97e9ab89672 100644 --- 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 index 69e21bbc9d6..58736afa7ec 100644 --- 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 index 4e85a1508d7..0fcccc9c383 100644 --- 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 index d0bde3344f8..44ed3e61dac 100644 --- 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; -- 2.30.2