procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

ada: Fix spurious error on 'Input of private type with Type_Invariant aspect

Browse source 
The problem is that it is necessary to break the privacy during the
expansion of the Input attribute, which may introduce a view mismatch
with the parameter of the routine checking the invariant of the type.

gcc/ada/

	* exp_util.adb (Make_Invariant_Call): Convert the expression to
	the type of the formal parameter if need be.
This commit is contained in:
Eric Botcazou 2023-07-25 23:03:22 +02:00 • committed by Marc Poulhiès
parent 5825635336
commit 3b21dae599
1 changed files with 19 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
gcc/ada/exp_util.adb
View file

@ -9928,11 +9928,16 @@ package body Exp_Util is
-------------------------
function Make_Invariant_Call (Expr : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (Expr);
Typ : constant Entity_Id := Base_Type (Etype (Expr));
Loc : constant Source_Ptr := Sloc (Expr);
Typ : constant Entity_Id := Base_Type (Etype (Expr));
pragma Assert (Has_Invariants (Typ));
Proc_Id : constant Entity_Id := Invariant_Procedure (Typ);
Proc_Id : constant Entity_Id := Invariant_Procedure (Typ);
pragma Assert (Present (Proc_Id));
Inv_Typ : constant Entity_Id
:= Base_Type (Etype (First_Formal (Proc_Id)));
Arg : Node_Id;
begin
-- The invariant procedure has a null body if assertions are disabled or
-- Assertion_Policy Ignore is in effect. In that case, generate a null
@ -9940,11 +9945,21 @@ package body Exp_Util is
if Has_Null_Body (Proc_Id) then
return Make_Null_Statement (Loc);
else
-- As done elsewhere, for example in Build_Initialization_Call, we
-- may need to bridge the gap between views of the type.
if Inv_Typ /= Typ then
Arg := OK_Convert_To (Inv_Typ, Expr);
else
Arg := Relocate_Node (Expr);
end if;
return
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Proc_Id, Loc),
Parameter_Associations => New_List (Relocate_Node (Expr)));
Parameter_Associations => New_List (Arg));
end if;
end Make_Invariant_Call;