From: Javier Miranda Date: Tue, 25 Aug 2020 19:08:22 +0000 (-0400) Subject: [Ada] ACATS 4.1H - B853001 - missed errors for renamed limited X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=b2dea70e920c5dab3118f362f693d4c0e6d9af87;p=gcc.git [Ada] ACATS 4.1H - B853001 - missed errors for renamed limited gcc/ada/ * einfo.ads (Has_Limited_View): New synthesized attribute. * einfo.adb (Has_Limited_View): New synthesized attribute. (Set_Limited_View): Complete assertion. * sem_ch10.ads (Is_Visible_Through_Renamings): Make this routine public to invoke it from Find_Expanded_Name and avoid reporting spurious errors on renamings of limited-with packages. (Load_Needed_Body): Moved to have this spec alphabetically ordered. * sem_ch10.adb (Is_Visible_Through_Renamings): Moved to library level. (Is_Limited_Withed_Unit): New subprogram. * sem_ch3.adb (Access_Type_Declaration): Adding protection to avoid reading attribute Entity() when not available. * sem_ch8.adb (Analyze_Package_Renaming): Report error on renamed package not visible through context clauses. (Find_Expanded_Name): Report error on renamed package not visible through context clauses; handle special case where the prefix is a renaming of a (now visible) shadow package. --- diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index d4a4310e364..0c88c883ac3 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -6071,7 +6071,8 @@ package body Einfo is procedure Set_Limited_View (Id : E; V : E) is begin - pragma Assert (Ekind (Id) = E_Package); + pragma Assert (Ekind (Id) = E_Package + and then not Is_Generic_Instance (Id)); Set_Node23 (Id, V); end Set_Limited_View; @@ -7846,6 +7847,17 @@ package body Einfo is return Has_Own_Invariants (Id) or else Has_Inherited_Invariants (Id); end Has_Invariants; + -------------------------- + -- Has_Limited_View -- + -------------------------- + + function Has_Limited_View (Id : E) return B is + begin + return Ekind (Id) = E_Package + and then not Is_Generic_Instance (Id) + and then Present (Limited_View (Id)); + end Has_Limited_View; + -------------------------- -- Has_Non_Limited_View -- -------------------------- diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index a3aeb36e099..520d506dc6a 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1785,6 +1785,10 @@ package Einfo is -- invariant of its own or inherits at least one class-wide invariant -- from a parent type or an interface. +-- Has_Limited_View (synth) +-- Defined in all entities. True for non-generic package entities that +-- are non-instances and their Limited_View attribute is present. + -- Has_Loop_Entry_Attributes (Flag260) -- Defined in E_Loop entities. Set when the loop is subject to at least -- one attribute 'Loop_Entry. The flag also implies that the loop has @@ -6484,6 +6488,7 @@ package Einfo is -- Has_Null_Abstract_State (synth) -- Is_Elaboration_Target (synth) -- Is_Wrapper_Package (synth) (non-generic case only) + -- Has_Limited_View (synth) (non-generic case only) -- Scope_Depth (synth) -- E_Package_Body @@ -7675,6 +7680,7 @@ package Einfo is function Has_Foreign_Convention (Id : E) return B; function Has_Interrupt_Handler (Id : E) return B; function Has_Invariants (Id : E) return B; + function Has_Limited_View (Id : E) return B; function Has_Non_Limited_View (Id : E) return B; function Has_Non_Null_Abstract_State (Id : E) return B; function Has_Non_Null_Visible_Refinement (Id : E) return B; @@ -9207,6 +9213,7 @@ package Einfo is pragma Inline (Base_Type); pragma Inline (Float_Rep); pragma Inline (Has_Foreign_Convention); + pragma Inline (Has_Limited_View); pragma Inline (Has_Non_Limited_View); pragma Inline (Is_Base_Type); pragma Inline (Is_Boolean_Type); diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 9749fd4b6f7..0bad136d3f2 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -4480,10 +4480,6 @@ package body Sem_Ch10 is -- Determine whether any package in the ancestor chain starting with -- C_Unit has a limited with clause for package Pack. - function Is_Visible_Through_Renamings (P : Entity_Id) return Boolean; - -- Check if some package installed though normal with-clauses has a - -- renaming declaration of package P. AARM 10.1.2(21/2). - ------------------------- -- Check_Body_Required -- ------------------------- @@ -4813,108 +4809,6 @@ package body Sem_Ch10 is return False; end Has_Limited_With_Clause; - ---------------------------------- - -- Is_Visible_Through_Renamings -- - ---------------------------------- - - function Is_Visible_Through_Renamings (P : Entity_Id) return Boolean is - Kind : constant Node_Kind := - Nkind (Unit (Cunit (Current_Sem_Unit))); - Aux_Unit : Node_Id; - Item : Node_Id; - Decl : Entity_Id; - - begin - -- Example of the error detected by this subprogram: - - -- package P is - -- type T is ... - -- end P; - - -- with P; - -- package Q is - -- package Ren_P renames P; - -- end Q; - - -- with Q; - -- package R is ... - - -- limited with P; -- ERROR - -- package R.C is ... - - Aux_Unit := Cunit (Current_Sem_Unit); - - loop - Item := First (Context_Items (Aux_Unit)); - while Present (Item) loop - if Nkind (Item) = N_With_Clause - and then not Limited_Present (Item) - and then Nkind (Unit (Library_Unit (Item))) = - N_Package_Declaration - then - Decl := - First (Visible_Declarations - (Specification (Unit (Library_Unit (Item))))); - while Present (Decl) loop - if Nkind (Decl) = N_Package_Renaming_Declaration - and then Entity (Name (Decl)) = P - then - -- Generate the error message only if the current unit - -- is a package declaration; in case of subprogram - -- bodies and package bodies we just return True to - -- indicate that the limited view must not be - -- installed. - - if Kind = N_Package_Declaration then - Error_Msg_N - ("simultaneous visibility of the limited and " & - "unlimited views not allowed", N); - Error_Msg_Sloc := Sloc (Item); - Error_Msg_NE - ("\\ unlimited view of & visible through the " & - "context clause #", N, P); - Error_Msg_Sloc := Sloc (Decl); - Error_Msg_NE ("\\ and the renaming #", N, P); - end if; - - return True; - end if; - - Next (Decl); - end loop; - end if; - - Next (Item); - end loop; - - -- If it is a body not acting as spec, follow pointer to the - -- corresponding spec, otherwise follow pointer to parent spec. - - if Present (Library_Unit (Aux_Unit)) - and then Nkind (Unit (Aux_Unit)) in - N_Package_Body | N_Subprogram_Body - then - 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 No (Aux_Unit); - end loop; - - return False; - end Is_Visible_Through_Renamings; - -- Start of processing for Install_Limited_With_Clause begin @@ -4952,7 +4846,7 @@ package body Sem_Ch10 is -- Do not install the limited-view if the full-view is already visible -- through renaming declarations. - if Is_Visible_Through_Renamings (P) then + if Is_Visible_Through_Renamings (P, N) then return; end if; @@ -5552,6 +5446,148 @@ package body Sem_Ch10 is end if; end Is_Ancestor_Unit; + ---------------------------------- + -- Is_Visible_Through_Renamings -- + ---------------------------------- + + function Is_Visible_Through_Renamings + (P : Entity_Id; + Error_Node : Node_Id := Empty) return Boolean + is + function Is_Limited_Withed_Unit + (Lib_Unit : Node_Id; + Pkg_Ent : Entity_Id) return Boolean; + -- Return True if Pkg_Ent is a limited-withed package of the given + -- library unit. + + ---------------------------- + -- Is_Limited_Withed_Unit -- + ---------------------------- + + function Is_Limited_Withed_Unit + (Lib_Unit : Node_Id; + Pkg_Ent : Entity_Id) return Boolean + is + Item : Node_Id := First (Context_Items (Lib_Unit)); + + begin + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then Limited_Present (Item) + and then Entity (Name (Item)) = Pkg_Ent + then + return True; + end if; + + Next (Item); + end loop; + + return False; + end Is_Limited_Withed_Unit; + + -- Local variables + + Kind : constant Node_Kind := Nkind (Unit (Cunit (Current_Sem_Unit))); + Aux_Unit : Node_Id; + Item : Node_Id; + Decl : Entity_Id; + + begin + -- Example of the error detected by this subprogram: + + -- package P is + -- type T is ... + -- end P; + + -- with P; + -- package Q is + -- package Ren_P renames P; + -- end Q; + + -- with Q; + -- package R is ... + + -- limited with P; -- ERROR + -- package R.C is ... + + Aux_Unit := Cunit (Current_Sem_Unit); + + loop + Item := First (Context_Items (Aux_Unit)); + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then not Limited_Present (Item) + and then Nkind (Unit (Library_Unit (Item))) = + N_Package_Declaration + then + Decl := + First (Visible_Declarations + (Specification (Unit (Library_Unit (Item))))); + while Present (Decl) loop + if Nkind (Decl) = N_Package_Renaming_Declaration + and then Entity (Name (Decl)) = P + and then not Is_Limited_Withed_Unit + (Lib_Unit => Library_Unit (Item), + Pkg_Ent => Entity (Name (Decl))) + then + -- Generate the error message only if the current unit + -- is a package declaration; in case of subprogram + -- bodies and package bodies we just return True to + -- indicate that the limited view must not be + -- installed. + + if Kind = N_Package_Declaration + and then Present (Error_Node) + then + Error_Msg_N + ("simultaneous visibility of the limited and " & + "unlimited views not allowed", Error_Node); + Error_Msg_Sloc := Sloc (Item); + Error_Msg_NE + ("\\ unlimited view of & visible through the " & + "context clause #", Error_Node, P); + Error_Msg_Sloc := Sloc (Decl); + Error_Msg_NE ("\\ and the renaming #", Error_Node, P); + end if; + + return True; + end if; + + Next (Decl); + end loop; + end if; + + Next (Item); + end loop; + + -- If it is a body not acting as spec, follow pointer to the + -- corresponding spec, otherwise follow pointer to parent spec. + + if Present (Library_Unit (Aux_Unit)) + and then Nkind (Unit (Aux_Unit)) in + N_Package_Body | N_Subprogram_Body + then + 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 No (Aux_Unit); + end loop; + + return False; + end Is_Visible_Through_Renamings; + ----------------------- -- Load_Needed_Body -- ----------------------- diff --git a/gcc/ada/sem_ch10.ads b/gcc/ada/sem_ch10.ads index 11f15865914..b0946a40547 100644 --- a/gcc/ada/sem_ch10.ads +++ b/gcc/ada/sem_ch10.ads @@ -51,6 +51,25 @@ package Sem_Ch10 is -- view, determine whether the package where T resides is imported through -- a regular with clause in the current package body. + function Is_Visible_Through_Renamings + (P : Entity_Id; + Error_Node : Node_Id := Empty) return Boolean; + -- Check if some package installed though normal with-clauses has a + -- renaming declaration of package P. AARM 10.1.2(21/2). Errors are + -- reported on Error_Node (if present); otherwise no error is reported. + + procedure Load_Needed_Body + (N : Node_Id; + OK : out Boolean; + Do_Analyze : Boolean := True); + -- Load and analyze the body of a context unit that is generic, or that + -- contains generic units or inlined units. The body becomes part of the + -- semantic dependency set of the unit that needs it. The returned result + -- in OK is True if the load is successful, and False if the requested file + -- cannot be found. If the flag Do_Analyze is false, the unit is loaded and + -- parsed only. This allows a selective analysis in some inlining cases + -- where a full analysis would lead so circularities in the back-end. + procedure Remove_Context (N : Node_Id); -- Removes the entities from the context clause of the given compilation -- unit from the visibility chains. This is done on exit from a unit as @@ -66,16 +85,4 @@ package Sem_Ch10 is -- rule imposes extra steps in order to install/remove the private_with -- clauses of an enclosing unit. - procedure Load_Needed_Body - (N : Node_Id; - OK : out Boolean; - Do_Analyze : Boolean := True); - -- Load and analyze the body of a context unit that is generic, or that - -- contains generic units or inlined units. The body becomes part of the - -- semantic dependency set of the unit that needs it. The returned result - -- in OK is True if the load is successful, and False if the requested file - -- cannot be found. If the flag Do_Analyze is false, the unit is loaded and - -- parsed only. This allows a selective analysis in some inlining cases - -- where a full analysis would lead so circularities in the back-end. - end Sem_Ch10; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index cea12f22661..cfef7c7ad48 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -1329,7 +1329,8 @@ package body Sem_Ch3 is if Nkind (S) /= N_Subtype_Indication then Analyze (S); - if Present (Entity (S)) + if Nkind (S) in N_Has_Entity + and then Present (Entity (S)) and then Ekind (Root_Type (Entity (S))) = E_Incomplete_Type then Set_Directly_Designated_Type (T, Entity (S)); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 3d50f5e86c3..3bdce445ffa 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -52,6 +52,7 @@ with Sem_Cat; use Sem_Cat; with Sem_Ch3; use Sem_Ch3; with Sem_Ch4; use Sem_Ch4; with Sem_Ch6; use Sem_Ch6; +with Sem_Ch10; use Sem_Ch10; with Sem_Ch12; use Sem_Ch12; with Sem_Ch13; use Sem_Ch13; with Sem_Dim; use Sem_Dim; @@ -1544,6 +1545,21 @@ package body Sem_Ch8 is Set_Ekind (New_P, E_Package); Set_Etype (New_P, Standard_Void_Type); + elsif Present (Renamed_Entity (Old_P)) + and then (From_Limited_With (Renamed_Entity (Old_P)) + or else Has_Limited_View (Renamed_Entity (Old_P))) + and then not + Unit_Is_Visible (Cunit (Get_Source_Unit (Renamed_Entity (Old_P)))) + then + Error_Msg_NE + ("renaming of limited view of package & not usable in this context" + & " (RM 8.5.3(3.1/2))", Name (N), Renamed_Entity (Old_P)); + + -- Set basic attributes to minimize cascaded errors + + Set_Ekind (New_P, E_Package); + Set_Etype (New_P, Standard_Void_Type); + -- Here for OK package renaming else @@ -6290,6 +6306,22 @@ package body Sem_Ch8 is then P_Name := Renamed_Object (P_Name); + if From_Limited_With (P_Name) + and then not Unit_Is_Visible (Cunit (Get_Source_Unit (P_Name))) + then + Error_Msg_NE + ("renaming of limited view of package & not usable in this" + & " context (RM 8.5.3(3.1/2))", Prefix (N), P_Name); + + elsif Has_Limited_View (P_Name) + and then not Unit_Is_Visible (Cunit (Get_Source_Unit (P_Name))) + and then not Is_Visible_Through_Renamings (P_Name) + then + Error_Msg_NE + ("renaming of limited view of package & not usable in this" + & " context (RM 8.5.3(3.1/2))", Prefix (N), P_Name); + end if; + -- Rewrite node with entity field pointing to renamed object Rewrite (Prefix (N), New_Copy (Prefix (N))); @@ -6355,6 +6387,19 @@ package body Sem_Ch8 is Candidate := Get_Full_View (Non_Limited_View (Id)); Is_New_Candidate := True; + -- Handle special case where the prefix is a renaming of a shadow + -- package which is visible. Required to avoid reporting spurious + -- errors. + + elsif Ekind (P_Name) = E_Package + and then From_Limited_With (P_Name) + and then not From_Limited_With (Id) + and then Sloc (Scope (Id)) = Sloc (P_Name) + and then Unit_Is_Visible (Cunit (Get_Source_Unit (P_Name))) + then + Candidate := Get_Full_View (Id); + Is_New_Candidate := True; + -- An unusual case arises with a fully qualified name for an -- entity local to a generic child unit package, within an -- instantiation of that package. The name of the unit now