+2008-08-22 Bob Duff <duff@adacore.com>
+
+ * exp_ch5.adb, exp_ch7.adb, exp_ch7.ads, exp_util.adb, freeze.adb,
+ exp_ch4.adb, exp_ch6.ads, exp_ch6.adb, sem_ch6.adb, exp_aggr.adb,
+ exp_intr.adb, exp_ch3.adb: Rename:
+ Exp_Ch7.Controlled_Type => Needs_Finalization
+ Exp_Ch7.CW_Or_Controlled_Type => CW_Or_Has_Controlled_Part
+ Exp_Ch5.Expand_N_Extended_Return_Statement.Controlled_Type =>
+ Has_Controlled_Parts
+ (Has_Some_Controlled_Component): Fix bug in array case.
+
2008-08-22 Robert Dewar <dewar@adacore.com>
* sem_ch8.adb: Minor reformatting
if Present (Flist) then
F := New_Copy_Tree (Flist);
- elsif Present (Etype (N)) and then Controlled_Type (Etype (N)) then
+ elsif Present (Etype (N)) and then Needs_Finalization (Etype (N)) then
if Is_Entity_Name (Into)
and then Present (Scope (Entity (Into)))
then
Expression => Make_Null (Loc)));
end if;
- if Controlled_Type (Ctype) then
+ if Needs_Finalization (Ctype) then
Append_List_To (L,
Make_Init_Call (
Ref => New_Copy_Tree (Indexed_Comp),
Name => Indexed_Comp,
Expression => New_Copy_Tree (Expr));
- if Present (Comp_Type) and then Controlled_Type (Comp_Type) then
+ if Present (Comp_Type) and then Needs_Finalization (Comp_Type) then
Set_No_Ctrl_Actions (A);
-- If this is an aggregate for an array of arrays, each
-- inner finalization actions).
if Present (Comp_Type)
- and then Controlled_Type (Comp_Type)
+ and then Needs_Finalization (Comp_Type)
and then not Is_Limited_Type (Comp_Type)
and then
(not Is_Array_Type (Comp_Type)
-- proper scope is the scope of the target rather than the
-- potentially transient current scope.
- if Controlled_Type (Typ) then
+ if Needs_Finalization (Typ) then
-- The current aggregate belongs to an allocator which creates
-- an object through an anonymous access type or acts as the root
-- Call Adjust manually
- if Controlled_Type (Etype (A))
+ if Needs_Finalization (Etype (A))
and then not Is_Limited_Type (Etype (A))
then
Append_List_To (Assign,
-- The controller is the one of the parent type defining the
-- component (in case of inherited components).
- if Controlled_Type (Comp_Type) then
+ if Needs_Finalization (Comp_Type) then
Internal_Final_List :=
Make_Selected_Component (Loc,
Prefix => Convert_To (
-- Attach_To_Final_List (tmp.comp,
-- comp_typ (tmp)._record_controller.f)
- if Controlled_Type (Comp_Type)
+ if Needs_Finalization (Comp_Type)
and then not Is_Limited_Type (Comp_Type)
then
Append_List_To (L,
or else Parent_Kind = N_Extension_Aggregate
or else Parent_Kind = N_Component_Association
or else (Parent_Kind = N_Object_Declaration
- and then Controlled_Type (Typ))
+ and then Needs_Finalization (Typ))
or else (Parent_Kind = N_Assignment_Statement
and then Inside_Init_Proc)
then
-- in any case no point in inlining such complex init procs.
if not Has_Task (Proc_Id)
- and then not Controlled_Type (Proc_Id)
+ and then not Needs_Finalization (Proc_Id)
then
Set_Is_Inlined (Proc_Id);
end if;
Name => New_Occurrence_Of (Proc, Loc),
Parameter_Associations => Args));
- if Controlled_Type (Typ)
+ if Needs_Finalization (Typ)
and then Nkind (Id_Ref) = N_Selected_Component
then
if Chars (Selector_Name (Id_Ref)) /= Name_uParent then
Kind := Nkind (Expression (N));
end if;
- if Controlled_Type (Typ)
+ if Needs_Finalization (Typ)
and then not (Kind = N_Aggregate or else Kind = N_Extension_Aggregate)
and then not Is_Inherently_Limited_Type (Typ)
then
if not Is_Concurrent_Type (Rec_Type)
and then not Has_Task (Rec_Type)
- and then not Controlled_Type (Rec_Type)
+ and then not Needs_Finalization (Rec_Type)
then
Set_Is_Inlined (Proc_Id);
end if;
-- Initialize call as it is required but one for each ancestor of
-- its type. This processing is suppressed if No_Initialization set.
- if not Controlled_Type (Typ)
+ if not Needs_Finalization (Typ)
or else No_Initialization (N)
then
null;
-- we plan to support in-place function results for some cases
-- of nonlimited types. ???)
- if Controlled_Type (Typ)
+ if Needs_Finalization (Typ)
and then not Is_Inherently_Limited_Type (Typ)
and then not BIP_Call
then
end if;
elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type
- and then Controlled_Type (Directly_Designated_Type (Comp_Typ))
+ and then Needs_Finalization (Directly_Designated_Type (Comp_Typ))
then
Set_Associated_Final_Chain (Comp_Typ, Add_Final_Chain (Typ));
end if;
Set_Has_Controlled_Component (Def_Id);
elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type
- and then Controlled_Type (Directly_Designated_Type (Comp_Typ))
+ and then Needs_Finalization (Directly_Designated_Type (Comp_Typ))
then
if No (Flist) then
Flist := Add_Final_Chain (Def_Id);
then
null;
- elsif (Controlled_Type (Desig_Type)
+ elsif (Needs_Finalization (Desig_Type)
and then Convention (Desig_Type) /= Convention_Java
and then Convention (Desig_Type) /= Convention_CIL)
or else
or else (Is_Array_Type (Desig_Type)
and then not Is_Frozen (Desig_Type)
- and then Controlled_Type (Component_Type (Desig_Type)))
+ and then Needs_Finalization (Component_Type (Desig_Type)))
-- The designated type has controlled anonymous access
-- discriminants.
null;
elsif Etype (Tag_Typ) = Tag_Typ
- or else Controlled_Type (Tag_Typ)
+ or else Needs_Finalization (Tag_Typ)
-- Ada 2005 (AI-251): We must also generate these subprograms if
-- the immediate ancestor is an interface to ensure the correct
-- Start of processing for Expand_Allocator_Expression
begin
- if Is_Tagged_Type (T) or else Controlled_Type (T) then
+ if Is_Tagged_Type (T) or else Needs_Finalization (T) then
-- Ada 2005 (AI-318-02): If the initialization expression is a call
-- to a build-in-place function, then access to the allocated object
Set_No_Initialization (Expression (Tmp_Node));
Insert_Action (N, Tmp_Node);
- if Controlled_Type (T)
+ if Needs_Finalization (T)
and then Ekind (PtrT) = E_Anonymous_Access_Type
then
-- Create local finalization list for access parameter
-- Inherit the final chain to ensure that the expansion of the
-- aggregate is correct in case of controlled types
- if Controlled_Type (Directly_Designated_Type (PtrT)) then
+ if Needs_Finalization (Directly_Designated_Type (PtrT)) then
Set_Associated_Final_Chain (Def_Id,
Associated_Final_Chain (PtrT));
end if;
Set_No_Initialization (Expression (Tmp_Node));
Insert_Action (N, Tmp_Node);
- if Controlled_Type (T)
+ if Needs_Finalization (T)
and then Ekind (PtrT) = E_Anonymous_Access_Type
then
-- Create local finalization list for access parameter
Insert_Action (N, Tag_Assign);
end if;
- if Controlled_Type (DesigT)
- and then Controlled_Type (T)
+ if Needs_Finalization (DesigT)
+ and then Needs_Finalization (T)
then
declare
Attach : Node_Id;
-- Normal case, not a secondary stack allocation
else
- if Controlled_Type (T)
+ if Needs_Finalization (T)
and then Ekind (PtrT) = E_Anonymous_Access_Type
then
-- Create local finalization list for access parameter
Parameter_Associations => Args));
end if;
- if Controlled_Type (T) then
+ if Needs_Finalization (T) then
-- Postpone the generation of a finalization call for the
-- current allocator if it acts as a coextension.
-- Cases where either Forwards_OK or Backwards_OK is true
if Forwards_OK (N) or else Backwards_OK (N) then
- if Controlled_Type (Component_Type (L_Type))
+ if Needs_Finalization (Component_Type (L_Type))
and then Base_Type (L_Type) = Base_Type (R_Type)
and then Ndim = 1
and then not No_Ctrl_Actions (N)
Right_Opnd => Cright_Lo);
end if;
- if Controlled_Type (Component_Type (L_Type))
+ if Needs_Finalization (Component_Type (L_Type))
and then Base_Type (L_Type) = Base_Type (R_Type)
and then Ndim = 1
and then not No_Ctrl_Actions (N)
return;
elsif Is_Tagged_Type (Typ)
- or else (Controlled_Type (Typ) and then not Is_Array_Type (Typ))
+ or else (Needs_Finalization (Typ) and then not Is_Array_Type (Typ))
then
Tagged_Case : declare
L : List_Id := No_List;
-- If no restrictions on aborts, protect the whole assignment
-- for controlled objects as per 9.8(11).
- if Controlled_Type (Typ)
+ if Needs_Finalization (Typ)
and then Expand_Ctrl_Actions
and then Abort_Allowed
then
Result : Node_Id;
Exp : Node_Id;
- function Controlled_Type (Typ : Entity_Id) return Boolean;
+ function Has_Controlled_Parts (Typ : Entity_Id) return Boolean;
-- Determine whether type Typ is controlled or contains a controlled
- -- component.
+ -- subcomponent.
function Move_Activation_Chain return Node_Id;
-- Construct a call to System.Tasking.Stages.Move_Activation_Chain
-- From finalization list of the return statement
-- To finalization list passed in by the caller
- ---------------------
- -- Controlled_Type --
- ---------------------
+ --------------------------
+ -- Has_Controlled_Parts --
+ --------------------------
- function Controlled_Type (Typ : Entity_Id) return Boolean is
+ function Has_Controlled_Parts (Typ : Entity_Id) return Boolean is
begin
return
Is_Controlled (Typ)
or else Has_Controlled_Component (Typ);
- end Controlled_Type;
+ end Has_Controlled_Parts;
---------------------------
-- Move_Activation_Chain --
if Is_Build_In_Place
and then
- (Controlled_Type (Parent_Function_Typ)
+ (Has_Controlled_Parts (Parent_Function_Typ)
or else (Is_Class_Wide_Type (Parent_Function_Typ)
and then
- Controlled_Type (Root_Type (Parent_Function_Typ)))
- or else Controlled_Type (Etype (Return_Object_Entity))
+ Has_Controlled_Parts (Root_Type (Parent_Function_Typ)))
+ or else Has_Controlled_Parts (Etype (Return_Object_Entity))
or else (Present (Exp)
- and then Controlled_Type (Etype (Exp))))
+ and then Has_Controlled_Parts (Etype (Exp))))
then
Append_To (Statements, Move_Final_List);
end if;
and then
(not Is_Array_Type (Exptyp)
or else Is_Constrained (Exptyp) = Is_Constrained (R_Type)
- or else CW_Or_Controlled_Type (Utyp))
+ or else CW_Or_Has_Controlled_Part (Utyp))
and then Nkind (Exp) = N_Function_Call
then
Set_By_Ref (N);
-- controlled (by the virtue of restriction No_Finalization) because
-- gigi is not able to properly allocate class-wide types.
- elsif CW_Or_Controlled_Type (Utyp) then
+ elsif CW_Or_Has_Controlled_Part (Utyp) then
declare
Loc : constant Source_Ptr := Sloc (N);
Temp : constant Entity_Id :=
L : constant Node_Id := Name (N);
T : constant Entity_Id := Underlying_Type (Etype (L));
- Ctrl_Act : constant Boolean := Controlled_Type (T)
+ Ctrl_Act : constant Boolean := Needs_Finalization (T)
and then not No_Ctrl_Actions (N);
Save_Tag : constant Boolean := Is_Tagged_Type (T)
Final_List_Actual : Node_Id;
Final_List_Formal : Node_Id;
Is_Ctrl_Result : constant Boolean :=
- Controlled_Type
+ Needs_Finalization
(Underlying_Type (Etype (Function_Id)));
begin
-- No such extra parameter is needed if there are no controlled parts.
- -- The test for Controlled_Type accounts for class-wide results (which
- -- potentially have controlled parts, even if the root type doesn't),
- -- and the test for a tagged result type is needed because calls to
- -- such a function can in general occur in dispatching contexts, which
- -- must be treated the same as a call to class-wide functions. Both of
- -- these situations require that a finalization list be passed.
-
- if not Is_Ctrl_Result
- and then not Is_Tagged_Type (Underlying_Type (Etype (Function_Id)))
- then
+ -- The test for Needs_Finalization accounts for class-wide results
+ -- (which potentially have controlled parts, even if the root type
+ -- doesn't), and the test for a tagged result type is needed because
+ -- calls to such a function can in general occur in dispatching
+ -- contexts, which must be treated the same as a call to class-wide
+ -- functions. Both of these situations require that a finalization list
+ -- be passed.
+
+ if not Needs_BIP_Final_List (Function_Id) then
return;
end if;
-- If the return type is limited the context is an initialization
-- and different processing applies.
- if Controlled_Type (Etype (Subp))
+ if Needs_Finalization (Etype (Subp))
and then not Is_Inherently_Limited_Type (Etype (Subp))
and then not Is_Limited_Interface (Etype (Subp))
then
elsif Is_Inherently_Limited_Type (Typ) then
Set_Returns_By_Ref (Spec_Id);
- elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then
+ elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
Set_Returns_By_Ref (Spec_Id);
end if;
end;
begin
if Is_Inherently_Limited_Type (Typ) then
Set_Returns_By_Ref (Subp);
- elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then
+ elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
Set_Returns_By_Ref (Subp);
end if;
end;
end if;
end Make_Build_In_Place_Call_In_Object_Declaration;
+ function Needs_BIP_Final_List (E : Entity_Id) return Boolean is
+ pragma Assert (Is_Build_In_Place_Function (E));
+ Result_Subt : constant Entity_Id := Underlying_Type (Etype (E));
+ begin
+ -- We need the BIP_Final_List if the result type needs finalization. We
+ -- also need it for tagged types, even if not class-wide, because some
+ -- type extension might need finalization, and all overriding functions
+ -- must have the same calling conventions. However, if there is a
+ -- pragma Restrictions (No_Finalization), we never need this parameter.
+
+ return (Needs_Finalization (Result_Subt)
+ or else Is_Tagged_Type (Underlying_Type (Result_Subt)))
+ and then not Restriction_Active (No_Finalization);
+ end Needs_BIP_Final_List;
+
end Exp_Ch6;
-- for which Is_Build_In_Place_Call is True, or an N_Qualified_Expression
-- node applied to such a function call.
+ function Needs_BIP_Final_List (E : Entity_Id) return Boolean;
+ pragma Precondition (Is_Build_In_Place_Function (E));
+ -- Ada 2005 (AI-318-02): Returns True if the function needs the
+ -- BIP_Final_List implicit parameter.
+
end Exp_Ch6;
end if;
end Check_Visibly_Controlled;
- ---------------------
- -- Controlled_Type --
- ---------------------
+ ------------------------
+ -- Needs_Finalization --
+ ------------------------
- function Controlled_Type (T : Entity_Id) return Boolean is
+ function Needs_Finalization (T : Entity_Id) return Boolean is
function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean;
-- If type is not frozen yet, check explicitly among its components,
while Present (Comp) loop
if not Is_Type (Comp)
- and then Controlled_Type (Etype (Comp))
+ and then Needs_Finalization (Etype (Comp))
then
return True;
end if;
return False;
elsif Is_Array_Type (Rec) then
- return Is_Controlled (Component_Type (Rec));
+ return Needs_Finalization (Component_Type (Rec));
else
return Has_Controlled_Component (Rec);
end if;
end Has_Some_Controlled_Component;
- -- Start of processing for Controlled_Type
+ -- Start of processing for Needs_Finalization
begin
-- Class-wide types must be treated as controlled because they may
or else Is_Controlled (T)
or else Has_Some_Controlled_Component (T)
or else (Is_Concurrent_Type (T)
- and then Present (Corresponding_Record_Type (T))
- and then Controlled_Type (Corresponding_Record_Type (T)));
- end Controlled_Type;
+ and then Present (Corresponding_Record_Type (T))
+ and then Needs_Finalization (Corresponding_Record_Type (T)));
+ end Needs_Finalization;
- ---------------------------
- -- CW_Or_Controlled_Type --
- ---------------------------
+ -------------------------------
+ -- CW_Or_Has_Controlled_Part --
+ -------------------------------
- function CW_Or_Controlled_Type (T : Entity_Id) return Boolean is
+ function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is
begin
- return Is_Class_Wide_Type (T) or else Controlled_Type (T);
- end CW_Or_Controlled_Type;
+ return Is_Class_Wide_Type (T) or else Needs_Finalization (T);
+ end CW_Or_Has_Controlled_Part;
--------------------------
-- Controller_Component --
null;
elsif Scope (Original_Record_Component (Comp)) = E
- and then Controlled_Type (Etype (Comp))
+ and then Needs_Finalization (Etype (Comp))
then
return True;
end if;
-- and the actual should be finalized on return from the call ???
if Nkind (N) = N_Object_Renaming_Declaration
- and then Controlled_Type (Etype (Defining_Identifier (N)))
+ and then Needs_Finalization (Etype (Defining_Identifier (N)))
then
null;
N_Selected_Component,
N_Indexed_Component)
and then
- Controlled_Type
+ Needs_Finalization
(Etype (Prefix (Renamed_Object (Defining_Identifier (N)))))
then
null;
function Controller_Component (Typ : Entity_Id) return Entity_Id;
-- Returns the entity of the component whose name is 'Name_uController'
- function Controlled_Type (T : Entity_Id) return Boolean;
- -- True if T potentially needs finalization actions
-
- function CW_Or_Controlled_Type (T : Entity_Id) return Boolean;
- -- True if T is either a potentially controlled type or a class-wide type.
- -- Note that in normal mode, class-wide types are potentially controlled so
- -- this function is different from Controlled_Type only under restrictions
- -- No_Finalization.
+ function Needs_Finalization (T : Entity_Id) return Boolean;
+ -- True if T potentially needs finalization actions. True if T is
+ -- controlled, or has subcomponents. Also True if T is a class-wide type,
+ -- because some type extension might add controlled subcomponents, except
+ -- that if pragma Restrictions (No_Finalization) applies, this is False for
+ -- class-wide types.
+
+ function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean;
+ -- True if T is a class-wide type, or if it has controlled parts ("part"
+ -- means T or any of its subcomponents). This is the same as
+ -- Needs_Finalization, except when pragma Restrictions (No_Finalization)
+ -- applies, in which case we know that class-wide objects do not contain
+ -- controlled parts.
function Find_Final_List
(E : Entity_Id;
-- Processing for pointer to controlled type
- if Controlled_Type (Desig_T) then
+ if Needs_Finalization (Desig_T) then
Deref :=
Make_Explicit_Dereference (Loc,
Prefix => Duplicate_Subexpr_No_Checks (Arg));
elsif Nkind (Exp) = N_Unchecked_Type_Conversion
and then not Safe_Unchecked_Type_Conversion (Exp)
then
- if CW_Or_Controlled_Type (Exp_Type) then
+ if CW_Or_Has_Controlled_Part (Exp_Type) then
-- Use a renaming to capture the expression, rather than create
-- a controlled temporary.
-- the address expression must be a constant.
if (No (Expression (Decl))
- and then not Controlled_Type (Typ)
+ and then not Needs_Finalization (Typ)
and then
(not Has_Non_Null_Base_Init_Proc (Typ)
or else Is_Imported (E)))
end if;
if not Error_Posted (Expr)
- and then not Controlled_Type (Typ)
+ and then not Needs_Finalization (Typ)
then
Warn_Overlay (Expr, Typ, Name (Addr));
end if;
elsif Is_Access_Type (E)
and then Comes_From_Source (E)
and then Ekind (Directly_Designated_Type (E)) = E_Incomplete_Type
- and then Controlled_Type (Designated_Type (E))
+ and then Needs_Finalization (Designated_Type (E))
and then No (Associated_Final_Chain (E))
then
Build_Final_List (Parent (E), E);
-- actions interfere in complex ways with inlining.
elsif Ekind (Subp) = E_Function
- and then Controlled_Type (Etype (Subp))
+ and then Needs_Finalization (Etype (Subp))
then
Cannot_Inline
("cannot inline & (controlled return type)?", N, Subp);
if Is_Inherently_Limited_Type (Typ) then
Set_Returns_By_Ref (Designator);
- elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then
+ elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
Set_Returns_By_Ref (Designator);
end if;
end;
-- returns. This is true even if we are able to get away with
-- having 'in out' parameters, which are normally illegal for
-- functions. This formal is also needed when the function has
- -- a tagged result, because generally such functions can be called
- -- in a dispatching context and such calls must be handled like
- -- calls to class-wide functions.
+ -- a tagged result.
- if Controlled_Type (Result_Subt)
- or else Is_Tagged_Type (Underlying_Type (Result_Subt))
- then
+ if Needs_BIP_Final_List (E) then
Discard :=
Add_Extra_Formal
(E, RTE (RE_Finalizable_Ptr_Ptr),
projects / thirdparty / gcc.git / commitdiff
