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
This commit is contained in:
Robert Dewar
Arnaud Charlet
parent
d838715349
commit
81d435f35b
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- 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 --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
|
|
@ -95,7 +95,7 @@ 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 (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
|
||||
-- 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
|
||||
|
|
@ -998,7 +998,7 @@ package body Sem_Ch10 is
|
|||
Check_Stub_Level (N);
|
||||
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);
|
||||
|
||||
elsif Has_Completion (Nam)
|
||||
|
|
@ -1843,9 +1843,8 @@ package body Sem_Ch10 is
|
|||
|
||||
E_Name := Defining_Entity (Specification (Instance_Spec (U)));
|
||||
|
||||
elsif Unit_Kind = N_Procedure_Instantiation
|
||||
or else Unit_Kind = N_Function_Instantiation
|
||||
then
|
||||
elsif Unit_Kind in N_Subprogram_Instantiation then
|
||||
|
||||
-- Instantiation node is replaced with a package that contains
|
||||
-- renaming declarations and instance itself. The subprogram
|
||||
-- Instance is declared in the visible part of the wrapper package.
|
||||
|
|
@ -1953,6 +1952,13 @@ package body Sem_Ch10 is
|
|||
if Private_Present (N) then
|
||||
Set_Is_Immediately_Visible (E_Name, False);
|
||||
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;
|
||||
|
||||
------------------------------
|
||||
|
|
@ -2480,13 +2486,14 @@ package body Sem_Ch10 is
|
|||
-- 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);
|
||||
Ent : constant Entity_Id := Entity (Nam);
|
||||
Withn : Node_Id;
|
||||
P : Node_Id;
|
||||
|
||||
function Build_Unit_Name (Nam : Node_Id) return Node_Id;
|
||||
-- Comment requireed here ???
|
||||
|
||||
---------------------
|
||||
-- Build_Unit_Name --
|
||||
|
|
@ -2523,12 +2530,20 @@ package body Sem_Ch10 is
|
|||
Set_First_Name (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));
|
||||
Mark_Rewrite_Insertion (Withn);
|
||||
Install_Withed_Unit (Withn);
|
||||
|
||||
if Nkind (Nam) = N_Expanded_Name then
|
||||
Expand_With_Clause (Prefix (Nam), N);
|
||||
Expand_With_Clause (Item, Prefix (Nam), N);
|
||||
end if;
|
||||
|
||||
New_Nodes_OK := New_Nodes_OK - 1;
|
||||
|
|
@ -2640,6 +2655,16 @@ package body Sem_Ch10 is
|
|||
P_Unit := Original_Node (P_Unit);
|
||||
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;
|
||||
Withn := Make_With_Clause (Loc, Name => Build_Unit_Name);
|
||||
|
||||
|
|
@ -2764,7 +2789,7 @@ package body Sem_Ch10 is
|
|||
|
||||
if Is_Child_Spec (Decl_Node) 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
|
||||
-- if not an expanded name, the child unit must be a
|
||||
-- renaming, nothing to do.
|
||||
|
|
@ -2784,10 +2809,12 @@ package body Sem_Ch10 is
|
|||
|
||||
if Sloc (Library_Unit (Item)) /= No_Location then
|
||||
License_Check : declare
|
||||
|
||||
Withu : constant Unit_Number_Type :=
|
||||
Get_Source_Unit (Library_Unit (Item));
|
||||
|
||||
Withl : constant License_Type :=
|
||||
License (Source_Index
|
||||
(Get_Source_Unit
|
||||
(Library_Unit (Item))));
|
||||
License (Source_Index (Withu));
|
||||
|
||||
Unitl : constant License_Type :=
|
||||
License (Source_Index (Current_Sem_Unit));
|
||||
|
|
@ -2802,35 +2829,44 @@ package body Sem_Ch10 is
|
|||
procedure License_Error is
|
||||
begin
|
||||
Error_Msg_N
|
||||
("?license of with'ed unit & is incompatible",
|
||||
("?license of with'ed unit & may be inconsistent",
|
||||
Name (Item));
|
||||
end License_Error;
|
||||
|
||||
-- Start of processing for License_Check
|
||||
|
||||
begin
|
||||
case Unitl is
|
||||
when Unknown =>
|
||||
null;
|
||||
-- Exclude license check if withed unit is an internal unit.
|
||||
-- This situation arises e.g. with the GPL version of GNAT.
|
||||
|
||||
when Restricted =>
|
||||
if Withl = GPL then
|
||||
License_Error;
|
||||
end if;
|
||||
if Is_Internal_File_Name (Unit_File_Name (Withu)) then
|
||||
null;
|
||||
|
||||
when GPL =>
|
||||
if Withl = Restricted then
|
||||
License_Error;
|
||||
end if;
|
||||
-- Otherwise check various cases
|
||||
else
|
||||
case Unitl is
|
||||
when Unknown =>
|
||||
null;
|
||||
|
||||
when Modified_GPL =>
|
||||
if Withl = Restricted or else Withl = GPL then
|
||||
License_Error;
|
||||
end if;
|
||||
when Restricted =>
|
||||
if Withl = GPL then
|
||||
License_Error;
|
||||
end if;
|
||||
|
||||
when Unrestricted =>
|
||||
null;
|
||||
end case;
|
||||
when GPL =>
|
||||
if Withl = Restricted then
|
||||
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 if;
|
||||
|
||||
|
|
@ -2901,10 +2937,12 @@ package body Sem_Ch10 is
|
|||
begin
|
||||
Lib_Spec := Unit (Library_Unit (N));
|
||||
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
|
||||
P_Name := Defining_Entity (P);
|
||||
if not (Private_Present (Parent (Lib_Spec)))
|
||||
and then not In_Private_Part (P_Name)
|
||||
then
|
||||
Install_Private_Declarations (P_Name);
|
||||
Install_Private_With_Clauses (P_Name);
|
||||
Set_Use (Private_Declarations (Specification (P)));
|
||||
|
|
@ -3125,7 +3163,7 @@ package body Sem_Ch10 is
|
|||
Item : Node_Id;
|
||||
|
||||
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.
|
||||
|
||||
Item := First (Context_Items (Comp_Unit));
|
||||
|
|
@ -3270,7 +3308,7 @@ package body Sem_Ch10 is
|
|||
Error_Msg_N
|
||||
("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
|
||||
("parent unit must be package or generic package", Lib_Unit);
|
||||
raise Unrecoverable_Error;
|
||||
|
|
@ -4378,16 +4416,12 @@ package body Sem_Ch10 is
|
|||
& "limited with_clauses", N);
|
||||
return;
|
||||
|
||||
when N_Package_Instantiation |
|
||||
N_Function_Instantiation |
|
||||
N_Procedure_Instantiation =>
|
||||
when N_Generic_Instantiation =>
|
||||
Error_Msg_N ("generic instantiations not allowed in "
|
||||
& "limited with_clauses", N);
|
||||
return;
|
||||
|
||||
when N_Generic_Package_Renaming_Declaration |
|
||||
N_Generic_Procedure_Renaming_Declaration |
|
||||
N_Generic_Function_Renaming_Declaration =>
|
||||
when N_Generic_Renaming_Declaration =>
|
||||
Error_Msg_N ("generic renamings not allowed in "
|
||||
& "limited with_clauses", N);
|
||||
return;
|
||||
|
|
|
|||
Loading…
Reference in New Issue