-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 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- --
with Debug; use Debug;
with Einfo; use Einfo;
with Errout; use Errout;
-with Elists; use Elists;
with Exp_Util; use Exp_Util;
with Fname; use Fname;
with Fname.UF; use Fname.UF;
with Opt; use Opt;
with Output; use Output;
with Restrict; use Restrict;
+with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
-- in a limited_with clause. If the package was not previously analyzed
-- then it also performs a basic decoration of the real entities; this
-- is required to do not pass non-decorated entities to the back-end.
+ -- Implements Ada 2005 (AI-50217).
procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id);
-- Check whether the source for the body of a compilation unit must
-- and not in an inner frame.
procedure Expand_Limited_With_Clause (Nam : Node_Id; N : Node_Id);
- -- if a child unit appears in a limited_with clause, there are implicit
+ -- If a child unit appears in a limited_with clause, there are implicit
-- limited_with clauses on all parents that are not already visible
-- through a regular with clause. This procedure creates the implicit
-- limited with_clauses for the parents and loads the corresponding units.
-- The shadow entities are created when the inserted clause is analyzed.
+ -- Implements Ada 2005 (AI-50217).
procedure Expand_With_Clause (Nam : Node_Id; N : Node_Id);
-- When a child unit appears in a context clause, the implicit withs on
procedure Install_Limited_Context_Clauses (N : Node_Id);
-- Subsidiary to Install_Context. Process only limited with_clauses
- -- for current unit.
+ -- for current unit. Implements Ada 2005 (AI-50217).
procedure Install_Limited_Withed_Unit (N : Node_Id);
-- Place shadow entities for a limited_with package in the visibility
- -- structures for the current compilation.
+ -- structures for the current compilation. Implements Ada 2005 (AI-50217).
+
+ procedure Install_Withed_Unit
+ (With_Clause : Node_Id;
+ Private_With_OK : Boolean := False);
- procedure Install_Withed_Unit (With_Clause : Node_Id);
-- If the unit is not a child unit, make unit immediately visible.
-- The caller ensures that the unit is not already currently installed.
+ -- The flag Private_With_OK is set true in Install_Private_With_Clauses,
+ -- which is called when compiling the private part of a package, or
+ -- installing the private declarations of a parent unit.
procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean);
-- This procedure establishes the context for the compilation of a child
procedure Remove_Limited_With_Clause (N : Node_Id);
-- Remove from visibility the shadow entities introduced for a package
- -- mentioned in a limited_with clause.
+ -- mentioned in a limited_with clause. Implements Ada 2005 (AI-50217).
procedure Remove_Parents (Lib_Unit : Node_Id);
-- Remove_Parents checks if Lib_Unit is a child spec. If so then the parent
if Unum /= No_Unit then
-- Build subprogram declaration and attach parent unit to it
- -- This subprogram declaration does not come from source!
+ -- This subprogram declaration does not come from source,
+ -- Nevertheless the backend must generate debugging info for
+ -- it, and this must be indicated explicitly.
declare
Loc : constant Source_Ptr := Sloc (N);
Set_Parent_Spec (Unit (Lib_Unit), Cunit (Unum));
Semantics (Lib_Unit);
Set_Acts_As_Spec (N, False);
+ Set_Needs_Debug_Info (Defining_Entity (Unit (Lib_Unit)));
Set_Comes_From_Source_Default (SCS);
end;
end if;
declare
Save_Style_Check : constant Boolean := Style_Check;
- Save_C_Restrict : constant Save_Compilation_Unit_Restrictions :=
- Compilation_Unit_Restrictions_Save;
+ Save_C_Restrict : constant Save_Cunit_Boolean_Restrictions :=
+ Cunit_Boolean_Restrictions_Save;
begin
if not GNAT_Mode then
Semantics (Parent_Spec (Unit_Node));
Version_Update (N, Parent_Spec (Unit_Node));
Style_Check := Save_Style_Check;
- Compilation_Unit_Restrictions_Restore (Save_C_Restrict);
+ Cunit_Boolean_Restrictions_Restore (Save_C_Restrict);
end;
end if;
Set_Acts_As_Spec (N);
end if;
+ -- Register predefined units in Rtsfind
+
+ declare
+ Unum : constant Unit_Number_Type := Get_Source_Unit (Sloc (N));
+ begin
+ if Is_Predefined_File_Name (Unit_File_Name (Unum)) then
+ Set_RTU_Loaded (Unit_Node);
+ end if;
+ end;
+
-- Treat compilation unit pragmas that appear after the library unit
if Present (Pragmas_After (Aux_Decls_Node (N))) then
end;
end if;
- -- Generate distribution stub files if requested and no error
+ -- Generate distribution stubs if requested and no error
if N = Main_Cunit
and then (Distribution_Stub_Mode = Generate_Receiver_Stub_Body
Add_Stub_Constructs (N);
end if;
- -- Reanalyze the unit with the new constructs
-
- Analyze (Unit_Node);
end if;
if Nkind (Unit_Node) = N_Package_Declaration
Un : Unit_Number_Type;
Save_Style_Check : constant Boolean := Style_Check;
- Save_C_Restrict : constant Save_Compilation_Unit_Restrictions :=
- Compilation_Unit_Restrictions_Save;
+ Save_C_Restrict : constant Save_Cunit_Boolean_Restrictions :=
+ Cunit_Boolean_Restrictions_Save;
begin
Item := First (Context_Items (N));
while Present (Item) loop
+
+ -- Ada 2005 (AI-50217): Do not consider limited-withed units
+
if Nkind (Item) = N_With_Clause
and then not Implicit_With (Item)
and then not Limited_Present (Item)
end loop;
Style_Check := Save_Style_Check;
- Compilation_Unit_Restrictions_Restore (Save_C_Restrict);
+ Cunit_Boolean_Restrictions_Restore (Save_C_Restrict);
end;
end if;
-- Loop through context items. This is done is three passes:
-- a) The first pass analyze non-limited with-clauses.
-- b) The second pass add implicit limited_with clauses for
- -- the parents of child units.
- -- c) The third pass analyzes limited_with clauses.
+ -- the parents of child units (Ada 2005: AI-50217)
+ -- c) The third pass analyzes limited_with clauses (Ada 2005: AI-50217)
Item := First (Context_Items (N));
while Present (Item) loop
-- Errout to ignore all errors. Note that Fatal_Error will still
-- be set, so we will be able to check for this case below.
- Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
+ if not ASIS_Mode then
+ Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
+ end if;
+
Unum :=
Load_Unit
(Load_Name => Subunit_Name,
Required => False,
Subunit => True,
Error_Node => N);
- Ignore_Errors_Enable := Ignore_Errors_Enable - 1;
+
+ if not ASIS_Mode then
+ Ignore_Errors_Enable := Ignore_Errors_Enable - 1;
+ end if;
-- All done if we successfully loaded the subunit
then
Comp_Unit := Cunit (Unum);
- Set_Corresponding_Stub (Unit (Comp_Unit), N);
- Analyze_Subunit (Comp_Unit);
- Set_Library_Unit (N, Comp_Unit);
+ if Nkind (Unit (Comp_Unit)) /= N_Subunit then
+ Error_Msg_N
+ ("expected SEPARATE subunit, found child unit",
+ Cunit_Entity (Unum));
+ else
+ Set_Corresponding_Stub (Unit (Comp_Unit), N);
+ Analyze_Subunit (Comp_Unit);
+ Set_Library_Unit (N, Comp_Unit);
+ end if;
elsif Unum = No_Unit
and then Present (Nam)
-- Remove current scope from scope stack, and preserve the list
-- of use clauses in it, to be reinstalled after context is analyzed.
- ------------------------------
- -- Analyze_Subunit_Context --
- ------------------------------
+ -----------------------------
+ -- Analyze_Subunit_Context --
+ -----------------------------
procedure Analyze_Subunit_Context is
Item : Node_Id;
for J in reverse 1 .. Num_Scopes loop
U := Use_Clauses (J);
Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := U;
- Install_Use_Clauses (U);
+ Install_Use_Clauses (U, Force_Installation => True);
end loop;
end Re_Install_Use_Clauses;
end if;
end if;
+ Set_Is_Immediately_Visible (Par_Unit, False);
+
Analyze_Subunit_Context;
+
Re_Install_Parents (Lib_Unit, Par_Unit);
+ Set_Is_Immediately_Visible (Par_Unit);
-- If the context includes a child unit of the parent of the
-- subunit, the parent will have been removed from visibility,
-- Set True if the unit currently being compiled is an internal unit
Save_Style_Check : constant Boolean := Opt.Style_Check;
- Save_C_Restrict : constant Save_Compilation_Unit_Restrictions :=
- Compilation_Unit_Restrictions_Save;
+ Save_C_Restrict : constant Save_Cunit_Boolean_Restrictions :=
+ Cunit_Boolean_Restrictions_Save;
begin
if Limited_Present (N) then
-
- -- Build visibility structures but do not analyze unit
+ -- Ada 2005 (AI-50217): Build visibility structures but do not
+ -- analyze unit
Build_Limited_Views (N);
return;
-- Restore style checks and restrictions
Style_Check := Save_Style_Check;
- Compilation_Unit_Restrictions_Restore (Save_C_Restrict);
+ Cunit_Boolean_Restrictions_Restore (Save_C_Restrict);
-- Record the reference, but do NOT set the unit as referenced, we
-- want to consider the unit as unreferenced if this is the only
Generate_Reference (Par_Name, Pref);
Pref := Prefix (Pref);
- Par_Name := Scope (Par_Name);
+
+ -- If E_Name is the dummy entity for a nonexistent unit,
+ -- its scope is set to Standard_Standard, and no attempt
+ -- should be made to further unwind scopes.
+
+ if Par_Name /= Standard_Standard then
+ Par_Name := Scope (Par_Name);
+ end if;
end loop;
if Present (Entity (Pref))
null;
end if;
+
+ -- Ada 2005 (AI-262): Remove from visibility the entity corresponding
+ -- to private_with units; they will be made visible later (just before
+ -- the private part is analyzed)
+
+ if Private_Present (N) then
+ Set_Is_Immediately_Visible (E_Name, False);
+ end if;
end Analyze_With_Clause;
------------------------------
or else Nkind (Lib_Unit) = N_Subprogram_Body)
then
Check_Parent_Context (Library_Unit (N));
+
if Is_Child_Spec (Unit (Library_Unit (N))) then
Check_Parent_Context (Parent_Spec (Unit (Library_Unit (N))));
end if;
Item := First (Context_Items (N));
while Present (Item) loop
+ -- Ada 2005 (AI-262): Allow private_with of a private child package
+ -- in public siblings
+
if Nkind (Item) = N_With_Clause
and then not Implicit_With (Item)
+ and then not Private_Present (Item)
and then Is_Private_Descendant (Entity (Name (Item)))
then
Priv_Child := Entity (Name (Item));
procedure Expand_Limited_With_Clause (Nam : Node_Id; N : Node_Id) is
Loc : constant Source_Ptr := Sloc (Nam);
- P : Entity_Id;
Unum : Unit_Number_Type;
Withn : Node_Id;
Subunit => False,
Error_Node => Nam);
- P := Cunit_Entity (Unum);
-
if not Analyzed (Cunit (Unum)) then
Set_Library_Unit (Withn, Cunit (Unum));
Set_Corresponding_Spec
Mark_Rewrite_Insertion (Withn);
end if;
- elsif Nkind (Nam) = N_Selected_Component then
+ else pragma Assert (Nkind (Nam) = N_Selected_Component);
Withn :=
Make_With_Clause
(Loc,
Subunit => False,
Error_Node => Nam);
- P := Cunit_Entity (Unum);
-
if not Analyzed (Cunit (Unum)) then
Set_Library_Unit (Withn, Cunit (Unum));
Set_Corresponding_Spec
Expand_Limited_With_Clause (Prefix (Nam), N);
end if;
-
- else
- null;
- pragma Assert (False);
end if;
New_Nodes_OK := New_Nodes_OK - 1;
function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is
begin
- if Nkind (Unit) = N_Package_Instantiation then
+ if Nkind (Unit) = N_Package_Body
+ and then Nkind (Original_Node (Unit)) = N_Package_Instantiation
+ then
+ return
+ Defining_Entity
+ (Specification (Instance_Spec (Original_Node (Unit))));
+
+ elsif Nkind (Unit) = N_Package_Instantiation then
return Defining_Entity (Specification (Instance_Spec (Unit)));
+
else
return Defining_Entity (Unit);
end if;
is
Loc : constant Source_Ptr := Sloc (N);
P : constant Node_Id := Parent_Spec (Child_Unit);
- P_Unit : constant Node_Id := Unit (P);
+
+ P_Unit : Node_Id := Unit (P);
+
P_Name : constant Entity_Id := Get_Parent_Entity (P_Unit);
Withn : Node_Id;
- function Build_Ancestor_Name (P : Node_Id) return Node_Id;
+ function Build_Ancestor_Name (P : Node_Id) return Node_Id;
-- Build prefix of child unit name. Recurse if needed.
function Build_Unit_Name return Node_Id;
function Build_Ancestor_Name (P : Node_Id) return Node_Id is
P_Ref : constant Node_Id :=
New_Reference_To (Defining_Entity (P), Loc);
-
begin
if No (Parent_Spec (P)) then
return P_Ref;
function Build_Unit_Name return Node_Id is
Result : Node_Id;
-
begin
if No (Parent_Spec (P_Unit)) then
return New_Reference_To (P_Name, Loc);
-- Start of processing for Implicit_With_On_Parent
begin
+ -- The unit of the current compilation may be a package body
+ -- that replaces an instance node. In this case we need the
+ -- original instance node to construct the proper parent name.
+
+ if Nkind (P_Unit) = N_Package_Body
+ and then Nkind (Original_Node (P_Unit)) = N_Package_Instantiation
+ then
+ P_Unit := Original_Node (P_Unit);
+ end if;
+
New_Nodes_OK := New_Nodes_OK + 1;
Withn := Make_With_Clause (Loc, Name => Build_Unit_Name);
if Is_Child_Spec (P_Unit) then
Implicit_With_On_Parent (P_Unit, N);
end if;
+
New_Nodes_OK := New_Nodes_OK - 1;
end Implicit_With_On_Parent;
if not (Private_Present (Parent (Lib_Spec))) then
P_Name := Defining_Entity (P);
Install_Private_Declarations (P_Name);
+ Install_Private_With_Clauses (P_Name);
Set_Use (Private_Declarations (Specification (P)));
end if;
-- context_clause as a nonlimited with_clause that mentions
-- the same library.
- --------------------
- -- Check_Parent --
- --------------------
+ ------------------
+ -- Check_Parent --
+ ------------------
procedure Check_Parent (P : Node_Id; W : Node_Id) is
Item : Node_Id;
if Nkind (Item) = N_With_Clause
and then Limited_Present (Item)
then
-
Check_Withed_Unit (Item);
if Private_Present (Library_Unit (Item)) then
or else Private_Present (Parent (Lib_Unit))
then
Install_Private_Declarations (P_Name);
+ Install_Private_With_Clauses (P_Name);
Set_Use (Private_Declarations (P_Spec));
end if;
end Install_Parents;
- ----------------------
- -- Install_Siblings --
- ----------------------
-
- procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id) is
- Item : Node_Id;
- Id : Entity_Id;
- Prev : Entity_Id;
-
- function Is_Ancestor (E : Entity_Id) return Boolean;
- -- Determine whether the scope of a child unit is an ancestor of
- -- the current unit.
- -- Shouldn't this be somewhere more general ???
-
- -----------------
- -- Is_Ancestor --
- -----------------
+ ----------------------------------
+ -- Install_Private_With_Clauses --
+ ----------------------------------
- function Is_Ancestor (E : Entity_Id) return Boolean is
- Par : Entity_Id;
+ procedure Install_Private_With_Clauses (P : Entity_Id) is
+ Decl : constant Node_Id := Unit_Declaration_Node (P);
+ Item : Node_Id;
- begin
- Par := U_Name;
+ begin
+ if Debug_Flag_I then
+ Write_Str ("install private with clauses of ");
+ Write_Name (Chars (P));
+ Write_Eol;
+ end if;
- while Present (Par)
- and then Par /= Standard_Standard
- loop
+ if Nkind (Parent (Decl)) = N_Compilation_Unit then
+ Item := First (Context_Items (Parent (Decl)));
- if Par = E then
- return True;
+ while Present (Item) loop
+ if Nkind (Item) = N_With_Clause
+ and then Private_Present (Item)
+ then
+ if Limited_Present (Item) then
+ Install_Limited_Withed_Unit (Item);
+ else
+ Install_Withed_Unit (Item, Private_With_OK => True);
+ end if;
end if;
- Par := Scope (Par);
+ Next (Item);
end loop;
+ end if;
+ end Install_Private_With_Clauses;
- return False;
- end Is_Ancestor;
-
- -- Start of processing for Install_Siblings
+ ----------------------
+ -- Install_Siblings --
+ ----------------------
+ procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id) is
+ Item : Node_Id;
+ Id : Entity_Id;
+ Prev : Entity_Id;
begin
-- Iterate over explicit with clauses, and check whether the
-- scope of each entity is an ancestor of the current unit.
Item := First (Context_Items (N));
-
while Present (Item) loop
-
if Nkind (Item) = N_With_Clause
and then not Implicit_With (Item)
and then not Limited_Present (Item)
Id := Entity (Name (Item));
if Is_Child_Unit (Id)
- and then Is_Ancestor (Scope (Id))
+ and then Is_Ancestor_Package (Scope (Id), U_Name)
then
Set_Is_Immediately_Visible (Id);
- Prev := Current_Entity (Id);
-- Check for the presence of another unit in the context,
-- that may be inadvertently hidden by the child.
+ Prev := Current_Entity (Id);
+
if Present (Prev)
and then Is_Immediately_Visible (Prev)
and then not Is_Child_Unit (Prev)
-- the child immediately visible.
elsif Is_Child_Unit (Scope (Id))
- and then Is_Ancestor (Scope (Scope (Id)))
+ and then Is_Ancestor_Package (Scope (Scope (Id)), U_Name)
then
Set_Is_Immediately_Visible (Scope (Id));
end if;
-
end if;
Next (Item);
-------------------------------
procedure Install_Limited_Withed_Unit (N : Node_Id) is
- Unum : Unit_Number_Type :=
+ Unum : constant Unit_Number_Type :=
Get_Source_Unit (Library_Unit (N));
- P_Unit : Entity_Id := Unit (Library_Unit (N));
+ P_Unit : constant Entity_Id := Unit (Library_Unit (N));
P : Entity_Id;
- Lim_Elmt : Elmt_Id;
- Lim_Typ : Entity_Id;
Is_Child_Package : Boolean := False;
+ Lim_Header : Entity_Id;
+ Lim_Typ : Entity_Id;
+
function In_Chain (E : Entity_Id) return Boolean;
-- Check that the shadow entity is not already in the homonym
-- chain, for example through a limited_with clause in a parent unit.
+ --------------
+ -- In_Chain --
+ --------------
+
function In_Chain (E : Entity_Id) return Boolean is
H : Entity_Id := Current_Entity (E);
return;
when others =>
- pragma Assert (False);
- null;
+ raise Program_Error;
end case;
P := Defining_Unit_Name (Specification (P_Unit));
-- view because the full view of X supersedes its limited view.
if Analyzed (Cunit (Unum))
- and then Is_Immediately_Visible (P)
+ and then (Is_Immediately_Visible (P)
+ or else (Is_Child_Package
+ and then Is_Visible_Child_Unit (P)))
then
+ -- Ada 2005 (AI-262): Install the private declarations of P
+
+ if Private_Present (N)
+ and then not In_Private_Part (P)
+ then
+ declare
+ Id : Entity_Id;
+ begin
+ Id := First_Private_Entity (P);
+
+ while Present (Id) loop
+ if not Is_Internal (Id)
+ and then not Is_Child_Unit (Id)
+ then
+ if not In_Chain (Id) then
+ Set_Homonym (Id, Current_Entity (Id));
+ Set_Current_Entity (Id);
+ end if;
+
+ Set_Is_Immediately_Visible (Id);
+ end if;
+
+ Next_Entity (Id);
+ end loop;
+
+ Set_In_Private_Part (P);
+ end;
+ end if;
+
return;
end if;
Set_Is_Immediately_Visible (P);
- -- Install each incomplete view
+ -- Install each incomplete view. The first element of the limited view
+ -- is a header (an E_Package entity) that is used to reference the first
+ -- shadow entity in the private part of the package
- Lim_Elmt := First_Elmt (Limited_Views (P));
+ Lim_Header := Limited_View (P);
+ Lim_Typ := First_Entity (Lim_Header);
- while Present (Lim_Elmt) loop
- Lim_Typ := Node (Lim_Elmt);
+ while Present (Lim_Typ) loop
+
+ exit when not Private_Present (N)
+ and then Lim_Typ = First_Private_Entity (Lim_Header);
if not In_Chain (Lim_Typ) then
Set_Homonym (Lim_Typ, Current_Entity (Lim_Typ));
Write_Name (Chars (Lim_Typ));
Write_Eol;
end if;
-
end if;
- Next_Elmt (Lim_Elmt);
+ Next_Entity (Lim_Typ);
end loop;
-- The context clause has installed a limited-view, mark it
-- Install_Withed_Unit --
-------------------------
- procedure Install_Withed_Unit (With_Clause : Node_Id) is
+ procedure Install_Withed_Unit
+ (With_Clause : Node_Id;
+ Private_With_OK : Boolean := False)
+ is
Uname : constant Entity_Id := Entity (Name (With_Clause));
P : constant Entity_Id := Scope (Uname);
begin
+ -- Ada 2005 (AI-262): Do not install the private withed unit if we are
+ -- compiling a package declaration and the Private_With_OK flag was not
+ -- set by the caller. These declarations will be installed later (before
+ -- analyzing the private part of the package).
+
+ if Private_Present (With_Clause)
+ and then Nkind (Cunit (Current_Sem_Unit)) = N_Package_Declaration
+ and then not (Private_With_OK)
+ then
+ return;
+ end if;
if Debug_Flag_I then
- Write_Str ("install withed unit ");
+ if Private_Present (With_Clause) then
+ Write_Str ("install private withed unit ");
+ else
+ Write_Str ("install withed unit ");
+ end if;
+
Write_Name (Chars (Uname));
Write_Eol;
end if;
Set_Is_Visible_Child_Unit
(Related_Instance
(Defining_Entity (Unit (Library_Unit (With_Clause)))));
- null;
end if;
-- The parent unit may have been installed already, and
end if;
elsif not Is_Immediately_Visible (Uname) then
- Set_Is_Immediately_Visible (Uname);
+ if not Private_Present (With_Clause)
+ or else Private_With_OK
+ then
+ Set_Is_Immediately_Visible (Uname);
+ end if;
+
Set_Context_Installed (With_Clause);
end if;
-------------------------
procedure Build_Limited_Views (N : Node_Id) is
+ Unum : constant Unit_Number_Type := Get_Source_Unit (Library_Unit (N));
+ P : constant Entity_Id := Cunit_Entity (Unum);
- Unum : Unit_Number_Type := Get_Source_Unit (Library_Unit (N));
- P : Entity_Id := Cunit_Entity (Unum);
+ Spec : Node_Id; -- To denote a package specification
+ Lim_Typ : Entity_Id; -- To denote shadow entities
+ Comp_Typ : Entity_Id; -- To denote real entities
- Spec : Node_Id; -- To denote a package specification
- Lim_Typ : Entity_Id; -- To denote shadow entities.
- Comp_Typ : Entity_Id; -- To denote real entities.
+ Lim_Header : Entity_Id; -- Package entity
+ Last_Lim_E : Entity_Id := Empty; -- Last limited entity built
+ Last_Pub_Lim_E : Entity_Id; -- To set the first private entity
procedure Decorate_Incomplete_Type
(E : Entity_Id;
-- Set basic attributes of tagged type T, including its class_wide type.
-- The parameters Loc, Scope are used to decorate the class_wide type.
- procedure Build_Chain (Spec : Node_Id; Scope : Entity_Id);
+ procedure Build_Chain
+ (Scope : Entity_Id;
+ First_Decl : Node_Id);
-- Construct list of shadow entities and attach it to entity of
-- package that is mentioned in a limited_with clause.
(Kind : Entity_Kind;
Sloc_Value : Source_Ptr;
Id_Char : Character) return Entity_Id;
- -- This function is similar to New_Internal_Entity, except that the
- -- entity is not added to the scope's list of entities.
+ -- Build a new internal entity and append it to the list of shadow
+ -- entities available through the limited-header
------------------------------
-- Decorate_Incomplete_Type --
Scop : Entity_Id)
is
begin
- Set_Ekind (E, E_Incomplete_Type);
- Set_Scope (E, Scop);
- Set_Etype (E, E);
- Set_Is_First_Subtype (E, True);
- Set_Stored_Constraint (E, No_Elist);
- Set_Full_View (E, Empty);
- Init_Size_Align (E);
+ Set_Ekind (E, E_Incomplete_Type);
+ Set_Scope (E, Scop);
+ Set_Etype (E, E);
+ Set_Is_First_Subtype (E, True);
+ Set_Stored_Constraint (E, No_Elist);
+ Set_Full_View (E, Empty);
+ Init_Size_Align (E);
end Decorate_Incomplete_Type;
--------------------------
Set_Equivalent_Type (CW, Empty);
Set_From_With_Type (CW, From_With_Type (T));
- Set_Class_Wide_Type (T, CW);
+ Set_Class_Wide_Type (T, CW);
end if;
end Decorate_Tagged_Type;
Sloc_Value : Source_Ptr;
Id_Char : Character) return Entity_Id
is
- N : constant Entity_Id :=
+ E : constant Entity_Id :=
Make_Defining_Identifier (Sloc_Value,
Chars => New_Internal_Name (Id_Char));
begin
- Set_Ekind (N, Kind);
- Set_Is_Internal (N, True);
+ Set_Ekind (E, Kind);
+ Set_Is_Internal (E, True);
if Kind in Type_Kind then
- Init_Size_Align (N);
+ Init_Size_Align (E);
end if;
- return N;
+ Append_Entity (E, Lim_Header);
+ Last_Lim_E := E;
+ return E;
end New_Internal_Shadow_Entity;
-----------------
-- Build_Chain --
-----------------
- -- Could use more comments below ???
-
- procedure Build_Chain (Spec : Node_Id; Scope : Entity_Id) is
- Decl : Node_Id;
- Analyzed_Unit : Boolean := Analyzed (Cunit (Unum));
+ procedure Build_Chain
+ (Scope : Entity_Id;
+ First_Decl : Node_Id)
+ is
+ Analyzed_Unit : constant Boolean := Analyzed (Cunit (Unum));
Is_Tagged : Boolean;
+ Decl : Node_Id;
begin
- Decl := First (Visible_Declarations (Spec));
+ Decl := First_Decl;
while Present (Decl) loop
+
+ -- For each library_package_declaration in the environment, there
+ -- is an implicit declaration of a *limited view* of that library
+ -- package. The limited view of a package contains:
+ --
+ -- * For each nested package_declaration, a declaration of the
+ -- limited view of that package, with the same defining-
+ -- program-unit name.
+ --
+ -- * For each type_declaration in the visible part, an incomplete
+ -- type-declaration with the same defining_identifier, whose
+ -- completion is the type_declaration. If the type_declaration
+ -- is tagged, then the incomplete_type_declaration is tagged
+ -- incomplete.
+
if Nkind (Decl) = N_Full_Type_Declaration then
Is_Tagged :=
Nkind (Type_Definition (Decl)) = N_Record_Definition
-- Create shadow entity for type
- Lim_Typ := New_Internal_Shadow_Entity
+ Lim_Typ := New_Internal_Shadow_Entity
(Kind => Ekind (Comp_Typ),
Sloc_Value => Sloc (Comp_Typ),
Id_Char => 'Z');
end if;
Set_Non_Limited_View (Lim_Typ, Comp_Typ);
- Append_Elmt (Lim_Typ, To => Limited_Views (P));
elsif Nkind (Decl) = N_Private_Type_Declaration
and then Tagged_Present (Decl)
Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope);
Set_Non_Limited_View (Lim_Typ, Comp_Typ);
- Append_Elmt (Lim_Typ, To => Limited_Views (P));
elsif Nkind (Decl) = N_Package_Declaration then
-- Local package
declare
- Spec : Node_Id := Specification (Decl);
+ Spec : constant Node_Id := Specification (Decl);
begin
Comp_Typ := Defining_Unit_Name (Spec);
-- Note: The non_limited_view attribute is not used
-- for local packages.
- Append_Elmt (Lim_Typ, To => Limited_Views (P));
-
- Build_Chain (Spec, Scope => Lim_Typ);
+ Build_Chain
+ (Scope => Lim_Typ,
+ First_Decl => First (Visible_Declarations (Spec)));
end;
end if;
return;
when others =>
- pragma Assert (False);
- null;
+ raise Program_Error;
end case;
-- Check if the chain is already built
end if;
Set_Ekind (P, E_Package);
- Set_Limited_Views (P, New_Elmt_List);
- -- Set_Entity (Name (N), P);
- -- Create the auxiliary chain
+ -- Build the header of the limited_view
+
+ Lim_Header := Make_Defining_Identifier (Sloc (N),
+ Chars => New_Internal_Name (Id_Char => 'Z'));
+ Set_Ekind (Lim_Header, E_Package);
+ Set_Is_Internal (Lim_Header);
+ Set_Limited_View (P, Lim_Header);
+
+ -- Create the auxiliary chain. All the shadow entities are appended
+ -- to the list of entities of the limited-view header
+
+ Build_Chain
+ (Scope => P,
+ First_Decl => First (Visible_Declarations (Spec)));
+
+ -- Save the last built shadow entity. It is needed later to set the
+ -- reference to the first shadow entity in the private part
+
+ Last_Pub_Lim_E := Last_Lim_E;
+
+ -- Ada 2005 (AI-262): Add the limited view of the private declarations
+ -- Required to give support to limited-private-with clauses
+
+ Build_Chain (Scope => P,
+ First_Decl => First (Private_Declarations (Spec)));
+
+ if Last_Pub_Lim_E /= Empty then
+ Set_First_Private_Entity (Lim_Header,
+ Next_Entity (Last_Pub_Lim_E));
+ else
+ Set_First_Private_Entity (Lim_Header,
+ First_Entity (P));
+ end if;
- Build_Chain (Spec, Scope => P);
Set_Limited_View_Installed (Spec);
end Build_Limited_Views;
Unit_Name : Entity_Id;
begin
- -- We remove the context clauses in two phases: limited-views first
- -- and regular-views later (to maintain the stack model).
+ -- Ada 2005 (AI-50217): We remove the context clauses in two phases:
+ -- limited-views first and regular-views later (to maintain the
+ -- stack model).
-- First Phase: Remove limited_with context clauses
and then Limited_View_Installed (Item)
then
Remove_Limited_With_Clause (Item);
-
end if;
Next (Item);
--------------------------------
procedure Remove_Limited_With_Clause (N : Node_Id) is
- P_Unit : Entity_Id := Unit (Library_Unit (N));
- P : Entity_Id := Defining_Unit_Name (Specification (P_Unit));
- Lim_Elmt : Elmt_Id;
- Lim_Typ : Entity_Id;
+ P_Unit : constant Entity_Id := Unit (Library_Unit (N));
+ P : Entity_Id := Defining_Unit_Name (Specification (P_Unit));
+ Lim_Typ : Entity_Id;
begin
if Nkind (P) = N_Defining_Program_Unit_Name then
Write_Eol;
end if;
- -- Remove all shadow entities from visibility
-
- Lim_Elmt := First_Elmt (Limited_Views (P));
+ -- Remove all shadow entities from visibility. The first element of the
+ -- limited view is a header (an E_Package entity) that is used to
+ -- reference the first shadow entity in the private part of the package
- while Present (Lim_Elmt) loop
- Lim_Typ := Node (Lim_Elmt);
+ Lim_Typ := First_Entity (Limited_View (P));
+ while Present (Lim_Typ) loop
Unchain (Lim_Typ);
- Next_Elmt (Lim_Elmt);
+ Next_Entity (Lim_Typ);
end loop;
-- Indicate that the limited view of the package is not installed
Write_Name (Chars (Ent));
Write_Eol;
end if;
-
end if;
Next_Entity (Ent);
procedure Remove_Parents (Lib_Unit : Node_Id) is
P : Node_Id;
P_Name : Entity_Id;
+ P_Spec : Node_Id := Empty;
E : Entity_Id;
Vis : constant Boolean :=
Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility;
begin
if Is_Child_Spec (Lib_Unit) then
- P := Unit (Parent_Spec (Lib_Unit));
- P_Name := Get_Parent_Entity (P);
+ P_Spec := Parent_Spec (Lib_Unit);
- Remove_Context_Clauses (Parent_Spec (Lib_Unit));
+ elsif Nkind (Lib_Unit) = N_Package_Body
+ and then Nkind (Original_Node (Lib_Unit)) = N_Package_Instantiation
+ then
+ P_Spec := Parent_Spec (Original_Node (Lib_Unit));
+ end if;
+
+ if Present (P_Spec) then
+
+ P := Unit (P_Spec);
+ P_Name := Get_Parent_Entity (P);
+ Remove_Context_Clauses (P_Spec);
End_Package_Scope (P_Name);
Set_Is_Immediately_Visible (P_Name, Vis);
OSDN Git Service
