From: squirek <squi...@adacore.com>
The patch implements the experimental feature to allow use package
clauses within the context area to imply with.
gcc/ada/ChangeLog:
* sem_ch8.adb (Analyze_Package_Name): Add code to expand use
clauses such that they have an implicit with associated with them
when extensions are enabled.
* sem_ch10.ads (Analyze_With_Clause): New.
* sem_ch10.adb (Analyze_With_Clause): Add comes from source check
for warning.
(Expand_With_Clause): Moved to the spec.
* sem_util.adb, sem_util.ads
(Is_In_Context_Clause): Moved from sem_prag.
* sem_prag.adb (Analyze_Pragma): Update calls to
Is_In_Context_Clause.
(Is_In_Context_Clause): Moved to sem_util.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_ch10.adb | 10 +---------
gcc/ada/sem_ch10.ads | 9 +++++++++
gcc/ada/sem_ch8.adb | 39 +++++++++++++++++++++++++++++++++++++++
gcc/ada/sem_prag.adb | 31 +++----------------------------
gcc/ada/sem_util.adb | 21 +++++++++++++++++++++
gcc/ada/sem_util.ads | 4 ++++
6 files changed, 77 insertions(+), 37 deletions(-)
diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb
index de5a8c846ba..9af96fc41b6 100644
--- a/gcc/ada/sem_ch10.adb
+++ b/gcc/ada/sem_ch10.adb
@@ -123,15 +123,6 @@ package body Sem_Ch10 is
-- Verify that a stub is declared immediately within a compilation unit,
-- and not in an inner frame.
- procedure Expand_With_Clause (Item : Node_Id; Nam : Node_Id; N : Node_Id);
- -- When a child unit appears in a context clause, the implicit withs on
- -- parents are made explicit, and with clauses are inserted in the context
- -- clause before the one for the child. If a parent in the with_clause
- -- is a renaming, the implicit with_clause is on the renaming whose name
- -- is mentioned in the with_clause, and not on the package it renames.
- -- N is the compilation unit whose list of context items receives the
- -- implicit with_clauses.
-
procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id);
-- Generate cross-reference information for the parents of child units
-- and of subunits. N is a defining_program_unit_name, and P_Id is the
@@ -2955,6 +2946,7 @@ package body Sem_Ch10 is
if Ada_Version >= Ada_95
and then In_Predefined_Renaming (U)
+ and then Comes_From_Source (N)
then
if Restriction_Check_Required (No_Obsolescent_Features) then
Check_Restriction (No_Obsolescent_Features, N);
diff --git a/gcc/ada/sem_ch10.ads b/gcc/ada/sem_ch10.ads
index c80c4129506..9585785f10a 100644
--- a/gcc/ada/sem_ch10.ads
+++ b/gcc/ada/sem_ch10.ads
@@ -45,6 +45,15 @@ package Sem_Ch10 is
-- set when Ent is a tagged type and its class-wide type needs to appear
-- in the tree.
+ procedure Expand_With_Clause (Item : Node_Id; Nam : Node_Id; N : Node_Id);
+ -- When a child unit appears in a context clause, the implicit withs on
+ -- parents are made explicit, and with clauses are inserted in the context
+ -- clause before the one for the child. If a parent in the with_clause
+ -- is a renaming, the implicit with_clause is on the renaming whose name
+ -- is mentioned in the with_clause, and not on the package it renames.
+ -- N is the compilation unit whose list of context items receives the
+ -- implicit with_clauses.
+
procedure Install_Context (N : Node_Id; Chain : Boolean := True);
-- Installs the entities from the context clause of the given compilation
-- unit into the visibility chains. This is done before analyzing a unit.
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index 6fb9a9a1f5a..65d30967ae0 100644
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -77,6 +77,7 @@ with Style;
with Table;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
+with Uname; use Uname;
with Warnsw; use Warnsw;
package body Sem_Ch8 is
@@ -4300,6 +4301,44 @@ package body Sem_Ch8 is
begin
pragma Assert (Nkind (Clause) = N_Use_Package_Clause);
+
+ -- Perform "use implies with" expansion (when extensions are enabled)
+ -- by inserting an extra with clause since redundant clauses don't
+ -- really matter.
+
+ if All_Extensions_Allowed and then Is_In_Context_Clause (Clause) then
+ declare
+ Unum : Unit_Number_Type;
+ With_Clause : constant Node_Id :=
+ Make_With_Clause (Sloc (Clause),
+ Name => New_Copy_Tree (Pack));
+ begin
+ -- Attempt to load the unit mentioned in the use clause
+
+ Unum := Load_Unit
+ (Load_Name => Get_Unit_Name (With_Clause),
+ Required => False,
+ Subunit => False,
+ Error_Node => Clause,
+ With_Node => With_Clause);
+
+ -- Either we can't file the unit or the use clause is a
+ -- reference to a nested package - in that case just handle
+ -- the use clause normally.
+
+ if Unum /= No_Unit then
+
+ Set_Library_Unit (With_Clause, Cunit (Unum));
+ Set_Is_Implicit_With (With_Clause);
+
+ Analyze (With_Clause);
+ Expand_With_Clause
+ (With_Clause, Name (With_Clause),
+ Enclosing_Comp_Unit_Node (Clause));
+ end if;
+ end;
+ end if;
+
Analyze (Pack);
-- Verify that the package standard is not directly named in a
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 6fe29665148..dcee8600d7c 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -5117,10 +5117,6 @@ package body Sem_Prag is
-- Determines if the placement of the current pragma is appropriate
-- for a configuration pragma.
- function Is_In_Context_Clause return Boolean;
- -- Returns True if pragma appears within the context clause of a unit,
- -- and False for any other placement (does not generate any messages).
-
function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
-- Analyzes the argument, and determines if it is a static string
-- expression, returns True if so, False if non-static or not String.
@@ -6014,7 +6010,7 @@ package body Sem_Prag is
-- Check case of appearing within context clause
- if not Is_Unused and then Is_In_Context_Clause then
+ if not Is_Unused and then Is_In_Context_Clause (N) then
-- The arguments must all be units mentioned in a with clause in
-- the same context clause. Note that Par.Prag already checked
@@ -8132,27 +8128,6 @@ package body Sem_Prag is
end if;
end Is_Configuration_Pragma;
- --------------------------
- -- Is_In_Context_Clause --
- --------------------------
-
- function Is_In_Context_Clause return Boolean is
- Plist : List_Id;
- Parent_Node : Node_Id;
-
- begin
- if Is_List_Member (N) then
- Plist := List_Containing (N);
- Parent_Node := Parent (Plist);
-
- return Present (Parent_Node)
- and then Nkind (Parent_Node) = N_Compilation_Unit
- and then Context_Items (Parent_Node) = Plist;
- end if;
-
- return False;
- end Is_In_Context_Clause;
-
---------------------------------
-- Is_Static_String_Expression --
---------------------------------
@@ -16876,7 +16851,7 @@ package body Sem_Prag is
begin
-- Pragma must be in context items list of a compilation unit
- if not Is_In_Context_Clause then
+ if not Is_In_Context_Clause (N) then
Pragma_Misplaced;
end if;
@@ -16972,7 +16947,7 @@ package body Sem_Prag is
-- Pragma must be in context items list of a compilation unit
- if not Is_In_Context_Clause then
+ if not Is_In_Context_Clause (N) then
Pragma_Misplaced;
end if;
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index b833b355297..ce54deaab85 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -17872,6 +17872,27 @@ package body Sem_Util is
return Nkind (Spec_Decl) in N_Generic_Declaration;
end Is_Generic_Declaration_Or_Body;
+ --------------------------
+ -- Is_In_Context_Clause --
+ --------------------------
+
+ function Is_In_Context_Clause (N : Node_Id) return Boolean is
+ Plist : List_Id;
+ Parent_Node : Node_Id;
+
+ begin
+ if Is_List_Member (N) then
+ Plist := List_Containing (N);
+ Parent_Node := Parent (Plist);
+
+ return Present (Parent_Node)
+ and then Nkind (Parent_Node) = N_Compilation_Unit
+ and then Context_Items (Parent_Node) = Plist;
+ end if;
+
+ return False;
+ end Is_In_Context_Clause;
+
---------------------------
-- Is_Independent_Object --
---------------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index fd749c4b8d4..167b0966dad 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -2095,6 +2095,10 @@ package Sem_Util is
-- Determine whether arbitrary declaration Decl denotes a generic package,
-- a generic subprogram or a generic body.
+ function Is_In_Context_Clause (N : Node_Id) return Boolean;
+ -- Returns True if N appears within the context clause of a unit, and False
+ -- for any other placement.
+
function Is_Independent_Object (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N denotes a reference to an independent
-- object as per RM C.6(8).
--
2.43.0
