Commit 81d435f3 by Robert Dewar Committed by Arnaud Charlet

sem_ch10.adb: Change name Is_Package to Is_Package_Or_Generic_Package Do not give obsolescent...

2005-11-14  Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* sem_ch10.adb: Change name Is_Package to Is_Package_Or_Generic_Package
	Do not give obsolescent warning on with of subprogram (since we
	diagnose calls)
	(Analyze_With_Clause): Add test for obsolescent package
	(Install_Context_Clauses): If the unit is the body of a child unit, do
	not install twice the private declarations of the parents, to prevent
	circular lists of Use_Clauses in a parent.
	(Implicit_With_On_Parent): Do add duplicate with_clause on parent when
	compiling body of child unit.
	Use new class N_Subprogram_Instantiation
	(Expand_With_Clause): If this is a private with_clause for a child unit,
	appearing in the context of a package declaration, then the implicit
	with_clauses generated for parent units are private as well.
	(License_Check): Do not generate message if with'ed unit is internal

From-SVN: r106998
parent d8387153
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -95,7 +95,7 @@ package body Sem_Ch10 is ...@@ -95,7 +95,7 @@ package body Sem_Ch10 is
-- Verify that a stub is declared immediately within a compilation unit, -- Verify that a stub is declared immediately within a compilation unit,
-- and not in an inner frame. -- and not in an inner frame.
procedure Expand_With_Clause (Nam : Node_Id; N : Node_Id); 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 -- 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 -- 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 -- clause before the one for the child. If a parent in the with_clause
...@@ -998,7 +998,7 @@ package body Sem_Ch10 is ...@@ -998,7 +998,7 @@ package body Sem_Ch10 is
Check_Stub_Level (N); Check_Stub_Level (N);
Nam := Current_Entity_In_Scope (Id); Nam := Current_Entity_In_Scope (Id);
if No (Nam) or else not Is_Package (Nam) then if No (Nam) or else not Is_Package_Or_Generic_Package (Nam) then
Error_Msg_N ("missing specification for package stub", N); Error_Msg_N ("missing specification for package stub", N);
elsif Has_Completion (Nam) elsif Has_Completion (Nam)
...@@ -1843,9 +1843,8 @@ package body Sem_Ch10 is ...@@ -1843,9 +1843,8 @@ package body Sem_Ch10 is
E_Name := Defining_Entity (Specification (Instance_Spec (U))); E_Name := Defining_Entity (Specification (Instance_Spec (U)));
elsif Unit_Kind = N_Procedure_Instantiation elsif Unit_Kind in N_Subprogram_Instantiation then
or else Unit_Kind = N_Function_Instantiation
then
-- Instantiation node is replaced with a package that contains -- Instantiation node is replaced with a package that contains
-- renaming declarations and instance itself. The subprogram -- renaming declarations and instance itself. The subprogram
-- Instance is declared in the visible part of the wrapper package. -- Instance is declared in the visible part of the wrapper package.
...@@ -1953,6 +1952,13 @@ package body Sem_Ch10 is ...@@ -1953,6 +1952,13 @@ package body Sem_Ch10 is
if Private_Present (N) then if Private_Present (N) then
Set_Is_Immediately_Visible (E_Name, False); Set_Is_Immediately_Visible (E_Name, False);
end if; end if;
-- Check for with'ing obsolescent package. Exclude subprograms here
-- since we will catch those on the call rather than the WITH.
if Is_Package_Or_Generic_Package (E_Name) then
Check_Obsolescent (E_Name, N);
end if;
end Analyze_With_Clause; end Analyze_With_Clause;
------------------------------ ------------------------------
...@@ -2480,13 +2486,14 @@ package body Sem_Ch10 is ...@@ -2480,13 +2486,14 @@ package body Sem_Ch10 is
-- Expand_With_Clause -- -- Expand_With_Clause --
------------------------ ------------------------
procedure Expand_With_Clause (Nam : Node_Id; N : Node_Id) is procedure Expand_With_Clause (Item : Node_Id; Nam : Node_Id; N : Node_Id) is
Loc : constant Source_Ptr := Sloc (Nam); Loc : constant Source_Ptr := Sloc (Nam);
Ent : constant Entity_Id := Entity (Nam); Ent : constant Entity_Id := Entity (Nam);
Withn : Node_Id; Withn : Node_Id;
P : Node_Id; P : Node_Id;
function Build_Unit_Name (Nam : Node_Id) return Node_Id; function Build_Unit_Name (Nam : Node_Id) return Node_Id;
-- Comment requireed here ???
--------------------- ---------------------
-- Build_Unit_Name -- -- Build_Unit_Name --
...@@ -2523,12 +2530,20 @@ package body Sem_Ch10 is ...@@ -2523,12 +2530,20 @@ package body Sem_Ch10 is
Set_First_Name (Withn, True); Set_First_Name (Withn, True);
Set_Implicit_With (Withn, True); Set_Implicit_With (Withn, True);
-- If the unit is a package declaration, a private_with_clause on a
-- child unit implies that the implicit with on the parent is also
-- private.
if Nkind (Unit (N)) = N_Package_Declaration then
Set_Private_Present (Withn, Private_Present (Item));
end if;
Prepend (Withn, Context_Items (N)); Prepend (Withn, Context_Items (N));
Mark_Rewrite_Insertion (Withn); Mark_Rewrite_Insertion (Withn);
Install_Withed_Unit (Withn); Install_Withed_Unit (Withn);
if Nkind (Nam) = N_Expanded_Name then if Nkind (Nam) = N_Expanded_Name then
Expand_With_Clause (Prefix (Nam), N); Expand_With_Clause (Item, Prefix (Nam), N);
end if; end if;
New_Nodes_OK := New_Nodes_OK - 1; New_Nodes_OK := New_Nodes_OK - 1;
...@@ -2640,6 +2655,16 @@ package body Sem_Ch10 is ...@@ -2640,6 +2655,16 @@ package body Sem_Ch10 is
P_Unit := Original_Node (P_Unit); P_Unit := Original_Node (P_Unit);
end if; end if;
-- We add the implicit with if the child unit is the current unit
-- being compiled. If the current unit is a body, we do not want
-- to add an implicit_with a second time to the corresponding spec.
if Nkind (Child_Unit) = N_Package_Declaration
and then Child_Unit /= Unit (Cunit (Current_Sem_Unit))
then
return;
end if;
New_Nodes_OK := New_Nodes_OK + 1; New_Nodes_OK := New_Nodes_OK + 1;
Withn := Make_With_Clause (Loc, Name => Build_Unit_Name); Withn := Make_With_Clause (Loc, Name => Build_Unit_Name);
...@@ -2764,7 +2789,7 @@ package body Sem_Ch10 is ...@@ -2764,7 +2789,7 @@ package body Sem_Ch10 is
if Is_Child_Spec (Decl_Node) then if Is_Child_Spec (Decl_Node) then
if Nkind (Name (Item)) = N_Expanded_Name then if Nkind (Name (Item)) = N_Expanded_Name then
Expand_With_Clause (Prefix (Name (Item)), N); Expand_With_Clause (Item, Prefix (Name (Item)), N);
else else
-- if not an expanded name, the child unit must be a -- if not an expanded name, the child unit must be a
-- renaming, nothing to do. -- renaming, nothing to do.
...@@ -2784,10 +2809,12 @@ package body Sem_Ch10 is ...@@ -2784,10 +2809,12 @@ package body Sem_Ch10 is
if Sloc (Library_Unit (Item)) /= No_Location then if Sloc (Library_Unit (Item)) /= No_Location then
License_Check : declare License_Check : declare
Withu : constant Unit_Number_Type :=
Get_Source_Unit (Library_Unit (Item));
Withl : constant License_Type := Withl : constant License_Type :=
License (Source_Index License (Source_Index (Withu));
(Get_Source_Unit
(Library_Unit (Item))));
Unitl : constant License_Type := Unitl : constant License_Type :=
License (Source_Index (Current_Sem_Unit)); License (Source_Index (Current_Sem_Unit));
...@@ -2802,35 +2829,44 @@ package body Sem_Ch10 is ...@@ -2802,35 +2829,44 @@ package body Sem_Ch10 is
procedure License_Error is procedure License_Error is
begin begin
Error_Msg_N Error_Msg_N
("?license of with'ed unit & is incompatible", ("?license of with'ed unit & may be inconsistent",
Name (Item)); Name (Item));
end License_Error; end License_Error;
-- Start of processing for License_Check -- Start of processing for License_Check
begin begin
case Unitl is -- Exclude license check if withed unit is an internal unit.
when Unknown => -- This situation arises e.g. with the GPL version of GNAT.
null;
when Restricted => if Is_Internal_File_Name (Unit_File_Name (Withu)) then
if Withl = GPL then null;
License_Error;
end if;
when GPL => -- Otherwise check various cases
if Withl = Restricted then else
License_Error; case Unitl is
end if; when Unknown =>
null;
when Modified_GPL => when Restricted =>
if Withl = Restricted or else Withl = GPL then if Withl = GPL then
License_Error; License_Error;
end if; end if;
when Unrestricted => when GPL =>
null; if Withl = Restricted then
end case; License_Error;
end if;
when Modified_GPL =>
if Withl = Restricted or else Withl = GPL then
License_Error;
end if;
when Unrestricted =>
null;
end case;
end if;
end License_Check; end License_Check;
end if; end if;
...@@ -2901,10 +2937,12 @@ package body Sem_Ch10 is ...@@ -2901,10 +2937,12 @@ package body Sem_Ch10 is
begin begin
Lib_Spec := Unit (Library_Unit (N)); Lib_Spec := Unit (Library_Unit (N));
while Is_Child_Spec (Lib_Spec) loop while Is_Child_Spec (Lib_Spec) loop
P := Unit (Parent_Spec (Lib_Spec)); P := Unit (Parent_Spec (Lib_Spec));
P_Name := Defining_Entity (P);
if not (Private_Present (Parent (Lib_Spec))) then if not (Private_Present (Parent (Lib_Spec)))
P_Name := Defining_Entity (P); and then not In_Private_Part (P_Name)
then
Install_Private_Declarations (P_Name); Install_Private_Declarations (P_Name);
Install_Private_With_Clauses (P_Name); Install_Private_With_Clauses (P_Name);
Set_Use (Private_Declarations (Specification (P))); Set_Use (Private_Declarations (Specification (P)));
...@@ -3125,7 +3163,7 @@ package body Sem_Ch10 is ...@@ -3125,7 +3163,7 @@ package body Sem_Ch10 is
Item : Node_Id; Item : Node_Id;
begin begin
-- A limited with_clause can not appear in the same context_clause -- A limited with_clause cannot appear in the same context_clause
-- as a nonlimited with_clause which mentions the same library. -- as a nonlimited with_clause which mentions the same library.
Item := First (Context_Items (Comp_Unit)); Item := First (Context_Items (Comp_Unit));
...@@ -3270,7 +3308,7 @@ package body Sem_Ch10 is ...@@ -3270,7 +3308,7 @@ package body Sem_Ch10 is
Error_Msg_N Error_Msg_N
("child of a generic package must be a generic unit", Lib_Unit); ("child of a generic package must be a generic unit", Lib_Unit);
elsif not Is_Package (P_Name) then elsif not Is_Package_Or_Generic_Package (P_Name) then
Error_Msg_N Error_Msg_N
("parent unit must be package or generic package", Lib_Unit); ("parent unit must be package or generic package", Lib_Unit);
raise Unrecoverable_Error; raise Unrecoverable_Error;
...@@ -4378,16 +4416,12 @@ package body Sem_Ch10 is ...@@ -4378,16 +4416,12 @@ package body Sem_Ch10 is
& "limited with_clauses", N); & "limited with_clauses", N);
return; return;
when N_Package_Instantiation | when N_Generic_Instantiation =>
N_Function_Instantiation |
N_Procedure_Instantiation =>
Error_Msg_N ("generic instantiations not allowed in " Error_Msg_N ("generic instantiations not allowed in "
& "limited with_clauses", N); & "limited with_clauses", N);
return; return;
when N_Generic_Package_Renaming_Declaration | when N_Generic_Renaming_Declaration =>
N_Generic_Procedure_Renaming_Declaration |
N_Generic_Function_Renaming_Declaration =>
Error_Msg_N ("generic renamings not allowed in " Error_Msg_N ("generic renamings not allowed in "
& "limited with_clauses", N); & "limited with_clauses", N);
return; return;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment