-- --
-- B o d y --
-- --
--- $Revision$
--- --
--- Copyright (C) 1992-2001 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- --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
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;
with Sinput; use Sinput;
with Snames; use Snames;
with Style; use Style;
+with Stylesw; use Stylesw;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uname; use Uname;
procedure Analyze_Context (N : Node_Id);
-- Analyzes items in the context clause of compilation unit
+ procedure Build_Limited_Views (N : Node_Id);
+ -- Build and decorate the list of shadow entities for a package mentioned
+ -- 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
+ -- be included in a standalone library.
+
procedure Check_With_Type_Clauses (N : Node_Id);
-- If N is a body, verify that any with_type clauses on the spec, or
-- on the spec of any parent, have a matching with_clause.
-- Verify that a stub is declared immediately within a compilation unit,
-- 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
+ -- 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
-- parents are made explicit, and with clauses are inserted in the context
-- N is the compilation unit whose list of context items receives the
-- implicit with_clauses.
+ function Get_Parent_Entity (Unit : Node_Id) return Entity_Id;
+ -- Get defining entity of parent unit of a child unit. In most cases this
+ -- is the defining entity of the unit, but for a child instance whose
+ -- parent needs a body for inlining, the instantiation node of the parent
+ -- has not yet been rewritten as a package declaration, and the entity has
+ -- to be retrieved from the Instance_Spec of the unit.
+
procedure Implicit_With_On_Parent (Child_Unit : Node_Id; N : Node_Id);
-- If the main unit is a child unit, implicit withs are also added for
-- all its ancestors.
-- Subsidiary to previous one. Process only with_ and use_clauses for
-- current unit and its library unit if any.
- procedure Install_Withed_Unit (With_Clause : Node_Id);
+ procedure Install_Limited_Context_Clauses (N : Node_Id);
+ -- Subsidiary to Install_Context. Process only limited with_clauses
+ -- 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. Implements Ada 2005 (AI-50217).
+
+ procedure Install_Withed_Unit
+ (With_Clause : Node_Id;
+ Private_With_OK : Boolean := False);
+
-- 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
-- analysis (should it appear otherwise in the context).
procedure Remove_Context_Clauses (N : Node_Id);
- -- Subsidiary of previous one. Remove use_ and with_clauses.
+ -- Subsidiary of previous one. Remove use_ and with_clauses
+
+ procedure Remove_Limited_With_Clause (N : Node_Id);
+ -- Remove from visibility the shadow entities introduced for a package
+ -- 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
-- Reset all visibility flags on unit after compiling it, either as a
-- main unit or as a unit in the context.
+ procedure Unchain (E : Entity_Id);
+ -- Remove single entity from visibility list
+
procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id);
-- Common processing for all stubs (subprograms, tasks, packages, and
-- protected cases). N is the stub to be analyzed. Once the subunit
-- entity for which the proper body provides a completion. Subprogram
-- stubs are handled differently because they can be declarations.
+ --------------------------
+ -- Limited_With_Clauses --
+ --------------------------
+
+ -- Limited_With clauses are the mechanism chosen for Ada05 to support
+ -- mutually recursive types declared in different units. A limited_with
+ -- clause that names package P in the context of unit U makes the types
+ -- declared in the visible part of P available within U, but with the
+ -- restriction that these types can only be used as incomplete types.
+ -- The limited_with clause does not impose a semantic dependence on P,
+ -- and it is possible for two packages to have limited_with_clauses on
+ -- each other without creating an elaboration circularity.
+
+ -- To support this feature, the analysis of a limited_with clause must
+ -- create an abbreviated view of the package, without performing any
+ -- semantic analysis on it. This "package abstract" contains shadow
+ -- types that are in one-one correspondence with the real types in the
+ -- package, and that have the properties of incomplete types.
+
+ -- The implementation creates two element lists: one to chain the shadow
+ -- entities, and one to chain the corresponding type entities in the tree
+ -- of the package. Links between corresponding entities in both chains
+ -- allow the compiler to select the proper view of a given type, depending
+ -- on the context. Note that in contrast with the handling of private
+ -- types, the limited view and the non-limited view of a type are treated
+ -- as separate entities, and no entity exchange needs to take place, which
+ -- makes the implementation must simpler than could be feared.
+
------------------------------
-- Analyze_Compilation_Unit --
------------------------------
Semantics (Lib_Unit);
if not Analyzed (Proper_Body (Unit_Node)) then
- if Errors_Detected > 0 then
+ if Serious_Errors_Detected > 0 then
Error_Msg_N ("subunit not analyzed (errors in parent unit)", N);
else
Error_Msg_N ("missing stub for subunit", N);
Semantics (Lib_Unit);
Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit));
- -- Verify that the library unit is a package declaration.
+ -- Verify that the library unit is a package declaration
if Nkind (Unit (Lib_Unit)) /= N_Package_Declaration
and then
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;
-- The analysis of the parent is done with style checks off
declare
- Save_Style_Check : constant Boolean := Opt.Style_Check;
- Save_C_Restrict : constant Save_Compilation_Unit_Restrictions :=
- Compilation_Unit_Restrictions_Save;
+ Save_Style_Check : constant Boolean := Style_Check;
+ 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;
if Is_Child_Spec (Unit_Node) then
- -- Set the entities of all parents in the program_unit_name.
+ -- Set the entities of all parents in the program_unit_name
Generate_Parent_References (
- Unit_Node, Defining_Entity (Unit (Parent_Spec (Unit_Node))));
+ Unit_Node, Get_Parent_Entity (Unit (Parent_Spec (Unit_Node))));
end if;
-- All components of the context: with-clauses, library unit, ancestors
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
then
Remove_Unit_From_Visibility (Defining_Entity (Unit_Node));
+ -- If the unit is an instantiation whose body will be elaborated
+ -- for inlining purposes, use the the proper entity of the instance.
+
+ elsif Nkind (Unit_Node) = N_Package_Instantiation
+ and then not Error_Posted (Unit_Node)
+ then
+ Remove_Unit_From_Visibility
+ (Defining_Entity (Instance_Spec (Unit_Node)));
+
elsif Nkind (Unit_Node) = N_Package_Body
or else (Nkind (Unit_Node) = N_Subprogram_Body
and then not Acts_As_Spec (Unit_Node))
and then Operating_Mode = Generate_Code
and then Expander_Active
then
+ -- Check whether the source for the body of the unit must be
+ -- included in a standalone library.
+
+ Check_Body_Needed_For_SAL (Cunit_Entity (Main_Unit));
+
-- Indicate that the main unit is now analyzed, to catch possible
-- circularities between it and generic bodies. Remove main unit
-- from visibility. This might seem superfluous, but the main unit
Nam : Entity_Id;
Un : Unit_Number_Type;
- Save_Style_Check : constant Boolean := Opt.Style_Check;
- Save_C_Restrict : constant Save_Compilation_Unit_Restrictions :=
- Compilation_Unit_Restrictions_Save;
+ Save_Style_Check : constant Boolean := Style_Check;
+ 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)
then
Nam := Entity (Name (Item));
- if (Ekind (Nam) = E_Generic_Procedure
+ if (Is_Generic_Subprogram (Nam)
and then not Is_Intrinsic_Subprogram (Nam))
- or else (Ekind (Nam) = E_Generic_Function
- and then not Is_Intrinsic_Subprogram (Nam))
or else (Ekind (Nam) = E_Generic_Package
and then Unit_Requires_Body (Nam))
then
- Opt.Style_Check := False;
+ Style_Check := False;
if Present (Renamed_Object (Nam)) then
Un :=
elsif not Analyzed (Cunit (Un))
and then Un /= Main_Unit
+ and then not Fatal_Error (Un)
then
- Opt.Style_Check := False;
+ Style_Check := False;
Semantics (Cunit (Un));
end if;
end if;
end loop;
Style_Check := Save_Style_Check;
- Compilation_Unit_Restrictions_Restore (Save_C_Restrict);
+ Cunit_Boolean_Restrictions_Restore (Save_C_Restrict);
end;
end if;
if Nkind (Unit_Node) = N_Package_Declaration
and then Get_Cunit_Unit_Number (N) /= Main_Unit
- and then Front_End_Inlining
and then Expander_Active
then
- Check_Body_For_Inlining (N, Defining_Entity (Unit_Node));
+ declare
+ Save_Style_Check : constant Boolean := Style_Check;
+ Save_Warning : constant Warning_Mode_Type := Warning_Mode;
+ Options : Style_Check_Options;
+
+ begin
+ Save_Style_Check_Options (Options);
+ Reset_Style_Check_Options;
+ Opt.Warning_Mode := Suppress;
+ Check_Body_For_Inlining (N, Defining_Entity (Unit_Node));
+
+ Reset_Style_Check_Options;
+ Set_Style_Check_Options (Options);
+ Style_Check := Save_Style_Check;
+ Warning_Mode := Save_Warning;
+ end;
end if;
end Analyze_Compilation_Unit;
---------------------
procedure Analyze_Context (N : Node_Id) is
+ Ukind : constant Node_Kind := Nkind (Unit (N));
Item : Node_Id;
begin
- -- Loop through context items
+ -- 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 (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
-- For with clause, analyze the with clause, and then update
-- the version, since we are dependent on a unit that we with.
- if Nkind (Item) = N_With_Clause then
+ if Nkind (Item) = N_With_Clause
+ and then not Limited_Present (Item)
+ then
-- Skip analyzing with clause if no unit, nothing to do (this
-- happens for a with that references a non-existant unit)
Next (Item);
end loop;
+
+ -- Second pass: add implicit limited_with_clauses for parents of
+ -- child units mentioned in limited_with clauses.
+
+ Item := First (Context_Items (N));
+
+ while Present (Item) loop
+ if Nkind (Item) = N_With_Clause
+ and then Limited_Present (Item)
+ and then Nkind (Name (Item)) = N_Selected_Component
+ then
+ Expand_Limited_With_Clause
+ (Nam => Prefix (Name (Item)), N => Item);
+ end if;
+
+ Next (Item);
+ end loop;
+
+ -- Third pass: examine all limited_with clauses
+
+ Item := First (Context_Items (N));
+
+ while Present (Item) loop
+ if Nkind (Item) = N_With_Clause
+ and then Limited_Present (Item)
+ then
+ -- Check the compilation unit containing the limited-with
+ -- clause
+
+ if Ukind /= N_Package_Declaration
+ and then Ukind /= N_Subprogram_Declaration
+ and then Ukind /= N_Subprogram_Renaming_Declaration
+ and then Ukind /= N_Generic_Package_Declaration
+ and then Ukind /= N_Generic_Package_Renaming_Declaration
+ and then Ukind /= N_Generic_Subprogram_Declaration
+ and then Ukind /= N_Generic_Procedure_Renaming_Declaration
+ and then Ukind /= N_Package_Instantiation
+ and then Ukind /= N_Package_Renaming_Declaration
+ and then Ukind /= N_Procedure_Instantiation
+ then
+ Error_Msg_N
+ ("limited with_clause not allowed here", Item);
+ end if;
+
+ -- Skip analyzing with clause if no unit, see above
+
+ if Present (Library_Unit (Item)) then
+ Analyze (Item);
+ end if;
+
+ -- A limited_with does not impose an elaboration order, but
+ -- there is a semantic dependency for recompilation purposes.
+
+ if not Implicit_With (Item) then
+ Version_Update (N, Library_Unit (Item));
+ end if;
+ end if;
+
+ Next (Item);
+ end loop;
end Analyze_Context;
-------------------------------
Nam : Entity_Id;
begin
- -- The package declaration must be in the current declarative part.
+ -- The package declaration must be in the current declarative part
Check_Stub_Level (N);
Nam := Current_Entity_In_Scope (Id);
Set_Has_Completion (Nam);
Set_Scope (Defining_Entity (N), Current_Scope);
+ Generate_Reference (Nam, Id, 'b');
Analyze_Proper_Body (N, Nam);
end if;
end Analyze_Package_Body_Stub;
procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id) is
Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N);
Unum : Unit_Number_Type;
- Subunit_Not_Found : Boolean := False;
procedure Optional_Subunit;
-- This procedure is called when the main unit is a stub, or when we
-- 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
- if Unum /= No_Unit and then not Fatal_Error (Unum) then
+ if Unum /= No_Unit
+ and then (not Fatal_Error (Unum) or else Try_Semantics)
+ then
Comp_Unit := Cunit (Unum);
- Set_Corresponding_Stub (Unit (Comp_Unit), N);
- Analyze_Subunit (Comp_Unit);
- Set_Library_Unit (N, Comp_Unit);
+ -- If the file was empty or seriously mangled, the unit
+ -- itself may be missing.
+
+ if No (Unit (Comp_Unit)) then
+ Error_Msg_N
+ ("subunit does not contain expected proper body", N);
+
+ elsif 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)
if Unum /= No_Unit then
Compiler_State := Analyzing;
+
+ -- Check that the proper body is a subunit and not a child
+ -- unit. If the unit was previously loaded, the error will
+ -- have been emitted when copying the generic node, so we
+ -- just return to avoid cascaded errors.
+
+ if Nkind (Unit (Cunit (Unum))) /= N_Subunit then
+ return;
+ end if;
+
Set_Corresponding_Stub (Unit (Cunit (Unum)), N);
Analyze_Subunit (Cunit (Unum));
Set_Library_Unit (N, Cunit (Unum));
elsif Nkind (Unit (Cunit (Main_Unit))) = N_Subunit
and then Subunit_Name /= Unit_Name (Main_Unit)
then
- if Tree_Output then
+ if ASIS_Mode then
Optional_Subunit;
end if;
-- presence, and emit a warning if not found, rather than terminating
-- the compilation abruptly, as for other missing file problems.
- elsif Operating_Mode = Generate_Code then
+ elsif Original_Operating_Mode = Generate_Code then
-- If the proper body is already linked to the stub node,
-- the stub is in a generic unit and just needs analyzing.
Subunit => True,
Error_Node => N);
- if Operating_Mode = Generate_Code
+ if Original_Operating_Mode = Generate_Code
and then Unum = No_Unit
then
Error_Msg_Name_1 := Subunit_Name;
Error_Msg_N
("subunit% in file{ not found!?", N);
Subunits_Missing := True;
- Subunit_Not_Found := True;
end if;
-- Load_Unit may reset Compiler_State, since it may have been
Compiler_State := Analyzing;
- if Unum /= No_Unit and then not Fatal_Error (Unum) then
-
+ if Unum /= No_Unit
+ and then (not Fatal_Error (Unum) or else Try_Semantics)
+ then
if Debug_Flag_L then
Write_Str ("*** Loaded subunit from stub. Analyze");
Write_Eol;
begin
Check_Stub_Level (N);
- -- First occurence of name may have been as an incomplete type.
+ -- First occurence of name may have been as an incomplete type
if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then
Nam := Full_View (Nam);
else
Set_Scope (Defining_Entity (N), Current_Scope);
Set_Has_Completion (Etype (Nam));
+ Generate_Reference (Nam, Defining_Identifier (N), 'b');
Analyze_Proper_Body (N, Etype (Nam));
end if;
end Analyze_Protected_Body_Stub;
-- declaration, or else introduces entity and its signature.
Analyze_Subprogram_Body (N);
-
- if Errors_Detected = 0 then
- Analyze_Proper_Body (N, Empty);
- end if;
-
+ Analyze_Proper_Body (N, Empty);
end Analyze_Subprogram_Body_Stub;
---------------------
Num_Scopes : Int := 0;
Use_Clauses : array (1 .. Scope_Stack.Last) of Node_Id;
Enclosing_Child : Entity_Id := Empty;
+ Svg : constant Suppress_Array := Scope_Suppress;
procedure Analyze_Subunit_Context;
-- Capture names in use clauses of the subunit. This must be done
-- 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;
while Present (Item) loop
if Nkind (Item) = N_With_Clause then
- Unit_Name := Entity (Name (Item));
+ -- Protect the frontend against previous errors
+ -- in context clauses
- while Is_Child_Unit (Unit_Name) loop
- Set_Is_Visible_Child_Unit (Unit_Name);
- Unit_Name := Scope (Unit_Name);
- end loop;
+ if Nkind (Name (Item)) /= N_Selected_Component then
+ Unit_Name := Entity (Name (Item));
+
+ while Is_Child_Unit (Unit_Name) loop
+ Set_Is_Visible_Child_Unit (Unit_Name);
+ Unit_Name := Scope (Unit_Name);
+ end loop;
- if not Is_Immediately_Visible (Unit_Name) then
- Set_Is_Immediately_Visible (Unit_Name);
- Set_Context_Installed (Item);
+ if not Is_Immediately_Visible (Unit_Name) then
+ Set_Is_Immediately_Visible (Unit_Name);
+ Set_Context_Installed (Item);
+ end if;
end if;
elsif Nkind (Item) = N_Use_Package_Clause then
while Present (Item) loop
- if Nkind (Item) = N_With_Clause then
+ if Nkind (Item) = N_With_Clause
+
+ -- Protect the frontend against previous errors in context
+ -- clauses
+
+ and then Nkind (Name (Item)) /= N_Selected_Component
+ then
Unit_Name := Entity (Name (Item));
while Is_Child_Unit (Unit_Name) loop
E := First_Entity (Current_Scope);
+ -- Make entities in scope visible again. For child units, restore
+ -- visibility only if they are actually in context.
+
while Present (E) loop
- Set_Is_Immediately_Visible (E);
+ if not Is_Child_Unit (E)
+ or else Is_Visible_Child_Unit (E)
+ then
+ Set_Is_Immediately_Visible (E);
+ end if;
+
Next_Entity (E);
end loop;
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;
begin
if not Is_Empty_List (Context_Items (N)) then
- -- Save current use clauses.
+ -- Save current use clauses
Remove_Scope;
Remove_Context (Lib_Unit);
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,
Re_Install_Use_Clauses;
Install_Context (N);
+ -- Restore state of suppress flags for current body
+
+ Scope_Suppress := Svg;
+
-- If the subunit is within a child unit, then siblings of any
-- parent unit that appear in the context clause of the subunit
-- must also be made immediately visible.
Analyze (Proper_Body (Unit (N)));
Remove_Context (N);
-
end Analyze_Subunit;
----------------------------
begin
Check_Stub_Level (N);
- -- First occurence of name may have been as an incomplete type.
+ -- First occurence of name may have been as an incomplete type
if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then
Nam := Full_View (Nam);
Error_Msg_N ("missing specification for task body", N);
else
Set_Scope (Defining_Entity (N), Current_Scope);
+ Generate_Reference (Nam, Defining_Identifier (N), 'b');
Set_Has_Completion (Etype (Nam));
Analyze_Proper_Body (N, Etype (Nam));
-- label the with clause with the defining entity for the unit.
procedure Analyze_With_Clause (N : Node_Id) is
- Unit_Kind : constant Node_Kind := Nkind (Unit (Library_Unit (N)));
+
+ -- Retrieve the original kind of the unit node, before analysis.
+ -- If it is a subprogram instantiation, its analysis below will
+ -- rewrite as the declaration of the wrapper package. If the same
+ -- instantiation appears indirectly elsewhere in the context, it
+ -- will have been analyzed already.
+
+ Unit_Kind : constant Node_Kind :=
+ Nkind (Original_Node (Unit (Library_Unit (N))));
+
E_Name : Entity_Id;
Par_Name : Entity_Id;
Pref : Node_Id;
-- 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
+ -- Ada 2005 (AI-50217): Build visibility structures but do not
+ -- analyze unit
+
+ Build_Limited_Views (N);
+ return;
+ end if;
+
-- We reset ordinary style checking during the analysis of a with'ed
-- unit, but we do NOT reset GNAT special analysis mode (the latter
-- definitely *does* apply to with'ed units).
Style_Check := False;
end if;
- -- If the library unit is a predefined unit, and we are in no
- -- run time mode, then temporarily reset No_Run_Time mode for the
- -- analysis of the with'ed unit. The No_Run_Time pragma does not
- -- prevent explicit with'ing of run-time units.
+ -- If the library unit is a predefined unit, and we are in high
+ -- integrity mode, then temporarily reset Configurable_Run_Time_Mode
+ -- for the analysis of the with'ed unit. This mode does not prevent
+ -- explicit with'ing of run-time units.
- if No_Run_Time
+ if Configurable_Run_Time_Mode
and then
Is_Predefined_File_Name
(Unit_File_Name (Get_Source_Unit (Unit (Library_Unit (N)))))
then
- No_Run_Time := False;
+ Configurable_Run_Time_Mode := False;
Semantics (Library_Unit (N));
- No_Run_Time := True;
+ Configurable_Run_Time_Mode := True;
else
Semantics (Library_Unit (N));
end if;
U := Unit (Library_Unit (N));
+ Check_Restriction_No_Dependence (Name (N), N);
Intunit := Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit));
-- Following checks are skipped for dummy packages (those supplied
-- Check for inappropriate with of internal implementation unit
-- if we are currently compiling the main unit and the main unit
- -- is itself not an internal unit.
+ -- is itself not an internal unit. We do not issue this message
+ -- for implicit with's generated by the compiler itself.
if Implementation_Unit_Warnings
and then Current_Sem_Unit = Main_Unit
- and then Implementation_Unit (Get_Source_Unit (U))
and then not Intunit
+ and then not Implicit_With (N)
+ and then not GNAT_Mode
then
- Error_Msg_N ("& is an internal 'G'N'A'T unit?", Name (N));
- Error_Msg_N
- ("\use of this unit is non-portable and version-dependent?",
- Name (N));
+ declare
+ U_Kind : constant Kind_Of_Unit :=
+ Get_Kind_Of_Unit (Get_Source_Unit (U));
+
+ begin
+ if U_Kind = Implementation_Unit then
+ Error_Msg_N ("& is an internal 'G'N'A'T unit?", Name (N));
+ Error_Msg_N
+ ("\use of this unit is non-portable " &
+ "and version-dependent?",
+ Name (N));
+
+ elsif U_Kind = Ada_05_Unit
+ and then Ada_Version < Ada_05
+ and then Warn_On_Ada_2005_Compatibility
+ then
+ Error_Msg_N ("& is an Ada 2005 unit?", Name (N));
+ end if;
+ end;
end if;
end if;
E_Name := Defining_Entity (U);
-- Note: in the following test, Unit_Kind is the original Nkind, but
- -- in the case of an instantiation, the call to Semantics above will
- -- have replaced the unit by its instantiated version.
-
- elsif Unit_Kind = N_Package_Instantiation
+ -- in the case of an instantiation, semantic analysis above will
+ -- have replaced the unit by its instantiated version. If the instance
+ -- body has been generated, the instance now denotes the body entity.
+ -- For visibility purposes we need the entity of its spec.
+
+ elsif (Unit_Kind = N_Package_Instantiation
+ or else Nkind (Original_Node (Unit (Library_Unit (N)))) =
+ N_Package_Instantiation)
and then Nkind (U) = N_Package_Body
then
- -- Instantiation node is replaced with body of instance.
- -- Unit name is defining unit name in corresponding spec.
-
E_Name := Corresponding_Spec (U);
elsif Unit_Kind = N_Package_Instantiation
-- 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
-- reference that occurs.
Set_Entity_With_Style_Check (Name (N), E_Name);
- Generate_Reference (E_Name, Name (N), Set_Ref => False);
+ Generate_Reference (E_Name, Name (N), 'w', Set_Ref => False);
if Is_Child_Unit (E_Name) then
Pref := Prefix (Name (N));
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))
if Chars (E_Name) = Name_System
and then Scope (E_Name) = Standard_Standard
- and then Present (System_Extend_Pragma_Arg)
+ and then Present (System_Extend_Unit)
and then Present_System_Aux (N)
then
- -- If the extension is not present, an error will have been emitted.
+ -- If the extension is not present, an error will have been emitted
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;
------------------------------
procedure Analyze_With_Type_Clause (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Nam : Node_Id := Name (N);
+ Nam : constant Node_Id := Name (N);
Pack : Node_Id;
Decl : Node_Id;
P : Entity_Id;
Unum : Unit_Number_Type;
Sel : Node_Id;
- procedure Decorate_Tagged_Type (T : Entity_Id; Kind : Entity_Kind);
- -- Set basic attributes of type, including its class_wide type.
+ procedure Decorate_Tagged_Type (T : Entity_Id);
+ -- Set basic attributes of type, including its class_wide type
function In_Chain (E : Entity_Id) return Boolean;
-- Check that the imported type is not already in the homonym chain,
-- Decorate_Tagged_Type --
--------------------------
- procedure Decorate_Tagged_Type (T : Entity_Id; Kind : Entity_Kind) is
+ procedure Decorate_Tagged_Type (T : Entity_Id) is
CW : Entity_Id;
begin
Set_Current_Entity (T);
end if;
- -- Build bogus class_wide type, if not previously done.
+ -- Build bogus class_wide type, if not previously done
if No (Class_Wide_Type (T)) then
CW := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
if Nkind (Parent (P)) = N_Defining_Program_Unit_Name then
- -- Make parent packages visible.
+ -- Make parent packages visible
declare
Parent_Comp : Node_Id;
-- to type and build its class-wide type.
Init_Size_Align (Typ);
- Decorate_Tagged_Type (Typ, E_Record_Type);
+ Decorate_Tagged_Type (Typ);
end if;
else
Error_Msg_N ("type must be declared tagged", N);
elsif not Analyzed (Decl) then
- Decorate_Tagged_Type (Typ, E_Private_Type);
+ Decorate_Tagged_Type (Typ);
end if;
Set_Entity (Sel, Typ);
Lib_Unit : constant Node_Id := Unit (N);
procedure Check_Parent_Context (U : Node_Id);
- -- Examine context items of parent unit to locate with_type clauses.
+ -- Examine context items of parent unit to locate with_type clauses
--------------------------
-- Check_Parent_Context --
From_With_Type (Scope (Entity (Selector_Name (Name (Item)))))
then
Error_Msg_Sloc := Sloc (Item);
- Error_Msg_N ("Missing With_Clause for With_Type_Clause#", N);
+ Error_Msg_N ("missing With_Clause for With_Type_Clause#", N);
end if;
Next (Item);
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;
-- an explicit designation of private.
function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean is
+ Comp_Unit : constant Node_Id := Parent (Unit_Declaration_Node (Unit));
+
begin
- return Private_Present (Parent (Unit_Declaration_Node (Unit)));
+ return Private_Present (Comp_Unit);
end Is_Private_Library_Unit;
-- Start of processing for Check_Private_Child_Unit
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));
New_Nodes_OK := New_Nodes_OK - 1;
end Expand_With_Clause;
+ --------------------------------
+ -- Expand_Limited_With_Clause --
+ --------------------------------
+
+ procedure Expand_Limited_With_Clause (Nam : Node_Id; N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Nam);
+ Unum : Unit_Number_Type;
+ Withn : Node_Id;
+
+ begin
+ New_Nodes_OK := New_Nodes_OK + 1;
+
+ if Nkind (Nam) = N_Identifier then
+ Withn :=
+ Make_With_Clause (Loc, Name => Nam);
+ Set_Limited_Present (Withn);
+ Set_First_Name (Withn);
+ Set_Implicit_With (Withn);
+
+ -- Load the corresponding parent unit
+
+ Unum :=
+ Load_Unit
+ (Load_Name => Get_Spec_Name (Get_Unit_Name (Nam)),
+ Required => True,
+ Subunit => False,
+ Error_Node => Nam);
+
+ if not Analyzed (Cunit (Unum)) then
+ Set_Library_Unit (Withn, Cunit (Unum));
+ Set_Corresponding_Spec
+ (Withn, Specification (Unit (Cunit (Unum))));
+
+ Prepend (Withn, Context_Items (Parent (N)));
+ Mark_Rewrite_Insertion (Withn);
+ end if;
+
+ else pragma Assert (Nkind (Nam) = N_Selected_Component);
+ Withn :=
+ Make_With_Clause
+ (Loc,
+ Name =>
+ Make_Selected_Component
+ (Loc,
+ Prefix => Prefix (Nam),
+ Selector_Name => Selector_Name (Nam)));
+
+ Set_Parent (Withn, Parent (N));
+ Set_Limited_Present (Withn);
+ Set_First_Name (Withn);
+ Set_Implicit_With (Withn);
+
+ Unum :=
+ Load_Unit
+ (Load_Name => Get_Spec_Name (Get_Unit_Name (Nam)),
+ Required => True,
+ Subunit => False,
+ Error_Node => Nam);
+
+ if not Analyzed (Cunit (Unum)) then
+ Set_Library_Unit (Withn, Cunit (Unum));
+ Set_Corresponding_Spec
+ (Withn, Specification (Unit (Cunit (Unum))));
+ Prepend (Withn, Context_Items (Parent (N)));
+ Mark_Rewrite_Insertion (Withn);
+
+ Expand_Limited_With_Clause (Prefix (Nam), N);
+ end if;
+ end if;
+
+ New_Nodes_OK := New_Nodes_OK - 1;
+ end Expand_Limited_With_Clause;
+
+ -----------------------
+ -- Get_Parent_Entity --
+ -----------------------
+
+ function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is
+ begin
+ 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;
+ end Get_Parent_Entity;
+
-----------------------------
-- Implicit_With_On_Parent --
-----------------------------
is
Loc : constant Source_Ptr := Sloc (N);
P : constant Node_Id := Parent_Spec (Child_Unit);
- P_Unit : constant Node_Id := Unit (P);
- P_Name : Entity_Id := Defining_Entity (P_Unit);
+ 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;
- -- Build prefix of child unit name. Recurse if needed.
+ 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;
-- If the unit is a child unit, build qualified name with all
-------------------------
function Build_Ancestor_Name (P : Node_Id) return Node_Id is
- P_Ref : Node_Id := New_Reference_To (Defining_Entity (P), Loc);
+ P_Ref : constant Node_Id :=
+ New_Reference_To (Defining_Entity (P), Loc);
+ P_Spec : Node_Id := P;
begin
- if No (Parent_Spec (P)) then
+ -- Ancestor may have been rewritten as a package body. Retrieve
+ -- the original spec to trace earlier ancestors.
+
+ if Nkind (P) = N_Package_Body
+ and then Nkind (Original_Node (P)) = N_Package_Instantiation
+ then
+ P_Spec := Original_Node (P);
+ end if;
+
+ if No (Parent_Spec (P_Spec)) then
return P_Ref;
else
return
Make_Selected_Component (Loc,
- Prefix => Build_Ancestor_Name (Unit (Parent_Spec (P))),
+ Prefix => Build_Ancestor_Name (Unit (Parent_Spec (P_Spec))),
Selector_Name => P_Ref);
end if;
end Build_Ancestor_Name;
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;
---------------------
procedure Install_Context (N : Node_Id) is
- Lib_Unit : Node_Id := Unit (N);
+ Lib_Unit : constant Node_Id := Unit (N);
begin
Install_Context_Clauses (N);
Install_Parents (Lib_Unit, Private_Present (Parent (Lib_Unit)));
end if;
+ Install_Limited_Context_Clauses (N);
+
Check_With_Type_Clauses (N);
end Install_Context;
-----------------------------
procedure Install_Context_Clauses (N : Node_Id) is
- Lib_Unit : Node_Id := Unit (N);
+ Lib_Unit : constant Node_Id := Unit (N);
Item : Node_Id;
Uname_Node : Entity_Id;
Check_Private : Boolean := False;
Lib_Parent : Entity_Id;
begin
- -- Loop through context clauses to find the with/use clauses
+ -- Loop through context clauses to find the with/use clauses.
+ -- This is done twice, first for everything except limited_with
+ -- clauses, and then for those, if any are present.
Item := First (Context_Items (N));
while Present (Item) loop
if Nkind (Item) = N_With_Clause
and then not Implicit_With (Item)
then
+ if Limited_Present (Item) then
+
+ -- Limited withed units will be installed later
+
+ goto Continue;
+
-- If Name (Item) is not an entity name, something is wrong, and
-- this will be detected in due course, for now ignore the item
- if not Is_Entity_Name (Name (Item)) then
+ elsif not Is_Entity_Name (Name (Item)) then
+ goto Continue;
+
+ elsif No (Entity (Name (Item))) then
+ Set_Entity (Name (Item), Any_Id);
goto Continue;
end if;
if Is_Child_Spec (Lib_Unit) then
- -- The unit also has implicit withs on its own parents.
+ -- The unit also has implicit withs on its own parents
if No (Context_Items (N)) then
Set_Context_Items (N, New_List);
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;
end if;
end Install_Context_Clauses;
- ---------------------
- -- Install_Parents --
- ---------------------
+ -------------------------------------
+ -- Install_Limited_Context_Clauses --
+ -------------------------------------
- procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean) is
- P : Node_Id;
- E_Name : Entity_Id;
- P_Name : Entity_Id;
- P_Spec : Node_Id;
+ procedure Install_Limited_Context_Clauses (N : Node_Id) is
+ Item : Node_Id;
- begin
- P := Unit (Parent_Spec (Lib_Unit));
- P_Name := Defining_Entity (P);
+ procedure Check_Parent (P : Node_Id; W : Node_Id);
+ -- Check that the unlimited view of a given compilation_unit is not
+ -- already visible in the parents (neither immediately through the
+ -- context clauses, nor indirectly through "use + renamings").
- if Etype (P_Name) = Any_Type then
- return;
- end if;
+ procedure Check_Private_Limited_Withed_Unit (N : Node_Id);
+ -- Check that if a limited_with clause of a given compilation_unit
+ -- mentions a private child of some library unit, then the given
+ -- compilation_unit shall be the declaration of a private descendant
+ -- of that library unit.
- if Ekind (P_Name) = E_Generic_Package
- and then Nkind (Lib_Unit) /= N_Generic_Subprogram_Declaration
- and then Nkind (Lib_Unit) /= N_Generic_Package_Declaration
- and then Nkind (Lib_Unit) not in N_Generic_Renaming_Declaration
- then
- Error_Msg_N
- ("child of a generic package must be a generic unit", Lib_Unit);
+ procedure Check_Withed_Unit (W : Node_Id);
+ -- Check that a limited with_clause does not appear in the same
+ -- context_clause as a nonlimited with_clause that mentions
+ -- the same library.
- elsif not Is_Package (P_Name) then
- Error_Msg_N
- ("parent unit must be package or generic package", Lib_Unit);
- raise Unrecoverable_Error;
+ ------------------
+ -- Check_Parent --
+ ------------------
- elsif Present (Renamed_Object (P_Name)) then
- Error_Msg_N ("parent unit cannot be a renaming", Lib_Unit);
- raise Unrecoverable_Error;
+ procedure Check_Parent (P : Node_Id; W : Node_Id) is
+ Item : Node_Id;
+ Spec : Node_Id;
+ WEnt : Entity_Id;
+ Nam : Node_Id;
+ E : Entity_Id;
+ E2 : Entity_Id;
- -- Verify that a child of an instance is itself an instance, or
- -- the renaming of one. Given that an instance that is a unit is
- -- replaced with a package declaration, check against the original
- -- node.
+ begin
+ pragma Assert (Nkind (W) = N_With_Clause);
- elsif Nkind (Original_Node (P)) = N_Package_Instantiation
- and then Nkind (Lib_Unit)
- not in N_Renaming_Declaration
- and then Nkind (Original_Node (Lib_Unit))
- not in N_Generic_Instantiation
- then
- Error_Msg_N
- ("child of an instance must be an instance or renaming", Lib_Unit);
- end if;
+ -- Protect the frontend against previous critical errors
- -- This is the recursive call that ensures all parents are loaded
+ case Nkind (Unit (Library_Unit (W))) is
+ when N_Subprogram_Declaration |
+ N_Package_Declaration |
+ N_Generic_Subprogram_Declaration |
+ N_Generic_Package_Declaration =>
+ null;
- if Is_Child_Spec (P) then
- Install_Parents (P,
- Is_Private or else Private_Present (Parent (Lib_Unit)));
- end if;
+ when others =>
+ return;
+ end case;
- -- Now we can install the context for this parent
+ -- Step 1: Check if the unlimited view is installed in the parent
- Install_Context_Clauses (Parent_Spec (Lib_Unit));
- Install_Siblings (P_Name, Parent (Lib_Unit));
+ Item := First (Context_Items (P));
+ while Present (Item) loop
+ if Nkind (Item) = N_With_Clause
+ and then not Limited_Present (Item)
+ and then not Implicit_With (Item)
+ and then Library_Unit (Item) = Library_Unit (W)
+ then
+ Error_Msg_N ("unlimited view visible in ancestor", W);
+ return;
+ end if;
- -- The child unit is in the declarative region of the parent. The
- -- parent must therefore appear in the scope stack and be visible,
- -- as when compiling the corresponding body. If the child unit is
- -- private or it is a package body, private declarations must be
- -- accessible as well. Use declarations in the parent must also
- -- be installed. Finally, other child units of the same parent that
- -- are in the context are immediately visible.
+ Next (Item);
+ end loop;
- -- Find entity for compilation unit, and set its private descendant
- -- status as needed.
+ -- Step 2: Check "use + renamings"
- E_Name := Defining_Entity (Lib_Unit);
+ WEnt := Defining_Unit_Name (Specification (Unit (Library_Unit (W))));
+ Spec := Specification (Unit (P));
- Set_Is_Child_Unit (E_Name);
+ -- We tried to traverse the list of entities corresponding to the
+ -- defining entity of the package spec. However, first_entity was
+ -- found to be 'empty'. Don't know why???
- Set_Is_Private_Descendant (E_Name,
- Is_Private_Descendant (P_Name)
- or else Private_Present (Parent (Lib_Unit)));
+ -- Def := Defining_Unit_Name (Spec);
+ -- Ent := First_Entity (Def);
- P_Spec := Specification (Unit_Declaration_Node (P_Name));
- New_Scope (P_Name);
+ -- As a workaround we traverse the list of visible declarations ???
+
+ Item := First (Visible_Declarations (Spec));
+ while Present (Item) loop
+
+ if Nkind (Item) = N_Use_Package_Clause then
+
+ -- Traverse the list of packages
+
+ Nam := First (Names (Item));
+
+ while Present (Nam) loop
+ E := Entity (Nam);
+
+ pragma Assert (Present (Parent (E)));
+
+ if Nkind (Parent (E))
+ = N_Package_Renaming_Declaration
+ and then Renamed_Entity (E) = WEnt
+ then
+ Error_Msg_N ("unlimited view visible through "
+ & "use_clause + renamings", W);
+ return;
+
+ elsif Nkind (Parent (E)) = N_Package_Specification then
+
+ -- The use clause may refer to a local package.
+ -- Check all the enclosing scopes.
+
+ E2 := E;
+ while E2 /= Standard_Standard
+ and then E2 /= WEnt loop
+ E2 := Scope (E2);
+ end loop;
+
+ if E2 = WEnt then
+ Error_Msg_N ("unlimited view visible through "
+ & "use_clause ", W);
+ return;
+ end if;
+
+ end if;
+ Next (Nam);
+ end loop;
+
+ end if;
+
+ Next (Item);
+ end loop;
+
+ -- Recursive call to check all the ancestors
+
+ if Is_Child_Spec (Unit (P)) then
+ Check_Parent (P => Parent_Spec (Unit (P)), W => W);
+ end if;
+ end Check_Parent;
+
+ ---------------------------------------
+ -- Check_Private_Limited_Withed_Unit --
+ ---------------------------------------
+
+ procedure Check_Private_Limited_Withed_Unit (N : Node_Id) is
+ C : Node_Id;
+ P : Node_Id;
+ Found : Boolean := False;
+
+ begin
+ -- If the current compilation unit is not private we don't
+ -- need to check anything else.
+
+ if not Private_Present (Parent (N)) then
+ Found := False;
+
+ else
+ -- Compilation unit of the parent of the withed library unit
+
+ P := Parent_Spec (Unit (Library_Unit (N)));
+
+ -- Traverse all the ancestors of the current compilation
+ -- unit to check if it is a descendant of named library unit.
+
+ C := Parent (N);
+ while Present (Parent_Spec (Unit (C))) loop
+ C := Parent_Spec (Unit (C));
+
+ if C = P then
+ Found := True;
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ if not Found then
+ Error_Msg_N ("current unit is not a private descendant"
+ & " of the withed unit ('R'M 10.1.2(8)", N);
+ end if;
+ end Check_Private_Limited_Withed_Unit;
+
+ -----------------------
+ -- Check_Withed_Unit --
+ -----------------------
+
+ procedure Check_Withed_Unit (W : Node_Id) is
+ Item : Node_Id;
+
+ begin
+ -- A limited with_clause can not appear in the same context_clause
+ -- as a nonlimited with_clause which mentions the same library.
+
+ Item := First (Context_Items (N));
+ while Present (Item) loop
+ if Nkind (Item) = N_With_Clause
+ and then not Limited_Present (Item)
+ and then not Implicit_With (Item)
+ and then Library_Unit (Item) = Library_Unit (W)
+ then
+ Error_Msg_N ("limited and unlimited view "
+ & "not allowed in the same context clauses", W);
+ return;
+ end if;
+
+ Next (Item);
+ end loop;
+ end Check_Withed_Unit;
+
+ -- Start of processing for Install_Limited_Context_Clauses
+
+ begin
+ Item := First (Context_Items (N));
+ while Present (Item) loop
+ if Nkind (Item) = N_With_Clause
+ and then Limited_Present (Item)
+ then
+ Check_Withed_Unit (Item);
+
+ if Private_Present (Library_Unit (Item)) then
+ Check_Private_Limited_Withed_Unit (Item);
+ end if;
+
+ if Is_Child_Spec (Unit (N)) then
+ Check_Parent (Parent_Spec (Unit (N)), Item);
+ end if;
+
+ Install_Limited_Withed_Unit (Item);
+ end if;
+
+ Next (Item);
+ end loop;
+ end Install_Limited_Context_Clauses;
+
+ ---------------------
+ -- Install_Parents --
+ ---------------------
+
+ procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean) is
+ P : Node_Id;
+ E_Name : Entity_Id;
+ P_Name : Entity_Id;
+ P_Spec : Node_Id;
+
+ begin
+ P := Unit (Parent_Spec (Lib_Unit));
+ P_Name := Get_Parent_Entity (P);
+
+ if Etype (P_Name) = Any_Type then
+ return;
+ end if;
+
+ if Ekind (P_Name) = E_Generic_Package
+ and then Nkind (Lib_Unit) /= N_Generic_Subprogram_Declaration
+ and then Nkind (Lib_Unit) /= N_Generic_Package_Declaration
+ and then Nkind (Lib_Unit) not in N_Generic_Renaming_Declaration
+ then
+ Error_Msg_N
+ ("child of a generic package must be a generic unit", Lib_Unit);
+
+ elsif not Is_Package (P_Name) then
+ Error_Msg_N
+ ("parent unit must be package or generic package", Lib_Unit);
+ raise Unrecoverable_Error;
+
+ elsif Present (Renamed_Object (P_Name)) then
+ Error_Msg_N ("parent unit cannot be a renaming", Lib_Unit);
+ raise Unrecoverable_Error;
+
+ -- Verify that a child of an instance is itself an instance, or
+ -- the renaming of one. Given that an instance that is a unit is
+ -- replaced with a package declaration, check against the original
+ -- node. The parent may be currently being instantiated, in which
+ -- case it appears as a declaration, but the generic_parent is
+ -- already established indicating that we deal with an instance.
+
+ elsif Nkind (Original_Node (P)) = N_Package_Instantiation then
+
+ if Nkind (Lib_Unit) in N_Renaming_Declaration
+ or else Nkind (Original_Node (Lib_Unit)) in N_Generic_Instantiation
+ or else
+ (Nkind (Lib_Unit) = N_Package_Declaration
+ and then Present (Generic_Parent (Specification (Lib_Unit))))
+ then
+ null;
+ else
+ Error_Msg_N
+ ("child of an instance must be an instance or renaming",
+ Lib_Unit);
+ end if;
+ end if;
+
+ -- This is the recursive call that ensures all parents are loaded
+
+ if Is_Child_Spec (P) then
+ Install_Parents (P,
+ Is_Private or else Private_Present (Parent (Lib_Unit)));
+ end if;
+
+ -- Now we can install the context for this parent
+
+ Install_Context_Clauses (Parent_Spec (Lib_Unit));
+ Install_Siblings (P_Name, Parent (Lib_Unit));
+
+ -- The child unit is in the declarative region of the parent. The
+ -- parent must therefore appear in the scope stack and be visible,
+ -- as when compiling the corresponding body. If the child unit is
+ -- private or it is a package body, private declarations must be
+ -- accessible as well. Use declarations in the parent must also
+ -- be installed. Finally, other child units of the same parent that
+ -- are in the context are immediately visible.
+
+ -- Find entity for compilation unit, and set its private descendant
+ -- status as needed.
+
+ E_Name := Defining_Entity (Lib_Unit);
+
+ Set_Is_Child_Unit (E_Name);
+
+ Set_Is_Private_Descendant (E_Name,
+ Is_Private_Descendant (P_Name)
+ or else Private_Present (Parent (Lib_Unit)));
+
+ P_Spec := Specification (Unit_Declaration_Node (P_Name));
+ New_Scope (P_Name);
-- Save current visibility of unit
Install_Visible_Declarations (P_Name);
Set_Use (Visible_Declarations (P_Spec));
+ -- If the parent is a generic unit, its formal part may contain
+ -- formal packages and use clauses for them.
+
+ if Ekind (P_Name) = E_Generic_Package then
+ Set_Use (Generic_Formal_Declarations (Parent (P_Spec)));
+ end if;
+
if Is_Private
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 ???
+ ----------------------------------
+ -- 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
+ -- Do not install private_with_clauses if the unit is a package
+ -- declaration, unless it is itself a private child unit.
+ while Present (Item) loop
if Nkind (Item) = N_With_Clause
and then not Implicit_With (Item)
+ and then not Limited_Present (Item)
+ and then
+ (not Private_Present (Item)
+ or else Nkind (Unit (N)) /= N_Package_Declaration
+ or else Private_Present (N))
then
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 loop;
end Install_Siblings;
+ -------------------------------
+ -- Install_Limited_With_Unit --
+ -------------------------------
+
+ procedure Install_Limited_Withed_Unit (N : Node_Id) is
+ Unum : constant Unit_Number_Type :=
+ Get_Source_Unit (Library_Unit (N));
+ P_Unit : constant Entity_Id := Unit (Library_Unit (N));
+ P : 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);
+
+ begin
+ while Present (H) loop
+ if H = E then
+ return True;
+ else
+ H := Homonym (H);
+ end if;
+ end loop;
+
+ return False;
+ end In_Chain;
+
+ -- Start of processing for Install_Limited_Withed_Unit
+
+ begin
+ -- In case of limited with_clause on subprograms, generics, instances,
+ -- or renamings, the corresponding error was previously posted and we
+ -- have nothing to do here.
+
+ if Nkind (P_Unit) /= N_Package_Declaration then
+ return;
+ end if;
+
+ P := Defining_Unit_Name (Specification (P_Unit));
+
+ if Nkind (P) = N_Defining_Program_Unit_Name then
+
+ -- Retrieve entity of child package
+
+ Is_Child_Package := True;
+ P := Defining_Identifier (P);
+ end if;
+
+ -- A common usage of the limited-with is to have a limited-with
+ -- in the package spec, and a normal with in its package body.
+ -- For example:
+
+ -- limited with X; -- [1]
+ -- package A is ...
+
+ -- with X; -- [2]
+ -- package body A is ...
+
+ -- The compilation of A's body installs the entities of its
+ -- withed packages (the context clauses found at [2]) and
+ -- then the context clauses of its specification (found at [1]).
+
+ -- As a consequence, at point [1] the specification of X has been
+ -- analyzed and it is immediately visible. According to the semantics
+ -- of the limited-with context clauses we don't install the limited
+ -- view because the full view of X supersedes its limited view.
+
+ if Analyzed (Cunit (Unum))
+ 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;
+
+ if Debug_Flag_I then
+ Write_Str ("install limited view of ");
+ Write_Name (Chars (P));
+ Write_Eol;
+ end if;
+
+ if not Analyzed (Cunit (Unum)) then
+ Set_Ekind (P, E_Package);
+ Set_Etype (P, Standard_Void_Type);
+ Set_Scope (P, Standard_Standard);
+
+ -- Place entity on visibility structure
+
+ if Current_Entity (P) /= P then
+ Set_Homonym (P, Current_Entity (P));
+ Set_Current_Entity (P);
+
+ if Debug_Flag_I then
+ Write_Str (" (homonym) chain ");
+ Write_Name (Chars (P));
+ Write_Eol;
+ end if;
+
+ end if;
+
+ if Is_Child_Package then
+ Set_Is_Child_Unit (P);
+ Set_Is_Visible_Child_Unit (P);
+
+ declare
+ Parent_Comp : Node_Id;
+ Parent_Id : Entity_Id;
+
+ begin
+ Parent_Comp := Parent_Spec (Unit (Cunit (Unum)));
+ Parent_Id := Defining_Entity (Unit (Parent_Comp));
+
+ Set_Scope (P, Parent_Id);
+ end;
+ end if;
+
+ else
+
+ -- If the unit appears in a previous regular with_clause, the
+ -- regular entities must be unchained before the shadow ones
+ -- are made accessible.
+
+ declare
+ Ent : Entity_Id;
+ begin
+ Ent := First_Entity (P);
+
+ while Present (Ent) loop
+ Unchain (Ent);
+ Next_Entity (Ent);
+ end loop;
+ end;
+
+ end if;
+
+ -- The package must be visible while the with_type clause is active,
+ -- because references to the type P.T must resolve in the usual way.
+
+ Set_Is_Immediately_Visible (P);
+
+ -- 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_Header := Limited_View (P);
+ Lim_Typ := First_Entity (Lim_Header);
+
+ 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));
+ Set_Current_Entity (Lim_Typ);
+
+ if Debug_Flag_I then
+ Write_Str (" (homonym) chain ");
+ Write_Name (Chars (Lim_Typ));
+ Write_Eol;
+ end if;
+ end if;
+
+ Next_Entity (Lim_Typ);
+ end loop;
+
+ -- The context clause has installed a limited-view, mark it
+ -- accordingly, to uninstall it when the context is removed.
+
+ Set_Limited_View_Installed (N);
+ Set_From_With_Type (P);
+ end Install_Limited_Withed_Unit;
+
-------------------------
-- Install_Withed_Unit --
-------------------------
- procedure Install_Withed_Unit (With_Clause : Node_Id) is
- Uname : Entity_Id := Entity (Name (With_Clause));
+ 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
- -- If the unit is a package instantiation, its body may have been
- -- generated for an inner instance, and the instance now denotes the
- -- body entity. For visibility purposes we need the instance in the
- -- specification.
-
- if Ekind (Uname) = E_Package_Body
- and then Is_Generic_Instance (Uname)
+ -- 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 (Unit (Parent (With_Clause))) = N_Package_Declaration
+ and then not (Private_With_OK)
then
- Uname := Spec_Entity (Uname);
+ return;
+ end if;
+
+ if Debug_Flag_I then
+ 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;
-- We do not apply the restrictions to an internal unit unless
elsif not Is_Visible_Child_Unit (Uname) then
Set_Is_Visible_Child_Unit (Uname);
+ -- If the child unit appears in the context of its parent, it
+ -- is immediately visible.
+
+ if In_Open_Scopes (Scope (Uname)) then
+ Set_Is_Immediately_Visible (Uname);
+ end if;
+
if Is_Generic_Instance (Uname)
and then Ekind (Uname) in Subprogram_Kind
then
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;
- -- A with-clause overrides a with-type clause: there are no restric-
- -- tions on the use of package entities.
+ -- A with-clause overrides a with-type clause: there are no restric-
+ -- tions on the use of package entities.
+
+ if Ekind (Uname) = E_Package then
+ Set_From_With_Type (Uname, False);
+ end if;
+
+ -- Ada 2005 (AI-377): it is illegal for a with_clause to name a child
+ -- unit if there is a visible homograph for it declared in the same
+ -- declarative region. This pathological case can only arise when an
+ -- instance I1 of a generic unit G1 has an explicit child unit I1.G2,
+ -- G1 has a generic child also named G2, and the context includes with_
+ -- clauses for both I1.G2 and for G1.G2, making an implicit declaration
+ -- of I1.G2 visible as well.
+
+ if Is_Child_Unit (Uname)
+ and then Is_Visible_Child_Unit (Uname)
+ and then Ada_Version >= Ada_05
+ then
+ declare
+ Decl1 : constant Node_Id := Unit_Declaration_Node (P);
+ Decl2 : Node_Id;
+ P2 : Entity_Id;
+ U2 : Entity_Id;
+
+ begin
+ U2 := Homonym (Uname);
+ while Present (U2) loop
+ P2 := Scope (U2);
+ Decl2 := Unit_Declaration_Node (P2);
- if Ekind (Uname) = E_Package then
- Set_From_With_Type (Uname, False);
+ if Is_Child_Unit (U2)
+ and then Is_Visible_Child_Unit (U2)
+ then
+ if Is_Generic_Instance (P)
+ and then Nkind (Decl1) = N_Package_Declaration
+ and then Generic_Parent (Specification (Decl1)) = P2
+ then
+ Error_Msg_N ("illegal with_clause", With_Clause);
+ Error_Msg_N
+ ("\child unit has visible homograph" &
+ " ('R'M 8.3(26), 10.1.1(19))",
+ With_Clause);
+ exit;
+
+ elsif Is_Generic_Instance (P2)
+ and then Nkind (Decl2) = N_Package_Declaration
+ and then Generic_Parent (Specification (Decl2)) = P
+ then
+ -- With_clause for child unit of instance appears before
+ -- in the context. We want to place the error message on
+ -- it, not on the generic child unit itself.
+
+ declare
+ Prev_Clause : Node_Id;
+
+ begin
+ Prev_Clause := First (List_Containing (With_Clause));
+ while Entity (Name (Prev_Clause)) /= U2 loop
+ Next (Prev_Clause);
+ end loop;
+
+ pragma Assert (Present (Prev_Clause));
+ Error_Msg_N ("illegal with_clause", Prev_Clause);
+ Error_Msg_N
+ ("\child unit has visible homograph" &
+ " ('R'M 8.3(26), 10.1.1(19))",
+ Prev_Clause);
+ exit;
+ end;
+ end if;
+ end if;
+
+ U2 := Homonym (U2);
+ end loop;
+ end;
end if;
end Install_Withed_Unit;
else
Compiler_State := Analyzing; -- reset after load
- if not Fatal_Error (Unum) then
+ if not Fatal_Error (Unum) or else Try_Semantics then
if Debug_Flag_L then
Write_Str ("*** Loaded generic body");
Write_Eol;
Style_Check := Save_Style_Check;
end Load_Needed_Body;
+ -------------------------
+ -- Build_Limited_Views --
+ -------------------------
+
+ 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);
+
+ 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;
+ Scop : Entity_Id);
+ -- Add attributes of an incomplete type to a shadow entity. The same
+ -- attributes are placed on the real entity, so that gigi receives
+ -- a consistent view.
+
+ procedure Decorate_Package_Specification (P : Entity_Id);
+ -- Add attributes of a package entity to the entity in a package
+ -- declaration
+
+ procedure Decorate_Tagged_Type
+ (Loc : Source_Ptr;
+ T : Entity_Id;
+ Scop : 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
+ (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.
+
+ function New_Internal_Shadow_Entity
+ (Kind : Entity_Kind;
+ Sloc_Value : Source_Ptr;
+ Id_Char : Character) return Entity_Id;
+ -- Build a new internal entity and append it to the list of shadow
+ -- entities available through the limited-header
+
+ ------------------------------
+ -- Decorate_Incomplete_Type --
+ ------------------------------
+
+ procedure Decorate_Incomplete_Type
+ (E : Entity_Id;
+ 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);
+ end Decorate_Incomplete_Type;
+
+ --------------------------
+ -- Decorate_Tagged_Type --
+ --------------------------
+
+ procedure Decorate_Tagged_Type
+ (Loc : Source_Ptr;
+ T : Entity_Id;
+ Scop : Entity_Id)
+ is
+ CW : Entity_Id;
+
+ begin
+ Decorate_Incomplete_Type (T, Scop);
+ Set_Is_Tagged_Type (T);
+
+ -- Build corresponding class_wide type, if not previously done
+
+ if No (Class_Wide_Type (T)) then
+ CW := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
+
+ Set_Ekind (CW, E_Class_Wide_Type);
+ Set_Etype (CW, T);
+ Set_Scope (CW, Scop);
+ Set_Is_Tagged_Type (CW);
+ Set_Is_First_Subtype (CW, True);
+ Init_Size_Align (CW);
+ Set_Has_Unknown_Discriminants (CW, True);
+ Set_Class_Wide_Type (CW, CW);
+ Set_Equivalent_Type (CW, Empty);
+ Set_From_With_Type (CW, From_With_Type (T));
+
+ Set_Class_Wide_Type (T, CW);
+ end if;
+ end Decorate_Tagged_Type;
+
+ ------------------------------------
+ -- Decorate_Package_Specification --
+ ------------------------------------
+
+ procedure Decorate_Package_Specification (P : Entity_Id) is
+ begin
+ -- Place only the most basic attributes
+
+ Set_Ekind (P, E_Package);
+ Set_Etype (P, Standard_Void_Type);
+ end Decorate_Package_Specification;
+
+ -------------------------
+ -- New_Internal_Entity --
+ -------------------------
+
+ function New_Internal_Shadow_Entity
+ (Kind : Entity_Kind;
+ Sloc_Value : Source_Ptr;
+ Id_Char : Character) return Entity_Id
+ is
+ E : constant Entity_Id :=
+ Make_Defining_Identifier (Sloc_Value,
+ Chars => New_Internal_Name (Id_Char));
+
+ begin
+ Set_Ekind (E, Kind);
+ Set_Is_Internal (E, True);
+
+ if Kind in Type_Kind then
+ Init_Size_Align (E);
+ end if;
+
+ Append_Entity (E, Lim_Header);
+ Last_Lim_E := E;
+ return E;
+ end New_Internal_Shadow_Entity;
+
+ -----------------
+ -- Build_Chain --
+ -----------------
+
+ 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_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
+ and then Tagged_Present (Type_Definition (Decl));
+
+ Comp_Typ := Defining_Identifier (Decl);
+
+ if not Analyzed_Unit then
+ if Is_Tagged then
+ Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope);
+ else
+ Decorate_Incomplete_Type (Comp_Typ, Scope);
+ end if;
+ end if;
+
+ -- Create shadow entity for type
+
+ Lim_Typ := New_Internal_Shadow_Entity
+ (Kind => Ekind (Comp_Typ),
+ Sloc_Value => Sloc (Comp_Typ),
+ Id_Char => 'Z');
+
+ Set_Chars (Lim_Typ, Chars (Comp_Typ));
+ Set_Parent (Lim_Typ, Parent (Comp_Typ));
+ Set_From_With_Type (Lim_Typ);
+
+ if Is_Tagged then
+ Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope);
+ else
+ Decorate_Incomplete_Type (Lim_Typ, Scope);
+ end if;
+
+ Set_Non_Limited_View (Lim_Typ, Comp_Typ);
+
+ elsif Nkind (Decl) = N_Private_Type_Declaration
+ and then Tagged_Present (Decl)
+ then
+ Comp_Typ := Defining_Identifier (Decl);
+
+ if not Analyzed_Unit then
+ Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope);
+ end if;
+
+ Lim_Typ := New_Internal_Shadow_Entity
+ (Kind => Ekind (Comp_Typ),
+ Sloc_Value => Sloc (Comp_Typ),
+ Id_Char => 'Z');
+
+ Set_Chars (Lim_Typ, Chars (Comp_Typ));
+ Set_Parent (Lim_Typ, Parent (Comp_Typ));
+ Set_From_With_Type (Lim_Typ);
+
+ Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope);
+
+ Set_Non_Limited_View (Lim_Typ, Comp_Typ);
+
+ elsif Nkind (Decl) = N_Package_Declaration then
+
+ -- Local package
+
+ declare
+ Spec : constant Node_Id := Specification (Decl);
+
+ begin
+ Comp_Typ := Defining_Unit_Name (Spec);
+
+ if not Analyzed (Cunit (Unum)) then
+ Decorate_Package_Specification (Comp_Typ);
+ Set_Scope (Comp_Typ, Scope);
+ end if;
+
+ Lim_Typ := New_Internal_Shadow_Entity
+ (Kind => Ekind (Comp_Typ),
+ Sloc_Value => Sloc (Comp_Typ),
+ Id_Char => 'Z');
+
+ Decorate_Package_Specification (Lim_Typ);
+ Set_Scope (Lim_Typ, Scope);
+
+ Set_Chars (Lim_Typ, Chars (Comp_Typ));
+ Set_Parent (Lim_Typ, Parent (Comp_Typ));
+ Set_From_With_Type (Lim_Typ);
+
+ -- Note: The non_limited_view attribute is not used
+ -- for local packages.
+
+ Build_Chain
+ (Scope => Lim_Typ,
+ First_Decl => First (Visible_Declarations (Spec)));
+ end;
+ end if;
+
+ Next (Decl);
+ end loop;
+ end Build_Chain;
+
+ -- Start of processing for Build_Limited_Views
+
+ begin
+ pragma Assert (Limited_Present (N));
+
+ -- A library_item mentioned in a limited_with_clause shall be
+ -- a package_declaration, not a subprogram_declaration,
+ -- generic_declaration, generic_instantiation, or
+ -- package_renaming_declaration
+
+ case Nkind (Unit (Library_Unit (N))) is
+
+ when N_Package_Declaration =>
+ null;
+
+ when N_Subprogram_Declaration =>
+ Error_Msg_N ("subprograms not allowed in "
+ & "limited with_clauses", N);
+ return;
+
+ when N_Generic_Package_Declaration |
+ N_Generic_Subprogram_Declaration =>
+ Error_Msg_N ("generics not allowed in "
+ & "limited with_clauses", N);
+ return;
+
+ when N_Package_Instantiation |
+ N_Function_Instantiation |
+ N_Procedure_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 =>
+ Error_Msg_N ("generic renamings not allowed in "
+ & "limited with_clauses", N);
+ return;
+
+ when N_Subprogram_Renaming_Declaration =>
+ Error_Msg_N ("renamed subprograms not allowed in "
+ & "limited with_clauses", N);
+ return;
+
+ when N_Package_Renaming_Declaration =>
+ Error_Msg_N ("renamed packages not allowed in "
+ & "limited with_clauses", N);
+ return;
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ -- Check if the chain is already built
+
+ Spec := Specification (Unit (Library_Unit (N)));
+
+ if Limited_View_Installed (Spec) then
+ return;
+ end if;
+
+ Set_Ekind (P, E_Package);
+
+ -- 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;
+
+ Set_Limited_View_Installed (Spec);
+ end Build_Limited_Views;
+
+ -------------------------------
+ -- Check_Body_Needed_For_SAL --
+ -------------------------------
+
+ procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id) is
+
+ function Entity_Needs_Body (E : Entity_Id) return Boolean;
+ -- Determine whether use of entity E might require the presence
+ -- of its body. For a package this requires a recursive traversal
+ -- of all nested declarations.
+
+ ---------------------------
+ -- Entity_Needed_For_SAL --
+ ---------------------------
+
+ function Entity_Needs_Body (E : Entity_Id) return Boolean is
+ Ent : Entity_Id;
+
+ begin
+ if Is_Subprogram (E)
+ and then Has_Pragma_Inline (E)
+ then
+ return True;
+
+ elsif Ekind (E) = E_Generic_Function
+ or else Ekind (E) = E_Generic_Procedure
+ then
+ return True;
+
+ elsif Ekind (E) = E_Generic_Package
+ and then
+ Nkind (Unit_Declaration_Node (E)) = N_Generic_Package_Declaration
+ and then Present (Corresponding_Body (Unit_Declaration_Node (E)))
+ then
+ return True;
+
+ elsif Ekind (E) = E_Package
+ and then
+ Nkind (Unit_Declaration_Node (E)) = N_Package_Declaration
+ and then Present (Corresponding_Body (Unit_Declaration_Node (E)))
+ then
+ Ent := First_Entity (E);
+
+ while Present (Ent) loop
+ if Entity_Needs_Body (Ent) then
+ return True;
+ end if;
+
+ Next_Entity (Ent);
+ end loop;
+
+ return False;
+
+ else
+ return False;
+ end if;
+ end Entity_Needs_Body;
+
+ -- Start of processing for Check_Body_Needed_For_SAL
+
+ begin
+ if Ekind (Unit_Name) = E_Generic_Package
+ and then
+ Nkind (Unit_Declaration_Node (Unit_Name)) =
+ N_Generic_Package_Declaration
+ and then
+ Present (Corresponding_Body (Unit_Declaration_Node (Unit_Name)))
+ then
+ Set_Body_Needed_For_SAL (Unit_Name);
+
+ elsif Ekind (Unit_Name) = E_Generic_Procedure
+ or else Ekind (Unit_Name) = E_Generic_Function
+ then
+ Set_Body_Needed_For_SAL (Unit_Name);
+
+ elsif Is_Subprogram (Unit_Name)
+ and then Nkind (Unit_Declaration_Node (Unit_Name)) =
+ N_Subprogram_Declaration
+ and then Has_Pragma_Inline (Unit_Name)
+ then
+ Set_Body_Needed_For_SAL (Unit_Name);
+
+ elsif Ekind (Unit_Name) = E_Subprogram_Body then
+ Check_Body_Needed_For_SAL
+ (Corresponding_Spec (Unit_Declaration_Node (Unit_Name)));
+
+ elsif Ekind (Unit_Name) = E_Package
+ and then Entity_Needs_Body (Unit_Name)
+ then
+ Set_Body_Needed_For_SAL (Unit_Name);
+
+ elsif Ekind (Unit_Name) = E_Package_Body
+ and then Nkind (Unit_Declaration_Node (Unit_Name)) = N_Package_Body
+ then
+ Check_Body_Needed_For_SAL
+ (Corresponding_Spec (Unit_Declaration_Node (Unit_Name)));
+ end if;
+ end Check_Body_Needed_For_SAL;
+
--------------------
-- Remove_Context --
--------------------
Lib_Unit : constant Node_Id := Unit (N);
begin
- -- If this is a child unit, first remove the parent units.
+ -- If this is a child unit, first remove the parent units
if Is_Child_Spec (Lib_Unit) then
Remove_Parents (Lib_Unit);
Unit_Name : Entity_Id;
begin
+ -- Ada 2005 (AI-50217): We remove the context clauses in two phases:
+ -- limited-views first and regular-views later (to maintain the
+ -- stack model).
- -- Loop through context items and undo with_clauses and use_clauses.
+ -- First Phase: Remove limited_with context clauses
Item := First (Context_Items (N));
+ while Present (Item) loop
+
+ -- We are interested only in with clauses which got installed
+ -- on entry.
+
+ if Nkind (Item) = N_With_Clause
+ and then Limited_Present (Item)
+ and then Limited_View_Installed (Item)
+ then
+ Remove_Limited_With_Clause (Item);
+ end if;
+
+ Next (Item);
+ end loop;
+ -- Second Phase: Loop through context items and undo regular
+ -- with_clauses and use_clauses.
+
+ Item := First (Context_Items (N));
while Present (Item) loop
-- We are interested only in with clauses which got installed
-- on entry, as indicated by their Context_Installed flag set
if Nkind (Item) = N_With_Clause
+ and then Limited_Present (Item)
+ and then Limited_View_Installed (Item)
+ then
+ null;
+
+ elsif Nkind (Item) = N_With_Clause
and then Context_Installed (Item)
then
-- Remove items from one with'ed unit
Next (Item);
end loop;
-
end Remove_Context_Clauses;
+ --------------------------------
+ -- Remove_Limited_With_Clause --
+ --------------------------------
+
+ procedure Remove_Limited_With_Clause (N : Node_Id) is
+ 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
+
+ -- Retrieve entity of Child package
+
+ P := Defining_Identifier (P);
+ end if;
+
+ if Debug_Flag_I then
+ Write_Str ("remove limited view of ");
+ Write_Name (Chars (P));
+ Write_Str (" from visibility");
+ Write_Eol;
+ end if;
+
+ -- 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
+
+ Lim_Typ := First_Entity (Limited_View (P));
+
+ while Present (Lim_Typ) loop
+ Unchain (Lim_Typ);
+ Next_Entity (Lim_Typ);
+ end loop;
+
+ -- Indicate that the limited view of the package is not installed
+
+ Set_From_With_Type (P, False);
+ Set_Limited_View_Installed (N, False);
+
+ -- If the exporting package has previously been analyzed, it
+ -- has appeared in the closure already and should be left alone.
+ -- Otherwise, remove package itself from visibility.
+
+ if not Analyzed (P_Unit) then
+ Unchain (P);
+ Set_First_Entity (P, Empty);
+ Set_Last_Entity (P, Empty);
+ Set_Ekind (P, E_Void);
+ Set_Scope (P, Empty);
+ Set_Is_Immediately_Visible (P, False);
+
+ else
+
+ -- Reinstall visible entities (entities removed from visibility in
+ -- Install_Limited_Withed to install the shadow entities).
+
+ declare
+ Ent : Entity_Id;
+
+ begin
+ Ent := First_Entity (P);
+ while Present (Ent) and then Ent /= First_Private_Entity (P) loop
+
+ -- Shadow entities have not been added to the list of
+ -- entities associated to the package spec. Therefore we
+ -- just have to re-chain all its visible entities.
+
+ if not Is_Class_Wide_Type (Ent) then
+
+ Set_Homonym (Ent, Current_Entity (Ent));
+ Set_Current_Entity (Ent);
+
+ if Debug_Flag_I then
+ Write_Str (" (homonym) chain ");
+ Write_Name (Chars (Ent));
+ Write_Eol;
+ end if;
+ end if;
+
+ Next_Entity (Ent);
+ end loop;
+ end;
+ end if;
+ end Remove_Limited_With_Clause;
+
--------------------
-- Remove_Parents --
--------------------
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 := Defining_Entity (P);
+ P_Spec := 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
- Remove_Context_Clauses (Parent_Spec (Lib_Unit));
+ 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);
P : Entity_Id;
procedure Unchain (E : Entity_Id);
- -- Remove entity from visibility list.
+ -- Remove entity from visibility list
+
+ -------------
+ -- Unchain --
+ -------------
procedure Unchain (E : Entity_Id) is
Prev : Entity_Id;
Prev := Homonym (Prev);
end loop;
- if (Present (Prev)) then
+ if Present (Prev) then
Set_Homonym (Prev, Homonym (E));
end if;
end if;
end Unchain;
+ -- Start of processing for Remove_With_Type_Clause
+
begin
if Nkind (Name) = N_Selected_Component then
Typ := Entity (Selector_Name (Name));
- if No (Typ) then -- error in declaration.
+ -- If no Typ, then error in declaration, ignore
+
+ if No (Typ) then
return;
end if;
else
Set_From_With_Type (P, False);
- -- If P is a child unit, remove parents as well.
+ -- If P is a child unit, remove parents as well
P := Scope (P);
---------------------------------
procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id) is
- P : Entity_Id := Scope (Unit_Name);
+ P : constant Entity_Id := Scope (Unit_Name);
begin
if Debug_Flag_I then
- Write_Str ("remove withed unit ");
+ Write_Str ("remove unit ");
Write_Name (Chars (Unit_Name));
+ Write_Str (" from visibility");
Write_Eol;
end if;
end Remove_Unit_From_Visibility;
+ -------------
+ -- Unchain --
+ -------------
+
+ procedure Unchain (E : Entity_Id) is
+ Prev : Entity_Id;
+
+ begin
+ Prev := Current_Entity (E);
+
+ if No (Prev) then
+ return;
+
+ elsif Prev = E then
+ Set_Name_Entity_Id (Chars (E), Homonym (E));
+
+ else
+ while Present (Prev)
+ and then Homonym (Prev) /= E
+ loop
+ Prev := Homonym (Prev);
+ end loop;
+
+ if Present (Prev) then
+ Set_Homonym (Prev, Homonym (E));
+ end if;
+ end if;
+
+ if Debug_Flag_I then
+ Write_Str (" (homonym) unchain ");
+ Write_Name (Chars (E));
+ Write_Eol;
+ end if;
+
+ end Unchain;
end Sem_Ch10;
OSDN Git Service
