Google Git
Sign in
gnu / gcc / refs/tags/basepoints/gcc-13 / . / gcc / ada / sem_util.adb
blob: 3c55dda5a85666d52d2087e10b54470d6b5f6854 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S E M _ U T I L --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2022, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Casing; use Casing;
with Checks; use Checks;
with Debug; use Debug;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
with Erroutc; use Erroutc;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch11; use Exp_Ch11;
with Exp_Util; use Exp_Util;
with Fname; use Fname;
with Freeze; use Freeze;
with Itypes; use Itypes;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
with Namet.Sp; use Namet.Sp;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Output; use Output;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Attr; use Sem_Attr;
with Sem_Cat; use Sem_Cat;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Disp; use Sem_Disp;
with Sem_Elab; use Sem_Elab;
with Sem_Eval; use Sem_Eval;
with Sem_Prag; use Sem_Prag;
with Sem_Res; use Sem_Res;
with Sem_Warn; use Sem_Warn;
with Sem_Type; use Sem_Type;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sinput; use Sinput;
with Stand; use Stand;
with Style;
with Stringt; use Stringt;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uname; use Uname;
with GNAT.Heap_Sort_G;
with GNAT.HTable; use GNAT.HTable;
package body Sem_Util is
---------------------------
-- Local Data Structures --
---------------------------
Invalid_Binder_Values : array (Scalar_Id) of Entity_Id := (others => Empty);
-- A collection to hold the entities of the variables declared in package
-- System.Scalar_Values which describe the invalid values of scalar types.
Invalid_Binder_Values_Set : Boolean := False;
-- This flag prevents multiple attempts to initialize Invalid_Binder_Values
Invalid_Floats : array (Float_Scalar_Id) of Ureal := (others => No_Ureal);
-- A collection to hold the invalid values of float types as specified by
-- pragma Initialize_Scalars.
Invalid_Integers : array (Integer_Scalar_Id) of Uint := (others => No_Uint);
-- A collection to hold the invalid values of integer types as specified
-- by pragma Initialize_Scalars.
-----------------------
-- Local Subprograms --
-----------------------
function Build_Component_Subtype
(C : List_Id;
Loc : Source_Ptr;
T : Entity_Id) return Node_Id;
-- This function builds the subtype for Build_Actual_Subtype_Of_Component
-- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
-- Loc is the source location, T is the original subtype.
procedure Examine_Array_Bounds
(Typ : Entity_Id;
All_Static : out Boolean;
Has_Empty : out Boolean);
-- Inspect the index constraints of array type Typ. Flag All_Static is set
-- when all ranges are static. Flag Has_Empty is set only when All_Static
-- is set and indicates that at least one range is empty.
function Has_Enabled_Property
(Item_Id : Entity_Id;
Property : Name_Id) return Boolean;
-- Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled.
-- Determine whether the state abstraction, object, or type denoted by
-- entity Item_Id has enabled property Property.
function Has_Null_Extension (T : Entity_Id) return Boolean;
-- T is a derived tagged type. Check whether the type extension is null.
-- If the parent type is fully initialized, T can be treated as such.
function Is_Atomic_Object_Entity (Id : Entity_Id) return Boolean;
-- Determine whether arbitrary entity Id denotes an atomic object as per
-- RM C.6(7).
function Is_Container_Aggregate (Exp : Node_Id) return Boolean;
-- Is the given expression a container aggregate?
generic
with function Is_Effectively_Volatile_Entity
(Id : Entity_Id) return Boolean;
-- Function to use on object and type entities
function Is_Effectively_Volatile_Object_Shared
(N : Node_Id) return Boolean;
-- Shared function used to detect effectively volatile objects and
-- effectively volatile objects for reading.
function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean;
-- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
-- with discriminants whose default values are static, examine only the
-- components in the selected variant to determine whether all of them
-- have a default.
function Is_Preelaborable_Function (Id : Entity_Id) return Boolean;
-- Ada 2022: Determine whether the specified function is suitable as the
-- name of a call in a preelaborable construct (RM 10.2.1(7/5)).
type Null_Status_Kind is
(Is_Null,
-- This value indicates that a subexpression is known to have a null
-- value at compile time.
Is_Non_Null,
-- This value indicates that a subexpression is known to have a non-null
-- value at compile time.
Unknown);
-- This value indicates that it cannot be determined at compile time
-- whether a subexpression yields a null or non-null value.
function Null_Status (N : Node_Id) return Null_Status_Kind;
-- Determine whether subexpression N of an access type yields a null value,
-- a non-null value, or the value cannot be determined at compile time. The
-- routine does not take simple flow diagnostics into account, it relies on
-- static facts such as the presence of null exclusions.
function Subprogram_Name (N : Node_Id) return String;
-- Return the fully qualified name of the enclosing subprogram for the
-- given node N, with file:line:col information appended, e.g.
-- "subp:file:line:col", corresponding to the source location of the
-- body of the subprogram.
-----------------------------
-- Abstract_Interface_List --
-----------------------------
function Abstract_Interface_List (Typ : Entity_Id) return List_Id is
Nod : Node_Id;
begin
if Is_Concurrent_Type (Typ) then
-- If we are dealing with a synchronized subtype, go to the base
-- type, whose declaration has the interface list.
Nod := Declaration_Node (Base_Type (Typ));
if Nkind (Nod) in N_Full_Type_Declaration | N_Private_Type_Declaration
then
return Empty_List;
end if;
elsif Ekind (Typ) = E_Record_Type_With_Private then
if Nkind (Parent (Typ)) = N_Full_Type_Declaration then
Nod := Type_Definition (Parent (Typ));
elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then
if Present (Full_View (Typ))
and then
Nkind (Parent (Full_View (Typ))) = N_Full_Type_Declaration
then
Nod := Type_Definition (Parent (Full_View (Typ)));
-- If the full-view is not available we cannot do anything else
-- here (the source has errors).
else
return Empty_List;
end if;
-- Support for generic formals with interfaces is still missing ???
elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
return Empty_List;
else
pragma Assert
(Nkind (Parent (Typ)) = N_Private_Extension_Declaration);
Nod := Parent (Typ);
end if;
elsif Ekind (Typ) = E_Record_Subtype then
Nod := Type_Definition (Parent (Etype (Typ)));
elsif Ekind (Typ) = E_Record_Subtype_With_Private then
-- Recurse, because parent may still be a private extension. Also
-- note that the full view of the subtype or the full view of its
-- base type may (both) be unavailable.
return Abstract_Interface_List (Etype (Typ));
elsif Ekind (Typ) = E_Record_Type then
if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
Nod := Formal_Type_Definition (Parent (Typ));
else
Nod := Type_Definition (Parent (Typ));
end if;
-- Otherwise the type is of a kind which does not implement interfaces
else
return Empty_List;
end if;
return Interface_List (Nod);
end Abstract_Interface_List;
-------------------------
-- Accessibility_Level --
-------------------------
function Accessibility_Level
(Expr : Node_Id;
Level : Accessibility_Level_Kind;
In_Return_Context : Boolean := False;
Allow_Alt_Model : Boolean := True) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Expr);
function Accessibility_Level (Expr : Node_Id) return Node_Id
is (Accessibility_Level (Expr, Level, In_Return_Context));
-- Renaming of the enclosing function to facilitate recursive calls
function Make_Level_Literal (Level : Uint) return Node_Id;
-- Construct an integer literal representing an accessibility level
-- with its type set to Natural.
function Innermost_Master_Scope_Depth (N : Node_Id) return Uint;
-- Returns the scope depth of the given node's innermost
-- enclosing dynamic scope (effectively the accessibility
-- level of the innermost enclosing master).
function Function_Call_Or_Allocator_Level (N : Node_Id) return Node_Id;
-- Centralized processing of subprogram calls which may appear in
-- prefix notation.
function Typ_Access_Level (Typ : Entity_Id) return Uint
is (Type_Access_Level (Typ, Allow_Alt_Model));
-- Renaming of Type_Access_Level with Allow_Alt_Model specified to avoid
-- passing the parameter specifically in every call.
----------------------------------
-- Innermost_Master_Scope_Depth --
----------------------------------
function Innermost_Master_Scope_Depth (N : Node_Id) return Uint is
Encl_Scop : Entity_Id;
Ent : Entity_Id;
Node_Par : Node_Id := Parent (N);
Master_Lvl_Modifier : Int := 0;
begin
-- Locate the nearest enclosing node (by traversing Parents)
-- that Defining_Entity can be applied to, and return the
-- depth of that entity's nearest enclosing dynamic scope.
-- The rules that define what a master are defined in
-- RM 7.6.1 (3), and include statements and conditions for loops
-- among other things. These cases are detected properly ???
while Present (Node_Par) loop
Ent := Defining_Entity_Or_Empty (Node_Par);
if Present (Ent) then
Encl_Scop := Nearest_Dynamic_Scope (Ent);
-- Ignore transient scopes made during expansion
if Comes_From_Source (Node_Par) then
return
Scope_Depth_Default_0 (Encl_Scop) + Master_Lvl_Modifier;
end if;
-- For a return statement within a function, return
-- the depth of the function itself. This is not just
-- a small optimization, but matters when analyzing
-- the expression in an expression function before
-- the body is created.
elsif Nkind (Node_Par) in N_Extended_Return_Statement
| N_Simple_Return_Statement
and then Ekind (Current_Scope) = E_Function
then
return Scope_Depth (Current_Scope);
-- Statements are counted as masters
elsif Is_Master (Node_Par) then
Master_Lvl_Modifier := Master_Lvl_Modifier + 1;
end if;
Node_Par := Parent (Node_Par);
end loop;
-- Should never reach the following return
pragma Assert (False);
return Scope_Depth (Current_Scope) + 1;
end Innermost_Master_Scope_Depth;
------------------------
-- Make_Level_Literal --
------------------------
function Make_Level_Literal (Level : Uint) return Node_Id is
Result : constant Node_Id := Make_Integer_Literal (Loc, Level);
begin
Set_Etype (Result, Standard_Natural);
return Result;
end Make_Level_Literal;
--------------------------------------
-- Function_Call_Or_Allocator_Level --
--------------------------------------
function Function_Call_Or_Allocator_Level (N : Node_Id) return Node_Id is
Par : Node_Id;
Prev_Par : Node_Id;
begin
-- Results of functions are objects, so we either get the
-- accessibility of the function or, in case of a call which is
-- indirect, the level of the access-to-subprogram type.
-- This code looks wrong ???
if Nkind (N) = N_Function_Call
and then Ada_Version < Ada_2005
then
if Is_Entity_Name (Name (N)) then
return Make_Level_Literal
(Subprogram_Access_Level (Entity (Name (N))));
else
return Make_Level_Literal
(Typ_Access_Level (Etype (Prefix (Name (N)))));
end if;
-- We ignore coextensions as they cannot be implemented under the
-- "small-integer" model.
elsif Nkind (N) = N_Allocator
and then (Is_Static_Coextension (N)
or else Is_Dynamic_Coextension (N))
then
return Make_Level_Literal (Scope_Depth (Standard_Standard));
end if;
-- Named access types have a designated level
if Is_Named_Access_Type (Etype (N)) then
return Make_Level_Literal (Typ_Access_Level (Etype (N)));
-- Otherwise, the level is dictated by RM 3.10.2 (10.7/3)
else
-- Check No_Dynamic_Accessibility_Checks restriction override for
-- alternative accessibility model.
if Allow_Alt_Model
and then No_Dynamic_Accessibility_Checks_Enabled (N)
and then Is_Anonymous_Access_Type (Etype (N))
then
-- In the alternative model the level is that of the
-- designated type.
if Debug_Flag_Underscore_B then
return Make_Level_Literal (Typ_Access_Level (Etype (N)));
-- For function calls the level is that of the innermost
-- master, otherwise (for allocators etc.) we get the level
-- of the corresponding anonymous access type, which is
-- calculated through the normal path of execution.
elsif Nkind (N) = N_Function_Call then
return Make_Level_Literal
(Innermost_Master_Scope_Depth (Expr));
end if;
end if;
if Nkind (N) = N_Function_Call then
-- Dynamic checks are generated when we are within a return
-- value or we are in a function call within an anonymous
-- access discriminant constraint of a return object (signified
-- by In_Return_Context) on the side of the callee.
-- So, in this case, return accessibility level of the
-- enclosing subprogram.
if In_Return_Value (N)
or else In_Return_Context
then
return Make_Level_Literal
(Subprogram_Access_Level (Current_Subprogram));
end if;
end if;
-- When the call is being dereferenced the level is that of the
-- enclosing master of the dereferenced call.
if Nkind (Parent (N)) in N_Explicit_Dereference
| N_Indexed_Component
| N_Selected_Component
then
return Make_Level_Literal
(Innermost_Master_Scope_Depth (Expr));
end if;
-- Find any relevant enclosing parent nodes that designate an
-- object being initialized.
-- Note: The above is only relevant if the result is used "in its
-- entirety" as RM 3.10.2 (10.2/3) states. However, this is
-- accounted for in the case statement in the main body of
-- Accessibility_Level for N_Selected_Component.
Par := Parent (Expr);
Prev_Par := Empty;
while Present (Par) loop
-- Detect an expanded implicit conversion, typically this
-- occurs on implicitly converted actuals in calls.
-- Does this catch all implicit conversions ???
if Nkind (Par) = N_Type_Conversion
and then Is_Named_Access_Type (Etype (Par))
then
return Make_Level_Literal
(Typ_Access_Level (Etype (Par)));
end if;
-- Jump out when we hit an object declaration or the right-hand
-- side of an assignment, or a construct such as an aggregate
-- subtype indication which would be the result is not used
-- "in its entirety."
exit when Nkind (Par) in N_Object_Declaration
or else (Nkind (Par) = N_Assignment_Statement
and then Name (Par) /= Prev_Par);
Prev_Par := Par;
Par := Parent (Par);
end loop;
-- Assignment statements are handled in a similar way in
-- accordance to the left-hand part. However, strictly speaking,
-- this is illegal according to the RM, but this change is needed
-- to pass an ACATS C-test and is useful in general ???
case Nkind (Par) is
when N_Object_Declaration =>
return Make_Level_Literal
(Scope_Depth
(Scope (Defining_Identifier (Par))));
when N_Assignment_Statement =>
-- Return the accessibility level of the left-hand part
return Accessibility_Level
(Expr => Name (Par),
Level => Object_Decl_Level,
In_Return_Context => In_Return_Context);
when others =>
return Make_Level_Literal
(Innermost_Master_Scope_Depth (Expr));
end case;
end if;
end Function_Call_Or_Allocator_Level;
-- Local variables
E : Entity_Id := Original_Node (Expr);
Pre : Node_Id;
-- Start of processing for Accessibility_Level
begin
-- We could be looking at a reference to a formal due to the expansion
-- of entries and other cases, so obtain the renaming if necessary.
if Present (Param_Entity (Expr)) then
E := Param_Entity (Expr);
end if;
-- Extract the entity
if Nkind (E) in N_Has_Entity and then Present (Entity (E)) then
E := Entity (E);
-- Deal with a possible renaming of a private protected component
if Ekind (E) in E_Constant | E_Variable and then Is_Prival (E) then
E := Prival_Link (E);
end if;
end if;
-- Perform the processing on the expression
case Nkind (E) is
-- The level of an aggregate is that of the innermost master that
-- evaluates it as defined in RM 3.10.2 (10/4).
when N_Aggregate =>
return Make_Level_Literal (Innermost_Master_Scope_Depth (Expr));
-- The accessibility level is that of the access type, except for an
-- anonymous allocators which have special rules defined in RM 3.10.2
-- (14/3).
when N_Allocator =>
return Function_Call_Or_Allocator_Level (E);
-- We could reach this point for two reasons. Either the expression
-- applies to a special attribute ('Loop_Entry, 'Result, or 'Old), or
-- we are looking at the access attributes directly ('Access,
-- 'Address, or 'Unchecked_Access).
when N_Attribute_Reference =>
Pre := Original_Node (Prefix (E));
-- Regular 'Access attribute presence means we have to look at the
-- prefix.
if Attribute_Name (E) = Name_Access then
return Accessibility_Level (Prefix (E));
-- Unchecked or unrestricted attributes have unlimited depth
elsif Attribute_Name (E) in Name_Address
| Name_Unchecked_Access
| Name_Unrestricted_Access
then
return Make_Level_Literal (Scope_Depth (Standard_Standard));
-- 'Access can be taken further against other special attributes,
-- so handle these cases explicitly.
elsif Attribute_Name (E)
in Name_Old | Name_Loop_Entry | Name_Result
then
-- Named access types
if Is_Named_Access_Type (Etype (Pre)) then
return Make_Level_Literal
(Typ_Access_Level (Etype (Pre)));
-- Anonymous access types
elsif Nkind (Pre) in N_Has_Entity
and then Present (Get_Dynamic_Accessibility (Entity (Pre)))
and then Level = Dynamic_Level
then
return New_Occurrence_Of
(Get_Dynamic_Accessibility (Entity (Pre)), Loc);
-- Otherwise the level is treated in a similar way as
-- aggregates according to RM 6.1.1 (35.1/4) which concerns
-- an implicit constant declaration - in turn defining the
-- accessibility level to be that of the implicit constant
-- declaration.
else
return Make_Level_Literal
(Innermost_Master_Scope_Depth (Expr));
end if;
else
raise Program_Error;
end if;
-- This is the "base case" for accessibility level calculations which
-- means we are near the end of our recursive traversal.
when N_Defining_Identifier =>
-- A dynamic check is performed on the side of the callee when we
-- are within a return statement, so return a library-level
-- accessibility level to null out checks on the side of the
-- caller.
if Is_Explicitly_Aliased (E)
and then (In_Return_Context
or else (Level /= Dynamic_Level
and then In_Return_Value (Expr)))
then
return Make_Level_Literal (Scope_Depth (Standard_Standard));
-- Something went wrong and an extra accessibility formal has not
-- been generated when one should have ???
elsif Is_Formal (E)
and then not Present (Get_Dynamic_Accessibility (E))
and then Ekind (Etype (E)) = E_Anonymous_Access_Type
then
return Make_Level_Literal (Scope_Depth (Standard_Standard));
-- Stand-alone object of an anonymous access type "SAOAAT"
elsif (Is_Formal (E)
or else Ekind (E) in E_Variable
| E_Constant)
and then Present (Get_Dynamic_Accessibility (E))
and then (Level = Dynamic_Level
or else Level = Zero_On_Dynamic_Level)
then
if Level = Zero_On_Dynamic_Level then
return Make_Level_Literal
(Scope_Depth (Standard_Standard));
end if;
-- No_Dynamic_Accessibility_Checks restriction override for
-- alternative accessibility model.
if Allow_Alt_Model
and then No_Dynamic_Accessibility_Checks_Enabled (E)
then
-- In the alternative model the level is that of the
-- designated type entity's context.
if Debug_Flag_Underscore_B then
return Make_Level_Literal (Typ_Access_Level (Etype (E)));
-- Otherwise the level depends on the entity's context
elsif Is_Formal (E) then
return Make_Level_Literal
(Subprogram_Access_Level
(Enclosing_Subprogram (E)));
else
return Make_Level_Literal
(Scope_Depth (Enclosing_Dynamic_Scope (E)));
end if;
end if;
-- Return the dynamic level in the normal case
return New_Occurrence_Of
(Get_Dynamic_Accessibility (E), Loc);
-- Initialization procedures have a special extra accessibility
-- parameter associated with the level at which the object
-- being initialized exists
elsif Ekind (E) = E_Record_Type
and then Is_Limited_Record (E)
and then Current_Scope = Init_Proc (E)
and then Present (Init_Proc_Level_Formal (Current_Scope))
then
return New_Occurrence_Of
(Init_Proc_Level_Formal (Current_Scope), Loc);
-- Current instance of the type is deeper than that of the type
-- according to RM 3.10.2 (21).
elsif Is_Type (E) then
-- When restriction No_Dynamic_Accessibility_Checks is active
-- along with -gnatd_b.
if Allow_Alt_Model
and then No_Dynamic_Accessibility_Checks_Enabled (E)
and then Debug_Flag_Underscore_B
then
return Make_Level_Literal (Typ_Access_Level (E));
end if;
-- Normal path
return Make_Level_Literal (Typ_Access_Level (E) + 1);
-- Move up the renamed entity or object if it came from source
-- since expansion may have created a dummy renaming under
-- certain circumstances.
-- Note: We check if the original node of the renaming comes
-- from source because the node may have been rewritten.
elsif Present (Renamed_Entity_Or_Object (E))
and then Comes_From_Source
(Original_Node (Renamed_Entity_Or_Object (E)))
then
return Accessibility_Level (Renamed_Entity_Or_Object (E));
-- Named access types get their level from their associated type
elsif Is_Named_Access_Type (Etype (E)) then
return Make_Level_Literal
(Typ_Access_Level (Etype (E)));
-- Check if E is an expansion-generated renaming of an iterator
-- by examining Related_Expression. If so, determine the
-- accessibility level based on the original expression.
elsif Ekind (E) in E_Constant | E_Variable
and then Present (Related_Expression (E))
then
return Accessibility_Level (Related_Expression (E));
elsif Level = Dynamic_Level
and then Ekind (E) in E_In_Parameter | E_In_Out_Parameter
and then Present (Init_Proc_Level_Formal (Scope (E)))
then
return New_Occurrence_Of
(Init_Proc_Level_Formal (Scope (E)), Loc);
-- Normal object - get the level of the enclosing scope
else
return Make_Level_Literal
(Scope_Depth (Enclosing_Dynamic_Scope (E)));
end if;
-- Handle indexed and selected components including the special cases
-- whereby there is an implicit dereference, a component of a
-- composite type, or a function call in prefix notation.
-- We don't handle function calls in prefix notation correctly ???
when N_Indexed_Component | N_Selected_Component =>
Pre := Original_Node (Prefix (E));
-- When E is an indexed component or selected component and
-- the current Expr is a function call, we know that we are
-- looking at an expanded call in prefix notation.
if Nkind (Expr) = N_Function_Call then
return Function_Call_Or_Allocator_Level (Expr);
-- If the prefix is a named access type, then we are dealing
-- with an implicit deferences. In that case the level is that
-- of the named access type in the prefix.
elsif Is_Named_Access_Type (Etype (Pre)) then
return Make_Level_Literal
(Typ_Access_Level (Etype (Pre)));
-- The current expression is a named access type, so there is no
-- reason to look at the prefix. Instead obtain the level of E's
-- named access type.
elsif Is_Named_Access_Type (Etype (E)) then
return Make_Level_Literal
(Typ_Access_Level (Etype (E)));
-- A nondiscriminant selected component where the component
-- is an anonymous access type means that its associated
-- level is that of the containing type - see RM 3.10.2 (16).
-- Note that when restriction No_Dynamic_Accessibility_Checks is
-- in effect we treat discriminant components as regular
-- components.
elsif Nkind (E) = N_Selected_Component
and then Ekind (Etype (E)) = E_Anonymous_Access_Type
and then Ekind (Etype (Pre)) /= E_Anonymous_Access_Type
and then (not (Nkind (Selector_Name (E)) in N_Has_Entity
and then Ekind (Entity (Selector_Name (E)))
= E_Discriminant)
-- The alternative accessibility models both treat
-- discriminants as regular components.
or else (No_Dynamic_Accessibility_Checks_Enabled (E)
and then Allow_Alt_Model))
then
-- When restriction No_Dynamic_Accessibility_Checks is active
-- and -gnatd_b set, the level is that of the designated type.
if Allow_Alt_Model
and then No_Dynamic_Accessibility_Checks_Enabled (E)
and then Debug_Flag_Underscore_B
then
return Make_Level_Literal
(Typ_Access_Level (Etype (E)));
end if;
-- Otherwise proceed normally
return Make_Level_Literal
(Typ_Access_Level (Etype (Prefix (E))));
-- Similar to the previous case - arrays featuring components of
-- anonymous access components get their corresponding level from
-- their containing type's declaration.
elsif Nkind (E) = N_Indexed_Component
and then Ekind (Etype (E)) = E_Anonymous_Access_Type
and then Ekind (Etype (Pre)) in Array_Kind
and then Ekind (Component_Type (Base_Type (Etype (Pre))))
= E_Anonymous_Access_Type
then
-- When restriction No_Dynamic_Accessibility_Checks is active
-- and -gnatd_b set, the level is that of the designated type.
if Allow_Alt_Model
and then No_Dynamic_Accessibility_Checks_Enabled (E)
and then Debug_Flag_Underscore_B
then
return Make_Level_Literal
(Typ_Access_Level (Etype (E)));
end if;
-- Otherwise proceed normally
return Make_Level_Literal
(Typ_Access_Level (Etype (Prefix (E))));
-- The accessibility calculation routine that handles function
-- calls (Function_Call_Level) assumes, in the case the
-- result is of an anonymous access type, that the result will be
-- used "in its entirety" when the call is present within an
-- assignment or object declaration.
-- To properly handle cases where the result is not used in its
-- entirety, we test if the prefix of the component in question is
-- a function call, which tells us that one of its components has
-- been identified and is being accessed. Therefore we can
-- conclude that the result is not used "in its entirety"
-- according to RM 3.10.2 (10.2/3).
elsif Nkind (Pre) = N_Function_Call
and then not Is_Named_Access_Type (Etype (Pre))
then
-- Dynamic checks are generated when we are within a return
-- value or we are in a function call within an anonymous
-- access discriminant constraint of a return object (signified
-- by In_Return_Context) on the side of the callee.
-- So, in this case, return a library accessibility level to
-- null out the check on the side of the caller.
if (In_Return_Value (E)
or else In_Return_Context)
and then Level /= Dynamic_Level
then
return Make_Level_Literal
(Scope_Depth (Standard_Standard));
end if;
return Make_Level_Literal
(Innermost_Master_Scope_Depth (Expr));
-- Otherwise, continue recursing over the expression prefixes
else
return Accessibility_Level (Prefix (E));
end if;
-- Qualified expressions
when N_Qualified_Expression =>
if Is_Named_Access_Type (Etype (E)) then
return Make_Level_Literal
(Typ_Access_Level (Etype (E)));
else
return Accessibility_Level (Expression (E));
end if;
-- Handle function calls
when N_Function_Call =>
return Function_Call_Or_Allocator_Level (E);
-- Explicit dereference accessibility level calculation
when N_Explicit_Dereference =>
Pre := Original_Node (Prefix (E));
-- The prefix is a named access type so the level is taken from
-- its type.
if Is_Named_Access_Type (Etype (Pre)) then
return Make_Level_Literal (Typ_Access_Level (Etype (Pre)));
-- Otherwise, recurse deeper
else
return Accessibility_Level (Prefix (E));
end if;
-- Type conversions
when N_Type_Conversion | N_Unchecked_Type_Conversion =>
-- View conversions are special in that they require use to
-- inspect the expression of the type conversion.
-- Allocators of anonymous access types are internally generated,
-- so recurse deeper in that case as well.
if Is_View_Conversion (E)
or else Ekind (Etype (E)) = E_Anonymous_Access_Type
then
return Accessibility_Level (Expression (E));
-- We don't care about the master if we are looking at a named
-- access type.
elsif Is_Named_Access_Type (Etype (E)) then
return Make_Level_Literal
(Typ_Access_Level (Etype (E)));
-- In section RM 3.10.2 (10/4) the accessibility rules for
-- aggregates and value conversions are outlined. Are these
-- followed in the case of initialization of an object ???
-- Should use Innermost_Master_Scope_Depth ???
else
return Accessibility_Level (Current_Scope);
end if;
-- Default to the type accessibility level for the type of the
-- expression's entity.
when others =>
return Make_Level_Literal (Typ_Access_Level (Etype (E)));
end case;
end Accessibility_Level;
--------------------------------
-- Static_Accessibility_Level --
--------------------------------
function Static_Accessibility_Level
(Expr : Node_Id;
Level : Static_Accessibility_Level_Kind;
In_Return_Context : Boolean := False) return Uint
is
begin
return Intval
(Accessibility_Level (Expr, Level, In_Return_Context));
end Static_Accessibility_Level;
----------------------------------
-- Acquire_Warning_Match_String --
----------------------------------
function Acquire_Warning_Match_String (Str_Lit : Node_Id) return String is
S : constant String := To_String (Strval (Str_Lit));
begin
if S = "" then
return "";
else
-- Put "*" before or after or both, if it's not already there
declare
F : constant Boolean := S (S'First) = '*';
L : constant Boolean := S (S'Last) = '*';
begin
if F then
if L then
return S;
else
return S & "*";
end if;
else
if L then
return "*" & S;
else
return "*" & S & "*";
end if;
end if;
end;
end if;
end Acquire_Warning_Match_String;
--------------------------------
-- Add_Access_Type_To_Process --
--------------------------------
procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is
L : Elist_Id;
begin
Ensure_Freeze_Node (E);
L := Access_Types_To_Process (Freeze_Node (E));
if No (L) then
L := New_Elmt_List;
Set_Access_Types_To_Process (Freeze_Node (E), L);
end if;
Append_Elmt (A, L);
end Add_Access_Type_To_Process;
--------------------------
-- Add_Block_Identifier --
--------------------------
procedure Add_Block_Identifier (N : Node_Id; Id : out Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
begin
pragma Assert (Nkind (N) = N_Block_Statement);
-- The block already has a label, return its entity
if Present (Identifier (N)) then
Id := Entity (Identifier (N));
-- Create a new block label and set its attributes
else
Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
Set_Etype (Id, Standard_Void_Type);
Set_Parent (Id, N);
Set_Identifier (N, New_Occurrence_Of (Id, Loc));
Set_Block_Node (Id, Identifier (N));
end if;
end Add_Block_Identifier;
----------------------------
-- Add_Global_Declaration --
----------------------------
procedure Add_Global_Declaration (N : Node_Id) is
Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit));
begin
if No (Declarations (Aux_Node)) then
Set_Declarations (Aux_Node, New_List);
end if;
Append_To (Declarations (Aux_Node), N);
Analyze (N);
end Add_Global_Declaration;
--------------------------------
-- Address_Integer_Convert_OK --
--------------------------------
function Address_Integer_Convert_OK (T1, T2 : Entity_Id) return Boolean is
begin
if Allow_Integer_Address
and then ((Is_Descendant_Of_Address (T1)
and then Is_Private_Type (T1)
and then Is_Integer_Type (T2))
or else
(Is_Descendant_Of_Address (T2)
and then Is_Private_Type (T2)
and then Is_Integer_Type (T1)))
then
return True;
else
return False;
end if;
end Address_Integer_Convert_OK;
-------------------
-- Address_Value --
-------------------
function Address_Value (N : Node_Id) return Node_Id is
Expr : Node_Id := N;
begin
loop
-- For constant, get constant expression
if Is_Entity_Name (Expr)
and then Ekind (Entity (Expr)) = E_Constant
then
Expr := Constant_Value (Entity (Expr));
-- For unchecked conversion, get result to convert
elsif Nkind (Expr) = N_Unchecked_Type_Conversion then
Expr := Expression (Expr);
-- For (common case) of To_Address call, get argument
elsif Nkind (Expr) = N_Function_Call
and then Is_Entity_Name (Name (Expr))
and then Is_RTE (Entity (Name (Expr)), RE_To_Address)
then
Expr := First_Actual (Expr);
-- We finally have the real expression
else
exit;
end if;
end loop;
return Expr;
end Address_Value;
-----------------
-- Addressable --
-----------------
function Addressable (V : Uint) return Boolean is
begin
if No (V) then
return False;
end if;
return V = Uint_8 or else
V = Uint_16 or else
V = Uint_32 or else
V = Uint_64 or else
(V = Uint_128 and then System_Max_Integer_Size = 128);
end Addressable;
function Addressable (V : Int) return Boolean is
begin
return V = 8 or else
V = 16 or else
V = 32 or else
V = 64 or else
V = System_Max_Integer_Size;
end Addressable;
---------------------------------
-- Aggregate_Constraint_Checks --
---------------------------------
procedure Aggregate_Constraint_Checks
(Exp : Node_Id;
Check_Typ : Entity_Id)
is
Exp_Typ : constant Entity_Id := Etype (Exp);
begin
if Raises_Constraint_Error (Exp) then
return;
end if;
-- Ada 2005 (AI-230): Generate a conversion to an anonymous access
-- component's type to force the appropriate accessibility checks.
-- Ada 2005 (AI-231): Generate conversion to the null-excluding type to
-- force the corresponding run-time check
if Is_Access_Type (Check_Typ)
and then Is_Local_Anonymous_Access (Check_Typ)
then
Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
Analyze_And_Resolve (Exp, Check_Typ);
Check_Unset_Reference (Exp);
end if;
-- What follows is really expansion activity, so check that expansion
-- is on and is allowed. In GNATprove mode, we also want check flags to
-- be added in the tree, so that the formal verification can rely on
-- those to be present. In GNATprove mode for formal verification, some
-- treatment typically only done during expansion needs to be performed
-- on the tree, but it should not be applied inside generics. Otherwise,
-- this breaks the name resolution mechanism for generic instances.
if not Expander_Active
and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode)
then
return;
end if;
if Is_Access_Type (Check_Typ)
and then Can_Never_Be_Null (Check_Typ)
and then not Can_Never_Be_Null (Exp_Typ)
then
Install_Null_Excluding_Check (Exp);
end if;
-- First check if we have to insert discriminant checks
if Has_Discriminants (Exp_Typ) then
Apply_Discriminant_Check (Exp, Check_Typ);
-- Next emit length checks for array aggregates
elsif Is_Array_Type (Exp_Typ) then
Apply_Length_Check (Exp, Check_Typ);
-- Finally emit scalar and string checks. If we are dealing with a
-- scalar literal we need to check by hand because the Etype of
-- literals is not necessarily correct.
elsif Is_Scalar_Type (Exp_Typ)
and then Compile_Time_Known_Value (Exp)
then
if Is_Out_Of_Range (Exp, Base_Type (Check_Typ)) then
Apply_Compile_Time_Constraint_Error
(Exp, "value not in range of}??", CE_Range_Check_Failed,
Ent => Base_Type (Check_Typ),
Typ => Base_Type (Check_Typ));
elsif Is_Out_Of_Range (Exp, Check_Typ) then
Apply_Compile_Time_Constraint_Error
(Exp, "value not in range of}??", CE_Range_Check_Failed,
Ent => Check_Typ,
Typ => Check_Typ);
elsif not Range_Checks_Suppressed (Check_Typ) then
Apply_Scalar_Range_Check (Exp, Check_Typ);
end if;
-- Verify that target type is also scalar, to prevent view anomalies
-- in instantiations.
elsif (Is_Scalar_Type (Exp_Typ)
or else Nkind (Exp) = N_String_Literal)
and then Is_Scalar_Type (Check_Typ)
and then Exp_Typ /= Check_Typ
then
if Is_Entity_Name (Exp)
and then Ekind (Entity (Exp)) = E_Constant
then
-- If expression is a constant, it is worthwhile checking whether
-- it is a bound of the type.
if (Is_Entity_Name (Type_Low_Bound (Check_Typ))
and then Entity (Exp) = Entity (Type_Low_Bound (Check_Typ)))
or else
(Is_Entity_Name (Type_High_Bound (Check_Typ))
and then Entity (Exp) = Entity (Type_High_Bound (Check_Typ)))
then
return;
else
Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
Analyze_And_Resolve (Exp, Check_Typ);
Check_Unset_Reference (Exp);
end if;
-- Could use a comment on this case ???
else
Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
Analyze_And_Resolve (Exp, Check_Typ);
Check_Unset_Reference (Exp);
end if;
end if;
end Aggregate_Constraint_Checks;
-----------------------
-- Alignment_In_Bits --
-----------------------
function Alignment_In_Bits (E : Entity_Id) return Uint is
begin
return Alignment (E) * System_Storage_Unit;
end Alignment_In_Bits;
--------------------------------------
-- All_Composite_Constraints_Static --
--------------------------------------
function All_Composite_Constraints_Static
(Constr : Node_Id) return Boolean
is
begin
if No (Constr) or else Error_Posted (Constr) then
return True;
end if;
case Nkind (Constr) is
when N_Subexpr =>
if Nkind (Constr) in N_Has_Entity
and then Present (Entity (Constr))
then
if Is_Type (Entity (Constr)) then
return
not Is_Discrete_Type (Entity (Constr))
or else Is_OK_Static_Subtype (Entity (Constr));
end if;
elsif Nkind (Constr) = N_Range then
return
Is_OK_Static_Expression (Low_Bound (Constr))
and then
Is_OK_Static_Expression (High_Bound (Constr));
elsif Nkind (Constr) = N_Attribute_Reference
and then Attribute_Name (Constr) = Name_Range
then
return
Is_OK_Static_Expression
(Type_Low_Bound (Etype (Prefix (Constr))))
and then
Is_OK_Static_Expression
(Type_High_Bound (Etype (Prefix (Constr))));
end if;
return
not Present (Etype (Constr)) -- previous error
or else not Is_Discrete_Type (Etype (Constr))
or else Is_OK_Static_Expression (Constr);
when N_Discriminant_Association =>
return All_Composite_Constraints_Static (Expression (Constr));
when N_Range_Constraint =>
return
All_Composite_Constraints_Static (Range_Expression (Constr));
when N_Index_Or_Discriminant_Constraint =>
declare
One_Cstr : Entity_Id;
begin
One_Cstr := First (Constraints (Constr));
while Present (One_Cstr) loop
if not All_Composite_Constraints_Static (One_Cstr) then
return False;
end if;
Next (One_Cstr);
end loop;
end;
return True;
when N_Subtype_Indication =>
return
All_Composite_Constraints_Static (Subtype_Mark (Constr))
and then
All_Composite_Constraints_Static (Constraint (Constr));
when others =>
raise Program_Error;
end case;
end All_Composite_Constraints_Static;
------------------------
-- Append_Entity_Name --
------------------------
procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id) is
Temp : Bounded_String;
procedure Inner (E : Entity_Id);
-- Inner recursive routine, keep outer routine nonrecursive to ease
-- debugging when we get strange results from this routine.
-----------
-- Inner --
-----------
procedure Inner (E : Entity_Id) is
Scop : Node_Id;
begin
-- If entity has an internal name, skip by it, and print its scope.
-- Note that we strip a final R from the name before the test; this
-- is needed for some cases of instantiations.
declare
E_Name : Bounded_String;
begin
Append (E_Name, Chars (E));
if E_Name.Chars (E_Name.Length) = 'R' then
E_Name.Length := E_Name.Length - 1;
end if;
if Is_Internal_Name (E_Name) then
Inner (Scope (E));
return;
end if;
end;
Scop := Scope (E);
-- Just print entity name if its scope is at the outer level
if Scop = Standard_Standard then
null;
-- If scope comes from source, write scope and entity
elsif Comes_From_Source (Scop) then
Append_Entity_Name (Temp, Scop);
Append (Temp, '.');
-- If in wrapper package skip past it
elsif Present (Scop) and then Is_Wrapper_Package (Scop) then
Append_Entity_Name (Temp, Scope (Scop));
Append (Temp, '.');
-- Otherwise nothing to output (happens in unnamed block statements)
else
null;
end if;
-- Output the name
declare
E_Name : Bounded_String;
begin
Append_Unqualified_Decoded (E_Name, Chars (E));
-- Remove trailing upper-case letters from the name (useful for
-- dealing with some cases of internal names generated in the case
-- of references from within a generic).
while E_Name.Length > 1
and then E_Name.Chars (E_Name.Length) in 'A' .. 'Z'
loop
E_Name.Length := E_Name.Length - 1;
end loop;
-- Adjust casing appropriately (gets name from source if possible)
Adjust_Name_Case (E_Name, Sloc (E));
Append (Temp, E_Name);
end;
end Inner;
-- Start of processing for Append_Entity_Name
begin
Inner (E);
Append (Buf, Temp);
end Append_Entity_Name;
---------------------------------
-- Append_Inherited_Subprogram --
---------------------------------
procedure Append_Inherited_Subprogram (S : Entity_Id) is
Par : constant Entity_Id := Alias (S);
-- The parent subprogram
Scop : constant Entity_Id := Scope (Par);
-- The scope of definition of the parent subprogram
Typ : constant Entity_Id := Defining_Entity (Parent (S));
-- The derived type of which S is a primitive operation
Decl : Node_Id;
Next_E : Entity_Id;
begin
if Ekind (Current_Scope) = E_Package
and then In_Private_Part (Current_Scope)
and then Has_Private_Declaration (Typ)
and then Is_Tagged_Type (Typ)
and then Scop = Current_Scope
then
-- The inherited operation is available at the earliest place after
-- the derived type declaration (RM 7.3.1 (6/1)). This is only
-- relevant for type extensions. If the parent operation appears
-- after the type extension, the operation is not visible.
Decl := First
(Visible_Declarations
(Package_Specification (Current_Scope)));
while Present (Decl) loop
if Nkind (Decl) = N_Private_Extension_Declaration
and then Defining_Entity (Decl) = Typ
then
if Sloc (Decl) > Sloc (Par) then
Next_E := Next_Entity (Par);
Link_Entities (Par, S);
Link_Entities (S, Next_E);
return;
else
exit;
end if;
end if;
Next (Decl);
end loop;
end if;
-- If partial view is not a type extension, or it appears before the
-- subprogram declaration, insert normally at end of entity list.
Append_Entity (S, Current_Scope);
end Append_Inherited_Subprogram;
-----------------------------------------
-- Apply_Compile_Time_Constraint_Error --
-----------------------------------------
procedure Apply_Compile_Time_Constraint_Error
(N : Node_Id;
Msg : String;
Reason : RT_Exception_Code;
Ent : Entity_Id := Empty;
Typ : Entity_Id := Empty;
Loc : Source_Ptr := No_Location;
Warn : Boolean := False;
Emit_Message : Boolean := True)
is
Stat : constant Boolean := Is_Static_Expression (N);
R_Stat : constant Node_Id :=
Make_Raise_Constraint_Error (Sloc (N), Reason => Reason);
Rtyp : Entity_Id;
begin
if No (Typ) then
Rtyp := Etype (N);
else
Rtyp := Typ;
end if;
if Emit_Message then
Discard_Node
(Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));
end if;
-- Now we replace the node by an N_Raise_Constraint_Error node
-- This does not need reanalyzing, so set it as analyzed now.
Rewrite (N, R_Stat);
Set_Analyzed (N, True);
Set_Etype (N, Rtyp);
Set_Raises_Constraint_Error (N);
-- Now deal with possible local raise handling
Possible_Local_Raise (N, Standard_Constraint_Error);
-- If the original expression was marked as static, the result is
-- still marked as static, but the Raises_Constraint_Error flag is
-- always set so that further static evaluation is not attempted.
if Stat then
Set_Is_Static_Expression (N);
end if;
end Apply_Compile_Time_Constraint_Error;
---------------------------
-- Async_Readers_Enabled --
---------------------------
function Async_Readers_Enabled (Id : Entity_Id) return Boolean is
begin
return Has_Enabled_Property (Id, Name_Async_Readers);
end Async_Readers_Enabled;
---------------------------
-- Async_Writers_Enabled --
---------------------------
function Async_Writers_Enabled (Id : Entity_Id) return Boolean is
begin
return Has_Enabled_Property (Id, Name_Async_Writers);
end Async_Writers_Enabled;
--------------------------------------
-- Available_Full_View_Of_Component --
--------------------------------------
function Available_Full_View_Of_Component (T : Entity_Id) return Boolean is
ST : constant Entity_Id := Scope (T);
SCT : constant Entity_Id := Scope (Component_Type (T));
begin
return In_Open_Scopes (ST)
and then In_Open_Scopes (SCT)
and then Scope_Depth (ST) >= Scope_Depth (SCT);
end Available_Full_View_Of_Component;
----------------
-- Bad_Aspect --
----------------
procedure Bad_Aspect
(N : Node_Id;
Nam : Name_Id;
Warn : Boolean := False)
is
begin
Error_Msg_Warn := Warn;
Error_Msg_N ("<<& is not a valid aspect identifier", N);
-- Check bad spelling
Error_Msg_Name_1 := Aspect_Spell_Check (Nam);
if Error_Msg_Name_1 /= No_Name then
Error_Msg_N -- CODEFIX
("\<<possible misspelling of %", N);
end if;
end Bad_Aspect;
-------------------
-- Bad_Attribute --
-------------------
procedure Bad_Attribute
(N : Node_Id;
Nam : Name_Id;
Warn : Boolean := False)
is
begin
Error_Msg_Warn := Warn;
Error_Msg_N ("<<unrecognized attribute&", N);
-- Check for possible misspelling
Error_Msg_Name_1 := Attribute_Spell_Check (Nam);
if Error_Msg_Name_1 /= No_Name then
Error_Msg_N -- CODEFIX
("\<<possible misspelling of %", N);
end if;
end Bad_Attribute;
--------------------------------
-- Bad_Predicated_Subtype_Use --
--------------------------------
procedure Bad_Predicated_Subtype_Use
(Msg : String;
N : Node_Id;
Typ : Entity_Id;
Suggest_Static : Boolean := False)
is
Gen : Entity_Id;
begin
-- Avoid cascaded errors
if Error_Posted (N) then
return;
end if;
if Inside_A_Generic then
Gen := Current_Scope;
while Present (Gen) and then Ekind (Gen) /= E_Generic_Package loop
Gen := Scope (Gen);
end loop;
if No (Gen) then
return;
end if;
if Is_Generic_Formal (Typ) and then Is_Discrete_Type (Typ) then
Set_No_Predicate_On_Actual (Typ);
end if;
elsif Has_Predicates (Typ) then
if Is_Generic_Actual_Type (Typ) then
-- The restriction on loop parameters is only that the type
-- should have no dynamic predicates.
if Nkind (Parent (N)) = N_Loop_Parameter_Specification
and then not Has_Dynamic_Predicate_Aspect (Typ)
and then Is_OK_Static_Subtype (Typ)
then
return;
end if;
Gen := Current_Scope;
while not Is_Generic_Instance (Gen) loop
Gen := Scope (Gen);
end loop;
pragma Assert (Present (Gen));
if Ekind (Gen) = E_Package and then In_Package_Body (Gen) then
Error_Msg_Warn := SPARK_Mode /= On;
Error_Msg_FE (Msg & "<<", N, Typ);
Error_Msg_F ("\Program_Error [<<", N);
Insert_Action (N,
Make_Raise_Program_Error (Sloc (N),
Reason => PE_Bad_Predicated_Generic_Type));
else
Error_Msg_FE (Msg, N, Typ);
end if;
else
Error_Msg_FE (Msg, N, Typ);
end if;
-- Emit an optional suggestion on how to remedy the error if the
-- context warrants it.
if Suggest_Static and then Has_Static_Predicate (Typ) then
Error_Msg_FE ("\predicate of & should be marked static", N, Typ);
end if;
end if;
end Bad_Predicated_Subtype_Use;
-----------------------------------------
-- Bad_Unordered_Enumeration_Reference --
-----------------------------------------
function Bad_Unordered_Enumeration_Reference
(N : Node_Id;
T : Entity_Id) return Boolean
is
begin
return Is_Enumeration_Type (T)
and then Warn_On_Unordered_Enumeration_Type
and then not Is_Generic_Type (T)
and then Comes_From_Source (N)
and then not Has_Pragma_Ordered (T)
and then not In_Same_Extended_Unit (N, T);
end Bad_Unordered_Enumeration_Reference;
----------------------------
-- Begin_Keyword_Location --
----------------------------
function Begin_Keyword_Location (N : Node_Id) return Source_Ptr is
HSS : Node_Id;
begin
pragma Assert
(Nkind (N) in
N_Block_Statement |
N_Entry_Body |
N_Package_Body |
N_Subprogram_Body |
N_Task_Body);
HSS := Handled_Statement_Sequence (N);
-- When the handled sequence of statements comes from source, the
-- location of the "begin" keyword is that of the sequence itself.
-- Note that an internal construct may inherit a source sequence.
if Comes_From_Source (HSS) then
return Sloc (HSS);
-- The parser generates an internal handled sequence of statements to
-- capture the location of the "begin" keyword if present in the source.
-- Since there are no source statements, the location of the "begin"
-- keyword is effectively that of the "end" keyword.
elsif Comes_From_Source (N) then
return Sloc (HSS);
-- Otherwise the construct is internal and should carry the location of
-- the original construct which prompted its creation.
else
return Sloc (N);
end if;
end Begin_Keyword_Location;
--------------------------
-- Build_Actual_Subtype --
--------------------------
function Build_Actual_Subtype
(T : Entity_Id;
N : Node_Or_Entity_Id) return Node_Id
is
Loc : Source_Ptr;
-- Normally Sloc (N), but may point to corresponding body in some cases
Constraints : List_Id;
Decl : Node_Id;
Discr : Entity_Id;
Hi : Node_Id;
Lo : Node_Id;
Subt : Entity_Id;
Disc_Type : Entity_Id;
Obj : Node_Id;
Index : Node_Id;
begin
Loc := Sloc (N);
if Nkind (N) = N_Defining_Identifier then
Obj := New_Occurrence_Of (N, Loc);
-- If this is a formal parameter of a subprogram declaration, and
-- we are compiling the body, we want the declaration for the
-- actual subtype to carry the source position of the body, to
-- prevent anomalies in gdb when stepping through the code.
if Is_Formal (N) then
declare
Decl : constant Node_Id := Unit_Declaration_Node (Scope (N));
begin
if Nkind (Decl) = N_Subprogram_Declaration
and then Present (Corresponding_Body (Decl))
then
Loc := Sloc (Corresponding_Body (Decl));
end if;
end;
end if;
else
Obj := N;
end if;
if Is_Array_Type (T) then
Constraints := New_List;
Index := First_Index (T);
for J in 1 .. Number_Dimensions (T) loop
-- Build an array subtype declaration with the nominal subtype and
-- the bounds of the actual. Add the declaration in front of the
-- local declarations for the subprogram, for analysis before any
-- reference to the formal in the body.
-- If this is for an index with a fixed lower bound, then use
-- the fixed lower bound as the lower bound of the actual
-- subtype's corresponding index.
if not Is_Constrained (T)
and then Is_Fixed_Lower_Bound_Index_Subtype (Etype (Index))
then
Lo := New_Copy_Tree (Type_Low_Bound (Etype (Index)));
else
Lo :=
Make_Attribute_Reference (Loc,
Prefix =>
Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
Attribute_Name => Name_First,
Expressions => New_List (
Make_Integer_Literal (Loc, J)));
end if;
Hi :=
Make_Attribute_Reference (Loc,
Prefix =>
Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
Attribute_Name => Name_Last,
Expressions => New_List (
Make_Integer_Literal (Loc, J)));
Append (Make_Range (Loc, Lo, Hi), Constraints);
Next_Index (Index);
end loop;
-- If the type has unknown discriminants there is no constrained
-- subtype to build. This is never called for a formal or for a
-- lhs, so returning the type is ok ???
elsif Has_Unknown_Discriminants (T) then
return T;
else
Constraints := New_List;
-- Type T is a generic derived type, inherit the discriminants from
-- the parent type.
if Is_Private_Type (T)
and then No (Full_View (T))
-- T was flagged as an error if it was declared as a formal
-- derived type with known discriminants. In this case there
-- is no need to look at the parent type since T already carries
-- its own discriminants.
and then not Error_Posted (T)
then
Disc_Type := Etype (Base_Type (T));
else
Disc_Type := T;
end if;
Discr := First_Discriminant (Disc_Type);
while Present (Discr) loop
Append_To (Constraints,
Make_Selected_Component (Loc,
Prefix =>
Duplicate_Subexpr_No_Checks (Obj),
Selector_Name => New_Occurrence_Of (Discr, Loc)));
Next_Discriminant (Discr);
end loop;
end if;
Subt := Make_Temporary (Loc, 'S', Related_Node => N);
Set_Is_Internal (Subt);
Decl :=
Make_Subtype_Declaration (Loc,
Defining_Identifier => Subt,
Subtype_Indication =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Occurrence_Of (T, Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => Constraints)));
Mark_Rewrite_Insertion (Decl);
return Decl;
end Build_Actual_Subtype;
---------------------------------------
-- Build_Actual_Subtype_Of_Component --
---------------------------------------
function Build_Actual_Subtype_Of_Component
(T : Entity_Id;
N : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
P : constant Node_Id := Prefix (N);
D : Elmt_Id;
Id : Node_Id;
Index_Typ : Entity_Id;
Sel : Entity_Id := Empty;
Desig_Typ : Entity_Id;
-- This is either a copy of T, or if T is an access type, then it is
-- the directly designated type of this access type.
function Build_Access_Record_Constraint (C : List_Id) return List_Id;
-- If the record component is a constrained access to the current
-- record, the subtype has not been constructed during analysis of
-- the enclosing record type (see Analyze_Access). In that case, build
-- a constrained access subtype after replacing references to the
-- enclosing discriminants with the corresponding discriminant values
-- of the prefix.
function Build_Actual_Array_Constraint return List_Id;
-- If one or more of the bounds of the component depends on
-- discriminants, build actual constraint using the discriminants
-- of the prefix, as above.
function Build_Actual_Record_Constraint return List_Id;
-- Similar to previous one, for discriminated components constrained
-- by the discriminant of the enclosing object.
function Build_Discriminant_Reference
(Discrim_Name : Node_Id; Obj : Node_Id := P) return Node_Id;
-- Build a reference to the discriminant denoted by Discrim_Name.
-- The prefix of the result is usually Obj, but it could be
-- a prefix of Obj in some corner cases.
function Copy_And_Maybe_Dereference (N : Node_Id) return Node_Id;
-- Copy the subtree rooted at N and insert an explicit dereference if it
-- is of an access type.
-----------------------------------
-- Build_Actual_Array_Constraint --
-----------------------------------
function Build_Actual_Array_Constraint return List_Id is
Constraints : constant List_Id := New_List;
Indx : Node_Id;
Hi : Node_Id;
Lo : Node_Id;
Old_Hi : Node_Id;
Old_Lo : Node_Id;
begin
Indx := First_Index (Desig_Typ);
while Present (Indx) loop
Old_Lo := Type_Low_Bound (Etype (Indx));
Old_Hi := Type_High_Bound (Etype (Indx));
if Denotes_Discriminant (Old_Lo) then
Lo := Build_Discriminant_Reference (Old_Lo);
else
Lo := New_Copy_Tree (Old_Lo);
-- The new bound will be reanalyzed in the enclosing
-- declaration. For literal bounds that come from a type
-- declaration, the type of the context must be imposed, so
-- insure that analysis will take place. For non-universal
-- types this is not strictly necessary.
Set_Analyzed (Lo, False);
end if;
if Denotes_Discriminant (Old_Hi) then
Hi := Build_Discriminant_Reference (Old_Hi);
else
Hi := New_Copy_Tree (Old_Hi);
Set_Analyzed (Hi, False);
end if;
Append (Make_Range (Loc, Lo, Hi), Constraints);
Next_Index (Indx);
end loop;
return Constraints;
end Build_Actual_Array_Constraint;
------------------------------------
-- Build_Actual_Record_Constraint --
------------------------------------
function Build_Actual_Record_Constraint return List_Id is
Constraints : constant List_Id := New_List;
D : Elmt_Id;
D_Val : Node_Id;
begin
D := First_Elmt (Discriminant_Constraint (Desig_Typ));
while Present (D) loop
if Denotes_Discriminant (Node (D)) then
D_Val := Build_Discriminant_Reference (Node (D));
else
D_Val := New_Copy_Tree (Node (D));
end if;
Append (D_Val, Constraints);
Next_Elmt (D);
end loop;
return Constraints;
end Build_Actual_Record_Constraint;
----------------------------------
-- Build_Discriminant_Reference --
----------------------------------
function Build_Discriminant_Reference
(Discrim_Name : Node_Id; Obj : Node_Id := P) return Node_Id
is
Discrim : constant Entity_Id := Entity (Discrim_Name);
function Obj_Is_Good_Prefix return Boolean;
-- Returns True if Obj.Discrim makes sense; that is, if
-- Obj has Discrim as one of its discriminants (or is an
-- access value that designates such an object).
------------------------
-- Obj_Is_Good_Prefix --
------------------------
function Obj_Is_Good_Prefix return Boolean is
Obj_Type : Entity_Id :=
Implementation_Base_Type (Etype (Obj));
Discriminated_Type : constant Entity_Id :=
Implementation_Base_Type
(Scope (Original_Record_Component (Discrim)));
begin
-- The order of the following two tests matters in the
-- access-to-class-wide case.
if Is_Access_Type (Obj_Type) then
Obj_Type := Implementation_Base_Type
(Designated_Type (Obj_Type));
end if;
if Is_Class_Wide_Type (Obj_Type) then
Obj_Type := Implementation_Base_Type
(Find_Specific_Type (Obj_Type));
end if;
-- If a type T1 defines a discriminant D1, then Obj.D1 is ok (for
-- our purposes here) if T1 is an ancestor of the type of Obj.
-- So that's what we would like to test for here.
-- The bad news: Is_Ancestor is only defined in the tagged case.
-- The good news: in the untagged case, Implementation_Base_Type
-- looks through derived types so we can use a simpler test.
if Is_Tagged_Type (Discriminated_Type) then
return Is_Ancestor (Discriminated_Type, Obj_Type);
else
return Discriminated_Type = Obj_Type;
end if;
end Obj_Is_Good_Prefix;
-- Start of processing for Build_Discriminant_Reference
begin
if not Obj_Is_Good_Prefix then
-- If the given discriminant is not a component of the given
-- object, then try the enclosing object.
if Nkind (Obj) = N_Selected_Component then
return Build_Discriminant_Reference
(Discrim_Name => Discrim_Name,
Obj => Prefix (Obj));
elsif Nkind (Obj) in N_Has_Entity
and then Nkind (Parent (Entity (Obj))) =
N_Object_Renaming_Declaration
then
-- Look through a renaming (a corner case of a corner case).
return Build_Discriminant_Reference
(Discrim_Name => Discrim_Name,
Obj => Name (Parent (Entity (Obj))));
else
-- We are in some unexpected case here, so revert to the
-- old behavior (by falling through to it).
null;
end if;
end if;
return Make_Selected_Component (Loc,
Prefix => Copy_And_Maybe_Dereference (Obj),
Selector_Name => New_Occurrence_Of (Discrim, Loc));
end Build_Discriminant_Reference;
------------------------------------
-- Build_Access_Record_Constraint --
------------------------------------
function Build_Access_Record_Constraint (C : List_Id) return List_Id is
Constraints : constant List_Id := New_List;
D : Node_Id;
D_Val : Node_Id;
begin
-- Retrieve the constraint from the component declaration, because
-- the component subtype has not been constructed and the component
-- type is an unconstrained access.
D := First (C);
while Present (D) loop
if Nkind (D) = N_Discriminant_Association
and then Denotes_Discriminant (Expression (D))
then
D_Val := New_Copy_Tree (D);
Set_Expression (D_Val,
Make_Selected_Component (Loc,
Prefix => Copy_And_Maybe_Dereference (P),
Selector_Name =>
New_Occurrence_Of (Entity (Expression (D)), Loc)));
elsif Denotes_Discriminant (D) then
D_Val := Make_Selected_Component (Loc,
Prefix => Copy_And_Maybe_Dereference (P),
Selector_Name => New_Occurrence_Of (Entity (D), Loc));
else
D_Val := New_Copy_Tree (D);
end if;
Append (D_Val, Constraints);
Next (D);
end loop;
return Constraints;
end Build_Access_Record_Constraint;
--------------------------------
-- Copy_And_Maybe_Dereference --
--------------------------------
function Copy_And_Maybe_Dereference (N : Node_Id) return Node_Id is
New_N : constant Node_Id := New_Copy_Tree (N);
begin
if Is_Access_Type (Etype (N)) then
return Make_Explicit_Dereference (Sloc (Parent (N)), New_N);
else
return New_N;
end if;
end Copy_And_Maybe_Dereference;
-- Start of processing for Build_Actual_Subtype_Of_Component
begin
-- The subtype does not need to be created for a selected component
-- in a Spec_Expression.
if In_Spec_Expression then
return Empty;
-- More comments for the rest of this body would be good ???
elsif Nkind (N) = N_Explicit_Dereference then
if Is_Composite_Type (T)
and then not Is_Constrained (T)
and then not (Is_Class_Wide_Type (T)
and then Is_Constrained (Root_Type (T)))
and then not Has_Unknown_Discriminants (T)
then
-- If the type of the dereference is already constrained, it is an
-- actual subtype.
if Is_Array_Type (Etype (N))
and then Is_Constrained (Etype (N))
then
return Empty;
else
Remove_Side_Effects (P);
return Build_Actual_Subtype (T, N);
end if;
else
return Empty;
end if;
elsif Nkind (N) = N_Selected_Component then
-- The entity of the selected component allows us to retrieve
-- the original constraint from its component declaration.
Sel := Entity (Selector_Name (N));
if Parent_Kind (Sel) /= N_Component_Declaration then
return Empty;
end if;
end if;
if Is_Access_Type (T) then
Desig_Typ := Designated_Type (T);
else
Desig_Typ := T;
end if;
if Ekind (Desig_Typ) = E_Array_Subtype then
Id := First_Index (Desig_Typ);
-- Check whether an index bound is constrained by a discriminant
while Present (Id) loop
Index_Typ := Underlying_Type (Etype (Id));
if Denotes_Discriminant (Type_Low_Bound (Index_Typ))
or else
Denotes_Discriminant (Type_High_Bound (Index_Typ))
then
Remove_Side_Effects (P);
return
Build_Component_Subtype
(Build_Actual_Array_Constraint, Loc, Base_Type (T));
end if;
Next_Index (Id);
end loop;
elsif Is_Composite_Type (Desig_Typ)
and then Has_Discriminants (Desig_Typ)
and then not Is_Empty_Elmt_List (Discriminant_Constraint (Desig_Typ))
and then not Has_Unknown_Discriminants (Desig_Typ)
then
if Is_Private_Type (Desig_Typ)
and then No (Discriminant_Constraint (Desig_Typ))
then
Desig_Typ := Full_View (Desig_Typ);
end if;
D := First_Elmt (Discriminant_Constraint (Desig_Typ));
while Present (D) loop
if Denotes_Discriminant (Node (D)) then
Remove_Side_Effects (P);
return
Build_Component_Subtype (
Build_Actual_Record_Constraint, Loc, Base_Type (T));
end if;
Next_Elmt (D);
end loop;
-- Special processing for an access record component that is
-- the target of an assignment. If the designated type is an
-- unconstrained discriminated record we create its actual
-- subtype now.
elsif Ekind (T) = E_Access_Type
and then Present (Sel)
and then Has_Per_Object_Constraint (Sel)
and then Nkind (Parent (N)) = N_Assignment_Statement
and then N = Name (Parent (N))
-- and then not Inside_Init_Proc
-- and then Has_Discriminants (Desig_Typ)
-- and then not Is_Constrained (Desig_Typ)
then
declare
S_Indic : constant Node_Id :=
(Subtype_Indication
(Component_Definition (Parent (Sel))));
Discs : List_Id;
begin
if Nkind (S_Indic) = N_Subtype_Indication then
Discs := Constraints (Constraint (S_Indic));
Remove_Side_Effects (P);
return Build_Component_Subtype
(Build_Access_Record_Constraint (Discs), Loc, T);
else
return Empty;
end if;
end;
end if;
-- If none of the above, the actual and nominal subtypes are the same
return Empty;
end Build_Actual_Subtype_Of_Component;
-----------------------------
-- Build_Component_Subtype --
-----------------------------
function Build_Component_Subtype
(C : List_Id;
Loc : Source_Ptr;
T : Entity_Id) return Node_Id
is
Subt : Entity_Id;
Decl : Node_Id;
begin
-- Unchecked_Union components do not require component subtypes
if Is_Unchecked_Union (T) then
return Empty;
end if;
Subt := Make_Temporary (Loc, 'S');
Set_Is_Internal (Subt);
Decl :=
Make_Subtype_Declaration (Loc,
Defining_Identifier => Subt,
Subtype_Indication =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Occurrence_Of (Base_Type (T), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => C)));
Mark_Rewrite_Insertion (Decl);
return Decl;
end Build_Component_Subtype;
-----------------------------
-- Build_Constrained_Itype --
-----------------------------
procedure Build_Constrained_Itype
(N : Node_Id;
Typ : Entity_Id;
New_Assoc_List : List_Id)
is
Constrs : constant List_Id := New_List;
Loc : constant Source_Ptr := Sloc (N);
Def_Id : Entity_Id;
Indic : Node_Id;
New_Assoc : Node_Id;
Subtyp_Decl : Node_Id;
begin
New_Assoc := First (New_Assoc_List);
while Present (New_Assoc) loop
-- There is exactly one choice in the component association (and
-- it is either a discriminant, a component or the others clause).
pragma Assert (List_Length (Choices (New_Assoc)) = 1);
-- Duplicate expression for the discriminant and put it on the
-- list of constraints for the itype declaration.
if Is_Entity_Name (First (Choices (New_Assoc)))
and then
Ekind (Entity (First (Choices (New_Assoc)))) = E_Discriminant
then
Append_To (Constrs, Duplicate_Subexpr (Expression (New_Assoc)));
end if;
Next (New_Assoc);
end loop;
if Has_Unknown_Discriminants (Typ)
and then Present (Underlying_Record_View (Typ))
then
Indic :=
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (Underlying_Record_View (Typ), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => Constrs));
else
Indic :=
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (Base_Type (Typ), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => Constrs));
end if;
Def_Id := Create_Itype (Ekind (Typ), N);
Subtyp_Decl :=
Make_Subtype_Declaration (Loc,
Defining_Identifier => Def_Id,
Subtype_Indication => Indic);
Set_Parent (Subtyp_Decl, Parent (N));
-- Itypes must be analyzed with checks off (see itypes.ads)
Analyze (Subtyp_Decl, Suppress => All_Checks);
Set_Etype (N, Def_Id);
end Build_Constrained_Itype;
---------------------------
-- Build_Default_Subtype --
---------------------------
function Build_Default_Subtype
(T : Entity_Id;
N : Node_Id) return Entity_Id
is
Loc : constant Source_Ptr := Sloc (N);
Disc : Entity_Id;
Bas : Entity_Id;
-- The base type that is to be constrained by the defaults
begin
if not Has_Discriminants (T) or else Is_Constrained (T) then
return T;
end if;
Bas := Base_Type (T);
-- If T is non-private but its base type is private, this is the
-- completion of a subtype declaration whose parent type is private
-- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants
-- are to be found in the full view of the base. Check that the private
-- status of T and its base differ.
if Is_Private_Type (Bas)
and then not Is_Private_Type (T)
and then Present (Full_View (Bas))
then
Bas := Full_View (Bas);
end if;
Disc := First_Discriminant (T);
if No (Discriminant_Default_Value (Disc)) then
return T;
end if;
declare
Act : constant Entity_Id := Make_Temporary (Loc, 'S');
Constraints : constant List_Id := New_List;
Decl : Node_Id;
begin
while Present (Disc) loop
Append_To (Constraints,
New_Copy_Tree (Discriminant_Default_Value (Disc)));
Next_Discriminant (Disc);
end loop;
Decl :=
Make_Subtype_Declaration (Loc,
Defining_Identifier => Act,
Subtype_Indication =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Occurrence_Of (Bas, Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => Constraints)));
Insert_Action (N, Decl);
-- If the context is a component declaration the subtype declaration
-- will be analyzed when the enclosing type is frozen, otherwise do
-- it now.
if Ekind (Current_Scope) /= E_Record_Type then
Analyze (Decl);
end if;
return Act;
end;
end Build_Default_Subtype;
--------------------------------------------
-- Build_Discriminal_Subtype_Of_Component --
--------------------------------------------
function Build_Discriminal_Subtype_Of_Component
(T : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (T);
D : Elmt_Id;
Id : Node_Id;
function Build_Discriminal_Array_Constraint return List_Id;
-- If one or more of the bounds of the component depends on
-- discriminants, build actual constraint using the discriminants
-- of the prefix.
function Build_Discriminal_Record_Constraint return List_Id;
-- Similar to previous one, for discriminated components constrained by
-- the discriminant of the enclosing object.
----------------------------------------
-- Build_Discriminal_Array_Constraint --
----------------------------------------
function Build_Discriminal_Array_Constraint return List_Id is
Constraints : constant List_Id := New_List;
Indx : Node_Id;
Hi : Node_Id;
Lo : Node_Id;
Old_Hi : Node_Id;
Old_Lo : Node_Id;
begin
Indx := First_Index (T);
while Present (Indx) loop
Old_Lo := Type_Low_Bound (Etype (Indx));
Old_Hi := Type_High_Bound (Etype (Indx));
if Denotes_Discriminant (Old_Lo) then
Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc);
else
Lo := New_Copy_Tree (Old_Lo);
end if;
if Denotes_Discriminant (Old_Hi) then
Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc);
else
Hi := New_Copy_Tree (Old_Hi);
end if;
Append (Make_Range (Loc, Lo, Hi), Constraints);
Next_Index (Indx);
end loop;
return Constraints;
end Build_Discriminal_Array_Constraint;
-----------------------------------------
-- Build_Discriminal_Record_Constraint --
-----------------------------------------
function Build_Discriminal_Record_Constraint return List_Id is
Constraints : constant List_Id := New_List;
D : Elmt_Id;
D_Val : Node_Id;
begin
D := First_Elmt (Discriminant_Constraint (T));
while Present (D) loop
if Denotes_Discriminant (Node (D)) then
D_Val :=
New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc);
else
D_Val := New_Copy_Tree (Node (D));
end if;
Append (D_Val, Constraints);
Next_Elmt (D);
end loop;
return Constraints;
end Build_Discriminal_Record_Constraint;
-- Start of processing for Build_Discriminal_Subtype_Of_Component
begin
if Ekind (T) = E_Array_Subtype then
Id := First_Index (T);
while Present (Id) loop
if Denotes_Discriminant (Type_Low_Bound (Etype (Id)))
or else
Denotes_Discriminant (Type_High_Bound (Etype (Id)))
then
return Build_Component_Subtype
(Build_Discriminal_Array_Constraint, Loc, T);
end if;
Next_Index (Id);
end loop;
elsif Ekind (T) = E_Record_Subtype
and then Has_Discriminants (T)
and then not Has_Unknown_Discriminants (T)
then
D := First_Elmt (Discriminant_Constraint (T));
while Present (D) loop
if Denotes_Discriminant (Node (D)) then
return Build_Component_Subtype
(Build_Discriminal_Record_Constraint, Loc, T);
end if;
Next_Elmt (D);
end loop;
end if;
-- If none of the above, the actual and nominal subtypes are the same
return Empty;
end Build_Discriminal_Subtype_Of_Component;
------------------------------
-- Build_Elaboration_Entity --
------------------------------
procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
Decl : Node_Id;
Elab_Ent : Entity_Id;
procedure Set_Package_Name (Ent : Entity_Id);
-- Given an entity, sets the fully qualified name of the entity in
-- Name_Buffer, with components separated by double underscores. This
-- is a recursive routine that climbs the scope chain to Standard.
----------------------
-- Set_Package_Name --
----------------------
procedure Set_Package_Name (Ent : Entity_Id) is
begin
if Scope (Ent) /= Standard_Standard then
Set_Package_Name (Scope (Ent));
declare
Nam : constant String := Get_Name_String (Chars (Ent));
begin
Name_Buffer (Name_Len + 1) := '_';
Name_Buffer (Name_Len + 2) := '_';
Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam;
Name_Len := Name_Len + Nam'Length + 2;
end;
else
Get_Name_String (Chars (Ent));
end if;
end Set_Package_Name;
-- Start of processing for Build_Elaboration_Entity
begin
-- Ignore call if already constructed
if Present (Elaboration_Entity (Spec_Id)) then
return;
-- Do not generate an elaboration entity in GNATprove move because the
-- elaboration counter is a form of expansion.
elsif GNATprove_Mode then
return;
-- See if we need elaboration entity
-- We always need an elaboration entity when preserving control flow, as
-- we want to remain explicit about the unit's elaboration order.
elsif Opt.Suppress_Control_Flow_Optimizations then
null;
-- We always need an elaboration entity for the dynamic elaboration
-- model, since it is needed to properly generate the PE exception for
-- access before elaboration.
elsif Dynamic_Elaboration_Checks then
null;
-- For the static model, we don't need the elaboration counter if this
-- unit is sure to have no elaboration code, since that means there
-- is no elaboration unit to be called. Note that we can't just decide
-- after the fact by looking to see whether there was elaboration code,
-- because that's too late to make this decision.
elsif Restriction_Active (No_Elaboration_Code) then
return;
-- Similarly, for the static model, we can skip the elaboration counter
-- if we have the No_Multiple_Elaboration restriction, since for the
-- static model, that's the only purpose of the counter (to avoid
-- multiple elaboration).
elsif Restriction_Active (No_Multiple_Elaboration) then
return;
end if;
-- Here we need the elaboration entity
-- Construct name of elaboration entity as xxx_E, where xxx is the unit
-- name with dots replaced by double underscore. We have to manually
-- construct this name, since it will be elaborated in the outer scope,
-- and thus will not have the unit name automatically prepended.
Set_Package_Name (Spec_Id);
Add_Str_To_Name_Buffer ("_E");
-- Create elaboration counter
Elab_Ent := Make_Defining_Identifier (Loc, Chars => Name_Find);
Set_Elaboration_Entity (Spec_Id, Elab_Ent);
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Elab_Ent,
Object_Definition =>
New_Occurrence_Of (Standard_Short_Integer, Loc),
Expression => Make_Integer_Literal (Loc, Uint_0));
Push_Scope (Standard_Standard);
Add_Global_Declaration (Decl);
Pop_Scope;
-- Reset True_Constant indication, since we will indeed assign a value
-- to the variable in the binder main. We also kill the Current_Value
-- and Last_Assignment fields for the same reason.
Set_Is_True_Constant (Elab_Ent, False);
Set_Current_Value (Elab_Ent, Empty);
Set_Last_Assignment (Elab_Ent, Empty);
-- We do not want any further qualification of the name (if we did not
-- do this, we would pick up the name of the generic package in the case
-- of a library level generic instantiation).
Set_Has_Qualified_Name (Elab_Ent);
Set_Has_Fully_Qualified_Name (Elab_Ent);
end Build_Elaboration_Entity;
--------------------------------
-- Build_Explicit_Dereference --
--------------------------------
procedure Build_Explicit_Dereference
(Expr : Node_Id;
Disc : Entity_Id)
is
Loc : constant Source_Ptr := Sloc (Expr);
I : Interp_Index;
It : Interp;
begin
-- An entity of a type with a reference aspect is overloaded with
-- both interpretations: with and without the dereference. Now that
-- the dereference is made explicit, set the type of the node properly,
-- to prevent anomalies in the backend. Same if the expression is an
-- overloaded function call whose return type has a reference aspect.
if Is_Entity_Name (Expr) then
Set_Etype (Expr, Etype (Entity (Expr)));
-- The designated entity will not be examined again when resolving
-- the dereference, so generate a reference to it now.
Generate_Reference (Entity (Expr), Expr);
elsif Nkind (Expr) = N_Function_Call then
-- If the name of the indexing function is overloaded, locate the one
-- whose return type has an implicit dereference on the desired
-- discriminant, and set entity and type of function call.
if Is_Overloaded (Name (Expr)) then
Get_First_Interp (Name (Expr), I, It);
while Present (It.Nam) loop
if Ekind ((It.Typ)) = E_Record_Type
and then First_Entity ((It.Typ)) = Disc
then
Set_Entity (Name (Expr), It.Nam);
Set_Etype (Name (Expr), Etype (It.Nam));
exit;
end if;
Get_Next_Interp (I, It);
end loop;
end if;
-- Set type of call from resolved function name.
Set_Etype (Expr, Etype (Name (Expr)));
end if;
Set_Is_Overloaded (Expr, False);
-- The expression will often be a generalized indexing that yields a
-- container element that is then dereferenced, in which case the
-- generalized indexing call is also non-overloaded.
if Nkind (Expr) = N_Indexed_Component
and then Present (Generalized_Indexing (Expr))
then
Set_Is_Overloaded (Generalized_Indexing (Expr), False);
end if;
Rewrite (Expr,
Make_Explicit_Dereference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => Relocate_Node (Expr),
Selector_Name => New_Occurrence_Of (Disc, Loc))));
Set_Etype (Prefix (Expr), Etype (Disc));
Set_Etype (Expr, Designated_Type (Etype (Disc)));
end Build_Explicit_Dereference;
---------------------------
-- Build_Overriding_Spec --
---------------------------
function Build_Overriding_Spec
(Op : Entity_Id;
Typ : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Typ);
Par_Typ : constant Entity_Id := Find_Dispatching_Type (Op);
Spec : constant Node_Id := Specification (Unit_Declaration_Node (Op));
Formal_Spec : Node_Id;
Formal_Type : Node_Id;
New_Spec : Node_Id;
begin
New_Spec := Copy_Subprogram_Spec (Spec);
Formal_Spec := First (Parameter_Specifications (New_Spec));
while Present (Formal_Spec) loop
Formal_Type := Parameter_Type (Formal_Spec);
if Is_Entity_Name (Formal_Type)
and then Entity (Formal_Type) = Par_Typ
then
Rewrite (Formal_Type, New_Occurrence_Of (Typ, Loc));
end if;
-- Nothing needs to be done for access parameters
Next (Formal_Spec);
end loop;
return New_Spec;
end Build_Overriding_Spec;
-------------------
-- Build_Subtype --
-------------------
function Build_Subtype
(Related_Node : Node_Id;
Loc : Source_Ptr;
Typ : Entity_Id;
Constraints : List_Id)
return Entity_Id
is
Indic : Node_Id;
Subtyp_Decl : Node_Id;
Def_Id : Entity_Id;
Btyp : Entity_Id := Base_Type (Typ);
begin
-- The Related_Node better be here or else we won't be able to
-- attach new itypes to a node in the tree.
pragma Assert (Present (Related_Node));
-- If the view of the component's type is incomplete or private
-- with unknown discriminants, then the constraint must be applied
-- to the full type.
if Has_Unknown_Discriminants (Btyp)
and then Present (Underlying_Type (Btyp))
then
Btyp := Underlying_Type (Btyp);
end if;
Indic :=
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Occurrence_Of (Btyp, Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc, Constraints));
Def_Id := Create_Itype (Ekind (Typ), Related_Node);
Subtyp_Decl :=
Make_Subtype_Declaration (Loc,
Defining_Identifier => Def_Id,
Subtype_Indication => Indic);
Set_Parent (Subtyp_Decl, Parent (Related_Node));
-- Itypes must be analyzed with checks off (see package Itypes)
Analyze (Subtyp_Decl, Suppress => All_Checks);
if Is_Itype (Def_Id) and then Has_Predicates (Typ) then
Inherit_Predicate_Flags (Def_Id, Typ);
-- Indicate where the predicate function may be found
if Is_Itype (Typ) then
if Present (Predicate_Function (Def_Id)) then
null;
elsif Present (Predicate_Function (Typ)) then
Set_Predicate_Function (Def_Id, Predicate_Function (Typ));
else
Set_Predicated_Parent (Def_Id, Predicated_Parent (Typ));
end if;
elsif No (Predicate_Function (Def_Id)) then
Set_Predicated_Parent (Def_Id, Typ);
end if;
end if;
return Def_Id;
end Build_Subtype;
-----------------------------------
-- Cannot_Raise_Constraint_Error --
-----------------------------------
function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is
function List_Cannot_Raise_CE (L : List_Id) return Boolean;
-- Returns True if none of the list members cannot possibly raise
-- Constraint_Error.
--------------------------
-- List_Cannot_Raise_CE --
--------------------------
function List_Cannot_Raise_CE (L : List_Id) return Boolean is
N : Node_Id;
begin
N := First (L);
while Present (N) loop
if Cannot_Raise_Constraint_Error (N) then
Next (N);
else
return False;
end if;
end loop;
return True;
end List_Cannot_Raise_CE;
-- Start of processing for Cannot_Raise_Constraint_Error
begin
if Compile_Time_Known_Value (Expr) then
return True;
elsif Do_Range_Check (Expr) then
return False;
elsif Raises_Constraint_Error (Expr) then
return False;
else
case Nkind (Expr) is
when N_Identifier =>
return True;
when N_Expanded_Name =>
return True;
when N_Indexed_Component =>
return not Do_Range_Check (Expr)
and then Cannot_Raise_Constraint_Error (Prefix (Expr))
and then List_Cannot_Raise_CE (Expressions (Expr));
when N_Selected_Component =>
return not Do_Discriminant_Check (Expr)
and then Cannot_Raise_Constraint_Error (Prefix (Expr));
when N_Attribute_Reference =>
if Do_Overflow_Check (Expr) then
return False;
elsif No (Expressions (Expr)) then
return True;
else
return List_Cannot_Raise_CE (Expressions (Expr));
end if;
when N_Type_Conversion =>
if Do_Overflow_Check (Expr)
or else Do_Length_Check (Expr)
then
return False;
else
return Cannot_Raise_Constraint_Error (Expression (Expr));
end if;
when N_Unchecked_Type_Conversion =>
return Cannot_Raise_Constraint_Error (Expression (Expr));
when N_Unary_Op =>
if Do_Overflow_Check (Expr) then
return False;
else
return Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
end if;
when N_Op_Divide
| N_Op_Mod
| N_Op_Rem
=>
if Do_Division_Check (Expr)
or else
Do_Overflow_Check (Expr)
then
return False;
else
return
Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
and then
Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
end if;
when N_Op_Add
| N_Op_And
| N_Op_Concat
| N_Op_Eq
| N_Op_Expon
| N_Op_Ge
| N_Op_Gt
| N_Op_Le
| N_Op_Lt
| N_Op_Multiply
| N_Op_Ne
| N_Op_Or
| N_Op_Rotate_Left
| N_Op_Rotate_Right
| N_Op_Shift_Left
| N_Op_Shift_Right
| N_Op_Shift_Right_Arithmetic
| N_Op_Subtract
| N_Op_Xor
=>
if Do_Overflow_Check (Expr) then
return False;
else
return
Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
and then
Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
end if;
when others =>
return False;
end case;
end if;
end Cannot_Raise_Constraint_Error;
-------------------------------
-- Check_Ambiguous_Aggregate --
-------------------------------
procedure Check_Ambiguous_Aggregate (Call : Node_Id) is
Actual : Node_Id;
begin
if Extensions_Allowed then
Actual := First_Actual (Call);
while Present (Actual) loop
if Nkind (Actual) = N_Aggregate then
Error_Msg_N
("\add type qualification to aggregate actual", Actual);
exit;
end if;
Next_Actual (Actual);
end loop;
end if;
end Check_Ambiguous_Aggregate;
-----------------------------------------
-- Check_Dynamically_Tagged_Expression --
-----------------------------------------
procedure Check_Dynamically_Tagged_Expression
(Expr : Node_Id;
Typ : Entity_Id;
Related_Nod : Node_Id)
is
begin
pragma Assert (Is_Tagged_Type (Typ));
-- In order to avoid spurious errors when analyzing the expanded code,
-- this check is done only for nodes that come from source and for
-- actuals of generic instantiations.
if (Comes_From_Source (Related_Nod)
or else In_Generic_Actual (Expr))
and then (Is_Class_Wide_Type (Etype (Expr))
or else Is_Dynamically_Tagged (Expr))
and then not Is_Class_Wide_Type (Typ)
then
Error_Msg_N ("dynamically tagged expression not allowed!", Expr);
end if;
end Check_Dynamically_Tagged_Expression;
--------------------------
-- Check_Fully_Declared --
--------------------------
procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is
begin
if Ekind (T) = E_Incomplete_Type then
-- Ada 2005 (AI-50217): If the type is available through a limited
-- with_clause, verify that its full view has been analyzed.
if From_Limited_With (T)
and then Present (Non_Limited_View (T))
and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type
then
-- The non-limited view is fully declared
null;
else
Error_Msg_NE
("premature usage of incomplete}", N, First_Subtype (T));
end if;
-- Need comments for these tests ???
elsif Has_Private_Component (T)
and then not Is_Generic_Type (Root_Type (T))
and then not In_Spec_Expression
then
-- Special case: if T is the anonymous type created for a single
-- task or protected object, use the name of the source object.
if Is_Concurrent_Type (T)
and then not Comes_From_Source (T)
and then Nkind (N) = N_Object_Declaration
then
Error_Msg_NE
("type of& has incomplete component",
N, Defining_Identifier (N));
else
Error_Msg_NE
("premature usage of incomplete}",
N, First_Subtype (T));
end if;
end if;
end Check_Fully_Declared;
-------------------------------------------
-- Check_Function_With_Address_Parameter --
-------------------------------------------
procedure Check_Function_With_Address_Parameter (Subp_Id : Entity_Id) is
F : Entity_Id;
T : Entity_Id;
begin
F := First_Formal (Subp_Id);
while Present (F) loop
T := Etype (F);
if Is_Private_Type (T) and then Present (Full_View (T)) then
T := Full_View (T);
end if;
if Is_Descendant_Of_Address (T) or else Is_Limited_Type (T) then
Set_Is_Pure (Subp_Id, False);
exit;
end if;
Next_Formal (F);
end loop;
end Check_Function_With_Address_Parameter;
-------------------------------------
-- Check_Function_Writable_Actuals --
-------------------------------------
procedure Check_Function_Writable_Actuals (N : Node_Id) is
Writable_Actuals_List : Elist_Id := No_Elist;
Identifiers_List : Elist_Id := No_Elist;
Aggr_Error_Node : Node_Id := Empty;
Error_Node : Node_Id := Empty;
procedure Collect_Identifiers (N : Node_Id);
-- In a single traversal of subtree N collect in Writable_Actuals_List
-- all the actuals of functions with writable actuals, and in the list
-- Identifiers_List collect all the identifiers that are not actuals of
-- functions with writable actuals. If a writable actual is referenced
-- twice as writable actual then Error_Node is set to reference its
-- second occurrence, the error is reported, and the tree traversal
-- is abandoned.
-------------------------
-- Collect_Identifiers --
-------------------------
procedure Collect_Identifiers (N : Node_Id) is
function Check_Node (N : Node_Id) return Traverse_Result;
-- Process a single node during the tree traversal to collect the
-- writable actuals of functions and all the identifiers which are
-- not writable actuals of functions.
function Contains (List : Elist_Id; N : Node_Id) return Boolean;
-- Returns True if List has a node whose Entity is Entity (N)
----------------
-- Check_Node --
----------------
function Check_Node (N : Node_Id) return Traverse_Result is
Is_Writable_Actual : Boolean := False;
Id : Entity_Id;
begin
if Nkind (N) = N_Identifier then
-- No analysis possible if the entity is not decorated
if No (Entity (N)) then
return Skip;
-- Don't collect identifiers of packages, called functions, etc
elsif Ekind (Entity (N)) in
E_Package | E_Function | E_Procedure | E_Entry
then
return Skip;
-- For rewritten nodes, continue the traversal in the original
-- subtree. Needed to handle aggregates in original expressions
-- extracted from the tree by Remove_Side_Effects.
elsif Is_Rewrite_Substitution (N) then
Collect_Identifiers (Original_Node (N));
return Skip;
-- For now we skip aggregate discriminants, since they require
-- performing the analysis in two phases to identify conflicts:
-- first one analyzing discriminants and second one analyzing
-- the rest of components (since at run time, discriminants are
-- evaluated prior to components): too much computation cost
-- to identify a corner case???
elsif Nkind (Parent (N)) = N_Component_Association
and then Nkind (Parent (Parent (N))) in
N_Aggregate | N_Extension_Aggregate
then
declare
Choice : constant Node_Id := First (Choices (Parent (N)));
begin
if Ekind (Entity (N)) = E_Discriminant then
return Skip;
elsif Expression (Parent (N)) = N
and then Nkind (Choice) = N_Identifier
and then Ekind (Entity (Choice)) = E_Discriminant
then
return Skip;
end if;
end;
-- Analyze if N is a writable actual of a function
elsif Nkind (Parent (N)) = N_Function_Call then
declare
Call : constant Node_Id := Parent (N);
Actual : Node_Id;
Formal : Node_Id;
begin
Id := Get_Called_Entity (Call);
-- In case of previous error, no check is possible
if No (Id) then
return Abandon;
end if;
if Ekind (Id) in E_Function | E_Generic_Function
and then Has_Out_Or_In_Out_Parameter (Id)
then
Formal := First_Formal (Id);
Actual := First_Actual (Call);
while Present (Actual) and then Present (Formal) loop
if Actual = N then
if Ekind (Formal) in E_Out_Parameter
| E_In_Out_Parameter
then
Is_Writable_Actual := True;
end if;
exit;
end if;
Next_Formal (Formal);
Next_Actual (Actual);
end loop;
end if;
end;
end if;
if Is_Writable_Actual then
-- Skip checking the error in non-elementary types since
-- RM 6.4.1(6.15/3) is restricted to elementary types, but
-- store this actual in Writable_Actuals_List since it is
-- needed to perform checks on other constructs that have
-- arbitrary order of evaluation (for example, aggregates).
if not Is_Elementary_Type (Etype (N)) then
if not Contains (Writable_Actuals_List, N) then
Append_New_Elmt (N, To => Writable_Actuals_List);
end if;
-- Second occurrence of an elementary type writable actual
elsif Contains (Writable_Actuals_List, N) then
-- Report the error on the second occurrence of the
-- identifier. We cannot assume that N is the second
-- occurrence (according to their location in the
-- sources), since Traverse_Func walks through Field2
-- last (see comment in the body of Traverse_Func).
declare
Elmt : Elmt_Id;
begin
Elmt := First_Elmt (Writable_Actuals_List);
while Present (Elmt)
and then Entity (Node (Elmt)) /= Entity (N)
loop
Next_Elmt (Elmt);
end loop;
if Sloc (N) > Sloc (Node (Elmt)) then
Error_Node := N;
else
Error_Node := Node (Elmt);
end if;
Error_Msg_NE
("value may be affected by call to & "
& "because order of evaluation is arbitrary",
Error_Node, Id);
return Abandon;
end;
-- First occurrence of a elementary type writable actual
else
Append_New_Elmt (N, To => Writable_Actuals_List);
end if;
else
if Identifiers_List = No_Elist then
Identifiers_List := New_Elmt_List;
end if;
Append_Unique_Elmt (N, Identifiers_List);
end if;
end if;
return OK;
end Check_Node;
--------------
-- Contains --
--------------
function Contains
(List : Elist_Id;
N : Node_Id) return Boolean
is
pragma Assert (Nkind (N) in N_Has_Entity);
Elmt : Elmt_Id;
begin
if List = No_Elist then
return False;
end if;
Elmt := First_Elmt (List);
while Present (Elmt) loop
if Entity (Node (Elmt)) = Entity (N) then
return True;
else
Next_Elmt (Elmt);
end if;
end loop;
return False;
end Contains;
------------------
-- Do_Traversal --
------------------
procedure Do_Traversal is new Traverse_Proc (Check_Node);
-- The traversal procedure
-- Start of processing for Collect_Identifiers
begin
if Present (Error_Node) then
return;
end if;
if Nkind (N) in N_Subexpr and then Is_OK_Static_Expression (N) then
return;
end if;
Do_Traversal (N);
end Collect_Identifiers;
-- Start of processing for Check_Function_Writable_Actuals
begin
-- The check only applies to Ada 2012 code on which Check_Actuals has
-- been set, and only to constructs that have multiple constituents
-- whose order of evaluation is not specified by the language.
if Ada_Version < Ada_2012
or else not Check_Actuals (N)
or else Nkind (N) not in N_Op
| N_Membership_Test
| N_Range
| N_Aggregate
| N_Extension_Aggregate
| N_Full_Type_Declaration
| N_Function_Call
| N_Procedure_Call_Statement
| N_Entry_Call_Statement
or else (Nkind (N) = N_Full_Type_Declaration
and then not Is_Record_Type (Defining_Identifier (N)))
-- In addition, this check only applies to source code, not to code
-- generated by constraint checks.
or else not Comes_From_Source (N)
then
return;
end if;
-- If a construct C has two or more direct constituents that are names
-- or expressions whose evaluation may occur in an arbitrary order, at
-- least one of which contains a function call with an in out or out
-- parameter, then the construct is legal only if: for each name N that
-- is passed as a parameter of mode in out or out to some inner function
-- call C2 (not including the construct C itself), there is no other
-- name anywhere within a direct constituent of the construct C other
-- than the one containing C2, that is known to refer to the same
-- object (RM 6.4.1(6.17/3)).
case Nkind (N) is
when N_Range =>
Collect_Identifiers (Low_Bound (N));
Collect_Identifiers (High_Bound (N));
when N_Membership_Test
| N_Op
=>
declare
Expr : Node_Id;
begin
Collect_Identifiers (Left_Opnd (N));
if Present (Right_Opnd (N)) then
Collect_Identifiers (Right_Opnd (N));
end if;
if Nkind (N) in N_In | N_Not_In
and then Present (Alternatives (N))
then
Expr := First (Alternatives (N));
while Present (Expr) loop
Collect_Identifiers (Expr);
Next (Expr);
end loop;
end if;
end;
when N_Full_Type_Declaration =>
declare
function Get_Record_Part (N : Node_Id) return Node_Id;
-- Return the record part of this record type definition
function Get_Record_Part (N : Node_Id) return Node_Id is
Type_Def : constant Node_Id := Type_Definition (N);
begin
if Nkind (Type_Def) = N_Derived_Type_Definition then
return Record_Extension_Part (Type_Def);
else
return Type_Def;
end if;
end Get_Record_Part;
Comp : Node_Id;
Def_Id : Entity_Id := Defining_Identifier (N);
Rec : Node_Id := Get_Record_Part (N);
begin
-- No need to perform any analysis if the record has no
-- components
if No (Rec) or else No (Component_List (Rec)) then
return;
end if;
-- Collect the identifiers starting from the deepest
-- derivation. Done to report the error in the deepest
-- derivation.
loop
if Present (Component_List (Rec)) then
Comp := First (Component_Items (Component_List (Rec)));
while Present (Comp) loop
if Nkind (Comp) = N_Component_Declaration
and then Present (Expression (Comp))
then
Collect_Identifiers (Expression (Comp));
end if;
Next (Comp);
end loop;
end if;
exit when No (Underlying_Type (Etype (Def_Id)))
or else Base_Type (Underlying_Type (Etype (Def_Id)))
= Def_Id;
Def_Id := Base_Type (Underlying_Type (Etype (Def_Id)));
Rec := Get_Record_Part (Parent (Def_Id));
end loop;
end;
when N_Entry_Call_Statement
| N_Subprogram_Call
=>
declare
Id : constant Entity_Id := Get_Called_Entity (N);
Formal : Node_Id;
Actual : Node_Id;
begin
Formal := First_Formal (Id);
Actual := First_Actual (N);
while Present (Actual) and then Present (Formal) loop
if Ekind (Formal) in E_Out_Parameter | E_In_Out_Parameter
then
Collect_Identifiers (Actual);
end if;
Next_Formal (Formal);
Next_Actual (Actual);
end loop;
end;
when N_Aggregate
| N_Extension_Aggregate
=>
declare
Assoc : Node_Id;
Choice : Node_Id;
Comp_Expr : Node_Id;
begin
-- Handle the N_Others_Choice of array aggregates with static
-- bounds. There is no need to perform this analysis in
-- aggregates without static bounds since we cannot evaluate
-- if the N_Others_Choice covers several elements. There is
-- no need to handle the N_Others choice of record aggregates
-- since at this stage it has been already expanded by
-- Resolve_Record_Aggregate.
if Is_Array_Type (Etype (N))
and then Nkind (N) = N_Aggregate
and then Present (Aggregate_Bounds (N))
and then Compile_Time_Known_Bounds (Etype (N))
and then Expr_Value (High_Bound (Aggregate_Bounds (N)))
>
Expr_Value (Low_Bound (Aggregate_Bounds (N)))
then
declare
Count_Components : Uint := Uint_0;
Num_Components : Uint;
Others_Assoc : Node_Id := Empty;
Others_Choice : Node_Id := Empty;
Others_Box_Present : Boolean := False;
begin
-- Count positional associations
if Present (Expressions (N)) then
Comp_Expr := First (Expressions (N));
while Present (Comp_Expr) loop
Count_Components := Count_Components + 1;
Next (Comp_Expr);
end loop;
end if;
-- Count the rest of elements and locate the N_Others
-- choice (if any)
Assoc := First (Component_Associations (N));
while Present (Assoc) loop
Choice := First (Choices (Assoc));
while Present (Choice) loop
if Nkind (Choice) = N_Others_Choice then
Others_Assoc := Assoc;
Others_Choice := Choice;
Others_Box_Present := Box_Present (Assoc);
-- Count several components
elsif Nkind (Choice) in
N_Range | N_Subtype_Indication
or else (Is_Entity_Name (Choice)
and then Is_Type (Entity (Choice)))
then
declare
L, H : Node_Id;
begin
Get_Index_Bounds (Choice, L, H);
pragma Assert
(Compile_Time_Known_Value (L)
and then Compile_Time_Known_Value (H));
Count_Components :=
Count_Components
+ Expr_Value (H) - Expr_Value (L) + 1;
end;
-- Count single component. No other case available
-- since we are handling an aggregate with static
-- bounds.
else
pragma Assert (Is_OK_Static_Expression (Choice)
or else Nkind (Choice) = N_Identifier
or else Nkind (Choice) = N_Integer_Literal);
Count_Components := Count_Components + 1;
end if;
Next (Choice);
end loop;
Next (Assoc);
end loop;
Num_Components :=
Expr_Value (High_Bound (Aggregate_Bounds (N))) -
Expr_Value (Low_Bound (Aggregate_Bounds (N))) + 1;
pragma Assert (Count_Components <= Num_Components);
-- Handle the N_Others choice if it covers several
-- components
if Present (Others_Choice)
and then (Num_Components - Count_Components) > 1
then
if not Others_Box_Present then
-- At this stage, if expansion is active, the
-- expression of the others choice has not been
-- analyzed. Hence we generate a duplicate and
-- we analyze it silently to have available the
-- minimum decoration required to collect the
-- identifiers.
pragma Assert (Present (Others_Assoc));
if not Expander_Active then
Comp_Expr := Expression (Others_Assoc);
else
Comp_Expr :=
New_Copy_Tree (Expression (Others_Assoc));
Preanalyze_Without_Errors (Comp_Expr);
end if;
Collect_Identifiers (Comp_Expr);
if Writable_Actuals_List /= No_Elist then
-- As suggested by Robert, at current stage we
-- report occurrences of this case as warnings.
Error_Msg_N
("writable function parameter may affect "
& "value in other component because order "
& "of evaluation is unspecified??",
Node (First_Elmt (Writable_Actuals_List)));
end if;
end if;
end if;
end;
-- For an array aggregate, a discrete_choice_list that has
-- a nonstatic range is considered as two or more separate
-- occurrences of the expression (RM 6.4.1(20/3)).
elsif Is_Array_Type (Etype (N))
and then Nkind (N) = N_Aggregate
and then Present (Aggregate_Bounds (N))
and then not Compile_Time_Known_Bounds (Etype (N))
then
-- Collect identifiers found in the dynamic bounds
declare
Count_Components : Natural := 0;
Low, High : Node_Id;
begin
Assoc := First (Component_Associations (N));
while Present (Assoc) loop
Choice := First (Choices (Assoc));
while Present (Choice) loop
if Nkind (Choice) in
N_Range | N_Subtype_Indication
or else (Is_Entity_Name (Choice)
and then Is_Type (Entity (Choice)))
then
Get_Index_Bounds (Choice, Low, High);
if not Compile_Time_Known_Value (Low) then
Collect_Identifiers (Low);
if No (Aggr_Error_Node) then
Aggr_Error_Node := Low;
end if;
end if;
if not Compile_Time_Known_Value (High) then
Collect_Identifiers (High);
if No (Aggr_Error_Node) then
Aggr_Error_Node := High;
end if;
end if;
-- The RM rule is violated if there is more than
-- a single choice in a component association.
else
Count_Components := Count_Components + 1;
if No (Aggr_Error_Node)
and then Count_Components > 1
then
Aggr_Error_Node := Choice;
end if;
if not Compile_Time_Known_Value (Choice) then
Collect_Identifiers (Choice);
end if;
end if;
Next (Choice);
end loop;
Next (Assoc);
end loop;
end;
end if;
-- Handle ancestor part of extension aggregates
if Nkind (N) = N_Extension_Aggregate then
Collect_Identifiers (Ancestor_Part (N));
end if;
-- Handle positional associations
if Present (Expressions (N)) then
Comp_Expr := First (Expressions (N));
while Present (Comp_Expr) loop
if not Is_OK_Static_Expression (Comp_Expr) then
Collect_Identifiers (Comp_Expr);
end if;
Next (Comp_Expr);
end loop;
end if;
-- Handle discrete associations
if Present (Component_Associations (N)) then
Assoc := First (Component_Associations (N));
while Present (Assoc) loop
if not Box_Present (Assoc) then
Choice := First (Choices (Assoc));
while Present (Choice) loop
-- For now we skip discriminants since it requires
-- performing the analysis in two phases: first one
-- analyzing discriminants and second one analyzing
-- the rest of components since discriminants are
-- evaluated prior to components: too much extra
-- work to detect a corner case???
if Nkind (Choice) in N_Has_Entity
and then Present (Entity (Choice))
and then Ekind (Entity (Choice)) = E_Discriminant
then
null;
elsif Box_Present (Assoc) then
null;
else
if not Analyzed (Expression (Assoc)) then
Comp_Expr :=
New_Copy_Tree (Expression (Assoc));
Set_Parent (Comp_Expr, Parent (N));
Preanalyze_Without_Errors (Comp_Expr);
else
Comp_Expr := Expression (Assoc);
end if;
Collect_Identifiers (Comp_Expr);
end if;
Next (Choice);
end loop;
end if;
Next (Assoc);
end loop;
end if;
end;
when others =>
return;
end case;
-- No further action needed if we already reported an error
if Present (Error_Node) then
return;
end if;
-- Check violation of RM 6.20/3 in aggregates
if Present (Aggr_Error_Node)
and then Writable_Actuals_List /= No_Elist
then
Error_Msg_N
("value may be affected by call in other component because they "
& "are evaluated in unspecified order",
Node (First_Elmt (Writable_Actuals_List)));
return;
end if;
-- Check if some writable argument of a function is referenced
if Writable_Actuals_List /= No_Elist
and then Identifiers_List /= No_Elist
then
declare
Elmt_1 : Elmt_Id;
Elmt_2 : Elmt_Id;
begin
Elmt_1 := First_Elmt (Writable_Actuals_List);
while Present (Elmt_1) loop
Elmt_2 := First_Elmt (Identifiers_List);
while Present (Elmt_2) loop
if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then
case Nkind (Parent (Node (Elmt_2))) is
when N_Aggregate
| N_Component_Association
| N_Component_Declaration
=>
Error_Msg_N
("value may be affected by call in other "
& "component because they are evaluated "
& "in unspecified order",
Node (Elmt_2));
when N_In
| N_Not_In
=>
Error_Msg_N
("value may be affected by call in other "
& "alternative because they are evaluated "
& "in unspecified order",
Node (Elmt_2));
when others =>
Error_Msg_N
("value of actual may be affected by call in "
& "other actual because they are evaluated "
& "in unspecified order",
Node (Elmt_2));
end case;
end if;
Next_Elmt (Elmt_2);
end loop;
Next_Elmt (Elmt_1);
end loop;
end;
end if;
end Check_Function_Writable_Actuals;
--------------------------------
-- Check_Implicit_Dereference --
--------------------------------
procedure Check_Implicit_Dereference (N : Node_Id; Typ : Entity_Id) is
Disc : Entity_Id;
Desig : Entity_Id;
Nam : Node_Id;
begin
if Nkind (N) = N_Indexed_Component
and then Present (Generalized_Indexing (N))
then
Nam := Generalized_Indexing (N);
else
Nam := N;
end if;
if Ada_Version < Ada_2012
or else not Has_Implicit_Dereference (Base_Type (Typ))
then
return;
elsif not Comes_From_Source (N)
and then Nkind (N) /= N_Indexed_Component
then
return;
elsif Is_Entity_Name (Nam) and then Is_Type (Entity (Nam)) then
null;
else
Disc := First_Discriminant (Typ);
while Present (Disc) loop
if Has_Implicit_Dereference (Disc) then
Desig := Designated_Type (Etype (Disc));
Add_One_Interp (Nam, Disc, Desig);
-- If the node is a generalized indexing, add interpretation
-- to that node as well, for subsequent resolution.
if Nkind (N) = N_Indexed_Component then
Add_One_Interp (N, Disc, Desig);
end if;
-- If the operation comes from a generic unit and the context
-- is a selected component, the selector name may be global
-- and set in the instance already. Remove the entity to
-- force resolution of the selected component, and the
-- generation of an explicit dereference if needed.
if In_Instance
and then Nkind (Parent (Nam)) = N_Selected_Component
then
Set_Entity (Selector_Name (Parent (Nam)), Empty);
end if;
exit;
end if;
Next_Discriminant (Disc);
end loop;
end if;
end Check_Implicit_Dereference;
----------------------------------
-- Check_Internal_Protected_Use --
----------------------------------
procedure Check_Internal_Protected_Use (N : Node_Id; Nam : Entity_Id) is
S : Entity_Id;
Prot : Entity_Id;
begin
Prot := Empty;
S := Current_Scope;
while Present (S) loop
if S = Standard_Standard then
exit;
elsif Ekind (S) = E_Function
and then Ekind (Scope (S)) = E_Protected_Type
then
Prot := Scope (S);
exit;
end if;
S := Scope (S);
end loop;
if Present (Prot)
and then Scope (Nam) = Prot
and then Ekind (Nam) /= E_Function
then
-- An indirect function call (e.g. a callback within a protected
-- function body) is not statically illegal. If the access type is
-- anonymous and is the type of an access parameter, the scope of Nam
-- will be the protected type, but it is not a protected operation.
if Ekind (Nam) = E_Subprogram_Type
and then Nkind (Associated_Node_For_Itype (Nam)) =
N_Function_Specification
then
null;
elsif Nkind (N) = N_Subprogram_Renaming_Declaration then
Error_Msg_N
("within protected function cannot use protected procedure in "
& "renaming or as generic actual", N);
elsif Nkind (N) = N_Attribute_Reference then
Error_Msg_N
("within protected function cannot take access of protected "
& "procedure", N);
else
Error_Msg_N
("within protected function, protected object is constant", N);
Error_Msg_N
("\cannot call operation that may modify it", N);
end if;
end if;
-- Verify that an internal call does not appear within a precondition
-- of a protected operation. This implements AI12-0166.
-- The precondition aspect has been rewritten as a pragma Precondition
-- and we check whether the scope of the called subprogram is the same
-- as that of the entity to which the aspect applies.
if Convention (Nam) = Convention_Protected then
declare
P : Node_Id;
begin
P := Parent (N);
while Present (P) loop
if Nkind (P) = N_Pragma
and then Chars (Pragma_Identifier (P)) = Name_Precondition
and then From_Aspect_Specification (P)
and then
Scope (Entity (Corresponding_Aspect (P))) = Scope (Nam)
then
Error_Msg_N
("internal call cannot appear in precondition of "
& "protected operation", N);
return;
elsif Nkind (P) = N_Pragma
and then Chars (Pragma_Identifier (P)) = Name_Contract_Cases
then
-- Check whether call is in a case guard. It is legal in a
-- consequence.
P := N;
while Present (P) loop
if Nkind (Parent (P)) = N_Component_Association
and then P /= Expression (Parent (P))
then
Error_Msg_N
("internal call cannot appear in case guard in a "
& "contract case", N);
end if;
P := Parent (P);
end loop;
return;
elsif Nkind (P) = N_Parameter_Specification
and then Scope (Current_Scope) = Scope (Nam)
and then Nkind (Parent (P)) in
N_Entry_Declaration | N_Subprogram_Declaration
then
Error_Msg_N
("internal call cannot appear in default for formal of "
& "protected operation", N);
return;
end if;
P := Parent (P);
end loop;
end;
end if;
end Check_Internal_Protected_Use;
---------------------------------------
-- Check_Later_Vs_Basic_Declarations --
---------------------------------------
procedure Check_Later_Vs_Basic_Declarations
(Decls : List_Id;
During_Parsing : Boolean)
is
Body_Sloc : Source_Ptr;
Decl : Node_Id;
function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean;
-- Return whether Decl is considered as a declarative item.
-- When During_Parsing is True, the semantics of Ada 83 is followed.
-- When During_Parsing is False, the semantics of SPARK is followed.
-------------------------------
-- Is_Later_Declarative_Item --
-------------------------------
function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean is
begin
if Nkind (Decl) in N_Later_Decl_Item then
return True;
elsif Nkind (Decl) = N_Pragma then
return True;
elsif During_Parsing then
return False;
-- In SPARK, a package declaration is not considered as a later
-- declarative item.
elsif Nkind (Decl) = N_Package_Declaration then
return False;
-- In SPARK, a renaming is considered as a later declarative item
elsif Nkind (Decl) in N_Renaming_Declaration then
return True;
else
return False;
end if;
end Is_Later_Declarative_Item;
-- Start of processing for Check_Later_Vs_Basic_Declarations
begin
Decl := First (Decls);
-- Loop through sequence of basic declarative items
Outer : while Present (Decl) loop
if Nkind (Decl) not in
N_Subprogram_Body | N_Package_Body | N_Task_Body
and then Nkind (Decl) not in N_Body_Stub
then
Next (Decl);
-- Once a body is encountered, we only allow later declarative
-- items. The inner loop checks the rest of the list.
else
Body_Sloc := Sloc (Decl);
Inner : while Present (Decl) loop
if not Is_Later_Declarative_Item (Decl) then
if During_Parsing then
if Ada_Version = Ada_83 then
Error_Msg_Sloc := Body_Sloc;
Error_Msg_N
("(Ada 83) decl cannot appear after body#", Decl);
end if;
end if;
end if;
Next (Decl);
end loop Inner;
end if;
end loop Outer;
end Check_Later_Vs_Basic_Declarations;
---------------------------
-- Check_No_Hidden_State --
---------------------------
procedure Check_No_Hidden_State (Id : Entity_Id) is
Context : Entity_Id := Empty;
Not_Visible : Boolean := False;
Scop : Entity_Id;
begin
pragma Assert (Ekind (Id) in E_Abstract_State | E_Variable);
-- Nothing to do for internally-generated abstract states and variables
-- because they do not represent the hidden state of the source unit.
if not Comes_From_Source (Id) then
return;
end if;
-- Find the proper context where the object or state appears
Scop := Scope (Id);
while Present (Scop) loop
Context := Scop;
-- Keep track of the context's visibility
Not_Visible := Not_Visible or else In_Private_Part (Context);
-- Prevent the search from going too far
if Context = Standard_Standard then
return;
-- Objects and states that appear immediately within a subprogram or
-- entry inside a construct nested within a subprogram do not
-- introduce a hidden state. They behave as local variable
-- declarations. The same is true for elaboration code inside a block
-- or a task.
elsif Is_Subprogram_Or_Entry (Context)
or else Ekind (Context) in E_Block | E_Task_Type
then
return;
end if;
-- Stop the traversal when a package subject to a null abstract state
-- has been found.
if Is_Package_Or_Generic_Package (Context)
and then Has_Null_Abstract_State (Context)
then
exit;
end if;
Scop := Scope (Scop);
end loop;
-- At this point we know that there is at least one package with a null
-- abstract state in visibility. Emit an error message unconditionally
-- if the entity being processed is a state because the placement of the
-- related package is irrelevant. This is not the case for objects as
-- the intermediate context matters.
if Present (Context)
and then (Ekind (Id) = E_Abstract_State or else Not_Visible)
then
Error_Msg_N ("cannot introduce hidden state &", Id);
Error_Msg_NE ("\package & has null abstract state", Id, Context);
end if;
end Check_No_Hidden_State;
---------------------------------------------
-- Check_Nonoverridable_Aspect_Consistency --
---------------------------------------------
procedure Check_Inherited_Nonoverridable_Aspects
(Inheritor : Entity_Id;
Interface_List : List_Id;
Parent_Type : Entity_Id) is
-- array needed for iterating over subtype values
Nonoverridable_Aspects : constant array (Positive range <>) of
Nonoverridable_Aspect_Id :=
(Aspect_Default_Iterator,
Aspect_Iterator_Element,
Aspect_Implicit_Dereference,
Aspect_Constant_Indexing,
Aspect_Variable_Indexing,
Aspect_Aggregate,