From 3ff38f33e666dc1eadd5daeba3c1c60b6c06f508 Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Wed, 29 Jul 2009 10:34:29 +0000 Subject: [PATCH] sem_ch3.ads, [...] (Add_Internal_Interface_Entities): Routine moved from the expander to the semantic analyzer to allow the... 2009-07-29 Javier Miranda * 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. From-SVN: r150205 --- gcc/ada/ChangeLog | 13 +++++ gcc/ada/exp_ch3.adb | 110 ------------------------------------------- gcc/ada/sem.adb | 2 +- gcc/ada/sem_ch13.adb | 28 +++++++++++ gcc/ada/sem_ch13.ads | 3 +- gcc/ada/sem_ch3.adb | 91 +++++++++++++++++++++++++++++++++++ gcc/ada/sem_ch3.ads | 5 ++ 7 files changed, 140 insertions(+), 112 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e54daa9ea65..90120e89d55 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,16 @@ +2009-07-29 Javier Miranda + + * 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 * exp_atag.ads, exp_atag.adb, s-tasini.adb, s-soflin.ads, diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 4895d2e0793..c0861e30890 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -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); diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 8e2acdda7ca..bac147c96b9 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -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); diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index a2156b38cd4..6542dd28174 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -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 -- ------------------------------------------ diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index 175f3040fc8..93587fd38d2 100644 --- a/gcc/ada/sem_ch13.ads +++ b/gcc/ada/sem_ch13.ads @@ -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); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 84deca1e7e5..d8f1e1dd36b 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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 -- ----------------------------------- diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index 6c7dbaae032..477f0205f38 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -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 ???)