with Exp_Util; use Exp_Util;
with Fname; use Fname;
with Freeze; use Freeze;
-with Ghost; use Ghost;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
with Namet.Sp; use Namet.Sp;
with Sem_Attr; use Sem_Attr;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch13; use Sem_Ch13;
with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Prag; use Sem_Prag;
return Decl;
end Build_Component_Subtype;
- ----------------------------------
- -- Build_Default_Init_Cond_Call --
- ----------------------------------
-
- function Build_Default_Init_Cond_Call
- (Loc : Source_Ptr;
- Obj_Id : Entity_Id;
- Typ : Entity_Id) return Node_Id
- is
- Proc_Id : constant Entity_Id := Default_Init_Cond_Procedure (Typ);
- Formal_Typ : constant Entity_Id := Etype (First_Formal (Proc_Id));
-
- begin
- return
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (Proc_Id, Loc),
- Parameter_Associations => New_List (
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (Formal_Typ, Loc),
- Expression => New_Occurrence_Of (Obj_Id, Loc))));
- end Build_Default_Init_Cond_Call;
-
- ----------------------------------------------
- -- Build_Default_Init_Cond_Procedure_Bodies --
- ----------------------------------------------
-
- procedure Build_Default_Init_Cond_Procedure_Bodies (Priv_Decls : List_Id) is
- procedure Build_Default_Init_Cond_Procedure_Body (Typ : Entity_Id);
- -- If type Typ is subject to pragma Default_Initial_Condition, build the
- -- body of the procedure which verifies the assumption of the pragma at
- -- run time. The generated body is added after the type declaration.
-
- --------------------------------------------
- -- Build_Default_Init_Cond_Procedure_Body --
- --------------------------------------------
-
- procedure Build_Default_Init_Cond_Procedure_Body (Typ : Entity_Id) is
- Param_Id : Entity_Id;
- -- The entity of the sole formal parameter of the default initial
- -- condition procedure.
-
- procedure Replace_Type_Reference (N : Node_Id);
- -- Replace a single reference to type Typ with a reference to formal
- -- parameter Param_Id.
-
- ----------------------------
- -- Replace_Type_Reference --
- ----------------------------
-
- procedure Replace_Type_Reference (N : Node_Id) is
- begin
- Rewrite (N, New_Occurrence_Of (Param_Id, Sloc (N)));
- end Replace_Type_Reference;
-
- procedure Replace_Type_References is
- new Replace_Type_References_Generic (Replace_Type_Reference);
-
- -- Local variables
-
- Loc : constant Source_Ptr := Sloc (Typ);
- Prag : constant Node_Id :=
- Get_Pragma (Typ, Pragma_Default_Initial_Condition);
- Proc_Id : constant Entity_Id := Default_Init_Cond_Procedure (Typ);
- Body_Decl : Node_Id;
- Expr : Node_Id;
- Spec_Decl : Node_Id;
- Stmt : Node_Id;
-
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
-
- -- Start of processing for Build_Default_Init_Cond_Procedure_Body
-
- begin
- -- The procedure should be generated only for [sub]types subject to
- -- pragma Default_Initial_Condition. Types that inherit the pragma do
- -- not get this specialized procedure.
-
- pragma Assert (Has_Default_Init_Cond (Typ));
- pragma Assert (Present (Prag));
-
- -- Nothing to do if the spec was not built. This occurs when the
- -- expression of the Default_Initial_Condition is missing or is
- -- null.
-
- if No (Proc_Id) then
- return;
-
- -- Nothing to do if the body was already built
-
- elsif Present (Corresponding_Body (Unit_Declaration_Node (Proc_Id)))
- then
- return;
- end if;
-
- -- The related type may be subject to pragma Ghost. Set the mode now
- -- to ensure that the analysis and expansion produce Ghost nodes.
-
- Set_Ghost_Mode_From_Entity (Typ);
-
- Param_Id := First_Formal (Proc_Id);
-
- -- The pragma has an argument. Note that the argument is analyzed
- -- after all references to the current instance of the type are
- -- replaced.
-
- if Present (Pragma_Argument_Associations (Prag)) then
- Expr :=
- Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
-
- if Nkind (Expr) = N_Null then
- Stmt := Make_Null_Statement (Loc);
-
- -- Preserve the original argument of the pragma by replicating it.
- -- Replace all references to the current instance of the type with
- -- references to the formal parameter.
-
- else
- Expr := New_Copy_Tree (Expr);
- Replace_Type_References (Expr, Typ);
-
- -- Generate:
- -- pragma Check (Default_Initial_Condition, <Expr>);
-
- Stmt :=
- Make_Pragma (Loc,
- Pragma_Identifier =>
- Make_Identifier (Loc, Name_Check),
-
- Pragma_Argument_Associations => New_List (
- Make_Pragma_Argument_Association (Loc,
- Expression =>
- Make_Identifier (Loc,
- Chars => Name_Default_Initial_Condition)),
- Make_Pragma_Argument_Association (Loc,
- Expression => Expr)));
- end if;
-
- -- Otherwise the pragma appears without an argument
-
- else
- Stmt := Make_Null_Statement (Loc);
- end if;
-
- -- Generate:
- -- procedure <Typ>Default_Init_Cond (I : <Typ>) is
- -- begin
- -- <Stmt>;
- -- end <Typ>Default_Init_Cond;
-
- Spec_Decl := Unit_Declaration_Node (Proc_Id);
- Body_Decl :=
- Make_Subprogram_Body (Loc,
- Specification =>
- Copy_Separate_Tree (Specification (Spec_Decl)),
- Declarations => Empty_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Stmt)));
-
- -- Link the spec and body of the default initial condition procedure
- -- to prevent the generation of a duplicate body.
-
- Set_Corresponding_Body (Spec_Decl, Defining_Entity (Body_Decl));
- Set_Corresponding_Spec (Body_Decl, Proc_Id);
-
- Insert_After_And_Analyze (Declaration_Node (Typ), Body_Decl);
- Ghost_Mode := Save_Ghost_Mode;
- end Build_Default_Init_Cond_Procedure_Body;
-
- -- Local variables
-
- Decl : Node_Id;
- Typ : Entity_Id;
-
- -- Start of processing for Build_Default_Init_Cond_Procedure_Bodies
-
- begin
- -- Inspect the private declarations looking for [sub]type declarations
-
- Decl := First (Priv_Decls);
- while Present (Decl) loop
- if Nkind_In (Decl, N_Full_Type_Declaration,
- N_Subtype_Declaration)
- then
- Typ := Defining_Entity (Decl);
-
- -- Guard against partially decorate types due to previous errors
-
- if Is_Type (Typ) then
-
- -- If the type is subject to pragma Default_Initial_Condition,
- -- generate the body of the internal procedure which verifies
- -- the assertion of the pragma at run time.
-
- if Has_Default_Init_Cond (Typ) then
- Build_Default_Init_Cond_Procedure_Body (Typ);
-
- -- A derived type inherits the default initial condition
- -- procedure from its parent type.
-
- elsif Has_Inherited_Default_Init_Cond (Typ) then
- Inherit_Default_Init_Cond_Procedure (Typ);
- end if;
- end if;
- end if;
-
- Next (Decl);
- end loop;
- end Build_Default_Init_Cond_Procedure_Bodies;
-
- ---------------------------------------------------
- -- Build_Default_Init_Cond_Procedure_Declaration --
- ---------------------------------------------------
-
- procedure Build_Default_Init_Cond_Procedure_Declaration (Typ : Entity_Id) is
- Loc : constant Source_Ptr := Sloc (Typ);
- Prag : constant Node_Id :=
- Get_Pragma (Typ, Pragma_Default_Initial_Condition);
-
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
-
- Args : List_Id;
- Proc_Id : Entity_Id;
-
- begin
- -- The procedure should be generated only for types subject to pragma
- -- Default_Initial_Condition. Types that inherit the pragma do not get
- -- this specialized procedure.
-
- pragma Assert (Has_Default_Init_Cond (Typ));
- pragma Assert (Present (Prag));
-
- Args := Pragma_Argument_Associations (Prag);
-
- -- Nothing to do if default initial condition procedure already built
-
- if Present (Default_Init_Cond_Procedure (Typ)) then
- return;
-
- -- Nothing to do if the default initial condition appears without an
- -- expression.
-
- elsif No (Args) then
- return;
-
- -- Nothing to do if the expression of the default initial condition is
- -- null.
-
- elsif Nkind (Get_Pragma_Arg (First (Args))) = N_Null then
- return;
- end if;
-
- -- The related type may be subject to pragma Ghost. Set the mode now to
- -- ensure that the analysis and expansion produce Ghost nodes.
-
- Set_Ghost_Mode_From_Entity (Typ);
-
- Proc_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Typ), "Default_Init_Cond"));
-
- -- Associate default initial condition procedure with the private type
-
- Set_Ekind (Proc_Id, E_Procedure);
- Set_Is_Default_Init_Cond_Procedure (Proc_Id);
- Set_Default_Init_Cond_Procedure (Typ, Proc_Id);
-
- -- Mark the default initial condition procedure explicitly as Ghost
- -- because it does not come from source.
-
- if Ghost_Mode > None then
- Set_Is_Ghost_Entity (Proc_Id);
- end if;
-
- -- Generate:
- -- procedure <Typ>Default_Init_Cond (Inn : <Typ>);
-
- Insert_After_And_Analyze (Prag,
- Make_Subprogram_Declaration (Loc,
- Specification =>
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Proc_Id,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Make_Temporary (Loc, 'I'),
- Parameter_Type => New_Occurrence_Of (Typ, Loc))))));
-
- Ghost_Mode := Save_Ghost_Mode;
- end Build_Default_Init_Cond_Procedure_Declaration;
-
---------------------------
-- Build_Default_Subtype --
---------------------------
Prag := Pre_Post_Conditions (Items);
while Present (Prag) loop
- if Nam_In (Pragma_Name (Prag), Name_Postcondition,
- Name_Refined_Post)
+ if Nam_In (Pragma_Name_Unmapped (Prag),
+ Name_Postcondition, Name_Refined_Post)
and then not Error_Posted (Prag)
then
Post_Prag := Prag;
end loop Find_Discrete_Value;
end Search_For_Discriminant_Value;
- if No (Variant) then
+ -- The case statement must include a variant that corresponds to the
+ -- value of the discriminant, unless the discriminant type has a
+ -- static predicate. In that case the absence of an others_choice that
+ -- would cover this value becomes a run-time error (3.8,1 (21.1/2)).
+
+ if No (Variant)
+ and then not Has_Static_Predicate (Etype (Discrim_Name))
+ then
Error_Msg_NE
("value of discriminant & is out of range", Discrim_Value, Discrim);
Report_Errors := True;
-- components to the Into list. The nested components are part of
-- the same record type.
- Gather_Components
- (Typ, Component_List (Variant), Governed_By, Into, Report_Errors);
+ if Present (Variant) then
+ Gather_Components
+ (Typ, Component_List (Variant), Governed_By, Into, Report_Errors);
+ end if;
end Gather_Components;
------------------------
function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
begin
- return Get_Pragma_Id (Pragma_Name (N));
+ return Get_Pragma_Id (Pragma_Name_Unmapped (N));
end Get_Pragma_Id;
------------------------
Full_Base : out Entity_Id;
CRec_Typ : out Entity_Id)
is
+ IP_View : Entity_Id;
+
begin
-- Assume that none of the views can be recovered
Full_Base := Empty;
CRec_Typ := Empty;
- -- The input type is private
-
- if Is_Private_Type (Typ) then
- Priv_Typ := Typ;
- Full_Typ := Full_View (Priv_Typ);
-
- if Present (Full_Typ) then
- Full_Base := Base_Type (Full_Typ);
-
- if Ekind_In (Full_Typ, E_Protected_Type, E_Task_Type) then
- CRec_Typ := Corresponding_Record_Type (Full_Typ);
- end if;
- end if;
-
-- The input type is the corresponding record type of a protected or a
-- task type.
- elsif Ekind (Typ) = E_Record_Type
+ if Ekind (Typ) = E_Record_Type
and then Is_Concurrent_Record_Type (Typ)
then
CRec_Typ := Typ;
Full_Base := Base_Type (Full_Typ);
Priv_Typ := Incomplete_Or_Partial_View (Full_Typ);
- -- Otherwise the input type could be the full view of a private type
+ -- Otherwise the input type denotes an arbitrary type
else
- Full_Typ := Typ;
- Full_Base := Base_Type (Full_Typ);
+ IP_View := Incomplete_Or_Partial_View (Typ);
- if Ekind_In (Full_Typ, E_Protected_Type, E_Task_Type) then
- CRec_Typ := Corresponding_Record_Type (Full_Typ);
- end if;
+ -- The input type denotes the full view of a private type
- -- The type is the full view of a private type, obtain the partial
- -- view.
+ if Present (IP_View) then
+ Priv_Typ := IP_View;
+ Full_Typ := Typ;
- if Has_Private_Declaration (Full_Typ)
- and then not Is_Private_Type (Full_Typ)
- then
- Priv_Typ := Incomplete_Or_Partial_View (Full_Typ);
+ -- The input type is a private type
+
+ elsif Is_Private_Type (Typ) then
+ Priv_Typ := Typ;
+ Full_Typ := Full_View (Priv_Typ);
+
+ -- Otherwise the input type does not have any views
- -- The full view of a private type should always have a partial
- -- view.
+ else
+ Full_Typ := Typ;
+ end if;
+
+ if Present (Full_Typ) then
+ Full_Base := Base_Type (Full_Typ);
- pragma Assert (Present (Priv_Typ));
+ if Ekind_In (Full_Typ, E_Protected_Type, E_Task_Type) then
+ CRec_Typ := Corresponding_Record_Type (Full_Typ);
+ end if;
end if;
end if;
end Get_Views;
-------------------------------------
function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean is
- Arg : Node_Id;
Comp : Entity_Id;
Prag : Node_Id;
begin
- -- A private type and its full view is fully default initialized when it
- -- is subject to pragma Default_Initial_Condition without an argument or
- -- with a non-null argument. Since any type may act as the full view of
- -- a private type, this check must be performed prior to the specialized
- -- tests below.
+ -- A type subject to pragma Default_Initial_Condition is fully default
+ -- initialized when the pragma appears with a non-null argument. Since
+ -- any type may act as the full view of a private type, this check must
+ -- be performed prior to the specialized tests below.
- if Has_Default_Init_Cond (Typ)
- or else Has_Inherited_Default_Init_Cond (Typ)
- then
+ if Has_DIC (Typ) then
Prag := Get_Pragma (Typ, Pragma_Default_Initial_Condition);
-
- -- Pragma Default_Initial_Condition must be present if one of the
- -- related entity flags is set.
-
pragma Assert (Present (Prag));
- Arg := First (Pragma_Argument_Associations (Prag));
- -- A non-null argument guarantees full default initialization
-
- if Present (Arg) then
- return Nkind (Arg) /= N_Null;
-
- -- Otherwise the missing argument defaults the pragma to "True" which
- -- is considered a non-null argument (see above).
-
- else
- return True;
- end if;
+ return Is_Verifiable_DIC_Pragma (Prag);
end if;
-- A scalar type is fully default initialized if it is subject to aspect
and then Assertion_Expression_Pragma (Get_Pragma_Id (Prag));
end In_Assertion_Expression_Pragma;
+ ----------------------
+ -- In_Generic_Scope --
+ ----------------------
+
+ function In_Generic_Scope (E : Entity_Id) return Boolean is
+ S : Entity_Id;
+
+ begin
+ S := Scope (E);
+ while Present (S) and then S /= Standard_Standard loop
+ if Is_Generic_Unit (S) then
+ return True;
+ end if;
+
+ S := Scope (S);
+ end loop;
+
+ return False;
+ end In_Generic_Scope;
+
-----------------
-- In_Instance --
-----------------
return Off * (Expr_Value (Exp) - Expr_Value (Low_Bound ((Ind))));
end Indexed_Component_Bit_Offset;
- -----------------------------------------
- -- Inherit_Default_Init_Cond_Procedure --
- -----------------------------------------
-
- procedure Inherit_Default_Init_Cond_Procedure (Typ : Entity_Id) is
- Par_Typ : constant Entity_Id := Etype (Typ);
-
- begin
- -- A derived type inherits the default initial condition procedure of
- -- its parent type.
-
- if No (Default_Init_Cond_Procedure (Typ)) then
- Set_Default_Init_Cond_Procedure
- (Typ, Default_Init_Cond_Procedure (Par_Typ));
- end if;
- end Inherit_Default_Init_Cond_Procedure;
-
----------------------------
-- Inherit_Rep_Item_Chain --
----------------------------
elsif Nkind (P) = N_Pragma
and then
- Get_Pragma_Id (Pragma_Name (P)) = Pragma_Predicate_Failure
+ Get_Pragma_Id (P) = Pragma_Predicate_Failure
then
return True;
end if;
end if;
end Is_Local_Variable_Reference;
- -----------------------------------------------
- -- Is_Nontrivial_Default_Init_Cond_Procedure --
- -----------------------------------------------
+ ---------------------------------
+ -- Is_Nontrivial_DIC_Procedure --
+ ---------------------------------
- function Is_Nontrivial_Default_Init_Cond_Procedure
- (Id : Entity_Id) return Boolean
- is
+ function Is_Nontrivial_DIC_Procedure (Id : Entity_Id) return Boolean is
Body_Decl : Node_Id;
- Stmt : Node_Id;
+ Stmt : Node_Id;
begin
- if Ekind (Id) = E_Procedure
- and then Is_Default_Init_Cond_Procedure (Id)
- then
+ if Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id) then
Body_Decl :=
Unit_Declaration_Node
(Corresponding_Body (Unit_Declaration_Node (Id)));
end if;
return False;
- end Is_Nontrivial_Default_Init_Cond_Procedure;
+ end Is_Nontrivial_DIC_Procedure;
-------------------------
-- Is_Null_Record_Type --
end if;
end Is_Variable;
+ ------------------------------
+ -- Is_Verifiable_DIC_Pragma --
+ ------------------------------
+
+ function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean is
+ Args : constant List_Id := Pragma_Argument_Associations (Prag);
+
+ begin
+ -- To qualify as verifiable, a DIC pragma must have a non-null argument
+
+ return
+ Present (Args)
+ and then Nkind (Get_Pragma_Arg (First (Args))) /= N_Null;
+ end Is_Verifiable_DIC_Pragma;
+
---------------------------
-- Is_Visibly_Controlled --
---------------------------
---------------------------
function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is
-
function Non_Internal_Name (E : Entity_Id) return Name_Id;
-- Given an internal name, returns the corresponding non-internal name
Set_Sloc (Endl, Loc);
end Process_End_Label;
+ --------------------------------
+ -- Propagate_Concurrent_Flags --
+ --------------------------------
+
+ procedure Propagate_Concurrent_Flags
+ (Typ : Entity_Id;
+ Comp_Typ : Entity_Id)
+ is
+ begin
+ if Has_Task (Comp_Typ) then
+ Set_Has_Task (Typ);
+ end if;
+
+ if Has_Protected (Comp_Typ) then
+ Set_Has_Protected (Typ);
+ end if;
+
+ if Has_Timing_Event (Comp_Typ) then
+ Set_Has_Timing_Event (Typ);
+ end if;
+ end Propagate_Concurrent_Flags;
+
+ ------------------------------
+ -- Propagate_DIC_Attributes --
+ ------------------------------
+
+ procedure Propagate_DIC_Attributes
+ (Typ : Entity_Id;
+ From_Typ : Entity_Id)
+ is
+ DIC_Proc : Entity_Id;
+
+ begin
+ if Present (Typ) and then Present (From_Typ) then
+ pragma Assert (Is_Type (Typ) and then Is_Type (From_Typ));
+
+ -- Nothing to do if both the source and the destination denote the
+ -- same type.
+
+ if From_Typ = Typ then
+ return;
+ end if;
+
+ DIC_Proc := DIC_Procedure (From_Typ);
+
+ -- The setting of the attributes is intentionally conservative. This
+ -- prevents accidental clobbering of enabled attributes.
+
+ if Has_Inherited_DIC (From_Typ)
+ and then not Has_Inherited_DIC (Typ)
+ then
+ Set_Has_Inherited_DIC (Typ);
+ end if;
+
+ if Has_Own_DIC (From_Typ) and then not Has_Own_DIC (Typ) then
+ Set_Has_Own_DIC (Typ);
+ end if;
+
+ if Present (DIC_Proc) and then No (DIC_Procedure (Typ)) then
+ Set_DIC_Procedure (Typ, DIC_Proc);
+ end if;
+ end if;
+ end Propagate_DIC_Attributes;
+
------------------------------------
-- Propagate_Invariant_Attributes --
------------------------------------
end if;
end Propagate_Invariant_Attributes;
- --------------------------------
- -- Propagate_Concurrent_Flags --
- --------------------------------
-
- procedure Propagate_Concurrent_Flags
- (Typ : Entity_Id;
- Comp_Typ : Entity_Id)
- is
- begin
- if Has_Task (Comp_Typ) then
- Set_Has_Task (Typ);
- end if;
-
- if Has_Protected (Comp_Typ) then
- Set_Has_Protected (Typ);
- end if;
-
- if Has_Timing_Event (Comp_Typ) then
- Set_Has_Timing_Event (Typ);
- end if;
- end Propagate_Concurrent_Flags;
-
---------------------------------------
-- Record_Possible_Part_Of_Reference --
---------------------------------------
if Nkind (Parent (E)) = N_Entry_Body then
declare
Prot_Item : Entity_Id;
+ Prot_Type : Entity_Id;
+
begin
+ if Ekind (E) = E_Entry then
+ Prot_Type := Scope (E);
+
+ -- Bodies of entry families are nested within an extra scope
+ -- that contains an entry index declaration
+
+ else
+ Prot_Type := Scope (Scope (E));
+ end if;
+
+ pragma Assert (Ekind (Prot_Type) = E_Protected_Type);
+
-- Traverse the entity list of the protected type and locate
-- an entry declaration which matches the entry body.
- Prot_Item := First_Entity (Scope (E));
+ Prot_Item := First_Entity (Prot_Type);
while Present (Prot_Item) loop
- if Ekind (Prot_Item) = E_Entry
+ if Ekind (Prot_Item) in Entry_Kind
and then Corresponding_Body (Parent (Prot_Item)) = E
then
U := Prot_Item;
and then Present (Corresponding_Spec_Of_Stub (P))
then
U := Corresponding_Spec_Of_Stub (P);
+
+ if Is_Single_Protected_Object (U) then
+ U := Etype (U);
+ end if;
end if;
when E_Subprogram_Body =>
and then Present (Corresponding_Spec_Of_Stub (P))
then
U := Corresponding_Spec_Of_Stub (P);
+
+ if Is_Single_Task_Object (U) then
+ U := Etype (U);
+ end if;
end if;
when Type_Kind =>
git://gcc.gnu.org / gcc.git / blobdiff