Use_All_Type extends the functionality of use_type clauses: it makes potentially
use-visible all the primitive operations of a type, as well as the class-wide
operations declared in the immediate scopes of ancestor types, and the literals
of enumeration types.
The following must compile quietly:
gcc -c -gnat12 r.adb
---
package P is
type Enum is (Aa, Bb, Cc);
type T is tagged null record;
procedure Proc (X : T'Class; Y : Enum);
procedure Moot (X : T'Class);
function "+" (X, Y: T) return T;
end P;
---
with P;
package Q is
subtype T_Sub is P.T;
subtype E_Sub is P.Enum;
end Q;
---
with Q;
procedure R is
use all type Q.T_Sub;
Z : Q.T_Sub;
It : Q.E_Sub;
begin
declare
use all type Q.E_Sub;
begin
Z := Z + Z;
Proc (X => Z, Y => Bb);
Moot (Z);
It := Aa;
end;
end R;
2011-08-02 Ed Schonberg <schonb...@adacore.com>
* 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.
Index: sinfo.adb
===================================================================
--- sinfo.adb (revision 177089)
+++ sinfo.adb (working copy)
@@ -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
Index: sinfo.ads
===================================================================
--- sinfo.ads (revision 177089)
+++ sinfo.ads (working copy)
@@ -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);
Index: par-ch8.adb
===================================================================
--- par-ch8.adb (revision 176998)
+++ par-ch8.adb (working copy)
@@ -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!");
Index: sem_ch8.adb
===================================================================
--- sem_ch8.adb (revision 177057)
+++ sem_ch8.adb (working copy)
@@ -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
Index: atree.adb
===================================================================
--- atree.adb (revision 177052)
+++ atree.adb (working copy)
@@ -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);
Index: atree.ads
===================================================================
--- atree.ads (revision 177028)
+++ atree.ads (working copy)
@@ -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);
Index: atree.h
===================================================================
--- atree.h (revision 176998)
+++ atree.h (working copy)
@@ -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)
