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
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.
+ -- 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));
-- 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
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
-- 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);
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);
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))));
-- 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));
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;
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
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.
+ -- spec, looking for incomplete subtype declarations of incomplete types
+ -- visible through a limited with clause.
if Ada_Version >= Ada_05
and then Analyzed (N)
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);
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
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))
-- 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;
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;
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_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;
+
-- Start of processing for Build_Limited_Views
begin
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);
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)))
Set_Body_Needed_For_SAL (Unit_Name);
elsif Ekind (Unit_Name) = E_Generic_Procedure
- or else Ekind (Unit_Name) = E_Generic_Function
+ or else
+ Ekind (Unit_Name) = E_Generic_Function
then
Set_Body_Needed_For_SAL (Unit_Name);
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;
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 --
OSDN Git Service
