-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
with Casing; use Casing;
with Checks; use Checks;
function Requires_Cleanup_Actions
(L : List_Id;
- For_Package : Boolean;
+ Lib_Level : Boolean;
Nested_Constructs : Boolean) return Boolean;
-- Given a list L, determine whether it contains one of the following:
--
-- 1) controlled objects
-- 2) library-level tagged types
--
- -- Flag For_Package should be set when the list comes from a package spec
- -- or body. Flag Nested_Constructs should be set when any nested packages
- -- declared in L must be processed.
+ -- Lib_Level is True when the list comes from a construct at the library
+ -- level, and False otherwise. Nested_Constructs is True when any nested
+ -- packages declared in L must be processed, and False otherwise.
-------------------------------------
-- Activate_Atomic_Synchronization --
end case;
if Present (Msg_Node) then
- Error_Msg_N ("?info: atomic synchronization set for &", Msg_Node);
+ Error_Msg_N
+ ("?N?info: atomic synchronization set for &", Msg_Node);
else
- Error_Msg_N ("?info: atomic synchronization set", N);
+ Error_Msg_N
+ ("?N?info: atomic synchronization set", N);
end if;
end if;
end Activate_Atomic_Synchronization;
Fnode := Freeze_Node (T);
if No (Actions (Fnode)) then
- Set_Actions (Fnode, New_List);
+ Set_Actions (Fnode, New_List (N));
+ else
+ Append (N, Actions (Fnode));
end if;
- Append (N, Actions (Fnode));
end Append_Freeze_Action;
---------------------------
---------------------------
procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id) is
- Fnode : constant Node_Id := Freeze_Node (T);
+ Fnode : Node_Id;
begin
if No (L) then
return;
+ end if;
+
+ Ensure_Freeze_Node (T);
+ Fnode := Freeze_Node (T);
+ if No (Actions (Fnode)) then
+ Set_Actions (Fnode, L);
else
- if No (Actions (Fnode)) then
- Set_Actions (Fnode, L);
- else
- Append_List (L, Actions (Fnode));
- end if;
+ Append_List (L, Actions (Fnode));
end if;
end Append_Freeze_Actions;
-- Handle private types
- if Is_Private_Type (Utyp)
- and then Present (Full_View (Utyp))
- then
+ if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then
Utyp := Full_View (Utyp);
end if;
Utyp := Base_Type (Utyp);
end if;
+ -- When dealing with an internally built full view for a type with
+ -- unknown discriminants, use the original record type.
+
+ if Is_Underlying_Record_View (Utyp) then
+ Utyp := Etype (Utyp);
+ end if;
+
return TSS (Utyp, TSS_Finalize_Address);
end Find_Finalize_Address;
Subpool := Subpool_Handle_Name (Expr);
end if;
+ -- If a subpool is present it can be an arbitrary name, so make
+ -- the actual by copying the tree.
+
if Present (Subpool) then
- Append_To (Actuals, New_Reference_To (Entity (Subpool), Loc));
+ Append_To (Actuals, New_Copy_Tree (Subpool, New_Sloc => Loc));
else
Append_To (Actuals, Make_Null (Loc));
end if;
-- Primitive Finalize_Address is never generated in CodePeer mode
-- since it contains an Unchecked_Conversion.
- if Needs_Finalization (Desig_Typ)
- and then not CodePeer_Mode
- then
+ if Needs_Finalization (Desig_Typ) and then not CodePeer_Mode then
Fin_Addr_Id := Find_Finalize_Address (Desig_Typ);
pragma Assert (Present (Fin_Addr_Id));
Append_To (Actuals, New_Reference_To (Addr_Id, Loc));
Append_To (Actuals, New_Reference_To (Size_Id, Loc));
- Append_To (Actuals, New_Reference_To (Alig_Id, Loc));
+
+ if Is_Allocate or else not Is_Class_Wide_Type (Desig_Typ) then
+ Append_To (Actuals, New_Reference_To (Alig_Id, Loc));
+
+ -- For deallocation of class wide types we obtain the value of
+ -- alignment from the Type Specific Record of the deallocated object.
+ -- This is needed because the frontend expansion of class-wide types
+ -- into equivalent types confuses the backend.
+
+ else
+ -- Generate:
+ -- Obj.all'Alignment
+
+ -- ... because 'Alignment applied to class-wide types is expanded
+ -- into the code that reads the value of alignment from the TSD
+ -- (see Expand_N_Attribute_Reference)
+
+ Append_To (Actuals,
+ Unchecked_Convert_To (RTE (RE_Storage_Offset),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Explicit_Dereference (Loc, Relocate_Node (Expr)),
+ Attribute_Name => Name_Alignment)));
+ end if;
-- h) Is_Controlled
else
Append_To (Actuals, New_Reference_To (Standard_True, Loc));
end if;
+
else
Append_To (Actuals, New_Reference_To (Standard_False, Loc));
end if;
-- P : Root_Storage_Pool
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Temporary (Loc, 'P'),
+ Defining_Identifier => Make_Temporary (Loc, 'P'),
Parameter_Type =>
New_Reference_To (RTE (RE_Root_Storage_Pool), Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Addr_Id,
- Out_Present => Is_Allocate,
- Parameter_Type =>
+ Out_Present => Is_Allocate,
+ Parameter_Type =>
New_Reference_To (RTE (RE_Address), Loc)),
-- S : Storage_Count
Make_Parameter_Specification (Loc,
Defining_Identifier => Size_Id,
- Parameter_Type =>
+ Parameter_Type =>
New_Reference_To (RTE (RE_Storage_Count), Loc)),
-- L : Storage_Count
Make_Parameter_Specification (Loc,
Defining_Identifier => Alig_Id,
- Parameter_Type =>
+ Parameter_Type =>
New_Reference_To (RTE (RE_Storage_Count), Loc)))),
Declarations => No_List,
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (Proc_To_Call, Loc),
+ Name => New_Reference_To (Proc_To_Call, Loc),
Parameter_Associations => Actuals)))));
-- The newly generated Allocate / Deallocate becomes the default
Temps (J) := T;
Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => T,
- Object_Definition => New_Occurrence_Of (Standard_String, Loc),
- Expression =>
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Image,
- Prefix => New_Occurrence_Of (Etype (Indx), Loc),
- Expressions => New_List (New_Copy_Tree (Val)))));
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => T,
+ Object_Definition => New_Occurrence_Of (Standard_String, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Image,
+ Prefix => New_Occurrence_Of (Etype (Indx), Loc),
+ Expressions => New_List (New_Copy_Tree (Val)))));
Next_Index (Indx);
Next (Val);
Make_Op_Add (Loc,
Left_Opnd => Sum,
Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Length,
- Prefix =>
- New_Occurrence_Of (Pref, Loc),
- Expressions => New_List (Make_Integer_Literal (Loc, 1))));
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Length,
+ Prefix => New_Occurrence_Of (Pref, Loc),
+ Expressions => New_List (Make_Integer_Literal (Loc, 1))));
for J in 1 .. Dims loop
Sum :=
- Make_Op_Add (Loc,
- Left_Opnd => Sum,
+ Make_Op_Add (Loc,
+ Left_Opnd => Sum,
Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Length,
- Prefix =>
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Length,
+ Prefix =>
New_Occurrence_Of (Temps (J), Loc),
- Expressions => New_List (Make_Integer_Literal (Loc, 1))));
+ Expressions => New_List (Make_Integer_Literal (Loc, 1))));
end loop;
Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
Set_Character_Literal_Name (Char_Code (Character'Pos ('(')));
Append_To (Stats,
- Make_Assignment_Statement (Loc,
- Name => Make_Indexed_Component (Loc,
- Prefix => New_Occurrence_Of (Res, Loc),
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Indexed_Component (Loc,
+ Prefix => New_Occurrence_Of (Res, Loc),
Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
- Expression =>
- Make_Character_Literal (Loc,
- Chars => Name_Find,
- Char_Literal_Value =>
- UI_From_Int (Character'Pos ('(')))));
+ Expression =>
+ Make_Character_Literal (Loc,
+ Chars => Name_Find,
+ Char_Literal_Value => UI_From_Int (Character'Pos ('(')))));
Append_To (Stats,
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Pos, Loc),
- Expression =>
- Make_Op_Add (Loc,
- Left_Opnd => New_Occurrence_Of (Pos, Loc),
- Right_Opnd => Make_Integer_Literal (Loc, 1))));
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Pos, Loc),
+ Expression =>
+ Make_Op_Add (Loc,
+ Left_Opnd => New_Occurrence_Of (Pos, Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, 1))));
for J in 1 .. Dims loop
Append_To (Stats,
- Make_Assignment_Statement (Loc,
- Name => Make_Slice (Loc,
- Prefix => New_Occurrence_Of (Res, Loc),
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Slice (Loc,
+ Prefix => New_Occurrence_Of (Res, Loc),
Discrete_Range =>
Make_Range (Loc,
- Low_Bound => New_Occurrence_Of (Pos, Loc),
- High_Bound => Make_Op_Subtract (Loc,
- Left_Opnd =>
- Make_Op_Add (Loc,
- Left_Opnd => New_Occurrence_Of (Pos, Loc),
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Length,
- Prefix =>
- New_Occurrence_Of (Temps (J), Loc),
- Expressions =>
- New_List (Make_Integer_Literal (Loc, 1)))),
+ Low_Bound => New_Occurrence_Of (Pos, Loc),
+ High_Bound =>
+ Make_Op_Subtract (Loc,
+ Left_Opnd =>
+ Make_Op_Add (Loc,
+ Left_Opnd => New_Occurrence_Of (Pos, Loc),
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Length,
+ Prefix =>
+ New_Occurrence_Of (Temps (J), Loc),
+ Expressions =>
+ New_List (Make_Integer_Literal (Loc, 1)))),
Right_Opnd => Make_Integer_Literal (Loc, 1)))),
Expression => New_Occurrence_Of (Temps (J), Loc)));
if J < Dims then
Append_To (Stats,
Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Pos, Loc),
+ Name => New_Occurrence_Of (Pos, Loc),
Expression =>
Make_Op_Add (Loc,
- Left_Opnd => New_Occurrence_Of (Pos, Loc),
+ Left_Opnd => New_Occurrence_Of (Pos, Loc),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Length,
- Prefix => New_Occurrence_Of (Temps (J), Loc),
- Expressions =>
- New_List (Make_Integer_Literal (Loc, 1))))));
+ Prefix => New_Occurrence_Of (Temps (J), Loc),
+ Expressions =>
+ New_List (Make_Integer_Literal (Loc, 1))))));
Set_Character_Literal_Name (Char_Code (Character'Pos (',')));
Append_To (Stats,
- Make_Assignment_Statement (Loc,
- Name => Make_Indexed_Component (Loc,
- Prefix => New_Occurrence_Of (Res, Loc),
- Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
- Expression =>
- Make_Character_Literal (Loc,
- Chars => Name_Find,
- Char_Literal_Value =>
- UI_From_Int (Character'Pos (',')))));
+ Make_Assignment_Statement (Loc,
+ Name => Make_Indexed_Component (Loc,
+ Prefix => New_Occurrence_Of (Res, Loc),
+ Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
+ Expression =>
+ Make_Character_Literal (Loc,
+ Chars => Name_Find,
+ Char_Literal_Value => UI_From_Int (Character'Pos (',')))));
Append_To (Stats,
Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Pos, Loc),
+ Name => New_Occurrence_Of (Pos, Loc),
Expression =>
Make_Op_Add (Loc,
- Left_Opnd => New_Occurrence_Of (Pos, Loc),
+ Left_Opnd => New_Occurrence_Of (Pos, Loc),
Right_Opnd => Make_Integer_Literal (Loc, 1))));
end if;
end loop;
Set_Character_Literal_Name (Char_Code (Character'Pos (')')));
Append_To (Stats,
- Make_Assignment_Statement (Loc,
- Name => Make_Indexed_Component (Loc,
- Prefix => New_Occurrence_Of (Res, Loc),
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Indexed_Component (Loc,
+ Prefix => New_Occurrence_Of (Res, Loc),
Expressions => New_List (New_Occurrence_Of (Len, Loc))),
Expression =>
Make_Character_Literal (Loc,
- Chars => Name_Find,
- Char_Literal_Value =>
- UI_From_Int (Character'Pos (')')))));
+ Chars => Name_Find,
+ Char_Literal_Value => UI_From_Int (Character'Pos (')')))));
return Build_Task_Image_Function (Loc, Decls, Stats, Res);
end Build_Task_Array_Image;
-- It is only array and record types that cause trouble
- if not Is_Record_Type (UT)
- and then not Is_Array_Type (UT)
- then
+ if not Is_Record_Type (UT) and then not Is_Array_Type (UT) then
return False;
-- If we know that we have a small (64 bits or less) record or small
-- handle these cases correctly.
elsif Esize (Comp) <= 64
- and then (Is_Record_Type (UT)
- or else Is_Bit_Packed_Array (UT))
+ and then (Is_Record_Type (UT) or else Is_Bit_Packed_Array (UT))
then
return False;
Name_Req : Boolean := False) return Node_Id
is
New_Exp : Node_Id;
-
begin
Remove_Side_Effects (Exp, Name_Req);
New_Exp := New_Copy_Tree (Exp);
-- An itype reference must only be created if this is a local itype, so
-- that gigi can elaborate it on the proper objstack.
- if Is_Itype (Typ)
- and then Scope (Typ) = Current_Scope
- then
+ if Is_Itype (Typ) and then Scope (Typ) = Current_Scope then
IR := Make_Itype_Reference (Sloc (N));
Set_Itype (IR, Typ);
Insert_Action (N, IR);
end if;
end Ensure_Defined;
+ ---------------
+ -- Entity_Of --
+ ---------------
+
+ function Entity_Of (N : Node_Id) return Entity_Id is
+ Id : Entity_Id;
+
+ begin
+ Id := Empty;
+
+ if Is_Entity_Name (N) then
+ Id := Entity (N);
+
+ -- Follow a possible chain of renamings to reach the root renamed
+ -- object.
+
+ while Present (Renamed_Object (Id)) loop
+ if Is_Entity_Name (Renamed_Object (Id)) then
+ Id := Entity (Renamed_Object (Id));
+ else
+ Id := Empty;
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ return Id;
+ end Entity_Of;
+
--------------------
-- Entry_Names_OK --
--------------------
-- standard string types and more generally arrays of characters.
if not Expander_Active
- and then (No (Etype (Exp))
- or else not Is_String_Type (Etype (Exp)))
+ and then (No (Etype (Exp)) or else not Is_String_Type (Etype (Exp)))
then
return;
end if;
end if;
end Expand_Subtype_From_Expr;
- --------------------
- -- Find_Init_Call --
- --------------------
-
- function Find_Init_Call
- (Var : Entity_Id;
- Rep_Clause : Node_Id) return Node_Id
- is
- Typ : constant Entity_Id := Etype (Var);
-
- Init_Proc : Entity_Id;
- -- Initialization procedure for Typ
-
- function Find_Init_Call_In_List (From : Node_Id) return Node_Id;
- -- Look for init call for Var starting at From and scanning the
- -- enclosing list until Rep_Clause or the end of the list is reached.
-
- ----------------------------
- -- Find_Init_Call_In_List --
- ----------------------------
-
- function Find_Init_Call_In_List (From : Node_Id) return Node_Id is
- Init_Call : Node_Id;
- begin
- Init_Call := From;
-
- while Present (Init_Call) and then Init_Call /= Rep_Clause loop
- if Nkind (Init_Call) = N_Procedure_Call_Statement
- and then Is_Entity_Name (Name (Init_Call))
- and then Entity (Name (Init_Call)) = Init_Proc
- then
- return Init_Call;
- end if;
-
- Next (Init_Call);
- end loop;
-
- return Empty;
- end Find_Init_Call_In_List;
-
- Init_Call : Node_Id;
-
- -- Start of processing for Find_Init_Call
-
- begin
- if not Has_Non_Null_Base_Init_Proc (Typ) then
- -- No init proc for the type, so obviously no call to be found
-
- return Empty;
- end if;
-
- Init_Proc := Base_Init_Proc (Typ);
-
- -- First scan the list containing the declaration of Var
-
- Init_Call := Find_Init_Call_In_List (From => Next (Parent (Var)));
-
- -- If not found, also look on Var's freeze actions list, if any, since
- -- the init call may have been moved there (case of an address clause
- -- applying to Var).
-
- if No (Init_Call) and then Present (Freeze_Node (Var)) then
- Init_Call :=
- Find_Init_Call_In_List (First (Actions (Freeze_Node (Var))));
- end if;
-
- return Init_Call;
- end Find_Init_Call;
-
------------------------
-- Find_Interface_ADT --
------------------------
-- Handle private types
- if Has_Private_Declaration (Typ)
- and then Present (Full_View (Typ))
- then
+ if Has_Private_Declaration (Typ) and then Present (Full_View (Typ)) then
Typ := Full_View (Typ);
end if;
-- Handle private types
- if Has_Private_Declaration (Typ)
- and then Present (Full_View (Typ))
- then
+ if Has_Private_Declaration (Typ) and then Present (Full_View (Typ)) then
Typ := Full_View (Typ);
end if;
exit when Chars (Op) = Name
and then
(Name /= Name_Op_Eq
- or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op)));
+ or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op)));
Next_Elmt (Prim);
begin
S := Scop;
while Present (S) loop
- if (Ekind (S) = E_Entry
- or else Ekind (S) = E_Entry_Family
- or else Ekind (S) = E_Function
- or else Ekind (S) = E_Procedure)
+ if Ekind_In (S, E_Entry, E_Entry_Family, E_Function, E_Procedure)
and then Present (Protection_Object (S))
then
return Protection_Object (S);
-- Deal with AND THEN and AND cases
- if Nkind (Cond) = N_And_Then
- or else Nkind (Cond) = N_Op_And
- then
+ if Nkind_In (Cond, N_And_Then, N_Op_And) then
+
-- Don't ever try to invert a condition that is of the form of an
-- AND or AND THEN (since we are not doing sufficiently general
-- processing to allow this).
-- reference had said var = True.
else
- if Is_Entity_Name (Cond)
- and then Ent = Entity (Cond)
- then
+ if Is_Entity_Name (Cond) and then Ent = Entity (Cond) then
Val := New_Occurrence_Of (Standard_True, Sloc (Cond));
if Sens = False then
T : constant Entity_Id := Etype (E);
begin
- if Has_Per_Object_Constraint (E)
- and then Has_Discriminants (T)
- then
+ if Has_Per_Object_Constraint (E) and then Has_Discriminants (T) then
Disc := First_Discriminant (T);
while Present (Disc) loop
if Is_Access_Type (Etype (Disc)) then
and then not Is_Frozen (Current_Scope)
then
if No (Scope_Stack.Table
- (Scope_Stack.Last).Pending_Freeze_Actions)
+ (Scope_Stack.Last).Pending_Freeze_Actions)
then
Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions :=
Ins_Actions;
-- N_Raise_xxx_Error is an annoying special case, it is a statement if
-- it has type Standard_Void_Type, and a subexpression otherwise.
- -- otherwise. Procedure attribute references are also statements.
+ -- otherwise. Procedure calls, and similarly procedure attribute
+ -- references, are also statements.
if Nkind (Assoc_Node) in N_Subexpr
- and then (Nkind (Assoc_Node) in N_Raise_xxx_Error
+ and then (Nkind (Assoc_Node) not in N_Raise_xxx_Error
or else Etype (Assoc_Node) /= Standard_Void_Type)
+ and then Nkind (Assoc_Node) /= N_Procedure_Call_Statement
and then (Nkind (Assoc_Node) /= N_Attribute_Reference
or else
not Is_Procedure_Attribute_Name
(Attribute_Name (Assoc_Node)))
then
- P := Assoc_Node; -- ??? does not agree with above!
- N := Parent (Assoc_Node);
+ N := Assoc_Node;
+ P := Parent (Assoc_Node);
-- Non-subexpression case. Note that N is initially Empty in this case
-- (N is only guaranteed Non-Empty in the subexpr case).
else
- P := Assoc_Node;
N := Empty;
+ P := Assoc_Node;
end if;
-- Capture root of the transient scope
loop
pragma Assert (Present (P));
+ -- Make sure that inserted actions stay in the transient scope
+
+ if Present (Wrapped_Node) and then N = Wrapped_Node then
+ Store_Before_Actions_In_Scope (Ins_Actions);
+ return;
+ end if;
+
case Nkind (P) is
-- Case of right operand of AND THEN or OR ELSE. Put the actions
return;
end if;
- -- Then or Else operand of conditional expression. Add actions to
- -- Then_Actions or Else_Actions field as appropriate. The actions
- -- will be moved further out when the conditional is expanded.
+ -- Then or Else dependent expression of an if expression. Add
+ -- actions to Then_Actions or Else_Actions field as appropriate.
+ -- The actions will be moved further out when the if is expanded.
- when N_Conditional_Expression =>
+ when N_If_Expression =>
declare
ThenX : constant Node_Id := Next (First (Expressions (P)));
ElseX : constant Node_Id := Next (ThenX);
null;
-- Actions belong to the then expression, temporarily place
- -- them as Then_Actions of the conditional expr. They will
- -- be moved to the proper place later when the conditional
- -- expression is expanded.
+ -- them as Then_Actions of the if expression. They will be
+ -- moved to the proper place later when the if expression
+ -- is expanded.
elsif N = ThenX then
if Present (Then_Actions (P)) then
return;
- -- Actions belong to the else expression, temporarily
- -- place them as Else_Actions of the conditional expr.
- -- They will be moved to the proper place later when
- -- the conditional expression is expanded.
+ -- Actions belong to the else expression, temporarily place
+ -- them as Else_Actions of the if expression. They will be
+ -- moved to the proper place later when the if expression
+ -- is expanded.
elsif N = ElseX then
if Present (Else_Actions (P)) then
return;
- -- Case of appearing within an Expressions_With_Actions node. We
- -- prepend the actions to the list of actions already there, if
- -- the node has not been analyzed yet. Otherwise find insertion
- -- location further up the tree.
+ -- Case of appearing within an Expressions_With_Actions node. When
+ -- the new actions come from the expression of the expression with
+ -- actions, they must be added to the existing actions. The other
+ -- alternative is when the new actions are related to one of the
+ -- existing actions of the expression with actions. In that case
+ -- they must be inserted further up the tree.
when N_Expression_With_Actions =>
- if not Analyzed (P) then
- Prepend_List (Ins_Actions, Actions (P));
+ if N = Expression (P) then
+ Insert_List_After_And_Analyze
+ (Last (Actions (P)), Ins_Actions);
return;
end if;
-- actions should be inserted outside the complete record
-- declaration.
- elsif Nkind (Parent (P)) = N_Variant
- or else Nkind (Parent (P)) = N_Record_Definition
- then
+ elsif Nkind_In (Parent (P), N_Variant, N_Record_Definition) then
null;
-- Do not insert freeze nodes within the loop generated for
N_Push_Storage_Error_Label |
N_Qualified_Expression |
N_Quantified_Expression |
+ N_Raise_Expression |
N_Range |
N_Range_Constraint |
N_Real_Literal |
end case;
- -- Make sure that inserted actions stay in the transient scope
-
- if P = Wrapped_Node then
- Store_Before_Actions_In_Scope (Ins_Actions);
- return;
- end if;
-
-- If we fall through above tests, keep climbing tree
N := P;
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Array := Scope_Suppress;
+ Sva : constant Suppress_Array := Scope_Suppress.Suppress;
begin
- Scope_Suppress := (others => True);
+ Scope_Suppress.Suppress := (others => True);
Insert_Actions (Assoc_Node, Ins_Actions);
- Scope_Suppress := Svg;
+ Scope_Suppress.Suppress := Sva;
end;
else
declare
- Svg : constant Boolean := Scope_Suppress (Suppress);
+ Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
begin
- Scope_Suppress (Suppress) := True;
+ Scope_Suppress.Suppress (Suppress) := True;
Insert_Actions (Assoc_Node, Ins_Actions);
- Scope_Suppress (Suppress) := Svg;
+ Scope_Suppress.Suppress (Suppress) := Svg;
end;
end if;
end Insert_Actions;
Ins_Actions : List_Id)
is
begin
- if Scope_Is_Transient
- and then Assoc_Node = Node_To_Be_Wrapped
- then
+ if Scope_Is_Transient and then Assoc_Node = Node_To_Be_Wrapped then
Store_After_Actions_In_Scope (Ins_Actions);
else
Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions);
begin
S := Current_Scope;
- while Present (S)
- and then S /= Standard_Standard
- loop
+ while Present (S) and then S /= Standard_Standard loop
if Is_Init_Proc (S) then
return True;
else
return True;
end Is_All_Null_Statements;
+ --------------------------------------------------
+ -- Is_Displacement_Of_Object_Or_Function_Result --
+ --------------------------------------------------
+
+ function Is_Displacement_Of_Object_Or_Function_Result
+ (Obj_Id : Entity_Id) return Boolean
+ is
+ function Is_Controlled_Function_Call (N : Node_Id) return Boolean;
+ -- Determine if particular node denotes a controlled function call
+
+ function Is_Displace_Call (N : Node_Id) return Boolean;
+ -- Determine whether a particular node is a call to Ada.Tags.Displace.
+ -- The call might be nested within other actions such as conversions.
+
+ function Is_Source_Object (N : Node_Id) return Boolean;
+ -- Determine whether a particular node denotes a source object
+
+ ---------------------------------
+ -- Is_Controlled_Function_Call --
+ ---------------------------------
+
+ function Is_Controlled_Function_Call (N : Node_Id) return Boolean is
+ Expr : Node_Id := Original_Node (N);
+
+ begin
+ if Nkind (Expr) = N_Function_Call then
+ Expr := Name (Expr);
+ end if;
+
+ -- The function call may appear in object.operation format
+
+ if Nkind (Expr) = N_Selected_Component then
+ Expr := Selector_Name (Expr);
+ end if;
+
+ return
+ Nkind_In (Expr, N_Expanded_Name, N_Identifier)
+ and then Ekind (Entity (Expr)) = E_Function
+ and then Needs_Finalization (Etype (Entity (Expr)));
+ end Is_Controlled_Function_Call;
+
+ ----------------------
+ -- Is_Displace_Call --
+ ----------------------
+
+ function Is_Displace_Call (N : Node_Id) return Boolean is
+ Call : Node_Id := N;
+
+ begin
+ -- Strip various actions which may precede a call to Displace
+
+ loop
+ if Nkind (Call) = N_Explicit_Dereference then
+ Call := Prefix (Call);
+
+ elsif Nkind_In (Call, N_Type_Conversion,
+ N_Unchecked_Type_Conversion)
+ then
+ Call := Expression (Call);
+
+ else
+ exit;
+ end if;
+ end loop;
+
+ return
+ Present (Call)
+ and then Nkind (Call) = N_Function_Call
+ and then Is_RTE (Entity (Name (Call)), RE_Displace);
+ end Is_Displace_Call;
+
+ ----------------------
+ -- Is_Source_Object --
+ ----------------------
+
+ function Is_Source_Object (N : Node_Id) return Boolean is
+ begin
+ return
+ Present (N)
+ and then Nkind (N) in N_Has_Entity
+ and then Is_Object (Entity (N))
+ and then Comes_From_Source (N);
+ end Is_Source_Object;
+
+ -- Local variables
+
+ Decl : constant Node_Id := Parent (Obj_Id);
+ Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
+ Orig_Decl : constant Node_Id := Original_Node (Decl);
+
+ -- Start of processing for Is_Displacement_Of_Object_Or_Function_Result
+
+ begin
+ -- Case 1:
+
+ -- Obj : CW_Type := Function_Call (...);
+
+ -- rewritten into:
+
+ -- Tmp : ... := Function_Call (...)'reference;
+ -- Obj : CW_Type renames (... Ada.Tags.Displace (Tmp));
+
+ -- where the return type of the function and the class-wide type require
+ -- dispatch table pointer displacement.
+
+ -- Case 2:
+
+ -- Obj : CW_Type := Src_Obj;
+
+ -- rewritten into:
+
+ -- Obj : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
+
+ -- where the type of the source object and the class-wide type require
+ -- dispatch table pointer displacement.
+
+ return
+ Nkind (Decl) = N_Object_Renaming_Declaration
+ and then Nkind (Orig_Decl) = N_Object_Declaration
+ and then Comes_From_Source (Orig_Decl)
+ and then Is_Class_Wide_Type (Obj_Typ)
+ and then Is_Displace_Call (Renamed_Object (Obj_Id))
+ and then
+ (Is_Controlled_Function_Call (Expression (Orig_Decl))
+ or else Is_Source_Object (Expression (Orig_Decl)));
+ end Is_Displacement_Of_Object_Or_Function_Result;
+
------------------------------
-- Is_Finalizable_Transient --
------------------------------
function Is_Allocated (Trans_Id : Entity_Id) return Boolean;
-- Determine whether transient object Trans_Id is allocated on the heap
+ function Is_Iterated_Container
+ (Trans_Id : Entity_Id;
+ First_Stmt : Node_Id) return Boolean;
+ -- Determine whether transient object Trans_Id denotes a container which
+ -- is in the process of being iterated in the statement list starting
+ -- from First_Stmt.
+
---------------------------
-- Initialized_By_Access --
---------------------------
Next (Param);
end loop;
- return Access_OK and then Alloc_OK;
+ return Access_OK and Alloc_OK;
end;
end if;
elsif Nkind (Stmt) = N_Object_Renaming_Declaration then
Ren_Obj := Find_Renamed_Object (Stmt);
- if Present (Ren_Obj)
- and then Ren_Obj = Trans_Id
- then
+ if Present (Ren_Obj) and then Ren_Obj = Trans_Id then
return True;
end if;
end if;
and then Nkind (Expr) = N_Allocator;
end Is_Allocated;
- -- Start of processing for Is_Finalizable_Transient
+ ---------------------------
+ -- Is_Iterated_Container --
+ ---------------------------
- begin
- -- Handle access types
+ function Is_Iterated_Container
+ (Trans_Id : Entity_Id;
+ First_Stmt : Node_Id) return Boolean
+ is
+ Aspect : Node_Id;
+ Call : Node_Id;
+ Iter : Entity_Id;
+ Param : Node_Id;
+ Stmt : Node_Id;
+ Typ : Entity_Id;
- if Is_Access_Type (Desig) then
- Desig := Available_View (Designated_Type (Desig));
- end if;
+ begin
+ -- It is not possible to iterate over containers in non-Ada 2012 code
- return
- Ekind_In (Obj_Id, E_Constant, E_Variable)
- and then Needs_Finalization (Desig)
- and then Requires_Transient_Scope (Desig)
- and then Nkind (Rel_Node) /= N_Simple_Return_Statement
+ if Ada_Version < Ada_2012 then
+ return False;
+ end if;
- -- Do not consider renamed or 'reference-d transient objects because
- -- the act of renaming extends the object's lifetime.
+ Typ := Etype (Trans_Id);
- and then not Is_Aliased (Obj_Id, Decl)
+ -- Handle access type created for secondary stack use
- -- Do not consider transient objects allocated on the heap since
- -- they are attached to a finalization master.
+ if Is_Access_Type (Typ) then
+ Typ := Designated_Type (Typ);
+ end if;
- and then not Is_Allocated (Obj_Id)
+ -- Look for aspect Default_Iterator
- -- If the transient object is a pointer, check that it is not
+ if Has_Aspects (Parent (Typ)) then
+ Aspect := Find_Aspect (Typ, Aspect_Default_Iterator);
+
+ if Present (Aspect) then
+ Iter := Entity (Aspect);
+
+ -- Examine the statements following the container object and
+ -- look for a call to the default iterate routine where the
+ -- first parameter is the transient. Such a call appears as:
+
+ -- It : Access_To_CW_Iterator :=
+ -- Iterate (Tran_Id.all, ...)'reference;
+
+ Stmt := First_Stmt;
+ while Present (Stmt) loop
+
+ -- Detect an object declaration which is initialized by a
+ -- secondary stack function call.
+
+ if Nkind (Stmt) = N_Object_Declaration
+ and then Present (Expression (Stmt))
+ and then Nkind (Expression (Stmt)) = N_Reference
+ and then Nkind (Prefix (Expression (Stmt))) =
+ N_Function_Call
+ then
+ Call := Prefix (Expression (Stmt));
+
+ -- The call must invoke the default iterate routine of
+ -- the container and the transient object must appear as
+ -- the first actual parameter. Skip any calls whose names
+ -- are not entities.
+
+ if Is_Entity_Name (Name (Call))
+ and then Entity (Name (Call)) = Iter
+ and then Present (Parameter_Associations (Call))
+ then
+ Param := First (Parameter_Associations (Call));
+
+ if Nkind (Param) = N_Explicit_Dereference
+ and then Entity (Prefix (Param)) = Trans_Id
+ then
+ return True;
+ end if;
+ end if;
+ end if;
+
+ Next (Stmt);
+ end loop;
+ end if;
+ end if;
+
+ return False;
+ end Is_Iterated_Container;
+
+ -- Start of processing for Is_Finalizable_Transient
+
+ begin
+ -- Handle access types
+
+ if Is_Access_Type (Desig) then
+ Desig := Available_View (Designated_Type (Desig));
+ end if;
+
+ return
+ Ekind_In (Obj_Id, E_Constant, E_Variable)
+ and then Needs_Finalization (Desig)
+ and then Requires_Transient_Scope (Desig)
+ and then Nkind (Rel_Node) /= N_Simple_Return_Statement
+
+ -- Do not consider renamed or 'reference-d transient objects because
+ -- the act of renaming extends the object's lifetime.
+
+ and then not Is_Aliased (Obj_Id, Decl)
+
+ -- Do not consider transient objects allocated on the heap since
+ -- they are attached to a finalization master.
+
+ and then not Is_Allocated (Obj_Id)
+
+ -- If the transient object is a pointer, check that it is not
-- initialized by a function which returns a pointer or acts as a
-- renaming of another pointer.
-- Do not consider conversions of tags to class-wide types
- and then not Is_Tag_To_CW_Conversion (Obj_Id);
+ and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
+
+ -- Do not consider containers in the context of iterator loops. Such
+ -- transient objects must exist for as long as the loop is around,
+ -- otherwise any operation carried out by the iterator will fail.
+
+ and then not Is_Iterated_Container (Obj_Id, Decl);
end Is_Finalizable_Transient;
---------------------------------
function Is_Library_Level_Tagged_Type (Typ : Entity_Id) return Boolean is
begin
- return Is_Tagged_Type (Typ)
- and then Is_Library_Level_Entity (Typ);
+ return Is_Tagged_Type (Typ) and then Is_Library_Level_Entity (Typ);
end Is_Library_Level_Tagged_Type;
- ----------------------------------
- -- Is_Null_Access_BIP_Func_Call --
- ----------------------------------
-
- function Is_Null_Access_BIP_Func_Call (Expr : Node_Id) return Boolean is
- Call : Node_Id := Expr;
-
- begin
- -- Build-in-place calls usually appear in 'reference format
-
- if Nkind (Call) = N_Reference then
- Call := Prefix (Call);
- end if;
-
- if Nkind_In (Call, N_Qualified_Expression,
- N_Unchecked_Type_Conversion)
- then
- Call := Expression (Call);
- end if;
-
- if Is_Build_In_Place_Function_Call (Call) then
- declare
- Access_Nam : Name_Id := No_Name;
- Actual : Node_Id;
- Param : Node_Id;
- Formal : Node_Id;
-
- begin
- -- Examine all parameter associations of the function call
-
- Param := First (Parameter_Associations (Call));
- while Present (Param) loop
- if Nkind (Param) = N_Parameter_Association
- and then Nkind (Selector_Name (Param)) = N_Identifier
- then
- Formal := Selector_Name (Param);
- Actual := Explicit_Actual_Parameter (Param);
-
- -- Construct the name of formal BIPaccess. It is much easier
- -- to extract the name of the function using an arbitrary
- -- formal's scope rather than the Name field of Call.
-
- if Access_Nam = No_Name
- and then Present (Entity (Formal))
- then
- Access_Nam :=
- New_External_Name
- (Chars (Scope (Entity (Formal))),
- BIP_Formal_Suffix (BIP_Object_Access));
- end if;
-
- -- A match for BIPaccess => null has been found
-
- if Chars (Formal) = Access_Nam
- and then Nkind (Actual) = N_Null
- then
- return True;
- end if;
- end if;
-
- Next (Param);
- end loop;
- end;
- end if;
-
- return False;
- end Is_Null_Access_BIP_Func_Call;
-
--------------------------
-- Is_Non_BIP_Func_Call --
--------------------------
if Known_Alignment (Ptyp)
and then (Unknown_Alignment (Styp)
- or else Alignment (Styp) > Alignment (Ptyp))
+ or else Alignment (Styp) > Alignment (Ptyp))
then
return True;
end if;
return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N)));
end if;
- if Nkind (N) = N_Indexed_Component
- or else
- Nkind (N) = N_Selected_Component
- then
+ if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
if Is_Bit_Packed_Array (Etype (Prefix (N))) then
Result := True;
else
then
return True;
- elsif Nkind (N) = N_Indexed_Component
- or else
- Nkind (N) = N_Selected_Component
- then
+ elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
return Is_Ref_To_Bit_Packed_Slice (Prefix (N));
else
end if;
end Is_Renamed_Object;
- -----------------------------
- -- Is_Tag_To_CW_Conversion --
- -----------------------------
+ --------------------------------------
+ -- Is_Secondary_Stack_BIP_Func_Call --
+ --------------------------------------
+
+ function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is
+ Call : Node_Id := Expr;
+
+ begin
+ -- Build-in-place calls usually appear in 'reference format. Note that
+ -- the accessibility check machinery may add an extra 'reference due to
+ -- side effect removal.
+
+ while Nkind (Call) = N_Reference loop
+ Call := Prefix (Call);
+ end loop;
+
+ if Nkind_In (Call, N_Qualified_Expression,
+ N_Unchecked_Type_Conversion)
+ then
+ Call := Expression (Call);
+ end if;
+
+ if Is_Build_In_Place_Function_Call (Call) then
+ declare
+ Access_Nam : Name_Id := No_Name;
+ Actual : Node_Id;
+ Param : Node_Id;
+ Formal : Node_Id;
+
+ begin
+ -- Examine all parameter associations of the function call
+
+ Param := First (Parameter_Associations (Call));
+ while Present (Param) loop
+ if Nkind (Param) = N_Parameter_Association
+ and then Nkind (Selector_Name (Param)) = N_Identifier
+ then
+ Formal := Selector_Name (Param);
+ Actual := Explicit_Actual_Parameter (Param);
+
+ -- Construct the name of formal BIPalloc. It is much easier
+ -- to extract the name of the function using an arbitrary
+ -- formal's scope rather than the Name field of Call.
+
+ if Access_Nam = No_Name
+ and then Present (Entity (Formal))
+ then
+ Access_Nam :=
+ New_External_Name
+ (Chars (Scope (Entity (Formal))),
+ BIP_Formal_Suffix (BIP_Alloc_Form));
+ end if;
+
+ -- A match for BIPalloc => 2 has been found
+
+ if Chars (Formal) = Access_Nam
+ and then Nkind (Actual) = N_Integer_Literal
+ and then Intval (Actual) = Uint_2
+ then
+ return True;
+ end if;
+ end if;
+
+ Next (Param);
+ end loop;
+ end;
+ end if;
- function Is_Tag_To_CW_Conversion (Obj_Id : Entity_Id) return Boolean is
+ return False;
+ end Is_Secondary_Stack_BIP_Func_Call;
+
+ -------------------------------------
+ -- Is_Tag_To_Class_Wide_Conversion --
+ -------------------------------------
+
+ function Is_Tag_To_Class_Wide_Conversion
+ (Obj_Id : Entity_Id) return Boolean
+ is
Expr : constant Node_Id := Expression (Parent (Obj_Id));
begin
and then Present (Expr)
and then Nkind (Expr) = N_Unchecked_Type_Conversion
and then Etype (Expression (Expr)) = RTE (RE_Tag);
- end Is_Tag_To_CW_Conversion;
+ end Is_Tag_To_Class_Wide_Conversion;
----------------------------
-- Is_Untagged_Derivation --
elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
if (Is_Entity_Name (Prefix (N))
- and then Has_Volatile_Components (Entity (Prefix (N))))
+ and then Has_Volatile_Components (Entity (Prefix (N))))
or else (Present (Etype (Prefix (N)))
- and then Has_Volatile_Components (Etype (Prefix (N))))
+ and then Has_Volatile_Components (Etype (Prefix (N))))
then
return True;
else
and then (Nkind (N) = N_Slice
or else
(Nkind (N) = N_Identifier
- and then Present (Renamed_Object (Entity (N)))
- and then Nkind (Renamed_Object (Entity (N)))
- = N_Slice));
+ and then Present (Renamed_Object (Entity (N)))
+ and then Nkind (Renamed_Object (Entity (N))) =
+ N_Slice));
end Is_VM_By_Copy_Actual;
--------------------
and then
(In_Instance
or else (Present (Entity (C))
- and then Has_Warnings_Off (Entity (C))))
+ and then Has_Warnings_Off (Entity (C))))
then
W := False;
end if;
if W then
Error_Msg_F
- ("?this code can never be executed and has been deleted!", N);
+ ("?t?this code can never be executed and has been deleted!",
+ N);
end if;
end if;
function Known_Non_Negative (Opnd : Node_Id) return Boolean is
begin
- if Is_OK_Static_Expression (Opnd)
- and then Expr_Value (Opnd) >= 0
- then
+ if Is_OK_Static_Expression (Opnd) and then Expr_Value (Opnd) >= 0 then
return True;
else
declare
Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd));
-
begin
return
Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0;
function Make_Predicate_Call
(Typ : Entity_Id;
- Expr : Node_Id) return Node_Id
+ Expr : Node_Id;
+ Mem : Boolean := False) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Expr);
begin
pragma Assert (Present (Predicate_Function (Typ)));
+ -- Call special membership version if requested and available
+
+ if Mem then
+ declare
+ PFM : constant Entity_Id := Predicate_Function_M (Typ);
+ begin
+ if Present (PFM) then
+ return
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (PFM, Loc),
+ Parameter_Associations => New_List (Relocate_Node (Expr)));
+ end if;
+ end;
+ end if;
+
+ -- Case of calling normal predicate function
+
return
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (Predicate_Function (Typ), Loc),
- Parameter_Associations => New_List (Relocate_Node (Expr)));
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (Predicate_Function (Typ), Loc),
+ Parameter_Associations => New_List (Relocate_Node (Expr)));
end Make_Predicate_Call;
--------------------------
elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then
return False;
- elsif Is_Array_Type (Typ)
- and then Present (Packed_Array_Type (Typ))
- then
+ elsif Is_Array_Type (Typ) and then Present (Packed_Array_Type (Typ)) then
return May_Generate_Large_Temp (Packed_Array_Type (Typ));
-- We could do more here to find other small types ???
or else Has_Some_Controlled_Component (T)
or else
(Is_Concurrent_Type (T)
- and then Present (Corresponding_Record_Type (T))
- and then Needs_Finalization (Corresponding_Record_Type (T)));
+ and then Present (Corresponding_Record_Type (T))
+ and then Needs_Finalization (Corresponding_Record_Type (T)));
end if;
end Needs_Finalization;
or else Is_Access_Type (Typ)
or else
(Is_Bit_Packed_Array (Typ)
- and then Is_Modular_Integer_Type (Packed_Array_Type (Typ)))
+ and then Is_Modular_Integer_Type (Packed_Array_Type (Typ)))
then
return False;
end case;
end Process_Statements_For_Controlled_Objects;
+ ----------------------
+ -- Remove_Init_Call --
+ ----------------------
+
+ function Remove_Init_Call
+ (Var : Entity_Id;
+ Rep_Clause : Node_Id) return Node_Id
+ is
+ Par : constant Node_Id := Parent (Var);
+ Typ : constant Entity_Id := Etype (Var);
+
+ Init_Proc : Entity_Id;
+ -- Initialization procedure for Typ
+
+ function Find_Init_Call_In_List (From : Node_Id) return Node_Id;
+ -- Look for init call for Var starting at From and scanning the
+ -- enclosing list until Rep_Clause or the end of the list is reached.
+
+ ----------------------------
+ -- Find_Init_Call_In_List --
+ ----------------------------
+
+ function Find_Init_Call_In_List (From : Node_Id) return Node_Id is
+ Init_Call : Node_Id;
+
+ begin
+ Init_Call := From;
+ while Present (Init_Call) and then Init_Call /= Rep_Clause loop
+ if Nkind (Init_Call) = N_Procedure_Call_Statement
+ and then Is_Entity_Name (Name (Init_Call))
+ and then Entity (Name (Init_Call)) = Init_Proc
+ then
+ return Init_Call;
+ end if;
+
+ Next (Init_Call);
+ end loop;
+
+ return Empty;
+ end Find_Init_Call_In_List;
+
+ Init_Call : Node_Id;
+
+ -- Start of processing for Find_Init_Call
+
+ begin
+ if Present (Initialization_Statements (Var)) then
+ Init_Call := Initialization_Statements (Var);
+ Set_Initialization_Statements (Var, Empty);
+
+ elsif not Has_Non_Null_Base_Init_Proc (Typ) then
+
+ -- No init proc for the type, so obviously no call to be found
+
+ return Empty;
+
+ else
+ -- We might be able to handle other cases below by just properly
+ -- setting Initialization_Statements at the point where the init proc
+ -- call is generated???
+
+ Init_Proc := Base_Init_Proc (Typ);
+
+ -- First scan the list containing the declaration of Var
+
+ Init_Call := Find_Init_Call_In_List (From => Next (Par));
+
+ -- If not found, also look on Var's freeze actions list, if any,
+ -- since the init call may have been moved there (case of an address
+ -- clause applying to Var).
+
+ if No (Init_Call) and then Present (Freeze_Node (Var)) then
+ Init_Call :=
+ Find_Init_Call_In_List (First (Actions (Freeze_Node (Var))));
+ end if;
+
+ -- If the initialization call has actuals that use the secondary
+ -- stack, the call may have been wrapped into a temporary block, in
+ -- which case the block itself has to be removed.
+
+ if No (Init_Call) and then Nkind (Next (Par)) = N_Block_Statement then
+ declare
+ Blk : constant Node_Id := Next (Par);
+ begin
+ if Present
+ (Find_Init_Call_In_List
+ (First (Statements (Handled_Statement_Sequence (Blk)))))
+ then
+ Init_Call := Blk;
+ end if;
+ end;
+ end if;
+ end if;
+
+ if Present (Init_Call) then
+ Remove (Init_Call);
+ end if;
+ return Init_Call;
+ end Remove_Init_Call;
+
-------------------------
-- Remove_Side_Effects --
-------------------------
Name_Req : Boolean := False;
Variable_Ref : Boolean := False)
is
- Loc : constant Source_Ptr := Sloc (Exp);
- Exp_Type : constant Entity_Id := Etype (Exp);
- Svg_Suppress : constant Suppress_Array := Scope_Suppress;
+ Loc : constant Source_Ptr := Sloc (Exp);
+ Exp_Type : constant Entity_Id := Etype (Exp);
+ Svg_Suppress : constant Suppress_Record := Scope_Suppress;
Def_Id : Entity_Id;
E : Node_Id;
New_Exp : Node_Id;
and then Is_Renaming_Of_Object (Entity (Original_Node (N)))
and then Ekind (Entity (Original_Node (N))) /= E_Constant
then
- return False;
+ declare
+ RO : constant Node_Id :=
+ Renamed_Object (Entity (Original_Node (N)));
+
+ begin
+ -- If the renamed object is an indexed component, or an
+ -- explicit dereference, then the designated object could
+ -- be modified by an assignment.
+
+ if Nkind_In (RO, N_Indexed_Component,
+ N_Explicit_Dereference)
+ then
+ return False;
+
+ -- A selected component must have a safe prefix
+
+ elsif Nkind (RO) = N_Selected_Component then
+ return Safe_Prefixed_Reference (RO);
+
+ -- In all other cases, designated object cannot be changed so
+ -- we are side effect free.
+
+ else
+ return True;
+ end if;
+ end;
-- Remove_Side_Effects generates an object renaming declaration to
-- capture the expression of a class-wide expression. In VM targets
elsif Is_Entity_Name (N) then
return Ekind (Entity (N)) = E_In_Parameter;
- elsif Nkind (N) = N_Indexed_Component
- or else Nkind (N) = N_Selected_Component
- then
+ elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
return Within_In_Parameter (Prefix (N));
- else
+ else
return False;
end if;
end Within_In_Parameter;
-- Start of processing for Remove_Side_Effects
begin
- -- We only need to do removal of side effects if we are generating
- -- actual code. That's because the whole issue of side effects is purely
- -- a run-time issue, and the removal is required only to get proper
- -- behavior at run-time.
-
- -- In the Alfa case, we don't need to remove side effects because we
- -- only perform formal verification is performed only on expressions
- -- that are provably side-effect free. If we tried to remove side
- -- effects in the Alfa case, we would get into a mess since in the case
- -- of limited types in particular, removal of side effects involves the
- -- use of access types or references which are not permitted in Alfa
- -- mode.
-
- if not Full_Expander_Active then
+ -- Handle cases in which there is nothing to do
+
+ if not Expander_Active then
return;
end if;
return;
end if;
- -- All this must not have any checks
+ -- The remaining procesaing is done with all checks suppressed
- Scope_Suppress := (others => True);
+ -- Note: from now on, don't use return statements, instead do a goto
+ -- Leave, to ensure that we properly restore Scope_Suppress.Suppress.
+
+ Scope_Suppress.Suppress := (others => True);
-- If it is a scalar type and we need to capture the value, just make
-- a copy. Likewise for a function call, an attribute reference, an
if Is_Elementary_Type (Exp_Type)
and then (Variable_Ref
- or else Nkind (Exp) = N_Function_Call
- or else Nkind (Exp) = N_Attribute_Reference
- or else Nkind (Exp) = N_Allocator
+ or else Nkind_In (Exp, N_Function_Call,
+ N_Attribute_Reference,
+ N_Allocator)
or else Nkind (Exp) in N_Op
or else (not Name_Req and then Is_Volatile_Reference (Exp)))
then
and then Nkind (Expression (Exp)) = N_Explicit_Dereference
then
Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
- Scope_Suppress := Svg_Suppress;
- return;
+ goto Leave;
-- If this is a type conversion, leave the type conversion and remove
-- the side effects in the expression. This is important in several
elsif Nkind (Exp) = N_Type_Conversion then
Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
- Scope_Suppress := Svg_Suppress;
- return;
+ goto Leave;
-- If this is an unchecked conversion that Gigi can't handle, make
-- a copy or a use a renaming to capture the value.
end if;
-- For expressions that denote objects, we can use a renaming scheme.
- -- This is needed for correctness in the case of a volatile object of a
- -- non-volatile type because the Make_Reference call of the "default"
+ -- This is needed for correctness in the case of a volatile object of
+ -- a non-volatile type because the Make_Reference call of the "default"
-- approach would generate an illegal access value (an access value
-- cannot designate such an object - see Analyze_Reference). We skip
-- using this scheme if we have an object of a volatile type and we do
-- not have Name_Req set true (see comments above for Side_Effect_Free).
+ -- In Ada 2012 a qualified expression is an object, but for purposes of
+ -- removing side effects it still need to be transformed into a separate
+ -- declaration, particularly if the expression is an aggregate.
+
elsif Is_Object_Reference (Exp)
and then Nkind (Exp) /= N_Function_Call
+ and then Nkind (Exp) /= N_Qualified_Expression
and then (Name_Req or else not Treat_As_Volatile (Exp_Type))
then
Def_Id := Make_Temporary (Loc, 'R', Exp);
-- by the expression it renames, which would defeat the purpose of
-- removing the side-effect.
- if (Nkind (Exp) = N_Selected_Component
- or else Nkind (Exp) = N_Indexed_Component)
+ if Nkind_In (Exp, N_Selected_Component, N_Indexed_Component)
and then Has_Non_Standard_Rep (Etype (Prefix (Exp)))
then
null;
-- Otherwise we generate a reference to the value
else
+ -- An expression which is in Alfa mode is considered side effect free
+ -- if the resulting value is captured by a variable or a constant.
+
+ if Alfa_Mode and then Nkind (Parent (Exp)) = N_Object_Declaration then
+ goto Leave;
+ end if;
+
-- Special processing for function calls that return a limited type.
-- We need to build a declaration that will enable build-in-place
-- expansion of the call. This is not done if the context is already
Insert_Action (Exp, Decl);
Set_Etype (Obj, Exp_Type);
Rewrite (Exp, New_Occurrence_Of (Obj, Loc));
- return;
+ goto Leave;
end;
end if;
Def_Id := Make_Temporary (Loc, 'R', Exp);
Set_Etype (Def_Id, Exp_Type);
- Res :=
- Make_Explicit_Dereference (Loc,
- Prefix => New_Reference_To (Def_Id, Loc));
+ -- The regular expansion of functions with side effects involves the
+ -- generation of an access type to capture the return value found on
+ -- the secondary stack. Since Alfa (and why) cannot process access
+ -- types, use a different approach which ignores the secondary stack
+ -- and "copies" the returned object.
+
+ if Alfa_Mode then
+ Res := New_Reference_To (Def_Id, Loc);
+ Ref_Type := Exp_Type;
+
+ -- Regular expansion utilizing an access type and 'reference
+
+ else
+ Res :=
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Reference_To (Def_Id, Loc));
- -- Generate:
- -- type Ann is access all <Exp_Type>;
+ -- Generate:
+ -- type Ann is access all <Exp_Type>;
- Ref_Type := Make_Temporary (Loc, 'A');
+ Ref_Type := Make_Temporary (Loc, 'A');
- Ptr_Typ_Decl :=
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Ref_Type,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- All_Present => True,
- Subtype_Indication =>
- New_Reference_To (Exp_Type, Loc)));
+ Ptr_Typ_Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Ref_Type,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication =>
+ New_Reference_To (Exp_Type, Loc)));
- Insert_Action (Exp, Ptr_Typ_Decl);
+ Insert_Action (Exp, Ptr_Typ_Decl);
+ end if;
E := Exp;
if Nkind (E) = N_Explicit_Dereference then
Rewrite (Exp, Res);
Analyze_And_Resolve (Exp, Exp_Type);
+
+ <<Leave>>
Scope_Suppress := Svg_Suppress;
end Remove_Side_Effects;
begin
return Is_Scalar_Type (UT)
or else (Is_Bit_Packed_Array (UT)
- and then Is_Scalar_Type (Packed_Array_Type (UT)));
+ and then Is_Scalar_Type (Packed_Array_Type (UT)));
end Represented_As_Scalar;
------------------------------
-- Requires_Cleanup_Actions --
------------------------------
- function Requires_Cleanup_Actions (N : Node_Id) return Boolean is
- For_Pkg : constant Boolean :=
- Nkind_In (N, N_Package_Body, N_Package_Specification);
+ function Requires_Cleanup_Actions
+ (N : Node_Id;
+ Lib_Level : Boolean) return Boolean
+ is
+ At_Lib_Level : constant Boolean :=
+ Lib_Level
+ and then Nkind_In (N, N_Package_Body,
+ N_Package_Specification);
+ -- N is at the library level if the top-most context is a package and
+ -- the path taken to reach N does not inlcude non-package constructs.
begin
case Nkind (N) is
N_Subprogram_Body |
N_Task_Body =>
return
- Requires_Cleanup_Actions (Declarations (N), For_Pkg, True)
+ Requires_Cleanup_Actions (Declarations (N), At_Lib_Level, True)
or else
- (Present (Handled_Statement_Sequence (N))
- and then
- Requires_Cleanup_Actions (Statements
- (Handled_Statement_Sequence (N)), For_Pkg, True));
+ (Present (Handled_Statement_Sequence (N))
+ and then
+ Requires_Cleanup_Actions
+ (Statements (Handled_Statement_Sequence (N)),
+ At_Lib_Level, True));
when N_Package_Specification =>
return
Requires_Cleanup_Actions
- (Visible_Declarations (N), For_Pkg, True)
+ (Visible_Declarations (N), At_Lib_Level, True)
or else
Requires_Cleanup_Actions
- (Private_Declarations (N), For_Pkg, True);
+ (Private_Declarations (N), At_Lib_Level, True);
when others =>
return False;
function Requires_Cleanup_Actions
(L : List_Id;
- For_Package : Boolean;
+ Lib_Level : Boolean;
Nested_Constructs : Boolean) return Boolean
is
Decl : Node_Id;
-- finalization disabled. This applies only to objects at the
-- library level.
- if For_Package
- and then Finalize_Storage_Only (Obj_Typ)
- then
+ if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
null;
-- Transient variables are treated separately in order to minimize
elsif not Is_Imported (Obj_Id)
and then Needs_Finalization (Obj_Typ)
and then not (Ekind (Obj_Id) = E_Constant
- and then not Has_Completion (Obj_Id))
- and then not Is_Tag_To_CW_Conversion (Obj_Id)
+ and then not Has_Completion (Obj_Id))
+ and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
then
return True;
-- Obj : Access_Typ := Non_BIP_Function_Call'reference;
--
-- Obj : Access_Typ :=
- -- BIP_Function_Call
- -- (..., BIPaccess => null, ...)'reference;
+ -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
elsif Is_Access_Type (Obj_Typ)
and then Needs_Finalization
(Available_View (Designated_Type (Obj_Typ)))
and then Present (Expr)
and then
- (Is_Null_Access_BIP_Func_Call (Expr)
- or else
- (Is_Non_BIP_Func_Call (Expr)
- and then not Is_Related_To_Func_Return (Obj_Id)))
+ (Is_Secondary_Stack_BIP_Func_Call (Expr)
+ or else
+ (Is_Non_BIP_Func_Call (Expr)
+ and then not Is_Related_To_Func_Return (Obj_Id)))
then
return True;
-- transients declared inside an Expression_With_Actions.
elsif Is_Access_Type (Obj_Typ)
- and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
- and then Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) =
- N_Object_Declaration
+ and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
+ and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
+ N_Object_Declaration
and then Is_Finalizable_Transient
- (Return_Flag_Or_Transient_Decl (Obj_Id), Decl)
+ (Status_Flag_Or_Transient_Decl (Obj_Id), Decl)
+ then
+ return True;
+
+ -- Processing for intermediate results of if expressions where
+ -- one of the alternatives uses a controlled function call.
+
+ elsif Is_Access_Type (Obj_Typ)
+ and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
+ and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
+ N_Defining_Identifier
+ and then Present (Expr)
+ and then Nkind (Expr) = N_Null
then
return True;
-- Specific cases of object renamings
- elsif Nkind (Decl) = N_Object_Renaming_Declaration
- and then Nkind (Name (Decl)) = N_Explicit_Dereference
- and then Nkind (Prefix (Name (Decl))) = N_Identifier
- then
+ elsif Nkind (Decl) = N_Object_Renaming_Declaration then
Obj_Id := Defining_Identifier (Decl);
Obj_Typ := Base_Type (Etype (Obj_Id));
-- finalization disabled. This applies only to objects at the
-- library level.
- if For_Package
- and then Finalize_Storage_Only (Obj_Typ)
- then
+ if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
null;
-- Return object of a build-in-place function. This case is
elsif Needs_Finalization (Obj_Typ)
and then Is_Return_Object (Obj_Id)
- and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
+ and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
then
return True;
+
+ -- Detect a case where a source object has been initialized by
+ -- a controlled function call or another object which was later
+ -- rewritten as a class-wide conversion of Ada.Tags.Displace.
+
+ -- Obj1 : CW_Type := Src_Obj;
+ -- Obj2 : CW_Type := Function_Call (...);
+
+ -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
+ -- Tmp : ... := Function_Call (...)'reference;
+ -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
+
+ elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
+ return True;
end if;
-- Inspect the freeze node of an access-to-controlled type and look
(Available_View (Designated_Type (Typ))))
or else
(Is_Type (Typ)
- and then Needs_Finalization (Typ)))
+ and then Needs_Finalization (Typ)))
and then Requires_Cleanup_Actions
- (Actions (Decl), For_Package, Nested_Constructs)
+ (Actions (Decl), Lib_Level, Nested_Constructs)
then
return True;
end if;
end if;
if Ekind (Pack_Id) /= E_Generic_Package
- and then Requires_Cleanup_Actions (Specification (Decl))
+ and then
+ Requires_Cleanup_Actions (Specification (Decl), Lib_Level)
then
return True;
end if;
-- Nested package bodies
- elsif Nested_Constructs
- and then Nkind (Decl) = N_Package_Body
- then
+ elsif Nested_Constructs and then Nkind (Decl) = N_Package_Body then
Pack_Id := Corresponding_Spec (Decl);
if Ekind (Pack_Id) /= E_Generic_Package
- and then Requires_Cleanup_Actions (Decl)
+ and then Requires_Cleanup_Actions (Decl, Lib_Level)
then
return True;
end if;
if (Nkind (Pexp) = N_Assignment_Statement
and then Expression (Pexp) = Exp)
- or else Nkind (Pexp) = N_Object_Declaration
- or else Nkind (Pexp) = N_Object_Renaming_Declaration
+ or else Nkind_In (Pexp, N_Object_Declaration,
+ N_Object_Renaming_Declaration)
then
return True;
-- introduce a temporary in this case.
elsif Nkind (Pexp) = N_Selected_Component
- and then Prefix (Pexp) = Exp
+ and then Prefix (Pexp) = Exp
then
if No (Etype (Pexp)) then
return True;
elsif Size_Known_At_Compile_Time (Otyp)
and then
(not Stack_Checking_Enabled
- or else not May_Generate_Large_Temp (Otyp))
+ or else not May_Generate_Large_Temp (Otyp))
and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp))
then
return True;
end if;
end Type_May_Have_Bit_Aligned_Components;
+ ----------------------------------
+ -- Within_Case_Or_If_Expression --
+ ----------------------------------
+
+ function Within_Case_Or_If_Expression (N : Node_Id) return Boolean is
+ Par : Node_Id;
+
+ begin
+ -- Locate an enclosing case or if expression. Note: these constructs can
+ -- get expanded into Expression_With_Actions, hence the need to test
+ -- using the original node.
+
+ Par := N;
+ while Present (Par) loop
+ if Nkind_In (Original_Node (Par), N_Case_Expression,
+ N_If_Expression)
+ then
+ return True;
+
+ -- Prevent the search from going too far
+
+ elsif Nkind_In (Par, N_Entry_Body,
+ N_Package_Body,
+ N_Package_Declaration,
+ N_Protected_Body,
+ N_Subprogram_Body,
+ N_Task_Body)
+ then
+ return False;
+ end if;
+
+ Par := Parent (Par);
+ end loop;
+
+ return False;
+ end Within_Case_Or_If_Expression;
+
----------------------------
-- Wrap_Cleanup_Procedure --
----------------------------
OSDN Git Service
