+2015-05-22 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * einfo.adb Node36 is now used as Anonymous_Master. Flag253
+ is now unused.
+ (Anonymous_Master): New routine.
+ (Has_Anonymous_Master): Removed.
+ (Set_Anonymous_Master): New routine.
+ (Set_Has_Anonymous_Master): Removed.
+ (Write_Entity_Flags): Remove the output for Has_Anonymous_Maser.
+ (Write_Field36_Name): Add output for Anonymous_Master.
+ * einfo.ads Add new attribute Anonymous_Master along with
+ occurrences in nodes. Remove attribute Has_Anonymous_Master along
+ with occurrences in nodes.
+ (Anonymous_Master): New routine along with pragma Inline.
+ (Has_Anonymous_Master): Removed along with pragma Inline.
+ (Set_Anonymous_Master): New routine along with pragma Inline.
+ (Set_Has_Anonymous_Master): Removed along with pragma Inline.
+ * exp_ch4.adb (Create_Anonymous_Master): New routine.
+ (Current_Anonymous_Master): Reimplemented.
+
2015-05-22 Bob Duff <duff@adacore.com>
* freeze.adb (Freeze_Profile): Suppress warning if imported
-- Import_Pragma Node35
- -- (unused) Node36
+ -- Anonymous_Master Node36
+
-- (unused) Node38
-- (unused) Node39
-- (unused) Node40
-- Has_Implicit_Dereference Flag251
-- Is_Processed_Transient Flag252
- -- Has_Anonymous_Master Flag253
-- Is_Implementation_Defined Flag254
-- Is_Predicate_Function Flag255
-- Is_Predicate_Function_M Flag256
-- Has_Volatile_Full_Access Flag285
-- Needs_Typedef Flag286
+ -- (unused) Flag253
-- (unused) Flag287
-- (unused) Flag288
-- (unused) Flag289
return Uint14 (Id);
end Alignment;
+ function Anonymous_Master (Id : E) return E is
+ begin
+ pragma Assert (Ekind_In (Id, E_Function, E_Package, E_Procedure));
+ return Node36 (Id);
+ end Anonymous_Master;
+
function Associated_Entity (Id : E) return E is
begin
return Node37 (Id);
return Flag79 (Id);
end Has_All_Calls_Remote;
- function Has_Anonymous_Master (Id : E) return B is
- begin
- pragma Assert
- (Ekind_In (Id, E_Function, E_Package, E_Package_Body, E_Procedure));
- return Flag253 (Id);
- end Has_Anonymous_Master;
-
function Has_Atomic_Components (Id : E) return B is
begin
return Flag86 (Implementation_Base_Type (Id));
Set_Elist16 (Id, V);
end Set_Access_Disp_Table;
+ procedure Set_Anonymous_Master (Id : E; V : E) is
+ begin
+ pragma Assert (Ekind_In (Id, E_Function, E_Package, E_Procedure));
+ Set_Node36 (Id, V);
+ end Set_Anonymous_Master;
+
procedure Set_Associated_Entity (Id : E; V : E) is
begin
Set_Node37 (Id, V);
Set_Flag79 (Id, V);
end Set_Has_All_Calls_Remote;
- procedure Set_Has_Anonymous_Master (Id : E; V : B := True) is
- begin
- pragma Assert
- (Ekind_In (Id, E_Function, E_Package, E_Package_Body, E_Procedure));
- Set_Flag253 (Id, V);
- end Set_Has_Anonymous_Master;
-
procedure Set_Has_Atomic_Components (Id : E; V : B := True) is
begin
pragma Assert (not Is_Type (Id) or else Is_Base_Type (Id));
W ("Has_Aliased_Components", Flag135 (Id));
W ("Has_Alignment_Clause", Flag46 (Id));
W ("Has_All_Calls_Remote", Flag79 (Id));
- W ("Has_Anonymous_Master", Flag253 (Id));
W ("Has_Atomic_Components", Flag86 (Id));
W ("Has_Biased_Representation", Flag139 (Id));
W ("Has_Completion", Flag26 (Id));
procedure Write_Field36_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
+ when E_Function |
+ E_Operator |
+ E_Package |
+ E_Procedure =>
+ Write_Str ("Anonymous_Master");
+
when others =>
Write_Str ("Field36??");
end case;
-- definition clause with an (obsolescent) mod clause is converted
-- into an attribute definition clause for this purpose.
+-- Anonymous_Master (Node36)
+-- Defined in the entities of non-generic subprogram and package units.
+-- Contains the entity of a special heterogeneous finalization master
+-- that services most anonymous access-to-controlled allocations that
+-- occur within the unit.
+
-- Associated_Entity (Node37)
-- Defined in all entities. This field is similar to Associated_Node, but
-- applied to entities. The attribute links an entity from the generic
-- entities, so the flag Is_Remote_Call_Interface will always be set if
-- this flag is set.
--- Has_Anonymous_Master (Flag253)
--- Defined in units (top-level functions and procedures, library-level
--- packages). Set if the associated unit contains a heterogeneous
--- finalization master. The master's name is of the form <unit>AM and it
--- services anonymous access-to-controlled types with an undetermined
--- lifetime.
-
-- Has_Atomic_Components (Flag86) [implementation base type only]
-- Defined in all types and objects. Set only for an array type or
-- an array object if a valid pragma Atomic_Components applies to the
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Import_Pragma (Node35) (non-generic case only)
+ -- Anonymous_Master (Node36) (non-generic case only)
-- Body_Needed_For_SAL (Flag40)
-- Contains_Ignored_Ghost_Code (Flag279)
-- Default_Expressions_Processed (Flag108)
-- Delay_Subprogram_Descriptors (Flag50)
-- Discard_Names (Flag88)
-- Elaboration_Entity_Required (Flag174)
- -- Has_Anonymous_Master (Flag253)
-- Has_Completion (Flag26)
-- Has_Controlling_Result (Flag98)
-- Has_Expanded_Contract (Flag240) (non-generic case only)
-- SPARK_Pragma (Node32)
-- SPARK_Aux_Pragma (Node33)
-- Contract (Node34)
+ -- Anonymous_Master (Node36) (non-generic case only)
-- Delay_Subprogram_Descriptors (Flag50)
-- Body_Needed_For_SAL (Flag40)
-- Contains_Ignored_Ghost_Code (Flag279)
-- Elaborate_Body_Desirable (Flag210) (non-generic case only)
-- From_Limited_With (Flag159)
-- Has_All_Calls_Remote (Flag79)
- -- Has_Anonymous_Master (Flag253)
-- Has_Completion (Flag26)
-- Has_Forward_Instantiation (Flag175)
-- Has_Master_Entity (Flag21)
-- Contract (Node34)
-- Contains_Ignored_Ghost_Code (Flag279)
-- Delay_Subprogram_Descriptors (Flag50)
- -- Has_Anonymous_Master (Flag253)
-- SPARK_Aux_Pragma_Inherited (Flag266)
-- SPARK_Pragma_Inherited (Flag265)
-- Scope_Depth (synth)
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Import_Pragma (Node35) (non-generic case only)
+ -- Anonymous_Master (Node36) (non-generic case only)
-- Body_Needed_For_SAL (Flag40)
-- Contains_Ignored_Ghost_Code (Flag279)
-- Delay_Cleanups (Flag114)
-- Delay_Cleanups (Flag114)
-- Delay_Subprogram_Descriptors (Flag50)
-- Discard_Names (Flag88)
- -- Has_Anonymous_Master (Flag253)
-- Has_Completion (Flag26)
-- Has_Expanded_Contract (Flag240) (non-generic case only)
-- Has_Invariants (Flag232)
function Address_Taken (Id : E) return B;
function Alias (Id : E) return E;
function Alignment (Id : E) return U;
+ function Anonymous_Master (Id : E) return E;
function Associated_Entity (Id : E) return E;
function Associated_Formal_Package (Id : E) return E;
function Associated_Node_For_Itype (Id : E) return N;
function Has_Aliased_Components (Id : E) return B;
function Has_Alignment_Clause (Id : E) return B;
function Has_All_Calls_Remote (Id : E) return B;
- function Has_Anonymous_Master (Id : E) return B;
function Has_Atomic_Components (Id : E) return B;
function Has_Biased_Representation (Id : E) return B;
function Has_Completion (Id : E) return B;
procedure Set_Address_Taken (Id : E; V : B := True);
procedure Set_Alias (Id : E; V : E);
procedure Set_Alignment (Id : E; V : U);
+ procedure Set_Anonymous_Master (Id : E; V : E);
procedure Set_Associated_Entity (Id : E; V : E);
procedure Set_Associated_Formal_Package (Id : E; V : E);
procedure Set_Associated_Node_For_Itype (Id : E; V : N);
procedure Set_Has_Aliased_Components (Id : E; V : B := True);
procedure Set_Has_Alignment_Clause (Id : E; V : B := True);
procedure Set_Has_All_Calls_Remote (Id : E; V : B := True);
- procedure Set_Has_Anonymous_Master (Id : E; V : B := True);
procedure Set_Has_Atomic_Components (Id : E; V : B := True);
procedure Set_Has_Biased_Representation (Id : E; V : B := True);
procedure Set_Has_Completion (Id : E; V : B := True);
pragma Inline (Address_Taken);
pragma Inline (Alias);
pragma Inline (Alignment);
+ pragma Inline (Anonymous_Master);
pragma Inline (Associated_Entity);
pragma Inline (Associated_Formal_Package);
pragma Inline (Associated_Node_For_Itype);
pragma Inline (Has_Aliased_Components);
pragma Inline (Has_Alignment_Clause);
pragma Inline (Has_All_Calls_Remote);
- pragma Inline (Has_Anonymous_Master);
pragma Inline (Has_Atomic_Components);
pragma Inline (Has_Biased_Representation);
pragma Inline (Has_Completion);
pragma Inline (Set_Address_Taken);
pragma Inline (Set_Alias);
pragma Inline (Set_Alignment);
+ pragma Inline (Set_Anonymous_Master);
pragma Inline (Set_Associated_Entity);
pragma Inline (Set_Associated_Formal_Package);
pragma Inline (Set_Associated_Node_For_Itype);
pragma Inline (Set_Has_Aliased_Components);
pragma Inline (Set_Has_Alignment_Clause);
pragma Inline (Set_Has_All_Calls_Remote);
- pragma Inline (Set_Has_Anonymous_Master);
pragma Inline (Set_Has_Atomic_Components);
pragma Inline (Set_Has_Biased_Representation);
pragma Inline (Set_Has_Completion);
------------------------------
function Current_Anonymous_Master return Entity_Id is
- Decls : List_Id;
- Loc : Source_Ptr;
- Subp_Body : Node_Id;
- Unit_Decl : Node_Id;
- Unit_Id : Entity_Id;
+ function Create_Anonymous_Master
+ (Unit_Id : Entity_Id;
+ Decls : List_Id) return Entity_Id;
+ -- Create a new anonymous finalization master for a unit denoted by
+ -- Unit_Id. The declaration of the master along with any specialized
+ -- initialization is inserted at the top of declarative list Decls.
+ -- Return the entity of the anonymous master.
- begin
- Unit_Id := Cunit_Entity (Current_Sem_Unit);
+ -----------------------------
+ -- Create_Anonymous_Master --
+ -----------------------------
- -- Find the entity of the current unit
+ function Create_Anonymous_Master
+ (Unit_Id : Entity_Id;
+ Decls : List_Id) return Entity_Id
+ is
+ First_Decl : Node_Id := Empty;
+ -- The first declaration of list Decls. This variable is used when
+ -- inserting various actions.
- if Ekind (Unit_Id) = E_Subprogram_Body then
+ procedure Insert_And_Analyze (Action : Node_Id);
+ -- Insert arbitrary node Action in declarative list Decl and analyze
+ -- it.
- -- When processing subprogram bodies, the proper scope is always that
- -- of the spec.
+ ------------------------
+ -- Insert_And_Analyze --
+ ------------------------
- Subp_Body := Unit_Id;
- while Present (Subp_Body)
- and then Nkind (Subp_Body) /= N_Subprogram_Body
- loop
- Subp_Body := Parent (Subp_Body);
- end loop;
+ procedure Insert_And_Analyze (Action : Node_Id) is
+ begin
+ -- The list is already populated, the actions are inserted at the
+ -- top of the list, preserving their order.
- Unit_Id := Corresponding_Spec (Subp_Body);
- end if;
+ if Present (First_Decl) then
+ Insert_Before_And_Analyze (First_Decl, Action);
- Loc := Sloc (Unit_Id);
- Unit_Decl := Unit (Cunit (Current_Sem_Unit));
+ -- Otherwise append to the declarations to preserve order
- -- Find the declarations list of the current unit
+ else
+ Append_To (Decls, Action);
+ Analyze (Action);
+ end if;
+ end Insert_And_Analyze;
- if Nkind (Unit_Decl) = N_Package_Declaration then
- Unit_Decl := Specification (Unit_Decl);
- Decls := Visible_Declarations (Unit_Decl);
+ -- Local variables
- if No (Decls) then
- Decls := New_List (Make_Null_Statement (Loc));
- Set_Visible_Declarations (Unit_Decl, Decls);
+ Loc : constant Source_Ptr := Sloc (Unit_Id);
+ FM_Id : Entity_Id;
- elsif Is_Empty_List (Decls) then
- Append_To (Decls, Make_Null_Statement (Loc));
- end if;
+ -- Start of processing for Create_Anonymous_Master
- else
- Decls := Declarations (Unit_Decl);
-
- if No (Decls) then
- Decls := New_List (Make_Null_Statement (Loc));
- Set_Declarations (Unit_Decl, Decls);
-
- elsif Is_Empty_List (Decls) then
- Append_To (Decls, Make_Null_Statement (Loc));
+ begin
+ if Present (Decls) then
+ First_Decl := First (Decls);
end if;
- end if;
-
- -- The current unit has an existing anonymous master, traverse its
- -- declarations and locate the entity.
-
- if Has_Anonymous_Master (Unit_Id) then
- declare
- Decl : Node_Id;
- Fin_Mas_Id : Entity_Id;
- begin
- Decl := First (Decls);
- while Present (Decl) loop
-
- -- Look for the first variable in the declarations whole type
- -- is Finalization_Master.
-
- if Nkind (Decl) = N_Object_Declaration then
- Fin_Mas_Id := Defining_Identifier (Decl);
-
- if Ekind (Fin_Mas_Id) = E_Variable
- and then Etype (Fin_Mas_Id) = RTE (RE_Finalization_Master)
- then
- return Fin_Mas_Id;
- end if;
- end if;
+ -- Since the anonymous master and all its initialization actions are
+ -- inserted at top level, use the scope of the unit when analyzing.
- Next (Decl);
- end loop;
+ Push_Scope (Unit_Id);
- -- The master was not found even though the unit was labeled as
- -- having one.
+ -- Create the anonymous master
- raise Program_Error;
- end;
+ FM_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Unit_Id), "AM"));
+ Set_Anonymous_Master (Unit_Id, FM_Id);
- -- Create a new anonymous master
+ -- Generate:
+ -- <FM_Id> : Finalization_Master;
- else
- declare
- First_Decl : constant Node_Id := First (Decls);
- Action : Node_Id;
- Fin_Mas_Id : Entity_Id;
+ Insert_And_Analyze
+ (Make_Object_Declaration (Loc,
+ Defining_Identifier => FM_Id,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Finalization_Master), Loc)));
- begin
- -- Since the master and its associated initialization is inserted
- -- at top level, use the scope of the unit when analyzing.
+ -- Do not set the base pool and mode of operation on .NET/JVM since
+ -- those targets do not support pools and all VM masters defaulted to
+ -- heterogeneous.
- Push_Scope (Unit_Id);
+ if VM_Target = No_VM then
- -- Create the finalization master
+ -- Generate:
+ -- Set_Base_Pool
+ -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
- Fin_Mas_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Unit_Id), "AM"));
+ Insert_And_Analyze
+ (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:
- -- <Fin_Mas_Id> : Finalization_Master;
+ -- Set_Is_Heterogeneous (<FM_Id>);
- Action :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Fin_Mas_Id,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Finalization_Master), Loc));
-
- Insert_Before_And_Analyze (First_Decl, Action);
+ Insert_And_Analyze
+ (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))));
+ end if;
- -- Mark the unit to prevent the generation of multiple masters
+ Pop_Scope;
- Set_Has_Anonymous_Master (Unit_Id);
+ return FM_Id;
+ end Create_Anonymous_Master;
- -- Do not set the base pool and mode of operation on .NET/JVM
- -- since those targets do not support pools and all VM masters
- -- are heterogeneous by default.
+ -- Local declarations
- if VM_Target = No_VM then
+ Unit_Decl : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
+ Unit_Id : constant Entity_Id := Corresponding_Spec_Of (Unit_Decl);
+ Decls : List_Id;
+ FM_Id : Entity_Id;
+ Unit_Spec : Node_Id;
- -- Generate:
- -- Set_Base_Pool
- -- (<Fin_Mas_Id>, Global_Pool_Object'Unrestricted_Access);
+ -- Start of processing for Current_Anonymous_Master
- Action :=
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
+ begin
+ FM_Id := Anonymous_Master (Unit_Id);
- Parameter_Associations => New_List (
- New_Occurrence_Of (Fin_Mas_Id, Loc),
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc),
- Attribute_Name => Name_Unrestricted_Access)));
+ -- Create a new anonymous master when allocating an object of anonymous
+ -- access-to-controlled type for the first time.
- Insert_Before_And_Analyze (First_Decl, Action);
+ if No (FM_Id) then
- -- Generate:
- -- Set_Is_Heterogeneous (<Fin_Mas_Id>);
+ -- Find the declarative list of the current unit
- Action :=
- 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)));
+ if Nkind (Unit_Decl) = N_Package_Declaration then
+ Unit_Spec := Specification (Unit_Decl);
+ Decls := Visible_Declarations (Unit_Spec);
- Insert_Before_And_Analyze (First_Decl, Action);
+ if No (Decls) then
+ Decls := New_List;
+ Set_Visible_Declarations (Unit_Spec, Decls);
end if;
- -- Restore the original state of the scope stack
+ -- Package or subprogram body
- Pop_Scope;
+ else
+ Decls := Declarations (Unit_Decl);
- return Fin_Mas_Id;
- end;
+ if No (Decls) then
+ Decls := New_List;
+ Set_Declarations (Unit_Decl, Decls);
+ end if;
+ end if;
+
+ FM_Id := Create_Anonymous_Master (Unit_Id, Decls);
end if;
+
+ return FM_Id;
end Current_Anonymous_Master;
--------------------------------
projects / gcc.git / commitdiff