This patch reimplements a key aspect of heap-allocated controlled objects.
Primitive Finalize_Address is now associated with the finalization master of
an access-to-controlled type when the designated type is frozen and not at the
point of object allocation.
------------
-- Source --
------------
-- types.ads
with Ada.Finalization; use Ada.Finalization;
package Types is
type Ctrl is new Controlled with record
Id : Natural := 0;
end record;
procedure Finalize (Obj : in out Ctrl);
procedure Initialize (Obj : in out Ctrl);
type Root is abstract tagged limited null record;
type Any_Root_Ptr is access all Root'Class;
function Make_Any_Root_Ptr (Is_Child_1 : Boolean) return Any_Root_Ptr;
type Child_1 is new Root with record
Comp_1 : Ctrl;
Comp_2 : Ctrl;
end record;
type Any_Child_1_Ptr is access all Child_1'Class;
type Child_1_Ptr is access all Child_1;
function Make_Child_1 return Child_1;
function Make_Child_1_Ptr return Child_1_Ptr;
type Child_2 is new Root with record
Comp_1 : Ctrl;
end record;
type Any_Child_2_Ptr is access all Child_2'Class;
type Child_2_Ptr is access all Child_2;
function Make_Child_2 return Child_2;
function Make_Child_2_Ptr return Child_2_Ptr;
end Types;
-- types.adb
with Ada.Text_IO; use Ada.Text_IO;
package body Types is
Id_Gen : Natural := 0;
procedure Finalize (Obj : in out Ctrl) is
begin
Put_Line (" fin:" & Obj.Id'Img);
Obj.Id := 0;
end Finalize;
procedure Initialize (Obj : in out Ctrl) is
begin
Id_Gen := Id_Gen + 1;
Obj.Id := Id_Gen;
Put_Line (" ini:" & Obj.Id'Img);
end Initialize;
function Make_Child_1 return Child_1 is
begin
return Obj : Child_1;
end Make_Child_1;
function Make_Child_1_Ptr return Child_1_Ptr is
Result : constant Any_Child_1_Ptr := new Child_1'(Make_Child_1);
begin
return Child_1_Ptr (Result);
end Make_Child_1_Ptr;
function Make_Child_2 return Child_2 is
begin
return Obj : Child_2;
end Make_Child_2;
function Make_Child_2_Ptr return Child_2_Ptr is
Result : constant Any_Child_2_Ptr := new Child_2'(Make_Child_2);
begin
return Child_2_Ptr (Result);
end Make_Child_2_Ptr;
function Make_Any_Root_Ptr (Is_Child_1 : Boolean) return Any_Root_Ptr is
begin
if Is_Child_1 then
return Any_Root_Ptr (Make_Child_1_Ptr);
else
return Any_Root_Ptr (Make_Child_2_Ptr);
end if;
end Make_Any_Root_Ptr;
end Types;
-- main.adb
with Types; use Types;
procedure Main is
Obj : Any_Root_Ptr;
begin
Obj := Make_Any_Root_Ptr (True);
Obj := Make_Any_Root_Ptr (False);
end Main;
----------------------------
-- Compilation and output --
----------------------------
$ gnatmake -q main.adb
$ ./main
ini: 1
ini: 2
ini: 3
fin: 3
fin: 2
fin: 1
Tested on x86_64-pc-linux-gnu, committed on trunk
2015-01-30 Hristian Kirtchev <kirtc...@adacore.com>
* einfo.adb Update the usage of attributes Entry_Bodies_Array,
Lit_Indexes, Scale_Value, Storage_Size_Variable,
String_Literal_Low_Bound along associated routines and
Write_FieldX_Name.
(Pending_Access_Types): New routine.
(Set_Pending_Access_Types): New routine.
(Write_Field15_Name): Add an entry for Pending_Access_Types.
* einfo.ads Add new attribute Pending_Access_Types along
with usage in nodes. Update the usage of attributes
Entry_Bodies_Array, Lit_Indexes, Scale_Value,
Storage_Size_Variable, String_Literal_Low_Bound.
(Pending_Access_Types): New routine along with pragma Inline.
(Set_Pending_Access_Types): New routine along with pragma Inline.
* exp_ch3.adb (Expand_Freeze_Array_Type): Add new local variable
Ins_Node. Determine the insertion node for anonynous access type
that acts as a component type of an array. Update the call to
Build_Finalization_Master.
(Expand_Freeze_Record_Type): Update
the calls to Build_Finalization_Master.
(Freeze_Type): Remove
local variable RACW_Seen. Factor out the code that deals with
remote access-to-class-wide types. Create a finalization master
when the designated type contains a private component. Fully
initialize all pending access types.
(Process_RACW_Types): New routine.
(Process_Pending_Access_Types): New routine.
* exp_ch4.adb (Expand_Allocator_Expression): Allocation no longer
needs to set primitive Finalize_Address.
(Expand_N_Allocator): Allocation no longer sets primitive
Finalize_Address.
* exp_ch6.adb (Add_Finalization_Master_Actual_To_Build_In_Place_Call):
Update the call to Build_Finalization_Master.
(Make_Build_In_Place_Call_In_Allocator): Allocation no longer
needs to set primitive Finalize_Address.
* exp_ch7.adb (Add_Pending_Access_Type): New routine.
(Build_Finalization_Master): New parameter profile. Associate
primitive Finalize_Address with the finalization master if the
designated type has been frozen, otherwise treat the access
type as pending. Simplify the insertion of the master and
related initialization code.
(Make_Finalize_Address_Body): Allow Finalize_Address for class-wide
abstract types.
(Make_Set_Finalize_Address_Call): Remove forlam parameter Typ.
Simplify the implementation.
* exp_ch7.ads (Build_Finalization_Master): New parameter profile
along with comment on usage.
(Make_Set_Finalize_Address_Call): Remove formal parameter Typ. Update
the comment on usage.
* exp_util.adb (Build_Allocate_Deallocate_Proc): Use routine
Finalize_Address to retrieve the primitive.
(Finalize_Address): New routine.
(Find_Finalize_Address): Removed.
* exp_util.ads (Finalize_Address): New routine.
* freeze.adb (Freeze_All): Remove the generation of finalization
masters.
* sem_ch3.adb (Analyze_Full_Type_Declaration): Propagate any
pending access types from the partial to the full view.
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 220273)
+++ sem_ch3.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
@@ -2792,6 +2792,14 @@
Generate_Definition (Def_Id);
end if;
+ -- Propagate any pending access types whose finalization masters need to
+ -- be fully initialized from the partial to the full view. Guard against
+ -- an illegal full view that remains unanalyzed.
+
+ if Is_Type (Def_Id) and then Is_Incomplete_Or_Private_Type (Prev) then
+ Set_Pending_Access_Types (Def_Id, Pending_Access_Types (Prev));
+ end if;
+
if Chars (Scope (Def_Id)) = Name_System
and then Chars (Def_Id) = Name_Address
and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (N)))
Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb (revision 220273)
+++ exp_ch7.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
@@ -764,14 +764,42 @@
-------------------------------
procedure Build_Finalization_Master
- (Typ : Entity_Id;
- Ins_Node : Node_Id := Empty;
- Encl_Scope : Entity_Id := Empty)
+ (Typ : Entity_Id;
+ For_Anonymous : Boolean := False;
+ For_Private : Boolean := False;
+ Context_Scope : Entity_Id := Empty;
+ Insertion_Node : Node_Id := Empty)
is
+ procedure Add_Pending_Access_Type
+ (Typ : Entity_Id;
+ Ptr_Typ : Entity_Id);
+ -- Add access type Ptr_Typ to the pending access type list for type Typ
+
function In_Deallocation_Instance (E : Entity_Id) return Boolean;
-- Determine whether entity E is inside a wrapper package created for
-- an instance of Ada.Unchecked_Deallocation.
+ -----------------------------
+ -- Add_Pending_Access_Type --
+ -----------------------------
+
+ procedure Add_Pending_Access_Type
+ (Typ : Entity_Id;
+ Ptr_Typ : Entity_Id)
+ is
+ List : Elist_Id;
+
+ begin
+ if Present (Pending_Access_Types (Typ)) then
+ List := Pending_Access_Types (Typ);
+ else
+ List := New_Elmt_List;
+ Set_Pending_Access_Types (Typ, List);
+ end if;
+
+ Prepend_Elmt (Ptr_Typ, List);
+ end Add_Pending_Access_Type;
+
------------------------------
-- In_Deallocation_Instance --
------------------------------
@@ -799,7 +827,7 @@
-- Local variables
- Desig_Typ : constant Entity_Id := Directly_Designated_Type (Typ);
+ Desig_Typ : constant Entity_Id := Designated_Type (Typ);
Ptr_Typ : constant Entity_Id := Root_Type_Of_Full_View (Base_Type (Typ));
-- A finalization master created for a named access type is associated
@@ -855,7 +883,7 @@
-- requires a finalization master.
elsif Ekind (Ptr_Typ) = E_Anonymous_Access_Type
- and then No (Ins_Node)
+ and then not For_Anonymous
then
return;
@@ -874,25 +902,21 @@
elsif VM_Target /= No_VM and then not Is_Controlled (Desig_Typ) then
return;
- -- Do not create finalization masters in SPARK mode because they result
- -- in unwanted expansion.
+ -- Do not create finalization masters in GNATprove mode because this
+ -- unwanted extra expansion. A compilation in this mode keeps the tree
+ -- as close as possible to the original sources.
- -- More detail would be useful here ???
-
elsif GNATprove_Mode then
return;
end if;
declare
+ Actions : constant List_Id := New_List;
Loc : constant Source_Ptr := Sloc (Ptr_Typ);
- Actions : constant List_Id := New_List;
Fin_Mas_Id : Entity_Id;
Pool_Id : Entity_Id;
begin
- -- Generate:
- -- Fnn : aliased Finalization_Master;
-
-- Source access types use fixed master names since the master is
-- inserted in the same source unit only once. The only exception to
-- this are instances using the same access type as generic actual.
@@ -910,6 +934,11 @@
Fin_Mas_Id := Make_Temporary (Loc, 'F');
end if;
+ Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
+
+ -- Generate:
+ -- <Ptr_Typ>FM : aliased Finalization_Master;
+
Append_To (Actions,
Make_Object_Declaration (Loc,
Defining_Identifier => Fin_Mas_Id,
@@ -917,19 +946,18 @@
Object_Definition =>
New_Occurrence_Of (RTE (RE_Finalization_Master), Loc)));
- -- Storage pool selection and attribute decoration of the generated
- -- master. Since .NET/JVM compilers do not support pools, this step
- -- is skipped.
+ -- Set the associated pool and primitive Finalize_Address of the new
+ -- finalization master. This step is skipped on .NET/JVM because the
+ -- target does not support storage pools or address arithmetic.
if VM_Target = No_VM then
- -- If the access type has a user-defined pool, use it as the base
- -- storage medium for the finalization pool.
+ -- The access type has a user-defined storage pool, use it
if Present (Associated_Storage_Pool (Ptr_Typ)) then
Pool_Id := Associated_Storage_Pool (Ptr_Typ);
- -- The default choice is the global pool
+ -- Otherwise the default choice is the global storage pool
else
Pool_Id := RTE (RE_Global_Pool_Object);
@@ -937,7 +965,7 @@
end if;
-- Generate:
- -- Set_Base_Pool (Fnn, Pool_Id'Unchecked_Access);
+ -- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access);
Append_To (Actions,
Make_Procedure_Call_Statement (Loc,
@@ -948,67 +976,90 @@
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Pool_Id, Loc),
Attribute_Name => Name_Unrestricted_Access))));
- end if;
- Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
+ -- Finalize_Address is not generated in CodePeer mode because the
+ -- body contains address arithmetic. Skip this step.
- -- A finalization master created for an anonymous access type must be
- -- inserted before a context-dependent node.
+ if CodePeer_Mode then
+ null;
- if Present (Ins_Node) then
- Push_Scope (Encl_Scope);
+ -- Associate the Finalize_Address primitive of the designated type
+ -- with the finalization master of the access type. The designated
+ -- type must be forzen as Finalize_Address is generated when the
+ -- freeze node is expanded.
- -- Treat use clauses as declarations and insert directly in front
- -- of them.
+ elsif Is_Frozen (Desig_Typ)
+ and then Present (Finalize_Address (Desig_Typ))
- if Nkind_In (Ins_Node, N_Use_Package_Clause,
- N_Use_Type_Clause)
+ -- The finalization master of an anonymous access type may need
+ -- to be inserted in a specific place in the tree. For instance:
+
+ -- type Comp_Typ;
+
+ -- <finalization master of "access Comp_Typ">
+
+ -- type Rec_Typ is record
+ -- Comp : access Comp_Typ;
+ -- end record;
+
+ -- <freeze node for Comp_Typ>
+ -- <freeze node for Rec_Typ>
+
+ -- Due to this oddity, the anonymous access type is stored for
+ -- later processing (see below).
+
+ and then Ekind (Ptr_Typ) /= E_Anonymous_Access_Type
then
- Insert_List_Before_And_Analyze (Ins_Node, Actions);
+ -- Generate:
+ -- Set_Finalize_Address
+ -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
+
+ Append_To (Actions,
+ Make_Set_Finalize_Address_Call
+ (Loc => Loc,
+ Ptr_Typ => Ptr_Typ));
+
+ -- Otherwise the designated type is either anonymous access or a
+ -- Taft-amendment type and has not been frozen. Store the access
+ -- type for later processing (see Freeze_Type).
+
else
- Insert_Actions (Ins_Node, Actions);
+ Add_Pending_Access_Type (Desig_Typ, Ptr_Typ);
end if;
+ end if;
- Pop_Scope;
+ -- A finalization master created for an anonymous access type or an
+ -- access designating a type with private components must be inserted
+ -- before a context-dependent node.
- elsif Ekind (Desig_Typ) = E_Incomplete_Type
- and then Has_Completion_In_Body (Desig_Typ)
- then
- Insert_Actions (Parent (Ptr_Typ), Actions);
+ if For_Anonymous or For_Private then
- -- 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
- -- whichever type is frozen later, similarly to what Freeze_Type does
- -- for appending the storage pool declaration for an access type.
- -- Otherwise, the call to Set_Storage_Pool_Ptr might reference the
- -- pool object before it's declared. However, it's not clear that
- -- this is exactly the right test to accomplish that here. ???
+ -- At this point both the scope of the context and the insertion
+ -- mode must be known.
- elsif Present (Freeze_Node (Desig_Typ))
- and then not Analyzed (Freeze_Node (Desig_Typ))
- then
- Append_Freeze_Actions (Desig_Typ, Actions);
+ pragma Assert (Present (Context_Scope));
+ pragma Assert (Present (Insertion_Node));
- elsif Present (Freeze_Node (Ptr_Typ))
- and then not Analyzed (Freeze_Node (Ptr_Typ))
- then
- Append_Freeze_Actions (Ptr_Typ, Actions);
+ Push_Scope (Context_Scope);
- -- 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,
- -- because otherwise we can have a forward reference, so we force the
- -- master actions to be inserted and analyzed after the pool entity.
- -- Note that both the access type and its designated type may have
- -- already been frozen and had their freezing actions analyzed at
- -- this point. (This seems a little unclean.???)
+ -- Treat use clauses as declarations and insert directly in front
+ -- of them.
- elsif VM_Target = No_VM
- and then Scope (Pool_Id) = Scope (Ptr_Typ)
- then
- Insert_List_After_And_Analyze (Parent (Pool_Id), Actions);
+ if Nkind_In (Insertion_Node, N_Use_Package_Clause,
+ N_Use_Type_Clause)
+ then
+ Insert_List_Before_And_Analyze (Insertion_Node, Actions);
+ else
+ Insert_Actions (Insertion_Node, Actions);
+ end if;
+ Pop_Scope;
+
+ -- Otherwise the finalization master and its initialization become a
+ -- part of the freeze node.
+
else
- Insert_Actions (Parent (Ptr_Typ), Actions);
+ Append_Freeze_Actions (Ptr_Typ, Actions);
end if;
end;
end Build_Finalization_Master;
@@ -7397,7 +7448,6 @@
-- do not need the Finalize_Address primitive.
elsif not Needs_Finalization (Typ)
- or else Is_Abstract_Type (Typ)
or else Present (TSS (Typ, TSS_Finalize_Address))
or else
(Is_Class_Wide_Type (Typ)
@@ -7801,85 +7851,32 @@
function Make_Set_Finalize_Address_Call
(Loc : Source_Ptr;
- Typ : Entity_Id;
Ptr_Typ : Entity_Id) return Node_Id
is
- Desig_Typ : constant Entity_Id :=
- Available_View (Designated_Type (Ptr_Typ));
- Fin_Mas_Id : constant Entity_Id := Finalization_Master (Ptr_Typ);
- Fin_Mas_Ref : Node_Id;
- Utyp : Entity_Id;
+ Desig_Typ : constant Entity_Id :=
+ Available_View (Designated_Type (Ptr_Typ));
+ Fin_Addr : constant Entity_Id := Finalize_Address (Desig_Typ);
+ Fin_Mas : constant Entity_Id := Finalization_Master (Ptr_Typ);
begin
- -- If the context is a class-wide allocator, we use the class-wide type
- -- to obtain the proper Finalize_Address routine.
+ -- Both the finalization master and primitive Finalize_Address must be
+ -- available.
- if Is_Class_Wide_Type (Desig_Typ) then
- Utyp := Desig_Typ;
+ pragma Assert (Present (Fin_Addr) and Present (Fin_Mas));
- else
- Utyp := Typ;
-
- if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then
- Utyp := Full_View (Utyp);
- end if;
-
- if Is_Concurrent_Type (Utyp) then
- Utyp := Corresponding_Record_Type (Utyp);
- end if;
- end if;
-
- Utyp := Underlying_Type (Base_Type (Utyp));
-
- -- Deal with untagged derivation of private views. If the parent is
- -- now known to be protected, the finalization routine is the one
- -- defined on the corresponding record of the ancestor (corresponding
- -- records do not automatically inherit operations, but maybe they
- -- should???)
-
- if Is_Untagged_Derivation (Typ) then
- if Is_Protected_Type (Typ) then
- Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
- else
- Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
-
- if Is_Protected_Type (Utyp) then
- Utyp := Corresponding_Record_Type (Utyp);
- end if;
- end if;
- end if;
-
- -- If the underlying_type is a subtype, we are dealing with the
- -- completion of a private type. We need to access the base type and
- -- generate a conversion to it.
-
- if Utyp /= Base_Type (Utyp) then
- pragma Assert (Is_Private_Type (Typ));
-
- Utyp := Base_Type (Utyp);
- end if;
-
- Fin_Mas_Ref := New_Occurrence_Of (Fin_Mas_Id, Loc);
-
- -- If the call is from a build-in-place function, the Master parameter
- -- is actually a pointer. Dereference it for the call.
-
- if Is_Access_Type (Etype (Fin_Mas_Id)) then
- Fin_Mas_Ref := Make_Explicit_Dereference (Loc, Fin_Mas_Ref);
- end if;
-
-- Generate:
- -- Set_Finalize_Address (<Ptr_Typ>FM, <Utyp>FD'Unrestricted_Access);
+ -- Set_Finalize_Address
+ -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
return
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Set_Finalize_Address), Loc),
Parameter_Associations => New_List (
- Fin_Mas_Ref,
+ New_Occurrence_Of (Fin_Mas, Loc),
+
Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (TSS (Utyp, TSS_Finalize_Address), Loc),
+ Prefix => New_Occurrence_Of (Fin_Addr, Loc),
Attribute_Name => Name_Unrestricted_Access)));
end Make_Set_Finalize_Address_Call;
Index: exp_ch7.ads
===================================================================
--- exp_ch7.ads (revision 220273)
+++ exp_ch7.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
@@ -98,17 +98,20 @@
-- exception will be saved to a global location.
procedure Build_Finalization_Master
- (Typ : Entity_Id;
- Ins_Node : Node_Id := Empty;
- Encl_Scope : Entity_Id := Empty);
+ (Typ : Entity_Id;
+ For_Anonymous : Boolean := False;
+ For_Private : Boolean := False;
+ Context_Scope : Entity_Id := Empty;
+ Insertion_Node : Node_Id := Empty);
-- Build a finalization master for an access type. The designated type may
- -- not necessarely be controlled or need finalization actions. The routine
- -- creates a wrapper around a user-defined storage pool or the general
- -- storage pool for access types. Ins_Nod and Encl_Scope are used in
- -- conjunction with anonymous access types. Ins_Node designates the
- -- insertion point before which the collection should be added. Encl_Scope
- -- is the scope of the context, either the enclosing record or the scope
- -- of the related function.
+ -- not necessarely be controlled or need finalization actions depending on
+ -- the context. Flag For_Anonymous must be set when creating a master for
+ -- an anonymous access type. Flag For_Private must be set when the
+ -- designated type contains a private component. Parameters Context_Scope
+ -- and Insertion_Node must be used in conjunction with flags For_Anonymous
+ -- and For_Private. Context_Scope is the scope of the context where the
+ -- finalization master must be analyzed. Insertion_Node is the insertion
+ -- point before which the master is inserted.
procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id);
-- Build one controlling procedure when a late body overrides one of
@@ -222,15 +225,13 @@
function Make_Set_Finalize_Address_Call
(Loc : Source_Ptr;
- Typ : Entity_Id;
Ptr_Typ : Entity_Id) return Node_Id;
+ -- Associate the Finalize_Address primitive of the designated type with the
+ -- finalization master of access type Ptr_Typ. The returned call is:
-- Generate the following call:
--
- -- Set_Finalize_Address (<Ptr_Typ>FM, <Typ>FD'Unrestricted_Access);
- --
- -- where Finalize_Address is the corresponding TSS primitive of type Typ
- -- and Ptr_Typ is the access type of the related allocation. Loc is the
- -- source location of the related allocator.
+ -- Set_Finalize_Address
+ -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
--------------------------------------------
-- Task and Protected Object finalization --
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 220273)
+++ exp_util.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
@@ -412,9 +412,6 @@
Proc_To_Call : Node_Id := Empty;
Ptr_Typ : Entity_Id;
- function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id;
- -- Locate TSS primitive Finalize_Address in type Typ
-
function Find_Object (E : Node_Id) return Node_Id;
-- Given an arbitrary expression of an allocator, try to find an object
-- reference in it, otherwise return the original expression.
@@ -423,82 +420,6 @@
-- Determine whether subprogram Subp denotes a custom allocate or
-- deallocate.
- ---------------------------
- -- Find_Finalize_Address --
- ---------------------------
-
- function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id is
- Utyp : Entity_Id := Typ;
-
- begin
- -- Handle protected class-wide or task class-wide types
-
- if Is_Class_Wide_Type (Utyp) then
- if Is_Concurrent_Type (Root_Type (Utyp)) then
- Utyp := Root_Type (Utyp);
-
- elsif Is_Private_Type (Root_Type (Utyp))
- and then Present (Full_View (Root_Type (Utyp)))
- and then Is_Concurrent_Type (Full_View (Root_Type (Utyp)))
- then
- Utyp := Full_View (Root_Type (Utyp));
- end if;
- end if;
-
- -- Handle private types
-
- if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then
- Utyp := Full_View (Utyp);
- end if;
-
- -- Handle protected and task types
-
- if Is_Concurrent_Type (Utyp)
- and then Present (Corresponding_Record_Type (Utyp))
- then
- Utyp := Corresponding_Record_Type (Utyp);
- end if;
-
- Utyp := Underlying_Type (Base_Type (Utyp));
-
- -- Deal with untagged derivation of private views. If the parent is
- -- now known to be protected, the finalization routine is the one
- -- defined on the corresponding record of the ancestor (corresponding
- -- records do not automatically inherit operations, but maybe they
- -- should???)
-
- if Is_Untagged_Derivation (Typ) then
- if Is_Protected_Type (Typ) then
- Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
- else
- Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
-
- if Is_Protected_Type (Utyp) then
- Utyp := Corresponding_Record_Type (Utyp);
- end if;
- end if;
- end if;
-
- -- If the underlying_type is a subtype, we are dealing with the
- -- completion of a private type. We need to access the base type and
- -- generate a conversion to it.
-
- if Utyp /= Base_Type (Utyp) then
- pragma Assert (Is_Private_Type (Typ));
-
- Utyp := Base_Type (Utyp);
- end if;
-
- -- When dealing with an internally built full view for a type with
- -- unknown discriminants, use the original record type.
-
- if Is_Underlying_Record_View (Utyp) then
- Utyp := Etype (Utyp);
- end if;
-
- return TSS (Utyp, TSS_Finalize_Address);
- end Find_Finalize_Address;
-
-----------------
-- Find_Object --
-----------------
@@ -764,7 +685,7 @@
-- since it contains an Unchecked_Conversion.
if Needs_Finalization (Desig_Typ) and then not CodePeer_Mode then
- Fin_Addr_Id := Find_Finalize_Address (Desig_Typ);
+ Fin_Addr_Id := Finalize_Address (Desig_Typ);
pragma Assert (Present (Fin_Addr_Id));
Append_To (Actuals,
@@ -2443,6 +2364,82 @@
end if;
end Expand_Subtype_From_Expr;
+ ----------------------
+ -- Finalize_Address --
+ ----------------------
+
+ function Finalize_Address (Typ : Entity_Id) return Entity_Id is
+ Utyp : Entity_Id := Typ;
+
+ begin
+ -- Handle protected class-wide or task class-wide types
+
+ if Is_Class_Wide_Type (Utyp) then
+ if Is_Concurrent_Type (Root_Type (Utyp)) then
+ Utyp := Root_Type (Utyp);
+
+ elsif Is_Private_Type (Root_Type (Utyp))
+ and then Present (Full_View (Root_Type (Utyp)))
+ and then Is_Concurrent_Type (Full_View (Root_Type (Utyp)))
+ then
+ Utyp := Full_View (Root_Type (Utyp));
+ end if;
+ end if;
+
+ -- Handle private types
+
+ if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then
+ Utyp := Full_View (Utyp);
+ end if;
+
+ -- Handle protected and task types
+
+ if Is_Concurrent_Type (Utyp)
+ and then Present (Corresponding_Record_Type (Utyp))
+ then
+ Utyp := Corresponding_Record_Type (Utyp);
+ end if;
+
+ Utyp := Underlying_Type (Base_Type (Utyp));
+
+ -- Deal with untagged derivation of private views. If the parent is
+ -- now known to be protected, the finalization routine is the one
+ -- defined on the corresponding record of the ancestor (corresponding
+ -- records do not automatically inherit operations, but maybe they
+ -- should???)
+
+ if Is_Untagged_Derivation (Typ) then
+ if Is_Protected_Type (Typ) then
+ Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
+ else
+ Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
+
+ if Is_Protected_Type (Utyp) then
+ Utyp := Corresponding_Record_Type (Utyp);
+ end if;
+ end if;
+ end if;
+
+ -- If the underlying_type is a subtype, we are dealing with the
+ -- completion of a private type. We need to access the base type and
+ -- generate a conversion to it.
+
+ if Utyp /= Base_Type (Utyp) then
+ pragma Assert (Is_Private_Type (Typ));
+
+ Utyp := Base_Type (Utyp);
+ end if;
+
+ -- When dealing with an internally built full view for a type with
+ -- unknown discriminants, use the original record type.
+
+ if Is_Underlying_Record_View (Utyp) then
+ Utyp := Etype (Utyp);
+ end if;
+
+ return TSS (Utyp, TSS_Finalize_Address);
+ end Finalize_Address;
+
------------------------
-- Find_Interface_ADT --
------------------------
Index: exp_util.ads
===================================================================
--- exp_util.ads (revision 220273)
+++ exp_util.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
@@ -450,6 +450,9 @@
-- declarations and/or allocations when the type is indefinite (including
-- class-wide).
+ function Finalize_Address (Typ : Entity_Id) return Entity_Id;
+ -- Locate TSS primitive Finalize_Address in type Typ
+
function Find_Interface_ADT
(T : Entity_Id;
Iface : Entity_Id) return Elmt_Id;
Index: einfo.adb
===================================================================
--- einfo.adb (revision 220273)
+++ einfo.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
@@ -121,15 +121,11 @@
-- Discriminant_Number Uint15
-- DT_Position Uint15
-- DT_Entry_Count Uint15
- -- Entry_Bodies_Array Node15
-- Entry_Parameters_Type Node15
-- Extra_Formal Node15
- -- Lit_Indexes Node15
+ -- Pending_Access_Types Elist15
-- Related_Instance Node15
-- Status_Flag_Or_Transient_Decl Node15
- -- Scale_Value Uint15
- -- Storage_Size_Variable Node15
- -- String_Literal_Low_Bound Node15
-- Access_Disp_Table Elist16
-- Body_References Elist16
@@ -138,6 +134,7 @@
-- Entry_Formal Node16
-- First_Private_Entity Node16
-- Lit_Strings Node16
+ -- Scale_Value Uint16
-- String_Literal_Length Uint16
-- Unset_Reference Node16
@@ -159,14 +156,17 @@
-- Delta_Value Ureal18
-- Enclosing_Scope Node18
-- Equivalent_Type Node18
+ -- Lit_Indexes Node18
-- Private_Dependents Elist18
-- Renamed_Entity Node18
-- Renamed_Object Node18
+ -- String_Literal_Low_Bound Node18
-- Body_Entity Node19
-- Corresponding_Discriminant Node19
-- Default_Aspect_Component_Value Node19
-- Default_Aspect_Value Node19
+ -- Entry_Bodies_Array Node19
-- Extra_Accessibility_Of_Result Node19
-- Parent_Subtype Node19
-- Size_Check_Code Node19
@@ -226,10 +226,9 @@
-- Dispatch_Table_Wrappers Elist26
-- Last_Assignment Node26
- -- Original_Access_Type Node26
-- Overridden_Operation Node26
-- Package_Instantiation Node26
- -- Relative_Deadline_Variable Node26
+ -- Storage_Size_Variable Node26
-- Current_Use_Clause Node27
-- Related_Type Node27
@@ -238,6 +237,8 @@
-- Extra_Formals Node28
-- Finalizer Node28
-- Initialization_Statements Node28
+ -- Original_Access_Type Node28
+ -- Relative_Deadline_Variable Node28
-- Underlying_Record_View Node28
-- BIP_Initialization_Call Node29
@@ -1093,7 +1094,7 @@
function Entry_Bodies_Array (Id : E) return E is
begin
- return Node15 (Id);
+ return Node19 (Id);
end Entry_Bodies_Array;
function Entry_Cancel_Parameter (Id : E) return E is
@@ -2505,7 +2506,7 @@
function Lit_Indexes (Id : E) return E is
begin
pragma Assert (Is_Enumeration_Type (Id));
- return Node15 (Id);
+ return Node18 (Id);
end Lit_Indexes;
function Lit_Strings (Id : E) return E is
@@ -2689,7 +2690,7 @@
function Original_Access_Type (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Access_Subprogram_Type);
- return Node26 (Id);
+ return Node28 (Id);
end Original_Access_Type;
function Original_Array_Type (Id : E) return E is
@@ -2738,6 +2739,12 @@
return Elist9 (Id);
end Part_Of_Constituents;
+ function Pending_Access_Types (Id : E) return L is
+ begin
+ pragma Assert (Is_Type (Id));
+ return Elist15 (Id);
+ end Pending_Access_Types;
+
function Postcondition_Proc (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Procedure);
@@ -2853,7 +2860,7 @@
function Relative_Deadline_Variable (Id : E) return E is
begin
pragma Assert (Is_Task_Type (Id));
- return Node26 (Implementation_Base_Type (Id));
+ return Node28 (Implementation_Base_Type (Id));
end Relative_Deadline_Variable;
function Renamed_Entity (Id : E) return N is
@@ -2929,7 +2936,7 @@
function Scale_Value (Id : E) return U is
begin
- return Uint15 (Id);
+ return Uint16 (Id);
end Scale_Value;
function Scope_Depth_Value (Id : E) return U is
@@ -3063,7 +3070,7 @@
function Storage_Size_Variable (Id : E) return E is
begin
pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id));
- return Node15 (Implementation_Base_Type (Id));
+ return Node26 (Implementation_Base_Type (Id));
end Storage_Size_Variable;
function Static_Elaboration_Desired (Id : E) return B is
@@ -3103,7 +3110,7 @@
function String_Literal_Low_Bound (Id : E) return N is
begin
- return Node15 (Id);
+ return Node18 (Id);
end String_Literal_Low_Bound;
function Subprograms_For_Type (Id : E) return E is
@@ -3920,7 +3927,7 @@
procedure Set_Entry_Bodies_Array (Id : E; V : E) is
begin
- Set_Node15 (Id, V);
+ Set_Node19 (Id, V);
end Set_Entry_Bodies_Array;
procedure Set_Entry_Cancel_Parameter (Id : E; V : E) is
@@ -5386,7 +5393,7 @@
procedure Set_Lit_Indexes (Id : E; V : E) is
begin
pragma Assert (Is_Enumeration_Type (Id) and then Root_Type (Id) = Id);
- Set_Node15 (Id, V);
+ Set_Node18 (Id, V);
end Set_Lit_Indexes;
procedure Set_Lit_Strings (Id : E; V : E) is
@@ -5576,7 +5583,7 @@
procedure Set_Original_Access_Type (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Access_Subprogram_Type);
- Set_Node26 (Id, V);
+ Set_Node28 (Id, V);
end Set_Original_Access_Type;
procedure Set_Original_Array_Type (Id : E; V : E) is
@@ -5625,6 +5632,12 @@
Set_Elist9 (Id, V);
end Set_Part_Of_Constituents;
+ procedure Set_Pending_Access_Types (Id : E; V : L) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Elist15 (Id, V);
+ end Set_Pending_Access_Types;
+
procedure Set_Postcondition_Proc (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Procedure);
@@ -5748,7 +5761,7 @@
procedure Set_Relative_Deadline_Variable (Id : E; V : E) is
begin
pragma Assert (Is_Task_Type (Id) and then Is_Base_Type (Id));
- Set_Node26 (Id, V);
+ Set_Node28 (Id, V);
end Set_Relative_Deadline_Variable;
procedure Set_Renamed_Entity (Id : E; V : N) is
@@ -5827,7 +5840,7 @@
procedure Set_Scale_Value (Id : E; V : U) is
begin
- Set_Uint15 (Id, V);
+ Set_Uint16 (Id, V);
end Set_Scale_Value;
procedure Set_Scope_Depth_Value (Id : E; V : U) is
@@ -5972,7 +5985,7 @@
begin
pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id));
pragma Assert (Id = Base_Type (Id));
- Set_Node15 (Id, V);
+ Set_Node26 (Id, V);
end Set_Storage_Size_Variable;
procedure Set_Static_Elaboration_Desired (Id : E; V : B) is
@@ -6015,7 +6028,7 @@
procedure Set_String_Literal_Low_Bound (Id : E; V : N) is
begin
pragma Assert (Ekind (Id) = E_String_Literal_Subtype);
- Set_Node15 (Id, V);
+ Set_Node18 (Id, V);
end Set_String_Literal_Low_Bound;
procedure Set_Subprograms_For_Type (Id : E; V : E) is
@@ -9092,36 +9105,23 @@
E_Procedure =>
Write_Str ("DT_Position");
- when E_Protected_Type =>
- Write_Str ("Entry_Bodies_Array");
-
when Entry_Kind =>
Write_Str ("Entry_Parameters_Type");
when Formal_Kind =>
Write_Str ("Extra_Formal");
- when Enumeration_Kind =>
- Write_Str ("Lit_Indexes");
+ when Type_Kind =>
+ Write_Str ("Pending_Access_Types");
when E_Package |
E_Package_Body =>
Write_Str ("Related_Instance");
- when Decimal_Fixed_Point_Kind =>
- Write_Str ("Scale_Value");
-
when E_Constant |
E_Variable =>
Write_Str ("Status_Flag_Or_Transient_Decl");
- when Access_Kind |
- Task_Kind =>
- Write_Str ("Storage_Size_Variable");
-
- when E_String_Literal_Subtype =>
- Write_Str ("String_Literal_Low_Bound");
-
when others =>
Write_Str ("Field15??");
end case;
@@ -9160,6 +9160,9 @@
when Enumeration_Kind =>
Write_Str ("Lit_Strings");
+ when Decimal_Fixed_Point_Kind =>
+ Write_Str ("Scale_Value");
+
when E_String_Literal_Subtype =>
Write_Str ("String_Literal_Length");
@@ -9282,6 +9285,9 @@
when Fixed_Point_Kind =>
Write_Str ("Delta_Value");
+ when Enumeration_Kind =>
+ Write_Str ("Lit_Indexes");
+
when Incomplete_Or_Private_Kind |
E_Record_Subtype =>
Write_Str ("Private_Dependents");
@@ -9296,6 +9302,9 @@
E_Generic_Package =>
Write_Str ("Renamed_Entity");
+ when E_String_Literal_Subtype =>
+ Write_Str ("String_Literal_Low_Bound");
+
when others =>
Write_Str ("Field18??");
end case;
@@ -9321,6 +9330,14 @@
when E_Array_Type =>
Write_Str ("Default_Component_Value");
+ when E_Protected_Type =>
+ Write_Str ("Entry_Bodies_Array");
+
+ when E_Function |
+ E_Operator |
+ E_Subprogram_Type =>
+ Write_Str ("Extra_Accessibility_Of_Result");
+
when E_Record_Type =>
Write_Str ("Parent_Subtype");
@@ -9335,9 +9352,6 @@
when Private_Kind =>
Write_Str ("Underlying_Full_View");
- when E_Function | E_Operator | E_Subprogram_Type =>
- Write_Str ("Extra_Accessibility_Of_Result");
-
when others =>
Write_Str ("Field19??");
end case;
@@ -9648,8 +9662,9 @@
E_Variable =>
Write_Str ("Last_Assignment");
- when E_Access_Subprogram_Type =>
- Write_Str ("Original_Access_Type");
+ when E_Procedure |
+ E_Function =>
+ Write_Str ("Overridden_Operation");
when E_Generic_Package |
E_Package =>
@@ -9659,13 +9674,10 @@
E_Constant =>
Write_Str ("Related_Type");
- when Task_Kind =>
- Write_Str ("Relative_Deadline_Variable");
+ when Access_Kind |
+ Task_Kind =>
+ Write_Str ("Storage_Size_Variable");
- when E_Procedure |
- E_Function =>
- Write_Str ("Overridden_Operation");
-
when others =>
Write_Str ("Field26??");
end case;
@@ -9719,6 +9731,12 @@
E_Variable =>
Write_Str ("Initialization_Statements");
+ when E_Access_Subprogram_Type =>
+ Write_Str ("Original_Access_Type");
+
+ when Task_Kind =>
+ Write_Str ("Relative_Deadline_Variable");
+
when E_Record_Type =>
Write_Str ("Underlying_Record_View");
@@ -9867,6 +9885,7 @@
case Ekind (Id) is
when Subprogram_Kind =>
Write_Str ("Import_Pragma");
+
when others =>
Write_Str ("Field35??");
end case;
Index: einfo.ads
===================================================================
--- einfo.ads (revision 220273)
+++ einfo.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
@@ -1036,7 +1036,7 @@
-- at least one accept for this entry in the task body. Used to
-- generate warnings for missing accepts.
--- Entry_Bodies_Array (Node15)
+-- Entry_Bodies_Array (Node19)
-- Defined in protected types for which Has_Entries is true.
-- This is the defining identifier for the array of entry body
-- action procedures and barrier functions used by the runtime to
@@ -3178,7 +3178,7 @@
-- field may be set as a result of a linker section pragma applied to the
-- type of the object.
--- Lit_Indexes (Node15)
+-- Lit_Indexes (Node18)
-- Defined in enumeration types and subtypes. Non-empty only for the
-- case of an enumeration root type, where it contains the entity for
-- the generated indexes entity. See unit Exp_Imgv for full details of
@@ -3495,7 +3495,7 @@
-- Optimize_Alignment (Off) mode applies to the type/object, then neither
-- of the flags Optimize_Alignment_Space/Optimize_Alignment_Time is set.
--- Original_Access_Type (Node26)
+-- Original_Access_Type (Node28)
-- Defined in E_Access_Subprogram_Type entities. Set only if the access
-- type was generated by the expander as part of processing an access
-- to protected subprogram type. Points to the access to protected
@@ -3578,6 +3578,14 @@
-- Present in abstract state entities. Contains all constituents that are
-- subject to indicator Part_Of (both aspect and option variants).
+-- Pending_Access_Types (Elist15)
+-- Defined in all types. Set for incomplete, private, Taft-amendment
+-- types, and their corresponding full views. This list contains all
+-- access types, both named and anonymous, declared between the partial
+-- and the full view. The list is used by the finalization machinery to
+-- ensure that the finalization masters of all pending access types are
+-- fully initialized when the full view is frozen.
+
-- Postcondition_Proc (Node8)
-- Defined only in procedure entities, saves the entity of the generated
-- postcondition proc if one is present, otherwise is set to Empty. Used
@@ -3735,7 +3743,7 @@
-- associated dispatch table to point to entities containing primary or
-- secondary tags. Not set in the _tag component of record types.
--- Relative_Deadline_Variable (Node26) [implementation base type only]
+-- Relative_Deadline_Variable (Node28) [implementation base type only]
-- Defined in task type entities. This flag is set if a valid and
-- effective pragma Relative_Deadline applies to the base type. Points
-- to the entity for a variable that is created to hold the value given
@@ -3852,7 +3860,7 @@
-- node (with a constraint), or a Range node, but not a simple
-- subtype reference (a subtype is converted into a range).
--- Scale_Value (Uint15)
+-- Scale_Value (Uint16)
-- Defined in decimal fixed-point types and subtypes. Contains the scale
-- for the type (i.e. the value of type'Scale = the number of decimal
-- digits after the decimal point).
@@ -4043,7 +4051,7 @@
-- This attribute uses the same field as Overridden_Operation, which is
-- irrelevant in init_procs.
--- Storage_Size_Variable (Node15) [implementation base type only]
+-- Storage_Size_Variable (Node26) [implementation base type only]
-- Defined in access types and task type entities. This flag is set
-- if a valid and effective pragma Storage_Size applies to the base
-- type. Points to the entity for a variable that is created to
@@ -4073,7 +4081,7 @@
-- to string literals in the program). Contains the length of the string
-- literal.
--- String_Literal_Low_Bound (Node15)
+-- String_Literal_Low_Bound (Node18)
-- Defined in string literal subtypes (which are created to correspond
-- to string literals in the program). Contains an expression whose
-- value represents the low bound of the literal. This is a copy of
@@ -5280,6 +5288,7 @@
-- Esize (Uint12)
-- RM_Size (Uint13)
-- Alignment (Uint14)
+ -- Pending_Access_Types (Elist15)
-- Related_Expression (Node24)
-- Current_Use_Clause (Node27)
-- Subprograms_For_Type (Node29)
@@ -5396,17 +5405,17 @@
-- Directly_Designated_Type (Node20)
-- Interface_Name (Node21) (JGNAT usage only)
-- Needs_No_Actuals (Flag22)
- -- Original_Access_Type (Node26)
+ -- Original_Access_Type (Node28)
-- Can_Use_Internal_Rep (Flag229)
-- (plus type attributes)
-- E_Access_Type
-- E_Access_Subtype
- -- Storage_Size_Variable (Node15) (base type only)
-- Master_Id (Node17)
-- Directly_Designated_Type (Node20)
-- Associated_Storage_Pool (Node22) (base type only)
-- Finalization_Master (Node23) (base type only)
+ -- Storage_Size_Variable (Node26) (base type only)
-- Has_Pragma_Controlled (Flag27) (base type only)
-- Has_Storage_Size_Clause (Flag23) (base type only)
-- Is_Access_Constant (Flag69)
@@ -5426,15 +5435,15 @@
-- E_Anonymous_Access_Subprogram_Type
-- E_Anonymous_Access_Protected_Subprogram_Type
- -- Storage_Size_Variable (Node15) ??? is this needed ???
-- Directly_Designated_Type (Node20)
+ -- Storage_Size_Variable (Node26) ??? is this needed ???
-- Can_Use_Internal_Rep (Flag229)
-- (plus type attributes)
-- E_Anonymous_Access_Type
- -- Storage_Size_Variable (Node15) ??? is this needed ???
-- Directly_Designated_Type (Node20)
-- Finalization_Master (Node23)
+ -- Storage_Size_Variable (Node26) ??? is this needed ???
-- (plus type attributes)
-- E_Array_Type
@@ -5558,7 +5567,7 @@
-- E_Decimal_Fixed_Point_Type
-- E_Decimal_Fixed_Subtype
- -- Scale_Value (Uint15)
+ -- Scale_Value (Uint16)
-- Digits_Value (Uint17)
-- Scalar_Range (Node20)
-- Delta_Value (Ureal18)
@@ -5631,9 +5640,9 @@
-- E_Enumeration_Type
-- E_Enumeration_Subtype
- -- Lit_Indexes (Node15) (root type only)
-- Lit_Strings (Node16) (root type only)
-- First_Literal (Node17)
+ -- Lit_Indexes (Node18) (root type only)
-- Default_Aspect_Value (Node19) (base type only)
-- Scalar_Range (Node20)
-- Enum_Pos_To_Rep (Node23) (type only)
@@ -5768,11 +5777,11 @@
-- Scope_Depth (synth)
-- E_General_Access_Type
- -- Storage_Size_Variable (Node15) (base type only)
-- Master_Id (Node17)
-- Directly_Designated_Type (Node20)
-- Associated_Storage_Pool (Node22) (root type only)
-- Finalization_Master (Node23) (root type only)
+ -- Storage_Size_Variable (Node26) (base type only)
-- (plus type attributes)
-- E_Generic_In_Parameter
@@ -6072,10 +6081,10 @@
-- E_Protected_Type
-- E_Protected_Subtype
-- Direct_Primitive_Operations (Elist10)
- -- Entry_Bodies_Array (Node15)
-- First_Private_Entity (Node16)
-- First_Entity (Node17)
-- Corresponding_Record_Type (Node18)
+ -- Entry_Bodies_Array (Node19)
-- Last_Entity (Node20)
-- Discriminant_Constraint (Elist21)
-- Scope_Depth_Value (Uint22)
@@ -6170,9 +6179,9 @@
-- (plus type attributes)
-- E_String_Literal_Subtype
- -- String_Literal_Low_Bound (Node15)
-- String_Literal_Length (Uint16)
-- First_Index (Node17) (always Empty)
+ -- String_Literal_Low_Bound (Node18)
-- Packed_Array_Impl_Type (Node23)
-- (plus type attributes)
@@ -6205,7 +6214,6 @@
-- E_Task_Type
-- E_Task_Subtype
-- Direct_Primitive_Operations (Elist10)
- -- Storage_Size_Variable (Node15) (base type only)
-- First_Private_Entity (Node16)
-- First_Entity (Node17)
-- Corresponding_Record_Type (Node18)
@@ -6215,6 +6223,8 @@
-- Scope_Depth (synth)
-- Stored_Constraint (Elist23)
-- Task_Body_Procedure (Node25)
+ -- Storage_Size_Variable (Node26) (base type only)
+ -- Relative_Deadline_Variable (Node28) (base type only)
-- Delay_Cleanups (Flag114)
-- Has_Master_Entity (Flag21)
-- Has_Storage_Size_Clause (Flag23) (base type only)
@@ -6222,7 +6232,6 @@
-- Sec_Stack_Needed_For_Return (Flag167) ???
-- Has_Entries (synth)
-- Number_Entries (synth)
- -- Relative_Deadline_Variable (Node26) (base type only)
-- (plus type attributes)
-- E_Variable
@@ -6868,6 +6877,7 @@
function Packed_Array_Impl_Type (Id : E) return E;
function Parent_Subtype (Id : E) return E;
function Part_Of_Constituents (Id : E) return L;
+ function Pending_Access_Types (Id : E) return L;
function Postcondition_Proc (Id : E) return E;
function Prival (Id : E) return E;
function Prival_Link (Id : E) return E;
@@ -7514,6 +7524,7 @@
procedure Set_Packed_Array_Impl_Type (Id : E; V : E);
procedure Set_Parent_Subtype (Id : E; V : E);
procedure Set_Part_Of_Constituents (Id : E; V : L);
+ procedure Set_Pending_Access_Types (Id : E; V : L);
procedure Set_Postcondition_Proc (Id : E; V : E);
procedure Set_Prival (Id : E; V : E);
procedure Set_Prival_Link (Id : E; V : E);
@@ -8312,6 +8323,7 @@
pragma Inline (Parameter_Mode);
pragma Inline (Parent_Subtype);
pragma Inline (Part_Of_Constituents);
+ pragma Inline (Pending_Access_Types);
pragma Inline (Postcondition_Proc);
pragma Inline (Prival);
pragma Inline (Prival_Link);
@@ -8757,6 +8769,7 @@
pragma Inline (Set_Packed_Array_Impl_Type);
pragma Inline (Set_Parent_Subtype);
pragma Inline (Set_Part_Of_Constituents);
+ pragma Inline (Set_Pending_Access_Types);
pragma Inline (Set_Postcondition_Proc);
pragma Inline (Set_Prival);
pragma Inline (Set_Prival_Link);
Index: freeze.adb
===================================================================
--- freeze.adb (revision 220273)
+++ freeze.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
@@ -1796,25 +1796,6 @@
Next_Entity (Ent);
end loop;
end;
-
- -- 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 derived from them, 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 (Root_Type (E))
- and then Needs_Finalization (Designated_Type (E))
- then
- Build_Finalization_Master (E);
end if;
Next_Entity (E);
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb (revision 220273)
+++ exp_ch4.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
@@ -1278,30 +1278,6 @@
Prefix => New_Occurrence_Of (Temp, Loc))),
Typ => T));
end if;
-
- -- Generate:
- -- Set_Finalize_Address (<PtrT>FM, <T>FD'Unrestricted_Access);
-
- -- Do not generate this call in the following cases:
-
- -- * .NET/JVM - these targets do not support address arithmetic
- -- and unchecked conversion, key elements of Finalize_Address.
-
- -- * CodePeer mode - TSS primitive Finalize_Address is not
- -- created in this mode.
-
- if VM_Target = No_VM
- and then not CodePeer_Mode
- and then Present (Finalization_Master (PtrT))
- and then Present (Temp_Decl)
- and then Nkind (Expression (Temp_Decl)) = N_Allocator
- then
- Insert_Action (N,
- Make_Set_Finalize_Address_Call
- (Loc => Loc,
- Typ => T,
- Ptr_Typ => PtrT));
- end if;
end if;
Rewrite (N, New_Occurrence_Of (Temp, Loc));
@@ -4868,40 +4844,22 @@
(Obj_Ref => New_Copy_Tree (Init_Arg1),
Typ => T));
- if Present (Finalization_Master (PtrT)) then
+ -- Special processing for .NET/JVM, the allocated object is
+ -- attached to the finalization master. Generate:
- -- 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>FM, Root_Controlled_Ptr (Init_Arg1));
+ -- Types derived from [Limited_]Controlled are the only ones
+ -- considered since they have fields Prev and Next.
- -- Types derived from [Limited_]Controlled are the only
- -- ones considered since they have fields Prev and Next.
-
- if VM_Target /= No_VM then
- if Is_Controlled (T) then
- Insert_Action (N,
- Make_Attach_Call
- (Obj_Ref => New_Copy_Tree (Init_Arg1),
- Ptr_Typ => PtrT));
- end if;
-
- -- Default case, generate:
-
- -- Set_Finalize_Address
- -- (<PtrT>FM, <T>FD'Unrestricted_Access);
-
- -- Do not generate this call in CodePeer mode, as TSS
- -- primitive Finalize_Address is not created in this
- -- mode.
-
- elsif not CodePeer_Mode then
- Insert_Action (N,
- Make_Set_Finalize_Address_Call
- (Loc => Loc,
- Typ => T,
- Ptr_Typ => PtrT));
- end if;
+ if VM_Target /= No_VM
+ and then Is_Controlled (T)
+ and then Present (Finalization_Master (PtrT))
+ then
+ Insert_Action (N,
+ Make_Attach_Call
+ (Obj_Ref => New_Copy_Tree (Init_Arg1),
+ Ptr_Typ => PtrT));
end if;
end if;
Index: exp_ch6.adb
===================================================================
--- exp_ch6.adb (revision 220273)
+++ exp_ch6.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
@@ -415,9 +415,10 @@
and then No (Finalization_Master (Ptr_Typ))
then
Build_Finalization_Master
- (Typ => Ptr_Typ,
- Ins_Node => Associated_Node_For_Itype (Ptr_Typ),
- Encl_Scope => Scope (Ptr_Typ));
+ (Typ => Ptr_Typ,
+ For_Anonymous => True,
+ Context_Scope => Scope (Ptr_Typ),
+ Insertion_Node => Associated_Node_For_Itype (Ptr_Typ));
end if;
-- Access-to-controlled types should always have a master
@@ -8357,33 +8358,6 @@
Add_Access_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Return_Obj_Actual);
- -- If the build-in-place function call returns a controlled object,
- -- the finalization master will require a reference to routine
- -- Finalize_Address of the designated type. Setting this attribute
- -- is done in the same manner to expansion of allocators.
-
- if Needs_Finalization (Result_Subt) then
-
- -- Controlled types with supressed finalization do not need to
- -- associate the address of their Finalize_Address primitives with
- -- a master since they do not need a master to begin with.
-
- if Is_Library_Level_Entity (Acc_Type)
- and then Finalize_Storage_Only (Result_Subt)
- then
- null;
-
- -- Do not generate the call to Set_Finalize_Address in CodePeer mode
- -- because Finalize_Address is never built.
-
- elsif not CodePeer_Mode then
- Insert_Action (Allocator,
- Make_Set_Finalize_Address_Call (Loc,
- Typ => Etype (Function_Id),
- Ptr_Typ => Acc_Type));
- end if;
- end if;
-
-- Finally, replace the allocator node with a reference to the temp
Rewrite (Allocator, New_Occurrence_Of (Return_Obj_Access, Loc));
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb (revision 220273)
+++ exp_ch3.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
@@ -2395,16 +2395,14 @@
declare
Parent_IP : constant Name_Id :=
Make_Init_Proc_Name (Etype (Rec_Ent));
- Stmt : Node_Id;
- IP_Call : Node_Id;
+ Stmt : Node_Id := First (Stmts);
+ IP_Call : Node_Id := Empty;
IP_Stmts : List_Id;
begin
-- Look for a call to the parent IP at the beginning
-- of Stmts associated with the record extension
- Stmt := First (Stmts);
- IP_Call := Empty;
while Present (Stmt) loop
if Nkind (Stmt) = N_Procedure_Call_Statement
and then Chars (Name (Stmt)) = Parent_IP
@@ -6318,8 +6316,9 @@
procedure Expand_Freeze_Array_Type (N : Node_Id) is
Typ : constant Entity_Id := Entity (N);
+ Base : constant Entity_Id := Base_Type (Typ);
Comp_Typ : constant Entity_Id := Component_Type (Typ);
- Base : constant Entity_Id := Base_Type (Typ);
+ Ins_Node : Node_Id;
begin
if not Is_Bit_Packed_Array (Typ) then
@@ -6386,10 +6385,22 @@
if Ekind (Comp_Typ) = E_Anonymous_Access_Type
and then Needs_Finalization (Designated_Type (Comp_Typ))
then
+ -- The finalization master is inserted before the declaration
+ -- of the array type. The only exception to this is when the
+ -- array type is an itype, in which case the master appears
+ -- before the related context.
+
+ if Is_Itype (Typ) then
+ Ins_Node := Associated_Node_For_Itype (Typ);
+ else
+ Ins_Node := Parent (Typ);
+ end if;
+
Build_Finalization_Master
- (Typ => Comp_Typ,
- Ins_Node => Parent (Typ),
- Encl_Scope => Scope (Typ));
+ (Typ => Comp_Typ,
+ For_Anonymous => True,
+ Context_Scope => Scope (Typ),
+ Insertion_Node => Ins_Node);
end if;
end if;
@@ -7342,9 +7353,10 @@
(Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object));
Build_Finalization_Master
- (Typ => Root_Type (Comp_Typ),
- Ins_Node => Ins_Node,
- Encl_Scope => Encl_Scope);
+ (Typ => Root_Type (Comp_Typ),
+ For_Anonymous => True,
+ Context_Scope => Encl_Scope,
+ Insertion_Node => Ins_Node);
Fin_Mas_Id := Finalization_Master (Comp_Typ);
@@ -7387,9 +7399,10 @@
else
Build_Finalization_Master
- (Typ => Comp_Typ,
- Ins_Node => Ins_Node,
- Encl_Scope => Encl_Scope);
+ (Typ => Comp_Typ,
+ For_Anonymous => True,
+ Context_Scope => Encl_Scope,
+ Insertion_Node => Ins_Node);
end if;
end if;
@@ -7466,9 +7479,97 @@
-- Save the current Ghost mode in effect in case the type being frozen
-- sets a different mode.
+ procedure Process_RACW_Types (Typ : Entity_Id);
+ -- Validate and generate stubs for all RACW types associated with type
+ -- Typ.
+
+ procedure Process_Pending_Access_Types (Typ : Entity_Id);
+ -- Associate type Typ's Finalize_Address primitive with the finalization
+ -- masters of pending access-to-Typ types.
+
procedure Restore_Globals;
-- Restore the values of all saved global variables
+ ------------------------
+ -- Process_RACW_Types --
+ ------------------------
+
+ procedure Process_RACW_Types (Typ : Entity_Id) is
+ List : constant Elist_Id := Access_Types_To_Process (N);
+ E : Elmt_Id;
+ Seen : Boolean := False;
+
+ begin
+ if Present (List) then
+ E := First_Elmt (List);
+ while Present (E) loop
+ if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then
+ Validate_RACW_Primitives (Node (E));
+ Seen := True;
+ end if;
+
+ Next_Elmt (E);
+ end loop;
+ end if;
+
+ -- If there are RACWs designating this type, make stubs now
+
+ if Seen then
+ Remote_Types_Tagged_Full_View_Encountered (Typ);
+ end if;
+ end Process_RACW_Types;
+
+ ----------------------------------
+ -- Process_Pending_Access_Types --
+ ----------------------------------
+
+ procedure Process_Pending_Access_Types (Typ : Entity_Id) is
+ E : Elmt_Id;
+
+ begin
+ -- Finalize_Address is not generated in CodePeer mode because the
+ -- body contains address arithmetic. This processing is disabled.
+
+ if CodePeer_Mode then
+ null;
+
+ -- Certain itypes are generated for contexts that cannot allocate
+ -- objects and should not set primitive Finalize_Address.
+
+ elsif Is_Itype (Typ)
+ and then Nkind (Associated_Node_For_Itype (Typ)) =
+ N_Explicit_Dereference
+ then
+ null;
+
+ -- When an access type is declared after the incomplete view of a
+ -- Taft-amendment type, the access type is considered pending in
+ -- case the full view of the Taft-amendment type is controlled. If
+ -- this is indeed the case, associate the Finalize_Address routine
+ -- of the full view with the finalization masters of all pending
+ -- access types. This scenario applies to anonymous access types as
+ -- well.
+
+ elsif Needs_Finalization (Typ)
+ and then Present (Pending_Access_Types (Typ))
+ then
+ E := First_Elmt (Pending_Access_Types (Typ));
+ while Present (E) loop
+
+ -- Generate:
+ -- Set_Finalize_Address
+ -- (Ptr_Typ, <Typ>FD'Unrestricted_Access);
+
+ Append_Freeze_Action (Typ,
+ Make_Set_Finalize_Address_Call
+ (Loc => Sloc (N),
+ Ptr_Typ => Node (E)));
+
+ Next_Elmt (E);
+ end loop;
+ end if;
+ end Process_Pending_Access_Types;
+
---------------------
-- Restore_Globals --
---------------------
@@ -7480,9 +7581,8 @@
-- Local variables
- Def_Id : constant Entity_Id := Entity (N);
- RACW_Seen : Boolean := False;
- Result : Boolean := False;
+ Def_Id : constant Entity_Id := Entity (N);
+ Result : Boolean := False;
-- Start of processing for Freeze_Type
@@ -7493,30 +7593,11 @@
Set_Ghost_Mode_For_Freeze (Def_Id, N);
- -- Process associated access types needing special processing
+ -- Process any remote access-to-class-wide types designating the type
+ -- being frozen.
- if Present (Access_Types_To_Process (N)) then
- declare
- E : Elmt_Id := First_Elmt (Access_Types_To_Process (N));
+ Process_RACW_Types (Def_Id);
- begin
- while Present (E) loop
- if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then
- Validate_RACW_Primitives (Node (E));
- RACW_Seen := True;
- end if;
-
- E := Next_Elmt (E);
- end loop;
- end;
-
- -- If there are RACWs designating this type, make stubs now
-
- if RACW_Seen then
- Remote_Types_Tagged_Full_View_Encountered (Def_Id);
- end if;
- end if;
-
-- Freeze processing for record types
if Is_Record_Type (Def_Id) then
@@ -7760,18 +7841,26 @@
then
null;
- -- Assume that incomplete and private types are always completed
- -- by a controlled full view.
+ -- Create a finalization master for an access-to-controlled type
+ -- or an access-to-incomplete type. It is assumed that the full
+ -- view will be controlled.
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 Needs_Finalization (Component_Type (Desig_Type)))
+ or else (Is_Incomplete_Type (Desig_Type)
+ and then No (Full_View (Desig_Type)))
then
Build_Finalization_Master (Def_Id);
+
+ -- Create a finalization master when the designated type contains
+ -- a private component. It is assumed that the full view will be
+ -- controlled.
+
+ elsif Has_Private_Component (Desig_Type) then
+ Build_Finalization_Master
+ (Typ => Def_Id,
+ For_Private => True,
+ Context_Scope => Scope (Def_Id),
+ Insertion_Node => Declaration_Node (Desig_Type));
end if;
end;
@@ -7810,6 +7899,11 @@
end if;
+ -- Complete the initialization of all pending access types' finalization
+ -- masters now that the designated type has been is frozen and primitive
+ -- Finalize_Address generated.
+
+ Process_Pending_Access_Types (Def_Id);
Freeze_Stream_Operations (N, Def_Id);
Restore_Globals;
