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;
end if;
end Address_Integer_Convert_OK;
+ -------------------
+ -- Address_Value --
+ -------------------
+
+ function Address_Value (N : Node_Id) return Node_Id is
+ Expr : Node_Id := N;
+
+ begin
+ loop
+ -- For constant, get constant expression
+
+ if Is_Entity_Name (Expr)
+ and then Ekind (Entity (Expr)) = E_Constant
+ then
+ Expr := Constant_Value (Entity (Expr));
+
+ -- For unchecked conversion, get result to convert
+
+ elsif Nkind (Expr) = N_Unchecked_Type_Conversion then
+ Expr := Expression (Expr);
+
+ -- For (common case) of To_Address call, get argument
+
+ elsif Nkind (Expr) = N_Function_Call
+ and then Is_Entity_Name (Name (Expr))
+ and then Is_RTE (Entity (Name (Expr)), RE_To_Address)
+ then
+ Expr := First (Parameter_Associations (Expr));
+
+ if Nkind (Expr) = N_Parameter_Association then
+ Expr := Explicit_Actual_Parameter (Expr);
+ end if;
+
+ -- We finally have the real expression
+
+ else
+ exit;
+ end if;
+ end loop;
+
+ return Expr;
+ end Address_Value;
+
-----------------
-- Addressable --
-----------------
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);
- Spec_Decl : constant Node_Id := Unit_Declaration_Node (Proc_Id);
- Body_Decl : Node_Id;
- Expr : 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));
- pragma Assert (Present (Proc_Id));
-
- -- Nothing to do if the body was already built
-
- if Present (Corresponding_Body (Spec_Decl)) 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;
-
- 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;
-
- 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));
-
- -- Nothing to do if default initial condition procedure already built
-
- if Present (Default_Init_Cond_Procedure (Typ)) 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;
Full_T := Full_View (Typ);
if Ekind (Full_T) = E_Record_Subtype then
- Full_T := Full_View (Etype (Typ));
+ Full_T := Etype (Typ);
+
+ if Present (Full_View (Full_T)) then
+ Full_T := Full_View (Full_T);
+ end if;
end if;
end if;
Msgl := Msg'Length;
for J in 1 .. Msgl loop
- if Msg (J) = '?' and then (J = 1 or else Msg (J) /= ''') then
+ if Msg (J) = '?' and then (J = 1 or else Msg (J - 1) /= ''') then
Msgc (J) := '<';
else
Msgc (J) := Msg (J);
Encl_Unit := Library_Unit (Encl_Unit);
end loop;
+ pragma Assert (Nkind (Encl_Unit) = N_Compilation_Unit);
return Encl_Unit;
end Enclosing_Lib_Unit_Node;
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;
------------------------
is
Btyp : Entity_Id := Base_Type (T);
Lit : Node_Id;
+ LLoc : Source_Ptr;
begin
-- In the case where the literal is of type Character, Wide_Character
if Is_Standard_Character_Type (T) then
Set_Character_Literal_Name (UI_To_CC (Pos));
+
return
Make_Character_Literal (Loc,
Chars => Name_Find,
Lit := First_Literal (Btyp);
for J in 1 .. UI_To_Int (Pos) loop
Next_Literal (Lit);
+
+ -- If Lit is Empty, Pos is not in range, so raise Constraint_Error
+ -- inside the loop to avoid calling Next_Literal on Empty.
+
+ if No (Lit) then
+ raise Constraint_Error;
+ end if;
end loop;
- return New_Occurrence_Of (Lit, Loc);
+ -- Create a new node from Lit, with source location provided by Loc
+ -- if not equal to No_Location, or by copying the source location of
+ -- Lit otherwise.
+
+ LLoc := Loc;
+
+ if LLoc = No_Location then
+ LLoc := Sloc (Lit);
+ end if;
+
+ return New_Occurrence_Of (Lit, LLoc);
end if;
end Get_Enum_Lit_From_Pos;
pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
end Get_Library_Unit_Name_String;
+ --------------------------
+ -- Get_Max_Queue_Length --
+ --------------------------
+
+ function Get_Max_Queue_Length (Id : Entity_Id) return Uint is
+ pragma Assert (Is_Entry (Id));
+ Prag : constant Entity_Id := Get_Pragma (Id, Pragma_Max_Queue_Length);
+
+ begin
+ -- A value of 0 represents no maximum specified, and entries and entry
+ -- families with no Max_Queue_Length aspect or pragma default to it.
+
+ if not Present (Prag) then
+ return Uint_0;
+ end if;
+
+ return Intval (Expression (First (Pragma_Argument_Associations (Prag))));
+ end Get_Max_Queue_Length;
+
------------------------
-- Get_Name_Entity_Id --
------------------------
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;
------------------------
return Empty;
end Get_User_Defined_Eq;
+ ---------------
+ -- Get_Views --
+ ---------------
+
+ procedure Get_Views
+ (Typ : Entity_Id;
+ Priv_Typ : out Entity_Id;
+ Full_Typ : out Entity_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
+
+ Priv_Typ := Empty;
+ Full_Typ := Empty;
+ Full_Base := Empty;
+ CRec_Typ := Empty;
+
+ -- The input type is the corresponding record type of a protected or a
+ -- task type.
+
+ if Ekind (Typ) = E_Record_Type
+ and then Is_Concurrent_Record_Type (Typ)
+ then
+ CRec_Typ := Typ;
+ Full_Typ := Corresponding_Concurrent_Type (CRec_Typ);
+ Full_Base := Base_Type (Full_Typ);
+ Priv_Typ := Incomplete_Or_Partial_View (Full_Typ);
+
+ -- Otherwise the input type denotes an arbitrary type
+
+ else
+ IP_View := Incomplete_Or_Partial_View (Typ);
+
+ -- The input type denotes the full view of a private type
+
+ if Present (IP_View) then
+ Priv_Typ := IP_View;
+ Full_Typ := 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
+
+ else
+ Full_Typ := Typ;
+ end if;
+
+ 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;
+ end if;
+ end Get_Views;
+
-----------------------
-- Has_Access_Values --
-----------------------
elsif Nkind (Expr) = N_Indexed_Component then
declare
Typ : constant Entity_Id := Etype (Prefix (Expr));
- Ind : constant Node_Id := First_Index (Typ);
begin
-- Packing generates unknown alignment if layout is not done
Set_Result (Unknown);
end if;
- -- Check prefix and component offset
+ -- Check prefix and component offset (or at least size)
Check_Prefix;
- Offs := Component_Size (Typ);
-
- -- Small optimization: compute the full offset when possible
-
- if Offs /= No_Uint
- and then Offs > Uint_0
- and then Present (Ind)
- and then Nkind (Ind) = N_Range
- and then Compile_Time_Known_Value (Low_Bound (Ind))
- and then Compile_Time_Known_Value (First (Expressions (Expr)))
- then
- Offs := Offs * (Expr_Value (First (Expressions (Expr)))
- - Expr_Value (Low_Bound ((Ind))));
+ Offs := Indexed_Component_Bit_Offset (Expr);
+ if Offs = No_Uint then
+ Offs := Component_Size (Typ);
end if;
end;
end if;
-------------------------------------
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
return False;
end Has_Interfaces;
+ --------------------------
+ -- Has_Max_Queue_Length --
+ --------------------------
+
+ function Has_Max_Queue_Length (Id : Entity_Id) return Boolean is
+ begin
+ return
+ Ekind (Id) = E_Entry
+ and then Present (Get_Pragma (Id, Pragma_Max_Queue_Length));
+ end Has_Max_Queue_Length;
+
---------------------------------
-- Has_No_Obvious_Side_Effects --
---------------------------------
function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is
begin
- -- For now, just handle literals, constants, and non-volatile
- -- variables and expressions combining these with operators or
- -- short circuit forms.
+ -- For now handle literals, constants, and non-volatile variables and
+ -- expressions combining these with operators or short circuit forms.
if Nkind (N) in N_Numeric_Or_String_Literal then
return True;
and then Nkind (Node (First_Elmt (Constits))) /= N_Null;
end Has_Non_Null_Refinement;
+ -------------------
+ -- Has_Null_Body --
+ -------------------
+
+ function Has_Null_Body (Proc_Id : Entity_Id) return Boolean is
+ Body_Id : Entity_Id;
+ Decl : Node_Id;
+ Spec : Node_Id;
+ Stmt1 : Node_Id;
+ Stmt2 : Node_Id;
+
+ begin
+ Spec := Parent (Proc_Id);
+ Decl := Parent (Spec);
+
+ -- Retrieve the entity of the procedure body (e.g. invariant proc).
+
+ if Nkind (Spec) = N_Procedure_Specification
+ and then Nkind (Decl) = N_Subprogram_Declaration
+ then
+ Body_Id := Corresponding_Body (Decl);
+
+ -- The body acts as a spec
+
+ else
+ Body_Id := Proc_Id;
+ end if;
+
+ -- The body will be generated later
+
+ if No (Body_Id) then
+ return False;
+ end if;
+
+ Spec := Parent (Body_Id);
+ Decl := Parent (Spec);
+
+ pragma Assert
+ (Nkind (Spec) = N_Procedure_Specification
+ and then Nkind (Decl) = N_Subprogram_Body);
+
+ Stmt1 := First (Statements (Handled_Statement_Sequence (Decl)));
+
+ -- Look for a null statement followed by an optional return
+ -- statement.
+
+ if Nkind (Stmt1) = N_Null_Statement then
+ Stmt2 := Next (Stmt1);
+
+ if Present (Stmt2) then
+ return Nkind (Stmt2) = N_Simple_Return_Statement;
+ else
+ return True;
+ end if;
+ end if;
+
+ return False;
+ end Has_Null_Body;
+
------------------------
-- Has_Null_Exclusion --
------------------------
return Name_Find;
end Remove_Suffix;
+ ----------------------------------
+ -- Replace_Null_By_Null_Address --
+ ----------------------------------
+
+ procedure Replace_Null_By_Null_Address (N : Node_Id) is
+ procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id);
+ -- Replace operand Op with a reference to Null_Address when the operand
+ -- denotes a null Address. Other_Op denotes the other operand.
+
+ --------------------------
+ -- Replace_Null_Operand --
+ --------------------------
+
+ procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id) is
+ begin
+ -- Check the type of the complementary operand since the N_Null node
+ -- has not been decorated yet.
+
+ if Nkind (Op) = N_Null
+ and then Is_Descendant_Of_Address (Etype (Other_Op))
+ then
+ Rewrite (Op, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (Op)));
+ end if;
+ end Replace_Null_Operand;
+
+ -- Start of processing for Replace_Null_By_Null_Address
+
+ begin
+ pragma Assert (Relaxed_RM_Semantics);
+ pragma Assert (Nkind_In (N, N_Null,
+ N_Op_Eq,
+ N_Op_Ge,
+ N_Op_Gt,
+ N_Op_Le,
+ N_Op_Lt,
+ N_Op_Ne));
+
+ if Nkind (N) = N_Null then
+ Rewrite (N, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
+
+ else
+ declare
+ L : constant Node_Id := Left_Opnd (N);
+ R : constant Node_Id := Right_Opnd (N);
+
+ begin
+ Replace_Null_Operand (L, Other_Op => R);
+ Replace_Null_Operand (R, Other_Op => L);
+ end;
+ end if;
+ end Replace_Null_By_Null_Address;
+
--------------------------
-- Has_Tagged_Component --
--------------------------
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 --
-----------------
while Present (Decl) loop
Match := Empty;
+ -- The partial view of a Taft-amendment type is an incomplete
+ -- type.
+
if Taft then
if Nkind (Decl) = N_Incomplete_Type_Declaration then
Match := Defining_Identifier (Decl);
end if;
- else
- if Nkind_In (Decl, N_Private_Extension_Declaration,
+ -- Otherwise look for a private type whose full view matches the
+ -- input type. Note that this checks full_type_declaration nodes
+ -- to account for derivations from a private type where the type
+ -- declaration hold the partial view and the full view is an
+ -- itype.
+
+ elsif Nkind_In (Decl, N_Full_Type_Declaration,
+ N_Private_Extension_Declaration,
N_Private_Type_Declaration)
- then
- Match := Defining_Identifier (Decl);
- end if;
+ then
+ Match := Defining_Identifier (Decl);
end if;
+ -- Guard against unanalyzed entities
+
if Present (Match)
+ and then Is_Type (Match)
and then Present (Full_View (Match))
and then Full_View (Match) = Id
then
Pkg_Decl : Node_Id := Pkg;
begin
- if Present (Pkg) and then Ekind (Pkg) = E_Package then
+ if Present (Pkg)
+ and then Ekind_In (Pkg, E_Generic_Package, E_Package)
+ then
while Nkind (Pkg_Decl) /= N_Package_Specification loop
Pkg_Decl := Parent (Pkg_Decl);
end loop;
return Empty;
end Incomplete_Or_Partial_View;
- -----------------------------------------
- -- Inherit_Default_Init_Cond_Procedure --
- -----------------------------------------
+ ----------------------------------
+ -- Indexed_Component_Bit_Offset --
+ ----------------------------------
- procedure Inherit_Default_Init_Cond_Procedure (Typ : Entity_Id) is
- Par_Typ : constant Entity_Id := Etype (Typ);
+ function Indexed_Component_Bit_Offset (N : Node_Id) return Uint is
+ Exp : constant Node_Id := First (Expressions (N));
+ Typ : constant Entity_Id := Etype (Prefix (N));
+ Off : constant Uint := Component_Size (Typ);
+ Ind : Node_Id;
begin
- -- A derived type inherits the default initial condition procedure of
- -- its parent type.
+ -- Return early if the component size is not known or variable
+
+ if Off = No_Uint or else Off < Uint_0 then
+ return No_Uint;
+ end if;
+
+ -- Deal with the degenerate case of an empty component
+
+ if Off = Uint_0 then
+ return Off;
+ end if;
+
+ -- Check that both the index value and the low bound are known
+
+ if not Compile_Time_Known_Value (Exp) then
+ return No_Uint;
+ end if;
- if No (Default_Init_Cond_Procedure (Typ)) then
- Set_Default_Init_Cond_Procedure
- (Typ, Default_Init_Cond_Procedure (Par_Typ));
+ Ind := First_Index (Typ);
+ if No (Ind) then
+ return No_Uint;
end if;
- end Inherit_Default_Init_Cond_Procedure;
+
+ if Nkind (Ind) = N_Subtype_Indication then
+ Ind := Constraint (Ind);
+
+ if Nkind (Ind) = N_Range_Constraint then
+ Ind := Range_Expression (Ind);
+ end if;
+ end if;
+
+ if Nkind (Ind) /= N_Range
+ or else not Compile_Time_Known_Value (Low_Bound (Ind))
+ then
+ return No_Uint;
+ end if;
+
+ -- Return the scaled offset
+
+ return Off * (Expr_Value (Exp) - Expr_Value (Low_Bound ((Ind))));
+ end Indexed_Component_Bit_Offset;
----------------------------
-- Inherit_Rep_Item_Chain --
------------------------------------------
procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is
- Decl : Node_Id;
+ Decl : Node_Id;
begin
Decl := First (Decls);
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;
return True;
-- An array type is effectively volatile when it is subject to pragma
- -- Atomic_Components or Volatile_Components or its compolent type is
+ -- Atomic_Components or Volatile_Components or its component type is
-- effectively volatile.
elsif Is_Array_Type (Id) then
if Is_Entity_Name (N) then
return Is_Effectively_Volatile (Entity (N));
- elsif Nkind (N) = N_Expanded_Name then
- return Is_Effectively_Volatile (Entity (N));
-
elsif Nkind (N) = N_Indexed_Component then
return Is_Effectively_Volatile_Object (Prefix (N));
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 --
elsif Nkind (Context) = N_Attribute_Reference
and then Prefix (Context) = Obj_Ref
- and then Nam_In (Attribute_Name (Context), Name_Alignment,
+ and then Nam_In (Attribute_Name (Context), Name_Address,
+ Name_Alignment,
Name_Component_Size,
Name_First_Bit,
Name_Last_Bit,
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 --
---------------------------
when N_Assignment_Statement =>
return N = Name (P);
- -- Function call arguments are never lvalues
+ -- Function call arguments are never lvalues
when N_Function_Call =>
return False;
return N = Name (P);
-- Test prefix of component or attribute. Note that the prefix of an
- -- explicit or implicit dereference cannot be an l-value.
+ -- explicit or implicit dereference cannot be an l-value. In the case
+ -- of a 'Read attribute, the reference can be an actual in the
+ -- argument list of the attribute.
when N_Attribute_Reference =>
- return N = Prefix (P)
- and then Name_Implies_Lvalue_Prefix (Attribute_Name (P));
+ return (N = Prefix (P)
+ and then Name_Implies_Lvalue_Prefix (Attribute_Name (P)))
+ or else
+ Attribute_Name (P) = Name_Read;
-- For an expanded name, the name is an lvalue if the expanded name
-- is an lvalue, but the prefix is never an lvalue, since it is just
function New_Copy_Tree
(Source : Node_Id;
- Map : Elist_Id := No_Elist;
+ Map : Elist_Id := No_Elist;
New_Sloc : Source_Ptr := No_Location;
- New_Scope : Entity_Id := Empty) return Node_Id
+ New_Scope : Entity_Id := Empty) return Node_Id
is
Actual_Map : Elist_Id := Map;
-- This is the actual map for the copy. It is initialized with the
if Comes_From_Source (Exp)
or else Modification_Comes_From_Source
then
- -- Give warning if pragma unmodified given and we are
+ -- Give warning if pragma unmodified is given and we are
-- sure this is a modification.
if Has_Pragma_Unmodified (Ent) and then Sure then
- Error_Msg_NE ("??pragma Unmodified given for &!", N, Ent);
+
+ -- Note that the entity may be present only as a result
+ -- of pragma Unused.
+
+ if Has_Pragma_Unused (Ent) then
+ Error_Msg_NE ("??pragma Unused given for &!", N, Ent);
+ else
+ Error_Msg_NE
+ ("??pragma Unmodified given for &!", N, Ent);
+ end if;
end if;
Set_Never_Set_In_Source (Ent, False);
end loop;
end Note_Possible_Modification;
+ --------------------------------------
+ -- Null_To_Null_Address_Convert_OK --
+ --------------------------------------
+
+ function Null_To_Null_Address_Convert_OK
+ (N : Node_Id;
+ Typ : Entity_Id := Empty) return Boolean
+ is
+ begin
+ if not Relaxed_RM_Semantics then
+ return False;
+ end if;
+
+ if Nkind (N) = N_Null then
+ return Present (Typ) and then Is_Descendant_Of_Address (Typ);
+
+ elsif Nkind_In (N, N_Op_Eq, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt, N_Op_Ne)
+ then
+ declare
+ L : constant Node_Id := Left_Opnd (N);
+ R : constant Node_Id := Right_Opnd (N);
+
+ begin
+ -- We check the Etype of the complementary operand since the
+ -- N_Null node is not decorated at this stage.
+
+ return
+ ((Nkind (L) = N_Null
+ and then Is_Descendant_Of_Address (Etype (R)))
+ or else
+ (Nkind (R) = N_Null
+ and then Is_Descendant_Of_Address (Etype (L))));
+ end;
+ end if;
+
+ return False;
+ end Null_To_Null_Address_Convert_OK;
+
-------------------------
-- Object_Access_Level --
-------------------------
---------------------------
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 --
+ ------------------------------------
+
+ procedure Propagate_Invariant_Attributes
+ (Typ : Entity_Id;
+ From_Typ : Entity_Id)
+ is
+ Full_IP : Entity_Id;
+ Part_IP : 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;
+
+ Full_IP := Invariant_Procedure (From_Typ);
+ Part_IP := Partial_Invariant_Procedure (From_Typ);
+
+ -- The setting of the attributes is intentionally conservative. This
+ -- prevents accidental clobbering of enabled attributes.
+
+ if Has_Inheritable_Invariants (From_Typ)
+ and then not Has_Inheritable_Invariants (Typ)
+ then
+ Set_Has_Inheritable_Invariants (Typ, True);
+ end if;
+
+ if Has_Inherited_Invariants (From_Typ)
+ and then not Has_Inherited_Invariants (Typ)
+ then
+ Set_Has_Inherited_Invariants (Typ, True);
+ end if;
+
+ if Has_Own_Invariants (From_Typ)
+ and then not Has_Own_Invariants (Typ)
+ then
+ Set_Has_Own_Invariants (Typ, True);
+ end if;
+
+ if Present (Full_IP) and then No (Invariant_Procedure (Typ)) then
+ Set_Invariant_Procedure (Typ, Full_IP);
+ end if;
+
+ if Present (Part_IP) and then No (Partial_Invariant_Procedure (Typ))
+ then
+ Set_Partial_Invariant_Procedure (Typ, Part_IP);
+ end if;
+ end if;
+ end Propagate_Invariant_Attributes;
+
---------------------------------------
-- 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