-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2022, 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- --
-- handling of private and full declarations, and the construction of dispatch
-- tables for tagged types.
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Contracts; use Contracts;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Errout; use Errout;
-with Exp_Disp; use Exp_Disp;
-with Exp_Dist; use Exp_Dist;
-with Exp_Dbug; use Exp_Dbug;
-with Freeze; use Freeze;
-with Ghost; use Ghost;
-with Lib; use Lib;
-with Lib.Xref; use Lib.Xref;
-with Namet; use Namet;
-with Nmake; use Nmake;
-with Nlists; use Nlists;
-with Opt; use Opt;
-with Output; use Output;
-with Restrict; use Restrict;
-with Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Cat; use Sem_Cat;
-with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch6; use Sem_Ch6;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch10; use Sem_Ch10;
-with Sem_Ch12; use Sem_Ch12;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Disp; use Sem_Disp;
-with Sem_Eval; use Sem_Eval;
-with Sem_Prag; use Sem_Prag;
-with Sem_Util; use Sem_Util;
-with Sem_Warn; use Sem_Warn;
-with Snames; use Snames;
-with Stand; use Stand;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Contracts; use Contracts;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Errout; use Errout;
+with Exp_Disp; use Exp_Disp;
+with Exp_Dist; use Exp_Dist;
+with Exp_Dbug; use Exp_Dbug;
+with Freeze; use Freeze;
+with Ghost; use Ghost;
+with Lib; use Lib;
+with Lib.Xref; use Lib.Xref;
+with Namet; use Namet;
+with Nmake; use Nmake;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Output; use Output;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Cat; use Sem_Cat;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch10; use Sem_Ch10;
+with Sem_Ch12; use Sem_Ch12;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Disp; use Sem_Disp;
+with Sem_Eval; use Sem_Eval;
+with Sem_Prag; use Sem_Prag;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
+with Snames; use Snames;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
with Style;
-with Uintp; use Uintp;
+with Uintp; use Uintp;
+with Warnsw; use Warnsw;
with GNAT.HTable;
subtype Entity_Header_Num is Integer range 0 .. Entity_Table_Size - 1;
-- Range of headers in hash table
- function Entity_Hash (Id : Entity_Id) return Entity_Header_Num;
+ function Node_Hash (Id : Entity_Id) return Entity_Header_Num;
-- Simple hash function for Entity_Ids
package Subprogram_Table is new GNAT.Htable.Simple_HTable
Element => Boolean,
No_Element => False,
Key => Entity_Id,
- Hash => Entity_Hash,
+ Hash => Node_Hash,
Equal => "=");
-- Hash table to record which subprograms are referenced. It is declared
-- at library level to avoid elaborating it for every call to Analyze.
+ package Traversed_Table is new GNAT.Htable.Simple_HTable
+ (Header_Num => Entity_Header_Num,
+ Element => Boolean,
+ No_Element => False,
+ Key => Node_Id,
+ Hash => Node_Hash,
+ Equal => "=");
+ -- Hash table to record which nodes we have traversed, so we can avoid
+ -- traversing the same nodes repeatedly.
+
-----------------
- -- Entity_Hash --
+ -- Node_Hash --
-----------------
- function Entity_Hash (Id : Entity_Id) return Entity_Header_Num is
+ function Node_Hash (Id : Entity_Id) return Entity_Header_Num is
begin
return Entity_Header_Num (Id mod Entity_Table_Size);
- end Entity_Hash;
+ end Node_Hash;
---------------------------------
-- Analyze_Package_Body_Helper --
procedure Hide_Public_Entities (Decls : List_Id) is
function Has_Referencer
- (Decls : List_Id;
- Top_Level : Boolean := False) return Boolean;
+ (Decls : List_Id;
+ In_Nested_Instance : Boolean;
+ Has_Outer_Referencer_Of_Non_Subprograms : Boolean) return Boolean;
-- A "referencer" is a construct which may reference a previous
-- declaration. Examine all declarations in list Decls in reverse
- -- and determine whether once such referencer exists. All entities
+ -- and determine whether one such referencer exists. All entities
-- in the range Last (Decls) .. Referencer are hidden from external
- -- visibility.
+ -- visibility. In_Nested_Instance is true if we are inside a package
+ -- instance that has a body.
function Scan_Subprogram_Ref (N : Node_Id) return Traverse_Result;
-- Determine whether a node denotes a reference to a subprogram
- procedure Scan_Subprogram_Refs is
+ procedure Traverse_And_Scan_Subprogram_Refs is
new Traverse_Proc (Scan_Subprogram_Ref);
-- Subsidiary to routine Has_Referencer. Determine whether a node
-- contains references to a subprogram and record them.
-- WARNING: this is a very expensive routine as it performs a full
-- tree traversal.
+ procedure Scan_Subprogram_Refs (Node : Node_Id);
+ -- If we haven't already traversed Node, then mark and traverse it.
+
--------------------
-- Has_Referencer --
--------------------
function Has_Referencer
- (Decls : List_Id;
- Top_Level : Boolean := False) return Boolean
+ (Decls : List_Id;
+ In_Nested_Instance : Boolean;
+ Has_Outer_Referencer_Of_Non_Subprograms : Boolean) return Boolean
is
- Decl : Node_Id;
- Decl_Id : Entity_Id;
- Spec : Node_Id;
-
- Has_Non_Subprograms_Referencer : Boolean := False;
+ Has_Referencer_Of_Non_Subprograms : Boolean :=
+ Has_Outer_Referencer_Of_Non_Subprograms;
-- Set if an inlined subprogram body was detected as a referencer.
-- In this case, we do not return True immediately but keep hiding
-- subprograms from external visibility.
+ Decl : Node_Id;
+ Decl_Id : Entity_Id;
+ In_Instance : Boolean;
+ Spec : Node_Id;
+ Ignore : Boolean;
+
+ function Set_Referencer_Of_Non_Subprograms return Boolean;
+ -- Set Has_Referencer_Of_Non_Subprograms and call
+ -- Scan_Subprogram_Refs if relevant.
+ -- Return whether Scan_Subprogram_Refs was called.
+
+ ---------------------------------------
+ -- Set_Referencer_Of_Non_Subprograms --
+ ---------------------------------------
+
+ function Set_Referencer_Of_Non_Subprograms return Boolean is
+ begin
+ -- An inlined subprogram body acts as a referencer
+ -- unless we generate C code since inlining is then
+ -- handled by the C compiler.
+
+ -- Note that we test Has_Pragma_Inline here in addition
+ -- to Is_Inlined. We are doing this for a client, since
+ -- we are computing which entities should be public, and
+ -- it is the client who will decide if actual inlining
+ -- should occur, so we need to catch all cases where the
+ -- subprogram may be inlined by the client.
+
+ if (not CCG_Mode or else Has_Pragma_Inline_Always (Decl_Id))
+ and then (Is_Inlined (Decl_Id)
+ or else Has_Pragma_Inline (Decl_Id))
+ then
+ Has_Referencer_Of_Non_Subprograms := True;
+
+ -- Inspect the statements of the subprogram body
+ -- to determine whether the body references other
+ -- subprograms.
+
+ Scan_Subprogram_Refs (Decl);
+ return True;
+ else
+ return False;
+ end if;
+ end Set_Referencer_Of_Non_Subprograms;
+
begin
if No (Decls) then
return False;
elsif Nkind (Decl) = N_Package_Declaration then
Spec := Specification (Decl);
+ Decl_Id := Defining_Entity (Spec);
-- Inspect the declarations of a non-generic package to try
-- and hide more entities from external visibility.
- if not Is_Generic_Unit (Defining_Entity (Spec)) then
- if Has_Referencer (Private_Declarations (Spec))
- or else Has_Referencer (Visible_Declarations (Spec))
+ if not Is_Generic_Unit (Decl_Id) then
+ if In_Nested_Instance then
+ In_Instance := True;
+ elsif Is_Generic_Instance (Decl_Id) then
+ In_Instance :=
+ Has_Completion (Decl_Id)
+ or else Unit_Requires_Body (Generic_Parent (Spec));
+ else
+ In_Instance := False;
+ end if;
+
+ if Has_Referencer (Private_Declarations (Spec),
+ In_Instance,
+ Has_Referencer_Of_Non_Subprograms)
+ or else
+ Has_Referencer (Visible_Declarations (Spec),
+ In_Instance,
+ Has_Referencer_Of_Non_Subprograms)
then
return True;
end if;
-- Inspect the declarations of a non-generic package body to
-- try and hide more entities from external visibility.
- elsif Has_Referencer (Declarations (Decl)) then
+ elsif Has_Referencer (Declarations (Decl),
+ In_Nested_Instance
+ or else
+ Is_Generic_Instance (Decl_Id),
+ Has_Referencer_Of_Non_Subprograms)
+ then
return True;
end if;
return True;
end if;
- -- An inlined subprogram body acts as a referencer
-
- -- Note that we test Has_Pragma_Inline here in addition
- -- to Is_Inlined. We are doing this for a client, since
- -- we are computing which entities should be public, and
- -- it is the client who will decide if actual inlining
- -- should occur, so we need to catch all cases where the
- -- subprogram may be inlined by the client.
-
- if Is_Inlined (Decl_Id)
- or else Has_Pragma_Inline (Decl_Id)
- then
- Has_Non_Subprograms_Referencer := True;
-
- -- Inspect the statements of the subprogram body
- -- to determine whether the body references other
- -- subprograms.
-
- Scan_Subprogram_Refs (Decl);
- end if;
+ Ignore := Set_Referencer_Of_Non_Subprograms;
-- Otherwise this is a stand alone subprogram body
else
Decl_Id := Defining_Entity (Decl);
- -- An inlined subprogram body acts as a referencer
-
- if Is_Inlined (Decl_Id)
- or else Has_Pragma_Inline (Decl_Id)
+ if not Set_Referencer_Of_Non_Subprograms
+ and then not Subprogram_Table.Get (Decl_Id)
then
- Has_Non_Subprograms_Referencer := True;
-
- -- Inspect the statements of the subprogram body
- -- to determine whether the body references other
- -- subprograms.
-
- Scan_Subprogram_Refs (Decl);
-
- -- Otherwise we can reset Is_Public right away
-
- elsif not Subprogram_Table.Get (Decl_Id) then
+ -- We can reset Is_Public right away
Set_Is_Public (Decl_Id, False);
end if;
end if;
Discard : Boolean;
pragma Unreferenced (Discard);
begin
- -- Inspect the actions to find references to subprograms
-
- Discard := Has_Referencer (Actions (Decl));
+ -- Inspect the actions to find references to subprograms.
+ -- We assume that the actions do not contain other kinds
+ -- of references and, therefore, we do not stop the scan
+ -- or set Has_Referencer_Of_Non_Subprograms here. Doing
+ -- it would pessimize common cases for which the actions
+ -- contain the declaration of an init procedure, since
+ -- such a procedure is automatically marked inline.
+
+ Discard :=
+ Has_Referencer (Actions (Decl),
+ In_Nested_Instance,
+ Has_Referencer_Of_Non_Subprograms);
end;
-- Exceptions, objects and renamings do not need to be public
-- if they are not followed by a construct which can reference
- -- and export them. The Is_Public flag is reset on top level
- -- entities only as anything nested is local to its context.
- -- Likewise for subprograms, but we work harder for them.
-
- elsif Nkind_In (Decl, N_Exception_Declaration,
- N_Object_Declaration,
- N_Object_Renaming_Declaration,
- N_Subprogram_Declaration,
- N_Subprogram_Renaming_Declaration)
+ -- and export them.
+
+ elsif Nkind (Decl) in N_Exception_Declaration
+ | N_Object_Declaration
+ | N_Object_Renaming_Declaration
+ then
+ Decl_Id := Defining_Entity (Decl);
+
+ -- We cannot say anything for objects declared in nested
+ -- instances because instantiations are not done yet so the
+ -- bodies are not visible and could contain references to
+ -- them.
+
+ if not In_Nested_Instance
+ and then not Is_Imported (Decl_Id)
+ and then not Is_Exported (Decl_Id)
+ and then No (Interface_Name (Decl_Id))
+ and then not Has_Referencer_Of_Non_Subprograms
+ then
+ Set_Is_Public (Decl_Id, False);
+ end if;
+
+ -- Likewise for subprograms and renamings, but we work harder
+ -- for them to see whether they are referenced on an individual
+ -- basis by looking into the table of referenced subprograms.
+
+ elsif Nkind (Decl) in N_Subprogram_Declaration
+ | N_Subprogram_Renaming_Declaration
then
Decl_Id := Defining_Entity (Decl);
- if Top_Level
+ -- We cannot say anything for subprograms declared in nested
+ -- instances because instantiations are not done yet so the
+ -- bodies are not visible and could contain references to
+ -- them, except if we still have no subprograms at all which
+ -- are referenced by an inlined body.
+
+ if (not In_Nested_Instance
+ or else not Subprogram_Table.Get_First)
and then not Is_Imported (Decl_Id)
and then not Is_Exported (Decl_Id)
and then No (Interface_Name (Decl_Id))
- and then
- (not Has_Non_Subprograms_Referencer
- or else (Nkind (Decl) = N_Subprogram_Declaration
- and then not Subprogram_Table.Get (Decl_Id)))
+ and then not Subprogram_Table.Get (Decl_Id)
then
Set_Is_Public (Decl_Id, False);
end if;
Prev (Decl);
end loop;
- return Has_Non_Subprograms_Referencer;
+ return Has_Referencer_Of_Non_Subprograms;
end Has_Referencer;
-------------------------
return OK;
end Scan_Subprogram_Ref;
+ --------------------------
+ -- Scan_Subprogram_Refs --
+ --------------------------
+
+ procedure Scan_Subprogram_Refs (Node : Node_Id) is
+ begin
+ if not Traversed_Table.Get (Node) then
+ Traversed_Table.Set (Node, True);
+ Traverse_And_Scan_Subprogram_Refs (Node);
+ end if;
+ end Scan_Subprogram_Refs;
+
-- Local variables
Discard : Boolean;
-- i.e. not just syntactic, and the gain would very likely be worth
-- neither the hassle nor the slowdown of the compiler.
+ -- Finally, an important thing to be aware of is that, at this point,
+ -- instantiations are not done yet so we cannot directly see inlined
+ -- bodies coming from them. That's not catastrophic because only the
+ -- actual parameters of the instantiations matter here, and they are
+ -- present in the declarations list of the instantiated packages.
+
+ Traversed_Table.Reset;
Subprogram_Table.Reset;
- Discard := Has_Referencer (Decls, Top_Level => True);
+ Discard := Has_Referencer (Decls, False, False);
end Hide_Public_Entities;
----------------------------------
-- Local variables
Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
+ Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
+ Saved_EA : constant Boolean := Expander_Active;
Saved_ISMP : constant Boolean :=
Ignore_SPARK_Mode_Pragmas_In_Instance;
-- Save the Ghost and SPARK mode-related data to restore on exit
("optional package body (not allowed in Ada 95)??", N);
else
Error_Msg_N ("spec of this package does not allow a body", N);
+ Error_Msg_N ("\either remove the body or add pragma "
+ & "Elaborate_Body in the spec", N);
end if;
end if;
end if;
- -- A [generic] package body "freezes" the contract of the nearest
- -- enclosing package body and all other contracts encountered in the
- -- same declarative part up to and excluding the package body:
+ -- A [generic] package body freezes the contract of the nearest
+ -- enclosing package body and all other contracts encountered in
+ -- the same declarative part up to and excluding the package body:
-- package body Nearest_Enclosing_Package
-- with Refined_State => (State => Constit)
-- This ensures that any annotations referenced by the contract of a
-- [generic] subprogram body declared within the current package body
- -- are available. This form of "freezing" is decoupled from the usual
+ -- are available. This form of freezing is decoupled from the usual
-- Freeze_xxx mechanism because it must also work in the context of
-- generics where normal freezing is disabled.
- -- Only bodies coming from source should cause this type of "freezing".
+ -- Only bodies coming from source should cause this type of freezing.
-- Instantiated generic bodies are excluded because their processing is
-- performed in a separate compilation pass which lacks enough semantic
-- information with respect to contract analysis. It is safe to suppress
- -- the "freezing" of contracts in this case because this action already
+ -- the freezing of contracts in this case because this action already
-- took place at the end of the enclosing declarative part.
if Comes_From_Source (N)
and then not Is_Generic_Instance (Spec_Id)
then
- Analyze_Previous_Contracts (N);
+ Freeze_Previous_Contracts (N);
end if;
-- A package body is Ghost when the corresponding spec is Ghost. Set
Mark_And_Set_Ghost_Body (N, Spec_Id);
+ -- Deactivate expansion inside the body of ignored Ghost entities,
+ -- as this code will ultimately be ignored. This avoids requiring the
+ -- presence of run-time units which are not needed. Only do this for
+ -- user entities, as internally generated entities might still need
+ -- to be expanded (e.g. those generated for types).
+
+ if Present (Ignored_Ghost_Region)
+ and then Comes_From_Source (Body_Id)
+ then
+ Expander_Active := False;
+ end if;
+
+ -- If the body completes the initial declaration of a compilation unit
+ -- which is subject to pragma Elaboration_Checks, set the model of the
+ -- pragma because it applies to all parts of the unit.
+
+ Install_Elaboration_Model (Spec_Id);
+
Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
Style.Check_Identifier (Body_Id, Spec_Id);
-- unannotated body will be used in all instantiations.
Body_Id := Defining_Entity (N);
- Set_Ekind (Body_Id, E_Package_Body);
+ Mutate_Ekind (Body_Id, E_Package_Body);
Set_Scope (Body_Id, Scope (Spec_Id));
Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Spec_Id));
Set_Body_Entity (Spec_Id, Body_Id);
-- current node otherwise. Note that N was rewritten above, so we must
-- be sure to get the latest Body_Id value.
- Set_Ekind (Body_Id, E_Package_Body);
+ Mutate_Ekind (Body_Id, E_Package_Body);
Set_Body_Entity (Spec_Id, Body_Id);
Set_Spec_Entity (Body_Id, Spec_Id);
-- This is a nested package, so it may be necessary to declare certain
-- inherited subprograms that are not yet visible because the parent
-- type's subprograms are now visible.
+ -- Note that for child units these operations were generated when
+ -- analyzing the package specification.
if Ekind (Scope (Spec_Id)) = E_Package
and then Scope (Spec_Id) /= Standard_Standard
+ and then not Is_Child_Unit (Spec_Id)
then
Declare_Inherited_Private_Subprograms (Spec_Id);
end if;
- -- A package body "freezes" the contract of its initial declaration.
- -- This analysis depends on attribute Corresponding_Spec being set. Only
- -- bodies coming from source shuld cause this type of "freezing".
-
if Present (Declarations (N)) then
Analyze_Declarations (Declarations (N));
Inspect_Deferred_Constant_Completion (Declarations (N));
("\value Off was set for SPARK_Mode on & #", N, Spec_Id);
end if;
+ -- SPARK_Mode Off could complete no SPARK_Mode in a generic, either
+ -- as specified in source code, or because SPARK_Mode On is ignored
+ -- in an instance where the context is SPARK_Mode Off/Auto.
+
+ elsif Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Body_Id)) = Off
+ and then (Is_Generic_Unit (Spec_Id) or else In_Instance)
+ then
+ null;
+
else
Error_Msg_Sloc := Sloc (SPARK_Pragma (Body_Id));
Error_Msg_N ("incorrect application of SPARK_Mode#", N);
Set_Last_Entity (Spec_Id, Empty);
end if;
+ Update_Use_Clause_Chain;
End_Package_Scope (Spec_Id);
-- All entities declared in body are not visible
-- to the linker as their Is_Public flag is set to True. This proactive
-- approach is necessary because an inlined or a generic body for which
-- code is generated in other units may need to see these entities. Cut
- -- down the number of global symbols that do not neet public visibility
+ -- down the number of global symbols that do not need public visibility
-- as this has two beneficial effects:
-- (1) It makes the compilation process more efficient.
-- (2) It gives the code generator more leeway to optimize within each
-- unit, especially subprograms.
-- This is done only for top-level library packages or child units as
- -- the algorithm does a top-down traversal of the package body.
+ -- the algorithm does a top-down traversal of the package body. This is
+ -- also done for instances because instantiations are still pending by
+ -- the time the enclosing package body is analyzed.
- if (Scope (Spec_Id) = Standard_Standard or else Is_Child_Unit (Spec_Id))
+ if (Scope (Spec_Id) = Standard_Standard
+ or else Is_Child_Unit (Spec_Id)
+ or else Is_Generic_Instance (Spec_Id))
and then not Is_Generic_Unit (Spec_Id)
then
Hide_Public_Entities (Declarations (N));
end if;
end if;
+ if Present (Ignored_Ghost_Region) then
+ Expander_Active := Saved_EA;
+ end if;
+
Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP;
- Restore_Ghost_Mode (Saved_GM);
+ Restore_Ghost_Region (Saved_GM, Saved_IGR);
end Analyze_Package_Body_Helper;
---------------------------------
Generate_Definition (Id);
Enter_Name (Id);
- Set_Ekind (Id, E_Package);
+ Mutate_Ekind (Id, E_Package);
Set_Etype (Id, Standard_Void_Type);
-- Set SPARK_Mode from context
Check_Completion;
-- If the package spec does not require an explicit body, then all
- -- abstract states declared in nested packages cannot possibly get
- -- a proper refinement (SPARK RM 7.2.2(3)). This check is performed
- -- only when the compilation unit is the main unit to allow for
- -- modular SPARK analysis where packages do not necessarily have
- -- bodies.
+ -- abstract states declared in nested packages cannot possibly get a
+ -- proper refinement (SPARK RM 7.1.4(4) and SPARK RM 7.2.2(3)). This
+ -- check is performed only when the compilation unit is the main
+ -- unit to allow for modular SPARK analysis where packages do not
+ -- necessarily have bodies.
if Is_Comp_Unit then
Check_State_Refinements
(Context => N,
Is_Main_Unit => Parent (N) = Cunit (Main_Unit));
end if;
- end if;
- if Is_Comp_Unit then
+ -- Warn about references to unset objects, which is straightforward
+ -- for packages with no bodies. For packages with bodies this is more
+ -- complicated, because some of the objects might be set between spec
+ -- and body elaboration, in nested or child packages, etc.
+
+ Check_References (Id);
+ end if;
- -- Set Body_Required indication on the compilation unit node, and
- -- determine whether elaboration warnings may be meaningful on it.
+ -- Set Body_Required indication on the compilation unit node
+ if Is_Comp_Unit then
Set_Body_Required (Parent (N), Body_Required);
- if not Body_Required then
+ if Legacy_Elaboration_Checks and not Body_Required then
Set_Suppress_Elaboration_Warnings (Id);
end if;
end if;
-- private_with_clauses, and remove them at the end of the nested
-- package.
- procedure Check_One_Tagged_Type_Or_Extension_At_Most;
- -- Issue an error in SPARK mode if a package specification contains
- -- more than one tagged type or type extension.
-
- procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id);
- -- Clears constant indications (Never_Set_In_Source, Constant_Value, and
- -- Is_True_Constant) on all variables that are entities of Id, and on
- -- the chain whose first element is FE. A recursive call is made for all
- -- packages and generic packages.
+ procedure Clear_Constants (Id : Entity_Id);
+ -- Clears constant indications (Never_Set_In_Source, Constant_Value,
+ -- and Is_True_Constant) on all variables that are entities of Id.
+ -- A recursive call is made for all packages and generic packages.
procedure Generate_Parent_References;
-- For a child unit, generate references to parent units, for
- -- GPS navigation purposes.
+ -- GNAT Studio navigation purposes.
function Is_Public_Child (Child, Unit : Entity_Id) return Boolean;
-- Child and Unit are entities of compilation units. True if Child
-- Reject completion of an incomplete or private type declarations
-- having a known discriminant part by an unchecked union.
+ procedure Inspect_Untagged_Record_Completion (Decls : List_Id);
+ -- Find out whether a nonlimited untagged record completion has got a
+ -- primitive equality operator and, if so, make it so that it will be
+ -- used as the predefined operator of the private view of the record.
+
procedure Install_Parent_Private_Declarations (Inst_Id : Entity_Id);
-- Given the package entity of a generic package instantiation or
-- formal package whose corresponding generic is a child unit, installs
-- private part rather than being done in Sem_Ch12.Install_Parent
-- (which is where the parents' visible declarations are installed).
- ------------------------------------------------
- -- Check_One_Tagged_Type_Or_Extension_At_Most --
- ------------------------------------------------
-
- procedure Check_One_Tagged_Type_Or_Extension_At_Most is
- Previous : Node_Id;
-
- procedure Check_Decls (Decls : List_Id);
- -- Check that either Previous is Empty and Decls does not contain
- -- more than one tagged type or type extension, or Previous is
- -- already set and Decls contains no tagged type or type extension.
-
- -----------------
- -- Check_Decls --
- -----------------
-
- procedure Check_Decls (Decls : List_Id) is
- Decl : Node_Id;
-
- begin
- Decl := First (Decls);
- while Present (Decl) loop
- if Nkind (Decl) = N_Full_Type_Declaration
- and then Is_Tagged_Type (Defining_Identifier (Decl))
- then
- if No (Previous) then
- Previous := Decl;
-
- else
- Error_Msg_Sloc := Sloc (Previous);
- Check_SPARK_05_Restriction
- ("at most one tagged type or type extension allowed",
- "\\ previous declaration#",
- Decl);
- end if;
- end if;
-
- Next (Decl);
- end loop;
- end Check_Decls;
-
- -- Start of processing for Check_One_Tagged_Type_Or_Extension_At_Most
-
- begin
- Previous := Empty;
- Check_Decls (Vis_Decls);
-
- if Present (Priv_Decls) then
- Check_Decls (Priv_Decls);
- end if;
- end Check_One_Tagged_Type_Or_Extension_At_Most;
-
---------------------
-- Clear_Constants --
---------------------
- procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id) is
+ procedure Clear_Constants (Id : Entity_Id) is
E : Entity_Id;
begin
-- package can contain a renaming declaration to itself, and such
-- renamings are generated automatically within package instances.
- E := FE;
+ E := First_Entity (Id);
while Present (E) and then E /= Id loop
- if Is_Assignable (E) then
+ if Ekind (E) = E_Variable then
Set_Never_Set_In_Source (E, False);
Set_Is_True_Constant (E, False);
Set_Current_Value (E, Empty);
end if;
elsif Is_Package_Or_Generic_Package (E) then
- Clear_Constants (E, First_Entity (E));
- Clear_Constants (E, First_Private_Entity (E));
+ Clear_Constants (E);
end if;
Next_Entity (E);
then
Generate_Reference (Id, Scope (Id), 'k', False);
- elsif not Nkind_In (Unit (Cunit (Main_Unit)), N_Subprogram_Body,
- N_Subunit)
+ elsif Nkind (Unit (Cunit (Main_Unit))) not in
+ N_Subprogram_Body | N_Subunit
then
-- If current unit is an ancestor of main unit, generate a
-- reference to its own parent.
Decl := First (Decls);
while Present (Decl) loop
- -- We are looking at an incomplete or private type declaration
+ -- We are looking for an incomplete or private type declaration
-- with a known_discriminant_part whose full view is an
- -- Unchecked_Union.
+ -- Unchecked_Union. The seemingly useless check with Is_Type
+ -- prevents cascaded errors when routines defined only for type
+ -- entities are called with non-type entities.
- if Nkind_In (Decl, N_Incomplete_Type_Declaration,
- N_Private_Type_Declaration)
+ if Nkind (Decl) in N_Incomplete_Type_Declaration
+ | N_Private_Type_Declaration
+ and then Is_Type (Defining_Identifier (Decl))
and then Has_Discriminants (Defining_Identifier (Decl))
and then Present (Full_View (Defining_Identifier (Decl)))
and then
end loop;
end Inspect_Unchecked_Union_Completion;
+ ----------------------------------------
+ -- Inspect_Untagged_Record_Completion --
+ ----------------------------------------
+
+ procedure Inspect_Untagged_Record_Completion (Decls : List_Id) is
+ Decl : Node_Id;
+
+ begin
+ Decl := First (Decls);
+ while Present (Decl) loop
+
+ -- We are looking for a full type declaration of an untagged
+ -- record with a private declaration and primitive operations.
+
+ if Nkind (Decl) in N_Full_Type_Declaration
+ and then Is_Record_Type (Defining_Identifier (Decl))
+ and then not Is_Limited_Type (Defining_Identifier (Decl))
+ and then not Is_Tagged_Type (Defining_Identifier (Decl))
+ and then Has_Private_Declaration (Defining_Identifier (Decl))
+ and then Has_Primitive_Operations (Defining_Identifier (Decl))
+ then
+ declare
+ Prim_List : constant Elist_Id :=
+ Collect_Primitive_Operations (Defining_Identifier (Decl));
+
+ E : Entity_Id;
+ Ne_Id : Entity_Id;
+ Op_Decl : Node_Id;
+ Op_Id : Entity_Id;
+ Prim : Elmt_Id;
+
+ begin
+ Prim := First_Elmt (Prim_List);
+ while Present (Prim) loop
+ Op_Id := Node (Prim);
+ Op_Decl := Declaration_Node (Op_Id);
+ if Nkind (Op_Decl) in N_Subprogram_Specification then
+ Op_Decl := Parent (Op_Decl);
+ end if;
+
+ -- We are looking for an equality operator immediately
+ -- visible and declared in the private part followed by
+ -- the synthesized inequality operator.
+
+ if Is_User_Defined_Equality (Op_Id)
+ and then Is_Immediately_Visible (Op_Id)
+ and then List_Containing (Op_Decl) = Decls
+ then
+ Ne_Id := Next_Entity (Op_Id);
+ pragma Assert (Ekind (Ne_Id) = E_Function
+ and then Corresponding_Equality (Ne_Id) = Op_Id);
+
+ E := First_Private_Entity (Id);
+
+ -- Move them from the private part of the entity list
+ -- up to the end of the visible part of the same list.
+
+ Remove_Entity (Op_Id);
+ Remove_Entity (Ne_Id);
+
+ Link_Entities (Prev_Entity (E), Op_Id);
+ Link_Entities (Op_Id, Ne_Id);
+ Link_Entities (Ne_Id, E);
+
+ -- And if the private part contains another equality
+ -- operator, move the equality operator to after it
+ -- in the homonym chain, so that all its next homonyms
+ -- in the same scope, if any, also are in the visible
+ -- part. This is relied upon to resolve expanded names
+ -- in Collect_Interps for example.
+
+ while Present (E) loop
+ exit when Ekind (E) = E_Function
+ and then Chars (E) = Name_Op_Eq;
+
+ Next_Entity (E);
+ end loop;
+
+ if Present (E) then
+ Remove_Homonym (Op_Id);
+
+ Set_Homonym (Op_Id, Homonym (E));
+ Set_Homonym (E, Op_Id);
+ end if;
+
+ exit;
+ end if;
+
+ Next_Elmt (Prim);
+ end loop;
+ end;
+ end if;
+
+ Next (Decl);
+ end loop;
+ end Inspect_Untagged_Record_Completion;
+
-----------------------------------------
-- Install_Parent_Private_Declarations --
-----------------------------------------
Gen_Par :=
Generic_Parent (Specification (Unit_Declaration_Node (Inst_Par)));
while Present (Gen_Par) and then Is_Child_Unit (Gen_Par) loop
- Inst_Node := Get_Package_Instantiation_Node (Inst_Par);
+ Inst_Node := Get_Unit_Instantiation_Node (Inst_Par);
- if Nkind_In (Inst_Node, N_Package_Instantiation,
- N_Formal_Package_Declaration)
+ if Nkind (Inst_Node) in
+ N_Package_Instantiation | N_Formal_Package_Declaration
and then Nkind (Name (Inst_Node)) = N_Expanded_Name
then
Inst_Par := Entity (Prefix (Name (Inst_Node)));
Inst_Par := Renamed_Entity (Inst_Par);
end if;
- Gen_Par :=
- Generic_Parent
- (Specification (Unit_Declaration_Node (Inst_Par)));
+ -- The instance may appear in a sibling generic unit, in
+ -- which case the prefix must include the common (generic)
+ -- ancestor, which is treated as a current instance.
+
+ if Inside_A_Generic
+ and then Ekind (Inst_Par) = E_Generic_Package
+ then
+ Gen_Par := Inst_Par;
+ pragma Assert (In_Open_Scopes (Gen_Par));
+
+ else
+ Gen_Par :=
+ Generic_Parent
+ (Specification (Unit_Declaration_Node (Inst_Par)));
+ end if;
-- Install the private declarations and private use clauses
-- of a parent instance of the child instance, unless the
-- If this is a package associated with a generic instance or formal
-- package, then the private declarations of each of the generic's
- -- parents must be installed at this point.
+ -- parents must be installed at this point, but not if this is the
+ -- abbreviated instance created to check a formal package, see the
+ -- same condition in Analyze_Package_Instantiation.
- if Is_Generic_Instance (Id) then
+ if Is_Generic_Instance (Id)
+ and then not Is_Abbreviated_Instance (Id)
+ then
Install_Parent_Private_Declarations (Id);
end if;
-- Analyze private part if present. The flag In_Private_Part is reset
- -- in End_Package_Scope.
+ -- in Uninstall_Declarations.
L := Last_Entity (Id);
end if;
-- There may be inherited private subprograms that need to be declared,
- -- even in the absence of an explicit private part. If there are any
+ -- even in the absence of an explicit private part. If there are any
-- public declarations in the package and the package is a public child
-- unit, then an implicit private part is assumed.
end if;
-- Check preelaborable initialization for full type completing a
- -- private type for which pragma Preelaborable_Initialization given.
+ -- private type when aspect Preelaborable_Initialization is True
+ -- or is specified by Preelaborable_Initialization attributes
+ -- (in the case of a private type in a generic unit). We pass
+ -- the expression of the aspect (when present) to the parameter
+ -- Preelab_Init_Expr to take into account the rule that presumes
+ -- that subcomponents of generic formal types mentioned in the
+ -- type's P_I aspect have preelaborable initialization (see
+ -- AI12-0409 and RM 10.2.1(11.8/5)).
+
+ if Is_Type (E) and then Must_Have_Preelab_Init (E) then
+ declare
+ PI_Aspect : constant Node_Id :=
+ Find_Aspect
+ (E, Aspect_Preelaborable_Initialization);
+ PI_Expr : Node_Id := Empty;
+ begin
+ if Present (PI_Aspect) then
+ PI_Expr := Expression (PI_Aspect);
+ end if;
- if Is_Type (E)
- and then Must_Have_Preelab_Init (E)
- and then not Has_Preelaborable_Initialization (E)
- then
- Error_Msg_N
- ("full view of & does not have preelaborable initialization", E);
+ if not Has_Preelaborable_Initialization
+ (E, Preelab_Init_Expr => PI_Expr)
+ then
+ Error_Msg_N
+ ("full view of & does not have "
+ & "preelaborable initialization", E);
+ end if;
+ end;
end if;
Next_Entity (E);
Inspect_Unchecked_Union_Completion (Priv_Decls);
end if;
+ -- Implement AI12-0101 (which only removes a legality rule) and then
+ -- AI05-0123 (which directly applies in the previously illegal case)
+ -- in Ada 2012. Note that AI12-0101 is a binding interpretation.
+
+ if Present (Priv_Decls) and then Ada_Version >= Ada_2012 then
+ Inspect_Untagged_Record_Completion (Priv_Decls);
+ end if;
+
if Ekind (Id) = E_Generic_Package
and then Nkind (Orig_Decl) = N_Generic_Package_Declaration
and then Present (Priv_Decls)
if Is_Library_Level_Entity (Id)
or else Is_Generic_Instance (Id)
then
- Clear_Constants (Id, First_Entity (Id));
- Clear_Constants (Id, First_Private_Entity (Id));
+ Clear_Constants (Id);
end if;
- -- Issue an error in SPARK mode if a package specification contains
- -- more than one tagged type or type extension.
-
- Check_One_Tagged_Type_Or_Extension_At_Most;
-
-- Output relevant information as to why the package requires a body.
-- Do not consider generated packages as this exposes internal symbols
-- and leads to confusing messages.
then
Unit_Requires_Body_Info (Id);
end if;
+
+ -- Nested package specs that do not require bodies are not checked for
+ -- ineffective use clauses due to the possibility of subunits. This is
+ -- because at this stage it is impossible to tell whether there will be
+ -- a separate body.
+
+ if not Unit_Requires_Body (Id)
+ and then Is_Compilation_Unit (Id)
+ and then not Is_Private_Descendant (Id)
+ then
+ Update_Use_Clause_Chain;
+ end if;
end Analyze_Package_Specification;
--------------------------------------
begin
Generate_Definition (Id);
Set_Is_Pure (Id, PF);
- Init_Size_Align (Id);
+ Reinit_Size_Align (Id);
if not Is_Package_Or_Generic_Package (Current_Scope)
or else In_Private_Part (Current_Scope)
New_Private_Type (N, Id, N);
Set_Depends_On_Private (Id);
+ -- Set the SPARK mode from the current context
+
+ Set_SPARK_Pragma (Id, SPARK_Mode_Pragma);
+ Set_SPARK_Pragma_Inherited (Id);
+
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, Id);
end if;
Replace_Elmt (Op_Elmt, New_Op);
Remove_Elmt (Op_List, Op_Elmt_2);
Set_Overridden_Operation (New_Op, Parent_Subp);
+ Set_Is_Ada_2022_Only (New_Op,
+ Is_Ada_2022_Only (Parent_Subp));
-- We don't need to inherit its dispatching slot.
-- Set_All_DT_Position has previously ensured that
-- a derived scalar type). Further declarations cannot
-- include inherited operations of the type.
- if Present (Prim_Op) then
- exit when Ekind (Prim_Op) not in Overloadable_Kind;
- end if;
+ exit when Present (Prim_Op)
+ and then not Is_Overloadable (Prim_Op);
end loop;
end if;
end if;
Exchange_Entities (Id, Full_Id);
- Set_Next_Entity (Id, Next1);
- Set_Homonym (Id, H1);
+ Link_Entities (Id, Next1);
+ Set_Homonym (Id, H1);
- Set_Full_View (Full_Id, Id);
- Set_Next_Entity (Full_Id, Next2);
- Set_Homonym (Full_Id, H2);
+ Set_Full_View (Full_Id, Id);
+ Link_Entities (Full_Id, Next2);
+ Set_Homonym (Full_Id, H2);
end Exchange_Declarations;
----------------------------
procedure Swap_Private_Dependents (Priv_Deps : Elist_Id);
-- When the full view of a private type is made available, we do the
-- same for its private dependents under proper visibility conditions.
- -- When compiling a grand-chid unit this needs to be done recursively.
+ -- When compiling a child unit this needs to be done recursively.
-----------------------------
-- Swap_Private_Dependents --
-----------------------------
procedure Swap_Private_Dependents (Priv_Deps : Elist_Id) is
+ Cunit : Entity_Id;
Deps : Elist_Id;
Priv : Entity_Id;
Priv_Elmt : Elmt_Id;
if Present (Full_View (Priv)) and then Is_Visible_Dependent (Priv)
then
if Is_Private_Type (Priv) then
+ Cunit := Cunit_Entity (Current_Sem_Unit);
Deps := Private_Dependents (Priv);
Is_Priv := True;
else
Set_Is_Potentially_Use_Visible
(Priv, Is_Potentially_Use_Visible (Node (Priv_Elmt)));
- -- Within a child unit, recurse, except in generic child unit,
- -- which (unfortunately) handle private_dependents separately.
+ -- Recurse for child units, except in generic child units,
+ -- which unfortunately handle private_dependents separately.
+ -- Note that the current unit may not have been analyzed,
+ -- for example a package body, so we cannot rely solely on
+ -- the Is_Child_Unit flag, but that's only an optimization.
if Is_Priv
- and then Is_Child_Unit (Cunit_Entity (Current_Sem_Unit))
+ and then (No (Etype (Cunit)) or else Is_Child_Unit (Cunit))
and then not Is_Empty_Elmt_List (Deps)
and then not Inside_A_Generic
then
-- defined in the associated package, subject to at least one Part_Of
-- constituent.
- if Ekind_In (P, E_Generic_Package, E_Package) then
+ if Is_Package_Or_Generic_Package (P) then
declare
States : constant Elist_Id := Abstract_States (P);
State_Elmt : Elmt_Id;
end if;
if Limited_Present (Def) then
- Set_Ekind (Id, E_Limited_Private_Type);
+ Mutate_Ekind (Id, E_Limited_Private_Type);
else
- Set_Ekind (Id, E_Private_Type);
+ Mutate_Ekind (Id, E_Private_Type);
end if;
Set_Etype (Id, Id);
Set_Has_Delayed_Freeze (Id);
Set_Is_First_Subtype (Id);
- Init_Size_Align (Id);
+ Reinit_Size_Align (Id);
Set_Is_Constrained (Id,
No (Discriminant_Specifications (N))
Set_Private_Dependents (Id, New_Elmt_List);
if Tagged_Present (Def) then
- Set_Ekind (Id, E_Record_Type_With_Private);
+ Mutate_Ekind (Id, E_Record_Type_With_Private);
Set_Direct_Primitive_Operations (Id, New_Elmt_List);
Set_Is_Abstract_Type (Id, Abstract_Present (Def));
Set_Is_Limited_Record (Id, Limited_Present (Def));
elsif Abstract_Present (Def) then
Error_Msg_N ("only a tagged type can be abstract", N);
+
+ -- We initialize the primitive operations list of an untagged private
+ -- type to an empty element list. Do this even when Extensions_Allowed
+ -- is False to issue better error messages. (Note: This could be done
+ -- for all private types and shared with the tagged case above, but
+ -- for now we do it separately.)
+
+ else
+ Set_Direct_Primitive_Operations (Id, New_Elmt_List);
end if;
end New_Private_Type;
-- implicit completion at some point.
elsif (Is_Overloadable (Id)
- and then not Ekind_In (Id, E_Enumeration_Literal, E_Operator)
+ and then Ekind (Id) not in E_Enumeration_Literal | E_Operator
and then not Is_Abstract_Subprogram (Id)
and then not Has_Completion (Id)
and then Comes_From_Source (Parent (Id)))
and then not Is_Generic_Type (Id))
or else
- (Ekind_In (Id, E_Task_Type, E_Protected_Type)
+ (Ekind (Id) in E_Task_Type | E_Protected_Type
and then not Has_Completion (Id))
or else
Decl : constant Node_Id := Unit_Declaration_Node (P);
Id : Entity_Id;
Full : Entity_Id;
- Priv_Elmt : Elmt_Id;
- Priv_Sub : Entity_Id;
procedure Preserve_Full_Attributes (Priv : Entity_Id; Full : Entity_Id);
-- Copy to the private declaration the attributes of the full view that
-- need to be available for the partial view also.
+ procedure Swap_Private_Dependents (Priv_Deps : Elist_Id);
+ -- When the full view of a private type is made unavailable, we do the
+ -- same for its private dependents under proper visibility conditions.
+ -- When compiling a child unit this needs to be done recursively.
+
function Type_In_Use (T : Entity_Id) return Boolean;
-- Check whether type or base type appear in an active use_type clause
begin
Set_Size_Info (Priv, Full);
- Set_RM_Size (Priv, RM_Size (Full));
+ Copy_RM_Size (To => Priv, From => Full);
Set_Size_Known_At_Compile_Time
(Priv, Size_Known_At_Compile_Time (Full));
Set_Is_Volatile (Priv, Is_Volatile (Full));
Set_Treat_As_Volatile (Priv, Treat_As_Volatile (Full));
+ Set_Is_Atomic (Priv, Is_Atomic (Full));
Set_Is_Ada_2005_Only (Priv, Is_Ada_2005_Only (Full));
Set_Is_Ada_2012_Only (Priv, Is_Ada_2012_Only (Full));
+ Set_Is_Ada_2022_Only (Priv, Is_Ada_2022_Only (Full));
Set_Has_Pragma_Unmodified (Priv, Has_Pragma_Unmodified (Full));
Set_Has_Pragma_Unreferenced (Priv, Has_Pragma_Unreferenced (Full));
Set_Has_Pragma_Unreferenced_Objects
(Priv, Has_Pragma_Unreferenced_Objects
(Full));
+ Set_Predicates_Ignored (Priv, Predicates_Ignored (Full));
if Is_Unchecked_Union (Full) then
Set_Is_Unchecked_Union (Base_Type (Priv));
end if;
- -- Why is atomic not copied here ???
if Referenced (Full) then
Set_Referenced (Priv);
end if;
if Priv_Is_Base_Type then
- Set_Is_Controlled (Priv, Is_Controlled (Full_Base));
+ Set_Is_Controlled_Active
+ (Priv, Is_Controlled_Active (Full_Base));
Set_Finalize_Storage_Only
(Priv, Finalize_Storage_Only (Full_Base));
Set_Has_Controlled_Component
Propagate_Concurrent_Flags (Priv, Base_Type (Full));
end if;
- Set_Freeze_Node (Priv, Freeze_Node (Full));
+ -- As explained in Freeze_Entity, private types are required to point
+ -- to the same freeze node as their corresponding full view, if any.
+ -- But we ought not to overwrite a node already inserted in the tree.
- -- Propagate Default_Initial_Condition-related attributes from the
- -- base type of the full view to the full view and vice versa. This
- -- may seem strange, but is necessary depending on which type
- -- triggered the generation of the DIC procedure body. As a result,
- -- both the full view and its base type carry the same DIC-related
- -- information.
+ pragma Assert
+ (Serious_Errors_Detected /= 0
+ or else No (Freeze_Node (Priv))
+ or else No (Parent (Freeze_Node (Priv)))
+ or else Freeze_Node (Priv) = Freeze_Node (Full));
- Propagate_DIC_Attributes (Full, From_Typ => Full_Base);
- Propagate_DIC_Attributes (Full_Base, From_Typ => Full);
+ Set_Freeze_Node (Priv, Freeze_Node (Full));
-- Propagate Default_Initial_Condition-related attributes from the
-- full view to the private view.
Propagate_DIC_Attributes (Priv, From_Typ => Full);
- -- Propagate invariant-related attributes from the base type of the
- -- full view to the full view and vice versa. This may seem strange,
- -- but is necessary depending on which type triggered the generation
- -- of the invariant procedure body. As a result, both the full view
- -- and its base type carry the same invariant-related information.
-
- Propagate_Invariant_Attributes (Full, From_Typ => Full_Base);
- Propagate_Invariant_Attributes (Full_Base, From_Typ => Full);
-
-- Propagate invariant-related attributes from the full view to the
-- private view.
Propagate_Invariant_Attributes (Priv, From_Typ => Full);
+ -- Propagate predicate-related attributes from the full view to the
+ -- private view.
+
+ Propagate_Predicate_Attributes (Priv, From_Typ => Full);
+
if Is_Tagged_Type (Priv)
and then Is_Tagged_Type (Full)
and then not Error_Posted (Full)
end if;
end Preserve_Full_Attributes;
+ -----------------------------
+ -- Swap_Private_Dependents --
+ -----------------------------
+
+ procedure Swap_Private_Dependents (Priv_Deps : Elist_Id) is
+ Cunit : Entity_Id;
+ Deps : Elist_Id;
+ Priv : Entity_Id;
+ Priv_Elmt : Elmt_Id;
+ Is_Priv : Boolean;
+
+ begin
+ Priv_Elmt := First_Elmt (Priv_Deps);
+ while Present (Priv_Elmt) loop
+ Priv := Node (Priv_Elmt);
+
+ -- Before we do the swap, we verify the presence of the Full_View
+ -- field, which may be empty due to a swap by a previous call to
+ -- End_Package_Scope (e.g. from the freezing mechanism).
+
+ if Present (Full_View (Priv)) then
+ if Is_Private_Type (Priv) then
+ Cunit := Cunit_Entity (Current_Sem_Unit);
+ Deps := Private_Dependents (Priv);
+ Is_Priv := True;
+ else
+ Is_Priv := False;
+ end if;
+
+ if Scope (Priv) = P
+ or else not In_Open_Scopes (Scope (Priv))
+ then
+ Set_Is_Immediately_Visible (Priv, False);
+ end if;
+
+ if Is_Visible_Dependent (Priv) then
+ Preserve_Full_Attributes (Priv, Full_View (Priv));
+ Replace_Elmt (Priv_Elmt, Full_View (Priv));
+ Exchange_Declarations (Priv);
+
+ -- Recurse for child units, except in generic child units,
+ -- which unfortunately handle private_dependents separately.
+ -- Note that the current unit may not have been analyzed,
+ -- for example a package body, so we cannot rely solely on
+ -- the Is_Child_Unit flag, but that's only an optimization.
+
+ if Is_Priv
+ and then (No (Etype (Cunit)) or else Is_Child_Unit (Cunit))
+ and then not Is_Empty_Elmt_List (Deps)
+ and then not Inside_A_Generic
+ then
+ Swap_Private_Dependents (Deps);
+ end if;
+ end if;
+ end if;
+
+ Next_Elmt (Priv_Elmt);
+ end loop;
+ end Swap_Private_Dependents;
+
-----------------
-- Type_In_Use --
-----------------
-- a) If the entity is an operator, it may be a primitive operator of
-- a type for which there is a visible use-type clause.
- -- b) for other entities, their use-visibility is determined by a
- -- visible use clause for the package itself. For a generic instance,
+ -- b) For other entities, their use-visibility is determined by a
+ -- visible use clause for the package itself or a use-all-type clause
+ -- applied directly to the entity's type. For a generic instance,
-- the instantiation of the formals appears in the visible part,
-- but the formals are private and remain so.
Set_Is_Potentially_Use_Visible (Id);
end if;
+ -- Avoid crash caused by previous errors
+
+ elsif No (Etype (Id)) and then Serious_Errors_Detected /= 0 then
+ null;
+
+ -- We need to avoid incorrectly marking enumeration literals as
+ -- non-visible when a visible use-all-type clause is in effect.
+
+ elsif Type_In_Use (Etype (Id))
+ and then Nkind (Current_Use_Clause (Etype (Id))) =
+ N_Use_Type_Clause
+ and then All_Present (Current_Use_Clause (Etype (Id)))
+ then
+ null;
+
else
Set_Is_Potentially_Use_Visible (Id, False);
end if;
Check_Conventions (Id);
end if;
- if Ekind_In (Id, E_Private_Type, E_Limited_Private_Type)
+ if Ekind (Id) in E_Private_Type | E_Limited_Private_Type
and then No (Full_View (Id))
and then not Is_Generic_Type (Id)
and then not Is_Derived_Type (Id)
if not In_Private_Part (P) then
return;
- else
- Set_In_Private_Part (P, False);
end if;
+ -- Reset the flag now
+
+ Set_In_Private_Part (P, False);
+
-- Make private entities invisible and exchange full and private
-- declarations for private types. Id is now the first private entity
-- in the package.
-- were compiled in this scope, or installed previously
-- by Install_Private_Declarations.
- -- Before we do the swap, we verify the presence of the Full_View
- -- field which may be empty due to a swap by a previous call to
- -- End_Package_Scope (e.g. from the freezing mechanism).
-
- Priv_Elmt := First_Elmt (Private_Dependents (Id));
- while Present (Priv_Elmt) loop
- Priv_Sub := Node (Priv_Elmt);
-
- if Present (Full_View (Priv_Sub)) then
- if Scope (Priv_Sub) = P
- or else not In_Open_Scopes (Scope (Priv_Sub))
- then
- Set_Is_Immediately_Visible (Priv_Sub, False);
- end if;
-
- if Is_Visible_Dependent (Priv_Sub) then
- Preserve_Full_Attributes
- (Priv_Sub, Full_View (Priv_Sub));
- Replace_Elmt (Priv_Elmt, Full_View (Priv_Sub));
- Exchange_Declarations (Priv_Sub);
- end if;
- end if;
-
- Next_Elmt (Priv_Elmt);
- end loop;
+ Swap_Private_Dependents (Private_Dependents (Id));
-- Now restore the type itself to its private view
end loop;
end;
+ -- For subtypes of private types the frontend generates two entities:
+ -- one associated with the partial view and the other associated with
+ -- the full view. When the subtype declaration is public the frontend
+ -- places the former entity in the list of public entities of the
+ -- package and the latter entity in the private part of the package.
+ -- When the subtype declaration is private it generates these two
+ -- entities but both are placed in the private part of the package
+ -- (and the full view has the same source location as the partial
+ -- view and no parent; see Prepare_Private_Subtype_Completion).
+
+ elsif Ekind (Id) in E_Private_Subtype
+ | E_Limited_Private_Subtype
+ and then Present (Full_View (Id))
+ and then Sloc (Id) = Sloc (Full_View (Id))
+ and then No (Parent (Full_View (Id)))
+ then
+ Set_Is_Hidden (Id);
+ Set_Is_Potentially_Use_Visible (Id, False);
+
elsif not Is_Child_Unit (Id)
and then (not Is_Private_Type (Id) or else No (Full_View (Id)))
then
E : Entity_Id;
Requires_Body : Boolean := False;
- -- Flag set when the unit has at least one construct that requries
+ -- Flag set when the unit has at least one construct that requires
-- completion in a body.
begin
-- A [generic] package that defines at least one non-null abstract state
-- requires a completion only when at least one other construct requires
- -- a completion in a body (SPARK RM 7.1.4(4) and (6)). This check is not
+ -- a completion in a body (SPARK RM 7.1.4(4) and (5)). This check is not
-- performed if the caller requests this behavior.
if Do_Abstract_States
- and then Ekind_In (Pack_Id, E_Generic_Package, E_Package)
+ and then Is_Package_Or_Generic_Package (Pack_Id)
and then Has_Non_Null_Abstract_State (Pack_Id)
and then Requires_Body
then
-- Body required if library package with pragma Elaborate_Body
elsif Has_Pragma_Elaborate_Body (Pack_Id) then
- Error_Msg_N ("info: & requires body (Elaborate_Body)?Y?", Pack_Id);
+ Error_Msg_N ("info: & requires body (Elaborate_Body)?.y?", Pack_Id);
-- Body required if subprogram
elsif Is_Subprogram_Or_Generic_Subprogram (Pack_Id) then
- Error_Msg_N ("info: & requires body (subprogram case)?Y?", Pack_Id);
+ Error_Msg_N ("info: & requires body (subprogram case)?.y?", Pack_Id);
-- Body required if generic parent has Elaborate_Body
begin
if Has_Pragma_Elaborate_Body (G_P) then
Error_Msg_N
- ("info: & requires body (generic parent Elaborate_Body)?Y?",
+ ("info: & requires body (generic parent Elaborate_Body)?.y?",
Pack_Id);
end if;
end;
-- provided). If Ignore_Abstract_State is True, we don't do this check
-- (so we can use Unit_Requires_Body to check for some other reason).
- elsif Ekind_In (Pack_Id, E_Generic_Package, E_Package)
+ elsif Is_Package_Or_Generic_Package (Pack_Id)
and then Present (Abstract_States (Pack_Id))
and then not Is_Null_State
(Node (First_Elmt (Abstract_States (Pack_Id))))
then
Error_Msg_N
- ("info: & requires body (non-null abstract state aspect)?Y?",
+ ("info: & requires body (non-null abstract state aspect)?.y?",
Pack_Id);
end if;
if Requires_Completion_In_Body (E, Pack_Id) then
Error_Msg_Node_2 := E;
Error_Msg_NE
- ("info: & requires body (& requires completion)?Y?", E, Pack_Id);
+ ("info: & requires body (& requires completion)?.y?", E,
+ Pack_Id);
end if;
Next_Entity (E);