git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

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
This commit is contained in:
Ed Schonberg 2011-08-02 08:03:11 +00:00 committed by Arnaud Charlet
parent b0186f718a
commit 29efbb8cc6
8 changed files with 185 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
gcc/ada/ChangeLog
View File

@ -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,

16
gcc/ada/atree.adb
View File

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

6
gcc/ada/atree.ads
View File

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

1
gcc/ada/atree.h
View File

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

1
gcc/ada/par-ch8.adb
View File

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

169
gcc/ada/sem_ch8.adb
View File

@ -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

16
gcc/ada/sinfo.adb
View File

@ -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

15
gcc/ada/sinfo.ads
View File

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