------------------------------------------------------------------------------
with Atree; use Atree;
+with Casing; use Casing;
with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
with Sem_Aux; use Sem_Aux;
with Sem_Ch8; use Sem_Ch8;
with Sem_Eval; use Sem_Eval;
+with Sem_Prag; use Sem_Prag;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
-- local to the init proc for the array type, and is called for each one
-- of the components. The constructed image has the form of an indexed
-- component, whose prefix is the outer variable of the array type.
- -- The n-dimensional array type has known indices Index, Index2...
+ -- The n-dimensional array type has known indexes Index, Index2...
-- Id_Ref is an indexed component form created by the enclosing init proc.
- -- Its successive indices are Val1, Val2, ... which are the loop variables
+ -- Its successive indexes are Val1, Val2, ... which are the loop variables
-- in the loops that call the individual task init proc on each component.
-- The generated function has the following structure:
-- String to hold result
Val : Node_Id;
- -- Value of successive indices
+ -- Value of successive indexes
Sum : Node_Id;
-- Expression to compute total size of string
Remove_Side_Effects (Exp, Name_Req, Variable_Ref => True);
end Force_Evaluation;
+ ---------------------------------
+ -- Fully_Qualified_Name_String --
+ ---------------------------------
+
+ function Fully_Qualified_Name_String (E : Entity_Id) return String_Id is
+ procedure Internal_Full_Qualified_Name (E : Entity_Id);
+ -- Compute recursively the qualified name without NUL at the end, adding
+ -- it to the currently started string being generated
+
+ ----------------------------------
+ -- Internal_Full_Qualified_Name --
+ ----------------------------------
+
+ procedure Internal_Full_Qualified_Name (E : Entity_Id) is
+ Ent : Entity_Id;
+
+ begin
+ -- Deal properly with child units
+
+ if Nkind (E) = N_Defining_Program_Unit_Name then
+ Ent := Defining_Identifier (E);
+ else
+ Ent := E;
+ end if;
+
+ -- Compute qualification recursively (only "Standard" has no scope)
+
+ if Present (Scope (Scope (Ent))) then
+ Internal_Full_Qualified_Name (Scope (Ent));
+ Store_String_Char (Get_Char_Code ('.'));
+ end if;
+
+ -- Every entity should have a name except some expanded blocks
+ -- don't bother about those.
+
+ if Chars (Ent) = No_Name then
+ return;
+ end if;
+
+ -- Generates the entity name in upper case
+
+ Get_Decoded_Name_String (Chars (Ent));
+ Set_All_Upper_Case;
+ Store_String_Chars (Name_Buffer (1 .. Name_Len));
+ return;
+ end Internal_Full_Qualified_Name;
+
+ -- Start of processing for Full_Qualified_Name
+
+ begin
+ Start_String;
+ Internal_Full_Qualified_Name (E);
+ Store_String_Char (Get_Char_Code (ASCII.NUL));
+ return End_String;
+ end Fully_Qualified_Name_String;
+
------------------------
-- Generate_Poll_Call --
------------------------
N_Package_Declaration |
N_Package_Instantiation |
N_Package_Renaming_Declaration |
+ N_Parameterized_Expression |
N_Private_Extension_Declaration |
N_Private_Type_Declaration |
N_Procedure_Instantiation |
N_Access_To_Object_Definition |
N_Aggregate |
N_Allocator |
+ N_Aspect_Specification |
N_Case_Expression |
N_Case_Statement_Alternative |
N_Character_Literal |
N_Index_Or_Discriminant_Constraint |
N_Indexed_Component |
N_Integer_Literal |
+ N_Iterator_Specification |
N_Itype_Reference |
N_Label |
N_Loop_Parameter_Specification |
N_Push_Program_Error_Label |
N_Push_Storage_Error_Label |
N_Qualified_Expression |
+ N_Quantified_Expression |
N_Range |
N_Range_Constraint |
N_Real_Literal |
return Equiv_Type;
end Make_CW_Equivalent_Type;
+ -------------------------
+ -- Make_Invariant_Call --
+ -------------------------
+
+ function Make_Invariant_Call (Expr : Node_Id) return Node_Id is
+ Loc : constant Source_Ptr := Sloc (Expr);
+ Typ : constant Entity_Id := Etype (Expr);
+
+ begin
+ pragma Assert
+ (Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)));
+
+ if Check_Enabled (Name_Invariant)
+ or else
+ Check_Enabled (Name_Assertion)
+ then
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (Invariant_Procedure (Typ), Loc),
+ Parameter_Associations => New_List (Relocate_Node (Expr)));
+
+ else
+ return
+ Make_Null_Statement (Loc);
+ end if;
+ end Make_Invariant_Call;
+
------------------------
-- Make_Literal_Range --
------------------------
Make_Integer_Literal (Loc, 0));
end Make_Non_Empty_Check;
+ -------------------------
+ -- Make_Predicate_Call --
+ -------------------------
+
+ function Make_Predicate_Call
+ (Typ : Entity_Id;
+ Expr : Node_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Expr);
+
+ begin
+ pragma Assert (Present (Predicate_Function (Typ)));
+
+ return
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (Predicate_Function (Typ), Loc),
+ Parameter_Associations => New_List (Relocate_Node (Expr)));
+ end Make_Predicate_Call;
+
+ --------------------------
+ -- Make_Predicate_Check --
+ --------------------------
+
+ function Make_Predicate_Check
+ (Typ : Entity_Id;
+ Expr : Node_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Expr);
+
+ begin
+ return
+ Make_Pragma (Loc,
+ Pragma_Identifier => Make_Identifier (Loc, Name_Check),
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Make_Identifier (Loc, Name_Predicate)),
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Make_Predicate_Call (Typ, Expr))));
+ end Make_Predicate_Check;
+
----------------------------
-- Make_Subtype_From_Expr --
----------------------------
if Is_Tagged_Type (Priv_Subtyp) then
Set_Class_Wide_Type
(Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
- Set_Primitive_Operations (Priv_Subtyp,
- Primitive_Operations (Unc_Typ));
+ Set_Direct_Primitive_Operations (Priv_Subtyp,
+ Direct_Primitive_Operations (Unc_Typ));
end if;
Set_Full_View (Priv_Subtyp, Full_Subtyp);
or else Ekind (Entity (Prefix (N))) = E_In_Parameter;
end if;
+ -- If the prefix is an explicit dereference then this construct is a
+ -- variable reference, which means it is to be considered to have
+ -- side effects if Variable_Ref is True.
+
+ -- We do NOT exclude dereferences of access-to-constant types because
+ -- we handle them as constant view of variables.
+
+ -- Exception is an access to an entity that is a constant or an
+ -- in-parameter.
+
+ elsif Nkind (Prefix (N)) = N_Explicit_Dereference
+ and then Variable_Ref
+ then
+ declare
+ DDT : constant Entity_Id :=
+ Designated_Type (Etype (Prefix (Prefix (N))));
+ begin
+ return Ekind_In (DDT, E_Constant, E_In_Parameter);
+ end;
+
-- The following test is the simplest way of solving a complex
-- problem uncovered by BB08-010: Side effect on loop bound that
-- is a subcomponent of a global variable:
function Side_Effect_Free (N : Node_Id) return Boolean is
begin
- -- Note on checks that could raise Constraint_Error. Strictly, if
- -- we take advantage of 11.6, these checks do not count as side
- -- effects. However, we would just as soon consider that they are
- -- side effects, since the backend CSE does not work very well on
- -- expressions which can raise Constraint_Error. On the other
- -- hand, if we do not consider them to be side effect free, then
- -- we get some awkward expansions in -gnato mode, resulting in
- -- code insertions at a point where we do not have a clear model
- -- for performing the insertions.
+ -- Note on checks that could raise Constraint_Error. Strictly, if we
+ -- take advantage of 11.6, these checks do not count as side effects.
+ -- However, we would prefer to consider that they are side effects,
+ -- since the backend CSE does not work very well on expressions which
+ -- can raise Constraint_Error. On the other hand if we don't consider
+ -- them to be side effect free, then we get some awkward expansions
+ -- in -gnato mode, resulting in code insertions at a point where we
+ -- do not have a clear model for performing the insertions.
-- Special handling for entity names
-- some cases, and an assignment can modify the component
-- designated by N, so we need to create a temporary for it.
+ -- The guard testing for Entity being present is needed at least
+ -- in the case of rewritten predicate expressions, and may be
+ -- appropriate elsewhere. Obviously we can't go testing the entity
+ -- field if it does not exist, so it's reasonable to say that this
+ -- is not the renaming case if it does not exist.
+
elsif Is_Entity_Name (Original_Node (N))
+ and then Present (Entity (Original_Node (N)))
and then Is_Renaming_Of_Object (Entity (Original_Node (N)))
and then Ekind (Entity (Original_Node (N))) /= E_Constant
then
return False;
+
+ -- Remove_Side_Effects generates an object renaming declaration to
+ -- capture the expression of a class-wide expression. In VM targets
+ -- the frontend performs no expansion for dispatching calls to
+ -- class-wide types since they are handled by the VM. Hence, we must
+ -- locate here if this node corresponds to a previous invocation of
+ -- Remove_Side_Effects to avoid a never ending loop in the frontend.
+
+ elsif VM_Target /= No_VM
+ and then not Comes_From_Source (N)
+ and then Nkind (Parent (N)) = N_Object_Renaming_Declaration
+ and then Is_Class_Wide_Type (Etype (N))
+ then
+ return True;
end if;
-- For other than entity names and compile time known values,
-- to accommodate functions returning limited objects by reference.
if Nkind (Exp) = N_Function_Call
- and then Is_Inherently_Limited_Type (Etype (Exp))
+ and then Is_Immutably_Limited_Type (Etype (Exp))
and then Nkind (Parent (Exp)) /= N_Object_Declaration
- and then Ada_Version >= Ada_05
+ and then Ada_Version >= Ada_2005
then
declare
Obj : constant Entity_Id := Make_Temporary (Loc, 'F', Exp);
declare
CS : constant Boolean := Comes_From_Source (N);
begin
- Rewrite (N, Make_Identifier (Sloc (N), Chars => Chars (E)));
+ Rewrite (N, Make_Identifier (Sloc (N), Chars (E)));
Set_Entity (N, E);
Set_Comes_From_Source (N, CS);
Set_Analyzed (N, True);
OSDN Git Service
