[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.

6 files changed, 229 insertions, 121 deletions

diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index d4a4310e..0c88c88 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;
 
@@ -7847,6 +7848,17 @@ package body Einfo is
    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 a3aeb36..520d506 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 9749fd4..0bad136 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 11f1586..b0946a4 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 cea12f2..cfef7c7a 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 3d50f5e..3bdce44 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