* sem_res.adb (Resolve_Selected_Component): do not generate a discriminant check if the selected component is a component of the argument of an initialization procedure. * trans.c (tree_transform, case of arithmetic operators): If result type is private, the gnu_type is the base type of the full view, given that the full view itself may be a subtype. * sem_res.adb: Minor reformatting * trans.c (tree_transform, case N_Real_Literal): Add missing third parameter in call to Machine (unknown horrible effects from this omission). * urealp.h: Add definition of Round_Even for call to Machine Add third parameter for Machine * sem_warn.adb (Check_One_Unit): Suppress warnings completely on predefined units in No_Run_Time mode. * misc.c (insn-codes.h): Now include. * a-except.adb: Preparation work for future integration of the GCC 3 exception handling mechanism (Notify_Handled_Exception, Notify_Unhandled_Exception): New routines to factorize previous code sequences and make them externally callable, e.g. for the Ada personality routine when the GCC 3 mechanism is used. (Propagate_Exception, Raise_Current_Excep, Raise_From_Signal_Handler): Use the new notification routines. * prj-tree.ads (First_Choice_Of): Document the when others case * bindgen.adb (Gen_Ada_Init_*): Set priority of environment task in HI-E mode, in order to support Ravenscar profile properly. * cstand.adb (Create_Standard): Duration is a 32 bit type in HI-E mode on 32 bits targets. * fmap.adb: Initial version. * fmap.ads: Initial version. * fname-uf.adb (Get_File_Name): Use mapping if unit name mapped. If search is successfully done, add to mapping. * frontend.adb: Initialize the mapping if a -gnatem switch was used. * make.adb: (Gnatmake): Add new local variable Mapping_File_Name. Create mapping file when using project file(s). Delete mapping file before exiting. * opt.ads (Mapping_File_Name): New variable * osint.adb (Find_File): Use path name found in mapping, if any. * prj-env.adb (Create_Mapping_File): New procedure * prj-env.ads (Create_Mapping_File): New procedure. * switch.adb (Scan_Front_End_Switches): Add processing for -gnatem (Mapping_File) * usage.adb: Add entry for new switch -gnatem. * Makefile.in: Add dependencies for fmap.o. * sem_ch10.adb (Analyze_With_Clause): Retrieve proper entity when unit is a package instantiation rewritten as a package body. (Install_Withed_Unit): Undo previous change, now redundant. * layout.adb: (Compute_Length): Move conversion to Unsigned to callers. (Get_Max_Size): Convert Len expression to Unsigned after calls to Compute_Length and Determine_Range. (Layout_Array_Type): Convert Len expression to Unsigned after calls to Compute_Length and Determine_Range. Above changes fix problem with length computation for supernull arrays where Max (Len, 0) wasn't getting applied due to the Unsigned conversion used by Compute_Length. * rtsfind.ads: (OK_To_Use_In_No_Run_Time_Mode): Allow Ada.Exceptions and System.Secondary_Stack. (OK_To_Use_In_Ravenscar_Mode): New table needed to implement Ravenscar in HI-E mode. Remove unused entity RE_Exception_Data. * rtsfind.adb (RTE): Allow Ravenscar Profile in HI mode. * rident.ads (No_Secondary_Stack): New restriction. From-SVN: r48168
3074 lines
105 KiB
Ada
3074 lines
105 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- S E M _ C H 1 0 --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- $Revision$
|
|
-- --
|
|
-- Copyright (C) 1992-2001 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- --
|
|
-- ware Foundation; either version 2, or (at your option) any later ver- --
|
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
|
-- for more details. You should have received a copy of the GNU General --
|
|
-- Public License distributed with GNAT; see file COPYING. If not, write --
|
|
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
|
-- MA 02111-1307, USA. --
|
|
-- --
|
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
|
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
|
|
with Atree; use Atree;
|
|
with Debug; use Debug;
|
|
with Einfo; use Einfo;
|
|
with Errout; use Errout;
|
|
with Exp_Util; use Exp_Util;
|
|
with Fname; use Fname;
|
|
with Fname.UF; use Fname.UF;
|
|
with Freeze; use Freeze;
|
|
with Impunit; use Impunit;
|
|
with Inline; use Inline;
|
|
with Lib; use Lib;
|
|
with Lib.Load; use Lib.Load;
|
|
with Lib.Xref; use Lib.Xref;
|
|
with Namet; use Namet;
|
|
with Nlists; use Nlists;
|
|
with Nmake; use Nmake;
|
|
with Opt; use Opt;
|
|
with Output; use Output;
|
|
with Restrict; use Restrict;
|
|
with Sem; use Sem;
|
|
with Sem_Ch6; use Sem_Ch6;
|
|
with Sem_Ch7; use Sem_Ch7;
|
|
with Sem_Ch8; use Sem_Ch8;
|
|
with Sem_Dist; use Sem_Dist;
|
|
with Sem_Prag; use Sem_Prag;
|
|
with Sem_Util; use Sem_Util;
|
|
with Sem_Warn; use Sem_Warn;
|
|
with Stand; use Stand;
|
|
with Sinfo; use Sinfo;
|
|
with Sinfo.CN; use Sinfo.CN;
|
|
with Sinput; use Sinput;
|
|
with Snames; use Snames;
|
|
with Style; use Style;
|
|
with Tbuild; use Tbuild;
|
|
with Ttypes; use Ttypes;
|
|
with Uname; use Uname;
|
|
|
|
package body Sem_Ch10 is
|
|
|
|
-----------------------
|
|
-- Local Subprograms --
|
|
-----------------------
|
|
|
|
procedure Analyze_Context (N : Node_Id);
|
|
-- Analyzes items in the context clause of compilation unit
|
|
|
|
procedure Check_With_Type_Clauses (N : Node_Id);
|
|
-- If N is a body, verify that any with_type clauses on the spec, or
|
|
-- on the spec of any parent, have a matching with_clause.
|
|
|
|
procedure Check_Private_Child_Unit (N : Node_Id);
|
|
-- If a with_clause mentions a private child unit, the compilation
|
|
-- unit must be a member of the same family, as described in 10.1.2 (8).
|
|
|
|
procedure Check_Stub_Level (N : Node_Id);
|
|
-- Verify that a stub is declared immediately within a compilation unit,
|
|
-- and not in an inner frame.
|
|
|
|
procedure Expand_With_Clause (Nam : Node_Id; N : Node_Id);
|
|
-- When a child unit appears in a context clause, the implicit withs on
|
|
-- parents are made explicit, and with clauses are inserted in the context
|
|
-- clause before the one for the child. If a parent in the with_clause
|
|
-- is a renaming, the implicit with_clause is on the renaming whose name
|
|
-- is mentioned in the with_clause, and not on the package it renames.
|
|
-- N is the compilation unit whose list of context items receives the
|
|
-- implicit with_clauses.
|
|
|
|
procedure Implicit_With_On_Parent (Child_Unit : Node_Id; N : Node_Id);
|
|
-- If the main unit is a child unit, implicit withs are also added for
|
|
-- all its ancestors.
|
|
|
|
procedure Install_Context_Clauses (N : Node_Id);
|
|
-- Subsidiary to previous one. Process only with_ and use_clauses for
|
|
-- current unit and its library unit if any.
|
|
|
|
procedure Install_Withed_Unit (With_Clause : Node_Id);
|
|
-- If the unit is not a child unit, make unit immediately visible.
|
|
-- The caller ensures that the unit is not already currently installed.
|
|
|
|
procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean);
|
|
-- This procedure establishes the context for the compilation of a child
|
|
-- unit. If Lib_Unit is a child library spec then the context of the parent
|
|
-- is installed, and the parent itself made immediately visible, so that
|
|
-- the child unit is processed in the declarative region of the parent.
|
|
-- Install_Parents makes a recursive call to itself to ensure that all
|
|
-- parents are loaded in the nested case. If Lib_Unit is a library body,
|
|
-- the only effect of Install_Parents is to install the private decls of
|
|
-- the parents, because the visible parent declarations will have been
|
|
-- installed as part of the context of the corresponding spec.
|
|
|
|
procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id);
|
|
-- In the compilation of a child unit, a child of any of the ancestor
|
|
-- units is directly visible if it is visible, because the parent is in
|
|
-- an enclosing scope. Iterate over context to find child units of U_Name
|
|
-- or of some ancestor of it.
|
|
|
|
function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean;
|
|
-- Lib_Unit is a library unit which may be a spec or a body. Is_Child_Spec
|
|
-- returns True if Lib_Unit is a library spec which is a child spec, i.e.
|
|
-- a library spec that has a parent. If the call to Is_Child_Spec returns
|
|
-- 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.
|
|
|
|
procedure Remove_With_Type_Clause (Name : Node_Id);
|
|
-- Remove imported type and its enclosing package from visibility, and
|
|
-- remove attributes of imported type so they don't interfere with its
|
|
-- analysis (should it appear otherwise in the context).
|
|
|
|
procedure Remove_Context_Clauses (N : Node_Id);
|
|
-- Subsidiary of previous one. Remove use_ and with_clauses.
|
|
|
|
procedure Remove_Parents (Lib_Unit : Node_Id);
|
|
-- Remove_Parents checks if Lib_Unit is a child spec. If so then the parent
|
|
-- contexts established by the corresponding call to Install_Parents are
|
|
-- removed. Remove_Parents contains a recursive call to itself to ensure
|
|
-- that all parents are removed in the nested case.
|
|
|
|
procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id);
|
|
-- Reset all visibility flags on unit after compiling it, either as a
|
|
-- main unit or as a unit in the context.
|
|
|
|
procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id);
|
|
-- Common processing for all stubs (subprograms, tasks, packages, and
|
|
-- protected cases). N is the stub to be analyzed. Once the subunit
|
|
-- name is established, load and analyze. Nam is the non-overloadable
|
|
-- entity for which the proper body provides a completion. Subprogram
|
|
-- stubs are handled differently because they can be declarations.
|
|
|
|
------------------------------
|
|
-- Analyze_Compilation_Unit --
|
|
------------------------------
|
|
|
|
procedure Analyze_Compilation_Unit (N : Node_Id) is
|
|
Unit_Node : constant Node_Id := Unit (N);
|
|
Lib_Unit : Node_Id := Library_Unit (N);
|
|
Spec_Id : Node_Id;
|
|
Main_Cunit : constant Node_Id := Cunit (Main_Unit);
|
|
Par_Spec_Name : Unit_Name_Type;
|
|
Unum : Unit_Number_Type;
|
|
|
|
procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id);
|
|
-- Generate cross-reference information for the parents of child units.
|
|
-- N is a defining_program_unit_name, and P_Id is the immediate parent.
|
|
|
|
--------------------------------
|
|
-- Generate_Parent_References --
|
|
--------------------------------
|
|
|
|
procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id) is
|
|
Pref : Node_Id;
|
|
P_Name : Entity_Id := P_Id;
|
|
|
|
begin
|
|
Pref := Name (Parent (Defining_Entity (N)));
|
|
|
|
if Nkind (Pref) = N_Expanded_Name then
|
|
|
|
-- Done already, if the unit has been compiled indirectly as
|
|
-- part of the closure of its context because of inlining.
|
|
|
|
return;
|
|
end if;
|
|
|
|
while Nkind (Pref) = N_Selected_Component loop
|
|
Change_Selected_Component_To_Expanded_Name (Pref);
|
|
Set_Entity (Pref, P_Name);
|
|
Set_Etype (Pref, Etype (P_Name));
|
|
Generate_Reference (P_Name, Pref, 'r');
|
|
Pref := Prefix (Pref);
|
|
P_Name := Scope (P_Name);
|
|
end loop;
|
|
|
|
-- The guard here on P_Name is to handle the error condition where
|
|
-- the parent unit is missing because the file was not found.
|
|
|
|
if Present (P_Name) then
|
|
Set_Entity (Pref, P_Name);
|
|
Set_Etype (Pref, Etype (P_Name));
|
|
Generate_Reference (P_Name, Pref, 'r');
|
|
Style.Check_Identifier (Pref, P_Name);
|
|
end if;
|
|
end Generate_Parent_References;
|
|
|
|
-- Start of processing for Analyze_Compilation_Unit
|
|
|
|
begin
|
|
Process_Compilation_Unit_Pragmas (N);
|
|
|
|
-- If the unit is a subunit whose parent has not been analyzed (which
|
|
-- indicates that the main unit is a subunit, either the current one or
|
|
-- one of its descendents) then the subunit is compiled as part of the
|
|
-- analysis of the parent, which we proceed to do. Basically this gets
|
|
-- handled from the top down and we don't want to do anything at this
|
|
-- level (i.e. this subunit will be handled on the way down from the
|
|
-- parent), so at this level we immediately return. If the subunit
|
|
-- ends up not analyzed, it means that the parent did not contain a
|
|
-- stub for it, or that there errors were dectected in some ancestor.
|
|
|
|
if Nkind (Unit_Node) = N_Subunit
|
|
and then not Analyzed (Lib_Unit)
|
|
then
|
|
Semantics (Lib_Unit);
|
|
|
|
if not Analyzed (Proper_Body (Unit_Node)) then
|
|
if Errors_Detected > 0 then
|
|
Error_Msg_N ("subunit not analyzed (errors in parent unit)", N);
|
|
else
|
|
Error_Msg_N ("missing stub for subunit", N);
|
|
end if;
|
|
end if;
|
|
|
|
return;
|
|
end if;
|
|
|
|
-- Analyze context (this will call Sem recursively for with'ed units)
|
|
|
|
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 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
|
|
return;
|
|
|
|
else
|
|
Semantics (Lib_Unit);
|
|
Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit));
|
|
|
|
-- Verify that the library unit is a package declaration.
|
|
|
|
if Nkind (Unit (Lib_Unit)) /= N_Package_Declaration
|
|
and then
|
|
Nkind (Unit (Lib_Unit)) /= N_Generic_Package_Declaration
|
|
then
|
|
Error_Msg_N
|
|
("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.
|
|
|
|
else
|
|
Spec_Id := Defining_Entity (Unit (Lib_Unit));
|
|
Set_Is_Immediately_Visible (Spec_Id, True);
|
|
Version_Update (N, Lib_Unit);
|
|
|
|
if Nkind (Defining_Unit_Name (Unit_Node))
|
|
= N_Defining_Program_Unit_Name
|
|
then
|
|
Generate_Parent_References (Unit_Node, Scope (Spec_Id));
|
|
end if;
|
|
end if;
|
|
end if;
|
|
|
|
-- If the unit is a subprogram body, then we similarly need to analyze
|
|
-- its spec. However, things are a little simpler in this case, because
|
|
-- here, this analysis is done only for error checking and consistency
|
|
-- purposes, so there's nothing else to be done.
|
|
|
|
elsif Nkind (Unit_Node) = N_Subprogram_Body then
|
|
if Acts_As_Spec (N) then
|
|
|
|
-- If the subprogram body is a child unit, we must create a
|
|
-- declaration for it, in order to properly load the parent(s).
|
|
-- After this, the original unit does not acts as a spec, because
|
|
-- there is an explicit one. If this unit appears in a context
|
|
-- clause, then an implicit with on the parent will be added when
|
|
-- installing the context. If this is the main unit, there is no
|
|
-- Unit_Table entry for the declaration, (It has the unit number
|
|
-- of the main unit) and code generation is unaffected.
|
|
|
|
Unum := Get_Cunit_Unit_Number (N);
|
|
Par_Spec_Name := Get_Parent_Spec_Name (Unit_Name (Unum));
|
|
|
|
if Par_Spec_Name /= No_Name then
|
|
Unum :=
|
|
Load_Unit
|
|
(Load_Name => Par_Spec_Name,
|
|
Required => True,
|
|
Subunit => False,
|
|
Error_Node => N);
|
|
|
|
if Unum /= No_Unit then
|
|
|
|
-- Build subprogram declaration and attach parent unit to it
|
|
-- This subprogram declaration does not come from source!
|
|
|
|
declare
|
|
Loc : constant Source_Ptr := Sloc (N);
|
|
SCS : constant Boolean :=
|
|
Get_Comes_From_Source_Default;
|
|
|
|
begin
|
|
Set_Comes_From_Source_Default (False);
|
|
Lib_Unit :=
|
|
Make_Compilation_Unit (Loc,
|
|
Context_Items => New_Copy_List (Context_Items (N)),
|
|
Unit =>
|
|
Make_Subprogram_Declaration (Sloc (N),
|
|
Specification =>
|
|
Copy_Separate_Tree
|
|
(Specification (Unit_Node))),
|
|
Aux_Decls_Node =>
|
|
Make_Compilation_Unit_Aux (Loc));
|
|
|
|
Set_Library_Unit (N, Lib_Unit);
|
|
Set_Parent_Spec (Unit (Lib_Unit), Cunit (Unum));
|
|
Semantics (Lib_Unit);
|
|
Set_Acts_As_Spec (N, False);
|
|
Set_Comes_From_Source_Default (SCS);
|
|
end;
|
|
end if;
|
|
end if;
|
|
|
|
-- Here for subprogram with separate declaration
|
|
|
|
else
|
|
Semantics (Lib_Unit);
|
|
Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit));
|
|
Version_Update (N, Lib_Unit);
|
|
end if;
|
|
|
|
if Nkind (Defining_Unit_Name (Specification (Unit_Node))) =
|
|
N_Defining_Program_Unit_Name
|
|
then
|
|
Generate_Parent_References (
|
|
Specification (Unit_Node),
|
|
Scope (Defining_Entity (Unit (Lib_Unit))));
|
|
end if;
|
|
end if;
|
|
|
|
-- If it is a child unit, the parent must be elaborated first
|
|
-- and we update version, since we are dependent on our parent.
|
|
|
|
if Is_Child_Spec (Unit_Node) then
|
|
|
|
-- The analysis of the parent is done with style checks off
|
|
|
|
declare
|
|
Save_Style_Check : constant Boolean := Opt.Style_Check;
|
|
Save_C_Restrict : constant Save_Compilation_Unit_Restrictions :=
|
|
Compilation_Unit_Restrictions_Save;
|
|
|
|
begin
|
|
if not GNAT_Mode then
|
|
Style_Check := False;
|
|
end if;
|
|
|
|
Semantics (Parent_Spec (Unit_Node));
|
|
Version_Update (N, Parent_Spec (Unit_Node));
|
|
Style_Check := Save_Style_Check;
|
|
Compilation_Unit_Restrictions_Restore (Save_C_Restrict);
|
|
end;
|
|
end if;
|
|
|
|
-- With the analysis done, install the context. Note that we can't
|
|
-- install the context from the with clauses as we analyze them,
|
|
-- because each with clause must be analyzed in a clean visibility
|
|
-- context, so we have to wait and install them all at once.
|
|
|
|
Install_Context (N);
|
|
|
|
if Is_Child_Spec (Unit_Node) then
|
|
|
|
-- Set the entities of all parents in the program_unit_name.
|
|
|
|
Generate_Parent_References (
|
|
Unit_Node, Defining_Entity (Unit (Parent_Spec (Unit_Node))));
|
|
end if;
|
|
|
|
-- All components of the context: with-clauses, library unit, ancestors
|
|
-- if any, (and their context) are analyzed and installed. Now analyze
|
|
-- the unit itself, which is either a package, subprogram spec or body.
|
|
|
|
Analyze (Unit_Node);
|
|
|
|
-- The above call might have made Unit_Node an N_Subprogram_Body
|
|
-- from something else, so propagate any Acts_As_Spec flag.
|
|
|
|
if Nkind (Unit_Node) = N_Subprogram_Body
|
|
and then Acts_As_Spec (Unit_Node)
|
|
then
|
|
Set_Acts_As_Spec (N);
|
|
end if;
|
|
|
|
-- Treat compilation unit pragmas that appear after the library unit
|
|
|
|
if Present (Pragmas_After (Aux_Decls_Node (N))) then
|
|
declare
|
|
Prag_Node : Node_Id := First (Pragmas_After (Aux_Decls_Node (N)));
|
|
|
|
begin
|
|
while Present (Prag_Node) loop
|
|
Analyze (Prag_Node);
|
|
Next (Prag_Node);
|
|
end loop;
|
|
end;
|
|
end if;
|
|
|
|
-- Generate distribution stub files if requested and no error
|
|
|
|
if N = Main_Cunit
|
|
and then (Distribution_Stub_Mode = Generate_Receiver_Stub_Body
|
|
or else
|
|
Distribution_Stub_Mode = Generate_Caller_Stub_Body)
|
|
and then not Fatal_Error (Main_Unit)
|
|
then
|
|
if Is_RCI_Pkg_Spec_Or_Body (N) then
|
|
|
|
-- Regular RCI package
|
|
|
|
Add_Stub_Constructs (N);
|
|
|
|
elsif (Nkind (Unit_Node) = N_Package_Declaration
|
|
and then Is_Shared_Passive (Defining_Entity
|
|
(Specification (Unit_Node))))
|
|
or else (Nkind (Unit_Node) = N_Package_Body
|
|
and then
|
|
Is_Shared_Passive (Corresponding_Spec (Unit_Node)))
|
|
then
|
|
-- Shared passive package
|
|
|
|
Add_Stub_Constructs (N);
|
|
|
|
elsif Nkind (Unit_Node) = N_Package_Instantiation
|
|
and then
|
|
Is_Remote_Call_Interface
|
|
(Defining_Entity (Specification (Instance_Spec (Unit_Node))))
|
|
then
|
|
-- Instantiation of a RCI generic package
|
|
|
|
Add_Stub_Constructs (N);
|
|
end if;
|
|
|
|
-- Reanalyze the unit with the new constructs
|
|
|
|
Analyze (Unit_Node);
|
|
end if;
|
|
|
|
if Nkind (Unit_Node) = N_Package_Declaration
|
|
or else Nkind (Unit_Node) in N_Generic_Declaration
|
|
or else Nkind (Unit_Node) = N_Package_Renaming_Declaration
|
|
or else Nkind (Unit_Node) = N_Subprogram_Declaration
|
|
then
|
|
Remove_Unit_From_Visibility (Defining_Entity (Unit_Node));
|
|
|
|
elsif Nkind (Unit_Node) = N_Package_Body
|
|
or else (Nkind (Unit_Node) = N_Subprogram_Body
|
|
and then not Acts_As_Spec (Unit_Node))
|
|
then
|
|
-- Bodies that are not the main unit are compiled if they
|
|
-- are generic or contain generic or inlined units. Their
|
|
-- analysis brings in the context of the corresponding spec
|
|
-- (unit declaration) which must be removed as well, to
|
|
-- return the compilation environment to its proper state.
|
|
|
|
Remove_Context (Lib_Unit);
|
|
Set_Is_Immediately_Visible (Defining_Entity (Unit (Lib_Unit)), False);
|
|
end if;
|
|
|
|
-- Last step is to deinstall the context we just installed
|
|
-- as well as the unit just compiled.
|
|
|
|
Remove_Context (N);
|
|
|
|
-- If this is the main unit and we are generating code, we must
|
|
-- check that all generic units in the context have a body if they
|
|
-- need it, even if they have not been instantiated. In the absence
|
|
-- of .ali files for generic units, we must force the load of the body,
|
|
-- just to produce the proper error if the body is absent. We skip this
|
|
-- verification if the main unit itself is generic.
|
|
|
|
if Get_Cunit_Unit_Number (N) = Main_Unit
|
|
and then Operating_Mode = Generate_Code
|
|
and then Expander_Active
|
|
then
|
|
-- Indicate that the main unit is now analyzed, to catch possible
|
|
-- circularities between it and generic bodies. Remove main unit
|
|
-- from visibility. This might seem superfluous, but the main unit
|
|
-- must not be visible in the generic body expansions that follow.
|
|
|
|
Set_Analyzed (N, True);
|
|
Set_Is_Immediately_Visible (Cunit_Entity (Main_Unit), False);
|
|
|
|
declare
|
|
Item : Node_Id;
|
|
Nam : Entity_Id;
|
|
Un : Unit_Number_Type;
|
|
|
|
Save_Style_Check : constant Boolean := Opt.Style_Check;
|
|
Save_C_Restrict : constant Save_Compilation_Unit_Restrictions :=
|
|
Compilation_Unit_Restrictions_Save;
|
|
|
|
begin
|
|
Item := First (Context_Items (N));
|
|
|
|
while Present (Item) loop
|
|
|
|
if Nkind (Item) = N_With_Clause
|
|
and then not Implicit_With (Item)
|
|
then
|
|
Nam := Entity (Name (Item));
|
|
|
|
if (Ekind (Nam) = E_Generic_Procedure
|
|
and then not Is_Intrinsic_Subprogram (Nam))
|
|
or else (Ekind (Nam) = E_Generic_Function
|
|
and then not Is_Intrinsic_Subprogram (Nam))
|
|
or else (Ekind (Nam) = E_Generic_Package
|
|
and then Unit_Requires_Body (Nam))
|
|
then
|
|
Opt.Style_Check := False;
|
|
|
|
if Present (Renamed_Object (Nam)) then
|
|
Un :=
|
|
Load_Unit
|
|
(Load_Name => Get_Body_Name
|
|
(Get_Unit_Name
|
|
(Unit_Declaration_Node
|
|
(Renamed_Object (Nam)))),
|
|
Required => False,
|
|
Subunit => False,
|
|
Error_Node => N,
|
|
Renamings => True);
|
|
else
|
|
Un :=
|
|
Load_Unit
|
|
(Load_Name => Get_Body_Name
|
|
(Get_Unit_Name (Item)),
|
|
Required => False,
|
|
Subunit => False,
|
|
Error_Node => N,
|
|
Renamings => True);
|
|
end if;
|
|
|
|
if Un = No_Unit then
|
|
Error_Msg_NE
|
|
("body of generic unit& not found", Item, Nam);
|
|
exit;
|
|
|
|
elsif not Analyzed (Cunit (Un))
|
|
and then Un /= Main_Unit
|
|
then
|
|
Opt.Style_Check := False;
|
|
Semantics (Cunit (Un));
|
|
end if;
|
|
end if;
|
|
end if;
|
|
|
|
Next (Item);
|
|
end loop;
|
|
|
|
Style_Check := Save_Style_Check;
|
|
Compilation_Unit_Restrictions_Restore (Save_C_Restrict);
|
|
end;
|
|
end if;
|
|
|
|
-- Deal with creating elaboration Boolean if needed. We create an
|
|
-- elaboration boolean only for units that come from source since
|
|
-- units manufactured by the compiler never need elab checks.
|
|
|
|
if Comes_From_Source (N)
|
|
and then
|
|
(Nkind (Unit (N)) = N_Package_Declaration or else
|
|
Nkind (Unit (N)) = N_Generic_Package_Declaration or else
|
|
Nkind (Unit (N)) = N_Subprogram_Declaration or else
|
|
Nkind (Unit (N)) = N_Generic_Subprogram_Declaration)
|
|
then
|
|
declare
|
|
Loc : constant Source_Ptr := Sloc (N);
|
|
Unum : constant Unit_Number_Type := Get_Source_Unit (Loc);
|
|
|
|
begin
|
|
Spec_Id := Defining_Entity (Unit (N));
|
|
Generate_Definition (Spec_Id);
|
|
|
|
-- See if an elaboration entity is required for possible
|
|
-- access before elaboration checking. Note that we must
|
|
-- allow for this even if -gnatE is not set, since a client
|
|
-- may be compiled in -gnatE mode and reference the entity.
|
|
|
|
-- Case of units which do not require elaboration checks
|
|
|
|
if
|
|
-- Pure units do not need checks
|
|
|
|
Is_Pure (Spec_Id)
|
|
|
|
-- Preelaborated units do not need checks
|
|
|
|
or else Is_Preelaborated (Spec_Id)
|
|
|
|
-- No checks needed if pagma Elaborate_Body present
|
|
|
|
or else Has_Pragma_Elaborate_Body (Spec_Id)
|
|
|
|
-- No checks needed if unit does not require a body
|
|
|
|
or else not Unit_Requires_Body (Spec_Id)
|
|
|
|
-- No checks needed for predefined files
|
|
|
|
or else Is_Predefined_File_Name (Unit_File_Name (Unum))
|
|
|
|
-- No checks required if no separate spec
|
|
|
|
or else Acts_As_Spec (N)
|
|
then
|
|
-- This is a case where we only need the entity for
|
|
-- checking to prevent multiple elaboration checks.
|
|
|
|
Set_Elaboration_Entity_Required (Spec_Id, False);
|
|
|
|
-- Case of elaboration entity is required for access before
|
|
-- elaboration checking (so certainly we must build it!)
|
|
|
|
else
|
|
Set_Elaboration_Entity_Required (Spec_Id, True);
|
|
end if;
|
|
|
|
Build_Elaboration_Entity (N, Spec_Id);
|
|
end;
|
|
end if;
|
|
|
|
-- Finally, freeze the compilation unit entity. This for sure is needed
|
|
-- because of some warnings that can be output (see Freeze_Subprogram),
|
|
-- but may in general be required. If freezing actions result, place
|
|
-- them in the compilation unit actions list, and analyze them.
|
|
|
|
declare
|
|
Loc : constant Source_Ptr := Sloc (N);
|
|
L : constant List_Id :=
|
|
Freeze_Entity (Cunit_Entity (Current_Sem_Unit), Loc);
|
|
|
|
begin
|
|
while Is_Non_Empty_List (L) loop
|
|
Insert_Library_Level_Action (Remove_Head (L));
|
|
end loop;
|
|
end;
|
|
|
|
Set_Analyzed (N);
|
|
|
|
if Nkind (Unit_Node) = N_Package_Declaration
|
|
and then Get_Cunit_Unit_Number (N) /= Main_Unit
|
|
and then Front_End_Inlining
|
|
and then Expander_Active
|
|
then
|
|
Check_Body_For_Inlining (N, Defining_Entity (Unit_Node));
|
|
end if;
|
|
end Analyze_Compilation_Unit;
|
|
|
|
---------------------
|
|
-- Analyze_Context --
|
|
---------------------
|
|
|
|
procedure Analyze_Context (N : Node_Id) is
|
|
Item : Node_Id;
|
|
|
|
begin
|
|
-- Loop through context items
|
|
|
|
Item := First (Context_Items (N));
|
|
while Present (Item) loop
|
|
|
|
-- For with clause, analyze the with clause, and then update
|
|
-- the version, since we are dependent on a unit that we with.
|
|
|
|
if Nkind (Item) = N_With_Clause then
|
|
|
|
-- Skip analyzing with clause if no unit, nothing to do (this
|
|
-- happens for a with that references a non-existent unit)
|
|
|
|
if Present (Library_Unit (Item)) then
|
|
Analyze (Item);
|
|
end if;
|
|
|
|
if not Implicit_With (Item) then
|
|
Version_Update (N, Library_Unit (Item));
|
|
end if;
|
|
|
|
-- But skip use clauses at this stage, since we don't want to do
|
|
-- any installing of potentially use visible entities until we
|
|
-- we actually install the complete context (in Install_Context).
|
|
-- Otherwise things can get installed in the wrong context.
|
|
-- Similarly, pragmas are analyzed in Install_Context, after all
|
|
-- the implicit with's on parent units are generated.
|
|
|
|
else
|
|
null;
|
|
end if;
|
|
|
|
Next (Item);
|
|
end loop;
|
|
end Analyze_Context;
|
|
|
|
-------------------------------
|
|
-- Analyze_Package_Body_Stub --
|
|
-------------------------------
|
|
|
|
procedure Analyze_Package_Body_Stub (N : Node_Id) is
|
|
Id : constant Entity_Id := Defining_Identifier (N);
|
|
Nam : Entity_Id;
|
|
|
|
begin
|
|
-- The package declaration must be in the current declarative part.
|
|
|
|
Check_Stub_Level (N);
|
|
Nam := Current_Entity_In_Scope (Id);
|
|
|
|
if No (Nam) or else not Is_Package (Nam) then
|
|
Error_Msg_N ("missing specification for package stub", N);
|
|
|
|
elsif Has_Completion (Nam)
|
|
and then Present (Corresponding_Body (Unit_Declaration_Node (Nam)))
|
|
then
|
|
Error_Msg_N ("duplicate or redundant stub for package", N);
|
|
|
|
else
|
|
-- Indicate that the body of the package exists. If we are doing
|
|
-- only semantic analysis, the stub stands for the body. If we are
|
|
-- generating code, the existence of the body will be confirmed
|
|
-- when we load the proper body.
|
|
|
|
Set_Has_Completion (Nam);
|
|
Set_Scope (Defining_Entity (N), Current_Scope);
|
|
Analyze_Proper_Body (N, Nam);
|
|
end if;
|
|
end Analyze_Package_Body_Stub;
|
|
|
|
-------------------------
|
|
-- Analyze_Proper_Body --
|
|
-------------------------
|
|
|
|
procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id) is
|
|
Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N);
|
|
Unum : Unit_Number_Type;
|
|
Subunit_Not_Found : Boolean := False;
|
|
|
|
procedure Optional_Subunit;
|
|
-- This procedure is called when the main unit is a stub, or when we
|
|
-- are not generating code. In such a case, we analyze the subunit if
|
|
-- present, which is user-friendly and in fact required for ASIS, but
|
|
-- we don't complain if the subunit is missing.
|
|
|
|
----------------------
|
|
-- Optional_Subunit --
|
|
----------------------
|
|
|
|
procedure Optional_Subunit is
|
|
Comp_Unit : Node_Id;
|
|
|
|
begin
|
|
-- Try to load subunit, but ignore any errors that occur during
|
|
-- the loading of the subunit, by using the special feature in
|
|
-- Errout to ignore all errors. Note that Fatal_Error will still
|
|
-- be set, so we will be able to check for this case below.
|
|
|
|
Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
|
|
Unum :=
|
|
Load_Unit
|
|
(Load_Name => Subunit_Name,
|
|
Required => False,
|
|
Subunit => True,
|
|
Error_Node => N);
|
|
Ignore_Errors_Enable := Ignore_Errors_Enable - 1;
|
|
|
|
-- All done if we successfully loaded the subunit
|
|
|
|
if Unum /= No_Unit and then not Fatal_Error (Unum) then
|
|
Comp_Unit := Cunit (Unum);
|
|
|
|
Set_Corresponding_Stub (Unit (Comp_Unit), N);
|
|
Analyze_Subunit (Comp_Unit);
|
|
Set_Library_Unit (N, Comp_Unit);
|
|
|
|
elsif Unum = No_Unit
|
|
and then Present (Nam)
|
|
then
|
|
if Is_Protected_Type (Nam) then
|
|
Set_Corresponding_Body (Parent (Nam), Defining_Identifier (N));
|
|
else
|
|
Set_Corresponding_Body (
|
|
Unit_Declaration_Node (Nam), Defining_Identifier (N));
|
|
end if;
|
|
end if;
|
|
end Optional_Subunit;
|
|
|
|
-- 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 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 Present (Library_Unit (N)) then
|
|
Set_Corresponding_Stub (Unit (Library_Unit (N)), N);
|
|
Analyze_Subunit (Library_Unit (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.
|
|
|
|
Unum :=
|
|
Load_Unit
|
|
(Load_Name => Subunit_Name,
|
|
Required => True,
|
|
Subunit => False,
|
|
Error_Node => N);
|
|
|
|
-- And analyze the subunit in the parent context (note that we
|
|
-- do not call Semantics, since that would remove the parent
|
|
-- context). Because of this, we have to manually reset the
|
|
-- compiler state to Analyzing since it got destroyed by Load.
|
|
|
|
if Unum /= No_Unit then
|
|
Compiler_State := Analyzing;
|
|
Set_Corresponding_Stub (Unit (Cunit (Unum)), N);
|
|
Analyze_Subunit (Cunit (Unum));
|
|
Set_Library_Unit (N, Cunit (Unum));
|
|
end if;
|
|
end if;
|
|
|
|
-- If the main unit is a subunit, then we are just performing semantic
|
|
-- analysis on that subunit, and any other subunits of any parent unit
|
|
-- should be ignored, except that if we are building trees for ASIS
|
|
-- usage we want to annotate the stub properly.
|
|
|
|
elsif Nkind (Unit (Cunit (Main_Unit))) = N_Subunit
|
|
and then Subunit_Name /= Unit_Name (Main_Unit)
|
|
then
|
|
if Tree_Output then
|
|
Optional_Subunit;
|
|
end if;
|
|
|
|
-- But before we return, set the flag for unloaded subunits. This
|
|
-- will suppress junk warnings of variables in the same declarative
|
|
-- part (or a higher level one) that are in danger of looking unused
|
|
-- when in fact there might be a declaration in the subunit that we
|
|
-- do not intend to load.
|
|
|
|
Unloaded_Subunits := True;
|
|
return;
|
|
|
|
-- If the subunit is not already loaded, and we are generating code,
|
|
-- then this is the case where compilation started from the parent,
|
|
-- and we are generating code for an entire subunit tree. In that
|
|
-- case we definitely need to load the subunit.
|
|
|
|
-- In order to continue the analysis with the rest of the parent,
|
|
-- and other subunits, we load the unit without requiring its
|
|
-- presence, and emit a warning if not found, rather than terminating
|
|
-- the compilation abruptly, as for other missing file problems.
|
|
|
|
elsif Operating_Mode = Generate_Code then
|
|
|
|
-- If the proper body is already linked to the stub node,
|
|
-- the stub is in a generic unit and just needs analyzing.
|
|
|
|
-- We update the version. Although we are not technically
|
|
-- semantically dependent on the subunit, given our approach
|
|
-- of macro substitution of subunits, it makes sense to
|
|
-- include it in the version identification.
|
|
|
|
if Present (Library_Unit (N)) then
|
|
Set_Corresponding_Stub (Unit (Library_Unit (N)), N);
|
|
Analyze_Subunit (Library_Unit (N));
|
|
Version_Update (Cunit (Main_Unit), Library_Unit (N));
|
|
|
|
-- Otherwise we must load the subunit and link to it
|
|
|
|
else
|
|
Unum :=
|
|
Load_Unit
|
|
(Load_Name => Subunit_Name,
|
|
Required => False,
|
|
Subunit => True,
|
|
Error_Node => N);
|
|
|
|
if Operating_Mode = Generate_Code
|
|
and then Unum = No_Unit
|
|
then
|
|
Error_Msg_Name_1 := Subunit_Name;
|
|
Error_Msg_Name_2 :=
|
|
Get_File_Name (Subunit_Name, Subunit => True);
|
|
Error_Msg_N
|
|
("subunit% in file{ not found!?", N);
|
|
Subunits_Missing := True;
|
|
Subunit_Not_Found := True;
|
|
end if;
|
|
|
|
-- Load_Unit may reset Compiler_State, since it may have been
|
|
-- necessary to parse an additional units, so we make sure
|
|
-- that we reset it to the Analyzing state.
|
|
|
|
Compiler_State := Analyzing;
|
|
|
|
if Unum /= No_Unit and then not Fatal_Error (Unum) then
|
|
|
|
if Debug_Flag_L then
|
|
Write_Str ("*** Loaded subunit from stub. Analyze");
|
|
Write_Eol;
|
|
end if;
|
|
|
|
declare
|
|
Comp_Unit : constant Node_Id := Cunit (Unum);
|
|
|
|
begin
|
|
-- Check for child unit instead of subunit
|
|
|
|
if Nkind (Unit (Comp_Unit)) /= N_Subunit then
|
|
Error_Msg_N
|
|
("expected SEPARATE subunit, found child unit",
|
|
Cunit_Entity (Unum));
|
|
|
|
-- OK, we have a subunit, so go ahead and analyze it,
|
|
-- and set Scope of entity in stub, for ASIS use.
|
|
|
|
else
|
|
Set_Corresponding_Stub (Unit (Comp_Unit), N);
|
|
Analyze_Subunit (Comp_Unit);
|
|
Set_Library_Unit (N, Comp_Unit);
|
|
|
|
-- We update the version. Although we are not technically
|
|
-- semantically dependent on the subunit, given our
|
|
-- approach of macro substitution of subunits, it makes
|
|
-- sense to include it in the version identification.
|
|
|
|
Version_Update (Cunit (Main_Unit), Comp_Unit);
|
|
end if;
|
|
end;
|
|
end if;
|
|
end if;
|
|
|
|
-- The remaining case is when the subunit is not already loaded and
|
|
-- we are not generating code. In this case we are just performing
|
|
-- semantic analysis on the parent, and we are not interested in
|
|
-- the subunit. For subprograms, analyze the stub as a body. For
|
|
-- other entities the stub has already been marked as completed.
|
|
|
|
else
|
|
Optional_Subunit;
|
|
end if;
|
|
|
|
end Analyze_Proper_Body;
|
|
|
|
----------------------------------
|
|
-- Analyze_Protected_Body_Stub --
|
|
----------------------------------
|
|
|
|
procedure Analyze_Protected_Body_Stub (N : Node_Id) is
|
|
Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N));
|
|
|
|
begin
|
|
Check_Stub_Level (N);
|
|
|
|
-- First occurrence of name may have been as an incomplete type.
|
|
|
|
if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then
|
|
Nam := Full_View (Nam);
|
|
end if;
|
|
|
|
if No (Nam)
|
|
or else not Is_Protected_Type (Etype (Nam))
|
|
then
|
|
Error_Msg_N ("missing specification for Protected body", N);
|
|
else
|
|
Set_Scope (Defining_Entity (N), Current_Scope);
|
|
Set_Has_Completion (Etype (Nam));
|
|
Analyze_Proper_Body (N, Etype (Nam));
|
|
end if;
|
|
end Analyze_Protected_Body_Stub;
|
|
|
|
----------------------------------
|
|
-- 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.
|
|
|
|
procedure Analyze_Subprogram_Body_Stub (N : Node_Id) is
|
|
Decl : Node_Id;
|
|
|
|
begin
|
|
Check_Stub_Level (N);
|
|
|
|
-- Verify that the identifier for the stub is unique within this
|
|
-- declarative part.
|
|
|
|
if Nkind (Parent (N)) = N_Block_Statement
|
|
or else Nkind (Parent (N)) = N_Package_Body
|
|
or else Nkind (Parent (N)) = N_Subprogram_Body
|
|
then
|
|
Decl := First (Declarations (Parent (N)));
|
|
|
|
while Present (Decl)
|
|
and then Decl /= N
|
|
loop
|
|
if Nkind (Decl) = N_Subprogram_Body_Stub
|
|
and then (Chars (Defining_Unit_Name (Specification (Decl)))
|
|
= Chars (Defining_Unit_Name (Specification (N))))
|
|
then
|
|
Error_Msg_N ("identifier for stub is not unique", N);
|
|
end if;
|
|
|
|
Next (Decl);
|
|
end loop;
|
|
end if;
|
|
|
|
-- Treat stub as a body, which checks conformance if there is a previous
|
|
-- declaration, or else introduces entity and its signature.
|
|
|
|
Analyze_Subprogram_Body (N);
|
|
|
|
if Errors_Detected = 0 then
|
|
Analyze_Proper_Body (N, Empty);
|
|
end if;
|
|
|
|
end Analyze_Subprogram_Body_Stub;
|
|
|
|
---------------------
|
|
-- 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.
|
|
|
|
procedure Analyze_Subunit (N : Node_Id) is
|
|
Lib_Unit : constant Node_Id := Library_Unit (N);
|
|
Par_Unit : constant Entity_Id := Current_Scope;
|
|
|
|
Lib_Spec : Node_Id := Library_Unit (Lib_Unit);
|
|
Num_Scopes : Int := 0;
|
|
Use_Clauses : array (1 .. Scope_Stack.Last) of Node_Id;
|
|
Enclosing_Child : Entity_Id := Empty;
|
|
|
|
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.
|
|
|
|
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.
|
|
|
|
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.
|
|
|
|
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.
|
|
|
|
------------------------------
|
|
-- Analyze_Subunit_Context --
|
|
------------------------------
|
|
|
|
procedure Analyze_Subunit_Context is
|
|
Item : Node_Id;
|
|
Nam : Node_Id;
|
|
Unit_Name : Entity_Id;
|
|
|
|
begin
|
|
Analyze_Context (N);
|
|
Item := First (Context_Items (N));
|
|
|
|
-- make withed units immediately visible. If child unit, make the
|
|
-- ultimate parent immediately visible.
|
|
|
|
while Present (Item) loop
|
|
|
|
if Nkind (Item) = N_With_Clause then
|
|
Unit_Name := Entity (Name (Item));
|
|
|
|
while Is_Child_Unit (Unit_Name) loop
|
|
Set_Is_Visible_Child_Unit (Unit_Name);
|
|
Unit_Name := Scope (Unit_Name);
|
|
end loop;
|
|
|
|
if not Is_Immediately_Visible (Unit_Name) then
|
|
Set_Is_Immediately_Visible (Unit_Name);
|
|
Set_Context_Installed (Item);
|
|
end if;
|
|
|
|
elsif Nkind (Item) = N_Use_Package_Clause then
|
|
Nam := First (Names (Item));
|
|
|
|
while Present (Nam) loop
|
|
Analyze (Nam);
|
|
Next (Nam);
|
|
end loop;
|
|
|
|
elsif Nkind (Item) = N_Use_Type_Clause then
|
|
Nam := First (Subtype_Marks (Item));
|
|
|
|
while Present (Nam) loop
|
|
Analyze (Nam);
|
|
Next (Nam);
|
|
end loop;
|
|
end if;
|
|
|
|
Next (Item);
|
|
end loop;
|
|
|
|
Item := First (Context_Items (N));
|
|
|
|
-- reset visibility of withed units. They will be made visible
|
|
-- again when we install the subunit context.
|
|
|
|
while Present (Item) loop
|
|
|
|
if Nkind (Item) = N_With_Clause then
|
|
Unit_Name := Entity (Name (Item));
|
|
|
|
while Is_Child_Unit (Unit_Name) loop
|
|
Set_Is_Visible_Child_Unit (Unit_Name, False);
|
|
Unit_Name := Scope (Unit_Name);
|
|
end loop;
|
|
|
|
if Context_Installed (Item) then
|
|
Set_Is_Immediately_Visible (Unit_Name, False);
|
|
Set_Context_Installed (Item, False);
|
|
end if;
|
|
end if;
|
|
|
|
Next (Item);
|
|
end loop;
|
|
|
|
end Analyze_Subunit_Context;
|
|
|
|
------------------------
|
|
-- Re_Install_Parents --
|
|
------------------------
|
|
|
|
procedure Re_Install_Parents (L : Node_Id; Scop : Entity_Id) is
|
|
E : Entity_Id;
|
|
|
|
begin
|
|
if Nkind (Unit (L)) = N_Subunit then
|
|
Re_Install_Parents (Library_Unit (L), Scope (Scop));
|
|
end if;
|
|
|
|
Install_Context (L);
|
|
|
|
-- If the subunit occurs within a child unit, we must restore the
|
|
-- immediate visibility of any siblings that may occur in context.
|
|
|
|
if Present (Enclosing_Child) then
|
|
Install_Siblings (Enclosing_Child, L);
|
|
end if;
|
|
|
|
New_Scope (Scop);
|
|
|
|
if Scop /= Par_Unit then
|
|
Set_Is_Immediately_Visible (Scop);
|
|
end if;
|
|
|
|
E := First_Entity (Current_Scope);
|
|
|
|
while Present (E) loop
|
|
Set_Is_Immediately_Visible (E);
|
|
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.
|
|
|
|
if Ekind (Scop) = E_Package then
|
|
Set_In_Package_Body (Scop);
|
|
Install_Private_Declarations (Scop);
|
|
end if;
|
|
end Re_Install_Parents;
|
|
|
|
----------------------------
|
|
-- Re_Install_Use_Clauses --
|
|
----------------------------
|
|
|
|
procedure Re_Install_Use_Clauses is
|
|
U : Node_Id;
|
|
|
|
begin
|
|
for J in reverse 1 .. Num_Scopes loop
|
|
U := Use_Clauses (J);
|
|
Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := U;
|
|
Install_Use_Clauses (U);
|
|
end loop;
|
|
end Re_Install_Use_Clauses;
|
|
|
|
------------------
|
|
-- Remove_Scope --
|
|
------------------
|
|
|
|
procedure Remove_Scope is
|
|
E : Entity_Id;
|
|
|
|
begin
|
|
Num_Scopes := Num_Scopes + 1;
|
|
Use_Clauses (Num_Scopes) :=
|
|
Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause;
|
|
E := First_Entity (Current_Scope);
|
|
|
|
while Present (E) loop
|
|
Set_Is_Immediately_Visible (E, False);
|
|
Next_Entity (E);
|
|
end loop;
|
|
|
|
if Is_Child_Unit (Current_Scope) then
|
|
Enclosing_Child := Current_Scope;
|
|
end if;
|
|
|
|
Pop_Scope;
|
|
end Remove_Scope;
|
|
|
|
-- Start of processing for Analyze_Subunit
|
|
|
|
begin
|
|
if not Is_Empty_List (Context_Items (N)) then
|
|
|
|
-- Save current use clauses.
|
|
|
|
Remove_Scope;
|
|
Remove_Context (Lib_Unit);
|
|
|
|
-- Now remove parents and their context, including enclosing
|
|
-- subunits and the outer parent body which is not a subunit.
|
|
|
|
if Present (Lib_Spec) then
|
|
Remove_Context (Lib_Spec);
|
|
|
|
while Nkind (Unit (Lib_Spec)) = N_Subunit loop
|
|
Lib_Spec := Library_Unit (Lib_Spec);
|
|
Remove_Scope;
|
|
Remove_Context (Lib_Spec);
|
|
end loop;
|
|
|
|
if Nkind (Unit (Lib_Unit)) = N_Subunit then
|
|
Remove_Scope;
|
|
end if;
|
|
|
|
if Nkind (Unit (Lib_Spec)) = N_Package_Body then
|
|
Remove_Context (Library_Unit (Lib_Spec));
|
|
end if;
|
|
end if;
|
|
|
|
Analyze_Subunit_Context;
|
|
Re_Install_Parents (Lib_Unit, 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 Ekind (Par_Unit) = E_Package then
|
|
if not Is_Immediately_Visible (Par_Unit)
|
|
or else (Present (First_Entity (Par_Unit))
|
|
and then not Is_Immediately_Visible
|
|
(First_Entity (Par_Unit)))
|
|
then
|
|
Set_Is_Immediately_Visible (Par_Unit);
|
|
Install_Visible_Declarations (Par_Unit);
|
|
Install_Private_Declarations (Par_Unit);
|
|
end if;
|
|
end if;
|
|
|
|
Re_Install_Use_Clauses;
|
|
Install_Context (N);
|
|
|
|
-- If the subunit is within a child unit, then siblings of any
|
|
-- parent unit that appear in the context clause of the subunit
|
|
-- must also be made immediately visible.
|
|
|
|
if Present (Enclosing_Child) then
|
|
Install_Siblings (Enclosing_Child, N);
|
|
end if;
|
|
|
|
end if;
|
|
|
|
Analyze (Proper_Body (Unit (N)));
|
|
Remove_Context (N);
|
|
|
|
end Analyze_Subunit;
|
|
|
|
----------------------------
|
|
-- Analyze_Task_Body_Stub --
|
|
----------------------------
|
|
|
|
procedure Analyze_Task_Body_Stub (N : Node_Id) is
|
|
Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N));
|
|
Loc : constant Source_Ptr := Sloc (N);
|
|
|
|
begin
|
|
Check_Stub_Level (N);
|
|
|
|
-- First occurrence of name may have been as an incomplete type.
|
|
|
|
if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then
|
|
Nam := Full_View (Nam);
|
|
end if;
|
|
|
|
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.
|
|
|
|
if Expander_Active then
|
|
Insert_After (N,
|
|
Make_Assignment_Statement (Loc,
|
|
Name =>
|
|
Make_Identifier (Loc,
|
|
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.
|
|
|
|
procedure Analyze_With_Clause (N : Node_Id) is
|
|
Unit_Kind : constant Node_Kind := Nkind (Unit (Library_Unit (N)));
|
|
E_Name : Entity_Id;
|
|
Par_Name : Entity_Id;
|
|
Pref : Node_Id;
|
|
U : Node_Id;
|
|
|
|
Intunit : Boolean;
|
|
-- Set True if the unit currently being compiled is an internal unit
|
|
|
|
Save_Style_Check : constant Boolean := Opt.Style_Check;
|
|
Save_C_Restrict : constant Save_Compilation_Unit_Restrictions :=
|
|
Compilation_Unit_Restrictions_Save;
|
|
|
|
begin
|
|
-- We reset ordinary style checking during the analysis of a with'ed
|
|
-- unit, but we do NOT reset GNAT special analysis mode (the latter
|
|
-- definitely *does* apply to with'ed units).
|
|
|
|
if not GNAT_Mode then
|
|
Style_Check := False;
|
|
end if;
|
|
|
|
-- If the library unit is a predefined unit, and we are in no
|
|
-- run time mode, then temporarily reset No_Run_Time mode for the
|
|
-- analysis of the with'ed unit. The No_Run_Time pragma does not
|
|
-- prevent explicit with'ing of run-time units.
|
|
|
|
if No_Run_Time
|
|
and then
|
|
Is_Predefined_File_Name
|
|
(Unit_File_Name (Get_Source_Unit (Unit (Library_Unit (N)))))
|
|
then
|
|
No_Run_Time := False;
|
|
Semantics (Library_Unit (N));
|
|
No_Run_Time := True;
|
|
|
|
else
|
|
Semantics (Library_Unit (N));
|
|
end if;
|
|
|
|
U := Unit (Library_Unit (N));
|
|
Intunit := Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit));
|
|
|
|
-- Following checks are skipped for dummy packages (those supplied
|
|
-- for with's where no matching file could be found). Such packages
|
|
-- are identified by the Sloc value being set to No_Location
|
|
|
|
if Sloc (U) /= No_Location then
|
|
|
|
-- Check restrictions, except that we skip the check if this
|
|
-- is an internal unit unless we are compiling the internal
|
|
-- unit as the main unit. We also skip this for dummy packages.
|
|
|
|
if not Intunit or else Current_Sem_Unit = Main_Unit then
|
|
Check_Restricted_Unit (Unit_Name (Get_Source_Unit (U)), N);
|
|
end if;
|
|
|
|
-- Check for inappropriate with of internal implementation unit
|
|
-- if we are currently compiling the main unit and the main unit
|
|
-- is itself not an internal unit.
|
|
|
|
if Implementation_Unit_Warnings
|
|
and then Current_Sem_Unit = Main_Unit
|
|
and then Implementation_Unit (Get_Source_Unit (U))
|
|
and then not Intunit
|
|
then
|
|
Error_Msg_N ("& is an internal 'G'N'A'T unit?", Name (N));
|
|
Error_Msg_N
|
|
("\use of this unit is non-portable and version-dependent?",
|
|
Name (N));
|
|
end if;
|
|
end if;
|
|
|
|
-- Semantic analysis of a generic unit is performed on a copy of
|
|
-- the original tree. Retrieve the entity on which semantic info
|
|
-- actually appears.
|
|
|
|
if Unit_Kind in N_Generic_Declaration then
|
|
E_Name := Defining_Entity (U);
|
|
|
|
-- Note: in the following test, Unit_Kind is the original Nkind, but
|
|
-- in the case of an instantiation, semantic analysis above will
|
|
-- have replaced the unit by its instantiated version. If the instance
|
|
-- body has been generated, the instance now denotes the body entity.
|
|
-- For visibility purposes we need the entity of its spec.
|
|
|
|
elsif (Unit_Kind = N_Package_Instantiation
|
|
or else Nkind (Original_Node (Unit (Library_Unit (N)))) =
|
|
N_Package_Instantiation)
|
|
and then Nkind (U) = N_Package_Body
|
|
then
|
|
E_Name := Corresponding_Spec (U);
|
|
|
|
elsif Unit_Kind = N_Package_Instantiation
|
|
and then Nkind (U) = N_Package_Instantiation
|
|
then
|
|
-- If the instance has not been rewritten as a package declaration,
|
|
-- then it appeared already in a previous with clause. Retrieve
|
|
-- the entity from the previous instance.
|
|
|
|
E_Name := Defining_Entity (Specification (Instance_Spec (U)));
|
|
|
|
elsif Unit_Kind = N_Procedure_Instantiation
|
|
or else Unit_Kind = N_Function_Instantiation
|
|
then
|
|
-- Instantiation node is replaced with a package that contains
|
|
-- renaming declarations and instance itself. The subprogram
|
|
-- Instance is declared in the visible part of the wrapper package.
|
|
|
|
E_Name := First_Entity (Defining_Entity (U));
|
|
|
|
while Present (E_Name) loop
|
|
exit when Is_Subprogram (E_Name)
|
|
and then Is_Generic_Instance (E_Name);
|
|
E_Name := Next_Entity (E_Name);
|
|
end loop;
|
|
|
|
elsif Unit_Kind = N_Package_Renaming_Declaration
|
|
or else Unit_Kind in N_Generic_Renaming_Declaration
|
|
then
|
|
E_Name := Defining_Entity (U);
|
|
|
|
elsif Unit_Kind = N_Subprogram_Body
|
|
and then Nkind (Name (N)) = N_Selected_Component
|
|
and then not Acts_As_Spec (Library_Unit (N))
|
|
then
|
|
-- For a child unit that has no spec, one has been created and
|
|
-- analyzed. The entity required is that of the spec.
|
|
|
|
E_Name := Corresponding_Spec (U);
|
|
|
|
else
|
|
E_Name := Defining_Entity (U);
|
|
end if;
|
|
|
|
if Nkind (Name (N)) = N_Selected_Component then
|
|
|
|
-- Child unit in a with clause
|
|
|
|
Change_Selected_Component_To_Expanded_Name (Name (N));
|
|
end if;
|
|
|
|
-- Restore style checks and restrictions
|
|
|
|
Style_Check := Save_Style_Check;
|
|
Compilation_Unit_Restrictions_Restore (Save_C_Restrict);
|
|
|
|
-- Record the reference, but do NOT set the unit as referenced, we
|
|
-- want to consider the unit as unreferenced if this is the only
|
|
-- reference that occurs.
|
|
|
|
Set_Entity_With_Style_Check (Name (N), E_Name);
|
|
Generate_Reference (E_Name, Name (N), Set_Ref => False);
|
|
|
|
if Is_Child_Unit (E_Name) then
|
|
Pref := Prefix (Name (N));
|
|
Par_Name := Scope (E_Name);
|
|
|
|
while Nkind (Pref) = N_Selected_Component loop
|
|
Change_Selected_Component_To_Expanded_Name (Pref);
|
|
Set_Entity_With_Style_Check (Pref, Par_Name);
|
|
|
|
Generate_Reference (Par_Name, Pref);
|
|
Pref := Prefix (Pref);
|
|
Par_Name := Scope (Par_Name);
|
|
end loop;
|
|
|
|
if Present (Entity (Pref))
|
|
and then not Analyzed (Parent (Parent (Entity (Pref))))
|
|
then
|
|
-- If the entity is set without its unit being compiled,
|
|
-- the original parent is a renaming, and Par_Name is the
|
|
-- renamed entity. For visibility purposes, we need the
|
|
-- original entity, which must be analyzed now, because
|
|
-- Load_Unit retrieves directly the renamed unit, and the
|
|
-- renaming declaration itself has not been analyzed.
|
|
|
|
Analyze (Parent (Parent (Entity (Pref))));
|
|
pragma Assert (Renamed_Object (Entity (Pref)) = Par_Name);
|
|
Par_Name := Entity (Pref);
|
|
end if;
|
|
|
|
Set_Entity_With_Style_Check (Pref, Par_Name);
|
|
Generate_Reference (Par_Name, Pref);
|
|
end if;
|
|
|
|
-- If the withed unit is System, and a system extension pragma is
|
|
-- present, compile the extension now, rather than waiting for
|
|
-- a visibility check on a specific entity.
|
|
|
|
if Chars (E_Name) = Name_System
|
|
and then Scope (E_Name) = Standard_Standard
|
|
and then Present (System_Extend_Pragma_Arg)
|
|
and then Present_System_Aux (N)
|
|
then
|
|
-- If the extension is not present, an error will have been emitted.
|
|
|
|
null;
|
|
end if;
|
|
end Analyze_With_Clause;
|
|
|
|
------------------------------
|
|
-- Analyze_With_Type_Clause --
|
|
------------------------------
|
|
|
|
procedure Analyze_With_Type_Clause (N : Node_Id) is
|
|
Loc : constant Source_Ptr := Sloc (N);
|
|
Nam : Node_Id := Name (N);
|
|
Pack : Node_Id;
|
|
Decl : Node_Id;
|
|
P : Entity_Id;
|
|
Unum : Unit_Number_Type;
|
|
Sel : Node_Id;
|
|
|
|
procedure Decorate_Tagged_Type (T : Entity_Id; Kind : Entity_Kind);
|
|
-- Set basic attributes of type, including its class_wide type.
|
|
|
|
function In_Chain (E : Entity_Id) return Boolean;
|
|
-- Check that the imported type is not already in the homonym chain,
|
|
-- for example through a with_type clause in a parent unit.
|
|
|
|
--------------------------
|
|
-- Decorate_Tagged_Type --
|
|
--------------------------
|
|
|
|
procedure Decorate_Tagged_Type (T : Entity_Id; Kind : Entity_Kind) is
|
|
CW : Entity_Id;
|
|
|
|
begin
|
|
Set_Ekind (T, E_Record_Type);
|
|
Set_Is_Tagged_Type (T);
|
|
Set_Etype (T, T);
|
|
Set_From_With_Type (T);
|
|
Set_Scope (T, P);
|
|
|
|
if not In_Chain (T) then
|
|
Set_Homonym (T, Current_Entity (T));
|
|
Set_Current_Entity (T);
|
|
end if;
|
|
|
|
-- Build bogus class_wide type, if not previously done.
|
|
|
|
if No (Class_Wide_Type (T)) then
|
|
CW := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
|
|
|
|
Set_Ekind (CW, E_Class_Wide_Type);
|
|
Set_Etype (CW, T);
|
|
Set_Scope (CW, P);
|
|
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);
|
|
|
|
Set_Class_Wide_Type (T, CW);
|
|
end if;
|
|
end Decorate_Tagged_Type;
|
|
|
|
--------------
|
|
-- In_Chain --
|
|
--------------
|
|
|
|
function In_Chain (E : Entity_Id) return Boolean is
|
|
H : Entity_Id := Current_Entity (E);
|
|
|
|
begin
|
|
while Present (H) loop
|
|
|
|
if H = E then
|
|
return True;
|
|
else
|
|
H := Homonym (H);
|
|
end if;
|
|
end loop;
|
|
|
|
return False;
|
|
end In_Chain;
|
|
|
|
-- Start of processing for Analyze_With_Type_Clause
|
|
|
|
begin
|
|
if Nkind (Nam) = N_Selected_Component then
|
|
Pack := New_Copy_Tree (Prefix (Nam));
|
|
Sel := Selector_Name (Nam);
|
|
|
|
else
|
|
Error_Msg_N ("illegal name for imported type", Nam);
|
|
return;
|
|
end if;
|
|
|
|
Decl :=
|
|
Make_Package_Declaration (Loc,
|
|
Specification =>
|
|
(Make_Package_Specification (Loc,
|
|
Defining_Unit_Name => Pack,
|
|
Visible_Declarations => New_List,
|
|
End_Label => Empty)));
|
|
|
|
Unum :=
|
|
Load_Unit
|
|
(Load_Name => Get_Unit_Name (Decl),
|
|
Required => True,
|
|
Subunit => False,
|
|
Error_Node => Nam);
|
|
|
|
if Unum = No_Unit
|
|
or else Nkind (Unit (Cunit (Unum))) /= N_Package_Declaration
|
|
then
|
|
Error_Msg_N ("imported type must be declared in package", Nam);
|
|
return;
|
|
|
|
elsif Unum = Current_Sem_Unit then
|
|
|
|
-- If type is defined in unit being analyzed, then the clause
|
|
-- is redundant.
|
|
|
|
return;
|
|
|
|
else
|
|
P := Cunit_Entity (Unum);
|
|
end if;
|
|
|
|
-- Find declaration for imported type, and set its basic attributes
|
|
-- if it has not been analyzed (which will be the case if there is
|
|
-- circular dependence).
|
|
|
|
declare
|
|
Decl : Node_Id;
|
|
Typ : Entity_Id;
|
|
|
|
begin
|
|
if not Analyzed (Cunit (Unum))
|
|
and then not From_With_Type (P)
|
|
then
|
|
Set_Ekind (P, E_Package);
|
|
Set_Etype (P, Standard_Void_Type);
|
|
Set_From_With_Type (P);
|
|
Set_Scope (P, Standard_Standard);
|
|
Set_Homonym (P, Current_Entity (P));
|
|
Set_Current_Entity (P);
|
|
|
|
elsif Analyzed (Cunit (Unum))
|
|
and then Is_Child_Unit (P)
|
|
then
|
|
-- If the child unit is already in scope, indicate that it is
|
|
-- visible, and remains so after intervening calls to rtsfind.
|
|
|
|
Set_Is_Visible_Child_Unit (P);
|
|
end if;
|
|
|
|
if Nkind (Parent (P)) = N_Defining_Program_Unit_Name then
|
|
|
|
-- Make parent packages visible.
|
|
|
|
declare
|
|
Parent_Comp : Node_Id;
|
|
Parent_Id : Entity_Id;
|
|
Child : Entity_Id;
|
|
|
|
begin
|
|
Child := P;
|
|
Parent_Comp := Parent_Spec (Unit (Cunit (Unum)));
|
|
|
|
loop
|
|
Parent_Id := Defining_Entity (Unit (Parent_Comp));
|
|
Set_Scope (Child, Parent_Id);
|
|
|
|
-- The type may be imported from a child unit, in which
|
|
-- case the current compilation appears in the name. Do
|
|
-- not change its visibility here because it will conflict
|
|
-- with the subsequent normal processing.
|
|
|
|
if not Analyzed (Unit_Declaration_Node (Parent_Id))
|
|
and then Parent_Id /= Cunit_Entity (Current_Sem_Unit)
|
|
then
|
|
Set_Ekind (Parent_Id, E_Package);
|
|
Set_Etype (Parent_Id, Standard_Void_Type);
|
|
|
|
-- The same package may appear is several with_type
|
|
-- clauses.
|
|
|
|
if not From_With_Type (Parent_Id) then
|
|
Set_Homonym (Parent_Id, Current_Entity (Parent_Id));
|
|
Set_Current_Entity (Parent_Id);
|
|
Set_From_With_Type (Parent_Id);
|
|
end if;
|
|
end if;
|
|
|
|
Set_Is_Immediately_Visible (Parent_Id);
|
|
|
|
Child := Parent_Id;
|
|
Parent_Comp := Parent_Spec (Unit (Parent_Comp));
|
|
exit when No (Parent_Comp);
|
|
end loop;
|
|
|
|
Set_Scope (Parent_Id, Standard_Standard);
|
|
end;
|
|
end if;
|
|
|
|
-- Even if analyzed, the package may not be currently visible. It
|
|
-- must be while the with_type clause is active.
|
|
|
|
Set_Is_Immediately_Visible (P);
|
|
|
|
Decl :=
|
|
First (Visible_Declarations (Specification (Unit (Cunit (Unum)))));
|
|
|
|
while Present (Decl) loop
|
|
|
|
if Nkind (Decl) = N_Full_Type_Declaration
|
|
and then Chars (Defining_Identifier (Decl)) = Chars (Sel)
|
|
then
|
|
Typ := Defining_Identifier (Decl);
|
|
|
|
if Tagged_Present (N) then
|
|
|
|
-- The declaration must indicate that this is a tagged
|
|
-- type or a type extension.
|
|
|
|
if (Nkind (Type_Definition (Decl)) = N_Record_Definition
|
|
and then Tagged_Present (Type_Definition (Decl)))
|
|
or else
|
|
(Nkind (Type_Definition (Decl))
|
|
= N_Derived_Type_Definition
|
|
and then Present
|
|
(Record_Extension_Part (Type_Definition (Decl))))
|
|
then
|
|
null;
|
|
else
|
|
Error_Msg_N ("imported type is not a tagged type", Nam);
|
|
return;
|
|
end if;
|
|
|
|
if not Analyzed (Decl) then
|
|
|
|
-- Unit is not currently visible. Add basic attributes
|
|
-- to type and build its class-wide type.
|
|
|
|
Init_Size_Align (Typ);
|
|
Decorate_Tagged_Type (Typ, E_Record_Type);
|
|
end if;
|
|
|
|
else
|
|
if Nkind (Type_Definition (Decl))
|
|
/= N_Access_To_Object_Definition
|
|
then
|
|
Error_Msg_N
|
|
("imported type is not an access type", Nam);
|
|
|
|
elsif not Analyzed (Decl) then
|
|
Set_Ekind (Typ, E_Access_Type);
|
|
Set_Etype (Typ, Typ);
|
|
Set_Scope (Typ, P);
|
|
Init_Size (Typ, System_Address_Size);
|
|
Init_Alignment (Typ);
|
|
Set_Directly_Designated_Type (Typ, Standard_Integer);
|
|
Set_From_With_Type (Typ);
|
|
|
|
if not In_Chain (Typ) then
|
|
Set_Homonym (Typ, Current_Entity (Typ));
|
|
Set_Current_Entity (Typ);
|
|
end if;
|
|
end if;
|
|
end if;
|
|
|
|
Set_Entity (Sel, Typ);
|
|
return;
|
|
|
|
elsif ((Nkind (Decl) = N_Private_Type_Declaration
|
|
and then Tagged_Present (Decl))
|
|
or else (Nkind (Decl) = N_Private_Extension_Declaration))
|
|
and then Chars (Defining_Identifier (Decl)) = Chars (Sel)
|
|
then
|
|
Typ := Defining_Identifier (Decl);
|
|
|
|
if not Tagged_Present (N) then
|
|
Error_Msg_N ("type must be declared tagged", N);
|
|
|
|
elsif not Analyzed (Decl) then
|
|
Decorate_Tagged_Type (Typ, E_Private_Type);
|
|
end if;
|
|
|
|
Set_Entity (Sel, Typ);
|
|
Set_From_With_Type (Typ);
|
|
return;
|
|
end if;
|
|
|
|
Decl := Next (Decl);
|
|
end loop;
|
|
|
|
Error_Msg_NE ("not a visible access or tagged type in&", Nam, P);
|
|
end;
|
|
end Analyze_With_Type_Clause;
|
|
|
|
-----------------------------
|
|
-- Check_With_Type_Clauses --
|
|
-----------------------------
|
|
|
|
procedure Check_With_Type_Clauses (N : Node_Id) is
|
|
Lib_Unit : constant Node_Id := Unit (N);
|
|
|
|
procedure Check_Parent_Context (U : Node_Id);
|
|
-- Examine context items of parent unit to locate with_type clauses.
|
|
|
|
--------------------------
|
|
-- Check_Parent_Context --
|
|
--------------------------
|
|
|
|
procedure Check_Parent_Context (U : Node_Id) is
|
|
Item : Node_Id;
|
|
|
|
begin
|
|
Item := First (Context_Items (U));
|
|
while Present (Item) loop
|
|
if Nkind (Item) = N_With_Type_Clause
|
|
and then not Error_Posted (Item)
|
|
and then
|
|
From_With_Type (Scope (Entity (Selector_Name (Name (Item)))))
|
|
then
|
|
Error_Msg_Sloc := Sloc (Item);
|
|
Error_Msg_N ("Missing With_Clause for With_Type_Clause#", N);
|
|
end if;
|
|
|
|
Next (Item);
|
|
end loop;
|
|
end Check_Parent_Context;
|
|
|
|
-- Start of processing for Check_With_Type_Clauses
|
|
|
|
begin
|
|
if Extensions_Allowed
|
|
and then (Nkind (Lib_Unit) = N_Package_Body
|
|
or else Nkind (Lib_Unit) = N_Subprogram_Body)
|
|
then
|
|
Check_Parent_Context (Library_Unit (N));
|
|
if Is_Child_Spec (Unit (Library_Unit (N))) then
|
|
Check_Parent_Context (Parent_Spec (Unit (Library_Unit (N))));
|
|
end if;
|
|
end if;
|
|
end Check_With_Type_Clauses;
|
|
|
|
------------------------------
|
|
-- Check_Private_Child_Unit --
|
|
------------------------------
|
|
|
|
procedure Check_Private_Child_Unit (N : Node_Id) is
|
|
Lib_Unit : constant Node_Id := Unit (N);
|
|
Item : Node_Id;
|
|
Curr_Unit : Entity_Id;
|
|
Sub_Parent : Node_Id;
|
|
Priv_Child : Entity_Id;
|
|
Par_Lib : Entity_Id;
|
|
Par_Spec : Node_Id;
|
|
|
|
function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean;
|
|
-- Returns true if and only if the library unit is declared with
|
|
-- an explicit designation of private.
|
|
|
|
function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean is
|
|
begin
|
|
return Private_Present (Parent (Unit_Declaration_Node (Unit)));
|
|
end Is_Private_Library_Unit;
|
|
|
|
-- Start of processing for Check_Private_Child_Unit
|
|
|
|
begin
|
|
if Nkind (Lib_Unit) = N_Package_Body
|
|
or else Nkind (Lib_Unit) = N_Subprogram_Body
|
|
then
|
|
Curr_Unit := Defining_Entity (Unit (Library_Unit (N)));
|
|
Par_Lib := Curr_Unit;
|
|
|
|
elsif Nkind (Lib_Unit) = N_Subunit then
|
|
|
|
-- The parent is itself a body. The parent entity is to be found
|
|
-- in the corresponding spec.
|
|
|
|
Sub_Parent := Library_Unit (N);
|
|
Curr_Unit := Defining_Entity (Unit (Library_Unit (Sub_Parent)));
|
|
|
|
-- If the parent itself is a subunit, Curr_Unit is the entity
|
|
-- of the enclosing body, retrieve the spec entity which is
|
|
-- the proper ancestor we need for the following tests.
|
|
|
|
if Ekind (Curr_Unit) = E_Package_Body then
|
|
Curr_Unit := Spec_Entity (Curr_Unit);
|
|
end if;
|
|
|
|
Par_Lib := Curr_Unit;
|
|
|
|
else
|
|
Curr_Unit := Defining_Entity (Lib_Unit);
|
|
|
|
Par_Lib := Curr_Unit;
|
|
Par_Spec := Parent_Spec (Lib_Unit);
|
|
|
|
if No (Par_Spec) then
|
|
Par_Lib := Empty;
|
|
else
|
|
Par_Lib := Defining_Entity (Unit (Par_Spec));
|
|
end if;
|
|
end if;
|
|
|
|
-- Loop through context items
|
|
|
|
Item := First (Context_Items (N));
|
|
while Present (Item) loop
|
|
|
|
if Nkind (Item) = N_With_Clause
|
|
and then not Implicit_With (Item)
|
|
and then Is_Private_Descendant (Entity (Name (Item)))
|
|
then
|
|
Priv_Child := Entity (Name (Item));
|
|
|
|
declare
|
|
Curr_Parent : Entity_Id := Par_Lib;
|
|
Child_Parent : Entity_Id := Scope (Priv_Child);
|
|
Prv_Ancestor : Entity_Id := Child_Parent;
|
|
Curr_Private : Boolean := Is_Private_Library_Unit (Curr_Unit);
|
|
|
|
begin
|
|
-- If the child unit is a public child then locate
|
|
-- the nearest private ancestor; Child_Parent will
|
|
-- then be set to the parent of that ancestor.
|
|
|
|
if not Is_Private_Library_Unit (Priv_Child) then
|
|
while Present (Prv_Ancestor)
|
|
and then not Is_Private_Library_Unit (Prv_Ancestor)
|
|
loop
|
|
Prv_Ancestor := Scope (Prv_Ancestor);
|
|
end loop;
|
|
|
|
if Present (Prv_Ancestor) then
|
|
Child_Parent := Scope (Prv_Ancestor);
|
|
end if;
|
|
end if;
|
|
|
|
while Present (Curr_Parent)
|
|
and then Curr_Parent /= Standard_Standard
|
|
and then Curr_Parent /= Child_Parent
|
|
loop
|
|
Curr_Private :=
|
|
Curr_Private or else Is_Private_Library_Unit (Curr_Parent);
|
|
Curr_Parent := Scope (Curr_Parent);
|
|
end loop;
|
|
|
|
if not Present (Curr_Parent) then
|
|
Curr_Parent := Standard_Standard;
|
|
end if;
|
|
|
|
if Curr_Parent /= Child_Parent then
|
|
|
|
if Ekind (Priv_Child) = E_Generic_Package
|
|
and then Chars (Priv_Child) in Text_IO_Package_Name
|
|
and then Chars (Scope (Scope (Priv_Child))) = Name_Ada
|
|
then
|
|
Error_Msg_NE
|
|
("& is a nested package, not a compilation unit",
|
|
Name (Item), Priv_Child);
|
|
|
|
else
|
|
Error_Msg_N
|
|
("unit in with clause is private child unit!", Item);
|
|
Error_Msg_NE
|
|
("current unit must also have parent&!",
|
|
Item, Child_Parent);
|
|
end if;
|
|
|
|
elsif not Curr_Private
|
|
and then Nkind (Lib_Unit) /= N_Package_Body
|
|
and then Nkind (Lib_Unit) /= N_Subprogram_Body
|
|
and then Nkind (Lib_Unit) /= N_Subunit
|
|
then
|
|
Error_Msg_NE
|
|
("current unit must also be private descendant of&",
|
|
Item, Child_Parent);
|
|
end if;
|
|
end;
|
|
end if;
|
|
|
|
Next (Item);
|
|
end loop;
|
|
|
|
end Check_Private_Child_Unit;
|
|
|
|
----------------------
|
|
-- Check_Stub_Level --
|
|
----------------------
|
|
|
|
procedure Check_Stub_Level (N : Node_Id) is
|
|
Par : constant Node_Id := Parent (N);
|
|
Kind : constant Node_Kind := Nkind (Par);
|
|
|
|
begin
|
|
if (Kind = N_Package_Body
|
|
or else Kind = N_Subprogram_Body
|
|
or else Kind = N_Task_Body
|
|
or else Kind = N_Protected_Body)
|
|
|
|
and then (Nkind (Parent (Par)) = N_Compilation_Unit
|
|
or else Nkind (Parent (Par)) = N_Subunit)
|
|
then
|
|
null;
|
|
|
|
-- In an instance, a missing stub appears at any level. A warning
|
|
-- message will have been emitted already for the missing file.
|
|
|
|
elsif not In_Instance then
|
|
Error_Msg_N ("stub cannot appear in an inner scope", N);
|
|
|
|
elsif Expander_Active then
|
|
Error_Msg_N ("missing proper body", N);
|
|
end if;
|
|
end Check_Stub_Level;
|
|
|
|
------------------------
|
|
-- Expand_With_Clause --
|
|
------------------------
|
|
|
|
procedure Expand_With_Clause (Nam : Node_Id; N : Node_Id) is
|
|
Loc : constant Source_Ptr := Sloc (Nam);
|
|
Ent : constant Entity_Id := Entity (Nam);
|
|
Withn : Node_Id;
|
|
P : Node_Id;
|
|
|
|
function Build_Unit_Name (Nam : Node_Id) return Node_Id;
|
|
|
|
function Build_Unit_Name (Nam : Node_Id) return Node_Id is
|
|
Result : Node_Id;
|
|
|
|
begin
|
|
if Nkind (Nam) = N_Identifier then
|
|
return New_Occurrence_Of (Entity (Nam), Loc);
|
|
|
|
else
|
|
Result :=
|
|
Make_Expanded_Name (Loc,
|
|
Chars => Chars (Entity (Nam)),
|
|
Prefix => Build_Unit_Name (Prefix (Nam)),
|
|
Selector_Name => New_Occurrence_Of (Entity (Nam), Loc));
|
|
Set_Entity (Result, Entity (Nam));
|
|
return Result;
|
|
end if;
|
|
end Build_Unit_Name;
|
|
|
|
begin
|
|
New_Nodes_OK := New_Nodes_OK + 1;
|
|
Withn :=
|
|
Make_With_Clause (Loc, Name => Build_Unit_Name (Nam));
|
|
|
|
P := Parent (Unit_Declaration_Node (Ent));
|
|
Set_Library_Unit (Withn, P);
|
|
Set_Corresponding_Spec (Withn, Ent);
|
|
Set_First_Name (Withn, True);
|
|
Set_Implicit_With (Withn, True);
|
|
|
|
Prepend (Withn, Context_Items (N));
|
|
Mark_Rewrite_Insertion (Withn);
|
|
Install_Withed_Unit (Withn);
|
|
|
|
if Nkind (Nam) = N_Expanded_Name then
|
|
Expand_With_Clause (Prefix (Nam), N);
|
|
end if;
|
|
|
|
New_Nodes_OK := New_Nodes_OK - 1;
|
|
end Expand_With_Clause;
|
|
|
|
-----------------------------
|
|
-- Implicit_With_On_Parent --
|
|
-----------------------------
|
|
|
|
procedure Implicit_With_On_Parent
|
|
(Child_Unit : Node_Id;
|
|
N : Node_Id)
|
|
is
|
|
Loc : constant Source_Ptr := Sloc (N);
|
|
P : constant Node_Id := Parent_Spec (Child_Unit);
|
|
P_Unit : constant Node_Id := Unit (P);
|
|
|
|
P_Name : Entity_Id := Defining_Entity (P_Unit);
|
|
Withn : Node_Id;
|
|
|
|
function Build_Ancestor_Name (P : Node_Id) return Node_Id;
|
|
-- Build prefix of child unit name. Recurse if needed.
|
|
|
|
function Build_Unit_Name return Node_Id;
|
|
-- If the unit is a child unit, build qualified name with all
|
|
-- ancestors.
|
|
|
|
-------------------------
|
|
-- Build_Ancestor_Name --
|
|
-------------------------
|
|
|
|
function Build_Ancestor_Name (P : Node_Id) return Node_Id is
|
|
P_Ref : Node_Id := New_Reference_To (Defining_Entity (P), Loc);
|
|
|
|
begin
|
|
if No (Parent_Spec (P)) then
|
|
return P_Ref;
|
|
else
|
|
return
|
|
Make_Selected_Component (Loc,
|
|
Prefix => Build_Ancestor_Name (Unit (Parent_Spec (P))),
|
|
Selector_Name => P_Ref);
|
|
end if;
|
|
end Build_Ancestor_Name;
|
|
|
|
---------------------
|
|
-- Build_Unit_Name --
|
|
---------------------
|
|
|
|
function Build_Unit_Name return Node_Id is
|
|
Result : Node_Id;
|
|
|
|
begin
|
|
if No (Parent_Spec (P_Unit)) then
|
|
return New_Reference_To (P_Name, Loc);
|
|
else
|
|
Result :=
|
|
Make_Expanded_Name (Loc,
|
|
Chars => Chars (P_Name),
|
|
Prefix => Build_Ancestor_Name (Unit (Parent_Spec (P_Unit))),
|
|
Selector_Name => New_Reference_To (P_Name, Loc));
|
|
Set_Entity (Result, P_Name);
|
|
return Result;
|
|
end if;
|
|
end Build_Unit_Name;
|
|
|
|
-- Start of processing for Implicit_With_On_Parent
|
|
|
|
begin
|
|
New_Nodes_OK := New_Nodes_OK + 1;
|
|
Withn := Make_With_Clause (Loc, Name => Build_Unit_Name);
|
|
|
|
Set_Library_Unit (Withn, P);
|
|
Set_Corresponding_Spec (Withn, P_Name);
|
|
Set_First_Name (Withn, True);
|
|
Set_Implicit_With (Withn, True);
|
|
|
|
-- Node is placed at the beginning of the context items, so that
|
|
-- subsequent use clauses on the parent can be validated.
|
|
|
|
Prepend (Withn, Context_Items (N));
|
|
Mark_Rewrite_Insertion (Withn);
|
|
Install_Withed_Unit (Withn);
|
|
|
|
if Is_Child_Spec (P_Unit) then
|
|
Implicit_With_On_Parent (P_Unit, N);
|
|
end if;
|
|
New_Nodes_OK := New_Nodes_OK - 1;
|
|
end Implicit_With_On_Parent;
|
|
|
|
---------------------
|
|
-- Install_Context --
|
|
---------------------
|
|
|
|
procedure Install_Context (N : Node_Id) is
|
|
Lib_Unit : Node_Id := Unit (N);
|
|
|
|
begin
|
|
Install_Context_Clauses (N);
|
|
|
|
if Is_Child_Spec (Lib_Unit) then
|
|
Install_Parents (Lib_Unit, Private_Present (Parent (Lib_Unit)));
|
|
end if;
|
|
|
|
Check_With_Type_Clauses (N);
|
|
end Install_Context;
|
|
|
|
-----------------------------
|
|
-- Install_Context_Clauses --
|
|
-----------------------------
|
|
|
|
procedure Install_Context_Clauses (N : Node_Id) is
|
|
Lib_Unit : Node_Id := Unit (N);
|
|
Item : Node_Id;
|
|
Uname_Node : Entity_Id;
|
|
Check_Private : Boolean := False;
|
|
Decl_Node : Node_Id;
|
|
Lib_Parent : Entity_Id;
|
|
|
|
begin
|
|
-- Loop through context clauses to find the with/use clauses
|
|
|
|
Item := First (Context_Items (N));
|
|
while Present (Item) loop
|
|
|
|
-- Case of explicit WITH clause
|
|
|
|
if Nkind (Item) = N_With_Clause
|
|
and then not Implicit_With (Item)
|
|
then
|
|
-- If Name (Item) is not an entity name, something is wrong, and
|
|
-- this will be detected in due course, for now ignore the item
|
|
|
|
if not Is_Entity_Name (Name (Item)) then
|
|
goto Continue;
|
|
end if;
|
|
|
|
Uname_Node := Entity (Name (Item));
|
|
|
|
if Is_Private_Descendant (Uname_Node) then
|
|
Check_Private := True;
|
|
end if;
|
|
|
|
Install_Withed_Unit (Item);
|
|
|
|
Decl_Node := Unit_Declaration_Node (Uname_Node);
|
|
|
|
-- If the unit is a subprogram instance, it appears nested
|
|
-- within a package that carries the parent information.
|
|
|
|
if Is_Generic_Instance (Uname_Node)
|
|
and then Ekind (Uname_Node) /= E_Package
|
|
then
|
|
Decl_Node := Parent (Parent (Decl_Node));
|
|
end if;
|
|
|
|
if Is_Child_Spec (Decl_Node) then
|
|
if Nkind (Name (Item)) = N_Expanded_Name then
|
|
Expand_With_Clause (Prefix (Name (Item)), N);
|
|
else
|
|
-- if not an expanded name, the child unit must be a
|
|
-- renaming, nothing to do.
|
|
|
|
null;
|
|
end if;
|
|
|
|
elsif Nkind (Decl_Node) = N_Subprogram_Body
|
|
and then not Acts_As_Spec (Parent (Decl_Node))
|
|
and then Is_Child_Spec (Unit (Library_Unit (Parent (Decl_Node))))
|
|
then
|
|
Implicit_With_On_Parent
|
|
(Unit (Library_Unit (Parent (Decl_Node))), N);
|
|
end if;
|
|
|
|
-- Check license conditions unless this is a dummy unit
|
|
|
|
if Sloc (Library_Unit (Item)) /= No_Location then
|
|
License_Check : declare
|
|
Withl : constant License_Type :=
|
|
License (Source_Index
|
|
(Get_Source_Unit
|
|
(Library_Unit (Item))));
|
|
|
|
Unitl : constant License_Type :=
|
|
License (Source_Index (Current_Sem_Unit));
|
|
|
|
procedure License_Error;
|
|
-- Signal error of bad license
|
|
|
|
-------------------
|
|
-- License_Error --
|
|
-------------------
|
|
|
|
procedure License_Error is
|
|
begin
|
|
Error_Msg_N
|
|
("?license of with'ed unit & is incompatible",
|
|
Name (Item));
|
|
end License_Error;
|
|
|
|
-- Start of processing for License_Check
|
|
|
|
begin
|
|
case Unitl is
|
|
when Unknown =>
|
|
null;
|
|
|
|
when Restricted =>
|
|
if Withl = GPL then
|
|
License_Error;
|
|
end if;
|
|
|
|
when GPL =>
|
|
if Withl = Restricted then
|
|
License_Error;
|
|
end if;
|
|
|
|
when Modified_GPL =>
|
|
if Withl = Restricted or else Withl = GPL then
|
|
License_Error;
|
|
end if;
|
|
|
|
when Unrestricted =>
|
|
null;
|
|
end case;
|
|
end License_Check;
|
|
end if;
|
|
|
|
-- Case of USE PACKAGE clause
|
|
|
|
elsif Nkind (Item) = N_Use_Package_Clause then
|
|
Analyze_Use_Package (Item);
|
|
|
|
-- Case of USE TYPE clause
|
|
|
|
elsif Nkind (Item) = N_Use_Type_Clause then
|
|
Analyze_Use_Type (Item);
|
|
|
|
-- Case of WITH TYPE clause
|
|
|
|
-- A With_Type_Clause is processed when installing the context,
|
|
-- because it is a visibility mechanism and does not create a
|
|
-- semantic dependence on other units, as a With_Clause does.
|
|
|
|
elsif Nkind (Item) = N_With_Type_Clause then
|
|
Analyze_With_Type_Clause (Item);
|
|
|
|
-- case of PRAGMA
|
|
|
|
elsif Nkind (Item) = N_Pragma then
|
|
Analyze (Item);
|
|
end if;
|
|
|
|
<<Continue>>
|
|
Next (Item);
|
|
end loop;
|
|
|
|
if Is_Child_Spec (Lib_Unit) then
|
|
|
|
-- The unit also has implicit withs on its own parents.
|
|
|
|
if No (Context_Items (N)) then
|
|
Set_Context_Items (N, New_List);
|
|
end if;
|
|
|
|
Implicit_With_On_Parent (Lib_Unit, N);
|
|
end if;
|
|
|
|
-- If the unit is a body, the context of the specification must also
|
|
-- be installed.
|
|
|
|
if Nkind (Lib_Unit) = N_Package_Body
|
|
or else (Nkind (Lib_Unit) = N_Subprogram_Body
|
|
and then not Acts_As_Spec (N))
|
|
then
|
|
Install_Context (Library_Unit (N));
|
|
|
|
if Is_Child_Spec (Unit (Library_Unit (N))) then
|
|
|
|
-- If the unit is the body of a public child unit, the private
|
|
-- declarations of the parent must be made visible. If the child
|
|
-- unit is private, the private declarations have been installed
|
|
-- already in the call to Install_Parents for the spec. Installing
|
|
-- private declarations must be done for all ancestors of public
|
|
-- child units. In addition, sibling units mentioned in the
|
|
-- context clause of the body are directly visible.
|
|
|
|
declare
|
|
Lib_Spec : Node_Id := Unit (Library_Unit (N));
|
|
P : Node_Id;
|
|
P_Name : Entity_Id;
|
|
|
|
begin
|
|
while Is_Child_Spec (Lib_Spec) loop
|
|
P := Unit (Parent_Spec (Lib_Spec));
|
|
|
|
if not (Private_Present (Parent (Lib_Spec))) then
|
|
P_Name := Defining_Entity (P);
|
|
Install_Private_Declarations (P_Name);
|
|
Set_Use (Private_Declarations (Specification (P)));
|
|
end if;
|
|
|
|
Lib_Spec := P;
|
|
end loop;
|
|
end;
|
|
end if;
|
|
|
|
-- For a package body, children in context are immediately visible
|
|
|
|
Install_Siblings (Defining_Entity (Unit (Library_Unit (N))), N);
|
|
end if;
|
|
|
|
if Nkind (Lib_Unit) = N_Generic_Package_Declaration
|
|
or else Nkind (Lib_Unit) = N_Generic_Subprogram_Declaration
|
|
or else Nkind (Lib_Unit) = N_Package_Declaration
|
|
or else Nkind (Lib_Unit) = N_Subprogram_Declaration
|
|
then
|
|
if Is_Child_Spec (Lib_Unit) then
|
|
Lib_Parent := Defining_Entity (Unit (Parent_Spec (Lib_Unit)));
|
|
Set_Is_Private_Descendant
|
|
(Defining_Entity (Lib_Unit),
|
|
Is_Private_Descendant (Lib_Parent)
|
|
or else Private_Present (Parent (Lib_Unit)));
|
|
|
|
else
|
|
Set_Is_Private_Descendant
|
|
(Defining_Entity (Lib_Unit),
|
|
Private_Present (Parent (Lib_Unit)));
|
|
end if;
|
|
end if;
|
|
|
|
if Check_Private then
|
|
Check_Private_Child_Unit (N);
|
|
end if;
|
|
end Install_Context_Clauses;
|
|
|
|
---------------------
|
|
-- Install_Parents --
|
|
---------------------
|
|
|
|
procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean) is
|
|
P : Node_Id;
|
|
E_Name : Entity_Id;
|
|
P_Name : Entity_Id;
|
|
P_Spec : Node_Id;
|
|
|
|
begin
|
|
P := Unit (Parent_Spec (Lib_Unit));
|
|
P_Name := Defining_Entity (P);
|
|
|
|
if Etype (P_Name) = Any_Type then
|
|
return;
|
|
end if;
|
|
|
|
if Ekind (P_Name) = E_Generic_Package
|
|
and then Nkind (Lib_Unit) /= N_Generic_Subprogram_Declaration
|
|
and then Nkind (Lib_Unit) /= N_Generic_Package_Declaration
|
|
and then Nkind (Lib_Unit) not in N_Generic_Renaming_Declaration
|
|
then
|
|
Error_Msg_N
|
|
("child of a generic package must be a generic unit", Lib_Unit);
|
|
|
|
elsif not Is_Package (P_Name) then
|
|
Error_Msg_N
|
|
("parent unit must be package or generic package", Lib_Unit);
|
|
raise Unrecoverable_Error;
|
|
|
|
elsif Present (Renamed_Object (P_Name)) then
|
|
Error_Msg_N ("parent unit cannot be a renaming", Lib_Unit);
|
|
raise Unrecoverable_Error;
|
|
|
|
-- Verify that a child of an instance is itself an instance, or
|
|
-- the renaming of one. Given that an instance that is a unit is
|
|
-- replaced with a package declaration, check against the original
|
|
-- node.
|
|
|
|
elsif Nkind (Original_Node (P)) = N_Package_Instantiation
|
|
and then Nkind (Lib_Unit)
|
|
not in N_Renaming_Declaration
|
|
and then Nkind (Original_Node (Lib_Unit))
|
|
not in N_Generic_Instantiation
|
|
then
|
|
Error_Msg_N
|
|
("child of an instance must be an instance or renaming", Lib_Unit);
|
|
end if;
|
|
|
|
-- This is the recursive call that ensures all parents are loaded
|
|
|
|
if Is_Child_Spec (P) then
|
|
Install_Parents (P,
|
|
Is_Private or else Private_Present (Parent (Lib_Unit)));
|
|
end if;
|
|
|
|
-- Now we can install the context for this parent
|
|
|
|
Install_Context_Clauses (Parent_Spec (Lib_Unit));
|
|
Install_Siblings (P_Name, Parent (Lib_Unit));
|
|
|
|
-- The child unit is in the declarative region of the parent. The
|
|
-- parent must therefore appear in the scope stack and be visible,
|
|
-- as when compiling the corresponding body. If the child unit is
|
|
-- private or it is a package body, private declarations must be
|
|
-- accessible as well. Use declarations in the parent must also
|
|
-- be installed. Finally, other child units of the same parent that
|
|
-- are in the context are immediately visible.
|
|
|
|
-- Find entity for compilation unit, and set its private descendant
|
|
-- status as needed.
|
|
|
|
E_Name := Defining_Entity (Lib_Unit);
|
|
|
|
Set_Is_Child_Unit (E_Name);
|
|
|
|
Set_Is_Private_Descendant (E_Name,
|
|
Is_Private_Descendant (P_Name)
|
|
or else Private_Present (Parent (Lib_Unit)));
|
|
|
|
P_Spec := Specification (Unit_Declaration_Node (P_Name));
|
|
New_Scope (P_Name);
|
|
|
|
-- Save current visibility of unit
|
|
|
|
Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility :=
|
|
Is_Immediately_Visible (P_Name);
|
|
Set_Is_Immediately_Visible (P_Name);
|
|
Install_Visible_Declarations (P_Name);
|
|
Set_Use (Visible_Declarations (P_Spec));
|
|
|
|
if Is_Private
|
|
or else Private_Present (Parent (Lib_Unit))
|
|
then
|
|
Install_Private_Declarations (P_Name);
|
|
Set_Use (Private_Declarations (P_Spec));
|
|
end if;
|
|
end Install_Parents;
|
|
|
|
----------------------
|
|
-- Install_Siblings --
|
|
----------------------
|
|
|
|
procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id) is
|
|
Item : Node_Id;
|
|
Id : Entity_Id;
|
|
Prev : Entity_Id;
|
|
|
|
function Is_Ancestor (E : Entity_Id) return Boolean;
|
|
-- Determine whether the scope of a child unit is an ancestor of
|
|
-- the current unit.
|
|
-- Shouldn't this be somewhere more general ???
|
|
|
|
function Is_Ancestor (E : Entity_Id) return Boolean is
|
|
Par : Entity_Id;
|
|
|
|
begin
|
|
Par := U_Name;
|
|
|
|
while Present (Par)
|
|
and then Par /= Standard_Standard
|
|
loop
|
|
|
|
if Par = E then
|
|
return True;
|
|
end if;
|
|
|
|
Par := Scope (Par);
|
|
end loop;
|
|
|
|
return False;
|
|
end Is_Ancestor;
|
|
|
|
-- Start of processing for Install_Siblings
|
|
|
|
begin
|
|
-- Iterate over explicit with clauses, and check whether the
|
|
-- scope of each entity is an ancestor of the current unit.
|
|
|
|
Item := First (Context_Items (N));
|
|
|
|
while Present (Item) loop
|
|
|
|
if Nkind (Item) = N_With_Clause
|
|
and then not Implicit_With (Item)
|
|
then
|
|
Id := Entity (Name (Item));
|
|
|
|
if Is_Child_Unit (Id)
|
|
and then Is_Ancestor (Scope (Id))
|
|
then
|
|
Set_Is_Immediately_Visible (Id);
|
|
Prev := Current_Entity (Id);
|
|
|
|
-- Check for the presence of another unit in the context,
|
|
-- that may be inadvertently hidden by the child.
|
|
|
|
if Present (Prev)
|
|
and then Is_Immediately_Visible (Prev)
|
|
and then not Is_Child_Unit (Prev)
|
|
then
|
|
declare
|
|
Clause : Node_Id;
|
|
|
|
begin
|
|
Clause := First (Context_Items (N));
|
|
|
|
while Present (Clause) loop
|
|
if Nkind (Clause) = N_With_Clause
|
|
and then Entity (Name (Clause)) = Prev
|
|
then
|
|
Error_Msg_NE
|
|
("child unit& hides compilation unit " &
|
|
"with the same name?",
|
|
Name (Item), Id);
|
|
exit;
|
|
end if;
|
|
|
|
Next (Clause);
|
|
end loop;
|
|
end;
|
|
end if;
|
|
|
|
-- the With_Clause may be on a grand-child, which makes
|
|
-- the child immediately visible.
|
|
|
|
elsif Is_Child_Unit (Scope (Id))
|
|
and then Is_Ancestor (Scope (Scope (Id)))
|
|
then
|
|
Set_Is_Immediately_Visible (Scope (Id));
|
|
end if;
|
|
end if;
|
|
|
|
Next (Item);
|
|
end loop;
|
|
end Install_Siblings;
|
|
|
|
-------------------------
|
|
-- Install_Withed_Unit --
|
|
-------------------------
|
|
|
|
procedure Install_Withed_Unit (With_Clause : Node_Id) is
|
|
Uname : Entity_Id := Entity (Name (With_Clause));
|
|
P : constant Entity_Id := Scope (Uname);
|
|
|
|
begin
|
|
-- 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))
|
|
or else Current_Sem_Unit = Main_Unit)
|
|
then
|
|
Check_Restricted_Unit
|
|
(Unit_Name (Get_Source_Unit (Uname)), With_Clause);
|
|
end if;
|
|
|
|
if P /= Standard_Standard then
|
|
|
|
-- If the unit is not analyzed after analysis of the with clause,
|
|
-- and it is an instantiation, then it awaits a body and is the main
|
|
-- unit. Its appearance in the context of some other unit indicates
|
|
-- a circular dependency (DEC suite perversity).
|
|
|
|
if not Analyzed (Uname)
|
|
and then Nkind (Parent (Uname)) = N_Package_Instantiation
|
|
then
|
|
Error_Msg_N
|
|
("instantiation depends on itself", Name (With_Clause));
|
|
|
|
elsif not Is_Visible_Child_Unit (Uname) then
|
|
Set_Is_Visible_Child_Unit (Uname);
|
|
|
|
if Is_Generic_Instance (Uname)
|
|
and then Ekind (Uname) in Subprogram_Kind
|
|
then
|
|
-- Set flag as well on the visible entity that denotes the
|
|
-- instance, which renames the current one.
|
|
|
|
Set_Is_Visible_Child_Unit
|
|
(Related_Instance
|
|
(Defining_Entity (Unit (Library_Unit (With_Clause)))));
|
|
null;
|
|
end if;
|
|
|
|
-- The parent unit may have been installed already, and
|
|
-- may have appeared in a use clause.
|
|
|
|
if In_Use (Scope (Uname)) then
|
|
Set_Is_Potentially_Use_Visible (Uname);
|
|
end if;
|
|
|
|
Set_Context_Installed (With_Clause);
|
|
end if;
|
|
|
|
elsif not Is_Immediately_Visible (Uname) then
|
|
Set_Is_Immediately_Visible (Uname);
|
|
Set_Context_Installed (With_Clause);
|
|
end if;
|
|
|
|
-- A with-clause overrides a with-type clause: there are no restric-
|
|
-- tions on the use of package entities.
|
|
|
|
if Ekind (Uname) = E_Package then
|
|
Set_From_With_Type (Uname, False);
|
|
end if;
|
|
end Install_Withed_Unit;
|
|
|
|
-------------------
|
|
-- Is_Child_Spec --
|
|
-------------------
|
|
|
|
function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean is
|
|
K : constant Node_Kind := Nkind (Lib_Unit);
|
|
|
|
begin
|
|
return (K in N_Generic_Declaration or else
|
|
K in N_Generic_Instantiation or else
|
|
K in N_Generic_Renaming_Declaration or else
|
|
K = N_Package_Declaration or else
|
|
K = N_Package_Renaming_Declaration or else
|
|
K = N_Subprogram_Declaration or else
|
|
K = N_Subprogram_Renaming_Declaration)
|
|
and then Present (Parent_Spec (Lib_Unit));
|
|
end Is_Child_Spec;
|
|
|
|
-----------------------
|
|
-- Load_Needed_Body --
|
|
-----------------------
|
|
|
|
-- N is a generic unit named in a with clause, or else it is
|
|
-- a unit that contains a generic unit or an inlined function.
|
|
-- In order to perform an instantiation, the body of the unit
|
|
-- must be present. If the unit itself is generic, we assume
|
|
-- that an instantiation follows, and load and analyze the body
|
|
-- unconditionally. This forces analysis of the spec as well.
|
|
|
|
-- If the unit is not generic, but contains a generic unit, it
|
|
-- is loaded on demand, at the point of instantiation (see ch12).
|
|
|
|
procedure Load_Needed_Body (N : Node_Id; OK : out Boolean) is
|
|
Body_Name : Unit_Name_Type;
|
|
Unum : Unit_Number_Type;
|
|
|
|
Save_Style_Check : constant Boolean := Opt.Style_Check;
|
|
-- The loading and analysis is done with style checks off
|
|
|
|
begin
|
|
if not GNAT_Mode then
|
|
Style_Check := False;
|
|
end if;
|
|
|
|
Body_Name := Get_Body_Name (Get_Unit_Name (Unit (N)));
|
|
Unum :=
|
|
Load_Unit
|
|
(Load_Name => Body_Name,
|
|
Required => False,
|
|
Subunit => False,
|
|
Error_Node => N,
|
|
Renamings => True);
|
|
|
|
if Unum = No_Unit then
|
|
OK := False;
|
|
|
|
else
|
|
Compiler_State := Analyzing; -- reset after load
|
|
|
|
if not Fatal_Error (Unum) then
|
|
if Debug_Flag_L then
|
|
Write_Str ("*** Loaded generic body");
|
|
Write_Eol;
|
|
end if;
|
|
|
|
Semantics (Cunit (Unum));
|
|
end if;
|
|
|
|
OK := True;
|
|
end if;
|
|
|
|
Style_Check := Save_Style_Check;
|
|
end Load_Needed_Body;
|
|
|
|
--------------------
|
|
-- Remove_Context --
|
|
--------------------
|
|
|
|
procedure Remove_Context (N : Node_Id) is
|
|
Lib_Unit : constant Node_Id := Unit (N);
|
|
|
|
begin
|
|
-- If this is a child unit, first remove the parent units.
|
|
|
|
if Is_Child_Spec (Lib_Unit) then
|
|
Remove_Parents (Lib_Unit);
|
|
end if;
|
|
|
|
Remove_Context_Clauses (N);
|
|
end Remove_Context;
|
|
|
|
----------------------------
|
|
-- Remove_Context_Clauses --
|
|
----------------------------
|
|
|
|
procedure Remove_Context_Clauses (N : Node_Id) is
|
|
Item : Node_Id;
|
|
Unit_Name : Entity_Id;
|
|
|
|
begin
|
|
|
|
-- Loop through context items and undo with_clauses and use_clauses.
|
|
|
|
Item := First (Context_Items (N));
|
|
|
|
while Present (Item) loop
|
|
|
|
-- We are interested only in with clauses which got installed
|
|
-- on entry, as indicated by their Context_Installed flag set
|
|
|
|
if Nkind (Item) = N_With_Clause
|
|
and then Context_Installed (Item)
|
|
then
|
|
-- Remove items from one with'ed unit
|
|
|
|
Unit_Name := Entity (Name (Item));
|
|
Remove_Unit_From_Visibility (Unit_Name);
|
|
Set_Context_Installed (Item, False);
|
|
|
|
elsif Nkind (Item) = N_Use_Package_Clause then
|
|
End_Use_Package (Item);
|
|
|
|
elsif Nkind (Item) = N_Use_Type_Clause then
|
|
End_Use_Type (Item);
|
|
|
|
elsif Nkind (Item) = N_With_Type_Clause then
|
|
Remove_With_Type_Clause (Name (Item));
|
|
end if;
|
|
|
|
Next (Item);
|
|
end loop;
|
|
|
|
end Remove_Context_Clauses;
|
|
|
|
--------------------
|
|
-- Remove_Parents --
|
|
--------------------
|
|
|
|
procedure Remove_Parents (Lib_Unit : Node_Id) is
|
|
P : Node_Id;
|
|
P_Name : Entity_Id;
|
|
E : Entity_Id;
|
|
Vis : constant Boolean :=
|
|
Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility;
|
|
|
|
begin
|
|
if Is_Child_Spec (Lib_Unit) then
|
|
P := Unit (Parent_Spec (Lib_Unit));
|
|
P_Name := Defining_Entity (P);
|
|
|
|
Remove_Context_Clauses (Parent_Spec (Lib_Unit));
|
|
End_Package_Scope (P_Name);
|
|
Set_Is_Immediately_Visible (P_Name, Vis);
|
|
|
|
-- Remove from visibility the siblings as well, which are directly
|
|
-- visible while the parent is in scope.
|
|
|
|
E := First_Entity (P_Name);
|
|
|
|
while Present (E) loop
|
|
|
|
if Is_Child_Unit (E) then
|
|
Set_Is_Immediately_Visible (E, False);
|
|
end if;
|
|
|
|
Next_Entity (E);
|
|
end loop;
|
|
|
|
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.
|
|
|
|
Remove_Parents (P);
|
|
end if;
|
|
end Remove_Parents;
|
|
|
|
-----------------------------
|
|
-- Remove_With_Type_Clause --
|
|
-----------------------------
|
|
|
|
procedure Remove_With_Type_Clause (Name : Node_Id) is
|
|
Typ : Entity_Id;
|
|
P : Entity_Id;
|
|
|
|
procedure Unchain (E : Entity_Id);
|
|
-- Remove entity from visibility list.
|
|
|
|
procedure Unchain (E : Entity_Id) is
|
|
Prev : Entity_Id;
|
|
|
|
begin
|
|
Prev := Current_Entity (E);
|
|
|
|
-- Package entity may appear is several with_type_clauses, and
|
|
-- may have been removed already.
|
|
|
|
if No (Prev) then
|
|
return;
|
|
|
|
elsif Prev = E then
|
|
Set_Name_Entity_Id (Chars (E), Homonym (E));
|
|
|
|
else
|
|
while Present (Prev)
|
|
and then Homonym (Prev) /= E
|
|
loop
|
|
Prev := Homonym (Prev);
|
|
end loop;
|
|
|
|
if (Present (Prev)) then
|
|
Set_Homonym (Prev, Homonym (E));
|
|
end if;
|
|
end if;
|
|
end Unchain;
|
|
|
|
begin
|
|
if Nkind (Name) = N_Selected_Component then
|
|
Typ := Entity (Selector_Name (Name));
|
|
|
|
if No (Typ) then -- error in declaration.
|
|
return;
|
|
end if;
|
|
else
|
|
return;
|
|
end if;
|
|
|
|
P := Scope (Typ);
|
|
|
|
-- If the exporting package has been analyzed, it has appeared in the
|
|
-- context already and should be left alone. Otherwise, remove from
|
|
-- visibility.
|
|
|
|
if not Analyzed (Unit_Declaration_Node (P)) then
|
|
Unchain (P);
|
|
Unchain (Typ);
|
|
Set_Is_Frozen (Typ, False);
|
|
end if;
|
|
|
|
if Ekind (Typ) = E_Record_Type then
|
|
Set_From_With_Type (Class_Wide_Type (Typ), False);
|
|
Set_From_With_Type (Typ, False);
|
|
end if;
|
|
|
|
Set_From_With_Type (P, False);
|
|
|
|
-- If P is a child unit, remove parents as well.
|
|
|
|
P := Scope (P);
|
|
|
|
while Present (P)
|
|
and then P /= Standard_Standard
|
|
loop
|
|
Set_From_With_Type (P, False);
|
|
|
|
if not Analyzed (Unit_Declaration_Node (P)) then
|
|
Unchain (P);
|
|
end if;
|
|
|
|
P := Scope (P);
|
|
end loop;
|
|
|
|
-- The back-end needs to know that an access type is imported, so it
|
|
-- does not need elaboration and can appear in a mutually recursive
|
|
-- record definition, so the imported flag on an access type is
|
|
-- preserved.
|
|
|
|
end Remove_With_Type_Clause;
|
|
|
|
---------------------------------
|
|
-- Remove_Unit_From_Visibility --
|
|
---------------------------------
|
|
|
|
procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id) is
|
|
P : Entity_Id := Scope (Unit_Name);
|
|
|
|
begin
|
|
|
|
if Debug_Flag_I then
|
|
Write_Str ("remove withed unit ");
|
|
Write_Name (Chars (Unit_Name));
|
|
Write_Eol;
|
|
end if;
|
|
|
|
if P /= Standard_Standard then
|
|
Set_Is_Visible_Child_Unit (Unit_Name, False);
|
|
end if;
|
|
|
|
Set_Is_Potentially_Use_Visible (Unit_Name, False);
|
|
Set_Is_Immediately_Visible (Unit_Name, False);
|
|
|
|
end Remove_Unit_From_Visibility;
|
|
|
|
end Sem_Ch10;
|