Google Git
Sign in
gnu / gcc / 926d9947847a0683cf34de6fc231209747576088 / . / gcc / ada / sem_ch12.adb
blob: b362362e70da584238fc5f4ebb9bfd6e8880d557 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S E M _ C H 1 2 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2015, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Aspects; use Aspects;
with Atree; use Atree;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Expander; use Expander;
with Exp_Disp; use Exp_Disp;
with Fname; use Fname;
with Fname.UF; use Fname.UF;
with Freeze; use Freeze;
with Ghost; use Ghost;
with Itypes; use Itypes;
with Lib; use Lib;
with Lib.Load; use Lib.Load;
with Lib.Xref; use Lib.Xref;
with Nlists; use Nlists;
with Namet; use Namet;
with Nmake; use Nmake;
with Opt; use Opt;
with Rident; use Rident;
with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch10; use Sem_Ch10;
with Sem_Ch13; use Sem_Ch13;
with Sem_Dim; use Sem_Dim;
with Sem_Disp; use Sem_Disp;
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 Warnsw; use Warnsw;
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 corresponding 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 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.
--------------------------------------------------
-- Formal packages and partial parameterization --
--------------------------------------------------
-- When compiling a generic, a formal package is a local instantiation. If
-- declared with a box, its generic formals are visible in the enclosing
-- generic. If declared with a partial list of actuals, those actuals that
-- are defaulted (covered by an Others clause, or given an explicit box
-- initialization) are also visible in the enclosing generic, while those
-- that have a corresponding actual are not.
-- In our source model of instantiation, the same visibility must be
-- present in the spec and body of an instance: the names of the formals
-- that are defaulted must be made visible within the instance, and made
-- invisible (hidden) after the instantiation is complete, so that they
-- are not accessible outside of the instance.
-- In a generic, a formal package is treated like a special instantiation.
-- Our Ada 95 compiler handled formals with and without box in different
-- ways. With partial parameterization, we use a single model for both.
-- We create a package declaration that consists of the specification of
-- the generic package, and a set of declarations that map the actuals
-- into local renamings, just as we do for bona fide instantiations. For
-- defaulted parameters and formals with a box, we copy directly the
-- declarations of the formal into this local package. The result is a
-- a package whose visible declarations may include generic formals. This
-- package is only used for type checking and visibility analysis, and
-- never reaches the back-end, so it can freely violate the placement
-- rules for generic formal declarations.
-- The list of declarations (renamings and copies of formals) is built
-- by Analyze_Associations, just as for regular instantiations.
-- At the point of instantiation, conformance checking must be applied only
-- to those parameters that were specified in the formal. We perform this
-- checking by creating another internal instantiation, this one including
-- only the renamings and the formals (the rest of the package spec is not
-- relevant to conformance checking). We can then traverse two lists: the
-- list of actuals in the instance that corresponds to the formal package,
-- and the list of actuals produced for this bogus instantiation. We apply
-- the conformance rules to those actuals that are not defaulted (i.e.
-- which still appear as generic formals.
-- When we compile an instance body we must make the right parameters
-- visible again. The predicate Is_Generic_Formal indicates which of the
-- formals should have its Is_Hidden flag reset.
-----------------------
-- 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_Interface_Type
(N : Node_Id;
T : Entity_Id;
Def : Node_Id);
procedure Analyze_Formal_Derived_Type
(N : Node_Id;
T : Entity_Id;
Def : Node_Id);
procedure Analyze_Formal_Interface_Type
(N : Node_Id;
T : Entity_Id;
Def : Node_Id);
-- The following subprograms create abbreviated declarations for formal
-- scalar types. We introduce an anonymous base of the proper class for
-- each of them, and define the formals as constrained first subtypes of
-- their bases. The bounds are expressions that are non-static in the
-- generic.
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);
-- Creates a new private type, which does not require completion
procedure Analyze_Formal_Incomplete_Type (T : Entity_Id; Def : Node_Id);
-- Ada 2012: Creates a new incomplete type whose actual does not freeze
procedure Analyze_Generic_Formal_Part (N : Node_Id);
-- Analyze generic formal part
procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id);
-- Create a new access type with the given designated type
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_Access_Definition (N : Node_Id);
-- Subsidiary routine to null exclusion processing. Perform an assertion
-- check on Ada version and the presence of an access definition in N.
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.
function Check_Hidden_Primitives (Assoc_List : List_Id) return Elist_Id;
-- Check if some association between formals and actuals requires to make
-- visible primitives of a tagged type, and make those primitives visible.
-- Return the list of primitives whose visibility is modified (to restore
-- their visibility later through Restore_Hidden_Primitives). If no
-- candidate is found then return No_Elist.
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_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;
On_Exit : Boolean := False;
Instance : Entity_Id := Empty) 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. If such
-- a package is used as a formal in an nested generic, or as an actual
-- in a nested instantiation, the visibility of ITS formals should not
-- be modified. When called from within Restore_Private_Views, the flag
-- On_Exit is true, to indicate that the search for a possible enclosing
-- instance should ignore the current one. In that case Instance denotes
-- the declaration for which this is an actual. This declaration may be
-- an instantiation in the source, or the internal instantiation that
-- corresponds to the actual for a formal package.
function Earlier (N1, N2 : Node_Id) return Boolean;
-- Yields True if N1 and N2 appear in the same compilation unit,
-- ignoring subunits, and if N1 is to the left of N2 in a left-to-right
-- traversal of the tree for the unit. Used to determine the placement
-- of freeze nodes for instance bodies that may depend on other instances.
function Find_Actual_Type
(Typ : Entity_Id;
Gen_Type : 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, or designated type of an
-- access formal) and Gen_Type is the enclosing analyzed formal array
-- or access type. The desired actual may be a formal of a parent, or may
-- be declared in a formal package of a parent. In both cases it is a
-- generic actual type because it appears within a visible instance.
-- Finally, it may be declared in a parent unit without being a formal
-- of that unit, in which case it must be retrieved by visibility.
-- Ambiguities may still arise if two homonyms are declared in two formal
-- packages, and the prefix of the formal type may be needed to resolve
-- the ambiguity in the instance ???
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 subprograms or concurrent units. Used to find the proper plave
-- for the freeze node of an instance, when the generic is declared in a
-- previous instance. If predicate is true, the freeze node of the instance
-- can be placed after the freeze node of the previous instance, Otherwise
-- it has to be placed at the end of the current declarative part.
function In_Main_Context (E : Entity_Id) return Boolean;
-- Check whether an instantiation is in the context of the main unit.
-- Used to determine whether its body should be elaborated to allow
-- front-end inlining.
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,
-- The procedure also examines whether the generic unit is a predefined
-- unit, in order to set configuration switches accordingly. As a result
-- the procedure must be called after analyzing and freezing the actuals.
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 instantiating 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 the instantiation. 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_Freeze_Node_For_Instance
(N : Node_Id;
F_Node : Node_Id);
-- N denotes a package or a subprogram instantiation and F_Node is the
-- associated freeze node. Insert the freeze node before the first source
-- body which follows immediately after N. If no such body is found, the
-- freeze node is inserted at the end of the declarative region which
-- contains N.
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_Formal_Packages (Par : Entity_Id);
-- Install the visible part of any formal of the parent that is a formal
-- package. Note that for the case of a formal package with a box, this
-- includes the formal part of the formal package (12.7(10/2)).
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 Install_Hidden_Primitives
(Prims_List : in out Elist_Id;
Gen_T : Entity_Id;
Act_T : Entity_Id);
-- Remove suffix 'P' from hidden primitives of Act_T to match the
-- visibility of primitives of Gen_T. The list of primitives to which
-- the suffix is removed is added to Prims_List to restore them later.
procedure Restore_Hidden_Primitives (Prims_List : in out Elist_Id);
-- Restore suffix 'P' to primitives of Prims_List and leave Prims_List
-- set to No_Elist.
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. In all of these
-- Formal is the entity in the generic unit, Actual is the entity of
-- expression in the generic associations, and Analyzed_Formal is the
-- formal in the generic copy, which contains the semantic information to
-- be used to validate the actual.
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 List_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 has 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.
-- This internal instantiation only needs to contain the renamings of the
-- formals: the visible and private declarations themselves need not be
-- created.
-- In Ada 2005, the formal package may be only partially parameterized.
-- In that case the visibility step must make visible those actuals whose
-- corresponding formals were given with a box. A final complication
-- involves inherited operations from formal derived types, which must
-- be visible if the type is.
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;
Body_Optional : Boolean := False);
-- 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.
--
-- Body_Optional is a flag that indicates that the body is being loaded to
-- ensure that temporaries are generated consistently when there are other
-- instances in the current declarative part that precede the one being
-- loaded. In that case a missing body is acceptable.
procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id);
-- Add the context clause of the unit containing a generic unit to a
-- compilation unit that is, or contains, an instantiation.
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 Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id);
-- Within the generic part, entities in the formal package are
-- visible. To validate subsequent type declarations, indicate
-- the correspondence between the entities in the analyzed formal,
-- and the entities in the actual package. There are three packages
-- involved in the instantiation of a formal package: the parent
-- generic P1 which appears in the generic declaration, the fake
-- instantiation P2 which appears in the analyzed generic, and whose
-- visible entities may be used in subsequent formals, and the actual
-- P3 in the instance. To validate subsequent formals, me indicate
-- that the entities in P2 are mapped into those of P3. The mapping of
-- entities has to be done recursively for nested packages.
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 Preanalyze_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.
function True_Parent (N : Node_Id) return Node_Id;
-- For a subunit, return parent of corresponding stub, else return
-- parent of node.
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.
Parent_Unit_Visible : Boolean := False;
-- Parent_Unit_Visible is used when the generic is a child unit, and
-- indicates whether the ultimate parent of the generic is visible in the
-- instantiation environment. It is used to reset the visibility of the
-- parent at the end of the instantiation (see Remove_Parent).
Instance_Parent_Unit : Entity_Id := Empty;
-- This records the ultimate parent unit of an instance of a generic
-- child unit and is used in conjunction with Parent_Unit_Visible to
-- indicate the unit to which the Parent_Unit_Visible flag corresponds.
type Instance_Env is record
Instantiated_Parent : Assoc;
Exchanged_Views : Elist_Id;
Hidden_Entities : Elist_Id;
Current_Sem_Unit : Unit_Number_Type;
Parent_Unit_Visible : Boolean := False;
Instance_Parent_Unit : Entity_Id := Empty;
Switches : Config_Switches_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 compatible 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
Actuals_To_Freeze : constant Elist_Id := New_Elmt_List;
Assoc : constant List_Id := New_List;
Default_Actuals : constant List_Id := New_List;
Gen_Unit : constant Entity_Id :=
Defining_Entity (Parent (F_Copy));
Actuals : List_Id;
Actual : Node_Id;
Analyzed_Formal : Node_Id;
First_Named : Node_Id := Empty;
Formal : Node_Id;
Match : Node_Id;
Named : Node_Id;
Saved_Formal : Node_Id;
Default_Formals : constant List_Id := New_List;
-- If an Others_Choice is present, some of the formals may be defaulted.
-- To simplify the treatment of visibility in an instance, we introduce
-- individual defaults for each such formal. These defaults are
-- appended to the list of associations and replace the Others_Choice.
Found_Assoc : Node_Id;
-- Association for the current formal being match. Empty if there are
-- no remaining actuals, or if there is no named association with the
-- name of the formal.
Is_Named_Assoc : Boolean;
Num_Matched : Int := 0;
Num_Actuals : Int := 0;
Others_Present : Boolean := False;
Others_Choice : Node_Id := Empty;
-- In Ada 2005, indicates partial parameterization of a formal
-- package. As usual an other association must be last in the list.
procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id);
-- Apply RM 12.3 (9): if a formal subprogram is overloaded, the instance
-- cannot have a named association for it. AI05-0025 extends this rule
-- to formals of formal packages by AI05-0025, and it also applies to
-- box-initialized formals.
function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean;
-- Determine whether the parameter types and the return type of Subp
-- are fully defined at the point of instantiation.
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.
--
-- In Ada 2005, a named association may be given with a box, in which
-- case Matching_Actual sets Found_Assoc to the generic association,
-- but return Empty for the actual itself. In this case the code below
-- creates a corresponding declaration for the formal.
function Partial_Parameterization return Boolean;
-- Ada 2005: if no match is found for a given formal, check if the
-- association for it includes a box, or whether the associations
-- include an Others clause.
procedure Process_Default (F : Entity_Id);
-- Add a copy of the declaration of generic formal F to the list of
-- associations, and add an explicit box association for F if there
-- is none yet, and the default comes from an Others_Choice.
function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean;
-- Determine whether Subp renames one of the subprograms defined in the
-- generated package Standard.
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.
----------------------------------------
-- Check_Overloaded_Formal_Subprogram --
----------------------------------------
procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id) is
Temp_Formal : Entity_Id;
begin
Temp_Formal := First (Formals);
while Present (Temp_Formal) loop
if Nkind (Temp_Formal) in N_Formal_Subprogram_Declaration
and then Temp_Formal /= Formal
and then
Chars (Defining_Unit_Name (Specification (Formal))) =
Chars (Defining_Unit_Name (Specification (Temp_Formal)))
then
if Present (Found_Assoc) then
Error_Msg_N
("named association not allowed for overloaded formal",
Found_Assoc);
else
Error_Msg_N
("named association not allowed for overloaded formal",
Others_Choice);
end if;
Abandon_Instantiation (Instantiation_Node);
end if;
Next (Temp_Formal);
end loop;
end Check_Overloaded_Formal_Subprogram;
-------------------------------
-- Has_Fully_Defined_Profile --
-------------------------------
function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean is
function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean;
-- Determine whethet type Typ is fully defined
---------------------------
-- Is_Fully_Defined_Type --
---------------------------
function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean is
begin
-- A private type without a full view is not fully defined
if Is_Private_Type (Typ)
and then No (Full_View (Typ))
then
return False;
-- An incomplete type is never fully defined
elsif Is_Incomplete_Type (Typ) then
return False;
-- All other types are fully defined
else
return True;
end if;
end Is_Fully_Defined_Type;
-- Local declarations
Param : Entity_Id;
-- Start of processing for Has_Fully_Defined_Profile
begin
-- Check the parameters
Param := First_Formal (Subp);
while Present (Param) loop
if not Is_Fully_Defined_Type (Etype (Param)) then
return False;
end if;
Next_Formal (Param);
end loop;
-- Check the return type
return Is_Fully_Defined_Type (Etype (Subp));
end Has_Fully_Defined_Profile;
---------------------
-- Matching_Actual --
---------------------
function Matching_Actual
(F : Entity_Id;
A_F : Entity_Id) return Node_Id
is
Prev : Node_Id;
Act : Node_Id;
begin
Is_Named_Assoc := False;
-- End of list of purely positional parameters
if No (Actual) or else Nkind (Actual) = N_Others_Choice then
Found_Assoc := Empty;
Act := Empty;
-- Case of positional parameter corresponding to current formal
elsif No (Selector_Name (Actual)) then
Found_Assoc := Actual;
Act := Explicit_Generic_Actual_Parameter (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_Assoc := Empty;
Act := Empty;
Prev := Empty;
while Present (Actual) loop
if Chars (Selector_Name (Actual)) = Chars (F) then
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;
Act := Explicit_Generic_Actual_Parameter (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;
if Is_Entity_Name (Act) and then Present (Entity (Act)) then
Set_Used_As_Generic_Actual (Entity (Act));
end if;
return Act;
end Matching_Actual;
------------------------------
-- Partial_Parameterization --
------------------------------
function Partial_Parameterization return Boolean is
begin
return Others_Present
or else (Present (Found_Assoc) and then Box_Present (Found_Assoc));
end Partial_Parameterization;
---------------------
-- Process_Default --
---------------------
procedure Process_Default (F : Entity_Id) is
Loc : constant Source_Ptr := Sloc (I_Node);
F_Id : constant Entity_Id := Defining_Entity (F);
Decl : Node_Id;
Default : Node_Id;
Id : Entity_Id;
begin
-- Append copy of formal declaration to associations, and create new
-- defining identifier for it.
Decl := New_Copy_Tree (F);
Id := Make_Defining_Identifier (Sloc (F_Id), Chars (F_Id));
if Nkind (F) in N_Formal_Subprogram_Declaration then
Set_Defining_Unit_Name (Specification (Decl), Id);
else
Set_Defining_Identifier (Decl, Id);
end if;
Append (Decl, Assoc);
if No (Found_Assoc) then
Default :=
Make_Generic_Association (Loc,
Selector_Name =>
New_Occurrence_Of (Id, Loc),
Explicit_Generic_Actual_Parameter => Empty);
Set_Box_Present (Default);
Append (Default, Default_Formals);
end if;
end Process_Default;
---------------------------------
-- Renames_Standard_Subprogram --
---------------------------------
function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean is
Id : Entity_Id;
begin
Id := Alias (Subp);
while Present (Id) loop
if Scope (Id) = Standard_Standard then
return True;
end if;
Id := Alias (Id);
end loop;
return False;
end Renames_Standard_Subprogram;
-------------------------
-- 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 in 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 Nkind_In (Kind, N_Formal_Package_Declaration,
N_Generic_Package_Declaration,
N_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 not in N_Formal_Subprogram_Declaration
and then not Nkind_In (Kind, N_Subprogram_Declaration,
N_Freeze_Entity,
N_Null_Statement,
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
Actuals := Generic_Associations (I_Node);
if Present (Actuals) then
-- Check for an Others choice, indicating a partial parameterization
-- for a formal package.
Actual := First (Actuals);
while Present (Actual) loop
if Nkind (Actual) = N_Others_Choice then
Others_Present := True;
Others_Choice := Actual;
if Present (Next (Actual)) then
Error_Msg_N ("others must be last association", Actual);
end if;
-- This subprogram is used both for formal packages and for
-- instantiations. For the latter, associations must all be
-- explicit.
if Nkind (I_Node) /= N_Formal_Package_Declaration
and then Comes_From_Source (I_Node)
then
Error_Msg_N
("others association not allowed in an instance",
Actual);
end if;
-- In any case, nothing to do after the others association
exit;
elsif Box_Present (Actual)
and then Comes_From_Source (I_Node)
and then Nkind (I_Node) /= N_Formal_Package_Declaration
then
Error_Msg_N
("box association not allowed in an instance", Actual);
end if;
Next (Actual);
end loop;
-- If named associations are present, save first named association
-- (it may of course be Empty) to facilitate subsequent name search.
First_Named := First (Actuals);
while Present (First_Named)
and then Nkind (First_Named) /= N_Others_Choice
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 Nkind (Named) /= N_Others_Choice
and then 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 Nkind (Named) /= N_Others_Choice
and then 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;
Saved_Formal := Next_Non_Pragma (Formal);
case Nkind (Formal) is
when N_Formal_Object_Declaration =>
Match :=
Matching_Actual
(Defining_Identifier (Formal),
Defining_Identifier (Analyzed_Formal));
if No (Match) and then Partial_Parameterization then
Process_Default (Formal);
else
Append_List
(Instantiate_Object (Formal, Match, Analyzed_Formal),
Assoc);
-- For a defaulted in_parameter, create an entry in the
-- the list of defaulted actuals, for GNATProve use. Do
-- not included these defaults for an instance nested
-- within a generic, because the defaults are also used
-- in the analysis of the enclosing generic, and only
-- defaulted subprograms are relevant there.
if No (Match) and then not Inside_A_Generic then
Append_To (Default_Actuals,
Make_Generic_Association (Sloc (I_Node),
Selector_Name =>
New_Occurrence_Of
(Defining_Identifier (Formal), Sloc (I_Node)),
Explicit_Generic_Actual_Parameter =>
New_Copy_Tree (Default_Expression (Formal))));
end if;
end if;
-- If the object is a call to an expression function, this
-- is a freezing point for it.
if Is_Entity_Name (Match)
and then Present (Entity (Match))
and then Nkind
(Original_Node (Unit_Declaration_Node (Entity (Match))))
= N_Expression_Function
then
Append_Elmt (Entity (Match), Actuals_To_Freeze);
end if;
when N_Formal_Type_Declaration =>
Match :=
Matching_Actual
(Defining_Identifier (Formal),
Defining_Identifier (Analyzed_Formal));
if No (Match) then
if Partial_Parameterization then
Process_Default (Formal);
else
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);
end if;
else
Analyze (Match);
Append_List
(Instantiate_Type
(Formal, Match, Analyzed_Formal, Assoc),
Assoc);
-- An instantiation is a freeze point for the actuals,
-- unless this is a rewritten formal package, or the
-- formal is an Ada 2012 formal incomplete type.
if Nkind (I_Node) = N_Formal_Package_Declaration
or else
(Ada_Version >= Ada_2012
and then
Ekind (Defining_Identifier (Analyzed_Formal)) =
E_Incomplete_Type)
then
null;
else
Append_Elmt (Entity (Match), Actuals_To_Freeze);
end if;
end if;
-- A remote access-to-class-wide type is not a legal actual
-- for a generic formal of an access type (E.2.2(17/2)).
-- In GNAT an exception to this rule is introduced when
-- the formal is marked as remote using implementation
-- defined aspect/pragma Remote_Access_Type. In that case
-- the actual must be remote as well.
-- If the current instantiation is the construction of a
-- local copy for a formal package the actuals may be
-- defaulted, and there is no matching actual to check.
if Nkind (Analyzed_Formal) = N_Formal_Type_Declaration
and then
Nkind (Formal_Type_Definition (Analyzed_Formal)) =
N_Access_To_Object_Definition
and then Present (Match)
then
declare
Formal_Ent : constant Entity_Id :=
Defining_Identifier (Analyzed_Formal);
begin
if Is_Remote_Access_To_Class_Wide_Type (Entity (Match))
= Is_Remote_Types (Formal_Ent)
then
-- Remoteness of formal and actual match
null;
elsif Is_Remote_Types (Formal_Ent) then
-- Remote formal, non-remote actual
Error_Msg_NE
("actual for& must be remote", Match, Formal_Ent);
else
-- Non-remote formal, remote actual
Error_Msg_NE
("actual for& may not be remote",
Match, Formal_Ent);
end if;
end;
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
Check_Overloaded_Formal_Subprogram (Formal);
end if;
-- If there is no corresponding actual, this may be case
-- of partial parameterization, or else the formal has a
-- default or a box.
if No (Match) and then Partial_Parameterization then
Process_Default (Formal);
if Nkind (I_Node) = N_Formal_Package_Declaration then
Check_Overloaded_Formal_Subprogram (Formal);
end if;
else
Append_To (Assoc,
Instantiate_Formal_Subprogram
(Formal, Match, Analyzed_Formal));
-- An instantiation is a freeze point for the actuals,
-- unless this is a rewritten formal package.
if Nkind (I_Node) /= N_Formal_Package_Declaration
and then Nkind (Match) = N_Identifier
and then Is_Subprogram (Entity (Match))
-- The actual subprogram may rename a routine defined
-- in Standard. Avoid freezing such renamings because
-- subprograms coming from Standard cannot be frozen.
and then
not Renames_Standard_Subprogram (Entity (Match))
-- If the actual subprogram comes from a different
-- unit, it is already frozen, either by a body in
-- that unit or by the end of the declarative part
-- of the unit. This check avoids the freezing of
-- subprograms defined in Standard which are used
-- as generic actuals.
and then In_Same_Code_Unit (Entity (Match), I_Node)
and then Has_Fully_Defined_Profile (Entity (Match))
then
-- Mark the subprogram as having a delayed freeze
-- since this may be an out-of-order action.
Set_Has_Delayed_Freeze (Entity (Match));
Append_Elmt (Entity (Match), Actuals_To_Freeze);
end if;
end if;
-- If this is a nested generic, preserve default for later
-- instantiations. We do this as well for GNATProve use,
-- so that the list of generic associations is complete.
if No (Match) and then Box_Present (Formal) then
declare
Subp : constant Entity_Id :=
Defining_Unit_Name (Specification (Last (Assoc)));
begin
Append_To (Default_Actuals,
Make_Generic_Association (Sloc (I_Node),
Selector_Name =>
New_Occurrence_Of (Subp, Sloc (I_Node)),
Explicit_Generic_Actual_Parameter =>
New_Occurrence_Of (Subp, Sloc (I_Node))));
end;
end if;
when N_Formal_Package_Declaration =>
Match :=
Matching_Actual
(Defining_Identifier (Formal),
Defining_Identifier (Original_Node (Analyzed_Formal)));
if No (Match) then
if Partial_Parameterization then
Process_Default (Formal);
else
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);
end if;
else
Analyze (Match);
Append_List
(Instantiate_Formal_Package
(Formal, Match, Analyzed_Formal),
Assoc);
end if;
-- For use type and use package appearing in the generic part,
-- 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 =>
if Nkind (Original_Node (I_Node)) =
N_Formal_Package_Declaration
then
Append (New_Copy_Tree (Formal), Assoc);
else
Remove (Formal);
Append (Formal, Assoc);
end if;
when others =>
raise Program_Error;
end case;
Formal := Saved_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;
-- An instantiation freezes all generic actuals. The only exceptions
-- to this are incomplete types and subprograms which are not fully
-- defined at the point of instantiation.
declare
Elmt : Elmt_Id := First_Elmt (Actuals_To_Freeze);
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.
if not Is_Empty_List (Default_Actuals) then
declare
Default : Node_Id;
begin
Default := First (Default_Actuals);
while Present (Default) loop
Mark_Rewrite_Insertion (Default);
Next (Default);
end loop;
if No (Actuals) then
Set_Generic_Associations (I_Node, Default_Actuals);
else
Append_List_To (Actuals, Default_Actuals);
end if;
end;
end if;
-- If this is a formal package, normalize the parameter list by adding
-- explicit box associations for the formals that are covered by an
-- Others_Choice.
if not Is_Empty_List (Default_Formals) then
Append_List (Default_Formals, Formals);
end if;
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_In (DSS, N_Subtype_Indication,
N_Range,
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);
-- Check that range constraint is not allowed on the component type
-- of a generic formal array type (AARM 12.5.3(3))
elsif Is_Internal (Component_Type (T))
and then Present (Subtype_Indication (Component_Definition (Def)))
and then Nkind (Original_Node
(Subtype_Indication (Component_Definition (Def)))) =
N_Subtype_Indication
then
Error_Msg_N
("in a formal, a subtype indication can only be "
& "a subtype mark (RM 12.5.3(3))",
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.
-- Here and in other similar routines, the Sloc of the generated internal
-- type must be the same as the sloc of the defining identifier of the
-- formal type declaration, to provide proper source navigation.
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 (Defining_Identifier (Parent (Def))), 'G');
Int_Base : constant Entity_Id := Standard_Integer;
Delta_Val : constant Ureal := Ureal_1;
Digs_Val : constant Uint := Uint_6;
function Make_Dummy_Bound return Node_Id;
-- Return a properly typed universal real literal to use as a bound
----------------------
-- Make_Dummy_Bound --
----------------------
function Make_Dummy_Bound return Node_Id is
Bound : constant Node_Id := Make_Real_Literal (Loc, Ureal_1);
begin
Set_Etype (Bound, Universal_Real);
return Bound;
end Make_Dummy_Bound;
-- Start of processing for Analyze_Formal_Decimal_Fixed_Point_Type
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_Dummy_Bound,
High_Bound => Make_Dummy_Bound));
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));
Set_Is_Constrained (T);
Check_Restriction (No_Fixed_Point, Def);
end Analyze_Formal_Decimal_Fixed_Point_Type;
-------------------------------------------
-- Analyze_Formal_Derived_Interface_Type --
-------------------------------------------
procedure Analyze_Formal_Derived_Interface_Type
(N : Node_Id;
T : Entity_Id;
Def : Node_Id)
is
Loc : constant Source_Ptr := Sloc (Def);
begin
-- Rewrite as a type declaration of a derived type. This ensures that
-- the interface list and primitive operations are properly captured.
Rewrite (N,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => T,
Type_Definition => Def));
Analyze (N);
Set_Is_Generic_Type (T);
end Analyze_Formal_Derived_Interface_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),
Interface_List => Interface_List (Def));
Set_Abstract_Present (New_N, Abstract_Present (Def));
Set_Limited_Present (New_N, Limited_Present (Def));
Set_Synchronized_Present (New_N, Synchronized_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));
Set_Limited_Present
(Type_Definition (New_N), Limited_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;
Base : constant Entity_Id :=
New_Internal_Entity
(E_Floating_Point_Type, Current_Scope,
Sloc (Defining_Identifier (Parent (Def))), 'G');
begin
Enter_Name (T);
Set_Ekind (T, E_Enumeration_Subtype);
Set_Etype (T, Base);
Init_Size (T, 8);
Init_Alignment (T);
Set_Is_Generic_Type (T);
Set_Is_Constrained (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_Occurrence_Of (T, Loc));
Set_Etype (Lo, T);
Hi :=
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Last,
Prefix => New_Occurrence_Of (T, Loc));
Set_Etype (Hi, T);
Set_Scalar_Range (T,
Make_Range (Loc,
Low_Bound => Lo,
High_Bound => Hi));
Set_Ekind (Base, E_Enumeration_Type);
Set_Etype (Base, Base);
Init_Size (Base, 8);
Init_Alignment (Base);
Set_Is_Generic_Type (Base);
Set_Scalar_Range (Base, Scalar_Range (T));
Set_Parent (Base, Parent (Def));
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 (Defining_Identifier (Parent (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_Constrained (T);
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_Interface_Type;--
-----------------------------------
procedure Analyze_Formal_Interface_Type
(N : Node_Id;
T : Entity_Id;
Def : Node_Id)
is
Loc : constant Source_Ptr := Sloc (N);
New_N : Node_Id;
begin
New_N :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => T,
Type_Definition => Def);
Rewrite (N, New_N);
Analyze (N);
Set_Is_Generic_Type (T);
end Analyze_Formal_Interface_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 := Default_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;
if Present (Subtype_Mark (N)) then
Find_Type (Subtype_Mark (N));
T := Entity (Subtype_Mark (N));
-- Verify that there is no redundant null exclusion
if Null_Exclusion_Present (N) then
if not Is_Access_Type (T) then
Error_Msg_N
("null exclusion can only apply to an access type", N);
elsif Can_Never_Be_Null (T) then
Error_Msg_NE
("`NOT NULL` not allowed (& already excludes null)", N, T);
end if;
end if;
-- Ada 2005 (AI-423): Formal object with an access definition
else
Check_Access_Definition (N);
T := Access_Definition
(Related_Nod => N,
N => Access_Definition (N));
end if;
if Ekind (T) = E_Incomplete_Type then
declare
Error_Node : Node_Id;
begin
if Present (Subtype_Mark (N)) then
Error_Node := Subtype_Mark (N);
else
Check_Access_Definition (N);
Error_Node := Access_Definition (N);
end if;
Error_Msg_N ("premature usage of incomplete type", Error_Node);
end;
end if;
if K = E_Generic_In_Parameter then
-- Ada 2005 (AI-287): Limited aggregates allowed in generic formals
if Ada_Version < Ada_2005 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_Type (T) then
Error_Msg_N
("generic formal of mode IN must not be of abstract type", N);
end if;
if Present (E) then
Preanalyze_Spec_Expression (E, T);
if Is_Limited_Type (T) and then not OK_For_Limited_Init (T, E) then
Error_Msg_N
("initialization not allowed for limited types", E);
Explain_Limited_Type (T, E);
end if;
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_Occurrence_Of (Id, Sloc (Id));
Decl : Node_Id;
begin
-- Make sure 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;
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, Id);
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 (Defining_Identifier (Parent (Def))), 'G');
begin
-- The semantic attributes are set for completeness only, their values
-- will never be used, since 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_Constrained (T);
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_Declaration --
----------------------------------------
procedure Analyze_Formal_Package_Declaration (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Pack_Id : constant Entity_Id := Defining_Identifier (N);
Formal : Entity_Id;
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;
Associations : Boolean := True;
Vis_Prims_List : Elist_Id := No_Elist;
-- List of primitives made temporarily visible in the instantiation
-- to match the visibility of the formal type
function Build_Local_Package return Node_Id;
-- The formal package is rewritten so that its parameters are replaced
-- with corresponding declarations. For parameters with bona fide
-- associations these declarations are created by Analyze_Associations
-- as for a regular instantiation. For boxed parameters, we preserve
-- the formal declarations and analyze them, in order to introduce
-- entities of the right kind in the environment of the formal.
-------------------------
-- Build_Local_Package --
-------------------------
function Build_Local_Package return Node_Id is
Decls : List_Id;
Pack_Decl : Node_Id;
begin
-- Within the formal, the name of the generic package is a renaming
-- of the formal (as for a regular instantiation).
Pack_Decl :=
Make_Package_Declaration (Loc,
Specification =>
Copy_Generic_Node
(Specification (Original_Node (Gen_Decl)),
Empty, Instantiating => True));
Renaming := Make_Package_Renaming_Declaration (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Chars (Gen_Unit)),
Name => New_Occurrence_Of (Formal, Loc));
if Nkind (Gen_Id) = N_Identifier
and then Chars (Gen_Id) = Chars (Pack_Id)
then
Error_Msg_NE
("& is hidden within declaration of instance", Gen_Id, Gen_Unit);
end if;
-- If the formal is declared with a box, or with an others choice,
-- create corresponding declarations for all entities in the formal
-- part, so that names with the proper types are available in the
-- specification of the formal package.
-- On the other hand, if there are no associations, then all the
-- formals must have defaults, and this will be checked by the
-- call to Analyze_Associations.
if Box_Present (N)
or else Nkind (First (Generic_Associations (N))) = N_Others_Choice
then
declare
Formal_Decl : Node_Id;
begin
-- TBA : for a formal package, need to recurse ???
Decls := New_List;
Formal_Decl :=
First
(Generic_Formal_Declarations (Original_Node (Gen_Decl)));
while Present (Formal_Decl) loop
Append_To
(Decls, Copy_Generic_Node (Formal_Decl, Empty, True));
Next (Formal_Decl);
end loop;
end;
-- If generic associations are present, use Analyze_Associations to
-- create the proper renaming declarations.
else
declare
Act_Tree : constant Node_Id :=
Copy_Generic_Node
(Original_Node (Gen_Decl), Empty,
Instantiating => True);
begin
Generic_Renamings.Set_Last (0);
Generic_Renamings_HTable.Reset;
Instantiation_Node := N;
Decls :=
Analyze_Associations
(I_Node => Original_Node (N),
Formals => Generic_Formal_Declarations (Act_Tree),
F_Copy => Generic_Formal_Declarations (Gen_Decl));
Vis_Prims_List := Check_Hidden_Primitives (Decls);
end;
end if;
Append (Renaming, To => Decls);
-- Add generated declarations ahead of local declarations in
-- the package.
if No (Visible_Declarations (Specification (Pack_Decl))) then
Set_Visible_Declarations (Specification (Pack_Decl), Decls);
else
Insert_List_Before
(First (Visible_Declarations (Specification (Pack_Decl))),
Decls);
end if;
return Pack_Decl;
end Build_Local_Package;
-- Start of processing for Analyze_Formal_Package_Declaration
begin
Check_Text_IO_Special_Unit (Gen_Id);
Init_Env;
Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
Gen_Unit := Entity (Gen_Id);
-- Check for a formal package that is a package renaming
if Present (Renamed_Object (Gen_Unit)) then
-- Indicate that unit is used, before replacing it with renamed
-- entity for use below.
if In_Extended_Main_Source_Unit (N) then
Set_Is_Instantiated (Gen_Unit);
Generate_Reference (Gen_Unit, N);
end if;
Gen_Unit := Renamed_Object (Gen_Unit);
end if;
if Ekind (Gen_Unit) /= E_Generic_Package then
Error_Msg_N ("expect generic package name", Gen_Id);
Restore_Env;
goto Leave;
elsif Gen_Unit = Current_Scope then
Error_Msg_N
("generic package cannot be used as a formal package of itself",
Gen_Id);
Restore_Env;
goto Leave;
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;
goto Leave;
end if;
end if;
-- Check that name of formal package does not hide name of generic,
-- or its leading prefix. This check must be done separately because
-- the name of the generic has already been analyzed.
declare
Gen_Name : Entity_Id;
begin
Gen_Name := Gen_Id;
while Nkind (Gen_Name) = N_Expanded_Name loop
Gen_Name := Prefix (Gen_Name);
end loop;
if Chars (Gen_Name) = Chars (Pack_Id) then
Error_Msg_NE
("& is hidden within declaration of formal package",
Gen_Id, Gen_Name);
end if;
end;
if Box_Present (N)
or else No (Generic_Associations (N))
or else Nkind (First (Generic_Associations (N))) = N_Others_Choice
then
Associations := False;
end if;
-- 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.
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;
Formal := New_Copy (Pack_Id);
Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
begin
-- Make local generic without formals. The formals will be replaced
-- with internal declarations.
New_N := Build_Local_Package;
-- If there are errors in the parameter list, Analyze_Associations
-- raises Instantiation_Error. Patch the declaration to prevent
-- further exception propagation.
exception
when Instantiation_Error =>
Enter_Name (Formal);
Set_Ekind (Formal, E_Variable);
Set_Etype (Formal, Any_Type);
Restore_Hidden_Primitives (Vis_Prims_List);
if Parent_Installed then
Remove_Parent;
end if;
goto Leave;
end;
Rewrite (N, New_N);
Set_Defining_Unit_Name (Specification (New_N), Formal);
Set_Generic_Parent (Specification (N), Gen_Unit);
Set_Instance_Env (Gen_Unit, Formal);
Set_Is_Generic_Instance (Formal);
Enter_Name (Formal);
Set_Ekind (Formal, E_Package);
Set_Etype (Formal, Standard_Void_Type);
Set_Inner_Instances (Formal, New_Elmt_List);
Push_Scope (Formal);
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 (Specification (N));
-- The formals for which associations are provided are not visible
-- outside of the formal package. The others are still declared by a
-- formal parameter declaration.
-- If there are no associations, the only local entity to hide is the
-- generated package renaming itself.
declare
E : Entity_Id;
begin
E := First_Entity (Formal);
while Present (E) loop
if Associations and then not Is_Generic_Formal (E) then
Set_Is_Hidden (E);
end if;
if Ekind (E) = E_Package and then Renamed_Entity (E) = Formal then
Set_Is_Hidden (E);
exit;
end if;
Next_Entity (E);
end loop;
end;
End_Package_Scope (Formal);
Restore_Hidden_Primitives (Vis_Prims_List);
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.
Set_Has_Completion (Formal, True);
-- Add semantic information to the original defining identifier.
-- for ASIS use.
Set_Ekind (Pack_Id, E_Package);
Set_Etype (Pack_Id, Standard_Void_Type);
Set_Scope (Pack_Id, Scope (Formal));
Set_Has_Completion (Pack_Id, True);
<<Leave>>
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, Pack_Id);
end if;
end Analyze_Formal_Package_Declaration;
---------------------------------
-- 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_Incomplete_Type --
------------------------------------
procedure Analyze_Formal_Incomplete_Type
(T : Entity_Id;
Def : Node_Id)
is
begin
Enter_Name (T);
Set_Ekind (T, E_Incomplete_Type);
Set_Etype (T, T);
Set_Private_Dependents (T, New_Elmt_List);
if Tagged_Present (Def) then
Set_Is_Tagged_Type (T);
Make_Class_Wide_Type (T);
Set_Direct_Primitive_Operations (T, New_Elmt_List);
end if;
end Analyze_Formal_Incomplete_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 (Defining_Identifier (Parent (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_Constrained (T);
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_Declaration --
-------------------------------------------
procedure Analyze_Formal_Subprogram_Declaration (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);
goto Leave;
end if;
Analyze_Subprogram_Declaration (N);
Set_Is_Formal_Subprogram (Nam);
Set_Has_Completion (Nam);
if Nkind (N) = N_Formal_Abstract_Subprogram_Declaration then
Set_Is_Abstract_Subprogram (Nam);
Set_Is_Dispatching_Operation (Nam);
declare
Ctrl_Type : constant Entity_Id := Find_Dispatching_Type (Nam);
begin
if No (Ctrl_Type) then
Error_Msg_N
("abstract formal subprogram must have a controlling type",
N);
elsif Ada_Version >= Ada_2012
and then Is_Incomplete_Type (Ctrl_Type)
then
Error_Msg_NE
("controlling type of abstract formal subprogram cannot "
& "be incomplete type", N, Ctrl_Type);
else
Check_Controlling_Formals (Ctrl_Type, Nam);
end if;
end;
end if;
-- 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);
goto Leave;
end if;
-- Default name may be overloaded, in which case the interpretation
-- with the correct profile must be selected, as for a renaming.
-- If the definition is an indexed component, it must denote a
-- member of an entry family. If it is a selected component, it
-- can be a protected operation.
if Etype (Def) = Any_Type then
goto Leave;
elsif Nkind (Def) = N_Selected_Component then
if not Is_Overloadable (Entity (Selector_Name (Def))) then
Error_Msg_N ("expect valid subprogram name as default", Def);
end if;
elsif Nkind (Def) = N_Indexed_Component then
if Is_Entity_Name (Prefix (Def)) then
if Ekind (Entity (Prefix (Def))) /= E_Entry_Family then
Error_Msg_N ("expect valid subprogram name as default", Def);
end if;
elsif Nkind (Prefix (Def)) = N_Selected_Component then
if Ekind (Entity (Selector_Name (Prefix (Def)))) /=
E_Entry_Family
then
Error_Msg_N ("expect valid subprogram name as default", Def);
end if;
else
Error_Msg_N ("expect valid subprogram name as default", Def);
goto Leave;
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);
goto Leave;
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;
-- More than one interpretation, so disambiguate as for a renaming
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
-- Subprogram found, generate reference to it
Set_Entity (Def, Subp);
Generate_Reference (Subp, Def);
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;
<<Leave>>
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, Nam);
end if;
end Analyze_Formal_Subprogram_Declaration;
-------------------------------------
-- 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", T);
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_Incomplete_Type_Definition =>
Analyze_Formal_Incomplete_Type (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);
-- Ada 2005: a interface declaration is encoded as an abstract
-- record declaration or a abstract type derivation.
when N_Record_Definition =>
Analyze_Formal_Interface_Type (N, T, Def);
when N_Derived_Type_Definition =>
Analyze_Formal_Derived_Interface_Type (N, T, Def);
when N_Error =>
null;
when others =>
raise Program_Error;
end case;
Set_Is_Generic_Type (T);
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, T);
end if;
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 not Is_Entity_Name (Subtype_Indication (Def)) 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
-- The generic package declaration may be subject to pragma Ghost with
-- policy Ignore. Set the mode now to ensure that any nodes generated
-- during analysis and expansion are properly flagged as ignored Ghost.
Set_Ghost_Mode (N);
Check_SPARK_05_Restriction ("generic is not allowed", N);
-- 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);
-- Once the contents of the generic copy and the template are swapped,
-- do the same for their respective aspect specifications.
Exchange_Aspects (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);
-- A generic package declared within a Ghost region is rendered Ghost
-- (SPARK RM 6.9(2)).
if Ghost_Mode > None then
Set_Is_Ghost_Entity (Id);
end if;
-- Analyze aspects now, so that generated pragmas appear in the
-- declarations before building and analyzing the generic copy.
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, Id);
end if;
Push_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;
-- If there is a specified storage pool in the context, create an
-- aspect on the package declaration, so that it is used in any
-- instance that does not override it.
if Present (Default_Pool) then
declare
ASN : Node_Id;
begin
ASN :=
Make_Aspect_Specification (Loc,
Identifier => Make_Identifier (Loc, Name_Default_Storage_Pool),
Expression => New_Copy (Default_Pool));
if No (Aspect_Specifications (Specification (N))) then
Set_Aspect_Specifications (Specification (N), New_List (ASN));
else
Append (ASN, Aspect_Specifications (Specification (N)));
end if;
end;
end if;
end Analyze_Generic_Package_Declaration;
--------------------------------------------
-- Analyze_Generic_Subprogram_Declaration --
--------------------------------------------
procedure Analyze_Generic_Subprogram_Declaration (N : Node_Id) is
Formals : List_Id;
Id : Entity_Id;
New_N : Node_Id;
Result_Type : Entity_Id;
Save_Parent : Node_Id;
Spec : Node_Id;
Typ : Entity_Id;
begin
-- The generic subprogram declaration may be subject to pragma Ghost
-- with policy Ignore. Set the mode now to ensure that any nodes
-- generated during analysis and expansion are properly flagged as
-- ignored Ghost.
Set_Ghost_Mode (N);
Check_SPARK_05_Restriction ("generic is not allowed", N);
-- 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);
-- Once the contents of the generic copy and the template are swapped,
-- do the same for their respective aspect specifications.
Exchange_Aspects (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);
-- Analyze the aspects of the generic copy to ensure that all generated
-- pragmas (if any) perform their semantic effects.
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, Id);
end if;
Push_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);
if Nkind (Result_Definition (Spec)) = N_Access_Definition then
Result_Type := Access_Definition (Spec, Result_Definition (Spec));
Set_Etype (Id, Result_Type);
-- Check restriction imposed by AI05-073: a generic function
-- cannot return an abstract type or an access to such.
-- This is a binding interpretation should it apply to earlier
-- versions of Ada as well as Ada 2012???
if Is_Abstract_Type (Designated_Type (Result_Type))
and then Ada_Version >= Ada_2012
then
Error_Msg_N
("generic function cannot have an access result "
& "that designates an abstract type", Spec);
end if;
else
Find_Type (Result_Definition (Spec));
Typ := Entity (Result_Definition (Spec));
if Is_Abstract_Type (Typ)
and then Ada_Version >= Ada_2012
then
Error_Msg_N
("generic function cannot have abstract result type", Spec);
end if;
-- If a null exclusion is imposed on the result type, then create
-- a null-excluding itype (an access subtype) and use it as the
-- function's Etype.
if Is_Access_Type (Typ)
and then Null_Exclusion_Present (Spec)
then
Set_Etype (Id,
Create_Null_Excluding_Itype
(T => Typ,
Related_Nod => Spec,
Scope_Id => Defining_Unit_Name (Spec)));
else
Set_Etype (Id, Typ);
end if;
end if;
else
Set_Ekind (Id, E_Generic_Procedure);
Set_Etype (Id, Standard_Void_Type);
end if;
-- A generic subprogram declared within a Ghost region is rendered Ghost
-- (SPARK RM 6.9(2)).
if Ghost_Mode > None then
Set_Is_Ghost_Entity (Id);
end if;
-- For a library unit, we have reconstructed the entity for the unit,
-- and must reset it in the library tables. We also 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);
-- Capture all global references that occur within the profile of the
-- generic subprogram. Aspects are not part of this processing because
-- they must be delayed. If processed now, Save_Global_References will
-- destroy the Associated_Node links and prevent the capture of global
-- references when the contract of the generic subprogram is analyzed.
Save_Global_References (Original_Node (N));
End_Generic;
End_Scope;
Exit_Generic_Scope (Id);
Generate_Reference_To_Formals (Id);
List_Inherited_Pre_Post_Aspects (Id);
end Analyze_Generic_Subprogram_Declaration;
-----------------------------------
-- Analyze_Package_Instantiation --
-----------------------------------
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_Spec : Node_Id;
Gen_Unit : Entity_Id;
Is_Actual_Pack : constant Boolean :=
Is_Internal (Defining_Entity (N));
Env_Installed : Boolean := False;
Parent_Installed : Boolean := False;
Renaming_List : List_Id;
Unit_Renaming : Node_Id;
Needs_Body : Boolean;
Inline_Now : Boolean := False;
Has_Inline_Always : Boolean := False;
Save_IPSM : constant Boolean := Ignore_Pragma_SPARK_Mode;
-- Save flag Ignore_Pragma_SPARK_Mode for restore on exit
Save_SM : constant SPARK_Mode_Type := SPARK_Mode;
Save_SMP : constant Node_Id := SPARK_Mode_Pragma;
-- Save the SPARK_Mode-related data for restore on exit
Save_Style_Check : constant Boolean := Style_Check;
-- Save style check mode for restore on exit
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.Append (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
-- Remember if there are any subprograms with Inline_Always
if Has_Pragma_Inline_Always (E) then
Has_Inline_Always := True;
end if;
return True;
end if;
Next_Entity (E);
end loop;
end if;
return False;
end Might_Inline_Subp;
-- Local declarations
Vis_Prims_List : Elist_Id := No_Elist;
-- List of primitives made temporarily visible in the instantiation
-- to match the visibility of the formal type
-- Start of processing for Analyze_Package_Instantiation
begin
Check_SPARK_05_Restriction ("generic is not allowed", N);
-- Very first thing: check for Text_IO sp[ecial unit in case we are
-- instantiating one of the children of [[Wide_]Wide_]Text_IO.
Check_Text_IO_Special_Unit (Name (N));
-- Make node global for error reporting
Instantiation_Node := N;
-- Turn off style checking in instances. If the check is enabled on the
-- generic unit, a warning in an instance would just be noise. If not
-- enabled on the generic, then a warning in an instance is just wrong.
Style_Check := False;
-- 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);
Preanalyze_Actuals (N);
Init_Env;
Env_Installed := True;
-- Reset renaming map for formal types. The mapping is established
-- when analyzing the generic associations, but some mappings are
-- inherited from formal packages of parent units, and these are
-- constructed when the parents are installed.
Generic_Renamings.Set_Last (0);
Generic_Renamings_HTable.Reset;
Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
Gen_Unit := Entity (Gen_Id);
-- Verify that it is the name of a generic package
-- A visibility glitch: if the instance is a child unit and the generic
-- is the generic unit of a parent instance (i.e. both the parent and
-- the child units are instances of the same package) the name now
-- denotes the renaming within the parent, not the intended generic
-- unit. See if there is a homonym that is the desired generic. The
-- renaming declaration must be visible inside the instance of the
-- child, but not when analyzing the name in the instantiation itself.
if Ekind (Gen_Unit) = E_Package
and then Present (Renamed_Entity (Gen_Unit))
and then In_Open_Scopes (Renamed_Entity (Gen_Unit))
and then Is_Generic_Instance (Renamed_Entity (Gen_Unit))
and then Present (Homonym (Gen_Unit))
then
Gen_Unit := Homonym (Gen_Unit);
end if;
if Etype (Gen_Unit) = Any_Type then
Restore_Env;
goto Leave;
elsif Ekind (Gen_Unit) /= E_Generic_Package then
-- Ada 2005 (AI-50217): Cannot use instance in limited with_clause
if From_Limited_With (Gen_Unit) then
Error_Msg_N
("cannot instantiate a limited withed package", Gen_Id);
else
Error_Msg_NE
("& is not the name of a generic package", Gen_Id, Gen_Unit);
end if;
Restore_Env;
goto Leave;
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;
goto Leave;
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;
goto Leave;
else
-- If the context of the instance is subject to SPARK_Mode "off",
-- set the global flag which signals Analyze_Pragma to ignore all
-- SPARK_Mode pragmas within the instance.
if SPARK_Mode = Off then
Ignore_Pragma_SPARK_Mode := True;
end if;
Gen_Decl := Unit_Declaration_Node (Gen_Unit);
Gen_Spec := Specification (Gen_Decl);
-- 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.
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
(I_Node => N,
Formals => Generic_Formal_Declarations (Act_Tree),
F_Copy => Generic_Formal_Declarations (Gen_Decl));
Vis_Prims_List := Check_Hidden_Primitives (Renaming_List);
Set_Instance_Env (Gen_Unit, Act_Decl_Id);
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_Occurrence_Of (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);
-- Propagate the aspect specifications from the package declaration
-- template to the instantiated version of the package declaration.
if Has_Aspects (Act_Tree) then
Set_Aspect_Specifications (Act_Decl,
New_Copy_List_Tree (Aspect_Specifications (Act_Tree)));
end if;
-- The generic may have a generated Default_Storage_Pool aspect,
-- set at the point of generic declaration. If the instance has
-- that aspect, it overrides the one inherited from the generic.
if Has_Aspects (Gen_Spec) then
if No (Aspect_Specifications (N)) then
Set_Aspect_Specifications (N,
(New_Copy_List_Tree
(Aspect_Specifications (Gen_Spec))));
else
declare
ASN1, ASN2 : Node_Id;
begin
ASN1 := First (Aspect_Specifications (N));
while Present (ASN1) loop
if Chars (Identifier (ASN1)) = Name_Default_Storage_Pool
then
-- If generic carries a default storage pool, remove
-- it in favor of the instance one.
ASN2 := First (Aspect_Specifications (Gen_Spec));
while Present (ASN2) loop
if Chars (Identifier (ASN2)) =
Name_Default_Storage_Pool
then
Remove (ASN2);
exit;
end if;
Next (ASN2);
end loop;
end if;
Next (ASN1);
end loop;
Prepend_List_To (Aspect_Specifications (N),
(New_Copy_List_Tree
(Aspect_Specifications (Gen_Spec))));
end;
end if;
end if;
-- Save the instantiation node, for subsequent instantiation of the
-- body, if there is one and we are generating code for the current
-- unit. Mark unit as having a body (avoids 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 or GNATprove 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;
elsif In_Open_Scopes (Scop)
and then In_Package_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 or there are any subprograms
-- marked with Inline_Always, 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 Expander_Active
and then (not Is_Child_Unit (Gen_Unit)
or else not Is_Generic_Unit (Scope (Gen_Unit)))
and then Might_Inline_Subp
and then not Is_Actual_Pack
then
if not Back_End_Inlining
and then (Front_End_Inlining or else Has_Inline_Always)
and then (Is_In_Main_Unit (N)
or else In_Main_Context (Current_Scope))
and then Nkind (Parent (N)) /= N_Compilation_Unit
then
Inline_Now := True;
-- In configurable_run_time mode we force the inlining of
-- predefined subprograms marked Inline_Always, to minimize
-- the use of the run-time library.
elsif Is_Predefined_File_Name
(Unit_File_Name (Get_Source_Unit (Gen_Decl)))
and then Configurable_Run_Time_Mode
and then Nkind (Parent (N)) /= N_Compilation_Unit
then
Inline_Now := True;
end if;
-- If the current scope is itself an instance within a child
-- unit, there will be duplications in the scope stack, and the
-- unstacking mechanism in Inline_Instance_Body will fail.
-- This loses some rare cases of optimization, and might be
-- improved some day, if we can find a proper abstraction for
-- "the complete compilation context" that can be saved and
-- restored. ???
if Is_Generic_Instance (Current_Scope) then
declare
Curr_Unit : constant Entity_Id :=
Cunit_Entity (Current_Sem_Unit);
begin
if Curr_Unit /= Current_Scope
and then Is_Child_Unit (Curr_Unit)
then
Inline_Now := False;
end if;
end;
end if;
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
-- Need comment for this check ???
or else (Operating_Mode = Check_Semantics
and then (ASIS_Mode or GNATprove_Mode)));
-- If front-end inlining is enabled or there are any subprograms
-- marked with Inline_Always, do not instantiate body when within
-- a generic context.
if ((Front_End_Inlining or else Has_Inline_Always)
and then not Expander_Active)
or else Is_Generic_Unit (Cunit_Entity (Main_Unit))
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 precedes 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;
-- For RCI unit calling stubs, we omit the instance body if the
-- instance is the RCI library unit itself.
-- However there is a special case for nested instances: in this case
-- we do generate the instance body, as it might be required, e.g.
-- because it provides stream attributes for some type used in the
-- profile of a remote subprogram. This is consistent with 12.3(12),
-- which indicates that the instance body occurs at the place of the
-- instantiation, and thus is part of the RCI declaration, which is
-- present on all client partitions (this is E.2.3(18)).
-- Note that AI12-0002 may make it illegal at some point to have
-- stream attributes defined in an RCI unit, in which case this
-- special case will become unnecessary. In the meantime, there
-- is known application code in production that depends on this
-- being possible, so we definitely cannot eliminate the body in
-- the case of nested instances for the time being.
-- When we generate a nested instance body, calling stubs for any
-- relevant subprogram will be be inserted immediately after the
-- subprogram declarations, and will take precedence over the
-- subsequent (original) body. (The stub and original body will be
-- complete homographs, but this is permitted in an instance).
-- (Could we do better and remove the original body???)
if Distribution_Stub_Mode = Generate_Caller_Stub_Body
and then Comes_From_Source (N)
and then Nkind (Parent (N)) = N_Compilation_Unit
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 > Maximum_Instantiations then
Error_Msg_Uint_1 := UI_From_Int (Maximum_Instantiations);
Error_Msg_N ("too many instantiations, exceeds max of^", N);
Error_Msg_N ("\limit can be changed using -gnateinn switch", 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;
begin
-- Loop to search enclosing masters
Enclosing_Master := Current_Scope;
Scope_Loop : 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 Scope_Loop;
else
Enclosing_Master := Scope (Enclosing_Master);
end if;
elsif Is_Generic_Unit (Enclosing_Master)
or else Ekind (Enclosing_Master) = E_Void
then
-- Cleanup actions will eventually be performed on the
-- enclosing subprogram or package instance, if any.
-- Enclosing scope is void in the formal part of a
-- generic subprogram.
exit Scope_Loop;
else
if Ekind (Enclosing_Master) = E_Entry
and then
Ekind (Scope (Enclosing_Master)) = E_Protected_Type
then
if not Expander_Active then
exit Scope_Loop;
else
Enclosing_Master :=
Protected_Body_Subprogram (Enclosing_Master);
end if;
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 Scope_Loop;
end if;
end loop Scope_Loop;
end;
-- Make entry in table
Pending_Instantiations.Append
((Inst_Node => N,
Act_Decl => Act_Decl,
Expander_Status => Expander_Active,
Current_Sem_Unit => Current_Sem_Unit,
Scope_Suppress => Scope_Suppress,
Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
Version => Ada_Version,
Version_Pragma => Ada_Version_Pragma,
Warnings => Save_Warnings,
SPARK_Mode => SPARK_Mode,
SPARK_Mode_Pragma => SPARK_Mode_Pragma));
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);
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, Act_Decl_Id);
-- The pragma created for a Default_Storage_Pool aspect must
-- appear ahead of the declarations in the instance spec.
-- Analysis has placed it after the instance node, so remove
-- it and reinsert it properly now.
declare
ASN : constant Node_Id := First (Aspect_Specifications (N));
A_Name : constant Name_Id := Chars (Identifier (ASN));
Decl : Node_Id;
begin
if A_Name = Name_Default_Storage_Pool then
if No (Visible_Declarations (Act_Spec)) then
Set_Visible_Declarations (Act_Spec, New_List);
end if;
Decl := Next (N);
while Present (Decl) loop
if Nkind (Decl) = N_Pragma then
Remove (Decl);
Prepend (Decl, Visible_Declarations (Act_Spec));
exit;
end if;
Next (Decl);
end loop;
end if;
end;
end if;
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). If this is the main unit,
-- the declaration eventually replaces the instantiation node.
-- If the instance body is created later, it replaces the
-- instance node, and the declaration 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));
Set_Package_Instantiation (Act_Decl_Id, N);
-- Process aspect specifications of the instance node, if any, to
-- take into account categorization pragmas before analyzing the
-- instance.
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, Act_Decl_Id);
end if;
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_Hidden_Primitives (Vis_Prims_List);
Restore_Private_Views (Act_Decl_Id);
Inherit_Context (Gen_Decl, N);
if Parent_Installed then
Remove_Parent;
end if;
Restore_Env;
Env_Installed := False;
end if;
Validate_Categorization_Dependency (N, Act_Decl_Id);
-- There used to be a check here to prevent instantiations in local
-- contexts if the No_Local_Allocators restriction was active. This
-- check was removed by a binding interpretation in AI-95-00130/07,
-- but we retain the code for documentation purposes.
-- 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;
-- The following is a tree patch for ASIS: ASIS needs separate nodes to
-- be used as defining identifiers for a formal package and for the
-- corresponding expanded package.
if Nkind (N) = N_Formal_Package_Declaration then
Act_Decl_Id := New_Copy (Defining_Entity (N));
Set_Comes_From_Source (Act_Decl_Id, True);
Set_Is_Generic_Instance (Act_Decl_Id, False);
Set_Defining_Identifier (N, Act_Decl_Id);
end if;
Ignore_Pragma_SPARK_Mode := Save_IPSM;
SPARK_Mode := Save_SM;
SPARK_Mode_Pragma := Save_SMP;
Style_Check := Save_Style_Check;
if SPARK_Mode = On then
Dynamic_Elaboration_Checks := False;
end if;
-- Check that if N is an instantiation of System.Dim_Float_IO or
-- System.Dim_Integer_IO, the formal type has a dimension system.
if Nkind (N) = N_Package_Instantiation
and then Is_Dim_IO_Package_Instantiation (N)
then
declare
Assoc : constant Node_Id := First (Generic_Associations (N));
begin
if not Has_Dimension_System
(Etype (Explicit_Generic_Actual_Parameter (Assoc)))
then
Error_Msg_N ("type with a dimension system expected", Assoc);
end if;
end;
end if;
<<Leave>>
if Has_Aspects (N) and then Nkind (Parent (N)) /= N_Compilation_Unit then
Analyze_Aspect_Specifications (N, Act_Decl_Id);
end if;
exception
when Instantiation_Error =>
if Parent_Installed then
Remove_Parent;
end if;
if Env_Installed then
Restore_Env;
end if;
Ignore_Pragma_SPARK_Mode := Save_IPSM;
SPARK_Mode := Save_SM;
SPARK_Mode_Pragma := Save_SMP;
Style_Check := Save_Style_Check;
if SPARK_Mode = On then
Dynamic_Elaboration_Checks := False;
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
Curr_Comp : constant Node_Id := Cunit (Current_Sem_Unit);
Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
Gen_Comp : constant Entity_Id :=
Cunit_Entity (Get_Source_Unit (Gen_Unit));
Save_SM : constant SPARK_Mode_Type := SPARK_Mode;
Save_SMP : constant Node_Id := SPARK_Mode_Pragma;
-- Save all SPARK_Mode-related attributes as removing enclosing scopes
-- to provide a clean environment for analysis of the inlined body will
-- eliminate any previously set SPARK_Mode.
Scope_Stack_Depth : constant Int :=
Scope_Stack.Last - Scope_Stack.First + 1;
Use_Clauses : array (1 .. Scope_Stack_Depth) of Node_Id;
Instances : array (1 .. Scope_Stack_Depth) of Entity_Id;
Inner_Scopes : array (1 .. Scope_Stack_Depth) of Entity_Id;
Curr_Scope : Entity_Id := Empty;
List : Elist_Id;