From: Ed Schonberg Date: Tue, 2 Aug 2011 08:03:11 +0000 (+0000) Subject: atree.h, [...]: New subprograms to manipulate Elist5. X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=29efbb8cc60bc986c8a761e2a947b84d3e10a9fd;p=gcc.git atree.h, [...]: New subprograms to manipulate Elist5. 2011-08-02 Ed Schonberg * atree.h, atree.ads, atree.adb: New subprograms to manipulate Elist5. * par_ch8.adb (P_Use_Type): initialize Used_Operations for node. * sinfo.ads, sinfo.adb (Used_Operations): new attribute of use_type_clauses, to handle more efficiently use_type and use_all_type constructs. * sem_ch8.adb: Rewrite Use_One_Type and End_Use_Type to handle the Ada2012 Use_All_Type clause. (Use_Class_Wide_Operations): new procedure. From-SVN: r177090 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b7a2c5e4abd..fb77921fccc 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,14 @@ +2011-08-02 Ed Schonberg + + * atree.h, atree.ads, atree.adb: New subprograms to manipulate Elist5. + * par_ch8.adb (P_Use_Type): initialize Used_Operations for node. + * sinfo.ads, sinfo.adb (Used_Operations): new attribute of + use_type_clauses, to handle more efficiently use_type and use_all_type + constructs. + * sem_ch8.adb: Rewrite Use_One_Type and End_Use_Type to handle the + Ada2012 Use_All_Type clause. + (Use_Class_Wide_Operations): new procedure. + 2011-08-02 Robert Dewar * exp_util.adb, par-ch10.adb, par-ch6.adb, sem.adb, sem_ch6.adb, diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index d0a9cc29229..306845b5f75 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -2457,6 +2457,17 @@ package body Atree is end if; end Elist4; + function Elist5 (N : Node_Id) return Elist_Id is + pragma Assert (N <= Nodes.Last); + Value : constant Union_Id := Nodes.Table (N).Field5; + begin + if Value = 0 then + return No_Elist; + else + return Elist_Id (Value); + end if; + end Elist5; + function Elist8 (N : Node_Id) return Elist_Id is pragma Assert (Nkind (N) in N_Entity); Value : constant Union_Id := Nodes.Table (N + 1).Field8; @@ -4696,6 +4707,11 @@ package body Atree is Nodes.Table (N).Field4 := Union_Id (Val); end Set_Elist4; + procedure Set_Elist5 (N : Node_Id; Val : Elist_Id) is + begin + Nodes.Table (N).Field5 := Union_Id (Val); + end Set_Elist5; + procedure Set_Elist8 (N : Node_Id; Val : Elist_Id) is begin pragma Assert (Nkind (N) in N_Entity); diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index dbdd93ac1ae..2f88bb40daa 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -1111,6 +1111,9 @@ package Atree is function Elist4 (N : Node_Id) return Elist_Id; pragma Inline (Elist4); + function Elist5 (N : Node_Id) return Elist_Id; + pragma Inline (Elist5); + function Elist8 (N : Node_Id) return Elist_Id; pragma Inline (Elist8); @@ -2177,6 +2180,9 @@ package Atree is procedure Set_Elist4 (N : Node_Id; Val : Elist_Id); pragma Inline (Set_Elist4); + procedure Set_Elist5 (N : Node_Id; Val : Elist_Id); + pragma Inline (Set_Elist5); + procedure Set_Elist8 (N : Node_Id; Val : Elist_Id); pragma Inline (Set_Elist8); diff --git a/gcc/ada/atree.h b/gcc/ada/atree.h index 553e60f1e3b..cc4e9b1e3ed 100644 --- a/gcc/ada/atree.h +++ b/gcc/ada/atree.h @@ -431,6 +431,7 @@ extern Node_Id Current_Error_Node; #define Elist2(N) Field2 (N) #define Elist3(N) Field3 (N) #define Elist4(N) Field4 (N) +#define Elist5(N) Field5 (N) #define Elist8(N) Field8 (N) #define Elist10(N) Field10 (N) #define Elist13(N) Field13 (N) diff --git a/gcc/ada/par-ch8.adb b/gcc/ada/par-ch8.adb index 2e58c0058f0..eefd7d82316 100644 --- a/gcc/ada/par-ch8.adb +++ b/gcc/ada/par-ch8.adb @@ -124,6 +124,7 @@ package body Ch8 is Use_Node := New_Node (N_Use_Type_Clause, Prev_Token_Ptr); Set_All_Present (Use_Node, All_Present); Set_Subtype_Marks (Use_Node, New_List); + Set_Used_Operations (Use_Node, No_Elist); if Ada_Version = Ada_83 then Error_Msg_SC ("(Ada 83) use type not allowed!"); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 11a31481aa2..ad87c6f6c65 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -2679,6 +2679,23 @@ package body Sem_Ch8 is Chain_Use_Clause (N); end if; + -- Commented needed??? + + if Used_Operations (N) /= No_Elist then + declare + Elmt : Elmt_Id; + begin + Elmt := First_Elmt (Used_Operations (N)); + while Present (Elmt) loop + Set_Is_Potentially_Use_Visible (Node (Elmt)); + Next_Elmt (Elmt); + end loop; + end; + + return; + end if; + + Set_Used_Operations (N, New_Elmt_List); Id := First (Subtype_Marks (N)); while Present (Id) loop Find_Type (Id); @@ -3535,25 +3552,8 @@ package body Sem_Ch8 is procedure End_Use_Type (N : Node_Id) is Elmt : Elmt_Id; Id : Entity_Id; - Op_List : Elist_Id; - Op : Entity_Id; T : Entity_Id; - function May_Be_Used_Primitive_Of (T : Entity_Id) return Boolean; - -- An operator may be primitive in several types, if they are declared - -- in the same scope as the operator. To determine the use-visibility of - -- the operator in such cases we must examine all types in the profile. - - ------------------------------ - -- May_Be_Used_Primitive_Of -- - ------------------------------ - - function May_Be_Used_Primitive_Of (T : Entity_Id) return Boolean is - begin - return Scope (Op) = Scope (T) - and then (In_Use (T) or else Is_Potentially_Use_Visible (T)); - end May_Be_Used_Primitive_Of; - -- Start of processing for End_Use_Type begin @@ -3585,43 +3585,22 @@ package body Sem_Ch8 is Set_In_Use (Base_Type (T), False); Set_Current_Use_Clause (T, Empty); Set_Current_Use_Clause (Base_Type (T), Empty); - Op_List := Collect_Primitive_Operations (T); - - Elmt := First_Elmt (Op_List); - while Present (Elmt) loop - Op := Node (Elmt); - - if Nkind (Op) = N_Defining_Operator_Symbol then - declare - T_First : constant Entity_Id := - Base_Type (Etype (First_Formal (Op))); - T_Res : constant Entity_Id := Base_Type (Etype (Op)); - T_Next : Entity_Id; - - begin - if Present (Next_Formal (First_Formal (Op))) then - T_Next := - Base_Type (Etype (Next_Formal (First_Formal (Op)))); - else - T_Next := T_First; - end if; - - if not May_Be_Used_Primitive_Of (T_First) - and then not May_Be_Used_Primitive_Of (T_Next) - and then not May_Be_Used_Primitive_Of (T_Res) - then - Set_Is_Potentially_Use_Visible (Op, False); - end if; - end; - end if; - - Next_Elmt (Elmt); - end loop; end if; <> - Next (Id); + Next (Id); end loop; + + if Is_Empty_Elmt_List (Used_Operations (N)) then + return; + + else + Elmt := First_Elmt (Used_Operations (N)); + while Present (Elmt) loop + Set_Is_Potentially_Use_Visible (Node (Elmt), False); + Next_Elmt (Elmt); + end loop; + end if; end End_Use_Type; ---------------------- @@ -7578,6 +7557,11 @@ package body Sem_Ch8 is -- type clause is in the spec of the same package. Even though the spec -- was analyzed first, its context is reloaded when analysing the body. + procedure Use_Class_Wide_Operations (Typ : Entity_Id); + -- AI05-150: if the use_type_clause carries the "all" qualifier, + -- class-wide operations of ancestor types are use-visible if the + -- ancestor type is visible. + ---------------------------- -- Spec_Reloaded_For_Body -- ---------------------------- @@ -7599,6 +7583,70 @@ package body Sem_Ch8 is return False; end Spec_Reloaded_For_Body; + ------------------------------- + -- Use_Class_Wide_Operations -- + ------------------------------- + + procedure Use_Class_Wide_Operations (Typ : Entity_Id) is + Scop : Entity_Id; + Ent : Entity_Id; + + function Is_Class_Wide_Operation_Of + (Op : Entity_Id; + T : Entity_Id) return Boolean; + -- Determine whether a subprogram has a class-wide parameter or + -- result that is T'Class. + + --------------------------------- + -- Is_Class_Wide_Operation_Of -- + --------------------------------- + + function Is_Class_Wide_Operation_Of + (Op : Entity_Id; + T : Entity_Id) return Boolean + is + Formal : Entity_Id; + + begin + Formal := First_Formal (Op); + while Present (Formal) loop + if Etype (Formal) = Class_Wide_Type (T) then + return True; + end if; + Next_Formal (Formal); + end loop; + + if Etype (Op) = Class_Wide_Type (T) then + return True; + end if; + + return False; + end Is_Class_Wide_Operation_Of; + + -- Start of processing for Use_Class_Wide_Operations + + begin + Scop := Scope (Typ); + if not Is_Hidden (Scop) then + Ent := First_Entity (Scop); + while Present (Ent) loop + if Is_Overloadable (Ent) + and then Is_Class_Wide_Operation_Of (Ent, Typ) + and then not Is_Potentially_Use_Visible (Ent) + then + Set_Is_Potentially_Use_Visible (Ent); + Append_Elmt (Ent, Used_Operations (Parent (Id))); + end if; + + Next_Entity (Ent); + end loop; + end if; + + if Is_Derived_Type (Typ) then + Use_Class_Wide_Operations (Etype (Base_Type (Typ))); + end if; + end Use_Class_Wide_Operations; + -- Start of processing for Use_One_Type; begin @@ -7654,19 +7702,40 @@ package body Sem_Ch8 is Set_Current_Use_Clause (T, Parent (Id)); Op_List := Collect_Primitive_Operations (T); + -- Iterate over primitive operations of the type. If an operation is + -- already use_visible, it is the result of a previous use_clause, + -- and already appears on the corresponding entity chain. + Elmt := First_Elmt (Op_List); while Present (Elmt) loop if (Nkind (Node (Elmt)) = N_Defining_Operator_Symbol or else Chars (Node (Elmt)) in Any_Operator_Name) and then not Is_Hidden (Node (Elmt)) + and then not Is_Potentially_Use_Visible (Node (Elmt)) then Set_Is_Potentially_Use_Visible (Node (Elmt)); + Append_Elmt (Node (Elmt), Used_Operations (Parent (Id))); + + elsif Ada_Version >= Ada_2012 + and then All_Present (Parent (Id)) + and then not Is_Hidden (Node (Elmt)) + and then not Is_Potentially_Use_Visible (Node (Elmt)) + then + Set_Is_Potentially_Use_Visible (Node (Elmt)); + Append_Elmt (Node (Elmt), Used_Operations (Parent (Id))); end if; Next_Elmt (Elmt); end loop; end if; + if Ada_Version >= Ada_2012 + and then All_Present (Parent (Id)) + and then Is_Tagged_Type (T) + then + Use_Class_Wide_Operations (T); + end if; + -- If warning on redundant constructs, check for unnecessary WITH if Warn_On_Redundant_Constructs diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 42421425a3e..9ac9424063c 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -3078,6 +3078,14 @@ package body Sinfo is return List2 (N); end Visible_Declarations; + function Used_Operations + (N : Node_Id) return Elist_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Use_Type_Clause); + return Elist5 (N); + end Used_Operations; + function Was_Originally_Stub (N : Node_Id) return Boolean is begin @@ -6123,6 +6131,14 @@ package body Sinfo is Set_List2_With_Parent (N, Val); end Set_Visible_Declarations; + procedure Set_Used_Operations + (N : Node_Id; Val : Elist_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Use_Type_Clause); + Set_Elist5 (N, Val); + end Set_Used_Operations; + procedure Set_Was_Originally_Stub (N : Node_Id; Val : Boolean := True) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index a4ccd62ef07..8d1b51ef6b5 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1804,6 +1804,12 @@ package Sinfo is -- the body, so this flag is used to generate the proper message (see -- Sem_Util.Check_Unused_Withs for details) + -- Used_Operations (Elist5-Sem) + -- Present in N_Use_Type_Clause nodes. Holds the list of operations that + -- are made potentially use-visible by the clause. Simplifies processing + -- on exit from the scope of the use_type_clause, in particular in the + -- case of Use_All_Type, when those operations several scopes. + -- Was_Originally_Stub (Flag13-Sem) -- This flag is set in the node for a proper body that replaces stub. -- During the analysis procedure, stubs in some situations get rewritten @@ -4913,6 +4919,7 @@ package Sinfo is -- Subtype_Marks (List2) -- Next_Use_Clause (Node3-Sem) -- Hidden_By_Use_Clause (Elist4-Sem) + -- Used_Operations (Elist5-Sem) -- All_Present (Flag15) ------------------------------- @@ -8960,6 +8967,9 @@ package Sinfo is function Visible_Declarations (N : Node_Id) return List_Id; -- List2 + function Used_Operations + (N : Node_Id) return Elist_Id; -- Elist5 + function Was_Originally_Stub (N : Node_Id) return Boolean; -- Flag13 @@ -9932,6 +9942,9 @@ package Sinfo is procedure Set_Visible_Declarations (N : Node_Id; Val : List_Id); -- List2 + procedure Set_Used_Operations + (N : Node_Id; Val : Elist_Id); -- Elist5 + procedure Set_Was_Originally_Stub (N : Node_Id; Val : Boolean := True); -- Flag13 @@ -11993,6 +12006,7 @@ package Sinfo is pragma Inline (Variant_Part); pragma Inline (Variants); pragma Inline (Visible_Declarations); + pragma Inline (Used_Operations); pragma Inline (Was_Originally_Stub); pragma Inline (Withed_Body); pragma Inline (Zero_Cost_Handling); @@ -12313,6 +12327,7 @@ package Sinfo is pragma Inline (Set_Variant_Part); pragma Inline (Set_Variants); pragma Inline (Set_Visible_Declarations); + pragma Inline (Set_Used_Operations); pragma Inline (Set_Was_Originally_Stub); pragma Inline (Set_Withed_Body); pragma Inline (Set_Zero_Cost_Handling);