===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2016, 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- --
@@ -301,6 +301,9 @@
Finalize_Case => TSS_Deep_Finalize,
Address_Case => TSS_Finalize_Address);
+ function Allows_Finalization_Master (Typ : Entity_Id) return Boolean;
+ -- Determine whether access type Typ may have a finalization master
+
procedure Build_Array_Deep_Procs (Typ : Entity_Id);
-- Build the deep Initialize/Adjust/Finalize for a record Typ with
-- Has_Controlled_Component set and store them using the TSS mechanism.
@@ -427,7 +430,333 @@
-- [Deep_]Finalize (Acc_Typ (V).all);
-- end;
+ --------------------------------
+ -- Allows_Finalization_Master --
+ --------------------------------
+
+ function Allows_Finalization_Master (Typ : Entity_Id) return Boolean is
+ 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.
+
+ ------------------------------
+ -- In_Deallocation_Instance --
+ ------------------------------
+
+ function In_Deallocation_Instance (E : Entity_Id) return Boolean is
+ Pkg : constant Entity_Id := Scope (E);
+ Par : Node_Id := Empty;
+
+ begin
+ if Ekind (Pkg) = E_Package
+ and then Present (Related_Instance (Pkg))
+ and then Ekind (Related_Instance (Pkg)) = E_Procedure
+ then
+ Par := Generic_Parent (Parent (Related_Instance (Pkg)));
+
+ return
+ Present (Par)
+ and then Chars (Par) = Name_Unchecked_Deallocation
+ and then Chars (Scope (Par)) = Name_Ada
+ and then Scope (Scope (Par)) = Standard_Standard;
+ end if;
+
+ return False;
+ end In_Deallocation_Instance;
+
+ -- Local variables
+
+ Desig_Typ : constant Entity_Id := Designated_Type (Typ);
+ Ptr_Typ : constant Entity_Id :=
+ Root_Type_Of_Full_View (Base_Type (Typ));
+
+ -- Start of processing for Allows_Finalization_Master
+
+ begin
+ -- Certain run-time configurations and targets do not provide support
+ -- for controlled types and therefore do not need masters.
+
+ if Restriction_Active (No_Finalization) then
+ return False;
+
+ -- Do not consider C and C++ types since it is assumed that the non-Ada
+ -- side will handle their clean up.
+
+ elsif Convention (Desig_Typ) = Convention_C
+ or else Convention (Desig_Typ) = Convention_CPP
+ then
+ return False;
+
+ -- Do not consider types that return on the secondary stack
+
+ elsif Present (Associated_Storage_Pool (Ptr_Typ))
+ and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool)
+ then
+ return False;
+
+ -- Do not consider types which may never allocate an object
+
+ elsif No_Pool_Assigned (Ptr_Typ) then
+ return False;
+
+ -- Do not consider 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 (Ptr_Typ) then
+ return False;
+
+ -- Do not consider non-library access types when restriction
+ -- No_Nested_Finalization is in effect since masters are controlled
+ -- objects.
+
+ elsif Restriction_Active (No_Nested_Finalization)
+ and then not Is_Library_Level_Entity (Ptr_Typ)
+ then
+ return False;
+
+ -- Do not create finalization masters in GNATprove mode because this
+ -- causes unwanted extra expansion. A compilation in this mode must
+ -- keep the tree as close as possible to the original sources.
+
+ elsif GNATprove_Mode then
+ return False;
+
+ -- Otherwise the access type may use a finalization master
+
+ else
+ return True;
+ end if;
+ end Allows_Finalization_Master;
+
----------------------------
+ -- Build_Anonymous_Master --
+ ----------------------------
+
+ procedure Build_Anonymous_Master (Ptr_Typ : Entity_Id) is
+ function Create_Anonymous_Master
+ (Desig_Typ : Entity_Id;
+ Unit_Id : Entity_Id;
+ Unit_Decl : Node_Id) return Entity_Id;
+ -- Create a new anonymous finalization master for access type Ptr_Typ
+ -- with designated type Desig_Typ. The declaration of the master along
+ -- with its specialized initialization is inserted in the declarative
+ -- part of unit Unit_Decl. Unit_Id denotes the entity of Unit_Decl.
+
+ function In_Subtree (N : Node_Id; Root : Node_Id) return Boolean;
+ -- Determine whether arbitrary node N appears within the subtree rooted
+ -- at node Root.
+
+ -----------------------------
+ -- Create_Anonymous_Master --
+ -----------------------------
+
+ function Create_Anonymous_Master
+ (Desig_Typ : Entity_Id;
+ Unit_Id : Entity_Id;
+ Unit_Decl : Node_Id) return Entity_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Unit_Id);
+ Spec_Id : constant Entity_Id := Unique_Defining_Entity (Unit_Decl);
+ Decls : List_Id;
+ FM_Decl : Node_Id;
+ FM_Id : Entity_Id;
+ FM_Init : Node_Id;
+ Pref : Character;
+ Unit_Spec : Node_Id;
+
+ begin
+ -- Find the declarative list of the unit
+
+ if Nkind (Unit_Decl) = N_Package_Declaration then
+ Unit_Spec := Specification (Unit_Decl);
+ Decls := Visible_Declarations (Unit_Spec);
+
+ if No (Decls) then
+ Decls := New_List;
+ Set_Visible_Declarations (Unit_Spec, Decls);
+ end if;
+
+ -- Package body or subprogram case
+
+ -- ??? A subprogram spec or body that acts as a compilation unit may
+ -- contain a formal parameter of an anonymous access-to-controlled
+ -- type initialized by an allocator.
+
+ -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
+
+ -- There is no suitable place to create the anonymous master as the
+ -- subprogram is not in a declarative list.
+
+ else
+ Decls := Declarations (Unit_Decl);
+
+ if No (Decls) then
+ Decls := New_List;
+ Set_Declarations (Unit_Decl, Decls);
+ end if;
+ end if;
+
+ -- Step 1: Anonymous master creation
+
+ -- Use a unique prefix in case the same unit requires two anonymous
+ -- masters, one for the spec (S) and one for the body (B).
+
+ if Ekind_In (Unit_Id, E_Function, E_Package, E_Procedure) then
+ Pref := 'S';
+ else
+ Pref := 'B';
+ end if;
+
+ -- The name of the anonymous master has the following format:
+
+ -- [BS]scopN__scop1__chars_of_desig_typAM
+
+ -- The name utilizes the fully qualified name of the designated type
+ -- in case two controlled types with the same name are declared in
+ -- different scopes and both have anonymous access types.
+
+ FM_Id :=
+ Make_Defining_Identifier (Loc,
+ New_External_Name
+ (Related_Id => Get_Qualified_Name (Desig_Typ),
+ Suffix => "AM",
+ Prefix => Pref));
+
+ -- Associate the anonymous master with the designated type. This
+ -- ensures that any additional anonymous access types with the same
+ -- designated type will share the same anonymous paster within the
+ -- same unit.
+
+ Set_Anonymous_Master (Desig_Typ, FM_Id);
+
+ -- Generate:
+ -- <FM_Id> : Finalization_Master;
+
+ FM_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => FM_Id,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Finalization_Master), Loc));
+
+ -- Step 2: Initialization actions
+
+ -- Generate:
+ -- Set_Base_Pool
+ -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
+
+ FM_Init :=
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (FM_Id, Loc),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc),
+ Attribute_Name => Name_Unrestricted_Access)));
+
+ Prepend_To (Decls, FM_Init);
+ Prepend_To (Decls, FM_Decl);
+
+ -- Since the anonymous master and all its initialization actions are
+ -- inserted at top level, use the scope of the unit when analyzing.
+
+ Push_Scope (Spec_Id);
+ Analyze (FM_Decl);
+ Analyze (FM_Init);
+ Pop_Scope;
+
+ return FM_Id;
+ end Create_Anonymous_Master;
+
+ ----------------
+ -- In_Subtree --
+ ----------------
+
+ function In_Subtree (N : Node_Id; Root : Node_Id) return Boolean is
+ Par : Node_Id;
+
+ begin
+ -- Traverse the parent chain until reaching the same root
+
+ Par := N;
+ while Present (Par) loop
+ if Par = Root then
+ return True;
+ end if;
+
+ Par := Parent (Par);
+ end loop;
+
+ return False;
+ end In_Subtree;
+
+ -- Local variables
+
+ Desig_Typ : Entity_Id;
+ FM_Id : Entity_Id;
+ Priv_View : Entity_Id;
+ Unit_Decl : Node_Id;
+ Unit_Id : Entity_Id;
+
+ -- Start of processing for Build_Anonymous_Master
+
+ begin
+ -- Nothing to do if the circumstances do not allow for a finalization
+ -- master.
+
+ if not Allows_Finalization_Master (Ptr_Typ) then
+ return;
+ end if;
+
+ Unit_Decl := Unit (Cunit (Current_Sem_Unit));
+ Unit_Id := Defining_Entity (Unit_Decl);
+
+ -- The compilation unit is a package instantiation. In this case the
+ -- anonymous master is associated with the package spec as both the
+ -- spec and body appear at the same level.
+
+ if Nkind (Unit_Decl) = N_Package_Body
+ and then Nkind (Original_Node (Unit_Decl)) = N_Package_Instantiation
+ then
+ Unit_Id := Corresponding_Spec (Unit_Decl);
+ Unit_Decl := Unit_Declaration_Node (Unit_Id);
+ end if;
+
+ -- Use the initial declaration of the designated type when it denotes
+ -- the full view of an incomplete or private type. This ensures that
+ -- types with one and two views are treated the same.
+
+ Desig_Typ := Directly_Designated_Type (Ptr_Typ);
+ Priv_View := Incomplete_Or_Partial_View (Desig_Typ);
+
+ if Present (Priv_View) then
+ Desig_Typ := Priv_View;
+ end if;
+
+ FM_Id := Anonymous_Master (Desig_Typ);
+
+ -- The designated type already has at least one anonymous access type
+ -- pointing to it within the current unit. Reuse the anonymous master
+ -- because the designated type is the same.
+
+ if Present (FM_Id)
+ and then In_Subtree (Declaration_Node (FM_Id), Root => Unit_Decl)
+ then
+ null;
+
+ -- Otherwise the designated type lacks an anonymous master or it is
+ -- declared in a different unit. Create a brand new master.
+
+ else
+ FM_Id := Create_Anonymous_Master (Desig_Typ, Unit_Id, Unit_Decl);
+ end if;
+
+ Set_Finalization_Master (Ptr_Typ, FM_Id);
+ end Build_Anonymous_Master;
+
+ ----------------------------
-- Build_Array_Deep_Procs --
----------------------------
@@ -762,7 +1091,6 @@
procedure Build_Finalization_Master
(Typ : Entity_Id;
- For_Anonymous : Boolean := False;
For_Lib_Level : Boolean := False;
For_Private : Boolean := False;
Context_Scope : Entity_Id := Empty;
@@ -773,10 +1101,6 @@
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 --
-----------------------------
@@ -798,31 +1122,6 @@
Prepend_Elmt (Ptr_Typ, List);
end Add_Pending_Access_Type;
- ------------------------------
- -- In_Deallocation_Instance --
- ------------------------------
-
- function In_Deallocation_Instance (E : Entity_Id) return Boolean is
- Pkg : constant Entity_Id := Scope (E);
- Par : Node_Id := Empty;
-
- begin
- if Ekind (Pkg) = E_Package
- and then Present (Related_Instance (Pkg))
- and then Ekind (Related_Instance (Pkg)) = E_Procedure
- then
- Par := Generic_Parent (Parent (Related_Instance (Pkg)));
-
- return
- Present (Par)
- and then Chars (Par) = Name_Unchecked_Deallocation
- and then Chars (Scope (Par)) = Name_Ada
- and then Scope (Scope (Par)) = Standard_Standard;
- end if;
-
- return False;
- end In_Deallocation_Instance;
-
-- Local variables
Desig_Typ : constant Entity_Id := Designated_Type (Typ);
@@ -836,67 +1135,17 @@
-- Start of processing for Build_Finalization_Master
begin
- -- Certain run-time configurations and targets do not provide support
- -- for controlled types.
+ -- Nothing to do if the circumstances do not allow for a finalization
+ -- master.
- if Restriction_Active (No_Finalization) then
+ if not Allows_Finalization_Master (Typ) then
return;
- -- Do not process C, C++ types since it is assumed that the non-Ada side
- -- will handle their clean up.
-
- elsif Convention (Desig_Typ) = Convention_C
- or else Convention (Desig_Typ) = Convention_CPP
- then
- return;
-
-- Various machinery such as freezing may have already created a
-- finalization master.
elsif Present (Finalization_Master (Ptr_Typ)) then
return;
-
- -- Do not process types that return on the secondary stack
-
- 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 (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 (Ptr_Typ) then
- return;
-
- -- Ignore the general use of anonymous access types unless the context
- -- requires a finalization master.
-
- elsif Ekind (Ptr_Typ) = E_Anonymous_Access_Type
- and then not For_Anonymous
- then
- return;
-
- -- Do not process non-library access types when restriction No_Nested_
- -- Finalization is in effect since masters are controlled objects.
-
- elsif Restriction_Active (No_Nested_Finalization)
- and then not Is_Library_Level_Entity (Ptr_Typ)
- then
- return;
-
- -- 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.
-
- elsif GNATprove_Mode then
- return;
end if;
declare
@@ -1013,11 +1262,11 @@
Add_Pending_Access_Type (Desig_Typ, Ptr_Typ);
end if;
- -- 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.
+ -- A finalization master created for an access designating a type
+ -- with private components is inserted before a context-dependent
+ -- node.
- if For_Anonymous or For_Private then
+ if For_Private then
-- At this point both the scope of the context and the insertion
-- mode must be known.
@@ -3693,15 +3942,6 @@
end if;
end Check_Visibly_Controlled;
- -------------------------------
- -- CW_Or_Has_Controlled_Part --
- -------------------------------
-
- function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is
- begin
- return Is_Class_Wide_Type (T) or else Needs_Finalization (T);
- end CW_Or_Has_Controlled_Part;
-
------------------
-- Convert_View --
------------------
@@ -3764,6 +4004,15 @@
end if;
end Convert_View;
+ -------------------------------
+ -- CW_Or_Has_Controlled_Part --
+ -------------------------------
+
+ function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is
+ begin
+ return Is_Class_Wide_Type (T) or else Needs_Finalization (T);
+ end CW_Or_Has_Controlled_Part;
+
------------------------
-- Enclosing_Function --
------------------------
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 1992-2016, 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- --
@@ -35,6 +35,11 @@
-- Finalization Management --
-----------------------------
+ procedure Build_Anonymous_Master (Ptr_Typ : Entity_Id);
+ -- Build a finalization master for an anonymous access-to-controlled type
+ -- denoted by Ptr_Typ. The master is inserted in the declarations of the
+ -- current unit.
+
procedure Build_Controlling_Procs (Typ : Entity_Id);
-- Typ is a record, and array type having controlled components.
-- Create the procedures Deep_Initialize, Deep_Adjust and Deep_Finalize
@@ -99,22 +104,19 @@
procedure Build_Finalization_Master
(Typ : Entity_Id;
- For_Anonymous : Boolean := False;
For_Lib_Level : 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 depending on
- -- the context. Flag For_Anonymous must be set when creating a master for
- -- an anonymous access type. Flag For_Lib_Level must be set when creating
- -- a master for a build-in-place function call access result 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 to be
- -- inserted.
+ -- the context. Flag For_Lib_Level must be set when creating a master for a
+ -- build-in-place function call access result 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 flag
+ -- 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 to be inserted.
procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id);
-- Build one controlling procedure when a late body overrides one of
===================================================================
@@ -265,10 +265,9 @@
-- Contract Node34
+ -- Anonymous_Master Node35
-- Import_Pragma Node35
- -- Anonymous_Master Node36
-
-- Class_Wide_Preconds List38
-- Class_Wide_Postconds List39
@@ -757,12 +756,8 @@
function Anonymous_Master (Id : E) return E is
begin
- pragma Assert (Ekind_In (Id, E_Function,
- E_Package,
- E_Package_Body,
- E_Procedure,
- E_Subprogram_Body));
- return Node36 (Id);
+ pragma Assert (Is_Type (Id));
+ return Node35 (Id);
end Anonymous_Master;
function Anonymous_Object (Id : E) return E is
@@ -3682,12 +3677,8 @@
procedure Set_Anonymous_Master (Id : E; V : E) is
begin
- pragma Assert (Ekind_In (Id, E_Function,
- E_Package,
- E_Package_Body,
- E_Procedure,
- E_Subprogram_Body));
- Set_Node36 (Id, V);
+ pragma Assert (Is_Type (Id));
+ Set_Node35 (Id, V);
end Set_Anonymous_Master;
procedure Set_Anonymous_Object (Id : E; V : E) is
@@ -10385,6 +10376,9 @@
procedure Write_Field35_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
+ when Type_Kind =>
+ Write_Str ("Anonymous_Master");
+
when Subprogram_Kind =>
Write_Str ("Import_Pragma");
@@ -10398,19 +10392,9 @@
------------------------
procedure Write_Field36_Name (Id : Entity_Id) is
+ pragma Unreferenced (Id);
begin
- case Ekind (Id) is
- when E_Function |
- E_Operator |
- E_Package |
- E_Package_Body |
- E_Procedure |
- E_Subprogram_Body =>
- Write_Str ("Anonymous_Master");
-
- when others =>
- Write_Str ("Field36??");
- end case;
+ Write_Str ("Field36??");
end Write_Field36_Name;
------------------------
===================================================================
@@ -438,11 +438,11 @@
-- definition clause with an (obsolescent) mod clause is converted
-- into an attribute definition clause for this purpose.
+-- Anonymous_Master (Node35)
+-- Defined in all types. Contains the entity of an anonymous finalization
+-- master which services all anonymous access types associated with the
+-- same designated type within the current semantic unit. The attribute
+-- is set reactively during the expansion of allocators.
-- Anonymous_Object (Node30)
-- Present in protected and task type entities. Contains the entity of
@@ -5468,6 +5468,7 @@
-- Derived_Type_Link (Node31)
-- No_Tagged_Streams_Pragma (Node32)
-- Linker_Section_Pragma (Node33)
+ -- Anonymous_Master (Node35)
-- Depends_On_Private (Flag14)
-- Disable_Controlled (Flag253)
@@ -5668,8 +5669,8 @@
-- Cloned_Subtype (Node16) (subtype case only)
-- First_Entity (Node17)
-- Equivalent_Type (Node18) (always Empty for type)
- -- Last_Entity (Node20)
-- Non_Limited_View (Node19)
+ -- Last_Entity (Node20)
-- SSO_Set_High_By_Default (Flag273) (base type only)
-- SSO_Set_Low_By_Default (Flag272) (base type only)
-- First_Component (synth)
@@ -5919,7 +5920,6 @@
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Import_Pragma (Node35) (non-generic case only)
- -- Anonymous_Master (Node36) (non-generic case only)
-- Class_Wide_Preconds (List38)
-- Class_Wide_Postconds (List39)
-- SPARK_Pragma (Node40)
@@ -6141,7 +6141,6 @@
-- Current_Use_Clause (Node27)
-- Finalizer (Node28) (non-generic case only)
-- Contract (Node34)
- -- Anonymous_Master (Node36) (non-generic case only)
-- SPARK_Pragma (Node40)
-- SPARK_Aux_Pragma (Node41)
-- Delay_Subprogram_Descriptors (Flag50)
@@ -6179,7 +6178,6 @@
-- Scope_Depth_Value (Uint22)
-- Finalizer (Node28) (non-generic case only)
-- Contract (Node34)
- -- Anonymous_Master (Node36)
-- SPARK_Pragma (Node40)
-- SPARK_Aux_Pragma (Node41)
-- Contains_Ignored_Ghost_Code (Flag279)
@@ -6233,7 +6231,6 @@
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Import_Pragma (Node35) (non-generic case only)
- -- Anonymous_Master (Node36) (non-generic case only)
-- Class_Wide_Preconds (List38)
-- Class_Wide_Postconds (List39)
-- SPARK_Pragma (Node40)
@@ -6419,7 +6416,6 @@
-- Scope_Depth_Value (Uint22)
-- Extra_Formals (Node28)
-- Contract (Node34)
- -- Anonymous_Master (Node36)
-- SPARK_Pragma (Node40)
-- Contains_Ignored_Ghost_Code (Flag279)
-- SPARK_Pragma_Inherited (Flag265)
===================================================================
@@ -8322,6 +8322,73 @@
return Get_Pragma_Id (Pragma_Name (N));
end Get_Pragma_Id;
+ ------------------------
+ -- Get_Qualified_Name --
+ ------------------------
+
+ function Get_Qualified_Name
+ (Id : Entity_Id;
+ Suffix : Entity_Id := Empty) return Name_Id
+ is
+ Suffix_Nam : Name_Id := No_Name;
+
+ begin
+ if Present (Suffix) then
+ Suffix_Nam := Chars (Suffix);
+ end if;
+
+ return Get_Qualified_Name (Chars (Id), Suffix_Nam, Scope (Id));
+ end Get_Qualified_Name;
+
+ function Get_Qualified_Name
+ (Nam : Name_Id;
+ Suffix : Name_Id := No_Name;
+ Scop : Entity_Id := Current_Scope) return Name_Id
+ is
+ procedure Add_Scope (S : Entity_Id);
+ -- Add the fully qualified form of scope S to the name buffer. The
+ -- format is:
+ -- s-1__s__
+
+ ---------------
+ -- Add_Scope --
+ ---------------
+
+ procedure Add_Scope (S : Entity_Id) is
+ begin
+ if S = Empty then
+ null;
+
+ elsif S = Standard_Standard then
+ null;
+
+ else
+ Add_Scope (Scope (S));
+ Get_Name_String_And_Append (Chars (S));
+ Add_Str_To_Name_Buffer ("__");
+ end if;
+ end Add_Scope;
+
+ -- Start of processing for Get_Qualified_Name
+
+ begin
+ Name_Len := 0;
+ Add_Scope (Scop);
+
+ -- Append the base name after all scopes have been chained
+
+ Get_Name_String_And_Append (Nam);
+
+ -- Append the suffix (if present)
+
+ if Suffix /= No_Name then
+ Add_Str_To_Name_Buffer ("__");
+ Get_Name_String_And_Append (Suffix);
+ end if;
+
+ return Name_Find;
+ end Get_Qualified_Name;
+
-----------------------
-- Get_Reason_String --
-----------------------
@@ -17762,39 +17829,13 @@
-----------------
procedure Output_Name (Nam : Name_Id; Scop : Entity_Id := Current_Scope) is
- procedure Output_Scope (S : Entity_Id);
- -- Add the fully qualified form of scope S to the name buffer. The
- -- qualification format is:
- -- scope1__scopeN__
-
- ------------------
- -- Output_Scope --
- ------------------
-
- procedure Output_Scope (S : Entity_Id) is
- begin
- if S = Empty then
- null;
-
- elsif S = Standard_Standard then
- null;
-
- else
- Output_Scope (Scope (S));
- Add_Str_To_Name_Buffer (Get_Name_String (Chars (S)));
- Add_Str_To_Name_Buffer ("__");
- end if;
- end Output_Scope;
-
- -- Start of processing for Output_Name
-
begin
- Name_Len := 0;
- Output_Scope (Scop);
-
- Add_Str_To_Name_Buffer (Get_Name_String (Nam));
-
- Write_Str (Name_Buffer (1 .. Name_Len));
+ Write_Str
+ (Get_Name_String
+ (Get_Qualified_Name
+ (Nam => Nam,
+ Suffix => No_Name,
+ Scop => Scop)));
Write_Eol;
end Output_Name;
===================================================================
@@ -950,6 +950,20 @@
pragma Inline (Get_Pragma_Id);
-- Obtains the Pragma_Id from the Chars field of Pragma_Identifier (N)
+ function Get_Qualified_Name
+ (Id : Entity_Id;
+ Suffix : Entity_Id := Empty) return Name_Id;
+ -- Obtain the fully qualified form of entity Id. The format is:
+ -- scope_of_id-1__scope_of_id__chars_of_id__chars_of_suffix
+
+ function Get_Qualified_Name
+ (Nam : Name_Id;
+ Suffix : Name_Id := No_Name;
+ Scop : Entity_Id := Current_Scope) return Name_Id;
+ -- Obtain the fully qualified form of name Nam assuming it appears in scope
+ -- Scop. The format is:
+ -- scop-1__scop__nam__suffix
+
procedure Get_Reason_String (N : Node_Id);
-- Recursive routine to analyze reason argument for pragma Warnings. The
-- value of the reason argument is appended to the current string using
===================================================================
@@ -44,7 +44,6 @@
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Inline; use Inline;
-with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
@@ -57,7 +56,6 @@
with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
@@ -92,12 +90,6 @@
-- If a boolean array assignment can be done in place, build call to
-- corresponding library procedure.
- function Current_Anonymous_Master return Entity_Id;
- -- Return the entity of the heterogeneous finalization master belonging to
- -- the current unit (either function, package or procedure). This master
- -- services all anonymous access-to-controlled types. If the current unit
- -- does not have such master, create one.
-
procedure Displace_Allocator_Pointer (N : Node_Id);
-- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
-- Expand_Allocator_Expression. Allocating class-wide interface objects
@@ -410,202 +402,6 @@
return;
end Build_Boolean_Array_Proc_Call;
- ------------------------------
- -- Current_Anonymous_Master --
- ------------------------------
-
- function Current_Anonymous_Master return Entity_Id is
- function Create_Anonymous_Master
- (Unit_Id : Entity_Id;
- Unit_Decl : Node_Id) return Entity_Id;
- -- Create a new anonymous master for a compilation unit denoted by its
- -- entity Unit_Id and declaration Unit_Decl. The declaration of the new
- -- master along with any specialized initialization is inserted at the
- -- top of the unit's declarations (see body for special cases). Return
- -- the entity of the anonymous master.
-
- -----------------------------
- -- Create_Anonymous_Master --
- -----------------------------
-
- function Create_Anonymous_Master
- (Unit_Id : Entity_Id;
- Unit_Decl : Node_Id) return Entity_Id
- is
- Insert_Nod : Node_Id := Empty;
- -- The point of insertion into the declarative list of the unit. All
- -- nodes are inserted before Insert_Nod.
-
- procedure Insert_And_Analyze (Decls : List_Id; N : Node_Id);
- -- Insert arbitrary node N in declarative list Decls and analyze it
-
- ------------------------
- -- Insert_And_Analyze --
- ------------------------
-
- procedure Insert_And_Analyze (Decls : List_Id; N : Node_Id) is
- begin
- -- The declarative list is already populated, the nodes are
- -- inserted at the top of the list, preserving their order.
-
- if Present (Insert_Nod) then
- Insert_Before (Insert_Nod, N);
-
- -- Otherwise append to the declarations to preserve order
-
- else
- Append_To (Decls, N);
- end if;
-
- Analyze (N);
- end Insert_And_Analyze;
-
- -- Local variables
-
- Loc : constant Source_Ptr := Sloc (Unit_Id);
- Spec_Id : constant Entity_Id := Unique_Defining_Entity (Unit_Decl);
- Decls : List_Id;
- FM_Id : Entity_Id;
- Pref : Character;
- Unit_Spec : Node_Id;
-
- -- Start of processing for Create_Anonymous_Master
-
- begin
- -- Find the declarative list of the unit
-
- if Nkind (Unit_Decl) = N_Package_Declaration then
- Unit_Spec := Specification (Unit_Decl);
- Decls := Visible_Declarations (Unit_Spec);
-
- if No (Decls) then
- Decls := New_List (Make_Null_Statement (Loc));
- Set_Visible_Declarations (Unit_Spec, Decls);
- end if;
-
- -- Package or subprogram body
-
- -- ??? A subprogram declaration that acts as a compilation unit may
- -- contain a formal parameter of an anonymous access-to-controlled
- -- type initialized by an allocator.
-
- -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
-
- -- There is no suitable place to create the anonymous master as the
- -- subprogram is not in a declarative list.
-
- else
- Decls := Declarations (Unit_Decl);
-
- if No (Decls) then
- Decls := New_List (Make_Null_Statement (Loc));
- Set_Declarations (Unit_Decl, Decls);
- end if;
- end if;
-
- -- The anonymous master and all initialization actions are inserted
- -- before the first declaration (if any).
-
- Insert_Nod := First (Decls);
-
- -- Since the anonymous master and all its initialization actions are
- -- inserted at top level, use the scope of the unit when analyzing.
-
- Push_Scope (Spec_Id);
-
- -- Step 1: Anonymous master creation
-
- -- Use a unique prefix in case the same unit requires two anonymous
- -- masters, one for the spec (S) and one for the body (B).
-
- if Ekind_In (Unit_Id, E_Function, E_Package, E_Procedure) then
- Pref := 'S';
- else
- Pref := 'B';
- end if;
-
- FM_Id :=
- Make_Defining_Identifier (Loc,
- New_External_Name
- (Related_Id => Chars (Unit_Id),
- Suffix => "AM",
- Prefix => Pref));
-
- Set_Anonymous_Master (Unit_Id, FM_Id);
-
- -- Generate:
- -- <FM_Id> : Finalization_Master;
-
- Insert_And_Analyze (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => FM_Id,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Finalization_Master), Loc)));
-
- -- Step 2: Initialization actions
-
- -- Generate:
- -- Set_Base_Pool
- -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
-
- Insert_And_Analyze (Decls,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (FM_Id, Loc),
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc),
- Attribute_Name => Name_Unrestricted_Access))));
-
- -- Generate:
- -- Set_Is_Heterogeneous (<FM_Id>);
-
- Insert_And_Analyze (Decls,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Set_Is_Heterogeneous), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (FM_Id, Loc))));
-
- Pop_Scope;
- return FM_Id;
- end Create_Anonymous_Master;
-
- -- Local declarations
-
- Unit_Decl : Node_Id;
- Unit_Id : Entity_Id;
-
- -- Start of processing for Current_Anonymous_Master
-
- begin
- Unit_Decl := Unit (Cunit (Current_Sem_Unit));
- Unit_Id := Defining_Entity (Unit_Decl);
-
- -- The compilation unit is a package instantiation. In this case the
- -- anonymous master is associated with the package spec as both the
- -- spec and body appear at the same level.
-
- if Nkind (Unit_Decl) = N_Package_Body
- and then Nkind (Original_Node (Unit_Decl)) = N_Package_Instantiation
- then
- Unit_Id := Corresponding_Spec (Unit_Decl);
- Unit_Decl := Unit_Declaration_Node (Unit_Id);
- end if;
-
- if Present (Anonymous_Master (Unit_Id)) then
- return Anonymous_Master (Unit_Id);
-
- -- Create a new anonymous master when allocating an object of anonymous
- -- access-to-controlled type for the first time.
-
- else
- return Create_Anonymous_Master (Unit_Id, Unit_Decl);
- end if;
- end Current_Anonymous_Master;
-
--------------------------------
-- Displace_Allocator_Pointer --
--------------------------------
@@ -4296,8 +4092,7 @@
Set_Finalization_Master
(Root_Type (PtrT), Finalization_Master (Rel_Typ));
else
- Set_Finalization_Master
- (Root_Type (PtrT), Current_Anonymous_Master);
+ Build_Anonymous_Master (Root_Type (PtrT));
end if;
end if;
===================================================================
@@ -422,11 +422,7 @@
if Ekind (Ptr_Typ) = E_Anonymous_Access_Type
and then No (Finalization_Master (Ptr_Typ))
then
- Build_Finalization_Master
- (Typ => Ptr_Typ,
- For_Anonymous => True,
- Context_Scope => Scope (Ptr_Typ),
- Insertion_Node => Associated_Node_For_Itype (Ptr_Typ));
+ Build_Anonymous_Master (Ptr_Typ);
end if;
-- Access-to-controlled types should always have a master
===================================================================
@@ -4600,8 +4600,6 @@
Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
- Ins_Node : Node_Id;
-
begin
-- Ensure that all freezing activities are properly flagged as Ghost
@@ -4654,39 +4652,13 @@
end if;
end if;
- if Typ = Base then
- if Has_Controlled_Component (Base) then
- Build_Controlling_Procs (Base);
+ if Typ = Base and then Has_Controlled_Component (Base) then
+ Build_Controlling_Procs (Base);
- if not Is_Limited_Type (Comp_Typ)
- and then Number_Dimensions (Typ) = 1
- then
- Build_Slice_Assignment (Typ);
- end if;
- end if;
-
- -- Create a finalization master to service the anonymous access
- -- components of the array.
-
- if Ekind (Comp_Typ) = E_Anonymous_Access_Type
- and then Needs_Finalization (Designated_Type (Comp_Typ))
+ if not Is_Limited_Type (Comp_Typ)
+ and then Number_Dimensions (Typ) = 1
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,
- For_Anonymous => True,
- Context_Scope => Scope (Typ),
- Insertion_Node => Ins_Node);
+ Build_Slice_Assignment (Typ);
end if;
end if;
@@ -5044,13 +5016,12 @@
Append_To (Lst,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => New_List (Make_Others_Choice (Loc)),
- Statements => New_List (
+ Statements => New_List (
Make_Raise_Constraint_Error (Loc,
Condition => Make_Identifier (Loc, Name_uF),
Reason => CE_Invalid_Data),
Make_Simple_Return_Statement (Loc,
- Expression =>
- Make_Integer_Literal (Loc, -1)))));
+ Expression => Make_Integer_Literal (Loc, -1)))));
-- If either of the restrictions No_Exceptions_Handlers/Propagation is
-- active then return -1 (we cannot usefully raise Constraint_Error in
@@ -5060,10 +5031,9 @@
Append_To (Lst,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => New_List (Make_Others_Choice (Loc)),
- Statements => New_List (
+ Statements => New_List (
Make_Simple_Return_Statement (Loc,
- Expression =>
- Make_Integer_Literal (Loc, -1)))));
+ Expression => Make_Integer_Literal (Loc, -1)))));
end if;
-- Now we can build the function body
@@ -5137,9 +5107,11 @@
Comp : Entity_Id;
Comp_Typ : Entity_Id;
- Has_AACC : Boolean;
Predef_List : List_Id;
+ Wrapper_Decl_List : List_Id := No_List;
+ Wrapper_Body_List : List_Id := No_List;
+
Renamed_Eq : Node_Id := Empty;
-- Defining unit name for the predefined equality function in the case
-- where the type has a primitive operation that is a renaming of
@@ -5147,9 +5119,6 @@
-- user-defined equality function). Used to pass this entity from
-- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies.
- Wrapper_Decl_List : List_Id := No_List;
- Wrapper_Body_List : List_Id := No_List;
-
-- Start of processing for Expand_Freeze_Record_Type
begin
@@ -5212,8 +5181,6 @@
-- of the component types may have been private at the point of the
-- record declaration. Detect anonymous access-to-controlled components.
- Has_AACC := False;
-
Comp := First_Component (Typ);
while Present (Comp) loop
Comp_Typ := Etype (Comp);
@@ -5238,15 +5205,6 @@
Set_Has_Controlled_Component (Typ);
end if;
- -- Non-self-referential anonymous access-to-controlled component
-
- if Ekind (Comp_Typ) = E_Anonymous_Access_Type
- and then Needs_Finalization (Designated_Type (Comp_Typ))
- and then Designated_Type (Comp_Typ) /= Typ
- then
- Has_AACC := True;
- end if;
-
Next_Component (Comp);
end loop;
@@ -5595,97 +5553,6 @@
end;
end if;
- -- Create a heterogeneous finalization master to service the anonymous
- -- access-to-controlled components of the record type.
-
- if Has_AACC then
- declare
- Encl_Scope : constant Entity_Id := Scope (Typ);
- Ins_Node : constant Node_Id := Parent (Typ);
- Loc : constant Source_Ptr := Sloc (Typ);
- Fin_Mas_Id : Entity_Id;
-
- Attributes_Set : Boolean := False;
- Master_Built : Boolean := False;
- -- Two flags which control the creation and initialization of a
- -- common heterogeneous master.
-
- begin
- Comp := First_Component (Typ);
- while Present (Comp) loop
- Comp_Typ := Etype (Comp);
-
- -- A non-self-referential anonymous access-to-controlled
- -- component.
-
- if Ekind (Comp_Typ) = E_Anonymous_Access_Type
- and then Needs_Finalization (Designated_Type (Comp_Typ))
- and then Designated_Type (Comp_Typ) /= Typ
- then
- -- Build a homogeneous master for the first anonymous
- -- access-to-controlled component. This master may be
- -- converted into a heterogeneous collection if more
- -- components are to follow.
-
- if not Master_Built then
- Master_Built := True;
-
- -- All anonymous access-to-controlled types allocate
- -- on the global pool. Note that the finalization
- -- master and the associated storage pool must be set
- -- on the root type (both are "root type only").
-
- Set_Associated_Storage_Pool
- (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object));
-
- Build_Finalization_Master
- (Typ => Root_Type (Comp_Typ),
- For_Anonymous => True,
- Context_Scope => Encl_Scope,
- Insertion_Node => Ins_Node);
-
- Fin_Mas_Id := Finalization_Master (Comp_Typ);
-
- -- Subsequent anonymous access-to-controlled components
- -- reuse the available master.
-
- else
- -- All anonymous access-to-controlled types allocate
- -- on the global pool. Note that both the finalization
- -- master and the associated storage pool must be set
- -- on the root type (both are "root type only").
-
- Set_Associated_Storage_Pool
- (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object));
-
- -- Shared the master among multiple components
-
- Set_Finalization_Master
- (Root_Type (Comp_Typ), Fin_Mas_Id);
-
- -- Convert the master into a heterogeneous collection.
- -- Generate:
- -- Set_Is_Heterogeneous (<Fin_Mas_Id>);
-
- if not Attributes_Set then
- Attributes_Set := True;
-
- Insert_Action (Ins_Node,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (RTE (RE_Set_Is_Heterogeneous), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Fin_Mas_Id, Loc))));
- end if;
- end if;
- end if;
-
- Next_Component (Comp);
- end loop;
- end;
- end if;
-
-- Check whether individual components have a defined invariant, and add
-- the corresponding component invariant checks.