+2009-07-29 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch3.ads, sem_ch3.adb (Add_Internal_Interface_Entities): Routine
+ moved from the expander to the semantic analyzer to allow the
+ generation of these internal entities when compiling with no code
+ generation. Required by ASIS.
+ * sem.adb (Analyze): Add processing for N_Freeze_Entity nodes.
+ * sem_ch13.ads, sem_ch13.adb (Analyze_Freeze_Entity): New subprogram.
+ * exp_ch3.adb (Add_Internal_Interface_Entities): Moved to sem_ch3
+ (Expand_Freeze_Record_Type): Remove call to
+ Add_Internal_Interface_Entities because this routine is now called at
+ early stage --when the freezing node is analyzed.
+
2009-07-29 Robert Dewar <dewar@adacore.com>
* exp_atag.ads, exp_atag.adb, s-tasini.adb, s-soflin.ads,
-------------------------------
procedure Expand_Freeze_Record_Type (N : Node_Id) is
-
- procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id);
- -- Add to the list of primitives of Tagged_Types the internal entities
- -- associated with interface primitives that are located in secondary
- -- dispatch tables.
-
- -------------------------------------
- -- Add_Internal_Interface_Entities --
- -------------------------------------
-
- procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is
- Elmt : Elmt_Id;
- Iface : Entity_Id;
- Iface_Elmt : Elmt_Id;
- Iface_Prim : Entity_Id;
- Ifaces_List : Elist_Id;
- New_Subp : Entity_Id := Empty;
- Prim : Entity_Id;
-
- begin
- pragma Assert (Ada_Version >= Ada_05
- and then Is_Record_Type (Tagged_Type)
- and then Is_Tagged_Type (Tagged_Type)
- and then Has_Interfaces (Tagged_Type)
- and then not Is_Interface (Tagged_Type));
-
- Collect_Interfaces (Tagged_Type, Ifaces_List);
-
- Iface_Elmt := First_Elmt (Ifaces_List);
- while Present (Iface_Elmt) loop
- Iface := Node (Iface_Elmt);
-
- -- Exclude from this processing interfaces that are parents
- -- of Tagged_Type because their primitives are located in the
- -- primary dispatch table (and hence no auxiliary internal
- -- entities are required to handle secondary dispatch tables
- -- in such case).
-
- if not Is_Ancestor (Iface, Tagged_Type) then
- Elmt := First_Elmt (Primitive_Operations (Iface));
- while Present (Elmt) loop
- Iface_Prim := Node (Elmt);
-
- if not Is_Predefined_Dispatching_Operation (Iface_Prim) then
- Prim :=
- Find_Primitive_Covering_Interface
- (Tagged_Type => Tagged_Type,
- Iface_Prim => Iface_Prim);
-
- pragma Assert (Present (Prim));
-
- Derive_Subprogram
- (New_Subp => New_Subp,
- Parent_Subp => Iface_Prim,
- Derived_Type => Tagged_Type,
- Parent_Type => Iface);
-
- -- Ada 2005 (AI-251): Decorate internal entity Iface_Subp
- -- associated with interface types. These entities are
- -- only registered in the list of primitives of its
- -- corresponding tagged type because they are only used
- -- to fill the contents of the secondary dispatch tables.
- -- Therefore they are removed from the homonym chains.
-
- Set_Is_Hidden (New_Subp);
- Set_Is_Internal (New_Subp);
- Set_Alias (New_Subp, Prim);
- Set_Is_Abstract_Subprogram (New_Subp,
- Is_Abstract_Subprogram (Prim));
- Set_Interface_Alias (New_Subp, Iface_Prim);
-
- -- Internal entities associated with interface types are
- -- only registered in the list of primitives of the
- -- tagged type. They are only used to fill the contents
- -- of the secondary dispatch tables. Therefore they are
- -- not needed in the homonym chains.
-
- Remove_Homonym (New_Subp);
-
- -- Hidden entities associated with interfaces must have
- -- set the Has_Delay_Freeze attribute to ensure that, in
- -- case of locally defined tagged types (or compiling
- -- with static dispatch tables generation disabled) the
- -- corresponding entry of the secondary dispatch table is
- -- filled when such entity is frozen.
-
- Set_Has_Delayed_Freeze (New_Subp);
- end if;
-
- Next_Elmt (Elmt);
- end loop;
- end if;
-
- Next_Elmt (Iface_Elmt);
- end loop;
- end Add_Internal_Interface_Entities;
-
- -- Local variables
-
Def_Id : constant Node_Id := Entity (N);
Type_Decl : constant Node_Id := Parent (Def_Id);
Comp : Entity_Id;
Insert_Actions (N, Null_Proc_Decl_List);
end if;
- -- Ada 2005 (AI-251): Add internal entities associated with
- -- secondary dispatch tables to the list of primitives of tagged
- -- types that are not interfaces
-
- if Ada_Version >= Ada_05
- and then not Is_Interface (Def_Id)
- and then Has_Interfaces (Def_Id)
- then
- Add_Internal_Interface_Entities (Def_Id);
- end if;
-
Set_Is_Frozen (Def_Id);
Set_All_DT_Position (Def_Id);
Analyze_Free_Statement (N);
when N_Freeze_Entity =>
- null; -- no semantic processing required
+ Analyze_Freeze_Entity (N);
when N_Full_Type_Declaration =>
Analyze_Type_Declaration (N);
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
+with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
Analyze (Expression (N));
end Analyze_Free_Statement;
+ ---------------------------
+ -- Analyze_Freeze_Entity --
+ ---------------------------
+
+ procedure Analyze_Freeze_Entity (N : Node_Id) is
+ E : constant Entity_Id := Entity (N);
+
+ begin
+ -- For tagged types covering interfaces add internal entities that link
+ -- the primitives of the interfaces with the primitives that cover them.
+
+ -- Note: These entities were originally generated only when generating
+ -- code because their main purpose was to provide support to initialize
+ -- the secondary dispatch tables. They are now generated also when
+ -- compiling with no code generation to provide ASIS the relationship
+ -- between interface primitives and tagged type primitives.
+
+ if Ada_Version >= Ada_05
+ and then Ekind (E) = E_Record_Type
+ and then Is_Tagged_Type (E)
+ and then not Is_Interface (E)
+ and then Has_Interfaces (E)
+ then
+ Add_Internal_Interface_Entities (E);
+ end if;
+ end Analyze_Freeze_Entity;
+
------------------------------------------
-- Analyze_Record_Representation_Clause --
------------------------------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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- --
procedure Analyze_Attribute_Definition_Clause (N : Node_Id);
procedure Analyze_Enumeration_Representation_Clause (N : Node_Id);
procedure Analyze_Free_Statement (N : Node_Id);
+ procedure Analyze_Freeze_Entity (N : Node_Id);
procedure Analyze_Record_Representation_Clause (N : Node_Id);
procedure Analyze_Code_Statement (N : Node_Id);
end if;
end Add_Interface_Tag_Components;
+ -------------------------------------
+ -- Add_Internal_Interface_Entities --
+ -------------------------------------
+
+ procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is
+ Elmt : Elmt_Id;
+ Iface : Entity_Id;
+ Iface_Elmt : Elmt_Id;
+ Iface_Prim : Entity_Id;
+ Ifaces_List : Elist_Id;
+ New_Subp : Entity_Id := Empty;
+ Prim : Entity_Id;
+
+ begin
+ pragma Assert (Ada_Version >= Ada_05
+ and then Is_Record_Type (Tagged_Type)
+ and then Is_Tagged_Type (Tagged_Type)
+ and then Has_Interfaces (Tagged_Type)
+ and then not Is_Interface (Tagged_Type));
+
+ Collect_Interfaces (Tagged_Type, Ifaces_List);
+
+ Iface_Elmt := First_Elmt (Ifaces_List);
+ while Present (Iface_Elmt) loop
+ Iface := Node (Iface_Elmt);
+
+ -- Exclude from this processing interfaces that are parents
+ -- of Tagged_Type because their primitives are located in the
+ -- primary dispatch table (and hence no auxiliary internal
+ -- entities are required to handle secondary dispatch tables
+ -- in such case).
+
+ if not Is_Ancestor (Iface, Tagged_Type) then
+ Elmt := First_Elmt (Primitive_Operations (Iface));
+ while Present (Elmt) loop
+ Iface_Prim := Node (Elmt);
+
+ if not Is_Predefined_Dispatching_Operation (Iface_Prim) then
+ Prim :=
+ Find_Primitive_Covering_Interface
+ (Tagged_Type => Tagged_Type,
+ Iface_Prim => Iface_Prim);
+
+ pragma Assert (Present (Prim));
+
+ Derive_Subprogram
+ (New_Subp => New_Subp,
+ Parent_Subp => Iface_Prim,
+ Derived_Type => Tagged_Type,
+ Parent_Type => Iface);
+
+ -- Ada 2005 (AI-251): Decorate internal entity Iface_Subp
+ -- associated with interface types. These entities are
+ -- only registered in the list of primitives of its
+ -- corresponding tagged type because they are only used
+ -- to fill the contents of the secondary dispatch tables.
+ -- Therefore they are removed from the homonym chains.
+
+ Set_Is_Hidden (New_Subp);
+ Set_Is_Internal (New_Subp);
+ Set_Alias (New_Subp, Prim);
+ Set_Is_Abstract_Subprogram (New_Subp,
+ Is_Abstract_Subprogram (Prim));
+ Set_Interface_Alias (New_Subp, Iface_Prim);
+
+ -- Internal entities associated with interface types are
+ -- only registered in the list of primitives of the
+ -- tagged type. They are only used to fill the contents
+ -- of the secondary dispatch tables. Therefore they are
+ -- not needed in the homonym chains.
+
+ Remove_Homonym (New_Subp);
+
+ -- Hidden entities associated with interfaces must have
+ -- set the Has_Delay_Freeze attribute to ensure that, in
+ -- case of locally defined tagged types (or compiling
+ -- with static dispatch tables generation disabled) the
+ -- corresponding entry of the secondary dispatch table is
+ -- filled when such entity is frozen.
+
+ Set_Has_Delayed_Freeze (New_Subp);
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
+
+ Next_Elmt (Iface_Elmt);
+ end loop;
+ end Add_Internal_Interface_Entities;
+
-----------------------------------
-- Analyze_Component_Declaration --
-----------------------------------
-- the signature of the implicit type works like the profile of a regular
-- subprogram.
+ procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id);
+ -- Add to the list of primitives of Tagged_Type the internal entities
+ -- associated with covered interface primitives. These entities link the
+ -- interface primitives with the tagged type primitives that cover them.
+
procedure Analyze_Declarations (L : List_Id);
-- Called to analyze a list of declarations (in what context ???). Also
-- performs necessary freezing actions (more description needed ???)
projects / thirdparty / gcc.git / commitdiff
