mirror of
https://github.com/autc04/Retro68.git
synced 2024-06-14 00:29:39 +00:00
14139 lines
482 KiB
Ada
14139 lines
482 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- E X P _ 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 Aspects; use Aspects;
|
|
with Atree; use Atree;
|
|
with Casing; use Casing;
|
|
with Checks; use Checks;
|
|
with Debug; use Debug;
|
|
with Einfo; use Einfo;
|
|
with Einfo.Entities; use Einfo.Entities;
|
|
with Einfo.Utils; use Einfo.Utils;
|
|
with Elists; use Elists;
|
|
with Errout; use Errout;
|
|
with Exp_Aggr; use Exp_Aggr;
|
|
with Exp_Ch6; use Exp_Ch6;
|
|
with Exp_Ch7; use Exp_Ch7;
|
|
with Exp_Ch11; use Exp_Ch11;
|
|
with Freeze; use Freeze;
|
|
with Ghost; use Ghost;
|
|
with Inline; use Inline;
|
|
with Itypes; use Itypes;
|
|
with Lib; use Lib;
|
|
with Nlists; use Nlists;
|
|
with Nmake; use Nmake;
|
|
with Opt; use Opt;
|
|
with Restrict; use Restrict;
|
|
with Rident; use Rident;
|
|
with Sem; use Sem;
|
|
with Sem_Aux; use Sem_Aux;
|
|
with Sem_Ch3; use Sem_Ch3;
|
|
with Sem_Ch6; use Sem_Ch6;
|
|
with Sem_Ch8; use Sem_Ch8;
|
|
with Sem_Ch12; use Sem_Ch12;
|
|
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_Res; use Sem_Res;
|
|
with Sem_Type; use Sem_Type;
|
|
with Sem_Util; use Sem_Util;
|
|
with Sinfo.Utils; use Sinfo.Utils;
|
|
with Snames; use Snames;
|
|
with Stand; use Stand;
|
|
with Stringt; use Stringt;
|
|
with Tbuild; use Tbuild;
|
|
with Ttypes; use Ttypes;
|
|
with Validsw; use Validsw;
|
|
|
|
with GNAT.HTable;
|
|
package body Exp_Util is
|
|
|
|
---------------------------------------------------------
|
|
-- Handling of inherited class-wide pre/postconditions --
|
|
---------------------------------------------------------
|
|
|
|
-- Following AI12-0113, the expression for a class-wide condition is
|
|
-- transformed for a subprogram that inherits it, by replacing calls
|
|
-- to primitive operations of the original controlling type into the
|
|
-- corresponding overriding operations of the derived type. The following
|
|
-- hash table manages this mapping, and is expanded on demand whenever
|
|
-- such inherited expression needs to be constructed.
|
|
|
|
-- The mapping is also used to check whether an inherited operation has
|
|
-- a condition that depends on overridden operations. For such an
|
|
-- operation we must create a wrapper that is then treated as a normal
|
|
-- overriding. In SPARK mode such operations are illegal.
|
|
|
|
-- For a given root type there may be several type extensions with their
|
|
-- own overriding operations, so at various times a given operation of
|
|
-- the root will be mapped into different overridings. The root type is
|
|
-- also mapped into the current type extension to indicate that its
|
|
-- operations are mapped into the overriding operations of that current
|
|
-- type extension.
|
|
|
|
-- The contents of the map are as follows:
|
|
|
|
-- Key Value
|
|
|
|
-- Discriminant (Entity_Id) Discriminant (Entity_Id)
|
|
-- Discriminant (Entity_Id) Non-discriminant name (Entity_Id)
|
|
-- Discriminant (Entity_Id) Expression (Node_Id)
|
|
-- Primitive subprogram (Entity_Id) Primitive subprogram (Entity_Id)
|
|
-- Type (Entity_Id) Type (Entity_Id)
|
|
|
|
Type_Map_Size : constant := 511;
|
|
|
|
subtype Type_Map_Header is Integer range 0 .. Type_Map_Size - 1;
|
|
function Type_Map_Hash (Id : Entity_Id) return Type_Map_Header;
|
|
|
|
package Type_Map is new GNAT.HTable.Simple_HTable
|
|
(Header_Num => Type_Map_Header,
|
|
Key => Entity_Id,
|
|
Element => Node_Or_Entity_Id,
|
|
No_element => Empty,
|
|
Hash => Type_Map_Hash,
|
|
Equal => "=");
|
|
|
|
-----------------------
|
|
-- Local Subprograms --
|
|
-----------------------
|
|
|
|
function Build_Task_Array_Image
|
|
(Loc : Source_Ptr;
|
|
Id_Ref : Node_Id;
|
|
A_Type : Entity_Id;
|
|
Dyn : Boolean := False) return Node_Id;
|
|
-- Build function to generate the image string for a task that is an array
|
|
-- component, concatenating the images of each index. To avoid storage
|
|
-- leaks, the string is built with successive slice assignments. The flag
|
|
-- Dyn indicates whether this is called for the initialization procedure of
|
|
-- an array of tasks, or for the name of a dynamically created task that is
|
|
-- assigned to an indexed component.
|
|
|
|
function Build_Task_Image_Function
|
|
(Loc : Source_Ptr;
|
|
Decls : List_Id;
|
|
Stats : List_Id;
|
|
Res : Entity_Id) return Node_Id;
|
|
-- Common processing for Task_Array_Image and Task_Record_Image. Build
|
|
-- function body that computes image.
|
|
|
|
procedure Build_Task_Image_Prefix
|
|
(Loc : Source_Ptr;
|
|
Len : out Entity_Id;
|
|
Res : out Entity_Id;
|
|
Pos : out Entity_Id;
|
|
Prefix : Entity_Id;
|
|
Sum : Node_Id;
|
|
Decls : List_Id;
|
|
Stats : List_Id);
|
|
-- Common processing for Task_Array_Image and Task_Record_Image. Create
|
|
-- local variables and assign prefix of name to result string.
|
|
|
|
function Build_Task_Record_Image
|
|
(Loc : Source_Ptr;
|
|
Id_Ref : Node_Id;
|
|
Dyn : Boolean := False) return Node_Id;
|
|
-- Build function to generate the image string for a task that is a record
|
|
-- component. Concatenate name of variable with that of selector. The flag
|
|
-- Dyn indicates whether this is called for the initialization procedure of
|
|
-- record with task components, or for a dynamically created task that is
|
|
-- assigned to a selected component.
|
|
|
|
procedure Evaluate_Slice_Bounds (Slice : Node_Id);
|
|
-- Force evaluation of bounds of a slice, which may be given by a range
|
|
-- or by a subtype indication with or without a constraint.
|
|
|
|
function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean;
|
|
-- Determine whether pragma Default_Initial_Condition denoted by Prag has
|
|
-- an assertion expression that should be verified at run time.
|
|
|
|
function Is_Uninitialized_Aggregate
|
|
(Exp : Node_Id;
|
|
T : Entity_Id) return Boolean;
|
|
-- Determine whether an array aggregate used in an object declaration
|
|
-- is uninitialized, when the aggregate is declared with a box and
|
|
-- the component type has no default value. Such an aggregate can be
|
|
-- optimized away to prevent the copying of uninitialized data, and
|
|
-- the bounds of the aggregate can be propagated directly to the
|
|
-- object declaration.
|
|
|
|
function Make_CW_Equivalent_Type
|
|
(T : Entity_Id;
|
|
E : Node_Id) return Entity_Id;
|
|
-- T is a class-wide type entity, E is the initial expression node that
|
|
-- constrains T in case such as: " X: T := E" or "new T'(E)". This function
|
|
-- returns the entity of the Equivalent type and inserts on the fly the
|
|
-- necessary declaration such as:
|
|
--
|
|
-- type anon is record
|
|
-- _parent : Root_Type (T); constrained with E discriminants (if any)
|
|
-- Extension : String (1 .. expr to match size of E);
|
|
-- end record;
|
|
--
|
|
-- This record is compatible with any object of the class of T thanks to
|
|
-- the first field and has the same size as E thanks to the second.
|
|
|
|
function Make_Literal_Range
|
|
(Loc : Source_Ptr;
|
|
Literal_Typ : Entity_Id) return Node_Id;
|
|
-- Produce a Range node whose bounds are:
|
|
-- Low_Bound (Literal_Type) ..
|
|
-- Low_Bound (Literal_Type) + (Length (Literal_Typ) - 1)
|
|
-- this is used for expanding declarations like X : String := "sdfgdfg";
|
|
--
|
|
-- If the index type of the target array is not integer, we generate:
|
|
-- Low_Bound (Literal_Type) ..
|
|
-- Literal_Type'Val
|
|
-- (Literal_Type'Pos (Low_Bound (Literal_Type))
|
|
-- + (Length (Literal_Typ) -1))
|
|
|
|
function Make_Non_Empty_Check
|
|
(Loc : Source_Ptr;
|
|
N : Node_Id) return Node_Id;
|
|
-- Produce a boolean expression checking that the unidimensional array
|
|
-- node N is not empty.
|
|
|
|
function New_Class_Wide_Subtype
|
|
(CW_Typ : Entity_Id;
|
|
N : Node_Id) return Entity_Id;
|
|
-- Create an implicit subtype of CW_Typ attached to node N
|
|
|
|
function Requires_Cleanup_Actions
|
|
(L : List_Id;
|
|
Lib_Level : Boolean;
|
|
Nested_Constructs : Boolean) return Boolean;
|
|
-- Given a list L, determine whether it contains one of the following:
|
|
--
|
|
-- 1) controlled objects
|
|
-- 2) library-level tagged types
|
|
--
|
|
-- Lib_Level is True when the list comes from a construct at the library
|
|
-- level, and False otherwise. Nested_Constructs is True when any nested
|
|
-- packages declared in L must be processed, and False otherwise.
|
|
|
|
function Side_Effect_Free_Attribute (Name : Name_Id) return Boolean;
|
|
-- Return True if the evaluation of the given attribute is considered
|
|
-- side-effect free, independently of its prefix and expressions.
|
|
|
|
-------------------------------------
|
|
-- Activate_Atomic_Synchronization --
|
|
-------------------------------------
|
|
|
|
procedure Activate_Atomic_Synchronization (N : Node_Id) is
|
|
Msg_Node : Node_Id;
|
|
|
|
begin
|
|
case Nkind (Parent (N)) is
|
|
|
|
-- Check for cases of appearing in the prefix of a construct where we
|
|
-- don't need atomic synchronization for this kind of usage.
|
|
|
|
when
|
|
-- Nothing to do if we are the prefix of an attribute, since we
|
|
-- do not want an atomic sync operation for things like 'Size.
|
|
|
|
N_Attribute_Reference
|
|
|
|
-- The N_Reference node is like an attribute
|
|
|
|
| N_Reference
|
|
|
|
-- Nothing to do for a reference to a component (or components)
|
|
-- of a composite object. Only reads and updates of the object
|
|
-- as a whole require atomic synchronization (RM C.6 (15)).
|
|
|
|
| N_Indexed_Component
|
|
| N_Selected_Component
|
|
| N_Slice
|
|
=>
|
|
-- For all the above cases, nothing to do if we are the prefix
|
|
|
|
if Prefix (Parent (N)) = N then
|
|
return;
|
|
end if;
|
|
|
|
when others =>
|
|
null;
|
|
end case;
|
|
|
|
-- Nothing to do for the identifier in an object renaming declaration,
|
|
-- the renaming itself does not need atomic synchronization.
|
|
|
|
if Nkind (Parent (N)) = N_Object_Renaming_Declaration then
|
|
return;
|
|
end if;
|
|
|
|
-- Go ahead and set the flag
|
|
|
|
Set_Atomic_Sync_Required (N);
|
|
|
|
-- Generate info message if requested
|
|
|
|
if Warn_On_Atomic_Synchronization then
|
|
case Nkind (N) is
|
|
when N_Identifier =>
|
|
Msg_Node := N;
|
|
|
|
when N_Expanded_Name
|
|
| N_Selected_Component
|
|
=>
|
|
Msg_Node := Selector_Name (N);
|
|
|
|
when N_Explicit_Dereference
|
|
| N_Indexed_Component
|
|
=>
|
|
Msg_Node := Empty;
|
|
|
|
when others =>
|
|
pragma Assert (False);
|
|
return;
|
|
end case;
|
|
|
|
if Present (Msg_Node) then
|
|
Error_Msg_N
|
|
("info: atomic synchronization set for &?.n?", Msg_Node);
|
|
else
|
|
Error_Msg_N
|
|
("info: atomic synchronization set?.n?", N);
|
|
end if;
|
|
end if;
|
|
end Activate_Atomic_Synchronization;
|
|
|
|
----------------------
|
|
-- Adjust_Condition --
|
|
----------------------
|
|
|
|
procedure Adjust_Condition (N : Node_Id) is
|
|
begin
|
|
if No (N) then
|
|
return;
|
|
end if;
|
|
|
|
declare
|
|
Loc : constant Source_Ptr := Sloc (N);
|
|
T : constant Entity_Id := Etype (N);
|
|
|
|
begin
|
|
-- Defend against a call where the argument has no type, or has a
|
|
-- type that is not Boolean. This can occur because of prior errors.
|
|
|
|
if No (T) or else not Is_Boolean_Type (T) then
|
|
return;
|
|
end if;
|
|
|
|
-- Apply validity checking if needed
|
|
|
|
if Validity_Checks_On and Validity_Check_Tests then
|
|
Ensure_Valid (N);
|
|
end if;
|
|
|
|
-- Immediate return if standard boolean, the most common case,
|
|
-- where nothing needs to be done.
|
|
|
|
if Base_Type (T) = Standard_Boolean then
|
|
return;
|
|
end if;
|
|
|
|
-- Case of zero/nonzero semantics or nonstandard enumeration
|
|
-- representation. In each case, we rewrite the node as:
|
|
|
|
-- ityp!(N) /= False'Enum_Rep
|
|
|
|
-- where ityp is an integer type with large enough size to hold any
|
|
-- value of type T.
|
|
|
|
if Nonzero_Is_True (T) or else Has_Non_Standard_Rep (T) then
|
|
Rewrite (N,
|
|
Make_Op_Ne (Loc,
|
|
Left_Opnd =>
|
|
Unchecked_Convert_To
|
|
(Integer_Type_For (Esize (T), Uns => False), N),
|
|
Right_Opnd =>
|
|
Make_Attribute_Reference (Loc,
|
|
Attribute_Name => Name_Enum_Rep,
|
|
Prefix =>
|
|
New_Occurrence_Of (First_Literal (T), Loc))));
|
|
Analyze_And_Resolve (N, Standard_Boolean);
|
|
|
|
else
|
|
Rewrite (N, Convert_To (Standard_Boolean, N));
|
|
Analyze_And_Resolve (N, Standard_Boolean);
|
|
end if;
|
|
end;
|
|
end Adjust_Condition;
|
|
|
|
------------------------
|
|
-- Adjust_Result_Type --
|
|
------------------------
|
|
|
|
procedure Adjust_Result_Type (N : Node_Id; T : Entity_Id) is
|
|
begin
|
|
-- Ignore call if current type is not Standard.Boolean
|
|
|
|
if Etype (N) /= Standard_Boolean then
|
|
return;
|
|
end if;
|
|
|
|
-- If result is already of correct type, nothing to do. Note that
|
|
-- this will get the most common case where everything has a type
|
|
-- of Standard.Boolean.
|
|
|
|
if Base_Type (T) = Standard_Boolean then
|
|
return;
|
|
|
|
else
|
|
declare
|
|
KP : constant Node_Kind := Nkind (Parent (N));
|
|
|
|
begin
|
|
-- If result is to be used as a Condition in the syntax, no need
|
|
-- to convert it back, since if it was changed to Standard.Boolean
|
|
-- using Adjust_Condition, that is just fine for this usage.
|
|
|
|
if KP in N_Raise_xxx_Error or else KP in N_Has_Condition then
|
|
return;
|
|
|
|
-- If result is an operand of another logical operation, no need
|
|
-- to reset its type, since Standard.Boolean is just fine, and
|
|
-- such operations always do Adjust_Condition on their operands.
|
|
|
|
elsif KP in N_Op_Boolean
|
|
or else KP in N_Short_Circuit
|
|
or else KP = N_Op_Not
|
|
then
|
|
return;
|
|
|
|
-- Otherwise we perform a conversion from the current type, which
|
|
-- must be Standard.Boolean, to the desired type. Use the base
|
|
-- type to prevent spurious constraint checks that are extraneous
|
|
-- to the transformation. The type and its base have the same
|
|
-- representation, standard or otherwise.
|
|
|
|
else
|
|
Set_Analyzed (N);
|
|
Rewrite (N, Convert_To (Base_Type (T), N));
|
|
Analyze_And_Resolve (N, Base_Type (T));
|
|
end if;
|
|
end;
|
|
end if;
|
|
end Adjust_Result_Type;
|
|
|
|
--------------------------
|
|
-- Append_Freeze_Action --
|
|
--------------------------
|
|
|
|
procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id) is
|
|
Fnode : Node_Id;
|
|
|
|
begin
|
|
Ensure_Freeze_Node (T);
|
|
Fnode := Freeze_Node (T);
|
|
|
|
if No (Actions (Fnode)) then
|
|
Set_Actions (Fnode, New_List (N));
|
|
else
|
|
Append (N, Actions (Fnode));
|
|
end if;
|
|
end Append_Freeze_Action;
|
|
|
|
---------------------------
|
|
-- Append_Freeze_Actions --
|
|
---------------------------
|
|
|
|
procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id) is
|
|
Fnode : Node_Id;
|
|
|
|
begin
|
|
if No (L) then
|
|
return;
|
|
end if;
|
|
|
|
Ensure_Freeze_Node (T);
|
|
Fnode := Freeze_Node (T);
|
|
|
|
if No (Actions (Fnode)) then
|
|
Set_Actions (Fnode, L);
|
|
else
|
|
Append_List (L, Actions (Fnode));
|
|
end if;
|
|
end Append_Freeze_Actions;
|
|
|
|
----------------------------------------
|
|
-- Attribute_Constrained_Static_Value --
|
|
----------------------------------------
|
|
|
|
function Attribute_Constrained_Static_Value (Pref : Node_Id) return Boolean
|
|
is
|
|
Ptyp : constant Entity_Id := Etype (Pref);
|
|
Formal_Ent : constant Entity_Id := Param_Entity (Pref);
|
|
|
|
function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean;
|
|
-- Ada 2005 (AI-363): Returns True if the object name Obj denotes a
|
|
-- view of an aliased object whose subtype is constrained.
|
|
|
|
---------------------------------
|
|
-- Is_Constrained_Aliased_View --
|
|
---------------------------------
|
|
|
|
function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean is
|
|
E : Entity_Id;
|
|
|
|
begin
|
|
if Is_Entity_Name (Obj) then
|
|
E := Entity (Obj);
|
|
|
|
if Present (Renamed_Object (E)) then
|
|
return Is_Constrained_Aliased_View (Renamed_Object (E));
|
|
else
|
|
return Is_Aliased (E) and then Is_Constrained (Etype (E));
|
|
end if;
|
|
|
|
else
|
|
return Is_Aliased_View (Obj)
|
|
and then
|
|
(Is_Constrained (Etype (Obj))
|
|
or else
|
|
(Nkind (Obj) = N_Explicit_Dereference
|
|
and then
|
|
not Object_Type_Has_Constrained_Partial_View
|
|
(Typ => Base_Type (Etype (Obj)),
|
|
Scop => Current_Scope)));
|
|
end if;
|
|
end Is_Constrained_Aliased_View;
|
|
|
|
-- Start of processing for Attribute_Constrained_Static_Value
|
|
|
|
begin
|
|
-- We are in a case where the attribute is known statically, and
|
|
-- implicit dereferences have been rewritten.
|
|
|
|
pragma Assert
|
|
(not (Present (Formal_Ent)
|
|
and then Ekind (Formal_Ent) /= E_Constant
|
|
and then Present (Extra_Constrained (Formal_Ent)))
|
|
and then
|
|
not (Is_Access_Type (Etype (Pref))
|
|
and then (not Is_Entity_Name (Pref)
|
|
or else Is_Object (Entity (Pref))))
|
|
and then
|
|
not (Nkind (Pref) = N_Identifier
|
|
and then Ekind (Entity (Pref)) = E_Variable
|
|
and then Present (Extra_Constrained (Entity (Pref)))));
|
|
|
|
if Is_Entity_Name (Pref) then
|
|
declare
|
|
Ent : constant Entity_Id := Entity (Pref);
|
|
Res : Boolean;
|
|
|
|
begin
|
|
-- (RM J.4) obsolescent cases
|
|
|
|
if Is_Type (Ent) then
|
|
|
|
-- Private type
|
|
|
|
if Is_Private_Type (Ent) then
|
|
Res := not Has_Discriminants (Ent)
|
|
or else Is_Constrained (Ent);
|
|
|
|
-- It not a private type, must be a generic actual type
|
|
-- that corresponded to a private type. We know that this
|
|
-- correspondence holds, since otherwise the reference
|
|
-- within the generic template would have been illegal.
|
|
|
|
else
|
|
if Is_Composite_Type (Underlying_Type (Ent)) then
|
|
Res := Is_Constrained (Ent);
|
|
else
|
|
Res := True;
|
|
end if;
|
|
end if;
|
|
|
|
else
|
|
|
|
-- If the prefix is not a variable or is aliased, then
|
|
-- definitely true; if it's a formal parameter without an
|
|
-- associated extra formal, then treat it as constrained.
|
|
|
|
-- Ada 2005 (AI-363): An aliased prefix must be known to be
|
|
-- constrained in order to set the attribute to True.
|
|
|
|
if not Is_Variable (Pref)
|
|
or else Present (Formal_Ent)
|
|
or else (Ada_Version < Ada_2005
|
|
and then Is_Aliased_View (Pref))
|
|
or else (Ada_Version >= Ada_2005
|
|
and then Is_Constrained_Aliased_View (Pref))
|
|
then
|
|
Res := True;
|
|
|
|
-- Variable case, look at type to see if it is constrained.
|
|
-- Note that the one case where this is not accurate (the
|
|
-- procedure formal case), has been handled above.
|
|
|
|
-- We use the Underlying_Type here (and below) in case the
|
|
-- type is private without discriminants, but the full type
|
|
-- has discriminants. This case is illegal, but we generate
|
|
-- it internally for passing to the Extra_Constrained
|
|
-- parameter.
|
|
|
|
else
|
|
-- In Ada 2012, test for case of a limited tagged type,
|
|
-- in which case the attribute is always required to
|
|
-- return True. The underlying type is tested, to make
|
|
-- sure we also return True for cases where there is an
|
|
-- unconstrained object with an untagged limited partial
|
|
-- view which has defaulted discriminants (such objects
|
|
-- always produce a False in earlier versions of
|
|
-- Ada). (Ada 2012: AI05-0214)
|
|
|
|
Res :=
|
|
Is_Constrained (Underlying_Type (Etype (Ent)))
|
|
or else
|
|
(Ada_Version >= Ada_2012
|
|
and then Is_Tagged_Type (Underlying_Type (Ptyp))
|
|
and then Is_Limited_Type (Ptyp));
|
|
end if;
|
|
end if;
|
|
|
|
return Res;
|
|
end;
|
|
|
|
-- Prefix is not an entity name. These are also cases where we can
|
|
-- always tell at compile time by looking at the form and type of the
|
|
-- prefix. If an explicit dereference of an object with constrained
|
|
-- partial view, this is unconstrained (Ada 2005: AI95-0363). If the
|
|
-- underlying type is a limited tagged type, then Constrained is
|
|
-- required to always return True (Ada 2012: AI05-0214).
|
|
|
|
else
|
|
return not Is_Variable (Pref)
|
|
or else
|
|
(Nkind (Pref) = N_Explicit_Dereference
|
|
and then
|
|
not Object_Type_Has_Constrained_Partial_View
|
|
(Typ => Base_Type (Ptyp),
|
|
Scop => Current_Scope))
|
|
or else Is_Constrained (Underlying_Type (Ptyp))
|
|
or else (Ada_Version >= Ada_2012
|
|
and then Is_Tagged_Type (Underlying_Type (Ptyp))
|
|
and then Is_Limited_Type (Ptyp));
|
|
end if;
|
|
end Attribute_Constrained_Static_Value;
|
|
|
|
------------------------------------
|
|
-- Build_Allocate_Deallocate_Proc --
|
|
------------------------------------
|
|
|
|
procedure Build_Allocate_Deallocate_Proc
|
|
(N : Node_Id;
|
|
Is_Allocate : Boolean)
|
|
is
|
|
function Find_Object (E : Node_Id) return Node_Id;
|
|
-- Given an arbitrary expression of an allocator, try to find an object
|
|
-- reference in it, otherwise return the original expression.
|
|
|
|
function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean;
|
|
-- Determine whether subprogram Subp denotes a custom allocate or
|
|
-- deallocate.
|
|
|
|
-----------------
|
|
-- Find_Object --
|
|
-----------------
|
|
|
|
function Find_Object (E : Node_Id) return Node_Id is
|
|
Expr : Node_Id;
|
|
|
|
begin
|
|
pragma Assert (Is_Allocate);
|
|
|
|
Expr := E;
|
|
loop
|
|
if Nkind (Expr) = N_Explicit_Dereference then
|
|
Expr := Prefix (Expr);
|
|
|
|
elsif Nkind (Expr) = N_Qualified_Expression then
|
|
Expr := Expression (Expr);
|
|
|
|
elsif Nkind (Expr) = N_Unchecked_Type_Conversion then
|
|
|
|
-- When interface class-wide types are involved in allocation,
|
|
-- the expander introduces several levels of address arithmetic
|
|
-- to perform dispatch table displacement. In this scenario the
|
|
-- object appears as:
|
|
|
|
-- Tag_Ptr (Base_Address (<object>'Address))
|
|
|
|
-- Detect this case and utilize the whole expression as the
|
|
-- "object" since it now points to the proper dispatch table.
|
|
|
|
if Is_RTE (Etype (Expr), RE_Tag_Ptr) then
|
|
exit;
|
|
|
|
-- Continue to strip the object
|
|
|
|
else
|
|
Expr := Expression (Expr);
|
|
end if;
|
|
|
|
else
|
|
exit;
|
|
end if;
|
|
end loop;
|
|
|
|
return Expr;
|
|
end Find_Object;
|
|
|
|
---------------------------------
|
|
-- Is_Allocate_Deallocate_Proc --
|
|
---------------------------------
|
|
|
|
function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean is
|
|
begin
|
|
-- Look for a subprogram body with only one statement which is a
|
|
-- call to Allocate_Any_Controlled / Deallocate_Any_Controlled.
|
|
|
|
if Ekind (Subp) = E_Procedure
|
|
and then Nkind (Parent (Parent (Subp))) = N_Subprogram_Body
|
|
then
|
|
declare
|
|
HSS : constant Node_Id :=
|
|
Handled_Statement_Sequence (Parent (Parent (Subp)));
|
|
Proc : Entity_Id;
|
|
|
|
begin
|
|
if Present (Statements (HSS))
|
|
and then Nkind (First (Statements (HSS))) =
|
|
N_Procedure_Call_Statement
|
|
then
|
|
Proc := Entity (Name (First (Statements (HSS))));
|
|
|
|
return
|
|
Is_RTE (Proc, RE_Allocate_Any_Controlled)
|
|
or else Is_RTE (Proc, RE_Deallocate_Any_Controlled);
|
|
end if;
|
|
end;
|
|
end if;
|
|
|
|
return False;
|
|
end Is_Allocate_Deallocate_Proc;
|
|
|
|
-- Local variables
|
|
|
|
Desig_Typ : Entity_Id;
|
|
Expr : Node_Id;
|
|
Needs_Fin : Boolean;
|
|
Pool_Id : Entity_Id;
|
|
Proc_To_Call : Node_Id := Empty;
|
|
Ptr_Typ : Entity_Id;
|
|
Use_Secondary_Stack_Pool : Boolean;
|
|
|
|
-- Start of processing for Build_Allocate_Deallocate_Proc
|
|
|
|
begin
|
|
-- Obtain the attributes of the allocation / deallocation
|
|
|
|
if Nkind (N) = N_Free_Statement then
|
|
Expr := Expression (N);
|
|
Ptr_Typ := Base_Type (Etype (Expr));
|
|
Proc_To_Call := Procedure_To_Call (N);
|
|
|
|
else
|
|
if Nkind (N) = N_Object_Declaration then
|
|
Expr := Expression (N);
|
|
else
|
|
Expr := N;
|
|
end if;
|
|
|
|
-- In certain cases an allocator with a qualified expression may
|
|
-- be relocated and used as the initialization expression of a
|
|
-- temporary:
|
|
|
|
-- before:
|
|
-- Obj : Ptr_Typ := new Desig_Typ'(...);
|
|
|
|
-- after:
|
|
-- Tmp : Ptr_Typ := new Desig_Typ'(...);
|
|
-- Obj : Ptr_Typ := Tmp;
|
|
|
|
-- Since the allocator is always marked as analyzed to avoid infinite
|
|
-- expansion, it will never be processed by this routine given that
|
|
-- the designated type needs finalization actions. Detect this case
|
|
-- and complete the expansion of the allocator.
|
|
|
|
if Nkind (Expr) = N_Identifier
|
|
and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
|
|
and then Nkind (Expression (Parent (Entity (Expr)))) = N_Allocator
|
|
then
|
|
Build_Allocate_Deallocate_Proc (Parent (Entity (Expr)), True);
|
|
return;
|
|
end if;
|
|
|
|
-- The allocator may have been rewritten into something else in which
|
|
-- case the expansion performed by this routine does not apply.
|
|
|
|
if Nkind (Expr) /= N_Allocator then
|
|
return;
|
|
end if;
|
|
|
|
Ptr_Typ := Base_Type (Etype (Expr));
|
|
Proc_To_Call := Procedure_To_Call (Expr);
|
|
end if;
|
|
|
|
Pool_Id := Associated_Storage_Pool (Ptr_Typ);
|
|
Desig_Typ := Available_View (Designated_Type (Ptr_Typ));
|
|
|
|
-- Handle concurrent types
|
|
|
|
if Is_Concurrent_Type (Desig_Typ)
|
|
and then Present (Corresponding_Record_Type (Desig_Typ))
|
|
then
|
|
Desig_Typ := Corresponding_Record_Type (Desig_Typ);
|
|
end if;
|
|
|
|
Use_Secondary_Stack_Pool :=
|
|
Is_RTE (Pool_Id, RE_SS_Pool)
|
|
or else (Nkind (Expr) = N_Allocator
|
|
and then Is_RTE (Storage_Pool (Expr), RE_SS_Pool));
|
|
|
|
-- Do not process allocations / deallocations without a pool
|
|
|
|
if No (Pool_Id) then
|
|
return;
|
|
|
|
-- Do not process allocations on / deallocations from the secondary
|
|
-- stack, except for access types used to implement indirect temps.
|
|
|
|
elsif Use_Secondary_Stack_Pool
|
|
and then not Old_Attr_Util.Indirect_Temps
|
|
.Is_Access_Type_For_Indirect_Temp (Ptr_Typ)
|
|
then
|
|
return;
|
|
|
|
-- Optimize the case where we are using the default Global_Pool_Object,
|
|
-- and we don't need the heavy finalization machinery.
|
|
|
|
elsif Is_RTE (Pool_Id, RE_Global_Pool_Object)
|
|
and then not Needs_Finalization (Desig_Typ)
|
|
then
|
|
return;
|
|
|
|
-- Do not replicate the machinery if the allocator / free has already
|
|
-- been expanded and has a custom Allocate / Deallocate.
|
|
|
|
elsif Present (Proc_To_Call)
|
|
and then Is_Allocate_Deallocate_Proc (Proc_To_Call)
|
|
then
|
|
return;
|
|
end if;
|
|
|
|
-- Finalization actions are required when the object to be allocated or
|
|
-- deallocated needs these actions and the associated access type is not
|
|
-- subject to pragma No_Heap_Finalization.
|
|
|
|
Needs_Fin :=
|
|
Needs_Finalization (Desig_Typ)
|
|
and then not No_Heap_Finalization (Ptr_Typ);
|
|
|
|
if Needs_Fin then
|
|
|
|
-- Do nothing if the access type may never allocate / deallocate
|
|
-- objects.
|
|
|
|
if No_Pool_Assigned (Ptr_Typ) then
|
|
return;
|
|
end if;
|
|
|
|
-- The allocation / deallocation of a controlled object must be
|
|
-- chained on / detached from a finalization master.
|
|
|
|
pragma Assert (Present (Finalization_Master (Ptr_Typ)));
|
|
|
|
-- The only other kind of allocation / deallocation supported by this
|
|
-- routine is on / from a subpool.
|
|
|
|
elsif Nkind (Expr) = N_Allocator
|
|
and then No (Subpool_Handle_Name (Expr))
|
|
then
|
|
return;
|
|
end if;
|
|
|
|
declare
|
|
Loc : constant Source_Ptr := Sloc (N);
|
|
Addr_Id : constant Entity_Id := Make_Temporary (Loc, 'A');
|
|
Alig_Id : constant Entity_Id := Make_Temporary (Loc, 'L');
|
|
Proc_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
|
|
Size_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
|
|
|
|
Actuals : List_Id;
|
|
Fin_Addr_Id : Entity_Id;
|
|
Fin_Mas_Act : Node_Id;
|
|
Fin_Mas_Id : Entity_Id;
|
|
Proc_To_Call : Entity_Id;
|
|
Subpool : Node_Id := Empty;
|
|
|
|
begin
|
|
-- Step 1: Construct all the actuals for the call to library routine
|
|
-- Allocate_Any_Controlled / Deallocate_Any_Controlled.
|
|
|
|
-- a) Storage pool
|
|
|
|
Actuals := New_List (New_Occurrence_Of (Pool_Id, Loc));
|
|
|
|
if Is_Allocate then
|
|
|
|
-- b) Subpool
|
|
|
|
if Nkind (Expr) = N_Allocator then
|
|
Subpool := Subpool_Handle_Name (Expr);
|
|
end if;
|
|
|
|
-- If a subpool is present it can be an arbitrary name, so make
|
|
-- the actual by copying the tree.
|
|
|
|
if Present (Subpool) then
|
|
Append_To (Actuals, New_Copy_Tree (Subpool, New_Sloc => Loc));
|
|
else
|
|
Append_To (Actuals, Make_Null (Loc));
|
|
end if;
|
|
|
|
-- c) Finalization master
|
|
|
|
if Needs_Fin then
|
|
Fin_Mas_Id := Finalization_Master (Ptr_Typ);
|
|
Fin_Mas_Act := New_Occurrence_Of (Fin_Mas_Id, Loc);
|
|
|
|
-- Handle the case where the master is actually a pointer to a
|
|
-- master. This case arises in build-in-place functions.
|
|
|
|
if Is_Access_Type (Etype (Fin_Mas_Id)) then
|
|
Append_To (Actuals, Fin_Mas_Act);
|
|
else
|
|
Append_To (Actuals,
|
|
Make_Attribute_Reference (Loc,
|
|
Prefix => Fin_Mas_Act,
|
|
Attribute_Name => Name_Unrestricted_Access));
|
|
end if;
|
|
else
|
|
Append_To (Actuals, Make_Null (Loc));
|
|
end if;
|
|
|
|
-- d) Finalize_Address
|
|
|
|
-- Primitive Finalize_Address is never generated in CodePeer mode
|
|
-- since it contains an Unchecked_Conversion.
|
|
|
|
if Needs_Fin and then not CodePeer_Mode then
|
|
Fin_Addr_Id := Finalize_Address (Desig_Typ);
|
|
pragma Assert (Present (Fin_Addr_Id));
|
|
|
|
Append_To (Actuals,
|
|
Make_Attribute_Reference (Loc,
|
|
Prefix => New_Occurrence_Of (Fin_Addr_Id, Loc),
|
|
Attribute_Name => Name_Unrestricted_Access));
|
|
else
|
|
Append_To (Actuals, Make_Null (Loc));
|
|
end if;
|
|
end if;
|
|
|
|
-- e) Address
|
|
-- f) Storage_Size
|
|
-- g) Alignment
|
|
|
|
Append_To (Actuals, New_Occurrence_Of (Addr_Id, Loc));
|
|
Append_To (Actuals, New_Occurrence_Of (Size_Id, Loc));
|
|
|
|
if (Is_Allocate or else not Is_Class_Wide_Type (Desig_Typ))
|
|
and then not Use_Secondary_Stack_Pool
|
|
then
|
|
Append_To (Actuals, New_Occurrence_Of (Alig_Id, Loc));
|
|
|
|
-- For deallocation of class-wide types we obtain the value of
|
|
-- alignment from the Type Specific Record of the deallocated object.
|
|
-- This is needed because the frontend expansion of class-wide types
|
|
-- into equivalent types confuses the back end.
|
|
|
|
else
|
|
-- Generate:
|
|
-- Obj.all'Alignment
|
|
|
|
-- ... because 'Alignment applied to class-wide types is expanded
|
|
-- into the code that reads the value of alignment from the TSD
|
|
-- (see Expand_N_Attribute_Reference)
|
|
|
|
-- In the Use_Secondary_Stack_Pool case, Alig_Id is not
|
|
-- passed in and therefore must not be referenced.
|
|
|
|
Append_To (Actuals,
|
|
Unchecked_Convert_To (RTE (RE_Storage_Offset),
|
|
Make_Attribute_Reference (Loc,
|
|
Prefix =>
|
|
Make_Explicit_Dereference (Loc, Relocate_Node (Expr)),
|
|
Attribute_Name => Name_Alignment)));
|
|
end if;
|
|
|
|
-- h) Is_Controlled
|
|
|
|
if Needs_Fin then
|
|
Is_Controlled : declare
|
|
Flag_Id : constant Entity_Id := Make_Temporary (Loc, 'F');
|
|
Flag_Expr : Node_Id;
|
|
Param : Node_Id;
|
|
Pref : Node_Id;
|
|
Temp : Node_Id;
|
|
|
|
begin
|
|
if Is_Allocate then
|
|
Temp := Find_Object (Expression (Expr));
|
|
else
|
|
Temp := Expr;
|
|
end if;
|
|
|
|
-- Processing for allocations where the expression is a subtype
|
|
-- indication.
|
|
|
|
if Is_Allocate
|
|
and then Is_Entity_Name (Temp)
|
|
and then Is_Type (Entity (Temp))
|
|
then
|
|
Flag_Expr :=
|
|
New_Occurrence_Of
|
|
(Boolean_Literals
|
|
(Needs_Finalization (Entity (Temp))), Loc);
|
|
|
|
-- The allocation / deallocation of a class-wide object relies
|
|
-- on a runtime check to determine whether the object is truly
|
|
-- controlled or not. Depending on this check, the finalization
|
|
-- machinery will request or reclaim extra storage reserved for
|
|
-- a list header.
|
|
|
|
elsif Is_Class_Wide_Type (Desig_Typ) then
|
|
|
|
-- Detect a special case where interface class-wide types
|
|
-- are involved as the object appears as:
|
|
|
|
-- Tag_Ptr (Base_Address (<object>'Address))
|
|
|
|
-- The expression already yields the proper tag, generate:
|
|
|
|
-- Temp.all
|
|
|
|
if Is_RTE (Etype (Temp), RE_Tag_Ptr) then
|
|
Param :=
|
|
Make_Explicit_Dereference (Loc,
|
|
Prefix => Relocate_Node (Temp));
|
|
|
|
-- In the default case, obtain the tag of the object about
|
|
-- to be allocated / deallocated. Generate:
|
|
|
|
-- Temp'Tag
|
|
|
|
-- If the object is an unchecked conversion (typically to
|
|
-- an access to class-wide type), we must preserve the
|
|
-- conversion to ensure that the object is seen as tagged
|
|
-- in the code that follows.
|
|
|
|
else
|
|
Pref := Temp;
|
|
|
|
if Nkind (Parent (Pref)) = N_Unchecked_Type_Conversion
|
|
then
|
|
Pref := Parent (Pref);
|
|
end if;
|
|
|
|
Param :=
|
|
Make_Attribute_Reference (Loc,
|
|
Prefix => Relocate_Node (Pref),
|
|
Attribute_Name => Name_Tag);
|
|
end if;
|
|
|
|
-- Generate:
|
|
-- Needs_Finalization (<Param>)
|
|
|
|
Flag_Expr :=
|
|
Make_Function_Call (Loc,
|
|
Name =>
|
|
New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc),
|
|
Parameter_Associations => New_List (Param));
|
|
|
|
-- Processing for generic actuals
|
|
|
|
elsif Is_Generic_Actual_Type (Desig_Typ) then
|
|
Flag_Expr :=
|
|
New_Occurrence_Of (Boolean_Literals
|
|
(Needs_Finalization (Base_Type (Desig_Typ))), Loc);
|
|
|
|
-- The object does not require any specialized checks, it is
|
|
-- known to be controlled.
|
|
|
|
else
|
|
Flag_Expr := New_Occurrence_Of (Standard_True, Loc);
|
|
end if;
|
|
|
|
-- Create the temporary which represents the finalization state
|
|
-- of the expression. Generate:
|
|
--
|
|
-- F : constant Boolean := <Flag_Expr>;
|
|
|
|
Insert_Action (N,
|
|
Make_Object_Declaration (Loc,
|
|
Defining_Identifier => Flag_Id,
|
|
Constant_Present => True,
|
|
Object_Definition =>
|
|
New_Occurrence_Of (Standard_Boolean, Loc),
|
|
Expression => Flag_Expr));
|
|
|
|
Append_To (Actuals, New_Occurrence_Of (Flag_Id, Loc));
|
|
end Is_Controlled;
|
|
|
|
-- The object is not controlled
|
|
|
|
else
|
|
Append_To (Actuals, New_Occurrence_Of (Standard_False, Loc));
|
|
end if;
|
|
|
|
-- i) On_Subpool
|
|
|
|
if Is_Allocate then
|
|
Append_To (Actuals,
|
|
New_Occurrence_Of (Boolean_Literals (Present (Subpool)), Loc));
|
|
end if;
|
|
|
|
-- Step 2: Build a wrapper Allocate / Deallocate which internally
|
|
-- calls Allocate_Any_Controlled / Deallocate_Any_Controlled.
|
|
|
|
-- Select the proper routine to call
|
|
|
|
if Is_Allocate then
|
|
Proc_To_Call := RTE (RE_Allocate_Any_Controlled);
|
|
else
|
|
Proc_To_Call := RTE (RE_Deallocate_Any_Controlled);
|
|
end if;
|
|
|
|
-- Create a custom Allocate / Deallocate routine which has identical
|
|
-- profile to that of System.Storage_Pools.
|
|
|
|
declare
|
|
-- P : Root_Storage_Pool
|
|
function Pool_Param return Node_Id is (
|
|
Make_Parameter_Specification (Loc,
|
|
Defining_Identifier => Make_Temporary (Loc, 'P'),
|
|
Parameter_Type =>
|
|
New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc)));
|
|
|
|
-- A : [out] Address
|
|
function Address_Param return Node_Id is (
|
|
Make_Parameter_Specification (Loc,
|
|
Defining_Identifier => Addr_Id,
|
|
Out_Present => Is_Allocate,
|
|
Parameter_Type =>
|
|
New_Occurrence_Of (RTE (RE_Address), Loc)));
|
|
|
|
-- S : Storage_Count
|
|
function Size_Param return Node_Id is (
|
|
Make_Parameter_Specification (Loc,
|
|
Defining_Identifier => Size_Id,
|
|
Parameter_Type =>
|
|
New_Occurrence_Of (RTE (RE_Storage_Count), Loc)));
|
|
|
|
-- L : Storage_Count
|
|
function Alignment_Param return Node_Id is (
|
|
Make_Parameter_Specification (Loc,
|
|
Defining_Identifier => Alig_Id,
|
|
Parameter_Type =>
|
|
New_Occurrence_Of (RTE (RE_Storage_Count), Loc)));
|
|
|
|
Formal_Params : List_Id;
|
|
begin
|
|
if Use_Secondary_Stack_Pool then
|
|
-- Gigi expects a different profile in the Secondary_Stack_Pool
|
|
-- case. There must be no uses of the two missing formals
|
|
-- (i.e., Pool_Param and Alignment_Param) in this case.
|
|
Formal_Params := New_List (Address_Param, Size_Param);
|
|
else
|
|
Formal_Params := New_List (
|
|
Pool_Param, Address_Param, Size_Param, Alignment_Param);
|
|
end if;
|
|
|
|
Insert_Action (N,
|
|
Make_Subprogram_Body (Loc,
|
|
Specification =>
|
|
-- procedure Pnn
|
|
Make_Procedure_Specification (Loc,
|
|
Defining_Unit_Name => Proc_Id,
|
|
Parameter_Specifications => Formal_Params),
|
|
|
|
Declarations => No_List,
|
|
|
|
Handled_Statement_Sequence =>
|
|
Make_Handled_Sequence_Of_Statements (Loc,
|
|
Statements => New_List (
|
|
Make_Procedure_Call_Statement (Loc,
|
|
Name =>
|
|
New_Occurrence_Of (Proc_To_Call, Loc),
|
|
Parameter_Associations => Actuals)))),
|
|
Suppress => All_Checks);
|
|
end;
|
|
|
|
-- The newly generated Allocate / Deallocate becomes the default
|
|
-- procedure to call when the back end processes the allocation /
|
|
-- deallocation.
|
|
|
|
if Is_Allocate then
|
|
Set_Procedure_To_Call (Expr, Proc_Id);
|
|
else
|
|
Set_Procedure_To_Call (N, Proc_Id);
|
|
end if;
|
|
end;
|
|
end Build_Allocate_Deallocate_Proc;
|
|
|
|
-------------------------------
|
|
-- Build_Abort_Undefer_Block --
|
|
-------------------------------
|
|
|
|
function Build_Abort_Undefer_Block
|
|
(Loc : Source_Ptr;
|
|
Stmts : List_Id;
|
|
Context : Node_Id) return Node_Id
|
|
is
|
|
Exceptions_OK : constant Boolean :=
|
|
not Restriction_Active (No_Exception_Propagation);
|
|
|
|
AUD : Entity_Id;
|
|
Blk : Node_Id;
|
|
Blk_Id : Entity_Id;
|
|
HSS : Node_Id;
|
|
|
|
begin
|
|
-- The block should be generated only when undeferring abort in the
|
|
-- context of a potential exception.
|
|
|
|
pragma Assert (Abort_Allowed and Exceptions_OK);
|
|
|
|
-- Generate:
|
|
-- begin
|
|
-- <Stmts>
|
|
-- at end
|
|
-- Abort_Undefer_Direct;
|
|
-- end;
|
|
|
|
AUD := RTE (RE_Abort_Undefer_Direct);
|
|
|
|
HSS :=
|
|
Make_Handled_Sequence_Of_Statements (Loc,
|
|
Statements => Stmts,
|
|
At_End_Proc => New_Occurrence_Of (AUD, Loc));
|
|
|
|
Blk :=
|
|
Make_Block_Statement (Loc,
|
|
Handled_Statement_Sequence => HSS);
|
|
Set_Is_Abort_Block (Blk);
|
|
|
|
Add_Block_Identifier (Blk, Blk_Id);
|
|
Expand_At_End_Handler (HSS, Blk_Id);
|
|
|
|
-- Present the Abort_Undefer_Direct function to the back end to inline
|
|
-- the call to the routine.
|
|
|
|
Add_Inlined_Body (AUD, Context);
|
|
|
|
return Blk;
|
|
end Build_Abort_Undefer_Block;
|
|
|
|
---------------------------------
|
|
-- Build_Class_Wide_Expression --
|
|
---------------------------------
|
|
|
|
procedure Build_Class_Wide_Expression
|
|
(Pragma_Or_Expr : Node_Id;
|
|
Subp : Entity_Id;
|
|
Par_Subp : Entity_Id;
|
|
Adjust_Sloc : Boolean)
|
|
is
|
|
function Replace_Entity (N : Node_Id) return Traverse_Result;
|
|
-- Replace reference to formal of inherited operation or to primitive
|
|
-- operation of root type, with corresponding entity for derived type,
|
|
-- when constructing the class-wide condition of an overriding
|
|
-- subprogram.
|
|
|
|
--------------------
|
|
-- Replace_Entity --
|
|
--------------------
|
|
|
|
function Replace_Entity (N : Node_Id) return Traverse_Result is
|
|
New_E : Entity_Id;
|
|
|
|
begin
|
|
if Adjust_Sloc then
|
|
Adjust_Inherited_Pragma_Sloc (N);
|
|
end if;
|
|
|
|
if Nkind (N) in N_Identifier | N_Expanded_Name | N_Operator_Symbol
|
|
and then Present (Entity (N))
|
|
and then
|
|
(Is_Formal (Entity (N)) or else Is_Subprogram (Entity (N)))
|
|
and then
|
|
(Nkind (Parent (N)) /= N_Attribute_Reference
|
|
or else Attribute_Name (Parent (N)) /= Name_Class)
|
|
then
|
|
-- The replacement does not apply to dispatching calls within the
|
|
-- condition, but only to calls whose static tag is that of the
|
|
-- parent type.
|
|
|
|
if Is_Subprogram (Entity (N))
|
|
and then Nkind (Parent (N)) = N_Function_Call
|
|
and then Present (Controlling_Argument (Parent (N)))
|
|
then
|
|
return OK;
|
|
end if;
|
|
|
|
-- Determine whether entity has a renaming
|
|
|
|
New_E := Type_Map.Get (Entity (N));
|
|
|
|
if Present (New_E) then
|
|
Rewrite (N, New_Occurrence_Of (New_E, Sloc (N)));
|
|
end if;
|
|
|
|
-- Update type of function call node, which should be the same as
|
|
-- the function's return type.
|
|
|
|
if Is_Subprogram (Entity (N))
|
|
and then Nkind (Parent (N)) = N_Function_Call
|
|
then
|
|
Set_Etype (Parent (N), Etype (Entity (N)));
|
|
end if;
|
|
|
|
-- The whole expression will be reanalyzed
|
|
|
|
elsif Nkind (N) in N_Has_Etype then
|
|
Set_Analyzed (N, False);
|
|
end if;
|
|
|
|
return OK;
|
|
end Replace_Entity;
|
|
|
|
procedure Replace_Condition_Entities is
|
|
new Traverse_Proc (Replace_Entity);
|
|
|
|
-- Local variables
|
|
|
|
Par_Typ : constant Entity_Id := Find_Dispatching_Type (Par_Subp);
|
|
Subp_Typ : constant Entity_Id := Find_Dispatching_Type (Subp);
|
|
|
|
-- Start of processing for Build_Class_Wide_Expression
|
|
|
|
begin
|
|
pragma Assert (Par_Typ /= Subp_Typ);
|
|
|
|
Update_Primitives_Mapping (Par_Subp, Subp);
|
|
Map_Formals (Par_Subp, Subp);
|
|
Replace_Condition_Entities (Pragma_Or_Expr);
|
|
end Build_Class_Wide_Expression;
|
|
|
|
--------------------
|
|
-- Build_DIC_Call --
|
|
--------------------
|
|
|
|
function Build_DIC_Call
|
|
(Loc : Source_Ptr;
|
|
Obj_Name : Node_Id;
|
|
Typ : Entity_Id) return Node_Id
|
|
is
|
|
Proc_Id : constant Entity_Id := DIC_Procedure (Typ);
|
|
Formal_Typ : constant Entity_Id := Etype (First_Formal (Proc_Id));
|
|
|
|
begin
|
|
-- The DIC procedure has a null body if assertions are disabled or
|
|
-- Assertion_Policy Ignore is in effect. In that case, it would be
|
|
-- nice to generate a null statement instead of a call to the DIC
|
|
-- procedure, but doing that seems to interfere with the determination
|
|
-- of ECRs (early call regions) in SPARK. ???
|
|
|
|
return
|
|
Make_Procedure_Call_Statement (Loc,
|
|
Name => New_Occurrence_Of (Proc_Id, Loc),
|
|
Parameter_Associations => New_List (
|
|
Unchecked_Convert_To (Formal_Typ, Obj_Name)));
|
|
end Build_DIC_Call;
|
|
|
|
------------------------------
|
|
-- Build_DIC_Procedure_Body --
|
|
------------------------------
|
|
|
|
-- WARNING: This routine manages Ghost regions. Return statements must be
|
|
-- replaced by gotos which jump to the end of the routine and restore the
|
|
-- Ghost mode.
|
|
|
|
procedure Build_DIC_Procedure_Body
|
|
(Typ : Entity_Id;
|
|
Partial_DIC : Boolean := False)
|
|
is
|
|
Pragmas_Seen : Elist_Id := No_Elist;
|
|
-- This list contains all DIC pragmas processed so far. The list is used
|
|
-- to avoid redundant Default_Initial_Condition checks.
|
|
|
|
procedure Add_DIC_Check
|
|
(DIC_Prag : Node_Id;
|
|
DIC_Expr : Node_Id;
|
|
Stmts : in out List_Id);
|
|
-- Subsidiary to all Add_xxx_DIC routines. Add a runtime check to verify
|
|
-- assertion expression DIC_Expr of pragma DIC_Prag. All generated code
|
|
-- is added to list Stmts.
|
|
|
|
procedure Add_Inherited_DIC
|
|
(DIC_Prag : Node_Id;
|
|
Par_Typ : Entity_Id;
|
|
Deriv_Typ : Entity_Id;
|
|
Stmts : in out List_Id);
|
|
-- Add a runtime check to verify the assertion expression of inherited
|
|
-- pragma DIC_Prag. Par_Typ is parent type, which is also the owner of
|
|
-- the DIC pragma. Deriv_Typ is the derived type inheriting the DIC
|
|
-- pragma. All generated code is added to list Stmts.
|
|
|
|
procedure Add_Inherited_Tagged_DIC
|
|
(DIC_Prag : Node_Id;
|
|
Expr : Node_Id;
|
|
Stmts : in out List_Id);
|
|
-- Add a runtime check to verify assertion expression DIC_Expr of
|
|
-- inherited pragma DIC_Prag. This routine applies class-wide pre-
|
|
-- and postcondition-like runtime semantics to the check. Expr is
|
|
-- the assertion expression after substitution has been performed
|
|
-- (via Replace_References). All generated code is added to list Stmts.
|
|
|
|
procedure Add_Inherited_DICs
|
|
(T : Entity_Id;
|
|
Priv_Typ : Entity_Id;
|
|
Full_Typ : Entity_Id;
|
|
Obj_Id : Entity_Id;
|
|
Checks : in out List_Id);
|
|
-- Generate a DIC check for each inherited Default_Initial_Condition
|
|
-- coming from all parent types of type T. Priv_Typ and Full_Typ denote
|
|
-- the partial and full view of the parent type. Obj_Id denotes the
|
|
-- entity of the _object formal parameter of the DIC procedure. All
|
|
-- created checks are added to list Checks.
|
|
|
|
procedure Add_Own_DIC
|
|
(DIC_Prag : Node_Id;
|
|
DIC_Typ : Entity_Id;
|
|
Obj_Id : Entity_Id;
|
|
Stmts : in out List_Id);
|
|
-- Add a runtime check to verify the assertion expression of pragma
|
|
-- DIC_Prag. DIC_Typ is the owner of the DIC pragma. Obj_Id is the
|
|
-- object to substitute in the assertion expression for any references
|
|
-- to the current instance of the type All generated code is added to
|
|
-- list Stmts.
|
|
|
|
procedure Add_Parent_DICs
|
|
(T : Entity_Id;
|
|
Obj_Id : Entity_Id;
|
|
Checks : in out List_Id);
|
|
-- Generate a Default_Initial_Condition check for each inherited DIC
|
|
-- aspect coming from all parent types of type T. Obj_Id denotes the
|
|
-- entity of the _object formal parameter of the DIC procedure. All
|
|
-- created checks are added to list Checks.
|
|
|
|
-------------------
|
|
-- Add_DIC_Check --
|
|
-------------------
|
|
|
|
procedure Add_DIC_Check
|
|
(DIC_Prag : Node_Id;
|
|
DIC_Expr : Node_Id;
|
|
Stmts : in out List_Id)
|
|
is
|
|
Loc : constant Source_Ptr := Sloc (DIC_Prag);
|
|
Nam : constant Name_Id := Original_Aspect_Pragma_Name (DIC_Prag);
|
|
|
|
begin
|
|
-- The DIC pragma is ignored, nothing left to do
|
|
|
|
if Is_Ignored (DIC_Prag) then
|
|
null;
|
|
|
|
-- Otherwise the DIC expression must be checked at run time.
|
|
-- Generate:
|
|
|
|
-- pragma Check (<Nam>, <DIC_Expr>);
|
|
|
|
else
|
|
Append_New_To (Stmts,
|
|
Make_Pragma (Loc,
|
|
Pragma_Identifier =>
|
|
Make_Identifier (Loc, Name_Check),
|
|
|
|
Pragma_Argument_Associations => New_List (
|
|
Make_Pragma_Argument_Association (Loc,
|
|
Expression => Make_Identifier (Loc, Nam)),
|
|
|
|
Make_Pragma_Argument_Association (Loc,
|
|
Expression => DIC_Expr))));
|
|
end if;
|
|
|
|
-- Add the pragma to the list of processed pragmas
|
|
|
|
Append_New_Elmt (DIC_Prag, Pragmas_Seen);
|
|
end Add_DIC_Check;
|
|
|
|
-----------------------
|
|
-- Add_Inherited_DIC --
|
|
-----------------------
|
|
|
|
procedure Add_Inherited_DIC
|
|
(DIC_Prag : Node_Id;
|
|
Par_Typ : Entity_Id;
|
|
Deriv_Typ : Entity_Id;
|
|
Stmts : in out List_Id)
|
|
is
|
|
Deriv_Proc : constant Entity_Id := DIC_Procedure (Deriv_Typ);
|
|
Deriv_Obj : constant Entity_Id := First_Entity (Deriv_Proc);
|
|
Par_Proc : constant Entity_Id := DIC_Procedure (Par_Typ);
|
|
Par_Obj : constant Entity_Id := First_Entity (Par_Proc);
|
|
Loc : constant Source_Ptr := Sloc (DIC_Prag);
|
|
|
|
begin
|
|
pragma Assert (Present (Deriv_Proc) and then Present (Par_Proc));
|
|
|
|
-- Verify the inherited DIC assertion expression by calling the DIC
|
|
-- procedure of the parent type.
|
|
|
|
-- Generate:
|
|
-- <Par_Typ>DIC (Par_Typ (_object));
|
|
|
|
Append_New_To (Stmts,
|
|
Make_Procedure_Call_Statement (Loc,
|
|
Name => New_Occurrence_Of (Par_Proc, Loc),
|
|
Parameter_Associations => New_List (
|
|
Convert_To
|
|
(Typ => Etype (Par_Obj),
|
|
Expr => New_Occurrence_Of (Deriv_Obj, Loc)))));
|
|
end Add_Inherited_DIC;
|
|
|
|
------------------------------
|
|
-- Add_Inherited_Tagged_DIC --
|
|
------------------------------
|
|
|
|
procedure Add_Inherited_Tagged_DIC
|
|
(DIC_Prag : Node_Id;
|
|
Expr : Node_Id;
|
|
Stmts : in out List_Id)
|
|
is
|
|
begin
|
|
-- Once the DIC assertion expression is fully processed, add a check
|
|
-- to the statements of the DIC procedure.
|
|
|
|
Add_DIC_Check
|
|
(DIC_Prag => DIC_Prag,
|
|
DIC_Expr => Expr,
|
|
Stmts => Stmts);
|
|
end Add_Inherited_Tagged_DIC;
|
|
|
|
------------------------
|
|
-- Add_Inherited_DICs --
|
|
------------------------
|
|
|
|
procedure Add_Inherited_DICs
|
|
(T : Entity_Id;
|
|
Priv_Typ : Entity_Id;
|
|
Full_Typ : Entity_Id;
|
|
Obj_Id : Entity_Id;
|
|
Checks : in out List_Id)
|
|
is
|
|
Deriv_Typ : Entity_Id;
|
|
Expr : Node_Id;
|
|
Prag : Node_Id;
|
|
Prag_Expr : Node_Id;
|
|
Prag_Expr_Arg : Node_Id;
|
|
Prag_Typ : Node_Id;
|
|
Prag_Typ_Arg : Node_Id;
|
|
|
|
Par_Proc : Entity_Id;
|
|
-- The "partial" invariant procedure of Par_Typ
|
|
|
|
Par_Typ : Entity_Id;
|
|
-- The suitable view of the parent type used in the substitution of
|
|
-- type attributes.
|
|
|
|
begin
|
|
if not Present (Priv_Typ) and then not Present (Full_Typ) then
|
|
return;
|
|
end if;
|
|
|
|
-- When the type inheriting the class-wide invariant is a concurrent
|
|
-- type, use the corresponding record type because it contains all
|
|
-- primitive operations of the concurrent type and allows for proper
|
|
-- substitution.
|
|
|
|
if Is_Concurrent_Type (T) then
|
|
Deriv_Typ := Corresponding_Record_Type (T);
|
|
else
|
|
Deriv_Typ := T;
|
|
end if;
|
|
|
|
pragma Assert (Present (Deriv_Typ));
|
|
|
|
-- Determine which rep item chain to use. Precedence is given to that
|
|
-- of the parent type's partial view since it usually carries all the
|
|
-- class-wide invariants.
|
|
|
|
if Present (Priv_Typ) then
|
|
Prag := First_Rep_Item (Priv_Typ);
|
|
else
|
|
Prag := First_Rep_Item (Full_Typ);
|
|
end if;
|
|
|
|
while Present (Prag) loop
|
|
if Nkind (Prag) = N_Pragma
|
|
and then Pragma_Name (Prag) = Name_Default_Initial_Condition
|
|
then
|
|
-- Nothing to do if the pragma was already processed
|
|
|
|
if Contains (Pragmas_Seen, Prag) then
|
|
return;
|
|
end if;
|
|
|
|
-- Extract arguments of the Default_Initial_Condition pragma
|
|
|
|
Prag_Expr_Arg := First (Pragma_Argument_Associations (Prag));
|
|
Prag_Expr := Expression_Copy (Prag_Expr_Arg);
|
|
|
|
-- Pick up the implicit second argument of the pragma, which
|
|
-- indicates the type that the pragma applies to.
|
|
|
|
Prag_Typ_Arg := Next (Prag_Expr_Arg);
|
|
if Present (Prag_Typ_Arg) then
|
|
Prag_Typ := Get_Pragma_Arg (Prag_Typ_Arg);
|
|
else
|
|
Prag_Typ := Empty;
|
|
end if;
|
|
|
|
-- The pragma applies to the partial view of the parent type
|
|
|
|
if Present (Priv_Typ)
|
|
and then Present (Prag_Typ)
|
|
and then Entity (Prag_Typ) = Priv_Typ
|
|
then
|
|
Par_Typ := Priv_Typ;
|
|
|
|
-- The pragma applies to the full view of the parent type
|
|
|
|
elsif Present (Full_Typ)
|
|
and then Present (Prag_Typ)
|
|
and then Entity (Prag_Typ) = Full_Typ
|
|
then
|
|
Par_Typ := Full_Typ;
|
|
|
|
-- Otherwise the pragma does not belong to the parent type and
|
|
-- should not be considered.
|
|
|
|
else
|
|
return;
|
|
end if;
|
|
|
|
-- Substitute references in the DIC expression that are related
|
|
-- to the partial type with corresponding references related to
|
|
-- the derived type (call to Replace_References below).
|
|
|
|
Expr := New_Copy_Tree (Prag_Expr);
|
|
|
|
Par_Proc := Partial_DIC_Procedure (Par_Typ);
|
|
|
|
-- If there's not a partial DIC procedure (such as when a
|
|
-- full type doesn't have its own DIC, but is inherited from
|
|
-- a type with DIC), get the full DIC procedure.
|
|
|
|
if not Present (Par_Proc) then
|
|
Par_Proc := DIC_Procedure (Par_Typ);
|
|
end if;
|
|
|
|
Replace_References
|
|
(Expr => Expr,
|
|
Par_Typ => Par_Typ,
|
|
Deriv_Typ => Deriv_Typ,
|
|
Par_Obj => First_Formal (Par_Proc),
|
|
Deriv_Obj => Obj_Id);
|
|
|
|
-- Why are there different actions depending on whether T is
|
|
-- tagged? Can these be unified? ???
|
|
|
|
if Is_Tagged_Type (T) then
|
|
Add_Inherited_Tagged_DIC
|
|
(DIC_Prag => Prag,
|
|
Expr => Expr,
|
|
Stmts => Checks);
|
|
|
|
else
|
|
Add_Inherited_DIC
|
|
(DIC_Prag => Prag,
|
|
Par_Typ => Par_Typ,
|
|
Deriv_Typ => Deriv_Typ,
|
|
Stmts => Checks);
|
|
end if;
|
|
|
|
-- Leave as soon as we get a DIC pragma, since we'll visit
|
|
-- the pragmas of the parents, so will get to any "inherited"
|
|
-- pragmas that way.
|
|
|
|
return;
|
|
end if;
|
|
|
|
Next_Rep_Item (Prag);
|
|
end loop;
|
|
end Add_Inherited_DICs;
|
|
|
|
-----------------
|
|
-- Add_Own_DIC --
|
|
-----------------
|
|
|
|
procedure Add_Own_DIC
|
|
(DIC_Prag : Node_Id;
|
|
DIC_Typ : Entity_Id;
|
|
Obj_Id : Entity_Id;
|
|
Stmts : in out List_Id)
|
|
is
|
|
DIC_Args : constant List_Id :=
|
|
Pragma_Argument_Associations (DIC_Prag);
|
|
DIC_Arg : constant Node_Id := First (DIC_Args);
|
|
DIC_Asp : constant Node_Id := Corresponding_Aspect (DIC_Prag);
|
|
DIC_Expr : constant Node_Id := Get_Pragma_Arg (DIC_Arg);
|
|
|
|
-- Local variables
|
|
|
|
Typ_Decl : constant Node_Id := Declaration_Node (DIC_Typ);
|
|
|
|
Expr : Node_Id;
|
|
|
|
-- Start of processing for Add_Own_DIC
|
|
|
|
begin
|
|
pragma Assert (Present (DIC_Expr));
|
|
Expr := New_Copy_Tree (DIC_Expr);
|
|
|
|
-- Perform the following substitution:
|
|
|
|
-- * Replace the current instance of DIC_Typ with a reference to
|
|
-- the _object formal parameter of the DIC procedure.
|
|
|
|
Replace_Type_References
|
|
(Expr => Expr,
|
|
Typ => DIC_Typ,
|
|
Obj_Id => Obj_Id);
|
|
|
|
-- Preanalyze the DIC expression to detect errors and at the same
|
|
-- time capture the visibility of the proper package part.
|
|
|
|
Set_Parent (Expr, Typ_Decl);
|
|
Preanalyze_Assert_Expression (Expr, Any_Boolean);
|
|
|
|
-- Save a copy of the expression with all replacements and analysis
|
|
-- already taken place in case a derived type inherits the pragma.
|
|
-- The copy will be used as the foundation of the derived type's own
|
|
-- version of the DIC assertion expression.
|
|
|
|
if Is_Tagged_Type (DIC_Typ) then
|
|
Set_Expression_Copy (DIC_Arg, New_Copy_Tree (Expr));
|
|
end if;
|
|
|
|
-- If the pragma comes from an aspect specification, replace the
|
|
-- saved expression because all type references must be substituted
|
|
-- for the call to Preanalyze_Spec_Expression in Check_Aspect_At_xxx
|
|
-- routines.
|
|
|
|
if Present (DIC_Asp) then
|
|
Set_Entity (Identifier (DIC_Asp), New_Copy_Tree (Expr));
|
|
end if;
|
|
|
|
-- Once the DIC assertion expression is fully processed, add a check
|
|
-- to the statements of the DIC procedure (unless the type is an
|
|
-- abstract type, in which case we don't want the possibility of
|
|
-- generating a call to an abstract function of the type; such DIC
|
|
-- procedures can never be called in any case, so not generating the
|
|
-- check at all is OK).
|
|
|
|
if not Is_Abstract_Type (DIC_Typ) or else GNATprove_Mode then
|
|
Add_DIC_Check
|
|
(DIC_Prag => DIC_Prag,
|
|
DIC_Expr => Expr,
|
|
Stmts => Stmts);
|
|
end if;
|
|
end Add_Own_DIC;
|
|
|
|
---------------------
|
|
-- Add_Parent_DICs --
|
|
---------------------
|
|
|
|
procedure Add_Parent_DICs
|
|
(T : Entity_Id;
|
|
Obj_Id : Entity_Id;
|
|
Checks : in out List_Id)
|
|
is
|
|
Dummy_1 : Entity_Id;
|
|
Dummy_2 : Entity_Id;
|
|
|
|
Curr_Typ : Entity_Id;
|
|
-- The entity of the current type being examined
|
|
|
|
Full_Typ : Entity_Id;
|
|
-- The full view of Par_Typ
|
|
|
|
Par_Typ : Entity_Id;
|
|
-- The entity of the parent type
|
|
|
|
Priv_Typ : Entity_Id;
|
|
-- The partial view of Par_Typ
|
|
|
|
Op_Node : Elmt_Id;
|
|
Par_Prim : Entity_Id;
|
|
Prim : Entity_Id;
|
|
|
|
begin
|
|
-- Map the overridden primitive to the overriding one; required by
|
|
-- Replace_References (called by Add_Inherited_DICs) to handle calls
|
|
-- to parent primitives.
|
|
|
|
Op_Node := First_Elmt (Primitive_Operations (T));
|
|
while Present (Op_Node) loop
|
|
Prim := Node (Op_Node);
|
|
|
|
if Present (Overridden_Operation (Prim))
|
|
and then Comes_From_Source (Prim)
|
|
then
|
|
Par_Prim := Overridden_Operation (Prim);
|
|
|
|
-- Create a mapping of the form:
|
|
-- parent type primitive -> derived type primitive
|
|
|
|
Type_Map.Set (Par_Prim, Prim);
|
|
end if;
|
|
|
|
Next_Elmt (Op_Node);
|
|
end loop;
|
|
|
|
-- Climb the parent type chain
|
|
|
|
Curr_Typ := T;
|
|
loop
|
|
-- Do not consider subtypes, as they inherit the DICs from their
|
|
-- base types.
|
|
|
|
Par_Typ := Base_Type (Etype (Base_Type (Curr_Typ)));
|
|
|
|
-- Stop the climb once the root of the parent chain is
|
|
-- reached.
|
|
|
|
exit when Curr_Typ = Par_Typ;
|
|
|
|
-- Process the DICs of the parent type
|
|
|
|
Get_Views (Par_Typ, Priv_Typ, Full_Typ, Dummy_1, Dummy_2);
|
|
|
|
-- Only try to inherit a DIC pragma from the parent type Par_Typ
|
|
-- if it Has_Own_DIC pragma. The loop will proceed up the parent
|
|
-- chain to find all types that have their own DIC.
|
|
|
|
if Has_Own_DIC (Par_Typ) then
|
|
Add_Inherited_DICs
|
|
(T => T,
|
|
Priv_Typ => Priv_Typ,
|
|
Full_Typ => Full_Typ,
|
|
Obj_Id => Obj_Id,
|
|
Checks => Checks);
|
|
end if;
|
|
|
|
Curr_Typ := Par_Typ;
|
|
end loop;
|
|
end Add_Parent_DICs;
|
|
|
|
-- Local variables
|
|
|
|
Loc : constant Source_Ptr := Sloc (Typ);
|
|
|
|
Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
|
|
Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
|
|
-- Save the Ghost-related attributes to restore on exit
|
|
|
|
DIC_Prag : Node_Id;
|
|
DIC_Typ : Entity_Id;
|
|
Dummy_1 : Entity_Id;
|
|
Dummy_2 : Entity_Id;
|
|
Proc_Body : Node_Id;
|
|
Proc_Body_Id : Entity_Id;
|
|
Proc_Decl : Node_Id;
|
|
Proc_Id : Entity_Id;
|
|
Stmts : List_Id := No_List;
|
|
|
|
CRec_Typ : Entity_Id := Empty;
|
|
-- The corresponding record type of Full_Typ
|
|
|
|
Full_Typ : Entity_Id := Empty;
|
|
-- The full view of the working type
|
|
|
|
Obj_Id : Entity_Id := Empty;
|
|
-- The _object formal parameter of the invariant procedure
|
|
|
|
Part_Proc : Entity_Id := Empty;
|
|
-- The entity of the "partial" invariant procedure
|
|
|
|
Priv_Typ : Entity_Id := Empty;
|
|
-- The partial view of the working type
|
|
|
|
Work_Typ : Entity_Id;
|
|
-- The working type
|
|
|
|
-- Start of processing for Build_DIC_Procedure_Body
|
|
|
|
begin
|
|
Work_Typ := Base_Type (Typ);
|
|
|
|
-- Do not process class-wide types as these are Itypes, but lack a first
|
|
-- subtype (see below).
|
|
|
|
if Is_Class_Wide_Type (Work_Typ) then
|
|
return;
|
|
|
|
-- Do not process the underlying full view of a private type. There is
|
|
-- no way to get back to the partial view, plus the body will be built
|
|
-- by the full view or the base type.
|
|
|
|
elsif Is_Underlying_Full_View (Work_Typ) then
|
|
return;
|
|
|
|
-- Use the first subtype when dealing with various base types
|
|
|
|
elsif Is_Itype (Work_Typ) then
|
|
Work_Typ := First_Subtype (Work_Typ);
|
|
|
|
-- The input denotes the corresponding record type of a protected or a
|
|
-- task type. Work with the concurrent type because the corresponding
|
|
-- record type may not be visible to clients of the type.
|
|
|
|
elsif Ekind (Work_Typ) = E_Record_Type
|
|
and then Is_Concurrent_Record_Type (Work_Typ)
|
|
then
|
|
Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
|
|
end if;
|
|
|
|
-- The working type may be subject to pragma Ghost. Set the mode now to
|
|
-- ensure that the DIC procedure is properly marked as Ghost.
|
|
|
|
Set_Ghost_Mode (Work_Typ);
|
|
|
|
-- The working type must be either define a DIC pragma of its own or
|
|
-- inherit one from a parent type.
|
|
|
|
pragma Assert (Has_DIC (Work_Typ));
|
|
|
|
-- Recover the type which defines the DIC pragma. This is either the
|
|
-- working type itself or a parent type when the pragma is inherited.
|
|
|
|
DIC_Typ := Find_DIC_Type (Work_Typ);
|
|
pragma Assert (Present (DIC_Typ));
|
|
|
|
DIC_Prag := Get_Pragma (DIC_Typ, Pragma_Default_Initial_Condition);
|
|
pragma Assert (Present (DIC_Prag));
|
|
|
|
-- Nothing to do if pragma DIC appears without an argument or its sole
|
|
-- argument is "null".
|
|
|
|
if not Is_Verifiable_DIC_Pragma (DIC_Prag) then
|
|
goto Leave;
|
|
end if;
|
|
|
|
-- Obtain both views of the type
|
|
|
|
Get_Views (Work_Typ, Priv_Typ, Full_Typ, Dummy_1, CRec_Typ);
|
|
|
|
-- The caller requests a body for the partial DIC procedure
|
|
|
|
if Partial_DIC then
|
|
Proc_Id := Partial_DIC_Procedure (Work_Typ);
|
|
|
|
-- The "full" DIC procedure body was already created
|
|
|
|
-- Create a declaration for the "partial" DIC procedure if it
|
|
-- is not available.
|
|
|
|
if No (Proc_Id) then
|
|
Build_DIC_Procedure_Declaration
|
|
(Typ => Work_Typ,
|
|
Partial_DIC => True);
|
|
|
|
Proc_Id := Partial_DIC_Procedure (Work_Typ);
|
|
end if;
|
|
|
|
-- The caller requests a body for the "full" DIC procedure
|
|
|
|
else
|
|
Proc_Id := DIC_Procedure (Work_Typ);
|
|
Part_Proc := Partial_DIC_Procedure (Work_Typ);
|
|
|
|
-- Create a declaration for the "full" DIC procedure if it is
|
|
-- not available.
|
|
|
|
if No (Proc_Id) then
|
|
Build_DIC_Procedure_Declaration (Work_Typ);
|
|
Proc_Id := DIC_Procedure (Work_Typ);
|
|
end if;
|
|
end if;
|
|
|
|
-- At this point there should be a DIC procedure declaration
|
|
|
|
pragma Assert (Present (Proc_Id));
|
|
Proc_Decl := Unit_Declaration_Node (Proc_Id);
|
|
|
|
-- Nothing to do if the DIC procedure already has a body
|
|
|
|
if Present (Corresponding_Body (Proc_Decl)) then
|
|
goto Leave;
|
|
end if;
|
|
|
|
-- Emulate the environment of the DIC procedure by installing its scope
|
|
-- and formal parameters.
|
|
|
|
Push_Scope (Proc_Id);
|
|
Install_Formals (Proc_Id);
|
|
|
|
Obj_Id := First_Formal (Proc_Id);
|
|
pragma Assert (Present (Obj_Id));
|
|
|
|
-- The "partial" DIC procedure verifies the DICs of the partial view
|
|
-- only.
|
|
|
|
if Partial_DIC then
|
|
pragma Assert (Present (Priv_Typ));
|
|
|
|
if Has_Own_DIC (Work_Typ) then -- If we're testing this then maybe
|
|
Add_Own_DIC -- we shouldn't be calling Find_DIC_Typ above???
|
|
(DIC_Prag => DIC_Prag,
|
|
DIC_Typ => DIC_Typ, -- Should this just be Work_Typ???
|
|
Obj_Id => Obj_Id,
|
|
Stmts => Stmts);
|
|
end if;
|
|
|
|
-- Otherwise, the "full" DIC procedure verifies the DICs inherited from
|
|
-- parent types, as well as indirectly verifying the DICs of the partial
|
|
-- view by calling the "partial" DIC procedure.
|
|
|
|
else
|
|
-- Check the DIC of the partial view by calling the "partial" DIC
|
|
-- procedure, unless the partial DIC body is empty. Generate:
|
|
|
|
-- <Work_Typ>Partial_DIC (_object);
|
|
|
|
if Present (Part_Proc) and then not Has_Null_Body (Part_Proc) then
|
|
Append_New_To (Stmts,
|
|
Make_Procedure_Call_Statement (Loc,
|
|
Name => New_Occurrence_Of (Part_Proc, Loc),
|
|
Parameter_Associations => New_List (
|
|
New_Occurrence_Of (Obj_Id, Loc))));
|
|
end if;
|
|
|
|
-- Process inherited Default_Initial_Conditions for all parent types
|
|
|
|
Add_Parent_DICs (Work_Typ, Obj_Id, Stmts);
|
|
end if;
|
|
|
|
End_Scope;
|
|
|
|
-- Produce an empty completing body in the following cases:
|
|
-- * Assertions are disabled
|
|
-- * The DIC Assertion_Policy is Ignore
|
|
|
|
if No (Stmts) then
|
|
Stmts := New_List (Make_Null_Statement (Loc));
|
|
end if;
|
|
|
|
-- Generate:
|
|
-- procedure <Work_Typ>DIC (_object : <Work_Typ>) is
|
|
-- begin
|
|
-- <Stmts>
|
|
-- end <Work_Typ>DIC;
|
|
|
|
Proc_Body :=
|
|
Make_Subprogram_Body (Loc,
|
|
Specification =>
|
|
Copy_Subprogram_Spec (Parent (Proc_Id)),
|
|
Declarations => Empty_List,
|
|
Handled_Statement_Sequence =>
|
|
Make_Handled_Sequence_Of_Statements (Loc,
|
|
Statements => Stmts));
|
|
Proc_Body_Id := Defining_Entity (Proc_Body);
|
|
|
|
-- Perform minor decoration in case the body is not analyzed
|
|
|
|
Mutate_Ekind (Proc_Body_Id, E_Subprogram_Body);
|
|
Set_Etype (Proc_Body_Id, Standard_Void_Type);
|
|
Set_Scope (Proc_Body_Id, Current_Scope);
|
|
Set_SPARK_Pragma (Proc_Body_Id, SPARK_Pragma (Proc_Id));
|
|
Set_SPARK_Pragma_Inherited
|
|
(Proc_Body_Id, SPARK_Pragma_Inherited (Proc_Id));
|
|
|
|
-- Link both spec and body to avoid generating duplicates
|
|
|
|
Set_Corresponding_Body (Proc_Decl, Proc_Body_Id);
|
|
Set_Corresponding_Spec (Proc_Body, Proc_Id);
|
|
|
|
-- The body should not be inserted into the tree when the context
|
|
-- is a generic unit because it is not part of the template.
|
|
-- Note that the body must still be generated in order to resolve the
|
|
-- DIC assertion expression.
|
|
|
|
if Inside_A_Generic then
|
|
null;
|
|
|
|
-- Semi-insert the body into the tree for GNATprove by setting its
|
|
-- Parent field. This allows for proper upstream tree traversals.
|
|
|
|
elsif GNATprove_Mode then
|
|
Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ)));
|
|
|
|
-- Otherwise the body is part of the freezing actions of the working
|
|
-- type.
|
|
|
|
else
|
|
Append_Freeze_Action (Work_Typ, Proc_Body);
|
|
end if;
|
|
|
|
<<Leave>>
|
|
Restore_Ghost_Region (Saved_GM, Saved_IGR);
|
|
end Build_DIC_Procedure_Body;
|
|
|
|
-------------------------------------
|
|
-- Build_DIC_Procedure_Declaration --
|
|
-------------------------------------
|
|
|
|
-- WARNING: This routine manages Ghost regions. Return statements must be
|
|
-- replaced by gotos which jump to the end of the routine and restore the
|
|
-- Ghost mode.
|
|
|
|
procedure Build_DIC_Procedure_Declaration
|
|
(Typ : Entity_Id;
|
|
Partial_DIC : Boolean := False)
|
|
is
|
|
Loc : constant Source_Ptr := Sloc (Typ);
|
|
|
|
Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
|
|
Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
|
|
-- Save the Ghost-related attributes to restore on exit
|
|
|
|
DIC_Prag : Node_Id;
|
|
DIC_Typ : Entity_Id;
|
|
Proc_Decl : Node_Id;
|
|
Proc_Id : Entity_Id;
|
|
Proc_Nam : Name_Id;
|
|
Typ_Decl : Node_Id;
|
|
|
|
CRec_Typ : Entity_Id;
|
|
-- The corresponding record type of Full_Typ
|
|
|
|
Full_Typ : Entity_Id;
|
|
-- The full view of working type
|
|
|
|
Obj_Id : Entity_Id;
|
|
-- The _object formal parameter of the DIC procedure
|
|
|
|
Priv_Typ : Entity_Id;
|
|
-- The partial view of working type
|
|
|
|
UFull_Typ : Entity_Id;
|
|
-- The underlying full view of Full_Typ
|
|
|
|
Work_Typ : Entity_Id;
|
|
-- The working type
|
|
|
|
begin
|
|
Work_Typ := Base_Type (Typ);
|
|
|
|
-- Do not process class-wide types as these are Itypes, but lack a first
|
|
-- subtype (see below).
|
|
|
|
if Is_Class_Wide_Type (Work_Typ) then
|
|
return;
|
|
|
|
-- Do not process the underlying full view of a private type. There is
|
|
-- no way to get back to the partial view, plus the body will be built
|
|
-- by the full view or the base type.
|
|
|
|
elsif Is_Underlying_Full_View (Work_Typ) then
|
|
return;
|
|
|
|
-- Use the first subtype when dealing with various base types
|
|
|
|
elsif Is_Itype (Work_Typ) then
|
|
Work_Typ := First_Subtype (Work_Typ);
|
|
|
|
-- The input denotes the corresponding record type of a protected or a
|
|
-- task type. Work with the concurrent type because the corresponding
|
|
-- record type may not be visible to clients of the type.
|
|
|
|
elsif Ekind (Work_Typ) = E_Record_Type
|
|
and then Is_Concurrent_Record_Type (Work_Typ)
|
|
then
|
|
Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
|
|
end if;
|
|
|
|
-- The working type may be subject to pragma Ghost. Set the mode now to
|
|
-- ensure that the DIC procedure is properly marked as Ghost.
|
|
|
|
Set_Ghost_Mode (Work_Typ);
|
|
|
|
-- The type must be either subject to a DIC pragma or inherit one from a
|
|
-- parent type.
|
|
|
|
pragma Assert (Has_DIC (Work_Typ));
|
|
|
|
-- Recover the type which defines the DIC pragma. This is either the
|
|
-- working type itself or a parent type when the pragma is inherited.
|
|
|
|
DIC_Typ := Find_DIC_Type (Work_Typ);
|
|
pragma Assert (Present (DIC_Typ));
|
|
|
|
DIC_Prag := Get_Pragma (DIC_Typ, Pragma_Default_Initial_Condition);
|
|
pragma Assert (Present (DIC_Prag));
|
|
|
|
-- Nothing to do if pragma DIC appears without an argument or its sole
|
|
-- argument is "null".
|
|
|
|
if not Is_Verifiable_DIC_Pragma (DIC_Prag) then
|
|
goto Leave;
|
|
end if;
|
|
|
|
-- Nothing to do if the type already has a "partial" DIC procedure
|
|
|
|
if Partial_DIC then
|
|
if Present (Partial_DIC_Procedure (Work_Typ)) then
|
|
goto Leave;
|
|
end if;
|
|
|
|
-- Nothing to do if the type already has a "full" DIC procedure
|
|
|
|
elsif Present (DIC_Procedure (Work_Typ)) then
|
|
goto Leave;
|
|
end if;
|
|
|
|
-- The caller requests the declaration of the "partial" DIC procedure
|
|
|
|
if Partial_DIC then
|
|
Proc_Nam := New_External_Name (Chars (Work_Typ), "Partial_DIC");
|
|
|
|
-- Otherwise the caller requests the declaration of the "full" DIC
|
|
-- procedure.
|
|
|
|
else
|
|
Proc_Nam := New_External_Name (Chars (Work_Typ), "DIC");
|
|
end if;
|
|
|
|
Proc_Id :=
|
|
Make_Defining_Identifier (Loc, Chars => Proc_Nam);
|
|
|
|
-- Perform minor decoration in case the declaration is not analyzed
|
|
|
|
Mutate_Ekind (Proc_Id, E_Procedure);
|
|
Set_Etype (Proc_Id, Standard_Void_Type);
|
|
Set_Is_DIC_Procedure (Proc_Id);
|
|
Set_Scope (Proc_Id, Current_Scope);
|
|
Set_SPARK_Pragma (Proc_Id, SPARK_Mode_Pragma);
|
|
Set_SPARK_Pragma_Inherited (Proc_Id);
|
|
|
|
Set_DIC_Procedure (Work_Typ, Proc_Id);
|
|
|
|
-- The DIC procedure requires debug info when the assertion expression
|
|
-- is subject to Source Coverage Obligations.
|
|
|
|
if Generate_SCO then
|
|
Set_Debug_Info_Needed (Proc_Id);
|
|
end if;
|
|
|
|
-- Obtain all views of the input type
|
|
|
|
Get_Views (Work_Typ, Priv_Typ, Full_Typ, UFull_Typ, CRec_Typ);
|
|
|
|
-- Associate the DIC procedure and various flags with all views
|
|
|
|
Propagate_DIC_Attributes (Priv_Typ, From_Typ => Work_Typ);
|
|
Propagate_DIC_Attributes (Full_Typ, From_Typ => Work_Typ);
|
|
Propagate_DIC_Attributes (UFull_Typ, From_Typ => Work_Typ);
|
|
Propagate_DIC_Attributes (CRec_Typ, From_Typ => Work_Typ);
|
|
|
|
-- The declaration of the DIC procedure must be inserted after the
|
|
-- declaration of the partial view as this allows for proper external
|
|
-- visibility.
|
|
|
|
if Present (Priv_Typ) then
|
|
Typ_Decl := Declaration_Node (Priv_Typ);
|
|
|
|
-- Derived types with the full view as parent do not have a partial
|
|
-- view. Insert the DIC procedure after the derived type.
|
|
|
|
else
|
|
Typ_Decl := Declaration_Node (Full_Typ);
|
|
end if;
|
|
|
|
-- The type should have a declarative node
|
|
|
|
pragma Assert (Present (Typ_Decl));
|
|
|
|
-- Create the formal parameter which emulates the variable-like behavior
|
|
-- of the type's current instance.
|
|
|
|
Obj_Id := Make_Defining_Identifier (Loc, Chars => Name_uObject);
|
|
|
|
-- Perform minor decoration in case the declaration is not analyzed
|
|
|
|
Mutate_Ekind (Obj_Id, E_In_Parameter);
|
|
Set_Etype (Obj_Id, Work_Typ);
|
|
Set_Scope (Obj_Id, Proc_Id);
|
|
|
|
Set_First_Entity (Proc_Id, Obj_Id);
|
|
Set_Last_Entity (Proc_Id, Obj_Id);
|
|
|
|
-- Generate:
|
|
-- procedure <Work_Typ>DIC (_object : <Work_Typ>);
|
|
|
|
Proc_Decl :=
|
|
Make_Subprogram_Declaration (Loc,
|
|
Specification =>
|
|
Make_Procedure_Specification (Loc,
|
|
Defining_Unit_Name => Proc_Id,
|
|
Parameter_Specifications => New_List (
|
|
Make_Parameter_Specification (Loc,
|
|
Defining_Identifier => Obj_Id,
|
|
Parameter_Type =>
|
|
New_Occurrence_Of (Work_Typ, Loc)))));
|
|
|
|
-- The declaration should not be inserted into the tree when the context
|
|
-- is a generic unit because it is not part of the template.
|
|
|
|
if Inside_A_Generic then
|
|
null;
|
|
|
|
-- Semi-insert the declaration into the tree for GNATprove by setting
|
|
-- its Parent field. This allows for proper upstream tree traversals.
|
|
|
|
elsif GNATprove_Mode then
|
|
Set_Parent (Proc_Decl, Parent (Typ_Decl));
|
|
|
|
-- Otherwise insert the declaration
|
|
|
|
else
|
|
Insert_After_And_Analyze (Typ_Decl, Proc_Decl);
|
|
end if;
|
|
|
|
<<Leave>>
|
|
Restore_Ghost_Region (Saved_GM, Saved_IGR);
|
|
end Build_DIC_Procedure_Declaration;
|
|
|
|
------------------------------------
|
|
-- Build_Invariant_Procedure_Body --
|
|
------------------------------------
|
|
|
|
-- WARNING: This routine manages Ghost regions. Return statements must be
|
|
-- replaced by gotos which jump to the end of the routine and restore the
|
|
-- Ghost mode.
|
|
|
|
procedure Build_Invariant_Procedure_Body
|
|
(Typ : Entity_Id;
|
|
Partial_Invariant : Boolean := False)
|
|
is
|
|
Loc : constant Source_Ptr := Sloc (Typ);
|
|
|
|
Pragmas_Seen : Elist_Id := No_Elist;
|
|
-- This list contains all invariant pragmas processed so far. The list
|
|
-- is used to avoid generating redundant invariant checks.
|
|
|
|
Produced_Check : Boolean := False;
|
|
-- This flag tracks whether the type has produced at least one invariant
|
|
-- check. The flag is used as a sanity check at the end of the routine.
|
|
|
|
-- NOTE: most of the routines in Build_Invariant_Procedure_Body are
|
|
-- intentionally unnested to avoid deep indentation of code.
|
|
|
|
-- NOTE: all Add_xxx_Invariants routines are reactive. In other words
|
|
-- they emit checks, loops (for arrays) and case statements (for record
|
|
-- variant parts) only when there are invariants to verify. This keeps
|
|
-- the body of the invariant procedure free of useless code.
|
|
|
|
procedure Add_Array_Component_Invariants
|
|
(T : Entity_Id;
|
|
Obj_Id : Entity_Id;
|
|
Checks : in out List_Id);
|
|
-- Generate an invariant check for each component of array type T.
|
|
-- Obj_Id denotes the entity of the _object formal parameter of the
|
|
-- invariant procedure. All created checks are added to list Checks.
|
|
|
|
procedure Add_Inherited_Invariants
|
|
(T : Entity_Id;
|
|
Priv_Typ : Entity_Id;
|
|
Full_Typ : Entity_Id;
|
|
Obj_Id : Entity_Id;
|
|
Checks : in out List_Id);
|
|
-- Generate an invariant check for each inherited class-wide invariant
|
|
-- coming from all parent types of type T. Priv_Typ and Full_Typ denote
|
|
-- the partial and full view of the parent type. Obj_Id denotes the
|
|
-- entity of the _object formal parameter of the invariant procedure.
|
|
-- All created checks are added to list Checks.
|
|
|
|
procedure Add_Interface_Invariants
|
|
(T : Entity_Id;
|
|
Obj_Id : Entity_Id;
|
|
Checks : in out List_Id);
|
|
-- Generate an invariant check for each inherited class-wide invariant
|
|
-- coming from all interfaces implemented by type T. Obj_Id denotes the
|
|
-- entity of the _object formal parameter of the invariant procedure.
|
|
-- All created checks are added to list Checks.
|
|
|
|
procedure Add_Invariant_Check
|
|
(Prag : Node_Id;
|
|
Expr : Node_Id;
|
|
Checks : in out List_Id;
|
|
Inherited : Boolean := False);
|
|
-- Subsidiary to all Add_xxx_Invariant routines. Add a runtime check to
|
|
-- verify assertion expression Expr of pragma Prag. All generated code
|
|
-- is added to list Checks. Flag Inherited should be set when the pragma
|
|
-- is inherited from a parent or interface type.
|
|
|
|
procedure Add_Own_Invariants
|
|
(T : Entity_Id;
|
|
Obj_Id : Entity_Id;
|
|
Checks : in out List_Id;
|
|
Priv_Item : Node_Id := Empty);
|
|
-- Generate an invariant check for each invariant found for type T.
|
|
-- Obj_Id denotes the entity of the _object formal parameter of the
|
|
-- invariant procedure. All created checks are added to list Checks.
|
|
-- Priv_Item denotes the first rep item of the private type.
|
|
|
|
procedure Add_Parent_Invariants
|
|
(T : Entity_Id;
|
|
Obj_Id : Entity_Id;
|
|
Checks : in out List_Id);
|
|
-- Generate an invariant check for each inherited class-wide invariant
|
|
-- coming from all parent types of type T. Obj_Id denotes the entity of
|
|
-- the _object formal parameter of the invariant procedure. All created
|
|
-- checks are added to list Checks.
|
|
|
|
procedure Add_Record_Component_Invariants
|
|
(T : Entity_Id;
|
|
Obj_Id : Entity_Id;
|
|
Checks : in out List_Id);
|
|
-- Generate an invariant check for each component of record type T.
|
|
-- Obj_Id denotes the entity of the _object formal parameter of the
|
|
-- invariant procedure. All created checks are added to list Checks.
|
|
|
|
------------------------------------
|
|
-- Add_Array_Component_Invariants --
|
|
------------------------------------
|
|
|
|
procedure Add_Array_Component_Invariants
|
|
(T : Entity_Id;
|
|
Obj_Id : Entity_Id;
|
|
Checks : in out List_Id)
|
|
is
|
|
Comp_Typ : constant Entity_Id := Component_Type (T);
|
|
Dims : constant Pos := Number_Dimensions (T);
|
|
|
|
procedure Process_Array_Component
|
|
(Indices : List_Id;
|
|
Comp_Checks : in out List_Id);
|
|
-- Generate an invariant check for an array component identified by
|
|
-- the indices in list Indices. All created checks are added to list
|
|
-- Comp_Checks.
|
|
|
|
procedure Process_One_Dimension
|
|
(Dim : Pos;
|
|
Indices : List_Id;
|
|
Dim_Checks : in out List_Id);
|
|
-- Generate a loop over the Nth dimension Dim of an array type. List
|
|
-- Indices contains all array indices for the dimension. All created
|
|
-- checks are added to list Dim_Checks.
|
|
|
|
-----------------------------
|
|
-- Process_Array_Component --
|
|
-----------------------------
|
|
|
|
procedure Process_Array_Component
|
|
(Indices : List_Id;
|
|
Comp_Checks : in out List_Id)
|
|
is
|
|
Proc_Id : Entity_Id;
|
|
|
|
begin
|
|
if Has_Invariants (Comp_Typ) then
|
|
|
|
-- In GNATprove mode, the component invariants are checked by
|
|
-- other means. They should not be added to the array type
|
|
-- invariant procedure, so that the procedure can be used to
|
|
-- check the array type invariants if any.
|
|
|
|
if GNATprove_Mode then
|
|
null;
|
|
|
|
else
|
|
Proc_Id := Invariant_Procedure (Base_Type (Comp_Typ));
|
|
|
|
-- The component type should have an invariant procedure
|
|
-- if it has invariants of its own or inherits class-wide
|
|
-- invariants from parent or interface types.
|
|
|
|
pragma Assert (Present (Proc_Id));
|
|
|
|
-- Generate:
|
|
-- <Comp_Typ>Invariant (_object (<Indices>));
|
|
|
|
-- The invariant procedure has a null body if assertions are
|
|
-- disabled or Assertion_Policy Ignore is in effect.
|
|
|
|
if not Has_Null_Body (Proc_Id) then
|
|
Append_New_To (Comp_Checks,
|
|
Make_Procedure_Call_Statement (Loc,
|
|
Name =>
|
|
New_Occurrence_Of (Proc_Id, Loc),
|
|
Parameter_Associations => New_List (
|
|
Make_Indexed_Component (Loc,
|
|
Prefix => New_Occurrence_Of (Obj_Id, Loc),
|
|
Expressions => New_Copy_List (Indices)))));
|
|
end if;
|
|
end if;
|
|
|
|
Produced_Check := True;
|
|
end if;
|
|
end Process_Array_Component;
|
|
|
|
---------------------------
|
|
-- Process_One_Dimension --
|
|
---------------------------
|
|
|
|
procedure Process_One_Dimension
|
|
(Dim : Pos;
|
|
Indices : List_Id;
|
|
Dim_Checks : in out List_Id)
|
|
is
|
|
Comp_Checks : List_Id := No_List;
|
|
Index : Entity_Id;
|
|
|
|
begin
|
|
-- Generate the invariant checks for the array component after all
|
|
-- dimensions have produced their respective loops.
|
|
|
|
if Dim > Dims then
|
|
Process_Array_Component
|
|
(Indices => Indices,
|
|
Comp_Checks => Dim_Checks);
|
|
|
|
-- Otherwise create a loop for the current dimension
|
|
|
|
else
|
|
-- Create a new loop variable for each dimension
|
|
|
|
Index :=
|
|
Make_Defining_Identifier (Loc,
|
|
Chars => New_External_Name ('I', Dim));
|
|
Append_To (Indices, New_Occurrence_Of (Index, Loc));
|
|
|
|
Process_One_Dimension
|
|
(Dim => Dim + 1,
|
|
Indices => Indices,
|
|
Dim_Checks => Comp_Checks);
|
|
|
|
-- Generate:
|
|
-- for I<Dim> in _object'Range (<Dim>) loop
|
|
-- <Comp_Checks>
|
|
-- end loop;
|
|
|
|
-- Note that the invariant procedure may have a null body if
|
|
-- assertions are disabled or Assertion_Policy Ignore is in
|
|
-- effect.
|
|
|
|
if Present (Comp_Checks) then
|
|
Append_New_To (Dim_Checks,
|
|
Make_Implicit_Loop_Statement (T,
|
|
Identifier => Empty,
|
|
Iteration_Scheme =>
|
|
Make_Iteration_Scheme (Loc,
|
|
Loop_Parameter_Specification =>
|
|
Make_Loop_Parameter_Specification (Loc,
|
|
Defining_Identifier => Index,
|
|
Discrete_Subtype_Definition =>
|
|
Make_Attribute_Reference (Loc,
|
|
Prefix =>
|
|
New_Occurrence_Of (Obj_Id, Loc),
|
|
Attribute_Name => Name_Range,
|
|
Expressions => New_List (
|
|
Make_Integer_Literal (Loc, Dim))))),
|
|
Statements => Comp_Checks));
|
|
end if;
|
|
end if;
|
|
end Process_One_Dimension;
|
|
|
|
-- Start of processing for Add_Array_Component_Invariants
|
|
|
|
begin
|
|
Process_One_Dimension
|
|
(Dim => 1,
|
|
Indices => New_List,
|
|
Dim_Checks => Checks);
|
|
end Add_Array_Component_Invariants;
|
|
|
|
------------------------------
|
|
-- Add_Inherited_Invariants --
|
|
------------------------------
|
|
|
|
procedure Add_Inherited_Invariants
|
|
(T : Entity_Id;
|
|
Priv_Typ : Entity_Id;
|
|
Full_Typ : Entity_Id;
|
|
Obj_Id : Entity_Id;
|
|
Checks : in out List_Id)
|
|
is
|
|
Deriv_Typ : Entity_Id;
|
|
Expr : Node_Id;
|
|
Prag : Node_Id;
|
|
Prag_Expr : Node_Id;
|
|
Prag_Expr_Arg : Node_Id;
|
|
Prag_Typ : Node_Id;
|
|
Prag_Typ_Arg : Node_Id;
|
|
|
|
Par_Proc : Entity_Id;
|
|
-- The "partial" invariant procedure of Par_Typ
|
|
|
|
Par_Typ : Entity_Id;
|
|
-- The suitable view of the parent type used in the substitution of
|
|
-- type attributes.
|
|
|
|
begin
|
|
if not Present (Priv_Typ) and then not Present (Full_Typ) then
|
|
return;
|
|
end if;
|
|
|
|
-- When the type inheriting the class-wide invariant is a concurrent
|
|
-- type, use the corresponding record type because it contains all
|
|
-- primitive operations of the concurrent type and allows for proper
|
|
-- substitution.
|
|
|
|
if Is_Concurrent_Type (T) then
|
|
Deriv_Typ := Corresponding_Record_Type (T);
|
|
else
|
|
Deriv_Typ := T;
|
|
end if;
|
|
|
|
pragma Assert (Present (Deriv_Typ));
|
|
|
|
-- Determine which rep item chain to use. Precedence is given to that
|
|
-- of the parent type's partial view since it usually carries all the
|
|
-- class-wide invariants.
|
|
|
|
if Present (Priv_Typ) then
|
|
Prag := First_Rep_Item (Priv_Typ);
|
|
else
|
|
Prag := First_Rep_Item (Full_Typ);
|
|
end if;
|
|
|
|
while Present (Prag) loop
|
|
if Nkind (Prag) = N_Pragma
|
|
and then Pragma_Name (Prag) = Name_Invariant
|
|
then
|
|
-- Nothing to do if the pragma was already processed
|
|
|
|
if Contains (Pragmas_Seen, Prag) then
|
|
return;
|
|
|
|
-- Nothing to do when the caller requests the processing of all
|
|
-- inherited class-wide invariants, but the pragma does not
|
|
-- fall in this category.
|
|
|
|
elsif not Class_Present (Prag) then
|
|
return;
|
|
end if;
|
|
|
|
-- Extract the arguments of the invariant pragma
|
|
|
|
Prag_Typ_Arg := First (Pragma_Argument_Associations (Prag));
|
|
Prag_Expr_Arg := Next (Prag_Typ_Arg);
|
|
Prag_Expr := Expression_Copy (Prag_Expr_Arg);
|
|
Prag_Typ := Get_Pragma_Arg (Prag_Typ_Arg);
|
|
|
|
-- The pragma applies to the partial view of the parent type
|
|
|
|
if Present (Priv_Typ)
|
|
and then Entity (Prag_Typ) = Priv_Typ
|
|
then
|
|
Par_Typ := Priv_Typ;
|
|
|
|
-- The pragma applies to the full view of the parent type
|
|
|
|
elsif Present (Full_Typ)
|
|
and then Entity (Prag_Typ) = Full_Typ
|
|
then
|
|
Par_Typ := Full_Typ;
|
|
|
|
-- Otherwise the pragma does not belong to the parent type and
|
|
-- should not be considered.
|
|
|
|
else
|
|
return;
|
|
end if;
|
|
|
|
-- Perform the following substitutions:
|
|
|
|
-- * Replace a reference to the _object parameter of the
|
|
-- parent type's partial invariant procedure with a
|
|
-- reference to the _object parameter of the derived
|
|
-- type's full invariant procedure.
|
|
|
|
-- * Replace a reference to a discriminant of the parent type
|
|
-- with a suitable value from the point of view of the
|
|
-- derived type.
|
|
|
|
-- * Replace a call to an overridden parent primitive with a
|
|
-- call to the overriding derived type primitive.
|
|
|
|
-- * Replace a call to an inherited parent primitive with a
|
|
-- call to the internally-generated inherited derived type
|
|
-- primitive.
|
|
|
|
Expr := New_Copy_Tree (Prag_Expr);
|
|
|
|
-- The parent type must have a "partial" invariant procedure
|
|
-- because class-wide invariants are captured exclusively by
|
|
-- it.
|
|
|
|
Par_Proc := Partial_Invariant_Procedure (Par_Typ);
|
|
pragma Assert (Present (Par_Proc));
|
|
|
|
Replace_References
|
|
(Expr => Expr,
|
|
Par_Typ => Par_Typ,
|
|
Deriv_Typ => Deriv_Typ,
|
|
Par_Obj => First_Formal (Par_Proc),
|
|
Deriv_Obj => Obj_Id);
|
|
|
|
Add_Invariant_Check (Prag, Expr, Checks, Inherited => True);
|
|
end if;
|
|
|
|
Next_Rep_Item (Prag);
|
|
end loop;
|
|
end Add_Inherited_Invariants;
|
|
|
|
------------------------------
|
|
-- Add_Interface_Invariants --
|
|
------------------------------
|
|
|
|
procedure Add_Interface_Invariants
|
|
(T : Entity_Id;
|
|
Obj_Id : Entity_Id;
|
|
Checks : in out List_Id)
|
|
is
|
|
Iface_Elmt : Elmt_Id;
|
|
Ifaces : Elist_Id;
|
|
|
|
begin
|
|
-- Generate an invariant check for each class-wide invariant coming
|
|
-- from all interfaces implemented by type T.
|
|
|
|
if Is_Tagged_Type (T) then
|
|
Collect_Interfaces (T, Ifaces);
|
|
|
|
-- Process the class-wide invariants of all implemented interfaces
|
|
|
|
Iface_Elmt := First_Elmt (Ifaces);
|
|
while Present (Iface_Elmt) loop
|
|
|
|
-- The Full_Typ parameter is intentionally left Empty because
|
|
-- interfaces are treated as the partial view of a private type
|
|
-- in order to achieve uniformity with the general case.
|
|
|
|
Add_Inherited_Invariants
|
|
(T => T,
|
|
Priv_Typ => Node (Iface_Elmt),
|
|
Full_Typ => Empty,
|
|
Obj_Id => Obj_Id,
|
|
Checks => Checks);
|
|
|
|
Next_Elmt (Iface_Elmt);
|
|
end loop;
|
|
end if;
|
|
end Add_Interface_Invariants;
|
|
|
|
-------------------------
|
|
-- Add_Invariant_Check --
|
|
-------------------------
|
|
|
|
procedure Add_Invariant_Check
|
|
(Prag : Node_Id;
|
|
Expr : Node_Id;
|
|
Checks : in out List_Id;
|
|
Inherited : Boolean := False)
|
|
is
|
|
Args : constant List_Id := Pragma_Argument_Associations (Prag);
|
|
Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
|
|
Ploc : constant Source_Ptr := Sloc (Prag);
|
|
Str_Arg : constant Node_Id := Next (Next (First (Args)));
|
|
|
|
Assoc : List_Id;
|
|
Str : String_Id;
|
|
|
|
begin
|
|
-- The invariant is ignored, nothing left to do
|
|
|
|
if Is_Ignored (Prag) then
|
|
null;
|
|
|
|
-- Otherwise the invariant is checked. Build a pragma Check to verify
|
|
-- the expression at run time.
|
|
|
|
else
|
|
Assoc := New_List (
|
|
Make_Pragma_Argument_Association (Ploc,
|
|
Expression => Make_Identifier (Ploc, Nam)),
|
|
Make_Pragma_Argument_Association (Ploc,
|
|
Expression => Expr));
|
|
|
|
-- Handle the String argument (if any)
|
|
|
|
if Present (Str_Arg) then
|
|
Str := Strval (Get_Pragma_Arg (Str_Arg));
|
|
|
|
-- When inheriting an invariant, modify the message from
|
|
-- "failed invariant" to "failed inherited invariant".
|
|
|
|
if Inherited then
|
|
String_To_Name_Buffer (Str);
|
|
|
|
if Name_Buffer (1 .. 16) = "failed invariant" then
|
|
Insert_Str_In_Name_Buffer ("inherited ", 8);
|
|
Str := String_From_Name_Buffer;
|
|
end if;
|
|
end if;
|
|
|
|
Append_To (Assoc,
|
|
Make_Pragma_Argument_Association (Ploc,
|
|
Expression => Make_String_Literal (Ploc, Str)));
|
|
end if;
|
|
|
|
-- Generate:
|
|
-- pragma Check (<Nam>, <Expr>, <Str>);
|
|
|
|
Append_New_To (Checks,
|
|
Make_Pragma (Ploc,
|
|
Chars => Name_Check,
|
|
Pragma_Argument_Associations => Assoc));
|
|
end if;
|
|
|
|
-- Output an info message when inheriting an invariant and the
|
|
-- listing option is enabled.
|
|
|
|
if Inherited and Opt.List_Inherited_Aspects then
|
|
Error_Msg_Sloc := Sloc (Prag);
|
|
Error_Msg_N
|
|
("info: & inherits `Invariant''Class` aspect from #?.l?", Typ);
|
|
end if;
|
|
|
|
-- Add the pragma to the list of processed pragmas
|
|
|
|
Append_New_Elmt (Prag, Pragmas_Seen);
|
|
Produced_Check := True;
|
|
end Add_Invariant_Check;
|
|
|
|
---------------------------
|
|
-- Add_Parent_Invariants --
|
|
---------------------------
|
|
|
|
procedure Add_Parent_Invariants
|
|
(T : Entity_Id;
|
|
Obj_Id : Entity_Id;
|
|
Checks : in out List_Id)
|
|
is
|
|
Dummy_1 : Entity_Id;
|
|
Dummy_2 : Entity_Id;
|
|
|
|
Curr_Typ : Entity_Id;
|
|
-- The entity of the current type being examined
|
|
|
|
Full_Typ : Entity_Id;
|
|
-- The full view of Par_Typ
|
|
|
|
Par_Typ : Entity_Id;
|
|
-- The entity of the parent type
|
|
|
|
Priv_Typ : Entity_Id;
|
|
-- The partial view of Par_Typ
|
|
|
|
begin
|
|
-- Do not process array types because they cannot have true parent
|
|
-- types. This also prevents the generation of a duplicate invariant
|
|
-- check when the input type is an array base type because its Etype
|
|
-- denotes the first subtype, both of which share the same component
|
|
-- type.
|
|
|
|
if Is_Array_Type (T) then
|
|
return;
|
|
end if;
|
|
|
|
-- Climb the parent type chain
|
|
|
|
Curr_Typ := T;
|
|
loop
|
|
-- Do not consider subtypes as they inherit the invariants
|
|
-- from their base types.
|
|
|
|
Par_Typ := Base_Type (Etype (Curr_Typ));
|
|
|
|
-- Stop the climb once the root of the parent chain is
|
|
-- reached.
|
|
|
|
exit when Curr_Typ = Par_Typ;
|
|
|
|
-- Process the class-wide invariants of the parent type
|
|
|
|
Get_Views (Par_Typ, Priv_Typ, Full_Typ, Dummy_1, Dummy_2);
|
|
|
|
-- Process the elements of an array type
|
|
|
|
if Is_Array_Type (Full_Typ) then
|
|
Add_Array_Component_Invariants (Full_Typ, Obj_Id, Checks);
|
|
|
|
-- Process the components of a record type
|
|
|
|
elsif Ekind (Full_Typ) = E_Record_Type then
|
|
Add_Record_Component_Invariants (Full_Typ, Obj_Id, Checks);
|
|
end if;
|
|
|
|
Add_Inherited_Invariants
|
|
(T => T,
|
|
Priv_Typ => Priv_Typ,
|
|
Full_Typ => Full_Typ,
|
|
Obj_Id => Obj_Id,
|
|
Checks => Checks);
|
|
|
|
Curr_Typ := Par_Typ;
|
|
end loop;
|
|
end Add_Parent_Invariants;
|
|
|
|
------------------------
|
|
-- Add_Own_Invariants --
|
|
------------------------
|
|
|
|
procedure Add_Own_Invariants
|
|
(T : Entity_Id;
|
|
Obj_Id : Entity_Id;
|
|
Checks : in out List_Id;
|
|
Priv_Item : Node_Id := Empty)
|
|
is
|
|
Expr : Node_Id;
|
|
Prag : Node_Id;
|
|
Prag_Asp : Node_Id;
|
|
Prag_Expr : Node_Id;
|
|
Prag_Expr_Arg : Node_Id;
|
|
Prag_Typ : Node_Id;
|
|
Prag_Typ_Arg : Node_Id;
|
|
|
|
begin
|
|
if not Present (T) then
|
|
return;
|
|
end if;
|
|
|
|
Prag := First_Rep_Item (T);
|
|
while Present (Prag) loop
|
|
if Nkind (Prag) = N_Pragma
|
|
and then Pragma_Name (Prag) = Name_Invariant
|
|
then
|
|
-- Stop the traversal of the rep item chain once a specific
|
|
-- item is encountered.
|
|
|
|
if Present (Priv_Item) and then Prag = Priv_Item then
|
|
exit;
|
|
end if;
|
|
|
|
-- Nothing to do if the pragma was already processed
|
|
|
|
if Contains (Pragmas_Seen, Prag) then
|
|
return;
|
|
end if;
|
|
|
|
-- Extract the arguments of the invariant pragma
|
|
|
|
Prag_Typ_Arg := First (Pragma_Argument_Associations (Prag));
|
|
Prag_Expr_Arg := Next (Prag_Typ_Arg);
|
|
Prag_Expr := Get_Pragma_Arg (Prag_Expr_Arg);
|
|
Prag_Typ := Get_Pragma_Arg (Prag_Typ_Arg);
|
|
Prag_Asp := Corresponding_Aspect (Prag);
|
|
|
|
-- Verify the pragma belongs to T, otherwise the pragma applies
|
|
-- to a parent type in which case it will be processed later by
|
|
-- Add_Parent_Invariants or Add_Interface_Invariants.
|
|
|
|
if Entity (Prag_Typ) /= T then
|
|
return;
|
|
end if;
|
|
|
|
Expr := New_Copy_Tree (Prag_Expr);
|
|
|
|
-- Substitute all references to type T with references to the
|
|
-- _object formal parameter.
|
|
|
|
Replace_Type_References (Expr, T, Obj_Id);
|
|
|
|
-- Preanalyze the invariant expression to detect errors and at
|
|
-- the same time capture the visibility of the proper package
|
|
-- part.
|
|
|
|
Set_Parent (Expr, Parent (Prag_Expr));
|
|
Preanalyze_Assert_Expression (Expr, Any_Boolean);
|
|
|
|
-- Save a copy of the expression when T is tagged to detect
|
|
-- errors and capture the visibility of the proper package part
|
|
-- for the generation of inherited type invariants.
|
|
|
|
if Is_Tagged_Type (T) then
|
|
Set_Expression_Copy (Prag_Expr_Arg, New_Copy_Tree (Expr));
|
|
end if;
|
|
|
|
-- If the pragma comes from an aspect specification, replace
|
|
-- the saved expression because all type references must be
|
|
-- substituted for the call to Preanalyze_Spec_Expression in
|
|
-- Check_Aspect_At_xxx routines.
|
|
|
|
if Present (Prag_Asp) then
|
|
Set_Entity (Identifier (Prag_Asp), New_Copy_Tree (Expr));
|
|
end if;
|
|
|
|
Add_Invariant_Check (Prag, Expr, Checks);
|
|
end if;
|
|
|
|
Next_Rep_Item (Prag);
|
|
end loop;
|
|
end Add_Own_Invariants;
|
|
|
|
-------------------------------------
|
|
-- Add_Record_Component_Invariants --
|
|
-------------------------------------
|
|
|
|
procedure Add_Record_Component_Invariants
|
|
(T : Entity_Id;
|
|
Obj_Id : Entity_Id;
|
|
Checks : in out List_Id)
|
|
is
|
|
procedure Process_Component_List
|
|
(Comp_List : Node_Id;
|
|
CL_Checks : in out List_Id);
|
|
-- Generate invariant checks for all record components found in
|
|
-- component list Comp_List, including variant parts. All created
|
|
-- checks are added to list CL_Checks.
|
|
|
|
procedure Process_Record_Component
|
|
(Comp_Id : Entity_Id;
|
|
Comp_Checks : in out List_Id);
|
|
-- Generate an invariant check for a record component identified by
|
|
-- Comp_Id. All created checks are added to list Comp_Checks.
|
|
|
|
----------------------------
|
|
-- Process_Component_List --
|
|
----------------------------
|
|
|
|
procedure Process_Component_List
|
|
(Comp_List : Node_Id;
|
|
CL_Checks : in out List_Id)
|
|
is
|
|
Comp : Node_Id;
|
|
Var : Node_Id;
|
|
Var_Alts : List_Id := No_List;
|
|
Var_Checks : List_Id := No_List;
|
|
Var_Stmts : List_Id;
|
|
|
|
Produced_Variant_Check : Boolean := False;
|
|
-- This flag tracks whether the component has produced at least
|
|
-- one invariant check.
|
|
|
|
begin
|
|
-- Traverse the component items
|
|
|
|
Comp := First (Component_Items (Comp_List));
|
|
while Present (Comp) loop
|
|
if Nkind (Comp) = N_Component_Declaration then
|
|
|
|
-- Generate the component invariant check
|
|
|
|
Process_Record_Component
|
|
(Comp_Id => Defining_Entity (Comp),
|
|
Comp_Checks => CL_Checks);
|
|
end if;
|
|
|
|
Next (Comp);
|
|
end loop;
|
|
|
|
-- Traverse the variant part
|
|
|
|
if Present (Variant_Part (Comp_List)) then
|
|
Var := First (Variants (Variant_Part (Comp_List)));
|
|
while Present (Var) loop
|
|
Var_Checks := No_List;
|
|
|
|
-- Generate invariant checks for all components and variant
|
|
-- parts that qualify.
|
|
|
|
Process_Component_List
|
|
(Comp_List => Component_List (Var),
|
|
CL_Checks => Var_Checks);
|
|
|
|
-- The components of the current variant produced at least
|
|
-- one invariant check.
|
|
|
|
if Present (Var_Checks) then
|
|
Var_Stmts := Var_Checks;
|
|
Produced_Variant_Check := True;
|
|
|
|
-- Otherwise there are either no components with invariants,
|
|
-- assertions are disabled, or Assertion_Policy Ignore is in
|
|
-- effect.
|
|
|
|
else
|
|
Var_Stmts := New_List (Make_Null_Statement (Loc));
|
|
end if;
|
|
|
|
Append_New_To (Var_Alts,
|
|
Make_Case_Statement_Alternative (Loc,
|
|
Discrete_Choices =>
|
|
New_Copy_List (Discrete_Choices (Var)),
|
|
Statements => Var_Stmts));
|
|
|
|
Next (Var);
|
|
end loop;
|
|
|
|
-- Create a case statement which verifies the invariant checks
|
|
-- of a particular component list depending on the discriminant
|
|
-- values only when there is at least one real invariant check.
|
|
|
|
if Produced_Variant_Check then
|
|
Append_New_To (CL_Checks,
|
|
Make_Case_Statement (Loc,
|
|
Expression =>
|
|
Make_Selected_Component (Loc,
|
|
Prefix => New_Occurrence_Of (Obj_Id, Loc),
|
|
Selector_Name =>
|
|
New_Occurrence_Of
|
|
(Entity (Name (Variant_Part (Comp_List))), Loc)),
|
|
Alternatives => Var_Alts));
|
|
end if;
|
|
end if;
|
|
end Process_Component_List;
|
|
|
|
------------------------------
|
|
-- Process_Record_Component --
|
|
------------------------------
|
|
|
|
procedure Process_Record_Component
|
|
(Comp_Id : Entity_Id;
|
|
Comp_Checks : in out List_Id)
|
|
is
|
|
Comp_Typ : constant Entity_Id := Etype (Comp_Id);
|
|
Proc_Id : Entity_Id;
|
|
|
|
Produced_Component_Check : Boolean := False;
|
|
-- This flag tracks whether the component has produced at least
|
|
-- one invariant check.
|
|
|
|
begin
|
|
-- Nothing to do for internal component _parent. Note that it is
|
|
-- not desirable to check whether the component comes from source
|
|
-- because protected type components are relocated to an internal
|
|
-- corresponding record, but still need processing.
|
|
|
|
if Chars (Comp_Id) = Name_uParent then
|
|
return;
|
|
end if;
|
|
|
|
-- Verify the invariant of the component. Note that an access
|
|
-- type may have an invariant when it acts as the full view of a
|
|
-- private type and the invariant appears on the partial view. In
|
|
-- this case verify the access value itself.
|
|
|
|
if Has_Invariants (Comp_Typ) then
|
|
|
|
-- In GNATprove mode, the component invariants are checked by
|
|
-- other means. They should not be added to the record type
|
|
-- invariant procedure, so that the procedure can be used to
|
|
-- check the record type invariants if any.
|
|
|
|
if GNATprove_Mode then
|
|
null;
|
|
|
|
else
|
|
Proc_Id := Invariant_Procedure (Base_Type (Comp_Typ));
|
|
|
|
-- The component type should have an invariant procedure
|
|
-- if it has invariants of its own or inherits class-wide
|
|
-- invariants from parent or interface types.
|
|
|
|
pragma Assert (Present (Proc_Id));
|
|
|
|
-- Generate:
|
|
-- <Comp_Typ>Invariant (T (_object).<Comp_Id>);
|
|
|
|
-- Note that the invariant procedure may have a null body if
|
|
-- assertions are disabled or Assertion_Policy Ignore is in
|
|
-- effect.
|
|
|
|
if not Has_Null_Body (Proc_Id) then
|
|
Append_New_To (Comp_Checks,
|
|
Make_Procedure_Call_Statement (Loc,
|
|
Name =>
|
|
New_Occurrence_Of (Proc_Id, Loc),
|
|
Parameter_Associations => New_List (
|
|
Make_Selected_Component (Loc,
|
|
Prefix =>
|
|
Unchecked_Convert_To
|
|
(T, New_Occurrence_Of (Obj_Id, Loc)),
|
|
Selector_Name =>
|
|
New_Occurrence_Of (Comp_Id, Loc)))));
|
|
end if;
|
|
end if;
|
|
|
|
Produced_Check := True;
|
|
Produced_Component_Check := True;
|
|
end if;
|
|
|
|
if Produced_Component_Check and then Has_Unchecked_Union (T) then
|
|
Error_Msg_NE
|
|
("invariants cannot be checked on components of "
|
|
& "unchecked_union type &??", Comp_Id, T);
|
|
end if;
|
|
end Process_Record_Component;
|
|
|
|
-- Local variables
|
|
|
|
Comps : Node_Id;
|
|
Def : Node_Id;
|
|
|
|
-- Start of processing for Add_Record_Component_Invariants
|
|
|
|
begin
|
|
-- An untagged derived type inherits the components of its parent
|
|
-- type. In order to avoid creating redundant invariant checks, do
|
|
-- not process the components now. Instead wait until the ultimate
|
|
-- parent of the untagged derivation chain is reached.
|
|
|
|
if not Is_Untagged_Derivation (T) then
|
|
Def := Type_Definition (Parent (T));
|
|
|
|
if Nkind (Def) = N_Derived_Type_Definition then
|
|
Def := Record_Extension_Part (Def);
|
|
end if;
|
|
|
|
pragma Assert (Nkind (Def) = N_Record_Definition);
|
|
Comps := Component_List (Def);
|
|
|
|
if Present (Comps) then
|
|
Process_Component_List
|
|
(Comp_List => Comps,
|
|
CL_Checks => Checks);
|
|
end if;
|
|
end if;
|
|
end Add_Record_Component_Invariants;
|
|
|
|
-- Local variables
|
|
|
|
Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
|
|
Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
|
|
-- Save the Ghost-related attributes to restore on exit
|
|
|
|
Dummy : Entity_Id;
|
|
Priv_Item : Node_Id;
|
|
Proc_Body : Node_Id;
|
|
Proc_Body_Id : Entity_Id;
|
|
Proc_Decl : Node_Id;
|
|
Proc_Id : Entity_Id;
|
|
Stmts : List_Id := No_List;
|
|
|
|
CRec_Typ : Entity_Id := Empty;
|
|
-- The corresponding record type of Full_Typ
|
|
|
|
Full_Proc : Entity_Id := Empty;
|
|
-- The entity of the "full" invariant procedure
|
|
|
|
Full_Typ : Entity_Id := Empty;
|
|
-- The full view of the working type
|
|
|
|
Obj_Id : Entity_Id := Empty;
|
|
-- The _object formal parameter of the invariant procedure
|
|
|
|
Part_Proc : Entity_Id := Empty;
|
|
-- The entity of the "partial" invariant procedure
|
|
|
|
Priv_Typ : Entity_Id := Empty;
|
|
-- The partial view of the working type
|
|
|
|
Work_Typ : Entity_Id := Empty;
|
|
-- The working type
|
|
|
|
-- Start of processing for Build_Invariant_Procedure_Body
|
|
|
|
begin
|
|
Work_Typ := Typ;
|
|
|
|
-- Do not process the underlying full view of a private type. There is
|
|
-- no way to get back to the partial view, plus the body will be built
|
|
-- by the full view or the base type.
|
|
|
|
if Is_Underlying_Full_View (Work_Typ) then
|
|
return;
|
|
|
|
-- The input type denotes the implementation base type of a constrained
|
|
-- array type. Work with the first subtype as all invariant pragmas are
|
|
-- on its rep item chain.
|
|
|
|
elsif Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then
|
|
Work_Typ := First_Subtype (Work_Typ);
|
|
|
|
-- The input type denotes the corresponding record type of a protected
|
|
-- or task type. Work with the concurrent type because the corresponding
|
|
-- record type may not be visible to clients of the type.
|
|
|
|
elsif Ekind (Work_Typ) = E_Record_Type
|
|
and then Is_Concurrent_Record_Type (Work_Typ)
|
|
then
|
|
Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
|
|
end if;
|
|
|
|
-- The working type may be subject to pragma Ghost. Set the mode now to
|
|
-- ensure that the invariant procedure is properly marked as Ghost.
|
|
|
|
Set_Ghost_Mode (Work_Typ);
|
|
|
|
-- The type must either have invariants of its own, inherit class-wide
|
|
-- invariants from parent types or interfaces, or be an array or record
|
|
-- type whose components have invariants.
|
|
|
|
pragma Assert (Has_Invariants (Work_Typ));
|
|
|
|
-- Interfaces are treated as the partial view of a private type in order
|
|
-- to achieve uniformity with the general case.
|
|
|
|
if Is_Interface (Work_Typ) then
|
|
Priv_Typ := Work_Typ;
|
|
|
|
-- Otherwise obtain both views of the type
|
|
|
|
else
|
|
Get_Views (Work_Typ, Priv_Typ, Full_Typ, Dummy, CRec_Typ);
|
|
end if;
|
|
|
|
-- The caller requests a body for the partial invariant procedure
|
|
|
|
if Partial_Invariant then
|
|
Full_Proc := Invariant_Procedure (Work_Typ);
|
|
Proc_Id := Partial_Invariant_Procedure (Work_Typ);
|
|
|
|
-- The "full" invariant procedure body was already created
|
|
|
|
if Present (Full_Proc)
|
|
and then Present
|
|
(Corresponding_Body (Unit_Declaration_Node (Full_Proc)))
|
|
then
|
|
-- This scenario happens only when the type is an untagged
|
|
-- derivation from a private parent and the underlying full
|
|
-- view was processed before the partial view.
|
|
|
|
pragma Assert
|
|
(Is_Untagged_Private_Derivation (Priv_Typ, Full_Typ));
|
|
|
|
-- Nothing to do because the processing of the underlying full
|
|
-- view already checked the invariants of the partial view.
|
|
|
|
goto Leave;
|
|
end if;
|
|
|
|
-- Create a declaration for the "partial" invariant procedure if it
|
|
-- is not available.
|
|
|
|
if No (Proc_Id) then
|
|
Build_Invariant_Procedure_Declaration
|
|
(Typ => Work_Typ,
|
|
Partial_Invariant => True);
|
|
|
|
Proc_Id := Partial_Invariant_Procedure (Work_Typ);
|
|
end if;
|
|
|
|
-- The caller requests a body for the "full" invariant procedure
|
|
|
|
else
|
|
Proc_Id := Invariant_Procedure (Work_Typ);
|
|
Part_Proc := Partial_Invariant_Procedure (Work_Typ);
|
|
|
|
-- Create a declaration for the "full" invariant procedure if it is
|
|
-- not available.
|
|
|
|
if No (Proc_Id) then
|
|
Build_Invariant_Procedure_Declaration (Work_Typ);
|
|
Proc_Id := Invariant_Procedure (Work_Typ);
|
|
end if;
|
|
end if;
|
|
|
|
-- At this point there should be an invariant procedure declaration
|
|
|
|
pragma Assert (Present (Proc_Id));
|
|
Proc_Decl := Unit_Declaration_Node (Proc_Id);
|
|
|
|
-- Nothing to do if the invariant procedure already has a body
|
|
|
|
if Present (Corresponding_Body (Proc_Decl)) then
|
|
goto Leave;
|
|
end if;
|
|
|
|
-- Emulate the environment of the invariant procedure by installing its
|
|
-- scope and formal parameters. Note that this is not needed, but having
|
|
-- the scope installed helps with the detection of invariant-related
|
|
-- errors.
|
|
|
|
Push_Scope (Proc_Id);
|
|
Install_Formals (Proc_Id);
|
|
|
|
Obj_Id := First_Formal (Proc_Id);
|
|
pragma Assert (Present (Obj_Id));
|
|
|
|
-- The "partial" invariant procedure verifies the invariants of the
|
|
-- partial view only.
|
|
|
|
if Partial_Invariant then
|
|
pragma Assert (Present (Priv_Typ));
|
|
|
|
Add_Own_Invariants
|
|
(T => Priv_Typ,
|
|
Obj_Id => Obj_Id,
|
|
Checks => Stmts);
|
|
|
|
-- Otherwise the "full" invariant procedure verifies the invariants of
|
|
-- the full view, all array or record components, as well as class-wide
|
|
-- invariants inherited from parent types or interfaces. In addition, it
|
|
-- indirectly verifies the invariants of the partial view by calling the
|
|
-- "partial" invariant procedure.
|
|
|
|
else
|
|
pragma Assert (Present (Full_Typ));
|
|
|
|
-- Check the invariants of the partial view by calling the "partial"
|
|
-- invariant procedure. Generate:
|
|
|
|
-- <Work_Typ>Partial_Invariant (_object);
|
|
|
|
if Present (Part_Proc) then
|
|
Append_New_To (Stmts,
|
|
Make_Procedure_Call_Statement (Loc,
|
|
Name => New_Occurrence_Of (Part_Proc, Loc),
|
|
Parameter_Associations => New_List (
|
|
New_Occurrence_Of (Obj_Id, Loc))));
|
|
|
|
Produced_Check := True;
|
|
end if;
|
|
|
|
Priv_Item := Empty;
|
|
|
|
-- Derived subtypes do not have a partial view
|
|
|
|
if Present (Priv_Typ) then
|
|
|
|
-- The processing of the "full" invariant procedure intentionally
|
|
-- skips the partial view because a) this may result in changes of
|
|
-- visibility and b) lead to duplicate checks. However, when the
|
|
-- full view is the underlying full view of an untagged derived
|
|
-- type whose parent type is private, partial invariants appear on
|
|
-- the rep item chain of the partial view only.
|
|
|
|
-- package Pack_1 is
|
|
-- type Root ... is private;
|
|
-- private
|
|
-- <full view of Root>
|
|
-- end Pack_1;
|
|
|
|
-- with Pack_1;
|
|
-- package Pack_2 is
|
|
-- type Child is new Pack_1.Root with Type_Invariant => ...;
|
|
-- <underlying full view of Child>
|
|
-- end Pack_2;
|
|
|
|
-- As a result, the processing of the full view must also consider
|
|
-- all invariants of the partial view.
|
|
|
|
if Is_Untagged_Private_Derivation (Priv_Typ, Full_Typ) then
|
|
null;
|
|
|
|
-- Otherwise the invariants of the partial view are ignored
|
|
|
|
else
|
|
-- Note that the rep item chain is shared between the partial
|
|
-- and full views of a type. To avoid processing the invariants
|
|
-- of the partial view, signal the logic to stop when the first
|
|
-- rep item of the partial view has been reached.
|
|
|
|
Priv_Item := First_Rep_Item (Priv_Typ);
|
|
|
|
-- Ignore the invariants of the partial view by eliminating the
|
|
-- view.
|
|
|
|
Priv_Typ := Empty;
|
|
end if;
|
|
end if;
|
|
|
|
-- Process the invariants of the full view and in certain cases those
|
|
-- of the partial view. This also handles any invariants on array or
|
|
-- record components.
|
|
|
|
Add_Own_Invariants
|
|
(T => Priv_Typ,
|
|
Obj_Id => Obj_Id,
|
|
Checks => Stmts,
|
|
Priv_Item => Priv_Item);
|
|
|
|
Add_Own_Invariants
|
|
(T => Full_Typ,
|
|
Obj_Id => Obj_Id,
|
|
Checks => Stmts,
|
|
Priv_Item => Priv_Item);
|
|
|
|
-- Process the elements of an array type
|
|
|
|
if Is_Array_Type (Full_Typ) then
|
|
Add_Array_Component_Invariants (Full_Typ, Obj_Id, Stmts);
|
|
|
|
-- Process the components of a record type
|
|
|
|
elsif Ekind (Full_Typ) = E_Record_Type then
|
|
Add_Record_Component_Invariants (Full_Typ, Obj_Id, Stmts);
|
|
|
|
-- Process the components of a corresponding record
|
|
|
|
elsif Present (CRec_Typ) then
|
|
Add_Record_Component_Invariants (CRec_Typ, Obj_Id, Stmts);
|
|
end if;
|
|
|
|
-- Process the inherited class-wide invariants of all parent types.
|
|
-- This also handles any invariants on record components.
|
|
|
|
Add_Parent_Invariants (Full_Typ, Obj_Id, Stmts);
|
|
|
|
-- Process the inherited class-wide invariants of all implemented
|
|
-- interface types.
|
|
|
|
Add_Interface_Invariants (Full_Typ, Obj_Id, Stmts);
|
|
end if;
|
|
|
|
End_Scope;
|
|
|
|
-- At this point there should be at least one invariant check. If this
|
|
-- is not the case, then the invariant-related flags were not properly
|
|
-- set, or there is a missing invariant procedure on one of the array
|
|
-- or record components.
|
|
|
|
pragma Assert (Produced_Check);
|
|
|
|
-- Account for the case where assertions are disabled or all invariant
|
|
-- checks are subject to Assertion_Policy Ignore. Produce a completing
|
|
-- empty body.
|
|
|
|
if No (Stmts) then
|
|
Stmts := New_List (Make_Null_Statement (Loc));
|
|
end if;
|
|
|
|
-- Generate:
|
|
-- procedure <Work_Typ>[Partial_]Invariant (_object : <Obj_Typ>) is
|
|
-- begin
|
|
-- <Stmts>
|
|
-- end <Work_Typ>[Partial_]Invariant;
|
|
|
|
Proc_Body :=
|
|
Make_Subprogram_Body (Loc,
|
|
Specification =>
|
|
Copy_Subprogram_Spec (Parent (Proc_Id)),
|
|
Declarations => Empty_List,
|
|
Handled_Statement_Sequence =>
|
|
Make_Handled_Sequence_Of_Statements (Loc,
|
|
Statements => Stmts));
|
|
Proc_Body_Id := Defining_Entity (Proc_Body);
|
|
|
|
-- Perform minor decoration in case the body is not analyzed
|
|
|
|
Mutate_Ekind (Proc_Body_Id, E_Subprogram_Body);
|
|
Set_Etype (Proc_Body_Id, Standard_Void_Type);
|
|
Set_Scope (Proc_Body_Id, Current_Scope);
|
|
|
|
-- Link both spec and body to avoid generating duplicates
|
|
|
|
Set_Corresponding_Body (Proc_Decl, Proc_Body_Id);
|
|
Set_Corresponding_Spec (Proc_Body, Proc_Id);
|
|
|
|
-- The body should not be inserted into the tree when the context is
|
|
-- a generic unit because it is not part of the template. Note
|
|
-- that the body must still be generated in order to resolve the
|
|
-- invariants.
|
|
|
|
if Inside_A_Generic then
|
|
null;
|
|
|
|
-- Semi-insert the body into the tree for GNATprove by setting its
|
|
-- Parent field. This allows for proper upstream tree traversals.
|
|
|
|
elsif GNATprove_Mode then
|
|
Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ)));
|
|
|
|
-- Otherwise the body is part of the freezing actions of the type
|
|
|
|
else
|
|
Append_Freeze_Action (Work_Typ, Proc_Body);
|
|
end if;
|
|
|
|
<<Leave>>
|
|
Restore_Ghost_Region (Saved_GM, Saved_IGR);
|
|
end Build_Invariant_Procedure_Body;
|
|
|
|
-------------------------------------------
|
|
-- Build_Invariant_Procedure_Declaration --
|
|
-------------------------------------------
|
|
|
|
-- WARNING: This routine manages Ghost regions. Return statements must be
|
|
-- replaced by gotos which jump to the end of the routine and restore the
|
|
-- Ghost mode.
|
|
|
|
procedure Build_Invariant_Procedure_Declaration
|
|
(Typ : Entity_Id;
|
|
Partial_Invariant : Boolean := False)
|
|
is
|
|
Loc : constant Source_Ptr := Sloc (Typ);
|
|
|
|
Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
|
|
Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
|
|
-- Save the Ghost-related attributes to restore on exit
|
|
|
|
Proc_Decl : Node_Id;
|
|
Proc_Id : Entity_Id;
|
|
Proc_Nam : Name_Id;
|
|
Typ_Decl : Node_Id;
|
|
|
|
CRec_Typ : Entity_Id;
|
|
-- The corresponding record type of Full_Typ
|
|
|
|
Full_Typ : Entity_Id;
|
|
-- The full view of working type
|
|
|
|
Obj_Id : Entity_Id;
|
|
-- The _object formal parameter of the invariant procedure
|
|
|
|
Obj_Typ : Entity_Id;
|
|
-- The type of the _object formal parameter
|
|
|
|
Priv_Typ : Entity_Id;
|
|
-- The partial view of working type
|
|
|
|
UFull_Typ : Entity_Id;
|
|
-- The underlying full view of Full_Typ
|
|
|
|
Work_Typ : Entity_Id;
|
|
-- The working type
|
|
|
|
begin
|
|
Work_Typ := Typ;
|
|
|
|
-- The input type denotes the implementation base type of a constrained
|
|
-- array type. Work with the first subtype as all invariant pragmas are
|
|
-- on its rep item chain.
|
|
|
|
if Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then
|
|
Work_Typ := First_Subtype (Work_Typ);
|
|
|
|
-- The input denotes the corresponding record type of a protected or a
|
|
-- task type. Work with the concurrent type because the corresponding
|
|
-- record type may not be visible to clients of the type.
|
|
|
|
elsif Ekind (Work_Typ) = E_Record_Type
|
|
and then Is_Concurrent_Record_Type (Work_Typ)
|
|
then
|
|
Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
|
|
end if;
|
|
|
|
-- The working type may be subject to pragma Ghost. Set the mode now to
|
|
-- ensure that the invariant procedure is properly marked as Ghost.
|
|
|
|
Set_Ghost_Mode (Work_Typ);
|
|
|
|
-- The type must either have invariants of its own, inherit class-wide
|
|
-- invariants from parent or interface types, or be an array or record
|
|
-- type whose components have invariants.
|
|
|
|
pragma Assert (Has_Invariants (Work_Typ));
|
|
|
|
-- Nothing to do if the type already has a "partial" invariant procedure
|
|
|
|
if Partial_Invariant then
|
|
if Present (Partial_Invariant_Procedure (Work_Typ)) then
|
|
goto Leave;
|
|
end if;
|
|
|
|
-- Nothing to do if the type already has a "full" invariant procedure
|
|
|
|
elsif Present (Invariant_Procedure (Work_Typ)) then
|
|
goto Leave;
|
|
end if;
|
|
|
|
-- The caller requests the declaration of the "partial" invariant
|
|
-- procedure.
|
|
|
|
if Partial_Invariant then
|
|
Proc_Nam := New_External_Name (Chars (Work_Typ), "Partial_Invariant");
|
|
|
|
-- Otherwise the caller requests the declaration of the "full" invariant
|
|
-- procedure.
|
|
|
|
else
|
|
Proc_Nam := New_External_Name (Chars (Work_Typ), "Invariant");
|
|
end if;
|
|
|
|
Proc_Id := Make_Defining_Identifier (Loc, Chars => Proc_Nam);
|
|
|
|
-- Perform minor decoration in case the declaration is not analyzed
|
|
|
|
Mutate_Ekind (Proc_Id, E_Procedure);
|
|
Set_Etype (Proc_Id, Standard_Void_Type);
|
|
Set_Scope (Proc_Id, Current_Scope);
|
|
|
|
if Partial_Invariant then
|
|
Set_Is_Partial_Invariant_Procedure (Proc_Id);
|
|
Set_Partial_Invariant_Procedure (Work_Typ, Proc_Id);
|
|
else
|
|
Set_Is_Invariant_Procedure (Proc_Id);
|
|
Set_Invariant_Procedure (Work_Typ, Proc_Id);
|
|
end if;
|
|
|
|
-- The invariant procedure requires debug info when the invariants are
|
|
-- subject to Source Coverage Obligations.
|
|
|
|
if Generate_SCO then
|
|
Set_Debug_Info_Needed (Proc_Id);
|
|
end if;
|
|
|
|
-- Obtain all views of the input type
|
|
|
|
Get_Views (Work_Typ, Priv_Typ, Full_Typ, UFull_Typ, CRec_Typ);
|
|
|
|
-- Associate the invariant procedure and various flags with all views
|
|
|
|
Propagate_Invariant_Attributes (Priv_Typ, From_Typ => Work_Typ);
|
|
Propagate_Invariant_Attributes (Full_Typ, From_Typ => Work_Typ);
|
|
Propagate_Invariant_Attributes (UFull_Typ, From_Typ => Work_Typ);
|
|
Propagate_Invariant_Attributes (CRec_Typ, From_Typ => Work_Typ);
|
|
|
|
-- The declaration of the invariant procedure is inserted after the
|
|
-- declaration of the partial view as this allows for proper external
|
|
-- visibility.
|
|
|
|
if Present (Priv_Typ) then
|
|
Typ_Decl := Declaration_Node (Priv_Typ);
|
|
|
|
-- Anonymous arrays in object declarations have no explicit declaration
|
|
-- so use the related object declaration as the insertion point.
|
|
|
|
elsif Is_Itype (Work_Typ) and then Is_Array_Type (Work_Typ) then
|
|
Typ_Decl := Associated_Node_For_Itype (Work_Typ);
|
|
|
|
-- Derived types with the full view as parent do not have a partial
|
|
-- view. Insert the invariant procedure after the derived type.
|
|
|
|
else
|
|
Typ_Decl := Declaration_Node (Full_Typ);
|
|
end if;
|
|
|
|
-- The type should have a declarative node
|
|
|
|
pragma Assert (Present (Typ_Decl));
|
|
|
|
-- Create the formal parameter which emulates the variable-like behavior
|
|
-- of the current type instance.
|
|
|
|
Obj_Id := Make_Defining_Identifier (Loc, Chars => Name_uObject);
|
|
|
|
-- When generating an invariant procedure declaration for an abstract
|
|
-- type (including interfaces), use the class-wide type as the _object
|
|
-- type. This has several desirable effects:
|
|
|
|
-- * The invariant procedure does not become a primitive of the type.
|
|
-- This eliminates the need to either special case the treatment of
|
|
-- invariant procedures, or to make it a predefined primitive and
|
|
-- force every derived type to potentially provide an empty body.
|
|
|
|
-- * The invariant procedure does not need to be declared as abstract.
|
|
-- This allows for a proper body, which in turn avoids redundant
|
|
-- processing of the same invariants for types with multiple views.
|
|
|
|
-- * The class-wide type allows for calls to abstract primitives
|
|
-- within a nonabstract subprogram. The calls are treated as
|
|
-- dispatching and require additional processing when they are
|
|
-- remapped to call primitives of derived types. See routine
|
|
-- Replace_References for details.
|
|
|
|
if Is_Abstract_Type (Work_Typ) then
|
|
Obj_Typ := Class_Wide_Type (Work_Typ);
|
|
else
|
|
Obj_Typ := Work_Typ;
|
|
end if;
|
|
|
|
-- Perform minor decoration in case the declaration is not analyzed
|
|
|
|
Mutate_Ekind (Obj_Id, E_In_Parameter);
|
|
Set_Etype (Obj_Id, Obj_Typ);
|
|
Set_Scope (Obj_Id, Proc_Id);
|
|
|
|
Set_First_Entity (Proc_Id, Obj_Id);
|
|
Set_Last_Entity (Proc_Id, Obj_Id);
|
|
|
|
-- Generate:
|
|
-- procedure <Work_Typ>[Partial_]Invariant (_object : <Obj_Typ>);
|
|
|
|
Proc_Decl :=
|
|
Make_Subprogram_Declaration (Loc,
|
|
Specification =>
|
|
Make_Procedure_Specification (Loc,
|
|
Defining_Unit_Name => Proc_Id,
|
|
Parameter_Specifications => New_List (
|
|
Make_Parameter_Specification (Loc,
|
|
Defining_Identifier => Obj_Id,
|
|
Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc)))));
|
|
|
|
-- The declaration should not be inserted into the tree when the context
|
|
-- is a generic unit because it is not part of the template.
|
|
|
|
if Inside_A_Generic then
|
|
null;
|
|
|
|
-- Semi-insert the declaration into the tree for GNATprove by setting
|
|
-- its Parent field. This allows for proper upstream tree traversals.
|
|
|
|
elsif GNATprove_Mode then
|
|
Set_Parent (Proc_Decl, Parent (Typ_Decl));
|
|
|
|
-- Otherwise insert the declaration
|
|
|
|
else
|
|
pragma Assert (Present (Typ_Decl));
|
|
Insert_After_And_Analyze (Typ_Decl, Proc_Decl);
|
|
end if;
|
|
|
|
<<Leave>>
|
|
Restore_Ghost_Region (Saved_GM, Saved_IGR);
|
|
end Build_Invariant_Procedure_Declaration;
|
|
|
|
--------------------------
|
|
-- Build_Procedure_Form --
|
|
--------------------------
|
|
|
|
procedure Build_Procedure_Form (N : Node_Id) is
|
|
Loc : constant Source_Ptr := Sloc (N);
|
|
Subp : constant Entity_Id := Defining_Entity (N);
|
|
|
|
Func_Formal : Entity_Id;
|
|
Proc_Formals : List_Id;
|
|
Proc_Decl : Node_Id;
|
|
|
|
begin
|
|
-- No action needed if this transformation was already done, or in case
|
|
-- of subprogram renaming declarations.
|
|
|
|
if Nkind (Specification (N)) = N_Procedure_Specification
|
|
or else Nkind (N) = N_Subprogram_Renaming_Declaration
|
|
then
|
|
return;
|
|
end if;
|
|
|
|
-- Ditto when dealing with an expression function, where both the
|
|
-- original expression and the generated declaration end up being
|
|
-- expanded here.
|
|
|
|
if Rewritten_For_C (Subp) then
|
|
return;
|
|
end if;
|
|
|
|
Proc_Formals := New_List;
|
|
|
|
-- Create a list of formal parameters with the same types as the
|
|
-- function.
|
|
|
|
Func_Formal := First_Formal (Subp);
|
|
while Present (Func_Formal) loop
|
|
Append_To (Proc_Formals,
|
|
Make_Parameter_Specification (Loc,
|
|
Defining_Identifier =>
|
|
Make_Defining_Identifier (Loc, Chars (Func_Formal)),
|
|
Parameter_Type =>
|
|
New_Occurrence_Of (Etype (Func_Formal), Loc)));
|
|
|
|
Next_Formal (Func_Formal);
|
|
end loop;
|
|
|
|
-- Add an extra out parameter to carry the function result
|
|
|
|
Append_To (Proc_Formals,
|
|
Make_Parameter_Specification (Loc,
|
|
Defining_Identifier =>
|
|
Make_Defining_Identifier (Loc, Name_UP_RESULT),
|
|
Out_Present => True,
|
|
Parameter_Type => New_Occurrence_Of (Etype (Subp), Loc)));
|
|
|
|
-- The new procedure declaration is inserted before the function
|
|
-- declaration. The processing in Build_Procedure_Body_Form relies on
|
|
-- this order. Note that we insert before because in the case of a
|
|
-- function body with no separate spec, we do not want to insert the
|
|
-- new spec after the body which will later get rewritten.
|
|
|
|
Proc_Decl :=
|
|
Make_Subprogram_Declaration (Loc,
|
|
Specification =>
|
|
Make_Procedure_Specification (Loc,
|
|
Defining_Unit_Name =>
|
|
Make_Defining_Identifier (Loc, Chars (Subp)),
|
|
Parameter_Specifications => Proc_Formals));
|
|
|
|
Insert_Before_And_Analyze (Unit_Declaration_Node (Subp), Proc_Decl);
|
|
|
|
-- Entity of procedure must remain invisible so that it does not
|
|
-- overload subsequent references to the original function.
|
|
|
|
Set_Is_Immediately_Visible (Defining_Entity (Proc_Decl), False);
|
|
|
|
-- Mark the function as having a procedure form and link the function
|
|
-- and its internally built procedure.
|
|
|
|
Set_Rewritten_For_C (Subp);
|
|
Set_Corresponding_Procedure (Subp, Defining_Entity (Proc_Decl));
|
|
Set_Corresponding_Function (Defining_Entity (Proc_Decl), Subp);
|
|
end Build_Procedure_Form;
|
|
|
|
------------------------
|
|
-- Build_Runtime_Call --
|
|
------------------------
|
|
|
|
function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id is
|
|
begin
|
|
-- If entity is not available, we can skip making the call (this avoids
|
|
-- junk duplicated error messages in a number of cases).
|
|
|
|
if not RTE_Available (RE) then
|
|
return Make_Null_Statement (Loc);
|
|
else
|
|
return
|
|
Make_Procedure_Call_Statement (Loc,
|
|
Name => New_Occurrence_Of (RTE (RE), Loc));
|
|
end if;
|
|
end Build_Runtime_Call;
|
|
|
|
------------------------
|
|
-- Build_SS_Mark_Call --
|
|
------------------------
|
|
|
|
function Build_SS_Mark_Call
|
|
(Loc : Source_Ptr;
|
|
Mark : Entity_Id) return Node_Id
|
|
is
|
|
begin
|
|
-- Generate:
|
|
-- Mark : constant Mark_Id := SS_Mark;
|
|
|
|
return
|
|
Make_Object_Declaration (Loc,
|
|
Defining_Identifier => Mark,
|
|
Constant_Present => True,
|
|
Object_Definition =>
|
|
New_Occurrence_Of (RTE (RE_Mark_Id), Loc),
|
|
Expression =>
|
|
Make_Function_Call (Loc,
|
|
Name => New_Occurrence_Of (RTE (RE_SS_Mark), Loc)));
|
|
end Build_SS_Mark_Call;
|
|
|
|
---------------------------
|
|
-- Build_SS_Release_Call --
|
|
---------------------------
|
|
|
|
function Build_SS_Release_Call
|
|
(Loc : Source_Ptr;
|
|
Mark : Entity_Id) return Node_Id
|
|
is
|
|
begin
|
|
-- Generate:
|
|
-- SS_Release (Mark);
|
|
|
|
return
|
|
Make_Procedure_Call_Statement (Loc,
|
|
Name =>
|
|
New_Occurrence_Of (RTE (RE_SS_Release), Loc),
|
|
Parameter_Associations => New_List (
|
|
New_Occurrence_Of (Mark, Loc)));
|
|
end Build_SS_Release_Call;
|
|
|
|
----------------------------
|
|
-- Build_Task_Array_Image --
|
|
----------------------------
|
|
|
|
-- This function generates the body for a function that constructs the
|
|
-- image string for a task that is an array component. The function is
|
|
-- local to the init proc for the array type, and is called for each one
|
|
-- of the components. The constructed image has the form of an indexed
|
|
-- component, whose prefix is the outer variable of the array type.
|
|
-- The n-dimensional array type has known indexes Index, Index2...
|
|
|
|
-- Id_Ref is an indexed component form created by the enclosing init proc.
|
|
-- Its successive indexes are Val1, Val2, ... which are the loop variables
|
|
-- in the loops that call the individual task init proc on each component.
|
|
|
|
-- The generated function has the following structure:
|
|
|
|
-- function F return String is
|
|
-- Pref : string renames Task_Name;
|
|
-- T1 : String := Index1'Image (Val1);
|
|
-- ...
|
|
-- Tn : String := indexn'image (Valn);
|
|
-- Len : Integer := T1'Length + ... + Tn'Length + n + 1;
|
|
-- -- Len includes commas and the end parentheses.
|
|
-- Res : String (1..Len);
|
|
-- Pos : Integer := Pref'Length;
|
|
--
|
|
-- begin
|
|
-- Res (1 .. Pos) := Pref;
|
|
-- Pos := Pos + 1;
|
|
-- Res (Pos) := '(';
|
|
-- Pos := Pos + 1;
|
|
-- Res (Pos .. Pos + T1'Length - 1) := T1;
|
|
-- Pos := Pos + T1'Length;
|
|
-- Res (Pos) := '.';
|
|
-- Pos := Pos + 1;
|
|
-- ...
|
|
-- Res (Pos .. Pos + Tn'Length - 1) := Tn;
|
|
-- Res (Len) := ')';
|
|
--
|
|
-- return Res;
|
|
-- end F;
|
|
--
|
|
-- Needless to say, multidimensional arrays of tasks are rare enough that
|
|
-- the bulkiness of this code is not really a concern.
|
|
|
|
function Build_Task_Array_Image
|
|
(Loc : Source_Ptr;
|
|
Id_Ref : Node_Id;
|
|
A_Type : Entity_Id;
|
|
Dyn : Boolean := False) return Node_Id
|
|
is
|
|
Dims : constant Nat := Number_Dimensions (A_Type);
|
|
-- Number of dimensions for array of tasks
|
|
|
|
Temps : array (1 .. Dims) of Entity_Id;
|
|
-- Array of temporaries to hold string for each index
|
|
|
|
Indx : Node_Id;
|
|
-- Index expression
|
|
|
|
Len : Entity_Id;
|
|
-- Total length of generated name
|
|
|
|
Pos : Entity_Id;
|
|
-- Running index for substring assignments
|
|
|
|
Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
|
|
-- Name of enclosing variable, prefix of resulting name
|
|
|
|
Res : Entity_Id;
|
|
-- String to hold result
|
|
|
|
Val : Node_Id;
|
|
-- Value of successive indexes
|
|
|
|
Sum : Node_Id;
|
|
-- Expression to compute total size of string
|
|
|
|
T : Entity_Id;
|
|
-- Entity for name at one index position
|
|
|
|
Decls : constant List_Id := New_List;
|
|
Stats : constant List_Id := New_List;
|
|
|
|
begin
|
|
-- For a dynamic task, the name comes from the target variable. For a
|
|
-- static one it is a formal of the enclosing init proc.
|
|
|
|
if Dyn then
|
|
Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
|
|
Append_To (Decls,
|
|
Make_Object_Declaration (Loc,
|
|
Defining_Identifier => Pref,
|
|
Object_Definition => New_Occurrence_Of (Standard_String, Loc),
|
|
Expression =>
|
|
Make_String_Literal (Loc,
|
|
Strval => String_From_Name_Buffer)));
|
|
|
|
else
|
|
Append_To (Decls,
|
|
Make_Object_Renaming_Declaration (Loc,
|
|
Defining_Identifier => Pref,
|
|
Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
|
|
Name => Make_Identifier (Loc, Name_uTask_Name)));
|
|
end if;
|
|
|
|
Indx := First_Index (A_Type);
|
|
Val := First (Expressions (Id_Ref));
|
|
|
|
for J in 1 .. Dims loop
|
|
T := Make_Temporary (Loc, 'T');
|
|
Temps (J) := T;
|
|
|
|
Append_To (Decls,
|
|
Make_Object_Declaration (Loc,
|
|
Defining_Identifier => T,
|
|
Object_Definition => New_Occurrence_Of (Standard_String, Loc),
|
|
Expression =>
|
|
Make_Attribute_Reference (Loc,
|
|
Attribute_Name => Name_Image,
|
|
Prefix => New_Occurrence_Of (Etype (Indx), Loc),
|
|
Expressions => New_List (New_Copy_Tree (Val)))));
|
|
|
|
Next_Index (Indx);
|
|
Next (Val);
|
|
end loop;
|
|
|
|
Sum := Make_Integer_Literal (Loc, Dims + 1);
|
|
|
|
Sum :=
|
|
Make_Op_Add (Loc,
|
|
Left_Opnd => Sum,
|
|
Right_Opnd =>
|
|
Make_Attribute_Reference (Loc,
|
|
Attribute_Name => Name_Length,
|
|
Prefix => New_Occurrence_Of (Pref, Loc),
|
|
Expressions => New_List (Make_Integer_Literal (Loc, 1))));
|
|
|
|
for J in 1 .. Dims loop
|
|
Sum :=
|
|
Make_Op_Add (Loc,
|
|
Left_Opnd => Sum,
|
|
Right_Opnd =>
|
|
Make_Attribute_Reference (Loc,
|
|
Attribute_Name => Name_Length,
|
|
Prefix =>
|
|
New_Occurrence_Of (Temps (J), Loc),
|
|
Expressions => New_List (Make_Integer_Literal (Loc, 1))));
|
|
end loop;
|
|
|
|
Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
|
|
|
|
Set_Character_Literal_Name (Char_Code (Character'Pos ('(')));
|
|
|
|
Append_To (Stats,
|
|
Make_Assignment_Statement (Loc,
|
|
Name =>
|
|
Make_Indexed_Component (Loc,
|
|
Prefix => New_Occurrence_Of (Res, Loc),
|
|
Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
|
|
Expression =>
|
|
Make_Character_Literal (Loc,
|
|
Chars => Name_Find,
|
|
Char_Literal_Value => UI_From_Int (Character'Pos ('(')))));
|
|
|
|
Append_To (Stats,
|
|
Make_Assignment_Statement (Loc,
|
|
Name => New_Occurrence_Of (Pos, Loc),
|
|
Expression =>
|
|
Make_Op_Add (Loc,
|
|
Left_Opnd => New_Occurrence_Of (Pos, Loc),
|
|
Right_Opnd => Make_Integer_Literal (Loc, 1))));
|
|
|
|
for J in 1 .. Dims loop
|
|
|
|
Append_To (Stats,
|
|
Make_Assignment_Statement (Loc,
|
|
Name =>
|
|
Make_Slice (Loc,
|
|
Prefix => New_Occurrence_Of (Res, Loc),
|
|
Discrete_Range =>
|
|
Make_Range (Loc,
|
|
Low_Bound => New_Occurrence_Of (Pos, Loc),
|
|
High_Bound =>
|
|
Make_Op_Subtract (Loc,
|
|
Left_Opnd =>
|
|
Make_Op_Add (Loc,
|
|
Left_Opnd => New_Occurrence_Of (Pos, Loc),
|
|
Right_Opnd =>
|
|
Make_Attribute_Reference (Loc,
|
|
Attribute_Name => Name_Length,
|
|
Prefix =>
|
|
New_Occurrence_Of (Temps (J), Loc),
|
|
Expressions =>
|
|
New_List (Make_Integer_Literal (Loc, 1)))),
|
|
Right_Opnd => Make_Integer_Literal (Loc, 1)))),
|
|
|
|
Expression => New_Occurrence_Of (Temps (J), Loc)));
|
|
|
|
if J < Dims then
|
|
Append_To (Stats,
|
|
Make_Assignment_Statement (Loc,
|
|
Name => New_Occurrence_Of (Pos, Loc),
|
|
Expression =>
|
|
Make_Op_Add (Loc,
|
|
Left_Opnd => New_Occurrence_Of (Pos, Loc),
|
|
Right_Opnd =>
|
|
Make_Attribute_Reference (Loc,
|
|
Attribute_Name => Name_Length,
|
|
Prefix => New_Occurrence_Of (Temps (J), Loc),
|
|
Expressions =>
|
|
New_List (Make_Integer_Literal (Loc, 1))))));
|
|
|
|
Set_Character_Literal_Name (Char_Code (Character'Pos (',')));
|
|
|
|
Append_To (Stats,
|
|
Make_Assignment_Statement (Loc,
|
|
Name => Make_Indexed_Component (Loc,
|
|
Prefix => New_Occurrence_Of (Res, Loc),
|
|
Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
|
|
Expression =>
|
|
Make_Character_Literal (Loc,
|
|
Chars => Name_Find,
|
|
Char_Literal_Value => UI_From_Int (Character'Pos (',')))));
|
|
|
|
Append_To (Stats,
|
|
Make_Assignment_Statement (Loc,
|
|
Name => New_Occurrence_Of (Pos, Loc),
|
|
Expression =>
|
|
Make_Op_Add (Loc,
|
|
Left_Opnd => New_Occurrence_Of (Pos, Loc),
|
|
Right_Opnd => Make_Integer_Literal (Loc, 1))));
|
|
end if;
|
|
end loop;
|
|
|
|
Set_Character_Literal_Name (Char_Code (Character'Pos (')')));
|
|
|
|
Append_To (Stats,
|
|
Make_Assignment_Statement (Loc,
|
|
Name =>
|
|
Make_Indexed_Component (Loc,
|
|
Prefix => New_Occurrence_Of (Res, Loc),
|
|
Expressions => New_List (New_Occurrence_Of (Len, Loc))),
|
|
Expression =>
|
|
Make_Character_Literal (Loc,
|
|
Chars => Name_Find,
|
|
Char_Literal_Value => UI_From_Int (Character'Pos (')')))));
|
|
return Build_Task_Image_Function (Loc, Decls, Stats, Res);
|
|
end Build_Task_Array_Image;
|
|
|
|
----------------------------
|
|
-- Build_Task_Image_Decls --
|
|
----------------------------
|
|
|
|
function Build_Task_Image_Decls
|
|
(Loc : Source_Ptr;
|
|
Id_Ref : Node_Id;
|
|
A_Type : Entity_Id;
|
|
In_Init_Proc : Boolean := False) return List_Id
|
|
is
|
|
Decls : constant List_Id := New_List;
|
|
T_Id : Entity_Id := Empty;
|
|
Decl : Node_Id;
|
|
Expr : Node_Id := Empty;
|
|
Fun : Node_Id := Empty;
|
|
Is_Dyn : constant Boolean :=
|
|
Nkind (Parent (Id_Ref)) = N_Assignment_Statement
|
|
and then
|
|
Nkind (Expression (Parent (Id_Ref))) = N_Allocator;
|
|
|
|
begin
|
|
-- If Discard_Names or No_Implicit_Heap_Allocations are in effect,
|
|
-- generate a dummy declaration only.
|
|
|
|
if Restriction_Active (No_Implicit_Heap_Allocations)
|
|
or else Global_Discard_Names
|
|
then
|
|
T_Id := Make_Temporary (Loc, 'J');
|
|
Name_Len := 0;
|
|
|
|
return
|
|
New_List (
|
|
Make_Object_Declaration (Loc,
|
|
Defining_Identifier => T_Id,
|
|
Object_Definition => New_Occurrence_Of (Standard_String, Loc),
|
|
Expression =>
|
|
Make_String_Literal (Loc,
|
|
Strval => String_From_Name_Buffer)));
|
|
|
|
else
|
|
if Nkind (Id_Ref) = N_Identifier
|
|
or else Nkind (Id_Ref) = N_Defining_Identifier
|
|
then
|
|
-- For a simple variable, the image of the task is built from
|
|
-- the name of the variable. To avoid possible conflict with the
|
|
-- anonymous type created for a single protected object, add a
|
|
-- numeric suffix.
|
|
|
|
T_Id :=
|
|
Make_Defining_Identifier (Loc,
|
|
New_External_Name (Chars (Id_Ref), 'T', 1));
|
|
|
|
Get_Name_String (Chars (Id_Ref));
|
|
|
|
Expr :=
|
|
Make_String_Literal (Loc,
|
|
Strval => String_From_Name_Buffer);
|
|
|
|
elsif Nkind (Id_Ref) = N_Selected_Component then
|
|
T_Id :=
|
|
Make_Defining_Identifier (Loc,
|
|
New_External_Name (Chars (Selector_Name (Id_Ref)), 'T'));
|
|
Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn);
|
|
|
|
elsif Nkind (Id_Ref) = N_Indexed_Component then
|
|
T_Id :=
|
|
Make_Defining_Identifier (Loc,
|
|
New_External_Name (Chars (A_Type), 'N'));
|
|
|
|
Fun := Build_Task_Array_Image (Loc, Id_Ref, A_Type, Is_Dyn);
|
|
end if;
|
|
end if;
|
|
|
|
if Present (Fun) then
|
|
Append (Fun, Decls);
|
|
Expr := Make_Function_Call (Loc,
|
|
Name => New_Occurrence_Of (Defining_Entity (Fun), Loc));
|
|
|
|
if not In_Init_Proc then
|
|
Set_Uses_Sec_Stack (Defining_Entity (Fun));
|
|
end if;
|
|
end if;
|
|
|
|
Decl := Make_Object_Declaration (Loc,
|
|
Defining_Identifier => T_Id,
|
|
Object_Definition => New_Occurrence_Of (Standard_String, Loc),
|
|
Constant_Present => True,
|
|
Expression => Expr);
|
|
|
|
Append (Decl, Decls);
|
|
return Decls;
|
|
end Build_Task_Image_Decls;
|
|
|
|
-------------------------------
|
|
-- Build_Task_Image_Function --
|
|
-------------------------------
|
|
|
|
function Build_Task_Image_Function
|
|
(Loc : Source_Ptr;
|
|
Decls : List_Id;
|
|
Stats : List_Id;
|
|
Res : Entity_Id) return Node_Id
|
|
is
|
|
Spec : Node_Id;
|
|
|
|
begin
|
|
Append_To (Stats,
|
|
Make_Simple_Return_Statement (Loc,
|
|
Expression => New_Occurrence_Of (Res, Loc)));
|
|
|
|
Spec := Make_Function_Specification (Loc,
|
|
Defining_Unit_Name => Make_Temporary (Loc, 'F'),
|
|
Result_Definition => New_Occurrence_Of (Standard_String, Loc));
|
|
|
|
-- Calls to 'Image use the secondary stack, which must be cleaned up
|
|
-- after the task name is built.
|
|
|
|
return Make_Subprogram_Body (Loc,
|
|
Specification => Spec,
|
|
Declarations => Decls,
|
|
Handled_Statement_Sequence =>
|
|
Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats));
|
|
end Build_Task_Image_Function;
|
|
|
|
-----------------------------
|
|
-- Build_Task_Image_Prefix --
|
|
-----------------------------
|
|
|
|
procedure Build_Task_Image_Prefix
|
|
(Loc : Source_Ptr;
|
|
Len : out Entity_Id;
|
|
Res : out Entity_Id;
|
|
Pos : out Entity_Id;
|
|
Prefix : Entity_Id;
|
|
Sum : Node_Id;
|
|
Decls : List_Id;
|
|
Stats : List_Id)
|
|
is
|
|
begin
|
|
Len := Make_Temporary (Loc, 'L', Sum);
|
|
|
|
Append_To (Decls,
|
|
Make_Object_Declaration (Loc,
|
|
Defining_Identifier => Len,
|
|
Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
|
|
Expression => Sum));
|
|
|
|
Res := Make_Temporary (Loc, 'R');
|
|
|
|
Append_To (Decls,
|
|
Make_Object_Declaration (Loc,
|
|
Defining_Identifier => Res,
|
|
Object_Definition =>
|
|
Make_Subtype_Indication (Loc,
|
|
Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
|
|
Constraint =>
|
|
Make_Index_Or_Discriminant_Constraint (Loc,
|
|
Constraints =>
|
|
New_List (
|
|
Make_Range (Loc,
|
|
Low_Bound => Make_Integer_Literal (Loc, 1),
|
|
High_Bound => New_Occurrence_Of (Len, Loc)))))));
|
|
|
|
-- Indicate that the result is an internal temporary, so it does not
|
|
-- receive a bogus initialization when declaration is expanded. This
|
|
-- is both efficient, and prevents anomalies in the handling of
|
|
-- dynamic objects on the secondary stack.
|
|
|
|
Set_Is_Internal (Res);
|
|
Pos := Make_Temporary (Loc, 'P');
|
|
|
|
Append_To (Decls,
|
|
Make_Object_Declaration (Loc,
|
|
Defining_Identifier => Pos,
|
|
Object_Definition => New_Occurrence_Of (Standard_Integer, Loc)));
|
|
|
|
-- Pos := Prefix'Length;
|
|
|
|
Append_To (Stats,
|
|
Make_Assignment_Statement (Loc,
|
|
Name => New_Occurrence_Of (Pos, Loc),
|
|
Expression =>
|
|
Make_Attribute_Reference (Loc,
|
|
Attribute_Name => Name_Length,
|
|
Prefix => New_Occurrence_Of (Prefix, Loc),
|
|
Expressions => New_List (Make_Integer_Literal (Loc, 1)))));
|
|
|
|
-- Res (1 .. Pos) := Prefix;
|
|
|
|
Append_To (Stats,
|
|
Make_Assignment_Statement (Loc,
|
|
Name =>
|
|
Make_Slice (Loc,
|
|
Prefix => New_Occurrence_Of (Res, Loc),
|
|
Discrete_Range =>
|
|
Make_Range (Loc,
|
|
Low_Bound => Make_Integer_Literal (Loc, 1),
|
|
High_Bound => New_Occurrence_Of (Pos, Loc))),
|
|
|
|
Expression => New_Occurrence_Of (Prefix, Loc)));
|
|
|
|
Append_To (Stats,
|
|
Make_Assignment_Statement (Loc,
|
|
Name => New_Occurrence_Of (Pos, Loc),
|
|
Expression =>
|
|
Make_Op_Add (Loc,
|
|
Left_Opnd => New_Occurrence_Of (Pos, Loc),
|
|
Right_Opnd => Make_Integer_Literal (Loc, 1))));
|
|
end Build_Task_Image_Prefix;
|
|
|
|
-----------------------------
|
|
-- Build_Task_Record_Image --
|
|
-----------------------------
|
|
|
|
function Build_Task_Record_Image
|
|
(Loc : Source_Ptr;
|
|
Id_Ref : Node_Id;
|
|
Dyn : Boolean := False) return Node_Id
|
|
is
|
|
Len : Entity_Id;
|
|
-- Total length of generated name
|
|
|
|
Pos : Entity_Id;
|
|
-- Index into result
|
|
|
|
Res : Entity_Id;
|
|
-- String to hold result
|
|
|
|
Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
|
|
-- Name of enclosing variable, prefix of resulting name
|
|
|
|
Sum : Node_Id;
|
|
-- Expression to compute total size of string
|
|
|
|
Sel : Entity_Id;
|
|
-- Entity for selector name
|
|
|
|
Decls : constant List_Id := New_List;
|
|
Stats : constant List_Id := New_List;
|
|
|
|
begin
|
|
-- For a dynamic task, the name comes from the target variable. For a
|
|
-- static one it is a formal of the enclosing init proc.
|
|
|
|
if Dyn then
|
|
Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
|
|
Append_To (Decls,
|
|
Make_Object_Declaration (Loc,
|
|
Defining_Identifier => Pref,
|
|
Object_Definition => New_Occurrence_Of (Standard_String, Loc),
|
|
Expression =>
|
|
Make_String_Literal (Loc,
|
|
Strval => String_From_Name_Buffer)));
|
|
|
|
else
|
|
Append_To (Decls,
|
|
Make_Object_Renaming_Declaration (Loc,
|
|
Defining_Identifier => Pref,
|
|
Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
|
|
Name => Make_Identifier (Loc, Name_uTask_Name)));
|
|
end if;
|
|
|
|
Sel := Make_Temporary (Loc, 'S');
|
|
|
|
Get_Name_String (Chars (Selector_Name (Id_Ref)));
|
|
|
|
Append_To (Decls,
|
|
Make_Object_Declaration (Loc,
|
|
Defining_Identifier => Sel,
|
|
Object_Definition => New_Occurrence_Of (Standard_String, Loc),
|
|
Expression =>
|
|
Make_String_Literal (Loc,
|
|
Strval => String_From_Name_Buffer)));
|
|
|
|
Sum := Make_Integer_Literal (Loc, Nat (Name_Len + 1));
|
|
|
|
Sum :=
|
|
Make_Op_Add (Loc,
|
|
Left_Opnd => Sum,
|
|
Right_Opnd =>
|
|
Make_Attribute_Reference (Loc,
|
|
Attribute_Name => Name_Length,
|
|
Prefix =>
|
|
New_Occurrence_Of (Pref, Loc),
|
|
Expressions => New_List (Make_Integer_Literal (Loc, 1))));
|
|
|
|
Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
|
|
|
|
Set_Character_Literal_Name (Char_Code (Character'Pos ('.')));
|
|
|
|
-- Res (Pos) := '.';
|
|
|
|
Append_To (Stats,
|
|
Make_Assignment_Statement (Loc,
|
|
Name => Make_Indexed_Component (Loc,
|
|
Prefix => New_Occurrence_Of (Res, Loc),
|
|
Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
|
|
Expression =>
|
|
Make_Character_Literal (Loc,
|
|
Chars => Name_Find,
|
|
Char_Literal_Value =>
|
|
UI_From_Int (Character'Pos ('.')))));
|
|
|
|
Append_To (Stats,
|
|
Make_Assignment_Statement (Loc,
|
|
Name => New_Occurrence_Of (Pos, Loc),
|
|
Expression =>
|
|
Make_Op_Add (Loc,
|
|
Left_Opnd => New_Occurrence_Of (Pos, Loc),
|
|
Right_Opnd => Make_Integer_Literal (Loc, 1))));
|
|
|
|
-- Res (Pos .. Len) := Selector;
|
|
|
|
Append_To (Stats,
|
|
Make_Assignment_Statement (Loc,
|
|
Name => Make_Slice (Loc,
|
|
Prefix => New_Occurrence_Of (Res, Loc),
|
|
Discrete_Range =>
|
|
Make_Range (Loc,
|
|
Low_Bound => New_Occurrence_Of (Pos, Loc),
|
|
High_Bound => New_Occurrence_Of (Len, Loc))),
|
|
Expression => New_Occurrence_Of (Sel, Loc)));
|
|
|
|
return Build_Task_Image_Function (Loc, Decls, Stats, Res);
|
|
end Build_Task_Record_Image;
|
|
|
|
---------------------------------------
|
|
-- Build_Transient_Object_Statements --
|
|
---------------------------------------
|
|
|
|
procedure Build_Transient_Object_Statements
|
|
(Obj_Decl : Node_Id;
|
|
Fin_Call : out Node_Id;
|
|
Hook_Assign : out Node_Id;
|
|
Hook_Clear : out Node_Id;
|
|
Hook_Decl : out Node_Id;
|
|
Ptr_Decl : out Node_Id;
|
|
Finalize_Obj : Boolean := True)
|
|
is
|
|
Loc : constant Source_Ptr := Sloc (Obj_Decl);
|
|
Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
|
|
Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
|
|
|
|
Desig_Typ : Entity_Id;
|
|
Hook_Expr : Node_Id;
|
|
Hook_Id : Entity_Id;
|
|
Obj_Ref : Node_Id;
|
|
Ptr_Typ : Entity_Id;
|
|
|
|
begin
|
|
-- Recover the type of the object
|
|
|
|
Desig_Typ := Obj_Typ;
|
|
|
|
if Is_Access_Type (Desig_Typ) then
|
|
Desig_Typ := Available_View (Designated_Type (Desig_Typ));
|
|
end if;
|
|
|
|
-- Create an access type which provides a reference to the transient
|
|
-- object. Generate:
|
|
|
|
-- type Ptr_Typ is access all Desig_Typ;
|
|
|
|
Ptr_Typ := Make_Temporary (Loc, 'A');
|
|
Mutate_Ekind (Ptr_Typ, E_General_Access_Type);
|
|
Set_Directly_Designated_Type (Ptr_Typ, Desig_Typ);
|
|
|
|
Ptr_Decl :=
|
|
Make_Full_Type_Declaration (Loc,
|
|
Defining_Identifier => Ptr_Typ,
|
|
Type_Definition =>
|
|
Make_Access_To_Object_Definition (Loc,
|
|
All_Present => True,
|
|
Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc)));
|
|
|
|
-- Create a temporary check which acts as a hook to the transient
|
|
-- object. Generate:
|
|
|
|
-- Hook : Ptr_Typ := null;
|
|
|
|
Hook_Id := Make_Temporary (Loc, 'T');
|
|
Mutate_Ekind (Hook_Id, E_Variable);
|
|
Set_Etype (Hook_Id, Ptr_Typ);
|
|
|
|
Hook_Decl :=
|
|
Make_Object_Declaration (Loc,
|
|
Defining_Identifier => Hook_Id,
|
|
Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
|
|
Expression => Make_Null (Loc));
|
|
|
|
-- Mark the temporary as a hook. This signals the machinery in
|
|
-- Build_Finalizer to recognize this special case.
|
|
|
|
Set_Status_Flag_Or_Transient_Decl (Hook_Id, Obj_Decl);
|
|
|
|
-- Hook the transient object to the temporary. Generate:
|
|
|
|
-- Hook := Ptr_Typ (Obj_Id);
|
|
-- <or>
|
|
-- Hool := Obj_Id'Unrestricted_Access;
|
|
|
|
if Is_Access_Type (Obj_Typ) then
|
|
Hook_Expr :=
|
|
Unchecked_Convert_To (Ptr_Typ, New_Occurrence_Of (Obj_Id, Loc));
|
|
else
|
|
Hook_Expr :=
|
|
Make_Attribute_Reference (Loc,
|
|
Prefix => New_Occurrence_Of (Obj_Id, Loc),
|
|
Attribute_Name => Name_Unrestricted_Access);
|
|
end if;
|
|
|
|
Hook_Assign :=
|
|
Make_Assignment_Statement (Loc,
|
|
Name => New_Occurrence_Of (Hook_Id, Loc),
|
|
Expression => Hook_Expr);
|
|
|
|
-- Crear the hook prior to finalizing the object. Generate:
|
|
|
|
-- Hook := null;
|
|
|
|
Hook_Clear :=
|
|
Make_Assignment_Statement (Loc,
|
|
Name => New_Occurrence_Of (Hook_Id, Loc),
|
|
Expression => Make_Null (Loc));
|
|
|
|
-- Finalize the object. Generate:
|
|
|
|
-- [Deep_]Finalize (Obj_Ref[.all]);
|
|
|
|
if Finalize_Obj then
|
|
Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
|
|
|
|
if Is_Access_Type (Obj_Typ) then
|
|
Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
|
|
Set_Etype (Obj_Ref, Desig_Typ);
|
|
end if;
|
|
|
|
Fin_Call :=
|
|
Make_Final_Call
|
|
(Obj_Ref => Obj_Ref,
|
|
Typ => Desig_Typ);
|
|
|
|
-- Otherwise finalize the hook. Generate:
|
|
|
|
-- [Deep_]Finalize (Hook.all);
|
|
|
|
else
|
|
Fin_Call :=
|
|
Make_Final_Call (
|
|
Obj_Ref =>
|
|
Make_Explicit_Dereference (Loc,
|
|
Prefix => New_Occurrence_Of (Hook_Id, Loc)),
|
|
Typ => Desig_Typ);
|
|
end if;
|
|
end Build_Transient_Object_Statements;
|
|
|
|
-----------------------------
|
|
-- Check_Float_Op_Overflow --
|
|
-----------------------------
|
|
|
|
procedure Check_Float_Op_Overflow (N : Node_Id) is
|
|
begin
|
|
-- Return if no check needed
|
|
|
|
if not Is_Floating_Point_Type (Etype (N))
|
|
or else not (Do_Overflow_Check (N) and then Check_Float_Overflow)
|
|
|
|
-- In CodePeer_Mode, rely on the overflow check flag being set instead
|
|
-- and do not expand the code for float overflow checking.
|
|
|
|
or else CodePeer_Mode
|
|
then
|
|
return;
|
|
end if;
|
|
|
|
-- Otherwise we replace the expression by
|
|
|
|
-- do Tnn : constant ftype := expression;
|
|
-- constraint_error when not Tnn'Valid;
|
|
-- in Tnn;
|
|
|
|
declare
|
|
Loc : constant Source_Ptr := Sloc (N);
|
|
Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
|
|
Typ : constant Entity_Id := Etype (N);
|
|
|
|
begin
|
|
-- Turn off the Do_Overflow_Check flag, since we are doing that work
|
|
-- right here. We also set the node as analyzed to prevent infinite
|
|
-- recursion from repeating the operation in the expansion.
|
|
|
|
Set_Do_Overflow_Check (N, False);
|
|
Set_Analyzed (N, True);
|
|
|
|
-- Do the rewrite to include the check
|
|
|
|
Rewrite (N,
|
|
Make_Expression_With_Actions (Loc,
|
|
Actions => New_List (
|
|
Make_Object_Declaration (Loc,
|
|
Defining_Identifier => Tnn,
|
|
Object_Definition => New_Occurrence_Of (Typ, Loc),
|
|
Constant_Present => True,
|
|
Expression => Relocate_Node (N)),
|
|
Make_Raise_Constraint_Error (Loc,
|
|
Condition =>
|
|
Make_Op_Not (Loc,
|
|
Right_Opnd =>
|
|
Make_Attribute_Reference (Loc,
|
|
Prefix => New_Occurrence_Of (Tnn, Loc),
|
|
Attribute_Name => Name_Valid)),
|
|
Reason => CE_Overflow_Check_Failed)),
|
|
Expression => New_Occurrence_Of (Tnn, Loc)));
|
|
|
|
Analyze_And_Resolve (N, Typ);
|
|
end;
|
|
end Check_Float_Op_Overflow;
|
|
|
|
----------------------------------
|
|
-- Component_May_Be_Bit_Aligned --
|
|
----------------------------------
|
|
|
|
function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is
|
|
UT : Entity_Id;
|
|
|
|
begin
|
|
-- If no component clause, then everything is fine, since the back end
|
|
-- never misaligns from byte boundaries by default, even if there is a
|
|
-- pragma Pack for the record.
|
|
|
|
if No (Comp) or else No (Component_Clause (Comp)) then
|
|
return False;
|
|
end if;
|
|
|
|
UT := Underlying_Type (Etype (Comp));
|
|
|
|
-- It is only array and record types that cause trouble
|
|
|
|
if not Is_Record_Type (UT) and then not Is_Array_Type (UT) then
|
|
return False;
|
|
|
|
-- If we know that we have a small (at most the maximum integer size)
|
|
-- record or bit-packed array, then everything is fine, since the back
|
|
-- end can handle these cases correctly.
|
|
|
|
elsif Known_Esize (Comp)
|
|
and then Esize (Comp) <= System_Max_Integer_Size
|
|
and then (Is_Record_Type (UT) or else Is_Bit_Packed_Array (UT))
|
|
then
|
|
return False;
|
|
|
|
elsif not Known_Normalized_First_Bit (Comp) then
|
|
return True;
|
|
|
|
-- Otherwise if the component is not byte aligned, we know we have the
|
|
-- nasty unaligned case.
|
|
|
|
elsif Normalized_First_Bit (Comp) /= Uint_0
|
|
or else Esize (Comp) mod System_Storage_Unit /= Uint_0
|
|
then
|
|
return True;
|
|
|
|
-- If we are large and byte aligned, then OK at this level
|
|
|
|
else
|
|
return False;
|
|
end if;
|
|
end Component_May_Be_Bit_Aligned;
|
|
|
|
-------------------------------
|
|
-- Convert_To_Actual_Subtype --
|
|
-------------------------------
|
|
|
|
procedure Convert_To_Actual_Subtype (Exp : Node_Id) is
|
|
Act_ST : Entity_Id;
|
|
|
|
begin
|
|
Act_ST := Get_Actual_Subtype (Exp);
|
|
|
|
if Act_ST = Etype (Exp) then
|
|
return;
|
|
else
|
|
Rewrite (Exp, Convert_To (Act_ST, Relocate_Node (Exp)));
|
|
Analyze_And_Resolve (Exp, Act_ST);
|
|
end if;
|
|
end Convert_To_Actual_Subtype;
|
|
|
|
-----------------------------------
|
|
-- Corresponding_Runtime_Package --
|
|
-----------------------------------
|
|
|
|
function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is
|
|
function Has_One_Entry_And_No_Queue (T : Entity_Id) return Boolean;
|
|
-- Return True if protected type T has one entry and the maximum queue
|
|
-- length is one.
|
|
|
|
--------------------------------
|
|
-- Has_One_Entry_And_No_Queue --
|
|
--------------------------------
|
|
|
|
function Has_One_Entry_And_No_Queue (T : Entity_Id) return Boolean is
|
|
Item : Entity_Id;
|
|
Is_First : Boolean := True;
|
|
|
|
begin
|
|
Item := First_Entity (T);
|
|
while Present (Item) loop
|
|
if Is_Entry (Item) then
|
|
|
|
-- The protected type has more than one entry
|
|
|
|
if not Is_First then
|
|
return False;
|
|
end if;
|
|
|
|
-- The queue length is not one
|
|
|
|
if not Restriction_Active (No_Entry_Queue)
|
|
and then Get_Max_Queue_Length (Item) /= Uint_1
|
|
then
|
|
return False;
|
|
end if;
|
|
|
|
Is_First := False;
|
|
end if;
|
|
|
|
Next_Entity (Item);
|
|
end loop;
|
|
|
|
return True;
|
|
end Has_One_Entry_And_No_Queue;
|
|
|
|
-- Local variables
|
|
|
|
Pkg_Id : RTU_Id := RTU_Null;
|
|
|
|
-- Start of processing for Corresponding_Runtime_Package
|
|
|
|
begin
|
|
pragma Assert (Is_Concurrent_Type (Typ));
|
|
|
|
if Is_Protected_Type (Typ) then
|
|
if Has_Entries (Typ)
|
|
|
|
-- A protected type without entries that covers an interface and
|
|
-- overrides the abstract routines with protected procedures is
|
|
-- considered equivalent to a protected type with entries in the
|
|
-- context of dispatching select statements. It is sufficient to
|
|
-- check for the presence of an interface list in the declaration
|
|
-- node to recognize this case.
|
|
|
|
or else Present (Interface_List (Parent (Typ)))
|
|
|
|
-- Protected types with interrupt handlers (when not using a
|
|
-- restricted profile) are also considered equivalent to
|
|
-- protected types with entries. The types which are used
|
|
-- (Static_Interrupt_Protection and Dynamic_Interrupt_Protection)
|
|
-- are derived from Protection_Entries.
|
|
|
|
or else (Has_Attach_Handler (Typ) and then not Restricted_Profile)
|
|
or else Has_Interrupt_Handler (Typ)
|
|
then
|
|
if Abort_Allowed
|
|
or else Restriction_Active (No_Select_Statements) = False
|
|
or else not Has_One_Entry_And_No_Queue (Typ)
|
|
or else (Has_Attach_Handler (Typ)
|
|
and then not Restricted_Profile)
|
|
then
|
|
Pkg_Id := System_Tasking_Protected_Objects_Entries;
|
|
else
|
|
Pkg_Id := System_Tasking_Protected_Objects_Single_Entry;
|
|
end if;
|
|
|
|
else
|
|
Pkg_Id := System_Tasking_Protected_Objects;
|
|
end if;
|
|
end if;
|
|
|
|
return Pkg_Id;
|
|
end Corresponding_Runtime_Package;
|
|
|
|
-----------------------------------
|
|
-- Current_Sem_Unit_Declarations --
|
|
-----------------------------------
|
|
|
|
function Current_Sem_Unit_Declarations return List_Id is
|
|
U : Node_Id := Unit (Cunit (Current_Sem_Unit));
|
|
Decls : List_Id;
|
|
|
|
begin
|
|
-- If the current unit is a package body, locate the visible
|
|
-- declarations of the package spec.
|
|
|
|
if Nkind (U) = N_Package_Body then
|
|
U := Unit (Library_Unit (Cunit (Current_Sem_Unit)));
|
|
end if;
|
|
|
|
if Nkind (U) = N_Package_Declaration then
|
|
U := Specification (U);
|
|
Decls := Visible_Declarations (U);
|
|
|
|
if No (Decls) then
|
|
Decls := New_List;
|
|
Set_Visible_Declarations (U, Decls);
|
|
end if;
|
|
|
|
else
|
|
Decls := Declarations (U);
|
|
|
|
if No (Decls) then
|
|
Decls := New_List;
|
|
Set_Declarations (U, Decls);
|
|
end if;
|
|
end if;
|
|
|
|
return Decls;
|
|
end Current_Sem_Unit_Declarations;
|
|
|
|
-----------------------
|
|
-- Duplicate_Subexpr --
|
|
-----------------------
|
|
|
|
function Duplicate_Subexpr
|
|
(Exp : Node_Id;
|
|
Name_Req : Boolean := False;
|
|
Renaming_Req : Boolean := False) return Node_Id
|
|
is
|
|
begin
|
|
Remove_Side_Effects (Exp, Name_Req, Renaming_Req);
|
|
return New_Copy_Tree (Exp);
|
|
end Duplicate_Subexpr;
|
|
|
|
---------------------------------
|
|
-- Duplicate_Subexpr_No_Checks --
|
|
---------------------------------
|
|
|
|
function Duplicate_Subexpr_No_Checks
|
|
(Exp : Node_Id;
|
|
Name_Req : Boolean := False;
|
|
Renaming_Req : Boolean := False;
|
|
Related_Id : Entity_Id := Empty;
|
|
Is_Low_Bound : Boolean := False;
|
|
Is_High_Bound : Boolean := False) return Node_Id
|
|
is
|
|
New_Exp : Node_Id;
|
|
|
|
begin
|
|
Remove_Side_Effects
|
|
(Exp => Exp,
|
|
Name_Req => Name_Req,
|
|
Renaming_Req => Renaming_Req,
|
|
Related_Id => Related_Id,
|
|
Is_Low_Bound => Is_Low_Bound,
|
|
Is_High_Bound => Is_High_Bound);
|
|
|
|
New_Exp := New_Copy_Tree (Exp);
|
|
Remove_Checks (New_Exp);
|
|
return New_Exp;
|
|
end Duplicate_Subexpr_No_Checks;
|
|
|
|
-----------------------------------
|
|
-- Duplicate_Subexpr_Move_Checks --
|
|
-----------------------------------
|
|
|
|
function Duplicate_Subexpr_Move_Checks
|
|
(Exp : Node_Id;
|
|
Name_Req : Boolean := False;
|
|
Renaming_Req : Boolean := False) return Node_Id
|
|
is
|
|
New_Exp : Node_Id;
|
|
|
|
begin
|
|
Remove_Side_Effects (Exp, Name_Req, Renaming_Req);
|
|
New_Exp := New_Copy_Tree (Exp);
|
|
Remove_Checks (Exp);
|
|
return New_Exp;
|
|
end Duplicate_Subexpr_Move_Checks;
|
|
|
|
-------------------------
|
|
-- Enclosing_Init_Proc --
|
|
-------------------------
|
|
|
|
function Enclosing_Init_Proc return Entity_Id is
|
|
S : Entity_Id;
|
|
|
|
begin
|
|
S := Current_Scope;
|
|
while Present (S) and then S /= Standard_Standard loop
|
|
if Is_Init_Proc (S) then
|
|
return S;
|
|
else
|
|
S := Scope (S);
|
|
end if;
|
|
end loop;
|
|
|
|
return Empty;
|
|
end Enclosing_Init_Proc;
|
|
|
|
--------------------
|
|
-- Ensure_Defined --
|
|
--------------------
|
|
|
|
procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is
|
|
IR : Node_Id;
|
|
|
|
begin
|
|
-- An itype reference must only be created if this is a local itype, so
|
|
-- that gigi can elaborate it on the proper objstack.
|
|
|
|
if Is_Itype (Typ) and then Scope (Typ) = Current_Scope then
|
|
IR := Make_Itype_Reference (Sloc (N));
|
|
Set_Itype (IR, Typ);
|
|
Insert_Action (N, IR);
|
|
end if;
|
|
end Ensure_Defined;
|
|
|
|
--------------------
|
|
-- Entry_Names_OK --
|
|
--------------------
|
|
|
|
function Entry_Names_OK return Boolean is
|
|
begin
|
|
return
|
|
not Restricted_Profile
|
|
and then not Global_Discard_Names
|
|
and then not Restriction_Active (No_Implicit_Heap_Allocations)
|
|
and then not Restriction_Active (No_Local_Allocators);
|
|
end Entry_Names_OK;
|
|
|
|
-------------------
|
|
-- Evaluate_Name --
|
|
-------------------
|
|
|
|
procedure Evaluate_Name (Nam : Node_Id) is
|
|
begin
|
|
case Nkind (Nam) is
|
|
-- For an aggregate, force its evaluation
|
|
|
|
when N_Aggregate =>
|
|
Force_Evaluation (Nam);
|
|
|
|
-- For an attribute reference or an indexed component, evaluate the
|
|
-- prefix, which is itself a name, recursively, and then force the
|
|
-- evaluation of all the subscripts (or attribute expressions).
|
|
|
|
when N_Attribute_Reference
|
|
| N_Indexed_Component
|
|
=>
|
|
Evaluate_Name (Prefix (Nam));
|
|
|
|
declare
|
|
E : Node_Id;
|
|
|
|
begin
|
|
E := First (Expressions (Nam));
|
|
while Present (E) loop
|
|
Force_Evaluation (E);
|
|
|
|
if Is_Rewrite_Substitution (E) then
|
|
Set_Do_Range_Check
|
|
(E, Do_Range_Check (Original_Node (E)));
|
|
end if;
|
|
|
|
Next (E);
|
|
end loop;
|
|
end;
|
|
|
|
-- For an explicit dereference, we simply force the evaluation of
|
|
-- the name expression. The dereference provides a value that is the
|
|
-- address for the renamed object, and it is precisely this value
|
|
-- that we want to preserve.
|
|
|
|
when N_Explicit_Dereference =>
|
|
Force_Evaluation (Prefix (Nam));
|
|
|
|
-- For a function call, we evaluate the call; same for an operator
|
|
|
|
when N_Function_Call
|
|
| N_Op
|
|
=>
|
|
Force_Evaluation (Nam);
|
|
|
|
-- For a qualified expression, we evaluate the expression
|
|
|
|
when N_Qualified_Expression =>
|
|
Evaluate_Name (Expression (Nam));
|
|
|
|
-- For a selected component, we simply evaluate the prefix
|
|
|
|
when N_Selected_Component =>
|
|
Evaluate_Name (Prefix (Nam));
|
|
|
|
-- For a slice, we evaluate the prefix, as for the indexed component
|
|
-- case and then, if there is a range present, either directly or as
|
|
-- the constraint of a discrete subtype indication, we evaluate the
|
|
-- two bounds of this range.
|
|
|
|
when N_Slice =>
|
|
Evaluate_Name (Prefix (Nam));
|
|
Evaluate_Slice_Bounds (Nam);
|
|
|
|
-- For a type conversion, the expression of the conversion must be
|
|
-- the name of an object, and we simply need to evaluate this name.
|
|
|
|
when N_Type_Conversion =>
|
|
Evaluate_Name (Expression (Nam));
|
|
|
|
-- The remaining cases are direct name and character literal. In all
|
|
-- these cases, we do nothing, since we want to reevaluate each time
|
|
-- the renamed object is used. ??? There are more remaining cases, at
|
|
-- least in the GNATprove_Mode, where this routine is called in more
|
|
-- contexts than in GNAT.
|
|
|
|
when others =>
|
|
null;
|
|
end case;
|
|
end Evaluate_Name;
|
|
|
|
---------------------------
|
|
-- Evaluate_Slice_Bounds --
|
|
---------------------------
|
|
|
|
procedure Evaluate_Slice_Bounds (Slice : Node_Id) is
|
|
DR : constant Node_Id := Discrete_Range (Slice);
|
|
Constr : Node_Id;
|
|
Rexpr : Node_Id;
|
|
|
|
begin
|
|
if Nkind (DR) = N_Range then
|
|
Force_Evaluation (Low_Bound (DR));
|
|
Force_Evaluation (High_Bound (DR));
|
|
|
|
elsif Nkind (DR) = N_Subtype_Indication then
|
|
Constr := Constraint (DR);
|
|
|
|
if Nkind (Constr) = N_Range_Constraint then
|
|
Rexpr := Range_Expression (Constr);
|
|
|
|
Force_Evaluation (Low_Bound (Rexpr));
|
|
Force_Evaluation (High_Bound (Rexpr));
|
|
end if;
|
|
end if;
|
|
end Evaluate_Slice_Bounds;
|
|
|
|
---------------------
|
|
-- Evolve_And_Then --
|
|
---------------------
|
|
|
|
procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id) is
|
|
begin
|
|
if No (Cond) then
|
|
Cond := Cond1;
|
|
else
|
|
Cond :=
|
|
Make_And_Then (Sloc (Cond1),
|
|
Left_Opnd => Cond,
|
|
Right_Opnd => Cond1);
|
|
end if;
|
|
end Evolve_And_Then;
|
|
|
|
--------------------
|
|
-- Evolve_Or_Else --
|
|
--------------------
|
|
|
|
procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id) is
|
|
begin
|
|
if No (Cond) then
|
|
Cond := Cond1;
|
|
else
|
|
Cond :=
|
|
Make_Or_Else (Sloc (Cond1),
|
|
Left_Opnd => Cond,
|
|
Right_Opnd => Cond1);
|
|
end if;
|
|
end Evolve_Or_Else;
|
|
|
|
-------------------------------
|
|
-- Expand_Sliding_Conversion --
|
|
-------------------------------
|
|
|
|
procedure Expand_Sliding_Conversion (N : Node_Id; Arr_Typ : Entity_Id) is
|
|
|
|
pragma Assert (Is_Array_Type (Arr_Typ)
|
|
and then not Is_Constrained (Arr_Typ)
|
|
and then Is_Fixed_Lower_Bound_Array_Subtype (Arr_Typ));
|
|
|
|
Constraints : List_Id;
|
|
Index : Node_Id := First_Index (Arr_Typ);
|
|
Loc : constant Source_Ptr := Sloc (N);
|
|
Subt_Decl : Node_Id;
|
|
Subt : Entity_Id;
|
|
Subt_Low : Node_Id;
|
|
Subt_High : Node_Id;
|
|
|
|
Act_Subt : Entity_Id;
|
|
Act_Index : Node_Id;
|
|
Act_Low : Node_Id;
|
|
Act_High : Node_Id;
|
|
Adjust_Incr : Node_Id;
|
|
Dimension : Int := 0;
|
|
All_FLBs_Match : Boolean := True;
|
|
|
|
begin
|
|
-- This procedure is called during semantic analysis, and we only expand
|
|
-- a sliding conversion when Expander_Active, to avoid doing it during
|
|
-- preanalysis (which can lead to problems with the target subtype not
|
|
-- getting properly expanded during later full analysis). Also, sliding
|
|
-- should never be needed for string literals, because their bounds are
|
|
-- determined directly based on the fixed lower bound of Arr_Typ and
|
|
-- their length.
|
|
|
|
if Expander_Active and then Nkind (N) /= N_String_Literal then
|
|
Constraints := New_List;
|
|
|
|
Act_Subt := Get_Actual_Subtype (N);
|
|
Act_Index := First_Index (Act_Subt);
|
|
|
|
-- Loop over the indexes of the fixed-lower-bound array type or
|
|
-- subtype to build up an index constraint for constructing the
|
|
-- subtype that will be the target of a conversion of the array
|
|
-- object that may need a sliding conversion.
|
|
|
|
while Present (Index) loop
|
|
pragma Assert (Present (Act_Index));
|
|
|
|
Dimension := Dimension + 1;
|
|
|
|
Get_Index_Bounds (Act_Index, Act_Low, Act_High);
|
|
|
|
-- If Index defines a normal unconstrained range (range <>),
|
|
-- then we will simply use the bounds of the actual subtype's
|
|
-- corresponding index range.
|
|
|
|
if not Is_Fixed_Lower_Bound_Index_Subtype (Etype (Index)) then
|
|
Subt_Low := Act_Low;
|
|
Subt_High := Act_High;
|
|
|
|
-- Otherwise, a range will be created with a low bound given by
|
|
-- the fixed lower bound of the array subtype's index, and with
|
|
-- high bound given by (Actual'Length + fixed lower bound - 1).
|
|
|
|
else
|
|
if Nkind (Index) = N_Subtype_Indication then
|
|
Subt_Low :=
|
|
New_Copy_Tree
|
|
(Low_Bound (Range_Expression (Constraint (Index))));
|
|
else
|
|
pragma Assert (Nkind (Index) = N_Range);
|
|
|
|
Subt_Low := New_Copy_Tree (Low_Bound (Index));
|
|
end if;
|
|
|
|
-- If either we have a nonstatic lower bound, or the target and
|
|
-- source subtypes are statically known to have unequal lower
|
|
-- bounds, then we will need to make a subtype conversion to
|
|
-- slide the bounds. However, if all of the indexes' lower
|
|
-- bounds are static and known to be equal (the common case),
|
|
-- then no conversion will be needed, and we'll end up not
|
|
-- creating the subtype or the conversion (though we still
|
|
-- build up the index constraint, which will simply be unused).
|
|
|
|
if not (Compile_Time_Known_Value (Subt_Low)
|
|
and then Compile_Time_Known_Value (Act_Low))
|
|
or else Expr_Value (Subt_Low) /= Expr_Value (Act_Low)
|
|
then
|
|
All_FLBs_Match := False;
|
|
end if;
|
|
|
|
-- Apply 'Pos to lower bound, which may be of an enumeration
|
|
-- type, before subtracting.
|
|
|
|
Adjust_Incr :=
|
|
Make_Op_Subtract (Loc,
|
|
Make_Attribute_Reference (Loc,
|
|
Prefix =>
|
|
New_Occurrence_Of (Etype (Act_Index), Loc),
|
|
Attribute_Name =>
|
|
Name_Pos,
|
|
Expressions =>
|
|
New_List (New_Copy_Tree (Subt_Low))),
|
|
Make_Integer_Literal (Loc, 1));
|
|
|
|
-- Apply 'Val to the result of adding the increment to the
|
|
-- length, to handle indexes of enumeration types.
|
|
|
|
Subt_High :=
|
|
Make_Attribute_Reference (Loc,
|
|
Prefix =>
|
|
New_Occurrence_Of (Etype (Act_Index), Loc),
|
|
Attribute_Name =>
|
|
Name_Val,
|
|
Expressions =>
|
|
New_List (Make_Op_Add (Loc,
|
|
Make_Attribute_Reference (Loc,
|
|
Prefix =>
|
|
New_Occurrence_Of (Act_Subt, Loc),
|
|
Attribute_Name =>
|
|
Name_Length,
|
|
Expressions =>
|
|
New_List
|
|
(Make_Integer_Literal
|
|
(Loc, Dimension))),
|
|
Adjust_Incr)));
|
|
end if;
|
|
|
|
Append (Make_Range (Loc, Subt_Low, Subt_High), Constraints);
|
|
|
|
Next (Index);
|
|
Next (Act_Index);
|
|
end loop;
|
|
|
|
-- If for each index with a fixed lower bound (FLB), the lower bound
|
|
-- of the corresponding index of the actual subtype is statically
|
|
-- known be equal to the FLB, then a sliding conversion isn't needed
|
|
-- at all, so just return without building a subtype or conversion.
|
|
|
|
if All_FLBs_Match then
|
|
return;
|
|
end if;
|
|
|
|
-- A sliding conversion is needed, so create the target subtype using
|
|
-- the index constraint created above, and rewrite the expression
|
|
-- as a conversion to that subtype.
|
|
|
|
Subt := Make_Temporary (Loc, 'S', Related_Node => N);
|
|
Set_Is_Internal (Subt);
|
|
|
|
Subt_Decl :=
|
|
Make_Subtype_Declaration (Loc,
|
|
Defining_Identifier => Subt,
|
|
Subtype_Indication =>
|
|
Make_Subtype_Indication (Loc,
|
|
Subtype_Mark =>
|
|
New_Occurrence_Of (Arr_Typ, Loc),
|
|
Constraint =>
|
|
Make_Index_Or_Discriminant_Constraint (Loc,
|
|
Constraints => Constraints)));
|
|
|
|
Mark_Rewrite_Insertion (Subt_Decl);
|
|
|
|
-- The actual subtype is an Itype, so we analyze the declaration,
|
|
-- but do not attach it to the tree.
|
|
|
|
Set_Parent (Subt_Decl, N);
|
|
Set_Is_Itype (Subt);
|
|
Analyze (Subt_Decl, Suppress => All_Checks);
|
|
Set_Associated_Node_For_Itype (Subt, N);
|
|
Set_Has_Delayed_Freeze (Subt, False);
|
|
|
|
-- We need to freeze the actual subtype immediately. This is needed
|
|
-- because otherwise this Itype will not get frozen at all, and it is
|
|
-- always safe to freeze on creation because any associated types
|
|
-- must be frozen at this point.
|
|
|
|
Freeze_Itype (Subt, N);
|
|
|
|
Rewrite (N,
|
|
Make_Type_Conversion (Loc,
|
|
Subtype_Mark =>
|
|
New_Occurrence_Of (Subt, Loc),
|
|
Expression => Relocate_Node (N)));
|
|
Analyze (N);
|
|
end if;
|
|
end Expand_Sliding_Conversion;
|
|
|
|
-----------------------------------------
|
|
-- Expand_Static_Predicates_In_Choices --
|
|
-----------------------------------------
|
|
|
|
procedure Expand_Static_Predicates_In_Choices (N : Node_Id) is
|
|
pragma Assert (Nkind (N) in N_Case_Statement_Alternative | N_Variant);
|
|
|
|
Choices : List_Id := Discrete_Choices (N);
|
|
|
|
Choice : Node_Id;
|
|
Next_C : Node_Id;
|
|
P : Node_Id;
|
|
C : Node_Id;
|
|
|
|
begin
|
|
-- If this is an "others" alternative, we need to process any static
|
|
-- predicates in its Others_Discrete_Choices.
|
|
|
|
if Nkind (First (Choices)) = N_Others_Choice then
|
|
Choices := Others_Discrete_Choices (First (Choices));
|
|
end if;
|
|
|
|
Choice := First (Choices);
|
|
while Present (Choice) loop
|
|
Next_C := Next (Choice);
|
|
|
|
-- Check for name of subtype with static predicate
|
|
|
|
if Is_Entity_Name (Choice)
|
|
and then Is_Type (Entity (Choice))
|
|
and then Has_Predicates (Entity (Choice))
|
|
then
|
|
-- Loop through entries in predicate list, converting to choices
|
|
-- and inserting in the list before the current choice. Note that
|
|
-- if the list is empty, corresponding to a False predicate, then
|
|
-- no choices are inserted.
|
|
|
|
P := First (Static_Discrete_Predicate (Entity (Choice)));
|
|
while Present (P) loop
|
|
|
|
-- If low bound and high bounds are equal, copy simple choice
|
|
|
|
if Expr_Value (Low_Bound (P)) = Expr_Value (High_Bound (P)) then
|
|
C := New_Copy (Low_Bound (P));
|
|
|
|
-- Otherwise copy a range
|
|
|
|
else
|
|
C := New_Copy (P);
|
|
end if;
|
|
|
|
-- Change Sloc to referencing choice (rather than the Sloc of
|
|
-- the predicate declaration element itself).
|
|
|
|
Set_Sloc (C, Sloc (Choice));
|
|
Insert_Before (Choice, C);
|
|
Next (P);
|
|
end loop;
|
|
|
|
-- Delete the predicated entry
|
|
|
|
Remove (Choice);
|
|
end if;
|
|
|
|
-- Move to next choice to check
|
|
|
|
Choice := Next_C;
|
|
end loop;
|
|
|
|
Set_Has_SP_Choice (N, False);
|
|
end Expand_Static_Predicates_In_Choices;
|
|
|
|
------------------------------
|
|
-- Expand_Subtype_From_Expr --
|
|
------------------------------
|
|
|
|
-- This function is applicable for both static and dynamic allocation of
|
|
-- objects which are constrained by an initial expression. Basically it
|
|
-- transforms an unconstrained subtype indication into a constrained one.
|
|
|
|
-- The expression may also be transformed in certain cases in order to
|
|
-- avoid multiple evaluation. In the static allocation case, the general
|
|
-- scheme is:
|
|
|
|
-- Val : T := Expr;
|
|
|
|
-- is transformed into
|
|
|
|
-- Val : Constrained_Subtype_Of_T := Maybe_Modified_Expr;
|
|
--
|
|
-- Here are the main cases :
|
|
--
|
|
-- <if Expr is a Slice>
|
|
-- Val : T ([Index_Subtype (Expr)]) := Expr;
|
|
--
|
|
-- <elsif Expr is a String Literal>
|
|
-- Val : T (T'First .. T'First + Length (string literal) - 1) := Expr;
|
|
--
|
|
-- <elsif Expr is Constrained>
|
|
-- subtype T is Type_Of_Expr
|
|
-- Val : T := Expr;
|
|
--
|
|
-- <elsif Expr is an entity_name>
|
|
-- Val : T (constraints taken from Expr) := Expr;
|
|
--
|
|
-- <else>
|
|
-- type Axxx is access all T;
|
|
-- Rval : Axxx := Expr'ref;
|
|
-- Val : T (constraints taken from Rval) := Rval.all;
|
|
|
|
-- ??? note: when the Expression is allocated in the secondary stack
|
|
-- we could use it directly instead of copying it by declaring
|
|
-- Val : T (...) renames Rval.all
|
|
|
|
procedure Expand_Subtype_From_Expr
|
|
(N : Node_Id;
|
|
Unc_Type : Entity_Id;
|
|
Subtype_Indic : Node_Id;
|
|
Exp : Node_Id;
|
|
Related_Id : Entity_Id := Empty)
|
|
is
|
|
Loc : constant Source_Ptr := Sloc (N);
|
|
Exp_Typ : constant Entity_Id := Etype (Exp);
|
|
T : Entity_Id;
|
|
|
|
begin
|
|
-- In general we cannot build the subtype if expansion is disabled,
|
|
-- because internal entities may not have been defined. However, to
|
|
-- avoid some cascaded errors, we try to continue when the expression is
|
|
-- an array (or string), because it is safe to compute the bounds. It is
|
|
-- in fact required to do so even in a generic context, because there
|
|
-- may be constants that depend on the bounds of a string literal, both
|
|
-- standard string types and more generally arrays of characters.
|
|
|
|
-- In GNATprove mode, these extra subtypes are not needed, unless Exp is
|
|
-- a static expression. In that case, the subtype will be constrained
|
|
-- while the original type might be unconstrained, so expanding the type
|
|
-- is necessary both for passing legality checks in GNAT and for precise
|
|
-- analysis in GNATprove.
|
|
|
|
if GNATprove_Mode and then not Is_Static_Expression (Exp) then
|
|
return;
|
|
end if;
|
|
|
|
if not Expander_Active
|
|
and then (No (Etype (Exp)) or else not Is_String_Type (Etype (Exp)))
|
|
then
|
|
return;
|
|
end if;
|
|
|
|
if Nkind (Exp) = N_Slice then
|
|
declare
|
|
Slice_Type : constant Entity_Id := Etype (First_Index (Exp_Typ));
|
|
|
|
begin
|
|
Rewrite (Subtype_Indic,
|
|
Make_Subtype_Indication (Loc,
|
|
Subtype_Mark => New_Occurrence_Of (Unc_Type, Loc),
|
|
Constraint =>
|
|
Make_Index_Or_Discriminant_Constraint (Loc,
|
|
Constraints => New_List
|
|
(New_Occurrence_Of (Slice_Type, Loc)))));
|
|
|
|
-- This subtype indication may be used later for constraint checks
|
|
-- we better make sure that if a variable was used as a bound of
|
|
-- the original slice, its value is frozen.
|
|
|
|
Evaluate_Slice_Bounds (Exp);
|
|
end;
|
|
|
|
elsif Ekind (Exp_Typ) = E_String_Literal_Subtype then
|
|
Rewrite (Subtype_Indic,
|
|
Make_Subtype_Indication (Loc,
|
|
Subtype_Mark => New_Occurrence_Of (Unc_Type, Loc),
|
|
Constraint =>
|
|
Make_Index_Or_Discriminant_Constraint (Loc,
|
|
Constraints => New_List (
|
|
Make_Literal_Range (Loc,
|
|
Literal_Typ => Exp_Typ)))));
|
|
|
|
-- If the type of the expression is an internally generated type it
|
|
-- may not be necessary to create a new subtype. However there are two
|
|
-- exceptions: references to the current instances, and aliased array
|
|
-- object declarations for which the back end has to create a template.
|
|
|
|
elsif Is_Constrained (Exp_Typ)
|
|
and then not Is_Class_Wide_Type (Unc_Type)
|
|
and then
|
|
(Nkind (N) /= N_Object_Declaration
|
|
or else not Is_Entity_Name (Expression (N))
|
|
or else not Comes_From_Source (Entity (Expression (N)))
|
|
or else not Is_Array_Type (Exp_Typ)
|
|
or else not Aliased_Present (N))
|
|
then
|
|
if Is_Itype (Exp_Typ) then
|
|
|
|
-- Within an initialization procedure, a selected component
|
|
-- denotes a component of the enclosing record, and it appears as
|
|
-- an actual in a call to its own initialization procedure. If
|
|
-- this component depends on the outer discriminant, we must
|
|
-- generate the proper actual subtype for it.
|
|
|
|
if Nkind (Exp) = N_Selected_Component
|
|
and then Within_Init_Proc
|
|
then
|
|
declare
|
|
Decl : constant Node_Id :=
|
|
Build_Actual_Subtype_Of_Component (Exp_Typ, Exp);
|
|
begin
|
|
if Present (Decl) then
|
|
Insert_Action (N, Decl);
|
|
T := Defining_Identifier (Decl);
|
|
else
|
|
T := Exp_Typ;
|
|
end if;
|
|
end;
|
|
|
|
-- No need to generate a new subtype
|
|
|
|
else
|
|
T := Exp_Typ;
|
|
end if;
|
|
|
|
else
|
|
T := Make_Temporary (Loc, 'T');
|
|
|
|
Insert_Action (N,
|
|
Make_Subtype_Declaration (Loc,
|
|
Defining_Identifier => T,
|
|
Subtype_Indication => New_Occurrence_Of (Exp_Typ, Loc)));
|
|
|
|
-- This type is marked as an itype even though it has an explicit
|
|
-- declaration since otherwise Is_Generic_Actual_Type can get
|
|
-- set, resulting in the generation of spurious errors. (See
|
|
-- sem_ch8.Analyze_Package_Renaming and sem_type.covers)
|
|
|
|
Set_Is_Itype (T);
|
|
Set_Associated_Node_For_Itype (T, Exp);
|
|
end if;
|
|
|
|
Rewrite (Subtype_Indic, New_Occurrence_Of (T, Loc));
|
|
|
|
-- Nothing needs to be done for private types with unknown discriminants
|
|
-- if the underlying type is not an unconstrained composite type or it
|
|
-- is an unchecked union.
|
|
|
|
elsif Is_Private_Type (Unc_Type)
|
|
and then Has_Unknown_Discriminants (Unc_Type)
|
|
and then (not Is_Composite_Type (Underlying_Type (Unc_Type))
|
|
or else Is_Constrained (Underlying_Type (Unc_Type))
|
|
or else Is_Unchecked_Union (Underlying_Type (Unc_Type)))
|
|
then
|
|
null;
|
|
|
|
-- Case of derived type with unknown discriminants where the parent type
|
|
-- also has unknown discriminants.
|
|
|
|
elsif Is_Record_Type (Unc_Type)
|
|
and then not Is_Class_Wide_Type (Unc_Type)
|
|
and then Has_Unknown_Discriminants (Unc_Type)
|
|
and then Has_Unknown_Discriminants (Underlying_Type (Unc_Type))
|
|
then
|
|
-- Nothing to be done if no underlying record view available
|
|
|
|
-- If this is a limited type derived from a type with unknown
|
|
-- discriminants, do not expand either, so that subsequent expansion
|
|
-- of the call can add build-in-place parameters to call.
|
|
|
|
if No (Underlying_Record_View (Unc_Type))
|
|
or else Is_Limited_Type (Unc_Type)
|
|
then
|
|
null;
|
|
|
|
-- Otherwise use the Underlying_Record_View to create the proper
|
|
-- constrained subtype for an object of a derived type with unknown
|
|
-- discriminants.
|
|
|
|
else
|
|
Remove_Side_Effects (Exp);
|
|
Rewrite (Subtype_Indic,
|
|
Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type)));
|
|
end if;
|
|
|
|
-- Renamings of class-wide interface types require no equivalent
|
|
-- constrained type declarations because we only need to reference
|
|
-- the tag component associated with the interface. The same is
|
|
-- presumably true for class-wide types in general, so this test
|
|
-- is broadened to include all class-wide renamings, which also
|
|
-- avoids cases of unbounded recursion in Remove_Side_Effects.
|
|
-- (Is this really correct, or are there some cases of class-wide
|
|
-- renamings that require action in this procedure???)
|
|
|
|
elsif Present (N)
|
|
and then Nkind (N) = N_Object_Renaming_Declaration
|
|
and then Is_Class_Wide_Type (Unc_Type)
|
|
then
|
|
null;
|
|
|
|
-- In Ada 95 nothing to be done if the type of the expression is limited
|
|
-- because in this case the expression cannot be copied, and its use can
|
|
-- only be by reference.
|
|
|
|
-- In Ada 2005 the context can be an object declaration whose expression
|
|
-- is a function that returns in place. If the nominal subtype has
|
|
-- unknown discriminants, the call still provides constraints on the
|
|
-- object, and we have to create an actual subtype from it.
|
|
|
|
-- If the type is class-wide, the expression is dynamically tagged and
|
|
-- we do not create an actual subtype either. Ditto for an interface.
|
|
-- For now this applies only if the type is immutably limited, and the
|
|
-- function being called is build-in-place. This will have to be revised
|
|
-- when build-in-place functions are generalized to other types.
|
|
|
|
elsif Is_Limited_View (Exp_Typ)
|
|
and then
|
|
(Is_Class_Wide_Type (Exp_Typ)
|
|
or else Is_Interface (Exp_Typ)
|
|
or else not Has_Unknown_Discriminants (Exp_Typ)
|
|
or else not Is_Composite_Type (Unc_Type))
|
|
then
|
|
null;
|
|
|
|
-- For limited objects initialized with build-in-place function calls,
|
|
-- nothing to be done; otherwise we prematurely introduce an N_Reference
|
|
-- node in the expression initializing the object, which breaks the
|
|
-- circuitry that detects and adds the additional arguments to the
|
|
-- called function.
|
|
|
|
elsif Is_Build_In_Place_Function_Call (Exp) then
|
|
null;
|
|
|
|
-- If the expression is an uninitialized aggregate, no need to build
|
|
-- a subtype from the expression, because this may require the use of
|
|
-- dynamic memory to create the object.
|
|
|
|
elsif Is_Uninitialized_Aggregate (Exp, Exp_Typ) then
|
|
Rewrite (Subtype_Indic, New_Occurrence_Of (Etype (Exp), Sloc (N)));
|
|
if Nkind (N) = N_Object_Declaration then
|
|
Set_Expression (N, Empty);
|
|
Set_No_Initialization (N);
|
|
end if;
|
|
|
|
else
|
|
Remove_Side_Effects (Exp);
|
|
Rewrite (Subtype_Indic,
|
|
Make_Subtype_From_Expr (Exp, Unc_Type, Related_Id));
|
|
end if;
|
|
end Expand_Subtype_From_Expr;
|
|
|
|
---------------------------------------------
|
|
-- Expression_Contains_Primitives_Calls_Of --
|
|
---------------------------------------------
|
|
|
|
function Expression_Contains_Primitives_Calls_Of
|
|
(Expr : Node_Id;
|
|
Typ : Entity_Id) return Boolean
|
|
is
|
|
U_Typ : constant Entity_Id := Unique_Entity (Typ);
|
|
|
|
Calls_OK : Boolean := False;
|
|
-- This flag is set to True when expression Expr contains at least one
|
|
-- call to a nondispatching primitive function of Typ.
|
|
|
|
function Search_Primitive_Calls (N : Node_Id) return Traverse_Result;
|
|
-- Search for nondispatching calls to primitive functions of type Typ
|
|
|
|
----------------------------
|
|
-- Search_Primitive_Calls --
|
|
----------------------------
|
|
|
|
function Search_Primitive_Calls (N : Node_Id) return Traverse_Result is
|
|
Disp_Typ : Entity_Id;
|
|
Subp : Entity_Id;
|
|
|
|
begin
|
|
-- Detect a function call that could denote a nondispatching
|
|
-- primitive of the input type.
|
|
|
|
if Nkind (N) = N_Function_Call
|
|
and then Is_Entity_Name (Name (N))
|
|
then
|
|
Subp := Entity (Name (N));
|
|
|
|
-- Do not consider function calls with a controlling argument, as
|
|
-- those are always dispatching calls.
|
|
|
|
if Is_Dispatching_Operation (Subp)
|
|
and then No (Controlling_Argument (N))
|
|
then
|
|
Disp_Typ := Find_Dispatching_Type (Subp);
|
|
|
|
-- To qualify as a suitable primitive, the dispatching type of
|
|
-- the function must be the input type.
|
|
|
|
if Present (Disp_Typ)
|
|
and then Unique_Entity (Disp_Typ) = U_Typ
|
|
then
|
|
Calls_OK := True;
|
|
|
|
-- There is no need to continue the traversal, as one such
|
|
-- call suffices.
|
|
|
|
return Abandon;
|
|
end if;
|
|
end if;
|
|
end if;
|
|
|
|
return OK;
|
|
end Search_Primitive_Calls;
|
|
|
|
procedure Search_Calls is new Traverse_Proc (Search_Primitive_Calls);
|
|
|
|
-- Start of processing for Expression_Contains_Primitives_Calls_Of_Type
|
|
|
|
begin
|
|
Search_Calls (Expr);
|
|
return Calls_OK;
|
|
end Expression_Contains_Primitives_Calls_Of;
|
|
|
|
----------------------
|
|
-- Finalize_Address --
|
|
----------------------
|
|
|
|
function Finalize_Address (Typ : Entity_Id) return Entity_Id is
|
|
Btyp : constant Entity_Id := Base_Type (Typ);
|
|
Utyp : Entity_Id := Typ;
|
|
|
|
begin
|
|
-- Handle protected class-wide or task class-wide types
|
|
|
|
if Is_Class_Wide_Type (Utyp) then
|
|
if Is_Concurrent_Type (Root_Type (Utyp)) then
|
|
Utyp := Root_Type (Utyp);
|
|
|
|
elsif Is_Private_Type (Root_Type (Utyp))
|
|
and then Present (Full_View (Root_Type (Utyp)))
|
|
and then Is_Concurrent_Type (Full_View (Root_Type (Utyp)))
|
|
then
|
|
Utyp := Full_View (Root_Type (Utyp));
|
|
end if;
|
|
end if;
|
|
|
|
-- Handle private types
|
|
|
|
if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then
|
|
Utyp := Full_View (Utyp);
|
|
end if;
|
|
|
|
-- Handle protected and task types
|
|
|
|
if Is_Concurrent_Type (Utyp)
|
|
and then Present (Corresponding_Record_Type (Utyp))
|
|
then
|
|
Utyp := Corresponding_Record_Type (Utyp);
|
|
end if;
|
|
|
|
Utyp := Underlying_Type (Base_Type (Utyp));
|
|
|
|
-- Deal with untagged derivation of private views. If the parent is
|
|
-- now known to be protected, the finalization routine is the one
|
|
-- defined on the corresponding record of the ancestor (corresponding
|
|
-- records do not automatically inherit operations, but maybe they
|
|
-- should???)
|
|
|
|
if Is_Untagged_Derivation (Btyp) then
|
|
if Is_Protected_Type (Btyp) then
|
|
Utyp := Corresponding_Record_Type (Root_Type (Btyp));
|
|
|
|
else
|
|
Utyp := Underlying_Type (Root_Type (Btyp));
|
|
|
|
if Is_Protected_Type (Utyp) then
|
|
Utyp := Corresponding_Record_Type (Utyp);
|
|
end if;
|
|
end if;
|
|
end if;
|
|
|
|
-- If the underlying_type is a subtype, we are dealing with the
|
|
-- completion of a private type. We need to access the base type and
|
|
-- generate a conversion to it.
|
|
|
|
if Utyp /= Base_Type (Utyp) then
|
|
pragma Assert (Is_Private_Type (Typ));
|
|
|
|
Utyp := Base_Type (Utyp);
|
|
end if;
|
|
|
|
-- When dealing with an internally built full view for a type with
|
|
-- unknown discriminants, use the original record type.
|
|
|
|
if Is_Underlying_Record_View (Utyp) then
|
|
Utyp := Etype (Utyp);
|
|
end if;
|
|
|
|
return TSS (Utyp, TSS_Finalize_Address);
|
|
end Finalize_Address;
|
|
|
|
------------------------
|
|
-- Find_Interface_ADT --
|
|
------------------------
|
|
|
|
function Find_Interface_ADT
|
|
(T : Entity_Id;
|
|
Iface : Entity_Id) return Elmt_Id
|
|
is
|
|
ADT : Elmt_Id;
|
|
Typ : Entity_Id := T;
|
|
|
|
begin
|
|
pragma Assert (Is_Interface (Iface));
|
|
|
|
-- Handle private types
|
|
|
|
if Has_Private_Declaration (Typ) and then Present (Full_View (Typ)) then
|
|
Typ := Full_View (Typ);
|
|
end if;
|
|
|
|
-- Handle access types
|
|
|
|
if Is_Access_Type (Typ) then
|
|
Typ := Designated_Type (Typ);
|
|
end if;
|
|
|
|
-- Handle task and protected types implementing interfaces
|
|
|
|
if Is_Concurrent_Type (Typ) then
|
|
Typ := Corresponding_Record_Type (Typ);
|
|
end if;
|
|
|
|
pragma Assert
|
|
(not Is_Class_Wide_Type (Typ)
|
|
and then Ekind (Typ) /= E_Incomplete_Type);
|
|
|
|
if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
|
|
return First_Elmt (Access_Disp_Table (Typ));
|
|
|
|
else
|
|
ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
|
|
while Present (ADT)
|
|
and then Present (Related_Type (Node (ADT)))
|
|
and then Related_Type (Node (ADT)) /= Iface
|
|
and then not Is_Ancestor (Iface, Related_Type (Node (ADT)),
|
|
Use_Full_View => True)
|
|
loop
|
|
Next_Elmt (ADT);
|
|
end loop;
|
|
|
|
pragma Assert (Present (Related_Type (Node (ADT))));
|
|
return ADT;
|
|
end if;
|
|
end Find_Interface_ADT;
|
|
|
|
------------------------
|
|
-- Find_Interface_Tag --
|
|
------------------------
|
|
|
|
function Find_Interface_Tag
|
|
(T : Entity_Id;
|
|
Iface : Entity_Id) return Entity_Id
|
|
is
|
|
AI_Tag : Entity_Id := Empty;
|
|
Found : Boolean := False;
|
|
Typ : Entity_Id := T;
|
|
|
|
procedure Find_Tag (Typ : Entity_Id);
|
|
-- Internal subprogram used to recursively climb to the ancestors
|
|
|
|
--------------
|
|
-- Find_Tag --
|
|
--------------
|
|
|
|
procedure Find_Tag (Typ : Entity_Id) is
|
|
AI_Elmt : Elmt_Id;
|
|
AI : Node_Id;
|
|
|
|
begin
|
|
-- This routine does not handle the case in which the interface is an
|
|
-- ancestor of Typ. That case is handled by the enclosing subprogram.
|
|
|
|
pragma Assert (Typ /= Iface);
|
|
|
|
-- Climb to the root type handling private types
|
|
|
|
if Present (Full_View (Etype (Typ))) then
|
|
if Full_View (Etype (Typ)) /= Typ then
|
|
Find_Tag (Full_View (Etype (Typ)));
|
|
end if;
|
|
|
|
elsif Etype (Typ) /= Typ then
|
|
Find_Tag (Etype (Typ));
|
|
end if;
|
|
|
|
-- Traverse the list of interfaces implemented by the type
|
|
|
|
if not Found
|
|
and then Present (Interfaces (Typ))
|
|
and then not (Is_Empty_Elmt_List (Interfaces (Typ)))
|
|
then
|
|
-- Skip the tag associated with the primary table
|
|
|
|
AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
|
|
pragma Assert (Present (AI_Tag));
|
|
|
|
AI_Elmt := First_Elmt (Interfaces (Typ));
|
|
while Present (AI_Elmt) loop
|
|
AI := Node (AI_Elmt);
|
|
|
|
if AI = Iface
|
|
or else Is_Ancestor (Iface, AI, Use_Full_View => True)
|
|
then
|
|
Found := True;
|
|
return;
|
|
end if;
|
|
|
|
AI_Tag := Next_Tag_Component (AI_Tag);
|
|
Next_Elmt (AI_Elmt);
|
|
end loop;
|
|
end if;
|
|
end Find_Tag;
|
|
|
|
-- Start of processing for Find_Interface_Tag
|
|
|
|
begin
|
|
pragma Assert (Is_Interface (Iface));
|
|
|
|
-- Handle access types
|
|
|
|
if Is_Access_Type (Typ) then
|
|
Typ := Designated_Type (Typ);
|
|
end if;
|
|
|
|
-- Handle class-wide types
|
|
|
|
if Is_Class_Wide_Type (Typ) then
|
|
Typ := Root_Type (Typ);
|
|
end if;
|
|
|
|
-- Handle private types
|
|
|
|
if Has_Private_Declaration (Typ) and then Present (Full_View (Typ)) then
|
|
Typ := Full_View (Typ);
|
|
end if;
|
|
|
|
-- Handle entities from the limited view
|
|
|
|
if Ekind (Typ) = E_Incomplete_Type then
|
|
pragma Assert (Present (Non_Limited_View (Typ)));
|
|
Typ := Non_Limited_View (Typ);
|
|
end if;
|
|
|
|
-- Handle task and protected types implementing interfaces
|
|
|
|
if Is_Concurrent_Type (Typ) then
|
|
Typ := Corresponding_Record_Type (Typ);
|
|
end if;
|
|
|
|
-- If the interface is an ancestor of the type, then it shared the
|
|
-- primary dispatch table.
|
|
|
|
if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
|
|
return First_Tag_Component (Typ);
|
|
|
|
-- Otherwise we need to search for its associated tag component
|
|
|
|
else
|
|
Find_Tag (Typ);
|
|
return AI_Tag;
|
|
end if;
|
|
end Find_Interface_Tag;
|
|
|
|
---------------------------
|
|
-- Find_Optional_Prim_Op --
|
|
---------------------------
|
|
|
|
function Find_Optional_Prim_Op
|
|
(T : Entity_Id; Name : Name_Id) return Entity_Id
|
|
is
|
|
Prim : Elmt_Id;
|
|
Typ : Entity_Id := T;
|
|
Op : Entity_Id;
|
|
|
|
begin
|
|
if Is_Class_Wide_Type (Typ) then
|
|
Typ := Root_Type (Typ);
|
|
end if;
|
|
|
|
Typ := Underlying_Type (Typ);
|
|
|
|
-- Loop through primitive operations
|
|
|
|
Prim := First_Elmt (Primitive_Operations (Typ));
|
|
while Present (Prim) loop
|
|
Op := Node (Prim);
|
|
|
|
-- We can retrieve primitive operations by name if it is an internal
|
|
-- name. For equality we must check that both of its operands have
|
|
-- the same type, to avoid confusion with user-defined equalities
|
|
-- than may have a asymmetric signature.
|
|
|
|
exit when Chars (Op) = Name
|
|
and then
|
|
(Name /= Name_Op_Eq
|
|
or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op)));
|
|
|
|
Next_Elmt (Prim);
|
|
end loop;
|
|
|
|
return Node (Prim); -- Empty if not found
|
|
end Find_Optional_Prim_Op;
|
|
|
|
---------------------------
|
|
-- Find_Optional_Prim_Op --
|
|
---------------------------
|
|
|
|
function Find_Optional_Prim_Op
|
|
(T : Entity_Id;
|
|
Name : TSS_Name_Type) return Entity_Id
|
|
is
|
|
Inher_Op : Entity_Id := Empty;
|
|
Own_Op : Entity_Id := Empty;
|
|
Prim_Elmt : Elmt_Id;
|
|
Prim_Id : Entity_Id;
|
|
Typ : Entity_Id := T;
|
|
|
|
begin
|
|
if Is_Class_Wide_Type (Typ) then
|
|
Typ := Root_Type (Typ);
|
|
end if;
|
|
|
|
Typ := Underlying_Type (Typ);
|
|
|
|
-- This search is based on the assertion that the dispatching version
|
|
-- of the TSS routine always precedes the real primitive.
|
|
|
|
Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
|
|
while Present (Prim_Elmt) loop
|
|
Prim_Id := Node (Prim_Elmt);
|
|
|
|
if Is_TSS (Prim_Id, Name) then
|
|
if Present (Alias (Prim_Id)) then
|
|
Inher_Op := Prim_Id;
|
|
else
|
|
Own_Op := Prim_Id;
|
|
end if;
|
|
end if;
|
|
|
|
Next_Elmt (Prim_Elmt);
|
|
end loop;
|
|
|
|
if Present (Own_Op) then
|
|
return Own_Op;
|
|
elsif Present (Inher_Op) then
|
|
return Inher_Op;
|
|
else
|
|
return Empty;
|
|
end if;
|
|
end Find_Optional_Prim_Op;
|
|
|
|
------------------
|
|
-- Find_Prim_Op --
|
|
------------------
|
|
|
|
function Find_Prim_Op
|
|
(T : Entity_Id; Name : Name_Id) return Entity_Id
|
|
is
|
|
Result : constant Entity_Id := Find_Optional_Prim_Op (T, Name);
|
|
begin
|
|
if No (Result) then
|
|
raise Program_Error;
|
|
end if;
|
|
|
|
return Result;
|
|
end Find_Prim_Op;
|
|
|
|
------------------
|
|
-- Find_Prim_Op --
|
|
------------------
|
|
|
|
function Find_Prim_Op
|
|
(T : Entity_Id;
|
|
Name : TSS_Name_Type) return Entity_Id
|
|
is
|
|
Result : constant Entity_Id := Find_Optional_Prim_Op (T, Name);
|
|
begin
|
|
if No (Result) then
|
|
raise Program_Error;
|
|
end if;
|
|
|
|
return Result;
|
|
end Find_Prim_Op;
|
|
|
|
----------------------------
|
|
-- Find_Protection_Object --
|
|
----------------------------
|
|
|
|
function Find_Protection_Object (Scop : Entity_Id) return Entity_Id is
|
|
S : Entity_Id;
|
|
|
|
begin
|
|
S := Scop;
|
|
while Present (S) loop
|
|
if Ekind (S) in E_Entry | E_Entry_Family | E_Function | E_Procedure
|
|
and then Present (Protection_Object (S))
|
|
then
|
|
return Protection_Object (S);
|
|
end if;
|
|
|
|
S := Scope (S);
|
|
end loop;
|
|
|
|
-- If we do not find a Protection object in the scope chain, then
|
|
-- something has gone wrong, most likely the object was never created.
|
|
|
|
raise Program_Error;
|
|
end Find_Protection_Object;
|
|
|
|
--------------------------
|
|
-- Find_Protection_Type --
|
|
--------------------------
|
|
|
|
function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id is
|
|
Comp : Entity_Id;
|
|
Typ : Entity_Id := Conc_Typ;
|
|
|
|
begin
|
|
if Is_Concurrent_Type (Typ) then
|
|
Typ := Corresponding_Record_Type (Typ);
|
|
end if;
|
|
|
|
-- Since restriction violations are not considered serious errors, the
|
|
-- expander remains active, but may leave the corresponding record type
|
|
-- malformed. In such cases, component _object is not available so do
|
|
-- not look for it.
|
|
|
|
if not Analyzed (Typ) then
|
|
return Empty;
|
|
end if;
|
|
|
|
Comp := First_Component (Typ);
|
|
while Present (Comp) loop
|
|
if Chars (Comp) = Name_uObject then
|
|
return Base_Type (Etype (Comp));
|
|
end if;
|
|
|
|
Next_Component (Comp);
|
|
end loop;
|
|
|
|
-- The corresponding record of a protected type should always have an
|
|
-- _object field.
|
|
|
|
raise Program_Error;
|
|
end Find_Protection_Type;
|
|
|
|
function Find_Storage_Op
|
|
(Typ : Entity_Id;
|
|
Nam : Name_Id) return Entity_Id
|
|
is
|
|
use Sem_Util.Storage_Model_Support;
|
|
|
|
begin
|
|
if Has_Storage_Model_Type_Aspect (Typ) then
|
|
declare
|
|
SMT_Op : constant Entity_Id :=
|
|
Get_Storage_Model_Type_Entity (Typ, Nam);
|
|
begin
|
|
if not Present (SMT_Op) then
|
|
raise Program_Error;
|
|
else
|
|
return SMT_Op;
|
|
end if;
|
|
end;
|
|
|
|
-- Otherwise we assume that Typ is a descendant of Root_Storage_Pool
|
|
|
|
else
|
|
return Find_Prim_Op (Typ, Nam);
|
|
end if;
|
|
end Find_Storage_Op;
|
|
|
|
-----------------------
|
|
-- Find_Hook_Context --
|
|
-----------------------
|
|
|
|
function Find_Hook_Context (N : Node_Id) return Node_Id is
|
|
Par : Node_Id;
|
|
Top : Node_Id;
|
|
|
|
Wrapped_Node : Node_Id;
|
|
-- Note: if we are in a transient scope, we want to reuse it as
|
|
-- the context for actions insertion, if possible. But if N is itself
|
|
-- part of the stored actions for the current transient scope,
|
|
-- then we need to insert at the appropriate (inner) location in
|
|
-- the not as an action on Node_To_Be_Wrapped.
|
|
|
|
In_Cond_Expr : constant Boolean := Within_Case_Or_If_Expression (N);
|
|
|
|
begin
|
|
-- When the node is inside a case/if expression, the lifetime of any
|
|
-- temporary controlled object is extended. Find a suitable insertion
|
|
-- node by locating the topmost case or if expressions.
|
|
|
|
if In_Cond_Expr then
|
|
Par := N;
|
|
Top := N;
|
|
while Present (Par) loop
|
|
if Nkind (Original_Node (Par)) in
|
|
N_Case_Expression | N_If_Expression
|
|
then
|
|
Top := Par;
|
|
|
|
-- Prevent the search from going too far
|
|
|
|
elsif Is_Body_Or_Package_Declaration (Par) then
|
|
exit;
|
|
end if;
|
|
|
|
Par := Parent (Par);
|
|
end loop;
|
|
|
|
-- The topmost case or if expression is now recovered, but it may
|
|
-- still not be the correct place to add generated code. Climb to
|
|
-- find a parent that is part of a declarative or statement list,
|
|
-- and is not a list of actuals in a call.
|
|
|
|
Par := Top;
|
|
while Present (Par) loop
|
|
if Is_List_Member (Par)
|
|
and then Nkind (Par) not in N_Component_Association
|
|
| N_Discriminant_Association
|
|
| N_Parameter_Association
|
|
| N_Pragma_Argument_Association
|
|
| N_Aggregate
|
|
| N_Delta_Aggregate
|
|
| N_Extension_Aggregate
|
|
and then Nkind (Parent (Par)) not in N_Function_Call
|
|
| N_Procedure_Call_Statement
|
|
| N_Entry_Call_Statement
|
|
|
|
then
|
|
return Par;
|
|
|
|
-- Prevent the search from going too far
|
|
|
|
elsif Is_Body_Or_Package_Declaration (Par) then
|
|
exit;
|
|
end if;
|
|
|
|
Par := Parent (Par);
|
|
end loop;
|
|
|
|
return Par;
|
|
|
|
else
|
|
Par := N;
|
|
while Present (Par) loop
|
|
|
|
-- Keep climbing past various operators
|
|
|
|
if Nkind (Parent (Par)) in N_Op
|
|
or else Nkind (Parent (Par)) in N_And_Then | N_Or_Else
|
|
then
|
|
Par := Parent (Par);
|
|
else
|
|
exit;
|
|
end if;
|
|
end loop;
|
|
|
|
Top := Par;
|
|
|
|
-- The node may be located in a pragma in which case return the
|
|
-- pragma itself:
|
|
|
|
-- pragma Precondition (... and then Ctrl_Func_Call ...);
|
|
|
|
-- Similar case occurs when the node is related to an object
|
|
-- declaration or assignment:
|
|
|
|
-- Obj [: Some_Typ] := ... and then Ctrl_Func_Call ...;
|
|
|
|
-- Another case to consider is when the node is part of a return
|
|
-- statement:
|
|
|
|
-- return ... and then Ctrl_Func_Call ...;
|
|
|
|
-- Another case is when the node acts as a formal in a procedure
|
|
-- call statement:
|
|
|
|
-- Proc (... and then Ctrl_Func_Call ...);
|
|
|
|
if Scope_Is_Transient then
|
|
Wrapped_Node := Node_To_Be_Wrapped;
|
|
else
|
|
Wrapped_Node := Empty;
|
|
end if;
|
|
|
|
while Present (Par) loop
|
|
if Par = Wrapped_Node
|
|
or else Nkind (Par) in N_Assignment_Statement
|
|
| N_Object_Declaration
|
|
| N_Pragma
|
|
| N_Procedure_Call_Statement
|
|
| N_Simple_Return_Statement
|
|
then
|
|
return Par;
|
|
|
|
-- Prevent the search from going too far
|
|
|
|
elsif Is_Body_Or_Package_Declaration (Par) then
|
|
exit;
|
|
end if;
|
|
|
|
Par := Parent (Par);
|
|
end loop;
|
|
|
|
-- Return the topmost short circuit operator
|
|
|
|
return Top;
|
|
end if;
|
|
end Find_Hook_Context;
|
|
|
|
------------------------------
|
|
-- Following_Address_Clause --
|
|
------------------------------
|
|
|
|
function Following_Address_Clause (D : Node_Id) return Node_Id is
|
|
Id : constant Entity_Id := Defining_Identifier (D);
|
|
Result : Node_Id;
|
|
Par : Node_Id;
|
|
|
|
function Check_Decls (D : Node_Id) return Node_Id;
|
|
-- This internal function differs from the main function in that it
|
|
-- gets called to deal with a following package private part, and
|
|
-- it checks declarations starting with D (the main function checks
|
|
-- declarations following D). If D is Empty, then Empty is returned.
|
|
|
|
-----------------
|
|
-- Check_Decls --
|
|
-----------------
|
|
|
|
function Check_Decls (D : Node_Id) return Node_Id is
|
|
Decl : Node_Id;
|
|
|
|
begin
|
|
Decl := D;
|
|
while Present (Decl) loop
|
|
if Nkind (Decl) = N_At_Clause
|
|
and then Chars (Identifier (Decl)) = Chars (Id)
|
|
then
|
|
return Decl;
|
|
|
|
elsif Nkind (Decl) = N_Attribute_Definition_Clause
|
|
and then Chars (Decl) = Name_Address
|
|
and then Chars (Name (Decl)) = Chars (Id)
|
|
then
|
|
return Decl;
|
|
end if;
|
|
|
|
Next (Decl);
|
|
end loop;
|
|
|
|
-- Otherwise not found, return Empty
|
|
|
|
return Empty;
|
|
end Check_Decls;
|
|
|
|
-- Start of processing for Following_Address_Clause
|
|
|
|
begin
|
|
-- If parser detected no address clause for the identifier in question,
|
|
-- then the answer is a quick NO, without the need for a search.
|
|
|
|
if not Get_Name_Table_Boolean1 (Chars (Id)) then
|
|
return Empty;
|
|
end if;
|
|
|
|
-- Otherwise search current declarative unit
|
|
|
|
Result := Check_Decls (Next (D));
|
|
|
|
if Present (Result) then
|
|
return Result;
|
|
end if;
|
|
|
|
-- Check for possible package private part following
|
|
|
|
Par := Parent (D);
|
|
|
|
if Nkind (Par) = N_Package_Specification
|
|
and then Visible_Declarations (Par) = List_Containing (D)
|
|
and then Present (Private_Declarations (Par))
|
|
then
|
|
-- Private part present, check declarations there
|
|
|
|
return Check_Decls (First (Private_Declarations (Par)));
|
|
|
|
else
|
|
-- No private part, clause not found, return Empty
|
|
|
|
return Empty;
|
|
end if;
|
|
end Following_Address_Clause;
|
|
|
|
----------------------
|
|
-- Force_Evaluation --
|
|
----------------------
|
|
|
|
procedure Force_Evaluation
|
|
(Exp : Node_Id;
|
|
Name_Req : Boolean := False;
|
|
Related_Id : Entity_Id := Empty;
|
|
Is_Low_Bound : Boolean := False;
|
|
Is_High_Bound : Boolean := False;
|
|
Discr_Number : Int := 0;
|
|
Mode : Force_Evaluation_Mode := Relaxed)
|
|
is
|
|
begin
|
|
Remove_Side_Effects
|
|
(Exp => Exp,
|
|
Name_Req => Name_Req,
|
|
Variable_Ref => True,
|
|
Renaming_Req => False,
|
|
Related_Id => Related_Id,
|
|
Is_Low_Bound => Is_Low_Bound,
|
|
Is_High_Bound => Is_High_Bound,
|
|
Discr_Number => Discr_Number,
|
|
Check_Side_Effects =>
|
|
Is_Static_Expression (Exp)
|
|
or else Mode = Relaxed);
|
|
end Force_Evaluation;
|
|
|
|
---------------------------------
|
|
-- Fully_Qualified_Name_String --
|
|
---------------------------------
|
|
|
|
function Fully_Qualified_Name_String
|
|
(E : Entity_Id;
|
|
Append_NUL : Boolean := True) return String_Id
|
|
is
|
|
procedure Internal_Full_Qualified_Name (E : Entity_Id);
|
|
-- Compute recursively the qualified name without NUL at the end, adding
|
|
-- it to the currently started string being generated
|
|
|
|
----------------------------------
|
|
-- Internal_Full_Qualified_Name --
|
|
----------------------------------
|
|
|
|
procedure Internal_Full_Qualified_Name (E : Entity_Id) is
|
|
Ent : Entity_Id;
|
|
|
|
begin
|
|
-- Deal properly with child units
|
|
|
|
if Nkind (E) = N_Defining_Program_Unit_Name then
|
|
Ent := Defining_Identifier (E);
|
|
else
|
|
Ent := E;
|
|
end if;
|
|
|
|
-- Compute qualification recursively (only "Standard" has no scope)
|
|
|
|
if Present (Scope (Scope (Ent))) then
|
|
Internal_Full_Qualified_Name (Scope (Ent));
|
|
Store_String_Char (Get_Char_Code ('.'));
|
|
end if;
|
|
|
|
-- Every entity should have a name except some expanded blocks
|
|
-- don't bother about those.
|
|
|
|
if Chars (Ent) = No_Name then
|
|
return;
|
|
end if;
|
|
|
|
-- Generates the entity name in upper case
|
|
|
|
Get_Decoded_Name_String (Chars (Ent));
|
|
Set_All_Upper_Case;
|
|
Store_String_Chars (Name_Buffer (1 .. Name_Len));
|
|
return;
|
|
end Internal_Full_Qualified_Name;
|
|
|
|
-- Start of processing for Full_Qualified_Name
|
|
|
|
begin
|
|
Start_String;
|
|
Internal_Full_Qualified_Name (E);
|
|
|
|
if Append_NUL then
|
|
Store_String_Char (Get_Char_Code (ASCII.NUL));
|
|
end if;
|
|
|
|
return End_String;
|
|
end Fully_Qualified_Name_String;
|
|
|
|
---------------------------------
|
|
-- Get_Current_Value_Condition --
|
|
---------------------------------
|
|
|
|
-- Note: the implementation of this procedure is very closely tied to the
|
|
-- implementation of Set_Current_Value_Condition. In the Get procedure, we
|
|
-- interpret Current_Value fields set by the Set procedure, so the two
|
|
-- procedures need to be closely coordinated.
|
|
|
|
procedure Get_Current_Value_Condition
|
|
(Var : Node_Id;
|
|
Op : out Node_Kind;
|
|
Val : out Node_Id)
|
|
is
|
|
Loc : constant Source_Ptr := Sloc (Var);
|
|
Ent : constant Entity_Id := Entity (Var);
|
|
|
|
procedure Process_Current_Value_Condition (N : Node_Id; S : Boolean);
|
|
-- N is an expression which holds either True (S = True) or False (S =
|
|
-- False) in the condition. This procedure digs out the expression and
|
|
-- if it refers to Ent, sets Op and Val appropriately.
|
|
|
|
-------------------------------------
|
|
-- Process_Current_Value_Condition --
|
|
-------------------------------------
|
|
|
|
procedure Process_Current_Value_Condition
|
|
(N : Node_Id;
|
|
S : Boolean)
|
|
is
|
|
Cond : Node_Id;
|
|
Prev_Cond : Node_Id;
|
|
Sens : Boolean;
|
|
|
|
begin
|
|
Cond := N;
|
|
Sens := S;
|
|
|
|
loop
|
|
Prev_Cond := Cond;
|
|
|
|
-- Deal with NOT operators, inverting sense
|
|
|
|
while Nkind (Cond) = N_Op_Not loop
|
|
Cond := Right_Opnd (Cond);
|
|
Sens := not Sens;
|
|
end loop;
|
|
|
|
-- Deal with conversions, qualifications, and expressions with
|
|
-- actions.
|
|
|
|
while Nkind (Cond) in N_Type_Conversion
|
|
| N_Qualified_Expression
|
|
| N_Expression_With_Actions
|
|
loop
|
|
Cond := Expression (Cond);
|
|
end loop;
|
|
|
|
exit when Cond = Prev_Cond;
|
|
end loop;
|
|
|
|
-- Deal with AND THEN and AND cases
|
|
|
|
if Nkind (Cond) in N_And_Then | N_Op_And then
|
|
|
|
-- Don't ever try to invert a condition that is of the form of an
|
|
-- AND or AND THEN (since we are not doing sufficiently general
|
|
-- processing to allow this).
|
|
|
|
if Sens = False then
|
|
Op := N_Empty;
|
|
Val := Empty;
|
|
return;
|
|
end if;
|
|
|
|
-- Recursively process AND and AND THEN branches
|
|
|
|
Process_Current_Value_Condition (Left_Opnd (Cond), True);
|
|
pragma Assert (Op'Valid);
|
|
|
|
if Op /= N_Empty then
|
|
return;
|
|
end if;
|
|
|
|
Process_Current_Value_Condition (Right_Opnd (Cond), True);
|
|
return;
|
|
|
|
-- Case of relational operator
|
|
|
|
elsif Nkind (Cond) in N_Op_Compare then
|
|
Op := Nkind (Cond);
|
|
|
|
-- Invert sense of test if inverted test
|
|
|
|
if Sens = False then
|
|
case Op is
|
|
when N_Op_Eq => Op := N_Op_Ne;
|
|
when N_Op_Ne => Op := N_Op_Eq;
|
|
when N_Op_Lt => Op := N_Op_Ge;
|
|
when N_Op_Gt => Op := N_Op_Le;
|
|
when N_Op_Le => Op := N_Op_Gt;
|
|
when N_Op_Ge => Op := N_Op_Lt;
|
|
when others => raise Program_Error;
|
|
end case;
|
|
end if;
|
|
|
|
-- Case of entity op value
|
|
|
|
if Is_Entity_Name (Left_Opnd (Cond))
|
|
and then Ent = Entity (Left_Opnd (Cond))
|
|
and then Compile_Time_Known_Value (Right_Opnd (Cond))
|
|
then
|
|
Val := Right_Opnd (Cond);
|
|
|
|
-- Case of value op entity
|
|
|
|
elsif Is_Entity_Name (Right_Opnd (Cond))
|
|
and then Ent = Entity (Right_Opnd (Cond))
|
|
and then Compile_Time_Known_Value (Left_Opnd (Cond))
|
|
then
|
|
Val := Left_Opnd (Cond);
|
|
|
|
-- We are effectively swapping operands
|
|
|
|
case Op is
|
|
when N_Op_Eq => null;
|
|
when N_Op_Ne => null;
|
|
when N_Op_Lt => Op := N_Op_Gt;
|
|
when N_Op_Gt => Op := N_Op_Lt;
|
|
when N_Op_Le => Op := N_Op_Ge;
|
|
when N_Op_Ge => Op := N_Op_Le;
|
|
when others => raise Program_Error;
|
|
end case;
|
|
|
|
else
|
|
Op := N_Empty;
|
|
end if;
|
|
|
|
return;
|
|
|
|
elsif Nkind (Cond) in N_Type_Conversion
|
|
| N_Qualified_Expression
|
|
| N_Expression_With_Actions
|
|
then
|
|
Cond := Expression (Cond);
|
|
|
|
-- Case of Boolean variable reference, return as though the
|
|
-- reference had said var = True.
|
|
|
|
else
|
|
if Is_Entity_Name (Cond) and then Ent = Entity (Cond) then
|
|
Val := New_Occurrence_Of (Standard_True, Sloc (Cond));
|
|
|
|
if Sens = False then
|
|
Op := N_Op_Ne;
|
|
else
|
|
Op := N_Op_Eq;
|
|
end if;
|
|
end if;
|
|
end if;
|
|
end Process_Current_Value_Condition;
|
|
|
|
-- Start of processing for Get_Current_Value_Condition
|
|
|
|
begin
|
|
Op := N_Empty;
|
|
Val := Empty;
|
|
|
|
-- Immediate return, nothing doing, if this is not an object
|
|
|
|
if not Is_Object (Ent) then
|
|
return;
|
|
end if;
|
|
|
|
-- In GNATprove mode we don't want to use current value optimizer, in
|
|
-- particular for loop invariant expressions and other assertions that
|
|
-- act as cut points for proof. The optimizer often folds expressions
|
|
-- into True/False where they trivially follow from the previous
|
|
-- assignments, but this deprives proof from the information needed to
|
|
-- discharge checks that are beyond the scope of the value optimizer.
|
|
|
|
if GNATprove_Mode then
|
|
return;
|
|
end if;
|
|
|
|
-- Otherwise examine current value
|
|
|
|
declare
|
|
CV : constant Node_Id := Current_Value (Ent);
|
|
Sens : Boolean;
|
|
Stm : Node_Id;
|
|
|
|
begin
|
|
-- If statement. Condition is known true in THEN section, known False
|
|
-- in any ELSIF or ELSE part, and unknown outside the IF statement.
|
|
|
|
if Nkind (CV) = N_If_Statement then
|
|
|
|
-- Before start of IF statement
|
|
|
|
if Loc < Sloc (CV) then
|
|
return;
|
|
|
|
-- After end of IF statement
|
|
|
|
elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then
|
|
return;
|
|
end if;
|
|
|
|
-- At this stage we know that we are within the IF statement, but
|
|
-- unfortunately, the tree does not record the SLOC of the ELSE so
|
|
-- we cannot use a simple SLOC comparison to distinguish between
|
|
-- the then/else statements, so we have to climb the tree.
|
|
|
|
declare
|
|
N : Node_Id;
|
|
|
|
begin
|
|
N := Parent (Var);
|
|
while Parent (N) /= CV loop
|
|
N := Parent (N);
|
|
|
|
-- If we fall off the top of the tree, then that's odd, but
|
|
-- perhaps it could occur in some error situation, and the
|
|
-- safest response is simply to assume that the outcome of
|
|
-- the condition is unknown. No point in bombing during an
|
|
-- attempt to optimize things.
|
|
|
|
if No (N) then
|
|
return;
|
|
end if;
|
|
end loop;
|
|
|
|
-- Now we have N pointing to a node whose parent is the IF
|
|
-- statement in question, so now we can tell if we are within
|
|
-- the THEN statements.
|
|
|
|
if Is_List_Member (N)
|
|
and then List_Containing (N) = Then_Statements (CV)
|
|
then
|
|
Sens := True;
|
|
|
|
-- If the variable reference does not come from source, we
|
|
-- cannot reliably tell whether it appears in the else part.
|
|
-- In particular, if it appears in generated code for a node
|
|
-- that requires finalization, it may be attached to a list
|
|
-- that has not been yet inserted into the code. For now,
|
|
-- treat it as unknown.
|
|
|
|
elsif not Comes_From_Source (N) then
|
|
return;
|
|
|
|
-- Otherwise we must be in ELSIF or ELSE part
|
|
|
|
else
|
|
Sens := False;
|
|
end if;
|
|
end;
|
|
|
|
-- ELSIF part. Condition is known true within the referenced
|
|
-- ELSIF, known False in any subsequent ELSIF or ELSE part,
|
|
-- and unknown before the ELSE part or after the IF statement.
|
|
|
|
elsif Nkind (CV) = N_Elsif_Part then
|
|
|
|
-- if the Elsif_Part had condition_actions, the elsif has been
|
|
-- rewritten as a nested if, and the original elsif_part is
|
|
-- detached from the tree, so there is no way to obtain useful
|
|
-- information on the current value of the variable.
|
|
-- Can this be improved ???
|
|
|
|
if No (Parent (CV)) then
|
|
return;
|
|
end if;
|
|
|
|
Stm := Parent (CV);
|
|
|
|
-- If the tree has been otherwise rewritten there is nothing
|
|
-- else to be done either.
|
|
|
|
if Nkind (Stm) /= N_If_Statement then
|
|
return;
|
|
end if;
|
|
|
|
-- Before start of ELSIF part
|
|
|
|
if Loc < Sloc (CV) then
|
|
return;
|
|
|
|
-- After end of IF statement
|
|
|
|
elsif Loc >= Sloc (Stm) +
|
|
Text_Ptr (UI_To_Int (End_Span (Stm)))
|
|
then
|
|
return;
|
|
end if;
|
|
|
|
-- Again we lack the SLOC of the ELSE, so we need to climb the
|
|
-- tree to see if we are within the ELSIF part in question.
|
|
|
|
declare
|
|
N : Node_Id;
|
|
|
|
begin
|
|
N := Parent (Var);
|
|
while Parent (N) /= Stm loop
|
|
N := Parent (N);
|
|
|
|
-- If we fall off the top of the tree, then that's odd, but
|
|
-- perhaps it could occur in some error situation, and the
|
|
-- safest response is simply to assume that the outcome of
|
|
-- the condition is unknown. No point in bombing during an
|
|
-- attempt to optimize things.
|
|
|
|
if No (N) then
|
|
return;
|
|
end if;
|
|
end loop;
|
|
|
|
-- Now we have N pointing to a node whose parent is the IF
|
|
-- statement in question, so see if is the ELSIF part we want.
|
|
-- the THEN statements.
|
|
|
|
if N = CV then
|
|
Sens := True;
|
|
|
|
-- Otherwise we must be in subsequent ELSIF or ELSE part
|
|
|
|
else
|
|
Sens := False;
|
|
end if;
|
|
end;
|
|
|
|
-- Iteration scheme of while loop. The condition is known to be
|
|
-- true within the body of the loop.
|
|
|
|
elsif Nkind (CV) = N_Iteration_Scheme then
|
|
declare
|
|
Loop_Stmt : constant Node_Id := Parent (CV);
|
|
|
|
begin
|
|
-- Before start of body of loop
|
|
|
|
if Loc < Sloc (Loop_Stmt) then
|
|
return;
|
|
|
|
-- After end of LOOP statement
|
|
|
|
elsif Loc >= Sloc (End_Label (Loop_Stmt)) then
|
|
return;
|
|
|
|
-- We are within the body of the loop
|
|
|
|
else
|
|
Sens := True;
|
|
end if;
|
|
end;
|
|
|
|
-- All other cases of Current_Value settings
|
|
|
|
else
|
|
return;
|
|
end if;
|
|
|
|
-- If we fall through here, then we have a reportable condition, Sens
|
|
-- is True if the condition is true and False if it needs inverting.
|
|
|
|
Process_Current_Value_Condition (Condition (CV), Sens);
|
|
end;
|
|
end Get_Current_Value_Condition;
|
|
|
|
-----------------------
|
|
-- Get_Index_Subtype --
|
|
-----------------------
|
|
|
|
function Get_Index_Subtype (N : Node_Id) return Entity_Id is
|
|
P_Type : Entity_Id := Etype (Prefix (N));
|
|
Indx : Node_Id;
|
|
J : Int;
|
|
|
|
begin
|
|
if Is_Access_Type (P_Type) then
|
|
P_Type := Designated_Type (P_Type);
|
|
end if;
|
|
|
|
if No (Expressions (N)) then
|
|
J := 1;
|
|
else
|
|
J := UI_To_Int (Expr_Value (First (Expressions (N))));
|
|
end if;
|
|
|
|
Indx := First_Index (P_Type);
|
|
while J > 1 loop
|
|
Next_Index (Indx);
|
|
J := J - 1;
|
|
end loop;
|
|
|
|
return Etype (Indx);
|
|
end Get_Index_Subtype;
|
|
|
|
-----------------------
|
|
-- Get_Mapped_Entity --
|
|
-----------------------
|
|
|
|
function Get_Mapped_Entity (E : Entity_Id) return Entity_Id is
|
|
begin
|
|
return Type_Map.Get (E);
|
|
end Get_Mapped_Entity;
|
|
|
|
---------------------
|
|
-- Get_Stream_Size --
|
|
---------------------
|
|
|
|
function Get_Stream_Size (E : Entity_Id) return Uint is
|
|
begin
|
|
-- If we have a Stream_Size clause for this type use it
|
|
|
|
if Has_Stream_Size_Clause (E) then
|
|
return Static_Integer (Expression (Stream_Size_Clause (E)));
|
|
|
|
-- Otherwise the Stream_Size is the size of the type
|
|
|
|
else
|
|
return Esize (E);
|
|
end if;
|
|
end Get_Stream_Size;
|
|
|
|
---------------------------
|
|
-- Has_Access_Constraint --
|
|
---------------------------
|
|
|
|
function Has_Access_Constraint (E : Entity_Id) return Boolean is
|
|
Disc : Entity_Id;
|
|
T : constant Entity_Id := Etype (E);
|
|
|
|
begin
|
|
if Has_Per_Object_Constraint (E) and then Has_Discriminants (T) then
|
|
Disc := First_Discriminant (T);
|
|
while Present (Disc) loop
|
|
if Is_Access_Type (Etype (Disc)) then
|
|
return True;
|
|
end if;
|
|
|
|
Next_Discriminant (Disc);
|
|
end loop;
|
|
|
|
return False;
|
|
else
|
|
return False;
|
|
end if;
|
|
end Has_Access_Constraint;
|
|
|
|
--------------------
|
|
-- Homonym_Number --
|
|
--------------------
|
|
|
|
function Homonym_Number (Subp : Entity_Id) return Pos is
|
|
Hom : Entity_Id := Homonym (Subp);
|
|
Count : Pos := 1;
|
|
|
|
begin
|
|
while Present (Hom) loop
|
|
if Scope (Hom) = Scope (Subp) then
|
|
Count := Count + 1;
|
|
end if;
|
|
|
|
Hom := Homonym (Hom);
|
|
end loop;
|
|
|
|
return Count;
|
|
end Homonym_Number;
|
|
|
|
-----------------------------------
|
|
-- In_Library_Level_Package_Body --
|
|
-----------------------------------
|
|
|
|
function In_Library_Level_Package_Body (Id : Entity_Id) return Boolean is
|
|
begin
|
|
-- First determine whether the entity appears at the library level, then
|
|
-- look at the containing unit.
|
|
|
|
if Is_Library_Level_Entity (Id) then
|
|
declare
|
|
Container : constant Node_Id := Cunit (Get_Source_Unit (Id));
|
|
|
|
begin
|
|
return Nkind (Unit (Container)) = N_Package_Body;
|
|
end;
|
|
end if;
|
|
|
|
return False;
|
|
end In_Library_Level_Package_Body;
|
|
|
|
------------------------------
|
|
-- In_Unconditional_Context --
|
|
------------------------------
|
|
|
|
function In_Unconditional_Context (Node : Node_Id) return Boolean is
|
|
P : Node_Id;
|
|
|
|
begin
|
|
P := Node;
|
|
while Present (P) loop
|
|
case Nkind (P) is
|
|
when N_Subprogram_Body => return True;
|
|
when N_If_Statement => return False;
|
|
when N_Loop_Statement => return False;
|
|
when N_Case_Statement => return False;
|
|
when others => P := Parent (P);
|
|
end case;
|
|
end loop;
|
|
|
|
return False;
|
|
end In_Unconditional_Context;
|
|
|
|
-------------------
|
|
-- Insert_Action --
|
|
-------------------
|
|
|
|
procedure Insert_Action
|
|
(Assoc_Node : Node_Id;
|
|
Ins_Action : Node_Id;
|
|
Spec_Expr_OK : Boolean := False)
|
|
is
|
|
begin
|
|
if Present (Ins_Action) then
|
|
Insert_Actions
|
|
(Assoc_Node => Assoc_Node,
|
|
Ins_Actions => New_List (Ins_Action),
|
|
Spec_Expr_OK => Spec_Expr_OK);
|
|
end if;
|
|
end Insert_Action;
|
|
|
|
-- Version with check(s) suppressed
|
|
|
|
procedure Insert_Action
|
|
(Assoc_Node : Node_Id;
|
|
Ins_Action : Node_Id;
|
|
Suppress : Check_Id;
|
|
Spec_Expr_OK : Boolean := False)
|
|
is
|
|
begin
|
|
Insert_Actions
|
|
(Assoc_Node => Assoc_Node,
|
|
Ins_Actions => New_List (Ins_Action),
|
|
Suppress => Suppress,
|
|
Spec_Expr_OK => Spec_Expr_OK);
|
|
end Insert_Action;
|
|
|
|
-------------------------
|
|
-- Insert_Action_After --
|
|
-------------------------
|
|
|
|
procedure Insert_Action_After
|
|
(Assoc_Node : Node_Id;
|
|
Ins_Action : Node_Id)
|
|
is
|
|
begin
|
|
Insert_Actions_After (Assoc_Node, New_List (Ins_Action));
|
|
end Insert_Action_After;
|
|
|
|
--------------------
|
|
-- Insert_Actions --
|
|
--------------------
|
|
|
|
procedure Insert_Actions
|
|
(Assoc_Node : Node_Id;
|
|
Ins_Actions : List_Id;
|
|
Spec_Expr_OK : Boolean := False)
|
|
is
|
|
N : Node_Id;
|
|
P : Node_Id;
|
|
|
|
Wrapped_Node : Node_Id := Empty;
|
|
|
|
begin
|
|
if Is_Empty_List (Ins_Actions) then
|
|
return;
|
|
end if;
|
|
|
|
-- Insert the action when the context is "Handling of Default and Per-
|
|
-- Object Expressions" only when requested by the caller.
|
|
|
|
if Spec_Expr_OK then
|
|
null;
|
|
|
|
-- Ignore insert of actions from inside default expression (or other
|
|
-- similar "spec expression") in the special spec-expression analyze
|
|
-- mode. Any insertions at this point have no relevance, since we are
|
|
-- only doing the analyze to freeze the types of any static expressions.
|
|
-- See section "Handling of Default and Per-Object Expressions" in the
|
|
-- spec of package Sem for further details.
|
|
|
|
elsif In_Spec_Expression then
|
|
return;
|
|
end if;
|
|
|
|
-- If the action derives from stuff inside a record, then the actions
|
|
-- are attached to the current scope, to be inserted and analyzed on
|
|
-- exit from the scope. The reason for this is that we may also be
|
|
-- generating freeze actions at the same time, and they must eventually
|
|
-- be elaborated in the correct order.
|
|
|
|
if Is_Record_Type (Current_Scope)
|
|
and then not Is_Frozen (Current_Scope)
|
|
then
|
|
if No (Scope_Stack.Table
|
|
(Scope_Stack.Last).Pending_Freeze_Actions)
|
|
then
|
|
Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions :=
|
|
Ins_Actions;
|
|
else
|
|
Append_List
|
|
(Ins_Actions,
|
|
Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions);
|
|
end if;
|
|
|
|
return;
|
|
end if;
|
|
|
|
-- We now intend to climb up the tree to find the right point to
|
|
-- insert the actions. We start at Assoc_Node, unless this node is a
|
|
-- subexpression in which case we start with its parent. We do this for
|
|
-- two reasons. First it speeds things up. Second, if Assoc_Node is
|
|
-- itself one of the special nodes like N_And_Then, then we assume that
|
|
-- an initial request to insert actions for such a node does not expect
|
|
-- the actions to get deposited in the node for later handling when the
|
|
-- node is expanded, since clearly the node is being dealt with by the
|
|
-- caller. Note that in the subexpression case, N is always the child we
|
|
-- came from.
|
|
|
|
-- N_Raise_xxx_Error is an annoying special case, it is a statement
|
|
-- if it has type Standard_Void_Type, and a subexpression otherwise.
|
|
-- Procedure calls, and similarly procedure attribute references, are
|
|
-- also statements.
|
|
|
|
if Nkind (Assoc_Node) in N_Subexpr
|
|
and then (Nkind (Assoc_Node) not in N_Raise_xxx_Error
|
|
or else Etype (Assoc_Node) /= Standard_Void_Type)
|
|
and then Nkind (Assoc_Node) /= N_Procedure_Call_Statement
|
|
and then (Nkind (Assoc_Node) /= N_Attribute_Reference
|
|
or else not Is_Procedure_Attribute_Name
|
|
(Attribute_Name (Assoc_Node)))
|
|
then
|
|
N := Assoc_Node;
|
|
P := Parent (Assoc_Node);
|
|
|
|
-- Nonsubexpression case. Note that N is initially Empty in this case
|
|
-- (N is only guaranteed non-Empty in the subexpr case).
|
|
|
|
else
|
|
N := Empty;
|
|
P := Assoc_Node;
|
|
end if;
|
|
|
|
-- Capture root of the transient scope
|
|
|
|
if Scope_Is_Transient then
|
|
Wrapped_Node := Node_To_Be_Wrapped;
|
|
end if;
|
|
|
|
loop
|
|
pragma Assert (Present (P));
|
|
|
|
-- Make sure that inserted actions stay in the transient scope
|
|
|
|
if Present (Wrapped_Node) and then N = Wrapped_Node then
|
|
Store_Before_Actions_In_Scope (Ins_Actions);
|
|
return;
|
|
end if;
|
|
|
|
case Nkind (P) is
|
|
|
|
-- Case of right operand of AND THEN or OR ELSE. Put the actions
|
|
-- in the Actions field of the right operand. They will be moved
|
|
-- out further when the AND THEN or OR ELSE operator is expanded.
|
|
-- Nothing special needs to be done for the left operand since
|
|
-- in that case the actions are executed unconditionally.
|
|
|
|
when N_Short_Circuit =>
|
|
if N = Right_Opnd (P) then
|
|
|
|
-- We are now going to either append the actions to the
|
|
-- actions field of the short-circuit operation. We will
|
|
-- also analyze the actions now.
|
|
|
|
-- This analysis is really too early, the proper thing would
|
|
-- be to just park them there now, and only analyze them if
|
|
-- we find we really need them, and to it at the proper
|
|
-- final insertion point. However attempting to this proved
|
|
-- tricky, so for now we just kill current values before and
|
|
-- after the analyze call to make sure we avoid peculiar
|
|
-- optimizations from this out of order insertion.
|
|
|
|
Kill_Current_Values;
|
|
|
|
-- If P has already been expanded, we can't park new actions
|
|
-- on it, so we need to expand them immediately, introducing
|
|
-- an Expression_With_Actions. N can't be an expression
|
|
-- with actions, or else then the actions would have been
|
|
-- inserted at an inner level.
|
|
|
|
if Analyzed (P) then
|
|
pragma Assert (Nkind (N) /= N_Expression_With_Actions);
|
|
Rewrite (N,
|
|
Make_Expression_With_Actions (Sloc (N),
|
|
Actions => Ins_Actions,
|
|
Expression => Relocate_Node (N)));
|
|
Analyze_And_Resolve (N);
|
|
|
|
elsif Present (Actions (P)) then
|
|
Insert_List_After_And_Analyze
|
|
(Last (Actions (P)), Ins_Actions);
|
|
else
|
|
Set_Actions (P, Ins_Actions);
|
|
Analyze_List (Actions (P));
|
|
end if;
|
|
|
|
Kill_Current_Values;
|
|
|
|
return;
|
|
end if;
|
|
|
|
-- Then or Else dependent expression of an if expression. Add
|
|
-- actions to Then_Actions or Else_Actions field as appropriate.
|
|
-- The actions will be moved further out when the if is expanded.
|
|
|
|
when N_If_Expression =>
|
|
declare
|
|
ThenX : constant Node_Id := Next (First (Expressions (P)));
|
|
ElseX : constant Node_Id := Next (ThenX);
|
|
|
|
begin
|
|
-- If the enclosing expression is already analyzed, as
|
|
-- is the case for nested elaboration checks, insert the
|
|
-- conditional further out.
|
|
|
|
if Analyzed (P) then
|
|
null;
|
|
|
|
-- Actions belong to the then expression, temporarily place
|
|
-- them as Then_Actions of the if expression. They will be
|
|
-- moved to the proper place later when the if expression is
|
|
-- expanded.
|
|
|
|
elsif N = ThenX then
|
|
if Present (Then_Actions (P)) then
|
|
Insert_List_After_And_Analyze
|
|
(Last (Then_Actions (P)), Ins_Actions);
|
|
else
|
|
Set_Then_Actions (P, Ins_Actions);
|
|
Analyze_List (Then_Actions (P));
|
|
end if;
|
|
|
|
return;
|
|
|
|
-- Else_Actions is treated the same as Then_Actions above
|
|
|
|
elsif N = ElseX then
|
|
if Present (Else_Actions (P)) then
|
|
Insert_List_After_And_Analyze
|
|
(Last (Else_Actions (P)), Ins_Actions);
|
|
else
|
|
Set_Else_Actions (P, Ins_Actions);
|
|
Analyze_List (Else_Actions (P));
|
|
end if;
|
|
|
|
return;
|
|
|
|
-- Actions belong to the condition. In this case they are
|
|
-- unconditionally executed, and so we can continue the
|
|
-- search for the proper insert point.
|
|
|
|
else
|
|
null;
|
|
end if;
|
|
end;
|
|
|
|
-- Alternative of case expression, we place the action in the
|
|
-- Actions field of the case expression alternative, this will
|
|
-- be handled when the case expression is expanded.
|
|
|
|
when N_Case_Expression_Alternative =>
|
|
if Present (Actions (P)) then
|
|
Insert_List_After_And_Analyze
|
|
(Last (Actions (P)), Ins_Actions);
|
|
else
|
|
Set_Actions (P, Ins_Actions);
|
|
Analyze_List (Actions (P));
|
|
end if;
|
|
|
|
return;
|
|
|
|
-- Case of appearing within an Expressions_With_Actions node. When
|
|
-- the new actions come from the expression of the expression with
|
|
-- actions, they must be added to the existing actions. The other
|
|
-- alternative is when the new actions are related to one of the
|
|
-- existing actions of the expression with actions, and should
|
|
-- never reach here: if actions are inserted on a statement
|
|
-- within the Actions of an expression with actions, or on some
|
|
-- subexpression of such a statement, then the outermost proper
|
|
-- insertion point is right before the statement, and we should
|
|
-- never climb up as far as the N_Expression_With_Actions itself.
|
|
|
|
when N_Expression_With_Actions =>
|
|
if N = Expression (P) then
|
|
if Is_Empty_List (Actions (P)) then
|
|
Append_List_To (Actions (P), Ins_Actions);
|
|
Analyze_List (Actions (P));
|
|
else
|
|
Insert_List_After_And_Analyze
|
|
(Last (Actions (P)), Ins_Actions);
|
|
end if;
|
|
|
|
return;
|
|
|
|
else
|
|
raise Program_Error;
|
|
end if;
|
|
|
|
-- Case of appearing in the condition of a while expression or
|
|
-- elsif. We insert the actions into the Condition_Actions field.
|
|
-- They will be moved further out when the while loop or elsif
|
|
-- is analyzed.
|
|
|
|
when N_Elsif_Part
|
|
| N_Iteration_Scheme
|
|
=>
|
|
if N = Condition (P) then
|
|
if Present (Condition_Actions (P)) then
|
|
Insert_List_After_And_Analyze
|
|
(Last (Condition_Actions (P)), Ins_Actions);
|
|
else
|
|
Set_Condition_Actions (P, Ins_Actions);
|
|
|
|
-- Set the parent of the insert actions explicitly. This
|
|
-- is not a syntactic field, but we need the parent field
|
|
-- set, in particular so that freeze can understand that
|
|
-- it is dealing with condition actions, and properly
|
|
-- insert the freezing actions.
|
|
|
|
Set_Parent (Ins_Actions, P);
|
|
Analyze_List (Condition_Actions (P));
|
|
end if;
|
|
|
|
return;
|
|
end if;
|
|
|
|
-- Statements, declarations, pragmas, representation clauses
|
|
|
|
when
|
|
-- Statements
|
|
|
|
N_Procedure_Call_Statement
|
|
| N_Statement_Other_Than_Procedure_Call
|
|
|
|
-- Pragmas
|
|
|
|
| N_Pragma
|
|
|
|
-- Representation_Clause
|
|
|
|
| N_At_Clause
|
|
| N_Attribute_Definition_Clause
|
|
| N_Enumeration_Representation_Clause
|
|
| N_Record_Representation_Clause
|
|
|
|
-- Declarations
|
|
|
|
| N_Abstract_Subprogram_Declaration
|
|
| N_Entry_Body
|
|
| N_Exception_Declaration
|
|
| N_Exception_Renaming_Declaration
|
|
| N_Expression_Function
|
|
| N_Formal_Abstract_Subprogram_Declaration
|
|
| N_Formal_Concrete_Subprogram_Declaration
|
|
| N_Formal_Object_Declaration
|
|
| N_Formal_Type_Declaration
|
|
| N_Full_Type_Declaration
|
|
| N_Function_Instantiation
|
|
| N_Generic_Function_Renaming_Declaration
|
|
| N_Generic_Package_Declaration
|
|
| N_Generic_Package_Renaming_Declaration
|
|
| N_Generic_Procedure_Renaming_Declaration
|
|
| N_Generic_Subprogram_Declaration
|
|
| N_Implicit_Label_Declaration
|
|
| N_Incomplete_Type_Declaration
|
|
| N_Number_Declaration
|
|
| N_Object_Declaration
|
|
| N_Object_Renaming_Declaration
|
|
| N_Package_Body
|
|
| N_Package_Body_Stub
|
|
| N_Package_Declaration
|
|
| N_Package_Instantiation
|
|
| N_Package_Renaming_Declaration
|
|
| N_Private_Extension_Declaration
|
|
| N_Private_Type_Declaration
|
|
| N_Procedure_Instantiation
|
|
| N_Protected_Body
|
|
| N_Protected_Body_Stub
|
|
| N_Single_Task_Declaration
|
|
| N_Subprogram_Body
|
|
| N_Subprogram_Body_Stub
|
|
| N_Subprogram_Declaration
|
|
| N_Subprogram_Renaming_Declaration
|
|
| N_Subtype_Declaration
|
|
| N_Task_Body
|
|
| N_Task_Body_Stub
|
|
|
|
-- Use clauses can appear in lists of declarations
|
|
|
|
| N_Use_Package_Clause
|
|
| N_Use_Type_Clause
|
|
|
|
-- Freeze entity behaves like a declaration or statement
|
|
|
|
| N_Freeze_Entity
|
|
| N_Freeze_Generic_Entity
|
|
=>
|
|
-- Do not insert here if the item is not a list member (this
|
|
-- happens for example with a triggering statement, and the
|
|
-- proper approach is to insert before the entire select).
|
|
|
|
if not Is_List_Member (P) then
|
|
null;
|
|
|
|
-- Do not insert if parent of P is an N_Component_Association
|
|
-- node (i.e. we are in the context of an N_Aggregate or
|
|
-- N_Extension_Aggregate node. In this case we want to insert
|
|
-- before the entire aggregate.
|
|
|
|
elsif Nkind (Parent (P)) = N_Component_Association then
|
|
null;
|
|
|
|
-- Do not insert if the parent of P is either an N_Variant node
|
|
-- or an N_Record_Definition node, meaning in either case that
|
|
-- P is a member of a component list, and that therefore the
|
|
-- actions should be inserted outside the complete record
|
|
-- declaration.
|
|
|
|
elsif Nkind (Parent (P)) in N_Variant | N_Record_Definition then
|
|
null;
|
|
|
|
-- Do not insert freeze nodes within the loop generated for
|
|
-- an aggregate, because they may be elaborated too late for
|
|
-- subsequent use in the back end: within a package spec the
|
|
-- loop is part of the elaboration procedure and is only
|
|
-- elaborated during the second pass.
|
|
|
|
-- If the loop comes from source, or the entity is local to the
|
|
-- loop itself it must remain within.
|
|
|
|
elsif Nkind (Parent (P)) = N_Loop_Statement
|
|
and then not Comes_From_Source (Parent (P))
|
|
and then Nkind (First (Ins_Actions)) = N_Freeze_Entity
|
|
and then
|
|
Scope (Entity (First (Ins_Actions))) /= Current_Scope
|
|
then
|
|
null;
|
|
|
|
-- Otherwise we can go ahead and do the insertion
|
|
|
|
elsif P = Wrapped_Node then
|
|
Store_Before_Actions_In_Scope (Ins_Actions);
|
|
return;
|
|
|
|
else
|
|
Insert_List_Before_And_Analyze (P, Ins_Actions);
|
|
return;
|
|
end if;
|
|
|
|
-- the expansion of Task and protected type declarations can
|
|
-- create declarations for temporaries which, like other actions
|
|
-- are inserted and analyzed before the current declaraation.
|
|
-- However, the current scope is the synchronized type, and
|
|
-- for unnesting it is critical that the proper scope for these
|
|
-- generated entities be the enclosing one.
|
|
|
|
when N_Task_Type_Declaration
|
|
| N_Protected_Type_Declaration =>
|
|
|
|
Push_Scope (Scope (Current_Scope));
|
|
Insert_List_Before_And_Analyze (P, Ins_Actions);
|
|
Pop_Scope;
|
|
return;
|
|
|
|
-- A special case, N_Raise_xxx_Error can act either as a statement
|
|
-- or a subexpression. We tell the difference by looking at the
|
|
-- Etype. It is set to Standard_Void_Type in the statement case.
|
|
|
|
when N_Raise_xxx_Error =>
|
|
if Etype (P) = Standard_Void_Type then
|
|
if P = Wrapped_Node then
|
|
Store_Before_Actions_In_Scope (Ins_Actions);
|
|
else
|
|
Insert_List_Before_And_Analyze (P, Ins_Actions);
|
|
end if;
|
|
|
|
return;
|
|
|
|
-- In the subexpression case, keep climbing
|
|
|
|
else
|
|
null;
|
|
end if;
|
|
|
|
-- If a component association appears within a loop created for
|
|
-- an array aggregate, attach the actions to the association so
|
|
-- they can be subsequently inserted within the loop. For other
|
|
-- component associations insert outside of the aggregate. For
|
|
-- an association that will generate a loop, its Loop_Actions
|
|
-- attribute is already initialized (see exp_aggr.adb).
|
|
|
|
-- The list of Loop_Actions can in turn generate additional ones,
|
|
-- that are inserted before the associated node. If the associated
|
|
-- node is outside the aggregate, the new actions are collected
|
|
-- at the end of the Loop_Actions, to respect the order in which
|
|
-- they are to be elaborated.
|
|
|
|
when N_Component_Association
|
|
| N_Iterated_Component_Association
|
|
| N_Iterated_Element_Association
|
|
=>
|
|
if Nkind (Parent (P)) in N_Aggregate | N_Delta_Aggregate
|
|
|
|
-- We must not climb up out of an N_Iterated_xxx_Association
|
|
-- because the actions might contain references to the loop
|
|
-- parameter. But it turns out that setting the Loop_Actions
|
|
-- attribute in the case of an N_Component_Association
|
|
-- when the attribute was not already set can lead to
|
|
-- (as yet not understood) bugboxes (gcc failures that are
|
|
-- presumably due to malformed trees). So we don't do that.
|
|
|
|
and then (Nkind (P) /= N_Component_Association
|
|
or else Present (Loop_Actions (P)))
|
|
then
|
|
if Is_Empty_List (Loop_Actions (P)) then
|
|
Set_Loop_Actions (P, Ins_Actions);
|
|
Analyze_List (Ins_Actions);
|
|
else
|
|
declare
|
|
Decl : Node_Id;
|
|
|
|
begin
|
|
-- Check whether these actions were generated by a
|
|
-- declaration that is part of the Loop_Actions for
|
|
-- the component_association.
|
|
|
|
Decl := Assoc_Node;
|
|
while Present (Decl) loop
|
|
exit when Parent (Decl) = P
|
|
and then Is_List_Member (Decl)
|
|
and then
|
|
List_Containing (Decl) = Loop_Actions (P);
|
|
Decl := Parent (Decl);
|
|
end loop;
|
|
|
|
if Present (Decl) then
|
|
Insert_List_Before_And_Analyze
|
|
(Decl, Ins_Actions);
|
|
else
|
|
Insert_List_After_And_Analyze
|
|
(Last (Loop_Actions (P)), Ins_Actions);
|
|
end if;
|
|
end;
|
|
end if;
|
|
|
|
return;
|
|
|
|
else
|
|
null;
|
|
end if;
|
|
|
|
-- Special case: an attribute denoting a procedure call
|
|
|
|
when N_Attribute_Reference =>
|
|
if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
|
|
if P = Wrapped_Node then
|
|
Store_Before_Actions_In_Scope (Ins_Actions);
|
|
else
|
|
Insert_List_Before_And_Analyze (P, Ins_Actions);
|
|
end if;
|
|
|
|
return;
|
|
|
|
-- In the subexpression case, keep climbing
|
|
|
|
else
|
|
null;
|
|
end if;
|
|
|
|
-- Special case: a marker
|
|
|
|
when N_Call_Marker
|
|
| N_Variable_Reference_Marker
|
|
=>
|
|
if Is_List_Member (P) then
|
|
Insert_List_Before_And_Analyze (P, Ins_Actions);
|
|
return;
|
|
end if;
|
|
|
|
-- A contract node should not belong to the tree
|
|
|
|
when N_Contract =>
|
|
raise Program_Error;
|
|
|
|
-- For all other node types, keep climbing tree
|
|
|
|
when N_Abortable_Part
|
|
| N_Accept_Alternative
|
|
| N_Access_Definition
|
|
| N_Access_Function_Definition
|
|
| N_Access_Procedure_Definition
|
|
| N_Access_To_Object_Definition
|
|
| N_Aggregate
|
|
| N_Allocator
|
|
| N_Aspect_Specification
|
|
| N_Case_Expression
|
|
| N_Case_Statement_Alternative
|
|
| N_Character_Literal
|
|
| N_Compilation_Unit
|
|
| N_Compilation_Unit_Aux
|
|
| N_Component_Clause
|
|
| N_Component_Declaration
|
|
| N_Component_Definition
|
|
| N_Component_List
|
|
| N_Constrained_Array_Definition
|
|
| N_Decimal_Fixed_Point_Definition
|
|
| N_Defining_Character_Literal
|
|
| N_Defining_Identifier
|
|
| N_Defining_Operator_Symbol
|
|
| N_Defining_Program_Unit_Name
|
|
| N_Delay_Alternative
|
|
| N_Delta_Aggregate
|
|
| N_Delta_Constraint
|
|
| N_Derived_Type_Definition
|
|
| N_Designator
|
|
| N_Digits_Constraint
|
|
| N_Discriminant_Association
|
|
| N_Discriminant_Specification
|
|
| N_Empty
|
|
| N_Entry_Body_Formal_Part
|
|
| N_Entry_Call_Alternative
|
|
| N_Entry_Declaration
|
|
| N_Entry_Index_Specification
|
|
| N_Enumeration_Type_Definition
|
|
| N_Error
|
|
| N_Exception_Handler
|
|
| N_Expanded_Name
|
|
| N_Explicit_Dereference
|
|
| N_Extension_Aggregate
|
|
| N_Floating_Point_Definition
|
|
| N_Formal_Decimal_Fixed_Point_Definition
|
|
| N_Formal_Derived_Type_Definition
|
|
| N_Formal_Discrete_Type_Definition
|
|
| N_Formal_Floating_Point_Definition
|
|
| N_Formal_Modular_Type_Definition
|
|
| N_Formal_Ordinary_Fixed_Point_Definition
|
|
| N_Formal_Package_Declaration
|
|
| N_Formal_Private_Type_Definition
|
|
| N_Formal_Incomplete_Type_Definition
|
|
| N_Formal_Signed_Integer_Type_Definition
|
|
| N_Function_Call
|
|
| N_Function_Specification
|
|
| N_Generic_Association
|
|
| N_Handled_Sequence_Of_Statements
|
|
| N_Identifier
|
|
| N_In
|
|
| N_Index_Or_Discriminant_Constraint
|
|
| N_Indexed_Component
|
|
| N_Integer_Literal
|
|
| N_Iterator_Specification
|
|
| N_Itype_Reference
|
|
| N_Label
|
|
| N_Loop_Parameter_Specification
|
|
| N_Mod_Clause
|
|
| N_Modular_Type_Definition
|
|
| N_Not_In
|
|
| N_Null
|
|
| N_Op_Abs
|
|
| N_Op_Add
|
|
| N_Op_And
|
|
| N_Op_Concat
|
|
| N_Op_Divide
|
|
| N_Op_Eq
|
|
| N_Op_Expon
|
|
| N_Op_Ge
|
|
| N_Op_Gt
|
|
| N_Op_Le
|
|
| N_Op_Lt
|
|
| N_Op_Minus
|
|
| N_Op_Mod
|
|
| N_Op_Multiply
|
|
| N_Op_Ne
|
|
| N_Op_Not
|
|
| N_Op_Or
|
|
| N_Op_Plus
|
|
| N_Op_Rem
|
|
| 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
|
|
| N_Operator_Symbol
|
|
| N_Ordinary_Fixed_Point_Definition
|
|
| N_Others_Choice
|
|
| N_Package_Specification
|
|
| N_Parameter_Association
|
|
| N_Parameter_Specification
|
|
| N_Pop_Constraint_Error_Label
|
|
| N_Pop_Program_Error_Label
|
|
| N_Pop_Storage_Error_Label
|
|
| N_Pragma_Argument_Association
|
|
| N_Procedure_Specification
|
|
| N_Protected_Definition
|
|
| N_Push_Constraint_Error_Label
|
|
| N_Push_Program_Error_Label
|
|
| N_Push_Storage_Error_Label
|
|
| N_Qualified_Expression
|
|
| N_Quantified_Expression
|
|
| N_Raise_Expression
|
|
| N_Range
|
|
| N_Range_Constraint
|
|
| N_Real_Literal
|
|
| N_Real_Range_Specification
|
|
| N_Record_Definition
|
|
| N_Reference
|
|
| N_SCIL_Dispatch_Table_Tag_Init
|
|
| N_SCIL_Dispatching_Call
|
|
| N_SCIL_Membership_Test
|
|
| N_Selected_Component
|
|
| N_Signed_Integer_Type_Definition
|
|
| N_Single_Protected_Declaration
|
|
| N_Slice
|
|
| N_String_Literal
|
|
| N_Subtype_Indication
|
|
| N_Subunit
|
|
| N_Target_Name
|
|
| N_Task_Definition
|
|
| N_Terminate_Alternative
|
|
| N_Triggering_Alternative
|
|
| N_Type_Conversion
|
|
| N_Unchecked_Expression
|
|
| N_Unchecked_Type_Conversion
|
|
| N_Unconstrained_Array_Definition
|
|
| N_Unused_At_End
|
|
| N_Unused_At_Start
|
|
| N_Variant
|
|
| N_Variant_Part
|
|
| N_Validate_Unchecked_Conversion
|
|
| N_With_Clause
|
|
=>
|
|
null;
|
|
end case;
|
|
|
|
-- If we fall through above tests, keep climbing tree
|
|
|
|
N := P;
|
|
|
|
if Nkind (Parent (N)) = N_Subunit then
|
|
|
|
-- This is the proper body corresponding to a stub. Insertion must
|
|
-- be done at the point of the stub, which is in the declarative
|
|
-- part of the parent unit.
|
|
|
|
P := Corresponding_Stub (Parent (N));
|
|
|
|
else
|
|
P := Parent (N);
|
|
end if;
|
|
end loop;
|
|
end Insert_Actions;
|
|
|
|
-- Version with check(s) suppressed
|
|
|
|
procedure Insert_Actions
|
|
(Assoc_Node : Node_Id;
|
|
Ins_Actions : List_Id;
|
|
Suppress : Check_Id;
|
|
Spec_Expr_OK : Boolean := False)
|
|
is
|
|
begin
|
|
if Suppress = All_Checks then
|
|
declare
|
|
Sva : constant Suppress_Array := Scope_Suppress.Suppress;
|
|
begin
|
|
Scope_Suppress.Suppress := (others => True);
|
|
Insert_Actions (Assoc_Node, Ins_Actions, Spec_Expr_OK);
|
|
Scope_Suppress.Suppress := Sva;
|
|
end;
|
|
|
|
else
|
|
declare
|
|
Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
|
|
begin
|
|
Scope_Suppress.Suppress (Suppress) := True;
|
|
Insert_Actions (Assoc_Node, Ins_Actions, Spec_Expr_OK);
|
|
Scope_Suppress.Suppress (Suppress) := Svg;
|
|
end;
|
|
end if;
|
|
end Insert_Actions;
|
|
|
|
--------------------------
|
|
-- Insert_Actions_After --
|
|
--------------------------
|
|
|
|
procedure Insert_Actions_After
|
|
(Assoc_Node : Node_Id;
|
|
Ins_Actions : List_Id)
|
|
is
|
|
begin
|
|
if Scope_Is_Transient and then Assoc_Node = Node_To_Be_Wrapped then
|
|
Store_After_Actions_In_Scope (Ins_Actions);
|
|
else
|
|
Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions);
|
|
end if;
|
|
end Insert_Actions_After;
|
|
|
|
---------------------------------
|
|
-- Insert_Library_Level_Action --
|
|
---------------------------------
|
|
|
|
procedure Insert_Library_Level_Action (N : Node_Id) is
|
|
Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
|
|
|
|
begin
|
|
Push_Scope (Cunit_Entity (Current_Sem_Unit));
|
|
-- And not Main_Unit as previously. If the main unit is a body,
|
|
-- the scope needed to analyze the actions is the entity of the
|
|
-- corresponding declaration.
|
|
|
|
if No (Actions (Aux)) then
|
|
Set_Actions (Aux, New_List (N));
|
|
else
|
|
Append (N, Actions (Aux));
|
|
end if;
|
|
|
|
Analyze (N);
|
|
Pop_Scope;
|
|
end Insert_Library_Level_Action;
|
|
|
|
----------------------------------
|
|
-- Insert_Library_Level_Actions --
|
|
----------------------------------
|
|
|
|
procedure Insert_Library_Level_Actions (L : List_Id) is
|
|
Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
|
|
|
|
begin
|
|
if Is_Non_Empty_List (L) then
|
|
Push_Scope (Cunit_Entity (Main_Unit));
|
|
-- ??? should this be Current_Sem_Unit instead of Main_Unit?
|
|
|
|
if No (Actions (Aux)) then
|
|
Set_Actions (Aux, L);
|
|
Analyze_List (L);
|
|
else
|
|
Insert_List_After_And_Analyze (Last (Actions (Aux)), L);
|
|
end if;
|
|
|
|
Pop_Scope;
|
|
end if;
|
|
end Insert_Library_Level_Actions;
|
|
|
|
----------------------
|
|
-- Inside_Init_Proc --
|
|
----------------------
|
|
|
|
function Inside_Init_Proc return Boolean is
|
|
begin
|
|
return Present (Enclosing_Init_Proc);
|
|
end Inside_Init_Proc;
|
|
|
|
----------------------
|
|
-- Integer_Type_For --
|
|
----------------------
|
|
|
|
function Integer_Type_For (S : Uint; Uns : Boolean) return Entity_Id is
|
|
begin
|
|
pragma Assert (S <= System_Max_Integer_Size);
|
|
|
|
-- This is the canonical 32-bit type
|
|
|
|
if S <= Standard_Integer_Size then
|
|
if Uns then
|
|
return Standard_Unsigned;
|
|
else
|
|
return Standard_Integer;
|
|
end if;
|
|
|
|
-- This is the canonical 64-bit type
|
|
|
|
elsif S <= Standard_Long_Long_Integer_Size then
|
|
if Uns then
|
|
return Standard_Long_Long_Unsigned;
|
|
else
|
|
return Standard_Long_Long_Integer;
|
|
end if;
|
|
|
|
-- This is the canonical 128-bit type
|
|
|
|
elsif S <= Standard_Long_Long_Long_Integer_Size then
|
|
if Uns then
|
|
return Standard_Long_Long_Long_Unsigned;
|
|
else
|
|
return Standard_Long_Long_Long_Integer;
|
|
end if;
|
|
|
|
else
|
|
raise Program_Error;
|
|
end if;
|
|
end Integer_Type_For;
|
|
|
|
--------------------------------------------------
|
|
-- Is_Displacement_Of_Object_Or_Function_Result --
|
|
--------------------------------------------------
|
|
|
|
function Is_Displacement_Of_Object_Or_Function_Result
|
|
(Obj_Id : Entity_Id) return Boolean
|
|
is
|
|
function Is_Controlled_Function_Call (N : Node_Id) return Boolean;
|
|
-- Determine whether node N denotes a controlled function call
|
|
|
|
function Is_Controlled_Indexing (N : Node_Id) return Boolean;
|
|
-- Determine whether node N denotes a generalized indexing form which
|
|
-- involves a controlled result.
|
|
|
|
function Is_Displace_Call (N : Node_Id) return Boolean;
|
|
-- Determine whether node N denotes a call to Ada.Tags.Displace
|
|
|
|
function Is_Source_Object (N : Node_Id) return Boolean;
|
|
-- Determine whether a particular node denotes a source object
|
|
|
|
function Strip (N : Node_Id) return Node_Id;
|
|
-- Examine arbitrary node N by stripping various indirections and return
|
|
-- the "real" node.
|
|
|
|
---------------------------------
|
|
-- Is_Controlled_Function_Call --
|
|
---------------------------------
|
|
|
|
function Is_Controlled_Function_Call (N : Node_Id) return Boolean is
|
|
Expr : Node_Id;
|
|
|
|
begin
|
|
-- When a function call appears in Object.Operation format, the
|
|
-- original representation has several possible forms depending on
|
|
-- the availability and form of actual parameters:
|
|
|
|
-- Obj.Func N_Selected_Component
|
|
-- Obj.Func (Actual) N_Indexed_Component
|
|
-- Obj.Func (Formal => Actual) N_Function_Call, whose Name is an
|
|
-- N_Selected_Component
|
|
|
|
Expr := Original_Node (N);
|
|
loop
|
|
if Nkind (Expr) = N_Function_Call then
|
|
Expr := Name (Expr);
|
|
|
|
-- "Obj.Func (Actual)" case
|
|
|
|
elsif Nkind (Expr) = N_Indexed_Component then
|
|
Expr := Prefix (Expr);
|
|
|
|
-- "Obj.Func" or "Obj.Func (Formal => Actual) case
|
|
|
|
elsif Nkind (Expr) = N_Selected_Component then
|
|
Expr := Selector_Name (Expr);
|
|
|
|
else
|
|
exit;
|
|
end if;
|
|
end loop;
|
|
|
|
return
|
|
Nkind (Expr) in N_Has_Entity
|
|
and then Present (Entity (Expr))
|
|
and then Ekind (Entity (Expr)) = E_Function
|
|
and then Needs_Finalization (Etype (Entity (Expr)));
|
|
end Is_Controlled_Function_Call;
|
|
|
|
----------------------------
|
|
-- Is_Controlled_Indexing --
|
|
----------------------------
|
|
|
|
function Is_Controlled_Indexing (N : Node_Id) return Boolean is
|
|
Expr : constant Node_Id := Original_Node (N);
|
|
|
|
begin
|
|
return
|
|
Nkind (Expr) = N_Indexed_Component
|
|
and then Present (Generalized_Indexing (Expr))
|
|
and then Needs_Finalization (Etype (Expr));
|
|
end Is_Controlled_Indexing;
|
|
|
|
----------------------
|
|
-- Is_Displace_Call --
|
|
----------------------
|
|
|
|
function Is_Displace_Call (N : Node_Id) return Boolean is
|
|
Call : constant Node_Id := Strip (N);
|
|
|
|
begin
|
|
return
|
|
Present (Call)
|
|
and then Nkind (Call) = N_Function_Call
|
|
and then Nkind (Name (Call)) in N_Has_Entity
|
|
and then Is_RTE (Entity (Name (Call)), RE_Displace);
|
|
end Is_Displace_Call;
|
|
|
|
----------------------
|
|
-- Is_Source_Object --
|
|
----------------------
|
|
|
|
function Is_Source_Object (N : Node_Id) return Boolean is
|
|
Obj : constant Node_Id := Strip (N);
|
|
|
|
begin
|
|
return
|
|
Present (Obj)
|
|
and then Comes_From_Source (Obj)
|
|
and then Nkind (Obj) in N_Has_Entity
|
|
and then Is_Object (Entity (Obj));
|
|
end Is_Source_Object;
|
|
|
|
-----------
|
|
-- Strip --
|
|
-----------
|
|
|
|
function Strip (N : Node_Id) return Node_Id is
|
|
Result : Node_Id;
|
|
|
|
begin
|
|
Result := N;
|
|
loop
|
|
if Nkind (Result) = N_Explicit_Dereference then
|
|
Result := Prefix (Result);
|
|
|
|
elsif Nkind (Result) in
|
|
N_Type_Conversion | N_Unchecked_Type_Conversion
|
|
then
|
|
Result := Expression (Result);
|
|
|
|
else
|
|
exit;
|
|
end if;
|
|
end loop;
|
|
|
|
return Result;
|
|
end Strip;
|
|
|
|
-- Local variables
|
|
|
|
Obj_Decl : constant Node_Id := Declaration_Node (Obj_Id);
|
|
Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
|
|
Orig_Decl : constant Node_Id := Original_Node (Obj_Decl);
|
|
Orig_Expr : Node_Id;
|
|
|
|
-- Start of processing for Is_Displacement_Of_Object_Or_Function_Result
|
|
|
|
begin
|
|
-- Case 1:
|
|
|
|
-- Obj : CW_Type := Function_Call (...);
|
|
|
|
-- is rewritten into:
|
|
|
|
-- Temp : ... := Function_Call (...)'reference;
|
|
-- Obj : CW_Type renames (... Ada.Tags.Displace (Temp));
|
|
|
|
-- where the return type of the function and the class-wide type require
|
|
-- dispatch table pointer displacement.
|
|
|
|
-- Case 2:
|
|
|
|
-- Obj : CW_Type := Container (...);
|
|
|
|
-- is rewritten into:
|
|
|
|
-- Temp : ... := Function_Call (Container, ...)'reference;
|
|
-- Obj : CW_Type renames (... Ada.Tags.Displace (Temp));
|
|
|
|
-- where the container element type and the class-wide type require
|
|
-- dispatch table pointer dispacement.
|
|
|
|
-- Case 3:
|
|
|
|
-- Obj : CW_Type := Src_Obj;
|
|
|
|
-- is rewritten into:
|
|
|
|
-- Obj : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
|
|
|
|
-- where the type of the source object and the class-wide type require
|
|
-- dispatch table pointer displacement.
|
|
|
|
if Nkind (Obj_Decl) = N_Object_Renaming_Declaration
|
|
and then Is_Class_Wide_Type (Obj_Typ)
|
|
and then Is_Displace_Call (Renamed_Object (Obj_Id))
|
|
and then Nkind (Orig_Decl) = N_Object_Declaration
|
|
and then Comes_From_Source (Orig_Decl)
|
|
then
|
|
Orig_Expr := Expression (Orig_Decl);
|
|
|
|
return
|
|
Is_Controlled_Function_Call (Orig_Expr)
|
|
or else Is_Controlled_Indexing (Orig_Expr)
|
|
or else Is_Source_Object (Orig_Expr);
|
|
end if;
|
|
|
|
return False;
|
|
end Is_Displacement_Of_Object_Or_Function_Result;
|
|
|
|
------------------------------
|
|
-- Is_Finalizable_Transient --
|
|
------------------------------
|
|
|
|
function Is_Finalizable_Transient
|
|
(Decl : Node_Id;
|
|
Rel_Node : Node_Id) return Boolean
|
|
is
|
|
Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
|
|
Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
|
|
|
|
function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean;
|
|
-- Determine whether transient object Trans_Id is initialized either
|
|
-- by a function call which returns an access type or simply renames
|
|
-- another pointer.
|
|
|
|
function Initialized_By_Aliased_BIP_Func_Call
|
|
(Trans_Id : Entity_Id) return Boolean;
|
|
-- Determine whether transient object Trans_Id is initialized by a
|
|
-- build-in-place function call where the BIPalloc parameter is of
|
|
-- value 1 and BIPaccess is not null. This case creates an aliasing
|
|
-- between the returned value and the value denoted by BIPaccess.
|
|
|
|
function Is_Aliased
|
|
(Trans_Id : Entity_Id;
|
|
First_Stmt : Node_Id) return Boolean;
|
|
-- Determine whether transient object Trans_Id has been renamed or
|
|
-- aliased through 'reference in the statement list starting from
|
|
-- First_Stmt.
|
|
|
|
function Is_Allocated (Trans_Id : Entity_Id) return Boolean;
|
|
-- Determine whether transient object Trans_Id is allocated on the heap
|
|
|
|
function Is_Iterated_Container
|
|
(Trans_Id : Entity_Id;
|
|
First_Stmt : Node_Id) return Boolean;
|
|
-- Determine whether transient object Trans_Id denotes a container which
|
|
-- is in the process of being iterated in the statement list starting
|
|
-- from First_Stmt.
|
|
|
|
function Is_Part_Of_BIP_Return_Statement (N : Node_Id) return Boolean;
|
|
-- Return True if N is directly part of a build-in-place return
|
|
-- statement.
|
|
|
|
---------------------------
|
|
-- Initialized_By_Access --
|
|
---------------------------
|
|
|
|
function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean is
|
|
Expr : constant Node_Id := Expression (Parent (Trans_Id));
|
|
|
|
begin
|
|
return
|
|
Present (Expr)
|
|
and then Nkind (Expr) /= N_Reference
|
|
and then Is_Access_Type (Etype (Expr));
|
|
end Initialized_By_Access;
|
|
|
|
------------------------------------------
|
|
-- Initialized_By_Aliased_BIP_Func_Call --
|
|
------------------------------------------
|
|
|
|
function Initialized_By_Aliased_BIP_Func_Call
|
|
(Trans_Id : Entity_Id) return Boolean
|
|
is
|
|
Call : Node_Id := Expression (Parent (Trans_Id));
|
|
|
|
begin
|
|
-- Build-in-place calls usually appear in 'reference format
|
|
|
|
if Nkind (Call) = N_Reference then
|
|
Call := Prefix (Call);
|
|
end if;
|
|
|
|
Call := Unqual_Conv (Call);
|
|
|
|
if Is_Build_In_Place_Function_Call (Call) then
|
|
declare
|
|
Access_Nam : Name_Id := No_Name;
|
|
Access_OK : Boolean := False;
|
|
Actual : Node_Id;
|
|
Alloc_Nam : Name_Id := No_Name;
|
|
Alloc_OK : Boolean := False;
|
|
Formal : Node_Id;
|
|
Func_Id : Entity_Id;
|
|
Param : Node_Id;
|
|
|
|
begin
|
|
-- Examine all parameter associations of the function call
|
|
|
|
Param := First (Parameter_Associations (Call));
|
|
while Present (Param) loop
|
|
if Nkind (Param) = N_Parameter_Association
|
|
and then Nkind (Selector_Name (Param)) = N_Identifier
|
|
then
|
|
Actual := Explicit_Actual_Parameter (Param);
|
|
Formal := Selector_Name (Param);
|
|
|
|
-- Construct the names of formals BIPaccess and BIPalloc
|
|
-- using the function name retrieved from an arbitrary
|
|
-- formal.
|
|
|
|
if Access_Nam = No_Name
|
|
and then Alloc_Nam = No_Name
|
|
and then Present (Entity (Formal))
|
|
then
|
|
Func_Id := Scope (Entity (Formal));
|
|
|
|
Access_Nam :=
|
|
New_External_Name (Chars (Func_Id),
|
|
BIP_Formal_Suffix (BIP_Object_Access));
|
|
|
|
Alloc_Nam :=
|
|
New_External_Name (Chars (Func_Id),
|
|
BIP_Formal_Suffix (BIP_Alloc_Form));
|
|
end if;
|
|
|
|
-- A match for BIPaccess => Temp has been found
|
|
|
|
if Chars (Formal) = Access_Nam
|
|
and then Nkind (Actual) /= N_Null
|
|
then
|
|
Access_OK := True;
|
|
end if;
|
|
|
|
-- A match for BIPalloc => 1 has been found
|
|
|
|
if Chars (Formal) = Alloc_Nam
|
|
and then Nkind (Actual) = N_Integer_Literal
|
|
and then Intval (Actual) = Uint_1
|
|
then
|
|
Alloc_OK := True;
|
|
end if;
|
|
end if;
|
|
|
|
Next (Param);
|
|
end loop;
|
|
|
|
return Access_OK and Alloc_OK;
|
|
end;
|
|
end if;
|
|
|
|
return False;
|
|
end Initialized_By_Aliased_BIP_Func_Call;
|
|
|
|
----------------
|
|
-- Is_Aliased --
|
|
----------------
|
|
|
|
function Is_Aliased
|
|
(Trans_Id : Entity_Id;
|
|
First_Stmt : Node_Id) return Boolean
|
|
is
|
|
function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id;
|
|
-- Given an object renaming declaration, retrieve the entity of the
|
|
-- renamed name. Return Empty if the renamed name is anything other
|
|
-- than a variable or a constant.
|
|
|
|
-------------------------
|
|
-- Find_Renamed_Object --
|
|
-------------------------
|
|
|
|
function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id is
|
|
Ren_Obj : Node_Id := Empty;
|
|
|
|
function Find_Object (N : Node_Id) return Traverse_Result;
|
|
-- Try to detect an object which is either a constant or a
|
|
-- variable.
|
|
|
|
-----------------
|
|
-- Find_Object --
|
|
-----------------
|
|
|
|
function Find_Object (N : Node_Id) return Traverse_Result is
|
|
begin
|
|
-- Stop the search once a constant or a variable has been
|
|
-- detected.
|
|
|
|
if Nkind (N) = N_Identifier
|
|
and then Present (Entity (N))
|
|
and then Ekind (Entity (N)) in E_Constant | E_Variable
|
|
then
|
|
Ren_Obj := Entity (N);
|
|
return Abandon;
|
|
end if;
|
|
|
|
return OK;
|
|
end Find_Object;
|
|
|
|
procedure Search is new Traverse_Proc (Find_Object);
|
|
|
|
-- Local variables
|
|
|
|
Typ : constant Entity_Id := Etype (Defining_Identifier (Ren_Decl));
|
|
|
|
-- Start of processing for Find_Renamed_Object
|
|
|
|
begin
|
|
-- Actions related to dispatching calls may appear as renamings of
|
|
-- tags. Do not process this type of renaming because it does not
|
|
-- use the actual value of the object.
|
|
|
|
if not Is_RTE (Typ, RE_Tag_Ptr) then
|
|
Search (Name (Ren_Decl));
|
|
end if;
|
|
|
|
return Ren_Obj;
|
|
end Find_Renamed_Object;
|
|
|
|
-- Local variables
|
|
|
|
Expr : Node_Id;
|
|
Ren_Obj : Entity_Id;
|
|
Stmt : Node_Id;
|
|
|
|
-- Start of processing for Is_Aliased
|
|
|
|
begin
|
|
-- A controlled transient object is not considered aliased when it
|
|
-- appears inside an expression_with_actions node even when there are
|
|
-- explicit aliases of it:
|
|
|
|
-- do
|
|
-- Trans_Id : Ctrl_Typ ...; -- transient object
|
|
-- Alias : ... := Trans_Id; -- object is aliased
|
|
-- Val : constant Boolean :=
|
|
-- ... Alias ...; -- aliasing ends
|
|
-- <finalize Trans_Id> -- object safe to finalize
|
|
-- in Val end;
|
|
|
|
-- Expansion ensures that all aliases are encapsulated in the actions
|
|
-- list and do not leak to the expression by forcing the evaluation
|
|
-- of the expression.
|
|
|
|
if Nkind (Rel_Node) = N_Expression_With_Actions then
|
|
return False;
|
|
|
|
-- Otherwise examine the statements after the controlled transient
|
|
-- object and look for various forms of aliasing.
|
|
|
|
else
|
|
Stmt := First_Stmt;
|
|
while Present (Stmt) loop
|
|
if Nkind (Stmt) = N_Object_Declaration then
|
|
Expr := Expression (Stmt);
|
|
|
|
-- Aliasing of the form:
|
|
-- Obj : ... := Trans_Id'reference;
|
|
|
|
if Present (Expr)
|
|
and then Nkind (Expr) = N_Reference
|
|
and then Nkind (Prefix (Expr)) = N_Identifier
|
|
and then Entity (Prefix (Expr)) = Trans_Id
|
|
then
|
|
return True;
|
|
end if;
|
|
|
|
elsif Nkind (Stmt) = N_Object_Renaming_Declaration then
|
|
Ren_Obj := Find_Renamed_Object (Stmt);
|
|
|
|
-- Aliasing of the form:
|
|
-- Obj : ... renames ... Trans_Id ...;
|
|
|
|
if Present (Ren_Obj) and then Ren_Obj = Trans_Id then
|
|
return True;
|
|
end if;
|
|
end if;
|
|
|
|
Next (Stmt);
|
|
end loop;
|
|
|
|
return False;
|
|
end if;
|
|
end Is_Aliased;
|
|
|
|
------------------
|
|
-- Is_Allocated --
|
|
------------------
|
|
|
|
function Is_Allocated (Trans_Id : Entity_Id) return Boolean is
|
|
Expr : constant Node_Id := Expression (Parent (Trans_Id));
|
|
begin
|
|
return
|
|
Is_Access_Type (Etype (Trans_Id))
|
|
and then Present (Expr)
|
|
and then Nkind (Expr) = N_Allocator;
|
|
end Is_Allocated;
|
|
|
|
---------------------------
|
|
-- Is_Iterated_Container --
|
|
---------------------------
|
|
|
|
function Is_Iterated_Container
|
|
(Trans_Id : Entity_Id;
|
|
First_Stmt : Node_Id) return Boolean
|
|
is
|
|
Aspect : Node_Id;
|
|
Call : Node_Id;
|
|
Iter : Entity_Id;
|
|
Param : Node_Id;
|
|
Stmt : Node_Id;
|
|
Typ : Entity_Id;
|
|
|
|
begin
|
|
-- It is not possible to iterate over containers in non-Ada 2012 code
|
|
|
|
if Ada_Version < Ada_2012 then
|
|
return False;
|
|
end if;
|
|
|
|
Typ := Etype (Trans_Id);
|
|
|
|
-- Handle access type created for secondary stack use
|
|
|
|
if Is_Access_Type (Typ) then
|
|
Typ := Designated_Type (Typ);
|
|
end if;
|
|
|
|
-- Look for aspect Default_Iterator. It may be part of a type
|
|
-- declaration for a container, or inherited from a base type
|
|
-- or parent type.
|
|
|
|
Aspect := Find_Value_Of_Aspect (Typ, Aspect_Default_Iterator);
|
|
|
|
if Present (Aspect) then
|
|
Iter := Entity (Aspect);
|
|
|
|
-- Examine the statements following the container object and
|
|
-- look for a call to the default iterate routine where the
|
|
-- first parameter is the transient. Such a call appears as:
|
|
|
|
-- It : Access_To_CW_Iterator :=
|
|
-- Iterate (Tran_Id.all, ...)'reference;
|
|
|
|
Stmt := First_Stmt;
|
|
while Present (Stmt) loop
|
|
|
|
-- Detect an object declaration which is initialized by a
|
|
-- secondary stack function call.
|
|
|
|
if Nkind (Stmt) = N_Object_Declaration
|
|
and then Present (Expression (Stmt))
|
|
and then Nkind (Expression (Stmt)) = N_Reference
|
|
and then Nkind (Prefix (Expression (Stmt))) = N_Function_Call
|
|
then
|
|
Call := Prefix (Expression (Stmt));
|
|
|
|
-- The call must invoke the default iterate routine of
|
|
-- the container and the transient object must appear as
|
|
-- the first actual parameter. Skip any calls whose names
|
|
-- are not entities.
|
|
|
|
if Is_Entity_Name (Name (Call))
|
|
and then Entity (Name (Call)) = Iter
|
|
and then Present (Parameter_Associations (Call))
|
|
then
|
|
Param := First (Parameter_Associations (Call));
|
|
|
|
if Nkind (Param) = N_Explicit_Dereference
|
|
and then Entity (Prefix (Param)) = Trans_Id
|
|
then
|
|
return True;
|
|
end if;
|
|
end if;
|
|
end if;
|
|
|
|
Next (Stmt);
|
|
end loop;
|
|
end if;
|
|
|
|
return False;
|
|
end Is_Iterated_Container;
|
|
|
|
-------------------------------------
|
|
-- Is_Part_Of_BIP_Return_Statement --
|
|
-------------------------------------
|
|
|
|
function Is_Part_Of_BIP_Return_Statement (N : Node_Id) return Boolean is
|
|
Subp : constant Entity_Id := Current_Subprogram;
|
|
Context : Node_Id;
|
|
begin
|
|
-- First check if N is part of a BIP function
|
|
|
|
if No (Subp)
|
|
or else not Is_Build_In_Place_Function (Subp)
|
|
then
|
|
return False;
|
|
end if;
|
|
|
|
-- Then check whether N is a complete part of a return statement
|
|
-- Should we consider other node kinds to go up the tree???
|
|
|
|
Context := N;
|
|
loop
|
|
case Nkind (Context) is
|
|
when N_Expression_With_Actions => Context := Parent (Context);
|
|
when N_Simple_Return_Statement => return True;
|
|
when others => return False;
|
|
end case;
|
|
end loop;
|
|
end Is_Part_Of_BIP_Return_Statement;
|
|
|
|
-- Local variables
|
|
|
|
Desig : Entity_Id := Obj_Typ;
|
|
|
|
-- Start of processing for Is_Finalizable_Transient
|
|
|
|
begin
|
|
-- Handle access types
|
|
|
|
if Is_Access_Type (Desig) then
|
|
Desig := Available_View (Designated_Type (Desig));
|
|
end if;
|
|
|
|
return
|
|
Ekind (Obj_Id) in E_Constant | E_Variable
|
|
and then Needs_Finalization (Desig)
|
|
and then Requires_Transient_Scope (Desig)
|
|
and then Nkind (Rel_Node) /= N_Simple_Return_Statement
|
|
and then not Is_Part_Of_BIP_Return_Statement (Rel_Node)
|
|
|
|
-- Do not consider a transient object that was already processed
|
|
|
|
and then not Is_Finalized_Transient (Obj_Id)
|
|
|
|
-- Do not consider renamed or 'reference-d transient objects because
|
|
-- the act of renaming extends the object's lifetime.
|
|
|
|
and then not Is_Aliased (Obj_Id, Decl)
|
|
|
|
-- Do not consider transient objects allocated on the heap since
|
|
-- they are attached to a finalization master.
|
|
|
|
and then not Is_Allocated (Obj_Id)
|
|
|
|
-- If the transient object is a pointer, check that it is not
|
|
-- initialized by a function that returns a pointer or acts as a
|
|
-- renaming of another pointer.
|
|
|
|
and then not
|
|
(Is_Access_Type (Obj_Typ) and then Initialized_By_Access (Obj_Id))
|
|
|
|
-- Do not consider transient objects which act as indirect aliases
|
|
-- of build-in-place function results.
|
|
|
|
and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id)
|
|
|
|
-- Do not consider conversions of tags to class-wide types
|
|
|
|
and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
|
|
|
|
-- Do not consider iterators because those are treated as normal
|
|
-- controlled objects and are processed by the usual finalization
|
|
-- machinery. This avoids the double finalization of an iterator.
|
|
|
|
and then not Is_Iterator (Desig)
|
|
|
|
-- Do not consider containers in the context of iterator loops. Such
|
|
-- transient objects must exist for as long as the loop is around,
|
|
-- otherwise any operation carried out by the iterator will fail.
|
|
|
|
and then not Is_Iterated_Container (Obj_Id, Decl);
|
|
end Is_Finalizable_Transient;
|
|
|
|
---------------------------------
|
|
-- Is_Fully_Repped_Tagged_Type --
|
|
---------------------------------
|
|
|
|
function Is_Fully_Repped_Tagged_Type (T : Entity_Id) return Boolean is
|
|
U : constant Entity_Id := Underlying_Type (T);
|
|
Comp : Entity_Id;
|
|
|
|
begin
|
|
if No (U) or else not Is_Tagged_Type (U) then
|
|
return False;
|
|
elsif Has_Discriminants (U) then
|
|
return False;
|
|
elsif not Has_Specified_Layout (U) then
|
|
return False;
|
|
end if;
|
|
|
|
-- Here we have a tagged type, see if it has any component (other than
|
|
-- tag and parent) with no component_clause. If so, we return False.
|
|
|
|
Comp := First_Component (U);
|
|
while Present (Comp) loop
|
|
if not Is_Tag (Comp)
|
|
and then Chars (Comp) /= Name_uParent
|
|
and then No (Component_Clause (Comp))
|
|
then
|
|
return False;
|
|
else
|
|
Next_Component (Comp);
|
|
end if;
|
|
end loop;
|
|
|
|
-- All components have clauses
|
|
|
|
return True;
|
|
end Is_Fully_Repped_Tagged_Type;
|
|
|
|
----------------------------------
|
|
-- Is_Library_Level_Tagged_Type --
|
|
----------------------------------
|
|
|
|
function Is_Library_Level_Tagged_Type (Typ : Entity_Id) return Boolean is
|
|
begin
|
|
return Is_Tagged_Type (Typ) and then Is_Library_Level_Entity (Typ);
|
|
end Is_Library_Level_Tagged_Type;
|
|
|
|
--------------------------
|
|
-- Is_Non_BIP_Func_Call --
|
|
--------------------------
|
|
|
|
function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean is
|
|
begin
|
|
-- The expected call is of the format
|
|
--
|
|
-- Func_Call'reference
|
|
|
|
return
|
|
Nkind (Expr) = N_Reference
|
|
and then Nkind (Prefix (Expr)) = N_Function_Call
|
|
and then not Is_Build_In_Place_Function_Call (Prefix (Expr));
|
|
end Is_Non_BIP_Func_Call;
|
|
|
|
----------------------------------
|
|
-- Is_Possibly_Unaligned_Object --
|
|
----------------------------------
|
|
|
|
function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean is
|
|
T : constant Entity_Id := Etype (N);
|
|
|
|
begin
|
|
-- If renamed object, apply test to underlying object
|
|
|
|
if Is_Entity_Name (N)
|
|
and then Is_Object (Entity (N))
|
|
and then Present (Renamed_Object (Entity (N)))
|
|
then
|
|
return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (N)));
|
|
end if;
|
|
|
|
-- Tagged and controlled types and aliased types are always aligned, as
|
|
-- are concurrent types.
|
|
|
|
if Is_Aliased (T)
|
|
or else Has_Controlled_Component (T)
|
|
or else Is_Concurrent_Type (T)
|
|
or else Is_Tagged_Type (T)
|
|
or else Is_Controlled (T)
|
|
then
|
|
return False;
|
|
end if;
|
|
|
|
-- If this is an element of a packed array, may be unaligned
|
|
|
|
if Is_Ref_To_Bit_Packed_Array (N) then
|
|
return True;
|
|
end if;
|
|
|
|
-- Case of indexed component reference: test whether prefix is unaligned
|
|
|
|
if Nkind (N) = N_Indexed_Component then
|
|
return Is_Possibly_Unaligned_Object (Prefix (N));
|
|
|
|
-- Case of selected component reference
|
|
|
|
elsif Nkind (N) = N_Selected_Component then
|
|
declare
|
|
P : constant Node_Id := Prefix (N);
|
|
C : constant Entity_Id := Entity (Selector_Name (N));
|
|
M : Nat;
|
|
S : Nat;
|
|
|
|
begin
|
|
-- If component reference is for an array with nonstatic bounds,
|
|
-- then it is always aligned: we can only process unaligned arrays
|
|
-- with static bounds (more precisely compile time known bounds).
|
|
|
|
if Is_Array_Type (T)
|
|
and then not Compile_Time_Known_Bounds (T)
|
|
then
|
|
return False;
|
|
end if;
|
|
|
|
-- If component is aliased, it is definitely properly aligned
|
|
|
|
if Is_Aliased (C) then
|
|
return False;
|
|
end if;
|
|
|
|
-- If component is for a type implemented as a scalar, and the
|
|
-- record is packed, and the component is other than the first
|
|
-- component of the record, then the component may be unaligned.
|
|
|
|
if Is_Packed (Etype (P))
|
|
and then Represented_As_Scalar (Etype (C))
|
|
and then First_Entity (Scope (C)) /= C
|
|
then
|
|
return True;
|
|
end if;
|
|
|
|
-- Compute maximum possible alignment for T
|
|
|
|
-- If alignment is known, then that settles things
|
|
|
|
if Known_Alignment (T) then
|
|
M := UI_To_Int (Alignment (T));
|
|
|
|
-- If alignment is not known, tentatively set max alignment
|
|
|
|
else
|
|
M := Ttypes.Maximum_Alignment;
|
|
|
|
-- We can reduce this if the Esize is known since the default
|
|
-- alignment will never be more than the smallest power of 2
|
|
-- that does not exceed this Esize value.
|
|
|
|
if Known_Esize (T) then
|
|
S := UI_To_Int (Esize (T));
|
|
|
|
while (M / 2) >= S loop
|
|
M := M / 2;
|
|
end loop;
|
|
end if;
|
|
end if;
|
|
|
|
-- Case of component clause present which may specify an
|
|
-- unaligned position.
|
|
|
|
if Present (Component_Clause (C)) then
|
|
|
|
-- Otherwise we can do a test to make sure that the actual
|
|
-- start position in the record, and the length, are both
|
|
-- consistent with the required alignment. If not, we know
|
|
-- that we are unaligned.
|
|
|
|
declare
|
|
Align_In_Bits : constant Nat := M * System_Storage_Unit;
|
|
Comp : Entity_Id;
|
|
|
|
begin
|
|
Comp := C;
|
|
|
|
-- For a component inherited in a record extension, the
|
|
-- clause is inherited but position and size are not set.
|
|
|
|
if Is_Base_Type (Etype (P))
|
|
and then Is_Tagged_Type (Etype (P))
|
|
and then Present (Original_Record_Component (Comp))
|
|
then
|
|
Comp := Original_Record_Component (Comp);
|
|
end if;
|
|
|
|
if Component_Bit_Offset (Comp) mod Align_In_Bits /= 0
|
|
or else Esize (Comp) mod Align_In_Bits /= 0
|
|
then
|
|
return True;
|
|
end if;
|
|
end;
|
|
end if;
|
|
|
|
-- Otherwise, for a component reference, test prefix
|
|
|
|
return Is_Possibly_Unaligned_Object (P);
|
|
end;
|
|
|
|
-- If not a component reference, must be aligned
|
|
|
|
else
|
|
return False;
|
|
end if;
|
|
end Is_Possibly_Unaligned_Object;
|
|
|
|
---------------------------------
|
|
-- Is_Possibly_Unaligned_Slice --
|
|
---------------------------------
|
|
|
|
function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean is
|
|
begin
|
|
-- Go to renamed object
|
|
|
|
if Is_Entity_Name (N)
|
|
and then Is_Object (Entity (N))
|
|
and then Present (Renamed_Object (Entity (N)))
|
|
then
|
|
return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (N)));
|
|
end if;
|
|
|
|
-- The reference must be a slice
|
|
|
|
if Nkind (N) /= N_Slice then
|
|
return False;
|
|
end if;
|
|
|
|
-- If it is a slice, then look at the array type being sliced
|
|
|
|
declare
|
|
Sarr : constant Node_Id := Prefix (N);
|
|
-- Prefix of the slice, i.e. the array being sliced
|
|
|
|
Styp : constant Entity_Id := Etype (Prefix (N));
|
|
-- Type of the array being sliced
|
|
|
|
Pref : Node_Id;
|
|
Ptyp : Entity_Id;
|
|
|
|
begin
|
|
-- The problems arise if the array object that is being sliced
|
|
-- is a component of a record or array, and we cannot guarantee
|
|
-- the alignment of the array within its containing object.
|
|
|
|
-- To investigate this, we look at successive prefixes to see
|
|
-- if we have a worrisome indexed or selected component.
|
|
|
|
Pref := Sarr;
|
|
loop
|
|
-- Case of array is part of an indexed component reference
|
|
|
|
if Nkind (Pref) = N_Indexed_Component then
|
|
Ptyp := Etype (Prefix (Pref));
|
|
|
|
-- The only problematic case is when the array is packed, in
|
|
-- which case we really know nothing about the alignment of
|
|
-- individual components.
|
|
|
|
if Is_Bit_Packed_Array (Ptyp) then
|
|
return True;
|
|
end if;
|
|
|
|
-- Case of array is part of a selected component reference
|
|
|
|
elsif Nkind (Pref) = N_Selected_Component then
|
|
Ptyp := Etype (Prefix (Pref));
|
|
|
|
-- We are definitely in trouble if the record in question
|
|
-- has an alignment, and either we know this alignment is
|
|
-- inconsistent with the alignment of the slice, or we don't
|
|
-- know what the alignment of the slice should be. But this
|
|
-- really matters only if the target has strict alignment.
|
|
|
|
if Target_Strict_Alignment
|
|
and then Known_Alignment (Ptyp)
|
|
and then (not Known_Alignment (Styp)
|
|
or else Alignment (Styp) > Alignment (Ptyp))
|
|
then
|
|
return True;
|
|
end if;
|
|
|
|
-- We are in potential trouble if the record type is packed.
|
|
-- We could special case when we know that the array is the
|
|
-- first component, but that's not such a simple case ???
|
|
|
|
if Is_Packed (Ptyp) then
|
|
return True;
|
|
end if;
|
|
|
|
-- We are in trouble if there is a component clause, and
|
|
-- either we do not know the alignment of the slice, or
|
|
-- the alignment of the slice is inconsistent with the
|
|
-- bit position specified by the component clause.
|
|
|
|
declare
|
|
Field : constant Entity_Id := Entity (Selector_Name (Pref));
|
|
begin
|
|
if Present (Component_Clause (Field))
|
|
and then
|
|
(not Known_Alignment (Styp)
|
|
or else
|
|
(Component_Bit_Offset (Field) mod
|
|
(System_Storage_Unit * Alignment (Styp))) /= 0)
|
|
then
|
|
return True;
|
|
end if;
|
|
end;
|
|
|
|
-- For cases other than selected or indexed components we know we
|
|
-- are OK, since no issues arise over alignment.
|
|
|
|
else
|
|
return False;
|
|
end if;
|
|
|
|
-- We processed an indexed component or selected component
|
|
-- reference that looked safe, so keep checking prefixes.
|
|
|
|
Pref := Prefix (Pref);
|
|
end loop;
|
|
end;
|
|
end Is_Possibly_Unaligned_Slice;
|
|
|
|
-------------------------------
|
|
-- Is_Related_To_Func_Return --
|
|
-------------------------------
|
|
|
|
function Is_Related_To_Func_Return (Id : Entity_Id) return Boolean is
|
|
Expr : constant Node_Id := Related_Expression (Id);
|
|
begin
|
|
-- In the case of a function with a class-wide result that returns
|
|
-- a call to a function with a specific result, we introduce a
|
|
-- type conversion for the return expression. We do not want that
|
|
-- type conversion to influence the result of this function.
|
|
|
|
return
|
|
Present (Expr)
|
|
and then Nkind (Unqual_Conv (Expr)) = N_Explicit_Dereference
|
|
and then Nkind (Parent (Expr)) = N_Simple_Return_Statement;
|
|
end Is_Related_To_Func_Return;
|
|
|
|
--------------------------------
|
|
-- Is_Ref_To_Bit_Packed_Array --
|
|
--------------------------------
|
|
|
|
function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean is
|
|
Result : Boolean;
|
|
Expr : Node_Id;
|
|
|
|
begin
|
|
if Is_Entity_Name (N)
|
|
and then Is_Object (Entity (N))
|
|
and then Present (Renamed_Object (Entity (N)))
|
|
then
|
|
return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N)));
|
|
end if;
|
|
|
|
if Nkind (N) in N_Indexed_Component | N_Selected_Component then
|
|
if Is_Bit_Packed_Array (Etype (Prefix (N))) then
|
|
Result := True;
|
|
else
|
|
Result := Is_Ref_To_Bit_Packed_Array (Prefix (N));
|
|
end if;
|
|
|
|
if Result and then Nkind (N) = N_Indexed_Component then
|
|
Expr := First (Expressions (N));
|
|
while Present (Expr) loop
|
|
Force_Evaluation (Expr);
|
|
Next (Expr);
|
|
end loop;
|
|
end if;
|
|
|
|
return Result;
|
|
|
|
else
|
|
return False;
|
|
end if;
|
|
end Is_Ref_To_Bit_Packed_Array;
|
|
|
|
--------------------------------
|
|
-- Is_Ref_To_Bit_Packed_Slice --
|
|
--------------------------------
|
|
|
|
function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean is
|
|
begin
|
|
if Nkind (N) = N_Type_Conversion then
|
|
return Is_Ref_To_Bit_Packed_Slice (Expression (N));
|
|
|
|
elsif Is_Entity_Name (N)
|
|
and then Is_Object (Entity (N))
|
|
and then Present (Renamed_Object (Entity (N)))
|
|
then
|
|
return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (N)));
|
|
|
|
elsif Nkind (N) = N_Slice
|
|
and then Is_Bit_Packed_Array (Etype (Prefix (N)))
|
|
then
|
|
return True;
|
|
|
|
elsif Nkind (N) in N_Indexed_Component | N_Selected_Component then
|
|
return Is_Ref_To_Bit_Packed_Slice (Prefix (N));
|
|
|
|
else
|
|
return False;
|
|
end if;
|
|
end Is_Ref_To_Bit_Packed_Slice;
|
|
|
|
-----------------------
|
|
-- Is_Renamed_Object --
|
|
-----------------------
|
|
|
|
function Is_Renamed_Object (N : Node_Id) return Boolean is
|
|
Pnod : constant Node_Id := Parent (N);
|
|
Kind : constant Node_Kind := Nkind (Pnod);
|
|
begin
|
|
if Kind = N_Object_Renaming_Declaration then
|
|
return True;
|
|
elsif Kind in N_Indexed_Component | N_Selected_Component then
|
|
return Is_Renamed_Object (Pnod);
|
|
else
|
|
return False;
|
|
end if;
|
|
end Is_Renamed_Object;
|
|
|
|
--------------------------------------
|
|
-- Is_Secondary_Stack_BIP_Func_Call --
|
|
--------------------------------------
|
|
|
|
function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is
|
|
Actual : Node_Id;
|
|
Call : Node_Id := Expr;
|
|
Formal : Node_Id;
|
|
Param : Node_Id;
|
|
|
|
begin
|
|
-- Build-in-place calls usually appear in 'reference format. Note that
|
|
-- the accessibility check machinery may add an extra 'reference due to
|
|
-- side effect removal.
|
|
|
|
while Nkind (Call) = N_Reference loop
|
|
Call := Prefix (Call);
|
|
end loop;
|
|
|
|
Call := Unqual_Conv (Call);
|
|
|
|
if Is_Build_In_Place_Function_Call (Call) then
|
|
|
|
-- Examine all parameter associations of the function call
|
|
|
|
Param := First (Parameter_Associations (Call));
|
|
while Present (Param) loop
|
|
if Nkind (Param) = N_Parameter_Association then
|
|
Formal := Selector_Name (Param);
|
|
Actual := Explicit_Actual_Parameter (Param);
|
|
|
|
-- A match for BIPalloc => 2 has been found
|
|
|
|
if Is_Build_In_Place_Entity (Formal)
|
|
and then BIP_Suffix_Kind (Formal) = BIP_Alloc_Form
|
|
and then Nkind (Actual) = N_Integer_Literal
|
|
and then Intval (Actual) = Uint_2
|
|
then
|
|
return True;
|
|
end if;
|
|
end if;
|
|
|
|
Next (Param);
|
|
end loop;
|
|
end if;
|
|
|
|
return False;
|
|
end Is_Secondary_Stack_BIP_Func_Call;
|
|
|
|
-------------------------------------
|
|
-- Is_Tag_To_Class_Wide_Conversion --
|
|
-------------------------------------
|
|
|
|
function Is_Tag_To_Class_Wide_Conversion
|
|
(Obj_Id : Entity_Id) return Boolean
|
|
is
|
|
Expr : constant Node_Id := Expression (Parent (Obj_Id));
|
|
|
|
begin
|
|
return
|
|
Is_Class_Wide_Type (Etype (Obj_Id))
|
|
and then Present (Expr)
|
|
and then Nkind (Expr) = N_Unchecked_Type_Conversion
|
|
and then Is_RTE (Etype (Expression (Expr)), RE_Tag);
|
|
end Is_Tag_To_Class_Wide_Conversion;
|
|
|
|
--------------------------------
|
|
-- Is_Uninitialized_Aggregate --
|
|
--------------------------------
|
|
|
|
function Is_Uninitialized_Aggregate
|
|
(Exp : Node_Id;
|
|
T : Entity_Id) return Boolean
|
|
is
|
|
Comp : Node_Id;
|
|
Comp_Type : Entity_Id;
|
|
Typ : Entity_Id;
|
|
|
|
begin
|
|
if Nkind (Exp) /= N_Aggregate then
|
|
return False;
|
|
end if;
|
|
|
|
Preanalyze_And_Resolve (Exp, T);
|
|
Typ := Etype (Exp);
|
|
|
|
if No (Typ)
|
|
or else Ekind (Typ) /= E_Array_Subtype
|
|
or else Present (Expressions (Exp))
|
|
or else No (Component_Associations (Exp))
|
|
then
|
|
return False;
|
|
else
|
|
Comp_Type := Component_Type (Typ);
|
|
Comp := First (Component_Associations (Exp));
|
|
|
|
if not Box_Present (Comp)
|
|
or else Present (Next (Comp))
|
|
then
|
|
return False;
|
|
end if;
|
|
|
|
return Is_Scalar_Type (Comp_Type)
|
|
and then No (Default_Aspect_Component_Value (Typ));
|
|
end if;
|
|
end Is_Uninitialized_Aggregate;
|
|
|
|
----------------------------
|
|
-- Is_Untagged_Derivation --
|
|
----------------------------
|
|
|
|
function Is_Untagged_Derivation (T : Entity_Id) return Boolean is
|
|
begin
|
|
return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
|
|
or else
|
|
(Is_Private_Type (T) and then Present (Full_View (T))
|
|
and then not Is_Tagged_Type (Full_View (T))
|
|
and then Is_Derived_Type (Full_View (T))
|
|
and then Etype (Full_View (T)) /= T);
|
|
end Is_Untagged_Derivation;
|
|
|
|
------------------------------------
|
|
-- Is_Untagged_Private_Derivation --
|
|
------------------------------------
|
|
|
|
function Is_Untagged_Private_Derivation
|
|
(Priv_Typ : Entity_Id;
|
|
Full_Typ : Entity_Id) return Boolean
|
|
is
|
|
begin
|
|
return
|
|
Present (Priv_Typ)
|
|
and then Is_Untagged_Derivation (Priv_Typ)
|
|
and then Is_Private_Type (Etype (Priv_Typ))
|
|
and then Present (Full_Typ)
|
|
and then Is_Itype (Full_Typ);
|
|
end Is_Untagged_Private_Derivation;
|
|
|
|
------------------------------
|
|
-- Is_Verifiable_DIC_Pragma --
|
|
------------------------------
|
|
|
|
function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean is
|
|
Args : constant List_Id := Pragma_Argument_Associations (Prag);
|
|
|
|
begin
|
|
-- To qualify as verifiable, a DIC pragma must have a non-null argument
|
|
|
|
return
|
|
Present (Args)
|
|
|
|
-- If there are args, but the first arg is Empty, then treat the
|
|
-- pragma the same as having no args (there may be a second arg that
|
|
-- is an implicitly added type arg, and Empty is a placeholder).
|
|
|
|
and then Present (Get_Pragma_Arg (First (Args)))
|
|
|
|
and then Nkind (Get_Pragma_Arg (First (Args))) /= N_Null;
|
|
end Is_Verifiable_DIC_Pragma;
|
|
|
|
---------------------------
|
|
-- Is_Volatile_Reference --
|
|
---------------------------
|
|
|
|
function Is_Volatile_Reference (N : Node_Id) return Boolean is
|
|
begin
|
|
-- Only source references are to be treated as volatile, internally
|
|
-- generated stuff cannot have volatile external effects.
|
|
|
|
if not Comes_From_Source (N) then
|
|
return False;
|
|
|
|
-- Never true for reference to a type
|
|
|
|
elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
|
|
return False;
|
|
|
|
-- Never true for a compile time known constant
|
|
|
|
elsif Compile_Time_Known_Value (N) then
|
|
return False;
|
|
|
|
-- True if object reference with volatile type
|
|
|
|
elsif Is_Volatile_Object_Ref (N) then
|
|
return True;
|
|
|
|
-- True if reference to volatile entity
|
|
|
|
elsif Is_Entity_Name (N) then
|
|
return Treat_As_Volatile (Entity (N));
|
|
|
|
-- True for slice of volatile array
|
|
|
|
elsif Nkind (N) = N_Slice then
|
|
return Is_Volatile_Reference (Prefix (N));
|
|
|
|
-- True if volatile component
|
|
|
|
elsif Nkind (N) in N_Indexed_Component | N_Selected_Component then
|
|
if (Is_Entity_Name (Prefix (N))
|
|
and then Has_Volatile_Components (Entity (Prefix (N))))
|
|
or else (Present (Etype (Prefix (N)))
|
|
and then Has_Volatile_Components (Etype (Prefix (N))))
|
|
then
|
|
return True;
|
|
else
|
|
return Is_Volatile_Reference (Prefix (N));
|
|
end if;
|
|
|
|
-- Otherwise false
|
|
|
|
else
|
|
return False;
|
|
end if;
|
|
end Is_Volatile_Reference;
|
|
|
|
--------------------
|
|
-- Kill_Dead_Code --
|
|
--------------------
|
|
|
|
procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False) is
|
|
W : Boolean := Warn;
|
|
-- Set False if warnings suppressed
|
|
|
|
begin
|
|
if Present (N) then
|
|
Remove_Warning_Messages (N);
|
|
|
|
-- Update the internal structures of the ABE mechanism in case the
|
|
-- dead node is an elaboration scenario.
|
|
|
|
Kill_Elaboration_Scenario (N);
|
|
|
|
-- Generate warning if appropriate
|
|
|
|
if W then
|
|
|
|
-- We suppress the warning if this code is under control of an
|
|
-- if/case statement and either
|
|
-- a) we are in an instance and the condition/selector
|
|
-- has a statically known value; or
|
|
-- b) the condition/selector is a simple identifier and
|
|
-- warnings off is set for this identifier.
|
|
-- Dead code is common and reasonable in instances, so we don't
|
|
-- want a warning in that case.
|
|
|
|
declare
|
|
C : Node_Id := Empty;
|
|
begin
|
|
if Nkind (Parent (N)) = N_If_Statement then
|
|
C := Condition (Parent (N));
|
|
elsif Nkind (Parent (N)) = N_Case_Statement_Alternative then
|
|
C := Expression (Parent (Parent (N)));
|
|
end if;
|
|
|
|
if Present (C) then
|
|
if (In_Instance and Compile_Time_Known_Value (C))
|
|
or else (Nkind (C) = N_Identifier
|
|
and then Present (Entity (C))
|
|
and then Has_Warnings_Off (Entity (C)))
|
|
then
|
|
W := False;
|
|
end if;
|
|
end if;
|
|
end;
|
|
|
|
-- Generate warning if not suppressed
|
|
|
|
if W then
|
|
Error_Msg_F
|
|
("?t?this code can never be executed and has been deleted!",
|
|
N);
|
|
end if;
|
|
end if;
|
|
|
|
-- Recurse into block statements and bodies to process declarations
|
|
-- and statements.
|
|
|
|
if Nkind (N) = N_Block_Statement
|
|
or else Nkind (N) = N_Subprogram_Body
|
|
or else Nkind (N) = N_Package_Body
|
|
then
|
|
Kill_Dead_Code (Declarations (N), False);
|
|
Kill_Dead_Code (Statements (Handled_Statement_Sequence (N)));
|
|
|
|
if Nkind (N) = N_Subprogram_Body then
|
|
Set_Is_Eliminated (Defining_Entity (N));
|
|
end if;
|
|
|
|
elsif Nkind (N) = N_Package_Declaration then
|
|
Kill_Dead_Code (Visible_Declarations (Specification (N)));
|
|
Kill_Dead_Code (Private_Declarations (Specification (N)));
|
|
|
|
-- ??? After this point, Delete_Tree has been called on all
|
|
-- declarations in Specification (N), so references to entities
|
|
-- therein look suspicious.
|
|
|
|
declare
|
|
E : Entity_Id := First_Entity (Defining_Entity (N));
|
|
|
|
begin
|
|
while Present (E) loop
|
|
if Ekind (E) = E_Operator then
|
|
Set_Is_Eliminated (E);
|
|
end if;
|
|
|
|
Next_Entity (E);
|
|
end loop;
|
|
end;
|
|
|
|
-- Recurse into composite statement to kill individual statements in
|
|
-- particular instantiations.
|
|
|
|
elsif Nkind (N) = N_If_Statement then
|
|
Kill_Dead_Code (Then_Statements (N));
|
|
Kill_Dead_Code (Elsif_Parts (N));
|
|
Kill_Dead_Code (Else_Statements (N));
|
|
|
|
elsif Nkind (N) = N_Loop_Statement then
|
|
Kill_Dead_Code (Statements (N));
|
|
|
|
elsif Nkind (N) = N_Case_Statement then
|
|
declare
|
|
Alt : Node_Id;
|
|
begin
|
|
Alt := First (Alternatives (N));
|
|
while Present (Alt) loop
|
|
Kill_Dead_Code (Statements (Alt));
|
|
Next (Alt);
|
|
end loop;
|
|
end;
|
|
|
|
elsif Nkind (N) = N_Case_Statement_Alternative then
|
|
Kill_Dead_Code (Statements (N));
|
|
|
|
-- Deal with dead instances caused by deleting instantiations
|
|
|
|
elsif Nkind (N) in N_Generic_Instantiation then
|
|
Remove_Dead_Instance (N);
|
|
end if;
|
|
end if;
|
|
end Kill_Dead_Code;
|
|
|
|
-- Case where argument is a list of nodes to be killed
|
|
|
|
procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False) is
|
|
N : Node_Id;
|
|
W : Boolean;
|
|
|
|
begin
|
|
W := Warn;
|
|
|
|
N := First (L);
|
|
while Present (N) loop
|
|
Kill_Dead_Code (N, W);
|
|
W := False;
|
|
Next (N);
|
|
end loop;
|
|
end Kill_Dead_Code;
|
|
|
|
-----------------------------
|
|
-- Make_CW_Equivalent_Type --
|
|
-----------------------------
|
|
|
|
-- Create a record type used as an equivalent of any member of the class
|
|
-- which takes its size from exp.
|
|
|
|
-- Generate the following code:
|
|
|
|
-- type Equiv_T is record
|
|
-- _parent : T (List of discriminant constraints taken from Exp);
|
|
-- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
|
|
-- end Equiv_T;
|
|
--
|
|
-- ??? Note that this type does not guarantee same alignment as all
|
|
-- derived types
|
|
--
|
|
-- Note: for the freezing circuitry, this looks like a record extension,
|
|
-- and so we need to make sure that the scalar storage order is the same
|
|
-- as that of the parent type. (This does not change anything for the
|
|
-- representation of the extension part.)
|
|
|
|
function Make_CW_Equivalent_Type
|
|
(T : Entity_Id;
|
|
E : Node_Id) return Entity_Id
|
|
is
|
|
Loc : constant Source_Ptr := Sloc (E);
|
|
Root_Typ : constant Entity_Id := Root_Type (T);
|
|
Root_Utyp : constant Entity_Id := Underlying_Type (Root_Typ);
|
|
List_Def : constant List_Id := Empty_List;
|
|
Comp_List : constant List_Id := New_List;
|
|
Equiv_Type : Entity_Id;
|
|
Range_Type : Entity_Id;
|
|
Str_Type : Entity_Id;
|
|
Constr_Root : Entity_Id;
|
|
Sizexpr : Node_Id;
|
|
|
|
begin
|
|
-- If the root type is already constrained, there are no discriminants
|
|
-- in the expression.
|
|
|
|
if not Has_Discriminants (Root_Typ)
|
|
or else Is_Constrained (Root_Typ)
|
|
then
|
|
Constr_Root := Root_Typ;
|
|
|
|
-- At this point in the expansion, nonlimited view of the type
|
|
-- must be available, otherwise the error will be reported later.
|
|
|
|
if From_Limited_With (Constr_Root)
|
|
and then Present (Non_Limited_View (Constr_Root))
|
|
then
|
|
Constr_Root := Non_Limited_View (Constr_Root);
|
|
end if;
|
|
|
|
else
|
|
Constr_Root := Make_Temporary (Loc, 'R');
|
|
|
|
-- subtype cstr__n is T (List of discr constraints taken from Exp)
|
|
|
|
Append_To (List_Def,
|
|
Make_Subtype_Declaration (Loc,
|
|
Defining_Identifier => Constr_Root,
|
|
Subtype_Indication => Make_Subtype_From_Expr (E, Root_Typ)));
|
|
end if;
|
|
|
|
-- Generate the range subtype declaration
|
|
|
|
Range_Type := Make_Temporary (Loc, 'G');
|
|
|
|
if not Is_Interface (Root_Typ) then
|
|
|
|
-- subtype rg__xx is
|
|
-- Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit
|
|
|
|
Sizexpr :=
|
|
Make_Op_Subtract (Loc,
|
|
Left_Opnd =>
|
|
Make_Attribute_Reference (Loc,
|
|
Prefix =>
|
|
OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
|
|
Attribute_Name => Name_Size),
|
|
Right_Opnd =>
|
|
Make_Attribute_Reference (Loc,
|
|
Prefix => New_Occurrence_Of (Constr_Root, Loc),
|
|
Attribute_Name => Name_Object_Size));
|
|
else
|
|
-- subtype rg__xx is
|
|
-- Storage_Offset range 1 .. Expr'size / Storage_Unit
|
|
|
|
Sizexpr :=
|
|
Make_Attribute_Reference (Loc,
|
|
Prefix =>
|
|
OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
|
|
Attribute_Name => Name_Size);
|
|
end if;
|
|
|
|
Set_Paren_Count (Sizexpr, 1);
|
|
|
|
Append_To (List_Def,
|
|
Make_Subtype_Declaration (Loc,
|
|
Defining_Identifier => Range_Type,
|
|
Subtype_Indication =>
|
|
Make_Subtype_Indication (Loc,
|
|
Subtype_Mark => New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
|
|
Constraint => Make_Range_Constraint (Loc,
|
|
Range_Expression =>
|
|
Make_Range (Loc,
|
|
Low_Bound => Make_Integer_Literal (Loc, 1),
|
|
High_Bound =>
|
|
Make_Op_Divide (Loc,
|
|
Left_Opnd => Sizexpr,
|
|
Right_Opnd => Make_Integer_Literal (Loc,
|
|
Intval => System_Storage_Unit)))))));
|
|
|
|
-- subtype str__nn is Storage_Array (rg__x);
|
|
|
|
Str_Type := Make_Temporary (Loc, 'S');
|
|
Append_To (List_Def,
|
|
Make_Subtype_Declaration (Loc,
|
|
Defining_Identifier => Str_Type,
|
|
Subtype_Indication =>
|
|
Make_Subtype_Indication (Loc,
|
|
Subtype_Mark => New_Occurrence_Of (RTE (RE_Storage_Array), Loc),
|
|
Constraint =>
|
|
Make_Index_Or_Discriminant_Constraint (Loc,
|
|
Constraints =>
|
|
New_List (New_Occurrence_Of (Range_Type, Loc))))));
|
|
|
|
-- type Equiv_T is record
|
|
-- [ _parent : Tnn; ]
|
|
-- E : Str_Type;
|
|
-- end Equiv_T;
|
|
|
|
Equiv_Type := Make_Temporary (Loc, 'T');
|
|
Mutate_Ekind (Equiv_Type, E_Record_Type);
|
|
Set_Parent_Subtype (Equiv_Type, Constr_Root);
|
|
|
|
-- Set Is_Class_Wide_Equivalent_Type very early to trigger the special
|
|
-- treatment for this type. In particular, even though _parent's type
|
|
-- is a controlled type or contains controlled components, we do not
|
|
-- want to set Has_Controlled_Component on it to avoid making it gain
|
|
-- an unwanted _controller component.
|
|
|
|
Set_Is_Class_Wide_Equivalent_Type (Equiv_Type);
|
|
|
|
-- A class-wide equivalent type does not require initialization
|
|
|
|
Set_Suppress_Initialization (Equiv_Type);
|
|
|
|
if not Is_Interface (Root_Typ) then
|
|
Append_To (Comp_List,
|
|
Make_Component_Declaration (Loc,
|
|
Defining_Identifier =>
|
|
Make_Defining_Identifier (Loc, Name_uParent),
|
|
Component_Definition =>
|
|
Make_Component_Definition (Loc,
|
|
Aliased_Present => False,
|
|
Subtype_Indication => New_Occurrence_Of (Constr_Root, Loc))));
|
|
|
|
Set_Reverse_Storage_Order
|
|
(Equiv_Type, Reverse_Storage_Order (Base_Type (Root_Utyp)));
|
|
Set_Reverse_Bit_Order
|
|
(Equiv_Type, Reverse_Bit_Order (Base_Type (Root_Utyp)));
|
|
end if;
|
|
|
|
Append_To (Comp_List,
|
|
Make_Component_Declaration (Loc,
|
|
Defining_Identifier => Make_Temporary (Loc, 'C'),
|
|
Component_Definition =>
|
|
Make_Component_Definition (Loc,
|
|
Aliased_Present => False,
|
|
Subtype_Indication => New_Occurrence_Of (Str_Type, Loc))));
|
|
|
|
Append_To (List_Def,
|
|
Make_Full_Type_Declaration (Loc,
|
|
Defining_Identifier => Equiv_Type,
|
|
Type_Definition =>
|
|
Make_Record_Definition (Loc,
|
|
Component_List =>
|
|
Make_Component_List (Loc,
|
|
Component_Items => Comp_List,
|
|
Variant_Part => Empty))));
|
|
|
|
-- Suppress all checks during the analysis of the expanded code to avoid
|
|
-- the generation of spurious warnings under ZFP run-time.
|
|
|
|
Insert_Actions (E, List_Def, Suppress => All_Checks);
|
|
return Equiv_Type;
|
|
end Make_CW_Equivalent_Type;
|
|
|
|
-------------------------
|
|
-- Make_Invariant_Call --
|
|
-------------------------
|
|
|
|
function Make_Invariant_Call (Expr : Node_Id) return Node_Id is
|
|
Loc : constant Source_Ptr := Sloc (Expr);
|
|
Typ : constant Entity_Id := Base_Type (Etype (Expr));
|
|
pragma Assert (Has_Invariants (Typ));
|
|
Proc_Id : constant Entity_Id := Invariant_Procedure (Typ);
|
|
pragma Assert (Present (Proc_Id));
|
|
begin
|
|
-- The invariant procedure has a null body if assertions are disabled or
|
|
-- Assertion_Policy Ignore is in effect. In that case, generate a null
|
|
-- statement instead of a call to the invariant procedure.
|
|
|
|
if Has_Null_Body (Proc_Id) then
|
|
return Make_Null_Statement (Loc);
|
|
else
|
|
return
|
|
Make_Procedure_Call_Statement (Loc,
|
|
Name => New_Occurrence_Of (Proc_Id, Loc),
|
|
Parameter_Associations => New_List (Relocate_Node (Expr)));
|
|
end if;
|
|
end Make_Invariant_Call;
|
|
|
|
------------------------
|
|
-- Make_Literal_Range --
|
|
------------------------
|
|
|
|
function Make_Literal_Range
|
|
(Loc : Source_Ptr;
|
|
Literal_Typ : Entity_Id) return Node_Id
|
|
is
|
|
Lo : constant Node_Id :=
|
|
New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
|
|
Index : constant Entity_Id := Etype (Lo);
|
|
Length_Expr : constant Node_Id :=
|
|
Make_Op_Subtract (Loc,
|
|
Left_Opnd =>
|
|
Make_Integer_Literal (Loc,
|
|
Intval => String_Literal_Length (Literal_Typ)),
|
|
Right_Opnd => Make_Integer_Literal (Loc, 1));
|
|
|
|
Hi : Node_Id;
|
|
|
|
begin
|
|
Set_Analyzed (Lo, False);
|
|
|
|
if Is_Integer_Type (Index) then
|
|
Hi :=
|
|
Make_Op_Add (Loc,
|
|
Left_Opnd => New_Copy_Tree (Lo),
|
|
Right_Opnd => Length_Expr);
|
|
else
|
|
Hi :=
|
|
Make_Attribute_Reference (Loc,
|
|
Attribute_Name => Name_Val,
|
|
Prefix => New_Occurrence_Of (Index, Loc),
|
|
Expressions => New_List (
|
|
Make_Op_Add (Loc,
|
|
Left_Opnd =>
|
|
Make_Attribute_Reference (Loc,
|
|
Attribute_Name => Name_Pos,
|
|
Prefix => New_Occurrence_Of (Index, Loc),
|
|
Expressions => New_List (New_Copy_Tree (Lo))),
|
|
Right_Opnd => Length_Expr)));
|
|
end if;
|
|
|
|
return
|
|
Make_Range (Loc,
|
|
Low_Bound => Lo,
|
|
High_Bound => Hi);
|
|
end Make_Literal_Range;
|
|
|
|
--------------------------
|
|
-- Make_Non_Empty_Check --
|
|
--------------------------
|
|
|
|
function Make_Non_Empty_Check
|
|
(Loc : Source_Ptr;
|
|
N : Node_Id) return Node_Id
|
|
is
|
|
begin
|
|
return
|
|
Make_Op_Ne (Loc,
|
|
Left_Opnd =>
|
|
Make_Attribute_Reference (Loc,
|
|
Attribute_Name => Name_Length,
|
|
Prefix => Duplicate_Subexpr_No_Checks (N, Name_Req => True)),
|
|
Right_Opnd =>
|
|
Make_Integer_Literal (Loc, 0));
|
|
end Make_Non_Empty_Check;
|
|
|
|
-------------------------
|
|
-- Make_Predicate_Call --
|
|
-------------------------
|
|
|
|
-- WARNING: This routine manages Ghost regions. Return statements must be
|
|
-- replaced by gotos which jump to the end of the routine and restore the
|
|
-- Ghost mode.
|
|
|
|
function Make_Predicate_Call
|
|
(Typ : Entity_Id;
|
|
Expr : Node_Id;
|
|
Mem : Boolean := False) return Node_Id
|
|
is
|
|
Loc : constant Source_Ptr := Sloc (Expr);
|
|
|
|
Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
|
|
Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
|
|
-- Save the Ghost-related attributes to restore on exit
|
|
|
|
Call : Node_Id;
|
|
Func_Id : Entity_Id;
|
|
|
|
begin
|
|
Func_Id := Predicate_Function (Typ);
|
|
pragma Assert (Present (Func_Id));
|
|
|
|
-- The related type may be subject to pragma Ghost. Set the mode now to
|
|
-- ensure that the call is properly marked as Ghost.
|
|
|
|
Set_Ghost_Mode (Typ);
|
|
|
|
-- Call special membership version if requested and available
|
|
|
|
if Mem and then Present (Predicate_Function_M (Typ)) then
|
|
Func_Id := Predicate_Function_M (Typ);
|
|
end if;
|
|
|
|
-- Case of calling normal predicate function
|
|
|
|
-- If the type is tagged, the expression may be class-wide, in which
|
|
-- case it has to be converted to its root type, given that the
|
|
-- generated predicate function is not dispatching. The conversion is
|
|
-- type-safe and does not need validation, which matters when private
|
|
-- extensions are involved.
|
|
|
|
if Is_Tagged_Type (Typ) then
|
|
Call :=
|
|
Make_Function_Call (Loc,
|
|
Name => New_Occurrence_Of (Func_Id, Loc),
|
|
Parameter_Associations =>
|
|
New_List (OK_Convert_To (Typ, Relocate_Node (Expr))));
|
|
else
|
|
Call :=
|
|
Make_Function_Call (Loc,
|
|
Name => New_Occurrence_Of (Func_Id, Loc),
|
|
Parameter_Associations => New_List (Relocate_Node (Expr)));
|
|
end if;
|
|
|
|
Restore_Ghost_Region (Saved_GM, Saved_IGR);
|
|
|
|
return Call;
|
|
end Make_Predicate_Call;
|
|
|
|
--------------------------
|
|
-- Make_Predicate_Check --
|
|
--------------------------
|
|
|
|
function Make_Predicate_Check
|
|
(Typ : Entity_Id;
|
|
Expr : Node_Id) return Node_Id
|
|
is
|
|
Loc : constant Source_Ptr := Sloc (Expr);
|
|
|
|
procedure Add_Failure_Expression (Args : List_Id);
|
|
-- Add the failure expression of pragma Predicate_Failure (if any) to
|
|
-- list Args.
|
|
|
|
----------------------------
|
|
-- Add_Failure_Expression --
|
|
----------------------------
|
|
|
|
procedure Add_Failure_Expression (Args : List_Id) is
|
|
function Failure_Expression return Node_Id;
|
|
pragma Inline (Failure_Expression);
|
|
-- Find aspect or pragma Predicate_Failure that applies to type Typ
|
|
-- and return its expression. Return Empty if no such annotation is
|
|
-- available.
|
|
|
|
function Is_OK_PF_Aspect (Asp : Node_Id) return Boolean;
|
|
pragma Inline (Is_OK_PF_Aspect);
|
|
-- Determine whether aspect Asp is a suitable Predicate_Failure
|
|
-- aspect that applies to type Typ.
|
|
|
|
function Is_OK_PF_Pragma (Prag : Node_Id) return Boolean;
|
|
pragma Inline (Is_OK_PF_Pragma);
|
|
-- Determine whether pragma Prag is a suitable Predicate_Failure
|
|
-- pragma that applies to type Typ.
|
|
|
|
procedure Replace_Subtype_Reference (N : Node_Id);
|
|
-- Replace the current instance of type Typ denoted by N with
|
|
-- expression Expr.
|
|
|
|
------------------------
|
|
-- Failure_Expression --
|
|
------------------------
|
|
|
|
function Failure_Expression return Node_Id is
|
|
Item : Node_Id;
|
|
|
|
begin
|
|
-- The management of the rep item chain involves "inheritance" of
|
|
-- parent type chains. If a parent [sub]type is already subject to
|
|
-- pragma Predicate_Failure, then the pragma will also appear in
|
|
-- the chain of the child [sub]type, which in turn may possess a
|
|
-- pragma of its own. Avoid order-dependent issues by inspecting
|
|
-- the rep item chain directly. Note that routine Get_Pragma may
|
|
-- return a parent pragma.
|
|
|
|
Item := First_Rep_Item (Typ);
|
|
while Present (Item) loop
|
|
|
|
-- Predicate_Failure appears as an aspect
|
|
|
|
if Nkind (Item) = N_Aspect_Specification
|
|
and then Is_OK_PF_Aspect (Item)
|
|
then
|
|
return Expression (Item);
|
|
|
|
-- Predicate_Failure appears as a pragma
|
|
|
|
elsif Nkind (Item) = N_Pragma
|
|
and then Is_OK_PF_Pragma (Item)
|
|
then
|
|
return
|
|
Get_Pragma_Arg
|
|
(Next (First (Pragma_Argument_Associations (Item))));
|
|
end if;
|
|
|
|
Next_Rep_Item (Item);
|
|
end loop;
|
|
|
|
return Empty;
|
|
end Failure_Expression;
|
|
|
|
---------------------
|
|
-- Is_OK_PF_Aspect --
|
|
---------------------
|
|
|
|
function Is_OK_PF_Aspect (Asp : Node_Id) return Boolean is
|
|
begin
|
|
-- To qualify, the aspect must apply to the type subjected to the
|
|
-- predicate check.
|
|
|
|
return
|
|
Chars (Identifier (Asp)) = Name_Predicate_Failure
|
|
and then Present (Entity (Asp))
|
|
and then Entity (Asp) = Typ;
|
|
end Is_OK_PF_Aspect;
|
|
|
|
---------------------
|
|
-- Is_OK_PF_Pragma --
|
|
---------------------
|
|
|
|
function Is_OK_PF_Pragma (Prag : Node_Id) return Boolean is
|
|
Args : constant List_Id := Pragma_Argument_Associations (Prag);
|
|
Typ_Arg : Node_Id;
|
|
|
|
begin
|
|
-- Nothing to do when the pragma does not denote Predicate_Failure
|
|
|
|
if Pragma_Name (Prag) /= Name_Predicate_Failure then
|
|
return False;
|
|
|
|
-- Nothing to do when the pragma lacks arguments, in which case it
|
|
-- is illegal.
|
|
|
|
elsif Is_Empty_List (Args) then
|
|
return False;
|
|
end if;
|
|
|
|
Typ_Arg := Get_Pragma_Arg (First (Args));
|
|
|
|
-- To qualify, the local name argument of the pragma must denote
|
|
-- the type subjected to the predicate check.
|
|
|
|
return
|
|
Is_Entity_Name (Typ_Arg)
|
|
and then Present (Entity (Typ_Arg))
|
|
and then Entity (Typ_Arg) = Typ;
|
|
end Is_OK_PF_Pragma;
|
|
|
|
--------------------------------
|
|
-- Replace_Subtype_Reference --
|
|
--------------------------------
|
|
|
|
procedure Replace_Subtype_Reference (N : Node_Id) is
|
|
begin
|
|
Rewrite (N, New_Copy_Tree (Expr));
|
|
end Replace_Subtype_Reference;
|
|
|
|
procedure Replace_Subtype_References is
|
|
new Replace_Type_References_Generic (Replace_Subtype_Reference);
|
|
|
|
-- Local variables
|
|
|
|
PF_Expr : constant Node_Id := Failure_Expression;
|
|
Expr : Node_Id;
|
|
|
|
-- Start of processing for Add_Failure_Expression
|
|
|
|
begin
|
|
if Present (PF_Expr) then
|
|
|
|
-- Replace any occurrences of the current instance of the type
|
|
-- with the object subjected to the predicate check.
|
|
|
|
Expr := New_Copy_Tree (PF_Expr);
|
|
Replace_Subtype_References (Expr, Typ);
|
|
|
|
-- The failure expression appears as the third argument of the
|
|
-- Check pragma.
|
|
|
|
Append_To (Args,
|
|
Make_Pragma_Argument_Association (Loc,
|
|
Expression => Expr));
|
|
end if;
|
|
end Add_Failure_Expression;
|
|
|
|
-- Local variables
|
|
|
|
Args : List_Id;
|
|
Nam : Name_Id;
|
|
|
|
-- Start of processing for Make_Predicate_Check
|
|
|
|
begin
|
|
-- If predicate checks are suppressed, then return a null statement. For
|
|
-- this call, we check only the scope setting. If the caller wants to
|
|
-- check a specific entity's setting, they must do it manually.
|
|
|
|
if Predicate_Checks_Suppressed (Empty) then
|
|
return Make_Null_Statement (Loc);
|
|
end if;
|
|
|
|
-- Do not generate a check within stream functions and the like.
|
|
|
|
if not Predicate_Check_In_Scope (Expr) then
|
|
return Make_Null_Statement (Loc);
|
|
end if;
|
|
|
|
-- Compute proper name to use, we need to get this right so that the
|
|
-- right set of check policies apply to the Check pragma we are making.
|
|
|
|
if Has_Dynamic_Predicate_Aspect (Typ) then
|
|
Nam := Name_Dynamic_Predicate;
|
|
elsif Has_Static_Predicate_Aspect (Typ) then
|
|
Nam := Name_Static_Predicate;
|
|
else
|
|
Nam := Name_Predicate;
|
|
end if;
|
|
|
|
Args := New_List (
|
|
Make_Pragma_Argument_Association (Loc,
|
|
Expression => Make_Identifier (Loc, Nam)),
|
|
Make_Pragma_Argument_Association (Loc,
|
|
Expression => Make_Predicate_Call (Typ, Expr)));
|
|
|
|
-- If the subtype is subject to pragma Predicate_Failure, add the
|
|
-- failure expression as an additional parameter.
|
|
|
|
Add_Failure_Expression (Args);
|
|
|
|
return
|
|
Make_Pragma (Loc,
|
|
Chars => Name_Check,
|
|
Pragma_Argument_Associations => Args);
|
|
end Make_Predicate_Check;
|
|
|
|
----------------------------
|
|
-- Make_Subtype_From_Expr --
|
|
----------------------------
|
|
|
|
-- 1. If Expr is an unconstrained array expression, creates
|
|
-- Unc_Type(Expr'first(1)..Expr'last(1),..., Expr'first(n)..Expr'last(n))
|
|
|
|
-- 2. If Expr is a unconstrained discriminated type expression, creates
|
|
-- Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
|
|
|
|
-- 3. If Expr is class-wide, creates an implicit class-wide subtype
|
|
|
|
function Make_Subtype_From_Expr
|
|
(E : Node_Id;
|
|
Unc_Typ : Entity_Id;
|
|
Related_Id : Entity_Id := Empty) return Node_Id
|
|
is
|
|
List_Constr : constant List_Id := New_List;
|
|
Loc : constant Source_Ptr := Sloc (E);
|
|
D : Entity_Id;
|
|
Full_Exp : Node_Id;
|
|
Full_Subtyp : Entity_Id;
|
|
High_Bound : Entity_Id;
|
|
Index_Typ : Entity_Id;
|
|
Low_Bound : Entity_Id;
|
|
Priv_Subtyp : Entity_Id;
|
|
Utyp : Entity_Id;
|
|
|
|
begin
|
|
if Is_Private_Type (Unc_Typ)
|
|
and then Has_Unknown_Discriminants (Unc_Typ)
|
|
then
|
|
-- The caller requests a unique external name for both the private
|
|
-- and the full subtype.
|
|
|
|
if Present (Related_Id) then
|
|
Full_Subtyp :=
|
|
Make_Defining_Identifier (Loc,
|
|
Chars => New_External_Name (Chars (Related_Id), 'C'));
|
|
Priv_Subtyp :=
|
|
Make_Defining_Identifier (Loc,
|
|
Chars => New_External_Name (Chars (Related_Id), 'P'));
|
|
|
|
else
|
|
Full_Subtyp := Make_Temporary (Loc, 'C');
|
|
Priv_Subtyp := Make_Temporary (Loc, 'P');
|
|
end if;
|
|
|
|
-- Prepare the subtype completion. Use the base type to find the
|
|
-- underlying type because the type may be a generic actual or an
|
|
-- explicit subtype.
|
|
|
|
Utyp := Underlying_Type (Base_Type (Unc_Typ));
|
|
|
|
Full_Exp :=
|
|
Unchecked_Convert_To (Utyp, Duplicate_Subexpr_No_Checks (E));
|
|
Set_Parent (Full_Exp, Parent (E));
|
|
|
|
Insert_Action (E,
|
|
Make_Subtype_Declaration (Loc,
|
|
Defining_Identifier => Full_Subtyp,
|
|
Subtype_Indication => Make_Subtype_From_Expr (Full_Exp, Utyp)));
|
|
|
|
-- Define the dummy private subtype
|
|
|
|
Mutate_Ekind (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ)));
|
|
Set_Etype (Priv_Subtyp, Base_Type (Unc_Typ));
|
|
Set_Scope (Priv_Subtyp, Full_Subtyp);
|
|
Set_Is_Constrained (Priv_Subtyp);
|
|
Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ));
|
|
Set_Is_Itype (Priv_Subtyp);
|
|
Set_Associated_Node_For_Itype (Priv_Subtyp, E);
|
|
|
|
if Is_Tagged_Type (Priv_Subtyp) then
|
|
Set_Class_Wide_Type
|
|
(Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
|
|
Set_Direct_Primitive_Operations (Priv_Subtyp,
|
|
Direct_Primitive_Operations (Unc_Typ));
|
|
end if;
|
|
|
|
Set_Full_View (Priv_Subtyp, Full_Subtyp);
|
|
|
|
return New_Occurrence_Of (Priv_Subtyp, Loc);
|
|
|
|
elsif Is_Array_Type (Unc_Typ) then
|
|
Index_Typ := First_Index (Unc_Typ);
|
|
for J in 1 .. Number_Dimensions (Unc_Typ) loop
|
|
|
|
-- Capture the bounds of each index constraint in case the context
|
|
-- is an object declaration of an unconstrained type initialized
|
|
-- by a function call:
|
|
|
|
-- Obj : Unconstr_Typ := Func_Call;
|
|
|
|
-- This scenario requires secondary scope management and the index
|
|
-- constraint cannot depend on the temporary used to capture the
|
|
-- result of the function call.
|
|
|
|
-- SS_Mark;
|
|
-- Temp : Unconstr_Typ_Ptr := Func_Call'reference;
|
|
-- subtype S is Unconstr_Typ (Temp.all'First .. Temp.all'Last);
|
|
-- Obj : S := Temp.all;
|
|
-- SS_Release; -- Temp is gone at this point, bounds of S are
|
|
-- -- non existent.
|
|
|
|
-- Generate:
|
|
-- Low_Bound : constant Base_Type (Index_Typ) := E'First (J);
|
|
|
|
Low_Bound := Make_Temporary (Loc, 'B');
|
|
Insert_Action (E,
|
|
Make_Object_Declaration (Loc,
|
|
Defining_Identifier => Low_Bound,
|
|
Object_Definition =>
|
|
New_Occurrence_Of (Base_Type (Etype (Index_Typ)), Loc),
|
|
Constant_Present => True,
|
|
Expression =>
|
|
Make_Attribute_Reference (Loc,
|
|
Prefix => Duplicate_Subexpr_No_Checks (E),
|
|
Attribute_Name => Name_First,
|
|
Expressions => New_List (
|
|
Make_Integer_Literal (Loc, J)))));
|
|
|
|
-- Generate:
|
|
-- High_Bound : constant Base_Type (Index_Typ) := E'Last (J);
|
|
|
|
High_Bound := Make_Temporary (Loc, 'B');
|
|
Insert_Action (E,
|
|
Make_Object_Declaration (Loc,
|
|
Defining_Identifier => High_Bound,
|
|
Object_Definition =>
|
|
New_Occurrence_Of (Base_Type (Etype (Index_Typ)), Loc),
|
|
Constant_Present => True,
|
|
Expression =>
|
|
Make_Attribute_Reference (Loc,
|
|
Prefix => Duplicate_Subexpr_No_Checks (E),
|
|
Attribute_Name => Name_Last,
|
|
Expressions => New_List (
|
|
Make_Integer_Literal (Loc, J)))));
|
|
|
|
Append_To (List_Constr,
|
|
Make_Range (Loc,
|
|
Low_Bound => New_Occurrence_Of (Low_Bound, Loc),
|
|
High_Bound => New_Occurrence_Of (High_Bound, Loc)));
|
|
|
|
Next_Index (Index_Typ);
|
|
end loop;
|
|
|
|
elsif Is_Class_Wide_Type (Unc_Typ) then
|
|
declare
|
|
CW_Subtype : Entity_Id;
|
|
EQ_Typ : Entity_Id := Empty;
|
|
|
|
begin
|
|
-- A class-wide equivalent type is not needed on VM targets
|
|
-- because the VM back-ends handle the class-wide object
|
|
-- initialization itself (and doesn't need or want the
|
|
-- additional intermediate type to handle the assignment).
|
|
|
|
if Expander_Active and then Tagged_Type_Expansion then
|
|
|
|
-- If this is the class-wide type of a completion that is a
|
|
-- record subtype, set the type of the class-wide type to be
|
|
-- the full base type, for use in the expanded code for the
|
|
-- equivalent type. Should this be done earlier when the
|
|
-- completion is analyzed ???
|
|
|
|
if Is_Private_Type (Etype (Unc_Typ))
|
|
and then
|
|
Ekind (Full_View (Etype (Unc_Typ))) = E_Record_Subtype
|
|
then
|
|
Set_Etype (Unc_Typ, Base_Type (Full_View (Etype (Unc_Typ))));
|
|
end if;
|
|
|
|
EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
|
|
end if;
|
|
|
|
CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E);
|
|
Set_Equivalent_Type (CW_Subtype, EQ_Typ);
|
|
Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ));
|
|
|
|
return New_Occurrence_Of (CW_Subtype, Loc);
|
|
end;
|
|
|
|
-- Indefinite record type with discriminants
|
|
|
|
else
|
|
D := First_Discriminant (Unc_Typ);
|
|
while Present (D) loop
|
|
Append_To (List_Constr,
|
|
Make_Selected_Component (Loc,
|
|
Prefix => Duplicate_Subexpr_No_Checks (E),
|
|
Selector_Name => New_Occurrence_Of (D, Loc)));
|
|
|
|
Next_Discriminant (D);
|
|
end loop;
|
|
end if;
|
|
|
|
return
|
|
Make_Subtype_Indication (Loc,
|
|
Subtype_Mark => New_Occurrence_Of (Unc_Typ, Loc),
|
|
Constraint =>
|
|
Make_Index_Or_Discriminant_Constraint (Loc,
|
|
Constraints => List_Constr));
|
|
end Make_Subtype_From_Expr;
|
|
|
|
-----------------------------
|
|
-- Make_Variant_Comparison --
|
|
-----------------------------
|
|
|
|
function Make_Variant_Comparison
|
|
(Loc : Source_Ptr;
|
|
Mode : Name_Id;
|
|
Curr_Val : Node_Id;
|
|
Old_Val : Node_Id) return Node_Id
|
|
is
|
|
begin
|
|
if Mode = Name_Increases then
|
|
return Make_Op_Gt (Loc, Curr_Val, Old_Val);
|
|
else pragma Assert (Mode = Name_Decreases);
|
|
return Make_Op_Lt (Loc, Curr_Val, Old_Val);
|
|
end if;
|
|
end Make_Variant_Comparison;
|
|
|
|
-----------------
|
|
-- Map_Formals --
|
|
-----------------
|
|
|
|
procedure Map_Formals
|
|
(Parent_Subp : Entity_Id;
|
|
Derived_Subp : Entity_Id;
|
|
Force_Update : Boolean := False)
|
|
is
|
|
Par_Formal : Entity_Id := First_Formal (Parent_Subp);
|
|
Subp_Formal : Entity_Id := First_Formal (Derived_Subp);
|
|
|
|
begin
|
|
if Force_Update then
|
|
Type_Map.Set (Parent_Subp, Derived_Subp);
|
|
end if;
|
|
|
|
-- At this stage either we are under regular processing and the caller
|
|
-- has previously ensured that these primitives are already mapped (by
|
|
-- means of calling previously to Update_Primitives_Mapping), or we are
|
|
-- processing a late-overriding primitive and Force_Update updated above
|
|
-- the mapping of these primitives.
|
|
|
|
while Present (Par_Formal) and then Present (Subp_Formal) loop
|
|
Type_Map.Set (Par_Formal, Subp_Formal);
|
|
Next_Formal (Par_Formal);
|
|
Next_Formal (Subp_Formal);
|
|
end loop;
|
|
end Map_Formals;
|
|
|
|
---------------
|
|
-- Map_Types --
|
|
---------------
|
|
|
|
procedure Map_Types (Parent_Type : Entity_Id; Derived_Type : Entity_Id) is
|
|
|
|
-- NOTE: Most of the routines in Map_Types are intentionally unnested to
|
|
-- avoid deep indentation of code.
|
|
|
|
-- NOTE: Routines which deal with discriminant mapping operate on the
|
|
-- [underlying/record] full view of various types because those views
|
|
-- contain all discriminants and stored constraints.
|
|
|
|
procedure Add_Primitive (Prim : Entity_Id; Par_Typ : Entity_Id);
|
|
-- Subsidiary to Map_Primitives. Find a primitive in the inheritance or
|
|
-- overriding chain starting from Prim whose dispatching type is parent
|
|
-- type Par_Typ and add a mapping between the result and primitive Prim.
|
|
|
|
function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id;
|
|
-- Subsidiary to Map_Primitives. Return the next ancestor primitive in
|
|
-- the inheritance or overriding chain of subprogram Subp. Return Empty
|
|
-- if no such primitive is available.
|
|
|
|
function Build_Chain
|
|
(Par_Typ : Entity_Id;
|
|
Deriv_Typ : Entity_Id) return Elist_Id;
|
|
-- Subsidiary to Map_Discriminants. Recreate the derivation chain from
|
|
-- parent type Par_Typ leading down towards derived type Deriv_Typ. The
|
|
-- list has the form:
|
|
--
|
|
-- head tail
|
|
-- v v
|
|
-- <Ancestor_N> -> <Ancestor_N-1> -> <Ancestor_1> -> Deriv_Typ
|
|
--
|
|
-- Note that Par_Typ is not part of the resulting derivation chain
|
|
|
|
function Discriminated_View (Typ : Entity_Id) return Entity_Id;
|
|
-- Return the view of type Typ which could potentially contains either
|
|
-- the discriminants or stored constraints of the type.
|
|
|
|
function Find_Discriminant_Value
|
|
(Discr : Entity_Id;
|
|
Par_Typ : Entity_Id;
|
|
Deriv_Typ : Entity_Id;
|
|
Typ_Elmt : Elmt_Id) return Node_Or_Entity_Id;
|
|
-- Subsidiary to Map_Discriminants. Find the value of discriminant Discr
|
|
-- in the derivation chain starting from parent type Par_Typ leading to
|
|
-- derived type Deriv_Typ. The returned value is one of the following:
|
|
--
|
|
-- * An entity which is either a discriminant or a nondiscriminant
|
|
-- name, and renames/constraints Discr.
|
|
--
|
|
-- * An expression which constraints Discr
|
|
--
|
|
-- Typ_Elmt is an element of the derivation chain created by routine
|
|
-- Build_Chain and denotes the current ancestor being examined.
|
|
|
|
procedure Map_Discriminants
|
|
(Par_Typ : Entity_Id;
|
|
Deriv_Typ : Entity_Id);
|
|
-- Map each discriminant of type Par_Typ to a meaningful constraint
|
|
-- from the point of view of type Deriv_Typ.
|
|
|
|
procedure Map_Primitives (Par_Typ : Entity_Id; Deriv_Typ : Entity_Id);
|
|
-- Map each primitive of type Par_Typ to a corresponding primitive of
|
|
-- type Deriv_Typ.
|
|
|
|
-------------------
|
|
-- Add_Primitive --
|
|
-------------------
|
|
|
|
procedure Add_Primitive (Prim : Entity_Id; Par_Typ : Entity_Id) is
|
|
Par_Prim : Entity_Id;
|
|
|
|
begin
|
|
-- Inspect the inheritance chain through the Alias attribute and the
|
|
-- overriding chain through the Overridden_Operation looking for an
|
|
-- ancestor primitive with the appropriate dispatching type.
|
|
|
|
Par_Prim := Prim;
|
|
while Present (Par_Prim) loop
|
|
exit when Find_Dispatching_Type (Par_Prim) = Par_Typ;
|
|
Par_Prim := Ancestor_Primitive (Par_Prim);
|
|
end loop;
|
|
|
|
-- Create a mapping of the form:
|
|
|
|
-- parent type primitive -> derived type primitive
|
|
|
|
if Present (Par_Prim) then
|
|
Type_Map.Set (Par_Prim, Prim);
|
|
end if;
|
|
end Add_Primitive;
|
|
|
|
------------------------
|
|
-- Ancestor_Primitive --
|
|
------------------------
|
|
|
|
function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id is
|
|
Inher_Prim : constant Entity_Id := Alias (Subp);
|
|
Over_Prim : constant Entity_Id := Overridden_Operation (Subp);
|
|
|
|
begin
|
|
-- The current subprogram overrides an ancestor primitive
|
|
|
|
if Present (Over_Prim) then
|
|
return Over_Prim;
|
|
|
|
-- The current subprogram is an internally generated alias of an
|
|
-- inherited ancestor primitive.
|
|
|
|
elsif Present (Inher_Prim) then
|
|
-- It is possible that an internally generated alias could be
|
|
-- set to a subprogram which overrides the same aliased primitive,
|
|
-- so return Empty in this case.
|
|
|
|
if Ancestor_Primitive (Inher_Prim) = Subp then
|
|
return Empty;
|
|
end if;
|
|
|
|
return Inher_Prim;
|
|
|
|
-- Otherwise the current subprogram is the root of the inheritance or
|
|
-- overriding chain.
|
|
|
|
else
|
|
return Empty;
|
|
end if;
|
|
end Ancestor_Primitive;
|
|
|
|
-----------------
|
|
-- Build_Chain --
|
|
-----------------
|
|
|
|
function Build_Chain
|
|
(Par_Typ : Entity_Id;
|
|
Deriv_Typ : Entity_Id) return Elist_Id
|
|
is
|
|
Anc_Typ : Entity_Id;
|
|
Chain : Elist_Id;
|
|
Curr_Typ : Entity_Id;
|
|
|
|
begin
|
|
Chain := New_Elmt_List;
|
|
|
|
-- Add the derived type to the derivation chain
|
|
|
|
Prepend_Elmt (Deriv_Typ, Chain);
|
|
|
|
-- Examine all ancestors starting from the derived type climbing
|
|
-- towards parent type Par_Typ.
|
|
|
|
Curr_Typ := Deriv_Typ;
|
|
loop
|
|
-- Handle the case where the current type is a record which
|
|
-- derives from a subtype.
|
|
|
|
-- subtype Sub_Typ is Par_Typ ...
|
|
-- type Deriv_Typ is Sub_Typ ...
|
|
|
|
if Ekind (Curr_Typ) = E_Record_Type
|
|
and then Present (Parent_Subtype (Curr_Typ))
|
|
then
|
|
Anc_Typ := Parent_Subtype (Curr_Typ);
|
|
|
|
-- Handle the case where the current type is a record subtype of
|
|
-- another subtype.
|
|
|
|
-- subtype Sub_Typ1 is Par_Typ ...
|
|
-- subtype Sub_Typ2 is Sub_Typ1 ...
|
|
|
|
elsif Ekind (Curr_Typ) = E_Record_Subtype
|
|
and then Present (Cloned_Subtype (Curr_Typ))
|
|
then
|
|
Anc_Typ := Cloned_Subtype (Curr_Typ);
|
|
|
|
-- Otherwise use the direct parent type
|
|
|
|
else
|
|
Anc_Typ := Etype (Curr_Typ);
|
|
end if;
|
|
|
|
-- Use the first subtype when dealing with itypes
|
|
|
|
if Is_Itype (Anc_Typ) then
|
|
Anc_Typ := First_Subtype (Anc_Typ);
|
|
end if;
|
|
|
|
-- Work with the view which contains the discriminants and stored
|
|
-- constraints.
|
|
|
|
Anc_Typ := Discriminated_View (Anc_Typ);
|
|
|
|
-- Stop the climb when either the parent type has been reached or
|
|
-- there are no more ancestors left to examine.
|
|
|
|
exit when Anc_Typ = Curr_Typ or else Anc_Typ = Par_Typ;
|
|
|
|
Prepend_Unique_Elmt (Anc_Typ, Chain);
|
|
Curr_Typ := Anc_Typ;
|
|
end loop;
|
|
|
|
return Chain;
|
|
end Build_Chain;
|
|
|
|
------------------------
|
|
-- Discriminated_View --
|
|
------------------------
|
|
|
|
function Discriminated_View (Typ : Entity_Id) return Entity_Id is
|
|
T : Entity_Id;
|
|
|
|
begin
|
|
T := Typ;
|
|
|
|
-- Use the [underlying] full view when dealing with private types
|
|
-- because the view contains all inherited discriminants or stored
|
|
-- constraints.
|
|
|
|
if Is_Private_Type (T) then
|
|
if Present (Underlying_Full_View (T)) then
|
|
T := Underlying_Full_View (T);
|
|
|
|
elsif Present (Full_View (T)) then
|
|
T := Full_View (T);
|
|
end if;
|
|
end if;
|
|
|
|
-- Use the underlying record view when the type is an extenstion of
|
|
-- a parent type with unknown discriminants because the view contains
|
|
-- all inherited discriminants or stored constraints.
|
|
|
|
if Ekind (T) = E_Record_Type
|
|
and then Present (Underlying_Record_View (T))
|
|
then
|
|
T := Underlying_Record_View (T);
|
|
end if;
|
|
|
|
return T;
|
|
end Discriminated_View;
|
|
|
|
-----------------------------
|
|
-- Find_Discriminant_Value --
|
|
-----------------------------
|
|
|
|
function Find_Discriminant_Value
|
|
(Discr : Entity_Id;
|
|
Par_Typ : Entity_Id;
|
|
Deriv_Typ : Entity_Id;
|
|
Typ_Elmt : Elmt_Id) return Node_Or_Entity_Id
|
|
is
|
|
Discr_Pos : constant Uint := Discriminant_Number (Discr);
|
|
Typ : constant Entity_Id := Node (Typ_Elmt);
|
|
|
|
function Find_Constraint_Value
|
|
(Constr : Node_Or_Entity_Id) return Node_Or_Entity_Id;
|
|
-- Given constraint Constr, find what it denotes. This is either:
|
|
--
|
|
-- * An entity which is either a discriminant or a name
|
|
--
|
|
-- * An expression
|
|
|
|
---------------------------
|
|
-- Find_Constraint_Value --
|
|
---------------------------
|
|
|
|
function Find_Constraint_Value
|
|
(Constr : Node_Or_Entity_Id) return Node_Or_Entity_Id
|
|
is
|
|
begin
|
|
if Nkind (Constr) in N_Entity then
|
|
|
|
-- The constraint denotes a discriminant of the curren type
|
|
-- which renames the ancestor discriminant:
|
|
|
|
-- vv
|
|
-- type Typ (D1 : ...; DN : ...) is
|
|
-- new Anc (Discr => D1) with ...
|
|
-- ^^
|
|
|
|
if Ekind (Constr) = E_Discriminant then
|
|
|
|
-- The discriminant belongs to derived type Deriv_Typ. This
|
|
-- is the final value for the ancestor discriminant as the
|
|
-- derivations chain has been fully exhausted.
|
|
|
|
if Typ = Deriv_Typ then
|
|
return Constr;
|
|
|
|
-- Otherwise the discriminant may be renamed or constrained
|
|
-- at a lower level. Continue looking down the derivation
|
|
-- chain.
|
|
|
|
else
|
|
return
|
|
Find_Discriminant_Value
|
|
(Discr => Constr,
|
|
Par_Typ => Par_Typ,
|
|
Deriv_Typ => Deriv_Typ,
|
|
Typ_Elmt => Next_Elmt (Typ_Elmt));
|
|
end if;
|
|
|
|
-- Otherwise the constraint denotes a reference to some name
|
|
-- which results in a Stored discriminant:
|
|
|
|
-- vvvv
|
|
-- Name : ...;
|
|
-- type Typ (D1 : ...; DN : ...) is
|
|
-- new Anc (Discr => Name) with ...
|
|
-- ^^^^
|
|
|
|
-- Return the name as this is the proper constraint of the
|
|
-- discriminant.
|
|
|
|
else
|
|
return Constr;
|
|
end if;
|
|
|
|
-- The constraint denotes a reference to a name
|
|
|
|
elsif Is_Entity_Name (Constr) then
|
|
return Find_Constraint_Value (Entity (Constr));
|
|
|
|
-- Otherwise the current constraint is an expression which yields
|
|
-- a Stored discriminant:
|
|
|
|
-- type Typ (D1 : ...; DN : ...) is
|
|
-- new Anc (Discr => <expression>) with ...
|
|
-- ^^^^^^^^^^
|
|
|
|
-- Return the expression as this is the proper constraint of the
|
|
-- discriminant.
|
|
|
|
else
|
|
return Constr;
|
|
end if;
|
|
end Find_Constraint_Value;
|
|
|
|
-- Local variables
|
|
|
|
Constrs : constant Elist_Id := Stored_Constraint (Typ);
|
|
|
|
Constr_Elmt : Elmt_Id;
|
|
Pos : Uint;
|
|
Typ_Discr : Entity_Id;
|
|
|
|
-- Start of processing for Find_Discriminant_Value
|
|
|
|
begin
|
|
-- The algorithm for finding the value of a discriminant works as
|
|
-- follows. First, it recreates the derivation chain from Par_Typ
|
|
-- to Deriv_Typ as a list:
|
|
|
|
-- Par_Typ (shown for completeness)
|
|
-- v
|
|
-- Ancestor_N <-- head of chain
|
|
-- v
|
|
-- Ancestor_1
|
|
-- v
|
|
-- Deriv_Typ <-- tail of chain
|
|
|
|
-- The algorithm then traces the fate of a parent discriminant down
|
|
-- the derivation chain. At each derivation level, the discriminant
|
|
-- may be either inherited or constrained.
|
|
|
|
-- 1) Discriminant is inherited: there are two cases, depending on
|
|
-- which type is inheriting.
|
|
|
|
-- 1.1) Deriv_Typ is inheriting:
|
|
|
|
-- type Ancestor (D_1 : ...) is tagged ...
|
|
-- type Deriv_Typ is new Ancestor ...
|
|
|
|
-- In this case the inherited discriminant is the final value of
|
|
-- the parent discriminant because the end of the derivation chain
|
|
-- has been reached.
|
|
|
|
-- 1.2) Some other type is inheriting:
|
|
|
|
-- type Ancestor_1 (D_1 : ...) is tagged ...
|
|
-- type Ancestor_2 is new Ancestor_1 ...
|
|
|
|
-- In this case the algorithm continues to trace the fate of the
|
|
-- inherited discriminant down the derivation chain because it may
|
|
-- be further inherited or constrained.
|
|
|
|
-- 2) Discriminant is constrained: there are three cases, depending
|
|
-- on what the constraint is.
|
|
|
|
-- 2.1) The constraint is another discriminant (aka renaming):
|
|
|
|
-- type Ancestor_1 (D_1 : ...) is tagged ...
|
|
-- type Ancestor_2 (D_2 : ...) is new Ancestor_1 (D_1 => D_2) ...
|
|
|
|
-- In this case the constraining discriminant becomes the one to
|
|
-- track down the derivation chain. The algorithm already knows
|
|
-- that D_2 constrains D_1, therefore if the algorithm finds the
|
|
-- value of D_2, then this would also be the value for D_1.
|
|
|
|
-- 2.2) The constraint is a name (aka Stored):
|
|
|
|
-- Name : ...
|
|
-- type Ancestor_1 (D_1 : ...) is tagged ...
|
|
-- type Ancestor_2 is new Ancestor_1 (D_1 => Name) ...
|
|
|
|
-- In this case the name is the final value of D_1 because the
|
|
-- discriminant cannot be further constrained.
|
|
|
|
-- 2.3) The constraint is an expression (aka Stored):
|
|
|
|
-- type Ancestor_1 (D_1 : ...) is tagged ...
|
|
-- type Ancestor_2 is new Ancestor_1 (D_1 => 1 + 2) ...
|
|
|
|
-- Similar to 2.2, the expression is the final value of D_1
|
|
|
|
Pos := Uint_1;
|
|
|
|
-- When a derived type constrains its parent type, all constaints
|
|
-- appear in the Stored_Constraint list. Examine the list looking
|
|
-- for a positional match.
|
|
|
|
if Present (Constrs) then
|
|
Constr_Elmt := First_Elmt (Constrs);
|
|
while Present (Constr_Elmt) loop
|
|
|
|
-- The position of the current constraint matches that of the
|
|
-- ancestor discriminant.
|
|
|
|
if Pos = Discr_Pos then
|
|
return Find_Constraint_Value (Node (Constr_Elmt));
|
|
end if;
|
|
|
|
Next_Elmt (Constr_Elmt);
|
|
Pos := Pos + 1;
|
|
end loop;
|
|
|
|
-- Otherwise the derived type does not constraint its parent type in
|
|
-- which case it inherits the parent discriminants.
|
|
|
|
else
|
|
Typ_Discr := First_Discriminant (Typ);
|
|
while Present (Typ_Discr) loop
|
|
|
|
-- The position of the current discriminant matches that of the
|
|
-- ancestor discriminant.
|
|
|
|
if Pos = Discr_Pos then
|
|
return Find_Constraint_Value (Typ_Discr);
|
|
end if;
|
|
|
|
Next_Discriminant (Typ_Discr);
|
|
Pos := Pos + 1;
|
|
end loop;
|
|
end if;
|
|
|
|
-- A discriminant must always have a corresponding value. This is
|
|
-- either another discriminant, a name, or an expression. If this
|
|
-- point is reached, them most likely the derivation chain employs
|
|
-- the wrong views of types.
|
|
|
|
pragma Assert (False);
|
|
|
|
return Empty;
|
|
end Find_Discriminant_Value;
|
|
|
|
-----------------------
|
|
-- Map_Discriminants --
|
|
-----------------------
|
|
|
|
procedure Map_Discriminants
|
|
(Par_Typ : Entity_Id;
|
|
Deriv_Typ : Entity_Id)
|
|
is
|
|
Deriv_Chain : constant Elist_Id := Build_Chain (Par_Typ, Deriv_Typ);
|
|
|
|
Discr : Entity_Id;
|
|
Discr_Val : Node_Or_Entity_Id;
|
|
|
|
begin
|
|
-- Examine each discriminant of parent type Par_Typ and find a
|
|
-- suitable value for it from the point of view of derived type
|
|
-- Deriv_Typ.
|
|
|
|
if Has_Discriminants (Par_Typ) then
|
|
Discr := First_Discriminant (Par_Typ);
|
|
while Present (Discr) loop
|
|
Discr_Val :=
|
|
Find_Discriminant_Value
|
|
(Discr => Discr,
|
|
Par_Typ => Par_Typ,
|
|
Deriv_Typ => Deriv_Typ,
|
|
Typ_Elmt => First_Elmt (Deriv_Chain));
|
|
|
|
-- Create a mapping of the form:
|
|
|
|
-- parent type discriminant -> value
|
|
|
|
Type_Map.Set (Discr, Discr_Val);
|
|
|
|
Next_Discriminant (Discr);
|
|
end loop;
|
|
end if;
|
|
end Map_Discriminants;
|
|
|
|
--------------------
|
|
-- Map_Primitives --
|
|
--------------------
|
|
|
|
procedure Map_Primitives (Par_Typ : Entity_Id; Deriv_Typ : Entity_Id) is
|
|
Deriv_Prim : Entity_Id;
|
|
Par_Prim : Entity_Id;
|
|
Par_Prims : Elist_Id;
|
|
Prim_Elmt : Elmt_Id;
|
|
|
|
begin
|
|
-- Inspect the primitives of the derived type and determine whether
|
|
-- they relate to the primitives of the parent type. If there is a
|
|
-- meaningful relation, create a mapping of the form:
|
|
|
|
-- parent type primitive -> derived type primitive
|
|
|
|
if Present (Direct_Primitive_Operations (Deriv_Typ)) then
|
|
Prim_Elmt := First_Elmt (Direct_Primitive_Operations (Deriv_Typ));
|
|
while Present (Prim_Elmt) loop
|
|
Deriv_Prim := Node (Prim_Elmt);
|
|
|
|
if Is_Subprogram (Deriv_Prim)
|
|
and then Find_Dispatching_Type (Deriv_Prim) = Deriv_Typ
|
|
then
|
|
Add_Primitive (Deriv_Prim, Par_Typ);
|
|
end if;
|
|
|
|
Next_Elmt (Prim_Elmt);
|
|
end loop;
|
|
end if;
|
|
|
|
-- If the parent operation is an interface operation, the overriding
|
|
-- indicator is not present. Instead, we get from the interface
|
|
-- operation the primitive of the current type that implements it.
|
|
|
|
if Is_Interface (Par_Typ) then
|
|
Par_Prims := Collect_Primitive_Operations (Par_Typ);
|
|
|
|
if Present (Par_Prims) then
|
|
Prim_Elmt := First_Elmt (Par_Prims);
|
|
|
|
while Present (Prim_Elmt) loop
|
|
Par_Prim := Node (Prim_Elmt);
|
|
Deriv_Prim :=
|
|
Find_Primitive_Covering_Interface (Deriv_Typ, Par_Prim);
|
|
|
|
if Present (Deriv_Prim) then
|
|
Type_Map.Set (Par_Prim, Deriv_Prim);
|
|
end if;
|
|
|
|
Next_Elmt (Prim_Elmt);
|
|
end loop;
|
|
end if;
|
|
end if;
|
|
end Map_Primitives;
|
|
|
|
-- Start of processing for Map_Types
|
|
|
|
begin
|
|
-- Nothing to do if there are no types to work with
|
|
|
|
if No (Parent_Type) or else No (Derived_Type) then
|
|
return;
|
|
|
|
-- Nothing to do if the mapping already exists
|
|
|
|
elsif Type_Map.Get (Parent_Type) = Derived_Type then
|
|
return;
|
|
|
|
-- Nothing to do if both types are not tagged. Note that untagged types
|
|
-- do not have primitive operations and their discriminants are already
|
|
-- handled by gigi.
|
|
|
|
elsif not Is_Tagged_Type (Parent_Type)
|
|
or else not Is_Tagged_Type (Derived_Type)
|
|
then
|
|
return;
|
|
end if;
|
|
|
|
-- Create a mapping of the form
|
|
|
|
-- parent type -> derived type
|
|
|
|
-- to prevent any subsequent attempts to produce the same relations
|
|
|
|
Type_Map.Set (Parent_Type, Derived_Type);
|
|
|
|
-- Create mappings of the form
|
|
|
|
-- parent type discriminant -> derived type discriminant
|
|
-- <or>
|
|
-- parent type discriminant -> constraint
|
|
|
|
-- Note that mapping of discriminants breaks privacy because it needs to
|
|
-- work with those views which contains the discriminants and any stored
|
|
-- constraints.
|
|
|
|
Map_Discriminants
|
|
(Par_Typ => Discriminated_View (Parent_Type),
|
|
Deriv_Typ => Discriminated_View (Derived_Type));
|
|
|
|
-- Create mappings of the form
|
|
|
|
-- parent type primitive -> derived type primitive
|
|
|
|
Map_Primitives
|
|
(Par_Typ => Parent_Type,
|
|
Deriv_Typ => Derived_Type);
|
|
end Map_Types;
|
|
|
|
----------------------------
|
|
-- Matching_Standard_Type --
|
|
----------------------------
|
|
|
|
function Matching_Standard_Type (Typ : Entity_Id) return Entity_Id is
|
|
pragma Assert (Is_Scalar_Type (Typ));
|
|
Siz : constant Uint := Esize (Typ);
|
|
|
|
begin
|
|
-- Floating-point cases
|
|
|
|
if Is_Floating_Point_Type (Typ) then
|
|
if Siz <= Esize (Standard_Short_Float) then
|
|
return Standard_Short_Float;
|
|
elsif Siz <= Esize (Standard_Float) then
|
|
return Standard_Float;
|
|
elsif Siz <= Esize (Standard_Long_Float) then
|
|
return Standard_Long_Float;
|
|
elsif Siz <= Esize (Standard_Long_Long_Float) then
|
|
return Standard_Long_Long_Float;
|
|
else
|
|
raise Program_Error;
|
|
end if;
|
|
|
|
-- Integer cases (includes fixed-point types)
|
|
|
|
-- Unsigned integer cases (includes normal enumeration types)
|
|
|
|
else
|
|
return Small_Integer_Type_For (Siz, Is_Unsigned_Type (Typ));
|
|
end if;
|
|
end Matching_Standard_Type;
|
|
|
|
-----------------------------
|
|
-- May_Generate_Large_Temp --
|
|
-----------------------------
|
|
|
|
-- At the current time, the only types that we return False for (i.e. where
|
|
-- we decide we know they cannot generate large temps) are ones where we
|
|
-- know the size is 256 bits or less at compile time, and we are still not
|
|
-- doing a thorough job on arrays and records.
|
|
|
|
function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
|
|
begin
|
|
if not Size_Known_At_Compile_Time (Typ) then
|
|
return False;
|
|
end if;
|
|
|
|
if Known_Esize (Typ) and then Esize (Typ) <= 256 then
|
|
return False;
|
|
end if;
|
|
|
|
if Is_Array_Type (Typ)
|
|
and then Present (Packed_Array_Impl_Type (Typ))
|
|
then
|
|
return May_Generate_Large_Temp (Packed_Array_Impl_Type (Typ));
|
|
end if;
|
|
|
|
return True;
|
|
end May_Generate_Large_Temp;
|
|
|
|
--------------------------------------------
|
|
-- Needs_Conditional_Null_Excluding_Check --
|
|
--------------------------------------------
|
|
|
|
function Needs_Conditional_Null_Excluding_Check
|
|
(Typ : Entity_Id) return Boolean
|
|
is
|
|
begin
|
|
return
|
|
Is_Array_Type (Typ) and then Can_Never_Be_Null (Component_Type (Typ));
|
|
end Needs_Conditional_Null_Excluding_Check;
|
|
|
|
----------------------------
|
|
-- Needs_Constant_Address --
|
|
----------------------------
|
|
|
|
function Needs_Constant_Address
|
|
(Decl : Node_Id;
|
|
Typ : Entity_Id) return Boolean
|
|
is
|
|
begin
|
|
-- If we have no initialization of any kind, then we don't need to place
|
|
-- any restrictions on the address clause, because the object will be
|
|
-- elaborated after the address clause is evaluated. This happens if the
|
|
-- declaration has no initial expression, or the type has no implicit
|
|
-- initialization, or the object is imported.
|
|
|
|
-- The same holds for all initialized scalar types and all access types.
|
|
-- Packed bit array types of size up to the maximum integer size are
|
|
-- represented using a modular type with an initialization (to zero) and
|
|
-- can be processed like other initialized scalar types.
|
|
|
|
-- If the type is controlled, code to attach the object to a
|
|
-- finalization chain is generated at the point of declaration, and
|
|
-- therefore the elaboration of the object cannot be delayed: the
|
|
-- address expression must be a constant.
|
|
|
|
if No (Expression (Decl))
|
|
and then not Needs_Finalization (Typ)
|
|
and then
|
|
(not Has_Non_Null_Base_Init_Proc (Typ)
|
|
or else Is_Imported (Defining_Identifier (Decl)))
|
|
then
|
|
return False;
|
|
|
|
elsif (Present (Expression (Decl)) and then Is_Scalar_Type (Typ))
|
|
or else Is_Access_Type (Typ)
|
|
or else
|
|
(Is_Bit_Packed_Array (Typ)
|
|
and then Is_Modular_Integer_Type (Packed_Array_Impl_Type (Typ)))
|
|
then
|
|
return False;
|
|
|
|
else
|
|
-- Otherwise, we require the address clause to be constant because
|
|
-- the call to the initialization procedure (or the attach code) has
|
|
-- to happen at the point of the declaration.
|
|
|
|
-- Actually the IP call has been moved to the freeze actions anyway,
|
|
-- so maybe we can relax this restriction???
|
|
|
|
return True;
|
|
end if;
|
|
end Needs_Constant_Address;
|
|
|
|
----------------------------
|
|
-- New_Class_Wide_Subtype --
|
|
----------------------------
|
|
|
|
function New_Class_Wide_Subtype
|
|
(CW_Typ : Entity_Id;
|
|
N : Node_Id) return Entity_Id
|
|
is
|
|
Res : constant Entity_Id := Create_Itype (E_Void, N);
|
|
|
|
-- Capture relevant attributes of the class-wide subtype which must be
|
|
-- restored after the copy.
|
|
|
|
Res_Chars : constant Name_Id := Chars (Res);
|
|
Res_Is_CGE : constant Boolean := Is_Checked_Ghost_Entity (Res);
|
|
Res_Is_IGE : constant Boolean := Is_Ignored_Ghost_Entity (Res);
|
|
Res_Is_IGN : constant Boolean := Is_Ignored_Ghost_Node (Res);
|
|
Res_Scope : constant Entity_Id := Scope (Res);
|
|
|
|
begin
|
|
Copy_Node (CW_Typ, Res);
|
|
|
|
-- Restore the relevant attributes of the class-wide subtype
|
|
|
|
Set_Chars (Res, Res_Chars);
|
|
Set_Is_Checked_Ghost_Entity (Res, Res_Is_CGE);
|
|
Set_Is_Ignored_Ghost_Entity (Res, Res_Is_IGE);
|
|
Set_Is_Ignored_Ghost_Node (Res, Res_Is_IGN);
|
|
Set_Scope (Res, Res_Scope);
|
|
|
|
-- Decorate the class-wide subtype
|
|
|
|
Set_Associated_Node_For_Itype (Res, N);
|
|
Set_Comes_From_Source (Res, False);
|
|
Mutate_Ekind (Res, E_Class_Wide_Subtype);
|
|
Set_Etype (Res, Base_Type (CW_Typ));
|
|
Set_Freeze_Node (Res, Empty);
|
|
Set_Is_Frozen (Res, False);
|
|
Set_Is_Itype (Res);
|
|
Set_Is_Public (Res, False);
|
|
Set_Next_Entity (Res, Empty);
|
|
Set_Prev_Entity (Res, Empty);
|
|
Set_Sloc (Res, Sloc (N));
|
|
|
|
Set_Public_Status (Res);
|
|
|
|
return Res;
|
|
end New_Class_Wide_Subtype;
|
|
|
|
-----------------------------------
|
|
-- OK_To_Do_Constant_Replacement --
|
|
-----------------------------------
|
|
|
|
function OK_To_Do_Constant_Replacement (E : Entity_Id) return Boolean is
|
|
ES : constant Entity_Id := Scope (E);
|
|
CS : Entity_Id;
|
|
|
|
begin
|
|
-- Do not replace statically allocated objects, because they may be
|
|
-- modified outside the current scope.
|
|
|
|
if Is_Statically_Allocated (E) then
|
|
return False;
|
|
|
|
-- Do not replace aliased or volatile objects, since we don't know what
|
|
-- else might change the value.
|
|
|
|
elsif Is_Aliased (E) or else Treat_As_Volatile (E) then
|
|
return False;
|
|
|
|
-- Debug flag -gnatdM disconnects this optimization
|
|
|
|
elsif Debug_Flag_MM then
|
|
return False;
|
|
|
|
-- Otherwise check scopes
|
|
|
|
else
|
|
CS := Current_Scope;
|
|
|
|
loop
|
|
-- If we are in right scope, replacement is safe
|
|
|
|
if CS = ES then
|
|
return True;
|
|
|
|
-- Packages do not affect the determination of safety
|
|
|
|
elsif Ekind (CS) = E_Package then
|
|
exit when CS = Standard_Standard;
|
|
CS := Scope (CS);
|
|
|
|
-- Blocks do not affect the determination of safety
|
|
|
|
elsif Ekind (CS) = E_Block then
|
|
CS := Scope (CS);
|
|
|
|
-- Loops do not affect the determination of safety. Note that we
|
|
-- kill all current values on entry to a loop, so we are just
|
|
-- talking about processing within a loop here.
|
|
|
|
elsif Ekind (CS) = E_Loop then
|
|
CS := Scope (CS);
|
|
|
|
-- Otherwise, the reference is dubious, and we cannot be sure that
|
|
-- it is safe to do the replacement.
|
|
|
|
else
|
|
exit;
|
|
end if;
|
|
end loop;
|
|
|
|
return False;
|
|
end if;
|
|
end OK_To_Do_Constant_Replacement;
|
|
|
|
------------------------------------
|
|
-- Possible_Bit_Aligned_Component --
|
|
------------------------------------
|
|
|
|
function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean is
|
|
begin
|
|
-- Do not process an unanalyzed node because it is not yet decorated and
|
|
-- most checks performed below will fail.
|
|
|
|
if not Analyzed (N) then
|
|
return False;
|
|
end if;
|
|
|
|
-- There are never alignment issues in CodePeer mode
|
|
|
|
if CodePeer_Mode then
|
|
return False;
|
|
end if;
|
|
|
|
case Nkind (N) is
|
|
|
|
-- Case of indexed component
|
|
|
|
when N_Indexed_Component =>
|
|
declare
|
|
P : constant Node_Id := Prefix (N);
|
|
Ptyp : constant Entity_Id := Etype (P);
|
|
|
|
begin
|
|
-- If we know the component size and it is not larger than the
|
|
-- maximum integer size, then we are OK. The back end does the
|
|
-- assignment of small misaligned objects correctly.
|
|
|
|
if Known_Static_Component_Size (Ptyp)
|
|
and then Component_Size (Ptyp) <= System_Max_Integer_Size
|
|
then
|
|
return False;
|
|
|
|
-- Otherwise, we need to test the prefix, to see if we are
|
|
-- indexing from a possibly unaligned component.
|
|
|
|
else
|
|
return Possible_Bit_Aligned_Component (P);
|
|
end if;
|
|
end;
|
|
|
|
-- Case of selected component
|
|
|
|
when N_Selected_Component =>
|
|
declare
|
|
P : constant Node_Id := Prefix (N);
|
|
Comp : constant Entity_Id := Entity (Selector_Name (N));
|
|
|
|
begin
|
|
-- This is the crucial test: if the component itself causes
|
|
-- trouble, then we can stop and return True.
|
|
|
|
if Component_May_Be_Bit_Aligned (Comp) then
|
|
return True;
|
|
|
|
-- Otherwise, we need to test the prefix, to see if we are
|
|
-- selecting from a possibly unaligned component.
|
|
|
|
else
|
|
return Possible_Bit_Aligned_Component (P);
|
|
end if;
|
|
end;
|
|
|
|
-- For a slice, test the prefix, if that is possibly misaligned,
|
|
-- then for sure the slice is.
|
|
|
|
when N_Slice =>
|
|
return Possible_Bit_Aligned_Component (Prefix (N));
|
|
|
|
-- For an unchecked conversion, check whether the expression may
|
|
-- be bit aligned.
|
|
|
|
when N_Unchecked_Type_Conversion =>
|
|
return Possible_Bit_Aligned_Component (Expression (N));
|
|
|
|
-- If we have none of the above, it means that we have fallen off the
|
|
-- top testing prefixes recursively, and we now have a stand alone
|
|
-- object, where we don't have a problem, unless this is a renaming,
|
|
-- in which case we need to look into the renamed object.
|
|
|
|
when others =>
|
|
if Is_Entity_Name (N)
|
|
and then Is_Object (Entity (N))
|
|
and then Present (Renamed_Object (Entity (N)))
|
|
then
|
|
return
|
|
Possible_Bit_Aligned_Component (Renamed_Object (Entity (N)));
|
|
else
|
|
return False;
|
|
end if;
|
|
end case;
|
|
end Possible_Bit_Aligned_Component;
|
|
|
|
-----------------------------------------------
|
|
-- Process_Statements_For_Controlled_Objects --
|
|
-----------------------------------------------
|
|
|
|
procedure Process_Statements_For_Controlled_Objects (N : Node_Id) is
|
|
Loc : constant Source_Ptr := Sloc (N);
|
|
|
|
function Are_Wrapped (L : List_Id) return Boolean;
|
|
-- Determine whether list L contains only one statement which is a block
|
|
|
|
function Wrap_Statements_In_Block
|
|
(L : List_Id;
|
|
Scop : Entity_Id := Current_Scope) return Node_Id;
|
|
-- Given a list of statements L, wrap it in a block statement and return
|
|
-- the generated node. Scop is either the current scope or the scope of
|
|
-- the context (if applicable).
|
|
|
|
-----------------
|
|
-- Are_Wrapped --
|
|
-----------------
|
|
|
|
function Are_Wrapped (L : List_Id) return Boolean is
|
|
Stmt : constant Node_Id := First (L);
|
|
begin
|
|
return
|
|
Present (Stmt)
|
|
and then No (Next (Stmt))
|
|
and then Nkind (Stmt) = N_Block_Statement;
|
|
end Are_Wrapped;
|
|
|
|
------------------------------
|
|
-- Wrap_Statements_In_Block --
|
|
------------------------------
|
|
|
|
function Wrap_Statements_In_Block
|
|
(L : List_Id;
|
|
Scop : Entity_Id := Current_Scope) return Node_Id
|
|
is
|
|
Block_Id : Entity_Id;
|
|
Block_Nod : Node_Id;
|
|
Iter_Loop : Entity_Id;
|
|
|
|
begin
|
|
Block_Nod :=
|
|
Make_Block_Statement (Loc,
|
|
Declarations => No_List,
|
|
Handled_Statement_Sequence =>
|
|
Make_Handled_Sequence_Of_Statements (Loc,
|
|
Statements => L));
|
|
|
|
-- Create a label for the block in case the block needs to manage the
|
|
-- secondary stack. A label allows for flag Uses_Sec_Stack to be set.
|
|
|
|
Add_Block_Identifier (Block_Nod, Block_Id);
|
|
|
|
-- When wrapping the statements of an iterator loop, check whether
|
|
-- the loop requires secondary stack management and if so, propagate
|
|
-- the appropriate flags to the block. This ensures that the cursor
|
|
-- is properly cleaned up at each iteration of the loop.
|
|
|
|
Iter_Loop := Find_Enclosing_Iterator_Loop (Scop);
|
|
|
|
if Present (Iter_Loop) then
|
|
Set_Uses_Sec_Stack (Block_Id, Uses_Sec_Stack (Iter_Loop));
|
|
|
|
-- Secondary stack reclamation is suppressed when the associated
|
|
-- iterator loop contains a return statement which uses the stack.
|
|
|
|
Set_Sec_Stack_Needed_For_Return
|
|
(Block_Id, Sec_Stack_Needed_For_Return (Iter_Loop));
|
|
end if;
|
|
|
|
return Block_Nod;
|
|
end Wrap_Statements_In_Block;
|
|
|
|
-- Local variables
|
|
|
|
Block : Node_Id;
|
|
|
|
-- Start of processing for Process_Statements_For_Controlled_Objects
|
|
|
|
begin
|
|
-- Whenever a non-handled statement list is wrapped in a block, the
|
|
-- block must be explicitly analyzed to redecorate all entities in the
|
|
-- list and ensure that a finalizer is properly built.
|
|
|
|
case Nkind (N) is
|
|
when N_Conditional_Entry_Call
|
|
| N_Elsif_Part
|
|
| N_If_Statement
|
|
| N_Selective_Accept
|
|
=>
|
|
-- Check the "then statements" for elsif parts and if statements
|
|
|
|
if Nkind (N) in N_Elsif_Part | N_If_Statement
|
|
and then not Is_Empty_List (Then_Statements (N))
|
|
and then not Are_Wrapped (Then_Statements (N))
|
|
and then Requires_Cleanup_Actions
|
|
(L => Then_Statements (N),
|
|
Lib_Level => False,
|
|
Nested_Constructs => False)
|
|
then
|
|
Block := Wrap_Statements_In_Block (Then_Statements (N));
|
|
Set_Then_Statements (N, New_List (Block));
|
|
|
|
Analyze (Block);
|
|
end if;
|
|
|
|
-- Check the "else statements" for conditional entry calls, if
|
|
-- statements and selective accepts.
|
|
|
|
if Nkind (N) in
|
|
N_Conditional_Entry_Call | N_If_Statement | N_Selective_Accept
|
|
and then not Is_Empty_List (Else_Statements (N))
|
|
and then not Are_Wrapped (Else_Statements (N))
|
|
and then Requires_Cleanup_Actions
|
|
(L => Else_Statements (N),
|
|
Lib_Level => False,
|
|
Nested_Constructs => False)
|
|
then
|
|
Block := Wrap_Statements_In_Block (Else_Statements (N));
|
|
Set_Else_Statements (N, New_List (Block));
|
|
|
|
Analyze (Block);
|
|
end if;
|
|
|
|
when N_Abortable_Part
|
|
| N_Accept_Alternative
|
|
| N_Case_Statement_Alternative
|
|
| N_Delay_Alternative
|
|
| N_Entry_Call_Alternative
|
|
| N_Exception_Handler
|
|
| N_Loop_Statement
|
|
| N_Triggering_Alternative
|
|
=>
|
|
if not Is_Empty_List (Statements (N))
|
|
and then not Are_Wrapped (Statements (N))
|
|
and then Requires_Cleanup_Actions
|
|
(L => Statements (N),
|
|
Lib_Level => False,
|
|
Nested_Constructs => False)
|
|
then
|
|
if Nkind (N) = N_Loop_Statement
|
|
and then Present (Identifier (N))
|
|
then
|
|
Block :=
|
|
Wrap_Statements_In_Block
|
|
(L => Statements (N),
|
|
Scop => Entity (Identifier (N)));
|
|
else
|
|
Block := Wrap_Statements_In_Block (Statements (N));
|
|
end if;
|
|
|
|
Set_Statements (N, New_List (Block));
|
|
Analyze (Block);
|
|
end if;
|
|
|
|
-- Could be e.g. a loop that was transformed into a block or null
|
|
-- statement. Do nothing for terminate alternatives.
|
|
|
|
when N_Block_Statement
|
|
| N_Null_Statement
|
|
| N_Terminate_Alternative
|
|
=>
|
|
null;
|
|
|
|
when others =>
|
|
raise Program_Error;
|
|
end case;
|
|
end Process_Statements_For_Controlled_Objects;
|
|
|
|
------------------
|
|
-- Power_Of_Two --
|
|
------------------
|
|
|
|
function Power_Of_Two (N : Node_Id) return Nat is
|
|
Typ : constant Entity_Id := Etype (N);
|
|
pragma Assert (Is_Integer_Type (Typ));
|
|
|
|
Siz : constant Nat := UI_To_Int (Esize (Typ));
|
|
Val : Uint;
|
|
|
|
begin
|
|
if not Compile_Time_Known_Value (N) then
|
|
return 0;
|
|
|
|
else
|
|
Val := Expr_Value (N);
|
|
for J in 1 .. Siz - 1 loop
|
|
if Val = Uint_2 ** J then
|
|
return J;
|
|
end if;
|
|
end loop;
|
|
|
|
return 0;
|
|
end if;
|
|
end Power_Of_Two;
|
|
|
|
----------------------
|
|
-- Remove_Init_Call --
|
|
----------------------
|
|
|
|
function Remove_Init_Call
|
|
(Var : Entity_Id;
|
|
Rep_Clause : Node_Id) return Node_Id
|
|
is
|
|
Par : constant Node_Id := Parent (Var);
|
|
Typ : constant Entity_Id := Etype (Var);
|
|
|
|
Init_Proc : Entity_Id;
|
|
-- Initialization procedure for Typ
|
|
|
|
function Find_Init_Call_In_List (From : Node_Id) return Node_Id;
|
|
-- Look for init call for Var starting at From and scanning the
|
|
-- enclosing list until Rep_Clause or the end of the list is reached.
|
|
|
|
----------------------------
|
|
-- Find_Init_Call_In_List --
|
|
----------------------------
|
|
|
|
function Find_Init_Call_In_List (From : Node_Id) return Node_Id is
|
|
Init_Call : Node_Id;
|
|
|
|
begin
|
|
Init_Call := From;
|
|
while Present (Init_Call) and then Init_Call /= Rep_Clause loop
|
|
if Nkind (Init_Call) = N_Procedure_Call_Statement
|
|
and then Is_Entity_Name (Name (Init_Call))
|
|
and then Entity (Name (Init_Call)) = Init_Proc
|
|
then
|
|
return Init_Call;
|
|
end if;
|
|
|
|
Next (Init_Call);
|
|
end loop;
|
|
|
|
return Empty;
|
|
end Find_Init_Call_In_List;
|
|
|
|
Init_Call : Node_Id;
|
|
|
|
-- Start of processing for Remove_Init_Call
|
|
|
|
begin
|
|
if Present (Initialization_Statements (Var)) then
|
|
Init_Call := Initialization_Statements (Var);
|
|
Set_Initialization_Statements (Var, Empty);
|
|
|
|
elsif not Has_Non_Null_Base_Init_Proc (Typ) then
|
|
|
|
-- No init proc for the type, so obviously no call to be found
|
|
|
|
return Empty;
|
|
|
|
else
|
|
-- We might be able to handle other cases below by just properly
|
|
-- setting Initialization_Statements at the point where the init proc
|
|
-- call is generated???
|
|
|
|
Init_Proc := Base_Init_Proc (Typ);
|
|
|
|
-- First scan the list containing the declaration of Var
|
|
|
|
Init_Call := Find_Init_Call_In_List (From => Next (Par));
|
|
|
|
-- If not found, also look on Var's freeze actions list, if any,
|
|
-- since the init call may have been moved there (case of an address
|
|
-- clause applying to Var).
|
|
|
|
if No (Init_Call) and then Present (Freeze_Node (Var)) then
|
|
Init_Call :=
|
|
Find_Init_Call_In_List (First (Actions (Freeze_Node (Var))));
|
|
end if;
|
|
|
|
-- If the initialization call has actuals that use the secondary
|
|
-- stack, the call may have been wrapped into a temporary block, in
|
|
-- which case the block itself has to be removed.
|
|
|
|
if No (Init_Call) and then Nkind (Next (Par)) = N_Block_Statement then
|
|
declare
|
|
Blk : constant Node_Id := Next (Par);
|
|
begin
|
|
if Present
|
|
(Find_Init_Call_In_List
|
|
(First (Statements (Handled_Statement_Sequence (Blk)))))
|
|
then
|
|
Init_Call := Blk;
|
|
end if;
|
|
end;
|
|
end if;
|
|
end if;
|
|
|
|
if Present (Init_Call) then
|
|
-- If restrictions have forbidden Aborts, the initialization call
|
|
-- for objects that require deep initialization has not been wrapped
|
|
-- into the following block (see Exp_Ch3, Default_Initialize_Object)
|
|
-- so if present remove it as well, and include the IP call in it,
|
|
-- in the rare case the caller may need to simply displace the
|
|
-- initialization, as is done for a later address specification.
|
|
|
|
if Nkind (Next (Init_Call)) = N_Block_Statement
|
|
and then Is_Initialization_Block (Next (Init_Call))
|
|
then
|
|
declare
|
|
IP_Call : constant Node_Id := Init_Call;
|
|
begin
|
|
Init_Call := Next (IP_Call);
|
|
Remove (IP_Call);
|
|
Prepend (IP_Call,
|
|
Statements (Handled_Statement_Sequence (Init_Call)));
|
|
end;
|
|
end if;
|
|
|
|
Remove (Init_Call);
|
|
end if;
|
|
|
|
return Init_Call;
|
|
end Remove_Init_Call;
|
|
|
|
-------------------------
|
|
-- Remove_Side_Effects --
|
|
-------------------------
|
|
|
|
procedure Remove_Side_Effects
|
|
(Exp : Node_Id;
|
|
Name_Req : Boolean := False;
|
|
Renaming_Req : Boolean := False;
|
|
Variable_Ref : Boolean := False;
|
|
Related_Id : Entity_Id := Empty;
|
|
Is_Low_Bound : Boolean := False;
|
|
Is_High_Bound : Boolean := False;
|
|
Discr_Number : Int := 0;
|
|
Check_Side_Effects : Boolean := True)
|
|
is
|
|
function Build_Temporary
|
|
(Loc : Source_Ptr;
|
|
Id : Character;
|
|
Related_Nod : Node_Id := Empty) return Entity_Id;
|
|
-- Create an external symbol of the form xxx_FIRST/_LAST if Related_Nod
|
|
-- is present (xxx is taken from the Chars field of Related_Nod),
|
|
-- otherwise it generates an internal temporary. The created temporary
|
|
-- entity is marked as internal.
|
|
|
|
function Possible_Side_Effect_In_SPARK (Exp : Node_Id) return Boolean;
|
|
-- Computes whether a side effect is possible in SPARK, which should
|
|
-- be handled by removing it from the expression for GNATprove. Note
|
|
-- that other side effects related to volatile variables are handled
|
|
-- separately.
|
|
|
|
---------------------
|
|
-- Build_Temporary --
|
|
---------------------
|
|
|
|
function Build_Temporary
|
|
(Loc : Source_Ptr;
|
|
Id : Character;
|
|
Related_Nod : Node_Id := Empty) return Entity_Id
|
|
is
|
|
Temp_Id : Entity_Id;
|
|
Temp_Nam : Name_Id;
|
|
Should_Set_Related_Expression : Boolean := False;
|
|
|
|
begin
|
|
-- The context requires an external symbol : expression is
|
|
-- the bound of an array, or a discriminant value. We create
|
|
-- a unique string using the related entity and an appropriate
|
|
-- suffix, rather than a numeric serial number (used for internal
|
|
-- entities) that may vary depending on compilation options, in
|
|
-- particular on the Assertions_Enabled mode. This avoids spurious
|
|
-- link errors.
|
|
|
|
if Present (Related_Id) then
|
|
if Is_Low_Bound then
|
|
Temp_Nam := New_External_Name (Chars (Related_Id), "_FIRST");
|
|
|
|
elsif Is_High_Bound then
|
|
Temp_Nam := New_External_Name (Chars (Related_Id), "_LAST");
|
|
|
|
else
|
|
pragma Assert (Discr_Number > 0);
|
|
|
|
-- We don't have any intelligible way of printing T_DISCR in
|
|
-- CodePeer. Thus, set a related expression in this case.
|
|
|
|
Should_Set_Related_Expression := True;
|
|
|
|
-- Use fully qualified name to avoid ambiguities.
|
|
|
|
Temp_Nam :=
|
|
New_External_Name
|
|
(Get_Qualified_Name (Related_Id), "_DISCR", Discr_Number);
|
|
end if;
|
|
|
|
Temp_Id := Make_Defining_Identifier (Loc, Temp_Nam);
|
|
|
|
if Should_Set_Related_Expression then
|
|
Set_Related_Expression (Temp_Id, Related_Nod);
|
|
end if;
|
|
|
|
-- Otherwise generate an internal temporary
|
|
|
|
else
|
|
Temp_Id := Make_Temporary (Loc, Id, Related_Nod);
|
|
end if;
|
|
|
|
Set_Is_Internal (Temp_Id);
|
|
|
|
return Temp_Id;
|
|
end Build_Temporary;
|
|
|
|
-----------------------------------
|
|
-- Possible_Side_Effect_In_SPARK --
|
|
-----------------------------------
|
|
|
|
function Possible_Side_Effect_In_SPARK (Exp : Node_Id) return Boolean is
|
|
begin
|
|
-- Side-effect removal in SPARK should only occur when not inside a
|
|
-- generic and not doing a preanalysis, inside an object renaming or
|
|
-- a type declaration or a for-loop iteration scheme.
|
|
|
|
return not Inside_A_Generic
|
|
and then Full_Analysis
|
|
and then Nkind (Enclosing_Declaration (Exp)) in
|
|
N_Component_Declaration
|
|
| N_Full_Type_Declaration
|
|
| N_Iterator_Specification
|
|
| N_Loop_Parameter_Specification
|
|
| N_Object_Renaming_Declaration
|
|
| N_Subtype_Declaration;
|
|
end Possible_Side_Effect_In_SPARK;
|
|
|
|
-- Local variables
|
|
|
|
Loc : constant Source_Ptr := Sloc (Exp);
|
|
Exp_Type : constant Entity_Id := Etype (Exp);
|
|
Svg_Suppress : constant Suppress_Record := Scope_Suppress;
|
|
Def_Id : Entity_Id;
|
|
E : Node_Id;
|
|
New_Exp : Node_Id;
|
|
Ptr_Typ_Decl : Node_Id;
|
|
Ref_Type : Entity_Id;
|
|
Res : Node_Id;
|
|
|
|
-- Start of processing for Remove_Side_Effects
|
|
|
|
begin
|
|
-- Handle cases in which there is nothing to do. In GNATprove mode,
|
|
-- removal of side effects is useful for the light expansion of
|
|
-- renamings.
|
|
|
|
if not Expander_Active
|
|
and then not
|
|
(GNATprove_Mode and then Possible_Side_Effect_In_SPARK (Exp))
|
|
then
|
|
return;
|
|
|
|
-- Cannot generate temporaries if the invocation to remove side effects
|
|
-- was issued too early and the type of the expression is not resolved
|
|
-- (this happens because routines Duplicate_Subexpr_XX implicitly invoke
|
|
-- Remove_Side_Effects).
|
|
|
|
elsif No (Exp_Type)
|
|
or else Ekind (Exp_Type) = E_Access_Attribute_Type
|
|
then
|
|
return;
|
|
|
|
-- Nothing to do if prior expansion determined that a function call does
|
|
-- not require side effect removal.
|
|
|
|
elsif Nkind (Exp) = N_Function_Call
|
|
and then No_Side_Effect_Removal (Exp)
|
|
then
|
|
return;
|
|
|
|
-- No action needed for side-effect free expressions
|
|
|
|
elsif Check_Side_Effects
|
|
and then Side_Effect_Free (Exp, Name_Req, Variable_Ref)
|
|
then
|
|
return;
|
|
|
|
-- Generating C code we cannot remove side effect of function returning
|
|
-- class-wide types since there is no secondary stack (required to use
|
|
-- 'reference).
|
|
|
|
elsif Modify_Tree_For_C
|
|
and then Nkind (Exp) = N_Function_Call
|
|
and then Is_Class_Wide_Type (Etype (Exp))
|
|
then
|
|
return;
|
|
end if;
|
|
|
|
-- The remaining processing is done with all checks suppressed
|
|
|
|
-- Note: from now on, don't use return statements, instead do a goto
|
|
-- Leave, to ensure that we properly restore Scope_Suppress.Suppress.
|
|
|
|
Scope_Suppress.Suppress := (others => True);
|
|
|
|
-- If this is a side-effect free attribute reference whose expressions
|
|
-- are also side-effect free and whose prefix is not a name, remove the
|
|
-- side effects of the prefix. A copy of the prefix is required in this
|
|
-- case and it is better not to make an additional one for the attribute
|
|
-- itself, because the return type of many of them is universal integer,
|
|
-- which is a very large type for a temporary.
|
|
-- The prefix of an attribute reference Reduce may be syntactically an
|
|
-- aggregate, but will be expanded into a loop, so no need to remove
|
|
-- side-effects.
|
|
|
|
if Nkind (Exp) = N_Attribute_Reference
|
|
and then Side_Effect_Free_Attribute (Attribute_Name (Exp))
|
|
and then Side_Effect_Free (Expressions (Exp), Name_Req, Variable_Ref)
|
|
and then (Attribute_Name (Exp) /= Name_Reduce
|
|
or else Nkind (Prefix (Exp)) /= N_Aggregate)
|
|
and then not Is_Name_Reference (Prefix (Exp))
|
|
then
|
|
Remove_Side_Effects (Prefix (Exp), Name_Req, Variable_Ref);
|
|
goto Leave;
|
|
|
|
-- If this is an elementary or a small not-by-reference record type, and
|
|
-- we need to capture the value, just make a constant; this is cheap and
|
|
-- objects of both kinds of types can be bit aligned, so it might not be
|
|
-- possible to generate a reference to them. Likewise if this is not a
|
|
-- name reference, except for a type conversion, because we would enter
|
|
-- an infinite recursion with Checks.Apply_Predicate_Check if the target
|
|
-- type has predicates (and type conversions need a specific treatment
|
|
-- anyway, see below). Also do it if we have a volatile reference and
|
|
-- Name_Req is not set (see comments for Side_Effect_Free).
|
|
|
|
elsif (Is_Elementary_Type (Exp_Type)
|
|
or else (Is_Record_Type (Exp_Type)
|
|
and then Known_Static_RM_Size (Exp_Type)
|
|
and then RM_Size (Exp_Type) <= System_Max_Integer_Size
|
|
and then not Has_Discriminants (Exp_Type)
|
|
and then not Is_By_Reference_Type (Exp_Type)))
|
|
and then (Variable_Ref
|
|
or else (not Is_Name_Reference (Exp)
|
|
and then Nkind (Exp) /= N_Type_Conversion)
|
|
or else (not Name_Req
|
|
and then Is_Volatile_Reference (Exp)))
|
|
then
|
|
Def_Id := Build_Temporary (Loc, 'R', Exp);
|
|
Set_Etype (Def_Id, Exp_Type);
|
|
Res := New_Occurrence_Of (Def_Id, Loc);
|
|
|
|
-- If the expression is a packed reference, it must be reanalyzed and
|
|
-- expanded, depending on context. This is the case for actuals where
|
|
-- a constraint check may capture the actual before expansion of the
|
|
-- call is complete.
|
|
|
|
if Nkind (Exp) = N_Indexed_Component
|
|
and then Is_Packed (Etype (Prefix (Exp)))
|
|
then
|
|
Set_Analyzed (Exp, False);
|
|
Set_Analyzed (Prefix (Exp), False);
|
|
end if;
|
|
|
|
-- Generate:
|
|
-- Rnn : Exp_Type renames Expr;
|
|
|
|
-- In GNATprove mode, we prefer to use renamings for intermediate
|
|
-- variables to definition of constants, due to the implicit move
|
|
-- operation that such a constant definition causes as part of the
|
|
-- support in GNATprove for ownership pointers. Hence, we generate
|
|
-- a renaming for a reference to an object of a nonscalar type.
|
|
|
|
if Renaming_Req
|
|
or else (GNATprove_Mode
|
|
and then Is_Object_Reference (Exp)
|
|
and then not Is_Scalar_Type (Exp_Type))
|
|
then
|
|
E :=
|
|
Make_Object_Renaming_Declaration (Loc,
|
|
Defining_Identifier => Def_Id,
|
|
Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
|
|
Name => Relocate_Node (Exp));
|
|
|
|
-- Generate:
|
|
-- Rnn : constant Exp_Type := Expr;
|
|
|
|
else
|
|
E :=
|
|
Make_Object_Declaration (Loc,
|
|
Defining_Identifier => Def_Id,
|
|
Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
|
|
Constant_Present => True,
|
|
Expression => Relocate_Node (Exp));
|
|
|
|
Set_Assignment_OK (E);
|
|
end if;
|
|
|
|
Insert_Action (Exp, E);
|
|
|
|
-- If the expression has the form v.all then we can just capture the
|
|
-- pointer, and then do an explicit dereference on the result, but
|
|
-- this is not right if this is a volatile reference.
|
|
|
|
elsif Nkind (Exp) = N_Explicit_Dereference
|
|
and then not Is_Volatile_Reference (Exp)
|
|
then
|
|
Def_Id := Build_Temporary (Loc, 'R', Exp);
|
|
Res :=
|
|
Make_Explicit_Dereference (Loc, New_Occurrence_Of (Def_Id, Loc));
|
|
|
|
Insert_Action (Exp,
|
|
Make_Object_Declaration (Loc,
|
|
Defining_Identifier => Def_Id,
|
|
Object_Definition =>
|
|
New_Occurrence_Of (Etype (Prefix (Exp)), Loc),
|
|
Constant_Present => True,
|
|
Expression => Relocate_Node (Prefix (Exp))));
|
|
|
|
-- Similar processing for an unchecked conversion of an expression of
|
|
-- the form v.all, where we want the same kind of treatment.
|
|
|
|
elsif Nkind (Exp) = N_Unchecked_Type_Conversion
|
|
and then Nkind (Expression (Exp)) = N_Explicit_Dereference
|
|
then
|
|
Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
|
|
goto Leave;
|
|
|
|
-- If this is a type conversion, leave the type conversion and remove
|
|
-- side effects in the expression, unless it is of universal integer,
|
|
-- which is a very large type for a temporary. This is important in
|
|
-- several circumstances: for change of representations and also when
|
|
-- this is a view conversion to a smaller object, where gigi can end
|
|
-- up creating its own temporary of the wrong size.
|
|
|
|
elsif Nkind (Exp) = N_Type_Conversion
|
|
and then Etype (Expression (Exp)) /= Universal_Integer
|
|
then
|
|
Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
|
|
|
|
-- Generating C code the type conversion of an access to constrained
|
|
-- array type into an access to unconstrained array type involves
|
|
-- initializing a fat pointer and the expression must be free of
|
|
-- side effects to safely compute its bounds.
|
|
|
|
if Modify_Tree_For_C
|
|
and then Is_Access_Type (Etype (Exp))
|
|
and then Is_Array_Type (Designated_Type (Etype (Exp)))
|
|
and then not Is_Constrained (Designated_Type (Etype (Exp)))
|
|
then
|
|
Def_Id := Build_Temporary (Loc, 'R', Exp);
|
|
Set_Etype (Def_Id, Exp_Type);
|
|
Res := New_Occurrence_Of (Def_Id, Loc);
|
|
|
|
Insert_Action (Exp,
|
|
Make_Object_Declaration (Loc,
|
|
Defining_Identifier => Def_Id,
|
|
Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
|
|
Constant_Present => True,
|
|
Expression => Relocate_Node (Exp)));
|
|
else
|
|
goto Leave;
|
|
end if;
|
|
|
|
-- If this is an unchecked conversion that Gigi can't handle, make
|
|
-- a copy or a use a renaming to capture the value.
|
|
|
|
elsif Nkind (Exp) = N_Unchecked_Type_Conversion
|
|
and then not Safe_Unchecked_Type_Conversion (Exp)
|
|
then
|
|
if CW_Or_Has_Controlled_Part (Exp_Type) then
|
|
|
|
-- Use a renaming to capture the expression, rather than create
|
|
-- a controlled temporary.
|
|
|
|
Def_Id := Build_Temporary (Loc, 'R', Exp);
|
|
Res := New_Occurrence_Of (Def_Id, Loc);
|
|
|
|
Insert_Action (Exp,
|
|
Make_Object_Renaming_Declaration (Loc,
|
|
Defining_Identifier => Def_Id,
|
|
Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
|
|
Name => Relocate_Node (Exp)));
|
|
|
|
else
|
|
Def_Id := Build_Temporary (Loc, 'R', Exp);
|
|
Set_Etype (Def_Id, Exp_Type);
|
|
Res := New_Occurrence_Of (Def_Id, Loc);
|
|
|
|
E :=
|
|
Make_Object_Declaration (Loc,
|
|
Defining_Identifier => Def_Id,
|
|
Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
|
|
Constant_Present => not Is_Variable (Exp),
|
|
Expression => Relocate_Node (Exp));
|
|
|
|
Set_Assignment_OK (E);
|
|
Insert_Action (Exp, E);
|
|
end if;
|
|
|
|
-- If this is a packed array component or a selected component with a
|
|
-- nonstandard representation, we cannot generate a reference because
|
|
-- the component may be unaligned, so we must use a renaming and this
|
|
-- renaming is handled by the front end, as the back end may balk at
|
|
-- the nonstandard representation (see Evaluation_Required in Exp_Ch8).
|
|
|
|
elsif Nkind (Exp) in N_Indexed_Component | N_Selected_Component
|
|
and then Has_Non_Standard_Rep (Etype (Prefix (Exp)))
|
|
then
|
|
Def_Id := Build_Temporary (Loc, 'R', Exp);
|
|
Res := New_Occurrence_Of (Def_Id, Loc);
|
|
|
|
Insert_Action (Exp,
|
|
Make_Object_Renaming_Declaration (Loc,
|
|
Defining_Identifier => Def_Id,
|
|
Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
|
|
Name => Relocate_Node (Exp)));
|
|
|
|
-- For an expression that denotes a name, we can use a renaming scheme.
|
|
-- This is needed for correctness in the case of a volatile object of
|
|
-- a nonvolatile type because the Make_Reference call of the "default"
|
|
-- approach would generate an illegal access value (an access value
|
|
-- cannot designate such an object - see Analyze_Reference).
|
|
|
|
elsif Is_Name_Reference (Exp)
|
|
|
|
-- We skip using this scheme if we have an object of a volatile
|
|
-- type and we do not have Name_Req set true (see comments for
|
|
-- Side_Effect_Free).
|
|
|
|
and then (Name_Req or else not Treat_As_Volatile (Exp_Type))
|
|
then
|
|
Def_Id := Build_Temporary (Loc, 'R', Exp);
|
|
Res := New_Occurrence_Of (Def_Id, Loc);
|
|
|
|
Insert_Action (Exp,
|
|
Make_Object_Renaming_Declaration (Loc,
|
|
Defining_Identifier => Def_Id,
|
|
Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
|
|
Name => Relocate_Node (Exp)));
|
|
|
|
-- Avoid generating a variable-sized temporary, by generating the
|
|
-- reference just for the function call. The transformation could be
|
|
-- refined to apply only when the array component is constrained by a
|
|
-- discriminant???
|
|
|
|
elsif Nkind (Exp) = N_Selected_Component
|
|
and then Nkind (Prefix (Exp)) = N_Function_Call
|
|
and then Is_Array_Type (Exp_Type)
|
|
then
|
|
Remove_Side_Effects (Prefix (Exp), Name_Req, Variable_Ref);
|
|
goto Leave;
|
|
|
|
-- Otherwise we generate a reference to the expression
|
|
|
|
else
|
|
-- When generating C code we cannot consider side effect free object
|
|
-- declarations that have discriminants and are initialized by means
|
|
-- of a function call since on this target there is no secondary
|
|
-- stack to store the return value and the expander may generate an
|
|
-- extra call to the function to compute the discriminant value. In
|
|
-- addition, for targets that have secondary stack, the expansion of
|
|
-- functions with side effects involves the generation of an access
|
|
-- type to capture the return value stored in the secondary stack;
|
|
-- by contrast when generating C code such expansion generates an
|
|
-- internal object declaration (no access type involved) which must
|
|
-- be identified here to avoid entering into a never-ending loop
|
|
-- generating internal object declarations.
|
|
|
|
if Modify_Tree_For_C
|
|
and then Nkind (Parent (Exp)) = N_Object_Declaration
|
|
and then
|
|
(Nkind (Exp) /= N_Function_Call
|
|
or else not Has_Discriminants (Exp_Type)
|
|
or else Is_Internal_Name
|
|
(Chars (Defining_Identifier (Parent (Exp)))))
|
|
then
|
|
goto Leave;
|
|
end if;
|
|
|
|
-- Special processing for function calls that return a limited type.
|
|
-- We need to build a declaration that will enable build-in-place
|
|
-- expansion of the call. This is not done if the context is already
|
|
-- an object declaration, to prevent infinite recursion.
|
|
|
|
-- This is relevant only in Ada 2005 mode. In Ada 95 programs we have
|
|
-- to accommodate functions returning limited objects by reference.
|
|
|
|
if Ada_Version >= Ada_2005
|
|
and then Nkind (Exp) = N_Function_Call
|
|
and then Is_Limited_View (Etype (Exp))
|
|
and then Nkind (Parent (Exp)) /= N_Object_Declaration
|
|
then
|
|
declare
|
|
Obj : constant Entity_Id := Make_Temporary (Loc, 'F', Exp);
|
|
Decl : Node_Id;
|
|
|
|
begin
|
|
Decl :=
|
|
Make_Object_Declaration (Loc,
|
|
Defining_Identifier => Obj,
|
|
Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
|
|
Expression => Relocate_Node (Exp));
|
|
|
|
Insert_Action (Exp, Decl);
|
|
Set_Etype (Obj, Exp_Type);
|
|
Rewrite (Exp, New_Occurrence_Of (Obj, Loc));
|
|
goto Leave;
|
|
end;
|
|
end if;
|
|
|
|
Def_Id := Build_Temporary (Loc, 'R', Exp);
|
|
|
|
-- The regular expansion of functions with side effects involves the
|
|
-- generation of an access type to capture the return value found on
|
|
-- the secondary stack. Since SPARK (and why) cannot process access
|
|
-- types, use a different approach which ignores the secondary stack
|
|
-- and "copies" the returned object.
|
|
-- When generating C code, no need for a 'reference since the
|
|
-- secondary stack is not supported.
|
|
|
|
if GNATprove_Mode or Modify_Tree_For_C then
|
|
Res := New_Occurrence_Of (Def_Id, Loc);
|
|
Ref_Type := Exp_Type;
|
|
|
|
-- Regular expansion utilizing an access type and 'reference
|
|
|
|
else
|
|
Res :=
|
|
Make_Explicit_Dereference (Loc,
|
|
Prefix => New_Occurrence_Of (Def_Id, Loc));
|
|
|
|
-- Generate:
|
|
-- type Ann is access all <Exp_Type>;
|
|
|
|
Ref_Type := Make_Temporary (Loc, 'A');
|
|
|
|
Ptr_Typ_Decl :=
|
|
Make_Full_Type_Declaration (Loc,
|
|
Defining_Identifier => Ref_Type,
|
|
Type_Definition =>
|
|
Make_Access_To_Object_Definition (Loc,
|
|
All_Present => True,
|
|
Subtype_Indication =>
|
|
New_Occurrence_Of (Exp_Type, Loc)));
|
|
|
|
Insert_Action (Exp, Ptr_Typ_Decl);
|
|
end if;
|
|
|
|
E := Exp;
|
|
if Nkind (E) = N_Explicit_Dereference then
|
|
New_Exp := Relocate_Node (Prefix (E));
|
|
|
|
else
|
|
E := Relocate_Node (E);
|
|
|
|
-- Do not generate a 'reference in SPARK mode or C generation
|
|
-- since the access type is not created in the first place.
|
|
|
|
if GNATprove_Mode or Modify_Tree_For_C then
|
|
New_Exp := E;
|
|
|
|
-- Otherwise generate reference, marking the value as non-null
|
|
-- since we know it cannot be null and we don't want a check.
|
|
|
|
else
|
|
New_Exp := Make_Reference (Loc, E);
|
|
Set_Is_Known_Non_Null (Def_Id);
|
|
end if;
|
|
end if;
|
|
|
|
if Is_Delayed_Aggregate (E) then
|
|
|
|
-- The expansion of nested aggregates is delayed until the
|
|
-- enclosing aggregate is expanded. As aggregates are often
|
|
-- qualified, the predicate applies to qualified expressions as
|
|
-- well, indicating that the enclosing aggregate has not been
|
|
-- expanded yet. At this point the aggregate is part of a
|
|
-- stand-alone declaration, and must be fully expanded.
|
|
|
|
if Nkind (E) = N_Qualified_Expression then
|
|
Set_Expansion_Delayed (Expression (E), False);
|
|
Set_Analyzed (Expression (E), False);
|
|
else
|
|
Set_Expansion_Delayed (E, False);
|
|
end if;
|
|
|
|
Set_Analyzed (E, False);
|
|
end if;
|
|
|
|
-- Generating C code of object declarations that have discriminants
|
|
-- and are initialized by means of a function call we propagate the
|
|
-- discriminants of the parent type to the internally built object.
|
|
-- This is needed to avoid generating an extra call to the called
|
|
-- function.
|
|
|
|
-- For example, if we generate here the following declaration, it
|
|
-- will be expanded later adding an extra call to evaluate the value
|
|
-- of the discriminant (needed to compute the size of the object).
|
|
--
|
|
-- type Rec (D : Integer) is ...
|
|
-- Obj : constant Rec := SomeFunc;
|
|
|
|
if Modify_Tree_For_C
|
|
and then Nkind (Parent (Exp)) = N_Object_Declaration
|
|
and then Has_Discriminants (Exp_Type)
|
|
and then Nkind (Exp) = N_Function_Call
|
|
then
|
|
Insert_Action (Exp,
|
|
Make_Object_Declaration (Loc,
|
|
Defining_Identifier => Def_Id,
|
|
Object_Definition => New_Copy_Tree
|
|
(Object_Definition (Parent (Exp))),
|
|
Constant_Present => True,
|
|
Expression => New_Exp));
|
|
else
|
|
Insert_Action (Exp,
|
|
Make_Object_Declaration (Loc,
|
|
Defining_Identifier => Def_Id,
|
|
Object_Definition => New_Occurrence_Of (Ref_Type, Loc),
|
|
Constant_Present => True,
|
|
Expression => New_Exp));
|
|
end if;
|
|
end if;
|
|
|
|
-- Preserve the Assignment_OK flag in all copies, since at least one
|
|
-- copy may be used in a context where this flag must be set (otherwise
|
|
-- why would the flag be set in the first place).
|
|
|
|
Set_Assignment_OK (Res, Assignment_OK (Exp));
|
|
|
|
-- Preserve the Do_Range_Check flag in all copies
|
|
|
|
Set_Do_Range_Check (Res, Do_Range_Check (Exp));
|
|
|
|
-- Finally rewrite the original expression and we are done
|
|
|
|
Rewrite (Exp, Res);
|
|
Analyze_And_Resolve (Exp, Exp_Type);
|
|
|
|
<<Leave>>
|
|
Scope_Suppress := Svg_Suppress;
|
|
end Remove_Side_Effects;
|
|
|
|
------------------------
|
|
-- Replace_References --
|
|
------------------------
|
|
|
|
procedure Replace_References
|
|
(Expr : Node_Id;
|
|
Par_Typ : Entity_Id;
|
|
Deriv_Typ : Entity_Id;
|
|
Par_Obj : Entity_Id := Empty;
|
|
Deriv_Obj : Entity_Id := Empty)
|
|
is
|
|
function Is_Deriv_Obj_Ref (Ref : Node_Id) return Boolean;
|
|
-- Determine whether node Ref denotes some component of Deriv_Obj
|
|
|
|
function Replace_Ref (Ref : Node_Id) return Traverse_Result;
|
|
-- Substitute a reference to an entity with the corresponding value
|
|
-- stored in table Type_Map.
|
|
|
|
function Type_Of_Formal
|
|
(Call : Node_Id;
|
|
Actual : Node_Id) return Entity_Id;
|
|
-- Find the type of the formal parameter which corresponds to actual
|
|
-- parameter Actual in subprogram call Call.
|
|
|
|
----------------------
|
|
-- Is_Deriv_Obj_Ref --
|
|
----------------------
|
|
|
|
function Is_Deriv_Obj_Ref (Ref : Node_Id) return Boolean is
|
|
Par : constant Node_Id := Parent (Ref);
|
|
|
|
begin
|
|
-- Detect the folowing selected component form:
|
|
|
|
-- Deriv_Obj.(something)
|
|
|
|
return
|
|
Nkind (Par) = N_Selected_Component
|
|
and then Is_Entity_Name (Prefix (Par))
|
|
and then Entity (Prefix (Par)) = Deriv_Obj;
|
|
end Is_Deriv_Obj_Ref;
|
|
|
|
-----------------
|
|
-- Replace_Ref --
|
|
-----------------
|
|
|
|
function Replace_Ref (Ref : Node_Id) return Traverse_Result is
|
|
procedure Remove_Controlling_Arguments (From_Arg : Node_Id);
|
|
-- Reset the Controlling_Argument of all function calls that
|
|
-- encapsulate node From_Arg.
|
|
|
|
----------------------------------
|
|
-- Remove_Controlling_Arguments --
|
|
----------------------------------
|
|
|
|
procedure Remove_Controlling_Arguments (From_Arg : Node_Id) is
|
|
Par : Node_Id;
|
|
|
|
begin
|
|
Par := From_Arg;
|
|
while Present (Par) loop
|
|
if Nkind (Par) = N_Function_Call
|
|
and then Present (Controlling_Argument (Par))
|
|
then
|
|
Set_Controlling_Argument (Par, Empty);
|
|
|
|
-- Prevent the search from going too far
|
|
|
|
elsif Is_Body_Or_Package_Declaration (Par) then
|
|
exit;
|
|
end if;
|
|
|
|
Par := Parent (Par);
|
|
end loop;
|
|
end Remove_Controlling_Arguments;
|
|
|
|
-- Local variables
|
|
|
|
Context : constant Node_Id :=
|
|
(if No (Ref) then Empty else Parent (Ref));
|
|
|
|
Loc : constant Source_Ptr := Sloc (Ref);
|
|
Ref_Id : Entity_Id;
|
|
Result : Traverse_Result;
|
|
|
|
New_Ref : Node_Id;
|
|
-- The new reference which is intended to substitute the old one
|
|
|
|
Old_Ref : Node_Id;
|
|
-- The reference designated for replacement. In certain cases this
|
|
-- may be a node other than Ref.
|
|
|
|
Val : Node_Or_Entity_Id;
|
|
-- The corresponding value of Ref from the type map
|
|
|
|
-- Start of processing for Replace_Ref
|
|
|
|
begin
|
|
-- Assume that the input reference is to be replaced and that the
|
|
-- traversal should examine the children of the reference.
|
|
|
|
Old_Ref := Ref;
|
|
Result := OK;
|
|
|
|
-- The input denotes a meaningful reference
|
|
|
|
if Nkind (Ref) in N_Has_Entity and then Present (Entity (Ref)) then
|
|
Ref_Id := Entity (Ref);
|
|
Val := Type_Map.Get (Ref_Id);
|
|
|
|
-- The reference has a corresponding value in the type map, a
|
|
-- substitution is possible.
|
|
|
|
if Present (Val) then
|
|
|
|
-- The reference denotes a discriminant
|
|
|
|
if Ekind (Ref_Id) = E_Discriminant then
|
|
if Nkind (Val) in N_Entity then
|
|
|
|
-- The value denotes another discriminant. Replace as
|
|
-- follows:
|
|
|
|
-- _object.Discr -> _object.Val
|
|
|
|
if Ekind (Val) = E_Discriminant then
|
|
New_Ref := New_Occurrence_Of (Val, Loc);
|
|
|
|
-- Otherwise the value denotes the entity of a name which
|
|
-- constraints the discriminant. Replace as follows:
|
|
|
|
-- _object.Discr -> Val
|
|
|
|
else
|
|
pragma Assert (Is_Deriv_Obj_Ref (Old_Ref));
|
|
|
|
New_Ref := New_Occurrence_Of (Val, Loc);
|
|
Old_Ref := Parent (Old_Ref);
|
|
end if;
|
|
|
|
-- Otherwise the value denotes an arbitrary expression which
|
|
-- constraints the discriminant. Replace as follows:
|
|
|
|
-- _object.Discr -> Val
|
|
|
|
else
|
|
pragma Assert (Is_Deriv_Obj_Ref (Old_Ref));
|
|
|
|
New_Ref := New_Copy_Tree (Val);
|
|
Old_Ref := Parent (Old_Ref);
|
|
end if;
|
|
|
|
-- Otherwise the reference denotes a primitive. Replace as
|
|
-- follows:
|
|
|
|
-- Primitive -> Val
|
|
|
|
else
|
|
pragma Assert (Nkind (Val) in N_Entity);
|
|
New_Ref := New_Occurrence_Of (Val, Loc);
|
|
end if;
|
|
|
|
-- The reference mentions the _object parameter of the parent
|
|
-- type's DIC or type invariant procedure. Replace as follows:
|
|
|
|
-- _object -> _object
|
|
|
|
elsif Present (Par_Obj)
|
|
and then Present (Deriv_Obj)
|
|
and then Ref_Id = Par_Obj
|
|
then
|
|
New_Ref := New_Occurrence_Of (Deriv_Obj, Loc);
|
|
|
|
-- The type of the _object parameter is class-wide when the
|
|
-- expression comes from an assertion pragma that applies to
|
|
-- an abstract parent type or an interface. The class-wide type
|
|
-- facilitates the preanalysis of the expression by treating
|
|
-- calls to abstract primitives that mention the current
|
|
-- instance of the type as dispatching. Once the calls are
|
|
-- remapped to invoke overriding or inherited primitives, the
|
|
-- calls no longer need to be dispatching. Examine all function
|
|
-- calls that encapsulate the _object parameter and reset their
|
|
-- Controlling_Argument attribute.
|
|
|
|
if Is_Class_Wide_Type (Etype (Par_Obj))
|
|
and then Is_Abstract_Type (Root_Type (Etype (Par_Obj)))
|
|
then
|
|
Remove_Controlling_Arguments (Old_Ref);
|
|
end if;
|
|
|
|
-- The reference to _object acts as an actual parameter in a
|
|
-- subprogram call which may be invoking a primitive of the
|
|
-- parent type:
|
|
|
|
-- Primitive (... _object ...);
|
|
|
|
-- The parent type primitive may not be overridden nor
|
|
-- inherited when it is declared after the derived type
|
|
-- definition:
|
|
|
|
-- type Parent is tagged private;
|
|
-- type Child is new Parent with private;
|
|
-- procedure Primitive (Obj : Parent);
|
|
|
|
-- In this scenario the _object parameter is converted to the
|
|
-- parent type. Due to complications with partial/full views
|
|
-- and view swaps, the parent type is taken from the formal
|
|
-- parameter of the subprogram being called.
|
|
|
|
if Nkind (Context) in N_Subprogram_Call
|
|
and then No (Type_Map.Get (Entity (Name (Context))))
|
|
then
|
|
declare
|
|
-- We need to use the Original_Node of the callee, in
|
|
-- case it was already modified. Note that we are using
|
|
-- Traverse_Proc to walk the tree, and it is defined to
|
|
-- walk subtrees in an arbitrary order.
|
|
|
|
Callee : constant Entity_Id :=
|
|
Entity (Original_Node (Name (Context)));
|
|
begin
|
|
if No (Type_Map.Get (Callee)) then
|
|
New_Ref :=
|
|
Convert_To
|
|
(Type_Of_Formal (Context, Old_Ref), New_Ref);
|
|
|
|
-- Do not process the generated type conversion
|
|
-- because both the parent type and the derived type
|
|
-- are in the Type_Map table. This will clobber the
|
|
-- type conversion by resetting its subtype mark.
|
|
|
|
Result := Skip;
|
|
end if;
|
|
end;
|
|
end if;
|
|
|
|
-- Otherwise there is nothing to replace
|
|
|
|
else
|
|
New_Ref := Empty;
|
|
end if;
|
|
|
|
if Present (New_Ref) then
|
|
Rewrite (Old_Ref, New_Ref);
|
|
|
|
-- Update the return type when the context of the reference
|
|
-- acts as the name of a function call. Note that the update
|
|
-- should not be performed when the reference appears as an
|
|
-- actual in the call.
|
|
|
|
if Nkind (Context) = N_Function_Call
|
|
and then Name (Context) = Old_Ref
|
|
then
|
|
Set_Etype (Context, Etype (Val));
|
|
end if;
|
|
end if;
|
|
end if;
|
|
|
|
-- Reanalyze the reference due to potential replacements
|
|
|
|
if Nkind (Old_Ref) in N_Has_Etype then
|
|
Set_Analyzed (Old_Ref, False);
|
|
end if;
|
|
|
|
return Result;
|
|
end Replace_Ref;
|
|
|
|
procedure Replace_Refs is new Traverse_Proc (Replace_Ref);
|
|
|
|
--------------------
|
|
-- Type_Of_Formal --
|
|
--------------------
|
|
|
|
function Type_Of_Formal
|
|
(Call : Node_Id;
|
|
Actual : Node_Id) return Entity_Id
|
|
is
|
|
A : Node_Id;
|
|
F : Entity_Id;
|
|
|
|
begin
|
|
-- Examine the list of actual and formal parameters in parallel
|
|
|
|
A := First (Parameter_Associations (Call));
|
|
F := First_Formal (Entity (Name (Call)));
|
|
while Present (A) and then Present (F) loop
|
|
if A = Actual then
|
|
return Etype (F);
|
|
end if;
|
|
|
|
Next (A);
|
|
Next_Formal (F);
|
|
end loop;
|
|
|
|
-- The actual parameter must always have a corresponding formal
|
|
|
|
pragma Assert (False);
|
|
|
|
return Empty;
|
|
end Type_Of_Formal;
|
|
|
|
-- Start of processing for Replace_References
|
|
|
|
begin
|
|
-- Map the attributes of the parent type to the proper corresponding
|
|
-- attributes of the derived type.
|
|
|
|
Map_Types
|
|
(Parent_Type => Par_Typ,
|
|
Derived_Type => Deriv_Typ);
|
|
|
|
-- Inspect the input expression and perform substitutions where
|
|
-- necessary.
|
|
|
|
Replace_Refs (Expr);
|
|
end Replace_References;
|
|
|
|
-----------------------------
|
|
-- Replace_Type_References --
|
|
-----------------------------
|
|
|
|
procedure Replace_Type_References
|
|
(Expr : Node_Id;
|
|
Typ : Entity_Id;
|
|
Obj_Id : Entity_Id)
|
|
is
|
|
procedure Replace_Type_Ref (N : Node_Id);
|
|
-- Substitute a single reference of the current instance of type Typ
|
|
-- with a reference to Obj_Id.
|
|
|
|
----------------------
|
|
-- Replace_Type_Ref --
|
|
----------------------
|
|
|
|
procedure Replace_Type_Ref (N : Node_Id) is
|
|
begin
|
|
-- Decorate the reference to Typ even though it may be rewritten
|
|
-- further down. This is done so that routines which examine
|
|
-- properties of the Original_Node have some semantic information.
|
|
|
|
if Nkind (N) = N_Identifier then
|
|
Set_Entity (N, Typ);
|
|
Set_Etype (N, Typ);
|
|
|
|
elsif Nkind (N) = N_Selected_Component then
|
|
Analyze (Prefix (N));
|
|
Set_Entity (Selector_Name (N), Typ);
|
|
Set_Etype (Selector_Name (N), Typ);
|
|
end if;
|
|
|
|
-- Perform the following substitution:
|
|
|
|
-- Typ --> _object
|
|
|
|
Rewrite (N, New_Occurrence_Of (Obj_Id, Sloc (N)));
|
|
Set_Comes_From_Source (N, True);
|
|
end Replace_Type_Ref;
|
|
|
|
procedure Replace_Type_Refs is
|
|
new Replace_Type_References_Generic (Replace_Type_Ref);
|
|
|
|
-- Start of processing for Replace_Type_References
|
|
|
|
begin
|
|
Replace_Type_Refs (Expr, Typ);
|
|
end Replace_Type_References;
|
|
|
|
---------------------------
|
|
-- Represented_As_Scalar --
|
|
---------------------------
|
|
|
|
function Represented_As_Scalar (T : Entity_Id) return Boolean is
|
|
UT : constant Entity_Id := Underlying_Type (T);
|
|
begin
|
|
return Is_Scalar_Type (UT)
|
|
or else (Is_Bit_Packed_Array (UT)
|
|
and then Is_Scalar_Type (Packed_Array_Impl_Type (UT)));
|
|
end Represented_As_Scalar;
|
|
|
|
------------------------------
|
|
-- Requires_Cleanup_Actions --
|
|
------------------------------
|
|
|
|
function Requires_Cleanup_Actions
|
|
(N : Node_Id;
|
|
Lib_Level : Boolean) return Boolean
|
|
is
|
|
At_Lib_Level : constant Boolean :=
|
|
Lib_Level
|
|
and then Nkind (N) in N_Package_Body | N_Package_Specification;
|
|
-- N is at the library level if the top-most context is a package and
|
|
-- the path taken to reach N does not include nonpackage constructs.
|
|
|
|
begin
|
|
case Nkind (N) is
|
|
when N_Accept_Statement
|
|
| N_Block_Statement
|
|
| N_Entry_Body
|
|
| N_Package_Body
|
|
| N_Protected_Body
|
|
| N_Subprogram_Body
|
|
| N_Task_Body
|
|
=>
|
|
return
|
|
Requires_Cleanup_Actions
|
|
(L => Declarations (N),
|
|
Lib_Level => At_Lib_Level,
|
|
Nested_Constructs => True)
|
|
or else
|
|
(Present (Handled_Statement_Sequence (N))
|
|
and then
|
|
Requires_Cleanup_Actions
|
|
(L =>
|
|
Statements (Handled_Statement_Sequence (N)),
|
|
Lib_Level => At_Lib_Level,
|
|
Nested_Constructs => True));
|
|
|
|
-- Extended return statements are the same as the above, except that
|
|
-- there is no Declarations field. We do not want to clean up the
|
|
-- Return_Object_Declarations.
|
|
|
|
when N_Extended_Return_Statement =>
|
|
return
|
|
Present (Handled_Statement_Sequence (N))
|
|
and then Requires_Cleanup_Actions
|
|
(L =>
|
|
Statements (Handled_Statement_Sequence (N)),
|
|
Lib_Level => At_Lib_Level,
|
|
Nested_Constructs => True);
|
|
|
|
when N_Package_Specification =>
|
|
return
|
|
Requires_Cleanup_Actions
|
|
(L => Visible_Declarations (N),
|
|
Lib_Level => At_Lib_Level,
|
|
Nested_Constructs => True)
|
|
or else
|
|
Requires_Cleanup_Actions
|
|
(L => Private_Declarations (N),
|
|
Lib_Level => At_Lib_Level,
|
|
Nested_Constructs => True);
|
|
|
|
when others =>
|
|
raise Program_Error;
|
|
end case;
|
|
end Requires_Cleanup_Actions;
|
|
|
|
------------------------------
|
|
-- Requires_Cleanup_Actions --
|
|
------------------------------
|
|
|
|
function Requires_Cleanup_Actions
|
|
(L : List_Id;
|
|
Lib_Level : Boolean;
|
|
Nested_Constructs : Boolean) return Boolean
|
|
is
|
|
Decl : Node_Id;
|
|
Expr : Node_Id;
|
|
Obj_Id : Entity_Id;
|
|
Obj_Typ : Entity_Id;
|
|
Pack_Id : Entity_Id;
|
|
Typ : Entity_Id;
|
|
|
|
begin
|
|
Decl := First (L);
|
|
while Present (Decl) loop
|
|
|
|
-- Library-level tagged types
|
|
|
|
if Nkind (Decl) = N_Full_Type_Declaration then
|
|
Typ := Defining_Identifier (Decl);
|
|
|
|
-- Ignored Ghost types do not need any cleanup actions because
|
|
-- they will not appear in the final tree.
|
|
|
|
if Is_Ignored_Ghost_Entity (Typ) then
|
|
null;
|
|
|
|
elsif Is_Tagged_Type (Typ)
|
|
and then Is_Library_Level_Entity (Typ)
|
|
and then Convention (Typ) = Convention_Ada
|
|
and then Present (Access_Disp_Table (Typ))
|
|
and then not Is_Abstract_Type (Typ)
|
|
and then not No_Run_Time_Mode
|
|
and then not Restriction_Active (No_Tagged_Type_Registration)
|
|
and then RTE_Available (RE_Unregister_Tag)
|
|
then
|
|
return True;
|
|
end if;
|
|
|
|
-- Regular object declarations
|
|
|
|
elsif Nkind (Decl) = N_Object_Declaration then
|
|
Obj_Id := Defining_Identifier (Decl);
|
|
Obj_Typ := Base_Type (Etype (Obj_Id));
|
|
Expr := Expression (Decl);
|
|
|
|
-- Bypass any form of processing for objects which have their
|
|
-- finalization disabled. This applies only to objects at the
|
|
-- library level.
|
|
|
|
if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
|
|
null;
|
|
|
|
-- Finalization of transient objects are treated separately in
|
|
-- order to handle sensitive cases. These include:
|
|
|
|
-- * Aggregate expansion
|
|
-- * If, case, and expression with actions expansion
|
|
-- * Transient scopes
|
|
|
|
-- If one of those contexts has marked the transient object as
|
|
-- ignored, do not generate finalization actions for it.
|
|
|
|
elsif Is_Finalized_Transient (Obj_Id)
|
|
or else Is_Ignored_Transient (Obj_Id)
|
|
then
|
|
null;
|
|
|
|
-- Ignored Ghost objects do not need any cleanup actions because
|
|
-- they will not appear in the final tree.
|
|
|
|
elsif Is_Ignored_Ghost_Entity (Obj_Id) then
|
|
null;
|
|
|
|
-- The object is of the form:
|
|
-- Obj : [constant] Typ [:= Expr];
|
|
--
|
|
-- Do not process tag-to-class-wide conversions because they do
|
|
-- not yield an object. Do not process the incomplete view of a
|
|
-- deferred constant. Note that an object initialized by means
|
|
-- of a build-in-place function call may appear as a deferred
|
|
-- constant after expansion activities. These kinds of objects
|
|
-- must be finalized.
|
|
|
|
elsif not Is_Imported (Obj_Id)
|
|
and then Needs_Finalization (Obj_Typ)
|
|
and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
|
|
and then not (Ekind (Obj_Id) = E_Constant
|
|
and then not Has_Completion (Obj_Id)
|
|
and then No (BIP_Initialization_Call (Obj_Id)))
|
|
then
|
|
return True;
|
|
|
|
-- The object is of the form:
|
|
-- Obj : Access_Typ := Non_BIP_Function_Call'reference;
|
|
--
|
|
-- Obj : Access_Typ :=
|
|
-- BIP_Function_Call (BIPalloc => 2, ...)'reference;
|
|
|
|
elsif Is_Access_Type (Obj_Typ)
|
|
and then Needs_Finalization
|
|
(Available_View (Designated_Type (Obj_Typ)))
|
|
and then Present (Expr)
|
|
and then
|
|
(Is_Secondary_Stack_BIP_Func_Call (Expr)
|
|
or else
|
|
(Is_Non_BIP_Func_Call (Expr)
|
|
and then not Is_Related_To_Func_Return (Obj_Id)))
|
|
then
|
|
return True;
|
|
|
|
-- Processing for "hook" objects generated for transient objects
|
|
-- declared inside an Expression_With_Actions.
|
|
|
|
elsif Is_Access_Type (Obj_Typ)
|
|
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
|
|
and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
|
|
N_Object_Declaration
|
|
then
|
|
return True;
|
|
|
|
-- Processing for intermediate results of if expressions where
|
|
-- one of the alternatives uses a controlled function call.
|
|
|
|
elsif Is_Access_Type (Obj_Typ)
|
|
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
|
|
and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
|
|
N_Defining_Identifier
|
|
and then Present (Expr)
|
|
and then Nkind (Expr) = N_Null
|
|
then
|
|
return True;
|
|
|
|
-- Simple protected objects which use type System.Tasking.
|
|
-- Protected_Objects.Protection to manage their locks should be
|
|
-- treated as controlled since they require manual cleanup.
|
|
|
|
elsif Ekind (Obj_Id) = E_Variable
|
|
and then (Is_Simple_Protected_Type (Obj_Typ)
|
|
or else Has_Simple_Protected_Object (Obj_Typ))
|
|
then
|
|
return True;
|
|
end if;
|
|
|
|
-- Specific cases of object renamings
|
|
|
|
elsif Nkind (Decl) = N_Object_Renaming_Declaration then
|
|
Obj_Id := Defining_Identifier (Decl);
|
|
Obj_Typ := Base_Type (Etype (Obj_Id));
|
|
|
|
-- Bypass any form of processing for objects which have their
|
|
-- finalization disabled. This applies only to objects at the
|
|
-- library level.
|
|
|
|
if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
|
|
null;
|
|
|
|
-- Ignored Ghost object renamings do not need any cleanup actions
|
|
-- because they will not appear in the final tree.
|
|
|
|
elsif Is_Ignored_Ghost_Entity (Obj_Id) then
|
|
null;
|
|
|
|
-- Return object of a build-in-place function. This case is
|
|
-- recognized and marked by the expansion of an extended return
|
|
-- statement (see Expand_N_Extended_Return_Statement).
|
|
|
|
elsif Needs_Finalization (Obj_Typ)
|
|
and then Is_Return_Object (Obj_Id)
|
|
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
|
|
then
|
|
return True;
|
|
|
|
-- Detect a case where a source object has been initialized by
|
|
-- a controlled function call or another object which was later
|
|
-- rewritten as a class-wide conversion of Ada.Tags.Displace.
|
|
|
|
-- Obj1 : CW_Type := Src_Obj;
|
|
-- Obj2 : CW_Type := Function_Call (...);
|
|
|
|
-- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
|
|
-- Tmp : ... := Function_Call (...)'reference;
|
|
-- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
|
|
|
|
elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
|
|
return True;
|
|
end if;
|
|
|
|
-- Inspect the freeze node of an access-to-controlled type and look
|
|
-- for a delayed finalization master. This case arises when the
|
|
-- freeze actions are inserted at a later time than the expansion of
|
|
-- the context. Since Build_Finalizer is never called on a single
|
|
-- construct twice, the master will be ultimately left out and never
|
|
-- finalized. This is also needed for freeze actions of designated
|
|
-- types themselves, since in some cases the finalization master is
|
|
-- associated with a designated type's freeze node rather than that
|
|
-- of the access type (see handling for freeze actions in
|
|
-- Build_Finalization_Master).
|
|
|
|
elsif Nkind (Decl) = N_Freeze_Entity
|
|
and then Present (Actions (Decl))
|
|
then
|
|
Typ := Entity (Decl);
|
|
|
|
-- Freeze nodes for ignored Ghost types do not need cleanup
|
|
-- actions because they will never appear in the final tree.
|
|
|
|
if Is_Ignored_Ghost_Entity (Typ) then
|
|
null;
|
|
|
|
elsif ((Is_Access_Object_Type (Typ)
|
|
and then Needs_Finalization
|
|
(Available_View (Designated_Type (Typ))))
|
|
or else (Is_Type (Typ) and then Needs_Finalization (Typ)))
|
|
and then Requires_Cleanup_Actions
|
|
(Actions (Decl), Lib_Level, Nested_Constructs)
|
|
then
|
|
return True;
|
|
end if;
|
|
|
|
-- Nested package declarations
|
|
|
|
elsif Nested_Constructs
|
|
and then Nkind (Decl) = N_Package_Declaration
|
|
then
|
|
Pack_Id := Defining_Entity (Decl);
|
|
|
|
-- Do not inspect an ignored Ghost package because all code found
|
|
-- within will not appear in the final tree.
|
|
|
|
if Is_Ignored_Ghost_Entity (Pack_Id) then
|
|
null;
|
|
|
|
elsif Ekind (Pack_Id) /= E_Generic_Package
|
|
and then Requires_Cleanup_Actions
|
|
(Specification (Decl), Lib_Level)
|
|
then
|
|
return True;
|
|
end if;
|
|
|
|
-- Nested package bodies
|
|
|
|
elsif Nested_Constructs and then Nkind (Decl) = N_Package_Body then
|
|
|
|
-- Do not inspect an ignored Ghost package body because all code
|
|
-- found within will not appear in the final tree.
|
|
|
|
if Is_Ignored_Ghost_Entity (Defining_Entity (Decl)) then
|
|
null;
|
|
|
|
elsif Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package
|
|
and then Requires_Cleanup_Actions (Decl, Lib_Level)
|
|
then
|
|
return True;
|
|
end if;
|
|
|
|
elsif Nkind (Decl) = N_Block_Statement
|
|
and then
|
|
|
|
-- Handle a rare case caused by a controlled transient object
|
|
-- created as part of a record init proc. The variable is wrapped
|
|
-- in a block, but the block is not associated with a transient
|
|
-- scope.
|
|
|
|
(Inside_Init_Proc
|
|
|
|
-- Handle the case where the original context has been wrapped in
|
|
-- a block to avoid interference between exception handlers and
|
|
-- At_End handlers. Treat the block as transparent and process its
|
|
-- contents.
|
|
|
|
or else Is_Finalization_Wrapper (Decl))
|
|
then
|
|
if Requires_Cleanup_Actions (Decl, Lib_Level) then
|
|
return True;
|
|
end if;
|
|
end if;
|
|
|
|
Next (Decl);
|
|
end loop;
|
|
|
|
return False;
|
|
end Requires_Cleanup_Actions;
|
|
|
|
------------------------------------
|
|
-- Safe_Unchecked_Type_Conversion --
|
|
------------------------------------
|
|
|
|
-- Note: this function knows quite a bit about the exact requirements of
|
|
-- Gigi with respect to unchecked type conversions, and its code must be
|
|
-- coordinated with any changes in Gigi in this area.
|
|
|
|
-- The above requirements should be documented in Sinfo ???
|
|
|
|
function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is
|
|
Otyp : Entity_Id;
|
|
Ityp : Entity_Id;
|
|
Oalign : Uint;
|
|
Ialign : Uint;
|
|
Pexp : constant Node_Id := Parent (Exp);
|
|
|
|
begin
|
|
-- If the expression is the RHS of an assignment or object declaration
|
|
-- we are always OK because there will always be a target.
|
|
|
|
-- Object renaming declarations, (generated for view conversions of
|
|
-- actuals in inlined calls), like object declarations, provide an
|
|
-- explicit type, and are safe as well.
|
|
|
|
if (Nkind (Pexp) = N_Assignment_Statement
|
|
and then Expression (Pexp) = Exp)
|
|
or else Nkind (Pexp)
|
|
in N_Object_Declaration | N_Object_Renaming_Declaration
|
|
then
|
|
return True;
|
|
|
|
-- If the expression is the prefix of an N_Selected_Component we should
|
|
-- also be OK because GCC knows to look inside the conversion except if
|
|
-- the type is discriminated. We assume that we are OK anyway if the
|
|
-- type is not set yet or if it is controlled since we can't afford to
|
|
-- introduce a temporary in this case.
|
|
|
|
elsif Nkind (Pexp) = N_Selected_Component
|
|
and then Prefix (Pexp) = Exp
|
|
then
|
|
return No (Etype (Pexp))
|
|
or else not Is_Type (Etype (Pexp))
|
|
or else not Has_Discriminants (Etype (Pexp))
|
|
or else Is_Constrained (Etype (Pexp));
|
|
end if;
|
|
|
|
-- Set the output type, this comes from Etype if it is set, otherwise we
|
|
-- take it from the subtype mark, which we assume was already fully
|
|
-- analyzed.
|
|
|
|
if Present (Etype (Exp)) then
|
|
Otyp := Etype (Exp);
|
|
else
|
|
Otyp := Entity (Subtype_Mark (Exp));
|
|
end if;
|
|
|
|
-- The input type always comes from the expression, and we assume this
|
|
-- is indeed always analyzed, so we can simply get the Etype.
|
|
|
|
Ityp := Etype (Expression (Exp));
|
|
|
|
-- Initialize alignments to unknown so far
|
|
|
|
Oalign := No_Uint;
|
|
Ialign := No_Uint;
|
|
|
|
-- Replace a concurrent type by its corresponding record type and each
|
|
-- type by its underlying type and do the tests on those. The original
|
|
-- type may be a private type whose completion is a concurrent type, so
|
|
-- find the underlying type first.
|
|
|
|
if Present (Underlying_Type (Otyp)) then
|
|
Otyp := Underlying_Type (Otyp);
|
|
end if;
|
|
|
|
if Present (Underlying_Type (Ityp)) then
|
|
Ityp := Underlying_Type (Ityp);
|
|
end if;
|
|
|
|
if Is_Concurrent_Type (Otyp) then
|
|
Otyp := Corresponding_Record_Type (Otyp);
|
|
end if;
|
|
|
|
if Is_Concurrent_Type (Ityp) then
|
|
Ityp := Corresponding_Record_Type (Ityp);
|
|
end if;
|
|
|
|
-- If the base types are the same, we know there is no problem since
|
|
-- this conversion will be a noop.
|
|
|
|
if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then
|
|
return True;
|
|
|
|
-- Same if this is an upwards conversion of an untagged type, and there
|
|
-- are no constraints involved (could be more general???)
|
|
|
|
elsif Etype (Ityp) = Otyp
|
|
and then not Is_Tagged_Type (Ityp)
|
|
and then not Has_Discriminants (Ityp)
|
|
and then No (First_Rep_Item (Base_Type (Ityp)))
|
|
then
|
|
return True;
|
|
|
|
-- If the expression has an access type (object or subprogram) we assume
|
|
-- that the conversion is safe, because the size of the target is safe,
|
|
-- even if it is a record (which might be treated as having unknown size
|
|
-- at this point).
|
|
|
|
elsif Is_Access_Type (Ityp) then
|
|
return True;
|
|
|
|
-- If the size of output type is known at compile time, there is never
|
|
-- a problem. Note that unconstrained records are considered to be of
|
|
-- known size, but we can't consider them that way here, because we are
|
|
-- talking about the actual size of the object.
|
|
|
|
-- We also make sure that in addition to the size being known, we do not
|
|
-- have a case which might generate an embarrassingly large temp in
|
|
-- stack checking mode.
|
|
|
|
elsif Size_Known_At_Compile_Time (Otyp)
|
|
and then
|
|
(not Stack_Checking_Enabled
|
|
or else not May_Generate_Large_Temp (Otyp))
|
|
and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp))
|
|
then
|
|
return True;
|
|
|
|
-- If either type is tagged, then we know the alignment is OK so Gigi
|
|
-- will be able to use pointer punning.
|
|
|
|
elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then
|
|
return True;
|
|
|
|
-- If either type is a limited record type, we cannot do a copy, so say
|
|
-- safe since there's nothing else we can do.
|
|
|
|
elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then
|
|
return True;
|
|
|
|
-- Conversions to and from packed array types are always ignored and
|
|
-- hence are safe.
|
|
|
|
elsif Is_Packed_Array_Impl_Type (Otyp)
|
|
or else Is_Packed_Array_Impl_Type (Ityp)
|
|
then
|
|
return True;
|
|
end if;
|
|
|
|
-- The only other cases known to be safe is if the input type's
|
|
-- alignment is known to be at least the maximum alignment for the
|
|
-- target or if both alignments are known and the output type's
|
|
-- alignment is no stricter than the input's. We can use the component
|
|
-- type alignment for an array if a type is an unpacked array type.
|
|
|
|
if Present (Alignment_Clause (Otyp)) then
|
|
Oalign := Expr_Value (Expression (Alignment_Clause (Otyp)));
|
|
|
|
elsif Is_Array_Type (Otyp)
|
|
and then Present (Alignment_Clause (Component_Type (Otyp)))
|
|
then
|
|
Oalign := Expr_Value (Expression (Alignment_Clause
|
|
(Component_Type (Otyp))));
|
|
end if;
|
|
|
|
if Present (Alignment_Clause (Ityp)) then
|
|
Ialign := Expr_Value (Expression (Alignment_Clause (Ityp)));
|
|
|
|
elsif Is_Array_Type (Ityp)
|
|
and then Present (Alignment_Clause (Component_Type (Ityp)))
|
|
then
|
|
Ialign := Expr_Value (Expression (Alignment_Clause
|
|
(Component_Type (Ityp))));
|
|
end if;
|
|
|
|
if Present (Ialign) and then Ialign > Maximum_Alignment then
|
|
return True;
|
|
|
|
elsif Present (Ialign)
|
|
and then Present (Oalign)
|
|
and then Ialign <= Oalign
|
|
then
|
|
return True;
|
|
|
|
-- Otherwise, Gigi cannot handle this and we must make a temporary
|
|
|
|
else
|
|
return False;
|
|
end if;
|
|
end Safe_Unchecked_Type_Conversion;
|
|
|
|
---------------------------------
|
|
-- Set_Current_Value_Condition --
|
|
---------------------------------
|
|
|
|
-- Note: the implementation of this procedure is very closely tied to the
|
|
-- implementation of Get_Current_Value_Condition. Here we set required
|
|
-- Current_Value fields, and in Get_Current_Value_Condition, we interpret
|
|
-- them, so they must have a consistent view.
|
|
|
|
procedure Set_Current_Value_Condition (Cnode : Node_Id) is
|
|
|
|
procedure Set_Entity_Current_Value (N : Node_Id);
|
|
-- If N is an entity reference, where the entity is of an appropriate
|
|
-- kind, then set the current value of this entity to Cnode, unless
|
|
-- there is already a definite value set there.
|
|
|
|
procedure Set_Expression_Current_Value (N : Node_Id);
|
|
-- If N is of an appropriate form, sets an appropriate entry in current
|
|
-- value fields of relevant entities. Multiple entities can be affected
|
|
-- in the case of an AND or AND THEN.
|
|
|
|
------------------------------
|
|
-- Set_Entity_Current_Value --
|
|
------------------------------
|
|
|
|
procedure Set_Entity_Current_Value (N : Node_Id) is
|
|
begin
|
|
if Is_Entity_Name (N) then
|
|
declare
|
|
Ent : constant Entity_Id := Entity (N);
|
|
|
|
begin
|
|
-- Don't capture if not safe to do so
|
|
|
|
if not Safe_To_Capture_Value (N, Ent, Cond => True) then
|
|
return;
|
|
end if;
|
|
|
|
-- Here we have a case where the Current_Value field may need
|
|
-- to be set. We set it if it is not already set to a compile
|
|
-- time expression value.
|
|
|
|
-- Note that this represents a decision that one condition
|
|
-- blots out another previous one. That's certainly right if
|
|
-- they occur at the same level. If the second one is nested,
|
|
-- then the decision is neither right nor wrong (it would be
|
|
-- equally OK to leave the outer one in place, or take the new
|
|
-- inner one). Really we should record both, but our data
|
|
-- structures are not that elaborate.
|
|
|
|
if Nkind (Current_Value (Ent)) not in N_Subexpr then
|
|
Set_Current_Value (Ent, Cnode);
|
|
end if;
|
|
end;
|
|
end if;
|
|
end Set_Entity_Current_Value;
|
|
|
|
----------------------------------
|
|
-- Set_Expression_Current_Value --
|
|
----------------------------------
|
|
|
|
procedure Set_Expression_Current_Value (N : Node_Id) is
|
|
Cond : Node_Id;
|
|
|
|
begin
|
|
Cond := N;
|
|
|
|
-- Loop to deal with (ignore for now) any NOT operators present. The
|
|
-- presence of NOT operators will be handled properly when we call
|
|
-- Get_Current_Value_Condition.
|
|
|
|
while Nkind (Cond) = N_Op_Not loop
|
|
Cond := Right_Opnd (Cond);
|
|
end loop;
|
|
|
|
-- For an AND or AND THEN, recursively process operands
|
|
|
|
if Nkind (Cond) = N_Op_And or else Nkind (Cond) = N_And_Then then
|
|
Set_Expression_Current_Value (Left_Opnd (Cond));
|
|
Set_Expression_Current_Value (Right_Opnd (Cond));
|
|
return;
|
|
end if;
|
|
|
|
-- Check possible relational operator
|
|
|
|
if Nkind (Cond) in N_Op_Compare then
|
|
if Compile_Time_Known_Value (Right_Opnd (Cond)) then
|
|
Set_Entity_Current_Value (Left_Opnd (Cond));
|
|
elsif Compile_Time_Known_Value (Left_Opnd (Cond)) then
|
|
Set_Entity_Current_Value (Right_Opnd (Cond));
|
|
end if;
|
|
|
|
elsif Nkind (Cond) in N_Type_Conversion
|
|
| N_Qualified_Expression
|
|
| N_Expression_With_Actions
|
|
then
|
|
Set_Expression_Current_Value (Expression (Cond));
|
|
|
|
-- Check possible boolean variable reference
|
|
|
|
else
|
|
Set_Entity_Current_Value (Cond);
|
|
end if;
|
|
end Set_Expression_Current_Value;
|
|
|
|
-- Start of processing for Set_Current_Value_Condition
|
|
|
|
begin
|
|
Set_Expression_Current_Value (Condition (Cnode));
|
|
end Set_Current_Value_Condition;
|
|
|
|
--------------------------
|
|
-- Set_Elaboration_Flag --
|
|
--------------------------
|
|
|
|
procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is
|
|
Loc : constant Source_Ptr := Sloc (N);
|
|
Ent : constant Entity_Id := Elaboration_Entity (Spec_Id);
|
|
Asn : Node_Id;
|
|
|
|
begin
|
|
if Present (Ent) then
|
|
|
|
-- Nothing to do if at the compilation unit level, because in this
|
|
-- case the flag is set by the binder generated elaboration routine.
|
|
|
|
if Nkind (Parent (N)) = N_Compilation_Unit then
|
|
null;
|
|
|
|
-- Here we do need to generate an assignment statement
|
|
|
|
else
|
|
Check_Restriction (No_Elaboration_Code, N);
|
|
|
|
Asn :=
|
|
Make_Assignment_Statement (Loc,
|
|
Name => New_Occurrence_Of (Ent, Loc),
|
|
Expression => Make_Integer_Literal (Loc, Uint_1));
|
|
|
|
-- Mark the assignment statement as elaboration code. This allows
|
|
-- the early call region mechanism (see Sem_Elab) to properly
|
|
-- ignore such assignments even though they are nonpreelaborable
|
|
-- code.
|
|
|
|
Set_Is_Elaboration_Code (Asn);
|
|
|
|
if Nkind (Parent (N)) = N_Subunit then
|
|
Insert_After (Corresponding_Stub (Parent (N)), Asn);
|
|
else
|
|
Insert_After (N, Asn);
|
|
end if;
|
|
|
|
Analyze (Asn);
|
|
|
|
-- Kill current value indication. This is necessary because the
|
|
-- tests of this flag are inserted out of sequence and must not
|
|
-- pick up bogus indications of the wrong constant value.
|
|
|
|
Set_Current_Value (Ent, Empty);
|
|
|
|
-- If the subprogram is in the current declarative part and
|
|
-- 'access has been applied to it, generate an elaboration
|
|
-- check at the beginning of the declarations of the body.
|
|
|
|
if Nkind (N) = N_Subprogram_Body
|
|
and then Address_Taken (Spec_Id)
|
|
and then
|
|
Ekind (Scope (Spec_Id)) in E_Block | E_Procedure | E_Function
|
|
then
|
|
declare
|
|
Loc : constant Source_Ptr := Sloc (N);
|
|
Decls : constant List_Id := Declarations (N);
|
|
Chk : Node_Id;
|
|
|
|
begin
|
|
-- No need to generate this check if first entry in the
|
|
-- declaration list is a raise of Program_Error now.
|
|
|
|
if Present (Decls)
|
|
and then Nkind (First (Decls)) = N_Raise_Program_Error
|
|
then
|
|
return;
|
|
end if;
|
|
|
|
-- Otherwise generate the check
|
|
|
|
Chk :=
|
|
Make_Raise_Program_Error (Loc,
|
|
Condition =>
|
|
Make_Op_Eq (Loc,
|
|
Left_Opnd => New_Occurrence_Of (Ent, Loc),
|
|
Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
|
|
Reason => PE_Access_Before_Elaboration);
|
|
|
|
if No (Decls) then
|
|
Set_Declarations (N, New_List (Chk));
|
|
else
|
|
Prepend (Chk, Decls);
|
|
end if;
|
|
|
|
Analyze (Chk);
|
|
end;
|
|
end if;
|
|
end if;
|
|
end if;
|
|
end Set_Elaboration_Flag;
|
|
|
|
----------------------------
|
|
-- Set_Renamed_Subprogram --
|
|
----------------------------
|
|
|
|
procedure Set_Renamed_Subprogram (N : Node_Id; E : Entity_Id) is
|
|
begin
|
|
-- If input node is an identifier, we can just reset it
|
|
|
|
if Nkind (N) = N_Identifier then
|
|
Set_Chars (N, Chars (E));
|
|
Set_Entity (N, E);
|
|
|
|
-- Otherwise we have to do a rewrite, preserving Comes_From_Source
|
|
|
|
else
|
|
declare
|
|
CS : constant Boolean := Comes_From_Source (N);
|
|
begin
|
|
Rewrite (N, Make_Identifier (Sloc (N), Chars (E)));
|
|
Set_Entity (N, E);
|
|
Set_Comes_From_Source (N, CS);
|
|
Set_Analyzed (N, True);
|
|
end;
|
|
end if;
|
|
end Set_Renamed_Subprogram;
|
|
|
|
----------------------
|
|
-- Side_Effect_Free --
|
|
----------------------
|
|
|
|
function Side_Effect_Free
|
|
(N : Node_Id;
|
|
Name_Req : Boolean := False;
|
|
Variable_Ref : Boolean := False) return Boolean
|
|
is
|
|
Typ : constant Entity_Id := Etype (N);
|
|
-- Result type of the expression
|
|
|
|
function Safe_Prefixed_Reference (N : Node_Id) return Boolean;
|
|
-- The argument N is a construct where the Prefix is dereferenced if it
|
|
-- is an access type and the result is a variable. The call returns True
|
|
-- if the construct is side effect free (not considering side effects in
|
|
-- other than the prefix which are to be tested by the caller).
|
|
|
|
function Within_In_Parameter (N : Node_Id) return Boolean;
|
|
-- Determines if N is a subcomponent of a composite in-parameter. If so,
|
|
-- N is not side-effect free when the actual is global and modifiable
|
|
-- indirectly from within a subprogram, because it may be passed by
|
|
-- reference. The front-end must be conservative here and assume that
|
|
-- this may happen with any array or record type. On the other hand, we
|
|
-- cannot create temporaries for all expressions for which this
|
|
-- condition is true, for various reasons that might require clearing up
|
|
-- ??? For example, discriminant references that appear out of place, or
|
|
-- spurious type errors with class-wide expressions. As a result, we
|
|
-- limit the transformation to loop bounds, which is so far the only
|
|
-- case that requires it.
|
|
|
|
-----------------------------
|
|
-- Safe_Prefixed_Reference --
|
|
-----------------------------
|
|
|
|
function Safe_Prefixed_Reference (N : Node_Id) return Boolean is
|
|
begin
|
|
-- If prefix is not side effect free, definitely not safe
|
|
|
|
if not Side_Effect_Free (Prefix (N), Name_Req, Variable_Ref) then
|
|
return False;
|
|
|
|
-- If the prefix is of an access type that is not access-to-constant,
|
|
-- then this construct is a variable reference, which means it is to
|
|
-- be considered to have side effects if Variable_Ref is set True.
|
|
|
|
elsif Is_Access_Type (Etype (Prefix (N)))
|
|
and then not Is_Access_Constant (Etype (Prefix (N)))
|
|
and then Variable_Ref
|
|
then
|
|
-- Exception is a prefix that is the result of a previous removal
|
|
-- of side effects.
|
|
|
|
return Is_Entity_Name (Prefix (N))
|
|
and then not Comes_From_Source (Prefix (N))
|
|
and then Ekind (Entity (Prefix (N))) = E_Constant
|
|
and then Is_Internal_Name (Chars (Entity (Prefix (N))));
|
|
|
|
-- If the prefix is an explicit dereference then this construct is a
|
|
-- variable reference, which means it is to be considered to have
|
|
-- side effects if Variable_Ref is True.
|
|
|
|
-- We do NOT exclude dereferences of access-to-constant types because
|
|
-- we handle them as constant view of variables.
|
|
|
|
elsif Nkind (Prefix (N)) = N_Explicit_Dereference
|
|
and then Variable_Ref
|
|
then
|
|
return False;
|
|
|
|
-- Note: The following test is the simplest way of solving a complex
|
|
-- problem uncovered by the following test (Side effect on loop bound
|
|
-- that is a subcomponent of a global variable:
|
|
|
|
-- with Text_Io; use Text_Io;
|
|
-- procedure Tloop is
|
|
-- type X is
|
|
-- record
|
|
-- V : Natural := 4;
|
|
-- S : String (1..5) := (others => 'a');
|
|
-- end record;
|
|
-- X1 : X;
|
|
|
|
-- procedure Modi;
|
|
|
|
-- generic
|
|
-- with procedure Action;
|
|
-- procedure Loop_G (Arg : X; Msg : String)
|
|
|
|
-- procedure Loop_G (Arg : X; Msg : String) is
|
|
-- begin
|
|
-- Put_Line ("begin loop_g " & Msg & " will loop till: "
|
|
-- & Natural'Image (Arg.V));
|
|
-- for Index in 1 .. Arg.V loop
|
|
-- Text_Io.Put_Line
|
|
-- (Natural'Image (Index) & " " & Arg.S (Index));
|
|
-- if Index > 2 then
|
|
-- Modi;
|
|
-- end if;
|
|
-- end loop;
|
|
-- Put_Line ("end loop_g " & Msg);
|
|
-- end;
|
|
|
|
-- procedure Loop1 is new Loop_G (Modi);
|
|
-- procedure Modi is
|
|
-- begin
|
|
-- X1.V := 1;
|
|
-- Loop1 (X1, "from modi");
|
|
-- end;
|
|
--
|
|
-- begin
|
|
-- Loop1 (X1, "initial");
|
|
-- end;
|
|
|
|
-- The output of the above program should be:
|
|
|
|
-- begin loop_g initial will loop till: 4
|
|
-- 1 a
|
|
-- 2 a
|
|
-- 3 a
|
|
-- begin loop_g from modi will loop till: 1
|
|
-- 1 a
|
|
-- end loop_g from modi
|
|
-- 4 a
|
|
-- begin loop_g from modi will loop till: 1
|
|
-- 1 a
|
|
-- end loop_g from modi
|
|
-- end loop_g initial
|
|
|
|
-- If a loop bound is a subcomponent of a global variable, a
|
|
-- modification of that variable within the loop may incorrectly
|
|
-- affect the execution of the loop.
|
|
|
|
elsif Parent_Kind (Parent (N)) = N_Loop_Parameter_Specification
|
|
and then Within_In_Parameter (Prefix (N))
|
|
and then Variable_Ref
|
|
then
|
|
return False;
|
|
|
|
-- All other cases are side effect free
|
|
|
|
else
|
|
return True;
|
|
end if;
|
|
end Safe_Prefixed_Reference;
|
|
|
|
-------------------------
|
|
-- Within_In_Parameter --
|
|
-------------------------
|
|
|
|
function Within_In_Parameter (N : Node_Id) return Boolean is
|
|
begin
|
|
if not Comes_From_Source (N) then
|
|
return False;
|
|
|
|
elsif Is_Entity_Name (N) then
|
|
return Ekind (Entity (N)) = E_In_Parameter;
|
|
|
|
elsif Nkind (N) in N_Indexed_Component | N_Selected_Component then
|
|
return Within_In_Parameter (Prefix (N));
|
|
|
|
else
|
|
return False;
|
|
end if;
|
|
end Within_In_Parameter;
|
|
|
|
-- Start of processing for Side_Effect_Free
|
|
|
|
begin
|
|
-- If volatile reference, always consider it to have side effects
|
|
|
|
if Is_Volatile_Reference (N) then
|
|
return False;
|
|
end if;
|
|
|
|
-- Note on checks that could raise Constraint_Error. Strictly, if we
|
|
-- take advantage of 11.6, these checks do not count as side effects.
|
|
-- However, we would prefer to consider that they are side effects,
|
|
-- since the back end CSE does not work very well on expressions which
|
|
-- can raise Constraint_Error. On the other hand if we don't consider
|
|
-- them to be side effect free, then we get some awkward expansions
|
|
-- in -gnato mode, resulting in code insertions at a point where we
|
|
-- do not have a clear model for performing the insertions.
|
|
|
|
-- Special handling for entity names
|
|
|
|
if Is_Entity_Name (N) then
|
|
|
|
-- A type reference is always side effect free
|
|
|
|
if Is_Type (Entity (N)) then
|
|
return True;
|
|
|
|
-- Variables are considered to be a side effect if Variable_Ref
|
|
-- is set or if we have a volatile reference and Name_Req is off.
|
|
-- If Name_Req is True then we can't help returning a name which
|
|
-- effectively allows multiple references in any case.
|
|
|
|
elsif Is_Variable (N, Use_Original_Node => False) then
|
|
return not Variable_Ref
|
|
and then (not Is_Volatile_Reference (N) or else Name_Req);
|
|
|
|
-- Any other entity (e.g. a subtype name) is definitely side
|
|
-- effect free.
|
|
|
|
else
|
|
return True;
|
|
end if;
|
|
|
|
-- A value known at compile time is always side effect free
|
|
|
|
elsif Compile_Time_Known_Value (N) then
|
|
return True;
|
|
|
|
-- A variable renaming is not side-effect free, because the renaming
|
|
-- will function like a macro in the front-end in some cases, and an
|
|
-- assignment can modify the component designated by N, so we need to
|
|
-- create a temporary for it.
|
|
|
|
-- The guard testing for Entity being present is needed at least in
|
|
-- the case of rewritten predicate expressions, and may well also be
|
|
-- appropriate elsewhere. Obviously we can't go testing the entity
|
|
-- field if it does not exist, so it's reasonable to say that this is
|
|
-- not the renaming case if it does not exist.
|
|
|
|
elsif Is_Entity_Name (Original_Node (N))
|
|
and then Present (Entity (Original_Node (N)))
|
|
and then Is_Renaming_Of_Object (Entity (Original_Node (N)))
|
|
and then Ekind (Entity (Original_Node (N))) /= E_Constant
|
|
then
|
|
declare
|
|
RO : constant Node_Id :=
|
|
Renamed_Object (Entity (Original_Node (N)));
|
|
|
|
begin
|
|
-- If the renamed object is an indexed component, or an
|
|
-- explicit dereference, then the designated object could
|
|
-- be modified by an assignment.
|
|
|
|
if Nkind (RO) in N_Indexed_Component | N_Explicit_Dereference then
|
|
return False;
|
|
|
|
-- A selected component must have a safe prefix
|
|
|
|
elsif Nkind (RO) = N_Selected_Component then
|
|
return Safe_Prefixed_Reference (RO);
|
|
|
|
-- In all other cases, designated object cannot be changed so
|
|
-- we are side effect free.
|
|
|
|
else
|
|
return True;
|
|
end if;
|
|
end;
|
|
|
|
-- Remove_Side_Effects generates an object renaming declaration to
|
|
-- capture the expression of a class-wide expression. In VM targets
|
|
-- the frontend performs no expansion for dispatching calls to
|
|
-- class- wide types since they are handled by the VM. Hence, we must
|
|
-- locate here if this node corresponds to a previous invocation of
|
|
-- Remove_Side_Effects to avoid a never ending loop in the frontend.
|
|
|
|
elsif not Tagged_Type_Expansion
|
|
and then not Comes_From_Source (N)
|
|
and then Nkind (Parent (N)) = N_Object_Renaming_Declaration
|
|
and then Is_Class_Wide_Type (Typ)
|
|
then
|
|
return True;
|
|
|
|
-- Generating C the type conversion of an access to constrained array
|
|
-- type into an access to unconstrained array type involves initializing
|
|
-- a fat pointer and the expression cannot be assumed to be free of side
|
|
-- effects since it must referenced several times to compute its bounds.
|
|
|
|
elsif Modify_Tree_For_C
|
|
and then Nkind (N) = N_Type_Conversion
|
|
and then Is_Access_Type (Typ)
|
|
and then Is_Array_Type (Designated_Type (Typ))
|
|
and then not Is_Constrained (Designated_Type (Typ))
|
|
then
|
|
return False;
|
|
end if;
|
|
|
|
-- For other than entity names and compile time known values,
|
|
-- check the node kind for special processing.
|
|
|
|
case Nkind (N) is
|
|
|
|
-- An attribute reference is side-effect free if its expressions
|
|
-- are side-effect free and its prefix is side-effect free or is
|
|
-- an entity reference.
|
|
|
|
when N_Attribute_Reference =>
|
|
return Side_Effect_Free_Attribute (Attribute_Name (N))
|
|
and then
|
|
Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
|
|
and then
|
|
(Is_Entity_Name (Prefix (N))
|
|
or else
|
|
Side_Effect_Free (Prefix (N), Name_Req, Variable_Ref));
|
|
|
|
-- A binary operator is side effect free if and both operands are
|
|
-- side effect free. For this purpose binary operators include
|
|
-- short circuit forms.
|
|
|
|
when N_Binary_Op
|
|
| N_Short_Circuit
|
|
=>
|
|
return Side_Effect_Free (Left_Opnd (N), Name_Req, Variable_Ref)
|
|
and then
|
|
Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref);
|
|
|
|
-- Membership tests may have either Right_Opnd or Alternatives set
|
|
|
|
when N_Membership_Test =>
|
|
return Side_Effect_Free (Left_Opnd (N), Name_Req, Variable_Ref)
|
|
and then
|
|
(if Present (Right_Opnd (N))
|
|
then Side_Effect_Free
|
|
(Right_Opnd (N), Name_Req, Variable_Ref)
|
|
else Side_Effect_Free
|
|
(Alternatives (N), Name_Req, Variable_Ref));
|
|
|
|
-- An explicit dereference is side effect free only if it is
|
|
-- a side effect free prefixed reference.
|
|
|
|
when N_Explicit_Dereference =>
|
|
return Safe_Prefixed_Reference (N);
|
|
|
|
-- An expression with action is side effect free if its expression
|
|
-- is side effect free and it has no actions.
|
|
|
|
when N_Expression_With_Actions =>
|
|
return
|
|
Is_Empty_List (Actions (N))
|
|
and then Side_Effect_Free
|
|
(Expression (N), Name_Req, Variable_Ref);
|
|
|
|
-- A call to _rep_to_pos is side effect free, since we generate
|
|
-- this pure function call ourselves. Moreover it is critically
|
|
-- important to make this exception, since otherwise we can have
|
|
-- discriminants in array components which don't look side effect
|
|
-- free in the case of an array whose index type is an enumeration
|
|
-- type with an enumeration rep clause.
|
|
|
|
-- All other function calls are not side effect free
|
|
|
|
when N_Function_Call =>
|
|
return
|
|
Nkind (Name (N)) = N_Identifier
|
|
and then Is_TSS (Name (N), TSS_Rep_To_Pos)
|
|
and then Side_Effect_Free
|
|
(First (Parameter_Associations (N)),
|
|
Name_Req, Variable_Ref);
|
|
|
|
-- An IF expression is side effect free if it's of a scalar type, and
|
|
-- all its components are all side effect free (conditions and then
|
|
-- actions and else actions). We restrict to scalar types, since it
|
|
-- is annoying to deal with things like (if A then B else C)'First
|
|
-- where the type involved is a string type.
|
|
|
|
when N_If_Expression =>
|
|
return
|
|
Is_Scalar_Type (Typ)
|
|
and then Side_Effect_Free
|
|
(Expressions (N), Name_Req, Variable_Ref);
|
|
|
|
-- An indexed component is side effect free if it is a side
|
|
-- effect free prefixed reference and all the indexing
|
|
-- expressions are side effect free.
|
|
|
|
when N_Indexed_Component =>
|
|
return
|
|
Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
|
|
and then Safe_Prefixed_Reference (N);
|
|
|
|
-- A type qualification, type conversion, or unchecked expression is
|
|
-- side effect free if the expression is side effect free.
|
|
|
|
when N_Qualified_Expression
|
|
| N_Type_Conversion
|
|
| N_Unchecked_Expression
|
|
=>
|
|
return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
|
|
|
|
-- A selected component is side effect free only if it is a side
|
|
-- effect free prefixed reference.
|
|
|
|
when N_Selected_Component =>
|
|
return Safe_Prefixed_Reference (N);
|
|
|
|
-- A range is side effect free if the bounds are side effect free
|
|
|
|
when N_Range =>
|
|
return Side_Effect_Free (Low_Bound (N), Name_Req, Variable_Ref)
|
|
and then
|
|
Side_Effect_Free (High_Bound (N), Name_Req, Variable_Ref);
|
|
|
|
-- A slice is side effect free if it is a side effect free
|
|
-- prefixed reference and the bounds are side effect free.
|
|
|
|
when N_Slice =>
|
|
return
|
|
Side_Effect_Free (Discrete_Range (N), Name_Req, Variable_Ref)
|
|
and then Safe_Prefixed_Reference (N);
|
|
|
|
-- A unary operator is side effect free if the operand
|
|
-- is side effect free.
|
|
|
|
when N_Unary_Op =>
|
|
return Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref);
|
|
|
|
-- An unchecked type conversion is side effect free only if it
|
|
-- is safe and its argument is side effect free.
|
|
|
|
when N_Unchecked_Type_Conversion =>
|
|
return
|
|
Safe_Unchecked_Type_Conversion (N)
|
|
and then Side_Effect_Free
|
|
(Expression (N), Name_Req, Variable_Ref);
|
|
|
|
-- A literal is side effect free
|
|
|
|
when N_Character_Literal
|
|
| N_Integer_Literal
|
|
| N_Real_Literal
|
|
| N_String_Literal
|
|
=>
|
|
return True;
|
|
|
|
-- An aggregate is side effect free if all its values are compile
|
|
-- time known.
|
|
|
|
when N_Aggregate =>
|
|
return Compile_Time_Known_Aggregate (N);
|
|
|
|
-- We consider that anything else has side effects. This is a bit
|
|
-- crude, but we are pretty close for most common cases, and we
|
|
-- are certainly correct (i.e. we never return True when the
|
|
-- answer should be False).
|
|
|
|
when others =>
|
|
return False;
|
|
end case;
|
|
end Side_Effect_Free;
|
|
|
|
-- A list is side effect free if all elements of the list are side
|
|
-- effect free.
|
|
|
|
function Side_Effect_Free
|
|
(L : List_Id;
|
|
Name_Req : Boolean := False;
|
|
Variable_Ref : Boolean := False) return Boolean
|
|
is
|
|
N : Node_Id;
|
|
|
|
begin
|
|
if L = No_List or else L = Error_List then
|
|
return True;
|
|
|
|
else
|
|
N := First (L);
|
|
while Present (N) loop
|
|
if not Side_Effect_Free (N, Name_Req, Variable_Ref) then
|
|
return False;
|
|
else
|
|
Next (N);
|
|
end if;
|
|
end loop;
|
|
|
|
return True;
|
|
end if;
|
|
end Side_Effect_Free;
|
|
|
|
--------------------------------
|
|
-- Side_Effect_Free_Attribute --
|
|
--------------------------------
|
|
|
|
function Side_Effect_Free_Attribute (Name : Name_Id) return Boolean is
|
|
begin
|
|
case Name is
|
|
when Name_Input =>
|
|
return False;
|
|
|
|
when Name_Image
|
|
| Name_Img
|
|
| Name_Wide_Image
|
|
| Name_Wide_Wide_Image
|
|
=>
|
|
-- CodePeer doesn't want to see replicated copies of 'Image calls
|
|
|
|
return not CodePeer_Mode;
|
|
|
|
when others =>
|
|
return True;
|
|
end case;
|
|
end Side_Effect_Free_Attribute;
|
|
|
|
----------------------------------
|
|
-- Silly_Boolean_Array_Not_Test --
|
|
----------------------------------
|
|
|
|
-- This procedure implements an odd and silly test. We explicitly check
|
|
-- for the case where the 'First of the component type is equal to the
|
|
-- 'Last of this component type, and if this is the case, we make sure
|
|
-- that constraint error is raised. The reason is that the NOT is bound
|
|
-- to cause CE in this case, and we will not otherwise catch it.
|
|
|
|
-- No such check is required for AND and OR, since for both these cases
|
|
-- False op False = False, and True op True = True. For the XOR case,
|
|
-- see Silly_Boolean_Array_Xor_Test.
|
|
|
|
-- Believe it or not, this was reported as a bug. Note that nearly always,
|
|
-- the test will evaluate statically to False, so the code will be
|
|
-- statically removed, and no extra overhead caused.
|
|
|
|
procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id) is
|
|
Loc : constant Source_Ptr := Sloc (N);
|
|
CT : constant Entity_Id := Component_Type (T);
|
|
|
|
begin
|
|
-- The check we install is
|
|
|
|
-- constraint_error when
|
|
-- component_type'first = component_type'last
|
|
-- and then array_type'Length /= 0)
|
|
|
|
-- We need the last guard because we don't want to raise CE for empty
|
|
-- arrays since no out of range values result. (Empty arrays with a
|
|
-- component type of True .. True -- very useful -- even the ACATS
|
|
-- does not test that marginal case).
|
|
|
|
Insert_Action (N,
|
|
Make_Raise_Constraint_Error (Loc,
|
|
Condition =>
|
|
Make_And_Then (Loc,
|
|
Left_Opnd =>
|
|
Make_Op_Eq (Loc,
|
|
Left_Opnd =>
|
|
Make_Attribute_Reference (Loc,
|
|
Prefix => New_Occurrence_Of (CT, Loc),
|
|
Attribute_Name => Name_First),
|
|
|
|
Right_Opnd =>
|
|
Make_Attribute_Reference (Loc,
|
|
Prefix => New_Occurrence_Of (CT, Loc),
|
|
Attribute_Name => Name_Last)),
|
|
|
|
Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))),
|
|
Reason => CE_Range_Check_Failed));
|
|
end Silly_Boolean_Array_Not_Test;
|
|
|
|
----------------------------------
|
|
-- Silly_Boolean_Array_Xor_Test --
|
|
----------------------------------
|
|
|
|
-- This procedure implements an odd and silly test. We explicitly check
|
|
-- for the XOR case where the component type is True .. True, since this
|
|
-- will raise constraint error. A special check is required since CE
|
|
-- will not be generated otherwise (cf Expand_Packed_Not).
|
|
|
|
-- No such check is required for AND and OR, since for both these cases
|
|
-- False op False = False, and True op True = True, and no check is
|
|
-- required for the case of False .. False, since False xor False = False.
|
|
-- See also Silly_Boolean_Array_Not_Test
|
|
|
|
procedure Silly_Boolean_Array_Xor_Test
|
|
(N : Node_Id;
|
|
R : Node_Id;
|
|
T : Entity_Id)
|
|
is
|
|
Loc : constant Source_Ptr := Sloc (N);
|
|
CT : constant Entity_Id := Component_Type (T);
|
|
|
|
begin
|
|
-- The check we install is
|
|
|
|
-- constraint_error when
|
|
-- Boolean (component_type'First)
|
|
-- and then Boolean (component_type'Last)
|
|
-- and then array_type'Length /= 0)
|
|
|
|
-- We need the last guard because we don't want to raise CE for empty
|
|
-- arrays since no out of range values result (Empty arrays with a
|
|
-- component type of True .. True -- very useful -- even the ACATS
|
|
-- does not test that marginal case).
|
|
|
|
Insert_Action (N,
|
|
Make_Raise_Constraint_Error (Loc,
|
|
Condition =>
|
|
Make_And_Then (Loc,
|
|
Left_Opnd =>
|
|
Make_And_Then (Loc,
|
|
Left_Opnd =>
|
|
Convert_To (Standard_Boolean,
|
|
Make_Attribute_Reference (Loc,
|
|
Prefix => New_Occurrence_Of (CT, Loc),
|
|
Attribute_Name => Name_First)),
|
|
|
|
Right_Opnd =>
|
|
Convert_To (Standard_Boolean,
|
|
Make_Attribute_Reference (Loc,
|
|
Prefix => New_Occurrence_Of (CT, Loc),
|
|
Attribute_Name => Name_Last))),
|
|
|
|
Right_Opnd => Make_Non_Empty_Check (Loc, R)),
|
|
Reason => CE_Range_Check_Failed));
|
|
end Silly_Boolean_Array_Xor_Test;
|
|
|
|
----------------------------
|
|
-- Small_Integer_Type_For --
|
|
----------------------------
|
|
|
|
function Small_Integer_Type_For (S : Uint; Uns : Boolean) return Entity_Id
|
|
is
|
|
begin
|
|
pragma Assert (S <= System_Max_Integer_Size);
|
|
|
|
if S <= Standard_Short_Short_Integer_Size then
|
|
if Uns then
|
|
return Standard_Short_Short_Unsigned;
|
|
else
|
|
return Standard_Short_Short_Integer;
|
|
end if;
|
|
|
|
elsif S <= Standard_Short_Integer_Size then
|
|
if Uns then
|
|
return Standard_Short_Unsigned;
|
|
else
|
|
return Standard_Short_Integer;
|
|
end if;
|
|
|
|
elsif S <= Standard_Integer_Size then
|
|
if Uns then
|
|
return Standard_Unsigned;
|
|
else
|
|
return Standard_Integer;
|
|
end if;
|
|
|
|
elsif S <= Standard_Long_Integer_Size then
|
|
if Uns then
|
|
return Standard_Long_Unsigned;
|
|
else
|
|
return Standard_Long_Integer;
|
|
end if;
|
|
|
|
elsif S <= Standard_Long_Long_Integer_Size then
|
|
if Uns then
|
|
return Standard_Long_Long_Unsigned;
|
|
else
|
|
return Standard_Long_Long_Integer;
|
|
end if;
|
|
|
|
elsif S <= Standard_Long_Long_Long_Integer_Size then
|
|
if Uns then
|
|
return Standard_Long_Long_Long_Unsigned;
|
|
else
|
|
return Standard_Long_Long_Long_Integer;
|
|
end if;
|
|
|
|
else
|
|
raise Program_Error;
|
|
end if;
|
|
end Small_Integer_Type_For;
|
|
|
|
-------------------
|
|
-- Type_Map_Hash --
|
|
-------------------
|
|
|
|
function Type_Map_Hash (Id : Entity_Id) return Type_Map_Header is
|
|
begin
|
|
return Type_Map_Header (Id mod Type_Map_Size);
|
|
end Type_Map_Hash;
|
|
|
|
------------------------------------------
|
|
-- Type_May_Have_Bit_Aligned_Components --
|
|
------------------------------------------
|
|
|
|
function Type_May_Have_Bit_Aligned_Components
|
|
(Typ : Entity_Id) return Boolean
|
|
is
|
|
begin
|
|
-- Array type, check component type
|
|
|
|
if Is_Array_Type (Typ) then
|
|
return
|
|
Type_May_Have_Bit_Aligned_Components (Component_Type (Typ));
|
|
|
|
-- Record type, check components
|
|
|
|
elsif Is_Record_Type (Typ) then
|
|
declare
|
|
E : Entity_Id;
|
|
|
|
begin
|
|
E := First_Component_Or_Discriminant (Typ);
|
|
while Present (E) loop
|
|
-- This is the crucial test: if the component itself causes
|
|
-- trouble, then we can stop and return True.
|
|
|
|
if Component_May_Be_Bit_Aligned (E) then
|
|
return True;
|
|
end if;
|
|
|
|
-- Otherwise, we need to test its type, to see if it may
|
|
-- itself contain a troublesome component.
|
|
|
|
if Type_May_Have_Bit_Aligned_Components (Etype (E)) then
|
|
return True;
|
|
end if;
|
|
|
|
Next_Component_Or_Discriminant (E);
|
|
end loop;
|
|
|
|
return False;
|
|
end;
|
|
|
|
-- Type other than array or record is always OK
|
|
|
|
else
|
|
return False;
|
|
end if;
|
|
end Type_May_Have_Bit_Aligned_Components;
|
|
|
|
-------------------------------
|
|
-- Update_Primitives_Mapping --
|
|
-------------------------------
|
|
|
|
procedure Update_Primitives_Mapping
|
|
(Inher_Id : Entity_Id;
|
|
Subp_Id : Entity_Id)
|
|
is
|
|
Parent_Type : constant Entity_Id := Find_Dispatching_Type (Inher_Id);
|
|
Derived_Type : constant Entity_Id := Find_Dispatching_Type (Subp_Id);
|
|
|
|
begin
|
|
pragma Assert (Parent_Type /= Derived_Type);
|
|
Map_Types (Parent_Type, Derived_Type);
|
|
end Update_Primitives_Mapping;
|
|
|
|
----------------------------------
|
|
-- Within_Case_Or_If_Expression --
|
|
----------------------------------
|
|
|
|
function Within_Case_Or_If_Expression (N : Node_Id) return Boolean is
|
|
Par : Node_Id;
|
|
|
|
begin
|
|
-- Locate an enclosing case or if expression. Note that these constructs
|
|
-- can be expanded into Expression_With_Actions, hence the test of the
|
|
-- original node.
|
|
|
|
Par := Parent (N);
|
|
while Present (Par) loop
|
|
if Nkind (Original_Node (Par)) in N_Case_Expression | N_If_Expression
|
|
then
|
|
return True;
|
|
|
|
-- Prevent the search from going too far
|
|
|
|
elsif Is_Body_Or_Package_Declaration (Par) then
|
|
return False;
|
|
end if;
|
|
|
|
Par := Parent (Par);
|
|
end loop;
|
|
|
|
return False;
|
|
end Within_Case_Or_If_Expression;
|
|
|
|
------------------------------
|
|
-- Predicate_Check_In_Scope --
|
|
------------------------------
|
|
|
|
function Predicate_Check_In_Scope (N : Node_Id) return Boolean is
|
|
S : Entity_Id;
|
|
|
|
begin
|
|
S := Current_Scope;
|
|
while Present (S) and then not Is_Subprogram (S) loop
|
|
S := Scope (S);
|
|
end loop;
|
|
|
|
if Present (S) then
|
|
|
|
-- Predicate checks should only be enabled in init procs for
|
|
-- expressions coming from source.
|
|
|
|
if Is_Init_Proc (S) then
|
|
return Comes_From_Source (N);
|
|
|
|
elsif Get_TSS_Name (S) /= TSS_Null
|
|
and then not Is_Predicate_Function (S)
|
|
and then not Is_Predicate_Function_M (S)
|
|
then
|
|
return False;
|
|
end if;
|
|
end if;
|
|
|
|
return True;
|
|
end Predicate_Check_In_Scope;
|
|
|
|
end Exp_Util;
|