Google Git
Sign in
gnu / gcc / refs/tags/basepoints/gcc-13 / . / gcc / ada / sem_ch12.adb
blob: 5eeaf3d252f08c44fccbabed11d344baec1e20e8 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S E M _ C H 1 2 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2022, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- 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 Contracts; use Contracts;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
with Expander; use Expander;
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_Prag; use Sem_Prag;
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.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
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;
-- It should really be reset upon encountering a new main unit, but in
-- practice we do not use multiple main units so this is not critical.
-----------------------------------------
-- Implementation of Generic Contracts --
-----------------------------------------
-- A "contract" is a collection of aspects and pragmas that either verify a
-- property of a construct at runtime or classify the data flow to and from
-- the construct in some fashion.
-- Generic packages, subprograms and their respective bodies may be subject
-- to the following contract-related aspects or pragmas collectively known
-- as annotations:
-- package subprogram [body]
-- Abstract_State Contract_Cases
-- Initial_Condition Depends
-- Initializes Extensions_Visible
-- Global
-- package body Post
-- Refined_State Post_Class
-- Postcondition
-- Pre
-- Pre_Class
-- Precondition
-- Refined_Depends
-- Refined_Global
-- Refined_Post
-- Subprogram_Variant
-- Test_Case
-- Most package contract annotations utilize forward references to classify
-- data declared within the package [body]. Subprogram annotations then use
-- the classifications to further refine them. These inter dependencies are
-- problematic with respect to the implementation of generics because their
-- analysis, capture of global references and instantiation does not mesh
-- well with the existing mechanism.
-- 1) Analysis of generic contracts is carried out the same way non-generic
-- contracts are analyzed:
-- 1.1) General rule - a contract is analyzed after all related aspects
-- and pragmas are analyzed. This is done by routines
-- Analyze_Package_Body_Contract
-- Analyze_Package_Contract
-- Analyze_Subprogram_Body_Contract
-- Analyze_Subprogram_Contract
-- 1.2) Compilation unit - the contract is analyzed after Pragmas_After
-- are processed.
-- 1.3) Compilation unit body - the contract is analyzed at the end of
-- the body declaration list.
-- 1.4) Package - the contract is analyzed at the end of the private or
-- visible declarations, prior to analyzing the contracts of any nested
-- packages or subprograms.
-- 1.5) Package body - the contract is analyzed at the end of the body
-- declaration list, prior to analyzing the contracts of any nested
-- packages or subprograms.
-- 1.6) Subprogram - if the subprogram is declared inside a block, a
-- package or a subprogram, then its contract is analyzed at the end of
-- the enclosing declarations, otherwise the subprogram is a compilation
-- unit 1.2).
-- 1.7) Subprogram body - if the subprogram body is declared inside a
-- block, a package body or a subprogram body, then its contract is
-- analyzed at the end of the enclosing declarations, otherwise the
-- subprogram is a compilation unit 1.3).
-- 2) Capture of global references within contracts is done after capturing
-- global references within the generic template. There are two reasons for
-- this delay - pragma annotations are not part of the generic template in
-- the case of a generic subprogram declaration, and analysis of contracts
-- is delayed.
-- Contract-related source pragmas within generic templates are prepared
-- for delayed capture of global references by routine
-- Create_Generic_Contract
-- The routine associates these pragmas with the contract of the template.
-- In the case of a generic subprogram declaration, the routine creates
-- generic templates for the pragmas declared after the subprogram because
-- they are not part of the template.
-- generic -- template starts
-- procedure Gen_Proc (Input : Integer); -- template ends
-- pragma Precondition (Input > 0); -- requires own template
-- 2.1) The capture of global references with aspect specifications and
-- source pragmas that apply to a generic unit must be suppressed when
-- the generic template is being processed because the contracts have not
-- been analyzed yet. Any attempts to capture global references at that
-- point will destroy the Associated_Node linkages and leave the template
-- undecorated. This delay is controlled by routine
-- Requires_Delayed_Save
-- 2.2) The real capture of global references within a contract is done
-- after the contract has been analyzed, by routine
-- Save_Global_References_In_Contract
-- 3) The instantiation of a generic contract occurs as part of the
-- instantiation of the contract owner. Generic subprogram declarations
-- require additional processing when the contract is specified by pragmas
-- because the pragmas are not part of the generic template. This is done
-- by routine
-- Instantiate_Subprogram_Contract
--------------------------------------------------
-- 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 formals into this local package. The result is 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 formals. 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.
function Build_Subprogram_Decl_Wrapper
(Formal_Subp : Entity_Id) return Node_Id;
-- Ada 2022 allows formal subprograms to carry pre/postconditions.
-- At the point of instantiation these contracts apply to uses of
-- the actual subprogram. This is implemented by creating wrapper
-- subprograms instead of the renamings previously used to link
-- formal subprograms and the corresponding actuals. If the actual
-- is not an entity (e.g. an attribute reference) a renaming is
-- created to handle the expansion of the attribute.
function Build_Subprogram_Body_Wrapper
(Formal_Subp : Entity_Id;
Actual_Name : Node_Id) return Node_Id;
-- The body of the wrapper is a call to the actual, with the generated
-- pre/postconditon checks added.
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.
-- Restore the visibility of the formals of the instance that are not
-- defaulted (see RM 12.7 (10)). Remove the anonymous package declaration
-- created for formal instances that are not defaulted.
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 ???
procedure Freeze_Package_Instance
(N : Node_Id;
Gen_Body : Node_Id;
Gen_Decl : Node_Id;
Act_Id : Entity_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. This rather complex machinery is
-- needed when nested instantiations are present, because the source does
-- not carry any indication of where the corresponding instance bodies must
-- be installed and frozen.
procedure Freeze_Subprogram_Instance
(N : 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.
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.
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.
function Has_Contracts (Decl : Node_Id) return Boolean;
-- Determine whether a formal subprogram has a Pre- or Postcondition,
-- in which case a subprogram wrapper has to be built for the actual.
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.
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 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.
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 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.
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, unless the instantiation is done in a package spec that is
-- not at library level, in which case it is inserted at the outer level.
-- This can also be invoked to insert the freeze node of a package that
-- encloses an instantiation, in which case N may denote an arbitrary node.
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_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 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.
-- 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 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; Inst : Entity_Id := Empty);
-- 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.
--
-- If Inst is present, it is the entity of the package instance. This
-- entity is marked as having a limited_view actual when some actual is
-- a limited view. This is used to place the instance body properly.
procedure Provide_Completing_Bodies (N : Node_Id);
-- Generate completing bodies for all subprograms found within package or
-- subprogram declaration N.
procedure Remove_Parent (In_Body : Boolean := False);
-- Reverse effect after instantiation of child is complete
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 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 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.
procedure Validate_Formal_Type_Default (Decl : Node_Id);
-- Ada_2022 AI12-205: if a default subtype_mark is present, verify
-- that it is the name of a type in the same class as the formal.
-- The treatment parallels what is done in Instantiate_Type but differs
-- in a few ways so that this machinery cannot be reused as is: on one
-- hand there are no visibility issues for a default, because it is
-- analyzed in the same context as the formal type definition; on the
-- other hand the check needs to take into acount the use of a previous
-- formal type in the current formal type definition (see details in
-- AI12-0205).
-------------------------------------------
-- 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;
----------------------------------
-- Adjust_Inherited_Pragma_Sloc --
----------------------------------
procedure Adjust_Inherited_Pragma_Sloc (N : Node_Id) is
begin
Adjust_Instantiation_Sloc (N, S_Adjustment);
end Adjust_Inherited_Pragma_Sloc;
--------------------------
-- 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_List : 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 : Nat := 0;
Num_Actuals : Nat := 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 Build_Subprogram_Wrappers;
-- Ada 2022: AI12-0272 introduces pre/postconditions for formal
-- subprograms. The implementation of making the formal into a renaming
-- of the actual does not work, given that subprogram renaming cannot
-- carry aspect specifications. Instead we must create subprogram
-- wrappers whose body is a call to the actual, and whose declaration
-- carries the aspects of the formal.
procedure Check_Fixed_Point_Actual (Actual : Node_Id);
-- Warn if an actual fixed-point type has user-defined arithmetic
-- operations, but there is no corresponding formal in the generic,
-- in which case the predefined operations will be used. This merits
-- a warning because of the special semantics of fixed point ops.
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.
--
-- 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.
-----------------------------------------
-- procedure Build_Subprogram_Wrappers --
-----------------------------------------
procedure Build_Subprogram_Wrappers is
Formal : constant Entity_Id :=
Defining_Unit_Name (Specification (Analyzed_Formal));
Aspect_Spec : Node_Id;
Decl_Node : Node_Id;
Actual_Name : Node_Id;
begin
-- Create declaration for wrapper subprogram
-- The actual can be overloaded, in which case it will be
-- resolved when the call in the wrapper body is analyzed.
-- We attach the possible interpretations of the actual to
-- the name to be used in the call in the wrapper body.
if Is_Entity_Name (Match) then
Actual_Name := New_Occurrence_Of (Entity (Match), Sloc (Match));
if Is_Overloaded (Match) then
Save_Interps (Match, Actual_Name);
end if;
else
-- Use renaming declaration created when analyzing actual.
-- This may be incomplete if there are several formal
-- subprograms whose actual is an attribute ???
declare
Renaming_Decl : constant Node_Id := Last (Assoc_List);
begin
Actual_Name := New_Occurrence_Of
(Defining_Entity (Renaming_Decl), Sloc (Match));
Set_Etype (Actual_Name, Get_Instance_Of (Etype (Formal)));
end;
end if;
Decl_Node := Build_Subprogram_Decl_Wrapper (Formal);
-- Transfer aspect specifications from formal subprogram to wrapper
Set_Aspect_Specifications (Decl_Node,
New_Copy_List_Tree (Aspect_Specifications (Analyzed_Formal)));
Aspect_Spec := First (Aspect_Specifications (Decl_Node));
while Present (Aspect_Spec) loop
Set_Analyzed (Aspect_Spec, False);
Next (Aspect_Spec);
end loop;
Append_To (Assoc_List, Decl_Node);
-- Create corresponding body, and append it to association list
-- that appears at the head of the declarations in the instance.
-- The subprogram may be called in the analysis of subsequent
-- actuals.
Append_To (Assoc_List,
Build_Subprogram_Body_Wrapper (Formal, Actual_Name));
end Build_Subprogram_Wrappers;
----------------------------------------
-- 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;
-------------------------------
-- Check_Fixed_Point_Actual --
-------------------------------
procedure Check_Fixed_Point_Actual (Actual : Node_Id) is
Typ : constant Entity_Id := Entity (Actual);
Prims : constant Elist_Id := Collect_Primitive_Operations (Typ);
Elem : Elmt_Id;
Formal : Node_Id;
Op : Entity_Id;
begin
-- Locate primitive operations of the type that are arithmetic
-- operations.
Elem := First_Elmt (Prims);
while Present (Elem) loop
if Nkind (Node (Elem)) = N_Defining_Operator_Symbol then
-- Check whether the generic unit has a formal subprogram of
-- the same name. This does not check types but is good enough
-- to justify a warning.
Formal := First_Non_Pragma (Formals);
Op := Alias (Node (Elem));
while Present (Formal) loop
if Nkind (Formal) = N_Formal_Concrete_Subprogram_Declaration
and then Chars (Defining_Entity (Formal)) =
Chars (Node (Elem))
then
exit;
elsif Nkind (Formal) = N_Formal_Package_Declaration then
declare
Assoc : Node_Id;
Ent : Entity_Id;
begin
-- Locate corresponding actual, and check whether it
-- includes a fixed-point type.
Assoc := First (Assoc_List);
while Present (Assoc) loop
exit when
Nkind (Assoc) = N_Package_Renaming_Declaration
and then Chars (Defining_Unit_Name (Assoc)) =
Chars (Defining_Identifier (Formal));
Next (Assoc);
end loop;
if Present (Assoc) then
-- If formal package declares a fixed-point type,
-- and the user-defined operator is derived from
-- a generic instance package, the fixed-point type
-- does not use the corresponding predefined op.
Ent := First_Entity (Entity (Name (Assoc)));
while Present (Ent) loop
if Is_Fixed_Point_Type (Ent)
and then Present (Op)
and then Is_Generic_Instance (Scope (Op))
then
return;
end if;
Next_Entity (Ent);
end loop;
end if;
end;
end if;
Next (Formal);
end loop;
if No (Formal) then
Error_Msg_Sloc := Sloc (Node (Elem));
Error_Msg_NE
("?instance uses predefined operation, not primitive "
& "operation&#", Actual, Node (Elem));
end if;
end if;
Next_Elmt (Elem);
end loop;
end Check_Fixed_Point_Actual;
-------------------------------
-- 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 Nkind (Actual) = N_Others_Choice then
Found_Assoc := Empty;
Act := Empty;
elsif 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_List);
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 Kind in 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 Kind not in 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 it has a box association it must
-- correspond to some formal in the generic.
if Nkind (Named) /= N_Others_Choice
and then (Present (Explicit_Generic_Actual_Parameter (Named))
or else Box_Present (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_List);
-- 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);
elsif Present (Default_Subtype_Mark (Formal)) then
Match := New_Copy (Default_Subtype_Mark (Formal));
Append_List
(Instantiate_Type
(Formal, Match, Analyzed_Formal, Assoc_List),
Assoc_List);
Append_Elmt (Entity (Match), Actuals_To_Freeze);
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_List),
Assoc_List);
-- Warn when an actual is a fixed-point with user-
-- defined promitives. The warning is superfluous
-- if the formal is private, because there can be
-- no arithmetic operations in the generic so there
-- no danger of confusion.
if Is_Fixed_Point_Type (Entity (Match))
and then not Is_Private_Type
(Defining_Identifier (Analyzed_Formal))
then
Check_Fixed_Point_Actual (Match);
end if;
-- 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_List,
Instantiate_Formal_Subprogram
(Formal, Match, Analyzed_Formal));
-- If formal subprogram has contracts, create wrappers
-- for it. This is an expansion activity that cannot
-- take place e.g. within an enclosing generic unit.
if Has_Contracts (Analyzed_Formal)
and then Expander_Active
then
Build_Subprogram_Wrappers;
end if;
-- 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_List)));
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 =>
-- The name of the formal package may be hidden by the
-- formal parameter itself.
if Error_Posted (Analyzed_Formal) then
Abandon_Instantiation (Instantiation_Node);
else
Match :=
Matching_Actual
(Defining_Identifier (Formal),
Defining_Identifier
(Original_Node (Analyzed_Formal)));
end if;
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_List);
-- Determine whether the actual package needs an explicit
-- freeze node. This is only the case if the actual is
-- declared in the same unit and has a body. Normally
-- packages do not have explicit freeze nodes, and gigi
-- only uses them to elaborate entities in a package
-- body.
Explicit_Freeze_Check : declare
Actual : constant Entity_Id := Entity (Match);
Gen_Par : Entity_Id;
Needs_Freezing : Boolean;
P : Node_Id;
procedure Check_Generic_Parent;
-- The actual may be an instantiation of a unit
-- declared in a previous instantiation. If that
-- one is also in the current compilation, it must
-- itself be frozen before the actual. The actual
-- may be an instantiation of a generic child unit,
-- in which case the same applies to the instance
-- of the parent which must be frozen before the
-- actual.
-- Should this itself be recursive ???
--------------------------
-- Check_Generic_Parent --
--------------------------
procedure Check_Generic_Parent is
Inst : constant Node_Id :=
Next (Unit_Declaration_Node (Actual));
Par : Entity_Id;
begin
Par := Empty;
if Nkind (Parent (Actual)) = N_Package_Specification
then
Par := Scope (Generic_Parent (Parent (Actual)));
if Is_Generic_Instance (Par) then
null;
-- If the actual is a child generic unit, check
-- whether the instantiation of the parent is
-- also local and must also be frozen now. We
-- must retrieve the instance node to locate the
-- parent instance if any.
elsif Ekind (Par) = E_Generic_Package
and then Is_Child_Unit (Gen_Par)
and then Ekind (Scope (Gen_Par)) =
E_Generic_Package
then
if Nkind (Inst) = N_Package_Instantiation
and then Nkind (Name (Inst)) =
N_Expanded_Name
then
-- Retrieve entity of parent instance
Par := Entity (Prefix (Name (Inst)));
end if;
else
Par := Empty;
end if;
end if;
if Present (Par)
and then Is_Generic_Instance (Par)
and then Scope (Par) = Current_Scope
and then
(No (Freeze_Node (Par))
or else
not Is_List_Member (Freeze_Node (Par)))
then
Set_Has_Delayed_Freeze (Par);
Append_Elmt (Par, Actuals_To_Freeze);
end if;
end Check_Generic_Parent;
-- Start of processing for Explicit_Freeze_Check
begin
if Present (Renamed_Entity (Actual)) then
Gen_Par :=
Generic_Parent (Specification
(Unit_Declaration_Node
(Renamed_Entity (Actual))));
else
Gen_Par :=
Generic_Parent (Specification
(Unit_Declaration_Node (Actual)));
end if;
if not Expander_Active
or else not Has_Completion (Actual)
or else not In_Same_Source_Unit (I_Node, Actual)
or else Is_Frozen (Actual)
or else
(Present (Renamed_Entity (Actual))
and then
not In_Same_Source_Unit
(I_Node, (Renamed_Entity (Actual))))
then
null;
else
-- Finally we want to exclude such freeze nodes
-- from statement sequences, which freeze
-- everything before them.
-- Is this strictly necessary ???
Needs_Freezing := True;
P := Parent (I_Node);
while Nkind (P) /= N_Compilation_Unit loop
if Nkind (P) = N_Handled_Sequence_Of_Statements
then
Needs_Freezing := False;
exit;
end if;
P := Parent (P);
end loop;
if Needs_Freezing then
Check_Generic_Parent;
-- If the actual is a renaming of a proper
-- instance of the formal package, indicate
-- that it is the instance that must be frozen.
if Nkind (Parent (Actual)) =
N_Package_Renaming_Declaration
then
Set_Has_Delayed_Freeze
(Renamed_Entity (Actual));
Append_Elmt
(Renamed_Entity (Actual),
Actuals_To_Freeze);
else
Set_Has_Delayed_Freeze (Actual);
Append_Elmt (Actual, Actuals_To_Freeze);
end if;
end if;
end if;
end Explicit_Freeze_Check;
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_List);
else
Remove (Formal);
Append (Formal, Assoc_List);
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.
Append_List (Default_Formals, Formals);
return Assoc_List;
end Analyze_Associations;
-------------------------------
-- Analyze_Formal_Array_Type --
-------------------------------
procedure Analyze_Formal_Array_Type
(T : in out Entity_Id;
Def : Node_Id)
is
DSS : Node_Id;
begin
-- Treated like a non-generic array declaration, with additional
-- semantic checks.
Enter_Name (T);
if Nkind (Def) = N_Constrained_Array_Definition then
DSS := First (Discrete_Subtype_Definitions (Def));
while Present (DSS) loop
if Nkind (DSS) in 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));
Mutate_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);
Mutate_Ekind (T, E_Enumeration_Subtype);
Set_Etype (T, Base);
Init_Size (T, 8);
Reinit_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));
Mutate_Ekind (Base, E_Enumeration_Type);
Set_Etype (Base, Base);
Init_Size (Base, 8);
Reinit_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);
Mutate_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);
Mutate_Ekind (T, E_Modular_Integer_Subtype);
Mutate_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;
Mutate_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.
Mutate_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);
Mutate_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
Gen_Id : constant Node_Id := Name (N);
Loc : constant Source_Ptr := Sloc (N);
Pack_Id : constant Entity_Id := Defining_Identifier (N);
Formal : Entity_Id;
Gen_Decl : Node_Id;
Gen_Unit : Entity_Id;
Renaming : Node_Id;
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, Instantiating => 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;
-- Local variables
Save_ISMP : constant Boolean := Ignore_SPARK_Mode_Pragmas_In_Instance;
-- Save flag Ignore_SPARK_Mode_Pragmas_In_Instance for restore on exit
Associations : Boolean := True;
New_N : Node_Id;
Parent_Installed : Boolean := False;
Parent_Instance : Entity_Id;
Renaming_In_Par : Entity_Id;
-- 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_Entity (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_Entity (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, S_Adjustment);
-- Make local generic without formals. The formals will be replaced with
-- internal declarations.
begin
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);
Mutate_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);
Mutate_Ekind (Formal, E_Package);
Set_Etype (Formal, Standard_Void_Type);
Set_Inner_Instances (Formal, New_Elmt_List);
-- It is unclear that any aspects can apply to a formal package
-- declaration, given that they look like a hidden conformance
-- requirement on the corresponding actual. However, Abstract_State
-- must be treated specially because it generates declarations that
-- must appear before other declarations in the specification and
-- must be analyzed at once.
if Present (Aspect_Specifications (Gen_Decl)) then
if No (Aspect_Specifications (N)) then
Set_Aspect_Specifications (N, New_List);
Set_Has_Aspects (N);
end if;
declare
ASN : Node_Id := First (Aspect_Specifications (Gen_Decl));
New_A : Node_Id;
begin
while Present (ASN) loop
if Get_Aspect_Id (ASN) = Aspect_Abstract_State then
New_A :=
Copy_Generic_Node (ASN, Empty, Instantiating => True);
Set_Entity (New_A, Formal);
Set_Analyzed (New_A, False);
Append (New_A, Aspect_Specifications (N));
Analyze_Aspect_Specifications (N, Formal);
exit;
end if;
Next (ASN);
end loop;
end;
end if;
Push_Scope (Formal);
-- Manually set the SPARK_Mode from the context because the package
-- declaration is never analyzed.
Set_SPARK_Pragma (Formal, SPARK_Mode_Pragma);
Set_SPARK_Aux_Pragma (Formal, SPARK_Mode_Pragma);
Set_SPARK_Pragma_Inherited (Formal);
Set_SPARK_Aux_Pragma_Inherited (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));
Mutate_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_Entity (Renaming_In_Par, Formal);
Append_Entity (Renaming_In_Par, Parent_Instance);
end if;
-- A formal package declaration behaves as a package instantiation with
-- respect to SPARK_Mode "off". If the annotation is "off" or altogether
-- missing, set the global flag which signals Analyze_Pragma to ingnore
-- all SPARK_Mode pragmas within the generic_package_name.
if SPARK_Mode /= On then
Ignore_SPARK_Mode_Pragmas_In_Instance := True;
-- Mark the formal spec in case the body is instantiated at a later
-- pass. This preserves the original context in effect for the body.
Set_Ignore_SPARK_Mode_Pragmas (Formal);
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.
Mutate_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
-- Unclear that any other aspects may appear here, analyze them
-- for completion, given that the grammar allows their appearance.
Analyze_Aspect_Specifications (N, Pack_Id);
end if;
Ignore_SPARK_Mode_Pragmas_In_Instance := Save_ISMP;
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);
Mutate_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);
Mutate_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);
Expr : constant Node_Id := Expression (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);
-- A formal abstract procedure cannot have a null default
-- (RM 12.6(4.1/2)).
if Nkind (Spec) = N_Procedure_Specification
and then Null_Present (Spec)
then
Error_Msg_N
("a formal abstract subprogram cannot default to null", Spec);
end if;
-- A formal abstract function cannot have an expression default
-- (expression defaults are allowed for nonabstract formal functions
-- when extensions are enabled).
if Nkind (Spec) = N_Function_Specification
and then Present (Expr)
then
Error_Msg_N
("a formal abstract subprogram cannot default to an expression",
Spec);
end if;
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;
-- Default name 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;
-- When extensions are enabled, an expression can be given as default
-- for a formal function. The expression must be of the function result
-- type and can reference formal parameters of the function.
elsif Present (Expr) then
Push_Scope (Nam);
Install_Formals (Nam);
Preanalyze_Spec_Expression (Expr, Etype (Nam));
End_Scope;
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_Function_Definition
| N_Access_Procedure_Definition
| N_Access_To_Object_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;
-- A formal type declaration declares a type and its first
-- subtype.
Set_Is_Generic_Type (T);
Set_Is_First_Subtype (T);
if Present (Default_Subtype_Mark (Original_Node (N))) then
Validate_Formal_Type_Default (N);
end if;
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);
-- For Ada 2022, some formal parameters can carry aspects, which must
-- be name-resolved at the end of the list of formal parameters (which
-- has the semantics of a declaration list).
Analyze_Contracts (Generic_Formal_Declarations (N));
end Analyze_Generic_Formal_Part;
------------------------------------------
-- Analyze_Generic_Package_Declaration --
------------------------------------------
procedure Analyze_Generic_Package_Declaration (N : Node_Id) is
Decls : constant List_Id := Visible_Declarations (Specification (N));
Loc : constant Source_Ptr := Sloc (N);
Decl : Node_Id;
Id : Entity_Id;
New_N : Node_Id;
Renaming : Node_Id;
Save_Parent : Node_Id;
begin
-- A generic may grant access to its private enclosing context depending
-- on the placement of its corresponding body. From elaboration point of
-- view, the flow of execution may enter this private context, and then
-- reach an external unit, thus producing a dependency on that external
-- unit. For such a path to be properly discovered and encoded in the
-- ALI file of the main unit, let the ABE mechanism process the body of
-- the main unit, and encode all relevant invocation constructs and the
-- relations between them.
Mark_Save_Invocation_Graph_Of_Body;
-- 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))));
-- The declaration is inserted before other declarations, but before
-- pragmas that may be library-unit pragmas and must appear before other
-- declarations. The pragma Compile_Time_Error is not in this class, and
-- may contain an expression that includes such a qualified name, so the
-- renaming declaration must appear before it.
-- Are there other pragmas that require this special handling ???
if Present (Decls) then
Decl := First (Decls);
while Present (Decl)
and then Nkind (Decl) = N_Pragma
and then Get_Pragma_Id (Decl) /= Pragma_Compile_Time_Error
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);
-- Collect all contract-related source pragmas found within the template
-- and attach them to the contract of the package spec. This contract is
-- used in the capture of global references within annotations.
Create_Generic_Contract (N);
Id := Defining_Entity (N);
Generate_Definition (Id);
-- Expansion is not applied to generic units
Start_Generic;
Enter_Name (Id);
Mutate_Ekind (Id, E_Generic_Package);
Set_Etype (Id, Standard_Void_Type);
-- Set SPARK_Mode from context
Set_SPARK_Pragma (Id, SPARK_Mode_Pragma);
Set_SPARK_Aux_Pragma (Id, SPARK_Mode_Pragma);
Set_SPARK_Pragma_Inherited (Id);
Set_SPARK_Aux_Pragma_Inherited (Id);
-- Preserve relevant elaboration-related attributes of the context which
-- are no longer available or very expensive to recompute once analysis,
-- resolution, and expansion are over.
Mark_Elaboration_Attributes
(N_Id => Id,
Checks => True,
Warnings => True);
-- 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 the generic appears within a package unit, the body of that unit
-- has to be present for instantiation and inlining.
if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration then
Set_Body_Needed_For_Inlining
(Defining_Entity (Unit (Cunit (Current_Sem_Unit))));
end if;
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
-- A generic may grant access to its private enclosing context depending
-- on the placement of its corresponding body. From elaboration point of
-- view, the flow of execution may enter this private context, and then
-- reach an external unit, thus producing a dependency on that external
-- unit. For such a path to be properly discovered and encoded in the
-- ALI file of the main unit, let the ABE mechanism process the body of
-- the main unit, and encode all relevant invocation constructs and the
-- relations between them.
Mark_Save_Invocation_Graph_Of_Body;
-- 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);
-- Collect all contract-related source pragmas found within the template
-- and attach them to the contract of the subprogram spec. This contract
-- is used in the capture of global references within annotations.
Create_Generic_Contract (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);
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);
if Nkind (Spec) = N_Function_Specification then
Mutate_Ekind (Id, E_Generic_Function);
else
Mutate_Ekind (Id, E_Generic_Procedure);
end if;
-- Set SPARK_Mode from context
Set_SPARK_Pragma (Id, SPARK_Mode_Pragma);
Set_SPARK_Pragma_Inherited (Id);
-- Preserve relevant elaboration-related attributes of the context which
-- are no longer available or very expensive to recompute once analysis,
-- resolution, and expansion are over.
Mark_Elaboration_Attributes
(N_Id => Id,
Checks => True,
Warnings => True);
Formals := Parameter_Specifications (Spec);
if Present (Formals) then
Process_Formals (Formals, Spec);
end if;
if Nkind (Spec) = N_Function_Specification then
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.
if Is_Abstract_Type (Designated_Type (Result_Type)) 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_Etype (Id, Standard_Void_Type);
end if;
-- 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;
-- 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;
-- If the generic appears within a package unit, the body of that unit
-- has to be present for instantiation and inlining.
if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration
and then Unit_Requires_Body (Id)
then
Set_Body_Needed_For_Inlining
(Defining_Entity (Unit (Cunit (Current_Sem_Unit))));
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 --
-----------------------------------
-- WARNING: This routine manages Ghost and SPARK regions. Return statements
-- must be replaced by gotos which jump to the end of the routine in order
-- to restore the Ghost and SPARK modes.
procedure Analyze_Package_Instantiation (N : Node_Id) is
Has_Inline_Always : Boolean := False;
-- Set if the generic unit contains any subprograms with Inline_Always.
-- Only relevant when back-end inlining is not enabled.
function Might_Inline_Subp (Gen_Unit : Entity_Id) return Boolean;
-- Return True if inlining is active and Gen_Unit contains inlined
-- subprograms. In this case, we may either instantiate the body when
-- front-end inlining is enabled, or add a pending instantiation when
-- back-end inlining is enabled. In the former case, this may cause
-- superfluous instantiations, but in either case we need to perform
-- the instantiation of the body in the context of the instance and
-- not in that of the point of inlining.
function Needs_Body_Instantiated (Gen_Unit : Entity_Id) return Boolean;
-- Return True if Gen_Unit needs to have its body instantiated in the
-- context of N. This in particular excludes generic contexts.
-----------------------
-- Might_Inline_Subp --
-----------------------
function Might_Inline_Subp (Gen_Unit : Entity_Id) return Boolean is
E : Entity_Id;
begin
if Inline_Processing_Required then
-- No need to recompute the answer if we know it is positive
-- and back-end inlining is enabled.
if Is_Inlined (Gen_Unit) and then Back_End_Inlining then
return True;
end if;
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;
Set_Is_Inlined (Gen_Unit);
return True;
end if;
Next_Entity (E);
end loop;
end if;
return False;
end Might_Inline_Subp;
-------------------------------
-- Needs_Body_Instantiated --
-------------------------------
function Needs_Body_Instantiated (Gen_Unit : Entity_Id) return Boolean is
begin
-- No need to instantiate bodies in generic units
if Is_Generic_Unit (Cunit_Entity (Main_Unit)) then
return False;
end if;
-- If the instantiation is in the main unit, then the body is needed
if Is_In_Main_Unit (N) then
return True;
end if;
-- In GNATprove mode, never instantiate bodies outside of the main
-- unit, as it does not use frontend/backend inlining in the way that
-- GNAT does, so does not benefit from such instantiations. On the
-- contrary, such instantiations may bring artificial constraints,
-- as for example such bodies may require preprocessing.
if GNATprove_Mode then
return False;
end if;
-- If not, then again no need to instantiate bodies in generic units
if Is_Generic_Unit (Cunit_Entity (Get_Code_Unit (N))) then
return False;
end if;
-- Here we have a special handling for back-end inlining: if inline
-- processing is required, then we unconditionally want to have the
-- body instantiated. The reason is that Might_Inline_Subp does not
-- catch all the cases (as it does not recurse into nested packages)
-- so this avoids the need to patch things up afterwards. Moreover,
-- these instantiations are only performed on demand when back-end
-- inlining is enabled, so this causes very little extra work.
if Inline_Processing_Required and then Back_End_Inlining then
return True;
end if;
-- We want to have the bodies instantiated in non-main units if
-- they might contribute inlined subprograms.
return Might_Inline_Subp (Gen_Unit);
end Needs_Body_Instantiated;
-- Local declarations
Gen_Id : constant Node_Id := Name (N);
Inst_Id : constant Entity_Id := Defining_Entity (N);
Is_Actual_Pack : constant Boolean := Is_Internal (Inst_Id);
Loc : constant Source_Ptr := Sloc (N);
Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
Saved_ISMP : constant Boolean :=
Ignore_SPARK_Mode_Pragmas_In_Instance;
Saved_SM : constant SPARK_Mode_Type := SPARK_Mode;
Saved_SMP : constant Node_Id := SPARK_Mode_Pragma;
-- Save the Ghost and SPARK mode-related data to restore on exit
Saved_Style_Check : constant Boolean := Style_Check;
-- Save style check mode for restore on exit
Act_Decl : Node_Id;
Act_Decl_Name : Node_Id;
Act_Decl_Id : Entity_Id;
Act_Spec : Node_Id;
Act_Tree : Node_Id;
Env_Installed : Boolean := False;
Gen_Decl : Node_Id;
Gen_Spec : Node_Id;
Gen_Unit : Entity_Id;
Inline_Now : Boolean := False;
Needs_Body : Boolean;
Parent_Installed : Boolean := False;
Renaming_List : List_Id;
Unit_Renaming : Node_Id;
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
-- Preserve relevant elaboration-related attributes of the context which
-- are no longer available or very expensive to recompute once analysis,
-- resolution, and expansion are over.
Mark_Elaboration_Attributes
(N_Id => N,
Checks => True,
Level => True,
Modes => True,
Warnings => True);
-- Very first thing: check for Text_IO special 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;
-- 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);