diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 19 | ||||
| -rw-r--r-- | gcc/ada/prj-tree.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/prj-tree.ads | 94 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_disp.adb | 38 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 7 |
8 files changed, 156 insertions, 38 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1f6be285147..ee3c5e2e348 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,22 @@ +2009-11-30 Vincent Celier <celier@adacore.com> + + * prj-tree.ads: Minor comment updates + * prj-tree.adb: Minor reformatting + +2009-11-30 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Derive_Subprogram): Indicate that an inherited + predefined control operation is hidden if the parent type is not + visibly controlled. + * sem_ch6.adb (Check_Overriding_Indicator): Do not report error if + overridden operation is not visible, as may be the case with predefined + control operations. + * sem_disp.adb (Check_Dispatching_Operation): Do not emit warning on + non-overriding control operation when type is not visibly controlled, + if the subprogram has an explicit overriding indicator. + * sem_util.ads, sem_util.adb (Is_Visibly_Controlled): Moved here from + sem_disp.adb. + 2009-11-30 Emmanuel Briot <briot@adacore.com> * prj-tree.adb (Create_Attribute): Fix handling of VMS and Windows diff --git a/gcc/ada/prj-tree.adb b/gcc/ada/prj-tree.adb index b35d889962a..0129f1d8342 100644 --- a/gcc/ada/prj-tree.adb +++ b/gcc/ada/prj-tree.adb @@ -3027,7 +3027,7 @@ package body Prj.Tree is return Pack; end Create_Package; - ------------------- + ---------------------- -- Create_Attribute -- ---------------------- diff --git a/gcc/ada/prj-tree.ads b/gcc/ada/prj-tree.ads index f794c4aab69..d3b86e6ef9a 100644 --- a/gcc/ada/prj-tree.ads +++ b/gcc/ada/prj-tree.ads @@ -408,7 +408,8 @@ package Prj.Tree is (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (First_Declarative_Item_Of); - -- Only valid for N_With_Clause nodes + -- Only valid for N_Project_Declaration, N_Case_Item and + -- N_Package_Declaration. function Extended_Project_Of (Node : Project_Node_Id; @@ -492,7 +493,7 @@ package Prj.Tree is In_Tree : Project_Node_Tree_Ref) return Name_Id; pragma Inline (Associative_Array_Index_Of); -- Only valid for N_Attribute_Declaration and N_Attribute_Reference. - -- Returns No_String for non associative array attributes. + -- Returns No_Name for non associative array attributes. function Next_Variable (Node : Project_Node_Id; @@ -573,8 +574,8 @@ package Prj.Tree is (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (First_Choice_Of); - -- Return the first choice in a N_Case_Item, or Empty_Node if - -- this is when others. + -- Only valid for N_Case_Item nodes. Return the first choice in a + -- N_Case_Item, or Empty_Node if this is when others. function Next_Case_Item (Node : Project_Node_Id; @@ -665,8 +666,11 @@ package Prj.Tree is -- The following procedures are part of the abstract interface of the -- Project File tree. - -- Each Set_* procedure is valid only for the same Project_Node_Kind - -- nodes as the corresponding query function above. + -- Foe each Set_* procedure the condition of validity is specified. If an + -- access function is called with invalid arguments, then exception + -- Assertion_Error is raised if assertions are enabled, otherwise the + -- behaviour is not defined and may result in a crash. + -- These are very low-level, and manipulate the tree itself directly. You -- should look at the Create_* procedure instead if you want to use higher -- level constructs @@ -676,146 +680,183 @@ package Prj.Tree is In_Tree : Project_Node_Tree_Ref; To : Name_Id); pragma Inline (Set_Name_Of); + -- Valid for all non empty nodes. procedure Set_Kind_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Kind); pragma Inline (Set_Kind_Of); + -- Valid for all non empty nodes procedure Set_Location_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Source_Ptr); pragma Inline (Set_Location_Of); + -- Valid for all non empty nodes procedure Set_First_Comment_After (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Comment_After); + -- Valid only for N_Comment_Zones nodes procedure Set_First_Comment_After_End (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Comment_After_End); + -- Valid only for N_Comment_Zones nodes procedure Set_First_Comment_Before (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Comment_Before); + -- Valid only for N_Comment_Zones nodes procedure Set_First_Comment_Before_End (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Comment_Before_End); + -- Valid only for N_Comment_Zones nodes procedure Set_Next_Comment (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_Comment); + -- Valid only for N_Comment nodes procedure Set_Parent_Project_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); + -- Valid only for N_Project nodes procedure Set_Project_File_Includes_Unkept_Comments (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Boolean); + -- Valid only for N_Project nodes procedure Set_Directory_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Path_Name_Type); pragma Inline (Set_Directory_Of); + -- Valid only for N_Project nodes procedure Set_Expression_Kind_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Variable_Kind); pragma Inline (Set_Expression_Kind_Of); + -- Only valid for N_Literal_String, N_Attribute_Declaration, + -- N_Variable_Declaration, N_Typed_Variable_Declaration, N_Expression, + -- N_Term, N_Variable_Reference or N_Attribute_Reference nodes. procedure Set_Is_Extending_All (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref); pragma Inline (Set_Is_Extending_All); + -- Only valid for N_Project and N_With_Clause procedure Set_Is_Not_Last_In_List (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref); pragma Inline (Set_Is_Not_Last_In_List); + -- Only valid for N_With_Clause procedure Set_First_Variable_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Variable_Node_Id); pragma Inline (Set_First_Variable_Of); + -- Only valid for N_Project or N_Package_Declaration nodes procedure Set_First_Package_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Package_Declaration_Id); pragma Inline (Set_First_Package_Of); + -- Only valid for N_Project nodes procedure Set_Package_Id_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Package_Node_Id); pragma Inline (Set_Package_Id_Of); + -- Only valid for N_Package_Declaration nodes procedure Set_Path_Name_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Path_Name_Type); pragma Inline (Set_Path_Name_Of); + -- Only valid for N_Project and N_With_Clause nodes procedure Set_String_Value_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Name_Id); pragma Inline (Set_String_Value_Of); + -- Only valid for N_With_Clause, N_Literal_String nodes or N_Comment. + + procedure Set_Source_Index_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Int); + pragma Inline (Set_Source_Index_Of); + -- Only valid for N_Literal_String and N_Attribute_Declaration nodes. For + -- N_Literal_String, set the source index of the litteral string. For + -- N_Attribute_Declaration, set the source index of the index of the + -- associative array element. procedure Set_First_With_Clause_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_With_Clause_Of); + -- Only valid for N_Project nodes procedure Set_Project_Declaration_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Project_Declaration_Of); + -- Only valid for N_Project nodes procedure Set_Project_Qualifier_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Qualifier); pragma Inline (Set_Project_Qualifier_Of); + -- Only valid for N_Project nodes procedure Set_Extending_Project_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Extending_Project_Of); + -- Only valid for N_Project_Declaration nodes procedure Set_First_String_Type_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_String_Type_Of); + -- Only valid for N_Project nodes procedure Set_Extended_Project_Path_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Path_Name_Type); pragma Inline (Set_Extended_Project_Path_Of); + -- Only valid for N_With_Clause nodes procedure Set_Project_Node_Of (Node : Project_Node_Id; @@ -823,185 +864,214 @@ package Prj.Tree is To : Project_Node_Id; Limited_With : Boolean := False); pragma Inline (Set_Project_Node_Of); + -- Only valid for N_With_Clause, N_Variable_Reference and + -- N_Attribute_Reference nodes. procedure Set_Next_With_Clause_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_With_Clause_Of); + -- Only valid for N_With_Clause nodes procedure Set_First_Declarative_Item_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Declarative_Item_Of); + -- Only valid for N_Project_Declaration, N_Case_Item and + -- N_Package_Declaration. procedure Set_Extended_Project_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Extended_Project_Of); + -- Only valid for N_Project_Declaration nodes procedure Set_Current_Item_Node (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Current_Item_Node); + -- Only valid for N_Declarative_Item nodes procedure Set_Next_Declarative_Item (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_Declarative_Item); + -- Only valid for N_Declarative_Item node procedure Set_Project_Of_Renamed_Package_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Project_Of_Renamed_Package_Of); + -- Only valid for N_Package_Declaration nodes. procedure Set_Next_Package_In_Project (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_Package_In_Project); + -- Only valid for N_Package_Declaration nodes procedure Set_First_Literal_String (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Literal_String); + -- Only valid for N_String_Type_Declaration nodes procedure Set_Next_String_Type (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_String_Type); + -- Only valid for N_String_Type_Declaration nodes procedure Set_Next_Literal_String (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_Literal_String); + -- Only valid for N_Literal_String nodes procedure Set_Expression_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Expression_Of); + -- Only valid for N_Attribute_Declaration, N_Typed_Variable_Declaration + -- or N_Variable_Declaration nodes procedure Set_Associative_Project_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Associative_Project_Of); + -- Only valid for N_Attribute_Declaration nodes procedure Set_Associative_Package_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Associative_Package_Of); + -- Only valid for N_Attribute_Declaration nodes procedure Set_Associative_Array_Index_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Name_Id); pragma Inline (Set_Associative_Array_Index_Of); + -- Only valid for N_Attribute_Declaration and N_Attribute_Reference. procedure Set_Next_Variable (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_Variable); + -- Only valid for N_Typed_Variable_Declaration or N_Variable_Declaration + -- nodes. procedure Set_First_Term (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Term); + -- Only valid for N_Expression nodes procedure Set_Next_Expression_In_List (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_Expression_In_List); + -- Only valid for N_Expression nodes procedure Set_Current_Term (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Current_Term); + -- Only valid for N_Term nodes procedure Set_Next_Term (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_Term); + -- Only valid for N_Term nodes procedure Set_First_Expression_In_List (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Expression_In_List); + -- Only valid for N_Literal_String_List nodes procedure Set_Package_Node_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Package_Node_Of); - - procedure Set_Source_Index_Of - (Node : Project_Node_Id; - In_Tree : Project_Node_Tree_Ref; - To : Int); - pragma Inline (Set_Source_Index_Of); + -- Only valid for N_Variable_Reference or N_Attribute_Reference nodes. procedure Set_String_Type_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_String_Type_Of); + -- Only valid for N_Variable_Reference or N_Typed_Variable_Declaration + -- nodes. procedure Set_External_Reference_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_External_Reference_Of); + -- Only valid for N_External_Value nodes procedure Set_External_Default_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_External_Default_Of); + -- Only valid for N_External_Value nodes procedure Set_Case_Variable_Reference_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Case_Variable_Reference_Of); + -- Only valid for N_Case_Construction nodes procedure Set_First_Case_Item_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Case_Item_Of); + -- Only valid for N_Case_Construction nodes procedure Set_First_Choice_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Choice_Of); + -- Only valid for N_Case_Item nodes. procedure Set_Next_Case_Item (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_Case_Item); + -- Only valid for N_Case_Item nodes. procedure Set_Case_Insensitive (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Boolean); + -- Only valid for N_Attribute_Declaration and N_Attribute_Reference nodes ------------------------------- -- Restricted Access Section -- diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 7dd9629da6a..a95c7fa7128 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -12418,6 +12418,24 @@ package body Sem_Ch3 is Set_Convention (New_Subp, Convention (Parent_Subp)); end if; + -- Predefined controlled operations retain their name even if the parent + -- is hidden (see above), but they are not primitive operations if the + -- ancestor is not visible, for example if the parent is a private + -- extension completed with a controlled extension. Note that a full + -- type that is controlled can break privacy: the flag Is_Controlled is + -- set on both views of the type. + + if Is_Controlled (Parent_Type) + and then + (Chars (Parent_Subp) = Name_Initialize + or else Chars (Parent_Subp) = Name_Adjust + or else Chars (Parent_Subp) = Name_Finalize) + and then Is_Hidden (Parent_Subp) + and then not Is_Visibly_Controlled (Parent_Type) + then + Set_Is_Hidden (New_Subp); + end if; + Set_Is_Imported (New_Subp, Is_Imported (Parent_Subp)); Set_Is_Exported (New_Subp, Is_Exported (Parent_Subp)); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 94ed69e2598..c57bb563656 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -4454,7 +4454,9 @@ package body Sem_Ch6 is end; end if; - if Present (Overridden_Subp) then + if Present (Overridden_Subp) + and then not Is_Hidden (Overridden_Subp) + then if Must_Not_Override (Spec) then Error_Msg_Sloc := Sloc (Overridden_Subp); diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 705f428716a..2ee5a80e5d0 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -48,7 +48,6 @@ with Sem_Eval; use Sem_Eval; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Snames; use Snames; -with Stand; use Stand; with Sinfo; use Sinfo; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -673,27 +672,6 @@ package body Sem_Disp is Has_Dispatching_Parent : Boolean := False; Body_Is_Last_Primitive : Boolean := False; - function Is_Visibly_Controlled (T : Entity_Id) return Boolean; - -- Check whether T is derived from a visibly controlled type. - -- This is true if the root type is declared in Ada.Finalization. - -- If T is derived instead from a private type whose full view - -- is controlled, an explicit Initialize/Adjust/Finalize subprogram - -- does not override the inherited one. - - --------------------------- - -- Is_Visibly_Controlled -- - --------------------------- - - function Is_Visibly_Controlled (T : Entity_Id) return Boolean is - Root : constant Entity_Id := Root_Type (T); - begin - return Chars (Scope (Root)) = Name_Finalization - and then Chars (Scope (Scope (Root))) = Name_Ada - and then Scope (Scope (Scope (Root))) = Standard_Standard; - end Is_Visibly_Controlled; - - -- Start of processing for Check_Dispatching_Operation - begin if Ekind (Subp) /= E_Procedure and then Ekind (Subp) /= E_Function then return; @@ -1030,8 +1008,20 @@ package body Sem_Disp is and then not Is_Visibly_Controlled (Tagged_Type) then Set_Is_Overriding_Operation (Subp, False); - Error_Msg_NE - ("operation does not override inherited&?", Subp, Subp); + -- If the subprogram specification carries an overriding + -- indicator, no need for the warning: it is either redundant, + -- or else an error will be reported. + + if Nkind (Parent (Subp)) = N_Procedure_Specification + and then + (Must_Override (Parent (Subp)) + or else Must_Not_Override (Parent (Subp))) + then + null; + else + Error_Msg_NE + ("operation does not override inherited&?", Subp, Subp); + end if; else Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp); Set_Is_Overriding_Operation (Subp); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index cbcbc16588e..48c7dff93b5 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -7238,6 +7238,18 @@ package body Sem_Util is end if; end Is_Variable; + --------------------------- + -- Is_Visibly_Controlled -- + --------------------------- + + function Is_Visibly_Controlled (T : Entity_Id) return Boolean is + Root : constant Entity_Id := Root_Type (T); + begin + return Chars (Scope (Root)) = Name_Finalization + and then Chars (Scope (Scope (Root))) = Name_Ada + and then Scope (Scope (Scope (Root))) = Standard_Standard; + end Is_Visibly_Controlled; + ------------------------ -- Is_Volatile_Object -- ------------------------ diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 623a72b2782..016ff91f52f 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -812,6 +812,13 @@ package Sem_Util is -- the point at which Assignment_OK is checked, and True is returned -- for any tree thus marked. + function Is_Visibly_Controlled (T : Entity_Id) return Boolean; + -- Check whether T is derived from a visibly controlled type. + -- This is true if the root type is declared in Ada.Finalization. + -- If T is derived instead from a private type whose full view + -- is controlled, an explicit Initialize/Adjust/Finalize subprogram + -- does not override the inherited one. + function Is_Volatile_Object (N : Node_Id) return Boolean; -- Determines if the given node denotes an volatile object in the sense -- of the legality checks described in RM C.6(12). Note that the test |