[Ada] Fix for missing calls to Adjust primitive with nested generics

2020-06-03  Eric Botcazou  <ebotcazou@adacore.com>

gcc/ada/

	* sem_ch12.adb (Denotes_Previous_Actual): Delete.
	(Check_Generic_Actuals): Do not special case array types whose
	component type denotes a previous actual.  Do not special case
	access types whose base type is private.
	(Check_Private_View): Remove code dealing with secondary types.
	Do not switch the views of an array because of its component.
	(Copy_Generic_Node): Add special handling for a comparison
	operator on array types.
	(Instantiate_Type): Do not special case access types whose
	designated type is private.
	(Set_Global_Type): Do not special case array types whose
	component type is private.

1 files changed, 81 insertions, 126 deletions

diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 71e1212..32a6333 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -6794,48 +6794,6 @@ package body Sem_Ch12 is
       E      : Entity_Id;
       Astype : Entity_Id;
 
-      function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean;
-      --  For a formal that is an array type, the component type is often a
-      --  previous formal in the same unit. The privacy status of the component
-      --  type will have been examined earlier in the traversal of the
-      --  corresponding actuals, and this status should not be modified for
-      --  the array (sub)type itself. However, if the base type of the array
-      --  (sub)type is private, its full view must be restored in the body to
-      --  be consistent with subsequent index subtypes, etc.
-      --
-      --  To detect this case we have to rescan the list of formals, which is
-      --  usually short enough to ignore the resulting inefficiency.
-
-      -----------------------------
-      -- Denotes_Previous_Actual --
-      -----------------------------
-
-      function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean is
-         Prev : Entity_Id;
-
-      begin
-         Prev := First_Entity (Instance);
-         while Present (Prev) loop
-            if Is_Type (Prev)
-              and then Nkind (Parent (Prev)) = N_Subtype_Declaration
-              and then Is_Entity_Name (Subtype_Indication (Parent (Prev)))
-              and then Entity (Subtype_Indication (Parent (Prev))) = Typ
-            then
-               return True;
-
-            elsif Prev = E then
-               return False;
-
-            else
-               Next_Entity (Prev);
-            end if;
-         end loop;
-
-         return False;
-      end Denotes_Previous_Actual;
-
-   --  Start of processing for Check_Generic_Actuals
-
    begin
       E := First_Entity (Instance);
       while Present (E) loop
@@ -6844,14 +6802,7 @@ package body Sem_Ch12 is
            and then Scope (Etype (E)) /= Instance
            and then Is_Entity_Name (Subtype_Indication (Parent (E)))
          then
-            if Is_Array_Type (E)
-              and then not Is_Private_Type (Etype (E))
-              and then Denotes_Previous_Actual (Component_Type (E))
-            then
-               null;
-            else
-               Check_Private_View (Subtype_Indication (Parent (E)));
-            end if;
+            Check_Private_View (Subtype_Indication (Parent (E)));
 
             Set_Is_Generic_Actual_Type (E);
 
@@ -6886,15 +6837,6 @@ package body Sem_Ch12 is
 
             if Is_Discrete_Or_Fixed_Point_Type (E) then
                Set_RM_Size (E, RM_Size (Astype));
-
-            --  In nested instances, the base type of an access actual may
-            --  itself be private, and need to be exchanged.
-
-            elsif Is_Access_Type (E)
-              and then Is_Private_Type (Etype (E))
-            then
-               Check_Private_View
-                 (New_Occurrence_Of (Etype (E), Sloc (Instance)));
             end if;
 
          elsif Ekind (E) = E_Package then
@@ -7451,63 +7393,6 @@ package body Sem_Ch12 is
             Prepend_Elmt (T, Exchanged_Views);
             Exchange_Declarations (Etype (Get_Associated_Node (N)));
 
-         --  For composite types with inconsistent representation exchange
-         --  component types accordingly.
-
-         elsif Is_Access_Type (T)
-           and then Is_Private_Type (Designated_Type (T))
-           and then not Has_Private_View (N)
-           and then Present (Full_View (Designated_Type (T)))
-         then
-            Switch_View (Designated_Type (T));
-
-         elsif Is_Array_Type (T) then
-            if Is_Private_Type (Component_Type (T))
-              and then not Has_Private_View (N)
-              and then Present (Full_View (Component_Type (T)))
-            then
-               Switch_View (Component_Type (T));
-            end if;
-
-            --  The normal exchange mechanism relies on the setting of a
-            --  flag on the reference in the generic. However, an additional
-            --  mechanism is needed for types that are not explicitly
-            --  mentioned in the generic, but may be needed in expanded code
-            --  in the instance. This includes component types of arrays and
-            --  designated types of access types. This processing must also
-            --  include the index types of arrays which we take care of here.
-
-            declare
-               Indx : Node_Id;
-               Typ  : Entity_Id;
-
-            begin
-               Indx := First_Index (T);
-               while Present (Indx) loop
-                  Typ := Base_Type (Etype (Indx));
-
-                  if Is_Private_Type (Typ)
-                    and then Present (Full_View (Typ))
-                  then
-                     Switch_View (Typ);
-                  end if;
-
-                  Next_Index (Indx);
-               end loop;
-            end;
-
-         --  The following case does not test Has_Private_View (N) so it may
-         --  end up switching views when they are not supposed to be switched.
-         --  This might be in keeping with Set_Global_Type setting the flag
-         --  for an array type even if it is not private ???
-
-         elsif Is_Private_Type (T)
-           and then Present (Full_View (T))
-           and then Is_Array_Type (Full_View (T))
-           and then Is_Private_Type (Component_Type (Full_View (T)))
-         then
-            Switch_View (T);
-
          --  Finally, a non-private subtype may have a private base type, which
          --  must be exchanged for consistency. This can happen when a package
          --  body is instantiated, when the scope stack is empty but in fact
@@ -7911,6 +7796,85 @@ package body Sem_Ch12 is
                      Set_Entity (New_N, Entity (Assoc));
                      Check_Private_View (N);
 
+                     --  Here we deal with a very peculiar case for which the
+                     --  Has_Private_View mechanism is not sufficient, because
+                     --  the reference to the type is implicit in the tree,
+                     --  that is to say, it's not referenced from a node but
+                     --  only from another type, namely through Component_Type.
+
+                     --    package P is
+
+                     --      type Pt is private;
+
+                     --      generic
+                     --        type Ft is array (Positive range <>) of Pt;
+                     --      package G is
+                     --        procedure Check (F1, F2 : Ft; Lt : Boolean);
+                     --      end G;
+
+                     --    private
+                     --      type Pt is new Boolean;
+                     --    end P;
+
+                     --    package body P is
+                     --      package body G is
+                     --        procedure Check (F1, F2 : Ft; Lt : Boolean) is
+                     --        begin
+                     --          if (F1 < F2) /= Lt then
+                     --            null;
+                     --          end if;
+                     --        end Check;
+                     --      end G;
+                     --    end P;
+
+                     --    type Arr is array (Positive range <>) of P.Pt;
+
+                     --    package Inst is new P.G (Arr);
+
+                     --  Pt is a global type for the generic package G and it
+                     --  is not referenced in its body, but only as component
+                     --  type of Ft, which is a local type. This means that no
+                     --  references to Pt or Ft are seen during the copy of the
+                     --  body, the only reference to Pt being seen is when the
+                     --  actuals are checked by Check_Generic_Actuals, but Pt
+                     --  is still private at this point. In the end, the views
+                     --  of Pt are not switched in the body and, therefore, the
+                     --  array comparison is rejected because the component is
+                     --  still private.
+
+                     --  Adding e.g. a dummy variable of type Pt in the body is
+                     --  sufficient to make everything work, so we generate an
+                     --  artificial reference to Pt on the fly and thus force
+                     --  the switcthing of views on the ground that, if the
+                     --  comparison was accepted during the semantics analysis
+                     --  of the generic, this means that the component cannot
+                     --  have been private (see Sem_Type.Valid_Comparison_Arg).
+
+                     if Nkind (Assoc) in N_Op_Compare
+                       and then Present (Etype (Left_Opnd (Assoc)))
+                       and then Is_Array_Type (Etype (Left_Opnd (Assoc)))
+                       and then Present (Etype (Right_Opnd (Assoc)))
+                       and then Is_Array_Type (Etype (Right_Opnd (Assoc)))
+                     then
+                        declare
+                           Ltyp : constant Entity_Id :=
+                                                     Etype (Left_Opnd (Assoc));
+                           Rtyp : constant Entity_Id :=
+                                                    Etype (Right_Opnd (Assoc));
+                        begin
+                           if Is_Private_Type (Component_Type (Ltyp)) then
+                              Check_Private_View
+                                (New_Occurrence_Of (Component_Type (Ltyp),
+                                 Sloc (N)));
+                           end if;
+                           if Is_Private_Type (Component_Type (Rtyp)) then
+                              Check_Private_View
+                                (New_Occurrence_Of (Component_Type (Rtyp),
+                                 Sloc (N)));
+                           end if;
+                        end;
+                     end if;
+
                   --  The node is a reference to a global type and acts as the
                   --  subtype mark of a qualified expression created in order
                   --  to aid resolution of accidental overloading in instances.
@@ -13641,11 +13605,6 @@ package body Sem_Ch12 is
 
       if Is_Private_Type (Act_T) then
          Set_Has_Private_View (Subtype_Indication (Decl_Node));
-
-      elsif Is_Access_Type (Act_T)
-        and then Is_Private_Type (Designated_Type (Act_T))
-      then
-         Set_Has_Private_View (Subtype_Indication (Decl_Node));
       end if;
 
       --  In Ada 2012 the actual may be a limited view. Indicate that
@@ -15213,11 +15172,7 @@ package body Sem_Ch12 is
             --  If not a private type, nothing else to do
 
             if not Is_Private_Type (Typ) then
-               if Is_Array_Type (Typ)
-                 and then Is_Private_Type (Component_Type (Typ))
-               then
-                  Set_Has_Private_View (N);
-               end if;
+               null;
 
             --  If it is a derivation of a private type in a context where no
             --  full view is needed, nothing to do either.