atree.h, [...]: New subprograms to manipulate Elist5.

2011-08-02  Ed Schonberg  <schonberg@adacore.com>

	* 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

gcc/ada/ChangeLog

@@ -1,3 +1,14 @@
+2011-08-02  Ed Schonberg  <schonberg@adacore.com>
+
+	* 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  <dewar@adacore.com>
 
 	* exp_util.adb, par-ch10.adb, par-ch6.adb, sem.adb, sem_ch6.adb,

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);

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);
 

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)

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!");

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;
 
          <<Continue>>
-         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

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

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);