Google Git
Sign in
gnu / gcc / refs/tags/releases/gcc-7.5.0 / . / gcc / ada / exp_util.adb
blob: 67a6c64a1d464ffc0c9eedd9e7c687044a4fa3b6 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ U T I L --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2016, 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 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 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_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Urealp; use Urealp;
with Validsw; use Validsw;
with GNAT.HTable; use 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.
Primitives_Mapping_Size : constant := 511;
subtype Num_Primitives is Integer range 0 .. Primitives_Mapping_Size - 1;
function Entity_Hash (E : Entity_Id) return Num_Primitives;
package Primitives_Mapping is new GNAT.HTable.Simple_HTable
(Header_Num => Num_Primitives,
Key => Entity_Id,
Element => Entity_Id,
No_element => Empty,
Hash => Entity_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 Find_DIC_Type (Typ : Entity_Id) return Entity_Id;
-- Subsidiary to all Build_DIC_Procedure_xxx routines. Find the type which
-- defines the Default_Initial_Condition pragma of type Typ. This is either
-- Typ itself or a parent type when the pragma is inherited.
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.
-------------------------------------
-- 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);
Ti : Entity_Id;
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/non-zero semantics or non-standard 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
if Esize (T) <= Esize (Standard_Integer) then
Ti := Standard_Integer;
else
Ti := Standard_Long_Long_Integer;
end if;
Rewrite (N,
Make_Op_Ne (Loc,
Left_Opnd => Unchecked_Convert_To (Ti, 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;
------------------------------------
-- Build_Allocate_Deallocate_Proc --
------------------------------------
procedure Build_Allocate_Deallocate_Proc
(N : Node_Id;
Is_Allocate : Boolean)
is
Desig_Typ : Entity_Id;
Expr : Node_Id;
Pool_Id : Entity_Id;
Proc_To_Call : Node_Id := Empty;
Ptr_Typ : Entity_Id;
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;
-- 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;
-- Do not process allocations / deallocations without a pool
if No (Pool_Id) then
return;
-- Do not process allocations on / deallocations from the secondary
-- stack.
elsif Is_RTE (Pool_Id, RE_SS_Pool) then
return;
-- Optimize the case where we are using the default Global_Pool_Object,
-- and we don't need the heavy finalization machinery.
elsif Pool_Id = RTE (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;
if Needs_Finalization (Desig_Typ) then
-- Certain run-time configurations and targets do not provide support
-- for controlled types.
if Restriction_Active (No_Finalization) then
return;
-- Do nothing if the access type may never allocate / deallocate
-- objects.
elsif 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_Finalization (Desig_Typ) 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_Finalization (Desig_Typ) 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) 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)
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_Finalization (Desig_Typ) then
declare
Flag_Id : constant Entity_Id := Make_Temporary (Loc, 'F');
Flag_Expr : Node_Id;
Param : 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
else
Param :=
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Temp),
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;
-- 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.
Insert_Action (N,
Make_Subprogram_Body (Loc,
Specification =>
-- procedure Pnn
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Proc_Id,
Parameter_Specifications => New_List (
-- P : Root_Storage_Pool
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Temporary (Loc, 'P'),
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc)),
-- A : [out] Address
Make_Parameter_Specification (Loc,
Defining_Identifier => Addr_Id,
Out_Present => Is_Allocate,
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Address), Loc)),
-- S : Storage_Count
Make_Parameter_Specification (Loc,
Defining_Identifier => Size_Id,
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Storage_Count), Loc)),
-- L : Storage_Count
Make_Parameter_Specification (Loc,
Defining_Identifier => Alig_Id,
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Storage_Count), Loc)))),
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)))));
-- 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
(Prag : 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) = N_Identifier
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 := Primitives_Mapping.Get (Entity (N));
if Present (New_E) then
Rewrite (N, New_Occurrence_Of (New_E, Sloc (N)));
end if;
-- Check that there are no calls left to abstract operations if
-- the current subprogram is not abstract.
if Nkind (Parent (N)) = N_Function_Call
and then N = Name (Parent (N))
then
if not Is_Abstract_Subprogram (Subp)
and then Is_Abstract_Subprogram (Entity (N))
then
Error_Msg_Sloc := Sloc (Current_Scope);
Error_Msg_NE
("cannot call abstract subprogram in inherited condition "
& "for&#", N, Current_Scope);
-- In SPARK mode, reject an inherited condition for an
-- inherited operation if it contains a call to an overriding
-- operation, because this implies that the pre/postconditions
-- of the inherited operation have changed silently.
elsif SPARK_Mode = On
and then Warn_On_Suspicious_Contract
and then Present (Alias (Subp))
and then Present (New_E)
and then Comes_From_Source (New_E)
then
Error_Msg_N
("cannot modify inherited condition (SPARK RM 6.1.1(1))",
Parent (Subp));
Error_Msg_Sloc := Sloc (New_E);
Error_Msg_Node_2 := Subp;
Error_Msg_NE
("\overriding of&# forces overriding of&",
Parent (Subp), New_E);
end if;
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_Formal : Entity_Id;
Subp_Formal : Entity_Id;
-- Start of processing for Build_Class_Wide_Expression
begin
-- Add mapping from old formals to new formals
Par_Formal := First_Formal (Par_Subp);
Subp_Formal := First_Formal (Subp);
while Present (Par_Formal) and then Present (Subp_Formal) loop
Primitives_Mapping.Set (Par_Formal, Subp_Formal);
Next_Formal (Par_Formal);
Next_Formal (Subp_Formal);
end loop;
Replace_Condition_Entities (Prag);
end Build_Class_Wide_Expression;
--------------------
-- Build_DIC_Call --
--------------------
function Build_DIC_Call
(Loc : Source_Ptr;
Obj_Id : Entity_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
return
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Proc_Id, Loc),
Parameter_Associations => New_List (
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark => New_Occurrence_Of (Formal_Typ, Loc),
Expression => New_Occurrence_Of (Obj_Id, Loc))));
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) is
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;
Par_Typ : Entity_Id;
Deriv_Typ : Entity_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. Par_Typ is the
-- parent type whose DIC pragma is being inherited. Deriv_Typ is the
-- derived type inheriting the DIC pragma. All generated code is added
-- to list Stmts.
procedure Add_Own_DIC
(DIC_Prag : Node_Id;
DIC_Typ : 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. All generated code
-- is added to list Stmts.
procedure Replace_Object_And_Primitive_References
(Expr : Node_Id;
Par_Typ : Entity_Id;
Deriv_Typ : Entity_Id;
Par_Obj : Entity_Id := Empty;
Deriv_Obj : Entity_Id := Empty);
-- Expr denotes an arbitrary expression. Par_Typ is a parent type in a
-- type hierarchy. Deriv_Typ is a type derived from Par_Typ. Par_Obj is
-- the formal parameter which emulates the current instance of Par_Typ.
-- Deriv_Obj is the formal parameter which emulates the current instance
-- of Deriv_Typ. Perform the following substitutions:
--
-- * Replace a reference to Par_Obj with a reference to Deriv_Obj if
-- applicable.
--
-- * 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.
procedure Replace_Type_References
(Expr : Node_Id;
Typ : Entity_Id;
Obj_Id : Entity_Id);
-- Substitute all references of the current instance of type Typ with
-- references to formal parameter Obj_Id within expression Expr.
-------------------
-- 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 runtime. 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;
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;
Par_Typ : Entity_Id;
Deriv_Typ : Entity_Id;
Stmts : in out List_Id)
is
Deriv_Decl : constant Node_Id := Declaration_Node (Deriv_Typ);
Deriv_Proc : constant Entity_Id := DIC_Procedure (Deriv_Typ);
DIC_Args : constant List_Id :=
Pragma_Argument_Associations (DIC_Prag);
DIC_Arg : constant Node_Id := First (DIC_Args);
DIC_Expr : constant Node_Id := Expression_Copy (DIC_Arg);
Par_Proc : constant Entity_Id := DIC_Procedure (Par_Typ);
Expr : Node_Id;
begin
-- The processing of an inherited DIC assertion expression starts off
-- with a copy of the original parent expression where all references
-- to the parent type have already been replaced with references to
-- the _object formal parameter of the parent type's DIC procedure.
pragma Assert (Present (DIC_Expr));
Expr := New_Copy_Tree (DIC_Expr);
-- Perform the following substitutions:
-- * Replace a reference to the _object parameter of the parent
-- type's DIC procedure with a reference to the _object parameter
-- of the derived types' DIC procedure.
-- * 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.
-- Note that primitives defined in the private part are automatically
-- handled by the overriding/inheritance mechanism and do not require
-- an extra replacement pass.
pragma Assert (Present (Deriv_Proc) and then Present (Par_Proc));
Replace_Object_And_Primitive_References
(Expr => Expr,
Par_Typ => Par_Typ,
Deriv_Typ => Deriv_Typ,
Par_Obj => First_Formal (Par_Proc),
Deriv_Obj => First_Formal (Deriv_Proc));
-- Preanalyze the DIC expression to detect errors and at the same
-- time capture the visibility of the proper package part.
Set_Parent (Expr, Deriv_Decl);
Preanalyze_Assert_Expression (Expr, Any_Boolean);
-- 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_Own_DIC --
-----------------
procedure Add_Own_DIC
(DIC_Prag : Node_Id;
DIC_Typ : 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);
DIC_Proc : constant Entity_Id := DIC_Procedure (DIC_Typ);
Obj_Id : constant Entity_Id := First_Formal (DIC_Proc);
procedure Preanalyze_Own_DIC_For_ASIS;
-- Preanalyze the original DIC expression of an aspect or a source
-- pragma for ASIS.
---------------------------------
-- Preanalyze_Own_DIC_For_ASIS --
---------------------------------
procedure Preanalyze_Own_DIC_For_ASIS is
Expr : Node_Id := Empty;
begin
-- The DIC pragma is a source construct, preanalyze the original
-- expression of the pragma.
if Comes_From_Source (DIC_Prag) then
Expr := DIC_Expr;
-- Otherwise preanalyze the expression of the corresponding aspect
elsif Present (DIC_Asp) then
Expr := Expression (DIC_Asp);
end if;
-- The expression must be subjected to the same substitutions as
-- the copy used in the generation of the runtime check.
if Present (Expr) then
Replace_Type_References
(Expr => Expr,
Typ => DIC_Typ,
Obj_Id => Obj_Id);
Preanalyze_Assert_Expression (Expr, Any_Boolean);
end if;
end Preanalyze_Own_DIC_For_ASIS;
-- Local variables
Typ_Decl : constant Node_Id := Declaration_Node (DIC_Typ);
Expr : Node_Id;
-- Start of processing for Add_Own_DIC
begin
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;
-- Preanalyze the original DIC expression for ASIS
if ASIS_Mode then
Preanalyze_Own_DIC_For_ASIS;
end if;
-- 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_Own_DIC;
---------------------------------------------
-- Replace_Object_And_Primitive_References --
---------------------------------------------
procedure Replace_Object_And_Primitive_References
(Expr : Node_Id;
Par_Typ : Entity_Id;
Deriv_Typ : Entity_Id;
Par_Obj : Entity_Id := Empty;
Deriv_Obj : Entity_Id := Empty)
is
function Replace_Ref (Ref : Node_Id) return Traverse_Result;
-- Substitute a reference to an entity with a reference to the
-- corresponding entity stored in in table Primitives_Mapping.
-----------------
-- Replace_Ref --
-----------------
function Replace_Ref (Ref : Node_Id) return Traverse_Result is
Context : constant Node_Id := Parent (Ref);
Loc : constant Source_Ptr := Sloc (Ref);
New_Id : Entity_Id;
New_Ref : Node_Id;
Ref_Id : Entity_Id;
Result : Traverse_Result;
begin
Result := OK;
-- The current node denotes a reference
if Nkind (Ref) in N_Has_Entity and then Present (Entity (Ref)) then
Ref_Id := Entity (Ref);
New_Id := Primitives_Mapping.Get (Ref_Id);
-- The reference mentions a parent type primitive which has a
-- corresponding derived type primitive.
if Present (New_Id) then
New_Ref := New_Occurrence_Of (New_Id, Loc);
-- The reference mentions the _object parameter of the parent
-- type's DIC procedure.
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 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.
if Nkind_In (Context, N_Function_Call,
N_Procedure_Call_Statement)
and then
No (Primitives_Mapping.Get (Entity (Name (Context))))
then
New_Ref := Convert_To (Par_Typ, New_Ref);
-- Do not process the generated type conversion because
-- both the parent type and the derived type are in the
-- Primitives_Mapping table. This will clobber the type
-- conversion by resetting its subtype mark.
Result := Skip;
end if;
-- Otherwise there is nothing to replace
else
New_Ref := Empty;
end if;
if Present (New_Ref) then
Rewrite (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) = Ref
then
Set_Etype (Context, Etype (New_Id));
end if;
end if;
end if;
-- Reanalyze the reference due to potential replacements
if Nkind (Ref) in N_Has_Etype then
Set_Analyzed (Ref, False);
end if;
return Result;
end Replace_Ref;
procedure Replace_Refs is new Traverse_Proc (Replace_Ref);
-- Start of processing for Replace_Object_And_Primitive_References
begin
-- Map each primitive operation of the parent type to the proper
-- primitive of the derived type.
Update_Primitives_Mapping_Of_Types
(Par_Typ => Par_Typ,
Deriv_Typ => Deriv_Typ);
-- Inspect the input expression and perform substitutions where
-- necessary.
Replace_Refs (Expr);
end Replace_Object_And_Primitive_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
Ref : Node_Id;
begin
-- Decorate the reference to Typ even though it may be rewritten
-- further down. This is done for two reasons:
-- 1) ASIS has all necessary semantic information in the
-- original tree.
-- 2) 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
Ref := Make_Identifier (Sloc (N), Chars (Obj_Id));
Set_Entity (Ref, Obj_Id);
Set_Etype (Ref, Typ);
Rewrite (N, Ref);
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;
-- Local variables
Loc : constant Source_Ptr := Sloc (Typ);
DIC_Prag : Node_Id;
DIC_Typ : Entity_Id;
Dummy_1 : Entity_Id;
Dummy_2 : Entity_Id;
Mode : Ghost_Mode_Type;
Proc_Body : Node_Id;
Proc_Body_Id : Entity_Id;
Proc_Decl : Node_Id;
Proc_Id : Entity_Id;
Stmts : List_Id := No_List;
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, Mode);
-- 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;
-- The working type may lack a DIC procedure declaration. This may be
-- due to several reasons:
-- * The working type's own DIC pragma does not contain a verifiable
-- assertion expression. In this case there is no need to build a
-- DIC procedure because there is nothing to check.
-- * The working type derives from a parent type. In this case a DIC
-- procedure should be built only when the inherited DIC pragma has
-- a verifiable assertion expression.
Proc_Id := DIC_Procedure (Work_Typ);
-- Build a DIC procedure declaration when the working type derives from
-- a parent type.
if No (Proc_Id) then
Build_DIC_Procedure_Declaration (Work_Typ);
Proc_Id := DIC_Procedure (Work_Typ);
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);
-- The working type defines its own DIC pragma. Replace the current
-- instance of the working type with the formal of the DIC procedure.
-- Note that there is no need to consider inherited DIC pragmas from
-- parent types because the working type's DIC pragma "hides" all
-- inherited DIC pragmas.
if Has_Own_DIC (Work_Typ) then
pragma Assert (DIC_Typ = Work_Typ);
Add_Own_DIC
(DIC_Prag => DIC_Prag,
DIC_Typ => DIC_Typ,
Stmts => Stmts);
-- Otherwise the working type inherits a DIC pragma from a parent type
else
pragma Assert (Has_Inherited_DIC (Work_Typ));
pragma Assert (DIC_Typ /= Work_Typ);
-- The working type is tagged. The verification of the assertion
-- expression is subject to the same semantics as class-wide pre-
-- and postconditions.
if Is_Tagged_Type (Work_Typ) then
Add_Inherited_Tagged_DIC
(DIC_Prag => DIC_Prag,
Par_Typ => DIC_Typ,
Deriv_Typ => Work_Typ,
Stmts => Stmts);
-- Otherwise the working type is not tagged. Verify the assertion
-- expression of the inherited DIC pragma by directly calling the
-- DIC procedure of the parent type.
else
Add_Inherited_DIC
(DIC_Prag => DIC_Prag,
Par_Typ => DIC_Typ,
Deriv_Typ => Work_Typ,
Stmts => Stmts);
end if;
end if;
End_Scope;
-- Produce an empty completing body in the following cases:
-- * Assertions are disabled
-- * The DIC Assertion_Policy is Ignore
-- * Pragma DIC appears without an argument
-- * Pragma DIC appears with argument "null"
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
Set_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
-- ASIS or 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 ASIS_Mode or 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_Mode (Mode);
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) is
Loc : constant Source_Ptr := Sloc (Typ);
DIC_Prag : Node_Id;
DIC_Typ : Entity_Id;
Mode : Ghost_Mode_Type;
Proc_Decl : Node_Id;
Proc_Id : Entity_Id;
Typ_Decl : Node_Id;
CRec_Typ : Entity_Id;
-- The corresponding record type of Full_Typ
Full_Base : Entity_Id;
-- The base 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
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, Mode);
-- 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;
-- Nothing to do if the type already has a DIC procedure
elsif Present (DIC_Procedure (Work_Typ)) then
goto Leave;
end if;
Proc_Id :=
Make_Defining_Identifier (Loc,
Chars =>
New_External_Name (Chars (Work_Typ), "Default_Initial_Condition"));
-- Perform minor decoration in case the declaration is not analyzed
Set_Ekind (Proc_Id, E_Procedure);
Set_Etype (Proc_Id, Standard_Void_Type);
Set_Scope (Proc_Id, Current_Scope);
Set_Is_DIC_Procedure (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 Opt.Generate_SCO then
Set_Needs_Debug_Info (Proc_Id);
end if;
-- Obtain all views of the input type
Get_Views (Work_Typ, Priv_Typ, Full_Typ, Full_Base, CRec_Typ);
-- Associate the DIC procedure and various relevant 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 (Full_Base, 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
Set_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);
-- 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 ASIS or a generic unit because it is not part of the template.
if ASIS_Mode or 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_Mode (Mode);
end Build_DIC_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
Name_Len := 6;
Name_Buffer (1 .. Name_Len) := "RESULT";
Append_To (Proc_Formals,
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Chars => Name_Find),
Out_Present => True,
Parameter_Type => New_Occurrence_Of (Etype (Subp), Loc)));
-- The new procedure declaration is inserted immediately after the
-- function declaration. The processing in Build_Procedure_Body_Form
-- relies on this order.
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_After_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');
Set_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');
Set_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 bit-misaligns by default, even if there is a pragma Packed 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 (64 bits or less) record or small
-- bit-packed array, then everything is fine, since the back end can
-- handle these cases correctly.
elsif Esize (Comp) <= 64
and then (Is_Record_Type (UT) or else Is_Bit_Packed_Array (UT))
then
return False;
-- 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;
----------------------------------------
-- Containing_Package_With_Ext_Axioms --
----------------------------------------
function Containing_Package_With_Ext_Axioms
(E : Entity_Id) return Entity_Id
is
begin
-- E is the package or generic package which is externally axiomatized
if Ekind_In (E, E_Generic_Package, E_Package)
and then Has_Annotate_Pragma_For_External_Axiomatization (E)
then
return E;
end if;
-- If E's scope is axiomatized, E is axiomatized
if Present (Scope (E)) then
declare
First_Ax_Parent_Scope : constant Entity_Id :=
Containing_Package_With_Ext_Axioms (Scope (E));
begin
if Present (First_Ax_Parent_Scope) then
return First_Ax_Parent_Scope;
end if;
end;
end if;
-- Otherwise, if E is a package instance, it is axiomatized if the
-- corresponding generic package is axiomatized.
if Ekind (E) = E_Package then
declare
Par : constant Node_Id := Parent (E);
Decl : Node_Id;
begin
if Nkind (Par) = N_Defining_Program_Unit_Name then
Decl := Parent (Par);
else
Decl := Par;
end if;
if Present (Generic_Parent (Decl)) then
return
Containing_Package_With_Ext_Axioms (Generic_Parent (Decl));
end if;
end;
end if;
return Empty;
end Containing_Package_With_Ext_Axioms;
-------------------------------
-- Convert_To_Actual_Subtype --
-------------------------------
procedure Convert_To_Actual_Subtype (Exp : Entity_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 Ekind (Typ) in Protected_Kind 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;
--------------------
-- 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;
-----------------
-- Entity_Hash --
-----------------
function Entity_Hash (E : Entity_Id) return Num_Primitives is
begin
return Num_Primitives (E mod Primitives_Mapping_Size);
end Entity_Hash;
--------------------
-- 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
K : constant Node_Kind := Nkind (Nam);
begin
-- 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.
if K = N_Explicit_Dereference then
Force_Evaluation (Prefix (Nam));
-- For a selected component, we simply evaluate the prefix
elsif K = N_Selected_Component then
Evaluate_Name (Prefix (Nam));
-- For an indexed component, or an attribute reference, we evaluate the
-- prefix, which is itself a name, recursively, and then force the
-- evaluation of all the subscripts (or attribute expressions).
elsif Nkind_In (K, N_Indexed_Component, N_Attribute_Reference) then
Evaluate_Name (Prefix (Nam));
declare
E : Node_Id;
begin
E := First (Expressions (Nam));
while Present (E) loop
Force_Evaluation (E);
if Original_Node (E) /= E then
Set_Do_Range_Check (E, Do_Range_Check (Original_Node (E)));
end if;
Next (E);
end loop;
end;
-- 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.
elsif K = N_Slice then
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.
elsif K = N_Type_Conversion then
Evaluate_Name (Expression (Nam));
-- For a function call, we evaluate the call
elsif K = N_Function_Call then
Force_Evaluation (Nam);
-- The remaining cases are direct name, operator symbol and character
-- literal. In all these cases, we do nothing, since we want to
-- reevaluate each time the renamed object is used.
else
return;
end if;
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_Static_Predicates_In_Choices --
-----------------------------------------
procedure Expand_Static_Predicates_In_Choices (N : Node_Id) is
pragma Assert (Nkind_In (N, N_Case_Statement_Alternative, N_Variant));
Choices : constant List_Id := Discrete_Choices (N);
Choice : Node_Id;
Next_C : Node_Id;
P : Node_Id;
C : Node_Id;
begin
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;
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
if GNATprove_Mode 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
-- 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;
else
Remove_Side_Effects (Exp);
Rewrite (Subtype_Indic,
Make_Subtype_From_Expr (Exp, Unc_Type, Related_Id));
end if;
end Expand_Subtype_From_Expr;
----------------------
-- Finalize_Address --
----------------------
function Finalize_Address (Typ : Entity_Id) return Entity_Id is
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 (Typ) then
if Is_Protected_Type (Typ) then
Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
else
Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
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_DIC_Type --
-------------------
function Find_DIC_Type (Typ : Entity_Id) return Entity_Id is
Curr_Typ : Entity_Id;
-- The current type being examined in the parent hierarchy traversal
DIC_Typ : Entity_Id;
-- The type which carries the DIC pragma. This variable denotes the
-- partial view when private types are involved.
Par_Typ : Entity_Id;
-- The parent type of the current type. This variable denotes the full
-- view when private types are involved.
begin
-- The input type defines its own DIC pragma, therefore it is the owner
if Has_Own_DIC (Typ) then
DIC_Typ := Typ;
-- Otherwise the DIC pragma is inherited from a parent type
else
pragma Assert (Has_Inherited_DIC (Typ));
-- Climb the parent chain
Curr_Typ := Typ;
loop
-- Inspect the parent type. Do not consider subtypes as they
-- inherit the DIC attributes from their base types.
DIC_Typ := Base_Type (Etype (Curr_Typ));
-- Look at the full view of a private type because the type may
-- have a hidden parent introduced in the full view.
Par_Typ := DIC_Typ;
if Is_Private_Type (Par_Typ)
and then Present (Full_View (Par_Typ))
then
Par_Typ := Full_View (Par_Typ);
end if;
-- Stop the climb once the nearest parent type which defines a DIC
-- pragma of its own is encountered or when the root of the parent
-- chain is reached.
exit when Has_Own_DIC (DIC_Typ) or else Curr_Typ = Par_Typ;
Curr_Typ := Par_Typ;
end loop;
end if;
return DIC_Typ;
end Find_DIC_Type;
------------------------
-- 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;
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
pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
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
pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
return First_Tag_Component (Typ);
-- Otherwise we need to search for its associated tag component
else
Find_Tag (Typ);
pragma Assert (Found);
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 non-symmetric 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_In (S, 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);