diff options
| -rw-r--r-- | gcc/ada/sem_ch10.adb | 509 |
1 files changed, 457 insertions, 52 deletions
diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 167d088..00df65b 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, 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- -- @@ -239,10 +239,305 @@ package body Sem_Ch10 is Par_Spec_Name : Unit_Name_Type; Unum : Unit_Number_Type; + procedure Check_Redundant_Withs + (Context_Items : List_Id; + Spec_Context_Items : List_Id := No_List); + -- Determine whether the context list of a compilation unit contains + -- redundant with clauses. When checking body clauses against spec + -- clauses, set Context_Items to the context list of the body and + -- Spec_Context_Items to that of the spec. Parent packages are not + -- examined for documentation purposes. + procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id); -- Generate cross-reference information for the parents of child units. -- N is a defining_program_unit_name, and P_Id is the immediate parent. + --------------------------- + -- Check_Redundant_Withs -- + --------------------------- + + procedure Check_Redundant_Withs + (Context_Items : List_Id; + Spec_Context_Items : List_Id := No_List) + is + Clause : Node_Id; + + procedure Process_Body_Clauses + (Context_List : List_Id; + Clause : Node_Id; + Used : in out Boolean; + Used_Type_Or_Elab : in out Boolean); + -- Examine the context clauses of a package body, trying to match + -- the name entity of Clause with any list element. If the match + -- occurs on a use package clause, set Used to True, for a use + -- type clause, pragma Elaborate or pragma Elaborate_All, set + -- Used_Type_Or_Elab to True. + + procedure Process_Spec_Clauses + (Context_List : List_Id; + Clause : Node_Id; + Used : in out Boolean; + Withed : in out Boolean; + Exit_On_Self : Boolean := False); + -- Examine the context clauses of a package spec, trying to match + -- the name entity of Clause with any list element. If the match + -- occurs on a use package clause, set Used to True, for a with + -- package clause other than Clause, set Withed to True. Limited + -- with clauses, implicitly generated with clauses and withs + -- having pragmas Elaborate or Elaborate_All applied to them are + -- skipped. Exit_On_Self is used to control the search loop and + -- force an exit whenever Clause sees itself in the search. + + -------------------------- + -- Process_Body_Clauses -- + -------------------------- + + procedure Process_Body_Clauses + (Context_List : List_Id; + Clause : Node_Id; + Used : in out Boolean; + Used_Type_Or_Elab : in out Boolean) + is + Nam_Ent : constant Entity_Id := Entity (Name (Clause)); + Cont_Item : Node_Id; + Prag_Unit : Node_Id; + Subt_Mark : Node_Id; + Use_Item : Node_Id; + + begin + Used := False; + Used_Type_Or_Elab := False; + + Cont_Item := First (Context_List); + while Present (Cont_Item) loop + + -- Package use clause + + if Nkind (Cont_Item) = N_Use_Package_Clause + and then not Used + then + Use_Item := First (Names (Cont_Item)); + while Present (Use_Item) and then not Used loop + if Entity (Use_Item) = Nam_Ent then + Used := True; + end if; + + Next (Use_Item); + end loop; + + -- Type use clause + + elsif Nkind (Cont_Item) = N_Use_Type_Clause + and then not Used_Type_Or_Elab + then + Subt_Mark := First (Subtype_Marks (Cont_Item)); + while Present (Subt_Mark) + and then not Used_Type_Or_Elab + loop + if Entity (Prefix (Subt_Mark)) = Nam_Ent then + Used_Type_Or_Elab := True; + end if; + + Next (Subt_Mark); + end loop; + + -- Pragma Elaborate or Elaborate_All + + elsif Nkind (Cont_Item) = N_Pragma + and then + (Chars (Cont_Item) = Name_Elaborate + or else + Chars (Cont_Item) = Name_Elaborate_All) + and then not Used_Type_Or_Elab + then + Prag_Unit := + First (Pragma_Argument_Associations (Cont_Item)); + while Present (Prag_Unit) + and then not Used_Type_Or_Elab + loop + if Entity (Expression (Prag_Unit)) = Nam_Ent then + Used_Type_Or_Elab := True; + end if; + + Next (Prag_Unit); + end loop; + end if; + + Next (Cont_Item); + end loop; + end Process_Body_Clauses; + + -------------------------- + -- Process_Spec_Clauses -- + -------------------------- + + procedure Process_Spec_Clauses + (Context_List : List_Id; + Clause : Node_Id; + Used : in out Boolean; + Withed : in out Boolean; + Exit_On_Self : Boolean := False) + is + Nam_Ent : constant Entity_Id := Entity (Name (Clause)); + Cont_Item : Node_Id; + Use_Item : Node_Id; + + begin + Used := False; + Withed := False; + + Cont_Item := First (Context_List); + while Present (Cont_Item) loop + + -- Stop the search since the context items after Cont_Item + -- have already been examined in a previous iteration of + -- the reverse loop in Check_Redundant_Withs. + + if Exit_On_Self + and Cont_Item = Clause + then + exit; + end if; + + -- Package use clause + + if Nkind (Cont_Item) = N_Use_Package_Clause + and then not Used + then + Use_Item := First (Names (Cont_Item)); + while Present (Use_Item) and then not Used loop + if Entity (Use_Item) = Nam_Ent then + Used := True; + end if; + + Next (Use_Item); + end loop; + + -- Package with clause. Avoid processing self, implicitly + -- generated with clauses or limited with clauses. Note + -- that we examine with clauses having pragmas Elaborate + -- or Elaborate_All applied to them due to cases such as: + -- + -- with Pack; + -- with Pack; + -- pragma Elaborate (Pack); + -- + -- In this case, the second with clause is redundant since + -- the pragma applies only to the first "with Pack;". + + elsif Nkind (Cont_Item) = N_With_Clause + and then not Implicit_With (Cont_Item) + and then not Limited_Present (Cont_Item) + and then Cont_Item /= Clause + and then Entity (Name (Cont_Item)) = Nam_Ent + then + Withed := True; + end if; + + Next (Cont_Item); + end loop; + end Process_Spec_Clauses; + + -- Start of processing for Check_Redundant_Withs + + begin + Clause := Last (Context_Items); + while Present (Clause) loop + + -- Avoid checking implicitly generated with clauses, limited + -- with clauses or withs that have pragma Elaborate or + -- Elaborate_All apllied. + + if Nkind (Clause) = N_With_Clause + and then not Implicit_With (Clause) + and then not Limited_Present (Clause) + and then not Elaborate_Present (Clause) + then + -- Package body-to-spec check + + if Present (Spec_Context_Items) then + declare + Used_In_Body : Boolean := False; + Used_In_Spec : Boolean := False; + Used_Type_Or_Elab : Boolean := False; + Withed_In_Spec : Boolean := False; + + begin + Process_Spec_Clauses + (Context_List => Spec_Context_Items, + Clause => Clause, + Used => Used_In_Spec, + Withed => Withed_In_Spec); + + Process_Body_Clauses + (Context_List => Context_Items, + Clause => Clause, + Used => Used_In_Body, + Used_Type_Or_Elab => Used_Type_Or_Elab); + + -- "Type Elab" refers to the presence of either a use + -- type clause, pragmas Elaborate or Elaborate_All. + + -- +---------------+---------------------------+------+ + -- | Spec | Body | Warn | + -- +--------+------+--------+------+-----------+------+ + -- | Withed | Used | Withed | Used | Type Elab | | + -- | X | | X | | | X | + -- | X | | X | X | | | + -- | X | | X | | X | | + -- | X | | X | X | X | | + -- | X | X | X | | | X | + -- | X | X | X | | X | | + -- | X | X | X | X | | X | + -- | X | X | X | X | X | | + -- +--------+------+--------+------+-----------+------+ + + if (Withed_In_Spec + and then not Used_Type_Or_Elab) + and then + ((not Used_In_Spec + and then not Used_In_Body) + or else + Used_In_Spec) + then + Error_Msg_N ("?redundant with clause in body", Clause); + end if; + + Used_In_Body := False; + Used_In_Spec := False; + Used_Type_Or_Elab := False; + Withed_In_Spec := False; + end; + + -- Standalone package spec or body check + + else + declare + Dont_Care : Boolean := False; + Withed : Boolean := False; + + begin + -- The mechanism for examining the context clauses of a + -- package spec can be applied to package body clauses. + + Process_Spec_Clauses + (Context_List => Context_Items, + Clause => Clause, + Used => Dont_Care, + Withed => Withed, + Exit_On_Self => True); + + if Withed then + Error_Msg_N ("?redundant with clause", Clause); + end if; + end; + end if; + end if; + + Prev (Clause); + end loop; + end Check_Redundant_Withs; + -------------------------------- -- Generate_Parent_References -- -------------------------------- @@ -483,6 +778,16 @@ package body Sem_Ch10 is Analyze (Unit_Node); + if Warn_On_Redundant_Constructs then + Check_Redundant_Withs (Context_Items (N)); + + if Nkind (Unit_Node) = N_Package_Body then + Check_Redundant_Withs + (Context_Items => Context_Items (N), + Spec_Context_Items => Context_Items (Lib_Unit)); + end if; + end if; + -- The above call might have made Unit_Node an N_Subprogram_Body -- from something else, so propagate any Acts_As_Spec flag. @@ -802,11 +1107,30 @@ package body Sem_Ch10 is Item : Node_Id; begin - -- Loop through context items. This is done in two: - -- a) The first pass analyzes non-limited with-clauses - -- b) The second pass analyzes limited_with clauses (Ada 2005: AI-50217) + -- First process all configuration pragmas at the start of the context + -- items. Strictly these are not part of the context clause, but that + -- is where the parser puts them. In any case for sure we must analyze + -- these before analyzing the actual context items, since they can have + -- an effect on that analysis (e.g. pragma Ada_2005 may allow a unit to + -- be with'ed as a result of changing categorizations in Ada 2005). Item := First (Context_Items (N)); + while Present (Item) + and then Nkind (Item) = N_Pragma + and then Chars (Item) in Configuration_Pragma_Names + loop + Analyze (Item); + Next (Item); + end loop; + + -- Loop through actual context items. This is done in two passes: + + -- a) The first pass analyzes non-limited with-clauses and also any + -- configuration pragmas (we need to get the latter analyzed right + -- away, since they can affect processing of subsequent items. + + -- b) The second pass analyzes limited_with clauses (Ada 2005: AI-50217) + while Present (Item) loop -- For with clause, analyze the with clause, and then update @@ -826,12 +1150,16 @@ package body Sem_Ch10 is Version_Update (N, Library_Unit (Item)); end if; - -- But skip use clauses at this stage, since we don't want to do - -- any installing of potentially use visible entities until we - -- we actually install the complete context (in Install_Context). + -- Skip pragmas. Configuration pragmas at the start were handled in + -- the loop above, and remaining pragmas are not processed until we + -- actually install the context (see Install_Context). We delay the + -- analysis of these pragmas to make sure that we have installed all + -- the implicit with's on parent units. + + -- Skip use clauses at this stage, since we don't want to do any + -- installing of potentially use visible entities until we we + -- actually install the complete context (in Install_Context). -- Otherwise things can get installed in the wrong context. - -- Similarly, pragmas are analyzed in Install_Context, after all - -- the implicit with's on parent units are generated. else null; @@ -840,7 +1168,8 @@ package body Sem_Ch10 is Next (Item); end loop; - -- Second pass: examine all limited_with clauses + -- Second pass: examine all limited_with clauses. All other context + -- items are ignored in this pass. Item := First (Context_Items (N)); while Present (Item) loop @@ -978,6 +1307,12 @@ package body Sem_Ch10 is if not Implicit_With (Item) then Version_Update (N, Library_Unit (Item)); end if; + + -- Pragmas and use clauses and with clauses other than limited + -- with's are ignored in this pass through the context items. + + else + null; end if; Next (Item); @@ -1215,7 +1550,7 @@ package body Sem_Ch10 is Error_Msg_Name_2 := Get_File_Name (Subunit_Name, Subunit => True); Error_Msg_N - ("subunit% in file{ not found!?", N); + ("subunit% in file{ not found?", N); Subunits_Missing := True; end if; @@ -2377,7 +2712,6 @@ package body Sem_Ch10 is if Nkind (Item) = N_With_Clause and then not Implicit_With (Item) - and then not Private_Present (Item) and then Is_Private_Descendant (Entity (Name (Item))) then Priv_Child := Entity (Name (Item)); @@ -2414,12 +2748,11 @@ package body Sem_Ch10 is Curr_Parent := Scope (Curr_Parent); end loop; - if not Present (Curr_Parent) then + if No (Curr_Parent) then Curr_Parent := Standard_Standard; end if; if Curr_Parent /= Child_Parent then - if Ekind (Priv_Child) = E_Generic_Package and then Chars (Priv_Child) in Text_IO_Package_Name and then Chars (Scope (Scope (Priv_Child))) = Name_Ada @@ -2437,6 +2770,7 @@ package body Sem_Ch10 is end if; elsif not Curr_Private + and then not Private_Present (Item) and then Nkind (Lib_Unit) /= N_Package_Body and then Nkind (Lib_Unit) /= N_Subprogram_Body and then Nkind (Lib_Unit) /= N_Subunit @@ -2739,11 +3073,22 @@ package body Sem_Ch10 is Lib_Parent : Entity_Id; begin - -- Loop through context clauses to find the with/use clauses. - -- This is done twice, first for everything except limited_with - -- clauses, and then for those, if any are present. + -- First skip configuration pragmas at the start of the context. They + -- are not technically part of the context clause, but that's where the + -- parser puts them. Note they were analyzed in Analyze_Context. Item := First (Context_Items (N)); + while Present (Item) + and then Nkind (Item) = N_Pragma + and then Chars (Item) in Configuration_Pragma_Names + loop + Next (Item); + end loop; + + -- Loop through the actual context clause items. We process everything + -- except Limited_With clauses in this routine. Limited_With clauses + -- are separately installed (see Install_Limited_Context_Clauses). + while Present (Item) loop -- Case of explicit WITH clause @@ -2993,11 +3338,11 @@ package body Sem_Ch10 is -- Check that the unlimited view of a given compilation_unit is not -- already visible through "use + renamings". - procedure Check_Private_Limited_Withed_Unit (N : Node_Id); + procedure Check_Private_Limited_Withed_Unit (Item : Node_Id); -- Check that if a limited_with clause of a given compilation_unit - -- mentions a private child of some library unit, then the given - -- compilation_unit shall be the declaration of a private descendant - -- of that library unit. + -- mentions a descendant of a private child of some library unit, + -- then the given compilation_unit shall be the declaration of a + -- private descendant of that library unit. procedure Expand_Limited_With_Clause (Comp_Unit : Node_Id; Nam : Node_Id; N : Node_Id); @@ -3098,40 +3443,60 @@ package body Sem_Ch10 is -- Check_Private_Limited_Withed_Unit -- --------------------------------------- - procedure Check_Private_Limited_Withed_Unit (N : Node_Id) is - C : Node_Id; - P : Node_Id; - Found : Boolean := False; + procedure Check_Private_Limited_Withed_Unit (Item : Node_Id) is + Curr_Parent : Node_Id; + Child_Parent : Node_Id; begin - -- If the current compilation unit is not private we don't - -- need to check anything else. - - if not Private_Present (Parent (N)) then - Found := False; + -- Compilation unit of the parent of the withed library unit - else - -- Compilation unit of the parent of the withed library unit + Child_Parent := Parent_Spec (Unit (Library_Unit (Item))); - P := Parent_Spec (Unit (Library_Unit (N))); + -- If the child unit is a public child, then locate its nearest + -- private ancestor, if any; Child_Parent will then be set to + -- the parent of that ancestor. - -- Traverse all the ancestors of the current compilation - -- unit to check if it is a descendant of named library unit. + if not Private_Present (Library_Unit (Item)) then + while Present (Child_Parent) + and then not Private_Present (Child_Parent) + loop + Child_Parent := Parent_Spec (Unit (Child_Parent)); + end loop; - C := Parent (N); - while Present (Parent_Spec (Unit (C))) loop - C := Parent_Spec (Unit (C)); + if No (Child_Parent) then + return; + end if; - if C = P then - Found := True; - exit; - end if; - end loop; + Child_Parent := Parent_Spec (Unit (Child_Parent)); end if; - if not Found then - Error_Msg_N ("current unit is not a private descendant" - & " of the withed unit ('R'M 10.1.2(8)", N); + -- Traverse all the ancestors of the current compilation + -- unit to check if it is a descendant of named library unit. + + Curr_Parent := Parent (Item); + + while Present (Parent_Spec (Unit (Curr_Parent))) + and then Curr_Parent /= Child_Parent + loop + Curr_Parent := Parent_Spec (Unit (Curr_Parent)); + end loop; + + if Curr_Parent /= Child_Parent then + Error_Msg_N + ("unit in with clause is private child unit!", Item); + Error_Msg_NE + ("current unit must also have parent&!", + Item, Defining_Unit_Name (Specification (Unit (Child_Parent)))); + + elsif not Private_Present (Parent (Item)) + and then not Private_Present (Item) + and then Nkind (Unit (Parent (Item))) /= N_Package_Body + and then Nkind (Unit (Parent (Item))) /= N_Subprogram_Body + and then Nkind (Unit (Parent (Item))) /= N_Subunit + then + Error_Msg_NE + ("current unit must also be private descendant of&", + Item, Defining_Unit_Name (Specification (Unit (Child_Parent)))); end if; end Check_Private_Limited_Withed_Unit; @@ -3194,7 +3559,7 @@ package body Sem_Ch10 is Withn := Make_With_Clause (Loc, Name => Make_Selected_Component (Loc, - Prefix => Prefix (Nam), + Prefix => New_Copy_Tree (Prefix (Nam)), Selector_Name => Selector_Name (Nam))); Set_Parent (Withn, Parent (N)); end if; @@ -3256,9 +3621,7 @@ package body Sem_Ch10 is (Comp_Unit => N, Nam => Prefix (Name (Item)), N => Item); end if; - if Private_Present (Library_Unit (Item)) then - Check_Private_Limited_Withed_Unit (Item); - end if; + Check_Private_Limited_Withed_Unit (Item); if not Implicit_With (Item) and then Is_Child_Spec (Unit (N)) @@ -3276,6 +3639,12 @@ package body Sem_Ch10 is then Install_Limited_Withed_Unit (Item); end if; + + -- All items other than Limited_With clauses are ignored (they were + -- installed separately early on by Install_Context_Clause). + + else + null; end if; Next (Item); @@ -3350,6 +3719,7 @@ package body Sem_Ch10 is -- Now we can install the context for this parent Install_Context_Clauses (Parent_Spec (Lib_Unit)); + Install_Limited_Context_Clauses (Parent_Spec (Lib_Unit)); Install_Siblings (P_Name, Parent (Lib_Unit)); -- The child unit is in the declarative region of the parent. The @@ -3556,6 +3926,7 @@ package body Sem_Ch10 is -- package R.C is ... Aux_Unit := Cunit (Current_Sem_Unit); + loop Item := First (Context_Items (Aux_Unit)); while Present (Item) loop @@ -3604,12 +3975,21 @@ package body Sem_Ch10 is end loop; if Present (Library_Unit (Aux_Unit)) then - Aux_Unit := Library_Unit (Aux_Unit); + if Aux_Unit = Library_Unit (Aux_Unit) then + + -- Aux_Unit is a body that acts as a spec. Clause has + -- already been flagged as illegal. + + return False; + + else + Aux_Unit := Library_Unit (Aux_Unit); + end if; else Aux_Unit := Parent_Spec (Unit (Aux_Unit)); end if; - exit when not Present (Aux_Unit); + exit when No (Aux_Unit); end loop; return False; @@ -3839,6 +4219,30 @@ package body Sem_Ch10 is Set_Is_Immediately_Visible (P); Set_Limited_View_Installed (N); + + -- If the package in the limited_with clause is a child unit, the + -- clause is unanalyzed and appears as a selected component. Recast + -- it as an expanded name so that the entity can be properly set. Use + -- entity of parent, if available, for higher ancestors in the name. + + if Nkind (Name (N)) = N_Selected_Component then + declare + Nam : Node_Id; + Ent : Entity_Id; + begin + Nam := Name (N); + Ent := P; + while Nkind (Nam) = N_Selected_Component + and then Present (Ent) + loop + Change_Selected_Component_To_Expanded_Name (Nam); + Nam := Prefix (Nam); + Ent := Scope (Ent); + end loop; + end; + end if; + + Set_Entity (Name (N), P); Set_From_With_Type (P); end Install_Limited_Withed_Unit; @@ -5003,4 +5407,5 @@ package body Sem_Ch10 is end if; end Unchain; + end Sem_Ch10; |