-- --
-- 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;
N : Node_Id) return Entity_Id;
-- Create an implicit subtype of CW_Typ attached to node N
+ function Requires_Cleanup_Actions
+ (L : List_Id;
+ 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
+ --
+ -- 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 --
+ -------------------------------------
+
+ procedure Activate_Atomic_Synchronization (N : Node_Id) is
+ Msg_Node : Node_Id;
+
+ begin
+ case Nkind (Parent (N)) is
+
+ -- Check for cases of appearing in the prefix of a construct where
+ -- we don't need atomic synchronization for this kind of usage.
+
+ when
+ -- Nothing to do if we are the prefix of an attribute, since we
+ -- do not want an atomic sync operation for things like 'Size.
+
+ N_Attribute_Reference |
+
+ -- The N_Reference node is like an attribute
+
+ N_Reference |
+
+ -- Nothing to do for a reference to a component (or components)
+ -- of a composite object. Only reads and updates of the object
+ -- as a whole require atomic synchronization (RM C.6 (15)).
+
+ N_Indexed_Component |
+ N_Selected_Component |
+ N_Slice =>
+
+ -- For all the above cases, nothing to do if we are the prefix
+
+ if Prefix (Parent (N)) = N then
+ return;
+ end if;
+
+ when others => null;
+ end case;
+
+ -- Go ahead and set the flag
+
+ Set_Atomic_Sync_Required (N);
+
+ -- Generate info message if requested
+
+ if Warn_On_Atomic_Synchronization then
+ case Nkind (N) is
+ when N_Identifier =>
+ Msg_Node := N;
+
+ when N_Selected_Component | N_Expanded_Name =>
+ Msg_Node := Selector_Name (N);
+
+ when N_Explicit_Dereference | N_Indexed_Component =>
+ Msg_Node := Empty;
+
+ when others =>
+ pragma Assert (False);
+ return;
+ end case;
+
+ if Present (Msg_Node) then
+ Error_Msg_N
+ ("?N?info: atomic synchronization set for &", Msg_Node);
+ else
+ Error_Msg_N
+ ("?N?info: atomic synchronization set", N);
+ end if;
+ end if;
+ end Activate_Atomic_Synchronization;
+
----------------------
-- Adjust_Condition --
----------------------
Ti : Entity_Id;
begin
- -- For now, we simply ignore a call where the argument has no type
- -- (probably case of unanalyzed condition), or has a type that is not
- -- Boolean. This is because this is a pretty marginal piece of
- -- functionality, and violations of these rules are likely to be
- -- truly marginal (how much code uses Fortran Logical as the barrier
- -- to a protected entry?) and we do not want to blow up existing
- -- programs. We can change this to an assertion after 3.12a is
- -- released ???
+ -- Defend against a call where the argument has no type, or has a
+ -- type that is not Boolean. This can occur because of prior errors.
if No (T) or else not Is_Boolean_Type (T) then
return;
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;
(N : Node_Id;
Is_Allocate : Boolean)
is
- Expr : constant Node_Id := Expression (N);
- Ptr_Typ : constant Entity_Id := Etype (Expr);
- Desig_Typ : constant Entity_Id :=
- Available_View (Designated_Type (Ptr_Typ));
+ Desig_Typ : Entity_Id;
+ Expr : Node_Id;
+ Pool_Id : Entity_Id;
+ Proc_To_Call : Node_Id := Empty;
+ Ptr_Typ : Entity_Id;
+
+ function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id;
+ -- Locate TSS primitive Finalize_Address in type Typ
function Find_Object (E : Node_Id) return Node_Id;
-- Given an arbitrary expression of an allocator, try to find an object
-- Determine whether subprogram Subp denotes a custom allocate or
-- deallocate.
+ ---------------------------
+ -- Find_Finalize_Address --
+ ---------------------------
+
+ function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id is
+ Utyp : Entity_Id := Typ;
+
+ begin
+ -- Handle protected class-wide or task class-wide types
+
+ if Is_Class_Wide_Type (Utyp) then
+ if Is_Concurrent_Type (Root_Type (Utyp)) then
+ Utyp := Root_Type (Utyp);
+
+ elsif Is_Private_Type (Root_Type (Utyp))
+ and then Present (Full_View (Root_Type (Utyp)))
+ and then Is_Concurrent_Type (Full_View (Root_Type (Utyp)))
+ then
+ Utyp := Full_View (Root_Type (Utyp));
+ end if;
+ end if;
+
+ -- Handle private types
+
+ if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then
+ Utyp := Full_View (Utyp);
+ end if;
+
+ -- Handle protected and task types
+
+ if Is_Concurrent_Type (Utyp)
+ and then Present (Corresponding_Record_Type (Utyp))
+ then
+ Utyp := Corresponding_Record_Type (Utyp);
+ end if;
+
+ Utyp := Underlying_Type (Base_Type (Utyp));
+
+ -- Deal with non-tagged derivation of private views. If the parent is
+ -- now known to be protected, the finalization routine is the one
+ -- defined on the corresponding record of the ancestor (corresponding
+ -- records do not automatically inherit operations, but maybe they
+ -- should???)
+
+ if Is_Untagged_Derivation (Typ) then
+ if Is_Protected_Type (Typ) then
+ Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
+ else
+ Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
+
+ if Is_Protected_Type (Utyp) then
+ Utyp := Corresponding_Record_Type (Utyp);
+ end if;
+ end if;
+ end if;
+
+ -- If the underlying_type is a subtype, we are dealing with the
+ -- completion of a private type. We need to access the base type and
+ -- generate a conversion to it.
+
+ if Utyp /= Base_Type (Utyp) then
+ pragma Assert (Is_Private_Type (Typ));
+
+ 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;
+
-----------------
-- Find_Object --
-----------------
function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean is
begin
-- Look for a subprogram body with only one statement which is a
- -- call to one of the Allocate / Deallocate routines in package
- -- Ada.Finalization.Heap_Management.
+ -- call to Allocate_Any_Controlled / Deallocate_Any_Controlled.
if Ekind (Subp) = E_Procedure
and then Nkind (Parent (Parent (Subp))) = N_Subprogram_Body
Proc := Entity (Name (First (Statements (HSS))));
return
- Is_RTE (Proc, RE_Allocate)
- or else Is_RTE (Proc, RE_Deallocate);
+ Is_RTE (Proc, RE_Allocate_Any_Controlled)
+ or else Is_RTE (Proc, RE_Deallocate_Any_Controlled);
end if;
end;
end if;
-- Start of processing for Build_Allocate_Deallocate_Proc
begin
- -- The allocation / deallocation of a non-controlled object does not
- -- need the machinery created by this routine.
+ -- Do not perform this expansion in Alfa mode because it is not
+ -- necessary.
+
+ if Alfa_Mode then
+ return;
+ end if;
+
+ -- Obtain the attributes of the allocation / deallocation
+
+ if Nkind (N) = N_Free_Statement then
+ Expr := Expression (N);
+ Ptr_Typ := Base_Type (Etype (Expr));
+ Proc_To_Call := Procedure_To_Call (N);
+
+ else
+ if Nkind (N) = N_Object_Declaration then
+ Expr := Expression (N);
+ else
+ Expr := N;
+ end if;
+
+ -- In certain cases an allocator with a qualified expression may
+ -- be relocated and used as the initialization expression of a
+ -- temporary:
+
+ -- before:
+ -- Obj : Ptr_Typ := new Desig_Typ'(...);
+
+ -- after:
+ -- Tmp : Ptr_Typ := new Desig_Typ'(...);
+ -- Obj : Ptr_Typ := Tmp;
+
+ -- Since the allocator is always marked as analyzed to avoid infinite
+ -- expansion, it will never be processed by this routine given that
+ -- the designated type needs finalization actions. Detect this case
+ -- and complete the expansion of the allocator.
+
+ if Nkind (Expr) = N_Identifier
+ and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
+ and then Nkind (Expression (Parent (Entity (Expr)))) = N_Allocator
+ then
+ Build_Allocate_Deallocate_Proc (Parent (Entity (Expr)), True);
+ return;
+ end if;
- if not Needs_Finalization (Desig_Typ) then
+ -- The allocator may have been rewritten into something else in which
+ -- case the expansion performed by this routine does not apply.
+
+ if Nkind (Expr) /= N_Allocator then
+ return;
+ end if;
+
+ Ptr_Typ := Base_Type (Etype (Expr));
+ Proc_To_Call := Procedure_To_Call (Expr);
+ end if;
+
+ Pool_Id := Associated_Storage_Pool (Ptr_Typ);
+ Desig_Typ := Available_View (Designated_Type (Ptr_Typ));
+
+ -- Handle concurrent types
+
+ if Is_Concurrent_Type (Desig_Typ)
+ and then Present (Corresponding_Record_Type (Desig_Typ))
+ then
+ Desig_Typ := Corresponding_Record_Type (Desig_Typ);
+ end if;
+
+ -- Do not process allocations / deallocations without a pool
+
+ if No (Pool_Id) then
+ return;
+
+ -- Do not process allocations on / deallocations from the secondary
+ -- stack.
+
+ elsif Is_RTE (Pool_Id, RE_SS_Pool) then
+ return;
+
+ -- Do not replicate the machinery if the allocator / free has already
+ -- been expanded and has a custom Allocate / Deallocate.
+
+ elsif Present (Proc_To_Call)
+ and then Is_Allocate_Deallocate_Proc (Proc_To_Call)
+ then
return;
+ end if;
+
+ if Needs_Finalization (Desig_Typ) then
+
+ -- Certain run-time configurations and targets do not provide support
+ -- for controlled types.
+
+ if Restriction_Active (No_Finalization) then
+ return;
+
+ -- Do nothing if the access type may never allocate / deallocate
+ -- objects.
+
+ elsif No_Pool_Assigned (Ptr_Typ) then
+ return;
+
+ -- Access-to-controlled types are not supported on .NET/JVM since
+ -- these targets cannot support pools and address arithmetic.
+
+ elsif VM_Target /= No_VM then
+ return;
+ end if;
+
+ -- The allocation / deallocation of a controlled object must be
+ -- chained on / detached from a finalization master.
- -- The allocator or free statmenet has already been expanded and already
- -- has a custom Allocate / Deallocate routine.
+ pragma Assert (Present (Finalization_Master (Ptr_Typ)));
+
+ -- The only other kind of allocation / deallocation supported by this
+ -- routine is on / from a subpool.
elsif Nkind (Expr) = N_Allocator
- and then Present (Procedure_To_Call (Expr))
- and then Is_Allocate_Deallocate_Proc (Procedure_To_Call (Expr))
+ and then No (Subpool_Handle_Name (Expr))
then
return;
end if;
Size_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
Actuals : List_Id;
- Collect_Act : Node_Id;
- Collect_Id : Entity_Id;
- Collect_Typ : Entity_Id;
+ Fin_Addr_Id : Entity_Id;
+ Fin_Mas_Act : Node_Id;
+ Fin_Mas_Id : Entity_Id;
Proc_To_Call : Entity_Id;
+ Subpool : Node_Id := Empty;
begin
- -- When dealing with an access subtype, use the collection of the
- -- base type.
+ -- Step 1: Construct all the actuals for the call to library routine
+ -- Allocate_Any_Controlled / Deallocate_Any_Controlled.
- if Ekind (Ptr_Typ) = E_Access_Subtype then
- Collect_Typ := Base_Type (Ptr_Typ);
- else
- Collect_Typ := Ptr_Typ;
- end if;
+ -- a) Storage pool
- Collect_Id := Associated_Collection (Collect_Typ);
- Collect_Act := New_Reference_To (Collect_Id, Loc);
+ Actuals := New_List (New_Reference_To (Pool_Id, Loc));
- -- Handle the case where the collection is actually a pointer to a
- -- collection. This case arises in build-in-place functions.
+ if Is_Allocate then
- if Is_Access_Type (Etype (Collect_Id)) then
- Collect_Act :=
- Make_Explicit_Dereference (Loc,
- Prefix => Collect_Act);
- end if;
+ -- b) Subpool
- -- Create the actuals for the call to Allocate / Deallocate
+ if Nkind (Expr) = N_Allocator then
+ Subpool := Subpool_Handle_Name (Expr);
+ end if;
- Actuals := New_List (
- Collect_Act,
- New_Reference_To (Addr_Id, Loc),
- New_Reference_To (Size_Id, Loc),
- New_Reference_To (Alig_Id, Loc));
+ -- If a subpool is present it can be an arbitrary name, so make
+ -- the actual by copying the tree.
- -- Generate a run-time check to determine whether a class-wide object
- -- is truly controlled.
+ if Present (Subpool) then
+ Append_To (Actuals, New_Copy_Tree (Subpool, New_Sloc => Loc));
+ else
+ Append_To (Actuals, Make_Null (Loc));
+ end if;
- if Is_Class_Wide_Type (Desig_Typ)
- or else Is_Generic_Actual_Type (Desig_Typ)
- then
- declare
- Flag_Id : constant Entity_Id := Make_Temporary (Loc, 'F');
- Flag_Expr : Node_Id;
- Param : Node_Id;
- Temp : Node_Id;
+ -- c) Finalization master
- begin
- if Is_Allocate then
- Temp := Find_Object (Expression (Expr));
+ if Needs_Finalization (Desig_Typ) then
+ Fin_Mas_Id := Finalization_Master (Ptr_Typ);
+ Fin_Mas_Act := New_Reference_To (Fin_Mas_Id, Loc);
+
+ -- Handle the case where the master is actually a pointer to a
+ -- master. This case arises in build-in-place functions.
+
+ if Is_Access_Type (Etype (Fin_Mas_Id)) then
+ Append_To (Actuals, Fin_Mas_Act);
else
- Temp := Expr;
+ Append_To (Actuals,
+ Make_Attribute_Reference (Loc,
+ Prefix => Fin_Mas_Act,
+ Attribute_Name => Name_Unrestricted_Access));
end if;
+ else
+ Append_To (Actuals, Make_Null (Loc));
+ end if;
- -- Processing for generic actuals
+ -- d) Finalize_Address
- if Is_Generic_Actual_Type (Desig_Typ) then
- Flag_Expr :=
- New_Reference_To (Boolean_Literals
- (Needs_Finalization (Base_Type (Desig_Typ))), Loc);
+ -- Primitive Finalize_Address is never generated in CodePeer mode
+ -- since it contains an Unchecked_Conversion.
- -- Processing for subtype indications
+ 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));
- elsif Nkind (Temp) in N_Has_Entity
- and then Is_Type (Entity (Temp))
- then
- Flag_Expr :=
- New_Reference_To (Boolean_Literals
- (Needs_Finalization (Entity (Temp))), Loc);
+ Append_To (Actuals,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Fin_Addr_Id, Loc),
+ Attribute_Name => Name_Unrestricted_Access));
+ else
+ Append_To (Actuals, Make_Null (Loc));
+ end if;
+ end if;
- -- Generate a runtime check to test the controlled state of an
- -- object for the purposes of allocation / deallocation.
+ -- e) Address
+ -- f) Storage_Size
+ -- g) Alignment
- else
- -- The following case arises when allocating through an
- -- interface class-wide type, generate:
- --
- -- Temp.all
+ Append_To (Actuals, New_Reference_To (Addr_Id, Loc));
+ Append_To (Actuals, New_Reference_To (Size_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
- if Is_RTE (Etype (Temp), RE_Tag_Ptr) then
- Param :=
- Make_Explicit_Dereference (Loc,
- Prefix =>
- Relocate_Node (Temp));
+ -- Generate a run-time check to determine whether a class-wide object
+ -- is truly controlled.
- -- Generate:
- -- Temp'Tag
+ if Needs_Finalization (Desig_Typ) then
+ if Is_Class_Wide_Type (Desig_Typ)
+ or else Is_Generic_Actual_Type (Desig_Typ)
+ then
+ declare
+ Flag_Id : constant Entity_Id := Make_Temporary (Loc, 'F');
+ Flag_Expr : Node_Id;
+ Param : Node_Id;
+ Temp : Node_Id;
+ begin
+ if Is_Allocate then
+ Temp := Find_Object (Expression (Expr));
else
- Param :=
- Make_Attribute_Reference (Loc,
- Prefix =>
- Relocate_Node (Temp),
- Attribute_Name => Name_Tag);
+ Temp := Expr;
end if;
- -- Generate:
- -- Needs_Finalization (Param)
+ -- Processing for generic actuals
- Flag_Expr :=
- Make_Function_Call (Loc,
- Name =>
- New_Reference_To (RTE (RE_Needs_Finalization), Loc),
- Parameter_Associations => New_List (Param));
- end if;
+ if Is_Generic_Actual_Type (Desig_Typ) then
+ Flag_Expr :=
+ New_Reference_To (Boolean_Literals
+ (Needs_Finalization (Base_Type (Desig_Typ))), Loc);
- -- Create the temporary which represents the finalization state
- -- of the expression. Generate:
- --
- -- F : constant Boolean := <Flag_Expr>;
+ -- Processing for subtype indications
- Insert_Action (N,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Flag_Id,
- Constant_Present => True,
- Object_Definition =>
- New_Reference_To (Standard_Boolean, Loc),
- Expression => Flag_Expr));
+ elsif Nkind (Temp) in N_Has_Entity
+ and then Is_Type (Entity (Temp))
+ then
+ Flag_Expr :=
+ New_Reference_To (Boolean_Literals
+ (Needs_Finalization (Entity (Temp))), Loc);
- -- The flag acts as the fifth actual
+ -- Generate a runtime check to test the controlled state of
+ -- an object for the purposes of allocation / deallocation.
- Append_To (Actuals, New_Reference_To (Flag_Id, Loc));
- end;
+ else
+ -- The following case arises when allocating through an
+ -- interface class-wide type, generate:
+ --
+ -- Temp.all
+
+ if Is_RTE (Etype (Temp), RE_Tag_Ptr) then
+ Param :=
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Relocate_Node (Temp));
+
+ -- Generate:
+ -- Temp'Tag
+
+ else
+ Param :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Relocate_Node (Temp),
+ Attribute_Name => Name_Tag);
+ end if;
+
+ -- Generate:
+ -- Needs_Finalization (<Param>)
+
+ Flag_Expr :=
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Needs_Finalization), Loc),
+ Parameter_Associations => New_List (Param));
+ end if;
+
+ -- Create the temporary which represents the finalization
+ -- state of the expression. Generate:
+ --
+ -- F : constant Boolean := <Flag_Expr>;
+
+ Insert_Action (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Flag_Id,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Reference_To (Standard_Boolean, Loc),
+ Expression => Flag_Expr));
+
+ -- The flag acts as the last actual
+
+ Append_To (Actuals, New_Reference_To (Flag_Id, Loc));
+ end;
+
+ -- The object is statically known to be 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;
+
+ -- i) On_Subpool
+
+ if Is_Allocate then
+ Append_To (Actuals,
+ New_Reference_To (Boolean_Literals (Present (Subpool)), Loc));
end if;
+ -- Step 2: Build a wrapper Allocate / Deallocate which internally
+ -- calls Allocate_Any_Controlled / Deallocate_Any_Controlled.
+
-- Select the proper routine to call
if Is_Allocate then
- Proc_To_Call := RTE (RE_Allocate);
+ Proc_To_Call := RTE (RE_Allocate_Any_Controlled);
else
- Proc_To_Call := RTE (RE_Deallocate);
+ Proc_To_Call := RTE (RE_Deallocate_Any_Controlled);
end if;
-- Create a custom Allocate / Deallocate routine which has identical
-- 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,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
-
- -- Allocate / Deallocate
- -- (<Ptr_Typ collection>, A, S, L[, F]);
-
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;
if Ekind (Typ) in Protected_Kind then
if Has_Entries (Typ)
- or else Has_Interrupt_Handler (Typ)
- or else (Has_Attach_Handler (Typ)
- and then not Restricted_Profile)
-- A protected type without entries that covers an interface and
-- overrides the abstract routines with protected procedures is
-- node to recognize this case.
or else Present (Interface_List (Parent (Typ)))
+ or else
+ (((Has_Attach_Handler (Typ) and then not Restricted_Profile)
+ or else Has_Interrupt_Handler (Typ))
+ and then not Restriction_Active (No_Dynamic_Attachment))
then
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Typ) > 1
or else (Has_Attach_Handler (Typ)
- and then not Restricted_Profile)
+ and then not Restricted_Profile)
then
Pkg_Id := System_Tasking_Protected_Objects_Entries;
else
if Act_ST = Etype (Exp) then
return;
-
else
- Rewrite (Exp,
- Convert_To (Act_ST, Relocate_Node (Exp)));
+ Rewrite (Exp, Convert_To (Act_ST, Relocate_Node (Exp)));
Analyze_And_Resolve (Exp, Act_ST);
end if;
end Convert_To_Actual_Subtype;
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);
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;
- --------------------
- -- Entry_Names_OK --
- --------------------
+ ---------------
+ -- Entity_Of --
+ ---------------
+
+ function Entity_Of (N : Node_Id) return Entity_Id is
+ Id : Entity_Id;
- function Entry_Names_OK return Boolean is
begin
- return
- not Restricted_Profile
+ 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 --
+ --------------------
+
+ function Entry_Names_OK return Boolean is
+ begin
+ return
+ not Restricted_Profile
and then not Global_Discard_Names
and then not Restriction_Active (No_Implicit_Heap_Allocations)
and then not Restriction_Active (No_Local_Allocators);
end Entry_Names_OK;
+ -------------------
+ -- Evaluate_Name --
+ -------------------
+
+ procedure Evaluate_Name (Nam : Node_Id) is
+ K : constant Node_Kind := Nkind (Nam);
+
+ begin
+ -- For an explicit dereference, we simply force the evaluation of the
+ -- name expression. The dereference provides a value that is the address
+ -- for the renamed object, and it is precisely this value that we want
+ -- to preserve.
+
+ if K = N_Explicit_Dereference then
+ Force_Evaluation (Prefix (Nam));
+
+ -- For a selected component, we simply evaluate the prefix
+
+ elsif K = N_Selected_Component then
+ Evaluate_Name (Prefix (Nam));
+
+ -- For an indexed component, or an attribute reference, we evaluate the
+ -- prefix, which is itself a name, recursively, and then force the
+ -- evaluation of all the subscripts (or attribute expressions).
+
+ elsif Nkind_In (K, N_Indexed_Component, N_Attribute_Reference) then
+ Evaluate_Name (Prefix (Nam));
+
+ declare
+ E : Node_Id;
+
+ begin
+ E := First (Expressions (Nam));
+ while Present (E) loop
+ Force_Evaluation (E);
+
+ if Original_Node (E) /= E then
+ Set_Do_Range_Check (E, Do_Range_Check (Original_Node (E)));
+ end if;
+
+ Next (E);
+ end loop;
+ end;
+
+ -- For a slice, we evaluate the prefix, as for the indexed component
+ -- case and then, if there is a range present, either directly or as the
+ -- constraint of a discrete subtype indication, we evaluate the two
+ -- bounds of this range.
+
+ elsif K = N_Slice then
+ Evaluate_Name (Prefix (Nam));
+
+ declare
+ DR : constant Node_Id := Discrete_Range (Nam);
+ Constr : Node_Id;
+ Rexpr : Node_Id;
+
+ begin
+ if Nkind (DR) = N_Range then
+ Force_Evaluation (Low_Bound (DR));
+ Force_Evaluation (High_Bound (DR));
+
+ elsif Nkind (DR) = N_Subtype_Indication then
+ Constr := Constraint (DR);
+
+ if Nkind (Constr) = N_Range_Constraint then
+ Rexpr := Range_Expression (Constr);
+
+ Force_Evaluation (Low_Bound (Rexpr));
+ Force_Evaluation (High_Bound (Rexpr));
+ end if;
+ end if;
+ end;
+
+ -- For a type conversion, the expression of the conversion must be the
+ -- name of an object, and we simply need to evaluate this name.
+
+ elsif K = N_Type_Conversion then
+ Evaluate_Name (Expression (Nam));
+
+ -- For a function call, we evaluate the call
+
+ elsif K = N_Function_Call then
+ Force_Evaluation (Nam);
+
+ -- The remaining cases are direct name, operator symbol and character
+ -- literal. In all these cases, we do nothing, since we want to
+ -- reevaluate each time the renamed object is used.
+
+ else
+ return;
+ end if;
+ end Evaluate_Name;
+
---------------------
-- Evolve_And_Then --
---------------------
-- 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;
then
null;
- -- In Ada95 nothing to be done if the type of the expression is limited,
+ -- In Ada 95 nothing to be done if the type of the expression is limited
-- because in this case the expression cannot be copied, and its use can
-- only be by reference.
- -- In Ada2005, the context can be an object declaration whose expression
+ -- In Ada 2005 the context can be an object declaration whose expression
-- is a function that returns in place. If the nominal subtype has
-- unknown discriminants, the call still provides constraints on the
-- object, and we have to create an actual subtype from it.
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);
Typ := Corresponding_Record_Type (Typ);
end if;
+ -- Since restriction violations are not considered serious errors, the
+ -- expander remains active, but may leave the corresponding record type
+ -- malformed. In such cases, component _object is not available so do
+ -- not look for it.
+
+ if not Analyzed (Typ) then
+ return Empty;
+ end if;
+
Comp := First_Component (Typ);
while Present (Comp) loop
if Chars (Comp) = Name_uObject then
-- 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
Disc : Entity_Id;
T : constant Entity_Id := Etype (E);
- begin
- 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
- return True;
- end if;
-
- Next_Discriminant (Disc);
- end loop;
-
- return False;
- else
- return False;
- end if;
- end Has_Access_Constraint;
-
- ----------------------------
- -- Has_Controlled_Objects --
- ----------------------------
-
- function Has_Controlled_Objects (N : Node_Id) return Boolean is
- For_Pkg : constant Boolean :=
- Nkind_In (N, N_Package_Body, N_Package_Specification);
-
- begin
- case Nkind (N) is
- when N_Accept_Statement |
- N_Block_Statement |
- N_Entry_Body |
- N_Package_Body |
- N_Protected_Body |
- N_Subprogram_Body |
- N_Task_Body =>
- return Has_Controlled_Objects (Declarations (N), For_Pkg)
- or else
-
- -- An expanded sequence of statements may introduce
- -- controlled objects.
-
- (Present (Handled_Statement_Sequence (N))
- and then
- Has_Controlled_Objects
- (Statements (Handled_Statement_Sequence (N)), For_Pkg));
-
- when N_Package_Specification =>
- return Has_Controlled_Objects (Visible_Declarations (N), For_Pkg)
- or else
- Has_Controlled_Objects (Private_Declarations (N), For_Pkg);
-
- when others =>
- return False;
- end case;
- end Has_Controlled_Objects;
-
- ----------------------------
- -- Has_Controlled_Objects --
- ----------------------------
-
- function Has_Controlled_Objects
- (L : List_Id;
- For_Package : Boolean) return Boolean
- is
- Decl : Node_Id;
- Expr : Node_Id;
- Obj_Id : Entity_Id;
- Obj_Typ : Entity_Id;
- Pack_Id : Entity_Id;
- Typ : Entity_Id;
-
- begin
- if No (L)
- or else Is_Empty_List (L)
- then
- return False;
- end if;
-
- Decl := First (L);
- while Present (Decl) loop
-
- -- Regular object declarations
-
- if Nkind (Decl) = N_Object_Declaration then
- Obj_Id := Defining_Identifier (Decl);
- Obj_Typ := Base_Type (Etype (Obj_Id));
- Expr := Expression (Decl);
-
- -- Bypass any form of processing for objects which have their
- -- finalization disabled. This applies only to objects at the
- -- library level.
-
- if For_Package
- and then Finalize_Storage_Only (Obj_Typ)
- then
- null;
-
- -- Transient variables are treated separately in order to minimize
- -- the size of the generated code. See Exp_Ch7.Process_Transient_
- -- Objects.
-
- elsif Is_Processed_Transient (Obj_Id) then
- null;
-
- -- The object is of the form:
- -- Obj : Typ [:= Expr];
- --
- -- Do not process the incomplete view of a deferred constant
-
- 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))
- then
- return True;
-
- -- The object is of the form:
- -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
- --
- -- Obj : Access_Typ :=
- -- BIP_Function_Call
- -- (..., BIPaccess => null, ...)'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)))
- then
- return True;
-
- -- Simple protected objects which use type System.Tasking.
- -- Protected_Objects.Protection to manage their locks should be
- -- treated as controlled since they require manual cleanup.
-
- elsif Ekind (Obj_Id) = E_Variable
- and then
- (Is_Simple_Protected_Type (Obj_Typ)
- or else Has_Simple_Protected_Object (Obj_Typ))
- then
- return True;
- end if;
-
- -- 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
- Obj_Id := Defining_Identifier (Decl);
- Obj_Typ := Base_Type (Etype (Obj_Id));
-
- -- Bypass any form of processing for objects which have their
- -- finalization disabled. This applies only to objects at the
- -- library level.
-
- if For_Package
- and then Finalize_Storage_Only (Obj_Typ)
- then
- null;
-
- -- Return object of a build-in-place function. This case is
- -- recognized and marked by the expansion of an extended return
- -- statement (see Expand_N_Extended_Return_Statement).
-
- elsif Needs_Finalization (Obj_Typ)
- and then Is_Return_Object (Obj_Id)
- and then Present (Return_Flag (Obj_Id))
- then
- return True;
- end if;
-
- -- Inspect the freeze node of an access-to-controlled type and
- -- look for a delayed finalization collection. This case arises
- -- when the freeze actions are inserted at a later time than the
- -- expansion of the context. Since Build_Finalizer is never called
- -- on a single construct twice, the collection will be ultimately
- -- left out and never finalized. This is also needed for freeze
- -- actions of designated types themselves, since in some cases the
- -- finalization collection is associated with a designated type's
- -- freeze node rather than that of the access type (see handling
- -- for freeze actions in Build_Finalization_Collection).
-
- elsif Nkind (Decl) = N_Freeze_Entity
- and then Present (Actions (Decl))
- then
- Typ := Entity (Decl);
-
- if (Is_Access_Type (Typ)
- and then not Is_Access_Subprogram_Type (Typ)
- and then Needs_Finalization
- (Available_View (Designated_Type (Typ))))
- or else
- (Is_Type (Typ)
- and then Needs_Finalization (Typ))
- then
- return True;
- end if;
-
- -- Nested package declarations
-
- elsif Nkind (Decl) = N_Package_Declaration then
- Pack_Id := Defining_Unit_Name (Specification (Decl));
-
- if Nkind (Pack_Id) = N_Defining_Program_Unit_Name then
- Pack_Id := Defining_Identifier (Pack_Id);
- end if;
-
- if Ekind (Pack_Id) /= E_Generic_Package
- and then Has_Controlled_Objects (Specification (Decl))
- then
- return True;
- end if;
-
- -- Nested package bodies
-
- elsif Nkind (Decl) = N_Package_Body then
- Pack_Id := Corresponding_Spec (Decl);
-
- if Ekind (Pack_Id) /= E_Generic_Package
- and then Has_Controlled_Objects (Decl)
- then
+ begin
+ 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
return True;
end if;
- end if;
- Next (Decl);
- end loop;
+ Next_Discriminant (Disc);
+ end loop;
- return False;
- end Has_Controlled_Objects;
+ return False;
+ else
+ return False;
+ end if;
+ end Has_Access_Constraint;
----------------------------------
-- Has_Following_Address_Clause --
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;
N_Task_Body_Stub |
N_Task_Type_Declaration |
+ -- Use clauses can appear in lists of declarations
+
+ N_Use_Package_Clause |
+ N_Use_Type_Clause |
+
-- Freeze entity behaves like a declaration or statement
N_Freeze_Entity
-- 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
null;
end if;
+ -- A contract node should not belong to the tree
+
+ when N_Contract =>
+ raise Program_Error;
+
-- For all other node types, keep climbing tree
when
N_Formal_Ordinary_Fixed_Point_Definition |
N_Formal_Package_Declaration |
N_Formal_Private_Type_Definition |
+ N_Formal_Incomplete_Type_Definition |
N_Formal_Signed_Integer_Type_Definition |
N_Function_Call |
N_Function_Specification |
N_Push_Storage_Error_Label |
N_Qualified_Expression |
N_Quantified_Expression |
+ N_Raise_Expression |
N_Range |
N_Range_Constraint |
N_Real_Literal |
N_Unconstrained_Array_Definition |
N_Unused_At_End |
N_Unused_At_Start |
- N_Use_Package_Clause |
- N_Use_Type_Clause |
N_Variant |
N_Variant_Part |
N_Validate_Unchecked_Conversion |
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 --
------------------------------
(Decl : Node_Id;
Rel_Node : Node_Id) return Boolean
is
- Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
- Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
- Desig : Entity_Id := Obj_Typ;
- Has_Rens : Boolean := True;
- Ren_Obj : Entity_Id;
+ Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
+ Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
+ Desig : Entity_Id := Obj_Typ;
function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean;
-- Determine whether transient object Trans_Id is initialized either
-- value 1 and BIPaccess is not null. This case creates an aliasing
-- between the returned value and the value denoted by BIPaccess.
+ function Is_Aliased
+ (Trans_Id : Entity_Id;
+ First_Stmt : Node_Id) return Boolean;
+ -- Determine whether transient object Trans_Id has been renamed or
+ -- aliased through 'reference in the statement list starting from
+ -- First_Stmt.
+
function Is_Allocated (Trans_Id : Entity_Id) return Boolean;
-- Determine whether transient object Trans_Id is allocated on the heap
- function Is_Renamed
+ function Is_Iterated_Container
(Trans_Id : Entity_Id;
First_Stmt : Node_Id) return Boolean;
- -- Determine whether transient object Trans_Id has been renamed in the
- -- statement list starting from First_Stmt.
+ -- 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;
return False;
end Initialized_By_Aliased_BIP_Func_Call;
- ------------------
- -- Is_Allocated --
- ------------------
-
- function Is_Allocated (Trans_Id : Entity_Id) return Boolean is
- Expr : constant Node_Id := Expression (Parent (Trans_Id));
-
- begin
- return
- Is_Access_Type (Etype (Trans_Id))
- and then Present (Expr)
- and then Nkind (Expr) = N_Allocator;
- end Is_Allocated;
-
----------------
- -- Is_Renamed --
+ -- Is_Aliased --
----------------
- function Is_Renamed
+ function Is_Aliased
(Trans_Id : Entity_Id;
First_Stmt : Node_Id) return Boolean
is
- Stmt : Node_Id;
-
- function Extract_Renamed_Object
- (Ren_Decl : Node_Id) return Entity_Id;
+ function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id;
-- Given an object renaming declaration, retrieve the entity of the
-- renamed name. Return Empty if the renamed name is anything other
-- than a variable or a constant.
- ----------------------------
- -- Extract_Renamed_Object --
- ----------------------------
+ -------------------------
+ -- Find_Renamed_Object --
+ -------------------------
- function Extract_Renamed_Object
- (Ren_Decl : Node_Id) return Entity_Id
- is
- Change : Boolean;
- Ren_Obj : Node_Id;
+ function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id is
+ Ren_Obj : Node_Id := Empty;
- begin
- Change := True;
- Ren_Obj := Renamed_Object (Defining_Identifier (Ren_Decl));
+ function Find_Object (N : Node_Id) return Traverse_Result;
+ -- Try to detect an object which is either a constant or a
+ -- variable.
- while Change loop
- Change := False;
+ -----------------
+ -- Find_Object --
+ -----------------
- if Nkind_In (Ren_Obj, N_Explicit_Dereference,
- N_Indexed_Component,
- N_Selected_Component)
- then
- Ren_Obj := Prefix (Ren_Obj);
- Change := True;
+ function Find_Object (N : Node_Id) return Traverse_Result is
+ begin
+ -- Stop the search once a constant or a variable has been
+ -- detected.
- elsif Nkind_In (Ren_Obj, N_Type_Conversion,
- N_Unchecked_Type_Conversion)
+ if Nkind (N) = N_Identifier
+ and then Present (Entity (N))
+ and then Ekind_In (Entity (N), E_Constant, E_Variable)
then
- Ren_Obj := Expression (Ren_Obj);
- Change := True;
+ Ren_Obj := Entity (N);
+ return Abandon;
end if;
- end loop;
- if Nkind (Ren_Obj) in N_Has_Entity then
- return Entity (Ren_Obj);
- end if;
+ return OK;
+ end Find_Object;
- return Empty;
- end Extract_Renamed_Object;
+ procedure Search is new Traverse_Proc (Find_Object);
- -- Start of processing for Is_Renamed
+ -- Local variables
- begin
- -- If a previous invocation of this routine has determined that a
- -- list has no renamings, then no point in repeating the same scan.
+ Typ : constant Entity_Id := Etype (Defining_Identifier (Ren_Decl));
- if not Has_Rens then
- return False;
- end if;
+ -- Start of processing for Find_Renamed_Object
+
+ begin
+ -- Actions related to dispatching calls may appear as renamings of
+ -- tags. Do not process this type of renaming because it does not
+ -- use the actual value of the object.
+
+ if not Is_RTE (Typ, RE_Tag_Ptr) then
+ Search (Name (Ren_Decl));
+ end if;
+
+ return Ren_Obj;
+ end Find_Renamed_Object;
- -- Assume that the statement list does not have a renaming. This is a
- -- minor optimization.
+ -- Local variables
- Has_Rens := False;
+ Expr : Node_Id;
+ Ren_Obj : Entity_Id;
+ Stmt : Node_Id;
+ -- Start of processing for Is_Aliased
+
+ begin
Stmt := First_Stmt;
while Present (Stmt) loop
- if Nkind (Stmt) = N_Object_Renaming_Declaration then
- Has_Rens := True;
- Ren_Obj := Extract_Renamed_Object (Stmt);
+ if Nkind (Stmt) = N_Object_Declaration then
+ Expr := Expression (Stmt);
- if Present (Ren_Obj)
- and then Ren_Obj = Trans_Id
+ if Present (Expr)
+ and then Nkind (Expr) = N_Reference
+ and then Nkind (Prefix (Expr)) = N_Identifier
+ and then Entity (Prefix (Expr)) = Trans_Id
then
return True;
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
+ return True;
+ end if;
end if;
Next (Stmt);
end loop;
return False;
- end Is_Renamed;
+ end Is_Aliased;
+
+ ------------------
+ -- Is_Allocated --
+ ------------------
+
+ function Is_Allocated (Trans_Id : Entity_Id) return Boolean is
+ Expr : constant Node_Id := Expression (Parent (Trans_Id));
+ begin
+ return
+ Is_Access_Type (Etype (Trans_Id))
+ and then Present (Expr)
+ and then Nkind (Expr) = N_Allocator;
+ end Is_Allocated;
+
+ ---------------------------
+ -- Is_Iterated_Container --
+ ---------------------------
+
+ 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;
+
+ begin
+ -- It is not possible to iterate over containers in non-Ada 2012 code
+
+ if Ada_Version < Ada_2012 then
+ return False;
+ end if;
+
+ Typ := Etype (Trans_Id);
+
+ -- Handle access type created for secondary stack use
+
+ if Is_Access_Type (Typ) then
+ Typ := Designated_Type (Typ);
+ end if;
+
+ -- Look for aspect Default_Iterator
+
+ 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
and then Requires_Transient_Scope (Desig)
and then Nkind (Rel_Node) /= N_Simple_Return_Statement
- -- Do not consider transient objects allocated on the heap since they
- -- are attached to a finalization collection.
+ -- Do not consider renamed or 'reference-d transient objects because
+ -- the act of renaming extends the object's lifetime.
- and then not Is_Allocated (Obj_Id)
+ and then not Is_Aliased (Obj_Id, Decl)
- -- Do not consider renamed transient objects because the act of
- -- renaming extends the object's lifetime.
+ -- Do not consider transient objects allocated on the heap since
+ -- they are attached to a finalization master.
- and then not Is_Renamed (Obj_Id, Decl)
+ 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.
+ -- 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.
and then
(not Is_Access_Type (Obj_Typ)
or else not Initialized_By_Access (Obj_Id))
- -- Do not consider transient objects which act as indirect aliases of
- -- build-in-place function results.
+ -- Do not consider transient objects which act as indirect aliases
+ -- of build-in-place function results.
+
+ and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id)
+
+ -- Do not consider conversions of tags to class-wide types
+
+ 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 Initialized_By_Aliased_BIP_Func_Call (Obj_Id);
+ and then not Is_Iterated_Container (Obj_Id, Decl);
end Is_Finalizable_Transient;
---------------------------------
elsif Has_Discriminants (U) then
return False;
elsif not Has_Specified_Layout (U) then
- return False;
- end if;
-
- -- Here we have a tagged type, see if it has any unlayed out fields
- -- other than a possible tag and parent fields. If so, we return False.
-
- Comp := First_Component (U);
- while Present (Comp) loop
- if not Is_Tag (Comp)
- and then Chars (Comp) /= Name_uParent
- and then No (Component_Clause (Comp))
- then
- return False;
- else
- Next_Component (Comp);
- end if;
- end loop;
-
- -- All components are layed out
-
- return True;
- end Is_Fully_Repped_Tagged_Type;
-
- ----------------------------------
- -- Is_Library_Level_Tagged_Type --
- ----------------------------------
-
- 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);
- 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);
+ return False;
+ end if;
- -- 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.
+ -- Here we have a tagged type, see if it has any unlayed out fields
+ -- other than a possible tag and parent fields. If so, we return False.
- 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;
+ Comp := First_Component (U);
+ while Present (Comp) loop
+ if not Is_Tag (Comp)
+ and then Chars (Comp) /= Name_uParent
+ and then No (Component_Clause (Comp))
+ then
+ return False;
+ else
+ Next_Component (Comp);
+ end if;
+ end loop;
- -- A match for BIPaccess => null has been found
+ -- All components are layed out
- if Chars (Formal) = Access_Nam
- and then Nkind (Actual) = N_Null
- then
- return True;
- end if;
- end if;
+ return True;
+ end Is_Fully_Repped_Tagged_Type;
- Next (Param);
- end loop;
- end;
- end if;
+ ----------------------------------
+ -- Is_Library_Level_Tagged_Type --
+ ----------------------------------
- return False;
- end Is_Null_Access_BIP_Func_Call;
+ 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);
+ end Is_Library_Level_Tagged_Type;
--------------------------
-- Is_Non_BIP_Func_Call --
return True;
end if;
- -- Case of component reference
+ -- Case of indexed component reference: test whether prefix is unaligned
+
+ if Nkind (N) = N_Indexed_Component then
+ return Is_Possibly_Unaligned_Object (Prefix (N));
- if Nkind (N) = N_Selected_Component then
+ -- Case of selected component reference
+
+ elsif Nkind (N) = N_Selected_Component then
declare
P : constant Node_Id := Prefix (N);
C : constant Entity_Id := Entity (Selector_Name (N));
begin
-- If component reference is for an array with non-static bounds,
-- then it is always aligned: we can only process unaligned arrays
- -- with static bounds (more accurately bounds known at compile
- -- time).
+ -- with static bounds (more precisely compile time known bounds).
if Is_Array_Type (T)
and then not Compile_Time_Known_Bounds (T)
-- alignment, and we either know it is too small, or cannot tell,
-- then the component may be unaligned.
+ -- What is the following commented out code ???
+
-- if Known_Alignment (Etype (P))
-- and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment
-- and then M > Alignment (Etype (P))
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_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;
+
+ 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
+ return
+ Is_Class_Wide_Type (Etype (Obj_Id))
+ and then Present (Expr)
+ and then Nkind (Expr) = N_Unchecked_Type_Conversion
+ and then Etype (Expression (Expr)) = RTE (RE_Tag);
+ 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 ???
if Restriction_Active (No_Finalization) then
return False;
+ -- C, C++, CIL and Java types are not considered controlled. It is
+ -- assumed that the non-Ada side will handle their clean up.
+
+ elsif Convention (T) = Convention_C
+ or else Convention (T) = Convention_CIL
+ or else Convention (T) = Convention_CPP
+ or else Convention (T) = Convention_Java
+ then
+ return False;
+
else
-- Class-wide types are treated as controlled because derivations
-- from the root type can introduce controlled components.
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;
when N_Slice =>
return Possible_Bit_Aligned_Component (Prefix (N));
+ -- For an unchecked conversion, check whether the expression may
+ -- be bit-aligned.
+
+ when N_Unchecked_Type_Conversion =>
+ return Possible_Bit_Aligned_Component (Expression (N));
+
-- If we have none of the above, it means that we have fallen off the
-- top testing prefixes recursively, and we now have a stand alone
-- object, where we don't have a problem.
end case;
end Possible_Bit_Aligned_Component;
+ -----------------------------------------------
+ -- Process_Statements_For_Controlled_Objects --
+ -----------------------------------------------
+
+ procedure Process_Statements_For_Controlled_Objects (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+
+ function Are_Wrapped (L : List_Id) return Boolean;
+ -- Determine whether list L contains only one statement which is a block
+
+ function Wrap_Statements_In_Block (L : List_Id) return Node_Id;
+ -- Given a list of statements L, wrap it in a block statement and return
+ -- the generated node.
+
+ -----------------
+ -- Are_Wrapped --
+ -----------------
+
+ function Are_Wrapped (L : List_Id) return Boolean is
+ Stmt : constant Node_Id := First (L);
+ begin
+ return
+ Present (Stmt)
+ and then No (Next (Stmt))
+ and then Nkind (Stmt) = N_Block_Statement;
+ end Are_Wrapped;
+
+ ------------------------------
+ -- Wrap_Statements_In_Block --
+ ------------------------------
+
+ function Wrap_Statements_In_Block (L : List_Id) return Node_Id is
+ begin
+ return
+ Make_Block_Statement (Loc,
+ Declarations => No_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => L));
+ end Wrap_Statements_In_Block;
+
+ -- Local variables
+
+ Block : Node_Id;
+
+ -- Start of processing for Process_Statements_For_Controlled_Objects
+
+ begin
+ -- Whenever a non-handled statement list is wrapped in a block, the
+ -- block must be explicitly analyzed to redecorate all entities in the
+ -- list and ensure that a finalizer is properly built.
+
+ case Nkind (N) is
+ when N_Elsif_Part |
+ N_If_Statement |
+ N_Conditional_Entry_Call |
+ N_Selective_Accept =>
+
+ -- Check the "then statements" for elsif parts and if statements
+
+ if Nkind_In (N, N_Elsif_Part, N_If_Statement)
+ and then not Is_Empty_List (Then_Statements (N))
+ and then not Are_Wrapped (Then_Statements (N))
+ and then Requires_Cleanup_Actions
+ (Then_Statements (N), False, False)
+ then
+ Block := Wrap_Statements_In_Block (Then_Statements (N));
+ Set_Then_Statements (N, New_List (Block));
+
+ Analyze (Block);
+ end if;
+
+ -- Check the "else statements" for conditional entry calls, if
+ -- statements and selective accepts.
+
+ if Nkind_In (N, N_Conditional_Entry_Call,
+ N_If_Statement,
+ N_Selective_Accept)
+ and then not Is_Empty_List (Else_Statements (N))
+ and then not Are_Wrapped (Else_Statements (N))
+ and then Requires_Cleanup_Actions
+ (Else_Statements (N), False, False)
+ then
+ Block := Wrap_Statements_In_Block (Else_Statements (N));
+ Set_Else_Statements (N, New_List (Block));
+
+ Analyze (Block);
+ end if;
+
+ when N_Abortable_Part |
+ N_Accept_Alternative |
+ N_Case_Statement_Alternative |
+ N_Delay_Alternative |
+ N_Entry_Call_Alternative |
+ N_Exception_Handler |
+ N_Loop_Statement |
+ N_Triggering_Alternative =>
+
+ if not Is_Empty_List (Statements (N))
+ and then not Are_Wrapped (Statements (N))
+ and then Requires_Cleanup_Actions (Statements (N), False, False)
+ then
+ Block := Wrap_Statements_In_Block (Statements (N));
+ Set_Statements (N, New_List (Block));
+
+ Analyze (Block);
+ end if;
+
+ when others =>
+ null;
+ 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;
+ Ptr_Typ_Decl : Node_Id;
Ref_Type : Entity_Id;
Res : Node_Id;
- Ptr_Typ_Decl : Node_Id;
- New_Exp : Node_Id;
- E : Node_Id;
function Side_Effect_Free (N : Node_Id) return Boolean;
-- Determines if the tree N represents an expression that is known not
-- 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:
-
- -- If a loop bound is a subcomponent of a global variable, a
- -- modification of that variable within the loop may incorrectly
- -- affect the execution of the loop.
+ then
+ return False;
- elsif not
- (Nkind (Parent (Parent (N))) /= N_Loop_Parameter_Specification
- or else not Within_In_Parameter (Prefix (N)))
+ -- Note: The following test is the simplest way of solving a complex
+ -- problem uncovered by the following test (Side effect on loop bound
+ -- that is a subcomponent of a global variable:
+
+ -- with Text_Io; use Text_Io;
+ -- procedure Tloop is
+ -- type X is
+ -- record
+ -- V : Natural := 4;
+ -- S : String (1..5) := (others => 'a');
+ -- end record;
+ -- X1 : X;
+
+ -- procedure Modi;
+
+ -- generic
+ -- with procedure Action;
+ -- procedure Loop_G (Arg : X; Msg : String)
+
+ -- procedure Loop_G (Arg : X; Msg : String) is
+ -- begin
+ -- Put_Line ("begin loop_g " & Msg & " will loop till: "
+ -- & Natural'Image (Arg.V));
+ -- for Index in 1 .. Arg.V loop
+ -- Text_Io.Put_Line
+ -- (Natural'Image (Index) & " " & Arg.S (Index));
+ -- if Index > 2 then
+ -- Modi;
+ -- end if;
+ -- end loop;
+ -- Put_Line ("end loop_g " & Msg);
+ -- end;
+
+ -- procedure Loop1 is new Loop_G (Modi);
+ -- procedure Modi is
+ -- begin
+ -- X1.V := 1;
+ -- Loop1 (X1, "from modi");
+ -- end;
+ --
+ -- begin
+ -- Loop1 (X1, "initial");
+ -- end;
+
+ -- The output of the above program should be:
+
+ -- begin loop_g initial will loop till: 4
+ -- 1 a
+ -- 2 a
+ -- 3 a
+ -- begin loop_g from modi will loop till: 1
+ -- 1 a
+ -- end loop_g from modi
+ -- 4 a
+ -- begin loop_g from modi will loop till: 1
+ -- 1 a
+ -- end loop_g from modi
+ -- end loop_g initial
+
+ -- If a loop bound is a subcomponent of a global variable, a
+ -- modification of that variable within the loop may incorrectly
+ -- affect the execution of the loop.
+
+ elsif Nkind (Parent (Parent (N))) = N_Loop_Parameter_Specification
+ and then Within_In_Parameter (Prefix (N))
+ and then Variable_Ref
then
return False;
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
-- A binary operator is side effect free if and both operands are
-- side effect free. For this purpose binary operators include
- -- membership tests and short circuit forms
+ -- membership tests and short circuit forms.
when N_Binary_Op | N_Membership_Test | N_Short_Circuit =>
return Side_Effect_Free (Left_Opnd (N))
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;
if not Expander_Active then
return;
+ end if;
-- Cannot generate temporaries if the invocation to remove side effects
-- was issued too early and the type of the expression is not resolved
-- (this happens because routines Duplicate_Subexpr_XX implicitly invoke
-- Remove_Side_Effects).
- elsif No (Exp_Type)
+ if No (Exp_Type)
or else Ekind (Exp_Type) = E_Access_Attribute_Type
then
return;
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
-- This is relevant only in Ada 2005 mode. In Ada 95 programs we have
-- to accommodate functions returning limited objects by reference.
- if Nkind (Exp) = N_Function_Call
+ if Ada_Version >= Ada_2005
+ and then Nkind (Exp) = N_Function_Call
and then Is_Immutably_Limited_Type (Etype (Exp))
and then Nkind (Parent (Exp)) /= N_Object_Declaration
- and then Ada_Version >= Ada_2005
then
declare
Obj : constant Entity_Id := Make_Temporary (Loc, 'F', Exp);
Insert_Action (Exp, Decl);
Set_Etype (Obj, Exp_Type);
Rewrite (Exp, New_Occurrence_Of (Obj, Loc));
- return;
+ goto Leave;
end;
end if;
- Ref_Type := Make_Temporary (Loc, 'A');
+ Def_Id := Make_Temporary (Loc, 'R', Exp);
+ Set_Etype (Def_Id, Exp_Type);
+
+ -- 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.
- 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)));
+ if Alfa_Mode then
+ Res := New_Reference_To (Def_Id, Loc);
+ Ref_Type := Exp_Type;
- E := Exp;
- Insert_Action (Exp, Ptr_Typ_Decl);
+ -- Regular expansion utilizing an access type and 'reference
- Def_Id := Make_Temporary (Loc, 'R', Exp);
- Set_Etype (Def_Id, Exp_Type);
+ else
+ Res :=
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Reference_To (Def_Id, Loc));
- Res :=
- Make_Explicit_Dereference (Loc,
- Prefix => New_Reference_To (Def_Id, Loc));
+ -- Generate:
+ -- type Ann is access all <Exp_Type>;
+
+ 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)));
+
+ Insert_Action (Exp, Ptr_Typ_Decl);
+ end if;
+ E := Exp;
if Nkind (E) = N_Explicit_Dereference then
New_Exp := Relocate_Node (Prefix (E));
else
E := Relocate_Node (E);
- New_Exp := Make_Reference (Loc, E);
+
+ -- Do not generate a 'reference in Alfa mode since the access type
+ -- is not created in the first place.
+
+ if Alfa_Mode then
+ New_Exp := E;
+
+ -- Otherwise generate reference, marking the value as non-null
+ -- since we know it cannot be null and we don't want a check.
+
+ else
+ New_Exp := Make_Reference (Loc, E);
+ Set_Is_Known_Non_Null (Def_Id);
+ end if;
end if;
if Is_Delayed_Aggregate (E) 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;
+ 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
+ when N_Accept_Statement |
+ N_Block_Statement |
+ N_Entry_Body |
+ N_Package_Body |
+ N_Protected_Body |
+ N_Subprogram_Body |
+ N_Task_Body =>
+ return
+ 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)),
+ At_Lib_Level, True));
+
+ when N_Package_Specification =>
+ return
+ Requires_Cleanup_Actions
+ (Visible_Declarations (N), At_Lib_Level, True)
+ or else
+ Requires_Cleanup_Actions
+ (Private_Declarations (N), At_Lib_Level, True);
+
+ when others =>
+ return False;
+ end case;
+ end Requires_Cleanup_Actions;
+
+ ------------------------------
+ -- Requires_Cleanup_Actions --
+ ------------------------------
+
+ function Requires_Cleanup_Actions
+ (L : List_Id;
+ Lib_Level : Boolean;
+ Nested_Constructs : Boolean) return Boolean
+ is
+ Decl : Node_Id;
+ Expr : Node_Id;
+ Obj_Id : Entity_Id;
+ Obj_Typ : Entity_Id;
+ Pack_Id : Entity_Id;
+ Typ : Entity_Id;
+
+ begin
+ if No (L)
+ or else Is_Empty_List (L)
+ then
+ return False;
+ end if;
+
+ Decl := First (L);
+ while Present (Decl) loop
+
+ -- Library-level tagged types
+
+ if Nkind (Decl) = N_Full_Type_Declaration then
+ Typ := Defining_Identifier (Decl);
+
+ if Is_Tagged_Type (Typ)
+ and then Is_Library_Level_Entity (Typ)
+ and then Convention (Typ) = Convention_Ada
+ and then Present (Access_Disp_Table (Typ))
+ and then RTE_Available (RE_Unregister_Tag)
+ and then not No_Run_Time_Mode
+ and then not Is_Abstract_Type (Typ)
+ then
+ return True;
+ end if;
+
+ -- Regular object declarations
+
+ elsif Nkind (Decl) = N_Object_Declaration then
+ Obj_Id := Defining_Identifier (Decl);
+ Obj_Typ := Base_Type (Etype (Obj_Id));
+ Expr := Expression (Decl);
+
+ -- Bypass any form of processing for objects which have their
+ -- finalization disabled. This applies only to objects at the
+ -- library level.
+
+ if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
+ null;
+
+ -- Transient variables are treated separately in order to minimize
+ -- the size of the generated code. See Exp_Ch7.Process_Transient_
+ -- Objects.
+
+ elsif Is_Processed_Transient (Obj_Id) then
+ null;
+
+ -- The object is of the form:
+ -- Obj : Typ [:= Expr];
+ --
+ -- Do not process the incomplete view of a deferred constant. Do
+ -- not consider tag-to-class-wide conversions.
+
+ 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_Class_Wide_Conversion (Obj_Id)
+ then
+ return True;
+
+ -- The object is of the form:
+ -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
+ --
+ -- Obj : Access_Typ :=
+ -- 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_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;
+
+ -- Processing for "hook" objects generated for controlled
+ -- transients declared inside an Expression_With_Actions.
+
+ 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_Object_Declaration
+ and then Is_Finalizable_Transient
+ (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;
+
+ -- Simple protected objects which use type System.Tasking.
+ -- Protected_Objects.Protection to manage their locks should be
+ -- treated as controlled since they require manual cleanup.
+
+ elsif Ekind (Obj_Id) = E_Variable
+ and then
+ (Is_Simple_Protected_Type (Obj_Typ)
+ or else Has_Simple_Protected_Object (Obj_Typ))
+ then
+ return True;
+ end if;
+
+ -- Specific cases of object renamings
+
+ elsif Nkind (Decl) = N_Object_Renaming_Declaration then
+ Obj_Id := Defining_Identifier (Decl);
+ Obj_Typ := Base_Type (Etype (Obj_Id));
+
+ -- Bypass any form of processing for objects which have their
+ -- finalization disabled. This applies only to objects at the
+ -- library level.
+
+ if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
+ null;
+
+ -- Return object of a build-in-place function. This case is
+ -- recognized and marked by the expansion of an extended return
+ -- statement (see Expand_N_Extended_Return_Statement).
+
+ elsif Needs_Finalization (Obj_Typ)
+ and then Is_Return_Object (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
+ -- for a delayed finalization master. This case arises when the
+ -- freeze actions are inserted at a later time than the expansion of
+ -- the context. Since Build_Finalizer is never called on a single
+ -- construct twice, the master will be ultimately left out and never
+ -- finalized. This is also needed for freeze actions of designated
+ -- types themselves, since in some cases the finalization master is
+ -- associated with a designated type's freeze node rather than that
+ -- of the access type (see handling for freeze actions in
+ -- Build_Finalization_Master).
+
+ elsif Nkind (Decl) = N_Freeze_Entity
+ and then Present (Actions (Decl))
+ then
+ Typ := Entity (Decl);
+
+ if ((Is_Access_Type (Typ)
+ and then not Is_Access_Subprogram_Type (Typ)
+ and then Needs_Finalization
+ (Available_View (Designated_Type (Typ))))
+ or else
+ (Is_Type (Typ)
+ and then Needs_Finalization (Typ)))
+ and then Requires_Cleanup_Actions
+ (Actions (Decl), Lib_Level, Nested_Constructs)
+ then
+ return True;
+ end if;
+
+ -- Nested package declarations
+
+ elsif Nested_Constructs
+ and then Nkind (Decl) = N_Package_Declaration
+ then
+ Pack_Id := Defining_Unit_Name (Specification (Decl));
+
+ if Nkind (Pack_Id) = N_Defining_Program_Unit_Name then
+ Pack_Id := Defining_Identifier (Pack_Id);
+ end if;
+
+ if Ekind (Pack_Id) /= E_Generic_Package
+ 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
+ Pack_Id := Corresponding_Spec (Decl);
+
+ if Ekind (Pack_Id) /= E_Generic_Package
+ and then Requires_Cleanup_Actions (Decl, Lib_Level)
+ then
+ return True;
+ end if;
+ end if;
+
+ Next (Decl);
+ end loop;
+
+ return False;
+ end Requires_Cleanup_Actions;
+
------------------------------------
-- Safe_Unchecked_Type_Conversion --
------------------------------------
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
