Google Git
Sign in
gnu / gcc / 19220ca6aa79921cc431e41f25986e16410c7a6a / . / gcc / ada / sem_ch12.adb
blob: 6a8c9873fde9c7b7f61a3d8125bd358f19d59ecf [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S E M _ C H 1 2 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004, 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. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Expander; use Expander;
with Fname; use Fname;
with Fname.UF; use Fname.UF;
with Freeze; use Freeze;
with Hostparm;
with Inline; use Inline;
with Lib; use Lib;
with Lib.Load; use Lib.Load;
with Lib.Xref; use Lib.Xref;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch10; use Sem_Ch10;
with Sem_Ch13; use Sem_Ch13;
with Sem_Elab; use Sem_Elab;
with Sem_Elim; use Sem_Elim;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
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 Sinput.L; use Sinput.L;
with Snames; use Snames;
with Stringt; use Stringt;
with Uname; use Uname;
with Table;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with Urealp; use Urealp;
with GNAT.HTable;
package body Sem_Ch12 is
----------------------------------------------------------
-- Implementation of Generic Analysis and Instantiation --
-----------------------------------------------------------
-- GNAT implements generics by macro expansion. No attempt is made to
-- share generic instantiations (for now). Analysis of a generic definition
-- does not perform any expansion action, but the expander must be called
-- on the tree for each instantiation, because the expansion may of course
-- depend on the generic actuals. All of this is best achieved as follows:
--
-- a) Semantic analysis of a generic unit is performed on a copy of the
-- tree for the generic unit. All tree modifications that follow analysis
-- do not affect the original tree. Links are kept between the original
-- tree and the copy, in order to recognize non-local references within
-- the generic, and propagate them to each instance (recall that name
-- resolution is done on the generic declaration: generics are not really
-- macros!). This is summarized in the following diagram:
--
-- .-----------. .----------.
-- | semantic |<--------------| generic |
-- | copy | | unit |
-- | |==============>| |
-- |___________| global |__________|
-- references | | |
-- | | |
-- .-----|--|.
-- | .-----|---.
-- | | .----------.
-- | | | generic |
-- |__| | |
-- |__| instance |
-- |__________|
--
-- b) Each instantiation copies the original tree, and inserts into it a
-- series of declarations that describe the mapping between generic formals
-- and actuals. For example, a generic In OUT parameter is an object
-- renaming of the corresponing actual, etc. Generic IN parameters are
-- constant declarations.
--
-- c) In order to give the right visibility for these renamings, we use
-- a different scheme for package and subprogram instantiations. For
-- packages, the list of renamings is inserted into the package
-- specification, before the visible declarations of the package. The
-- renamings are analyzed before any of the text of the instance, and are
-- thus visible at the right place. Furthermore, outside of the instance,
-- the generic parameters are visible and denote their corresponding
-- actuals.
-- For subprograms, we create a container package to hold the renamings
-- and the subprogram instance itself. Analysis of the package makes the
-- renaming declarations visible to the subprogram. After analyzing the
-- package, the defining entity for the subprogram is touched-up so that
-- it appears declared in the current scope, and not inside the container
-- package.
-- If the instantiation is a compilation unit, the container package is
-- given the same name as the subprogram instance. This ensures that
-- the elaboration procedure called by the binder, using the compilation
-- unit name, calls in fact the elaboration procedure for the package.
-- Not surprisingly, private types complicate this approach. By saving in
-- the original generic object the non-local references, we guarantee that
-- the proper entities are referenced at the point of instantiation.
-- However, for private types, this by itself does not insure that the
-- proper VIEW of the entity is used (the full type may be visible at the
-- point of generic definition, but not at instantiation, or vice-versa).
-- In order to reference the proper view, we special-case any reference
-- to private types in the generic object, by saving both views, one in
-- the generic and one in the semantic copy. At time of instantiation, we
-- check whether the two views are consistent, and exchange declarations if
-- necessary, in order to restore the correct visibility. Similarly, if
-- the instance view is private when the generic view was not, we perform
-- the exchange. After completing the instantiation, we restore the
-- current visibility. The flag Has_Private_View marks identifiers in the
-- the generic unit that require checking.
-- Visibility within nested generic units requires special handling.
-- Consider the following scheme:
--
-- type Global is ... -- outside of generic unit.
-- generic ...
-- package Outer is
-- ...
-- type Semi_Global is ... -- global to inner.
--
-- generic ... -- 1
-- procedure inner (X1 : Global; X2 : Semi_Global);
--
-- procedure in2 is new inner (...); -- 4
-- end Outer;
-- package New_Outer is new Outer (...); -- 2
-- procedure New_Inner is new New_Outer.Inner (...); -- 3
-- The semantic analysis of Outer captures all occurrences of Global.
-- The semantic analysis of Inner (at 1) captures both occurrences of
-- Global and Semi_Global.
-- At point 2 (instantiation of Outer), we also produce a generic copy
-- of Inner, even though Inner is, at that point, not being instantiated.
-- (This is just part of the semantic analysis of New_Outer).
-- Critically, references to Global within Inner must be preserved, while
-- references to Semi_Global should not preserved, because they must now
-- resolve to an entity within New_Outer. To distinguish between these, we
-- use a global variable, Current_Instantiated_Parent, which is set when
-- performing a generic copy during instantiation (at 2). This variable is
-- used when performing a generic copy that is not an instantiation, but
-- that is nested within one, as the occurrence of 1 within 2. The analysis
-- of a nested generic only preserves references that are global to the
-- enclosing Current_Instantiated_Parent. We use the Scope_Depth value to
-- determine whether a reference is external to the given parent.
-- The instantiation at point 3 requires no special treatment. The method
-- works as well for further nestings of generic units, but of course the
-- variable Current_Instantiated_Parent must be stacked because nested
-- instantiations can occur, e.g. the occurrence of 4 within 2.
-- The instantiation of package and subprogram bodies is handled in a
-- similar manner, except that it is delayed until after semantic
-- analysis is complete. In this fashion complex cross-dependencies
-- between several package declarations and bodies containing generics
-- can be compiled which otherwise would diagnose spurious circularities.
-- For example, it is possible to compile two packages A and B that
-- have the following structure:
-- package A is package B is
-- generic ... generic ...
-- package G_A is package G_B is
-- with B; with A;
-- package body A is package body B is
-- package N_B is new G_B (..) package N_A is new G_A (..)
-- The table Pending_Instantiations in package Inline is used to keep
-- track of body instantiations that are delayed in this manner. Inline
-- handles the actual calls to do the body instantiations. This activity
-- is part of Inline, since the processing occurs at the same point, and
-- for essentially the same reason, as the handling of inlined routines.
----------------------------------------------
-- Detection of Instantiation Circularities --
----------------------------------------------
-- If we have a chain of instantiations that is circular, this is a
-- static error which must be detected at compile time. The detection
-- of these circularities is carried out at the point that we insert
-- a generic instance spec or body. If there is a circularity, then
-- the analysis of the offending spec or body will eventually result
-- in trying to load the same unit again, and we detect this problem
-- as we analyze the package instantiation for the second time.
-- At least in some cases after we have detected the circularity, we
-- get into trouble if we try to keep going. The following flag is
-- set if a circularity is detected, and used to abandon compilation
-- after the messages have been posted.
Circularity_Detected : Boolean := False;
-- This should really be reset on encountering a new main unit, but in
-- practice we are not using multiple main units so it is not critical.
-----------------------
-- Local subprograms --
-----------------------
procedure Abandon_Instantiation (N : Node_Id);
pragma No_Return (Abandon_Instantiation);
-- Posts an error message "instantiation abandoned" at the indicated
-- node and then raises the exception Instantiation_Error to do it.
procedure Analyze_Formal_Array_Type
(T : in out Entity_Id;
Def : Node_Id);
-- A formal array type is treated like an array type declaration, and
-- invokes Array_Type_Declaration (sem_ch3) whose first parameter is
-- in-out, because in the case of an anonymous type the entity is
-- actually created in the procedure.
-- The following procedures treat other kinds of formal parameters.
procedure Analyze_Formal_Derived_Type
(N : Node_Id;
T : Entity_Id;
Def : Node_Id);
-- All the following need comments???
procedure Analyze_Formal_Decimal_Fixed_Point_Type
(T : Entity_Id; Def : Node_Id);
procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id);
procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id);
procedure Analyze_Formal_Signed_Integer_Type (T : Entity_Id; Def : Node_Id);
procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id);
procedure Analyze_Formal_Ordinary_Fixed_Point_Type
(T : Entity_Id; Def : Node_Id);
procedure Analyze_Formal_Private_Type
(N : Node_Id;
T : Entity_Id;
Def : Node_Id);
-- This needs comments???
procedure Analyze_Generic_Formal_Part (N : Node_Id);
procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id);
-- This needs comments ???
function Analyze_Associations
(I_Node : Node_Id;
Formals : List_Id;
F_Copy : List_Id)
return List_Id;
-- At instantiation time, build the list of associations between formals
-- and actuals. Each association becomes a renaming declaration for the
-- formal entity. F_Copy is the analyzed list of formals in the generic
-- copy. It is used to apply legality checks to the actuals. I_Node is the
-- instantiation node itself.
procedure Analyze_Subprogram_Instantiation
(N : Node_Id;
K : Entity_Kind);
procedure Build_Instance_Compilation_Unit_Nodes
(N : Node_Id;
Act_Body : Node_Id;
Act_Decl : Node_Id);
-- This procedure is used in the case where the generic instance of a
-- subprogram body or package body is a library unit. In this case, the
-- original library unit node for the generic instantiation must be
-- replaced by the resulting generic body, and a link made to a new
-- compilation unit node for the generic declaration. The argument N is
-- the original generic instantiation. Act_Body and Act_Decl are the body
-- and declaration of the instance (either package body and declaration
-- nodes or subprogram body and declaration nodes depending on the case).
-- On return, the node N has been rewritten with the actual body.
procedure Check_Formal_Packages (P_Id : Entity_Id);
-- Apply the following to all formal packages in generic associations.
procedure Check_Formal_Package_Instance
(Formal_Pack : Entity_Id;
Actual_Pack : Entity_Id);
-- Verify that the actuals of the actual instance match the actuals of
-- the template for a formal package that is not declared with a box.
procedure Check_Forward_Instantiation (Decl : Node_Id);
-- If the generic is a local entity and the corresponding body has not
-- been seen yet, flag enclosing packages to indicate that it will be
-- elaborated after the generic body. Subprograms declared in the same
-- package cannot be inlined by the front-end because front-end inlining
-- requires a strict linear order of elaboration.
procedure Check_Hidden_Child_Unit
(N : Node_Id;
Gen_Unit : Entity_Id;
Act_Decl_Id : Entity_Id);
-- If the generic unit is an implicit child instance within a parent
-- instance, we need to make an explicit test that it is not hidden by
-- a child instance of the same name and parent.
procedure Check_Private_View (N : Node_Id);
-- Check whether the type of a generic entity has a different view between
-- the point of generic analysis and the point of instantiation. If the
-- view has changed, then at the point of instantiation we restore the
-- correct view to perform semantic analysis of the instance, and reset
-- the current view after instantiation. The processing is driven by the
-- current private status of the type of the node, and Has_Private_View,
-- a flag that is set at the point of generic compilation. If view and
-- flag are inconsistent then the type is updated appropriately.
procedure Check_Generic_Actuals
(Instance : Entity_Id;
Is_Formal_Box : Boolean);
-- Similar to previous one. Check the actuals in the instantiation,
-- whose views can change between the point of instantiation and the point
-- of instantiation of the body. In addition, mark the generic renamings
-- as generic actuals, so that they are not compatible with other actuals.
-- Recurse on an actual that is a formal package whose declaration has
-- a box.
function Contains_Instance_Of
(Inner : Entity_Id;
Outer : Entity_Id;
N : Node_Id)
return Boolean;
-- Inner is instantiated within the generic Outer. Check whether Inner
-- directly or indirectly contains an instance of Outer or of one of its
-- parents, in the case of a subunit. Each generic unit holds a list of
-- the entities instantiated within (at any depth). This procedure
-- determines whether the set of such lists contains a cycle, i.e. an
-- illegal circular instantiation.
function Denotes_Formal_Package (Pack : Entity_Id) return Boolean;
-- Returns True if E is a formal package of an enclosing generic, or
-- the actual for such a formal in an enclosing instantiation. Used in
-- Restore_Private_Views, to keep the formals of such a package visible
-- on exit from an inner instantiation.
function Find_Actual_Type
(Typ : Entity_Id;
Gen_Scope : Entity_Id)
return Entity_Id;
-- When validating the actual types of a child instance, check whether
-- the formal is a formal type of the parent unit, and retrieve the current
-- actual for it. Typ is the entity in the analyzed formal type declaration
-- (component or index type of an array type) and Gen_Scope is the scope of
-- the analyzed formal array type.
function Get_Package_Instantiation_Node (A : Entity_Id) return Node_Id;
-- Given the entity of a unit that is an instantiation, retrieve the
-- original instance node. This is used when loading the instantiations
-- of the ancestors of a child generic that is being instantiated.
function In_Same_Declarative_Part
(F_Node : Node_Id;
Inst : Node_Id)
return Boolean;
-- True if the instantiation Inst and the given freeze_node F_Node appear
-- within the same declarative part, ignoring subunits, but with no inter-
-- vening suprograms or concurrent units. If true, the freeze node
-- of the instance can be placed after the freeze node of the parent,
-- which it itself an instance.
procedure Set_Instance_Env
(Gen_Unit : Entity_Id;
Act_Unit : Entity_Id);
-- Save current instance on saved environment, to be used to determine
-- the global status of entities in nested instances. Part of Save_Env.
-- called after verifying that the generic unit is legal for the instance.
procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id);
-- Associate analyzed generic parameter with corresponding
-- instance. Used for semantic checks at instantiation time.
function Has_Been_Exchanged (E : Entity_Id) return Boolean;
-- Traverse the Exchanged_Views list to see if a type was private
-- and has already been flipped during this phase of instantiation.
procedure Hide_Current_Scope;
-- When compiling a generic child unit, the parent context must be
-- present, but the instance and all entities that may be generated
-- must be inserted in the current scope. We leave the current scope
-- on the stack, but make its entities invisible to avoid visibility
-- problems. This is reversed at the end of instantiations. This is
-- not done for the instantiation of the bodies, which only require the
-- instances of the generic parents to be in scope.
procedure Install_Body
(Act_Body : Node_Id;
N : Node_Id;
Gen_Body : Node_Id;
Gen_Decl : Node_Id);
-- If the instantiation happens textually before the body of the generic,
-- the instantiation of the body must be analyzed after the generic body,
-- and not at the point of instantiation. Such early instantiations can
-- happen if the generic and the instance appear in a package declaration
-- because the generic body can only appear in the corresponding package
-- body. Early instantiations can also appear if generic, instance and
-- body are all in the declarative part of a subprogram or entry. Entities
-- of packages that are early instantiations are delayed, and their freeze
-- node appears after the generic body.
procedure Insert_After_Last_Decl (N : Node_Id; F_Node : Node_Id);
-- Insert freeze node at the end of the declarative part that includes the
-- instance node N. If N is in the visible part of an enclosing package
-- declaration, the freeze node has to be inserted at the end of the
-- private declarations, if any.
procedure Freeze_Subprogram_Body
(Inst_Node : Node_Id;
Gen_Body : Node_Id;
Pack_Id : Entity_Id);
-- The generic body may appear textually after the instance, including
-- in the proper body of a stub, or within a different package instance.
-- Given that the instance can only be elaborated after the generic, we
-- place freeze_nodes for the instance and/or for packages that may enclose
-- the instance and the generic, so that the back-end can establish the
-- proper order of elaboration.
procedure Init_Env;
-- Establish environment for subsequent instantiation. Separated from
-- Save_Env because data-structures for visibility handling must be
-- initialized before call to Check_Generic_Child_Unit.
procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False);
-- When compiling an instance of a child unit the parent (which is
-- itself an instance) is an enclosing scope that must be made
-- immediately visible. This procedure is also used to install the non-
-- generic parent of a generic child unit when compiling its body, so that
-- full views of types in the parent are made visible.
procedure Remove_Parent (In_Body : Boolean := False);
-- Reverse effect after instantiation of child is complete.
procedure Inline_Instance_Body
(N : Node_Id;
Gen_Unit : Entity_Id;
Act_Decl : Node_Id);
-- If front-end inlining is requested, instantiate the package body,
-- and preserve the visibility of its compilation unit, to insure
-- that successive instantiations succeed.
-- The functions Instantiate_XXX perform various legality checks and build
-- the declarations for instantiated generic parameters.
-- Need to describe what the parameters are ???
function Instantiate_Object
(Formal : Node_Id;
Actual : Node_Id;
Analyzed_Formal : Node_Id)
return List_Id;
function Instantiate_Type
(Formal : Node_Id;
Actual : Node_Id;
Analyzed_Formal : Node_Id;
Actual_Decls : List_Id)
return Node_Id;
function Instantiate_Formal_Subprogram
(Formal : Node_Id;
Actual : Node_Id;
Analyzed_Formal : Node_Id)
return Node_Id;
function Instantiate_Formal_Package
(Formal : Node_Id;
Actual : Node_Id;
Analyzed_Formal : Node_Id)
return List_Id;
-- If the formal package is declared with a box, special visibility rules
-- apply to its formals: they are in the visible part of the package. This
-- is true in the declarative region of the formal package, that is to say
-- in the enclosing generic or instantiation. For an instantiation, the
-- parameters of the formal package are made visible in an explicit step.
-- Furthermore, if the actual is a visible use_clause, these formals must
-- be made potentially use_visible as well. On exit from the enclosing
-- instantiation, the reverse must be done.
-- For a formal package declared without a box, there are conformance rules
-- that apply to the actuals in the generic declaration and the actuals of
-- the actual package in the enclosing instantiation. The simplest way to
-- apply these rules is to repeat the instantiation of the formal package
-- in the context of the enclosing instance, and compare the generic
-- associations of this instantiation with those of the actual package.
function Is_In_Main_Unit (N : Node_Id) return Boolean;
-- Test if given node is in the main unit
procedure Load_Parent_Of_Generic (N : Node_Id; Spec : Node_Id);
-- If the generic appears in a separate non-generic library unit,
-- load the corresponding body to retrieve the body of the generic.
-- N is the node for the generic instantiation, Spec is the generic
-- package declaration.
procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id);
-- Add the context clause of the unit containing a generic unit to
-- an instantiation that is a compilation unit.
function Get_Associated_Node (N : Node_Id) return Node_Id;
-- In order to propagate semantic information back from the analyzed
-- copy to the original generic, we maintain links between selected nodes
-- in the generic and their corresponding copies. At the end of generic
-- analysis, the routine Save_Global_References traverses the generic
-- tree, examines the semantic information, and preserves the links to
-- those nodes that contain global information. At instantiation, the
-- information from the associated node is placed on the new copy, so
-- that name resolution is not repeated.
--
-- Three kinds of source nodes have associated nodes:
--
-- a) those that can reference (denote) entities, that is identifiers,
-- character literals, expanded_names, operator symbols, operators,
-- and attribute reference nodes. These nodes have an Entity field
-- and are the set of nodes that are in N_Has_Entity.
--
-- b) aggregates (N_Aggregate and N_Extension_Aggregate)
--
-- c) selected components (N_Selected_Component)
--
-- For the first class, the associated node preserves the entity if it is
-- global. If the generic contains nested instantiations, the associated
-- node itself has been recopied, and a chain of them must be followed.
--
-- For aggregates, the associated node allows retrieval of the type, which
-- may otherwise not appear in the generic. The view of this type may be
-- different between generic and instantiation, and the full view can be
-- installed before the instantiation is analyzed. For aggregates of
-- type extensions, the same view exchange may have to be performed for
-- some of the ancestor types, if their view is private at the point of
-- instantiation.
--
-- Nodes that are selected components in the parse tree may be rewritten
-- as expanded names after resolution, and must be treated as potential
-- entity holders. which is why they also have an Associated_Node.
--
-- Nodes that do not come from source, such as freeze nodes, do not appear
-- in the generic tree, and need not have an associated node.
--
-- The associated node is stored in the Associated_Node field. Note that
-- this field overlaps Entity, which is fine, because the whole point is
-- that we don't need or want the normal Entity field in this situation.
procedure Move_Freeze_Nodes
(Out_Of : Entity_Id;
After : Node_Id;
L : List_Id);
-- Freeze nodes can be generated in the analysis of a generic unit, but
-- will not be seen by the back-end. It is necessary to move those nodes
-- to the enclosing scope if they freeze an outer entity. We place them
-- at the end of the enclosing generic package, which is semantically
-- neutral.
procedure Pre_Analyze_Actuals (N : Node_Id);
-- Analyze actuals to perform name resolution. Full resolution is done
-- later, when the expected types are known, but names have to be captured
-- before installing parents of generics, that are not visible for the
-- actuals themselves.
procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id);
-- Verify that an attribute that appears as the default for a formal
-- subprogram is a function or procedure with the correct profile.
-------------------------------------------
-- Data Structures for Generic Renamings --
-------------------------------------------
-- The map Generic_Renamings associates generic entities with their
-- corresponding actuals. Currently used to validate type instances.
-- It will eventually be used for all generic parameters to eliminate
-- the need for overload resolution in the instance.
type Assoc_Ptr is new Int;
Assoc_Null : constant Assoc_Ptr := -1;
type Assoc is record
Gen_Id : Entity_Id;
Act_Id : Entity_Id;
Next_In_HTable : Assoc_Ptr;
end record;
package Generic_Renamings is new Table.Table
(Table_Component_Type => Assoc,
Table_Index_Type => Assoc_Ptr,
Table_Low_Bound => 0,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Generic_Renamings");
-- Variable to hold enclosing instantiation. When the environment is
-- saved for a subprogram inlining, the corresponding Act_Id is empty.
Current_Instantiated_Parent : Assoc := (Empty, Empty, Assoc_Null);
-- Hash table for associations
HTable_Size : constant := 37;
type HTable_Range is range 0 .. HTable_Size - 1;
procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr);
function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr;
function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id;
function Hash (F : Entity_Id) return HTable_Range;
package Generic_Renamings_HTable is new GNAT.HTable.Static_HTable (
Header_Num => HTable_Range,
Element => Assoc,
Elmt_Ptr => Assoc_Ptr,
Null_Ptr => Assoc_Null,
Set_Next => Set_Next_Assoc,
Next => Next_Assoc,
Key => Entity_Id,
Get_Key => Get_Gen_Id,
Hash => Hash,
Equal => "=");
Exchanged_Views : Elist_Id;
-- This list holds the private views that have been exchanged during
-- instantiation to restore the visibility of the generic declaration.
-- (see comments above). After instantiation, the current visibility is
-- reestablished by means of a traversal of this list.
Hidden_Entities : Elist_Id;
-- This list holds the entities of the current scope that are removed
-- from immediate visibility when instantiating a child unit. Their
-- visibility is restored in Remove_Parent.
-- Because instantiations can be recursive, the following must be saved
-- on entry and restored on exit from an instantiation (spec or body).
-- This is done by the two procedures Save_Env and Restore_Env. For
-- package and subprogram instantiations (but not for the body instances)
-- the action of Save_Env is done in two steps: Init_Env is called before
-- Check_Generic_Child_Unit, because setting the parent instances requires
-- that the visibility data structures be properly initialized. Once the
-- generic is unit is validated, Set_Instance_Env completes Save_Env.
type Instance_Env is record
Ada_83 : Boolean;
Instantiated_Parent : Assoc;
Exchanged_Views : Elist_Id;
Hidden_Entities : Elist_Id;
Current_Sem_Unit : Unit_Number_Type;
end record;
package Instance_Envs is new Table.Table (
Table_Component_Type => Instance_Env,
Table_Index_Type => Int,
Table_Low_Bound => 0,
Table_Initial => 32,
Table_Increment => 100,
Table_Name => "Instance_Envs");
procedure Restore_Private_Views
(Pack_Id : Entity_Id;
Is_Package : Boolean := True);
-- Restore the private views of external types, and unmark the generic
-- renamings of actuals, so that they become comptible subtypes again.
-- For subprograms, Pack_Id is the package constructed to hold the
-- renamings.
procedure Switch_View (T : Entity_Id);
-- Switch the partial and full views of a type and its private
-- dependents (i.e. its subtypes and derived types).
------------------------------------
-- Structures for Error Reporting --
------------------------------------
Instantiation_Node : Node_Id;
-- Used by subprograms that validate instantiation of formal parameters
-- where there might be no actual on which to place the error message.
-- Also used to locate the instantiation node for generic subunits.
Instantiation_Error : exception;
-- When there is a semantic error in the generic parameter matching,
-- there is no point in continuing the instantiation, because the
-- number of cascaded errors is unpredictable. This exception aborts
-- the instantiation process altogether.
S_Adjustment : Sloc_Adjustment;
-- Offset created for each node in an instantiation, in order to keep
-- track of the source position of the instantiation in each of its nodes.
-- A subsequent semantic error or warning on a construct of the instance
-- points to both places: the original generic node, and the point of
-- instantiation. See Sinput and Sinput.L for additional details.
------------------------------------------------------------
-- Data structure for keeping track when inside a Generic --
------------------------------------------------------------
-- The following table is used to save values of the Inside_A_Generic
-- flag (see spec of Sem) when they are saved by Start_Generic.
package Generic_Flags is new Table.Table (
Table_Component_Type => Boolean,
Table_Index_Type => Int,
Table_Low_Bound => 0,
Table_Initial => 32,
Table_Increment => 200,
Table_Name => "Generic_Flags");
---------------------------
-- Abandon_Instantiation --
---------------------------
procedure Abandon_Instantiation (N : Node_Id) is
begin
Error_Msg_N ("instantiation abandoned!", N);
raise Instantiation_Error;
end Abandon_Instantiation;
--------------------------
-- Analyze_Associations --
--------------------------
function Analyze_Associations
(I_Node : Node_Id;
Formals : List_Id;
F_Copy : List_Id)
return List_Id
is
Actual_Types : constant Elist_Id := New_Elmt_List;
Assoc : constant List_Id := New_List;
Defaults : constant Elist_Id := New_Elmt_List;
Gen_Unit : constant Entity_Id := Defining_Entity
(Parent (F_Copy));
Actuals : List_Id;
Actual : Node_Id;
Formal : Node_Id;
Next_Formal : Node_Id;
Temp_Formal : Node_Id;
Analyzed_Formal : Node_Id;
Match : Node_Id;
Named : Node_Id;
First_Named : Node_Id := Empty;
Found_Assoc : Node_Id;
Is_Named_Assoc : Boolean;
Num_Matched : Int := 0;
Num_Actuals : Int := 0;
function Matching_Actual
(F : Entity_Id;
A_F : Entity_Id)
return Node_Id;
-- Find actual that corresponds to a given a formal parameter. If the
-- actuals are positional, return the next one, if any. If the actuals
-- are named, scan the parameter associations to find the right one.
-- A_F is the corresponding entity in the analyzed generic,which is
-- placed on the selector name for ASIS use.
procedure Set_Analyzed_Formal;
-- Find the node in the generic copy that corresponds to a given formal.
-- The semantic information on this node is used to perform legality
-- checks on the actuals. Because semantic analysis can introduce some
-- anonymous entities or modify the declaration node itself, the
-- correspondence between the two lists is not one-one. In addition to
-- anonymous types, the presence a formal equality will introduce an
-- implicit declaration for the corresponding inequality.
---------------------
-- Matching_Actual --
---------------------
function Matching_Actual
(F : Entity_Id;
A_F : Entity_Id)
return Node_Id
is
Found : Node_Id;
Prev : Node_Id;
begin
Is_Named_Assoc := False;
-- End of list of purely positional parameters
if No (Actual) then
Found := Empty;
-- Case of positional parameter corresponding to current formal
elsif No (Selector_Name (Actual)) then
Found := Explicit_Generic_Actual_Parameter (Actual);
Found_Assoc := Actual;
Num_Matched := Num_Matched + 1;
Next (Actual);
-- Otherwise scan list of named actuals to find the one with the
-- desired name. All remaining actuals have explicit names.
else
Is_Named_Assoc := True;
Found := Empty;
Prev := Empty;
while Present (Actual) loop
if Chars (Selector_Name (Actual)) = Chars (F) then
Found := Explicit_Generic_Actual_Parameter (Actual);
Set_Entity (Selector_Name (Actual), A_F);
Set_Etype (Selector_Name (Actual), Etype (A_F));
Generate_Reference (A_F, Selector_Name (Actual));
Found_Assoc := Actual;
Num_Matched := Num_Matched + 1;
exit;
end if;
Prev := Actual;
Next (Actual);
end loop;
-- Reset for subsequent searches. In most cases the named
-- associations are in order. If they are not, we reorder them
-- to avoid scanning twice the same actual. This is not just a
-- question of efficiency: there may be multiple defaults with
-- boxes that have the same name. In a nested instantiation we
-- insert actuals for those defaults, and cannot rely on their
-- names to disambiguate them.
if Actual = First_Named then
Next (First_Named);
elsif Present (Actual) then
Insert_Before (First_Named, Remove_Next (Prev));
end if;
Actual := First_Named;
end if;
return Found;
end Matching_Actual;
-------------------------
-- Set_Analyzed_Formal --
-------------------------
procedure Set_Analyzed_Formal is
Kind : Node_Kind;
begin
while Present (Analyzed_Formal) loop
Kind := Nkind (Analyzed_Formal);
case Nkind (Formal) is
when N_Formal_Subprogram_Declaration =>
exit when Kind = N_Formal_Subprogram_Declaration
and then
Chars
(Defining_Unit_Name (Specification (Formal))) =
Chars
(Defining_Unit_Name (Specification (Analyzed_Formal)));
when N_Formal_Package_Declaration =>
exit when
Kind = N_Formal_Package_Declaration
or else
Kind = N_Generic_Package_Declaration;
when N_Use_Package_Clause | N_Use_Type_Clause => exit;
when others =>
-- Skip freeze nodes, and nodes inserted to replace
-- unrecognized pragmas.
exit when
Kind /= N_Formal_Subprogram_Declaration
and then Kind /= N_Subprogram_Declaration
and then Kind /= N_Freeze_Entity
and then Kind /= N_Null_Statement
and then Kind /= N_Itype_Reference
and then Chars (Defining_Identifier (Formal)) =
Chars (Defining_Identifier (Analyzed_Formal));
end case;
Next (Analyzed_Formal);
end loop;
end Set_Analyzed_Formal;
-- Start of processing for Analyze_Associations
begin
-- If named associations are present, save the first named association
-- (it may of course be Empty) to facilitate subsequent name search.
Actuals := Generic_Associations (I_Node);
if Present (Actuals) then
First_Named := First (Actuals);
while Present (First_Named)
and then No (Selector_Name (First_Named))
loop
Num_Actuals := Num_Actuals + 1;
Next (First_Named);
end loop;
end if;
Named := First_Named;
while Present (Named) loop
if No (Selector_Name (Named)) then
Error_Msg_N ("invalid positional actual after named one", Named);
Abandon_Instantiation (Named);
end if;
-- A named association may lack an actual parameter, if it was
-- introduced for a default subprogram that turns out to be local
-- to the outer instantiation.
if Present (Explicit_Generic_Actual_Parameter (Named)) then
Num_Actuals := Num_Actuals + 1;
end if;
Next (Named);
end loop;
if Present (Formals) then
Formal := First_Non_Pragma (Formals);
Analyzed_Formal := First_Non_Pragma (F_Copy);
if Present (Actuals) then
Actual := First (Actuals);
-- All formals should have default values
else
Actual := Empty;
end if;
while Present (Formal) loop
Set_Analyzed_Formal;
Next_Formal := Next_Non_Pragma (Formal);
case Nkind (Formal) is
when N_Formal_Object_Declaration =>
Match :=
Matching_Actual (
Defining_Identifier (Formal),
Defining_Identifier (Analyzed_Formal));
Append_List
(Instantiate_Object (Formal, Match, Analyzed_Formal),
Assoc);
when N_Formal_Type_Declaration =>
Match :=
Matching_Actual (
Defining_Identifier (Formal),
Defining_Identifier (Analyzed_Formal));
if No (Match) then
Error_Msg_Sloc := Sloc (Gen_Unit);
Error_Msg_NE
("missing actual&",
Instantiation_Node, Defining_Identifier (Formal));
Error_Msg_NE ("\in instantiation of & declared#",
Instantiation_Node, Gen_Unit);
Abandon_Instantiation (Instantiation_Node);
else
Analyze (Match);
Append_To (Assoc,
Instantiate_Type
(Formal, Match, Analyzed_Formal, Assoc));
-- an instantiation is a freeze point for the actuals,
-- unless this is a rewritten formal package.
if Nkind (I_Node) /= N_Formal_Package_Declaration then
Append_Elmt (Entity (Match), Actual_Types);
end if;
end if;
-- A remote access-to-class-wide type must not be an
-- actual parameter for a generic formal of an access
-- type (E.2.2 (17)).
if Nkind (Analyzed_Formal) = N_Formal_Type_Declaration
and then
Nkind (Formal_Type_Definition (Analyzed_Formal)) =
N_Access_To_Object_Definition
then
Validate_Remote_Access_To_Class_Wide_Type (Match);
end if;
when N_Formal_Subprogram_Declaration =>
Match :=
Matching_Actual (
Defining_Unit_Name (Specification (Formal)),
Defining_Unit_Name (Specification (Analyzed_Formal)));
-- If the formal subprogram has the same name as
-- another formal subprogram of the generic, then
-- a named association is illegal (12.3(9)). Exclude
-- named associations that are generated for a nested
-- instance.
if Present (Match)
and then Is_Named_Assoc
and then Comes_From_Source (Found_Assoc)
then
Temp_Formal := First (Formals);
while Present (Temp_Formal) loop
if Nkind (Temp_Formal) =
N_Formal_Subprogram_Declaration
and then Temp_Formal /= Formal
and then
Chars (Selector_Name (Found_Assoc)) =
Chars (Defining_Unit_Name
(Specification (Temp_Formal)))
then
Error_Msg_N
("name not allowed for overloaded formal",
Found_Assoc);
Abandon_Instantiation (Instantiation_Node);
end if;
Next (Temp_Formal);
end loop;
end if;
Append_To (Assoc,
Instantiate_Formal_Subprogram
(Formal, Match, Analyzed_Formal));
if No (Match)
and then Box_Present (Formal)
then
Append_Elmt
(Defining_Unit_Name (Specification (Last (Assoc))),
Defaults);
end if;
when N_Formal_Package_Declaration =>
Match :=
Matching_Actual (
Defining_Identifier (Formal),
Defining_Identifier (Original_Node (Analyzed_Formal)));
if No (Match) then
Error_Msg_Sloc := Sloc (Gen_Unit);
Error_Msg_NE
("missing actual&",
Instantiation_Node, Defining_Identifier (Formal));
Error_Msg_NE ("\in instantiation of & declared#",
Instantiation_Node, Gen_Unit);
Abandon_Instantiation (Instantiation_Node);
else
Analyze (Match);
Append_List
(Instantiate_Formal_Package
(Formal, Match, Analyzed_Formal),
Assoc);
end if;
-- For use type and use package appearing in the context
-- clause, we have already copied them, so we can just
-- move them where they belong (we mustn't recopy them
-- since this would mess up the Sloc values).
when N_Use_Package_Clause |
N_Use_Type_Clause =>
Remove (Formal);
Append (Formal, Assoc);
when others =>
raise Program_Error;
end case;
Formal := Next_Formal;
Next_Non_Pragma (Analyzed_Formal);
end loop;
if Num_Actuals > Num_Matched then
Error_Msg_Sloc := Sloc (Gen_Unit);
if Present (Selector_Name (Actual)) then
Error_Msg_NE
("unmatched actual&",
Actual, Selector_Name (Actual));
Error_Msg_NE ("\in instantiation of& declared#",
Actual, Gen_Unit);
else
Error_Msg_NE
("unmatched actual in instantiation of& declared#",
Actual, Gen_Unit);
end if;
end if;
elsif Present (Actuals) then
Error_Msg_N
("too many actuals in generic instantiation", Instantiation_Node);
end if;
declare
Elmt : Elmt_Id := First_Elmt (Actual_Types);
begin
while Present (Elmt) loop
Freeze_Before (I_Node, Node (Elmt));
Next_Elmt (Elmt);
end loop;
end;
-- If there are default subprograms, normalize the tree by adding
-- explicit associations for them. This is required if the instance
-- appears within a generic.
declare
Elmt : Elmt_Id;
Subp : Entity_Id;
New_D : Node_Id;
begin
Elmt := First_Elmt (Defaults);
while Present (Elmt) loop
if No (Actuals) then
Actuals := New_List;
Set_Generic_Associations (I_Node, Actuals);
end if;
Subp := Node (Elmt);
New_D :=
Make_Generic_Association (Sloc (Subp),
Selector_Name => New_Occurrence_Of (Subp, Sloc (Subp)),
Explicit_Generic_Actual_Parameter =>
New_Occurrence_Of (Subp, Sloc (Subp)));
Mark_Rewrite_Insertion (New_D);
Append_To (Actuals, New_D);
Next_Elmt (Elmt);
end loop;
end;
return Assoc;
end Analyze_Associations;
-------------------------------
-- Analyze_Formal_Array_Type --
-------------------------------
procedure Analyze_Formal_Array_Type
(T : in out Entity_Id;
Def : Node_Id)
is
DSS : Node_Id;
begin
-- Treated like a non-generic array declaration, with
-- additional semantic checks.
Enter_Name (T);
if Nkind (Def) = N_Constrained_Array_Definition then
DSS := First (Discrete_Subtype_Definitions (Def));
while Present (DSS) loop
if Nkind (DSS) = N_Subtype_Indication
or else Nkind (DSS) = N_Range
or else Nkind (DSS) = N_Attribute_Reference
then
Error_Msg_N ("only a subtype mark is allowed in a formal", DSS);
end if;
Next (DSS);
end loop;
end if;
Array_Type_Declaration (T, Def);
Set_Is_Generic_Type (Base_Type (T));
if Ekind (Component_Type (T)) = E_Incomplete_Type
and then No (Full_View (Component_Type (T)))
then
Error_Msg_N ("premature usage of incomplete type", Def);
elsif Is_Internal (Component_Type (T))
and then Nkind (Original_Node
(Subtype_Indication (Component_Definition (Def))))
/= N_Attribute_Reference
then
Error_Msg_N
("only a subtype mark is allowed in a formal",
Subtype_Indication (Component_Definition (Def)));
end if;
end Analyze_Formal_Array_Type;
---------------------------------------------
-- Analyze_Formal_Decimal_Fixed_Point_Type --
---------------------------------------------
-- As for other generic types, we create a valid type representation
-- with legal but arbitrary attributes, whose values are never considered
-- static. For all scalar types we introduce an anonymous base type, with
-- the same attributes. We choose the corresponding integer type to be
-- Standard_Integer.
procedure Analyze_Formal_Decimal_Fixed_Point_Type
(T : Entity_Id;
Def : Node_Id)
is
Loc : constant Source_Ptr := Sloc (Def);
Base : constant Entity_Id :=
New_Internal_Entity
(E_Decimal_Fixed_Point_Type,
Current_Scope, Sloc (Def), 'G');
Int_Base : constant Entity_Id := Standard_Integer;
Delta_Val : constant Ureal := Ureal_1;
Digs_Val : constant Uint := Uint_6;
begin
Enter_Name (T);
Set_Etype (Base, Base);
Set_Size_Info (Base, Int_Base);
Set_RM_Size (Base, RM_Size (Int_Base));
Set_First_Rep_Item (Base, First_Rep_Item (Int_Base));
Set_Digits_Value (Base, Digs_Val);
Set_Delta_Value (Base, Delta_Val);
Set_Small_Value (Base, Delta_Val);
Set_Scalar_Range (Base,
Make_Range (Loc,
Low_Bound => Make_Real_Literal (Loc, Ureal_1),
High_Bound => Make_Real_Literal (Loc, Ureal_1)));
Set_Is_Generic_Type (Base);
Set_Parent (Base, Parent (Def));
Set_Ekind (T, E_Decimal_Fixed_Point_Subtype);
Set_Etype (T, Base);
Set_Size_Info (T, Int_Base);
Set_RM_Size (T, RM_Size (Int_Base));
Set_First_Rep_Item (T, First_Rep_Item (Int_Base));
Set_Digits_Value (T, Digs_Val);
Set_Delta_Value (T, Delta_Val);
Set_Small_Value (T, Delta_Val);
Set_Scalar_Range (T, Scalar_Range (Base));
Check_Restriction (No_Fixed_Point, Def);
end Analyze_Formal_Decimal_Fixed_Point_Type;
---------------------------------
-- Analyze_Formal_Derived_Type --
---------------------------------
procedure Analyze_Formal_Derived_Type
(N : Node_Id;
T : Entity_Id;
Def : Node_Id)
is
Loc : constant Source_Ptr := Sloc (Def);
Unk_Disc : constant Boolean := Unknown_Discriminants_Present (N);
New_N : Node_Id;
begin
Set_Is_Generic_Type (T);
if Private_Present (Def) then
New_N :=
Make_Private_Extension_Declaration (Loc,
Defining_Identifier => T,
Discriminant_Specifications => Discriminant_Specifications (N),
Unknown_Discriminants_Present => Unk_Disc,
Subtype_Indication => Subtype_Mark (Def));
Set_Abstract_Present (New_N, Abstract_Present (Def));
else
New_N :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => T,
Discriminant_Specifications =>
Discriminant_Specifications (Parent (T)),
Type_Definition =>
Make_Derived_Type_Definition (Loc,
Subtype_Indication => Subtype_Mark (Def)));
Set_Abstract_Present
(Type_Definition (New_N), Abstract_Present (Def));
end if;
Rewrite (N, New_N);
Analyze (N);
if Unk_Disc then
if not Is_Composite_Type (T) then
Error_Msg_N
("unknown discriminants not allowed for elementary types", N);
else
Set_Has_Unknown_Discriminants (T);
Set_Is_Constrained (T, False);
end if;
end if;
-- If the parent type has a known size, so does the formal, which
-- makes legal representation clauses that involve the formal.
Set_Size_Known_At_Compile_Time
(T, Size_Known_At_Compile_Time (Entity (Subtype_Mark (Def))));
end Analyze_Formal_Derived_Type;
----------------------------------
-- Analyze_Formal_Discrete_Type --
----------------------------------
-- The operations defined for a discrete types are those of an
-- enumeration type. The size is set to an arbitrary value, for use
-- in analyzing the generic unit.
procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id) is
Loc : constant Source_Ptr := Sloc (Def);
Lo : Node_Id;
Hi : Node_Id;
begin
Enter_Name (T);
Set_Ekind (T, E_Enumeration_Type);
Set_Etype (T, T);
Init_Size (T, 8);
Init_Alignment (T);
-- For semantic analysis, the bounds of the type must be set to some
-- non-static value. The simplest is to create attribute nodes for
-- those bounds, that refer to the type itself. These bounds are never
-- analyzed but serve as place-holders.
Lo :=
Make_Attribute_Reference (Loc,
Attribute_Name => Name_First,
Prefix => New_Reference_To (T, Loc));
Set_Etype (Lo, T);
Hi :=
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Last,
Prefix => New_Reference_To (T, Loc));
Set_Etype (Hi, T);
Set_Scalar_Range (T,
Make_Range (Loc,
Low_Bound => Lo,
High_Bound => Hi));
end Analyze_Formal_Discrete_Type;
----------------------------------
-- Analyze_Formal_Floating_Type --
---------------------------------
procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id) is
Base : constant Entity_Id :=
New_Internal_Entity
(E_Floating_Point_Type, Current_Scope, Sloc (Def), 'G');
begin
-- The various semantic attributes are taken from the predefined type
-- Float, just so that all of them are initialized. Their values are
-- never used because no constant folding or expansion takes place in
-- the generic itself.
Enter_Name (T);
Set_Ekind (T, E_Floating_Point_Subtype);
Set_Etype (T, Base);
Set_Size_Info (T, (Standard_Float));
Set_RM_Size (T, RM_Size (Standard_Float));
Set_Digits_Value (T, Digits_Value (Standard_Float));
Set_Scalar_Range (T, Scalar_Range (Standard_Float));
Set_Is_Generic_Type (Base);
Set_Etype (Base, Base);
Set_Size_Info (Base, (Standard_Float));
Set_RM_Size (Base, RM_Size (Standard_Float));
Set_Digits_Value (Base, Digits_Value (Standard_Float));
Set_Scalar_Range (Base, Scalar_Range (Standard_Float));
Set_Parent (Base, Parent (Def));
Check_Restriction (No_Floating_Point, Def);
end Analyze_Formal_Floating_Type;
---------------------------------
-- Analyze_Formal_Modular_Type --
---------------------------------
procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id) is
begin
-- Apart from their entity kind, generic modular types are treated
-- like signed integer types, and have the same attributes.
Analyze_Formal_Signed_Integer_Type (T, Def);
Set_Ekind (T, E_Modular_Integer_Subtype);
Set_Ekind (Etype (T), E_Modular_Integer_Type);
end Analyze_Formal_Modular_Type;
---------------------------------------
-- Analyze_Formal_Object_Declaration --
---------------------------------------
procedure Analyze_Formal_Object_Declaration (N : Node_Id) is
E : constant Node_Id := Expression (N);
Id : constant Node_Id := Defining_Identifier (N);
K : Entity_Kind;
T : Node_Id;
begin
Enter_Name (Id);
-- Determine the mode of the formal object
if Out_Present (N) then
K := E_Generic_In_Out_Parameter;
if not In_Present (N) then
Error_Msg_N ("formal generic objects cannot have mode OUT", N);
end if;
else
K := E_Generic_In_Parameter;
end if;
Find_Type (Subtype_Mark (N));
T := Entity (Subtype_Mark (N));
if Ekind (T) = E_Incomplete_Type then
Error_Msg_N ("premature usage of incomplete type", Subtype_Mark (N));
end if;
if K = E_Generic_In_Parameter then
-- Ada0Y (AI-287): Limited aggregates allowed in generic formals
if not Extensions_Allowed and then Is_Limited_Type (T) then
Error_Msg_N
("generic formal of mode IN must not be of limited type", N);
Explain_Limited_Type (T, N);
end if;
if Is_Abstract (T) then
Error_Msg_N
("generic formal of mode IN must not be of abstract type", N);
end if;
if Present (E) then
Analyze_Per_Use_Expression (E, T);
end if;
Set_Ekind (Id, K);
Set_Etype (Id, T);
-- Case of generic IN OUT parameter.
else
-- If the formal has an unconstrained type, construct its
-- actual subtype, as is done for subprogram formals. In this
-- fashion, all its uses can refer to specific bounds.
Set_Ekind (Id, K);
Set_Etype (Id, T);
if (Is_Array_Type (T)
and then not Is_Constrained (T))
or else
(Ekind (T) = E_Record_Type
and then Has_Discriminants (T))
then
declare
Non_Freezing_Ref : constant Node_Id :=
New_Reference_To (Id, Sloc (Id));
Decl : Node_Id;
begin
-- Make sure that the actual subtype doesn't generate
-- bogus freezing.
Set_Must_Not_Freeze (Non_Freezing_Ref);
Decl := Build_Actual_Subtype (T, Non_Freezing_Ref);
Insert_Before_And_Analyze (N, Decl);
Set_Actual_Subtype (Id, Defining_Identifier (Decl));
end;
else
Set_Actual_Subtype (Id, T);
end if;
if Present (E) then
Error_Msg_N
("initialization not allowed for `IN OUT` formals", N);
end if;
end if;
end Analyze_Formal_Object_Declaration;
----------------------------------------------
-- Analyze_Formal_Ordinary_Fixed_Point_Type --
----------------------------------------------
procedure Analyze_Formal_Ordinary_Fixed_Point_Type
(T : Entity_Id;
Def : Node_Id)
is
Loc : constant Source_Ptr := Sloc (Def);
Base : constant Entity_Id :=
New_Internal_Entity
(E_Ordinary_Fixed_Point_Type, Current_Scope, Sloc (Def), 'G');
begin
-- The semantic attributes are set for completeness only, their
-- values will never be used, because all properties of the type
-- are non-static.
Enter_Name (T);
Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype);
Set_Etype (T, Base);
Set_Size_Info (T, Standard_Integer);
Set_RM_Size (T, RM_Size (Standard_Integer));
Set_Small_Value (T, Ureal_1);
Set_Delta_Value (T, Ureal_1);
Set_Scalar_Range (T,
Make_Range (Loc,
Low_Bound => Make_Real_Literal (Loc, Ureal_1),
High_Bound => Make_Real_Literal (Loc, Ureal_1)));
Set_Is_Generic_Type (Base);
Set_Etype (Base, Base);
Set_Size_Info (Base, Standard_Integer);
Set_RM_Size (Base, RM_Size (Standard_Integer));
Set_Small_Value (Base, Ureal_1);
Set_Delta_Value (Base, Ureal_1);
Set_Scalar_Range (Base, Scalar_Range (T));
Set_Parent (Base, Parent (Def));
Check_Restriction (No_Fixed_Point, Def);
end Analyze_Formal_Ordinary_Fixed_Point_Type;
----------------------------
-- Analyze_Formal_Package --
----------------------------
procedure Analyze_Formal_Package (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Formal : constant Entity_Id := Defining_Identifier (N);
Gen_Id : constant Node_Id := Name (N);
Gen_Decl : Node_Id;
Gen_Unit : Entity_Id;
New_N : Node_Id;
Parent_Installed : Boolean := False;
Renaming : Node_Id;
Parent_Instance : Entity_Id;
Renaming_In_Par : Entity_Id;
begin
Text_IO_Kludge (Gen_Id);
Init_Env;
Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
Gen_Unit := Entity (Gen_Id);
if Ekind (Gen_Unit) /= E_Generic_Package then
Error_Msg_N ("expect generic package name", Gen_Id);
Restore_Env;
return;
elsif Gen_Unit = Current_Scope then
Error_Msg_N
("generic package cannot be used as a formal package of itself",
Gen_Id);
Restore_Env;
return;
elsif In_Open_Scopes (Gen_Unit) then
if Is_Compilation_Unit (Gen_Unit)
and then Is_Child_Unit (Current_Scope)
then
-- Special-case the error when the formal is a parent, and
-- continue analysis to minimize cascaded errors.
Error_Msg_N
("generic parent cannot be used as formal package "
& "of a child unit",
Gen_Id);
else
Error_Msg_N
("generic package cannot be used as a formal package "
& "within itself",
Gen_Id);
Restore_Env;
return;
end if;
end if;
-- Check for a formal package that is a package renaming.
if Present (Renamed_Object (Gen_Unit)) then
Gen_Unit := Renamed_Object (Gen_Unit);
end if;
-- The formal package is treated like a regular instance, but only
-- the specification needs to be instantiated, to make entities visible.
if not Box_Present (N) then
Hidden_Entities := New_Elmt_List;
Analyze_Package_Instantiation (N);
if Parent_Installed then
Remove_Parent;
end if;
else
-- If there are no generic associations, the generic parameters
-- appear as local entities and are instantiated like them. We copy
-- the generic package declaration as if it were an instantiation,
-- and analyze it like a regular package, except that we treat the
-- formals as additional visible components.
Set_Instance_Env (Gen_Unit, Formal);
Gen_Decl := Unit_Declaration_Node (Gen_Unit);
if In_Extended_Main_Source_Unit (N) then
Set_Is_Instantiated (Gen_Unit);
Generate_Reference (Gen_Unit, N);
end if;
New_N :=
Copy_Generic_Node
(Original_Node (Gen_Decl), Empty, Instantiating => True);
Set_Defining_Unit_Name (Specification (New_N), Formal);
Rewrite (N, New_N);
Enter_Name (Formal);
Set_Ekind (Formal, E_Generic_Package);
Set_Etype (Formal, Standard_Void_Type);
Set_Inner_Instances (Formal, New_Elmt_List);
New_Scope (Formal);
-- Within the formal, the name of the generic package is a renaming
-- of the formal (as for a regular instantiation).
Renaming := Make_Package_Renaming_Declaration (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Chars (Gen_Unit)),
Name => New_Reference_To (Formal, Loc));
if Present (Visible_Declarations (Specification (N))) then
Prepend (Renaming, To => Visible_Declarations (Specification (N)));
elsif Present (Private_Declarations (Specification (N))) then
Prepend (Renaming, To => Private_Declarations (Specification (N)));
end if;
if Is_Child_Unit (Gen_Unit)
and then Parent_Installed
then
-- Similarly, we have to make the name of the formal visible in
-- the parent instance, to resolve properly fully qualified names
-- that may appear in the generic unit. The parent instance has
-- been placed on the scope stack ahead of the current scope.
Parent_Instance := Scope_Stack.Table (Scope_Stack.Last - 1).Entity;
Renaming_In_Par :=
Make_Defining_Identifier (Loc, Chars (Gen_Unit));
Set_Ekind (Renaming_In_Par, E_Package);
Set_Etype (Renaming_In_Par, Standard_Void_Type);
Set_Scope (Renaming_In_Par, Parent_Instance);
Set_Parent (Renaming_In_Par, Parent (Formal));
Set_Renamed_Object (Renaming_In_Par, Formal);
Append_Entity (Renaming_In_Par, Parent_Instance);
end if;
Analyze_Generic_Formal_Part (N);
Analyze (Specification (N));
End_Package_Scope (Formal);
if Parent_Installed then
Remove_Parent;
end if;
Restore_Env;
-- Inside the generic unit, the formal package is a regular
-- package, but no body is needed for it. Note that after
-- instantiation, the defining_unit_name we need is in the
-- new tree and not in the original. (see Package_Instantiation).
-- A generic formal package is an instance, and can be used as
-- an actual for an inner instance. Mark its generic parent.
Set_Ekind (Formal, E_Package);
Set_Generic_Parent (Specification (N), Gen_Unit);
Set_Has_Completion (Formal, True);
end if;
end Analyze_Formal_Package;
---------------------------------
-- Analyze_Formal_Private_Type --
---------------------------------
procedure Analyze_Formal_Private_Type
(N : Node_Id;
T : Entity_Id;
Def : Node_Id)
is
begin
New_Private_Type (N, T, Def);
-- Set the size to an arbitrary but legal value.
Set_Size_Info (T, Standard_Integer);
Set_RM_Size (T, RM_Size (Standard_Integer));
end Analyze_Formal_Private_Type;
----------------------------------------
-- Analyze_Formal_Signed_Integer_Type --
----------------------------------------
procedure Analyze_Formal_Signed_Integer_Type
(T : Entity_Id;
Def : Node_Id)
is
Base : constant Entity_Id :=
New_Internal_Entity
(E_Signed_Integer_Type, Current_Scope, Sloc (Def), 'G');
begin
Enter_Name (T);
Set_Ekind (T, E_Signed_Integer_Subtype);
Set_Etype (T, Base);
Set_Size_Info (T, Standard_Integer);
Set_RM_Size (T, RM_Size (Standard_Integer));
Set_Scalar_Range (T, Scalar_Range (Standard_Integer));
Set_Is_Generic_Type (Base);
Set_Size_Info (Base, Standard_Integer);
Set_RM_Size (Base, RM_Size (Standard_Integer));
Set_Etype (Base, Base);
Set_Scalar_Range (Base, Scalar_Range (Standard_Integer));
Set_Parent (Base, Parent (Def));
end Analyze_Formal_Signed_Integer_Type;
-------------------------------
-- Analyze_Formal_Subprogram --
-------------------------------
procedure Analyze_Formal_Subprogram (N : Node_Id) is
Spec : constant Node_Id := Specification (N);
Def : constant Node_Id := Default_Name (N);
Nam : constant Entity_Id := Defining_Unit_Name (Spec);
Subp : Entity_Id;
begin
if Nam = Error then
return;
end if;
if Nkind (Nam) = N_Defining_Program_Unit_Name then
Error_Msg_N ("name of formal subprogram must be a direct name", Nam);
return;
end if;
Analyze_Subprogram_Declaration (N);
Set_Is_Formal_Subprogram (Nam);
Set_Has_Completion (Nam);
-- Default name is resolved at the point of instantiation
if Box_Present (N) then
null;
-- Else default is bound at the point of generic declaration
elsif Present (Def) then
if Nkind (Def) = N_Operator_Symbol then
Find_Direct_Name (Def);
elsif Nkind (Def) /= N_Attribute_Reference then
Analyze (Def);
else
-- For an attribute reference, analyze the prefix and verify
-- that it has the proper profile for the subprogram.
Analyze (Prefix (Def));
Valid_Default_Attribute (Nam, Def);
return;
end if;
-- Default name may be overloaded, in which case the interpretation
-- with the correct profile must be selected, as for a renaming.
if Etype (Def) = Any_Type then
return;
elsif Nkind (Def) = N_Selected_Component then
Subp := Entity (Selector_Name (Def));
if Ekind (Subp) /= E_Entry then
Error_Msg_N ("expect valid subprogram name as default", Def);
return;
end if;
elsif Nkind (Def) = N_Indexed_Component then
if Nkind (Prefix (Def)) /= N_Selected_Component then
Error_Msg_N ("expect valid subprogram name as default", Def);
return;
else
Subp := Entity (Selector_Name (Prefix (Def)));
if Ekind (Subp) /= E_Entry_Family then
Error_Msg_N ("expect valid subprogram name as default", Def);
return;
end if;
end if;
elsif Nkind (Def) = N_Character_Literal then
-- Needs some type checks: subprogram should be parameterless???
Resolve (Def, (Etype (Nam)));
elsif not Is_Entity_Name (Def)
or else not Is_Overloadable (Entity (Def))
then
Error_Msg_N ("expect valid subprogram name as default", Def);
return;
elsif not Is_Overloaded (Def) then
Subp := Entity (Def);
if Subp = Nam then
Error_Msg_N ("premature usage of formal subprogram", Def);
elsif not Entity_Matches_Spec (Subp, Nam) then
Error_Msg_N ("no visible entity matches specification", Def);
end if;
else
declare
I : Interp_Index;
I1 : Interp_Index := 0;
It : Interp;
It1 : Interp;
begin
Subp := Any_Id;
Get_First_Interp (Def, I, It);
while Present (It.Nam) loop
if Entity_Matches_Spec (It.Nam, Nam) then
if Subp /= Any_Id then
It1 := Disambiguate (Def, I1, I, Etype (Subp));
if It1 = No_Interp then
Error_Msg_N ("ambiguous default subprogram", Def);
else
Subp := It1.Nam;
end if;
exit;
else
I1 := I;
Subp := It.Nam;
end if;
end if;
Get_Next_Interp (I, It);
end loop;
end;
if Subp /= Any_Id then
Set_Entity (Def, Subp);
if Subp = Nam then
Error_Msg_N ("premature usage of formal subprogram", Def);
elsif Ekind (Subp) /= E_Operator then
Check_Mode_Conformant (Subp, Nam);
end if;
else
Error_Msg_N ("no visible subprogram matches specification", N);
end if;
end if;
end if;
end Analyze_Formal_Subprogram;
-------------------------------------
-- Analyze_Formal_Type_Declaration --
-------------------------------------
procedure Analyze_Formal_Type_Declaration (N : Node_Id) is
Def : constant Node_Id := Formal_Type_Definition (N);
T : Entity_Id;
begin
T := Defining_Identifier (N);
if Present (Discriminant_Specifications (N))
and then Nkind (Def) /= N_Formal_Private_Type_Definition
then
Error_Msg_N
("discriminants not allowed for this formal type",
Defining_Identifier (First (Discriminant_Specifications (N))));
end if;
-- Enter the new name, and branch to specific routine.
case Nkind (Def) is
when N_Formal_Private_Type_Definition =>
Analyze_Formal_Private_Type (N, T, Def);
when N_Formal_Derived_Type_Definition =>
Analyze_Formal_Derived_Type (N, T, Def);
when N_Formal_Discrete_Type_Definition =>
Analyze_Formal_Discrete_Type (T, Def);
when N_Formal_Signed_Integer_Type_Definition =>
Analyze_Formal_Signed_Integer_Type (T, Def);
when N_Formal_Modular_Type_Definition =>
Analyze_Formal_Modular_Type (T, Def);
when N_Formal_Floating_Point_Definition =>
Analyze_Formal_Floating_Type (T, Def);
when N_Formal_Ordinary_Fixed_Point_Definition =>
Analyze_Formal_Ordinary_Fixed_Point_Type (T, Def);
when N_Formal_Decimal_Fixed_Point_Definition =>
Analyze_Formal_Decimal_Fixed_Point_Type (T, Def);
when N_Array_Type_Definition =>
Analyze_Formal_Array_Type (T, Def);
when N_Access_To_Object_Definition |
N_Access_Function_Definition |
N_Access_Procedure_Definition =>
Analyze_Generic_Access_Type (T, Def);
when N_Error =>
null;
when others =>
raise Program_Error;
end case;
Set_Is_Generic_Type (T);
end Analyze_Formal_Type_Declaration;
------------------------------------
-- Analyze_Function_Instantiation --
------------------------------------
procedure Analyze_Function_Instantiation (N : Node_Id) is
begin
Analyze_Subprogram_Instantiation (N, E_Function);
end Analyze_Function_Instantiation;
---------------------------------
-- Analyze_Generic_Access_Type --
---------------------------------
procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id) is
begin
Enter_Name (T);
if Nkind (Def) = N_Access_To_Object_Definition then
Access_Type_Declaration (T, Def);
if Is_Incomplete_Or_Private_Type (Designated_Type (T))
and then No (Full_View (Designated_Type (T)))
and then not Is_Generic_Type (Designated_Type (T))
then
Error_Msg_N ("premature usage of incomplete type", Def);
elsif Is_Internal (Designated_Type (T)) then
Error_Msg_N
("only a subtype mark is allowed in a formal", Def);
end if;
else
Access_Subprogram_Declaration (T, Def);
end if;
end Analyze_Generic_Access_Type;
---------------------------------
-- Analyze_Generic_Formal_Part --
---------------------------------
procedure Analyze_Generic_Formal_Part (N : Node_Id) is
Gen_Parm_Decl : Node_Id;
begin
-- The generic formals are processed in the scope of the generic
-- unit, where they are immediately visible. The scope is installed
-- by the caller.
Gen_Parm_Decl := First (Generic_Formal_Declarations (N));
while Present (Gen_Parm_Decl) loop
Analyze (Gen_Parm_Decl);
Next (Gen_Parm_Decl);
end loop;
Generate_Reference_To_Generic_Formals (Current_Scope);
end Analyze_Generic_Formal_Part;
------------------------------------------
-- Analyze_Generic_Package_Declaration --
------------------------------------------
procedure Analyze_Generic_Package_Declaration (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Id : Entity_Id;
New_N : Node_Id;
Save_Parent : Node_Id;
Renaming : Node_Id;
Decls : constant List_Id :=
Visible_Declarations (Specification (N));
Decl : Node_Id;
begin
-- We introduce a renaming of the enclosing package, to have a usable
-- entity as the prefix of an expanded name for a local entity of the
-- form Par.P.Q, where P is the generic package. This is because a local
-- entity named P may hide it, so that the usual visibility rules in
-- the instance will not resolve properly.
Renaming :=
Make_Package_Renaming_Declaration (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Defining_Entity (N)), "GH")),
Name => Make_Identifier (Loc, Chars (Defining_Entity (N))));
if Present (Decls) then
Decl := First (Decls);
while Present (Decl)
and then Nkind (Decl) = N_Pragma
loop
Next (Decl);
end loop;
if Present (Decl) then
Insert_Before (Decl, Renaming);
else
Append (Renaming, Visible_Declarations (Specification (N)));
end if;
else
Set_Visible_Declarations (Specification (N), New_List (Renaming));
end if;
-- Create copy of generic unit, and save for instantiation.
-- If the unit is a child unit, do not copy the specifications
-- for the parent, which are not part of the generic tree.
Save_Parent := Parent_Spec (N);
Set_Parent_Spec (N, Empty);
New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
Set_Parent_Spec (New_N, Save_Parent);
Rewrite (N, New_N);
Id := Defining_Entity (N);
Generate_Definition (Id);
-- Expansion is not applied to generic units.
Start_Generic;
Enter_Name (Id);
Set_Ekind (Id, E_Generic_Package);
Set_Etype (Id, Standard_Void_Type);
New_Scope (Id);
Enter_Generic_Scope (Id);
Set_Inner_Instances (Id, New_Elmt_List);
Set_Categorization_From_Pragmas (N);
Set_Is_Pure (Id, Is_Pure (Current_Scope));
-- Link the declaration of the generic homonym in the generic copy
-- to the package it renames, so that it is always resolved properly.
Set_Generic_Homonym (Id, Defining_Unit_Name (Renaming));
Set_Entity (Associated_Node (Name (Renaming)), Id);
-- For a library unit, we have reconstructed the entity for the
-- unit, and must reset it in the library tables.
if Nkind (Parent (N)) = N_Compilation_Unit then
Set_Cunit_Entity (Current_Sem_Unit, Id);
end if;
Analyze_Generic_Formal_Part (N);
-- After processing the generic formals, analysis proceeds
-- as for a non-generic package.
Analyze (Specification (N));
Validate_Categorization_Dependency (N, Id);
End_Generic;
End_Package_Scope (Id);
Exit_Generic_Scope (Id);
if Nkind (Parent (N)) /= N_Compilation_Unit then
Move_Freeze_Nodes (Id, N, Visible_Declarations (Specification (N)));
Move_Freeze_Nodes (Id, N, Private_Declarations (Specification (N)));
Move_Freeze_Nodes (Id, N, Generic_Formal_Declarations (N));
else
Set_Body_Required (Parent (N), Unit_Requires_Body (Id));
Validate_RT_RAT_Component (N);
-- If this is a spec without a body, check that generic parameters
-- are referenced.
if not Body_Required (Parent (N)) then
Check_References (Id);
end if;
end if;
end Analyze_Generic_Package_Declaration;
--------------------------------------------
-- Analyze_Generic_Subprogram_Declaration --
--------------------------------------------
procedure Analyze_Generic_Subprogram_Declaration (N : Node_Id) is
Spec : Node_Id;
Id : Entity_Id;
Formals : List_Id;
New_N : Node_Id;
Save_Parent : Node_Id;
begin
-- Create copy of generic unit,and save for instantiation.
-- If the unit is a child unit, do not copy the specifications
-- for the parent, which are not part of the generic tree.
Save_Parent := Parent_Spec (N);
Set_Parent_Spec (N, Empty);
New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
Set_Parent_Spec (New_N, Save_Parent);
Rewrite (N, New_N);
Spec := Specification (N);
Id := Defining_Entity (Spec);
Generate_Definition (Id);
if Nkind (Id) = N_Defining_Operator_Symbol then
Error_Msg_N
("operator symbol not allowed for generic subprogram", Id);
end if;
Start_Generic;
Enter_Name (Id);
Set_Scope_Depth_Value (Id, Scope_Depth (Current_Scope) + 1);
New_Scope (Id);
Enter_Generic_Scope (Id);
Set_Inner_Instances (Id, New_Elmt_List);
Set_Is_Pure (Id, Is_Pure (Current_Scope));
Analyze_Generic_Formal_Part (N);
Formals := Parameter_Specifications (Spec);
if Present (Formals) then
Process_Formals (Formals, Spec);
end if;
if Nkind (Spec) = N_Function_Specification then
Set_Ekind (Id, E_Generic_Function);
Find_Type (Subtype_Mark (Spec));
Set_Etype (Id, Entity (Subtype_Mark (Spec)));
else
Set_Ekind (Id, E_Generic_Procedure);
Set_Etype (Id, Standard_Void_Type);
end if;
-- For a library unit, we have reconstructed the entity for the
-- unit, and must reset it in the library tables. We also need
-- to make sure that Body_Required is set properly in the original
-- compilation unit node.
if Nkind (Parent (N)) = N_Compilation_Unit then
Set_Cunit_Entity (Current_Sem_Unit, Id);
Set_Body_Required (Parent (N), Unit_Requires_Body (Id));
end if;
Set_Categorization_From_Pragmas (N);
Validate_Categorization_Dependency (N, Id);
Save_Global_References (Original_Node (N));
End_Generic;
End_Scope;
Exit_Generic_Scope (Id);
Generate_Reference_To_Formals (Id);
end Analyze_Generic_Subprogram_Declaration;
-----------------------------------
-- Analyze_Package_Instantiation --
-----------------------------------
-- Note: this procedure is also used for formal package declarations,
-- in which case the argument N is an N_Formal_Package_Declaration
-- node. This should really be noted in the spec! ???
procedure Analyze_Package_Instantiation (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Gen_Id : constant Node_Id := Name (N);
Act_Decl : Node_Id;
Act_Decl_Name : Node_Id;
Act_Decl_Id : Entity_Id;
Act_Spec : Node_Id;
Act_Tree : Node_Id;
Gen_Decl : Node_Id;
Gen_Unit : Entity_Id;
Is_Actual_Pack : constant Boolean :=
Is_Internal (Defining_Entity (N));
Parent_Installed : Boolean := False;
Renaming_List : List_Id;
Unit_Renaming : Node_Id;
Needs_Body : Boolean;
Inline_Now : Boolean := False;
procedure Delay_Descriptors (E : Entity_Id);
-- Delay generation of subprogram descriptors for given entity
function Might_Inline_Subp return Boolean;
-- If inlining is active and the generic contains inlined subprograms,
-- we instantiate the body. This may cause superfluous instantiations,
-- but it is simpler than detecting the need for the body at the point
-- of inlining, when the context of the instance is not available.
-----------------------
-- Delay_Descriptors --
-----------------------
procedure Delay_Descriptors (E : Entity_Id) is
begin
if not Delay_Subprogram_Descriptors (E) then
Set_Delay_Subprogram_Descriptors (E);
Pending_Descriptor.Increment_Last;
Pending_Descriptor.Table (Pending_Descriptor.Last) := E;
end if;
end Delay_Descriptors;
-----------------------
-- Might_Inline_Subp --
-----------------------
function Might_Inline_Subp return Boolean is
E : Entity_Id;
begin
if not Inline_Processing_Required then
return False;
else
E := First_Entity (Gen_Unit);
while Present (E) loop
if Is_Subprogram (E)
and then Is_Inlined (E)
then
return True;
end if;
Next_Entity (E);
end loop;
end if;
return False;
end Might_Inline_Subp;
-- Start of processing for Analyze_Package_Instantiation
begin
-- Very first thing: apply the special kludge for Text_IO processing
-- in case we are instantiating one of the children of [Wide_]Text_IO.
Text_IO_Kludge (Name (N));
-- Make node global for error reporting.
Instantiation_Node := N;
-- Case of instantiation of a generic package
if Nkind (N) = N_Package_Instantiation then
Act_Decl_Id := New_Copy (Defining_Entity (N));
Set_Comes_From_Source (Act_Decl_Id, True);
if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name then
Act_Decl_Name :=
Make_Defining_Program_Unit_Name (Loc,
Name => New_Copy_Tree (Name (Defining_Unit_Name (N))),
Defining_Identifier => Act_Decl_Id);
else
Act_Decl_Name := Act_Decl_Id;
end if;
-- Case of instantiation of a formal package
else
Act_Decl_Id := Defining_Identifier (N);
Act_Decl_Name := Act_Decl_Id;
end if;
Generate_Definition (Act_Decl_Id);
Pre_Analyze_Actuals (N);
Init_Env;
Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
Gen_Unit := Entity (Gen_Id);
-- Verify that it is the name of a generic package
if Etype (Gen_Unit) = Any_Type then
Restore_Env;
return;
elsif Ekind (Gen_Unit) /= E_Generic_Package then
-- Ada0Y (AI-50217): Instance can not be used in limited with_clause
if From_With_Type (Gen_Unit) then
Error_Msg_N
("cannot instantiate a limited withed package", Gen_Id);
else
Error_Msg_N
("expect name of generic package in instantiation", Gen_Id);
end if;
Restore_Env;
return;
end if;
if In_Extended_Main_Source_Unit (N) then
Set_Is_Instantiated (Gen_Unit);
Generate_Reference (Gen_Unit, N);
if Present (Renamed_Object (Gen_Unit)) then
Set_Is_Instantiated (Renamed_Object (Gen_Unit));
Generate_Reference (Renamed_Object (Gen_Unit), N);
end if;
end if;
if Nkind (Gen_Id) = N_Identifier
and then Chars (Gen_Unit) = Chars (Defining_Entity (N))
then
Error_Msg_NE
("& is hidden within declaration of instance", Gen_Id, Gen_Unit);
elsif Nkind (Gen_Id) = N_Expanded_Name
and then Is_Child_Unit (Gen_Unit)
and then Nkind (Prefix (Gen_Id)) = N_Identifier
and then Chars (Act_Decl_Id) = Chars (Prefix (Gen_Id))
then
Error_Msg_N
("& is hidden within declaration of instance ", Prefix (Gen_Id));
end if;
Set_Entity (Gen_Id, Gen_Unit);
-- If generic is a renaming, get original generic unit.
if Present (Renamed_Object (Gen_Unit))
and then Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Package
then
Gen_Unit := Renamed_Object (Gen_Unit);
end if;
-- Verify that there are no circular instantiations.
if In_Open_Scopes (Gen_Unit) then
Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit);
Restore_Env;
return;
elsif Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then
Error_Msg_Node_2 := Current_Scope;
Error_Msg_NE
("circular Instantiation: & instantiated in &!", N, Gen_Unit);
Circularity_Detected := True;
Restore_Env;
return;
else
Set_Instance_Env (Gen_Unit, Act_Decl_Id);
Gen_Decl := Unit_Declaration_Node (Gen_Unit);
-- Initialize renamings map, for error checking, and the list
-- that holds private entities whose views have changed between
-- generic definition and instantiation. If this is the instance
-- created to validate an actual package, the instantiation
-- environment is that of the enclosing instance.
Generic_Renamings.Set_Last (0);
Generic_Renamings_HTable.Reset;
Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
-- Copy original generic tree, to produce text for instantiation.
Act_Tree :=
Copy_Generic_Node
(Original_Node (Gen_Decl), Empty, Instantiating => True);
Act_Spec := Specification (Act_Tree);
-- If this is the instance created to validate an actual package,
-- only the formals matter, do not examine the package spec itself.
if Is_Actual_Pack then
Set_Visible_Declarations (Act_Spec, New_List);
Set_Private_Declarations (Act_Spec, New_List);
end if;
Renaming_List :=
Analyze_Associations
(N,
Generic_Formal_Declarations (Act_Tree),
Generic_Formal_Declarations (Gen_Decl));
Set_Defining_Unit_Name (Act_Spec, Act_Decl_Name);
Set_Is_Generic_Instance (Act_Decl_Id);
Set_Generic_Parent (Act_Spec, Gen_Unit);
-- References to the generic in its own declaration or its body
-- are references to the instance. Add a renaming declaration for
-- the generic unit itself. This declaration, as well as the renaming
-- declarations for the generic formals, must remain private to the
-- unit: the formals, because this is the language semantics, and
-- the unit because its use is an artifact of the implementation.
Unit_Renaming :=
Make_Package_Renaming_Declaration (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Chars (Gen_Unit)),
Name => New_Reference_To (Act_Decl_Id, Loc));
Append (Unit_Renaming, Renaming_List);
-- The renaming declarations are the first local declarations of
-- the new unit.
if Is_Non_Empty_List (Visible_Declarations (Act_Spec)) then
Insert_List_Before
(First (Visible_Declarations (Act_Spec)), Renaming_List);
else
Set_Visible_Declarations (Act_Spec, Renaming_List);
end if;
Act_Decl :=
Make_Package_Declaration (Loc,
Specification => Act_Spec);
-- Save the instantiation node, for subsequent instantiation
-- of the body, if there is one and we are generating code for
-- the current unit. Mark the unit as having a body, to avoid
-- a premature error message.
-- We instantiate the body if we are generating code, if we are
-- generating cross-reference information, or if we are building
-- trees for ASIS use.
declare
Enclosing_Body_Present : Boolean := False;
-- If the generic unit is not a compilation unit, then a body
-- may be present in its parent even if none is required. We
-- create a tentative pending instantiation for the body, which
-- will be discarded if none is actually present.
Scop : Entity_Id;
begin
if Scope (Gen_Unit) /= Standard_Standard
and then not Is_Child_Unit (Gen_Unit)
then
Scop := Scope (Gen_Unit);
while Present (Scop)
and then Scop /= Standard_Standard
loop
if Unit_Requires_Body (Scop) then
Enclosing_Body_Present := True;
exit;
end if;
exit when Is_Compilation_Unit (Scop);
Scop := Scope (Scop);
end loop;
end if;
-- If front-end inlining is enabled, and this is a unit for which
-- code will be generated, we instantiate the body at once.
-- This is done if the instance is not the main unit, and if the
-- generic is not a child unit of another generic, to avoid scope
-- problems and the reinstallation of parent instances.
if Front_End_Inlining
and then Expander_Active
and then (not Is_Child_Unit (Gen_Unit)
or else not Is_Generic_Unit (Scope (Gen_Unit)))
and then Is_In_Main_Unit (N)
and then Nkind (Parent (N)) /= N_Compilation_Unit
and then Might_Inline_Subp
and then not Is_Actual_Pack
then
Inline_Now := True;
end if;
Needs_Body :=
(Unit_Requires_Body (Gen_Unit)
or else Enclosing_Body_Present
or else Present (Corresponding_Body (Gen_Decl)))
and then (Is_In_Main_Unit (N)
or else Might_Inline_Subp)
and then not Is_Actual_Pack
and then not Inline_Now
and then (Operating_Mode = Generate_Code
or else (Operating_Mode = Check_Semantics
and then ASIS_Mode));
-- If front_end_inlining is enabled, do not instantiate a
-- body if within a generic context.
if Front_End_Inlining
and then not Expander_Active
then
Needs_Body := False;
end if;
-- If the current context is generic, and the package being
-- instantiated is declared within a formal package, there
-- is no body to instantiate until the enclosing generic is
-- instantiated, and there is an actual for the formal
-- package. If the formal package has parameters, we build a
-- regular package instance for it, that preceeds the original
-- formal package declaration.
if In_Open_Scopes (Scope (Scope (Gen_Unit))) then
declare
Decl : constant Node_Id :=
Original_Node
(Unit_Declaration_Node (Scope (Gen_Unit)));
begin
if Nkind (Decl) = N_Formal_Package_Declaration
or else (Nkind (Decl) = N_Package_Declaration
and then Is_List_Member (Decl)
and then Present (Next (Decl))
and then
Nkind (Next (Decl)) = N_Formal_Package_Declaration)
then
Needs_Body := False;
end if;
end;
end if;
end;
-- If we are generating the calling stubs from the instantiation
-- of a generic RCI package, we will not use the body of the
-- generic package.
if Distribution_Stub_Mode = Generate_Caller_Stub_Body
and then Is_Compilation_Unit (Defining_Entity (N))
then
Needs_Body := False;
end if;
if Needs_Body then
-- Here is a defence against a ludicrous number of instantiations
-- caused by a circular set of instantiation attempts.
if Pending_Instantiations.Last >
Hostparm.Max_Instantiations
then
Error_Msg_N ("too many instantiations", N);
raise Unrecoverable_Error;
end if;
-- Indicate that the enclosing scopes contain an instantiation,
-- and that cleanup actions should be delayed until after the
-- instance body is expanded.
Check_Forward_Instantiation (Gen_Decl);
if Nkind (N) = N_Package_Instantiation then
declare
Enclosing_Master : Entity_Id := Current_Scope;
begin
while Enclosing_Master /= Standard_Standard loop
if Ekind (Enclosing_Master) = E_Package then
if Is_Compilation_Unit (Enclosing_Master) then
if In_Package_Body (Enclosing_Master) then
Delay_Descriptors
(Body_Entity (Enclosing_Master));
else
Delay_Descriptors
(Enclosing_Master);
end if;
exit;
else
Enclosing_Master := Scope (Enclosing_Master);
end if;
elsif Ekind (Enclosing_Master) = E_Generic_Package then
Enclosing_Master := Scope (Enclosing_Master);
elsif Is_Generic_Subprogram (Enclosing_Master)
or else Ekind (Enclosing_Master) = E_Void
then
-- Cleanup actions will eventually be performed on
-- the enclosing instance, if any. enclosing scope
-- is void in the formal part of a generic subp.
exit;
else
if Ekind (Enclosing_Master) = E_Entry
and then
Ekind (Scope (Enclosing_Master)) = E_Protected_Type
then
Enclosing_Master :=
Protected_Body_Subprogram (Enclosing_Master);
end if;
Set_Delay_Cleanups (Enclosing_Master);
while Ekind (Enclosing_Master) = E_Block loop
Enclosing_Master := Scope (Enclosing_Master);
end loop;
if Is_Subprogram (Enclosing_Master) then
Delay_Descriptors (Enclosing_Master);
elsif Is_Task_Type (Enclosing_Master) then
declare
TBP : constant Node_Id :=
Get_Task_Body_Procedure
(Enclosing_Master);
begin
if Present (TBP) then
Delay_Descriptors (TBP);
Set_Delay_Cleanups (TBP);
end if;
end;
end if;
exit;
end if;
end loop;
end;
-- Make entry in table
Pending_Instantiations.Increment_Last;
Pending_Instantiations.Table (Pending_Instantiations.Last) :=
(N, Act_Decl, Expander_Active, Current_Sem_Unit);
end if;
end if;
Set_Categorization_From_Pragmas (Act_Decl);
if Parent_Installed then
Hide_Current_Scope;
end if;
Set_Instance_Spec (N, Act_Decl);
-- If not a compilation unit, insert the package declaration
-- before the original instantiation node.
if Nkind (Parent (N)) /= N_Compilation_Unit then
Mark_Rewrite_Insertion (Act_Decl);
Insert_Before (N, Act_Decl);
Analyze (Act_Decl);
-- For an instantiation that is a compilation unit, place
-- declaration on current node so context is complete
-- for analysis (including nested instantiations). It this
-- is the main unit, the declaration eventually replaces the
-- instantiation node. If the instance body is later created, it
-- replaces the instance node, and the declation is attached to
-- it (see Build_Instance_Compilation_Unit_Nodes).
else
if Cunit_Entity (Current_Sem_Unit) = Defining_Entity (N) then
-- The entity for the current unit is the newly created one,
-- and all semantic information is attached to it.
Set_Cunit_Entity (Current_Sem_Unit, Act_Decl_Id);
-- If this is the main unit, replace the main entity as well.
if Current_Sem_Unit = Main_Unit then
Main_Unit_Entity := Act_Decl_Id;
end if;
end if;
Set_Unit (Parent (N), Act_Decl);
Set_Parent_Spec (Act_Decl, Parent_Spec (N));
Analyze (Act_Decl);
Set_Unit (Parent (N), N);
Set_Body_Required (Parent (N), False);
-- We never need elaboration checks on instantiations, since
-- by definition, the body instantiation is elaborated at the
-- same time as the spec instantiation.
Set_Suppress_Elaboration_Warnings (Act_Decl_Id);
Set_Kill_Elaboration_Checks (Act_Decl_Id);
end if;
Check_Elab_Instantiation (N);
if ABE_Is_Certain (N) and then Needs_Body then
Pending_Instantiations.Decrement_Last;
end if;
Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id);
Set_First_Private_Entity (Defining_Unit_Name (Unit_Renaming),
First_Private_Entity (Act_Decl_Id));
-- If the instantiation will receive a body, the unit will
-- be transformed into a package body, and receive its own
-- elaboration entity. Otherwise, the nature of the unit is
-- now a package declaration.
if Nkind (Parent (N)) = N_Compilation_Unit
and then not Needs_Body
then
Rewrite (N, Act_Decl);
end if;
if Present (Corresponding_Body (Gen_Decl))
or else Unit_Requires_Body (Gen_Unit)
then
Set_Has_Completion (Act_Decl_Id);
end if;
Check_Formal_Packages (Act_Decl_Id);
Restore_Private_Views (Act_Decl_Id);
if not Generic_Separately_Compiled (Gen_Unit) then
Inherit_Context (Gen_Decl, N);
end if;
if Parent_Installed then
Remove_Parent;
end if;
Restore_Env;
end if;
Validate_Categorization_Dependency (N, Act_Decl_Id);
-- Check restriction, but skip this if something went wrong in
-- the above analysis, indicated by Act_Decl_Id being void.
if Ekind (Act_Decl_Id) /= E_Void
and then not Is_Library_Level_Entity (Act_Decl_Id)
then
Check_Restriction (No_Local_Allocators, N);
end if;
if Inline_Now then
Inline_Instance_Body (N, Gen_Unit, Act_Decl);
end if;
exception
when Instantiation_Error =>
if Parent_Installed then
Remove_Parent;
end if;
end Analyze_Package_Instantiation;
---------------------------
-- Inline_Instance_Body --
---------------------------
procedure Inline_Instance_Body
(N : Node_Id;
Gen_Unit : Entity_Id;
Act_Decl : Node_Id)
is
Vis : Boolean;
Gen_Comp : constant Entity_Id :=
Cunit_Entity (Get_Source_Unit (Gen_Unit));
Curr_Comp : constant Node_Id := Cunit (Current_Sem_Unit);
Curr_Scope : Entity_Id := Empty;
Curr_Unit : constant Entity_Id :=
Cunit_Entity (Current_Sem_Unit);
Removed : Boolean := False;
Num_Scopes : Int := 0;
Use_Clauses : array (1 .. Scope_Stack.Last) of Node_Id;
Instances : array (1 .. Scope_Stack.Last) of Entity_Id;
Inner_Scopes : array (1 .. Scope_Stack.Last) of Entity_Id;
Num_Inner : Int := 0;
N_Instances : Int := 0;
S : Entity_Id;
begin
-- Case of generic unit defined in another unit. We must remove
-- the complete context of the current unit to install that of
-- the generic.
if Gen_Comp /= Cunit_Entity (Current_Sem_Unit) then
S := Current_Scope;
while Present (S)
and then S /= Standard_Standard
loop
Num_Scopes := Num_Scopes + 1;
Use_Clauses (Num_Scopes) :=
(Scope_Stack.Table
(Scope_Stack.Last - Num_Scopes + 1).
First_Use_Clause);
End_Use_Clauses (Use_Clauses (Num_Scopes));
exit when Is_Generic_Instance (S)
and then (In_Package_Body (S)
or else Ekind (S) = E_Procedure
or else Ekind (S) = E_Function);
S := Scope (S);
end loop;
Vis := Is_Immediately_Visible (Gen_Comp);
-- Find and save all enclosing instances
S := Current_Scope;
while Present (S)
and then S /= Standard_Standard
loop
if Is_Generic_Instance (S) then
N_Instances := N_Instances + 1;
Instances (N_Instances) := S;
exit when In_Package_Body (S);
end if;
S := Scope (S);
end loop;
-- Remove context of current compilation unit, unless we
-- are within a nested package instantiation, in which case
-- the context has been removed previously.
-- If current scope is the body of a child unit, remove context
-- of spec as well.
S := Current_Scope;
while Present (S)
and then S /= Standard_Standard
loop
exit when Is_Generic_Instance (S)
and then (In_Package_Body (S)
or else Ekind (S) = E_Procedure
or else Ekind (S) = E_Function);
if S = Curr_Unit
or else (Ekind (Curr_Unit) = E_Package_Body
and then S = Spec_Entity (Curr_Unit))
or else (Ekind (Curr_Unit) = E_Subprogram_Body
and then S =
Corresponding_Spec
(Unit_Declaration_Node (Curr_Unit)))
then
Removed := True;
-- Remove entities in current scopes from visibility, so
-- than instance body is compiled in a clean environment.
Save_Scope_Stack (Handle_Use => False);
if Is_Child_Unit (S) then
-- Remove child unit from stack, as well as inner scopes.
-- Removing the context of a child unit removes parent
-- units as well.
while Current_Scope /= S loop
Num_Inner := Num_Inner + 1;
Inner_Scopes (Num_Inner) := Current_Scope;
Pop_Scope;
end loop;
Pop_Scope;
Remove_Context (Curr_Comp);
Curr_Scope := S;
else
Remove_Context (Curr_Comp);
end if;
if Ekind (Curr_Unit) = E_Package_Body then
Remove_Context (Library_Unit (Curr_Comp));
end if;
end if;
S := Scope (S);
end loop;
New_Scope (Standard_Standard);
Scope_Stack.Table (Scope_Stack.Last).Is_Active_Stack_Base := True;
Instantiate_Package_Body
((N, Act_Decl, Expander_Active, Current_Sem_Unit), True);
Pop_Scope;
-- Restore context
Set_Is_Immediately_Visible (Gen_Comp, Vis);
-- Reset Generic_Instance flag so that use clauses can be installed
-- in the proper order. (See Use_One_Package for effect of enclosing
-- instances on processing of use clauses).
for J in 1 .. N_Instances loop
Set_Is_Generic_Instance (Instances (J), False);
end loop;
if Removed then
Install_Context (Curr_Comp);
if Present (Curr_Scope)
and then Is_Child_Unit (Curr_Scope)
then
New_Scope (Curr_Scope);
Set_Is_Immediately_Visible (Curr_Scope);
-- Finally, restore inner scopes as well.
for J in reverse 1 .. Num_Inner loop
New_Scope (Inner_Scopes (J));
end loop;
end if;
Restore_Scope_Stack (Handle_Use => False);
end if;
-- Restore use clauses. For a child unit, use clauses in the
-- parents are restored when installing the context, so only
-- those in inner scopes (and those local to the child unit itself)
-- need to be installed explicitly.
if Is_Child_Unit (Curr_Unit)
and then Removed
then
for J in reverse 1 .. Num_Inner + 1 loop
Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause :=
Use_Clauses (J);
Install_Use_Clauses (Use_Clauses (J));
end loop;
else
for J in reverse 1 .. Num_Scopes loop
Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause :=
Use_Clauses (J);
Install_Use_Clauses (Use_Clauses (J));
end loop;
end if;
for J in 1 .. N_Instances loop
Set_Is_Generic_Instance (Instances (J), True);
end loop;
-- If generic unit is in current unit, current context is correct.
else
Instantiate_Package_Body
((N, Act_Decl, Expander_Active, Current_Sem_Unit), True);
end if;
end Inline_Instance_Body;
-------------------------------------
-- Analyze_Procedure_Instantiation --
-------------------------------------
procedure Analyze_Procedure_Instantiation (N : Node_Id) is
begin
Analyze_Subprogram_Instantiation (N, E_Procedure);
end Analyze_Procedure_Instantiation;
--------------------------------------
-- Analyze_Subprogram_Instantiation --
--------------------------------------
procedure Analyze_Subprogram_Instantiation
(N : Node_Id;
K : Entity_Kind)
is
Loc : constant Source_Ptr := Sloc (N);
Gen_Id : constant Node_Id := Name (N);
Anon_Id : constant Entity_Id :=
Make_Defining_Identifier (Sloc (Defining_Entity (N)),
Chars => New_External_Name
(Chars (Defining_Entity (N)), 'R'));
Act_Decl_Id : Entity_Id;
Act_Decl : Node_Id;
Act_Spec : Node_Id;
Act_Tree : Node_Id;
Gen_Unit : Entity_Id;
Gen_Decl : Node_Id;
Pack_Id : Entity_Id;
Parent_Installed : Boolean := False;
Renaming_List : List_Id;
procedure Analyze_Instance_And_Renamings;
-- The instance must be analyzed in a context that includes the
-- mappings of generic parameters into actuals. We create a package
-- declaration for this purpose, and a subprogram with an internal
-- name within the package. The subprogram instance is simply an
-- alias for the internal subprogram, declared in the current scope.
------------------------------------
-- Analyze_Instance_And_Renamings --
------------------------------------
procedure Analyze_Instance_And_Renamings is
Def_Ent : constant Entity_Id := Defining_Entity (N);
Pack_Decl : Node_Id;
begin
if Nkind (Parent (N)) = N_Compilation_Unit then
-- For the case of a compilation unit, the container package
-- has the same name as the instantiation, to insure that the
-- binder calls the elaboration procedure with the right name.
-- Copy the entity of the instance, which may have compilation
-- level flags (e.g. Is_Child_Unit) set.
Pack_Id := New_Copy (Def_Ent);
else
-- Otherwise we use the name of the instantiation concatenated
-- with its source position to ensure uniqueness if there are
-- several instantiations with the same name.
Pack_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name
(Related_Id => Chars (Def_Ent),
Suffix => "GP",
Suffix_Index => Source_Offset (Sloc (Def_Ent))));
end if;
Pack_Decl := Make_Package_Declaration (Loc,
Specification => Make_Package_Specification (Loc,
Defining_Unit_Name => Pack_Id,
Visible_Declarations => Renaming_List,
End_Label => Empty));
Set_Instance_Spec (N, Pack_Decl);
Set_Is_Generic_Instance (Pack_Id);
Set_Needs_Debug_Info (Pack_Id);
-- Case of not a compilation unit
if Nkind (Parent (N)) /= N_Compilation_Unit then
Mark_Rewrite_Insertion (Pack_Decl);
Insert_Before (N, Pack_Decl);
Set_Has_Completion (Pack_Id);
-- Case of an instantiation that is a compilation unit
-- Place declaration on current node so context is complete
-- for analysis (including nested instantiations), and for
-- use in a context_clause (see Analyze_With_Clause).
else
Set_Unit (Parent (N), Pack_Decl);
Set_Parent_Spec (Pack_Decl, Parent_Spec (N));
end if;
Analyze (Pack_Decl);
Check_Formal_Packages (Pack_Id);
Set_Is_Generic_Instance (Pack_Id, False);
-- Body of the enclosing package is supplied when instantiating
-- the subprogram body, after semantic analysis is completed.
if Nkind (Parent (N)) = N_Compilation_Unit then
-- Remove package itself from visibility, so it does not
-- conflict with subprogram.
Set_Name_Entity_Id (Chars (Pack_Id), Homonym (Pack_Id));
-- Set name and scope of internal subprogram so that the
-- proper external name will be generated. The proper scope
-- is the scope of the wrapper package. We need to generate
-- debugging information for the internal subprogram, so set
-- flag accordingly.
Set_Chars (Anon_Id, Chars (Defining_Entity (N)));
Set_Scope (Anon_Id, Scope (Pack_Id));
-- Mark wrapper package as referenced, to avoid spurious
-- warnings if the instantiation appears in various with_
-- clauses of subunits of the main unit.
Set_Referenced (Pack_Id);
end if;
Set_Is_Generic_Instance (Anon_Id);
Set_Needs_Debug_Info (Anon_Id);
Act_Decl_Id := New_Copy (Anon_Id);
Set_Parent (Act_Decl_Id, Parent (Anon_Id));
Set_Chars (Act_Decl_Id, Chars (Defining_Entity (N)));
Set_Sloc (Act_Decl_Id, Sloc (Defining_Entity (N)));
Set_Comes_From_Source (Act_Decl_Id, True);
-- The signature may involve types that are not frozen yet, but
-- the subprogram will be frozen at the point the wrapper package
-- is frozen, so it does not need its own freeze node. In fact, if
-- one is created, it might conflict with the freezing actions from
-- the wrapper package (see 7206-013).
Set_Has_Delayed_Freeze (Anon_Id, False);
-- If the instance is a child unit, mark the Id accordingly. Mark
-- the anonymous entity as well, which is the real subprogram and
-- which is used when the instance appears in a context clause.
Set_Is_Child_Unit (Act_Decl_Id, Is_Child_Unit (Defining_Entity (N)));
Set_Is_Child_Unit (Anon_Id, Is_Child_Unit (Defining_Entity (N)));
New_Overloaded_Entity (Act_Decl_Id);
Check_Eliminated (Act_Decl_Id);
-- In compilation unit case, kill elaboration checks on the
-- instantiation, since they are never needed -- the body is
-- instantiated at the same point as the spec.
if Nkind (Parent (N)) = N_Compilation_Unit then
Set_Suppress_Elaboration_Warnings (Act_Decl_Id);
Set_Kill_Elaboration_Checks (Act_Decl_Id);
Set_Is_Compilation_Unit (Anon_Id);
Set_Cunit_Entity (Current_Sem_Unit, Pack_Id);
end if;
-- The instance is not a freezing point for the new subprogram.
Set_Is_Frozen (Act_Decl_Id, False);
if Nkind (Defining_Entity (N)) = N_Defining_Operator_Symbol then
Valid_Operator_Definition (Act_Decl_Id);
end if;
Set_Alias (Act_Decl_Id, Anon_Id);
Set_Parent (Act_Decl_Id, Parent (Anon_Id));
Set_Has_Completion (Act_Decl_Id);
Set_Related_Instance (Pack_Id, Act_Decl_Id);
if Nkind (Parent (N)) = N_Compilation_Unit then
Set_Body_Required (Parent (N), False);
end if;
end Analyze_Instance_And_Renamings;
-- Start of processing for Analyze_Subprogram_Instantiation
begin
-- Very first thing: apply the special kludge for Text_IO processing
-- in case we are instantiating one of the children of [Wide_]Text_IO.
-- Of course such an instantiation is bogus (these are packages, not
-- subprograms), but we get a better error message if we do this.
Text_IO_Kludge (Gen_Id);
-- Make node global for error reporting.
Instantiation_Node := N;
Pre_Analyze_Actuals (N);
Init_Env;
Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
Gen_Unit := Entity (Gen_Id);
Generate_Reference (Gen_Unit, Gen_Id);
if Nkind (Gen_Id) = N_Identifier
and then Chars (Gen_Unit) = Chars (Defining_Entity (N))
then
Error_Msg_NE
("& is hidden within declaration of instance", Gen_Id, Gen_Unit);
end if;
if Etype (Gen_Unit) = Any_Type then
Restore_Env;
return;
end if;
-- Verify that it is a generic subprogram of the right kind, and that
-- it does not lead to a circular instantiation.
if Ekind (Gen_Unit) /= E_Generic_Procedure
and then Ekind (Gen_Unit) /= E_Generic_Function
then
Error_Msg_N ("expect generic subprogram in instantiation", Gen_Id);
elsif In_Open_Scopes (Gen_Unit) then
Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit);
elsif K = E_Procedure
and then Ekind (Gen_Unit) /= E_Generic_Procedure
then
if Ekind (Gen_Unit) = E_Generic_Function then
Error_Msg_N
("cannot instantiate generic function as procedure", Gen_Id);
else
Error_Msg_N
("expect name of generic procedure in instantiation", Gen_Id);
end if;
elsif K = E_Function
and then Ekind (Gen_Unit) /= E_Generic_Function
then
if Ekind (Gen_Unit) = E_Generic_Procedure then
Error_Msg_N
("cannot instantiate generic procedure as function", Gen_Id);
else
Error_Msg_N
("expect name of generic function in instantiation", Gen_Id);
end if;
else
Set_Entity (Gen_Id, Gen_Unit);
Set_Is_Instantiated (Gen_Unit);
if In_Extended_Main_Source_Unit (N) then
Generate_Reference (Gen_Unit, N);
end if;
-- If renaming, get original unit
if Present (Renamed_Object (Gen_Unit))
and then (Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Procedure
or else
Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Function)
then
Gen_Unit := Renamed_Object (Gen_Unit);
Set_Is_Instantiated (Gen_Unit);
Generate_Reference (Gen_Unit, N);
end if;
if Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then
Error_Msg_Node_2 := Current_Scope;
Error_Msg_NE
("circular Instantiation: & instantiated in &!", N, Gen_Unit);
Circularity_Detected := True;
return;
end if;
Gen_Decl := Unit_Declaration_Node (Gen_Unit);
-- The subprogram itself cannot contain a nested instance, so
-- the current parent is left empty.
Set_Instance_Env (Gen_Unit, Empty);
-- Initialize renamings map, for error checking.
Generic_Renamings.Set_Last (0);
Generic_Renamings_HTable.Reset;
Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
-- Copy original generic tree, to produce text for instantiation.
Act_Tree :=
Copy_Generic_Node
(Original_Node (Gen_Decl), Empty, Instantiating => True);
Act_Spec := Specification (Act_Tree);
Renaming_List :=
Analyze_Associations
(N,
Generic_Formal_Declarations (Act_Tree),
Generic_Formal_Declarations (Gen_Decl));
-- Build the subprogram declaration, which does not appear
-- in the generic template, and give it a sloc consistent
-- with that of the template.
Set_Defining_Unit_Name (Act_Spec, Anon_Id);
Set_Generic_Parent (Act_Spec, Gen_Unit);
Act_Decl :=
Make_Subprogram_Declaration (Sloc (Act_Spec),
Specification => Act_Spec);
Set_Categorization_From_Pragmas (Act_Decl);
if Parent_Installed then
Hide_Current_Scope;
end if;
Append (Act_Decl, Renaming_List);
Analyze_Instance_And_Renamings;
-- If the generic is marked Import (Intrinsic), then so is the
-- instance. This indicates that there is no body to instantiate.
-- If generic is marked inline, so it the instance, and the
-- anonymous subprogram it renames. If inlined, or else if inlining
-- is enabled for the compilation, we generate the instance body
-- even if it is not within the main unit.
-- Any other pragmas might also be inherited ???
if Is_Intrinsic_Subprogram (Gen_Unit) then
Set_Is_Intrinsic_Subprogram (Anon_Id);
Set_Is_Intrinsic_Subprogram (Act_Decl_Id);
if Chars (Gen_Unit) = Name_Unchecked_Conversion then
Validate_Unchecked_Conversion (N, Act_Decl_Id);
end if;
end if;
Generate_Definition (Act_Decl_Id);
Set_Is_Inlined (Act_Decl_Id, Is_Inlined (Gen_Unit));
Set_Is_Inlined (Anon_Id, Is_Inlined (Gen_Unit));
if not Is_Intrinsic_Subprogram (Gen_Unit) then
Check_Elab_Instantiation (N);
end if;
Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id);
-- Subject to change, pending on if other pragmas are inherited ???
Validate_Categorization_Dependency (N, Act_Decl_Id);
if not Is_Intrinsic_Subprogram (Act_Decl_Id) then
if not Generic_Separately_Compiled (Gen_Unit) then
Inherit_Context (Gen_Decl, N);
end if;
Restore_Private_Views (Pack_Id, False);
-- If the context requires a full instantiation, mark node for
-- subsequent construction of the body.
if (Is_In_Main_Unit (N)
or else Is_Inlined (Act_Decl_Id))
and then (Operating_Mode = Generate_Code
or else (Operating_Mode = Check_Semantics
and then ASIS_Mode))
and then (Expander_Active or else ASIS_Mode)
and then not ABE_Is_Certain (N)
and then not Is_Eliminated (Act_Decl_Id)
then
Pending_Instantiations.Increment_Last;
Pending_Instantiations.Table (Pending_Instantiations.Last) :=
(N, Act_Decl, Expander_Active, Current_Sem_Unit);
Check_Forward_Instantiation (Gen_Decl);
-- The wrapper package is always delayed, because it does
-- not constitute a freeze point, but to insure that the
-- freeze node is placed properly, it is created directly
-- when instantiating the body (otherwise the freeze node
-- might appear to early for nested instantiations).
elsif Nkind (Parent (N)) = N_Compilation_Unit then
-- For ASIS purposes, indicate that the wrapper package has
-- replaced the instantiation node.
Rewrite (N, Unit (Parent (N)));
Set_Unit (Parent (N), N);
end if;
elsif Nkind (Parent (N)) = N_Compilation_Unit then
-- Replace instance node for library-level instantiations
-- of intrinsic subprograms, for ASIS use.
Rewrite (N, Unit (Parent (N)));
Set_Unit (Parent (N), N);
end if;
if Parent_Installed then
Remove_Parent;
end if;
Restore_Env;
Generic_Renamings.Set_Last (0);
Generic_Renamings_HTable.Reset;
end if;
exception
when Instantiation_Error =>
if Parent_Installed then
Remove_Parent;
end if;
end Analyze_Subprogram_Instantiation;
-------------------------
-- Get_Associated_Node --
-------------------------
function Get_Associated_Node (N : Node_Id) return Node_Id is
Assoc : Node_Id := Associated_Node (N);
begin
if Nkind (Assoc) /= Nkind (N) then
return Assoc;
elsif Nkind (Assoc) = N_Aggregate
or else Nkind (Assoc) = N_Extension_Aggregate
then
return Assoc;
else
-- If the node is part of an inner generic, it may itself have been
-- remapped into a further generic copy. Associated_Node is otherwise
-- used for the entity of the node, and will be of a different node
-- kind, or else N has been rewritten as a literal or function call.
while Present (Associated_Node (Assoc))
and then Nkind (Associated_Node (Assoc)) = Nkind (Assoc)
loop
Assoc := Associated_Node (Assoc);
end loop;
-- Follow and additional link in case the final node was rewritten.
-- This can only happen with nested generic units.
if (Nkind (Assoc) = N_Identifier or else Nkind (Assoc) in N_Op)
and then Present (Associated_Node (Assoc))
and then (Nkind (Associated_Node (Assoc)) = N_Function_Call
or else
Nkind (Associated_Node (Assoc)) = N_Explicit_Dereference
or else
Nkind (Associated_Node (Assoc)) = N_Integer_Literal
or else
Nkind (Associated_Node (Assoc)) = N_Real_Literal
or else
Nkind (Associated_Node (Assoc)) = N_String_Literal)
then
Assoc := Associated_Node (Assoc);
end if;
return Assoc;
end if;
end Get_Associated_Node;
-------------------------------------------
-- Build_Instance_Compilation_Unit_Nodes --
-------------------------------------------
procedure Build_Instance_Compilation_Unit_Nodes
(N : Node_Id;
Act_Body : Node_Id;
Act_Decl : Node_Id)
is
Decl_Cunit : Node_Id;
Body_Cunit : Node_Id;
Citem : Node_Id;
New_Main : constant Entity_Id := Defining_Entity (Act_Decl);
Old_Main : constant Entity_Id := Cunit_Entity (Main_Unit);
begin
-- A new compilation unit node is built for the instance declaration
Decl_Cunit :=
Make_Compilation_Unit (Sloc (N),
Context_Items => Empty_List,
Unit => Act_Decl,
Aux_Decls_Node =>
Make_Compilation_Unit_Aux (Sloc (N)));
Set_Parent_Spec (Act_Decl, Parent_Spec (N));
Set_Body_Required (Decl_Cunit, True);
-- We use the original instantiation compilation unit as the resulting
-- compilation unit of the instance, since this is the main unit.
Rewrite (N, Act_Body);
Body_Cunit := Parent (N);
-- The two compilation unit nodes are linked by the Library_Unit field
Set_Library_Unit (Decl_Cunit, Body_Cunit);
Set_Library_Unit (Body_Cunit, Decl_Cunit);
-- Preserve the private nature of the package if needed.
Set_Private_Present (Decl_Cunit, Private_Present (Body_Cunit));
-- If the instance is not the main unit, its context, categorization,
-- and elaboration entity are not relevant to the compilation.
if Parent (N) /= Cunit (Main_Unit) then
return;
end if;
-- The context clause items on the instantiation, which are now
-- attached to the body compilation unit (since the body overwrote
-- the original instantiation node), semantically belong on the spec,
-- so copy them there. It's harmless to leave them on the body as well.
-- In fact one could argue that they belong in both places.
Citem := First (Context_Items (Body_Cunit));
while Present (Citem) loop
Append (New_Copy (Citem), Context_Items (Decl_Cunit));
Next (Citem);
end loop;
-- Propagate categorization flags on packages, so that they appear
-- in ali file for the spec of the unit.
if Ekind (New_Main) = E_Package then
Set_Is_Pure (Old_Main, Is_Pure (New_Main));
Set_Is_Preelaborated (Old_Main, Is_Preelaborated (New_Main));
Set_Is_Remote_Types (Old_Main, Is_Remote_Types (New_Main));
Set_Is_Shared_Passive (Old_Main, Is_Shared_Passive (New_Main));
Set_Is_Remote_Call_Interface
(Old_Main, Is_Remote_Call_Interface (New_Main));
end if;
-- Make entry in Units table, so that binder can generate call to
-- elaboration procedure for body, if any.
Make_Instance_Unit (Body_Cunit);
Main_Unit_Entity := New_Main;
Set_Cunit_Entity (Main_Unit, Main_Unit_Entity);
-- Build elaboration entity, since the instance may certainly
-- generate elaboration code requiring a flag for protection.
Build_Elaboration_Entity (Decl_Cunit, New_Main);
end Build_Instance_Compilation_Unit_Nodes;
-----------------------------------
-- Check_Formal_Package_Instance --
-----------------------------------
-- If the formal has specific parameters, they must match those of the
-- actual. Both of them are instances, and the renaming declarations
-- for their formal parameters appear in the same order in both. The
-- analyzed formal has been analyzed in the context of the current
-- instance.
procedure Check_Formal_Package_Instance
(Formal_Pack : Entity_Id;
Actual_Pack : Entity_Id)
is
E1 : Entity_Id := First_Entity (Actual_Pack);
E2 : Entity_Id := First_Entity (Formal_Pack);
Expr1 : Node_Id;
Expr2 : Node_Id;
procedure Check_Mismatch (B : Boolean);
-- Common error routine for mismatch between the parameters of
-- the actual instance and those of the formal package.
procedure Check_Mismatch (B : Boolean) is
begin
if B then
Error_Msg_NE
("actual for & in actual instance does not match formal",
Parent (Actual_Pack), E1);
end if;
end Check_Mismatch;
-- Start of processing for Check_Formal_Package_Instance
begin
while Present (E1)
and then Present (E2)
loop
exit when Ekind (E1) = E_Package
and then Renamed_Entity (E1) = Renamed_Entity (Actual_Pack);
if Is_Type (E1) then
-- Subtypes must statically match. E1 and E2 are the
-- local entities that are subtypes of the actuals.
-- Itypes generated for other parameters need not be checked,
-- the check will be performed on the parameters themselves.
if not Is_Itype (E1)
and then not Is_Itype (E2)
then
Check_Mismatch
(not Is_Type (E2)
or else Etype (E1) /= Etype (E2)
or else not Subtypes_Statically_Match (E1, E2));
end if;
elsif Ekind (E1) = E_Constant then
-- IN parameters must denote the same static value, or
-- the same constant, or the literal null.
Expr1 := Expression (Parent (E1));
if Ekind (E2) /= E_Constant then
Check_Mismatch (True);
goto Next_E;
else
Expr2 := Expression (Parent (E2));
end if;
if Is_Static_Expression (Expr1) then
if not Is_Static_Expression (Expr2) then
Check_Mismatch (True);
elsif Is_Integer_Type (Etype (E1)) then
declare
V1 : constant Uint := Expr_Value (Expr1);
V2 : constant Uint := Expr_Value (Expr2);
begin
Check_Mismatch (V1 /= V2);
end;
elsif Is_Real_Type (Etype (E1)) then
declare
V1 : constant Ureal := Expr_Value_R (Expr1);
V2 : constant Ureal := Expr_Value_R (Expr2);
begin
Check_Mismatch (V1 /= V2);
end;
elsif Is_String_Type (Etype (E1))
and then Nkind (Expr1) = N_String_Literal
then
if Nkind (Expr2) /= N_String_Literal then
Check_Mismatch (True);
else
Check_Mismatch
(not String_Equal (Strval (Expr1), Strval (Expr2)));
end if;
end if;
elsif Is_Entity_Name (Expr1) then
if Is_Entity_Name (Expr2) then
if Entity (Expr1) = Entity (Expr2) then
null;
elsif Ekind (Entity (Expr2)) = E_Constant
and then Is_Entity_Name (Constant_Value (Entity (Expr2)))
and then
Entity (Constant_Value (Entity (Expr2))) = Entity (Expr1)
then
null;
else
Check_Mismatch (True);
end if;
else
Check_Mismatch (True);
end if;
elsif Nkind (Expr1) = N_Null then
Check_Mismatch (Nkind (Expr1) /= N_Null);
else
Check_Mismatch (True);
end if;
elsif Ekind (E1) = E_Variable
or else Ekind (E1) = E_Package
then
Check_Mismatch
(Ekind (E1) /= Ekind (E2)
or else Renamed_Object (E1) /= Renamed_Object (E2));
elsif Is_Overloadable (E1) then
-- Verify that the names of the entities match.
-- What if actual is an attribute ???
Check_Mismatch
(Ekind (E2) /= Ekind (E1) or else (Alias (E1)) /= Alias (E2));
else
raise Program_Error;
end if;
<<Next_E>>
Next_Entity (E1);
Next_Entity (E2);
end loop;
end Check_Formal_Package_Instance;
---------------------------
-- Check_Formal_Packages --
---------------------------
procedure Check_Formal_Packages (P_Id : Entity_Id) is
E : Entity_Id;
Formal_P : Entity_Id;
begin
-- Iterate through the declarations in the instance, looking for
-- package renaming declarations that denote instances of formal
-- packages. Stop when we find the renaming of the current package
-- itself. The declaration for a formal package without a box is
-- followed by an internal entity that repeats the instantiation.
E := First_Entity (P_Id);
while Present (E) loop
if Ekind (E) = E_Package then
if Renamed_Object (E) = P_Id then
exit;
elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
null;
elsif not Box_Present (Parent (Associated_Formal_Package (E))) then
Formal_P := Next_Entity (E);
Check_Formal_Package_Instance (Formal_P, E);
end if;
end if;
Next_Entity (E);
end loop;
end Check_Formal_Packages;
---------------------------------
-- Check_Forward_Instantiation --
---------------------------------
procedure Check_Forward_Instantiation (Decl : Node_Id) is
S : Entity_Id;
Gen_Comp : Entity_Id := Cunit_Entity (Get_Source_Unit (Decl));
begin
-- The instantiation appears before the generic body if we are in the
-- scope of the unit containing the generic, either in its spec or in
-- the package body. and before the generic body.
if Ekind (Gen_Comp) = E_Package_Body then
Gen_Comp := Spec_Entity (Gen_Comp);
end if;
if In_Open_Scopes (Gen_Comp)
and then No (Corresponding_Body (Decl))
then
S := Current_Scope;
while Present (S)
and then not Is_Compilation_Unit (S)
and then not Is_Child_Unit (S)
loop
if Ekind (S) = E_Package then
Set_Has_Forward_Instantiation (S);
end if;
S := Scope (S);
end loop;
end if;
end Check_Forward_Instantiation;
---------------------------
-- Check_Generic_Actuals --
---------------------------
-- The visibility of the actuals may be different between the
-- point of generic instantiation and the instantiation of the body.
procedure Check_Generic_Actuals
(Instance : Entity_Id;
Is_Formal_Box : Boolean)
is
E : Entity_Id;
Astype : Entity_Id;
begin
E := First_Entity (Instance);
while Present (E) loop
if Is_Type (E)
and then Nkind (Parent (E)) = N_Subtype_Declaration
and then Scope (Etype (E)) /= Instance
and then Is_Entity_Name (Subtype_Indication (Parent (E)))
then
Check_Private_View (Subtype_Indication (Parent (E)));
Set_Is_Generic_Actual_Type (E, True);
Set_Is_Hidden (E, False);
-- We constructed the generic actual type as a subtype of
-- the supplied type. This means that it normally would not
-- inherit subtype specific attributes of the actual, which
-- is wrong for the generic case.
Astype := Ancestor_Subtype (E);
if No (Astype) then
-- can happen when E is an itype that is the full view of
-- a private type completed, e.g. with a constrained array.
Astype := Base_Type (E);
end if;
Set_Size_Info (E, (Astype));
Set_RM_Size (E, RM_Size (Astype));
Set_First_Rep_Item (E, First_Rep_Item (Astype));
if Is_Discrete_Or_Fixed_Point_Type (E) then
Set_RM_Size (E, RM_Size (Astype));
-- In nested instances, the base type of an access actual
-- may itself be private, and need to be exchanged.
elsif Is_Access_Type (E)
and then Is_Private_Type (Etype (E))
then
Check_Private_View
(New_Occurrence_Of (Etype (E), Sloc (Instance)));
end if;
elsif Ekind (E) = E_Package then
-- If this is the renaming for the current instance, we're done.
-- Otherwise it is a formal package. If the corresponding formal
-- was declared with a box, the (instantiations of the) generic
-- formal part are also visible. Otherwise, ignore the entity
-- created to validate the actuals.
if Renamed_Object (E) = Instance then
exit;
elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
null;
-- The visibility of a formal of an enclosing generic is already
-- correct.
elsif Denotes_Formal_Package (E) then
null;
elsif Present (Associated_Formal_Package (E))
and then Box_Present (Parent (Associated_Formal_Package (E)))
then
Check_Generic_Actuals (Renamed_Object (E), True);
Set_Is_Hidden (E, False);
end if;
-- If this is a subprogram instance (in a wrapper package) the
-- actual is fully visible.
elsif Is_Wrapper_Package (Instance) then
Set_Is_Hidden (E, False);
else
Set_Is_Hidden (E, not Is_Formal_Box);
end if;
Next_Entity (E);
end loop;
end Check_Generic_Actuals;
------------------------------
-- Check_Generic_Child_Unit --
------------------------------
procedure Check_Generic_Child_Unit
(Gen_Id : Node_Id;
Parent_Installed : in out Boolean)
is
Loc : constant Source_Ptr := Sloc (Gen_Id);
Gen_Par : Entity_Id := Empty;
Inst_Par : Entity_Id;
E : Entity_Id;
S : Node_Id;
function Find_Generic_Child
(Scop : Entity_Id;
Id : Node_Id)
return Entity_Id;
-- Search generic parent for possible child unit with the given name.
function In_Enclosing_Instance return Boolean;
-- Within an instance of the parent, the child unit may be denoted
-- by a simple name, or an abbreviated expanded name. Examine enclosing
-- scopes to locate a possible parent instantiation.
------------------------
-- Find_Generic_Child --
------------------------
function Find_Generic_Child
(Scop : Entity_Id;
Id : Node_Id)
return Entity_Id
is
E : Entity_Id;
begin
-- If entity of name is already set, instance has already been
-- resolved, e.g. in an enclosing instantiation.
if Present (Entity (Id)) then
if Scope (Entity (Id)) = Scop then
return Entity (Id);
else
return Empty;
end if;
else
E := First_Entity (Scop);
while Present (E) loop
if Chars (E) = Chars (Id)
and then Is_Child_Unit (E)
then
if Is_Child_Unit (E)
and then not Is_Visible_Child_Unit (E)
then
Error_Msg_NE
("generic child unit& is not visible", Gen_Id, E);
end if;
Set_Entity (Id, E);
return E;
end if;
Next_Entity (E);
end loop;
return Empty;
end if;
end Find_Generic_Child;
---------------------------
-- In_Enclosing_Instance --
---------------------------
function In_Enclosing_Instance return Boolean is
Enclosing_Instance : Node_Id;
Instance_Decl : Node_Id;
begin
Enclosing_Instance := Current_Scope;
while Present (Enclosing_Instance) loop
Instance_Decl := Unit_Declaration_Node (Enclosing_Instance);
if Ekind (Enclosing_Instance) = E_Package
and then Is_Generic_Instance (Enclosing_Instance)
and then Present
(Generic_Parent (Specification (Instance_Decl)))
then
-- Check whether the generic we are looking for is a child
-- of this instance.
E := Find_Generic_Child
(Generic_Parent (Specification (Instance_Decl)), Gen_Id);
exit when Present (E);
else
E := Empty;
end if;
Enclosing_Instance := Scope (Enclosing_Instance);
end loop;
if No (E) then
-- Not a child unit
Analyze (Gen_Id);
return False;
else
Rewrite (Gen_Id,
Make_Expanded_Name (Loc,
Chars => Chars (E),
Prefix => New_Occurrence_Of (Enclosing_Instance, Loc),
Selector_Name => New_Occurrence_Of (E, Loc)));
Set_Entity (Gen_Id, E);
Set_Etype (Gen_Id, Etype (E));
Parent_Installed := False; -- Already in scope.
return True;
end if;
end In_Enclosing_Instance;
-- Start of processing for Check_Generic_Child_Unit
begin
-- If the name of the generic is given by a selected component, it
-- may be the name of a generic child unit, and the prefix is the name
-- of an instance of the parent, in which case the child unit must be
-- visible. If this instance is not in scope, it must be placed there
-- and removed after instantiation, because what is being instantiated
-- is not the original child, but the corresponding child present in
-- the instance of the parent.
-- If the child is instantiated within the parent, it can be given by
-- a simple name. In this case the instance is already in scope, but
-- the child generic must be recovered from the generic parent as well.
if Nkind (Gen_Id) = N_Selected_Component then
S := Selector_Name (Gen_Id);
Analyze (Prefix (Gen_Id));
Inst_Par := Entity (Prefix (Gen_Id));
if Ekind (Inst_Par) = E_Package
and then Present (Renamed_Object (Inst_Par))
then
Inst_Par := Renamed_Object (Inst_Par);
end if;
if Ekind (Inst_Par) = E_Package then
if Nkind (Parent (Inst_Par)) = N_Package_Specification then
Gen_Par := Generic_Parent (Parent (Inst_Par));
elsif Nkind (Parent (Inst_Par)) = N_Defining_Program_Unit_Name
and then
Nkind (Parent (Parent (Inst_Par))) = N_Package_Specification
then
Gen_Par := Generic_Parent (Parent (Parent (Inst_Par)));
end if;
elsif Ekind (Inst_Par) = E_Generic_Package
and then Nkind (Parent (Gen_Id)) = N_Formal_Package_Declaration
then
-- A formal package may be a real child package, and not the
-- implicit instance within a parent. In this case the child is
-- not visible and has to be retrieved explicitly as well.
Gen_Par := Inst_Par;
end if;
if Present (Gen_Par) then
-- The prefix denotes an instantiation. The entity itself
-- may be a nested generic, or a child unit.
E := Find_Generic_Child (Gen_Par, S);
if Present (E) then
Change_Selected_Component_To_Expanded_Name (Gen_Id);
Set_Entity (Gen_Id, E);
Set_Etype (Gen_Id, Etype (E));
Set_Entity (S, E);
Set_Etype (S, Etype (E));
-- Indicate that this is a reference to the parent.
if In_Extended_Main_Source_Unit (Gen_Id) then
Set_Is_Instantiated (Inst_Par);
end if;
-- A common mistake is to replicate the naming scheme of
-- a hierarchy by instantiating a generic child directly,
-- rather than the implicit child in a parent instance:
-- generic .. package Gpar is ..
-- generic .. package Gpar.Child is ..
-- package Par is new Gpar ();
-- with Gpar.Child;
-- package Par.Child is new Gpar.Child ();
-- rather than Par.Child
-- In this case the instantiation is within Par, which is
-- an instance, but Gpar does not denote Par because we are
-- not IN the instance of Gpar, so this is illegal. The test
-- below recognizes this particular case.
if Is_Child_Unit (E)
and then not Comes_From_Source (Entity (Prefix (Gen_Id)))
and then (not In_Instance
or else Nkind (Parent (Parent (Gen_Id))) =
N_Compilation_Unit)
then
Error_Msg_N
("prefix of generic child unit must be instance of parent",
Gen_Id);
end if;
if not In_Open_Scopes (Inst_Par)
and then Nkind (Parent (Gen_Id)) not in
N_Generic_Renaming_Declaration
then
Install_Parent (Inst_Par);
Parent_Installed := True;
end if;
else
-- If the generic parent does not contain an entity that
-- corresponds to the selector, the instance doesn't either.
-- Analyzing the node will yield the appropriate error message.
-- If the entity is not a child unit, then it is an inner
-- generic in the parent.
Analyze (Gen_Id);
end if;
else
Analyze (Gen_Id);
if Is_Child_Unit (Entity (Gen_Id))
and then
Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration
and then not In_Open_Scopes (Inst_Par)
then
Install_Parent (Inst_Par);
Parent_Installed := True;
end if;
end if;
elsif Nkind (Gen_Id) = N_Expanded_Name then
-- Entity already present, analyze prefix, whose meaning may be
-- an instance in the current context. If it is an instance of
-- a relative within another, the proper parent may still have
-- to be installed, if they are not of the same generation.
Analyze (Prefix (Gen_Id));
Inst_Par := Entity (Prefix (Gen_Id));
if In_Enclosing_Instance then
null;
elsif Present (Entity (Gen_Id))
and then Is_Child_Unit (Entity (Gen_Id))
and then not In_Open_Scopes (Inst_Par)
then
Install_Parent (Inst_Par);
Parent_Installed := True;
end if;
elsif In_Enclosing_Instance then
-- The child unit is found in some enclosing scope
null;
else
Analyze (Gen_Id);
-- If this is the renaming of the implicit child in a parent
-- instance, recover the parent name and install it.
if Is_Entity_Name (Gen_Id) then
E := Entity (Gen_Id);
if Is_Generic_Unit (E)
and then Nkind (Parent (E)) in N_Generic_Renaming_Declaration
and then Is_Child_Unit (Renamed_Object (E))
and then Is_Generic_Unit (Scope (Renamed_Object (E)))
and then Nkind (Name (Parent (E))) = N_Expanded_Name
then
Rewrite (Gen_Id,
New_Copy_Tree (Name (Parent (E))));
Inst_Par := Entity (Prefix (Gen_Id));
if not In_Open_Scopes (Inst_Par) then
Install_Parent (Inst_Par);
Parent_Installed := True;
end if;
-- If it is a child unit of a non-generic parent, it may be
-- use-visible and given by a direct name. Install parent as
-- for other cases.
elsif Is_Generic_Unit (E)
and then Is_Child_Unit (E)
and then
Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration
and then not Is_Generic_Unit (Scope (E))
then
if not In_Open_Scopes (Scope (E)) then
Install_Parent (Scope (E));
Parent_Installed := True;
end if;
end if;
end if;
end if;
end Check_Generic_Child_Unit;
-----------------------------
-- Check_Hidden_Child_Unit --
-----------------------------
procedure Check_Hidden_Child_Unit
(N : Node_Id;
Gen_Unit : Entity_Id;
Act_Decl_Id : Entity_Id)
is
Gen_Id : constant Node_Id := Name (N);
begin
if Is_Child_Unit (Gen_Unit)
and then Is_Child_Unit (Act_Decl_Id)
and then Nkind (Gen_Id) = N_Expanded_Name
and then Entity (Prefix (Gen_Id)) = Scope (Act_Decl_Id)
and then Chars (Gen_Unit) = Chars (Act_Decl_Id)
then
Error_Msg_Node_2 := Scope (Act_Decl_Id);
Error_Msg_NE
("generic unit & is implicitly declared in &",