[Ada] Generate internal interface entities compiling with -gnatc
Arnaud Charlet
charlet@adacore.com
Wed Jul 29 12:14:00 GMT 2009
This patch does not modify the functionality of the compiler. It moves
the generation of internal interface entities associated with interfaces
to the semantic analyzer. Done to provide ASIS with such information.
These internal entities provide the relationship between the interface
primitives and the tagged type primitives that cover them.
Tested on x86_64-pc-linux-gnu, committed on trunk
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.
-------------- next part --------------
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 150198)
+++ sem_ch3.adb (working copy)
@@ -1506,6 +1506,97 @@ package body Sem_Ch3 is
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 --
-----------------------------------
Index: sem_ch3.ads
===================================================================
--- sem_ch3.ads (revision 150198)
+++ sem_ch3.ads (working copy)
@@ -64,6 +64,11 @@ package Sem_Ch3 is
-- 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 ???)
Index: sem.adb
===================================================================
--- sem.adb (revision 150198)
+++ sem.adb (working copy)
@@ -243,7 +243,7 @@ package body Sem is
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);
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb (revision 150198)
+++ sem_ch13.adb (working copy)
@@ -40,6 +40,7 @@ with Rident; use Rident;
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;
@@ -2197,6 +2198,33 @@ package body Sem_Ch13 is
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 --
------------------------------------------
Index: sem_ch13.ads
===================================================================
--- sem_ch13.ads (revision 150198)
+++ sem_ch13.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- 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- --
@@ -31,6 +31,7 @@ package Sem_Ch13 is
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);
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb (revision 150199)
+++ exp_ch3.adb (working copy)
@@ -5617,105 +5617,6 @@ package body Exp_Ch3 is
-------------------------------
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;
@@ -5948,17 +5849,6 @@ package body Exp_Ch3 is
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);
More information about the Gcc-patches
mailing list