-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Errout; use Errout;
-with Expander; use Expander;
-with Exp_Disp; use Exp_Disp;
-with Fname; use Fname;
-with Fname.UF; use Fname.UF;
-with Freeze; use Freeze;
-with Ghost; use Ghost;
-with Itypes; use Itypes;
-with Lib; use Lib;
-with Lib.Load; use Lib.Load;
-with Lib.Xref; use Lib.Xref;
-with Nlists; use Nlists;
-with Namet; use Namet;
-with Nmake; use Nmake;
-with Opt; use Opt;
-with Rident; use Rident;
-with Restrict; use Restrict;
-with Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Cat; use Sem_Cat;
-with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch6; use Sem_Ch6;
-with Sem_Ch7; use Sem_Ch7;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch10; use Sem_Ch10;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Dim; use Sem_Dim;
-with Sem_Disp; use Sem_Disp;
-with Sem_Elab; use Sem_Elab;
-with Sem_Elim; use Sem_Elim;
-with Sem_Eval; use Sem_Eval;
-with Sem_Res; use Sem_Res;
-with Sem_Type; use Sem_Type;
-with Sem_Util; use Sem_Util;
-with Sem_Warn; use Sem_Warn;
-with Stand; use Stand;
-with Sinfo; use Sinfo;
-with Sinfo.CN; use Sinfo.CN;
-with Sinput; use Sinput;
-with Sinput.L; use Sinput.L;
-with Snames; use Snames;
-with Stringt; use Stringt;
-with Uname; use Uname;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Contracts; use Contracts;
+with Einfo; use Einfo;
+with Elists; use Elists;
+with Errout; use Errout;
+with Expander; use Expander;
+with Exp_Disp; use Exp_Disp;
+with Fname; use Fname;
+with Fname.UF; use Fname.UF;
+with Freeze; use Freeze;
+with Ghost; use Ghost;
+with Itypes; use Itypes;
+with Lib; use Lib;
+with Lib.Load; use Lib.Load;
+with Lib.Xref; use Lib.Xref;
+with Nlists; use Nlists;
+with Namet; use Namet;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Rident; use Rident;
+with Restrict; use Restrict;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Cat; use Sem_Cat;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch7; use Sem_Ch7;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch10; use Sem_Ch10;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Dim; use Sem_Dim;
+with Sem_Disp; use Sem_Disp;
+with Sem_Elab; use Sem_Elab;
+with Sem_Elim; use Sem_Elim;
+with Sem_Eval; use Sem_Eval;
+with Sem_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.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 Tbuild; use Tbuild;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
+with Warnsw; use Warnsw;
with GNAT.HTable;
-- 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
+ -- 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
-- circularity is detected, and used to abandon compilation after the
-- messages have been posted.
+ -----------------------------------------
+ -- 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
+ -- 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
+
Circularity_Detected : Boolean := False;
-- This should really be reset on encountering a new main unit, but in
-- practice we are not using multiple main units so it is not critical.
-- 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
+ -- 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;
-- packages, and the prefix of the formal type may be needed to resolve
-- the ambiguity in the instance ???
+ procedure Freeze_Subprogram_Body
+ (Inst_Node : Node_Id;
+ Gen_Body : Node_Id;
+ Pack_Id : Entity_Id);
+ -- The generic body may appear textually after the instance, including
+ -- in the proper body of a stub, or within a different package instance.
+ -- Given that the instance can only be elaborated after the generic, we
+ -- place freeze_nodes for the instance and/or for packages that may enclose
+ -- the instance and the generic, so that the back-end can establish the
+ -- proper order of elaboration.
+
+ 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.
+
+ 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_Same_Declarative_Part
(F_Node : Node_Id;
Inst : Node_Id) return Boolean;
-- Used to determine whether its body should be elaborated to allow
-- front-end inlining.
- procedure Set_Instance_Env
- (Gen_Unit : Entity_Id;
- Act_Unit : Entity_Id);
- -- Save current instance on saved environment, to be used to determine
- -- the global status of entities in nested instances. Part of Save_Env.
- -- called after verifying that the generic unit is legal for the instance,
- -- The procedure also examines whether the generic unit is a predefined
- -- unit, in order to set configuration switches accordingly. As a result
- -- the procedure must be called after analyzing and freezing the actuals.
+ procedure 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 Set_Instance_Of (A : Entity_Id; B : Entity_Id);
- -- Associate analyzed generic parameter with corresponding
- -- instance. Used for semantic checks at instantiation time.
+ 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.
- function Has_Been_Exchanged (E : Entity_Id) return Boolean;
- -- Traverse the Exchanged_Views list to see if a type was private
- -- and has already been flipped during this phase of instantiation.
+ procedure 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 Hide_Current_Scope;
- -- When instantiating a generic child unit, the parent context must be
- -- present, but the instance and all entities that may be generated
- -- must be inserted in the current scope. We leave the current scope
- -- on the stack, but make its entities invisible to avoid visibility
- -- problems. This is reversed at the end of the instantiation. This is
- -- not done for the instantiation of the bodies, which only require the
- -- instances of the generic parents to be in scope.
+ procedure Insert_Freeze_Node_For_Instance
+ (N : Node_Id;
+ F_Node : Node_Id);
+ -- N denotes a package or a subprogram instantiation and F_Node is the
+ -- associated freeze node. Insert the freeze node before the first source
+ -- body which follows immediately after N. If no such body is found, the
+ -- freeze node is inserted at the end of the declarative region which
+ -- contains N.
procedure Install_Body
(Act_Body : Node_Id;
-- If the instantiation happens textually before the body of the generic,
-- the instantiation of the body must be analyzed after the generic body,
-- and not at the point of instantiation. Such early instantiations can
- -- happen if the generic and the instance appear in a package declaration
+ -- happen if the generic and the instance appear in a package declaration
-- because the generic body can only appear in the corresponding package
-- body. Early instantiations can also appear if generic, instance and
-- body are all in the declarative part of a subprogram or entry. Entities
-- of packages that are early instantiations are delayed, and their freeze
- -- node appears after the generic body.
-
- procedure Insert_Freeze_Node_For_Instance
- (N : Node_Id;
- F_Node : Node_Id);
- -- N denotes a package or a subprogram instantiation and F_Node is the
- -- associated freeze node. Insert the freeze node before the first source
- -- body which follows immediately after N. If no such body is found, the
- -- freeze node is inserted at the end of the declarative region which
- -- contains N.
-
- procedure Freeze_Subprogram_Body
- (Inst_Node : Node_Id;
- Gen_Body : Node_Id;
- Pack_Id : Entity_Id);
- -- The generic body may appear textually after the instance, including
- -- in the proper body of a stub, or within a different package instance.
- -- Given that the instance can only be elaborated after the generic, we
- -- place freeze_nodes for the instance and/or for packages that may enclose
- -- the instance and the generic, so that the back-end can establish the
- -- proper order of elaboration.
-
- procedure Init_Env;
- -- Establish environment for subsequent instantiation. Separated from
- -- Save_Env because data-structures for visibility handling must be
- -- initialized before call to Check_Generic_Child_Unit.
+ -- 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 Install_Formal_Packages (Par : Entity_Id);
-- Install the visible part of any formal of the parent that is a formal
-- package. Note that for the case of a formal package with a box, this
-- includes the formal part of the formal package (12.7(10/2)).
- procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False);
- -- When compiling an instance of a child unit the parent (which is
- -- itself an instance) is an enclosing scope that must be made
- -- immediately visible. This procedure is also used to install the non-
- -- generic parent of a generic child unit when compiling its body, so
- -- that full views of types in the parent are made visible.
-
- procedure Remove_Parent (In_Body : Boolean := False);
- -- Reverse effect after instantiation of child is complete
-
procedure Install_Hidden_Primitives
(Prims_List : in out Elist_Id;
Gen_T : Entity_Id;
-- visibility of primitives of Gen_T. The list of primitives to which
-- the suffix is removed is added to Prims_List to restore them later.
- procedure Restore_Hidden_Primitives (Prims_List : in out Elist_Id);
- -- Restore suffix 'P' to primitives of Prims_List and leave Prims_List
- -- set to No_Elist.
-
- procedure Inline_Instance_Body
- (N : Node_Id;
- Gen_Unit : Entity_Id;
- Act_Decl : Node_Id);
- -- If front-end inlining is requested, instantiate the package body,
- -- and preserve the visibility of its compilation unit, to insure
- -- that successive instantiations succeed.
+ 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
-- instances in the current declarative part that precede the one being
-- loaded. In that case a missing body is acceptable.
- procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id);
- -- Add the context clause of the unit containing a generic unit to a
- -- compilation unit that is, or contains, an instantiation.
-
- function Get_Associated_Node (N : Node_Id) return Node_Id;
- -- In order to propagate semantic information back from the analyzed copy
- -- to the original generic, we maintain links between selected nodes in the
- -- generic and their corresponding copies. At the end of generic analysis,
- -- the routine Save_Global_References traverses the generic tree, examines
- -- the semantic information, and preserves the links to those nodes that
- -- contain global information. At instantiation, the information from the
- -- associated node is placed on the new copy, so that name resolution is
- -- not repeated.
- --
- -- Three kinds of source nodes have associated nodes:
- --
- -- a) those that can reference (denote) entities, that is identifiers,
- -- character literals, expanded_names, operator symbols, operators,
- -- and attribute reference nodes. These nodes have an Entity field
- -- and are the set of nodes that are in N_Has_Entity.
- --
- -- b) aggregates (N_Aggregate and N_Extension_Aggregate)
- --
- -- c) selected components (N_Selected_Component)
- --
- -- For the first class, the associated node preserves the entity if it is
- -- global. If the generic contains nested instantiations, the associated
- -- node itself has been recopied, and a chain of them must be followed.
- --
- -- For aggregates, the associated node allows retrieval of the type, which
- -- may otherwise not appear in the generic. The view of this type may be
- -- different between generic and instantiation, and the full view can be
- -- installed before the instantiation is analyzed. For aggregates of type
- -- extensions, the same view exchange may have to be performed for some of
- -- the ancestor types, if their view is private at the point of
- -- instantiation.
- --
- -- Nodes that are selected components in the parse tree may be rewritten
- -- as expanded names after resolution, and must be treated as potential
- -- entity holders, which is why they also have an Associated_Node.
- --
- -- Nodes that do not come from source, such as freeze nodes, do not appear
- -- in the generic tree, and need not have an associated node.
- --
- -- The associated node is stored in the Associated_Node field. Note that
- -- this field overlaps Entity, which is fine, because the whole point is
- -- that we don't need or want the normal Entity field in this situation.
-
procedure Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id);
-- Within the generic part, entities in the formal package are
-- visible. To validate subsequent type declarations, indicate
-- the correspondence between the entities in the analyzed formal,
- -- and the entities in the actual package. There are three packages
+ -- 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
-- at the end of the enclosing generic package, which is semantically
-- neutral.
- procedure Preanalyze_Actuals (N : Node_Id);
+ 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 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
raise Instantiation_Error;
end Abandon_Instantiation;
+ --------------------------------
+ -- Add_Pending_Instantiation --
+ --------------------------------
+
+ procedure Add_Pending_Instantiation (Inst : Node_Id; Act_Decl : Node_Id) is
+ begin
+
+ -- Add to the instantiation node and the corresponding unit declaration
+ -- the current values of global flags to be used when analyzing the
+ -- instance body.
+
+ Pending_Instantiations.Append
+ ((Inst_Node => Inst,
+ Act_Decl => Act_Decl,
+ Expander_Status => Expander_Active,
+ Current_Sem_Unit => Current_Sem_Unit,
+ Scope_Suppress => Scope_Suppress,
+ Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
+ Version => Ada_Version,
+ Version_Pragma => Ada_Version_Pragma,
+ Warnings => Save_Warnings,
+ SPARK_Mode => SPARK_Mode,
+ SPARK_Mode_Pragma => SPARK_Mode_Pragma));
+ end Add_Pending_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 --
--------------------------
F_Copy : List_Id) return List_Id
is
Actuals_To_Freeze : constant Elist_Id := New_Elmt_List;
- Assoc : constant List_Id := New_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));
-- name of the formal.
Is_Named_Assoc : Boolean;
- Num_Matched : Int := 0;
- Num_Actuals : Int := 0;
+ 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 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
+ -- 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.
-- 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
+ -- A_F is the corresponding entity in the analyzed generic, which is
-- placed on the selector name for ASIS use.
--
-- In Ada 2005, a named association may be given with a box, in which
-- 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
+ -- 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;
end Check_Overloaded_Formal_Subprogram;
-------------------------------
- -- Has_Fully_Defined_Profile --
+ -- Check_Fixed_Point_Actual --
-------------------------------
- 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
+ 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;
- ---------------------------
- -- Is_Fully_Defined_Type --
- ---------------------------
+ begin
+ -- Locate primitive operations of the type that are arithmetic
+ -- operations.
- function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean is
- begin
- -- A private type without a full view is not fully defined
+ Elem := First_Elmt (Prims);
+ while Present (Elem) loop
+ if Nkind (Node (Elem)) = N_Defining_Operator_Symbol then
- if Is_Private_Type (Typ)
+ -- 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 does not use 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;
elsif No (Selector_Name (Actual)) then
Found_Assoc := Actual;
- Act := Explicit_Generic_Actual_Parameter (Actual);
+ Act := Explicit_Generic_Actual_Parameter (Actual);
Num_Matched := Num_Matched + 1;
Next (Actual);
Prev := Empty;
while Present (Actual) loop
- if Chars (Selector_Name (Actual)) = Chars (F) then
+ 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);
+ Act := Explicit_Generic_Actual_Parameter (Actual);
Num_Matched := Num_Matched + 1;
exit;
end if;
-- insert actuals for those defaults, and cannot rely on their
-- names to disambiguate them.
- if Actual = First_Named then
+ if Actual = First_Named then
Next (First_Named);
elsif Present (Actual) then
-- Process_Default --
---------------------
- procedure Process_Default (F : Entity_Id) is
+ 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;
Set_Defining_Identifier (Decl, Id);
end if;
- Append (Decl, Assoc);
+ Append (Decl, Assoc_List);
if No (Found_Assoc) then
Default :=
Kind := Nkind (Analyzed_Formal);
case Nkind (Formal) is
-
when N_Formal_Subprogram_Declaration =>
exit when Kind in N_Formal_Subprogram_Declaration
and then
N_Generic_Package_Declaration,
N_Package_Declaration);
- when N_Use_Package_Clause | N_Use_Type_Clause => exit;
+ when N_Use_Package_Clause
+ | N_Use_Type_Clause
+ =>
+ exit;
when others =>
-- 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.
+ -- 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))
+ and then (Present (Explicit_Generic_Actual_Parameter (Named))
+ or else Box_Present (Named))
then
Num_Actuals := Num_Actuals + 1;
end if;
else
Append_List
(Instantiate_Object (Formal, Match, Analyzed_Formal),
- Assoc);
+ Assoc_List);
-- For a defaulted in_parameter, create an entry in the
-- the list of defaulted actuals, for GNATProve use. Do
Analyze (Match);
Append_List
(Instantiate_Type
- (Formal, Match, Analyzed_Formal, Assoc),
- Assoc);
+ (Formal, Match, Analyzed_Formal, Assoc_List),
+ Assoc_List);
+
+ if Is_Fixed_Point_Type (Entity (Match)) 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
end if;
else
- Append_To (Assoc,
+ Append_To (Assoc_List,
Instantiate_Formal_Subprogram
(Formal, Match, Analyzed_Formal));
if No (Match) and then Box_Present (Formal) then
declare
Subp : constant Entity_Id :=
- Defining_Unit_Name (Specification (Last (Assoc)));
+ Defining_Unit_Name
+ (Specification (Last (Assoc_List)));
begin
Append_To (Default_Actuals,
Append_List
(Instantiate_Formal_Package
(Formal, Match, Analyzed_Formal),
- Assoc);
+ 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.
+
+ declare
+ Actual : constant Entity_Id := Entity (Match);
+
+ Needs_Freezing : Boolean;
+ S : Entity_Id;
+
+ begin
+ if not Expander_Active
+ or else not Has_Completion (Actual)
+ or else not In_Same_Source_Unit (I_Node, 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;
+
+ S := Current_Scope;
+ while Present (S) loop
+ if Ekind_In (S, E_Block,
+ E_Function,
+ E_Loop,
+ E_Procedure)
+ then
+ Needs_Freezing := False;
+ exit;
+ end if;
+
+ S := Scope (S);
+ end loop;
+
+ if Needs_Freezing then
+ Set_Has_Delayed_Freeze (Actual);
+ Append_Elmt (Actual, Actuals_To_Freeze);
+ end if;
+ end if;
+ end;
end if;
-- For use type and use package appearing in the generic part,
-- they belong (we mustn't recopy them since this would mess up
-- the Sloc values).
- when N_Use_Package_Clause |
- N_Use_Type_Clause =>
+ 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);
+ Append (New_Copy_Tree (Formal), Assoc_List);
else
Remove (Formal);
- Append (Formal, Assoc);
+ Append (Formal, Assoc_List);
end if;
when others =>
raise Program_Error;
-
end case;
Formal := Saved_Formal;
Append_List (Default_Formals, Formals);
end if;
- return Assoc;
+ return Assoc_List;
end Analyze_Associations;
-------------------------------
----------------------------------------
procedure Analyze_Formal_Package_Declaration (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Pack_Id : constant Entity_Id := Defining_Identifier (N);
- Formal : Entity_Id;
- Gen_Id : constant Node_Id := Name (N);
- Gen_Decl : Node_Id;
- Gen_Unit : Entity_Id;
- New_N : Node_Id;
- Parent_Installed : Boolean := False;
- Renaming : Node_Id;
- Parent_Instance : Entity_Id;
- Renaming_In_Par : Entity_Id;
- Associations : Boolean := True;
+ 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
+ -- 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
(Specification (Original_Node (Gen_Decl)),
Empty, Instantiating => True));
- Renaming := Make_Package_Renaming_Declaration (Loc,
+ Renaming :=
+ Make_Package_Renaming_Declaration (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Chars (Gen_Unit)),
- Name => New_Occurrence_Of (Formal, Loc));
+ Name => New_Occurrence_Of (Formal, Loc));
if Nkind (Gen_Id) = N_Identifier
and then Chars (Gen_Id) = Chars (Pack_Id)
(Generic_Formal_Declarations (Original_Node (Gen_Decl)));
while Present (Formal_Decl) loop
Append_To
- (Decls, Copy_Generic_Node (Formal_Decl, Empty, True));
+ (Decls,
+ Copy_Generic_Node
+ (Formal_Decl, Empty, Instantiating => True));
Next (Formal_Decl);
end loop;
end;
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
-- continue analysis to minimize cascaded errors.
Error_Msg_N
- ("generic parent cannot be used as formal package "
- & "of a child unit", Gen_Id);
+ ("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);
+ ("generic package cannot be used as a formal package within "
+ & "itself", Gen_Id);
Restore_Env;
goto Leave;
end if;
end if;
Formal := New_Copy (Pack_Id);
- Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
+ Create_Instantiation_Source (N, Gen_Unit, S_Adjustment);
- begin
- -- Make local generic without formals. The formals will be replaced
- -- with internal declarations.
+ -- 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.
+ -- If there are errors in the parameter list, Analyze_Associations
+ -- raises Instantiation_Error. Patch the declaration to prevent further
+ -- exception propagation.
exception
when Instantiation_Error =>
-
Enter_Name (Formal);
Set_Ekind (Formal, E_Variable);
Set_Etype (Formal, Any_Type);
Set_Inner_Instances (Formal, New_Elmt_List);
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
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
Set_Has_Completion (Formal, True);
- -- Add semantic information to the original defining identifier.
- -- for ASIS use.
+ -- Add semantic information to the original defining identifier for ASIS
+ -- use.
Set_Ekind (Pack_Id, E_Package);
Set_Etype (Pack_Id, Standard_Void_Type);
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, Pack_Id);
end if;
+
+ Ignore_SPARK_Mode_Pragmas_In_Instance := Save_ISMP;
end Analyze_Formal_Package_Declaration;
---------------------------------
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;
+
declare
Ctrl_Type : constant Entity_Id := Find_Dispatching_Type (Nam);
begin
end if;
-- Default name may be overloaded, in which case the interpretation
- -- with the correct profile must be selected, as for a renaming.
+ -- 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.
-- Enter the new name, and branch to specific routine
case Nkind (Def) is
- when N_Formal_Private_Type_Definition =>
+ when N_Formal_Private_Type_Definition =>
Analyze_Formal_Private_Type (N, T, Def);
- when N_Formal_Derived_Type_Definition =>
+ when N_Formal_Derived_Type_Definition =>
Analyze_Formal_Derived_Type (N, T, Def);
- when N_Formal_Incomplete_Type_Definition =>
+ when N_Formal_Incomplete_Type_Definition =>
Analyze_Formal_Incomplete_Type (T, Def);
- when N_Formal_Discrete_Type_Definition =>
+ when N_Formal_Discrete_Type_Definition =>
Analyze_Formal_Discrete_Type (T, Def);
- when N_Formal_Signed_Integer_Type_Definition =>
+ when N_Formal_Signed_Integer_Type_Definition =>
Analyze_Formal_Signed_Integer_Type (T, Def);
- when N_Formal_Modular_Type_Definition =>
+ when N_Formal_Modular_Type_Definition =>
Analyze_Formal_Modular_Type (T, Def);
- when N_Formal_Floating_Point_Definition =>
+ 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 =>
+ when N_Formal_Decimal_Fixed_Point_Definition =>
Analyze_Formal_Decimal_Fixed_Point_Type (T, Def);
when N_Array_Type_Definition =>
Analyze_Formal_Array_Type (T, Def);
- when N_Access_To_Object_Definition |
- N_Access_Function_Definition |
- N_Access_Procedure_Definition =>
+ 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 =>
+ when N_Record_Definition =>
Analyze_Formal_Interface_Type (N, T, Def);
- when N_Derived_Type_Definition =>
+ when N_Derived_Type_Definition =>
Analyze_Formal_Derived_Interface_Type (N, T, Def);
- when N_Error =>
+ when N_Error =>
null;
- when others =>
+ when others =>
raise Program_Error;
-
end case;
Set_Is_Generic_Type (T);
procedure Analyze_Generic_Package_Declaration (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Id : Entity_Id;
- New_N : Node_Id;
- Save_Parent : Node_Id;
- Renaming : Node_Id;
Decls : constant List_Id :=
Visible_Declarations (Specification (N));
Decl : Node_Id;
+ Id : Entity_Id;
+ New_N : Node_Id;
+ Renaming : Node_Id;
+ Save_Parent : Node_Id;
begin
- -- The generic package declaration may be subject to pragma Ghost with
- -- policy Ignore. Set the mode now to ensure that any nodes generated
- -- during analysis and expansion are properly flagged as ignored Ghost.
-
- Set_Ghost_Mode (N);
Check_SPARK_05_Restriction ("generic is not allowed", N);
-- We introduce a renaming of the enclosing package, to have a usable
-- 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);
Set_Ekind (Id, E_Generic_Package);
Set_Etype (Id, Standard_Void_Type);
- -- A generic package declared within a Ghost region is rendered Ghost
- -- (SPARK RM 6.9(2)).
+ -- Set SPARK_Mode from context
- if Ghost_Mode > None then
- Set_Is_Ghost_Entity (Id);
- end if;
+ 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);
-- Analyze aspects now, so that generated pragmas appear in the
-- declarations before building and analyzing the generic copy.
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)));
Typ : Entity_Id;
begin
- -- The generic subprogram declaration may be subject to pragma Ghost
- -- with policy Ignore. Set the mode now to ensure that any nodes
- -- generated during analysis and expansion are properly flagged as
- -- ignored Ghost.
-
- Set_Ghost_Mode (N);
Check_SPARK_05_Restriction ("generic is not allowed", N);
-- Create copy of generic unit, and save for instantiation. If the unit
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);
Formals := Parameter_Specifications (Spec);
+ if Nkind (Spec) = N_Function_Specification then
+ Set_Ekind (Id, E_Generic_Function);
+ else
+ Set_Ekind (Id, E_Generic_Procedure);
+ end if;
+
if Present (Formals) then
Process_Formals (Formals, Spec);
end if;
if Nkind (Spec) = N_Function_Specification then
- Set_Ekind (Id, E_Generic_Function);
-
if Nkind (Result_Definition (Spec)) = N_Access_Definition then
Result_Type := Access_Definition (Spec, Result_Definition (Spec));
Set_Etype (Id, Result_Type);
end if;
else
- Set_Ekind (Id, E_Generic_Procedure);
Set_Etype (Id, Standard_Void_Type);
end if;
- -- A generic subprogram declared within a Ghost region is rendered Ghost
- -- (SPARK RM 6.9(2)).
-
- if Ghost_Mode > None then
- Set_Is_Ghost_Entity (Id);
- end if;
-
-- For a library unit, we have reconstructed the entity for the unit,
-- and must reset it in the library tables. We also make sure that
-- Body_Required is set properly in the original compilation unit node.
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);
-- Analyze_Package_Instantiation --
-----------------------------------
- procedure Analyze_Package_Instantiation (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Gen_Id : constant Node_Id := Name (N);
-
- Act_Decl : Node_Id;
- Act_Decl_Name : Node_Id;
- Act_Decl_Id : Entity_Id;
- Act_Spec : Node_Id;
- Act_Tree : Node_Id;
-
- Gen_Decl : Node_Id;
- Gen_Spec : Node_Id;
- Gen_Unit : Entity_Id;
-
- Is_Actual_Pack : constant Boolean :=
- Is_Internal (Defining_Entity (N));
+ -- 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.
- Env_Installed : Boolean := False;
- Parent_Installed : Boolean := False;
- Renaming_List : List_Id;
- Unit_Renaming : Node_Id;
- Needs_Body : Boolean;
- Inline_Now : Boolean := False;
+ procedure Analyze_Package_Instantiation (N : Node_Id) is
Has_Inline_Always : Boolean := False;
- Save_IPSM : constant Boolean := Ignore_Pragma_SPARK_Mode;
- -- Save flag Ignore_Pragma_SPARK_Mode for restore on exit
-
- Save_SM : constant SPARK_Mode_Type := SPARK_Mode;
- Save_SMP : constant Node_Id := SPARK_Mode_Pragma;
- -- Save the SPARK_Mode-related data for restore on exit
-
- Save_Style_Check : constant Boolean := Style_Check;
- -- Save style check mode for restore on exit
-
procedure Delay_Descriptors (E : Entity_Id);
-- Delay generation of subprogram descriptors for given entity
- function Might_Inline_Subp return Boolean;
+ function Might_Inline_Subp (Gen_Unit : Entity_Id) return Boolean;
-- If inlining is active and the generic contains inlined subprograms,
-- we instantiate the body. This may cause superfluous instantiations,
-- but it is simpler than detecting the need for the body at the point
-- Might_Inline_Subp --
-----------------------
- function Might_Inline_Subp return Boolean is
+ function Might_Inline_Subp (Gen_Unit : Entity_Id) return Boolean is
E : Entity_Id;
begin
-- Local declarations
+ Gen_Id : constant Node_Id := Name (N);
+ Is_Actual_Pack : constant Boolean :=
+ Is_Internal (Defining_Entity (N));
+ Loc : constant Source_Ptr := Sloc (N);
+
+ Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
+ 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
begin
Check_SPARK_05_Restriction ("generic is not allowed", N);
- -- Very first thing: check for Text_IO sp[ecial unit in case we are
+ -- 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));
Instantiation_Node := N;
- -- Turn off style checking in instances. If the check is enabled on the
- -- generic unit, a warning in an instance would just be noise. If not
- -- enabled on the generic, then a warning in an instance is just wrong.
-
- Style_Check := False;
-
-- Case of instantiation of a generic package
if Nkind (N) = N_Package_Instantiation then
New_Copy_Tree (Name (Defining_Unit_Name (N))),
Defining_Identifier => Act_Decl_Id);
else
- Act_Decl_Name := Act_Decl_Id;
+ Act_Decl_Name := Act_Decl_Id;
end if;
-- Case of instantiation of a formal package
end if;
Generate_Definition (Act_Decl_Id);
- Preanalyze_Actuals (N);
+ Set_Ekind (Act_Decl_Id, E_Package);
+
+ -- Initialize list of incomplete actuals before analysis
+
+ Set_Incomplete_Actuals (Act_Decl_Id, New_Elmt_List);
+
+ Preanalyze_Actuals (N, Act_Decl_Id);
+
+ -- Turn off style checking in instances. If the check is enabled on the
+ -- generic unit, a warning in an instance would just be noise. If not
+ -- enabled on the generic, then a warning in an instance is just wrong.
+ -- This must be done after analyzing the actuals, which do come from
+ -- source and are subject to style checking.
+
+ Style_Check := False;
Init_Env;
Env_Installed := True;
Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
Gen_Unit := Entity (Gen_Id);
+ -- A package instantiation is Ghost when it is subject to pragma Ghost
+ -- or the generic template is Ghost. Set the mode now to ensure that
+ -- any nodes generated during analysis and expansion are marked as
+ -- Ghost.
+
+ Mark_And_Set_Ghost_Instantiation (N, Gen_Unit);
+
-- Verify that it is the name of a generic package
-- A visibility glitch: if the instance is a child unit and the generic
goto Leave;
else
- -- If the context of the instance is subject to SPARK_Mode "off",
- -- set the global flag which signals Analyze_Pragma to ignore all
- -- SPARK_Mode pragmas within the instance.
+ -- If the context of the instance is subject to SPARK_Mode "off" or
+ -- the annotation is altogether missing, set the global flag which
+ -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within
+ -- the instance.
+
+ if SPARK_Mode /= On then
+ Ignore_SPARK_Mode_Pragmas_In_Instance := True;
- if SPARK_Mode = Off then
- Ignore_Pragma_SPARK_Mode := True;
+ -- Mark the instance 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 (Act_Decl_Id);
end if;
Gen_Decl := Unit_Declaration_Node (Gen_Unit);
-- validate an actual package, the instantiation environment is that
-- of the enclosing instance.
- Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
+ Create_Instantiation_Source (N, Gen_Unit, S_Adjustment);
-- Copy original generic tree, to produce text for instantiation
if Expander_Active
and then (not Is_Child_Unit (Gen_Unit)
or else not Is_Generic_Unit (Scope (Gen_Unit)))
- and then Might_Inline_Subp
+ and then Might_Inline_Subp (Gen_Unit)
and then not Is_Actual_Pack
then
if not Back_End_Inlining
-- predefined subprograms marked Inline_Always, to minimize
-- the use of the run-time library.
- elsif Is_Predefined_File_Name
- (Unit_File_Name (Get_Source_Unit (Gen_Decl)))
+ elsif In_Predefined_Unit (Gen_Decl)
and then Configurable_Run_Time_Mode
and then Nkind (Parent (N)) /= N_Compilation_Unit
then
(Unit_Requires_Body (Gen_Unit)
or else Enclosing_Body_Present
or else Present (Corresponding_Body (Gen_Decl)))
- and then (Is_In_Main_Unit (N) or else Might_Inline_Subp)
+ and then (Is_In_Main_Unit (N)
+ or else Might_Inline_Subp (Gen_Unit))
and then not Is_Actual_Pack
and then not Inline_Now
and then (Operating_Mode = Generate_Code
-- Make entry in table
- Pending_Instantiations.Append
- ((Inst_Node => N,
- Act_Decl => Act_Decl,
- Expander_Status => Expander_Active,
- Current_Sem_Unit => Current_Sem_Unit,
- Scope_Suppress => Scope_Suppress,
- Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
- Version => Ada_Version,
- Version_Pragma => Ada_Version_Pragma,
- Warnings => Save_Warnings,
- SPARK_Mode => SPARK_Mode,
- SPARK_Mode_Pragma => SPARK_Mode_Pragma));
+ Add_Pending_Instantiation (N, Act_Decl);
end if;
end if;
Set_Defining_Identifier (N, Act_Decl_Id);
end if;
- Ignore_Pragma_SPARK_Mode := Save_IPSM;
- SPARK_Mode := Save_SM;
- SPARK_Mode_Pragma := Save_SMP;
- Style_Check := Save_Style_Check;
-
- if SPARK_Mode = On then
- Dynamic_Elaboration_Checks := False;
- end if;
-
-- Check that if N is an instantiation of System.Dim_Float_IO or
-- System.Dim_Integer_IO, the formal type has a dimension system.
Analyze_Aspect_Specifications (N, Act_Decl_Id);
end if;
+ Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP;
+ Restore_Ghost_Mode (Saved_GM);
+ Restore_SPARK_Mode (Saved_SM, Saved_SMP);
+ Style_Check := Saved_Style_Check;
+
exception
when Instantiation_Error =>
if Parent_Installed then
Restore_Env;
end if;
- Ignore_Pragma_SPARK_Mode := Save_IPSM;
- SPARK_Mode := Save_SM;
- SPARK_Mode_Pragma := Save_SMP;
- Style_Check := Save_Style_Check;
-
- if SPARK_Mode = On then
- Dynamic_Elaboration_Checks := False;
- end if;
+ Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP;
+ Restore_Ghost_Mode (Saved_GM);
+ Restore_SPARK_Mode (Saved_SM, Saved_SMP);
+ Style_Check := Saved_Style_Check;
end Analyze_Package_Instantiation;
--------------------------
-- Inline_Instance_Body --
--------------------------
+ -- WARNING: This routine manages SPARK regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- SPARK mode.
+
procedure Inline_Instance_Body
(N : Node_Id;
Gen_Unit : Entity_Id;
Gen_Comp : constant Entity_Id :=
Cunit_Entity (Get_Source_Unit (Gen_Unit));
- Save_SM : constant SPARK_Mode_Type := SPARK_Mode;
- Save_SMP : constant Node_Id := SPARK_Mode_Pragma;
- -- Save all SPARK_Mode-related attributes as removing enclosing scopes
- -- to provide a clean environment for analysis of the inlined body will
- -- eliminate any previously set SPARK_Mode.
+ Saved_SM : constant SPARK_Mode_Type := SPARK_Mode;
+ Saved_SMP : constant Node_Id := SPARK_Mode_Pragma;
+ -- Save the SPARK mode-related data to restore on exit. Removing
+ -- enclosing scopes to provide a clean environment for analysis of
+ -- the inlined body will eliminate any previously set SPARK_Mode.
- Scope_Stack_Depth : constant Int :=
+ Scope_Stack_Depth : constant Pos :=
Scope_Stack.Last - Scope_Stack.First + 1;
- Use_Clauses : array (1 .. Scope_Stack_Depth) of Node_Id;
- Instances : array (1 .. Scope_Stack_Depth) of Entity_Id;
Inner_Scopes : array (1 .. Scope_Stack_Depth) of Entity_Id;
- Curr_Scope : Entity_Id := Empty;
- List : Elist_Id;
- Num_Inner : Int := 0;
- Num_Scopes : Int := 0;
- N_Instances : Int := 0;
- Removed : Boolean := False;
- S : Entity_Id;
- Vis : Boolean;
+ Instances : array (1 .. Scope_Stack_Depth) of Entity_Id;
+ Use_Clauses : array (1 .. Scope_Stack_Depth) of Node_Id;
+
+ Curr_Scope : Entity_Id := Empty;
+ List : Elist_Id;
+ N_Instances : Nat := 0;
+ Num_Inner : Nat := 0;
+ Num_Scopes : Nat := 0;
+ Removed : Boolean := False;
+ S : Entity_Id;
+ Vis : Boolean;
begin
-- Case of generic unit defined in another unit. We must remove the
Version => Ada_Version,
Version_Pragma => Ada_Version_Pragma,
Warnings => Save_Warnings,
- SPARK_Mode => Save_SM,
- SPARK_Mode_Pragma => Save_SMP)),
+ SPARK_Mode => Saved_SM,
+ SPARK_Mode_Pragma => Saved_SMP)),
Inlined_Body => True);
Pop_Scope;
Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause :=
Use_Clauses (J);
Install_Use_Clauses (Use_Clauses (J));
- end loop;
+ end loop;
else
for J in reverse 1 .. Num_Scopes loop
Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause :=
Use_Clauses (J);
Install_Use_Clauses (Use_Clauses (J));
- end loop;
+ end loop;
end if;
-- Restore status of instances. If one of them is a body, make its
(N : Node_Id;
Subp : Entity_Id) return Boolean
is
+ function Is_Inlined_Or_Child_Of_Inlined (E : Entity_Id) return Boolean;
+ -- Return True if E is an inlined subprogram, an inlined renaming or a
+ -- subprogram nested in an inlined subprogram. The inlining machinery
+ -- totally disregards nested subprograms since it considers that they
+ -- will always be compiled if the parent is (see Inline.Is_Nested).
+
+ ------------------------------------
+ -- Is_Inlined_Or_Child_Of_Inlined --
+ ------------------------------------
+
+ function Is_Inlined_Or_Child_Of_Inlined (E : Entity_Id) return Boolean is
+ Scop : Entity_Id;
+
+ begin
+ if Is_Inlined (E) or else Is_Inlined (Alias (E)) then
+ return True;
+ end if;
+
+ Scop := Scope (E);
+ while Scop /= Standard_Standard loop
+ if Ekind (Scop) in Subprogram_Kind and then Is_Inlined (Scop) then
+ return True;
+ end if;
+
+ Scop := Scope (Scop);
+ end loop;
+
+ return False;
+ end Is_Inlined_Or_Child_Of_Inlined;
+
begin
- -- Must be inlined (or inlined renaming)
+ -- Must be in the main unit or inlined (or child of inlined)
- if (Is_In_Main_Unit (N)
- or else Is_Inlined (Subp)
- or else Is_Inlined (Alias (Subp)))
+ if (Is_In_Main_Unit (N) or else Is_Inlined_Or_Child_Of_Inlined (Subp))
-- Must be generating code or analyzing code in ASIS/GNATprove mode
and then not Is_Eliminated (Subp)
then
- Pending_Instantiations.Append
- ((Inst_Node => N,
- Act_Decl => Unit_Declaration_Node (Subp),
- Expander_Status => Expander_Active,
- Current_Sem_Unit => Current_Sem_Unit,
- Scope_Suppress => Scope_Suppress,
- Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
- Version => Ada_Version,
- Version_Pragma => Ada_Version_Pragma,
- Warnings => Save_Warnings,
- SPARK_Mode => SPARK_Mode,
- SPARK_Mode_Pragma => SPARK_Mode_Pragma));
+ Add_Pending_Instantiation (N, Unit_Declaration_Node (Subp));
return True;
-- Here if not inlined, or we ignore the inlining
-- Analyze_Subprogram_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_Subprogram_Instantiation
(N : Node_Id;
K : Entity_Kind)
-- aspects that appear in the generic. This renaming declaration is
-- inserted after the instance declaration which it renames.
- procedure Instantiate_Contract (Subp_Id : Entity_Id);
- -- Instantiate all source pragmas found in the contract of subprogram
- -- Subp_Id. The instantiated pragmas are added to list Renaming_List.
-
------------------------------------
-- Analyze_Instance_And_Renamings --
------------------------------------
Set_Debug_Info_Needed (Anon_Id);
Act_Decl_Id := New_Copy (Anon_Id);
- Set_Parent (Act_Decl_Id, Parent (Anon_Id));
- Set_Chars (Act_Decl_Id, Chars (Defining_Entity (N)));
- Set_Sloc (Act_Decl_Id, Sloc (Defining_Entity (N)));
+ Set_Parent (Act_Decl_Id, Parent (Anon_Id));
+ Set_Chars (Act_Decl_Id, Chars (Defining_Entity (N)));
+ Set_Sloc (Act_Decl_Id, Sloc (Defining_Entity (N)));
-- Subprogram instance comes from source only if generic does
Set_Comes_From_Source (Act_Decl_Id, Comes_From_Source (Gen_Unit));
- -- The signature may involve types that are not frozen yet, but the
- -- subprogram will be frozen at the point the wrapper package is
- -- frozen, so it does not need its own freeze node. In fact, if one
- -- is created, it might conflict with the freezing actions from the
- -- wrapper package.
-
- Set_Has_Delayed_Freeze (Anon_Id, False);
-
-- If the instance is a child unit, mark the Id accordingly. Mark
-- the anonymous entity as well, which is the real subprogram and
-- which is used when the instance appears in a context clause.
Set_Cunit_Entity (Current_Sem_Unit, Pack_Id);
end if;
- -- The instance is not a freezing point for the new subprogram
+ -- The instance is not a freezing point for the new subprogram.
+ -- The anonymous subprogram may have a freeze node, created for
+ -- some delayed aspects. This freeze node must not be inherited
+ -- by the visible subprogram entity.
- Set_Is_Frozen (Act_Decl_Id, False);
+ Set_Is_Frozen (Act_Decl_Id, False);
+ Set_Freeze_Node (Act_Decl_Id, Empty);
if Nkind (Defining_Entity (N)) = N_Defining_Operator_Symbol then
Valid_Operator_Definition (Act_Decl_Id);
end loop;
if No (Renaming_Decl) then
- Append (Unit_Renaming, Renaming_List);
+ Append (Unit_Renaming, Renaming_List);
end if;
end Build_Subprogram_Renaming;
- --------------------------
- -- Instantiate_Contract --
- --------------------------
-
- procedure Instantiate_Contract (Subp_Id : Entity_Id) is
- procedure Instantiate_Pragmas (First_Prag : Node_Id);
- -- Instantiate all contract-related source pragmas found in the list
- -- starting with pragma First_Prag. Each instantiated pragma is added
- -- to list Renaming_List.
-
- -------------------------
- -- Instantiate_Pragmas --
- -------------------------
-
- procedure Instantiate_Pragmas (First_Prag : Node_Id) is
- Inst_Prag : Node_Id;
- Prag : Node_Id;
-
- begin
- Prag := First_Prag;
- while Present (Prag) loop
- if Comes_From_Source (Prag)
- and then Nam_In (Pragma_Name (Prag), Name_Contract_Cases,
- Name_Depends,
- Name_Extensions_Visible,
- Name_Global,
- Name_Postcondition,
- Name_Precondition,
- Name_Test_Case)
- then
- Inst_Prag :=
- Copy_Generic_Node
- (Original_Node (Prag), Empty, Instantiating => True);
-
- Set_Analyzed (Inst_Prag, False);
- Append_To (Renaming_List, Inst_Prag);
- end if;
-
- Prag := Next_Pragma (Prag);
- end loop;
- end Instantiate_Pragmas;
-
- -- Local variables
-
- Items : constant Node_Id := Contract (Subp_Id);
-
- -- Start of processing for Instantiate_Contract
-
- begin
- if Present (Items) then
- Instantiate_Pragmas (Pre_Post_Conditions (Items));
- Instantiate_Pragmas (Contract_Test_Cases (Items));
- Instantiate_Pragmas (Classifications (Items));
- end if;
- end Instantiate_Contract;
-
-- Local variables
- Save_IPSM : constant Boolean := Ignore_Pragma_SPARK_Mode;
- -- Save flag Ignore_Pragma_SPARK_Mode for restore on exit
-
- Save_SM : constant SPARK_Mode_Type := SPARK_Mode;
- Save_SMP : constant Node_Id := SPARK_Mode_Pragma;
- -- Save the SPARK_Mode-related data for restore on exit
+ Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
+ 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
Vis_Prims_List : Elist_Id := No_Elist;
-- List of primitives made temporarily visible in the instantiation
Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
Gen_Unit := Entity (Gen_Id);
+ -- A subprogram instantiation is Ghost when it is subject to pragma
+ -- Ghost or the generic template is Ghost. Set the mode now to ensure
+ -- that any nodes generated during analysis and expansion are marked as
+ -- Ghost.
+
+ Mark_And_Set_Ghost_Instantiation (N, Gen_Unit);
+
Generate_Reference (Gen_Unit, Gen_Id);
if Nkind (Gen_Id) = N_Identifier
if Etype (Gen_Unit) = Any_Type then
Restore_Env;
- return;
+ goto Leave;
end if;
-- Verify that it is a generic subprogram of the right kind, and that
Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit);
else
- -- If the context of the instance is subject to SPARK_Mode "off",
- -- set the global flag which signals Analyze_Pragma to ignore all
- -- SPARK_Mode pragmas within the instance.
-
- if SPARK_Mode = Off then
- Ignore_Pragma_SPARK_Mode := True;
- end if;
-
Set_Entity (Gen_Id, Gen_Unit);
Set_Is_Instantiated (Gen_Unit);
Generic_Renamings.Set_Last (0);
Generic_Renamings_HTable.Reset;
- Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
+ Create_Instantiation_Source (N, Gen_Unit, S_Adjustment);
-- Copy original generic tree, to produce text for instantiation
end if;
Append (Act_Decl, Renaming_List);
- Instantiate_Contract (Gen_Unit);
- Build_Subprogram_Renaming;
+ -- Contract-related source pragmas that follow a generic subprogram
+ -- must be instantiated explicitly because they are not part of the
+ -- subprogram template.
+
+ Instantiate_Subprogram_Contract
+ (Original_Node (Gen_Decl), Renaming_List);
+
+ Build_Subprogram_Renaming;
Analyze_Instance_And_Renamings;
-- If the generic is marked Import (Intrinsic), then so is the
Set_Has_Pragma_Inline (Act_Decl_Id, Has_Pragma_Inline (Gen_Unit));
Set_Has_Pragma_Inline (Anon_Id, Has_Pragma_Inline (Gen_Unit));
+ -- Propagate No_Return if pragma applied to generic unit. This must
+ -- be done explicitly because pragma does not appear in generic
+ -- declaration (unlike the aspect case).
+
+ if No_Return (Gen_Unit) then
+ Set_No_Return (Act_Decl_Id);
+ Set_No_Return (Anon_Id);
+ end if;
+
Set_Has_Pragma_Inline_Always
(Act_Decl_Id, Has_Pragma_Inline_Always (Gen_Unit));
Set_Has_Pragma_Inline_Always
(Anon_Id, Has_Pragma_Inline_Always (Gen_Unit));
+ -- If the context of the instance is subject to SPARK_Mode "off" or
+ -- the annotation is altogether missing, set the global flag which
+ -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within
+ -- the instance.
+
+ if SPARK_Mode /= On then
+ Ignore_SPARK_Mode_Pragmas_In_Instance := True;
+
+ -- Mark both the instance spec and the anonymous package 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 (Act_Decl_Id);
+ Set_Ignore_SPARK_Mode_Pragmas (Anon_Id);
+ end if;
+
if not Is_Intrinsic_Subprogram (Gen_Unit) then
Check_Elab_Instantiation (N);
end if;
Error_Msg_NE
("access parameter& is controlling,", N, Formal);
Error_Msg_NE
- ("\corresponding parameter of & must be "
- & "explicitly null-excluding", N, Gen_Id);
+ ("\corresponding parameter of & must be explicitly "
+ & "null-excluding", N, Gen_Id);
end if;
Next_Formal (Formal);
if Need_Subprogram_Instance_Body (N, Act_Decl_Id) then
Check_Forward_Instantiation (Gen_Decl);
- -- The wrapper package is always delayed, because it does not
- -- constitute a freeze point, but to insure that the freeze
- -- node is placed properly, it is created directly when
- -- instantiating the body (otherwise the freeze node might
- -- appear to early for nested instantiations).
+ -- The wrapper package is always delayed, because it does not
+ -- constitute a freeze point, but to insure that the freeze node
+ -- is placed properly, it is created directly when instantiating
+ -- the body (otherwise the freeze node might appear to early for
+ -- nested instantiations). For ASIS purposes, indicate that the
+ -- wrapper package has replaced the instantiation node.
elsif Nkind (Parent (N)) = N_Compilation_Unit then
-
- -- For ASIS purposes, indicate that the wrapper package has
- -- replaced the instantiation node.
-
Rewrite (N, Unit (Parent (N)));
Set_Unit (Parent (N), N);
end if;
- elsif Nkind (Parent (N)) = N_Compilation_Unit then
-
- -- Replace instance node for library-level instantiations of
- -- intrinsic subprograms, for ASIS use.
+ -- Replace instance node for library-level instantiations of
+ -- intrinsic subprograms, for ASIS use.
- Rewrite (N, Unit (Parent (N)));
- Set_Unit (Parent (N), N);
+ elsif Nkind (Parent (N)) = N_Compilation_Unit then
+ Rewrite (N, Unit (Parent (N)));
+ Set_Unit (Parent (N), N);
end if;
if Parent_Installed then
Env_Installed := False;
Generic_Renamings.Set_Last (0);
Generic_Renamings_HTable.Reset;
-
- Ignore_Pragma_SPARK_Mode := Save_IPSM;
- SPARK_Mode := Save_SM;
- SPARK_Mode_Pragma := Save_SMP;
-
- if SPARK_Mode = On then
- Dynamic_Elaboration_Checks := False;
- end if;
-
end if;
<<Leave>>
Analyze_Aspect_Specifications (N, Act_Decl_Id);
end if;
+ Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP;
+ Restore_Ghost_Mode (Saved_GM);
+ Restore_SPARK_Mode (Saved_SM, Saved_SMP);
+
exception
when Instantiation_Error =>
if Parent_Installed then
Restore_Env;
end if;
- Ignore_Pragma_SPARK_Mode := Save_IPSM;
- SPARK_Mode := Save_SM;
- SPARK_Mode_Pragma := Save_SMP;
-
- if SPARK_Mode = On then
- Dynamic_Elaboration_Checks := False;
- end if;
+ Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP;
+ Restore_Ghost_Mode (Saved_GM);
+ Restore_SPARK_Mode (Saved_SM, Saved_SMP);
end Analyze_Subprogram_Instantiation;
-------------------------
Assoc := Associated_Node (Assoc);
end loop;
- -- Follow and additional link in case the final node was rewritten.
+ -- Follow an additional link in case the final node was rewritten.
-- This can only happen with nested generic units.
if (Nkind (Assoc) = N_Identifier or else Nkind (Assoc) in N_Op)
-- An additional special case: an unconstrained type in an object
-- declaration may have been rewritten as a local subtype constrained
-- by the expression in the declaration. We need to recover the
- -- original entity which may be global.
+ -- original entity, which may be global.
if Present (Original_Node (Assoc))
and then Nkind (Parent (N)) = N_Object_Declaration
Decl : Node_Id;
Expr : Node_Id;
+ pragma Warnings (Off, Expr);
F1, F2 : Entity_Id;
Func : Entity_Id;
Op_Name : Name_Id;
(Formal_Pack : Entity_Id;
Actual_Pack : Entity_Id)
is
- E1 : Entity_Id := First_Entity (Actual_Pack);
- E2 : Entity_Id := First_Entity (Formal_Pack);
+ E1 : Entity_Id := First_Entity (Actual_Pack);
+ E2 : Entity_Id := First_Entity (Formal_Pack);
+ Prev_E1 : Entity_Id;
Expr1 : Node_Id;
Expr2 : Node_Id;
-- same entity we may have to traverse several definitions to recover
-- the ultimate entity that they refer to.
+ function Same_Instantiated_Function (E1, E2 : Entity_Id) return Boolean;
+ -- The formal and the actual must be identical, but if both are
+ -- given by attributes they end up renaming different generated bodies,
+ -- and we must verify that the attributes themselves match.
+
function Same_Instantiated_Variable (E1, E2 : Entity_Id) return Boolean;
-- Similarly, if the formal comes from a nested formal package, the
-- actual may designate the formal through multiple renamings, which
--------------------
procedure Check_Mismatch (B : Boolean) is
- Kind : constant Node_Kind := Nkind (Parent (E2));
+ -- A Formal_Type_Declaration for a derived private type is rewritten
+ -- as a private extension decl. (see Analyze_Formal_Derived_Type),
+ -- which is why we examine the original node.
+
+ Kind : constant Node_Kind := Nkind (Original_Node (Parent (E2)));
begin
if Kind = N_Formal_Type_Declaration then
return False;
elsif Is_Entity_Name (Constant_Value (Ent)) then
- if Entity (Constant_Value (Ent)) = E1 then
+ if Entity (Constant_Value (Ent)) = E1 then
return True;
else
Ent := Entity (Constant_Value (Ent));
return False;
end Same_Instantiated_Constant;
+ --------------------------------
+ -- Same_Instantiated_Function --
+ --------------------------------
+
+ function Same_Instantiated_Function
+ (E1, E2 : Entity_Id) return Boolean
+ is
+ U1, U2 : Node_Id;
+ begin
+ if Alias (E1) = Alias (E2) then
+ return True;
+
+ elsif Present (Alias (E2)) then
+ U1 := Original_Node (Unit_Declaration_Node (E1));
+ U2 := Original_Node (Unit_Declaration_Node (Alias (E2)));
+
+ return Nkind (U1) = N_Subprogram_Renaming_Declaration
+ and then Nkind (Name (U1)) = N_Attribute_Reference
+
+ and then Nkind (U2) = N_Subprogram_Renaming_Declaration
+ and then Nkind (Name (U2)) = N_Attribute_Reference
+
+ and then
+ Attribute_Name (Name (U1)) = Attribute_Name (Name (U2));
+ else
+ return False;
+ end if;
+ end Same_Instantiated_Function;
+
--------------------------------
-- Same_Instantiated_Variable --
--------------------------------
-- Start of processing for Check_Formal_Package_Instance
begin
+ Prev_E1 := E1;
while Present (E1) and then Present (E2) loop
exit when Ekind (E1) = E_Package
and then Renamed_Entity (E1) = Renamed_Entity (Actual_Pack);
and then not Comes_From_Source (E1)
and then Chars (E1) /= Chars (E2)
then
- while Present (E1) and then Chars (E1) /= Chars (E2) loop
+ while Present (E1) and then Chars (E1) /= Chars (E2) loop
Next_Entity (E1);
end loop;
end if;
if No (E1) then
return;
+ -- Entities may be declared without full declaration, such as
+ -- itypes and predefined operators (concatenation for arrays, eg).
+ -- Skip it and keep the formal entity to find a later match for it.
+
+ elsif No (Parent (E2)) and then Ekind (E1) /= Ekind (E2) then
+ E1 := Prev_E1;
+ goto Next_E;
+
-- If the formal entity comes from a formal declaration, it was
-- defaulted in the formal package, and no check is needed on it.
- elsif Nkind (Parent (E2)) = N_Formal_Object_Declaration then
+ elsif Nkind_In (Original_Node (Parent (E2)),
+ N_Formal_Object_Declaration,
+ N_Formal_Type_Declaration)
+ then
+ -- If the formal is a tagged type the corresponding class-wide
+ -- type has been generated as well, and it must be skipped.
+
+ if Is_Type (E2) and then Is_Tagged_Type (E2) then
+ Next_Entity (E2);
+ end if;
+
goto Next_E;
-- Ditto for defaulted formal subprograms.
else
Check_Mismatch
- (Ekind (E2) /= Ekind (E1) or else (Alias (E1)) /= Alias (E2));
+ (Ekind (E2) /= Ekind (E1)
+ or else not Same_Instantiated_Function (E1, E2));
end if;
else
end if;
<<Next_E>>
+ Prev_E1 := E1;
Next_Entity (E1);
Next_Entity (E2);
end loop;
---------------------------
procedure Check_Formal_Packages (P_Id : Entity_Id) is
- E : Entity_Id;
- Formal_P : Entity_Id;
+ E : Entity_Id;
+ Formal_P : Entity_Id;
+ Formal_Decl : Node_Id;
begin
-- Iterate through the declarations in the instance, looking for package
elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
null;
- elsif not Box_Present (Parent (Associated_Formal_Package (E))) then
- Formal_P := Next_Entity (E);
- Check_Formal_Package_Instance (Formal_P, E);
+ else
+ Formal_Decl := Parent (Associated_Formal_Package (E));
+
+ -- Nothing to check if the formal has a box or an others_clause
+ -- (necessarily with a box).
+
+ if Box_Present (Formal_Decl) then
+ null;
+
+ elsif Nkind (First (Generic_Associations (Formal_Decl))) =
+ N_Others_Choice
+ then
+ -- The internal validating package was generated but formal
+ -- and instance are known to be compatible.
+
+ Formal_P := Next_Entity (E);
+ Remove (Unit_Declaration_Node (Formal_P));
+
+ else
+ Formal_P := Next_Entity (E);
+ Check_Formal_Package_Instance (Formal_P, E);
- -- After checking, remove the internal validating package. It
- -- is only needed for semantic checks, and as it may contain
- -- generic formal declarations it should not reach gigi.
+ -- After checking, remove the internal validating package.
+ -- It is only needed for semantic checks, and as it may
+ -- contain generic formal declarations it should not reach
+ -- gigi.
- Remove (Unit_Declaration_Node (Formal_P));
+ Remove (Unit_Declaration_Node (Formal_P));
+ end if;
end if;
end if;
Set_Is_Generic_Actual_Type (E, True);
Set_Is_Hidden (E, False);
- Set_Is_Potentially_Use_Visible (E,
- In_Use (Instance));
+ Set_Is_Potentially_Use_Visible (E, In_Use (Instance));
-- We constructed the generic actual type as a subtype of the
-- supplied type. This means that it normally would not inherit
elsif Nkind (Gen_Id) = N_Expanded_Name then
- -- Entity already present, analyze prefix, whose meaning may be
- -- an instance in the current context. If it is an instance of
- -- a relative within another, the proper parent may still have
- -- to be installed, if they are not of the same generation.
+ -- Entity already present, analyze prefix, whose meaning may be an
+ -- instance in the current context. If it is an instance of a
+ -- relative within another, the proper parent may still have to be
+ -- installed, if they are not of the same generation.
Analyze (Prefix (Gen_Id));
- -- In the unlikely case that a local declaration hides the name
- -- of the parent package, locate it on the homonym chain. If the
- -- context is an instance of the parent, the renaming entity is
- -- flagged as such.
+ -- Prevent cascaded errors
+
+ if Etype (Prefix (Gen_Id)) = Any_Type then
+ return;
+ end if;
+
+ -- In the unlikely case that a local declaration hides the name of
+ -- the parent package, locate it on the homonym chain. If the context
+ -- is an instance of the parent, the renaming entity is flagged as
+ -- such.
Inst_Par := Entity (Prefix (Gen_Id));
while Present (Inst_Par)
----------------------
procedure Copy_Descendants is
-
use Atree.Unchecked_Access;
-- This code section is part of the implementation of an untyped
-- tree traversal, so it needs direct access to node fields.
function In_Defining_Unit_Name (Nam : Node_Id) return Boolean is
begin
- return Present (Parent (Nam))
- and then (Nkind (Parent (Nam)) = N_Defining_Program_Unit_Name
- or else
- (Nkind (Parent (Nam)) = N_Expanded_Name
- and then In_Defining_Unit_Name (Parent (Nam))));
+ return
+ Present (Parent (Nam))
+ and then (Nkind (Parent (Nam)) = N_Defining_Program_Unit_Name
+ or else
+ (Nkind (Parent (Nam)) = N_Expanded_Name
+ and then In_Defining_Unit_Name (Parent (Nam))));
end In_Defining_Unit_Name;
-- Start of processing for Copy_Generic_Node
(New_N, Copy_Generic_List (Aspect_Specifications (N), Parent_Id));
end if;
- if Instantiating then
+ -- If we are instantiating, we want to adjust the sloc based on the
+ -- current S_Adjustment. However, if this is the root node of a subunit,
+ -- we need to defer that adjustment to below (see "elsif Instantiating
+ -- and Was_Stub"), so it comes after Create_Instantiation_Source has
+ -- computed the adjustment.
+
+ if Instantiating
+ and then not (Nkind (N) in N_Proper_Body
+ and then Was_Originally_Stub (N))
+ then
Adjust_Instantiation_Sloc (New_N, S_Adjustment);
end if;
Set_Parent (New_N, Parent_Id);
end if;
- -- If defining identifier, then all fields have been copied already
-
- if Nkind (New_N) in N_Entity then
- null;
-
-- Special casing for identifiers and other entity names and operators
- elsif Nkind_In (New_N, N_Identifier,
- N_Character_Literal,
- N_Expanded_Name,
- N_Operator_Symbol)
+ if Nkind_In (New_N, N_Character_Literal,
+ N_Expanded_Name,
+ N_Identifier,
+ N_Operator_Symbol)
or else Nkind (New_N) in N_Op
then
if not Instantiating then
Set_Entity (New_N, Entity (Assoc));
Check_Private_View (N);
+ -- The node is a reference to a global type and acts as the
+ -- subtype mark of a qualified expression created in order
+ -- to aid resolution of accidental overloading in instances.
+ -- Since N is a reference to a type, the Associated_Node of
+ -- N denotes an entity rather than another identifier. See
+ -- Qualify_Universal_Operands for details.
+
+ elsif Nkind (N) = N_Identifier
+ and then Nkind (Parent (N)) = N_Qualified_Expression
+ and then Subtype_Mark (Parent (N)) = N
+ and then Is_Qualified_Universal_Literal (Parent (N))
+ then
+ Set_Entity (New_N, Assoc);
+
-- The name in the call may be a selected component if the
-- call has not been analyzed yet, as may be the case for
-- pre/post conditions in a generic unit.
Set_Selector_Name (New_N,
Copy_Generic_Node (Selector_Name (N), New_N, Instantiating));
- -- For operators, we must copy the right operand
+ -- For operators, copy the operands
elsif Nkind (N) in N_Op then
- Set_Right_Opnd (New_N,
- Copy_Generic_Node (Right_Opnd (N), New_N, Instantiating));
-
- -- And for binary operators, the left operand as well
-
if Nkind (N) in N_Binary_Op then
Set_Left_Opnd (New_N,
Copy_Generic_Node (Left_Opnd (N), New_N, Instantiating));
end if;
+
+ Set_Right_Opnd (New_N,
+ Copy_Generic_Node (Right_Opnd (N), New_N, Instantiating));
+ end if;
+
+ -- Establish a link between an entity from the generic template and the
+ -- corresponding entity in the generic copy to be analyzed.
+
+ elsif Nkind (N) in N_Entity then
+ if not Instantiating then
+ Set_Associated_Entity (N, New_N);
end if;
+ -- Clear any existing link the copy may inherit from the replicated
+ -- generic template entity.
+
+ Set_Associated_Entity (New_N, Empty);
+
-- Special casing for stubs
elsif Nkind (N) in N_Body_Stub then
Copy_Generic_List (Context_Items (N), New_N));
Set_Unit (New_N,
- Copy_Generic_Node (Unit (N), New_N, False));
+ Copy_Generic_Node (Unit (N), New_N, Instantiating => False));
Set_First_Inlined_Subprogram (New_N,
Copy_Generic_Node
- (First_Inlined_Subprogram (N), New_N, False));
+ (First_Inlined_Subprogram (N), New_N, Instantiating => False));
- Set_Aux_Decls_Node (New_N,
- Copy_Generic_Node (Aux_Decls_Node (N), New_N, False));
+ Set_Aux_Decls_Node
+ (New_N,
+ Copy_Generic_Node
+ (Aux_Decls_Node (N), New_N, Instantiating => False));
-- For an assignment node, the assignment is known to be semantically
-- legal if we are instantiating the template. This avoids incorrect
elsif Nkind (N) in N_Proper_Body then
declare
Save_Adjustment : constant Sloc_Adjustment := S_Adjustment;
-
begin
if Instantiating and then Was_Originally_Stub (N) then
Create_Instantiation_Source
(Instantiation_Node,
Defining_Entity (N),
- False,
S_Adjustment);
+
+ Adjust_Instantiation_Sloc (New_N, S_Adjustment);
end if;
-- Now copy the fields of the proper body, using the new
Copy_Descendants;
- -- Restore the original adjustment factor in case changed
+ -- Restore the original adjustment factor
S_Adjustment := Save_Adjustment;
end;
- -- Don't copy Ident or Comment pragmas, since the comment belongs to the
- -- generic unit, not to the instantiating unit.
-
elsif Nkind (N) = N_Pragma and then Instantiating then
- declare
- Prag_Id : constant Pragma_Id := Get_Pragma_Id (N);
- begin
- if Prag_Id = Pragma_Ident or else Prag_Id = Pragma_Comment then
- New_N := Make_Null_Statement (Sloc (N));
- else
- Copy_Descendants;
- end if;
- end;
+
+ -- Do not copy Comment or Ident pragmas their content is relevant to
+ -- the generic unit, not to the instantiating unit.
+
+ if Nam_In (Pragma_Name_Unmapped (N), Name_Comment, Name_Ident) then
+ New_N := Make_Null_Statement (Sloc (N));
+
+ -- Do not copy pragmas generated from aspects because the pragmas do
+ -- not carry any semantic information, plus they will be regenerated
+ -- in the instance.
+
+ -- However, generating C we need to copy them since postconditions
+ -- are inlined by the front end, and the front-end inlining machinery
+ -- relies on this routine to perform inlining.
+
+ elsif From_Aspect_Specification (N)
+ and then not Modify_Tree_For_C
+ then
+ New_N := Make_Null_Statement (Sloc (N));
+
+ else
+ Copy_Descendants;
+ end if;
elsif Nkind_In (N, N_Integer_Literal, N_Real_Literal) then
end if;
end if;
+ -- Propagate dimensions if present, so that they are reflected in the
+ -- instance.
+
+ if Nkind (N) in N_Has_Etype
+ and then (Nkind (N) in N_Op or else Is_Entity_Name (N))
+ and then Present (Etype (N))
+ and then Is_Floating_Point_Type (Etype (N))
+ and then Has_Dimension_System (Etype (N))
+ then
+ Copy_Dimensions (N, New_N);
+ end if;
+
return New_N;
end Copy_Generic_Node;
begin
E1 := First_Entity (P);
- while Present (E1) and then E1 /= Instance loop
+ while Present (E1) and then E1 /= Instance loop
if Ekind (E1) = E_Package
and then Nkind (Parent (E1)) = N_Package_Renaming_Declaration
then
if Renamed_Object (E1) = Pack then
return True;
- elsif E1 = P or else Renamed_Object (E1) = P then
+ elsif E1 = P or else Renamed_Object (E1) = P then
return False;
elsif Is_Actual_Of_Previous_Formal (E1) then
end loop;
-- Expanded code usually shares the source location of the original
- -- construct it was generated for. This however may not necessarely
+ -- construct it was generated for. This however may not necessarily
-- reflect the true location of the code within the tree.
-- Before comparing the slocs of the two nodes, make sure that we are
end if;
-- At this point either both nodes came from source or we approximated
- -- their source locations through neighbouring source statements.
+ -- their source locations through neighboring source statements.
T1 := Top_Level_Location (Sloc (P1));
T2 := Top_Level_Location (Sloc (P2));
return Freeze_Node (Id);
end Package_Freeze_Node;
- -- Start of processing of Freeze_Subprogram_Body
+ -- Start of processing for Freeze_Subprogram_Body
begin
-- If the instance and the generic body appear within the same unit, and
if Scop = Par_I then
null;
- -- If the next node is a source body we must freeze in
+ -- If the next node is a source body we must freeze in
-- the current scope as well.
elsif Present (Next (N))
Gen_Body : Node_Id;
Gen_Decl : Node_Id)
is
- Act_Id : constant Entity_Id := Corresponding_Spec (Act_Body);
- Act_Unit : constant Node_Id := Unit (Cunit (Get_Source_Unit (N)));
- Gen_Id : constant Entity_Id := Corresponding_Spec (Gen_Body);
- Par : constant Entity_Id := Scope (Gen_Id);
- Gen_Unit : constant Node_Id :=
- Unit (Cunit (Get_Source_Unit (Gen_Decl)));
- Orig_Body : Node_Id := Gen_Body;
- F_Node : Node_Id;
- Body_Unit : Node_Id;
-
- Must_Delay : Boolean;
-
- function In_Same_Enclosing_Subp return Boolean;
- -- Check whether instance and generic body are within same subprogram.
+ function In_Same_Scope (Gen_Id, Act_Id : Node_Id) return Boolean;
+ -- Check if the generic definition and the instantiation come from
+ -- a common scope, in which case the instance must be frozen after
+ -- the generic body.
- function True_Sloc (N : Node_Id) return Source_Ptr;
+ function True_Sloc (N, Act_Unit : Node_Id) return Source_Ptr;
-- If the instance is nested inside a generic unit, the Sloc of the
-- instance indicates the place of the original definition, not the
-- point of the current enclosing instance. Pending a better usage of
-- origin of a node by finding the maximum sloc of any ancestor node.
-- Why is this not equivalent to Top_Level_Location ???
- ----------------------------
- -- In_Same_Enclosing_Subp --
- ----------------------------
+ -------------------
+ -- In_Same_Scope --
+ -------------------
- function In_Same_Enclosing_Subp return Boolean is
- Scop : Entity_Id;
- Subp : Entity_Id;
+ function In_Same_Scope (Gen_Id, Act_Id : Node_Id) return Boolean is
+ Act_Scop : Entity_Id := Scope (Act_Id);
+ Gen_Scop : Entity_Id := Scope (Gen_Id);
begin
- Scop := Scope (Act_Id);
- while Scop /= Standard_Standard
- and then not Is_Overloadable (Scop)
+ while Act_Scop /= Standard_Standard
+ and then Gen_Scop /= Standard_Standard
loop
- Scop := Scope (Scop);
- end loop;
-
- if Scop = Standard_Standard then
- return False;
- else
- Subp := Scop;
- end if;
-
- Scop := Scope (Gen_Id);
- while Scop /= Standard_Standard loop
- if Scop = Subp then
+ if Act_Scop = Gen_Scop then
return True;
- else
- Scop := Scope (Scop);
end if;
+
+ Act_Scop := Scope (Act_Scop);
+ Gen_Scop := Scope (Gen_Scop);
end loop;
return False;
- end In_Same_Enclosing_Subp;
+ end In_Same_Scope;
---------------
-- True_Sloc --
---------------
- function True_Sloc (N : Node_Id) return Source_Ptr is
- Res : Source_Ptr;
+ function True_Sloc (N, Act_Unit : Node_Id) return Source_Ptr is
N1 : Node_Id;
+ Res : Source_Ptr;
begin
Res := Sloc (N);
- N1 := N;
+ N1 := N;
while Present (N1) and then N1 /= Act_Unit loop
if Sloc (N1) > Res then
Res := Sloc (N1);
return Res;
end True_Sloc;
+ Act_Id : constant Entity_Id := Corresponding_Spec (Act_Body);
+ Act_Unit : constant Node_Id := Unit (Cunit (Get_Source_Unit (N)));
+ Gen_Id : constant Entity_Id := Corresponding_Spec (Gen_Body);
+ Par : constant Entity_Id := Scope (Gen_Id);
+ Gen_Unit : constant Node_Id :=
+ Unit (Cunit (Get_Source_Unit (Gen_Decl)));
+
+ Body_Unit : Node_Id;
+ F_Node : Node_Id;
+ Must_Delay : Boolean;
+ Orig_Body : Node_Id := Gen_Body;
+
-- Start of processing for Install_Body
begin
+ -- Handle first the case of an instance with incomplete actual types.
+ -- The instance body cannot be placed after the declaration because
+ -- full views have not been seen yet. Any use of the non-limited views
+ -- in the instance body requires the presence of a regular with_clause
+ -- in the enclosing unit, and will fail if this with_clause is missing.
+ -- We place the instance body at the beginning of the enclosing body,
+ -- which is the unit being compiled. The freeze node for the instance
+ -- is then placed after the instance body.
+
+ if not Is_Empty_Elmt_List (Incomplete_Actuals (Act_Id))
+ and then Expander_Active
+ and then Ekind (Scope (Act_Id)) = E_Package
+ then
+ declare
+ Scop : constant Entity_Id := Scope (Act_Id);
+ Body_Id : constant Node_Id :=
+ Corresponding_Body (Unit_Declaration_Node (Scop));
+
+ begin
+ Ensure_Freeze_Node (Act_Id);
+ F_Node := Freeze_Node (Act_Id);
+ if Present (Body_Id) then
+ Set_Is_Frozen (Act_Id, False);
+ Prepend (Act_Body, Declarations (Parent (Body_Id)));
+ if Is_List_Member (F_Node) then
+ Remove (F_Node);
+ end if;
+
+ Insert_After (Act_Body, F_Node);
+ end if;
+ end;
+ return;
+ end if;
+
-- If the body is a subunit, the freeze point is the corresponding stub
-- in the current compilation, not the subunit itself.
Must_Delay :=
(Gen_Unit = Act_Unit
- and then (Nkind_In (Gen_Unit, N_Package_Declaration,
- N_Generic_Package_Declaration)
+ and then (Nkind_In (Gen_Unit, N_Generic_Package_Declaration,
+ N_Package_Declaration)
or else (Gen_Unit = Body_Unit
- and then True_Sloc (N) < Sloc (Orig_Body)))
- and then Is_In_Main_Unit (Gen_Unit)
- and then (Scope (Act_Id) = Scope (Gen_Id)
- or else In_Same_Enclosing_Subp));
+ and then True_Sloc (N, Act_Unit)
+ < Sloc (Orig_Body)))
+ and then Is_In_Main_Unit (Original_Node (Gen_Unit))
+ and then In_Same_Scope (Gen_Id, Act_Id));
-- If this is an early instantiation, the freeze node is placed after
-- the generic body. Otherwise, if the generic appears in an instance,
-- no one-to-one correspondence between the two lists (for example,
-- the actual may include subtypes, itypes, and inherited primitive
-- operations, interspersed among the renaming declarations for the
- -- actuals) . We retrieve the corresponding actual by name because each
+ -- actuals). We retrieve the corresponding actual by name because each
-- actual has the same name as the formal, and they do appear in the
-- same order.
function Get_Formal_Entity (N : Node_Id) return Entity_Id;
- -- Retrieve entity of defining entity of generic formal parameter.
+ -- Retrieve entity of defining entity of generic formal parameter.
-- Only the declarations of formals need to be considered when
-- linking them to actuals, but the declarative list may include
-- internal entities generated during analysis, and those are ignored.
begin
case Nkind (Original_Node (F)) is
- when N_Formal_Object_Declaration |
- N_Formal_Type_Declaration =>
+ when N_Formal_Object_Declaration
+ | N_Formal_Type_Declaration
+ =>
Formal_Ent := Defining_Identifier (F);
while Chars (Act) /= Chars (Formal_Ent) loop
Next_Entity (Act);
end loop;
- when N_Formal_Subprogram_Declaration |
- N_Formal_Package_Declaration |
- N_Package_Declaration |
- N_Generic_Package_Declaration =>
+ when N_Formal_Package_Declaration
+ | N_Formal_Subprogram_Declaration
+ | N_Generic_Package_Declaration
+ | N_Package_Declaration
+ =>
Formal_Ent := Defining_Entity (F);
while Chars (Act) /= Chars (Formal_Ent) loop
Actual := Entity (Name (Original_Node (Formal_Node)));
- -- The actual in the formal package declaration may be a
+ -- The actual in the formal package declaration may be a
-- renamed generic package, in which case we want to retrieve
-- the original generic in order to traverse its formal part.
Kind : constant Node_Kind := Nkind (Original_Node (N));
begin
case Kind is
- when N_Formal_Object_Declaration =>
+ when N_Formal_Object_Declaration =>
return Defining_Identifier (N);
- when N_Formal_Type_Declaration =>
+ when N_Formal_Type_Declaration =>
return Defining_Identifier (N);
when N_Formal_Subprogram_Declaration =>
return Defining_Unit_Name (Specification (N));
- when N_Formal_Package_Declaration =>
+ when N_Formal_Package_Declaration =>
return Defining_Identifier (Original_Node (N));
- when N_Generic_Package_Declaration =>
+ when N_Generic_Package_Declaration =>
return Defining_Identifier (Original_Node (N));
-- All other declarations are introduced by semantic analysis and
Analyze (Actual);
if not Is_Entity_Name (Actual)
- or else Ekind (Entity (Actual)) /= E_Package
+ or else Ekind (Entity (Actual)) /= E_Package
then
Error_Msg_N
("expect package instance to instantiate formal", Actual);
("actual must exclude null to match generic formal#", Actual);
end if;
- -- An effectively volatile object cannot be used as an actual in
- -- a generic instance. The following check is only relevant when
- -- SPARK_Mode is on as it is not a standard Ada legality rule.
+ -- An effectively volatile object cannot be used as an actual in a
+ -- generic instantiation (SPARK RM 7.1.3(7)). The following check is
+ -- relevant only when SPARK_Mode is on as it is not a standard Ada
+ -- legality rule, and also verifies that the actual is an object.
if SPARK_Mode = On
and then Present (Actual)
+ and then Is_Object_Reference (Actual)
and then Is_Effectively_Volatile_Object (Actual)
then
Error_Msg_N
- ("volatile object cannot act as actual in generic instantiation "
- & "(SPARK RM 7.1.3(8))", Actual);
+ ("volatile object cannot act as actual in generic instantiation",
+ Actual);
end if;
return List;
-- Instantiate_Package_Body --
------------------------------
+ -- 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 Instantiate_Package_Body
(Body_Info : Pending_Body_Info;
Inlined_Body : Boolean := False;
Body_Optional : Boolean := False)
is
Act_Decl : constant Node_Id := Body_Info.Act_Decl;
+ Act_Decl_Id : constant Entity_Id := Defining_Entity (Act_Decl);
+ Act_Spec : constant Node_Id := Specification (Act_Decl);
Inst_Node : constant Node_Id := Body_Info.Inst_Node;
- Loc : constant Source_Ptr := Sloc (Inst_Node);
-
Gen_Id : constant Node_Id := Name (Inst_Node);
Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node);
Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit);
- Act_Spec : constant Node_Id := Specification (Act_Decl);
- Act_Decl_Id : constant Entity_Id := Defining_Entity (Act_Spec);
-
- Act_Body_Name : Node_Id;
- Gen_Body : Node_Id;
- Gen_Body_Id : Node_Id;
- Act_Body : Node_Id;
- Act_Body_Id : Entity_Id;
-
- Parent_Installed : Boolean := False;
- Save_Style_Check : constant Boolean := Style_Check;
-
- Par_Ent : Entity_Id := Empty;
- Par_Vis : Boolean := False;
+ Loc : constant Source_Ptr := Sloc (Inst_Node);
- Vis_Prims_List : Elist_Id := No_Elist;
- -- List of primitives made temporarily visible in the instantiation
- -- to match the visibility of the formal type
+ Saved_ISMP : constant Boolean :=
+ Ignore_SPARK_Mode_Pragmas_In_Instance;
+ Saved_Style_Check : constant Boolean := Style_Check;
procedure Check_Initialized_Types;
-- In a generic package body, an entity of a generic private type may
end loop;
end Check_Initialized_Types;
+ -- Local variables
+
+ Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
+ 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
+
+ Act_Body : Node_Id;
+ Act_Body_Id : Entity_Id;
+ Act_Body_Name : Node_Id;
+ Gen_Body : Node_Id;
+ Gen_Body_Id : Node_Id;
+ Par_Ent : Entity_Id := Empty;
+ Par_Vis : Boolean := False;
+ Parent_Installed : Boolean := False;
+
+ 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 Instantiate_Package_Body
begin
return;
end if;
+ -- The package being instantiated may be subject to pragma Ghost. Set
+ -- the mode now to ensure that any nodes generated during instantiation
+ -- are properly marked as Ghost.
+
+ Set_Ghost_Mode (Act_Decl_Id);
+
Expander_Mode_Save_And_Set (Body_Info.Expander_Status);
-- Re-establish the state of information on which checks are suppressed.
-- This information was set in Body_Info at the point of instantiation,
-- and now we restore it so that the instance is compiled using the
- -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01).
+ -- check status at the instantiation (RM 11.5(7.2/2), AI95-00224-01).
Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top;
Scope_Suppress := Body_Info.Scope_Suppress;
Opt.Ada_Version := Body_Info.Version;
Opt.Ada_Version_Pragma := Body_Info.Version_Pragma;
Restore_Warnings (Body_Info.Warnings);
- Opt.SPARK_Mode := Body_Info.SPARK_Mode;
- Opt.SPARK_Mode_Pragma := Body_Info.SPARK_Mode_Pragma;
+
+ -- Install the SPARK mode which applies to the package body
+
+ Install_SPARK_Mode (Body_Info.SPARK_Mode, Body_Info.SPARK_Mode_Pragma);
if No (Gen_Body_Id) then
if not Unit_Requires_Body (Defining_Entity (Gen_Decl))
and then Body_Optional
then
- return;
+ goto Leave;
else
Load_Parent_Of_Generic
(Inst_Node, Specification (Gen_Decl), Body_Optional);
end if;
-- Establish global variable for sloc adjustment and for error recovery
+ -- In the case of an instance body for an instantiation with actuals
+ -- from a limited view, the instance body is placed at the beginning
+ -- of the enclosing package body: use the body entity as the source
+ -- location for nodes of the instance body.
- Instantiation_Node := Inst_Node;
+ if not Is_Empty_Elmt_List (Incomplete_Actuals (Act_Decl_Id)) then
+ declare
+ Scop : constant Entity_Id := Scope (Act_Decl_Id);
+ Body_Id : constant Node_Id :=
+ Corresponding_Body (Unit_Declaration_Node (Scop));
+
+ begin
+ Instantiation_Node := Body_Id;
+ end;
+ else
+ Instantiation_Node := Inst_Node;
+ end if;
if Present (Gen_Body_Id) then
Save_Env (Gen_Unit, Act_Decl_Id);
Style_Check := False;
- Current_Sem_Unit := Body_Info.Current_Sem_Unit;
+ -- If the context of the instance is subject to SPARK_Mode "off", the
+ -- annotation is missing, or the body is instantiated at a later pass
+ -- and its spec ignored SPARK_Mode pragma, set the global flag which
+ -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within the
+ -- instance.
+
+ if SPARK_Mode /= On
+ or else Ignore_SPARK_Mode_Pragmas (Act_Decl_Id)
+ then
+ Ignore_SPARK_Mode_Pragmas_In_Instance := True;
+ end if;
+
+ Current_Sem_Unit := Body_Info.Current_Sem_Unit;
Gen_Body := Unit_Declaration_Node (Gen_Body_Id);
Create_Instantiation_Source
- (Inst_Node, Gen_Body_Id, False, S_Adjustment);
+ (Inst_Node, Gen_Body_Id, S_Adjustment);
Act_Body :=
Copy_Generic_Node
(Original_Node (Gen_Body), Empty, Instantiating => True);
- -- Build new name (possibly qualified) for body declaration
+ -- Create proper (possibly qualified) defining name for the body, to
+ -- correspond to the one in the spec.
- Act_Body_Id := New_Copy (Act_Decl_Id);
+ Act_Body_Id :=
+ Make_Defining_Identifier (Sloc (Act_Decl_Id), Chars (Act_Decl_Id));
+ Set_Comes_From_Source (Act_Body_Id, Comes_From_Source (Act_Decl_Id));
-- Some attributes of spec entity are not inherited by body entity
then
Act_Body_Name :=
Make_Defining_Program_Unit_Name (Loc,
- Name => New_Copy_Tree (Name (Defining_Unit_Name (Act_Spec))),
+ Name =>
+ New_Copy_Tree (Name (Defining_Unit_Name (Act_Spec))),
Defining_Identifier => Act_Body_Id);
else
- Act_Body_Name := Act_Body_Id;
+ Act_Body_Name := Act_Body_Id;
end if;
Set_Defining_Unit_Name (Act_Body, Act_Body_Name);
E := First_Entity (Act_Decl_Id);
while Present (E) loop
if Is_Type (E)
+ and then not Is_Itype (E)
and then Is_Generic_Actual_Type (E)
and then Is_Tagged_Type (E)
then
-- Note that we do NOT apply this criterion to children of GNAT
-- The latter units must suppress checks explicitly if needed.
- if Is_Predefined_File_Name
- (Unit_File_Name (Get_Source_Unit (Gen_Decl)))
+ -- We also do not suppress checks in CodePeer mode where we are
+ -- interested in finding possible runtime errors.
+
+ if not CodePeer_Mode
+ and then In_Predefined_Unit (Gen_Decl)
then
Analyze (Act_Body, Suppress => All_Checks);
else
end if;
Restore_Env;
- Style_Check := Save_Style_Check;
-- If we have no body, and the unit requires a body, then complain. This
-- complaint is suppressed if we have detected other errors (since a
-- was already detected, since this can cause blowups.
else
- return;
+ goto Leave;
end if;
-- Case of package that does not need a body
end if;
Expander_Mode_Restore;
+
+ <<Leave>>
+ Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP;
+ Restore_Ghost_Mode (Saved_GM);
+ Restore_SPARK_Mode (Saved_SM, Saved_SMP);
+ Style_Check := Saved_Style_Check;
end Instantiate_Package_Body;
---------------------------------
-- Instantiate_Subprogram_Body --
---------------------------------
+ -- 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 Instantiate_Subprogram_Body
(Body_Info : Pending_Body_Info;
Body_Optional : Boolean := False)
is
Act_Decl : constant Node_Id := Body_Info.Act_Decl;
+ Act_Decl_Id : constant Entity_Id := Defining_Entity (Act_Decl);
Inst_Node : constant Node_Id := Body_Info.Inst_Node;
- Loc : constant Source_Ptr := Sloc (Inst_Node);
Gen_Id : constant Node_Id := Name (Inst_Node);
Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node);
Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit);
- Anon_Id : constant Entity_Id :=
- Defining_Unit_Name (Specification (Act_Decl));
+ Loc : constant Source_Ptr := Sloc (Inst_Node);
Pack_Id : constant Entity_Id :=
Defining_Unit_Name (Parent (Act_Decl));
+ Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
+ 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;
Saved_Warnings : constant Warning_Record := Save_Warnings;
Act_Body : Node_Id;
+ Act_Body_Id : Entity_Id;
Gen_Body : Node_Id;
Gen_Body_Id : Node_Id;
Pack_Body : Node_Id;
return;
end if;
+ -- The subprogram being instantiated may be subject to pragma Ghost. Set
+ -- the mode now to ensure that any nodes generated during instantiation
+ -- are properly marked as Ghost.
+
+ Set_Ghost_Mode (Act_Decl_Id);
+
Expander_Mode_Save_And_Set (Body_Info.Expander_Status);
-- Re-establish the state of information on which checks are suppressed.
-- This information was set in Body_Info at the point of instantiation,
-- and now we restore it so that the instance is compiled using the
- -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01).
+ -- check status at the instantiation (RM 11.5(7.2/2), AI95-00224-01).
Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top;
Scope_Suppress := Body_Info.Scope_Suppress;
Opt.Ada_Version := Body_Info.Version;
Opt.Ada_Version_Pragma := Body_Info.Version_Pragma;
Restore_Warnings (Body_Info.Warnings);
- Opt.SPARK_Mode := Body_Info.SPARK_Mode;
- Opt.SPARK_Mode_Pragma := Body_Info.SPARK_Mode_Pragma;
+
+ -- Install the SPARK mode which applies to the subprogram body
+
+ Install_SPARK_Mode (Body_Info.SPARK_Mode, Body_Info.SPARK_Mode_Pragma);
if No (Gen_Body_Id) then
-- the spec entity appropriately.
if Is_Imported (Gen_Unit) then
- Set_Is_Imported (Anon_Id);
- Set_First_Rep_Item (Anon_Id, First_Rep_Item (Gen_Unit));
- Set_Interface_Name (Anon_Id, Interface_Name (Gen_Unit));
- Set_Convention (Anon_Id, Convention (Gen_Unit));
- Set_Has_Completion (Anon_Id);
- return;
+ Set_Is_Imported (Act_Decl_Id);
+ Set_First_Rep_Item (Act_Decl_Id, First_Rep_Item (Gen_Unit));
+ Set_Interface_Name (Act_Decl_Id, Interface_Name (Gen_Unit));
+ Set_Convention (Act_Decl_Id, Convention (Gen_Unit));
+ Set_Has_Completion (Act_Decl_Id);
+ goto Leave;
-- For other cases, compile the body
if Expander_Active
and then Operating_Mode = Generate_Code
then
- Error_Msg_N
- ("missing proper body for instantiation", Gen_Body);
+ Error_Msg_N ("missing proper body for instantiation", Gen_Body);
end if;
- Set_Has_Completion (Anon_Id);
- return;
+ Set_Has_Completion (Act_Decl_Id);
+ goto Leave;
end if;
- Save_Env (Gen_Unit, Anon_Id);
+ Save_Env (Gen_Unit, Act_Decl_Id);
Style_Check := False;
+
+ -- If the context of the instance is subject to SPARK_Mode "off", the
+ -- annotation is missing, or the body is instantiated at a later pass
+ -- and its spec ignored SPARK_Mode pragma, set the global flag which
+ -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within the
+ -- instance.
+
+ if SPARK_Mode /= On
+ or else Ignore_SPARK_Mode_Pragmas (Act_Decl_Id)
+ then
+ Ignore_SPARK_Mode_Pragmas_In_Instance := True;
+ end if;
+
Current_Sem_Unit := Body_Info.Current_Sem_Unit;
Create_Instantiation_Source
(Inst_Node,
Gen_Body_Id,
- False,
S_Adjustment);
Act_Body :=
Copy_Generic_Node
(Original_Node (Gen_Body), Empty, Instantiating => True);
- -- Create proper defining name for the body, to correspond to
- -- the one in the spec.
+ -- Create proper defining name for the body, to correspond to the one
+ -- in the spec.
+
+ Act_Body_Id :=
+ Make_Defining_Identifier (Sloc (Act_Decl_Id), Chars (Act_Decl_Id));
+
+ Set_Comes_From_Source (Act_Body_Id, Comes_From_Source (Act_Decl_Id));
+ Set_Defining_Unit_Name (Specification (Act_Body), Act_Body_Id);
- Set_Defining_Unit_Name (Specification (Act_Body),
- Make_Defining_Identifier
- (Sloc (Defining_Entity (Inst_Node)), Chars (Anon_Id)));
- Set_Corresponding_Spec (Act_Body, Anon_Id);
- Set_Has_Completion (Anon_Id);
+ Set_Corresponding_Spec (Act_Body, Act_Decl_Id);
+ Set_Has_Completion (Act_Decl_Id);
Check_Generic_Actuals (Pack_Id, False);
-- Generate a reference to link the visible subprogram instance to
end if;
Restore_Env;
- Style_Check := Saved_Style_Check;
Restore_Warnings (Saved_Warnings);
-- Body not found. Error was emitted already. If there were no previous
and then Nkind (Parent (Inst_Node)) /= N_Compilation_Unit
then
if Body_Optional then
- return;
+ goto Leave;
- elsif Ekind (Anon_Id) = E_Procedure then
+ elsif Ekind (Act_Decl_Id) = E_Procedure then
Act_Body :=
Make_Subprogram_Body (Loc,
- Specification =>
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, Chars (Anon_Id)),
- Parameter_Specifications =>
- New_Copy_List
- (Parameter_Specifications (Parent (Anon_Id)))),
-
- Declarations => Empty_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements =>
- New_List (
- Make_Raise_Program_Error (Loc,
- Reason =>
- PE_Access_Before_Elaboration))));
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc, Chars (Act_Decl_Id)),
+ Parameter_Specifications =>
+ New_Copy_List
+ (Parameter_Specifications (Parent (Act_Decl_Id)))),
+
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Access_Before_Elaboration))));
else
Ret_Expr :=
Make_Raise_Program_Error (Loc,
Reason => PE_Access_Before_Elaboration);
- Set_Etype (Ret_Expr, (Etype (Anon_Id)));
+ Set_Etype (Ret_Expr, (Etype (Act_Decl_Id)));
Set_Analyzed (Ret_Expr);
Act_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, Chars (Anon_Id)),
- Parameter_Specifications =>
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc, Chars (Act_Decl_Id)),
+ Parameter_Specifications =>
New_Copy_List
- (Parameter_Specifications (Parent (Anon_Id))),
+ (Parameter_Specifications (Parent (Act_Decl_Id))),
Result_Definition =>
- New_Occurrence_Of (Etype (Anon_Id), Loc)),
+ New_Occurrence_Of (Etype (Act_Decl_Id), Loc)),
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements =>
- New_List
- (Make_Simple_Return_Statement (Loc, Ret_Expr))));
+ Statements => New_List (
+ Make_Simple_Return_Statement (Loc, Ret_Expr))));
end if;
- Pack_Body := Make_Package_Body (Loc,
- Defining_Unit_Name => New_Copy (Pack_Id),
- Declarations => New_List (Act_Body));
+ Pack_Body :=
+ Make_Package_Body (Loc,
+ Defining_Unit_Name => New_Copy (Pack_Id),
+ Declarations => New_List (Act_Body));
Insert_After (Inst_Node, Pack_Body);
Set_Corresponding_Spec (Pack_Body, Pack_Id);
end if;
Expander_Mode_Restore;
+
+ <<Leave>>
+ Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP;
+ Restore_Ghost_Mode (Saved_GM);
+ Restore_SPARK_Mode (Saved_SM, Saved_SMP);
+ Style_Check := Saved_Style_Check;
end Instantiate_Subprogram_Body;
----------------------
Analyzed_Formal : Node_Id;
Actual_Decls : List_Id) return List_Id
is
- Gen_T : constant Entity_Id := Defining_Identifier (Formal);
A_Gen_T : constant Entity_Id :=
Defining_Identifier (Analyzed_Formal);
- Ancestor : Entity_Id := Empty;
Def : constant Node_Id := Formal_Type_Definition (Formal);
+ Gen_T : constant Entity_Id := Defining_Identifier (Formal);
Act_T : Entity_Id;
+ Ancestor : Entity_Id := Empty;
Decl_Node : Node_Id;
Decl_Nodes : List_Id;
Loc : Source_Ptr;
("expect protected access type for formal &",
Actual, Gen_T);
end if;
+
+ -- If the formal has a specified convention (which in most cases
+ -- will be StdCall) verify that the actual has the same convention.
+
+ if Has_Convention_Pragma (A_Gen_T)
+ and then Convention (A_Gen_T) /= Convention (Act_T)
+ then
+ Error_Msg_Name_1 := Get_Convention_Name (Convention (A_Gen_T));
+ Error_Msg_NE
+ ("actual for formal & must have convention %", Actual, Gen_T);
+ end if;
end Validate_Access_Subprogram_Instance;
-----------------------------------
-- Ada 2005: null-exclusion indicators of the two types must agree
- if Can_Never_Be_Null (A_Gen_T) /= Can_Never_Be_Null (Act_T) then
+ if Can_Never_Be_Null (A_Gen_T) /= Can_Never_Be_Null (Act_T) then
Error_Msg_NE
("non null exclusion of actual and formal & do not match",
Actual, Gen_T);
I2 : Node_Id;
T2 : Entity_Id;
- function Formal_Dimensions return Int;
+ function Formal_Dimensions return Nat;
-- Count number of dimensions in array type formal
-----------------------
-- Formal_Dimensions --
-----------------------
- function Formal_Dimensions return Int is
- Num : Int := 0;
+ function Formal_Dimensions return Nat is
+ Num : Nat := 0;
Index : Node_Id;
begin
Get_Instance_Of (Base_Type (Get_Instance_Of (A_Gen_T)));
end if;
+ -- Check whether parent is a previous formal of the current generic
+
+ elsif Is_Derived_Type (A_Gen_T)
+ and then Is_Generic_Type (Etype (A_Gen_T))
+ and then Scope (A_Gen_T) = Scope (Etype (A_Gen_T))
+ then
+ Ancestor := Get_Instance_Of (First_Subtype (Etype (A_Gen_T)));
+
-- An unusual case: the actual is a type declared in a parent unit,
-- but is not a formal type so there is no instance_of for it.
-- Retrieve it by analyzing the record extension.
Actual, Ancestor);
end if;
+ -- Finally verify that the (instance of) the ancestor is an ancestor
+ -- of the actual.
+
elsif not Is_Ancestor (Base_Type (Ancestor), Act_T) then
Error_Msg_NE
("expect type derived from & in instantiation",
-- It should not be necessary to check for unknown discriminants on
-- Formal, but for some reason Has_Unknown_Discriminants is false for
- -- A_Gen_T, so Is_Indefinite_Subtype incorrectly returns False. This
+ -- A_Gen_T, so Is_Definite_Subtype incorrectly returns True. This
-- needs fixing. ???
- if not Is_Indefinite_Subtype (A_Gen_T)
+ if Is_Definite_Subtype (A_Gen_T)
and then not Unknown_Discriminants_Present (Formal)
- and then Is_Indefinite_Subtype (Act_T)
+ and then not Is_Definite_Subtype (Act_T)
then
Error_Msg_N ("actual subtype must be constrained", Actual);
Abandon_Instantiation (Actual);
-- If the formal and actual types are abstract, check that there
-- are no abstract primitives of the actual type that correspond to
-- nonabstract primitives of the formal type (second sentence of
- -- RM95-3.9.3(9)).
+ -- RM95 3.9.3(9)).
if Is_Abstract_Type (A_Gen_T) and then Is_Abstract_Type (Act_T) then
Check_Abstract_Primitives : declare
end if;
-- Verify that limitedness matches. If parent is a limited
- -- interface then the generic formal is not unless declared
+ -- interface then the generic formal is not unless declared
-- explicitly so. If not declared limited, the actual cannot be
-- limited (see AI05-0087).
("actual for & must have preelaborable initialization", Actual,
Gen_T);
- elsif Is_Indefinite_Subtype (Act_T)
- and then not Is_Indefinite_Subtype (A_Gen_T)
+ elsif not Is_Definite_Subtype (Act_T)
+ and then Is_Definite_Subtype (A_Gen_T)
and then Ada_Version >= Ada_95
then
Error_Msg_NE
when N_Access_To_Object_Definition =>
Validate_Access_Type_Instance;
- when N_Access_Function_Definition |
- N_Access_Procedure_Definition =>
+ when N_Access_Function_Definition
+ | N_Access_Procedure_Definition
+ =>
Validate_Access_Subprogram_Instance;
- when N_Record_Definition =>
+ when N_Record_Definition =>
Validate_Interface_Type_Instance;
- when N_Derived_Type_Definition =>
+ when N_Derived_Type_Definition =>
Validate_Derived_Interface_Type_Instance;
when others =>
raise Program_Error;
-
end case;
end if;
end;
end if;
- return Decl_Nodes;
+ -- For a floating-point type, capture dimension info if any, because
+ -- the generated subtype declaration does not come from source and
+ -- will not process dimensions.
+
+ if Is_Floating_Point_Type (Act_T) then
+ Copy_Dimensions (Act_T, Subt);
+ end if;
+
+ return Decl_Nodes;
end Instantiate_Type;
---------------------
-- or in the declaration of the main unit, which in this last case must
-- be a body.
- return Unum = Main_Unit
- or else Current_Unit = Cunit (Main_Unit)
- or else Current_Unit = Library_Unit (Cunit (Main_Unit))
- or else (Present (Library_Unit (Current_Unit))
- and then Is_In_Main_Unit (Library_Unit (Current_Unit)));
+ return
+ Current_Unit = Cunit (Main_Unit)
+ or else Current_Unit = Library_Unit (Cunit (Main_Unit))
+ or else (Present (Current_Unit)
+ and then Present (Library_Unit (Current_Unit))
+ and then Is_In_Main_Unit (Library_Unit (Current_Unit)));
end Is_In_Main_Unit;
----------------------------
-- package, in which case the usual generic rule applies.
declare
- Exp_Status : Boolean := True;
- Scop : Entity_Id;
+ Exp_Status : Boolean := True;
+ Scop : Entity_Id;
begin
-- Loop through scopes looking for generic package
-- Package instance
- if
- Nkind (Node (Decl)) = N_Package_Instantiation
+ if Nkind (Node (Decl)) = N_Package_Instantiation
then
Instantiate_Package_Body
(Info, Body_Optional => True);
-- The instance_spec is in the wrapper package,
-- usually followed by its local renaming
-- declaration. See Build_Subprogram_Renaming
- -- for details.
+ -- for details. If the instance carries aspects,
+ -- these result in the corresponding pragmas,
+ -- inserted after the subprogram declaration.
+ -- They must be skipped as well when retrieving
+ -- the desired spec. Some of them may have been
+ -- rewritten as null statements.
+ -- A direct link would be more robust ???
declare
Decl : Node_Id :=
(Last (Visible_Declarations
(Specification (Info.Act_Decl))));
begin
- if Nkind (Decl) =
- N_Subprogram_Renaming_Declaration
- then
+ while Nkind_In (Decl,
+ N_Null_Statement,
+ N_Pragma,
+ N_Subprogram_Renaming_Declaration)
+ loop
Decl := Prev (Decl);
- end if;
+ end loop;
Info.Act_Decl := Decl;
end;
-- Preanalyze_Actuals --
------------------------
- procedure Preanalyze_Actuals (N : Node_Id) is
+ procedure Preanalyze_Actuals (N : Node_Id; Inst : Entity_Id := Empty) is
Assoc : Node_Id;
Act : Node_Id;
- Errs : constant Int := Serious_Errors_Detected;
+ Errs : constant Nat := Serious_Errors_Detected;
Cur : Entity_Id := Empty;
-- Current homograph of the instance name
- Vis : Boolean;
+ Vis : Boolean := False;
-- Saved visibility status of the current homograph
begin
elsif Nkind (Act) /= N_Operator_Symbol then
Analyze (Act);
+
+ -- Within a package instance, mark actuals that are limited
+ -- views, so their use can be moved to the body of the
+ -- enclosing unit.
+
+ if Is_Entity_Name (Act)
+ and then Is_Type (Entity (Act))
+ and then From_Limited_With (Entity (Act))
+ and then Present (Inst)
+ then
+ Append_Elmt (Entity (Act), Incomplete_Actuals (Inst));
+ end if;
end if;
if Errs /= Serious_Errors_Detected then
-- Save_Global_References --
----------------------------
- procedure Save_Global_References (N : Node_Id) is
+ procedure Save_Global_References (Templ : Node_Id) is
+
+ -- ??? it is horrible to use global variables in highly recursive code
+
+ E : Entity_Id;
+ -- The entity of the current associated node
+
Gen_Scope : Entity_Id;
- E : Entity_Id;
- N2 : Node_Id;
+ -- The scope of the generic for which references are being saved
+
+ N2 : Node_Id;
+ -- The current associated node
function Is_Global (E : Entity_Id) return Boolean;
-- Check whether entity is defined outside of generic unit. Examine the
-- global because it is used to denote a specific compilation unit at
-- the time the instantiations will be analyzed.
+ procedure Qualify_Universal_Operands
+ (Op : Node_Id;
+ Func_Call : Node_Id);
+ -- Op denotes a binary or unary operator in generic template Templ. Node
+ -- Func_Call is the function call alternative of the operator within the
+ -- the analyzed copy of the template. Change each operand which yields a
+ -- universal type by wrapping it into a qualified expression
+ --
+ -- Actual_Typ'(Operand)
+ --
+ -- where Actual_Typ is the type of corresponding actual parameter of
+ -- Operand in Func_Call.
+
procedure Reset_Entity (N : Node_Id);
-- Save semantic information on global entity so that it is not resolved
-- again at instantiation time.
-- nodes. N can also be a character literal, identifier, or operator
-- symbol node, but the call has no effect in these cases.
- procedure Save_Global_Defaults (N1, N2 : Node_Id);
+ procedure Save_Global_Defaults (N1 : Node_Id; N2 : Node_Id);
-- Default actuals in nested instances must be handled specially
-- because there is no link to them from the original tree. When an
-- actual subprogram is given by a default, we add an explicit generic
-- so that it can be properly resolved in a subsequent instantiation.
procedure Save_Global_Descendant (D : Union_Id);
- -- Apply Save_Global_References recursively to the descendents of the
- -- current node.
+ -- Apply Save_References recursively to the descendants of node D
procedure Save_References (N : Node_Id);
-- This is the recursive procedure that does the work, once the
end if;
end Is_Global;
+ --------------------------------
+ -- Qualify_Universal_Operands --
+ --------------------------------
+
+ procedure Qualify_Universal_Operands
+ (Op : Node_Id;
+ Func_Call : Node_Id)
+ is
+ procedure Qualify_Operand (Opnd : Node_Id; Actual : Node_Id);
+ -- Rewrite operand Opnd as a qualified expression of the form
+ --
+ -- Actual_Typ'(Opnd)
+ --
+ -- where Actual is the corresponding actual parameter of Opnd in
+ -- function call Func_Call.
+
+ function Qualify_Type
+ (Loc : Source_Ptr;
+ Typ : Entity_Id) return Node_Id;
+ -- Qualify type Typ by creating a selected component of the form
+ --
+ -- Scope_Of_Typ.Typ
+
+ ---------------------
+ -- Qualify_Operand --
+ ---------------------
+
+ procedure Qualify_Operand (Opnd : Node_Id; Actual : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Opnd);
+ Typ : constant Entity_Id := Etype (Actual);
+ Mark : Node_Id;
+ Qual : Node_Id;
+
+ begin
+ -- Qualify the operand when it is of a universal type. Note that
+ -- the template is unanalyzed and it is not possible to directly
+ -- query the type. This transformation is not done when the type
+ -- of the actual is internally generated because the type will be
+ -- regenerated in the instance.
+
+ if Yields_Universal_Type (Opnd)
+ and then Comes_From_Source (Typ)
+ and then not Is_Hidden (Typ)
+ then
+ -- The type of the actual may be a global reference. Save this
+ -- information by creating a reference to it.
+
+ if Is_Global (Typ) then
+ Mark := New_Occurrence_Of (Typ, Loc);
+
+ -- Otherwise rely on resolution to find the proper type within
+ -- the instance.
+
+ else
+ Mark := Qualify_Type (Loc, Typ);
+ end if;
+
+ Qual :=
+ Make_Qualified_Expression (Loc,
+ Subtype_Mark => Mark,
+ Expression => Relocate_Node (Opnd));
+
+ -- Mark the qualification to distinguish it from other source
+ -- constructs and signal the instantiation mechanism that this
+ -- node requires special processing. See Copy_Generic_Node for
+ -- details.
+
+ Set_Is_Qualified_Universal_Literal (Qual);
+
+ Rewrite (Opnd, Qual);
+ end if;
+ end Qualify_Operand;
+
+ ------------------
+ -- Qualify_Type --
+ ------------------
+
+ function Qualify_Type
+ (Loc : Source_Ptr;
+ Typ : Entity_Id) return Node_Id
+ is
+ Scop : constant Entity_Id := Scope (Typ);
+ Result : Node_Id;
+
+ begin
+ Result := Make_Identifier (Loc, Chars (Typ));
+
+ if Present (Scop) and then not Is_Generic_Unit (Scop) then
+ Result :=
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Chars (Scop)),
+ Selector_Name => Result);
+ end if;
+
+ return Result;
+ end Qualify_Type;
+
+ -- Local variables
+
+ Actuals : constant List_Id := Parameter_Associations (Func_Call);
+
+ -- Start of processing for Qualify_Universal_Operands
+
+ begin
+ if Nkind (Op) in N_Binary_Op then
+ Qualify_Operand (Left_Opnd (Op), First (Actuals));
+ Qualify_Operand (Right_Opnd (Op), Next (First (Actuals)));
+
+ elsif Nkind (Op) in N_Unary_Op then
+ Qualify_Operand (Right_Opnd (Op), First (Actuals));
+ end if;
+ end Qualify_Universal_Operands;
+
------------------
-- Reset_Entity --
------------------
procedure Reset_Entity (N : Node_Id) is
-
procedure Set_Global_Type (N : Node_Id; N2 : Node_Id);
-- If the type of N2 is global to the generic unit, save the type in
-- the generic node. Just as we perform name capture for explicit
begin
Set_Etype (N, Typ);
- if Entity (N) /= N2
- and then Has_Private_View (Entity (N))
- then
- -- If the entity of N is not the associated node, this is a
- -- nested generic and it has an associated node as well, whose
- -- type is already the full view (see below). Indicate that the
- -- original node has a private view.
+ -- If the entity of N is not the associated node, this is a
+ -- nested generic and it has an associated node as well, whose
+ -- type is already the full view (see below). Indicate that the
+ -- original node has a private view.
+ if Entity (N) /= N2 and then Has_Private_View (Entity (N)) then
Set_Has_Private_View (N);
end if;
Set_Etype (N2, Full_View (Typ));
end if;
end if;
+
+ if Is_Floating_Point_Type (Typ)
+ and then Has_Dimension_System (Typ)
+ then
+ Copy_Dimensions (N2, N);
+ end if;
end Set_Global_Type;
------------------
begin
N2 := Get_Associated_Node (N);
- E := Entity (N2);
+ E := Entity (N2);
if Present (E) then
-- preserve in this case, since the expansion will be redone in
-- the instance.
- if not Nkind_In (E, N_Defining_Identifier,
- N_Defining_Character_Literal,
+ if not Nkind_In (E, N_Defining_Character_Literal,
+ N_Defining_Identifier,
N_Defining_Operator_Symbol)
then
Set_Associated_Node (N, Empty);
- Set_Etype (N, Empty);
+ Set_Etype (N, Empty);
return;
end if;
if Is_Global (Entity (Original_Node (N2))) then
N2 := Original_Node (N2);
Set_Associated_Node (N, N2);
- Set_Global_Type (N, N2);
+ Set_Global_Type (N, N2);
- else
- -- Renaming is local, and will be resolved in instance
+ -- Renaming is local, and will be resolved in instance
+ else
Set_Associated_Node (N, Empty);
- Set_Etype (N, Empty);
+ Set_Etype (N, Empty);
end if;
else
and then Is_Generic_Type (Etype (N2))
and then (Base_Type (Etype (Right_Opnd (N2))) = Etype (N2)
or else
- Base_Type (Etype (Left_Opnd (N2))) = Etype (N2))
+ Base_Type (Etype (Left_Opnd (N2))) = Etype (N2))
and then Is_Intrinsic_Subprogram (E)
then
null;
- else
- -- Entity is local. Mark generic node as unresolved.
- -- Note that now it does not have an entity.
+ -- Entity is local. Mark generic node as unresolved. Note that now
+ -- it does not have an entity.
+ else
Set_Associated_Node (N, Empty);
- Set_Etype (N, Empty);
+ Set_Etype (N, Empty);
end if;
if Nkind (Parent (N)) in N_Generic_Instantiation
if Is_Global (Entity (Parent (N2))) then
Change_Selected_Component_To_Expanded_Name (Parent (N));
Set_Associated_Node (Parent (N), Parent (N2));
- Set_Global_Type (Parent (N), Parent (N2));
+ Set_Global_Type (Parent (N), Parent (N2));
Save_Entity_Descendants (N);
-- If this is a reference to the current generic entity, replace
and then Parent (N) = Name (Parent (Parent (N)))
then
Save_Global_Defaults
- (Parent (Parent (N)), Parent (Parent ((N2))));
+ (Parent (Parent (N)), Parent (Parent (N2)));
end if;
-- A selected component may denote a static constant that has been
then
Rewrite (Parent (N), New_Copy (Parent (N2)));
Set_Analyzed (Parent (N), False);
-
- else
- null;
end if;
-- A selected component may be transformed into a parameterless
if Is_Global (Entity (Name (Parent (N2)))) then
Change_Selected_Component_To_Expanded_Name (Parent (N));
Set_Associated_Node (Parent (N), Name (Parent (N2)));
- Set_Global_Type (Parent (N), Name (Parent (N2)));
+ Set_Global_Type (Parent (N), Name (Parent (N2)));
Save_Entity_Descendants (N);
else
begin
case Nkind (N) is
when N_Binary_Op =>
- Save_Global_Descendant (Union_Id (Left_Opnd (N)));
+ Save_Global_Descendant (Union_Id (Left_Opnd (N)));
Save_Global_Descendant (Union_Id (Right_Opnd (N)));
when N_Unary_Op =>
Save_Global_Descendant (Union_Id (Right_Opnd (N)));
- when N_Expanded_Name | N_Selected_Component =>
+ when N_Expanded_Name
+ | N_Selected_Component
+ =>
Save_Global_Descendant (Union_Id (Prefix (N)));
Save_Global_Descendant (Union_Id (Selector_Name (N)));
- when N_Identifier | N_Character_Literal | N_Operator_Symbol =>
+ when N_Character_Literal
+ | N_Identifier
+ | N_Operator_Symbol
+ =>
null;
when others =>
-- Save_Global_Defaults --
--------------------------
- procedure Save_Global_Defaults (N1, N2 : Node_Id) is
+ procedure Save_Global_Defaults (N1 : Node_Id; N2 : Node_Id) is
Loc : constant Source_Ptr := Sloc (N1);
Assoc2 : constant List_Id := Generic_Associations (N2);
Gen_Id : constant Entity_Id := Get_Generic_Entity (N2);
if Is_Global (Actual) then
Ndec :=
Make_Generic_Association (Loc,
- Selector_Name => New_Occurrence_Of (Subp, Loc),
- Explicit_Generic_Actual_Parameter =>
- New_Occurrence_Of (Actual, Loc));
+ Selector_Name =>
+ New_Occurrence_Of (Subp, Loc),
+ Explicit_Generic_Actual_Parameter =>
+ New_Occurrence_Of (Actual, Loc));
Set_Associated_Node
(Explicit_Generic_Actual_Parameter (Ndec), Def);
elsif Present (Next (Act2)) then
Ndec :=
Make_Generic_Association (Loc,
- Selector_Name => New_Occurrence_Of (Subp, Loc),
- Explicit_Generic_Actual_Parameter => Empty);
+ Selector_Name =>
+ New_Occurrence_Of (Subp, Loc),
+ Explicit_Generic_Actual_Parameter => Empty);
Append (Ndec, Assoc1);
end if;
(Selector_Name (Name (N1)), Selector_Name (Name (N2)));
Set_Etype (Name (N1), Etype (Gen_Id));
end if;
-
end Save_Global_Defaults;
----------------------------
end if;
elsif D in List_Range then
- if D = Union_Id (No_List) or else Is_Empty_List (List_Id (D)) then
+ pragma Assert (D /= Union_Id (No_List));
+ -- Because No_List = Empty, which is in Node_Range above
+
+ if Is_Empty_List (List_Id (D)) then
null;
else
procedure Save_References (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- begin
- if N = Empty then
- null;
+ function Requires_Delayed_Save (Nod : Node_Id) return Boolean;
+ -- Determine whether arbitrary node Nod requires delayed capture of
+ -- global references within its aspect specifications.
- elsif Nkind_In (N, N_Character_Literal, N_Operator_Symbol) then
+ procedure Save_References_In_Aggregate (N : Node_Id);
+ -- Save all global references in [extension] aggregate node N
+
+ procedure Save_References_In_Char_Lit_Or_Op_Symbol (N : Node_Id);
+ -- Save all global references in a character literal or operator
+ -- symbol denoted by N.
+
+ procedure Save_References_In_Descendants (N : Node_Id);
+ -- Save all global references in all descendants of node N
+
+ procedure Save_References_In_Identifier (N : Node_Id);
+ -- Save all global references in identifier node N
+
+ procedure Save_References_In_Operator (N : Node_Id);
+ -- Save all global references in operator node N
+
+ procedure Save_References_In_Pragma (Prag : Node_Id);
+ -- Save all global references found within the expression of pragma
+ -- Prag.
+
+ ---------------------------
+ -- Requires_Delayed_Save --
+ ---------------------------
+
+ function Requires_Delayed_Save (Nod : Node_Id) return Boolean is
+ begin
+ -- Generic packages and subprograms require delayed capture of
+ -- global references within their aspects due to the timing of
+ -- annotation analysis.
+
+ if Nkind_In (Nod, N_Generic_Package_Declaration,
+ N_Generic_Subprogram_Declaration,
+ N_Package_Body,
+ N_Package_Body_Stub,
+ N_Subprogram_Body,
+ N_Subprogram_Body_Stub)
+ then
+ -- Since the capture of global references is done on the
+ -- unanalyzed generic template, there is no information around
+ -- to infer the context. Use the Associated_Entity linkages to
+ -- peek into the analyzed generic copy and determine what the
+ -- template corresponds to.
+
+ if Nod = Templ then
+ return
+ Is_Generic_Declaration_Or_Body
+ (Unit_Declaration_Node
+ (Associated_Entity (Defining_Entity (Nod))));
+
+ -- Otherwise the generic unit being processed is not the top
+ -- level template. It is safe to capture of global references
+ -- within the generic unit because at this point the top level
+ -- copy is fully analyzed.
+
+ else
+ return False;
+ end if;
+
+ -- Otherwise capture the global references without interference
+
+ else
+ return False;
+ end if;
+ end Requires_Delayed_Save;
+
+ ----------------------------------
+ -- Save_References_In_Aggregate --
+ ----------------------------------
+
+ procedure Save_References_In_Aggregate (N : Node_Id) is
+ Nam : Node_Id;
+ Qual : Node_Id := Empty;
+ Typ : Entity_Id := Empty;
+
+ use Atree.Unchecked_Access;
+ -- This code section is part of implementing an untyped tree
+ -- traversal, so it needs direct access to node fields.
+
+ begin
+ N2 := Get_Associated_Node (N);
+
+ if Present (N2) then
+ Typ := Etype (N2);
+
+ -- In an instance within a generic, use the name of the actual
+ -- and not the original generic parameter. If the actual is
+ -- global in the current generic it must be preserved for its
+ -- instantiation.
+
+ if Nkind (Parent (Typ)) = N_Subtype_Declaration
+ and then Present (Generic_Parent_Type (Parent (Typ)))
+ then
+ Typ := Base_Type (Typ);
+ Set_Etype (N2, Typ);
+ end if;
+ end if;
+
+ if No (N2) or else No (Typ) or else not Is_Global (Typ) then
+ Set_Associated_Node (N, Empty);
+
+ -- If the aggregate is an actual in a call, it has been
+ -- resolved in the current context, to some local type. The
+ -- enclosing call may have been disambiguated by the aggregate,
+ -- and this disambiguation might fail at instantiation time
+ -- because the type to which the aggregate did resolve is not
+ -- preserved. In order to preserve some of this information,
+ -- wrap the aggregate in a qualified expression, using the id
+ -- of its type. For further disambiguation we qualify the type
+ -- name with its scope (if visible) because both id's will have
+ -- corresponding entities in an instance. This resolves most of
+ -- the problems with missing type information on aggregates in
+ -- instances.
+
+ if Present (N2)
+ and then Nkind (N2) = Nkind (N)
+ and then Nkind (Parent (N2)) in N_Subprogram_Call
+ and then Present (Typ)
+ and then Comes_From_Source (Typ)
+ then
+ Nam := Make_Identifier (Loc, Chars (Typ));
+
+ if Is_Immediately_Visible (Scope (Typ)) then
+ Nam :=
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Chars (Scope (Typ))),
+ Selector_Name => Nam);
+ end if;
+
+ Qual :=
+ Make_Qualified_Expression (Loc,
+ Subtype_Mark => Nam,
+ Expression => Relocate_Node (N));
+ end if;
+ end if;
+
+ Save_Global_Descendant (Field1 (N));
+ Save_Global_Descendant (Field2 (N));
+ Save_Global_Descendant (Field3 (N));
+ Save_Global_Descendant (Field5 (N));
+
+ if Present (Qual) then
+ Rewrite (N, Qual);
+ end if;
+ end Save_References_In_Aggregate;
+
+ ----------------------------------------------
+ -- Save_References_In_Char_Lit_Or_Op_Symbol --
+ ----------------------------------------------
+
+ procedure Save_References_In_Char_Lit_Or_Op_Symbol (N : Node_Id) is
+ begin
if Nkind (N) = Nkind (Get_Associated_Node (N)) then
Reset_Entity (N);
then
Change_Operator_Symbol_To_String_Literal (N);
end if;
+ end Save_References_In_Char_Lit_Or_Op_Symbol;
+
+ ------------------------------------
+ -- Save_References_In_Descendants --
+ ------------------------------------
+
+ procedure Save_References_In_Descendants (N : Node_Id) is
+ use Atree.Unchecked_Access;
+ -- This code section is part of implementing an untyped tree
+ -- traversal, so it needs direct access to node fields.
+
+ begin
+ Save_Global_Descendant (Field1 (N));
+ Save_Global_Descendant (Field2 (N));
+ Save_Global_Descendant (Field3 (N));
+ Save_Global_Descendant (Field4 (N));
+ Save_Global_Descendant (Field5 (N));
+ end Save_References_In_Descendants;
+
+ -----------------------------------
+ -- Save_References_In_Identifier --
+ -----------------------------------
+
+ procedure Save_References_In_Identifier (N : Node_Id) is
+ begin
+ -- The node did not undergo a transformation
+
+ if Nkind (N) = Nkind (Get_Associated_Node (N)) then
+ declare
+ Aux_N2 : constant Node_Id := Get_Associated_Node (N);
+ Orig_N2_Parent : constant Node_Id :=
+ Original_Node (Parent (Aux_N2));
+ begin
+ -- The parent of this identifier is a selected component
+ -- which denotes a named number that was constant folded.
+ -- Preserve the original name for ASIS and link the parent
+ -- with its expanded name. The constant folding will be
+ -- repeated in the instance.
+
+ if Nkind (Parent (N)) = N_Selected_Component
+ and then Nkind_In (Parent (Aux_N2), N_Integer_Literal,
+ N_Real_Literal)
+ and then Is_Entity_Name (Orig_N2_Parent)
+ and then Ekind (Entity (Orig_N2_Parent)) in Named_Kind
+ and then Is_Global (Entity (Orig_N2_Parent))
+ then
+ N2 := Aux_N2;
+ Set_Associated_Node
+ (Parent (N), Original_Node (Parent (N2)));
+
+ -- Common case
+
+ else
+ -- If this is a discriminant reference, always save it.
+ -- It is used in the instance to find the corresponding
+ -- discriminant positionally rather than by name.
+
+ Set_Original_Discriminant
+ (N, Original_Discriminant (Get_Associated_Node (N)));
+ end if;
+
+ Reset_Entity (N);
+ end;
+
+ -- The analysis of the generic copy transformed the identifier
+ -- into another construct. Propagate the changes to the template.
+
+ else
+ N2 := Get_Associated_Node (N);
+
+ -- The identifier denotes a call to a parameterless function.
+ -- Mark the node as resolved when the function is external.
+
+ if Nkind (N2) = N_Function_Call then
+ E := Entity (Name (N2));
+
+ if Present (E) and then Is_Global (E) then
+ Set_Etype (N, Etype (N2));
+ else
+ Set_Associated_Node (N, Empty);
+ Set_Etype (N, Empty);
+ end if;
+
+ -- The identifier denotes a named number that was constant
+ -- folded. Preserve the original name for ASIS and undo the
+ -- constant folding which will be repeated in the instance.
+
+ elsif Nkind_In (N2, N_Integer_Literal, N_Real_Literal)
+ and then Is_Entity_Name (Original_Node (N2))
+ then
+ Set_Associated_Node (N, Original_Node (N2));
+ Reset_Entity (N);
+
+ -- The identifier resolved to a string literal. Propagate this
+ -- information to the generic template.
+
+ elsif Nkind (N2) = N_String_Literal then
+ Rewrite (N, New_Copy (N2));
+
+ -- The identifier is rewritten as a dereference if it is the
+ -- prefix of an implicit dereference. Preserve the original
+ -- tree as the analysis of the instance will expand the node
+ -- again, but preserve the resolved entity if it is global.
+
+ elsif Nkind (N2) = N_Explicit_Dereference then
+ if Is_Entity_Name (Prefix (N2))
+ and then Present (Entity (Prefix (N2)))
+ and then Is_Global (Entity (Prefix (N2)))
+ then
+ Set_Associated_Node (N, Prefix (N2));
+
+ elsif Nkind (Prefix (N2)) = N_Function_Call
+ and then Present (Entity (Name (Prefix (N2))))
+ and then Is_Global (Entity (Name (Prefix (N2))))
+ then
+ Rewrite (N,
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Entity (Name (Prefix (N2))), Loc))));
+
+ else
+ Set_Associated_Node (N, Empty);
+ Set_Etype (N, Empty);
+ end if;
+
+ -- The subtype mark of a nominally unconstrained object is
+ -- rewritten as a subtype indication using the bounds of the
+ -- expression. Recover the original subtype mark.
+
+ elsif Nkind (N2) = N_Subtype_Indication
+ and then Is_Entity_Name (Original_Node (N2))
+ then
+ Set_Associated_Node (N, Original_Node (N2));
+ Reset_Entity (N);
+ end if;
+ end if;
+ end Save_References_In_Identifier;
+
+ ---------------------------------
+ -- Save_References_In_Operator --
+ ---------------------------------
+
+ procedure Save_References_In_Operator (N : Node_Id) is
+ begin
+ -- The node did not undergo a transformation
- elsif Nkind (N) in N_Op then
if Nkind (N) = Nkind (Get_Associated_Node (N)) then
if Nkind (N) = N_Op_Concat then
Set_Is_Component_Left_Opnd (N,
Reset_Entity (N);
- else
- -- Node may be transformed into call to a user-defined operator
+ -- The analysis of the generic copy transformed the operator into
+ -- some other construct. Propagate the changes to the template if
+ -- applicable.
+ else
N2 := Get_Associated_Node (N);
+ -- The operator resoved to a function call
+
if Nkind (N2) = N_Function_Call then
+
+ -- Add explicit qualifications in the generic template for
+ -- all operands of universal type. This aids resolution by
+ -- preserving the actual type of a literal or an attribute
+ -- that yields a universal result.
+
+ Qualify_Universal_Operands (N, N2);
+
E := Entity (Name (N2));
- if Present (E)
- and then Is_Global (E)
- then
+ if Present (E) and then Is_Global (E) then
Set_Etype (N, Etype (N2));
else
Set_Associated_Node (N, Empty);
- Set_Etype (N, Empty);
+ Set_Etype (N, Empty);
end if;
+ -- The operator was folded into a literal
+
elsif Nkind_In (N2, N_Integer_Literal,
N_Real_Literal,
N_String_Literal)
if Present (Original_Node (N2))
and then Nkind (Original_Node (N2)) = Nkind (N)
then
-
-- Operation was constant-folded. Whenever possible,
-- recover semantic information from unfolded node,
-- for ASIS use.
Reset_Entity (N);
- else
- -- If original node is already modified, propagate
- -- constant-folding to template.
+ -- Propagate the constant folding back to the template
+ else
Rewrite (N, New_Copy (N2));
Set_Analyzed (N, False);
end if;
+ -- The operator was folded into an enumeration literal. Retain
+ -- the entity to avoid spurious ambiguities if it is overloaded
+ -- at the point of instantiation or inlining.
+
elsif Nkind (N2) = N_Identifier
and then Ekind (Entity (N2)) = E_Enumeration_Literal
then
- -- Same if call was folded into a literal, but in this case
- -- retain the entity to avoid spurious ambiguities if it is
- -- overloaded at the point of instantiation or inlining.
-
Rewrite (N, New_Copy (N2));
Set_Analyzed (N, False);
end if;
end if;
- -- Complete operands check if node has not been constant-folded
+ -- Complete the operands check if node has not been constant
+ -- folded.
if Nkind (N) in N_Op then
Save_Entity_Descendants (N);
end if;
+ end Save_References_In_Operator;
- elsif Nkind (N) = N_Identifier then
- if Nkind (N) = Nkind (Get_Associated_Node (N)) then
+ -------------------------------
+ -- Save_References_In_Pragma --
+ -------------------------------
- -- If this is a discriminant reference, always save it. It is
- -- used in the instance to find the corresponding discriminant
- -- positionally rather than by name.
+ procedure Save_References_In_Pragma (Prag : Node_Id) is
+ Context : Node_Id;
+ Do_Save : Boolean := True;
- Set_Original_Discriminant
- (N, Original_Discriminant (Get_Associated_Node (N)));
- Reset_Entity (N);
-
- else
- N2 := Get_Associated_Node (N);
+ use Atree.Unchecked_Access;
+ -- This code section is part of implementing an untyped tree
+ -- traversal, so it needs direct access to node fields.
- if Nkind (N2) = N_Function_Call then
- E := Entity (Name (N2));
+ begin
+ -- Do not save global references in pragmas generated from aspects
+ -- because the pragmas will be regenerated at instantiation time.
- -- Name resolves to a call to parameterless function. If
- -- original entity is global, mark node as resolved.
+ if From_Aspect_Specification (Prag) then
+ Do_Save := False;
- if Present (E)
- and then Is_Global (E)
- then
- Set_Etype (N, Etype (N2));
- else
- Set_Associated_Node (N, Empty);
- Set_Etype (N, Empty);
- end if;
+ -- The capture of global references within contract-related source
+ -- pragmas associated with generic packages, subprograms or their
+ -- respective bodies must be delayed due to timing of annotation
+ -- analysis. Global references are still captured in routine
+ -- Save_Global_References_In_Contract.
- elsif Nkind_In (N2, N_Integer_Literal, N_Real_Literal)
- and then Is_Entity_Name (Original_Node (N2))
- then
- -- Name resolves to named number that is constant-folded,
- -- We must preserve the original name for ASIS use, and
- -- undo the constant-folding, which will be repeated in
- -- each instance.
+ elsif Is_Generic_Contract_Pragma (Prag) and then Prag /= Templ then
+ if Is_Package_Contract_Annotation (Prag) then
+ Context := Find_Related_Package_Or_Body (Prag);
+ else
+ pragma Assert (Is_Subprogram_Contract_Annotation (Prag));
+ Context := Find_Related_Declaration_Or_Body (Prag);
+ end if;
- Set_Associated_Node (N, Original_Node (N2));
- Reset_Entity (N);
+ -- The use of Original_Node accounts for the case when the
+ -- related context is generic template.
- elsif Nkind (N2) = N_String_Literal then
+ if Requires_Delayed_Save (Original_Node (Context)) then
+ Do_Save := False;
+ end if;
+ end if;
- -- Name resolves to string literal. Perform the same
- -- replacement in generic.
+ -- For all other cases, save all global references within the
+ -- descendants, but skip the following semantic fields:
- Rewrite (N, New_Copy (N2));
+ -- Field1 - Next_Pragma
+ -- Field3 - Corresponding_Aspect
+ -- Field5 - Next_Rep_Item
- elsif Nkind (N2) = N_Explicit_Dereference then
+ if Do_Save then
+ Save_Global_Descendant (Field2 (Prag));
+ Save_Global_Descendant (Field4 (Prag));
+ end if;
+ end Save_References_In_Pragma;
- -- An identifier is rewritten as a dereference if it is the
- -- prefix in an implicit dereference (call or attribute).
- -- The analysis of an instantiation will expand the node
- -- again, so we preserve the original tree but link it to
- -- the resolved entity in case it is global.
+ -- Start of processing for Save_References
- if Is_Entity_Name (Prefix (N2))
- and then Present (Entity (Prefix (N2)))
- and then Is_Global (Entity (Prefix (N2)))
- then
- Set_Associated_Node (N, Prefix (N2));
+ begin
+ if N = Empty then
+ null;
- elsif Nkind (Prefix (N2)) = N_Function_Call
- and then Is_Global (Entity (Name (Prefix (N2))))
- then
- Rewrite (N,
- Make_Explicit_Dereference (Loc,
- Prefix => Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of
- (Entity (Name (Prefix (N2))), Loc))));
+ -- Aggregates
- else
- Set_Associated_Node (N, Empty);
- Set_Etype (N, Empty);
- end if;
+ elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
+ Save_References_In_Aggregate (N);
- -- The subtype mark of a nominally unconstrained object is
- -- rewritten as a subtype indication using the bounds of the
- -- expression. Recover the original subtype mark.
+ -- Character literals, operator symbols
- elsif Nkind (N2) = N_Subtype_Indication
- and then Is_Entity_Name (Original_Node (N2))
- then
- Set_Associated_Node (N, Original_Node (N2));
- Reset_Entity (N);
+ elsif Nkind_In (N, N_Character_Literal, N_Operator_Symbol) then
+ Save_References_In_Char_Lit_Or_Op_Symbol (N);
- else
- null;
- end if;
- end if;
+ -- Defining identifiers
elsif Nkind (N) in N_Entity then
null;
- else
- declare
- Qual : Node_Id := Empty;
- Typ : Entity_Id := Empty;
- Nam : Node_Id;
-
- use Atree.Unchecked_Access;
- -- This code section is part of implementing an untyped tree
- -- traversal, so it needs direct access to node fields.
-
- begin
- if Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
- N2 := Get_Associated_Node (N);
-
- if No (N2) then
- Typ := Empty;
+ -- Identifiers
- else
- Typ := Etype (N2);
+ elsif Nkind (N) = N_Identifier then
+ Save_References_In_Identifier (N);
- -- In an instance within a generic, use the name of the
- -- actual and not the original generic parameter. If the
- -- actual is global in the current generic it must be
- -- preserved for its instantiation.
+ -- Operators
- if Nkind (Parent (Typ)) = N_Subtype_Declaration
- and then
- Present (Generic_Parent_Type (Parent (Typ)))
- then
- Typ := Base_Type (Typ);
- Set_Etype (N2, Typ);
- end if;
- end if;
+ elsif Nkind (N) in N_Op then
+ Save_References_In_Operator (N);
- if No (N2) or else No (Typ) or else not Is_Global (Typ) then
- Set_Associated_Node (N, Empty);
+ -- Pragmas
- -- If the aggregate is an actual in a call, it has been
- -- resolved in the current context, to some local type.
- -- The enclosing call may have been disambiguated by the
- -- aggregate, and this disambiguation might fail at
- -- instantiation time because the type to which the
- -- aggregate did resolve is not preserved. In order to
- -- preserve some of this information, we wrap the
- -- aggregate in a qualified expression, using the id of
- -- its type. For further disambiguation we qualify the
- -- type name with its scope (if visible) because both
- -- id's will have corresponding entities in an instance.
- -- This resolves most of the problems with missing type
- -- information on aggregates in instances.
-
- if Nkind (N2) = Nkind (N)
- and then Nkind (Parent (N2)) in N_Subprogram_Call
- and then Comes_From_Source (Typ)
- then
- if Is_Immediately_Visible (Scope (Typ)) then
- Nam :=
- Make_Selected_Component (Loc,
- Prefix =>
- Make_Identifier (Loc, Chars (Scope (Typ))),
- Selector_Name =>
- Make_Identifier (Loc, Chars (Typ)));
- else
- Nam := Make_Identifier (Loc, Chars (Typ));
- end if;
+ elsif Nkind (N) = N_Pragma then
+ Save_References_In_Pragma (N);
- Qual :=
- Make_Qualified_Expression (Loc,
- Subtype_Mark => Nam,
- Expression => Relocate_Node (N));
- end if;
- end if;
+ else
+ Save_References_In_Descendants (N);
+ end if;
- Save_Global_Descendant (Field1 (N));
- Save_Global_Descendant (Field2 (N));
- Save_Global_Descendant (Field3 (N));
- Save_Global_Descendant (Field5 (N));
+ -- Save all global references found within the aspect specifications
+ -- of the related node.
- if Present (Qual) then
- Rewrite (N, Qual);
- end if;
+ if Permits_Aspect_Specifications (N) and then Has_Aspects (N) then
- -- All other cases than aggregates
+ -- The capture of global references within aspects associated with
+ -- generic packages, subprograms or their bodies must be delayed
+ -- due to timing of annotation analysis. Global references are
+ -- still captured in routine Save_Global_References_In_Contract.
- else
- Save_Global_Descendant (Field1 (N));
- Save_Global_Descendant (Field2 (N));
- Save_Global_Descendant (Field3 (N));
- Save_Global_Descendant (Field4 (N));
- Save_Global_Descendant (Field5 (N));
- end if;
- end;
- end if;
+ if Requires_Delayed_Save (N) then
+ null;
- -- Save all global references found within the aspects of the related
- -- node. This is not done for generic subprograms because the aspects
- -- must be delayed and analyzed at the end of the declarative part.
- -- Only then can global references be saved. This action is performed
- -- by the analysis of the generic subprogram contract.
+ -- Otherwise save all global references within the aspects
- if Nkind (N) /= N_Generic_Subprogram_Declaration then
- Save_Global_References_In_Aspects (N);
+ else
+ Save_Global_References_In_Aspects (N);
+ end if;
end if;
end Save_References;
Gen_Scope := Scope (Gen_Scope);
end loop;
- Save_References (N);
+ Save_References (Templ);
end Save_Global_References;
---------------------------------------
Expr : Node_Id;
begin
- if Permits_Aspect_Specifications (N) and then Has_Aspects (N) then
- Asp := First (Aspect_Specifications (N));
- while Present (Asp) loop
- Expr := Expression (Asp);
+ Asp := First (Aspect_Specifications (N));
+ while Present (Asp) loop
+ Expr := Expression (Asp);
- if Present (Expr) then
- Save_Global_References (Expr);
- end if;
+ if Present (Expr) then
+ Save_Global_References (Expr);
+ end if;
- Next (Asp);
- end loop;
- end if;
+ Next (Asp);
+ end loop;
end Save_Global_References_In_Aspects;
+ ------------------------------------------
+ -- Set_Copied_Sloc_For_Inherited_Pragma --
+ ------------------------------------------
+
+ procedure Set_Copied_Sloc_For_Inherited_Pragma
+ (N : Node_Id;
+ E : Entity_Id)
+ is
+ begin
+ Create_Instantiation_Source (N, E,
+ Inlined_Body => False,
+ Inherited_Pragma => True,
+ Factor => S_Adjustment);
+ end Set_Copied_Sloc_For_Inherited_Pragma;
+
--------------------------------------
-- Set_Copied_Sloc_For_Inlined_Body --
--------------------------------------
procedure Set_Copied_Sloc_For_Inlined_Body (N : Node_Id; E : Entity_Id) is
begin
- Create_Instantiation_Source (N, E, True, S_Adjustment);
+ Create_Instantiation_Source (N, E,
+ Inlined_Body => True,
+ Inherited_Pragma => False,
+ Factor => S_Adjustment);
end Set_Copied_Sloc_For_Inlined_Body;
---------------------
-- Set_Instance_Env --
----------------------
+ -- WARNING: This routine manages SPARK regions
+
procedure Set_Instance_Env
(Gen_Unit : Entity_Id;
Act_Unit : Entity_Id)
is
- Assertion_Status : constant Boolean := Assertions_Enabled;
- Save_SPARK_Mode : constant SPARK_Mode_Type := SPARK_Mode;
- Save_SPARK_Mode_Pragma : constant Node_Id := SPARK_Mode_Pragma;
+ Saved_AE : constant Boolean := Assertions_Enabled;
+ Saved_SM : constant SPARK_Mode_Type := SPARK_Mode;
+ Saved_SMP : constant Node_Id := SPARK_Mode_Pragma;
+ -- Save the SPARK mode-related data because utilizing the configuration
+ -- values of pragmas and switches will eliminate any previously set
+ -- SPARK_Mode.
begin
-- Regardless of the current mode, predefined units are analyzed in the
-- to predefined units. Nothing needs to be done for non-internal units.
-- These are always analyzed in the current mode.
- if Is_Internal_File_Name
- (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)),
- Renamings_Included => True)
- then
+ if In_Internal_Unit (Gen_Unit) then
Set_Opt_Config_Switches (True, Current_Sem_Unit = Main_Unit);
-- In Ada2012 we may want to enable assertions in an instance of a
-- as is already the case for some numeric libraries.
if Ada_Version >= Ada_2012 then
- Assertions_Enabled := Assertion_Status;
+ Assertions_Enabled := Saved_AE;
end if;
- -- SPARK_Mode for an instance is the one applicable at the point of
+ -- Reinstall the SPARK_Mode which was in effect at the point of
-- instantiation.
- SPARK_Mode := Save_SPARK_Mode;
- SPARK_Mode_Pragma := Save_SPARK_Mode_Pragma;
-
- -- Make sure dynamic elaboration checks are off in SPARK Mode
-
- if SPARK_Mode = On then
- Dynamic_Elaboration_Checks := False;
- end if;
+ Install_SPARK_Mode (Saved_SM, Saved_SMP);
end if;
Current_Instantiated_Parent :=
T : constant Entity_Id := Entity (Prefix (Def));
Is_Fun : constant Boolean := (Ekind (Nam) = E_Function);
F : Entity_Id;
- Num_F : Int;
+ Num_F : Nat;
OK : Boolean;
begin
end loop;
case Attr_Id is
- when Attribute_Adjacent | Attribute_Ceiling | Attribute_Copy_Sign |
- Attribute_Floor | Attribute_Fraction | Attribute_Machine |
- Attribute_Model | Attribute_Remainder | Attribute_Rounding |
- Attribute_Unbiased_Rounding =>
+ when Attribute_Adjacent
+ | Attribute_Ceiling
+ | Attribute_Copy_Sign
+ | Attribute_Floor
+ | Attribute_Fraction
+ | Attribute_Machine
+ | Attribute_Model
+ | Attribute_Remainder
+ | Attribute_Rounding
+ | Attribute_Unbiased_Rounding
+ =>
OK := Is_Fun
and then Num_F = 1
and then Is_Floating_Point_Type (T);
- when Attribute_Image | Attribute_Pred | Attribute_Succ |
- Attribute_Value | Attribute_Wide_Image |
- Attribute_Wide_Value =>
- OK := (Is_Fun and then Num_F = 1 and then Is_Scalar_Type (T));
+ when Attribute_Image
+ | Attribute_Pred
+ | Attribute_Succ
+ | Attribute_Value
+ | Attribute_Wide_Image
+ | Attribute_Wide_Value
+ =>
+ OK := Is_Fun and then Num_F = 1 and then Is_Scalar_Type (T);
- when Attribute_Max | Attribute_Min =>
- OK := (Is_Fun and then Num_F = 2 and then Is_Scalar_Type (T));
+ when Attribute_Max
+ | Attribute_Min
+ =>
+ OK := Is_Fun and then Num_F = 2 and then Is_Scalar_Type (T);
when Attribute_Input =>
OK := (Is_Fun and then Num_F = 1);
- when Attribute_Output | Attribute_Read | Attribute_Write =>
- OK := (not Is_Fun and then Num_F = 2);
+ when Attribute_Output
+ | Attribute_Read
+ | Attribute_Write
+ =>
+ OK := not Is_Fun and then Num_F = 2;
when others =>
OK := False;
projects / gcc.git / blobdiff