Skip to content

R
riscv-gcc-1
Commit b554177a by Arnaud Charlet
Options

[multiple changes] 

2017-04-25  Justin Squirek  <squirek@adacore.com>

	* exp_ch3.adb (Freeze_Type): Add condition to always treat
	interface types as a partial view of a private type for the
	generation of invariant procedure bodies.
	* exp_util.adb, exp_util.ads (Add_Inherited_Invariants):
	Add a condition to get the Corresponding_Record_Type for
	concurrent types, add condition to return in the absence of a
	class in the pragma, remove call to Replace_Type_References,
	and add call to Replace_References.
	(Add_Interface_Invariatns),
	(Add_Parent_Invariants): Modify call to Add_Inherited_Invariants
	to including the working type T.
	(Add_Own_Invariants): Remove
	legacy condition for separate units, remove dispatching for ASIS
	and save a copy of the expression in the pragma expression.
	(Build_Invariant_Procedure_Body): Default initalize vars,
	remove return condition on interfaces, always use the
	private type for interfaces, and move the processing of types
	until after the processing of invariants for the full view.
	(Build_Invariant_Procedure_Declaration): Remove condition
	to return if an interface type is encountered and add
	condition to convert the formal parameter to its class-wide
	counterpart if Work_Typ is abstract.
	(Replace_Type): Add call to Remove_Controlling_Arguments.
	(Replace_Type_Ref): Remove class-wide dispatching for the current
	instance of the type.
	(Replace_Type_References): Remove parameter "Derived"
	(Remove_Controlling_Arguments): Created in order to removing
	the controlliong argument from calls to primitives in the case
	of the formal parameter being an class-wide abstract type.
	* sem_ch3.adb (Build_Assertion_Bodies_For_Type): Almost identical
	to the change made to Freeze_Type in exp_ch3. Add a condition
	to treat interface types as a partial view.
	* sem_prag.adb (Analyze_Pragma): Modify parameters in the call
	to Build_Invariant_Procedure_Declaration to properly generate a
	"partial" invariant procedure when Typ is an interface.

2017-04-25  Bob Duff  <duff@adacore.com>

	* a-numeri.ads: Go back to using brackets encoding for the Greek
	letter pi.

From-SVN: r247204
parent c9e9c3ac
Showing with 357 additions and 204 deletions
gcc/ada/ChangeLog
2017-04-25 Justin Squirek <squirek@adacore.com>
* exp_ch3.adb (Freeze_Type): Add condition to always treat
interface types as a partial view of a private type for the
generation of invariant procedure bodies.
* exp_util.adb, exp_util.ads (Add_Inherited_Invariants):
Add a condition to get the Corresponding_Record_Type for
concurrent types, add condition to return in the absence of a
class in the pragma, remove call to Replace_Type_References,
and add call to Replace_References.
(Add_Interface_Invariatns),
(Add_Parent_Invariants): Modify call to Add_Inherited_Invariants
to including the working type T.
(Add_Own_Invariants): Remove
legacy condition for separate units, remove dispatching for ASIS
and save a copy of the expression in the pragma expression.
(Build_Invariant_Procedure_Body): Default initalize vars,
remove return condition on interfaces, always use the
private type for interfaces, and move the processing of types
until after the processing of invariants for the full view.
(Build_Invariant_Procedure_Declaration): Remove condition
to return if an interface type is encountered and add
condition to convert the formal parameter to its class-wide
counterpart if Work_Typ is abstract.
(Replace_Type): Add call to Remove_Controlling_Arguments.
(Replace_Type_Ref): Remove class-wide dispatching for the current
instance of the type.
(Replace_Type_References): Remove parameter "Derived"
(Remove_Controlling_Arguments): Created in order to removing
the controlliong argument from calls to primitives in the case
of the formal parameter being an class-wide abstract type.
* sem_ch3.adb (Build_Assertion_Bodies_For_Type): Almost identical
to the change made to Freeze_Type in exp_ch3. Add a condition
to treat interface types as a partial view.
* sem_prag.adb (Analyze_Pragma): Modify parameters in the call
to Build_Invariant_Procedure_Declaration to properly generate a
"partial" invariant procedure when Typ is an interface.
2017-04-25 Bob Duff <duff@adacore.com>
* a-numeri.ads: Go back to using brackets encoding for the Greek
letter pi.
2017-04-25 Ed Schonberg <schonberg@adacore.com> 2017-04-25 Ed Schonberg <schonberg@adacore.com>
* sem_ch3.adb (Derive_Subprogram): Implement rule in RM 6.1.1 * sem_ch3.adb (Derive_Subprogram): Implement rule in RM 6.1.1
......
gcc/ada/a-numeri.ads
...@@ -18,20 +18,14 @@ package Ada.Numerics is ...@@ -18,20 +18,14 @@ package Ada.Numerics is
Argument_Error : exception; Argument_Error : exception;
pragma Wide_Character_Encoding (UTF8);
-- For the Greek letter Pi below. Note that this pragma cannot immediately
-- precede that character, because then the encoding gets set too late.
Pi : constant := Pi : constant :=
3.14159_26535_89793_23846_26433_83279_50288_41971_69399_37511; 3.14159_26535_89793_23846_26433_83279_50288_41971_69399_37511;
π : constant := Pi; ["03C0"] : constant := Pi;
-- This is the Greek letter Pi (for Ada 2005 AI-388). Note that it is -- This is the Greek letter Pi (for Ada 2005 AI-388). Note that it is
-- conforming to have this constant present even in Ada 95 mode, as there -- conforming to have this constant present even in Ada 95 mode, as there
-- is no way for a normal mode Ada 95 program to reference this identifier. -- is no way for a normal mode Ada 95 program to reference this identifier.
pragma Wide_Character_Encoding (BRACKETS);
e : constant := e : constant :=
2.71828_18284_59045_23536_02874_71352_66249_77572_47093_69996; 2.71828_18284_59045_23536_02874_71352_66249_77572_47093_69996;
......
gcc/ada/exp_ch3.adb
...@@ -7529,7 +7529,22 @@ package body Exp_Ch3 is ...@@ -7529,7 +7529,22 @@ package body Exp_Ch3 is
-- class-wide invariants from parent types or interfaces, and invariants -- class-wide invariants from parent types or interfaces, and invariants
-- on array elements or record components. -- on array elements or record components.
if Has_Invariants (Def_Id) then if Is_Interface (Def_Id) then
-- Interfaces are treated as the partial view of a private type in
-- order to achieve uniformity with the general case. As a result, an
-- interface receives only a "partial" invariant procedure which is
-- never called.
if Has_Own_Invariants (Def_Id) then
Build_Invariant_Procedure_Body
(Typ => Def_Id,
Partial_Invariant => Is_Interface (Def_Id));
end if;
-- Non-interface types
elsif Has_Invariants (Def_Id) then
Build_Invariant_Procedure_Body (Def_Id); Build_Invariant_Procedure_Body (Def_Id);
end if; end if;
......
gcc/ada/exp_util.adb
...@@ -1989,7 +1989,7 @@ package body Exp_Util is ...@@ -1989,7 +1989,7 @@ package body Exp_Util is
-- NOTE: all Add_xxx_Invariants routines are reactive. In other words -- NOTE: all Add_xxx_Invariants routines are reactive. In other words
-- they emit checks, loops (for arrays) and case statements (for record -- they emit checks, loops (for arrays) and case statements (for record
-- variant parts) only when there are invariants to verify. This keeps -- variant parts) only when there are invariants to verify. This keeps
-- the body of the invariant procedure free from useless code. -- the body of the invariant procedure free of useless code.
procedure Add_Array_Component_Invariants procedure Add_Array_Component_Invariants
(T : Entity_Id; (T : Entity_Id;
...@@ -2000,14 +2000,16 @@ package body Exp_Util is ...@@ -2000,14 +2000,16 @@ package body Exp_Util is
-- invariant procedure. All created checks are added to list Checks. -- invariant procedure. All created checks are added to list Checks.
procedure Add_Inherited_Invariants procedure Add_Inherited_Invariants
(Full_Typ : Entity_Id; (T : Entity_Id;
Priv_Typ : Entity_Id; Priv_Typ : Entity_Id;
Obj_Id : Entity_Id; Full_Typ : Entity_Id;
Checks : in out List_Id); Obj_Id : Entity_Id;
Checks : in out List_Id);
-- Generate an invariant check for each inherited class-wide invariant -- Generate an invariant check for each inherited class-wide invariant
-- coming from all parent types of type T. Obj_Id denotes the entity of -- coming from all parent types of type T. Priv_Typ and Full_Typ denote
-- the _object formal parameter of the invariant procedure. All created -- the partial and full view of the parent type. Obj_Id denotes the
-- checks are added to list Checks. -- entity of the _object formal parameter of the invariant procedure.
-- All created checks are added to list Checks.
procedure Add_Interface_Invariants procedure Add_Interface_Invariants
(T : Entity_Id; (T : Entity_Id;
...@@ -2196,7 +2198,6 @@ package body Exp_Util is ...@@ -2196,7 +2198,6 @@ package body Exp_Util is
Attribute_Name => Name_Range, Attribute_Name => Name_Range,
Expressions => New_List ( Expressions => New_List (
Make_Integer_Literal (Loc, Dim))))), Make_Integer_Literal (Loc, Dim))))),
Statements => Comp_Checks)); Statements => Comp_Checks));
end if; end if;
end if; end if;
...@@ -2216,25 +2217,36 @@ package body Exp_Util is ...@@ -2216,25 +2217,36 @@ package body Exp_Util is
------------------------------ ------------------------------
procedure Add_Inherited_Invariants procedure Add_Inherited_Invariants
(Full_Typ : Entity_Id; (T : Entity_Id;
Priv_Typ : Entity_Id; Priv_Typ : Entity_Id;
Obj_Id : Entity_Id; Full_Typ : Entity_Id;
Checks : in out List_Id) Obj_Id : Entity_Id;
Checks : in out List_Id)
is is
Arg1 : Node_Id; Deriv_Typ : Entity_Id;
Arg2 : Node_Id; Expr : Node_Id;
Expr : Node_Id; Prag : Node_Id;
Prag : Node_Id; Prag_Expr : Node_Id;
Prag_Expr_Arg : Node_Id;
Prag_Typ : Node_Id;
Prag_Typ_Arg : Node_Id;
Par_Proc : Entity_Id;
-- The "partial" invariant procedure of Par_Typ
Rep_Typ : Entity_Id; Par_Typ : Entity_Id;
-- The replacement type used in the substitution of the current -- The suitable view of the parent type used in the substitution of
-- instance of a type with the _object formal parameter -- type attributes.
begin begin
if not Present (Priv_Typ) and then not Present (Full_Typ) then if not Present (Priv_Typ) and then not Present (Full_Typ) then
return; return;
end if; end if;
-- Determine which rep item chain to use. Precedence is given to that
-- of the parent type's partial view since it usually carries all the
-- class-wide invariants.
if Present (Priv_Typ) then if Present (Priv_Typ) then
Prag := First_Rep_Item (Priv_Typ); Prag := First_Rep_Item (Priv_Typ);
else else
...@@ -2249,49 +2261,89 @@ package body Exp_Util is ...@@ -2249,49 +2261,89 @@ package body Exp_Util is
if Contains (Pragmas_Seen, Prag) then if Contains (Pragmas_Seen, Prag) then
return; return;
-- Nothing to do when the caller requests the processing of all
-- inherited class-wide invariants, but the pragma does not
-- fall in this category.
elsif not Class_Present (Prag) then
return;
end if; end if;
-- Extract the arguments of the invariant pragma -- Extract the arguments of the invariant pragma
Arg1 := First (Pragma_Argument_Associations (Prag)); Prag_Typ_Arg := First (Pragma_Argument_Associations (Prag));
Arg2 := Get_Pragma_Arg (Next (Arg1)); Prag_Expr_Arg := Next (Prag_Typ_Arg);
Arg1 := Get_Pragma_Arg (Arg1); Prag_Expr := Expression_Copy (Prag_Expr_Arg);
Prag_Typ := Get_Pragma_Arg (Prag_Typ_Arg);
-- The pragma applies to the partial view -- The pragma applies to the partial view of the parent type
if Present (Priv_Typ) and then Entity (Arg1) = Priv_Typ then if Present (Priv_Typ)
Rep_Typ := Priv_Typ; and then Entity (Prag_Typ) = Priv_Typ
then
Par_Typ := Priv_Typ;
-- The pragma applies to the full view -- The pragma applies to the full view of the parent type
elsif Present (Full_Typ) and then Entity (Arg1) = Full_Typ then elsif Present (Full_Typ)
Rep_Typ := Full_Typ; and then Entity (Prag_Typ) = Full_Typ
then
Par_Typ := Full_Typ;
-- Otherwise the pragma applies to a parent type and will be -- Otherwise the pragma does not belong to the parent type and
-- processed at a later step by routine Add_Parent_Invariants -- should not be considered.
-- or Add_Interface_Invariants.
else else
return; return;
end if; end if;
-- Nothing to do when the caller requests the processing of all -- Perform the following substitutions:
-- inherited class-wide invariants, but the pragma does not
-- fall in this category.
if not Class_Present (Prag) then -- * Replace a reference to the _object parameter of the
return; -- parent type's partial invariant procedure with a
-- reference to the _object parameter of the derived
-- type's full invariant procedure.
-- * Replace a reference to a discriminant of the parent type
-- with a suitable value from the point of view of the
-- derived type.
-- * Replace a call to an overridden parent primitive with a
-- call to the overriding derived type primitive.
-- * Replace a call to an inherited parent primitive with a
-- call to the internally-generated inherited derived type
-- primitive.
Expr := New_Copy_Tree (Prag_Expr);
-- When the type inheriting the class-wide invariant is a task
-- or protected type, use the corresponding record type because
-- it contains all primitive operations of the concurren type
-- and allows for proper substitution.
if Is_Concurrent_Type (T) then
Deriv_Typ := Corresponding_Record_Type (T);
else
Deriv_Typ := T;
end if; end if;
Expr := New_Copy_Tree (Arg2); pragma Assert (Present (Deriv_Typ));
-- Substitute all references to type T with references to the -- The parent type must have a "partial" invariant procedure
-- _object formal parameter. -- because class-wide invariants are captured exclusively by
-- it.
-- ??? Dispatching must be removed due to AI12-0150-1 Par_Proc := Partial_Invariant_Procedure (Par_Typ);
pragma Assert (Present (Par_Proc));
Replace_Type_References Replace_References
(Expr, Rep_Typ, Obj_Id, Dispatch => Class_Present (Prag)); (Expr => Expr,
Par_Typ => Par_Typ,
Deriv_Typ => Deriv_Typ,
Par_Obj => First_Formal (Par_Proc),
Deriv_Obj => Obj_Id);
Add_Invariant_Check (Prag, Expr, Checks, Inherited => True); Add_Invariant_Check (Prag, Expr, Checks, Inherited => True);
end if; end if;
...@@ -2323,11 +2375,17 @@ package body Exp_Util is ...@@ -2323,11 +2375,17 @@ package body Exp_Util is
Iface_Elmt := First_Elmt (Ifaces); Iface_Elmt := First_Elmt (Ifaces);
while Present (Iface_Elmt) loop while Present (Iface_Elmt) loop
-- The Full_Typ parameter is intentionally left Empty because
-- interfaces are treated as the partial view of a private type
-- in order to achieve uniformity with the general case.
Add_Inherited_Invariants Add_Inherited_Invariants
(Full_Typ => Node (Iface_Elmt), (T => T,
Priv_Typ => Empty, Priv_Typ => Node (Iface_Elmt),
Obj_Id => Obj_Id, Full_Typ => Empty,
Checks => Checks); Obj_Id => Obj_Id,
Checks => Checks);
Next_Elmt (Iface_Elmt); Next_Elmt (Iface_Elmt);
end loop; end loop;
...@@ -2358,7 +2416,7 @@ package body Exp_Util is ...@@ -2358,7 +2416,7 @@ package body Exp_Util is
if Is_Ignored (Prag) then if Is_Ignored (Prag) then
null; null;
-- Otherwise the invariant is checked. Build a Check pragma to verify -- Otherwise the invariant is checked. Build a pragma Check to verify
-- the expression at runtime. -- the expression at runtime.
else else
...@@ -2479,10 +2537,11 @@ package body Exp_Util is ...@@ -2479,10 +2537,11 @@ package body Exp_Util is
end if; end if;
Add_Inherited_Invariants Add_Inherited_Invariants
(Full_Typ => Full_Typ, (T => T,
Priv_Typ => Priv_Typ, Priv_Typ => Priv_Typ,
Obj_Id => Obj_Id, Full_Typ => Full_Typ,
Checks => Checks); Obj_Id => Obj_Id,
Checks => Checks);
Curr_Typ := Par_Typ; Curr_Typ := Par_Typ;
end loop; end loop;
...@@ -2498,13 +2557,14 @@ package body Exp_Util is ...@@ -2498,13 +2557,14 @@ package body Exp_Util is
Checks : in out List_Id; Checks : in out List_Id;
Priv_Item : Node_Id := Empty) Priv_Item : Node_Id := Empty)
is is
Arg1 : Node_Id; ASIS_Expr : Node_Id;
Arg2 : Node_Id; Expr : Node_Id;
ASIS_Expr : Node_Id; Prag : Node_Id;
Asp : Node_Id; Prag_Asp : Node_Id;
Expr : Node_Id; Prag_Expr : Node_Id;
Ploc : Source_Ptr; Prag_Expr_Arg : Node_Id;
Prag : Node_Id; Prag_Typ : Node_Id;
Prag_Typ_Arg : Node_Id;
begin begin
if not Present (T) then if not Present (T) then
...@@ -2531,49 +2591,49 @@ package body Exp_Util is ...@@ -2531,49 +2591,49 @@ package body Exp_Util is
-- Extract the arguments of the invariant pragma -- Extract the arguments of the invariant pragma
Arg1 := First (Pragma_Argument_Associations (Prag)); Prag_Typ_Arg := First (Pragma_Argument_Associations (Prag));
Arg2 := Get_Pragma_Arg (Next (Arg1)); Prag_Expr_Arg := Next (Prag_Typ_Arg);
Arg1 := Get_Pragma_Arg (Arg1); Prag_Expr := Get_Pragma_Arg (Prag_Expr_Arg);
Asp := Corresponding_Aspect (Prag); Prag_Typ := Get_Pragma_Arg (Prag_Typ_Arg);
Ploc := Sloc (Prag); Prag_Asp := Corresponding_Aspect (Prag);
-- Verify the pragma belongs to T, otherwise the pragma applies -- Verify the pragma belongs to T, otherwise the pragma applies
-- to a parent type in which case it will be processed later by -- to a parent type in which case it will be processed later by
-- Add_Parent_Invariants or Add_Interface_Invariants. -- Add_Parent_Invariants or Add_Interface_Invariants.
if Entity (Arg1) /= T then if Entity (Prag_Typ) /= T then
return; return;
end if; end if;
Expr := New_Copy_Tree (Arg2); Expr := New_Copy_Tree (Prag_Expr);
-- Substitute all references to type T with references to the -- Substitute all references to type T with references to the
-- _object formal parameter. -- _object formal parameter.
Replace_Type_References Replace_Type_References (Expr, T, Obj_Id);
(Expr => Expr,
Typ => T,
Obj_Id => Obj_Id,
Dispatch => Class_Present (Prag));
-- Preanalyze the invariant expression to detect errors and at -- Preanalyze the invariant expression to detect errors and at
-- the same time capture the visibility of the proper package -- the same time capture the visibility of the proper package
-- part. -- part.
-- Historical note: the old implementation of invariants used Set_Parent (Expr, Parent (Prag_Expr));
-- node N as the parent, but a package specification as parent
-- of an expression is bizarre.
Set_Parent (Expr, Parent (Arg2));
Preanalyze_Assert_Expression (Expr, Any_Boolean); Preanalyze_Assert_Expression (Expr, Any_Boolean);
-- Save a copy of the expression when T is tagged to detect
-- errors and capture the visibility of the proper package part
-- for the generation of inherited type invariants.
if Is_Tagged_Type (T) then
Set_Expression_Copy (Prag_Expr_Arg, New_Copy_Tree (Expr));
end if;
-- If the pragma comes from an aspect specification, replace -- If the pragma comes from an aspect specification, replace
-- the saved expression because all type references must be -- the saved expression because all type references must be
-- substituted for the call to Preanalyze_Spec_Expression in -- substituted for the call to Preanalyze_Spec_Expression in
-- Check_Aspect_At_xxx routines. -- Check_Aspect_At_xxx routines.
if Present (Asp) then if Present (Prag_Asp) then
Set_Entity (Identifier (Asp), New_Copy_Tree (Expr)); Set_Entity (Identifier (Prag_Asp), New_Copy_Tree (Expr));
end if; end if;
-- Analyze the original invariant expression for ASIS -- Analyze the original invariant expression for ASIS
...@@ -2582,43 +2642,17 @@ package body Exp_Util is ...@@ -2582,43 +2642,17 @@ package body Exp_Util is
ASIS_Expr := Empty; ASIS_Expr := Empty;
if Comes_From_Source (Prag) then if Comes_From_Source (Prag) then
ASIS_Expr := Arg2; ASIS_Expr := Prag_Expr;
elsif Present (Asp) then elsif Present (Prag_Asp) then
ASIS_Expr := Expression (Asp); ASIS_Expr := Expression (Prag_Asp);
end if; end if;
if Present (ASIS_Expr) then if Present (ASIS_Expr) then
Replace_Type_References Replace_Type_References (ASIS_Expr, T, Obj_Id);
(Expr => ASIS_Expr,
Typ => T,
Obj_Id => Obj_Id,
Dispatch => Class_Present (Prag));
Preanalyze_Assert_Expression (ASIS_Expr, Any_Boolean); Preanalyze_Assert_Expression (ASIS_Expr, Any_Boolean);
end if; end if;
end if; end if;
-- A class-wide invariant may be inherited in a separate unit,
-- where the corresponding expression cannot be resolved by
-- visibility, because it refers to a local function. Propagate
-- semantic information to the original representation item, to
-- be used when an invariant procedure for a derived type is
-- constructed.
-- ??? Unclear how to handle class-wide invariants that are not
-- function calls.
if Class_Present (Prag)
and then Nkind (Expr) = N_Function_Call
and then Nkind (Arg2) = N_Indexed_Component
then
Rewrite (Arg2,
Make_Function_Call (Ploc,
Name =>
New_Occurrence_Of (Entity (Name (Expr)), Ploc),
Parameter_Associations => Expressions (Arg2)));
end if;
Add_Invariant_Check (Prag, Expr, Checks); Add_Invariant_Check (Prag, Expr, Checks);
end if; end if;
...@@ -2863,25 +2897,25 @@ package body Exp_Util is ...@@ -2863,25 +2897,25 @@ package body Exp_Util is
Proc_Id : Entity_Id; Proc_Id : Entity_Id;
Stmts : List_Id := No_List; Stmts : List_Id := No_List;
CRec_Typ : Entity_Id; CRec_Typ : Entity_Id := Empty;
-- The corresponding record type of Full_Typ -- The corresponding record type of Full_Typ
Full_Proc : Entity_Id; Full_Proc : Entity_Id := Empty;
-- The entity of the "full" invariant procedure -- The entity of the "full" invariant procedure
Full_Typ : Entity_Id; Full_Typ : Entity_Id := Empty;
-- The full view of the working type -- The full view of the working type
Obj_Id : Entity_Id; Obj_Id : Entity_Id := Empty;
-- The _object formal parameter of the invariant procedure -- The _object formal parameter of the invariant procedure
Part_Proc : Entity_Id; Part_Proc : Entity_Id := Empty;
-- The entity of the "partial" invariant procedure -- The entity of the "partial" invariant procedure
Priv_Typ : Entity_Id; Priv_Typ : Entity_Id := Empty;
-- The partial view of the working type -- The partial view of the working type
Work_Typ : Entity_Id; Work_Typ : Entity_Id := Empty;
-- The working type -- The working type
-- Start of processing for Build_Invariant_Procedure_Body -- Start of processing for Build_Invariant_Procedure_Body
...@@ -2917,16 +2951,17 @@ package body Exp_Util is ...@@ -2917,16 +2951,17 @@ package body Exp_Util is
pragma Assert (Has_Invariants (Work_Typ)); pragma Assert (Has_Invariants (Work_Typ));
-- Nothing to do for interface types as their class-wide invariants are -- Interfaces are treated as the partial view of a private type in order
-- inherited by implementing types. -- to achieve uniformity with the general case.
if Is_Interface (Work_Typ) then if Is_Interface (Work_Typ) then
goto Leave; Priv_Typ := Work_Typ;
end if;
-- Obtain both views of the type -- Otherwise obtain both views of the type
Get_Views (Work_Typ, Priv_Typ, Full_Typ, Dummy, CRec_Typ); else
Get_Views (Work_Typ, Priv_Typ, Full_Typ, Dummy, CRec_Typ);
end if;
-- The caller requests a body for the partial invariant procedure -- The caller requests a body for the partial invariant procedure
...@@ -2990,10 +3025,10 @@ package body Exp_Util is ...@@ -2990,10 +3025,10 @@ package body Exp_Util is
goto Leave; goto Leave;
end if; end if;
-- Emulate the environment of the invariant procedure by installing -- Emulate the environment of the invariant procedure by installing its
-- its scope and formal parameters. Note that this is not needed, but -- scope and formal parameters. Note that this is not needed, but having
-- having the scope of the invariant procedure installed helps with -- the scope installed helps with the detection of invariant-related
-- the detection of invariant-related errors. -- errors.
Push_Scope (Proc_Id); Push_Scope (Proc_Id);
Install_Formals (Proc_Id); Install_Formals (Proc_Id);
...@@ -3084,17 +3119,6 @@ package body Exp_Util is ...@@ -3084,17 +3119,6 @@ package body Exp_Util is
end if; end if;
end if; end if;
-- Process the elements of an array type
if Is_Array_Type (Full_Typ) then
Add_Array_Component_Invariants (Full_Typ, Obj_Id, Stmts);
-- Process the components of a record type
elsif Ekind (Full_Typ) = E_Record_Type then
Add_Record_Component_Invariants (Full_Typ, Obj_Id, Stmts);
end if;
-- Process the invariants of the full view and in certain cases those -- Process the invariants of the full view and in certain cases those
-- of the partial view. This also handles any invariants on array or -- of the partial view. This also handles any invariants on array or
-- record components. -- record components.
...@@ -3111,7 +3135,19 @@ package body Exp_Util is ...@@ -3111,7 +3135,19 @@ package body Exp_Util is
Checks => Stmts, Checks => Stmts,
Priv_Item => Priv_Item); Priv_Item => Priv_Item);
if Present (CRec_Typ) then -- Process the elements of an array type
if Is_Array_Type (Full_Typ) then
Add_Array_Component_Invariants (Full_Typ, Obj_Id, Stmts);
-- Process the components of a record type
elsif Ekind (Full_Typ) = E_Record_Type then
Add_Record_Component_Invariants (Full_Typ, Obj_Id, Stmts);
-- Process the components of a corresponding record
elsif Present (CRec_Typ) then
Add_Record_Component_Invariants (CRec_Typ, Obj_Id, Stmts); Add_Record_Component_Invariants (CRec_Typ, Obj_Id, Stmts);
end if; end if;
...@@ -3144,7 +3180,7 @@ package body Exp_Util is ...@@ -3144,7 +3180,7 @@ package body Exp_Util is
end if; end if;
-- Generate: -- Generate:
-- procedure <Work_Typ>[Partial_]Invariant (_object : <Work_Typ>) is -- procedure <Work_Typ>[Partial_]Invariant (_object : <Obj_Typ>) is
-- begin -- begin
-- <Stmts> -- <Stmts>
-- end <Work_Typ>[Partial_]Invariant; -- end <Work_Typ>[Partial_]Invariant;
...@@ -3226,6 +3262,9 @@ package body Exp_Util is ...@@ -3226,6 +3262,9 @@ package body Exp_Util is
Obj_Id : Entity_Id; Obj_Id : Entity_Id;
-- The _object formal parameter of the invariant procedure -- The _object formal parameter of the invariant procedure
Obj_Typ : Entity_Id;
-- The type of the _object formal parameter
Priv_Typ : Entity_Id; Priv_Typ : Entity_Id;
-- The partial view of working type -- The partial view of working type
...@@ -3263,15 +3302,9 @@ package body Exp_Util is ...@@ -3263,15 +3302,9 @@ package body Exp_Util is
pragma Assert (Has_Invariants (Work_Typ)); pragma Assert (Has_Invariants (Work_Typ));
-- Nothing to do for interface types as their class-wide invariants are
-- inherited by implementing types.
if Is_Interface (Work_Typ) then
goto Leave;
-- Nothing to do if the type already has a "partial" invariant procedure -- Nothing to do if the type already has a "partial" invariant procedure
elsif Partial_Invariant then if Partial_Invariant then
if Present (Partial_Invariant_Procedure (Work_Typ)) then if Present (Partial_Invariant_Procedure (Work_Typ)) then
goto Leave; goto Leave;
end if; end if;
...@@ -3352,16 +3385,41 @@ package body Exp_Util is ...@@ -3352,16 +3385,41 @@ package body Exp_Util is
Obj_Id := Make_Defining_Identifier (Loc, Chars => Name_uObject); Obj_Id := Make_Defining_Identifier (Loc, Chars => Name_uObject);
-- When generating an invariant procedure declaration for an abstract
-- type (including interfaces), use the class-wide type as the _object
-- type. This has several desirable effects:
-- * The invariant procedure does not become a primitive of the type.
-- This eliminates the need to either special case the treatment of
-- invariant procedures, or to make it a predefined primitive and
-- force every derived type to potentially provide an empty body.
-- * The invariant procedure does not need to be declared as abstract.
-- This allows for a proper body which in turn avoids redundant
-- processing of the same invariants for types with multiple views.
-- * The class-wide type allows for calls to abstract primitives
-- within a non-abstract subprogram. The calls are treated as
-- dispatching and require additional processing when they are
-- remapped to call primitives of derived types. See routine
-- Replace_References for details.
if Is_Abstract_Type (Work_Typ) then
Obj_Typ := Class_Wide_Type (Work_Typ);
else
Obj_Typ := Work_Typ;
end if;
-- Perform minor decoration in case the declaration is not analyzed -- Perform minor decoration in case the declaration is not analyzed
Set_Ekind (Obj_Id, E_In_Parameter); Set_Ekind (Obj_Id, E_In_Parameter);
Set_Etype (Obj_Id, Work_Typ); Set_Etype (Obj_Id, Obj_Typ);
Set_Scope (Obj_Id, Proc_Id); Set_Scope (Obj_Id, Proc_Id);
Set_First_Entity (Proc_Id, Obj_Id); Set_First_Entity (Proc_Id, Obj_Id);
-- Generate: -- Generate:
-- procedure <Work_Typ>[Partial_]Invariant (_object : <Work_Typ>); -- procedure <Work_Typ>[Partial_]Invariant (_object : <Obj_Typ>);
Proc_Decl := Proc_Decl :=
Make_Subprogram_Declaration (Loc, Make_Subprogram_Declaration (Loc,
...@@ -3371,8 +3429,7 @@ package body Exp_Util is ...@@ -3371,8 +3429,7 @@ package body Exp_Util is
Parameter_Specifications => New_List ( Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc, Make_Parameter_Specification (Loc,
Defining_Identifier => Obj_Id, Defining_Identifier => Obj_Id,
Parameter_Type => Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc)))));
New_Occurrence_Of (Work_Typ, Loc)))));
-- The declaration should not be inserted into the tree when the context -- The declaration should not be inserted into the tree when the context
-- is ASIS or a generic unit because it is not part of the template. -- is ASIS or a generic unit because it is not part of the template.
...@@ -11448,6 +11505,37 @@ package body Exp_Util is ...@@ -11448,6 +11505,37 @@ package body Exp_Util is
----------------- -----------------
function Replace_Ref (Ref : Node_Id) return Traverse_Result is function Replace_Ref (Ref : Node_Id) return Traverse_Result is
procedure Remove_Controlling_Arguments (From_Arg : Node_Id);
-- Reset the Controlling_Argument of all function calls which
-- encapsulate node From_Arg.
----------------------------------
-- Remove_Controlling_Arguments --
----------------------------------
procedure Remove_Controlling_Arguments (From_Arg : Node_Id) is
Par : Node_Id;
begin
Par := From_Arg;
while Present (Par) loop
if Nkind (Par) = N_Function_Call
and then Present (Controlling_Argument (Par))
then
Set_Controlling_Argument (Par, Empty);
-- Prevent the search from going too far
elsif Is_Body_Or_Package_Declaration (Par) then
exit;
end if;
Par := Parent (Par);
end loop;
end Remove_Controlling_Arguments;
-- Local variables
Context : constant Node_Id := Parent (Ref); Context : constant Node_Id := Parent (Ref);
Loc : constant Source_Ptr := Sloc (Ref); Loc : constant Source_Ptr := Sloc (Ref);
Ref_Id : Entity_Id; Ref_Id : Entity_Id;
...@@ -11463,6 +11551,8 @@ package body Exp_Util is ...@@ -11463,6 +11551,8 @@ package body Exp_Util is
Val : Node_Or_Entity_Id; Val : Node_Or_Entity_Id;
-- The corresponding value of Ref from the type map -- The corresponding value of Ref from the type map
-- Start of processing for Replace_Ref
begin begin
-- Assume that the input reference is to be replaced and that the -- Assume that the input reference is to be replaced and that the
-- traversal should examine the children of the reference. -- traversal should examine the children of the reference.
...@@ -11529,7 +11619,7 @@ package body Exp_Util is ...@@ -11529,7 +11619,7 @@ package body Exp_Util is
end if; end if;
-- The reference mentions the _object parameter of the parent -- The reference mentions the _object parameter of the parent
-- type's DIC procedure. Replace as follows: -- type's DIC or type invariant procedure. Replace as follows:
-- _object -> _object -- _object -> _object
...@@ -11539,6 +11629,23 @@ package body Exp_Util is ...@@ -11539,6 +11629,23 @@ package body Exp_Util is
then then
New_Ref := New_Occurrence_Of (Deriv_Obj, Loc); New_Ref := New_Occurrence_Of (Deriv_Obj, Loc);
-- The type of the _object parameter is class-wide when the
-- expression comes from an assertion pragma which applies to
-- an abstract parent type or an interface. The class-wide type
-- facilitates the preanalysis of the expression by treating
-- calls to abstract primitives which mention the current
-- instance of the type as dispatching. Once the calls are
-- remapped to invoke overriding or inherited primitives, the
-- calls no longer need to be dispatching. Examine all function
-- calls which encapsule the _object parameter and reset their
-- Controlling_Argument attribute.
if Is_Class_Wide_Type (Etype (Par_Obj))
and then Is_Abstract_Type (Root_Type (Etype (Par_Obj)))
then
Remove_Controlling_Arguments (Old_Ref);
end if;
-- The reference to _object acts as an actual parameter in a -- The reference to _object acts as an actual parameter in a
-- subprogram call which may be invoking a primitive of the -- subprogram call which may be invoking a primitive of the
-- parent type: -- parent type:
...@@ -11659,10 +11766,9 @@ package body Exp_Util is ...@@ -11659,10 +11766,9 @@ package body Exp_Util is
----------------------------- -----------------------------
procedure Replace_Type_References procedure Replace_Type_References
(Expr : Node_Id; (Expr : Node_Id;
Typ : Entity_Id; Typ : Entity_Id;
Obj_Id : Entity_Id; Obj_Id : Entity_Id)
Dispatch : Boolean := False)
is is
procedure Replace_Type_Ref (N : Node_Id); procedure Replace_Type_Ref (N : Node_Id);
-- Substitute a single reference of the current instance of type Typ -- Substitute a single reference of the current instance of type Typ
...@@ -11673,9 +11779,6 @@ package body Exp_Util is ...@@ -11673,9 +11779,6 @@ package body Exp_Util is
---------------------- ----------------------
procedure Replace_Type_Ref (N : Node_Id) is procedure Replace_Type_Ref (N : Node_Id) is
Nloc : constant Source_Ptr := Sloc (N);
Ref : Node_Id;
begin begin
-- Decorate the reference to Typ even though it may be rewritten -- Decorate the reference to Typ even though it may be rewritten
-- further down. This is done for two reasons: -- further down. This is done for two reasons:
...@@ -11698,33 +11801,9 @@ package body Exp_Util is ...@@ -11698,33 +11801,9 @@ package body Exp_Util is
-- Perform the following substitution: -- Perform the following substitution:
-- Typ -> _object -- Typ --> _object
Ref := Make_Identifier (Sloc (N), Chars (Obj_Id));
Set_Entity (Ref, Obj_Id);
Set_Etype (Ref, Typ);
-- When the pragma denotes a class-wide and the Dispatch flag is set
-- perform the following substitution. Note: dispatching in this
-- fashion is illegal Ada according to AI12-0150-1 because class-wide
-- aspects like type invariants and default initial conditions be
-- evaluated statically. Currently it is used only for class-wide
-- type invariants, but this will be fixed.
-- Rep_Typ --> Rep_Typ'Class (_object)
if Dispatch then
Ref :=
Make_Type_Conversion (Nloc,
Subtype_Mark =>
Make_Attribute_Reference (Nloc,
Prefix =>
New_Occurrence_Of (Typ, Nloc),
Attribute_Name => Name_Class),
Expression => Ref);
end if;
Rewrite (N, Ref); Rewrite (N, New_Occurrence_Of (Obj_Id, Sloc (N)));
Set_Comes_From_Source (N, True); Set_Comes_From_Source (N, True);
end Replace_Type_Ref; end Replace_Type_Ref;
......
gcc/ada/exp_util.ads
...@@ -1062,10 +1062,9 @@ package Exp_Util is ...@@ -1062,10 +1062,9 @@ package Exp_Util is
-- the internally-generated inherited primitive of Deriv_Typ. -- the internally-generated inherited primitive of Deriv_Typ.
procedure Replace_Type_References procedure Replace_Type_References
(Expr : Node_Id; (Expr : Node_Id;
Typ : Entity_Id; Typ : Entity_Id;
Obj_Id : Entity_Id; Obj_Id : Entity_Id);
Dispatch : Boolean := False);
-- Substitute all references of the current instance of type Typ with -- Substitute all references of the current instance of type Typ with
-- references to formal parameter Obj_Id within expression Expr. -- references to formal parameter Obj_Id within expression Expr.
......
gcc/ada/sem_ch3.adb
...@@ -2279,12 +2279,32 @@ package body Sem_Ch3 is ...@@ -2279,12 +2279,32 @@ package body Sem_Ch3 is
if Nkind (Context) = N_Package_Specification then if Nkind (Context) = N_Package_Specification then
-- Preanalyze and resolve the class-wide invariants of an
-- interface at the end of whichever declarative part has the
-- interface type. Note that an interface may be declared in
-- any non-package declarative part, but reaching the end of
-- such a declarative part will always freeze the type and
-- generate the invariant procedure (see Freeze_Type).
if Is_Interface (Typ) then
-- Interfaces are treated as the partial view of a private
-- type in order to achieve uniformity with the general
-- case. As a result, an interface receives only a "partial"
-- invariant procedure which is never called.
if Has_Own_Invariants (Typ) then
Build_Invariant_Procedure_Body
(Typ => Typ,
Partial_Invariant => True);
end if;
-- Preanalyze and resolve the invariants of a private type -- Preanalyze and resolve the invariants of a private type
-- at the end of the visible declarations to catch potential -- at the end of the visible declarations to catch potential
-- errors. Inherited class-wide invariants are not included -- errors. Inherited class-wide invariants are not included
-- because they have already been resolved. -- because they have already been resolved.
if Decls = Visible_Declarations (Context) elsif Decls = Visible_Declarations (Context)
and then Ekind_In (Typ, E_Limited_Private_Type, and then Ekind_In (Typ, E_Limited_Private_Type,
E_Private_Type, E_Private_Type,
E_Record_Type_With_Private) E_Record_Type_With_Private)
...@@ -15315,10 +15335,9 @@ package body Sem_Ch3 is ...@@ -15315,10 +15335,9 @@ package body Sem_Ch3 is
New_Overloaded_Entity (New_Subp, Derived_Type); New_Overloaded_Entity (New_Subp, Derived_Type);
-- Implement rule in 6.1.1 (15) : if subprogram inherits non-conforming -- Ada RM 6.1.1 (15): If a subprogram inherits non-conforming class-wide
-- classwide preconditions and the derived type is abstract, the -- preconditions and the derived type is abstract, the derived operation
-- derived operation is abstract as well if parent subprogram is not -- is abstract as well if parent subprogram is not abstract or null.
-- abstract or null.
if Is_Abstract_Type (Derived_Type) if Is_Abstract_Type (Derived_Type)
and then Has_Non_Trivial_Precondition (Parent_Subp) and then Has_Non_Trivial_Precondition (Parent_Subp)
......
gcc/ada/sem_prag.adb
...@@ -17113,10 +17113,14 @@ package body Sem_Prag is ...@@ -17113,10 +17113,14 @@ package body Sem_Prag is
Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
-- Create the declaration of the invariant procedure which will -- Create the declaration of the invariant procedure which will
-- verify the invariant at run-time. Note that interfaces do not -- verify the invariant at run-time. Interfaces are treated as the
-- carry such a declaration. -- partial view of a private type in order to achieve uniformity
-- with the general case. As a result, an interface receives only
Build_Invariant_Procedure_Declaration (Typ); -- a "partial" invariant procedure which is never called.
Build_Invariant_Procedure_Declaration
(Typ => Typ,
Partial_Invariant => Is_Interface (Typ));
end Invariant; end Invariant;
---------------- ----------------
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment