Commit afe4375b by Ed Schonberg Committed by Arnaud Charlet

exp_ch7.ads, [...] (Find_Final_List): If the access type is anonymous, use…

exp_ch7.ads, [...] (Find_Final_List): If the access type is anonymous, use finalization list of enclosing dynamic scope.

2007-04-06  Ed Schonberg  <schonberg@adacore.com>
	    Bob Duff  <duff@adacore.com>
	    Cyrille Comar  <comar@adacore.com>

	* exp_ch7.ads, exp_ch7.adb (Find_Final_List): If the access type is
	anonymous, use finalization list of enclosing dynamic scope.
	(Expand_N_Package_Declaration): For a library package declaration
	without a corresponding body, generate RACW subprogram bodies in the
	spec (just as we do for the task activation call).
	(Convert_View): Split Is_Abstract flag into Is_Abstract_Subprogram and
	Is_Abstract_Type. Make sure these are called only when appropriate.
	Remove all code for DSP option
	(CW_Or_Controlled_Type): new subprogram.

From-SVN: r123563
parent dee4682a
...@@ -35,9 +35,11 @@ with Errout; use Errout; ...@@ -35,9 +35,11 @@ with Errout; use Errout;
with Exp_Ch9; use Exp_Ch9; with Exp_Ch9; use Exp_Ch9;
with Exp_Ch11; use Exp_Ch11; with Exp_Ch11; use Exp_Ch11;
with Exp_Dbug; use Exp_Dbug; with Exp_Dbug; use Exp_Dbug;
with Exp_Dist; use Exp_Dist;
with Exp_Tss; use Exp_Tss; with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util; with Exp_Util; use Exp_Util;
with Freeze; use Freeze; with Freeze; use Freeze;
with Lib; use Lib;
with Hostparm; use Hostparm; with Hostparm; use Hostparm;
with Nlists; use Nlists; with Nlists; use Nlists;
with Nmake; use Nmake; with Nmake; use Nmake;
...@@ -46,7 +48,6 @@ with Output; use Output; ...@@ -46,7 +48,6 @@ with Output; use Output;
with Restrict; use Restrict; with Restrict; use Restrict;
with Rident; use Rident; with Rident; use Rident;
with Rtsfind; use Rtsfind; with Rtsfind; use Rtsfind;
with Targparm; use Targparm;
with Sinfo; use Sinfo; with Sinfo; use Sinfo;
with Sem; use Sem; with Sem; use Sem;
with Sem_Ch3; use Sem_Ch3; with Sem_Ch3; use Sem_Ch3;
...@@ -900,6 +901,15 @@ package body Exp_Ch7 is ...@@ -900,6 +901,15 @@ package body Exp_Ch7 is
and then Controlled_Type (Corresponding_Record_Type (T))); and then Controlled_Type (Corresponding_Record_Type (T)));
end Controlled_Type; end Controlled_Type;
---------------------------
-- CW_Or_Controlled_Type --
---------------------------
function CW_Or_Controlled_Type (T : Entity_Id) return Boolean is
begin
return Is_Class_Wide_Type (T) or else Controlled_Type (T);
end CW_Or_Controlled_Type;
-------------------------- --------------------------
-- Controller_Component -- -- Controller_Component --
-------------------------- --------------------------
...@@ -977,7 +987,7 @@ package body Exp_Ch7 is ...@@ -977,7 +987,7 @@ package body Exp_Ch7 is
Atyp := Etype (Arg); Atyp := Etype (Arg);
end if; end if;
if Is_Abstract (Proc) and then Is_Tagged_Type (Ftyp) then if Is_Abstract_Subprogram (Proc) and then Is_Tagged_Type (Ftyp) then
return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg); return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg);
elsif Ftyp /= Atyp elsif Ftyp /= Atyp
...@@ -1020,17 +1030,12 @@ package body Exp_Ch7 is ...@@ -1020,17 +1030,12 @@ package body Exp_Ch7 is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Wrap_Node : Node_Id; Wrap_Node : Node_Id;
Sec_Stk : constant Boolean :=
Sec_Stack and not Functions_Return_By_DSP_On_Target;
-- We never need a secondary stack if functions return by DSP
begin begin
-- Do not create a transient scope if we are already inside one -- Do not create a transient scope if we are already inside one
for S in reverse Scope_Stack.First .. Scope_Stack.Last loop for S in reverse Scope_Stack.First .. Scope_Stack.Last loop
if Scope_Stack.Table (S).Is_Transient then if Scope_Stack.Table (S).Is_Transient then
if Sec_Stk then if Sec_Stack then
Set_Uses_Sec_Stack (Scope_Stack.Table (S).Entity); Set_Uses_Sec_Stack (Scope_Stack.Table (S).Entity);
end if; end if;
...@@ -1064,7 +1069,7 @@ package body Exp_Ch7 is ...@@ -1064,7 +1069,7 @@ package body Exp_Ch7 is
New_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B')); New_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'));
Set_Scope_Is_Transient; Set_Scope_Is_Transient;
if Sec_Stk then if Sec_Stack then
Set_Uses_Sec_Stack (Current_Scope); Set_Uses_Sec_Stack (Current_Scope);
Check_Restriction (No_Secondary_Stack, N); Check_Restriction (No_Secondary_Stack, N);
end if; end if;
...@@ -1546,12 +1551,12 @@ package body Exp_Ch7 is ...@@ -1546,12 +1551,12 @@ package body Exp_Ch7 is
-- Expand_N_Package_Body -- -- Expand_N_Package_Body --
--------------------------- ---------------------------
-- Add call to Activate_Tasks if body is an activator (actual -- Add call to Activate_Tasks if body is an activator (actual processing
-- processing is in chapter 9). -- is in chapter 9).
-- Generate subprogram descriptor for elaboration routine -- Generate subprogram descriptor for elaboration routine
-- ENcode entity names in package body -- Encode entity names in package body
procedure Expand_N_Package_Body (N : Node_Id) is procedure Expand_N_Package_Body (N : Node_Id) is
Ent : constant Entity_Id := Corresponding_Spec (N); Ent : constant Entity_Id := Corresponding_Spec (N);
...@@ -1583,14 +1588,76 @@ package body Exp_Ch7 is ...@@ -1583,14 +1588,76 @@ package body Exp_Ch7 is
-- whether a body will eventually appear. -- whether a body will eventually appear.
procedure Expand_N_Package_Declaration (N : Node_Id) is procedure Expand_N_Package_Declaration (N : Node_Id) is
Spec : constant Node_Id := Specification (N);
Decls : List_Id;
No_Body : Boolean;
-- True in the case of a package declaration that is a compilation unit
-- and for which no associated body will be compiled in
-- this compilation.
begin begin
if Nkind (Parent (N)) = N_Compilation_Unit
and then not Body_Required (Parent (N)) No_Body := False;
-- Case of a package declaration other than a compilation unit
if Nkind (Parent (N)) /= N_Compilation_Unit then
null;
-- Case of a compilation unit that does not require a body
elsif not Body_Required (Parent (N))
and then not Unit_Requires_Body (Defining_Entity (N)) and then not Unit_Requires_Body (Defining_Entity (N))
and then Present (Activation_Chain_Entity (N))
then then
No_Body := True;
-- Special case of generating calling stubs for a remote call interface
-- package: even though the package declaration requires one, the
-- body won't be processed in this compilation (so any stubs for RACWs
-- declared in the package must be generated here, along with the
-- spec).
elsif Parent (N) = Cunit (Main_Unit)
and then Is_Remote_Call_Interface (Defining_Entity (N))
and then Distribution_Stub_Mode = Generate_Caller_Stub_Body
then
No_Body := True;
end if;
-- For a package declaration that implies no associated body, generate
-- task activation call and RACW supporting bodies now (since we won't
-- have a specific separate compilation unit for that).
if No_Body then
New_Scope (Defining_Entity (N)); New_Scope (Defining_Entity (N));
if Has_RACW (Defining_Entity (N)) then
-- Generate RACW subprogram bodies
Decls := Private_Declarations (Spec);
if No (Decls) then
Decls := Visible_Declarations (Spec);
end if;
if No (Decls) then
Decls := New_List;
Set_Visible_Declarations (Spec, Decls);
end if;
Append_RACW_Bodies (Decls, Defining_Entity (N));
Analyze_List (Decls);
end if;
if Present (Activation_Chain_Entity (N)) then
-- Generate task activation call as last step of elaboration
Build_Task_Activation_Call (N); Build_Task_Activation_Call (N);
end if;
Pop_Scope; Pop_Scope;
end if; end if;
...@@ -1652,12 +1719,18 @@ package body Exp_Ch7 is ...@@ -1652,12 +1719,18 @@ package body Exp_Ch7 is
Selector_Name => Make_Identifier (Loc, Name_F)); Selector_Name => Make_Identifier (Loc, Name_F));
-- Case of a dynamically allocated object. The final list is the -- Case of a dynamically allocated object. The final list is the
-- corresponding list controller (The next entity in the scope of -- corresponding list controller (the next entity in the scope of the
-- the access type with the right type). If the type comes from a -- access type with the right type). If the type comes from a With_Type
-- With_Type clause, no controller was created, and we use the -- clause, no controller was created, we use the global chain instead.
-- global chain instead.
elsif Is_Access_Type (E) then -- An anonymous access type either has a list created for it when the
-- allocator is a for an access parameter or an access discriminant,
-- or else it uses the list of the enclosing dynamic scope, when the
-- context is a declaration or an assignment.
elsif Is_Access_Type (E)
and then Ekind (E) /= E_Anonymous_Access_Type
then
if not From_With_Type (E) then if not From_With_Type (E) then
return return
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
...@@ -2589,7 +2662,7 @@ package body Exp_Ch7 is ...@@ -2589,7 +2662,7 @@ package body Exp_Ch7 is
if Prim = Finalize_Case or else Prim = Adjust_Case then if Prim = Finalize_Case or else Prim = Adjust_Case then
Handler := New_List ( Handler := New_List (
Make_Exception_Handler (Loc, Make_Implicit_Exception_Handler (Loc,
Exception_Choices => New_List (Make_Others_Choice (Loc)), Exception_Choices => New_List (Make_Others_Choice (Loc)),
Statements => New_List ( Statements => New_List (
Make_Raise_Program_Error (Loc, Make_Raise_Program_Error (Loc,
...@@ -3025,11 +3098,9 @@ package body Exp_Ch7 is ...@@ -3025,11 +3098,9 @@ package body Exp_Ch7 is
Set_Uses_Sec_Stack (Current_Scope, False); Set_Uses_Sec_Stack (Current_Scope, False);
if not Requires_Transient_Scope (Etype (S)) then if not Requires_Transient_Scope (Etype (S)) then
if not Functions_Return_By_DSP_On_Target then
Set_Uses_Sec_Stack (S, True); Set_Uses_Sec_Stack (S, True);
Check_Restriction (No_Secondary_Stack, Action); Check_Restriction (No_Secondary_Stack, Action);
end if; end if;
end if;
exit; exit;
...@@ -3046,11 +3117,8 @@ package body Exp_Ch7 is ...@@ -3046,11 +3117,8 @@ package body Exp_Ch7 is
elsif K = E_Procedure elsif K = E_Procedure
or else K = E_Block or else K = E_Block
then then
if not Functions_Return_By_DSP_On_Target then
Set_Uses_Sec_Stack (S, True); Set_Uses_Sec_Stack (S, True);
Check_Restriction (No_Secondary_Stack, Action); Check_Restriction (No_Secondary_Stack, Action);
end if;
Set_Uses_Sec_Stack (Current_Scope, False); Set_Uses_Sec_Stack (Current_Scope, False);
exit; exit;
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -60,15 +60,21 @@ package Exp_Ch7 is ...@@ -60,15 +60,21 @@ package Exp_Ch7 is
function Controlled_Type (T : Entity_Id) return Boolean; function Controlled_Type (T : Entity_Id) return Boolean;
-- True if T potentially needs finalization actions -- 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 Find_Final_List function Find_Final_List
(E : Entity_Id; (E : Entity_Id;
Ref : Node_Id := Empty) return Node_Id; Ref : Node_Id := Empty) return Node_Id;
-- E is an entity representing a controlled object, a controlled type -- E is an entity representing a controlled object, a controlled type or a
-- or a scope. If Ref is not empty, it is a reference to a controlled -- scope. If Ref is not empty, it is a reference to a controlled record,
-- record, the closest Final list is in the controller component of -- the closest Final list is in the controller component of the record
-- the record containing Ref otherwise this function returns a -- containing Ref otherwise this function returns a reference to the final
-- reference to the final list attached to the closest dynamic scope -- list attached to the closest dynamic scope (that can be E itself)
-- (that can be E itself) creating this final list if necessary. -- creating this final list if necessary.
function Has_New_Controlled_Component (E : Entity_Id) return Boolean; function Has_New_Controlled_Component (E : Entity_Id) return Boolean;
-- E is a type entity. Give the same resul as Has_Controlled_Component -- E is a type entity. Give the same resul as Has_Controlled_Component
...@@ -79,30 +85,28 @@ package Exp_Ch7 is ...@@ -79,30 +85,28 @@ package Exp_Ch7 is
(Obj_Ref : Node_Id; (Obj_Ref : Node_Id;
Flist_Ref : Node_Id; Flist_Ref : Node_Id;
With_Attach : Node_Id) return Node_Id; With_Attach : Node_Id) return Node_Id;
-- Attach the referenced object to the referenced Final Chain -- Attach the referenced object to the referenced Final Chain 'Flist_Ref'
-- 'Flist_Ref' With_Attach is an expression of type Short_Short_Integer -- With_Attach is an expression of type Short_Short_Integer which can be
-- which can be either '0' to signify no attachment, '1' for -- either '0' to signify no attachment, '1' for attachement to a simply
-- attachement to a simply linked list or '2' for attachement to a -- linked list or '2' for attachement to a doubly linked list.
-- doubly linked list.
function Make_Init_Call function Make_Init_Call
(Ref : Node_Id; (Ref : Node_Id;
Typ : Entity_Id; Typ : Entity_Id;
Flist_Ref : Node_Id; Flist_Ref : Node_Id;
With_Attach : Node_Id) return List_Id; With_Attach : Node_Id) return List_Id;
-- Ref is an expression (with no-side effect and is not required to -- Ref is an expression (with no-side effect and is not required to have
-- have been previously analyzed) that references the object to be -- been previously analyzed) that references the object to be initialized.
-- initialized. Typ is the expected type of Ref, which is a controlled -- Typ is the expected type of Ref, which is either a controlled type
-- type (Is_Controlled) or a type with controlled components -- (Is_Controlled) or a type with controlled components (Has_Controlled).
-- (Has_Controlled). With_Attach is an integer expression representing -- With_Attach is an integer expression which is the attchment level,
-- the level of attachment, see Attach_To_Final_List's Nb_Link param -- see System.Finalization_Implementation.Attach_To_Final_List for the
-- documentation in s-finimp.ads. -- documentation of Nb_Link.
-- --
-- This function will generate the appropriate calls to make -- This function will generate the appropriate calls to make sure that the
-- sure that the objects referenced by Ref are initialized. The -- objects referenced by Ref are initialized. The generated code is quite
-- generate code is quite different depending on the fact the type -- different for an IS_Controlled type or a HAS_Controlled type, but this
-- IS_Controlled or HAS_Controlled but this is not the problem of the -- is not the problem for the caller, the details are in the body.
-- caller, the details are in the body.
function Make_Adjust_Call function Make_Adjust_Call
(Ref : Node_Id; (Ref : Node_Id;
...@@ -110,23 +114,23 @@ package Exp_Ch7 is ...@@ -110,23 +114,23 @@ package Exp_Ch7 is
Flist_Ref : Node_Id; Flist_Ref : Node_Id;
With_Attach : Node_Id; With_Attach : Node_Id;
Allocator : Boolean := False) return List_Id; Allocator : Boolean := False) return List_Id;
-- Ref is an expression (with no-side effect and is not required to -- Ref is an expression (with no-side effect and is not required to have
-- have been previously analyzed) that references the object to be -- been previously analyzed) that references the object to be adjusted. Typ
-- adjusted. Typ is the expected type of Ref, which is a controlled -- is the expected type of Ref, which is a controlled type (Is_Controlled)
-- type (Is_Controlled) or a type with controlled components -- or a type with controlled components (Has_Controlled). With_Attach is an
-- (Has_Controlled). With_Attach is an integer expression representing -- integer expression giving the attachment level (see documentation of
-- the level of attachment, see Attach_To_Final_List's Nb_Link param -- Attach_To_Final_List.Nb_Link param documentation in s-finimp.ads.
-- documentation in s-finimp.ads. Note: if Typ is Finalize_Storage_Only -- Note: if Typ is Finalize_Storage_Only and the object is at library
-- and the object is at library level, then With_Attach will be ignored, -- level, then With_Attach will be ignored, and a zero link level will be
-- and a zero link level will be passed to Attach_To_Final_List. -- passed to Attach_To_Final_List.
-- --
-- This function will generate the appropriate calls to make -- This function will generate the appropriate calls to make sure that the
-- sure that the objects referenced by Ref are adjusted. The generated -- objects referenced by Ref are adjusted. The generated code is quite
-- code is quite different depending on the fact the type IS_Controlled -- different depending on the fact the type IS_Controlled or HAS_Controlled
-- or HAS_Controlled but this is not the problem of the caller, the -- but this is not the problem of the caller, the details are in the body.
-- details are in the body. The objects must be attached when the adjust -- The objects must be attached when the adjust takes place after an
-- takes place after an initialization expression but not when it takes -- initialization expression but not when it takes place after a regular
-- place after a regular assignment. -- assignment.
-- --
-- If Allocator is True, we are adjusting a newly-created object. The -- If Allocator is True, we are adjusting a newly-created object. The
-- existing chaining pointers should not be left unchanged, because they -- existing chaining pointers should not be left unchanged, because they
...@@ -138,21 +142,21 @@ package Exp_Ch7 is ...@@ -138,21 +142,21 @@ package Exp_Ch7 is
(Ref : Node_Id; (Ref : Node_Id;
Typ : Entity_Id; Typ : Entity_Id;
With_Detach : Node_Id) return List_Id; With_Detach : Node_Id) return List_Id;
-- Ref is an expression (with no-side effect and is not required -- Ref is an expression (with no-side effect and is not required to have
-- to have been previously analyzed) that references the object to -- been previously analyzed) that references the object to be Finalized.
-- be Finalized. Typ is the expected type of Ref, which is a -- Typ is the expected type of Ref, which is a controlled type
-- controlled type (Is_Controlled) or a type with controlled -- (Is_Controlled) or a type with controlled components (Has_Controlled).
-- components (Has_Controlled). With_Detach is a boolean expression -- With_Detach is a boolean expression indicating whether to detach the
-- indicating whether to detach the controlled object from whatever -- controlled object from whatever finalization list it is currently
-- finalization list it is currently attached to. -- attached to.
-- --
-- This function will generate the appropriate calls to make -- This function will generate the appropriate calls to make sure that the
-- sure that the objects referenced by Ref are finalized. The generated -- objects referenced by Ref are finalized. The generated code is quite
-- code is quite different depending on the fact the type IS_Controlled -- different depending on the fact the type IS_Controlled or HAS_Controlled
-- or HAS_Controlled but this is not the problem of the caller, the -- but this is not the problem of the caller, the details are in the body.
-- details are in the body. The objects must be detached when finalizing -- The objects must be detached when finalizing an unchecked deallocated
-- an unchecked deallocated object but not when finalizing the target of -- object but not when finalizing the target of an assignment, it is not
-- an assignment, it is not necessary either on scope exit. -- necessary either on scope exit.
procedure Expand_Ctrl_Function_Call (N : Node_Id); procedure Expand_Ctrl_Function_Call (N : Node_Id);
-- Expand a call to a function returning a controlled value. That is to -- Expand a call to a function returning a controlled value. That is to
...@@ -167,8 +171,8 @@ package Exp_Ch7 is ...@@ -167,8 +171,8 @@ package Exp_Ch7 is
(N : Node_Id; (N : Node_Id;
Obj : Node_Id; Obj : Node_Id;
Typ : Entity_Id) return List_Id; Typ : Entity_Id) return List_Id;
-- Generate loops to finalize any tasks or simple protected objects -- Generate loops to finalize any tasks or simple protected objects that
-- that are subcomponents of an array. -- are subcomponents of an array.
function Cleanup_Protected_Object function Cleanup_Protected_Object
(N : Node_Id; (N : Node_Id;
...@@ -191,10 +195,10 @@ package Exp_Ch7 is ...@@ -191,10 +195,10 @@ package Exp_Ch7 is
-- Check whether composite type contains a simple protected component -- Check whether composite type contains a simple protected component
function Is_Simple_Protected_Type (T : Entity_Id) return Boolean; function Is_Simple_Protected_Type (T : Entity_Id) return Boolean;
-- Check whether argument is a protected type without entries. -- Check whether argument is a protected type without entries. Protected
-- Protected types with entries are controlled, and their cleanup -- types with entries are controlled, and their cleanup is handled by the
-- is handled by the standard finalization machinery. For simple -- standard finalization machinery. For simple protected types we generate
-- protected types we generate inline code to release their locks. -- inline code to release their locks.
-------------------------------- --------------------------------
-- Transient Scope Management -- -- Transient Scope Management --
...@@ -215,12 +219,12 @@ package Exp_Ch7 is ...@@ -215,12 +219,12 @@ package Exp_Ch7 is
-- return the node to be wrapped if the current scope is transient -- return the node to be wrapped if the current scope is transient
procedure Store_Before_Actions_In_Scope (L : List_Id); procedure Store_Before_Actions_In_Scope (L : List_Id);
-- Append the list L of actions to the end of the before-actions store -- Append the list L of actions to the end of the before-actions store in
-- in the top of the scope stack -- the top of the scope stack
procedure Store_After_Actions_In_Scope (L : List_Id); procedure Store_After_Actions_In_Scope (L : List_Id);
-- Append the list L of actions to the beginning of the after-actions -- Append the list L of actions to the beginning of the after-actions store
-- store in the top of the scope stack -- in the top of the scope stack
procedure Wrap_Transient_Declaration (N : Node_Id); procedure Wrap_Transient_Declaration (N : Node_Id);
-- N is an object declaration. Expand the finalization calls after the -- N is an object declaration. Expand the finalization calls after the
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment