+2011-08-29 Robert Dewar <dewar@adacore.com>
+
+ * a-exexpr-gcc.adb, a-synbar.adb, sem_ch13.adb: Minor reformatting.
+
+2011-08-29 Bob Duff <duff@adacore.com>
+
+ * sem_aggr.adb (Resolve_Aggr_Expr): Call this routine even in the case
+ of <>, because this is the routine that checks for dimensionality
+ errors (for example, for a two-dimensional array, (others => <>) should
+ be (others => (others => <>)).
+
+2011-08-29 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * impunit.adb: Add new run-time units.
+ * freeze.adb, exp_ch7.ads, exp_ch7.adb, exp_util.ads, exp_util.adb,
+ s-stposu.ads, s-stposu.adb: Code clean up.
+ Handle protected class-wide or task class-wide types
+ Handle C/C++/CIL/Java types.
+ * s-spsufi.adb, s-spsufi.ads: New files.
+
2011-08-29 Yannick Moy <moy@adacore.com>
* sem_ch13.adb (Analyze_Aspect_Specifications): Reject test-case on
a-envvar$(objext) \
a-except$(objext) \
a-exctra$(objext) \
- a-fihema$(objext) \
a-finali$(objext) \
a-flteio$(objext) \
a-fwteio$(objext) \
a-tiunio$(objext) \
a-unccon$(objext) \
a-uncdea$(objext) \
+ a-undesu$(objext) \
a-wichha$(objext) \
a-wichun$(objext) \
a-widcha$(objext) \
s-ficobl$(objext) \
s-fileio$(objext) \
s-filofl$(objext) \
+ s-finmas$(objext) \
s-finroo$(objext) \
s-fishfl$(objext) \
s-flocon$(objext) \
s-sequio$(objext) \
s-shasto$(objext) \
s-soflin$(objext) \
+ s-spsufi$(objext) \
s-stache$(objext) \
s-stalib$(objext) \
s-stausa$(objext) \
s-stchop$(objext) \
s-stoele$(objext) \
s-stopoo$(objext) \
+ s-stposu$(objext) \
s-stratt$(objext) \
s-strhas$(objext) \
s-string$(objext) \
procedure GNAT_GCC_Exception_Cleanup
(Reason : Unwind_Reason_Code;
- Excep : not null GNAT_GCC_Exception_Access) is
+ Excep : not null GNAT_GCC_Exception_Access)
+ is
pragma Unreferenced (Reason);
procedure Free is new Unchecked_Deallocation
(GNAT_GCC_Exception, GNAT_GCC_Exception_Access);
Copy : GNAT_GCC_Exception_Access := Excep;
+
begin
-- Simply free the memory
UW_Argument : System.Address) return Unwind_Reason_Code
is
pragma Unreferenced (UW_Version, UW_Eclass, UW_Context, UW_Argument);
+
begin
-- Terminate when the end of the stack is reached
Reraised : Boolean := False)
is
pragma Unreferenced (Excep, Current, Reraised);
+
begin
-- In the GNAT-SJLJ case this "stack" only exists implicitly, by way of
-- local occurrence declarations together with save/restore operations
-------------------------
procedure Setup_Current_Excep
- (GCC_Exception : not null GCC_Exception_Access) is
+ (GCC_Exception : not null GCC_Exception_Access)
+ is
Excep : constant EOA := Get_Current_Excep.all;
+
begin
-- Setup the exception occurrence
declare
GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
- To_GNAT_GCC_Exception (GCC_Exception);
+ To_GNAT_GCC_Exception (GCC_Exception);
begin
Excep.all := GNAT_Occurrence.Occurrence;
end;
-----------------------------
procedure Reraise_GCC_Exception
- (GCC_Exception : not null GCC_Exception_Access) is
+ (GCC_Exception : not null GCC_Exception_Access)
+ is
begin
-- Simply propagate it
Propagate_GCC_Exception (GCC_Exception);
-- the two phase scheme it implements.
procedure Propagate_GCC_Exception
- (GCC_Exception : not null GCC_Exception_Access) is
+ (GCC_Exception : not null GCC_Exception_Access)
+ is
begin
-- Perform a standard raise first. If a regular handler is found, it
-- will be entered after all the intermediate cleanups have run. If
-- Now, un a forced unwind to trigger cleanups. Control should not
-- resume there, if there are cleanups and in any cases as the
- -- unwinding hook calls Unhandled_Exception_Terminate when end of stack
- -- is reached.
+ -- unwinding hook calls Unhandled_Exception_Terminate when end of
+ -- stack is reached.
Unwind_ForcedUnwind (GCC_Exception,
CleanupUnwind_Handler'Address,
System.Null_Address);
- -- We get here in case of error.
- -- The debugger has been notified before the second step above.
+ -- We get here in case of error. The debugger has been notified before
+ -- the second step above.
Setup_Current_Excep (GCC_Exception);
Unhandled_Exception_Terminate;
-------------------------
-- Build an object suitable for the libgcc processing and call
- -- Unwind_RaiseException to actually throw, taking care of handling
- -- the two phase scheme it implements.
+ -- Unwind_RaiseException to actually do the raise, taking care of
+ -- handling the two phase scheme it implements.
procedure Propagate_Exception
(E : Exception_Id;
-- Allocate the GCC exception
- GCC_Exception := new GNAT_GCC_Exception'
- (Header => (Class => GNAT_Exception_Class,
- Cleanup => GNAT_GCC_Exception_Cleanup'Address,
- Private1 => 0,
- Private2 => 0),
- Occurrence => Excep.all);
+ GCC_Exception :=
+ new GNAT_GCC_Exception'
+ (Header => (Class => GNAT_Exception_Class,
+ Cleanup => GNAT_GCC_Exception_Cleanup'Address,
+ Private1 => 0,
+ Private2 => 0),
+ Occurrence => Excep.all);
+
+ -- Propagate it
- -- Propagate it.
Propagate_GCC_Exception (To_GCC_Exception (GCC_Exception));
end Propagate_Exception;
Notified := Wait'Count = 0;
end Wait;
-
end Synchronous_Barrier;
----------------------
-- ??? What is the header version here, see a-uncdea.adb. No GPL?
-with System.Storage_Pools.Subpools; use System.Storage_Pools.Subpools;
+with System.Storage_Pools.Subpools,
+ System.Storage_Pools.Subpools.Finalization;
+
+use System.Storage_Pools.Subpools,
+ System.Storage_Pools.Subpools.Finalization;
procedure Ada.Unchecked_Deallocate_Subpool
(Subpool : in out System.Storage_Pools.Subpools.Subpool_Handle)
is
begin
- -- Finalize all controlled objects allocated on the input subpool
-
- -- ??? It is awkward to create a child of Storage_Pools.Subpools for the
- -- sole purpose of exporting Finalize_Subpool.
-
--- Finalize_Subpool (Subpool);
-
- -- Dispatch to the user-defined implementation of Deallocate_Subpool
-
- Deallocate_Subpool (Pool_Of_Subpool (Subpool).all, Subpool);
+ Finalize_And_Deallocate (Subpool);
end Ada.Unchecked_Deallocate_Subpool;
-- finalization support if not needed.
if not Comes_From_Source (Def_Id)
- and then not Has_Private_Declaration (Def_Id)
+ and then not Has_Private_Declaration (Def_Id)
then
null;
- elsif (Needs_Finalization (Desig_Type)
- and then Convention (Desig_Type) /= Convention_Java
- and then Convention (Desig_Type) /= Convention_CIL)
- or else
- (Is_Incomplete_Or_Private_Type (Desig_Type)
- and then No (Full_View (Desig_Type))
-
- -- An exception is made for types defined in the run-time
- -- because Ada.Tags.Tag itself is such a type and cannot
- -- afford this unnecessary overhead that would generates a
- -- loop in the expansion scheme...
-
- and then not In_Runtime (Def_Id)
-
- -- Another exception is if Restrictions (No_Finalization)
- -- is active, since then we know nothing is controlled.
+ -- An exception is made for types defined in the run-time because
+ -- Ada.Tags.Tag itself is such a type and cannot afford this
+ -- unnecessary overhead that would generates a loop in the
+ -- expansion scheme. Another exception is if Restrictions
+ -- (No_Finalization) is active, since then we know nothing is
+ -- controlled.
- and then not Restriction_Active (No_Finalization))
+ elsif Restriction_Active (No_Finalization)
+ or else In_Runtime (Def_Id)
+ then
+ null;
- -- If the designated type is not frozen yet, its controlled
- -- status must be retrieved explicitly.
+ -- The machinery assumes that incomplete or private types are
+ -- always completed by a controlled full vies.
+ elsif Needs_Finalization (Desig_Type)
+ or else
+ (Is_Incomplete_Or_Private_Type (Desig_Type)
+ and then No (Full_View (Desig_Type)))
or else
(Is_Array_Type (Desig_Type)
- and then not Is_Frozen (Desig_Type)
and then Needs_Finalization (Component_Type (Desig_Type)))
then
Build_Finalization_Master (Def_Id);
-- If a boolean array assignment can be done in place, build call to
-- corresponding library procedure.
- procedure Complete_Controlled_Allocation (Temp_Decl : Node_Id);
- -- Subsidiary to Expand_N_Allocator and Expand_Allocator_Expression. Formal
- -- Temp_Decl is the declaration of a temporary which hold the value of the
- -- original allocator. Create a custom Allocate routine for the expression
- -- of Temp_Decl. The routine does special processing for anonymous access
- -- types.
+ function Current_Unit_First_Declaration return Node_Id;
+ -- Return the current unit's first declaration. If the declaration list is
+ -- empty, the routine generates a null statement and returns it.
+
+ function Current_Unit_Scope return Entity_Id;
+ -- Return the scope of the current unit. If the current unit is a body,
+ -- return the scope of the spec.
procedure Displace_Allocator_Pointer (N : Node_Id);
-- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
end Build_Boolean_Array_Proc_Call;
------------------------------------
- -- Complete_Controlled_Allocation --
+ -- Current_Unit_First_Declaration --
------------------------------------
- procedure Complete_Controlled_Allocation (Temp_Decl : Node_Id) is
- pragma Assert (Nkind (Temp_Decl) = N_Object_Declaration);
-
- Ptr_Typ : constant Entity_Id := Etype (Defining_Identifier (Temp_Decl));
+ function Current_Unit_First_Declaration return Node_Id is
+ Sem_U : Node_Id := Unit (Cunit (Current_Sem_Unit));
+ Decl : Node_Id;
+ Decls : List_Id;
- function First_Declaration_Of_Current_Unit return Node_Id;
- -- Return the current unit's first declaration. If the declaration list
- -- is empty, the routine generates a null statement and returns it.
-
- ---------------------------------------
- -- First_Declaration_Of_Current_Unit --
- ---------------------------------------
+ begin
+ if Nkind (Sem_U) = N_Package_Declaration then
+ Sem_U := Specification (Sem_U);
+ Decls := Visible_Declarations (Sem_U);
- function First_Declaration_Of_Current_Unit return Node_Id is
- Sem_U : Node_Id := Unit (Cunit (Current_Sem_Unit));
- Decl : Node_Id;
- Decls : List_Id;
+ if No (Decls) then
+ Decl := Make_Null_Statement (Sloc (Sem_U));
+ Decls := New_List (Decl);
+ Set_Visible_Declarations (Sem_U, Decls);
- begin
- if Nkind (Sem_U) = N_Package_Declaration then
- Sem_U := Specification (Sem_U);
- Decls := Visible_Declarations (Sem_U);
-
- if No (Decls) then
- Decl := Make_Null_Statement (Sloc (Sem_U));
- Decls := New_List (Decl);
- Set_Visible_Declarations (Sem_U, Decls);
- else
- Decl := First (Decls);
- end if;
+ elsif Is_Empty_List (Decls) then
+ Decl := Make_Null_Statement (Sloc (Sem_U));
+ Append_To (Decls, Decl);
else
- Decls := Declarations (Sem_U);
-
- if No (Decls) then
- Decl := Make_Null_Statement (Sloc (Sem_U));
- Decls := New_List (Decl);
- Set_Declarations (Sem_U, Decls);
- else
- Decl := First (Decls);
- end if;
+ Decl := First (Decls);
end if;
- return Decl;
- end First_Declaration_Of_Current_Unit;
-
- -- Start of processing for Complete_Controlled_Allocation
-
- begin
- -- 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 an object
+ else
+ Decls := Declarations (Sem_U);
- elsif No_Pool_Assigned (Ptr_Typ) then
- return;
+ if No (Decls) then
+ Decl := Make_Null_Statement (Sloc (Sem_U));
+ Decls := New_List (Decl);
+ Set_Declarations (Sem_U, Decls);
- -- Access-to-controlled types are not supported on .NET/JVM
+ elsif Is_Empty_List (Decls) then
+ Decl := Make_Null_Statement (Sloc (Sem_U));
+ Append_To (Decls, Decl);
- elsif VM_Target /= No_VM then
- return;
+ else
+ Decl := First (Decls);
+ end if;
end if;
- -- ??? Now that finalization masters act as heterogeneous lists, it
- -- might be worthed to revisit the global master approach.
-
- -- Processing for anonymous access-to-controlled types. These access
- -- types receive a special finalization master which appears in the
- -- declarations of the enclosing semantic unit.
+ return Decl;
+ end Current_Unit_First_Declaration;
- if Ekind (Ptr_Typ) = E_Anonymous_Access_Type
- and then No (Finalization_Master (Ptr_Typ))
- and then
- (not Restriction_Active (No_Nested_Finalization)
- or else Is_Library_Level_Entity (Ptr_Typ))
- then
- declare
- Pool_Id : constant Entity_Id :=
- Get_Global_Pool_For_Access_Type (Ptr_Typ);
- Scop : Node_Id := Cunit_Entity (Current_Sem_Unit);
+ ------------------------
+ -- Current_Unit_Scope --
+ ------------------------
- begin
- -- Use the scope of the current semantic unit when analyzing
+ function Current_Unit_Scope return Entity_Id is
+ Scop_Id : Entity_Id := Cunit_Entity (Current_Sem_Unit);
+ Subp_Bod : Node_Id;
- if Ekind (Scop) = E_Subprogram_Body then
- Scop := Corresponding_Spec (Parent (Parent (Parent (Scop))));
- end if;
+ begin
+ if Ekind (Scop_Id) = E_Subprogram_Body then
- Build_Finalization_Master
- (Typ => Ptr_Typ,
- Ins_Node => First_Declaration_Of_Current_Unit,
- Encl_Scope => Scop);
+ -- When processing subprogram bodies, the proper scope is always
+ -- that of the spec.
- -- Decorate the anonymous access type and the allocator node
+ Subp_Bod := Scop_Id;
+ while Present (Subp_Bod)
+ and then Nkind (Subp_Bod) /= N_Subprogram_Body
+ loop
+ Subp_Bod := Parent (Subp_Bod);
+ end loop;
- Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
- Set_Storage_Pool (Expression (Temp_Decl), Pool_Id);
- end;
+ Scop_Id := Corresponding_Spec (Subp_Bod);
end if;
- -- Since the temporary object reuses the original allocator, generate a
- -- custom Allocate routine for the temporary.
-
- if Present (Finalization_Master (Ptr_Typ)) then
- Build_Allocate_Deallocate_Proc
- (N => Temp_Decl,
- Is_Allocate => True);
- end if;
- end Complete_Controlled_Allocation;
+ return Scop_Id;
+ end Current_Unit_Scope;
--------------------------------
-- Displace_Allocator_Pointer --
return;
end if;
- -- Actions inserted before:
- -- Temp : constant ptr_T := new T'(Expression);
- -- <no CW> Temp._tag := T'tag;
- -- <CTRL> Adjust (Finalizable (Temp.all));
- -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
+ -- Actions inserted before:
+ -- Temp : constant ptr_T := new T'(Expression);
+ -- Temp._tag = T'tag; -- when not class-wide
+ -- [Deep_]Adjust (Temp.all);
- -- We analyze by hand the new internal allocator to avoid
- -- any recursion and inappropriate call to Initialize
+ -- We analyze by hand the new internal allocator to avoid any
+ -- recursion and inappropriate call to Initialize
-- We don't want to remove side effects when the expression must be
-- built in place. In the case of a build-in-place function call,
Set_No_Initialization (Expression (Temp_Decl));
Insert_Action (N, Temp_Decl);
- Complete_Controlled_Allocation (Temp_Decl);
+ Build_Allocate_Deallocate_Proc (Temp_Decl, True);
Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
-- Attach the object to the associated finalization master.
Expression => Node);
Insert_Action (N, Temp_Decl);
- Complete_Controlled_Allocation (Temp_Decl);
+ Build_Allocate_Deallocate_Proc (Temp_Decl, True);
-- Attach the object to the associated finalization master.
-- This is done manually on .NET/JVM since those compilers do
Set_No_Initialization (Expression (Temp_Decl));
Insert_Action (N, Temp_Decl);
- Complete_Controlled_Allocation (Temp_Decl);
+ Build_Allocate_Deallocate_Proc (Temp_Decl, True);
Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
else
Expression => Node);
Insert_Action (N, Temp_Decl);
- Complete_Controlled_Allocation (Temp_Decl);
+ Build_Allocate_Deallocate_Proc (Temp_Decl, True);
end if;
-- Generate an additional object containing the address of the
Set_No_Initialization (Expression (Temp_Decl));
Insert_Action (N, Temp_Decl);
- Complete_Controlled_Allocation (Temp_Decl);
+ Build_Allocate_Deallocate_Proc (Temp_Decl, True);
Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
-- Attach the object to the associated finalization master. Thisis
Etyp : constant Entity_Id := Etype (Expression (N));
Loc : constant Source_Ptr := Sloc (N);
Desig : Entity_Id;
- Temp : Entity_Id;
Nod : Node_Id;
+ Pool : Entity_Id;
+ Temp : Entity_Id;
procedure Rewrite_Coextension (N : Node_Id);
-- Static coextensions have the same lifetime as the entity they
Validate_Remote_Access_To_Class_Wide_Type (N);
- -- Set the Storage Pool
+ -- Processing for anonymous access-to-controlled types. These access
+ -- types receive a special finalization master which appears in the
+ -- declarations of the enclosing semantic unit. This expansion is done
+ -- now to ensure that any additional types generated by this routine
+ -- or Expand_Allocator_Expression inherit the proper type attributes.
+
+ if Ekind (PtrT) = E_Anonymous_Access_Type
+ and then Needs_Finalization (Dtyp)
+ then
+ -- Anonymous access-to-controlled types allocate on the global pool
+
+ if No (Associated_Storage_Pool (PtrT)) then
+ Set_Associated_Storage_Pool (PtrT,
+ Get_Global_Pool_For_Access_Type (PtrT));
+ end if;
+
+ -- The finalization master must be inserted and analyzed as part of
+ -- the current semantic unit.
+
+ if No (Finalization_Master (PtrT)) then
+ Build_Finalization_Master
+ (Typ => PtrT,
+ Ins_Node => Current_Unit_First_Declaration,
+ Encl_Scope => Current_Unit_Scope);
+ end if;
+ end if;
+
+ -- Set the storage pool and find the appropriate version of Allocate to
+ -- call.
- Set_Storage_Pool (N, Associated_Storage_Pool (Root_Type (PtrT)));
+ Pool := Associated_Storage_Pool (Root_Type (PtrT));
+ Set_Storage_Pool (N, Pool);
- if Present (Storage_Pool (N)) then
- if Is_RTE (Storage_Pool (N), RE_SS_Pool) then
+ if Present (Pool) then
+ if Is_RTE (Pool, RE_SS_Pool) then
if VM_Target = No_VM then
Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
end if;
- elsif Is_Class_Wide_Type (Etype (Storage_Pool (N))) then
+ elsif Is_Class_Wide_Type (Etype (Pool)) then
Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
else
Set_Procedure_To_Call (N,
- Find_Prim_Op (Etype (Storage_Pool (N)), Name_Allocate));
+ Find_Prim_Op (Etype (Pool), Name_Allocate));
end if;
end if;
and then Present (Finalization_Master (PtrT))
then
Build_Allocate_Deallocate_Proc
- (N => Parent (N),
+ (N => N,
Is_Allocate => True);
end if;
Nod := Relocate_Node (N);
-- Here is the transformation:
- -- input: new T
- -- output: Temp : constant ptr_T := new T;
- -- Init (Temp.all, ...);
- -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
- -- <CTRL> Initialize (Finalizable (Temp.all));
+ -- input: new Ctrl_Typ
+ -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
+ -- Ctrl_TypIP (Temp.all, ...);
+ -- [Deep_]Initialize (Temp.all);
- -- Here ptr_T is the pointer type for the allocator, and is the
- -- subtype of the allocator.
+ -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
+ -- is the subtype of the allocator.
Temp_Decl :=
Make_Object_Declaration (Loc,
Set_Assignment_OK (Temp_Decl);
Insert_Action (N, Temp_Decl, Suppress => All_Checks);
- Complete_Controlled_Allocation (Temp_Decl);
+ Build_Allocate_Deallocate_Proc (Temp_Decl, True);
-- If the designated type is a task type or contains tasks,
-- create block to activate created tasks, and insert
-- Special processing for .NET/JVM, the allocated object is
-- attached to the finalization master. Generate:
- -- Attach (<PtrT>FM, Root_Controlled_Ptr (Init_Arg1));
+ -- Attach (<PtrT>FC, Root_Controlled_Ptr (Init_Arg1));
-- Types derived from [Limited_]Controlled are the only
-- ones considered since they have fields Prev and Next.
return
Make_Exception_Handler (Loc,
- Exception_Choices => New_List (
- Make_Others_Choice (Loc)),
-
+ Exception_Choices =>
+ New_List (Make_Others_Choice (Loc)),
Statements => New_List (
Make_If_Statement (Loc,
Condition =>
Encl_Scope : Entity_Id := Empty)
is
Desig_Typ : constant Entity_Id := Directly_Designated_Type (Typ);
+ Ptr_Typ : Entity_Id := Root_Type (Base_Type (Typ));
function In_Deallocation_Instance (E : Entity_Id) return Boolean;
-- Determine whether entity E is inside a wrapper package created for
-- Start of processing for Build_Finalization_Master
begin
+ if Is_Private_Type (Ptr_Typ)
+ and then Present (Full_View (Ptr_Typ))
+ then
+ Ptr_Typ := Full_View (Ptr_Typ);
+ end if;
+
-- Certain run-time configurations and targets do not provide support
-- for controlled types.
if Restriction_Active (No_Finalization) then
return;
+ -- Do not process C, C++, CIL and Java types since it is assumend that
+ -- the non-Ada side will handle their clean up.
+
+ elsif Convention (Desig_Typ) = Convention_C
+ or else Convention (Desig_Typ) = Convention_CIL
+ or else Convention (Desig_Typ) = Convention_CPP
+ or else Convention (Desig_Typ) = Convention_Java
+ then
+ return;
+
-- Various machinery such as freezing may have already created a
-- finalization master.
- elsif Present (Finalization_Master (Typ)) then
+ elsif Present (Finalization_Master (Ptr_Typ)) then
return;
-- Do not process types that return on the secondary stack
- elsif Present (Associated_Storage_Pool (Typ))
- and then Is_RTE (Associated_Storage_Pool (Typ), RE_SS_Pool)
+ elsif Present (Associated_Storage_Pool (Ptr_Typ))
+ and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool)
then
return;
-- Do not process types which may never allocate an object
- elsif No_Pool_Assigned (Typ) then
+ elsif No_Pool_Assigned (Ptr_Typ) then
return;
-- Do not process access types coming from Ada.Unchecked_Deallocation
-- instances. Even though the designated type may be controlled, the
-- access type will never participate in allocation.
- elsif In_Deallocation_Instance (Typ) then
+ elsif In_Deallocation_Instance (Ptr_Typ) then
return;
-- Ignore the general use of anonymous access types unless the context
-- requires a finalization master.
- elsif Ekind (Typ) = E_Anonymous_Access_Type
+ elsif Ekind (Ptr_Typ) = E_Anonymous_Access_Type
and then No (Ins_Node)
then
return;
-- Finalization is in effect since masters are controlled objects.
elsif Restriction_Active (No_Nested_Finalization)
- and then not Is_Library_Level_Entity (Typ)
+ and then not Is_Library_Level_Entity (Ptr_Typ)
then
return;
end if;
declare
- Loc : constant Source_Ptr := Sloc (Typ);
+ Loc : constant Source_Ptr := Sloc (Ptr_Typ);
Actions : constant List_Id := New_List;
Fin_Mas_Id : Entity_Id;
Pool_Id : Entity_Id;
- Ptr_Typ : Entity_Id := Typ;
begin
- -- Access subtypes must use the storage pool of their base type
-
- if Ekind (Ptr_Typ) = E_Access_Subtype then
- Ptr_Typ := Base_Type (Ptr_Typ);
- end if;
-
-- Generate:
-- Fnn : aliased Finalization_Master;
Pop_Scope;
- elsif Ekind (Typ) = E_Access_Subtype
- or else (Ekind (Desig_Typ) = E_Incomplete_Type
- and then Has_Completion_In_Body (Desig_Typ))
+ elsif Ekind (Desig_Typ) = E_Incomplete_Type
+ and then Has_Completion_In_Body (Desig_Typ)
then
- Insert_Actions (Parent (Typ), Actions);
+ Insert_Actions (Parent (Ptr_Typ), Actions);
-- If the designated type is not yet frozen, then append the actions
-- to that type's freeze actions. The actions need to be appended to
then
Append_Freeze_Actions (Desig_Typ, Actions);
- elsif Present (Freeze_Node (Typ))
- and then not Analyzed (Freeze_Node (Typ))
+ elsif Present (Freeze_Node (Ptr_Typ))
+ and then not Analyzed (Freeze_Node (Ptr_Typ))
then
- Append_Freeze_Actions (Typ, Actions);
+ Append_Freeze_Actions (Ptr_Typ, Actions);
-- If there's a pool created locally for the access type, then we
-- need to ensure that the master gets created after the pool object,
-- this point. (This seems a little unclean.???)
elsif VM_Target = No_VM
- and then Scope (Pool_Id) = Scope (Typ)
+ and then Scope (Pool_Id) = Scope (Ptr_Typ)
then
Insert_List_After_And_Analyze (Parent (Pool_Id), Actions);
else
- Insert_Actions (Parent (Typ), Actions);
+ Insert_Actions (Parent (Ptr_Typ), Actions);
end if;
end;
end Build_Finalization_Master;
-- The local exception does not need to be reraised for library-
-- level finalizers. Generate:
--
- -- if Raised then
- -- Raise_From_Controlled_Operation (E, Abort);
+ -- if Raised and then not Abort then
+ -- Raise_From_Controlled_Operation (E);
-- end if;
if not For_Package
if Is_Controlled (Typ) then
Init := Find_Prim_Op (Typ, Name_Initialize);
+
+ if Present (Init) then
+ Init := Ultimate_Alias (Init);
+ end if;
end if;
return
Utyp := Typ;
end if;
+ if Is_Private_Type (Utyp)
+ and then Present (Full_View (Utyp))
+ then
+ Utyp := Full_View (Utyp);
+ end if;
+
-- The init procedures are arranged as follows:
-- Object : Controlled_Type;
E_Id : Entity_Id;
Raised_Id : Entity_Id) return Node_Id
is
- Params : List_Id;
Proc_Id : Entity_Id;
begin
- -- The default parameter is the local exception occurrence
-
- Params := New_List (New_Reference_To (E_Id, Loc));
-
- -- Standard run-time, .NET/JVM targets, this case handles finalization
- -- exceptions raised during an abort.
+ -- Standard run-time, .NET/JVM targets
if RTE_Available (RE_Raise_From_Controlled_Operation) then
Proc_Id := RTE (RE_Raise_From_Controlled_Operation);
- Append_To (Params, New_Reference_To (Abort_Id, Loc));
-- Restricted runtime: exception messages are not supported and hence
-- Raise_From_Controlled_Operation is not supported.
end if;
-- Generate:
- -- if Raised_Id then
+ -- if Raised_Id and then not Abort_Id then
-- <Proc_Id> (<Params>);
-- end if;
return
Make_If_Statement (Loc,
- Condition => New_Reference_To (Raised_Id, Loc),
+ Condition =>
+ Make_And_Then (Loc,
+ Left_Opnd => New_Reference_To (Raised_Id, Loc),
+ Right_Opnd =>
+ Make_Op_Not (Loc,
+ Right_Opnd => New_Reference_To (Abort_Id, Loc))),
+
Then_Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (Proc_Id, Loc),
- Parameter_Associations => Params)));
+ Parameter_Associations =>
+ New_List (New_Reference_To (E_Id, Loc)))));
end Build_Raise_Statement;
-----------------------------
-- exception
-- when others =>
- -- if not Rnn then
- -- Rnn := True;
+ -- if not Raised then
+ -- Raised := True;
-- Save_Occurrence
-- (Enn, Get_Current_Excep.all.all);
-- end if;
end loop;
-- Generate:
- -- if Rnn then
- -- Raise_From_Controlled_Operation (E, Abort);
+ -- if Raised and then not Abort then
+ -- Raise_From_Controlled_Operation (E);
-- end if;
if Built
-- ...
-- end loop;
--
- -- if Raised then
- -- Raise_From_Controlled_Operation (E, Abort);
+ -- if Raised and then not Abort then
+ -- Raise_From_Controlled_Operation (E);
-- end if;
-- end;
-- end loop;
-- end;
- -- if Raised then
- -- Raise_From_Controlled_Operation (E, Abort);
+ -- if Raised and then not Abort then
+ -- Raise_From_Controlled_Operation (E);
-- end if;
-- raise;
-- begin
-- <core loop>
- -- if Raised then -- Expection handlers allowed
- -- Raise_From_Controlled_Operation (E, Abort);
+ -- if Raised and then not Abort then -- Expection handlers OK
+ -- Raise_From_Controlled_Operation (E);
-- end if;
-- end;
-- <final loop>
- -- if Raised then -- Exception handlers allowed
- -- Raise_From_Controlled_Operation (E, Abort);
+ -- if Raised and then not Abort then -- Exception handlers OK
+ -- Raise_From_Controlled_Operation (E);
-- end if;
- -- raise; -- Exception handlers allowed
+ -- raise; -- Exception handlers OK
-- end;
Stmts := New_List (Build_Counter_Assignment, Final_Loop);
-- end;
-- end if;
--
- -- if Raised then
- -- Raise_From_Controlled_Object (E, Abort);
+ -- if Raised and then not Abort then
+ -- Raise_From_Controlled_Operation (E);
-- end if;
-- end;
-- end if;
-- end;
--
- -- if Raised then
- -- Raise_From_Controlled_Object (E, Abort);
+ -- if Raised and then not Abort then
+ -- Raise_From_Controlled_Operation (E);
-- end if;
-- end;
-- begin
-- <adjust statements>
- -- if Raised then
- -- Raise_From_Controlled_Operation (E, Abort);
+ -- if Raised and then not Abort then
+ -- Raise_From_Controlled_Operation (E);
-- end if;
-- end;
-- Raised : Boolean := False;
-- begin
- -- if V.Finalized then
- -- return;
- -- end if;
-
-- <finalize statements>
- -- V.Finalized := True;
- -- if Raised then
- -- Raise_From_Controlled_Operation (E, Abort);
+ -- if Raised and then not Abort then
+ -- Raise_From_Controlled_Operation (E);
-- end if;
-- end;
--------------------------------
procedure Make_Finalize_Address_Body (Typ : Entity_Id) is
+ Is_Task : constant Boolean :=
+ Ekind (Typ) = E_Record_Type
+ and then Is_Concurrent_Record_Type (Typ)
+ and then Ekind (Corresponding_Concurrent_Type (Typ)) =
+ E_Task_Type;
Loc : constant Source_Ptr := Sloc (Typ);
Proc_Id : Entity_Id;
+ Stmts : List_Id;
begin
+ -- The corresponding records of task types are not controlled by design.
+ -- For the sake of completeness, create an empty Finalize_Address to be
+ -- used in task class-wide allocations.
+
+ if Is_Task then
+ null;
+
-- Nothing to do if the type is not controlled or it already has a
-- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
-- come from source. These are usually generated for completeness and
-- do not need the Finalize_Address primitive.
- if not Needs_Finalization (Typ)
+ elsif not Needs_Finalization (Typ)
or else Is_Abstract_Type (Typ)
or else Present (TSS (Typ, TSS_Finalize_Address))
or else
-- Generate:
-- procedure <Typ>FD (V : System.Address) is
-- begin
- -- declare
+ -- null; -- for tasks
+ --
+ -- declare -- for all other types
-- type Pnn is access all Typ;
-- for Pnn'Storage_Size use 0;
-- begin
-- end;
-- end TypFD;
+ if Is_Task then
+ Stmts := New_List (Make_Null_Statement (Loc));
+ else
+ Stmts := Make_Finalize_Address_Stmts (Typ);
+ end if;
+
Discard_Node (
Make_Subprogram_Body (Loc,
Specification =>
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements =>
- Make_Finalize_Address_Stmts (Typ))));
+ Statements => Stmts)));
Set_TSS (Typ, Proc_Id);
end Make_Finalize_Address_Body;
-- Generate:
-- when E : others =>
- -- Raise_From_Controlled_Operation (E, False);
+ -- Raise_From_Controlled_Operation (E);
-- or:
New_Reference_To
(RTE (RE_Raise_From_Controlled_Operation), Loc),
Parameter_Associations => New_List (
- New_Reference_To (E_Occ, Loc),
- New_Reference_To (Standard_False, Loc)));
+ New_Reference_To (E_Occ, Loc)));
-- Restricted runtime: exception messages are not supported
-- Subsidiary to routines Build_Finalizer, Make_Deep_Array_Body and Make_
-- Deep_Record_Body. Generate the following conditional raise statement:
--
- -- if Raised_Id then
- -- Raise_From_Controlled_Operation (E_Id, Abort_Id);
+ -- if Raised_Id and then not Abort_Id then
+ -- Raise_From_Controlled_Operation (E_Id);
-- end if;
--
-- Abort_Id is a local boolean flag which is set when the finalization was
(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
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;
- if Is_Concurrent_Type (Utyp) then
+ -- 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;
-- 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.
+ -- 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;
+
+ Ptr_Typ := Base_Type (Etype (Expr));
+
+ -- The allocator may have been rewritten into something else
+
+ if Nkind (Expr) = N_Allocator then
+ Proc_To_Call := Procedure_To_Call (Expr);
+ end if;
+ end if;
+
+ Pool_Id := Associated_Storage_Pool (Ptr_Typ);
+ Desig_Typ := Available_View (Designated_Type (Ptr_Typ));
- if not Needs_Finalization (Desig_Typ) then
+ -- 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;
- -- The allocator or free statement has already been expanded and already
- -- has a custom Allocate / Deallocate routine.
+ -- 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.
+
+ 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;
Fin_Addr_Id : Entity_Id;
Fin_Mas_Act : Node_Id;
Fin_Mas_Id : Entity_Id;
- Fin_Mas_Typ : Entity_Id;
Proc_To_Call : Entity_Id;
+ Subpool : Node_Id := Empty;
begin
- -- When dealing with an access subtype, always use the base type
- -- since it carries all the attributes.
-
- if Ekind (Ptr_Typ) = E_Access_Subtype then
- Fin_Mas_Typ := Base_Type (Ptr_Typ);
- else
- Fin_Mas_Typ := Ptr_Typ;
- end if;
-
- Actuals := New_List;
-
-- Step 1: Construct all the actuals for the call to library routine
-- Allocate_Any_Controlled / Deallocate_Any_Controlled.
-- a) Storage pool
- Append_To (Actuals,
- New_Reference_To (Associated_Storage_Pool (Fin_Mas_Typ), Loc));
+ Actuals := New_List (New_Reference_To (Pool_Id, Loc));
if Is_Allocate then
-- b) Subpool
- if Present (Subpool_Handle_Name (Expr)) then
- Append_To (Actuals,
- New_Reference_To (Entity (Subpool_Handle_Name (Expr)), Loc));
+ if Nkind (Expr) = N_Allocator then
+ Subpool := Subpool_Handle_Name (Expr);
+ end if;
+
+ if Present (Subpool) then
+ Append_To (Actuals, New_Reference_To (Entity (Subpool), Loc));
else
Append_To (Actuals, Make_Null (Loc));
end if;
-- c) Finalization master
if Needs_Finalization (Desig_Typ) then
- Fin_Mas_Id := Finalization_Master (Fin_Mas_Typ);
+ 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
Fin_Addr_Id := Find_Finalize_Address (Desig_Typ);
- if Present (Fin_Addr_Id) then
+ if Needs_Finalization (Desig_Typ) then
+ pragma Assert (Present (Fin_Addr_Id));
+
Append_To (Actuals,
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Fin_Addr_Id, Loc),
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.
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.
(N : Node_Id;
Is_Allocate : Boolean);
-- Create a custom Allocate/Deallocate to be associated with an allocation
- -- or deallocation of a controlled or class-wide object. In the case of
- -- allocation, N is the declaration of the temporary variable which
+ -- or deallocation:
+ --
+ -- 1) controlled objects
+ -- 2) class-wide objects
+ -- 3) any kind of object on a subpool
+ --
+ -- N must be an allocator or the declaration of a temporary variable which
-- represents the expression of the original allocator node, otherwise N
-- must be a free statement. If flag Is_Allocate is set, the generated
-- routine is allocate, deallocate otherwise.
end loop;
end;
- -- We add finalization collections to access types whose designated
- -- types require finalization. This is normally done when freezing
- -- the type, but this misses recursive type definitions where the
- -- later members of the recursion introduce controlled components
- -- (such as can happen when incomplete types are involved), as well
- -- cases where a component type is private and the controlled full
- -- type occurs after the access type is frozen. Cases that don't
- -- need a finalization collection are generic formal types (the
- -- actual type will have it) and types with Java and CIL conventions,
- -- since those are used for API bindings. (Are there any other cases
- -- that should be excluded here???)
+ -- We add finalization masters to access types whose designated types
+ -- require finalization. This is normally done when freezing the
+ -- type, but this misses recursive type definitions where the later
+ -- members of the recursion introduce controlled components (such as
+ -- can happen when incomplete types are involved), as well cases
+ -- where a component type is private and the controlled full type
+ -- occurs after the access type is frozen. Cases that don't need a
+ -- finalization master are generic formal types (the actual type will
+ -- have it) and types with Java and CIL conventions, since those are
+ -- used for API bindings. (Are there any other cases that should be
+ -- excluded here???)
elsif Is_Access_Type (E)
and then Comes_From_Source (E)
and then not Is_Generic_Type (E)
and then Needs_Finalization (Designated_Type (E))
- and then No (Associated_Collection (E))
- and then Convention (Designated_Type (E)) /= Convention_Java
- and then Convention (Designated_Type (E)) /= Convention_CIL
then
- Build_Finalization_Collection (E);
+ Build_Finalization_Master (E);
end if;
Next_Entity (E);
"s-addima", -- System.Address_Image
"s-assert", -- System.Assertions
+ "s-finmas", -- System.Finalization_Masters
"s-memory", -- System.Memory
"s-parint", -- System.Partition_Interface
"s-pooglo", -- System.Pool_Global
Non_Imp_File_Names_12 : constant File_List := (
"s-multip", -- System.Multiprocessors
"s-mudido", -- System.Multiprocessors.Dispatching_Domains
+ "s-stposu", -- System.Storage_Pools.Subpools
"a-cobove", -- Ada.Containers.Bounded_Vectors
"a-cbdlli", -- Ada.Containers.Bounded_Doubly_Linked_Lists
"a-cborse", -- Ada.Containers.Bounded_Ordered_Sets
"a-extiin", -- Ada.Execution_Time.Interrupts
"a-iteint", -- Ada.Iterator_Interfaces
"a-synbar", -- Ada.Synchronous_Barriers
+ "a-undesu", -- Ada.Unchecked_Deallocate_Subpool
-----------------------------------------
-- GNAT Defined Additions to Ada 20012 --
-----------------------------------------
+ "s-spsufi", -- System.Storage_Pools.Subpools.Finalization
"a-cofove", -- Ada.Containers.Formal_Vectors
"a-cfdlli", -- Ada.Containers.Formal_Doubly_Linked_Lists
"a-cforse", -- Ada.Containers.Formal_Ordered_Sets
with System.Storage_Elements;
with System.Storage_Pools;
+pragma Compiler_Unit;
+
package System.Finalization_Masters is
pragma Preelaborate (System.Finalization_Masters);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . S T O R A G E _ P O O L S . S U B P O O L S . --
+-- F I N A L I Z A T I O N --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2011, 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- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Storage_Pools.Subpools.Finalization is
+
+ -----------------------------
+ -- Finalize_And_Deallocate --
+ -----------------------------
+
+ procedure Finalize_And_Deallocate (Subpool : in out Subpool_Handle) is
+ begin
+ -- Do nothing if the subpool was never created or never used. The latter
+ -- case may arise with an array of subpool implementations.
+
+ if Subpool = null
+ or else Subpool.Owner = null
+ or else Subpool.Node = null
+ then
+ return;
+ end if;
+
+ -- Clean up all controlled objects allocated through the subpool
+
+ Finalize_Subpool (Subpool);
+
+ -- Dispatch to the user-defined implementation of Deallocate_Subpool
+
+ Deallocate_Subpool (Pool_Of_Subpool (Subpool).all, Subpool);
+
+ Subpool := null;
+ end Finalize_And_Deallocate;
+
+end System.Storage_Pools.Subpools.Finalization;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . S T O R A G E _ P O O L S . S U B P O O L S . --
+-- F I N A L I Z A T I O N --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2011, 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- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+pragma Compiler_Unit;
+
+package System.Storage_Pools.Subpools.Finalization is
+
+ procedure Finalize_And_Deallocate (Subpool : in out Subpool_Handle);
+ -- This routine performs the following actions:
+ -- 1) Finalize all objects chained on the subpool's master
+ -- 2) Remove the the subpool from the owner's list of subpools
+ -- 3) Deallocate the doubly linked list node associated with the subpool
+ -- 4) Call Deallocate_Subpool
+
+end System.Storage_Pools.Subpools.Finalization;
Alignment : System.Storage_Elements.Storage_Count)
is
begin
- -- ??? The use of Allocate is very dangerous as it does not handle
- -- controlled objects properly. Perhaps we should provide an
- -- implementation which raises Program_Error instead.
-
-- Dispatch to the user-defined implementations of Allocate_From_Subpool
-- and Default_Subpool_For_Pool.
procedure Allocate_Any_Controlled
(Pool : in out Root_Storage_Pool'Class;
- Context_Subpool : Subpool_Handle := null;
- Context_Master : Finalization_Masters.Finalization_Master_Ptr := null;
- Fin_Address : Finalization_Masters.Finalize_Address_Ptr := null;
+ Context_Subpool : Subpool_Handle;
+ Context_Master : Finalization_Masters.Finalization_Master_Ptr;
+ Fin_Address : Finalization_Masters.Finalize_Address_Ptr;
Addr : out System.Address;
Storage_Size : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count;
- Is_Controlled : Boolean := True)
+ Is_Controlled : Boolean;
+ On_Subpool : Boolean)
is
Is_Subpool_Allocation : constant Boolean :=
Pool in Root_Storage_Pool_With_Subpools'Class;
-- Step 1: Pool-related runtime checks
-- Allocation on a pool_with_subpools. In this scenario there is a
- -- master for each subpool.
+ -- master for each subpool. The master of the access type is ignored.
if Is_Subpool_Allocation then
Default_Subpool_For_Pool
(Root_Storage_Pool_With_Subpools'Class (Pool));
- -- Ensure proper ownership
-
- if Subpool.Owner /=
- Root_Storage_Pool_With_Subpools'Class (Pool)'Unchecked_Access
- then
- raise Program_Error with "incorrect owner of default subpool";
- end if;
-
-- Allocation with a Subpool_Handle
else
Subpool := Context_Subpool;
+ end if;
- -- Ensure proper ownership
+ -- Ensure proper ownership and chaining of the subpool
- if Subpool.Owner /=
- Root_Storage_Pool_With_Subpools'Class (Pool)'Unchecked_Access
- then
- raise Program_Error with "incorrect owner of subpool";
- end if;
+ if Subpool.Owner /=
+ Root_Storage_Pool_With_Subpools'Class (Pool)'Unchecked_Access
+ or else Subpool.Node = null
+ or else Subpool.Node.Prev = null
+ or else Subpool.Node.Next = null
+ then
+ raise Program_Error with "incorrect owner of subpool";
end if;
Master := Subpool.Master'Unchecked_Access;
-- each access-to-controlled type. No context subpool should be present.
else
-
-- If the master is missing, then the expansion of the access type
-- failed to create one. This is a serious error.
if Context_Master = null then
raise Program_Error with "missing master in pool allocation";
+ end if;
-- If a subpool is present, then this is the result of erroneous
-- allocator expansion. This is not a serious error, but it should
-- still be detected.
- elsif Context_Subpool /= null then
+ if Context_Subpool /= null then
raise Program_Error with "subpool not required in pool allocation";
end if;
+ -- If the allocation is intended to be on a subpool, but the access
+ -- type's pool does not support subpools, then this is the result of
+ -- erroneous end-user code.
+
+ if On_Subpool then
+ raise Program_Error
+ with "pool of access type does not support subpools";
+ end if;
+
Master := Context_Master;
end if;
- -- Step 2: Master-related runtime checks and size calculations
+ -- Step 2: Master and Finalize_Address-related runtime checks and size
+ -- calculations.
-- Allocation of a descendant from [Limited_]Controlled, a class-wide
-- object or a record with controlled components.
raise Program_Error with "allocation after finalization started";
end if;
+ -- Check whether primitive Finalize_Address is available. If it is
+ -- not, then either the expansion of the designated type failed or
+ -- the expansion of the allocator failed. This is a serious error.
+
+ if Fin_Address = null then
+ raise Program_Error
+ with "primitive Finalize_Address not available";
+ end if;
+
-- The size must acount for the hidden header preceding the object.
-- Account for possible padding space before the header due to a
-- larger alignment.
-- due to larger alignment, the header is placed right next to the
-- object:
- -- N_Addr N_Ptr
- -- | |
- -- V V
- -- +-------+---------------+----------------------+
- -- |Padding| Header | Object |
- -- +-------+---------------+----------------------+
- -- ^ ^ ^
- -- | +- Header_Size -+
- -- | |
- -- +- Header_And_Padding --+
+ -- N_Addr N_Ptr
+ -- | |
+ -- V V
+ -- +-------+---------------+----------------------+
+ -- |Padding| Header | Object |
+ -- +-------+---------------+----------------------+
+ -- ^ ^ ^
+ -- | +- Header_Size -+
+ -- | |
+ -- +- Header_And_Padding --+
N_Ptr :=
Address_To_FM_Node_Ptr (N_Addr + Header_And_Padding - Header_Size);
- -- Check whether primitive Finalize_Address is available. If it is
- -- not, then either the expansion of the designated type failed or
- -- the expansion of the allocator failed. This is a serious error.
-
- if Fin_Address = null then
- raise Program_Error
- with "primitive Finalize_Address not available";
- end if;
-
N_Ptr.Finalize_Address := Fin_Address;
-- Prepend the allocated object to the finalization master
procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr) is
begin
+ -- Ensure that the node has not been attached already
+
+ pragma Assert (N.Prev = null and then N.Next = null);
+
Lock_Task.all;
L.Next.Prev := N;
Addr : System.Address;
Storage_Size : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count;
- Is_Controlled : Boolean := True)
+ Is_Controlled : Boolean)
is
N_Addr : Address;
N_Ptr : FM_Node_Ptr;
procedure Detach (N : not null SP_Node_Ptr) is
begin
- -- N must be attached to some list
+ -- Ensure that the node is attached to some list
pragma Assert (N.Next /= null and then N.Prev /= null);
-- Finalize --
--------------
- overriding procedure Finalize
- (Pool : in out Root_Storage_Pool_With_Subpools)
- is
+ overriding procedure Finalize (Controller : in out Pool_Controller) is
+ begin
+ Finalize_Pool (Controller.Enclosing_Pool.all);
+ end Finalize;
+
+ -------------------
+ -- Finalize_Pool --
+ -------------------
+
+ procedure Finalize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is
Curr_Ptr : SP_Node_Ptr;
Ex_Occur : Exception_Occurrence;
Next_Ptr : SP_Node_Ptr;
Raised : Boolean := False;
begin
- -- Uninitialized pools do not have subpools and do not contain objects
- -- of any kind.
-
- if not Pool.Initialized then
- return;
- end if;
-
-- It is possible for multiple tasks to cause the finalization of a
-- common pool. Allow only one task to finalize the contents.
while Curr_Ptr /= Pool.Subpools'Unchecked_Access loop
Next_Ptr := Curr_Ptr.Next;
- -- Remove the subpool node from the subpool list
+ -- Perform the following actions:
- Detach (Curr_Ptr);
-
- -- Finalize the current subpool
+ -- 1) Finalize all objects chained on the subpool's master
+ -- 2) Remove the the subpool from the owner's list of subpools
+ -- 3) Deallocate the doubly linked list node associated with the
+ -- subpool.
begin
Finalize_Subpool (Curr_Ptr.Subpool);
end if;
end;
- -- Since subpool nodes are not allocated on the owner pool, they must
- -- be explicitly destroyed.
-
- Free (Curr_Ptr);
-
Curr_Ptr := Next_Ptr;
end loop;
if Raised then
Reraise_Occurrence (Ex_Occur);
end if;
- end Finalize;
+ end Finalize_Pool;
----------------------
-- Finalize_Subpool --
procedure Finalize_Subpool (Subpool : not null Subpool_Handle) is
begin
+ -- Do nothing if the subpool was never used
+
+ if Subpool.Owner = null
+ or else Subpool.Node = null
+ then
+ return;
+ end if;
+
+ -- Clean up all controlled objects chained on the subpool's master
+
Finalize (Subpool.Master);
+
+ -- Remove the subpool from its owner's list of subpools
+
+ Detach (Subpool.Node);
+
+ -- Destroy the associated doubly linked list node which was created in
+ -- Set_Pool_Of_Subpool.
+
+ Free (Subpool.Node);
end Finalize_Subpool;
+ ----------------
+ -- Initialize --
+ ----------------
+
+ overriding procedure Initialize (Controller : in out Pool_Controller) is
+ begin
+ Initialize_Pool (Controller.Enclosing_Pool.all);
+ end Initialize;
+
+ ---------------------
+ -- Initialize_Pool --
+ ---------------------
+
+ procedure Initialize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is
+ begin
+ -- The dummy head must point to itself in both directions
+
+ Pool.Subpools.Next := Pool.Subpools'Unchecked_Access;
+ Pool.Subpools.Prev := Pool.Subpools'Unchecked_Access;
+ end Initialize_Pool;
+
---------------------
-- Pool_Of_Subpool --
---------------------
N_Ptr : SP_Node_Ptr;
begin
- if not Pool.Initialized then
-
- -- The dummy head must point to itself in both directions
-
- Pool.Subpools.Next := Pool.Subpools'Unchecked_Access;
- Pool.Subpools.Prev := Pool.Subpools'Unchecked_Access;
- Pool.Initialized := True;
- end if;
-
-- If the subpool is already owned, raise Program_Error. This is a
-- direct violation of the RM rules.
with "subpool creation after finalization started";
end if;
- -- Create a subpool node, decorate it and associate it with the subpool
- -- list of Pool.
+ Subpool.Owner := Pool'Unchecked_Access;
- N_Ptr := new SP_Node;
+ -- Create a subpool node and decorate it. Since this node is not
+ -- allocated on the owner's pool, it must be explicitly destroyed by
+ -- Finalize_And_Detach.
- Subpool.Owner := Pool'Unchecked_Access;
+ N_Ptr := new SP_Node;
N_Ptr.Subpool := Subpool;
+ Subpool.Node := N_Ptr;
Attach (N_Ptr, Pool.Subpools'Unchecked_Access);
end Set_Pool_Of_Subpool;
-- --
------------------------------------------------------------------------------
+with Ada.Finalization;
+
with System.Finalization_Masters;
with System.Storage_Elements;
Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count);
-- Allocate an object described by Size_In_Storage_Elements and Alignment
- -- on the default subpool of Pool.
+ -- on the default subpool of Pool. Controlled types allocated through this
+ -- routine will NOT be handled properly.
procedure Allocate_From_Subpool
(Pool : in out Root_Storage_Pool_With_Subpools;
private
-- Model
- -- Pool_With_Subpools
- -- +----> +---------------------+ <----+
- -- | +---------- Subpools | |
- -- | | +---------------------+ |
- -- | | : User data : |
- -- | | '.....................' |
- -- | | |
- -- | | SP_Node SP_Node |
- -- | +-> +-------+ +-------+ |
- -- | | Prev <-----> Prev | |
- -- | +-------+ +-------+ |
- -- | | Next <---->| Next | |
- -- | +-------+ +-------+ |
- -- | +----Subpool| |Subpool----+ |
- -- | | +-------+ +-------+ | |
- -- | | | |
- -- | | Subpool Subpool | |
- -- | +-> +-------+ +-------+ <-+ |
- -- +------- Owner | | Owner -------+
- -- +-------+ +-------+
- -- +------------------- Master| | Master---------------+
- -- | +-------+ +-------+ |
- -- | : User : : User : |
- -- | : Data : : Data : |
- -- | '.......' '.......' |
- -- | |
- -- | Heap |
- -- .. | ..................................................... | ..
- -- : | | :
- -- : | Object Object Object Object | :
- -- : +-> +------+ +------+ +------+ +------+ <-+ :
- -- : | Prev <--> Prev <--> Prev | | Prev | :
- -- : +------+ +------+ +------+ +------+ :
- -- : | Next <--> Next <--> Next | | Next | :
- -- : +------+ +------+ +------+ +------+ :
- -- : | FA | | FA | | FA | | FA | :
- -- : +------+ +------+ +------+ +------+ :
- -- : : : : : : : : : :
- -- : : : : : : : : : :
- -- : '......' '......' '......' '......' :
- -- : :
- -- '.............................................................'
+ -- Pool_With_Subpools SP_Node SP_Node SP_Node
+ -- +-->+--------------------+ +-----+ +-----+ +-----+
+ -- | | Subpools -------->| ------->| ------->| ------->
+ -- | +--------------------+ +-----+ +-----+ +-----+
+ -- | |Finalization_Started|<------ |<------- |<------- |<---
+ -- | +--------------------+ +-----+ +-----+ +-----+
+ -- +--- Controller.Encl_Pool| | nul | | + | | + |
+ -- | +--------------------+ +-----+ +--|--+ +--:--+
+ -- | : : Dummy | ^ :
+ -- | : : | | :
+ -- | Root_Subpool V |
+ -- | +-------------+ |
+ -- +-------------------------------- Owner | |
+ -- FM_Node FM_Node +-------------+ |
+ -- +-----+ +-----+<-- Master.Objects| |
+ -- <------ |<------ | +-------------+ |
+ -- +-----+ +-----+ | Node -------+
+ -- | ------>| -----> +-------------+
+ -- +-----+ +-----+ : :
+ -- |ctrl | Dummy : :
+ -- | obj |
+ -- +-----+
+ --
+ -- SP_Nodes are created on the heap. FM_Nodes and associated objects are
+ -- created on the pool_with_subpools.
+
+ type Any_Storage_Pool_With_Subpools_Ptr
+ is access all Root_Storage_Pool_With_Subpools'Class;
+ for Any_Storage_Pool_With_Subpools_Ptr'Storage_Size use 0;
+
+ -- A pool controller is a special controlled object which ensures the
+ -- proper initialization and finalization of the enclosing pool.
+
+ type Pool_Controller (Enclosing_Pool : Any_Storage_Pool_With_Subpools_Ptr)
+ is new Ada.Finalization.Limited_Controlled with null record;
-- Subpool list types. Each pool_with_subpools contains a list of subpools.
+ -- This is an indirect doubly linked list since subpools are not supposed
+ -- to be allocatable by language design.
type SP_Node;
type SP_Node_Ptr is access all SP_Node;
Subpool : Subpool_Handle := null;
end record;
- -- Root_Storage_Pool_With_Subpools internal structure
+ -- Root_Storage_Pool_With_Subpools internal structure. The type uses a
+ -- special controller to perform initialization and finalization actions
+ -- on itself. This is necessary because the end user of this package may
+ -- decide to override Initialize and Finalize, thus disabling the desired
+ -- behavior.
+
+ -- Pool_With_Subpools SP_Node SP_Node SP_Node
+ -- +-->+--------------------+ +-----+ +-----+ +-----+
+ -- | | Subpools -------->| ------->| ------->| ------->
+ -- | +--------------------+ +-----+ +-----+ +-----+
+ -- | |Finalization_Started| : : : : : :
+ -- | +--------------------+
+ -- +--- Controller.Encl_Pool|
+ -- +--------------------+
+ -- : End-user :
+ -- : components :
type Root_Storage_Pool_With_Subpools is abstract
new Root_Storage_Pool with
record
- Initialized : Boolean := False;
- pragma Atomic (Initialized);
- -- Even though this type is derived from Limited_Controlled, overriding
- -- Initialize would have no effect since the type is abstract. Routine
- -- Set_Pool_Of_Subpool is tasked with the initialization of a pool with
- -- subpools because it has to be called at some point. This flag is used
- -- to prevent the resetting of the subpool chain.
-
Subpools : aliased SP_Node;
-- A doubly linked list of subpools
-- A flag which prevents the creation of new subpools while the master
-- pool is being finalized. The flag needs to be atomic because it is
-- accessed without Lock_Task / Unlock_Task.
- end record;
- type Any_Storage_Pool_With_Subpools_Ptr
- is access all Root_Storage_Pool_With_Subpools'Class;
- for Any_Storage_Pool_With_Subpools_Ptr'Storage_Size use 0;
+ Controller : Pool_Controller
+ (Root_Storage_Pool_With_Subpools'Unchecked_Access);
+ -- A component which ensures that the enclosing pool is initialized and
+ -- finalized at the appropriate places.
+ end record;
-- A subpool is an abstraction layer which sits on top of a pool. It
-- contains links to all controlled objects allocated on a particular
-- subpool.
+ -- Pool_With_Subpools SP_Node SP_Node SP_Node
+ -- +-->+----------------+ +-----+ +-----+ +-----+
+ -- | | Subpools ------>| ------->| ------->| ------->
+ -- | +----------------+ +-----+ +-----+ +-----+
+ -- | : :<------ |<------- |<------- |
+ -- | : : +-----+ +-----+ +-----+
+ -- | |null | | + | | + |
+ -- | +-----+ +--|--+ +--:--+
+ -- | | ^ :
+ -- | Root_Subpool V |
+ -- | +-------------+ |
+ -- +---------------------------- Owner | |
+ -- +-------------+ |
+ -- .......... Master | |
+ -- +-------------+ |
+ -- | Node -------+
+ -- +-------------+
+ -- : End-user :
+ -- : components :
+
type Root_Subpool is abstract tagged limited record
Owner : Any_Storage_Pool_With_Subpools_Ptr := null;
-- A reference to the master pool_with_subpools
Master : aliased System.Finalization_Masters.Finalization_Master;
-- A collection of controlled objects
+
+ Node : SP_Node_Ptr := null;
+ -- A link to the doubly linked list node which contains the subpool.
+ -- This back pointer is used in subpool deallocation.
end record;
-- ??? Once Storage_Pools.Allocate_Any is removed, this should be renamed
procedure Allocate_Any_Controlled
(Pool : in out Root_Storage_Pool'Class;
- Context_Subpool : Subpool_Handle := null;
- Context_Master : Finalization_Masters.Finalization_Master_Ptr := null;
- Fin_Address : Finalization_Masters.Finalize_Address_Ptr := null;
+ Context_Subpool : Subpool_Handle;
+ Context_Master : Finalization_Masters.Finalization_Master_Ptr;
+ Fin_Address : Finalization_Masters.Finalize_Address_Ptr;
Addr : out System.Address;
Storage_Size : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count;
- Is_Controlled : Boolean := True);
+ Is_Controlled : Boolean;
+ On_Subpool : Boolean);
-- Compiler interface. This version of Allocate handles all possible cases,
- -- either on a pool or a pool_with_subpools.
+ -- either on a pool or a pool_with_subpools, regardless of the controlled
+ -- status of the allocated object. Parameter usage:
+ --
+ -- * Pool - The pool associated with the access type. Pool can be any
+ -- derivation from Root_Storage_Pool, including a pool_with_subpools.
+ --
+ -- * Context_Subpool - The subpool handle name of an allocator. If no
+ -- subpool handle is present at the point of allocation, the actual
+ -- would be null.
+ --
+ -- * Context_Master - The finalization master associated with the access
+ -- type. If the access type's designated type is not controlled, the
+ -- actual would be null.
+ --
+ -- * Fin_Address - TSS routine Finalize_Address of the designated type.
+ -- If the designated type is not controlled, the actual would be null.
+ --
+ -- * Addr - The address of the allocated object.
+ --
+ -- * Storage_Size - The size of the allocated object.
+ --
+ -- * Alignment - The alignment of the allocated object.
+ --
+ -- * Is_Controlled - A flag which determines whether the allocated object
+ -- is controlled. When set to True, the machinery generates additional
+ -- data.
+ --
+ -- * On_Subpool - A flag which determines whether the a subpool handle
+ -- name is present at the point of allocation. This is used for error
+ -- diagnostics.
procedure Deallocate_Any_Controlled
(Pool : in out Root_Storage_Pool'Class;
Addr : System.Address;
Storage_Size : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count;
- Is_Controlled : Boolean := True);
+ Is_Controlled : Boolean);
-- Compiler interface. This version of Deallocate handles all possible
- -- cases, either from a pool or a pool_with_subpools.
-
- overriding procedure Finalize
- (Pool : in out Root_Storage_Pool_With_Subpools);
+ -- cases, either from a pool or a pool_with_subpools, regardless of the
+ -- controlled status of the deallocated object. Parameter usage:
+ --
+ -- * Pool - The pool associated with the access type. Pool can be any
+ -- derivation from Root_Storage_Pool, including a pool_with_subpools.
+ --
+ -- * Addr - The address of the allocated object.
+ --
+ -- * Storage_Size - The size of the allocated object.
+ --
+ -- * Alignment - The alignment of the allocated object.
+ --
+ -- * Is_Controlled - A flag which determines whether the allocated object
+ -- is controlled. When set to True, the machinery generates additional
+ -- data.
+
+ overriding procedure Finalize (Controller : in out Pool_Controller);
+ -- Buffer routine, calls Finalize_Pool
+
+ procedure Finalize_Pool (Pool : in out Root_Storage_Pool_With_Subpools);
-- Iterate over all subpools of Pool, detach them one by one and finalize
-- their masters. This action first detaches a controlled object from a
-- particular master, then invokes its Finalize_Address primitive.
procedure Finalize_Subpool (Subpool : not null Subpool_Handle);
- -- Finalize the master of a subpool
+ -- Finalize all controlled objects chained on Subpool's master. Remove the
+ -- subpool from its owner's list. Deallocate the associated doubly linked
+ -- list node.
+
+ overriding procedure Initialize (Controller : in out Pool_Controller);
+ -- Buffer routine, calls Initialize_Pool
+
+ procedure Initialize_Pool (Pool : in out Root_Storage_Pool_With_Subpools);
+ -- Setup the doubly linked list of subpools
end System.Storage_Pools.Subpools;
-- for discrete choices such as "L .. H => Expr" or the OTHERS choice).
-- In this event we do not resolve Expr unless expansion is disabled.
-- To know why, see the DELAYED COMPONENT RESOLUTION note above.
+ --
+ -- NOTE: In the case of "... => <>", we pass the in the
+ -- N_Component_Association node as Expr, since there is no Expression in
+ -- that case, and we need a Sloc for the error message.
---------
-- Add --
end if;
end if;
+ -- If it's "... => <>", nothing to resolve
+
+ if Nkind (Expr) = N_Component_Association then
+ pragma Assert (Box_Present (Expr));
+ return Success;
+ end if;
+
-- Ada 2005 (AI-231): Propagate the type to the nested aggregate.
-- Required to check the null-exclusion attribute (if present).
-- This value may be overridden later on.
Resolution_OK := Resolve_Array_Aggregate
(Expr, Nxt_Ind, Nxt_Ind_Constr, Component_Typ, Others_Allowed);
- -- Do not resolve the expressions of discrete or others choices
- -- unless the expression covers a single component, or the expander
- -- is inactive.
+ else
+
+ -- If it's "... => <>", nothing to resolve
- elsif Single_Elmt
- or else not Expander_Active
- or else In_Spec_Expression
- then
- Analyze_And_Resolve (Expr, Component_Typ);
- Check_Expr_OK_In_Limited_Aggregate (Expr);
- Check_Non_Static_Context (Expr);
- Aggregate_Constraint_Checks (Expr, Component_Typ);
- Check_Unset_Reference (Expr);
+ if Nkind (Expr) = N_Component_Association then
+ pragma Assert (Box_Present (Expr));
+ return Success;
+ end if;
+
+ -- Do not resolve the expressions of discrete or others choices
+ -- unless the expression covers a single component, or the
+ -- expander is inactive.
+
+ if Single_Elmt
+ or else not Expander_Active
+ or else In_Spec_Expression
+ then
+ Analyze_And_Resolve (Expr, Component_Typ);
+ Check_Expr_OK_In_Limited_Aggregate (Expr);
+ Check_Non_Static_Context (Expr);
+ Aggregate_Constraint_Checks (Expr, Component_Typ);
+ Check_Unset_Reference (Expr);
+ end if;
end if;
if Raises_Constraint_Error (Expr)
-- Ada 2005 (AI-287): In case of default initialization of a
-- component the expander will generate calls to the
- -- corresponding initialization subprogram.
+ -- corresponding initialization subprogram. We need to call
+ -- Resolve_Aggr_Expr to check the rules about
+ -- dimensionality.
- null;
+ if not Resolve_Aggr_Expr (Assoc,
+ Single_Elmt => Single_Choice)
+ then
+ return Failure;
+ end if;
elsif not Resolve_Aggr_Expr (Expression (Assoc),
Single_Elmt => Single_Choice)
-- Ada 2005 (AI-287): In case of default initialization of a
-- component the expander will generate calls to the
- -- corresponding initialization subprogram.
+ -- corresponding initialization subprogram. We need to call
+ -- Resolve_Aggr_Expr to check the rules about
+ -- dimensionality.
- null;
+ if not Resolve_Aggr_Expr (Assoc, Single_Elmt => False) then
+ return Failure;
+ end if;
elsif not Resolve_Aggr_Expr (Expression (Assoc),
Single_Elmt => False)
else
case A_Id is
+
-- For Pre/Post cases, insert immediately after the
-- entity declaration, since that is the required pragma
-- placement.
-- the proper back-annotations.
if not Is_Frozen (Spec_Id)
- and then (Expander_Active or ASIS_Mode)
+ and then (Expander_Active or else ASIS_Mode)
then
-- Force the generation of its freezing node to ensure proper
-- management of access types in the backend.
end if;
-- In the case of functions whose result type needs finalization,
- -- add an extra formal of type Ada.Finalization.Heap_Management.
- -- Finalization_Collection_Ptr.
+ -- add an extra formal which represents the finalization master.
- if Needs_BIP_Collection (E) then
+ if Needs_BIP_Finalization_Master (E) then
Discard :=
Add_Extra_Formal
- (E, RTE (RE_Finalization_Collection_Ptr),
- E, BIP_Formal_Suffix (BIP_Collection));
+ (E, RTE (RE_Finalization_Master_Ptr),
+ E, BIP_Formal_Suffix (BIP_Finalization_Master));
end if;
-- If the result type contains tasks, we have two extra formals:
projects / platform / upstream / gcc.git / commitdiff