-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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 Nmake; use Nmake;
with Opt; use Opt;
with Output; use Output;
+with Par_SCO; use Par_SCO;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
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.
+ -- 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.
+ -- Check whether the source for the body of a compilation unit must be
+ -- included in a standalone library.
procedure Check_Private_Child_Unit (N : Node_Id);
-- If a with_clause mentions a private child unit, the compilation
-- and use_clauses for current unit and its library unit if any.
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).
+ -- 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
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.
+ -- 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
-- True, then Parent_Spec (Lib_Unit) is non-Empty and points to the
-- compilation unit for the parent spec.
--
- -- Lib_Unit can also be a subprogram body that acts as its own spec. If
- -- the Parent_Spec is non-empty, this is also a child unit.
+ -- Lib_Unit can also be a subprogram body that acts as its own spec. If the
+ -- Parent_Spec is non-empty, this is also a child unit.
procedure Remove_Context_Clauses (N : Node_Id);
-- Subsidiary of previous one. Remove use_ and with_clauses
-- 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.
+ -- 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
Use_Item : Node_Id;
function Same_Unit (N : Node_Id; P : Entity_Id) return Boolean;
- -- In an expanded name in a use clause, if the prefix is a
- -- renamed package, the entity is set to the original package
- -- as a result, when checking whether the package appears in a
- -- previous with_clause, the renaming has to be taken into
- -- account, to prevent spurious or incorrect warnings. The
- -- common case is the use of Text_IO.
+ -- In an expanded name in a use clause, if the prefix is a renamed
+ -- package, the entity is set to the original package as a result,
+ -- when checking whether the package appears in a previous with
+ -- clause, the renaming has to be taken into account, to prevent
+ -- spurious/incorrect warnings. A common case is use of Text_IO.
---------------
-- Same_Unit --
Cont_Item := First (Context_List);
while Present (Cont_Item) loop
- -- Stop the search since the context items after Cont_Item
- -- have already been examined in a previous iteration of
- -- the reverse loop in Check_Redundant_Withs.
+ -- Stop the search since the context items after Cont_Item have
+ -- already been examined in a previous iteration of the reverse
+ -- loop in Check_Redundant_Withs.
if Exit_On_Self
and Cont_Item = Clause
end loop;
-- Package with clause. Avoid processing self, implicitly
- -- generated with clauses or limited with clauses. Note
- -- that we examine with clauses having pragmas Elaborate
- -- or Elaborate_All applied to them due to cases such as:
+ -- generated with clauses or limited with clauses. Note that
+ -- we examine with clauses having pragmas Elaborate or
+ -- Elaborate_All applied to them due to cases such as:
--
+
-- with Pack;
-- with Pack;
-- pragma Elaborate (Pack);
Clause := Last (Context_Items);
while Present (Clause) loop
- -- Avoid checking implicitly generated with clauses, limited
- -- with clauses or withs that have pragma Elaborate or
- -- Elaborate_All applied.
+ -- Avoid checking implicitly generated with clauses, limited with
+ -- clauses or withs that have pragma Elaborate or Elaborate_All.
if Nkind (Clause) = N_With_Clause
and then not Implicit_With (Clause)
or else
Used_In_Spec)
then
- Error_Msg_N ("?redundant with clause in body", Clause);
+ Error_Msg_N -- CODEFIX
+ ("?redundant with clause in body", Clause);
end if;
Used_In_Body := False;
Exit_On_Self => True);
if Withed then
- Error_Msg_N ("?redundant with clause", Clause);
+ Error_Msg_N -- CODEFIX
+ ("?redundant with clause", Clause);
end if;
end;
end if;
-- analysis of the parent, which we proceed to do. Basically this gets
-- handled from the top down and we don't want to do anything at this
-- level (i.e. this subunit will be handled on the way down from the
- -- parent), so at this level we immediately return. If the subunit
- -- ends up not analyzed, it means that the parent did not contain a
- -- stub for it, or that there errors were detected in some ancestor.
+ -- parent), so at this level we immediately return. If the subunit ends
+ -- up not analyzed, it means that the parent did not contain a stub for
+ -- it, or that there errors were detected in some ancestor.
if Nkind (Unit_Node) = N_Subunit
and then not Analyzed (Lib_Unit)
return;
end if;
- -- Analyze context (this will call Sem recursively for with'ed units)
+ -- Analyze context (this will call Sem recursively for with'ed units) To
+ -- detect circularities among with-clauses that are not caught during
+ -- loading, we set the Context_Pending flag on the current unit. If the
+ -- flag is already set there is a potential circularity. We exclude
+ -- predefined units from this check because they are known to be safe.
+ -- We also exclude package bodies that are present because circularities
+ -- between bodies are harmless (and necessary).
+
+ if Context_Pending (N) then
+ declare
+ Circularity : Boolean := True;
+
+ begin
+ if Is_Predefined_File_Name
+ (Unit_File_Name (Get_Source_Unit (Unit (N))))
+ then
+ Circularity := False;
+
+ else
+ for U in Main_Unit + 1 .. Last_Unit loop
+ if Nkind (Unit (Cunit (U))) = N_Package_Body
+ and then not Analyzed (Cunit (U))
+ then
+ Circularity := False;
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ if Circularity then
+ Error_Msg_N ("circular dependency caused by with_clauses", N);
+ Error_Msg_N
+ ("\possibly missing limited_with clause"
+ & " in one of the following", N);
+
+ for U in Main_Unit .. Last_Unit loop
+ if Context_Pending (Cunit (U)) then
+ Error_Msg_Unit_1 := Get_Unit_Name (Unit (Cunit (U)));
+ Error_Msg_N ("\unit$", N);
+ end if;
+ end loop;
+
+ raise Unrecoverable_Error;
+ end if;
+ end;
+ else
+ Set_Context_Pending (N);
+ end if;
Analyze_Context (N);
- -- If the unit is a package body, the spec is already loaded and must
- -- be analyzed first, before we analyze the body.
+ Set_Context_Pending (N, False);
+
+ -- If the unit is a package body, the spec is already loaded and must be
+ -- analyzed first, before we analyze the body.
if Nkind (Unit_Node) = N_Package_Body then
- -- If no Lib_Unit, then there was a serious previous error, so
- -- just ignore the entire analysis effort
+ -- If no Lib_Unit, then there was a serious previous error, so just
+ -- ignore the entire analysis effort
if No (Lib_Unit) then
return;
("no legal package declaration for package body", N);
return;
- -- Otherwise, the entity in the declaration is visible. Update
- -- the version to reflect dependence of this body on the spec.
+ -- Otherwise, the entity in the declaration is visible. Update the
+ -- version to reflect dependence of this body on the spec.
else
Spec_Id := Defining_Entity (Unit (Lib_Unit));
-- in its scope. Finally we create a Units table entry for
-- the subprogram declaration, to maintain a one-to-one
-- correspondence with compilation unit nodes. This is
- -- critical for the tree traversals performed by Codepeer.
+ -- critical for the tree traversals performed by CodePeer.
declare
Loc : constant Source_Ptr := Sloc (N);
end if;
end if;
- -- Remove unit from visibility, so that environment is clean for
- -- the next compilation, which is either the main unit or some
- -- other unit in the context.
+ -- Remove unit from visibility, so that environment is clean for the
+ -- next compilation, which is either the main unit or some other unit
+ -- in the context.
if Nkind_In (Unit_Node, N_Package_Declaration,
N_Package_Renaming_Declaration,
Remove_Unit_From_Visibility (Defining_Entity (Unit_Node));
-- If the unit is an instantiation whose body will be elaborated for
- -- inlining purposes, use the proper entity of the instance. The
- -- entity may be missing if the instantiation was illegal.
+ -- inlining purposes, use the proper entity of the instance. The entity
+ -- may be missing if the instantiation was illegal.
elsif Nkind (Unit_Node) = N_Package_Instantiation
and then not Error_Posted (Unit_Node)
-- Case of units which do not require elaboration checks
if
- -- Pure units do not need checks
+ -- Pure units do not need checks
- Is_Pure (Spec_Id)
+ Is_Pure (Spec_Id)
- -- Preelaborated units do not need checks
+ -- Preelaborated units do not need checks
- or else Is_Preelaborated (Spec_Id)
+ or else Is_Preelaborated (Spec_Id)
- -- No checks needed if pragma Elaborate_Body present
+ -- No checks needed if pragma Elaborate_Body present
- or else Has_Pragma_Elaborate_Body (Spec_Id)
+ or else Has_Pragma_Elaborate_Body (Spec_Id)
- -- No checks needed if unit does not require a body
+ -- No checks needed if unit does not require a body
- or else not Unit_Requires_Body (Spec_Id)
+ or else not Unit_Requires_Body (Spec_Id)
- -- No checks needed for predefined files
+ -- No checks needed for predefined files
- or else Is_Predefined_File_Name (Unit_File_Name (Unum))
+ or else Is_Predefined_File_Name (Unit_File_Name (Unum))
- -- No checks required if no separate spec
+ -- No checks required if no separate spec
- or else Acts_As_Spec (N)
+ or else Acts_As_Spec (N)
then
-- This is a case where we only need the entity for
-- checking to prevent multiple elaboration checks.
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.
+ -- 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
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-existent unit)
- -- Skip as well if this is a with_clause for the main unit, which
+ -- happens for a with that references a non-existent unit). Skip
+ -- as well if this is a with_clause for the main unit, which
-- happens if a subunit has a useless with_clause on its parent.
if Present (Library_Unit (Item)) then
if not Implicit_With (Item) then
- -- Verify that the illegal contexts given in 10.1.2 (18/2)
- -- are properly rejected, including renaming declarations.
+ -- Verify that the illegal contexts given in 10.1.2 (18/2) are
+ -- properly rejected, including renaming declarations.
if not Nkind_In (Ukind, N_Package_Declaration,
N_Subprogram_Declaration)
and then not Limited_Present (It)
and then
Nkind_In (Unit (Library_Unit (It)),
- N_Package_Declaration,
- N_Package_Renaming_Declaration)
+ N_Package_Declaration,
+ N_Package_Renaming_Declaration)
then
if Nkind (Unit (Library_Unit (It))) =
N_Package_Declaration
-------------------------
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_Name : constant Unit_Name_Type := Get_Unit_Name (N);
+ Unum : Unit_Number_Type;
procedure Optional_Subunit;
-- This procedure is called when the main unit is a stub, or when we
Comp_Unit : Node_Id;
begin
- -- Try to load subunit, but ignore any errors that occur during
- -- the loading of the subunit, by using the special feature in
- -- Errout to ignore all errors. Note that Fatal_Error will still
- -- be set, so we will be able to check for this case below.
+ -- Try to load subunit, but ignore any errors that occur during the
+ -- loading of the subunit, by using the special feature in Errout to
+ -- ignore all errors. Note that Fatal_Error will still be set, so we
+ -- will be able to check for this case below.
if not ASIS_Mode then
Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
then
Comp_Unit := Cunit (Unum);
- -- If the file was empty or seriously mangled, the unit
- -- itself may be missing.
+ -- If the file was empty or seriously mangled, the unit itself may
+ -- be missing.
if No (Unit (Comp_Unit)) then
Error_Msg_N
-- Start of processing for Analyze_Proper_Body
begin
- -- If the subunit is already loaded, it means that the main unit
- -- is a subunit, and that the current unit is one of its parents
- -- which was being analyzed to provide the needed context for the
- -- analysis of the subunit. In this case we analyze the subunit and
- -- continue with the parent, without looking a subsequent subunits.
+ -- If the subunit is already loaded, it means that the main unit is a
+ -- subunit, and that the current unit is one of its parents which was
+ -- being analyzed to provide the needed context for the analysis of the
+ -- subunit. In this case we analyze the subunit and continue with the
+ -- parent, without looking a subsequent subunits.
if Is_Loaded (Subunit_Name) then
- -- If the proper body is already linked to the stub node,
- -- the stub is in a generic unit and just needs analyzing.
+ -- If the proper body is already linked to the stub node, the stub is
+ -- in a generic unit and just needs analyzing.
if Present (Library_Unit (N)) then
Set_Corresponding_Stub (Unit (Library_Unit (N)), N);
-- Otherwise we must load the subunit and link to it
else
- -- Load the subunit, this must work, since we originally
- -- loaded the subunit earlier on. So this will not really
- -- load it, just give access to it.
+ -- Load the subunit, this must work, since we originally loaded
+ -- the subunit earlier on. So this will not really load it, just
+ -- give access to it.
Unum :=
Load_Unit
return;
-- If the subunit is not already loaded, and we are generating code,
- -- then this is the case where compilation started from the parent,
- -- and we are generating code for an entire subunit tree. In that
- -- case we definitely need to load the subunit.
+ -- then this is the case where compilation started from the parent, and
+ -- we are generating code for an entire subunit tree. In that case we
+ -- definitely need to load the subunit.
-- In order to continue the analysis with the rest of the parent,
-- and other subunits, we load the unit without requiring its
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.
+ -- If the proper body is already linked to the stub node, the stub is
+ -- in a generic unit and just needs analyzing.
- -- We update the version. Although we are not technically
- -- semantically dependent on the subunit, given our approach
- -- of macro substitution of subunits, it makes sense to
- -- include it in the version identification.
+ -- We update the version. Although we are not strictly technically
+ -- semantically dependent on the subunit, given our approach of macro
+ -- substitution of subunits, it makes sense to include it in the
+ -- version identification.
if Present (Library_Unit (N)) then
Set_Corresponding_Stub (Unit (Library_Unit (N)), N);
-- Otherwise we must load the subunit and link to it
else
+ -- Make sure that, if the subunit is preprocessed and -gnateG is
+ -- specified, the preprocessed file will be written.
+
+ Lib.Analysing_Subunit_Of_Main := True;
Unum :=
Load_Unit
(Load_Name => Subunit_Name,
Required => False,
Subunit => True,
Error_Node => N);
+ Lib.Analysing_Subunit_Of_Main := False;
+
+ -- Give message if we did not get the unit Emit warning even if
+ -- missing subunit is not within main unit, to simplify debugging.
if Original_Operating_Mode = Generate_Code
and then Unum = No_Unit
Error_Msg_File_1 :=
Get_File_Name (Subunit_Name, Subunit => True);
Error_Msg_N
- ("subunit$$ in file{ not found?", N);
+ ("subunit$$ in file{ not found?!!", N);
Subunits_Missing := True;
end if;
-- Load_Unit may reset Compiler_State, since it may have been
- -- necessary to parse an additional units, so we make sure
- -- that we reset it to the Analyzing state.
+ -- necessary to parse an additional units, so we make sure that
+ -- we reset it to the Analyzing state.
Compiler_State := Analyzing;
Set_Corresponding_Stub (Unit (Comp_Unit), N);
+ -- Collect SCO information for loaded subunit if we are
+ -- in the main unit).
+
+ if Generate_SCO
+ and then
+ In_Extended_Main_Source_Unit
+ (Cunit_Entity (Current_Sem_Unit))
+ then
+ SCO_Record (Unum);
+ end if;
+
-- Analyze the unit if semantics active
if not Fatal_Error (Unum) or else Try_Semantics then
end if;
end if;
- -- The remaining case is when the subunit is not already loaded and
- -- we are not generating code. In this case we are just performing
- -- semantic analysis on the parent, and we are not interested in
- -- the subunit. For subprograms, analyze the stub as a body. For
- -- other entities the stub has already been marked as completed.
+ -- The remaining case is when the subunit is not already loaded and we
+ -- are not generating code. In this case we are just performing semantic
+ -- analysis on the parent, and we are not interested in the subunit. For
+ -- subprograms, analyze the stub as a body. For other entities the stub
+ -- has already been marked as completed.
else
Optional_Subunit;
-- Analyze_Subprogram_Body_Stub --
----------------------------------
- -- A subprogram body stub can appear with or without a previous
- -- specification. If there is one, the analysis of the body will
- -- find it and verify conformance. The formals appearing in the
- -- specification of the stub play no role, except for requiring an
- -- additional conformance check. If there is no previous subprogram
- -- declaration, the stub acts as a spec, and provides the defining
- -- entity for the subprogram.
+ -- A subprogram body stub can appear with or without a previous spec. If
+ -- there is one, then the analysis of the body will find it and verify
+ -- conformance. The formals appearing in the specification of the stub play
+ -- no role, except for requiring an additional conformance check. If there
+ -- is no previous subprogram declaration, the stub acts as a spec, and
+ -- provides the defining entity for the subprogram.
procedure Analyze_Subprogram_Body_Stub (N : Node_Id) is
Decl : Node_Id;
-- Analyze_Subunit --
---------------------
- -- A subunit is compiled either by itself (for semantic checking)
- -- or as part of compiling the parent (for code generation). In
- -- either case, by the time we actually process the subunit, the
- -- parent has already been installed and analyzed. The node N is
- -- a compilation unit, whose context needs to be treated here,
- -- because we come directly here from the parent without calling
- -- Analyze_Compilation_Unit.
-
- -- The compilation context includes the explicit context of the
- -- subunit, and the context of the parent, together with the parent
- -- itself. In order to compile the current context, we remove the
- -- one inherited from the parent, in order to have a clean visibility
- -- table. We restore the parent context before analyzing the proper
- -- body itself. On exit, we remove only the explicit context of the
- -- subunit.
+ -- A subunit is compiled either by itself (for semantic checking) or as
+ -- part of compiling the parent (for code generation). In either case, by
+ -- the time we actually process the subunit, the parent has already been
+ -- installed and analyzed. The node N is a compilation unit, whose context
+ -- needs to be treated here, because we come directly here from the parent
+ -- without calling Analyze_Compilation_Unit.
+
+ -- The compilation context includes the explicit context of the subunit,
+ -- and the context of the parent, together with the parent itself. In order
+ -- to compile the current context, we remove the one inherited from the
+ -- parent, in order to have a clean visibility table. We restore the parent
+ -- context before analyzing the proper body itself. On exit, we remove only
+ -- the explicit context of the subunit.
procedure Analyze_Subunit (N : Node_Id) is
Lib_Unit : constant Node_Id := Library_Unit (N);
Svg : constant Suppress_Array := Scope_Suppress;
procedure Analyze_Subunit_Context;
- -- Capture names in use clauses of the subunit. This must be done
- -- before re-installing parent declarations, because items in the
- -- context must not be hidden by declarations local to the parent.
+ -- Capture names in use clauses of the subunit. This must be done before
+ -- re-installing parent declarations, because items in the context must
+ -- not be hidden by declarations local to the parent.
procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id);
-- Recursive procedure to restore scope of all ancestors of subunit,
-- from outermost in. If parent is not a subunit, the call to install
- -- context installs context of spec and (if parent is a child unit)
- -- the context of its parents as well. It is confusing that parents
- -- should be treated differently in both cases, but the semantics are
- -- just not identical.
+ -- context installs context of spec and (if parent is a child unit) the
+ -- context of its parents as well. It is confusing that parents should
+ -- be treated differently in both cases, but the semantics are just not
+ -- identical.
procedure Re_Install_Use_Clauses;
-- As part of the removal of the parent scope, the use clauses are
- -- removed, to be reinstalled when the context of the subunit has
- -- been analyzed. Use clauses may also have been affected by the
- -- analysis of the context of the subunit, so they have to be applied
- -- again, to insure that the compilation environment of the rest of
- -- the parent unit is identical.
+ -- removed, to be reinstalled when the context of the subunit has been
+ -- analyzed. Use clauses may also have been affected by the analysis of
+ -- the context of the subunit, so they have to be applied again, to
+ -- insure that the compilation environment of the rest of the parent
+ -- unit is identical.
procedure Remove_Scope;
- -- Remove current scope from scope stack, and preserve the list
- -- of use clauses in it, to be reinstalled after context is analyzed.
+ -- 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 --
Next (Item);
end loop;
- -- Reset visibility of withed units. They will be made visible
- -- again when we install the subunit context.
+ -- Reset visibility of withed units. They will be made visible again
+ -- when we install the subunit context.
Item := First (Context_Items (N));
while Present (Item) loop
Next_Entity (E);
end loop;
- -- A subunit appears within a body, and for a nested subunits
- -- all the parents are bodies. Restore full visibility of their
- -- private entities.
+ -- A subunit appears within a body, and for a nested subunits all the
+ -- parents are bodies. Restore full visibility of their private
+ -- entities.
if Is_Package_Or_Generic_Package (Scop) then
Set_In_Package_Body (Scop);
-- Start of processing for Analyze_Subunit
begin
+ if Style_Check then
+ declare
+ Nam : Node_Id := Name (Unit (N));
+
+ begin
+ if Nkind (Nam) = N_Selected_Component then
+ Nam := Selector_Name (Nam);
+ end if;
+
+ Check_Identifier (Nam, Par_Unit);
+ end;
+ end if;
+
if not Is_Empty_List (Context_Items (N)) then
-- Save current use clauses
Remove_Scope;
Remove_Context (Lib_Unit);
- -- Now remove parents and their context, including enclosing
- -- subunits and the outer parent body which is not a subunit.
+ -- Now remove parents and their context, including enclosing subunits
+ -- and the outer parent body which is not a subunit.
if Present (Lib_Spec) then
Remove_Context (Lib_Spec);
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,
- -- after compiling that cousin in the context. The visibility
- -- of the parent must be restored now. This also applies if the
- -- context includes another subunit of the same parent which in
- -- turn includes a child unit in its context.
+ -- If the context includes a child unit of the parent of the subunit,
+ -- the parent will have been removed from visibility, after compiling
+ -- that cousin in the context. The visibility of the parent must be
+ -- restored now. This also applies if the context includes another
+ -- subunit of the same parent which in turn includes a child unit in
+ -- its context.
if Is_Package_Or_Generic_Package (Par_Unit) then
if not Is_Immediately_Visible (Par_Unit)
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.
+ -- 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.
if Present (Enclosing_Child) then
Install_Siblings (Enclosing_Child, N);
end if;
-
end if;
Analyze (Proper_Body (Unit (N)));
Remove_Context (N);
- -- The subunit may contain a with_clause on a sibling of some
- -- ancestor. Removing the context will remove from visibility those
- -- ancestor child units, which must be restored to the visibility
- -- they have in the enclosing body.
+ -- The subunit may contain a with_clause on a sibling of some ancestor.
+ -- Removing the context will remove from visibility those ancestor child
+ -- units, which must be restored to the visibility they have in the
+ -- enclosing body.
if Present (Enclosing_Child) then
declare
Nam := Full_View (Nam);
end if;
- if No (Nam)
- or else not Is_Task_Type (Etype (Nam))
- then
+ if No (Nam) or else not Is_Task_Type (Etype (Nam)) then
Error_Msg_N ("missing specification for task body", N);
else
Set_Scope (Defining_Entity (N), Current_Scope);
Set_Has_Completion (Etype (Nam));
Analyze_Proper_Body (N, Etype (Nam));
- -- Set elaboration flag to indicate that entity is callable.
- -- This cannot be done in the expansion of the body itself,
- -- because the proper body is not in a declarative part. This
- -- is only done if expansion is active, because the context
- -- may be generic and the flag not defined yet.
+ -- Set elaboration flag to indicate that entity is callable. This
+ -- cannot be done in the expansion of the body itself, because the
+ -- proper body is not in a declarative part. This is only done if
+ -- expansion is active, because the context may be generic and the
+ -- flag not defined yet.
if Expander_Active then
Insert_After (N,
New_External_Name (Chars (Etype (Nam)), 'E')),
Expression => New_Reference_To (Standard_True, Loc)));
end if;
-
end if;
end Analyze_Task_Body_Stub;
-- Analyze_With_Clause --
-------------------------
- -- Analyze the declaration of a unit in a with clause. At end,
- -- label the with clause with the defining entity for the unit.
+ -- Analyze the declaration of a unit in a with clause. At end, label the
+ -- with clause with the defining entity for the unit.
procedure Analyze_With_Clause (N : Node_Id) is
- -- 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.
+ -- Retrieve the original kind of the unit node, before analysis. If it
+ -- is a subprogram instantiation, its analysis below will rewrite the
+ -- node 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))));
-- 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_Cunit_Boolean_Restrictions :=
- Cunit_Boolean_Restrictions_Save;
+ Save_C_Restrict : Save_Cunit_Boolean_Restrictions;
begin
U := Unit (Library_Unit (N));
+ -- If this is an internal unit which is a renaming, then this is a
+ -- violation of No_Obsolescent_Features.
+
+ -- Note: this is not quite right if the user defines one of these units
+ -- himself, but that's a marginal case, and fixing it is hard ???
+
+ if Restriction_Check_Required (No_Obsolescent_Features) then
+ declare
+ F : constant File_Name_Type :=
+ Unit_File_Name (Get_Source_Unit (U));
+ begin
+ if Is_Predefined_File_Name (F, Renamings_Included => True)
+ and then not
+ Is_Predefined_File_Name (F, Renamings_Included => False)
+ then
+ Check_Restriction (No_Obsolescent_Features, N);
+ end if;
+ end;
+ end if;
+
+ -- Save current restriction set, does not apply to with'ed unit
+
+ Save_C_Restrict := Cunit_Boolean_Restrictions_Save;
+
-- Several actions are skipped for dummy packages (those supplied for
-- with's where no matching file could be found). Such packages are
-- identified by the Sloc value being set to No_Location.
-- explicit with'ing of run-time units.
if Configurable_Run_Time_Mode
- and then
- Is_Predefined_File_Name
- (Unit_File_Name (Get_Source_Unit (Unit (Library_Unit (N)))))
+ and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (U)))
then
Configurable_Run_Time_Mode := False;
Semantics (Library_Unit (N));
end if;
-- 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. We do not issue this message for implicit
- -- with's generated by the compiler itself.
+ -- are not compiling 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 not Intunit
and then not Implicit_With (N)
- and then not GNAT_Mode
then
declare
U_Kind : constant Kind_Of_Unit :=
begin
if U_Kind = Implementation_Unit then
Error_Msg_F ("& is an internal 'G'N'A'T unit?", Name (N));
- Error_Msg_F
- ("\use of this unit is non-portable " &
- "and version-dependent?",
- Name (N));
+
+ -- Add alternative name if available, otherwise issue a
+ -- general warning message.
+
+ if Error_Msg_Strlen /= 0 then
+ Error_Msg_F ("\use ""~"" instead", Name (N));
+ else
+ Error_Msg_F
+ ("\use of this unit is non-portable " &
+ "and version-dependent?", Name (N));
+ end if;
elsif U_Kind = Ada_05_Unit
and then Ada_Version < Ada_05
-- Returns true if and only if the library unit is declared with
-- an explicit designation of private.
+ -----------------------------
+ -- Is_Private_Library_Unit --
+ -----------------------------
+
function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean is
Comp_Unit : constant Node_Id := Parent (Unit_Declaration_Node (Unit));
Sub_Parent := Library_Unit (N);
Curr_Unit := Defining_Entity (Unit (Library_Unit (Sub_Parent)));
- -- If the parent itself is a subunit, Curr_Unit is the entity
- -- of the enclosing body, retrieve the spec entity which is
- -- the proper ancestor we need for the following tests.
+ -- If the parent itself is a subunit, Curr_Unit is the entity of the
+ -- enclosing body, retrieve the spec entity which is the proper
+ -- ancestor we need for the following tests.
if Ekind (Curr_Unit) = E_Package_Body then
Curr_Unit := Spec_Entity (Curr_Unit);
begin
if Nkind (Nam) = N_Identifier then
- -- If the parent unit P in the name of the with_clause for P.Q
- -- is a renaming of package R, then the entity of the parent is
- -- set to R, but the identifier retains Chars (P) to be consistent
- -- with the source (see details in lib-load). However, the
- -- implicit_with_clause for the parent must make the entity for
- -- P visible, because P.Q may be used as a prefix within the
- -- current unit. The entity for P is the current_entity with that
- -- name, because the package renaming declaration for it has just
- -- been analyzed. Note that this case can only happen if P.Q has
- -- already appeared in a previous with_clause in a related unit,
- -- such as the library body of the current unit.
+ -- If the parent unit P in the name of the with_clause for P.Q is
+ -- a renaming of package R, then the entity of the parent is set
+ -- to R, but the identifier retains Chars (P) to be consistent
+ -- with the source (see details in lib-load). However the implicit
+ -- with_clause for the parent must make the entity for P visible,
+ -- because P.Q may be used as a prefix within the current unit.
+ -- The entity for P is the current_entity with that name, because
+ -- the package renaming declaration for it has just been analyzed.
+ -- Note that this case can only happen if P.Q has already appeared
+ -- in a previous with_clause in a related unit, such as the
+ -- library body of the current unit.
if Chars (Nam) /= Chars (Entity (Nam)) then
Renaming := Current_Entity (Nam);
Nkind (Unit_Declaration_Node (Entity (Selector_Name (Nam))))
= N_Package_Renaming_Declaration
then
- -- The name in the with_clause is of the form A.B.C, and B
- -- is given by a renaming declaration. In that case we may
- -- not have analyzed the unit for B, but replaced it directly
- -- in lib-load with the unit it renames. We have to make A.B
+ -- The name in the with_clause is of the form A.B.C, and B is
+ -- given by a renaming declaration. In that case we may not
+ -- have analyzed the unit for B, but replaced it directly in
+ -- lib-load with the unit it renames. We have to make A.B
-- visible, so analyze the declaration for B now, in case it
-- has not been done yet.
Set_Implicit_With (Withn, True);
-- If the unit is a package declaration, a private_with_clause on a
- -- child unit implies that the implicit with on the parent is also
- -- private.
+ -- child unit implies the implicit with on the parent is also private.
if Nkind (Unit (N)) = N_Package_Declaration then
Set_Private_Present (Withn, Private_Present (Item));
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);
+
else
Result :=
Make_Expanded_Name (Loc,
if Sloc (Library_Unit (Item)) /= No_Location then
License_Check : declare
-
Withu : constant Unit_Number_Type :=
Get_Source_Unit (Library_Unit (Item));
-
Withl : constant License_Type :=
License (Source_Index (Withu));
-
Unitl : constant License_Type :=
License (Source_Index (Current_Sem_Unit));
procedure Check_Private_Limited_Withed_Unit (Item : Node_Id);
-- Check that if a limited_with clause of a given compilation_unit
- -- mentions a descendant of a private child of some library unit,
- -- then the given compilation_unit shall be the declaration of a
- -- private descendant of that library unit, or a public descendant
- -- of such. The code is analogous to that of Check_Private_Child_Unit
- -- but we cannot use entities on the limited with_clauses because
- -- their units have not been analyzed, so we have to climb the tree
- -- of ancestors looking for private keywords.
+ -- mentions a descendant of a private child of some library unit, then
+ -- the given compilation_unit shall be the declaration of a private
+ -- descendant of that library unit, or a public descendant of such. The
+ -- code is analogous to that of Check_Private_Child_Unit but we cannot
+ -- use entities on the limited with_clauses because their units have not
+ -- been analyzed, so we have to climb the tree of ancestors looking for
+ -- private keywords.
procedure Expand_Limited_With_Clause
(Comp_Unit : Node_Id;
-- units. The shadow entities are created when the inserted clause is
-- analyzed. Implements Ada 2005 (AI-50217).
+ function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean;
+ -- When compiling a unit Q descended from some parent unit P, a limited
+ -- with_clause in the context of P that names some other ancestor of Q
+ -- must not be installed because the ancestor is immediately visible.
+
---------------------
-- Check_Renamings --
---------------------
Child_Parent := Library_Unit (Item);
-- If the child unit is a public child, then locate its nearest
- -- private ancestor, if any; Child_Parent will then be set to
+ -- private ancestor, if any, then Child_Parent will then be set to
-- the parent of that ancestor.
if not Private_Present (Library_Unit (Item)) then
Child_Parent := Parent_Spec (Unit (Child_Parent));
- -- Traverse all the ancestors of the current compilation
- -- unit to check if it is a descendant of named library unit.
+ -- Traverse all the ancestors of the current compilation unit to
+ -- check if it is a descendant of named library unit.
Curr_Parent := Parent (Item);
Curr_Private := Private_Present (Curr_Parent);
or else Curr_Private
or else Private_Present (Item)
or else Nkind_In (Unit (Parent (Item)), N_Package_Body,
- N_Subprogram_Body,
- N_Subunit)
+ N_Subprogram_Body,
+ N_Subunit)
then
-- Current unit is private, of descendant of a private unit
Subunit => False,
Error_Node => Nam);
- -- Do not generate a limited_with_clause on the current unit.
- -- This path is taken when a unit has a limited_with clause on
- -- one of its child units.
+ -- Do not generate a limited_with_clause on the current unit. This
+ -- path is taken when a unit has a limited_with clause on one of its
+ -- child units.
if Unum = Current_Sem_Unit then
return;
New_Nodes_OK := New_Nodes_OK - 1;
end Expand_Limited_With_Clause;
+ ----------------------
+ -- Is_Ancestor_Unit --
+ ----------------------
+
+ function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean is
+ E1 : constant Entity_Id := Defining_Entity (Unit (U1));
+ E2 : Entity_Id;
+ begin
+ if Nkind_In (Unit (U2), N_Package_Body, N_Subprogram_Body) then
+ E2 := Defining_Entity (Unit (Library_Unit (U2)));
+ return Is_Ancestor_Package (E1, E2);
+ else
+ return False;
+ end if;
+ end Is_Ancestor_Unit;
+
-- Start of processing for Install_Limited_Context_Clauses
begin
if Library_Unit (Item) /= Cunit (Current_Sem_Unit)
and then not Limited_View_Installed (Item)
+ and then
+ not Is_Ancestor_Unit
+ (Library_Unit (Item), Cunit (Current_Sem_Unit))
then
if not Private_Present (Item)
or else Private_Present (N)
Next (Item);
end loop;
- -- Ada 2005 (AI-412): Examine the visible declarations of a package
- -- spec, looking for incomplete subtype declarations of incomplete
- -- types visible through a limited with clause.
+ -- Ada 2005 (AI-412): Examine visible declarations of a package spec,
+ -- looking for incomplete subtype declarations of incomplete types
+ -- visible through a limited with clause.
if Ada_Version >= Ada_05
and then Analyzed (N)
-- Convert an incomplete subtype declaration into a
-- corresponding non-limited view subtype declaration.
-- This is usually the case when analyzing a body that
- -- has regular with-clauses, when the spec has limited
+ -- has regular with clauses, when the spec has limited
-- ones.
-- If the non-limited view is still incomplete, it is
-- immediately visible.
-- Find entity for compilation unit, and set its private descendant
- -- status as needed.
+ -- status as needed. Indicate that it is a compilation unit, which is
+ -- redundant in general, but needed if this is a generated child spec
+ -- for a child body without previous spec.
E_Name := Defining_Entity (Lib_Unit);
Set_Is_Child_Unit (E_Name);
+ Set_Is_Compilation_Unit (E_Name);
Set_Is_Private_Descendant (E_Name,
Is_Private_Descendant (P_Name)
Item := First (Context_Items (N));
while Present (Item) loop
- -- Do not install private_with_clauses declaration, unless
- -- unit is itself a private child unit, or is a body.
- -- Note that for a subprogram body the private_with_clause does
- -- not take effect until after the specification.
+ -- Do not install private_with_clauses declaration, unless unit
+ -- is itself a private child unit, or is a body. Note that for a
+ -- subprogram body the private_with_clause does not take effect until
+ -- after the specification.
if Nkind (Item) /= N_With_Clause
or else Implicit_With (Item)
then
Set_Is_Immediately_Visible (Id);
- -- Check for the presence of another unit in the context,
- -- that may be inadvertently hidden by the child.
+ -- Check for the presence of another unit in the context that
+ -- may be inadvertently hidden by the child.
Prev := Current_Entity (Id);
-- If the item is a private with-clause on a child unit, the parent
-- may have been installed already, but the child unit must remain
- -- invisible until installed in a private part or body.
+ -- invisible until installed in a private part or body, unless there
+ -- is already a regular with_clause for it in the current unit.
elsif Private_Present (Item) then
Id := Entity (Name (Item));
if Is_Child_Unit (Id) then
- Set_Is_Visible_Child_Unit (Id, False);
+ declare
+ Clause : Node_Id;
+
+ function In_Context return Boolean;
+ -- Scan context of current unit, to check whether there is
+ -- a with_clause on the same unit as a private with-clause
+ -- on a parent, in which case child unit is visible. If the
+ -- unit is a grand-child, the same applies to its parent.
+
+ ----------------
+ -- In_Context --
+ ----------------
+
+ function In_Context return Boolean is
+ begin
+ Clause :=
+ First (Context_Items (Cunit (Current_Sem_Unit)));
+ while Present (Clause) loop
+ if Nkind (Clause) = N_With_Clause
+ and then Comes_From_Source (Clause)
+ and then Is_Entity_Name (Name (Clause))
+ and then not Private_Present (Clause)
+ then
+ if Entity (Name (Clause)) = Id
+ or else
+ (Nkind (Name (Clause)) = N_Expanded_Name
+ and then Entity (Prefix (Name (Clause))) = Id)
+ then
+ return True;
+ end if;
+ end if;
+
+ Next (Clause);
+ end loop;
+
+ return False;
+ end In_Context;
+
+ begin
+ Set_Is_Visible_Child_Unit (Id, In_Context);
+ end;
end if;
end if;
Next (Decl);
end loop;
- -- Look for declarations that require the presence of a body
+ -- Look for declarations that require the presence of a body. We
+ -- have already skipped pragmas at the start of the list.
while Present (Decl) loop
end loop;
end;
- -- Finally, check whether there are subprograms that still
- -- require a body, i.e. are not renamings or null.
+ -- Finally, check whether there are subprograms that still require
+ -- a body, i.e. are not renamings or null.
if not Is_Empty_Elmt_List (Subp_List) then
declare
return True;
end if;
- -- If there are more ancestors, climb up the tree, otherwise
- -- we are done.
+ -- If there are more ancestors, climb up the tree, otherwise we
+ -- are done.
if Is_Child_Unit (Par) then
Par := Scope (Par);
Next (Item);
end loop;
- -- If it's a body not acting as spec, follow pointer to
+ -- If it is a body not acting as spec, follow pointer to the
-- corresponding spec, otherwise follow pointer to parent spec.
if Present (Library_Unit (Aux_Unit))
-- Do not install the limited view if this is the unit being analyzed.
-- This unusual case will happen when a unit has a limited_with clause
- -- on one of its children. The compilation of the child forces the
- -- load of the parent which tries to install the limited view of the
- -- child again. Installing the limited view must also be disabled
- -- when compiling the body of the child unit.
+ -- on one of its children. The compilation of the child forces the load
+ -- of the parent which tries to install the limited view of the child
+ -- again. Installing the limited view must also be disabled when
+ -- compiling the body of the child unit.
if P = Cunit_Entity (Current_Sem_Unit)
or else
return;
end if;
- -- This scenario is similar to the one above, the difference is that
- -- the compilation of sibling Par.Sib forces the load of parent Par
- -- which tries to install the limited view of Lim_Pack [1]. However
- -- Par.Sib has a with clause for Lim_Pack [2] in its body, and thus
- -- needs the non-limited views of all entities from Lim_Pack.
+ -- This scenario is similar to the one above, the difference is that the
+ -- compilation of sibling Par.Sib forces the load of parent Par which
+ -- tries to install the limited view of Lim_Pack [1]. However Par.Sib
+ -- has a with clause for Lim_Pack [2] in its body, and thus needs the
+ -- non-limited views of all entities from Lim_Pack.
-- limited with Lim_Pack; -- [1]
-- package Par is ... package Lim_Pack is ...
-- One of the ancestors has a limited with clause
and then Nkind (Parent (Parent (Main_Unit_Entity))) =
- N_Package_Specification
+ N_Package_Specification
and then Has_Limited_With_Clause (Scope (Main_Unit_Entity), P)
then
return;
end if;
- -- A common use of the limited-with is to have a limited-with
- -- in the package spec, and a normal with in its package body.
- -- For example:
+ -- A common use 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 ...
if Analyzed (P_Unit)
and then
(Is_Immediately_Visible (P)
- or else
- (Is_Child_Package and then Is_Visible_Child_Unit (P)))
+ or else (Is_Child_Package and then Is_Visible_Child_Unit (P)))
then
return;
end if;
Prev := Current_Entity (Lim_Typ);
E := Prev;
- -- Replace E in the homonyms list, so that the limited
- -- view becomes available.
+ -- Replace E in the homonyms list, so that the limited view
+ -- becomes available.
if E = Non_Limited_View (Lim_Typ) then
Set_Homonym (Lim_Typ, Homonym (Prev));
loop
E := Homonym (Prev);
- -- E may have been removed when installing a
- -- previous limited_with_clause.
+ -- E may have been removed when installing a previous
+ -- limited_with_clause.
exit when No (E);
Check_Body_Required;
end if;
- -- If the package in the limited_with clause is a child unit, the
- -- clause is unanalyzed and appears as a selected component. Recast
- -- it as an expanded name so that the entity can be properly set. Use
- -- entity of parent, if available, for higher ancestors in the name.
+ -- If the package in the limited_with clause is a child unit, the clause
+ -- is unanalyzed and appears as a selected component. Recast it as an
+ -- expanded name so that the entity can be properly set. Use entity of
+ -- parent, if available, for higher ancestors in the name.
if Nkind (Name (N)) = N_Selected_Component then
declare
Write_Eol;
end if;
- -- We do not apply the restrictions to an internal unit unless
- -- we are compiling the internal unit as a main unit. This check
- -- is also skipped for dummy units (for missing packages).
+ -- We do not apply the restrictions to an internal unit unless we are
+ -- compiling the internal unit as a main unit. This check is also
+ -- skipped for dummy units (for missing packages).
if Sloc (Uname) /= No_Location
and then (not Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit))
C_Unit : constant Node_Id := Cunit (Current_Sem_Unit);
begin
return Nkind (Unit (C_Unit)) = N_Package_Body
- and then Has_With_Clause (C_Unit,
- Cunit_Entity (Get_Source_Unit (Non_Limited_View (T))));
+ and then
+ Has_With_Clause
+ (C_Unit, Cunit_Entity (Get_Source_Unit (Non_Limited_View (T))));
end Is_Legal_Shadow_Entity_In_Body;
-----------------------
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);
+ 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.
-- 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);
+ 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.
-- 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
-
- -- Note: The class-wide entity is shared by the limited-view
- -- and the full-view.
-
- if No (Class_Wide_Type (T)) then
- CW := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
-
- -- Set parent to be the same as the parent of the tagged type.
- -- We need a parent field set, and it is supposed to point to
- -- the declaration of the type. The tagged type declaration
- -- essentially declares two separate types, the tagged type
- -- itself and the corresponding class-wide type, so it is
- -- reasonable for the parent fields to point to the declaration
- -- in both cases.
-
- Set_Parent (CW, Parent (T));
-
- -- Set remaining fields of classwide type
-
- 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));
-
- -- Link type to its class-wide type
-
- 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_Shadow_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
+ procedure Build_Chain (Scope : Entity_Id; First_Decl : Node_Id) is
Analyzed_Unit : constant Boolean := Analyzed (Cunit (Unum));
Is_Tagged : Boolean;
Decl : Node_Id;
-- Create shadow entity for type
- Lim_Typ := New_Internal_Shadow_Entity
- (Kind => Ekind (Comp_Typ),
- Sloc_Value => Sloc (Comp_Typ),
- Id_Char => 'Z');
+ 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));
end if;
end if;
- Lim_Typ := New_Internal_Shadow_Entity
- (Kind => Ekind (Comp_Typ),
- Sloc_Value => Sloc (Comp_Typ),
- Id_Char => 'Z');
+ 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));
-- Create shadow entity for type
- Lim_Typ := New_Internal_Shadow_Entity
- (Kind => Ekind (Comp_Typ),
- Sloc_Value => Sloc (Comp_Typ),
- Id_Char => 'Z');
+ 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_Scope (Comp_Typ, Scope);
end if;
- Lim_Typ := New_Internal_Shadow_Entity
- (Kind => Ekind (Comp_Typ),
- Sloc_Value => Sloc (Comp_Typ),
- Id_Char => 'Z');
+ 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);
end loop;
end Build_Chain;
+ ------------------------------
+ -- 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
+
+ -- Note: The class-wide entity is shared by the limited-view
+ -- and the full-view.
+
+ if No (Class_Wide_Type (T)) then
+ CW := Make_Temporary (Loc, 'S');
+
+ -- Set parent to be the same as the parent of the tagged type.
+ -- We need a parent field set, and it is supposed to point to
+ -- the declaration of the type. The tagged type declaration
+ -- essentially declares two separate types, the tagged type
+ -- itself and the corresponding class-wide type, so it is
+ -- reasonable for the parent fields to point to the declaration
+ -- in both cases.
+
+ Set_Parent (CW, Parent (T));
+
+ -- Set remaining fields of classwide type
+
+ 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));
+
+ -- Link type to its class-wide type
+
+ 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_Shadow_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_Temporary (Sloc_Value, 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;
+
-- Start of processing for Build_Limited_Views
begin
-- Build the header of the limited_view
- Lim_Header :=
- Make_Defining_Identifier (Sloc (N),
- Chars => New_Internal_Name (Id_Char => 'Z'));
+ Lim_Header := Make_Temporary (Sloc (N), 'Z');
Set_Ekind (Lim_Header, E_Package);
Set_Is_Internal (Lim_Header);
Set_Limited_View (P, Lim_Header);
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));
+ Set_First_Private_Entity
+ (Lim_Header, Next_Entity (Last_Pub_Lim_E));
else
- Set_First_Private_Entity (Lim_Header,
- First_Entity (P));
+ Set_First_Private_Entity
+ (Lim_Header, First_Entity (P));
end if;
Set_Limited_View_Installed (Spec);
then
return True;
- elsif Ekind (E) = E_Generic_Function
- or else Ekind (E) = E_Generic_Procedure
- then
+ elsif Ekind_In (E, E_Generic_Function, E_Generic_Procedure) then
return True;
elsif Ekind (E) = E_Generic_Package
return True;
elsif Ekind (E) = E_Package
- and then
- Nkind (Unit_Declaration_Node (E)) = N_Package_Declaration
+ and then Nkind (Unit_Declaration_Node (E)) = N_Package_Declaration
and then Present (Corresponding_Body (Unit_Declaration_Node (E)))
then
Ent := First_Entity (E);
begin
if Ekind (Unit_Name) = E_Generic_Package
- and then
- Nkind (Unit_Declaration_Node (Unit_Name)) =
+ 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
+ elsif Ekind_In (Unit_Name, E_Generic_Procedure, E_Generic_Function) then
Set_Body_Needed_For_SAL (Unit_Name);
elsif Is_Subprogram (Unit_Name)
Write_Eol;
end if;
- -- Prepare the removal of the 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
+ -- Prepare the removal of the 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_Header := Limited_View (P);
Lim_Typ := First_Entity (Lim_Header);
if Ekind (Lim_Typ) /= E_Package
and then not Is_Child_Unit (Non_Limited_View (Lim_Typ))
then
-
- -- If the package has incomplete types, the limited view
- -- of the incomplete type is in fact never visible (AI05-129)
- -- but we have created a shadow entity E1 for it, that points
- -- to E2, a non-limited incomplete type. This in turn has a
- -- full view E3 that is the full declaration. There is a
- -- corresponding shadow entity E4. When reinstalling the
- -- non-limited view, E2 must become the current entity and
- -- E3 must be ignored.
+ -- If the package has incomplete types, the limited view of the
+ -- incomplete type is in fact never visible (AI05-129) but we
+ -- have created a shadow entity E1 for it, that points to E2,
+ -- a non-limited incomplete type. This in turn has a full view
+ -- E3 that is the full declaration. There is a corresponding
+ -- shadow entity E4. When reinstalling the non-limited view,
+ -- E2 must become the current entity and E3 must be ignored.
E := Non_Limited_View (Lim_Typ);
then
-- Lim_Typ is the limited view of a full type declaration
- -- that has a previous incomplete declaration, i.e. E3
- -- from the previous description. Nothing to insert.
+ -- that has a previous incomplete declaration, i.e. E3 from
+ -- the previous description. Nothing to insert.
null;
end if;
end if;
- -- Preserve structure of homonym chain.
+ -- Preserve structure of homonym chain
Set_Homonym (E, Homonym (Lim_Typ));
end if;
end if;
if Present (P_Spec) then
-
P := Unit (P_Spec);
P_Name := Get_Parent_Entity (P);
Remove_Context_Clauses (P_Spec);
Set_In_Package_Body (P_Name, False);
- -- This is the recursive call to remove the context of any
- -- higher level parent. This recursion ensures that all parents
- -- are removed in the reverse order of their installation.
+ -- This is the recursive call to remove the context of any higher
+ -- level parent. This recursion ensures that all parents are removed
+ -- in the reverse order of their installation.
Remove_Parents (P);
end if;
Item : Node_Id;
function In_Regular_With_Clause (E : Entity_Id) return Boolean;
- -- Check whether a given unit appears in a regular with_clause.
- -- Used to determine whether a private_with_clause, implicit or
- -- explicit, should be ignored.
+ -- Check whether a given unit appears in a regular with_clause. Used to
+ -- determine whether a private_with_clause, implicit or explicit, should
+ -- be ignored.
----------------------------
-- In_Regular_With_Clause --
if Nkind (Item) = N_With_Clause
and then Private_Present (Item)
then
- -- If private_with_clause is redundant, remove it from
- -- context, as a small optimization to subsequent handling
- -- of private_with clauses in other nested packages..
+ -- If private_with_clause is redundant, remove it from context,
+ -- as a small optimization to subsequent handling of private_with
+ -- clauses in other nested packages.
if In_Regular_With_Clause (Entity (Name (Item))) then
declare
OSDN Git Service
