with Atree; use Atree;
with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Disp; use Exp_Disp;
with Exp_Dbug; use Exp_Dbug;
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 Sem; use Sem;
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_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 Style;
package body Sem_Ch7 is
procedure Install_Package_Entity (Id : Entity_Id);
function Is_Private_Base_Type (E : Entity_Id) return Boolean;
function Is_Visible_Dependent (Dep : Entity_Id) return Boolean;
procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id);
procedure Analyze_Package_Body (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
HSS : Node_Id;
Body_Id : Entity_Id;
Spec_Id : Entity_Id;
Last_Spec_Entity : Entity_Id;
New_N : Node_Id;
Pack_Decl : Node_Id;
procedure Install_Composite_Operations (P : Entity_Id);
procedure Install_Composite_Operations (P : Entity_Id) is
Id : Entity_Id;
begin
Id := First_Entity (P);
while Present (Id) loop
if Is_Type (Id)
and then (Is_Limited_Composite (Id)
or else Is_Private_Composite (Id))
and then No (Private_Component (Id))
then
Set_Is_Limited_Composite (Id, False);
Set_Is_Private_Composite (Id, False);
end if;
Next_Entity (Id);
end loop;
end Install_Composite_Operations;
begin
if Debug_Flag_C then
Write_Str ("==== Compiling package body ");
Write_Name (Chars (Defining_Entity (N)));
Write_Str (" from ");
Write_Location (Loc);
Write_Eol;
end if;
Body_Id := Defining_Entity (N);
if Present (Corresponding_Spec (N)) then
Spec_Id := Corresponding_Spec (N);
Pack_Decl := Unit_Declaration_Node (Spec_Id);
else
Spec_Id := Current_Entity_In_Scope (Defining_Entity (N));
if Present (Spec_Id)
and then Is_Package (Spec_Id)
then
Pack_Decl := Unit_Declaration_Node (Spec_Id);
if Nkind (Pack_Decl) = N_Package_Renaming_Declaration then
Error_Msg_N ("cannot supply body for package renaming", N);
return;
elsif Present (Corresponding_Body (Pack_Decl)) then
Error_Msg_N ("redefinition of package body", N);
return;
end if;
else
Error_Msg_N ("missing specification for package body", N);
return;
end if;
if Is_Package (Spec_Id)
and then
(Scope (Spec_Id) = Standard_Standard
or else Is_Child_Unit (Spec_Id))
and then not Unit_Requires_Body (Spec_Id)
then
if Ada_Version = Ada_83 then
Error_Msg_N
("optional package body (not allowed in Ada 95)?", N);
else
Error_Msg_N
("spec of this package does not allow a body", N);
end if;
end if;
end if;
Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
Style.Check_Identifier (Body_Id, Spec_Id);
if Is_Child_Unit (Spec_Id) then
if Nkind (Parent (N)) /= N_Compilation_Unit then
Error_Msg_NE
("body of child unit& cannot be an inner package", N, Spec_Id);
end if;
Set_Is_Child_Unit (Body_Id);
end if;
if Ekind (Spec_Id) = E_Generic_Package then
Body_Id := Defining_Entity (N);
Set_Ekind (Body_Id, E_Package_Body);
Set_Scope (Body_Id, Scope (Spec_Id));
Set_Body_Entity (Spec_Id, Body_Id);
Set_Spec_Entity (Body_Id, Spec_Id);
New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
Rewrite (N, New_N);
Body_Id := Defining_Entity (N);
Start_Generic;
end if;
Set_Ekind (Body_Id, E_Package_Body);
Set_Body_Entity (Spec_Id, Body_Id);
Set_Spec_Entity (Body_Id, Spec_Id);
Set_Etype (Body_Id, Standard_Void_Type);
Set_Scope (Body_Id, Scope (Spec_Id));
Set_Corresponding_Spec (N, Spec_Id);
Set_Corresponding_Body (Pack_Decl, Body_Id);
if Scope (Spec_Id) /= Standard_Standard then
Append_Entity (Body_Id, Scope (Spec_Id));
end if;
Set_In_Package_Body (Spec_Id);
Set_Has_Completion (Spec_Id);
Last_Spec_Entity := Last_Entity (Spec_Id);
New_Scope (Spec_Id);
Set_Categorization_From_Pragmas (N);
Install_Visible_Declarations (Spec_Id);
Install_Private_Declarations (Spec_Id);
Install_Private_With_Clauses (Spec_Id);
Install_Composite_Operations (Spec_Id);
if Ekind (Spec_Id) = E_Generic_Package then
Set_Use (Generic_Formal_Declarations (Pack_Decl));
end if;
Set_Use (Visible_Declarations (Specification (Pack_Decl)));
Set_Use (Private_Declarations (Specification (Pack_Decl)));
if Ekind (Scope (Spec_Id)) = E_Package
and then Scope (Spec_Id) /= Standard_Standard
then
Declare_Inherited_Private_Subprograms (Spec_Id);
end if;
if Present (Declarations (N)) then
Analyze_Declarations (Declarations (N));
end if;
HSS := Handled_Statement_Sequence (N);
if Present (HSS) then
Process_End_Label (HSS, 't', Spec_Id);
Analyze (HSS);
Validate_Null_Statement_Sequence (N);
end if;
Validate_Categorization_Dependency (N, Spec_Id);
Check_Completion (Body_Id);
Generate_Reference (Spec_Id, Body_Id, 'b', Set_Ref => False);
if Ekind (Spec_Id) /= E_Package then
Save_Global_References (Original_Node (N));
End_Generic;
end if;
if Present (Last_Spec_Entity) then
Set_First_Entity (Body_Id, Next_Entity (Last_Spec_Entity));
Set_Next_Entity (Last_Spec_Entity, Empty);
Set_Last_Entity (Body_Id, Last_Entity (Spec_Id));
Set_Last_Entity (Spec_Id, Last_Spec_Entity);
else
Set_First_Entity (Body_Id, First_Entity (Spec_Id));
Set_Last_Entity (Body_Id, Last_Entity (Spec_Id));
Set_First_Entity (Spec_Id, Empty);
Set_Last_Entity (Spec_Id, Empty);
end if;
End_Package_Scope (Spec_Id);
declare
E : Entity_Id;
begin
E := First_Entity (Body_Id);
while Present (E) loop
Set_Is_Immediately_Visible (E, False);
Set_Is_Potentially_Use_Visible (E, False);
Set_Is_Hidden (E);
if not Is_Child_Unit (E) then
Set_Is_Package_Body_Entity (E);
end if;
Next_Entity (E);
end loop;
end;
Check_References (Body_Id);
if Ekind (Spec_Id) = E_Generic_Package then
Check_References (Spec_Id);
end if;
if (Scope (Spec_Id) = Standard_Standard or else Is_Child_Unit (Spec_Id))
and then not Is_Generic_Unit (Spec_Id)
and then Present (Declarations (N))
then
Make_Non_Public_Where_Possible : declare
function Has_Referencer
(L : List_Id;
Outer : Boolean)
return Boolean;
function Has_Referencer
(L : List_Id;
Outer : Boolean)
return Boolean
is
D : Node_Id;
E : Entity_Id;
K : Node_Kind;
S : Entity_Id;
begin
if No (L) then
return False;
end if;
D := Last (L);
while Present (D) loop
K := Nkind (D);
if K in N_Body_Stub then
return True;
elsif K = N_Subprogram_Body then
if Acts_As_Spec (D) then
E := Defining_Entity (D);
if Has_Pragma_Inline (E) then
return True;
else
Set_Is_Public (E, False);
end if;
else
E := Corresponding_Spec (D);
if Present (E)
and then (Is_Generic_Unit (E)
or else Has_Pragma_Inline (E)
or else Is_Inlined (E))
then
return True;
end if;
end if;
elsif K = N_Package_Body
and then Present (Corresponding_Spec (D))
then
E := Corresponding_Spec (D);
if Is_Generic_Unit (E) then
return True;
elsif not Is_Generic_Instance (E) then
if Has_Referencer
(Declarations (D), Outer => False)
then
return True;
end if;
end if;
elsif K = N_Package_Declaration then
S := Specification (D);
if not Is_Generic_Unit (Defining_Entity (S)) then
if Has_Referencer
(Private_Declarations (S), Outer => False)
then
return True;
elsif Has_Referencer
(Visible_Declarations (S), Outer => False)
then
return True;
end if;
end if;
elsif K = N_Object_Declaration
or else K = N_Exception_Declaration
or else K = N_Subprogram_Declaration
then
E := Defining_Entity (D);
if Outer
and then not Is_Imported (E)
and then not Is_Exported (E)
and then No (Interface_Name (E))
then
Set_Is_Public (E, False);
end if;
end if;
Prev (D);
end loop;
return False;
end Has_Referencer;
begin
declare
Discard : Boolean;
pragma Warnings (Off, Discard);
begin
Discard := Has_Referencer (Declarations (N), Outer => True);
end;
end Make_Non_Public_Where_Possible;
end if;
if not Expander_Active then
Set_In_Package_Body (Spec_Id, False);
if Is_Generic_Instance (Spec_Id)
and then Operating_Mode = Generate_Code
then
Qualify_Entity_Names (N);
end if;
end if;
end Analyze_Package_Body;
procedure Analyze_Package_Declaration (N : Node_Id) is
Id : constant Node_Id := Defining_Entity (N);
PF : Boolean;
begin
Generate_Definition (Id);
Enter_Name (Id);
Set_Ekind (Id, E_Package);
Set_Etype (Id, Standard_Void_Type);
New_Scope (Id);
PF := Is_Pure (Enclosing_Lib_Unit_Entity);
Set_Is_Pure (Id, PF);
Set_Categorization_From_Pragmas (N);
if Debug_Flag_C then
Write_Str ("==== Compiling package spec ");
Write_Name (Chars (Id));
Write_Str (" from ");
Write_Location (Sloc (N));
Write_Eol;
end if;
Analyze (Specification (N));
Validate_Categorization_Dependency (N, Id);
End_Package_Scope (Id);
if Nkind (Parent (N)) = N_Compilation_Unit then
Set_Body_Required (Parent (N), Unit_Requires_Body (Id));
if not Body_Required (Parent (N)) then
Set_Suppress_Elaboration_Warnings (Id);
end if;
Validate_RT_RAT_Component (N);
end if;
end Analyze_Package_Declaration;
procedure Analyze_Package_Specification (N : Node_Id) is
Id : constant Entity_Id := Defining_Entity (N);
Orig_Decl : constant Node_Id := Original_Node (Parent (N));
Vis_Decls : constant List_Id := Visible_Declarations (N);
Priv_Decls : constant List_Id := Private_Declarations (N);
E : Entity_Id;
L : Entity_Id;
Public_Child : Boolean;
procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id);
procedure Generate_Parent_References;
function Is_Public_Child (Child, Unit : Entity_Id) return Boolean;
procedure Inspect_Deferred_Constant_Completion;
procedure Inspect_Unchecked_Union_Completion (Decls : List_Id);
procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id) is
E : Entity_Id;
begin
if Nkind (Parent (Id)) = N_Package_Renaming_Declaration then
return;
end if;
E := FE;
while Present (E) and then E /= Id loop
if Ekind (E) = E_Variable then
Set_Never_Set_In_Source (E, False);
Set_Is_True_Constant (E, False);
Set_Current_Value (E, Empty);
Set_Is_Known_Non_Null (E, False);
elsif Ekind (E) = E_Package
or else
Ekind (E) = E_Generic_Package
then
Clear_Constants (E, First_Entity (E));
Clear_Constants (E, First_Private_Entity (E));
end if;
Next_Entity (E);
end loop;
end Clear_Constants;
procedure Generate_Parent_References is
Decl : constant Node_Id := Parent (N);
begin
if Id = Cunit_Entity (Main_Unit)
or else Parent (Decl) = Library_Unit (Cunit (Main_Unit))
then
Generate_Reference (Id, Scope (Id), 'k', False);
elsif Nkind (Unit (Cunit (Main_Unit))) /= N_Subprogram_Body
and then Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit
then
declare
U : Node_Id;
Main_Spec : Node_Id := Unit (Cunit (Main_Unit));
begin
if Nkind (Main_Spec) = N_Package_Body then
Main_Spec := Unit (Library_Unit (Cunit (Main_Unit)));
end if;
U := Parent_Spec (Main_Spec);
while Present (U) loop
if U = Parent (Decl) then
Generate_Reference (Id, Scope (Id), 'k', False);
exit;
elsif Nkind (Unit (U)) = N_Package_Body then
exit;
else
U := Parent_Spec (Unit (U));
end if;
end loop;
end;
end if;
end Generate_Parent_References;
function Is_Public_Child (Child, Unit : Entity_Id) return Boolean is
begin
if not Is_Private_Descendant (Child) then
return True;
else
if Child = Unit then
return not Private_Present (
Parent (Unit_Declaration_Node (Child)));
else
return Is_Public_Child (Scope (Child), Unit);
end if;
end if;
end Is_Public_Child;
procedure Inspect_Deferred_Constant_Completion is
Decl : Node_Id;
begin
Decl := First (Priv_Decls);
while Present (Decl) loop
if Nkind (Decl) = N_Object_Declaration
and then Constant_Present (Decl)
and then No (Expression (Decl))
and then Comes_From_Source (Decl)
and then not Has_Completion (Defining_Identifier (Decl))
then
Error_Msg_N
("constant declaration requires initialization expression",
Defining_Identifier (Decl));
end if;
Decl := Next (Decl);
end loop;
end Inspect_Deferred_Constant_Completion;
procedure Inspect_Unchecked_Union_Completion (Decls : List_Id) is
Decl : Node_Id := First (Decls);
begin
while Present (Decl) loop
if (Nkind (Decl) = N_Incomplete_Type_Declaration
or else
Nkind (Decl) = N_Private_Type_Declaration)
and then Has_Discriminants (Defining_Identifier (Decl))
and then Present (Full_View (Defining_Identifier (Decl)))
and then Is_Unchecked_Union
(Full_View (Defining_Identifier (Decl)))
then
Error_Msg_N ("completion of discriminated partial view" &
" cannot be an Unchecked_Union",
Full_View (Defining_Identifier (Decl)));
end if;
Next (Decl);
end loop;
end Inspect_Unchecked_Union_Completion;
begin
if Present (Vis_Decls) then
Analyze_Declarations (Vis_Decls);
end if;
E := First_Entity (Id);
while Present (E) loop
if Ekind (E) = E_Incomplete_Type
and then No (Full_View (E))
then
Error_Msg_N ("no declaration in visible part for incomplete}", E);
end if;
Next_Entity (E);
end loop;
if Is_Remote_Call_Interface (Id)
and then Nkind (Parent (Parent (N))) = N_Compilation_Unit
then
Validate_RCI_Declarations (Id);
end if;
if Ekind (Id) = E_Generic_Package
and then Nkind (Orig_Decl) = N_Generic_Package_Declaration
then
declare
Orig_Spec : constant Node_Id := Specification (Orig_Decl);
Save_Priv : constant List_Id := Private_Declarations (Orig_Spec);
begin
Set_Private_Declarations (Orig_Spec, Empty_List);
Save_Global_References (Orig_Decl);
Set_Private_Declarations (Orig_Spec, Save_Priv);
end;
end if;
Public_Child := False;
declare
Par : Entity_Id;
Pack_Decl : Node_Id;
Par_Spec : Node_Id;
begin
Par := Id;
Par_Spec := Parent_Spec (Parent (N));
if No (Par_Spec)
and then
Nkind (Original_Node (Parent (N))) = N_Formal_Package_Declaration
then
Par := Entity (Name (Original_Node (Parent (N))));
Par_Spec := Parent_Spec (Unit_Declaration_Node (Par));
end if;
if Present (Par_Spec) then
Generate_Parent_References;
while Scope (Par) /= Standard_Standard
and then Is_Public_Child (Id, Par)
loop
Public_Child := True;
Par := Scope (Par);
Install_Private_Declarations (Par);
Install_Private_With_Clauses (Par);
Pack_Decl := Unit_Declaration_Node (Par);
Set_Use (Private_Declarations (Specification (Pack_Decl)));
end loop;
end if;
end;
if Is_Compilation_Unit (Id) then
Install_Private_With_Clauses (Id);
end if;
L := Last_Entity (Id);
if Present (Priv_Decls) then
Set_In_Private_Part (Id);
if Public_Child then
Declare_Inherited_Private_Subprograms (Id);
end if;
Analyze_Declarations (Priv_Decls);
Inspect_Deferred_Constant_Completion;
if Present (L) then
Set_First_Private_Entity (Id, Next_Entity (L));
else
Set_First_Private_Entity (Id, First_Entity (Id));
end if;
elsif Present (L) and then Public_Child then
Set_In_Private_Part (Id);
Declare_Inherited_Private_Subprograms (Id);
Set_First_Private_Entity (Id, Next_Entity (L));
end if;
E := First_Entity (Id);
while Present (E) loop
if Ekind (E) = E_Record_Type or else Ekind (E) = E_Array_Type then
Check_Aliased_Component_Types (E);
end if;
Next_Entity (E);
end loop;
if Present (Vis_Decls) then
Inspect_Unchecked_Union_Completion (Vis_Decls);
end if;
if Present (Priv_Decls) then
Inspect_Unchecked_Union_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)
then
declare
Orig_Spec : constant Node_Id := Specification (Orig_Decl);
Save_Vis : constant List_Id := Visible_Declarations (Orig_Spec);
Save_Form : constant List_Id :=
Generic_Formal_Declarations (Orig_Decl);
begin
Set_Visible_Declarations (Orig_Spec, Empty_List);
Set_Generic_Formal_Declarations (Orig_Decl, Empty_List);
Save_Global_References (Orig_Decl);
Set_Generic_Formal_Declarations (Orig_Decl, Save_Form);
Set_Visible_Declarations (Orig_Spec, Save_Vis);
end;
end if;
Process_End_Label (N, 'e', Id);
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));
end if;
end Analyze_Package_Specification;
procedure Analyze_Private_Type_Declaration (N : Node_Id) is
PF : constant Boolean := Is_Pure (Enclosing_Lib_Unit_Entity);
Id : constant Entity_Id := Defining_Identifier (N);
begin
Generate_Definition (Id);
Set_Is_Pure (Id, PF);
Init_Size_Align (Id);
if (Ekind (Current_Scope) /= E_Package
and then Ekind (Current_Scope) /= E_Generic_Package)
or else In_Private_Part (Current_Scope)
then
Error_Msg_N ("invalid context for private declaration", N);
end if;
New_Private_Type (N, Id, N);
Set_Depends_On_Private (Id);
end Analyze_Private_Type_Declaration;
procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id) is
E : Entity_Id;
Op_List : Elist_Id;
Op_Elmt : Elmt_Id;
Op_Elmt_2 : Elmt_Id;
Prim_Op : Entity_Id;
New_Op : Entity_Id := Empty;
Parent_Subp : Entity_Id;
Found_Explicit : Boolean;
Decl_Privates : Boolean;
function Has_Overriding_Pragma (Subp : Entity_Id) return Boolean;
function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean;
function Has_Overriding_Pragma (Subp : Entity_Id) return Boolean is
Decl : constant Node_Id := Unit_Declaration_Node (Subp);
Prag : Node_Id;
begin
if No (Decl)
or else Nkind (Decl) /= N_Subprogram_Declaration
or else No (Next (Decl))
then
return False;
else
Prag := Next (Decl);
while Present (Prag)
and then Nkind (Prag) = N_Pragma
loop
if Chars (Prag) = Name_Overriding
or else Chars (Prag) = Name_Optional_Overriding
then
return True;
else
Next (Prag);
end if;
end loop;
end if;
return False;
end Has_Overriding_Pragma;
function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean is
Formal : Entity_Id;
begin
if Etype (S) = T then
return True;
else
Formal := First_Formal (S);
while Present (Formal) loop
if Etype (Formal) = T then
return True;
end if;
Next_Formal (Formal);
end loop;
return False;
end if;
end Is_Primitive_Of;
begin
E := First_Entity (Id);
while Present (E) loop
if ((Is_Derived_Type (E) and then not Is_Private_Type (E))
or else
(Nkind (Parent (E)) = N_Private_Extension_Declaration
and then Is_Generic_Type (E)))
and then In_Open_Scopes (Scope (Etype (E)))
and then E = Base_Type (E)
then
if Is_Tagged_Type (E) then
Op_List := Primitive_Operations (E);
New_Op := Empty;
Decl_Privates := False;
Op_Elmt := First_Elmt (Op_List);
while Present (Op_Elmt) loop
Prim_Op := Node (Op_Elmt);
if Present (Alias (Prim_Op))
and then not Comes_From_Source (Prim_Op)
and then Is_Internal_Name (Chars (Prim_Op))
and then not Is_Internal_Name (Chars (Alias (Prim_Op)))
then
Parent_Subp := Alias (Prim_Op);
Found_Explicit := False;
Op_Elmt_2 := Next_Elmt (Op_Elmt);
while Present (Op_Elmt_2) loop
if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp)
and then Type_Conformant (Prim_Op, Node (Op_Elmt_2))
then
New_Op := Node (Op_Elmt_2);
Replace_Elmt (Op_Elmt, New_Op);
Remove_Elmt (Op_List, Op_Elmt_2);
Found_Explicit := True;
Decl_Privates := True;
if Explicit_Overriding
and then Comes_From_Source (New_Op)
and then not Has_Overriding_Pragma (New_Op)
then
Error_Msg_NE
("Missing overriding pragma for&",
New_Op, New_Op);
end if;
exit;
end if;
Next_Elmt (Op_Elmt_2);
end loop;
if not Found_Explicit then
Derive_Subprogram
(New_Op, Alias (Prim_Op), E, Etype (E));
pragma Assert
(Is_Dispatching_Operation (New_Op)
and then Node (Last_Elmt (Op_List)) = New_Op);
Replace_Elmt (Op_Elmt, New_Op);
Remove_Last_Elmt (Op_List);
Decl_Privates := True;
end if;
end if;
Next_Elmt (Op_Elmt);
end loop;
if Decl_Privates
and then Expander_Active
then
Set_All_DT_Position (E);
end if;
else
Prim_Op := Next_Entity (E);
while Present (Prim_Op) loop
if Is_Subprogram (Prim_Op)
and then Present (Alias (Prim_Op))
and then not Comes_From_Source (Prim_Op)
and then Is_Internal_Name (Chars (Prim_Op))
and then not Is_Internal_Name (Chars (Alias (Prim_Op)))
and then Is_Primitive_Of (E, Prim_Op)
then
Derive_Subprogram (New_Op, Alias (Prim_Op), E, Etype (E));
end if;
Next_Entity (Prim_Op);
end loop;
end if;
end if;
Next_Entity (E);
end loop;
end Declare_Inherited_Private_Subprograms;
procedure End_Package_Scope (P : Entity_Id) is
begin
Uninstall_Declarations (P);
Pop_Scope;
end End_Package_Scope;
procedure Exchange_Declarations (Id : Entity_Id) is
Full_Id : constant Entity_Id := Full_View (Id);
H1 : constant Entity_Id := Homonym (Id);
Next1 : constant Entity_Id := Next_Entity (Id);
H2 : Entity_Id;
Next2 : Entity_Id;
begin
if No (Full_Id) then
return;
end if;
Next2 := Next_Entity (Full_Id);
H2 := Homonym (Full_Id);
Exchange_Entities (Id, Full_Id);
Set_Next_Entity (Id, Next1);
Set_Homonym (Id, H1);
Set_Full_View (Full_Id, Id);
Set_Next_Entity (Full_Id, Next2);
Set_Homonym (Full_Id, H2);
end Exchange_Declarations;
procedure Install_Package_Entity (Id : Entity_Id) is
begin
if not Is_Internal (Id) then
if Debug_Flag_E then
Write_Str ("Install: ");
Write_Name (Chars (Id));
Write_Eol;
end if;
if not Is_Child_Unit (Id) then
Set_Is_Immediately_Visible (Id);
end if;
end if;
end Install_Package_Entity;
procedure Install_Private_Declarations (P : Entity_Id) is
Id : Entity_Id;
Priv_Elmt : Elmt_Id;
Priv : Entity_Id;
Full : Entity_Id;
begin
Id := First_Entity (P);
while Present (Id) and then Id /= First_Private_Entity (P) loop
if Is_Private_Base_Type (Id)
and then Comes_From_Source (Full_View (Id))
and then Present (Full_View (Id))
and then Scope (Full_View (Id)) = Scope (Id)
and then Ekind (Full_View (Id)) /= E_Incomplete_Type
then
Set_In_Use (Full_View (Id), In_Use (Id));
Full := Full_View (Id);
if Is_Private_Base_Type (Full)
and then Has_Private_Declaration (Full)
and then Nkind (Parent (Full)) = N_Full_Type_Declaration
and then In_Open_Scopes (Scope (Etype (Full)))
and then In_Package_Body (Current_Scope)
and then not Is_Private_Type (Etype (Full))
then
if No (Full_View (Full))
and then Present (Underlying_Full_View (Full))
then
Set_Full_View (Id, Underlying_Full_View (Full));
Set_Underlying_Full_View (Full, Empty);
Set_Is_Frozen (Full_View (Id));
end if;
end if;
Priv_Elmt := First_Elmt (Private_Dependents (Id));
Exchange_Declarations (Id);
Set_Is_Immediately_Visible (Id);
while Present (Priv_Elmt) loop
Priv := Node (Priv_Elmt);
if Present (Full_View (Priv))
and then Is_Visible_Dependent (Priv)
then
Replace_Elmt (Priv_Elmt, Full_View (Priv));
Exchange_Declarations (Priv);
Set_Is_Immediately_Visible
(Priv, In_Open_Scopes (Scope (Priv)));
Set_Is_Potentially_Use_Visible
(Priv, Is_Potentially_Use_Visible (Node (Priv_Elmt)));
end if;
Next_Elmt (Priv_Elmt);
end loop;
end if;
Next_Entity (Id);
end loop;
Id := First_Private_Entity (P);
while Present (Id) loop
Install_Package_Entity (Id);
Set_Is_Hidden (Id, False);
Next_Entity (Id);
end loop;
Set_In_Private_Part (P);
end Install_Private_Declarations;
procedure Install_Visible_Declarations (P : Entity_Id) is
Id : Entity_Id;
begin
Id := First_Entity (P);
while Present (Id) and then Id /= First_Private_Entity (P) loop
Install_Package_Entity (Id);
Next_Entity (Id);
end loop;
end Install_Visible_Declarations;
function Is_Private_Base_Type (E : Entity_Id) return Boolean is
begin
return Ekind (E) = E_Private_Type
or else Ekind (E) = E_Limited_Private_Type
or else Ekind (E) = E_Record_Type_With_Private;
end Is_Private_Base_Type;
function Is_Visible_Dependent (Dep : Entity_Id) return Boolean
is
S : constant Entity_Id := Scope (Dep);
begin
if Ekind (S) = E_Package
and then Is_Generic_Instance (S)
and then (Is_Generic_Actual_Type (Dep)
or else Is_Generic_Actual_Type (Full_View (Dep)))
then
return True;
elsif not (Is_Derived_Type (Dep))
and then Is_Derived_Type (Full_View (Dep))
then
return In_Open_Scopes (S)
or else (Is_Generic_Instance (Current_Scope)
and then Scope (Dep) = Scope (Current_Scope));
else
return True;
end if;
end Is_Visible_Dependent;
procedure May_Need_Implicit_Body (E : Entity_Id) is
P : constant Node_Id := Unit_Declaration_Node (E);
S : constant Node_Id := Parent (P);
B : Node_Id;
Decls : List_Id;
begin
if not Has_Completion (E)
and then Nkind (P) = N_Package_Declaration
and then Present (Activation_Chain_Entity (P))
then
B :=
Make_Package_Body (Sloc (E),
Defining_Unit_Name => Make_Defining_Identifier (Sloc (E),
Chars => Chars (E)),
Declarations => New_List);
if Nkind (S) = N_Package_Specification then
if Present (Private_Declarations (S)) then
Decls := Private_Declarations (S);
else
Decls := Visible_Declarations (S);
end if;
else
Decls := Declarations (S);
end if;
Append (B, Decls);
Analyze (B);
end if;
end May_Need_Implicit_Body;
procedure New_Private_Type (N : Node_Id; Id : Entity_Id; Def : Node_Id) is
begin
Enter_Name (Id);
if Limited_Present (Def) then
Set_Ekind (Id, E_Limited_Private_Type);
else
Set_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);
Set_Is_Constrained (Id,
No (Discriminant_Specifications (N))
and then not Unknown_Discriminants_Present (N));
Set_Is_Tagged_Type (Id, Tagged_Present (Def));
Set_Discriminant_Constraint (Id, No_Elist);
Set_Stored_Constraint (Id, No_Elist);
if Present (Discriminant_Specifications (N)) then
New_Scope (Id);
Process_Discriminants (N);
End_Scope;
elsif Unknown_Discriminants_Present (N) then
Set_Has_Unknown_Discriminants (Id);
end if;
Set_Private_Dependents (Id, New_Elmt_List);
if Tagged_Present (Def) then
Set_Ekind (Id, E_Record_Type_With_Private);
Make_Class_Wide_Type (Id);
Set_Primitive_Operations (Id, New_Elmt_List);
Set_Is_Abstract (Id, Abstract_Present (Def));
Set_Is_Limited_Record (Id, Limited_Present (Def));
Set_Has_Delayed_Freeze (Id, True);
elsif Abstract_Present (Def) then
Error_Msg_N ("only a tagged type can be abstract", N);
end if;
end New_Private_Type;
procedure Uninstall_Declarations (P : Entity_Id) is
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, Full : Entity_Id);
function Type_In_Use (T : Entity_Id) return Boolean;
procedure Preserve_Full_Attributes (Priv, Full : Entity_Id) is
Priv_Is_Base_Type : constant Boolean := Priv = Base_Type (Priv);
begin
Set_Size_Info (Priv, (Full));
Set_RM_Size (Priv, RM_Size (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));
if Referenced (Full) then
Set_Referenced (Priv);
end if;
if Priv_Is_Base_Type then
Set_Is_Controlled (Priv, Is_Controlled (Base_Type (Full)));
Set_Finalize_Storage_Only (Priv, Finalize_Storage_Only
(Base_Type (Full)));
Set_Has_Task (Priv, Has_Task (Base_Type (Full)));
Set_Has_Controlled_Component (Priv, Has_Controlled_Component
(Base_Type (Full)));
end if;
Set_Freeze_Node (Priv, Freeze_Node (Full));
if Is_Tagged_Type (Priv)
and then Is_Tagged_Type (Full)
and then not Error_Posted (Full)
then
if Priv_Is_Base_Type then
Set_Access_Disp_Table (Priv, Access_Disp_Table
(Base_Type (Full)));
end if;
Set_First_Entity (Priv, First_Entity (Full));
Set_Last_Entity (Priv, Last_Entity (Full));
Set_Has_Discriminants (Priv, Has_Discriminants (Full));
end if;
end Preserve_Full_Attributes;
function Type_In_Use (T : Entity_Id) return Boolean is
begin
return Scope (Base_Type (T)) = P
and then (In_Use (T) or else In_Use (Base_Type (T)));
end Type_In_Use;
begin
Id := First_Entity (P);
while Present (Id) and then Id /= First_Private_Entity (P) loop
if Debug_Flag_E then
Write_Str ("unlinking visible entity ");
Write_Int (Int (Id));
Write_Eol;
end if;
if Ekind (Id) = E_Function
and then Is_Operator_Symbol_Name (Chars (Id))
and then not Is_Hidden (Id)
and then not Error_Posted (Id)
then
Set_Is_Potentially_Use_Visible (Id,
In_Use (P)
or else Type_In_Use (Etype (Id))
or else Type_In_Use (Etype (First_Formal (Id)))
or else (Present (Next_Formal (First_Formal (Id)))
and then
Type_In_Use
(Etype (Next_Formal (First_Formal (Id))))));
else
Set_Is_Potentially_Use_Visible (Id,
In_Use (P) and not Is_Hidden (Id));
end if;
Set_Is_Immediately_Visible (Id, False);
if Is_Type (Id)
and then Present (Full_View (Id))
then
Set_Is_Immediately_Visible (Full_View (Id), False);
end if;
if Is_Tagged_Type (Id) and then Ekind (Id) = E_Record_Type then
Check_Abstract_Overriding (Id);
end if;
if (Ekind (Id) = E_Private_Type
or else Ekind (Id) = E_Limited_Private_Type)
and then No (Full_View (Id))
and then not Is_Generic_Type (Id)
and then not Is_Derived_Type (Id)
then
Error_Msg_N ("missing full declaration for private type&", Id);
elsif Ekind (Id) = E_Record_Type_With_Private
and then not Is_Generic_Type (Id)
and then No (Full_View (Id))
then
if Nkind (Parent (Id)) = N_Private_Type_Declaration then
Error_Msg_N ("missing full declaration for private type&", Id);
else
Error_Msg_N
("missing full declaration for private extension", Id);
end if;
elsif Ekind (Id) = E_Constant
and then No (Constant_Value (Id))
and then No (Full_View (Id))
and then not Is_Imported (Id)
and then (Nkind (Parent (Id)) /= N_Object_Declaration
or else not No_Initialization (Parent (Id)))
then
if not Has_Private_Declaration (Etype (Id)) then
Error_Msg_N
("constant declaration requires initialization expression",
Parent (Id));
if Is_Limited_Type (Etype (Id)) then
Error_Msg_N
("\else remove keyword CONSTANT from declaration",
Parent (Id));
end if;
else
Error_Msg_N
("missing full declaration for deferred constant ('R'M 7.4)",
Id);
if Is_Limited_Type (Etype (Id)) then
Error_Msg_N
("\else remove keyword CONSTANT from declaration",
Parent (Id));
end if;
end if;
end if;
Next_Entity (Id);
end loop;
if not In_Private_Part (P) then
return;
else
Set_In_Private_Part (P, False);
end if;
while Present (Id) loop
if Debug_Flag_E then
Write_Str ("unlinking private entity ");
Write_Int (Int (Id));
Write_Eol;
end if;
if Is_Tagged_Type (Id) and then Ekind (Id) = E_Record_Type then
Check_Abstract_Overriding (Id);
end if;
Set_Is_Immediately_Visible (Id, False);
if Is_Private_Base_Type (Id)
and then Present (Full_View (Id))
then
Full := Full_View (Id);
if No (Parent (Id))
or else List_Containing (Parent (Id))
/= Visible_Declarations (Specification (Decl))
then
goto Next_Id;
end if;
Preserve_Full_Attributes (Id, Full);
Set_Is_Potentially_Use_Visible (Id, In_Use (P));
if Is_Indefinite_Subtype (Full)
and then not Is_Indefinite_Subtype (Id)
then
Error_Msg_N
("full view of type must be definite subtype", Full);
end if;
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;
Exchange_Declarations (Id);
elsif Ekind (Id) = E_Incomplete_Type
and then No (Full_View (Id))
then
Set_Has_Completion_In_Body (Id);
elsif not Is_Child_Unit (Id)
and then (not Is_Private_Type (Id)
or else No (Full_View (Id)))
then
Set_Is_Hidden (Id);
Set_Is_Potentially_Use_Visible (Id, False);
end if;
<<Next_Id>>
Next_Entity (Id);
end loop;
end Uninstall_Declarations;
function Unit_Requires_Body (P : Entity_Id) return Boolean is
E : Entity_Id;
begin
if Is_Imported (P) then
return False;
elsif Has_Pragma_Elaborate_Body (P) then
return True;
elsif Is_Subprogram (P) or else Is_Generic_Subprogram (P) then
return True;
elsif Ekind (P) = E_Block then
return True;
elsif Ekind (P) = E_Package
and then Nkind (Parent (P)) = N_Package_Specification
and then Present (Generic_Parent (Parent (P)))
then
declare
G_P : constant Entity_Id := Generic_Parent (Parent (P));
begin
if Has_Pragma_Elaborate_Body (G_P) then
return True;
end if;
end;
end if;
E := First_Entity (P);
while Present (E) loop
if Is_Child_Unit (E) then
null;
elsif Ekind (E) = E_Package
and then Nkind (Original_Node (Unit_Declaration_Node (E))) =
N_Formal_Package_Declaration
then
null;
elsif (Is_Overloadable (E)
and then Ekind (E) /= E_Enumeration_Literal
and then Ekind (E) /= E_Operator
and then not Is_Abstract (E)
and then not Has_Completion (E))
or else
(Ekind (E) = E_Package
and then E /= P
and then not Has_Completion (E)
and then Unit_Requires_Body (E))
or else
(Ekind (E) = E_Incomplete_Type and then No (Full_View (E)))
or else
((Ekind (E) = E_Task_Type or else
Ekind (E) = E_Protected_Type)
and then not Has_Completion (E))
or else
(Ekind (E) = E_Generic_Package and then E /= P
and then not Has_Completion (E)
and then Unit_Requires_Body (E))
or else
(Is_Generic_Subprogram (E)
and then not Has_Completion (E))
then
return True;
else
null;
end if;
Next_Entity (E);
end loop;
return False;
end Unit_Requires_Body;
end Sem_Ch7;