OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[Ada] ACATS 4.1H - BC60005 - null exclusion matching for formal subprograms

Browse Source 
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.
This commit is contained in:
Arnaud Charlet 2020-05-10 16:36:00 -04:00 committed by Pierre-Marie de Rodat
parent dae09f9b55
commit e378df6d39
4 changed files with 45 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
gcc/ada/sem_ch12.adb
View File

@ -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);

64
gcc/ada/sem_ch6.adb
View File

@ -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))

64
gcc/ada/sem_ch8.adb
View File

@ -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

3
gcc/ada/sem_util.adb
View File

@ -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;