Google Git
Sign in
gnu / gcc / refs/tags/basepoints/gcc-13 / . / gcc / ada / exp_ch7.adb
blob: d7863c30b68f229422ed96579e0f2fbb021c704d [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ C H 7 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2022, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package contains virtually all expansion mechanisms related to
-- - controlled types
-- - transient scopes
with Atree; use Atree;
with Contracts; use Contracts;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch9; use Exp_Ch9;
with Exp_Ch11; use Exp_Ch11;
with Exp_Dbug; use Exp_Dbug;
with Exp_Dist; use Exp_Dist;
with Exp_Disp; use Exp_Disp;
with Exp_Prag; use Exp_Prag;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with GNAT_CUDA; use GNAT_CUDA;
with Lib; use Lib;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Output; use Output;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Snames; use Snames;
with Stand; use Stand;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uintp; use Uintp;
package body Exp_Ch7 is
--------------------------------
-- Transient Scope Management --
--------------------------------
-- A transient scope is created when temporary objects are created by the
-- compiler. These temporary objects are allocated on the secondary stack
-- and the transient scope is responsible for finalizing the object when
-- appropriate and reclaiming the memory at the right time. The temporary
-- objects are generally the objects allocated to store the result of a
-- function returning an unconstrained or a tagged value. Expressions
-- needing to be wrapped in a transient scope (functions calls returning
-- unconstrained or tagged values) may appear in 3 different contexts which
-- lead to 3 different kinds of transient scope expansion:
-- 1. In a simple statement (procedure call, assignment, ...). In this
-- case the instruction is wrapped into a transient block. See
-- Wrap_Transient_Statement for details.
-- 2. In an expression of a control structure (test in a IF statement,
-- expression in a CASE statement, ...). See Wrap_Transient_Expression
-- for details.
-- 3. In a expression of an object_declaration. No wrapping is possible
-- here, so the finalization actions, if any, are done right after the
-- declaration and the secondary stack deallocation is done in the
-- proper enclosing scope. See Wrap_Transient_Declaration for details.
-- Note about functions returning tagged types: it has been decided to
-- always allocate their result in the secondary stack, even though is not
-- absolutely mandatory when the tagged type is constrained because the
-- caller knows the size of the returned object and thus could allocate the
-- result in the primary stack. An exception to this is when the function
-- builds its result in place, as is done for functions with inherently
-- limited result types for Ada 2005. In that case, certain callers may
-- pass the address of a constrained object as the target object for the
-- function result.
-- By allocating tagged results in the secondary stack a number of
-- implementation difficulties are avoided:
-- - If it is a dispatching function call, the computation of the size of
-- the result is possible but complex from the outside.
-- - If the returned type is controlled, the assignment of the returned
-- value to the anonymous object involves an Adjust, and we have no
-- easy way to access the anonymous object created by the back end.
-- - If the returned type is class-wide, this is an unconstrained type
-- anyway.
-- Furthermore, the small loss in efficiency which is the result of this
-- decision is not such a big deal because functions returning tagged types
-- are not as common in practice compared to functions returning access to
-- a tagged type.
--------------------------------------------------
-- Transient Blocks and Finalization Management --
--------------------------------------------------
procedure Insert_Actions_In_Scope_Around
(N : Node_Id;
Clean : Boolean;
Manage_SS : Boolean);
-- Insert the before-actions kept in the scope stack before N, and the
-- after-actions after N, which must be a member of a list. If flag Clean
-- is set, insert any cleanup actions. If flag Manage_SS is set, insert
-- calls to mark and release the secondary stack.
function Make_Transient_Block
(Loc : Source_Ptr;
Action : Node_Id;
Par : Node_Id) return Node_Id;
-- Action is a single statement or object declaration. Par is the proper
-- parent of the generated block. Create a transient block whose name is
-- the current scope and the only handled statement is Action. If Action
-- involves controlled objects or secondary stack usage, the corresponding
-- cleanup actions are performed at the end of the block.
procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id);
-- Shared processing for Store_xxx_Actions_In_Scope
-----------------------------
-- Finalization Management --
-----------------------------
-- This part describe how Initialization/Adjustment/Finalization procedures
-- are generated and called. Two cases must be considered, types that are
-- Controlled (Is_Controlled flag set) and composite types that contain
-- controlled components (Has_Controlled_Component flag set). In the first
-- case the procedures to call are the user-defined primitive operations
-- Initialize/Adjust/Finalize. In the second case, GNAT generates
-- Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge
-- of calling the former procedures on the controlled components.
-- For records with Has_Controlled_Component set, a hidden "controller"
-- component is inserted. This controller component contains its own
-- finalization list on which all controlled components are attached
-- creating an indirection on the upper-level Finalization list. This
-- technique facilitates the management of objects whose number of
-- controlled components changes during execution. This controller
-- component is itself controlled and is attached to the upper-level
-- finalization chain. Its adjust primitive is in charge of calling adjust
-- on the components and adjusting the finalization pointer to match their
-- new location (see a-finali.adb).
-- It is not possible to use a similar technique for arrays that have
-- Has_Controlled_Component set. In this case, deep procedures are
-- generated that call initialize/adjust/finalize + attachment or
-- detachment on the finalization list for all component.
-- Initialize calls: they are generated for declarations or dynamic
-- allocations of Controlled objects with no initial value. They are always
-- followed by an attachment to the current Finalization Chain. For the
-- dynamic allocation case this the chain attached to the scope of the
-- access type definition otherwise, this is the chain of the current
-- scope.
-- Adjust Calls: They are generated on 2 occasions: (1) for declarations
-- or dynamic allocations of Controlled objects with an initial value.
-- (2) after an assignment. In the first case they are followed by an
-- attachment to the final chain, in the second case they are not.
-- Finalization Calls: They are generated on (1) scope exit, (2)
-- assignments, (3) unchecked deallocations. In case (3) they have to
-- be detached from the final chain, in case (2) they must not and in
-- case (1) this is not important since we are exiting the scope anyway.
-- Other details:
-- Type extensions will have a new record controller at each derivation
-- level containing controlled components. The record controller for
-- the parent/ancestor is attached to the finalization list of the
-- extension's record controller (i.e. the parent is like a component
-- of the extension).
-- For types that are both Is_Controlled and Has_Controlled_Components,
-- the record controller and the object itself are handled separately.
-- It could seem simpler to attach the object at the end of its record
-- controller but this would not tackle view conversions properly.
-- A classwide type can always potentially have controlled components
-- but the record controller of the corresponding actual type may not
-- be known at compile time so the dispatch table contains a special
-- field that allows computation of the offset of the record controller
-- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
-- Here is a simple example of the expansion of a controlled block :
-- declare
-- X : Controlled;
-- Y : Controlled := Init;
--
-- type R is record
-- C : Controlled;
-- end record;
-- W : R;
-- Z : R := (C => X);
-- begin
-- X := Y;
-- W := Z;
-- end;
--
-- is expanded into
--
-- declare
-- _L : System.FI.Finalizable_Ptr;
-- procedure _Clean is
-- begin
-- Abort_Defer;
-- System.FI.Finalize_List (_L);
-- Abort_Undefer;
-- end _Clean;
-- X : Controlled;
-- begin
-- Abort_Defer;
-- Initialize (X);
-- Attach_To_Final_List (_L, Finalizable (X), 1);
-- at end: Abort_Undefer;
-- Y : Controlled := Init;
-- Adjust (Y);
-- Attach_To_Final_List (_L, Finalizable (Y), 1);
--
-- type R is record
-- C : Controlled;
-- end record;
-- W : R;
-- begin
-- Abort_Defer;
-- Deep_Initialize (W, _L, 1);
-- at end: Abort_Under;
-- Z : R := (C => X);
-- Deep_Adjust (Z, _L, 1);
-- begin
-- _Assign (X, Y);
-- Deep_Finalize (W, False);
-- <save W's final pointers>
-- W := Z;
-- <restore W's final pointers>
-- Deep_Adjust (W, _L, 0);
-- at end
-- _Clean;
-- end;
type Final_Primitives is
(Initialize_Case, Adjust_Case, Finalize_Case, Address_Case);
-- This enumeration type is defined in order to ease sharing code for
-- building finalization procedures for composite types.
Name_Of : constant array (Final_Primitives) of Name_Id :=
(Initialize_Case => Name_Initialize,
Adjust_Case => Name_Adjust,
Finalize_Case => Name_Finalize,
Address_Case => Name_Finalize_Address);
Deep_Name_Of : constant array (Final_Primitives) of TSS_Name_Type :=
(Initialize_Case => TSS_Deep_Initialize,
Adjust_Case => TSS_Deep_Adjust,
Finalize_Case => TSS_Deep_Finalize,
Address_Case => TSS_Finalize_Address);
function Allows_Finalization_Master (Typ : Entity_Id) return Boolean;
-- Determine whether access type Typ may have a finalization master
procedure Build_Array_Deep_Procs (Typ : Entity_Id);
-- Build the deep Initialize/Adjust/Finalize for a record Typ with
-- Has_Controlled_Component set and store them using the TSS mechanism.
function Build_Cleanup_Statements
(N : Node_Id;
Additional_Cleanup : List_Id) return List_Id;
-- Create the cleanup calls for an asynchronous call block, task master,
-- protected subprogram body, task allocation block or task body, or
-- additional cleanup actions parked on a transient block. If the context
-- does not contain the above constructs, the routine returns an empty
-- list.
procedure Build_Finalizer
(N : Node_Id;
Clean_Stmts : List_Id;
Mark_Id : Entity_Id;
Top_Decls : List_Id;
Defer_Abort : Boolean;
Fin_Id : out Entity_Id);
-- N may denote an accept statement, block, entry body, package body,
-- package spec, protected body, subprogram body, or a task body. Create
-- a procedure which contains finalization calls for all controlled objects
-- declared in the declarative or statement region of N. The calls are
-- built in reverse order relative to the original declarations. In the
-- case of a task body, the routine delays the creation of the finalizer
-- until all statements have been moved to the task body procedure.
-- Clean_Stmts may contain additional context-dependent code used to abort
-- asynchronous calls or complete tasks (see Build_Cleanup_Statements).
-- Mark_Id is the secondary stack used in the current context or Empty if
-- missing. Top_Decls is the list on which the declaration of the finalizer
-- is attached in the non-package case. Defer_Abort indicates that the
-- statements passed in perform actions that require abort to be deferred,
-- such as for task termination. Fin_Id is the finalizer declaration
-- entity.
procedure Build_Finalizer_Helper
(N : Node_Id;
Clean_Stmts : List_Id;
Mark_Id : Entity_Id;
Top_Decls : List_Id;
Defer_Abort : Boolean;
Fin_Id : out Entity_Id;
Finalize_Old_Only : Boolean);
-- An internal routine which does all of the heavy lifting on behalf of
-- Build_Finalizer.
procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id);
-- N is a construct which contains a handled sequence of statements, Fin_Id
-- is the entity of a finalizer. Create an At_End handler which covers the
-- statements of N and calls Fin_Id. If the handled statement sequence has
-- an exception handler, the statements will be wrapped in a block to avoid
-- unwanted interaction with the new At_End handler.
procedure Build_Record_Deep_Procs (Typ : Entity_Id);
-- Build the deep Initialize/Adjust/Finalize for a record Typ with
-- Has_Component_Component set and store them using the TSS mechanism.
-------------------------------------------
-- Unnesting procedures for CCG and LLVM --
-------------------------------------------
-- Expansion generates subprograms for controlled types management that
-- may appear in declarative lists in package declarations and bodies.
-- These subprograms appear within generated blocks that contain local
-- declarations and a call to finalization procedures. To ensure that
-- such subprograms get activation records when needed, we transform the
-- block into a procedure body, followed by a call to it in the same
-- declarative list.
procedure Check_Unnesting_Elaboration_Code (N : Node_Id);
-- The statement part of a package body that is a compilation unit may
-- contain blocks that declare local subprograms. In Subprogram_Unnesting_
-- Mode such subprograms must be handled as nested inside the (implicit)
-- elaboration procedure that executes that statement part. To handle
-- properly uplevel references we construct that subprogram explicitly,
-- to contain blocks and inner subprograms, the statement part becomes
-- a call to this subprogram. This is only done if blocks are present
-- in the statement list of the body. (It would be nice to unify this
-- procedure with Check_Unnesting_In_Decls_Or_Stmts, if possible, since
-- they're doing very similar work, but are structured differently. ???)
procedure Check_Unnesting_In_Decls_Or_Stmts (Decls_Or_Stmts : List_Id);
-- Similarly, the declarations or statements in library-level packages may
-- have created blocks with nested subprograms. Such a block must be
-- transformed into a procedure followed by a call to it, so that unnesting
-- can handle uplevel references within these nested subprograms (typically
-- subprograms that handle finalization actions). This also applies to
-- nested packages, including instantiations, in which case it must
-- recursively process inner bodies.
procedure Check_Unnesting_In_Handlers (N : Node_Id);
-- Similarly, check for blocks with nested subprograms occurring within
-- a set of exception handlers associated with a package body N.
procedure Unnest_Block (Decl : Node_Id);
-- Blocks that contain nested subprograms with up-level references need to
-- create activation records for them. We do this by rewriting the block as
-- a procedure, followed by a call to it in the same declarative list, to
-- replicate the semantics of the original block.
--
-- A common source for such block is a transient block created for a
-- construct (declaration, assignment, etc.) that involves controlled
-- actions or secondary-stack management, in which case the nested
-- subprogram is a finalizer.
procedure Unnest_If_Statement (If_Stmt : Node_Id);
-- The separate statement lists associated with an if-statement (then part,
-- elsif parts, else part) may require unnesting if they directly contain
-- a subprogram body that references up-level objects. Each statement list
-- is traversed to locate such subprogram bodies, and if a part's statement
-- list contains a body, then the list is replaced with a new procedure
-- containing the part's statements followed by a call to the procedure.
-- Furthermore, any nested blocks, loops, or if statements will also be
-- traversed to determine the need for further unnesting transformations.
procedure Unnest_Statement_List (Stmts : in out List_Id);
-- A list of statements that directly contains a subprogram at its outer
-- level, that may reference objects declared in that same statement list,
-- is rewritten as a procedure containing the statement list Stmts (which
-- includes any such objects as well as the nested subprogram), followed by
-- a call to the new procedure, and Stmts becomes the list containing the
-- procedure and the call. This ensures that Unnest_Subprogram will later
-- properly handle up-level references from the nested subprogram to
-- objects declared earlier in statement list, by creating an activation
-- record and passing it to the nested subprogram. This procedure also
-- resets the Scope of objects declared in the statement list, as well as
-- the Scope of the nested subprogram, to refer to the new procedure.
-- Also, the new procedure is marked Has_Nested_Subprogram, so this should
-- only be called when known that the statement list contains a subprogram.
procedure Unnest_Loop (Loop_Stmt : Node_Id);
-- Top-level Loops that contain nested subprograms with up-level references
-- need to have activation records. We do this by rewriting the loop as a
-- procedure containing the loop, followed by a call to the procedure in
-- the same library-level declarative list, to replicate the semantics of
-- the original loop. Such loops can occur due to aggregate expansions and
-- other constructs.
procedure Check_Visibly_Controlled
(Prim : Final_Primitives;
Typ : Entity_Id;
E : in out Entity_Id;
Cref : in out Node_Id);
-- The controlled operation declared for a derived type may not be
-- overriding, if the controlled operations of the parent type are hidden,
-- for example when the parent is a private type whose full view is
-- controlled. For other primitive operations we modify the name of the
-- operation to indicate that it is not overriding, but this is not
-- possible for Initialize, etc. because they have to be retrievable by
-- name. Before generating the proper call to one of these operations we
-- check whether Typ is known to be controlled at the point of definition.
-- If it is not then we must retrieve the hidden operation of the parent
-- and use it instead. This is one case that might be solved more cleanly
-- once Overriding pragmas or declarations are in place.
function Contains_Subprogram (Blk : Entity_Id) return Boolean;
-- Check recursively whether a loop or block contains a subprogram that
-- may need an activation record.
function Convert_View
(Proc : Entity_Id;
Arg : Node_Id;
Ind : Pos := 1) return Node_Id;
-- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
-- argument being passed to it. Ind indicates which formal of procedure
-- Proc we are trying to match. This function will, if necessary, generate
-- a conversion between the partial and full view of Arg to match the type
-- of the formal of Proc, or force a conversion to the class-wide type in
-- the case where the operation is abstract.
function Enclosing_Function (E : Entity_Id) return Entity_Id;
-- Given an arbitrary entity, traverse the scope chain looking for the
-- first enclosing function. Return Empty if no function was found.
function Make_Call
(Loc : Source_Ptr;
Proc_Id : Entity_Id;
Param : Node_Id;
Skip_Self : Boolean := False) return Node_Id;
-- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
-- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create
-- an adjust or finalization call. When flag Skip_Self is set, the related
-- action has an effect on the components only (if any).
function Make_Deep_Proc
(Prim : Final_Primitives;
Typ : Entity_Id;
Stmts : List_Id) return Entity_Id;
-- This function generates the tree for Deep_Initialize, Deep_Adjust or
-- Deep_Finalize procedures according to the first parameter. These
-- procedures operate on the type Typ. The Stmts parameter gives the
-- body of the procedure.
function Make_Deep_Array_Body
(Prim : Final_Primitives;
Typ : Entity_Id) return List_Id;
-- This function generates the list of statements for implementing
-- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
-- the first parameter, these procedures operate on the array type Typ.
function Make_Deep_Record_Body
(Prim : Final_Primitives;
Typ : Entity_Id;
Is_Local : Boolean := False) return List_Id;
-- This function generates the list of statements for implementing
-- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
-- the first parameter, these procedures operate on the record type Typ.
-- Flag Is_Local is used in conjunction with Deep_Finalize to designate
-- whether the inner logic should be dictated by state counters.
function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id;
-- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
-- Make_Deep_Record_Body. Generate the following statements:
--
-- declare
-- type Acc_Typ is access all Typ;
-- for Acc_Typ'Storage_Size use 0;
-- begin
-- [Deep_]Finalize (Acc_Typ (V).all);
-- end;
--------------------------------
-- Allows_Finalization_Master --
--------------------------------
function Allows_Finalization_Master (Typ : Entity_Id) return Boolean is
function In_Deallocation_Instance (E : Entity_Id) return Boolean;
-- Determine whether entity E is inside a wrapper package created for
-- an instance of Ada.Unchecked_Deallocation.
------------------------------
-- In_Deallocation_Instance --
------------------------------
function In_Deallocation_Instance (E : Entity_Id) return Boolean is
Pkg : constant Entity_Id := Scope (E);
Par : Node_Id := Empty;
begin
if Ekind (Pkg) = E_Package
and then Present (Related_Instance (Pkg))
and then Ekind (Related_Instance (Pkg)) = E_Procedure
then
Par := Generic_Parent (Parent (Related_Instance (Pkg)));
return
Present (Par)
and then Chars (Par) = Name_Unchecked_Deallocation
and then Chars (Scope (Par)) = Name_Ada
and then Scope (Scope (Par)) = Standard_Standard;
end if;
return False;
end In_Deallocation_Instance;
-- Local variables
Desig_Typ : constant Entity_Id := Designated_Type (Typ);
Ptr_Typ : constant Entity_Id :=
Root_Type_Of_Full_View (Base_Type (Typ));
-- Start of processing for Allows_Finalization_Master
begin
-- Certain run-time configurations and targets do not provide support
-- for controlled types and therefore do not need masters.
if Restriction_Active (No_Finalization) then
return False;
-- Do not consider C and C++ types since it is assumed that the non-Ada
-- side will handle their cleanup.
elsif Convention (Desig_Typ) = Convention_C
or else Convention (Desig_Typ) = Convention_CPP
then
return False;
-- Do not consider an access type that returns on the secondary stack
elsif Present (Associated_Storage_Pool (Ptr_Typ))
and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool)
then
return False;
-- Do not consider an access type that can never allocate an object
elsif No_Pool_Assigned (Ptr_Typ) then
return False;
-- Do not consider an access type coming from an Unchecked_Deallocation
-- instance. Even though the designated type may be controlled, the
-- access type will never participate in any allocations.
elsif In_Deallocation_Instance (Ptr_Typ) then
return False;
-- Do not consider a non-library access type when No_Nested_Finalization
-- is in effect since finalization masters are controlled objects and if
-- created will violate the restriction.
elsif Restriction_Active (No_Nested_Finalization)
and then not Is_Library_Level_Entity (Ptr_Typ)
then
return False;
-- Do not consider an access type subject to pragma No_Heap_Finalization
-- because objects allocated through such a type are not to be finalized
-- when the access type goes out of scope.
elsif No_Heap_Finalization (Ptr_Typ) then
return False;
-- Do not create finalization masters in GNATprove mode because this
-- causes unwanted extra expansion. A compilation in this mode must
-- keep the tree as close as possible to the original sources.
elsif GNATprove_Mode then
return False;
-- Otherwise the access type may use a finalization master
else
return True;
end if;
end Allows_Finalization_Master;
----------------------------
-- Build_Anonymous_Master --
----------------------------
procedure Build_Anonymous_Master (Ptr_Typ : Entity_Id) is
function Create_Anonymous_Master
(Desig_Typ : Entity_Id;
Unit_Id : Entity_Id;
Unit_Decl : Node_Id) return Entity_Id;
-- Create a new anonymous master for access type Ptr_Typ with designated
-- type Desig_Typ. The declaration of the master and its initialization
-- are inserted in the declarative part of unit Unit_Decl. Unit_Id is
-- the entity of Unit_Decl.
function Current_Anonymous_Master
(Desig_Typ : Entity_Id;
Unit_Id : Entity_Id) return Entity_Id;
-- Find an anonymous master declared within unit Unit_Id which services
-- designated type Desig_Typ. If there is no such master, return Empty.
-----------------------------
-- Create_Anonymous_Master --
-----------------------------
function Create_Anonymous_Master
(Desig_Typ : Entity_Id;
Unit_Id : Entity_Id;
Unit_Decl : Node_Id) return Entity_Id
is
Loc : constant Source_Ptr := Sloc (Unit_Id);
All_FMs : Elist_Id;
Decls : List_Id;
FM_Decl : Node_Id;
FM_Id : Entity_Id;
FM_Init : Node_Id;
Unit_Spec : Node_Id;
begin
-- Generate:
-- <FM_Id> : Finalization_Master;
FM_Id := Make_Temporary (Loc, 'A');
FM_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => FM_Id,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Finalization_Master), Loc));
-- Generate:
-- Set_Base_Pool
-- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
FM_Init :=
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (FM_Id, Loc),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc),
Attribute_Name => Name_Unrestricted_Access)));
-- Find the declarative list of the unit
if Nkind (Unit_Decl) = N_Package_Declaration then
Unit_Spec := Specification (Unit_Decl);
Decls := Visible_Declarations (Unit_Spec);
if No (Decls) then
Decls := New_List;
Set_Visible_Declarations (Unit_Spec, Decls);
end if;
-- Package body or subprogram case
-- ??? A subprogram spec or body that acts as a compilation unit may
-- contain a formal parameter of an anonymous access-to-controlled
-- type initialized by an allocator.
-- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
-- There is no suitable place to create the master as the subprogram
-- is not in a declarative list.
else
Decls := Declarations (Unit_Decl);
if No (Decls) then
Decls := New_List;
Set_Declarations (Unit_Decl, Decls);
end if;
end if;
Prepend_To (Decls, FM_Init);
Prepend_To (Decls, FM_Decl);
-- Use the scope of the unit when analyzing the declaration of the
-- master and its initialization actions.
Push_Scope (Unit_Id);
Analyze (FM_Decl);
Analyze (FM_Init);
Pop_Scope;
-- Mark the master as servicing this specific designated type
Set_Anonymous_Designated_Type (FM_Id, Desig_Typ);
-- Include the anonymous master in the list of existing masters which
-- appear in this unit. This effectively creates a mapping between a
-- master and a designated type which in turn allows for the reuse of
-- masters on a per-unit basis.
All_FMs := Anonymous_Masters (Unit_Id);
if No (All_FMs) then
All_FMs := New_Elmt_List;
Set_Anonymous_Masters (Unit_Id, All_FMs);
end if;
Prepend_Elmt (FM_Id, All_FMs);
return FM_Id;
end Create_Anonymous_Master;
------------------------------
-- Current_Anonymous_Master --
------------------------------
function Current_Anonymous_Master
(Desig_Typ : Entity_Id;
Unit_Id : Entity_Id) return Entity_Id
is
All_FMs : constant Elist_Id := Anonymous_Masters (Unit_Id);
FM_Elmt : Elmt_Id;
FM_Id : Entity_Id;
begin
-- Inspect the list of anonymous masters declared within the unit
-- looking for an existing master which services the same designated
-- type.
if Present (All_FMs) then
FM_Elmt := First_Elmt (All_FMs);
while Present (FM_Elmt) loop
FM_Id := Node (FM_Elmt);
-- The currect master services the same designated type. As a
-- result the master can be reused and associated with another
-- anonymous access-to-controlled type.
if Anonymous_Designated_Type (FM_Id) = Desig_Typ then
return FM_Id;
end if;
Next_Elmt (FM_Elmt);
end loop;
end if;
return Empty;
end Current_Anonymous_Master;
-- Local variables
Desig_Typ : Entity_Id;
FM_Id : Entity_Id;
Priv_View : Entity_Id;
Unit_Decl : Node_Id;
Unit_Id : Entity_Id;
-- Start of processing for Build_Anonymous_Master
begin
-- Nothing to do if the circumstances do not allow for a finalization
-- master.
if not Allows_Finalization_Master (Ptr_Typ) then
return;
end if;
Unit_Decl := Unit (Cunit (Current_Sem_Unit));
Unit_Id := Unique_Defining_Entity (Unit_Decl);
-- The compilation unit is a package instantiation. In this case the
-- anonymous master is associated with the package spec as both the
-- spec and body appear at the same level.
if Nkind (Unit_Decl) = N_Package_Body
and then Nkind (Original_Node (Unit_Decl)) = N_Package_Instantiation
then
Unit_Id := Corresponding_Spec (Unit_Decl);
Unit_Decl := Unit_Declaration_Node (Unit_Id);
end if;
-- Use the initial declaration of the designated type when it denotes
-- the full view of an incomplete or private type. This ensures that
-- types with one and two views are treated the same.
Desig_Typ := Directly_Designated_Type (Ptr_Typ);
Priv_View := Incomplete_Or_Partial_View (Desig_Typ);
if Present (Priv_View) then
Desig_Typ := Priv_View;
end if;
-- Determine whether the current semantic unit already has an anonymous
-- master which services the designated type.
FM_Id := Current_Anonymous_Master (Desig_Typ, Unit_Id);
-- If this is not the case, create a new master
if No (FM_Id) then
FM_Id := Create_Anonymous_Master (Desig_Typ, Unit_Id, Unit_Decl);
end if;
Set_Finalization_Master (Ptr_Typ, FM_Id);
end Build_Anonymous_Master;
----------------------------
-- Build_Array_Deep_Procs --
----------------------------
procedure Build_Array_Deep_Procs (Typ : Entity_Id) is
begin
Set_TSS (Typ,
Make_Deep_Proc
(Prim => Initialize_Case,
Typ => Typ,
Stmts => Make_Deep_Array_Body (Initialize_Case, Typ)));
if not Is_Limited_View (Typ) then
Set_TSS (Typ,
Make_Deep_Proc
(Prim => Adjust_Case,
Typ => Typ,
Stmts => Make_Deep_Array_Body (Adjust_Case, Typ)));
end if;
-- Do not generate Deep_Finalize and Finalize_Address if finalization is
-- suppressed since these routine will not be used.
if not Restriction_Active (No_Finalization) then
Set_TSS (Typ,
Make_Deep_Proc
(Prim => Finalize_Case,
Typ => Typ,
Stmts => Make_Deep_Array_Body (Finalize_Case, Typ)));
-- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
if not CodePeer_Mode then
Set_TSS (Typ,
Make_Deep_Proc
(Prim => Address_Case,
Typ => Typ,
Stmts => Make_Deep_Array_Body (Address_Case, Typ)));
end if;
end if;
end Build_Array_Deep_Procs;
------------------------------
-- Build_Cleanup_Statements --
------------------------------
function Build_Cleanup_Statements
(N : Node_Id;
Additional_Cleanup : List_Id) return List_Id
is
Is_Asynchronous_Call : constant Boolean :=
Nkind (N) = N_Block_Statement
and then Is_Asynchronous_Call_Block (N);
Is_Master : constant Boolean :=
Nkind (N) /= N_Entry_Body
and then Is_Task_Master (N);
Is_Protected_Body : constant Boolean :=
Nkind (N) = N_Subprogram_Body
and then Is_Protected_Subprogram_Body (N);
Is_Task_Allocation : constant Boolean :=
Nkind (N) = N_Block_Statement
and then Is_Task_Allocation_Block (N);
Is_Task_Body : constant Boolean :=
Nkind (Original_Node (N)) = N_Task_Body;
Loc : constant Source_Ptr := Sloc (N);
Stmts : constant List_Id := New_List;
begin
if Is_Task_Body then
if Restricted_Profile then
Append_To (Stmts,
Build_Runtime_Call (Loc, RE_Complete_Restricted_Task));
else
Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Task));
end if;
elsif Is_Master then
if Restriction_Active (No_Task_Hierarchy) = False then
Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Master));
end if;
-- Add statements to unlock the protected object parameter and to
-- undefer abort. If the context is a protected procedure and the object
-- has entries, call the entry service routine.
-- NOTE: The generated code references _object, a parameter to the
-- procedure.
elsif Is_Protected_Body then
declare
Spec : constant Node_Id := Parent (Corresponding_Spec (N));
Conc_Typ : Entity_Id := Empty;
Param : Node_Id;
Param_Typ : Entity_Id;
begin
-- Find the _object parameter representing the protected object
Param := First (Parameter_Specifications (Spec));
loop
Param_Typ := Etype (Parameter_Type (Param));
if Ekind (Param_Typ) = E_Record_Type then
Conc_Typ := Corresponding_Concurrent_Type (Param_Typ);
end if;
exit when No (Param) or else Present (Conc_Typ);
Next (Param);
end loop;
pragma Assert (Present (Param));
pragma Assert (Present (Conc_Typ));
-- Historical note: In earlier versions of GNAT, there was code
-- at this point to generate stuff to service entry queues. It is
-- now abstracted in Build_Protected_Subprogram_Call_Cleanup.
Build_Protected_Subprogram_Call_Cleanup
(Specification (N), Conc_Typ, Loc, Stmts);
end;
-- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
-- tasks. Other unactivated tasks are completed by Complete_Task or
-- Complete_Master.
-- NOTE: The generated code references _chain, a local object
elsif Is_Task_Allocation then
-- Generate:
-- Expunge_Unactivated_Tasks (_chain);
-- where _chain is the list of tasks created by the allocator but not
-- yet activated. This list will be empty unless the block completes
-- abnormally.
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of
(RTE (RE_Expunge_Unactivated_Tasks), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Activation_Chain_Entity (N), Loc))));
-- Attempt to cancel an asynchronous entry call whenever the block which
-- contains the abortable part is exited.
-- NOTE: The generated code references Cnn, a local object
elsif Is_Asynchronous_Call then
declare
Cancel_Param : constant Entity_Id :=
Entry_Cancel_Parameter (Entity (Identifier (N)));
begin
-- If it is of type Communication_Block, this must be a protected
-- entry call. Generate:
-- if Enqueued (Cancel_Param) then
-- Cancel_Protected_Entry_Call (Cancel_Param);
-- end if;
if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then
Append_To (Stmts,
Make_If_Statement (Loc,
Condition =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Enqueued), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Cancel_Param, Loc))),
Then_Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of
(RTE (RE_Cancel_Protected_Entry_Call), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Cancel_Param, Loc))))));
-- Asynchronous delay, generate:
-- Cancel_Async_Delay (Cancel_Param);
elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Cancel_Async_Delay), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Cancel_Param, Loc),
Attribute_Name => Name_Unchecked_Access))));
-- Task entry call, generate:
-- Cancel_Task_Entry_Call (Cancel_Param);
else
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Cancel_Task_Entry_Call), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Cancel_Param, Loc))));
end if;
end;
end if;
Append_List_To (Stmts, Additional_Cleanup);
return Stmts;
end Build_Cleanup_Statements;
-----------------------------
-- Build_Controlling_Procs --
-----------------------------
procedure Build_Controlling_Procs (Typ : Entity_Id) is
begin
if Is_Array_Type (Typ) then
Build_Array_Deep_Procs (Typ);
else pragma Assert (Is_Record_Type (Typ));
Build_Record_Deep_Procs (Typ);
end if;
end Build_Controlling_Procs;
-----------------------------
-- Build_Exception_Handler --
-----------------------------
function Build_Exception_Handler
(Data : Finalization_Exception_Data;
For_Library : Boolean := False) return Node_Id
is
Actuals : List_Id;
Proc_To_Call : Entity_Id;
Except : Node_Id;
Stmts : List_Id;
begin
pragma Assert (Present (Data.Raised_Id));
if Exception_Extra_Info
or else (For_Library and not Restricted_Profile)
then
if Exception_Extra_Info then
-- Generate:
-- Get_Current_Excep.all
Except :=
Make_Function_Call (Data.Loc,
Name =>
Make_Explicit_Dereference (Data.Loc,
Prefix =>
New_Occurrence_Of
(RTE (RE_Get_Current_Excep), Data.Loc)));
else
-- Generate:
-- null
Except := Make_Null (Data.Loc);
end if;
if For_Library and then not Restricted_Profile then
Proc_To_Call := RTE (RE_Save_Library_Occurrence);
Actuals := New_List (Except);
else
Proc_To_Call := RTE (RE_Save_Occurrence);
-- The dereference occurs only when Exception_Extra_Info is true,
-- and therefore Except is not null.
Actuals :=
New_List (
New_Occurrence_Of (Data.E_Id, Data.Loc),
Make_Explicit_Dereference (Data.Loc, Except));
end if;
-- Generate:
-- when others =>
-- if not Raised_Id then
-- Raised_Id := True;
-- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
-- or
-- Save_Library_Occurrence (Get_Current_Excep.all);
-- end if;
Stmts :=
New_List (
Make_If_Statement (Data.Loc,
Condition =>
Make_Op_Not (Data.Loc,
Right_Opnd => New_Occurrence_Of (Data.Raised_Id, Data.Loc)),
Then_Statements => New_List (
Make_Assignment_Statement (Data.Loc,
Name => New_Occurrence_Of (Data.Raised_Id, Data.Loc),
Expression => New_Occurrence_Of (Standard_True, Data.Loc)),
Make_Procedure_Call_Statement (Data.Loc,
Name =>
New_Occurrence_Of (Proc_To_Call, Data.Loc),
Parameter_Associations => Actuals))));
else
-- Generate:
-- Raised_Id := True;
Stmts := New_List (
Make_Assignment_Statement (Data.Loc,
Name => New_Occurrence_Of (Data.Raised_Id, Data.Loc),
Expression => New_Occurrence_Of (Standard_True, Data.Loc)));
end if;
-- Generate:
-- when others =>
return
Make_Exception_Handler (Data.Loc,
Exception_Choices => New_List (Make_Others_Choice (Data.Loc)),
Statements => Stmts);
end Build_Exception_Handler;
-------------------------------
-- Build_Finalization_Master --
-------------------------------
procedure Build_Finalization_Master
(Typ : Entity_Id;
For_Lib_Level : Boolean := False;
For_Private : Boolean := False;
Context_Scope : Entity_Id := Empty;
Insertion_Node : Node_Id := Empty)
is
procedure Add_Pending_Access_Type
(Typ : Entity_Id;
Ptr_Typ : Entity_Id);
-- Add access type Ptr_Typ to the pending access type list for type Typ
-----------------------------
-- Add_Pending_Access_Type --
-----------------------------
procedure Add_Pending_Access_Type
(Typ : Entity_Id;
Ptr_Typ : Entity_Id)
is
List : Elist_Id;
begin
if Present (Pending_Access_Types (Typ)) then
List := Pending_Access_Types (Typ);
else
List := New_Elmt_List;
Set_Pending_Access_Types (Typ, List);
end if;
Prepend_Elmt (Ptr_Typ, List);
end Add_Pending_Access_Type;
-- Local variables
Desig_Typ : constant Entity_Id := Designated_Type (Typ);
Ptr_Typ : constant Entity_Id := Root_Type_Of_Full_View (Base_Type (Typ));
-- A finalization master created for a named access type is associated
-- with the full view (if applicable) as a consequence of freezing. The
-- full view criteria does not apply to anonymous access types because
-- those cannot have a private and a full view.
-- Start of processing for Build_Finalization_Master
begin
-- Nothing to do if the circumstances do not allow for a finalization
-- master.
if not Allows_Finalization_Master (Typ) then
return;
-- Various machinery such as freezing may have already created a
-- finalization master.
elsif Present (Finalization_Master (Ptr_Typ)) then
return;
end if;
declare
Actions : constant List_Id := New_List;
Loc : constant Source_Ptr := Sloc (Ptr_Typ);
Fin_Mas_Id : Entity_Id;
Pool_Id : Entity_Id;
begin
-- Source access types use fixed master names since the master is
-- inserted in the same source unit only once. The only exception to
-- this are instances using the same access type as generic actual.
if Comes_From_Source (Ptr_Typ) and then not Inside_A_Generic then
Fin_Mas_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Ptr_Typ), "FM"));
-- Internally generated access types use temporaries as their names
-- due to possible collision with identical names coming from other
-- packages.
else
Fin_Mas_Id := Make_Temporary (Loc, 'F');
end if;
Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
-- Generate:
-- <Ptr_Typ>FM : aliased Finalization_Master;
Append_To (Actions,
Make_Object_Declaration (Loc,
Defining_Identifier => Fin_Mas_Id,
Aliased_Present => True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Finalization_Master), Loc)));
if Debug_Generated_Code then
Set_Debug_Info_Needed (Fin_Mas_Id);
end if;
-- Set the associated pool and primitive Finalize_Address of the new
-- finalization master.
-- The access type has a user-defined storage pool, use it
if Present (Associated_Storage_Pool (Ptr_Typ)) then
Pool_Id := Associated_Storage_Pool (Ptr_Typ);
-- Otherwise the default choice is the global storage pool
else
Pool_Id := RTE (RE_Global_Pool_Object);
Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
end if;
-- Generate:
-- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access);
Append_To (Actions,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Fin_Mas_Id, Loc),
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Pool_Id, Loc),
Attribute_Name => Name_Unrestricted_Access))));
-- Finalize_Address is not generated in CodePeer mode because the
-- body contains address arithmetic. Skip this step.
if CodePeer_Mode then
null;
-- Associate the Finalize_Address primitive of the designated type
-- with the finalization master of the access type. The designated
-- type must be forzen as Finalize_Address is generated when the
-- freeze node is expanded.
elsif Is_Frozen (Desig_Typ)
and then Present (Finalize_Address (Desig_Typ))
-- The finalization master of an anonymous access type may need
-- to be inserted in a specific place in the tree. For instance:
-- type Comp_Typ;
-- <finalization master of "access Comp_Typ">
-- type Rec_Typ is record
-- Comp : access Comp_Typ;
-- end record;
-- <freeze node for Comp_Typ>
-- <freeze node for Rec_Typ>
-- Due to this oddity, the anonymous access type is stored for
-- later processing (see below).
and then Ekind (Ptr_Typ) /= E_Anonymous_Access_Type
then
-- Generate:
-- Set_Finalize_Address
-- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
Append_To (Actions,
Make_Set_Finalize_Address_Call
(Loc => Loc,
Ptr_Typ => Ptr_Typ));
-- Otherwise the designated type is either anonymous access or a
-- Taft-amendment type and has not been frozen. Store the access
-- type for later processing (see Freeze_Type).
else
Add_Pending_Access_Type (Desig_Typ, Ptr_Typ);
end if;
-- A finalization master created for an access designating a type
-- with private components is inserted before a context-dependent
-- node.
if For_Private then
-- At this point both the scope of the context and the insertion
-- mode must be known.
pragma Assert (Present (Context_Scope));
pragma Assert (Present (Insertion_Node));
Push_Scope (Context_Scope);
-- Treat use clauses as declarations and insert directly in front
-- of them.
if Nkind (Insertion_Node) in
N_Use_Package_Clause | N_Use_Type_Clause
then
Insert_List_Before_And_Analyze (Insertion_Node, Actions);
else
Insert_Actions (Insertion_Node, Actions);
end if;
Pop_Scope;
-- The finalization master belongs to an access result type related
-- to a build-in-place function call used to initialize a library
-- level object. The master must be inserted in front of the access
-- result type declaration denoted by Insertion_Node.
elsif For_Lib_Level then
pragma Assert (Present (Insertion_Node));
Insert_Actions (Insertion_Node, Actions);
-- Otherwise the finalization master and its initialization become a
-- part of the freeze node.
else
Append_Freeze_Actions (Ptr_Typ, Actions);
end if;
Analyze_List (Actions);
-- When the type the finalization master is being generated for was
-- created to store a 'Old object, then mark it as such so its
-- finalization can be delayed until after postconditions have been
-- checked.
if Stores_Attribute_Old_Prefix (Ptr_Typ) then
Set_Stores_Attribute_Old_Prefix (Fin_Mas_Id);
end if;
end;
end Build_Finalization_Master;
----------------------------
-- Build_Finalizer_Helper --
----------------------------
procedure Build_Finalizer_Helper
(N : Node_Id;
Clean_Stmts : List_Id;
Mark_Id : Entity_Id;
Top_Decls : List_Id;
Defer_Abort : Boolean;
Fin_Id : out Entity_Id;
Finalize_Old_Only : Boolean)
is
Acts_As_Clean : constant Boolean :=
Present (Mark_Id)
or else
(Present (Clean_Stmts)
and then Is_Non_Empty_List (Clean_Stmts));
For_Package_Body : constant Boolean := Nkind (N) = N_Package_Body;
For_Package_Spec : constant Boolean := Nkind (N) = N_Package_Declaration;
For_Package : constant Boolean :=
For_Package_Body or else For_Package_Spec;
Loc : constant Source_Ptr := Sloc (N);
-- NOTE: Local variable declarations are conservative and do not create
-- structures right from the start. Entities and lists are created once
-- it has been established that N has at least one controlled object.
Components_Built : Boolean := False;
-- A flag used to avoid double initialization of entities and lists. If
-- the flag is set then the following variables have been initialized:
-- Counter_Id
-- Finalizer_Decls
-- Finalizer_Stmts
-- Jump_Alts
Counter_Id : Entity_Id := Empty;
Counter_Val : Nat := 0;
-- Name and value of the state counter
Decls : List_Id := No_List;
-- Declarative region of N (if available). If N is a package declaration
-- Decls denotes the visible declarations.
Finalizer_Data : Finalization_Exception_Data;
-- Data for the exception
Finalizer_Decls : List_Id := No_List;
-- Local variable declarations. This list holds the label declarations
-- of all jump block alternatives as well as the declaration of the
-- local exception occurrence and the raised flag:
-- E : Exception_Occurrence;
-- Raised : Boolean := False;
-- L<counter value> : label;
Finalizer_Insert_Nod : Node_Id := Empty;
-- Insertion point for the finalizer body. Depending on the context
-- (Nkind of N) and the individual grouping of controlled objects, this
-- node may denote a package declaration or body, package instantiation,
-- block statement or a counter update statement.
Finalizer_Stmts : List_Id := No_List;
-- The statement list of the finalizer body. It contains the following:
--
-- Abort_Defer; -- Added if abort is allowed
-- <call to Prev_At_End> -- Added if exists
-- <cleanup statements> -- Added if Acts_As_Clean
-- <jump block> -- Added if Has_Ctrl_Objs
-- <finalization statements> -- Added if Has_Ctrl_Objs
-- <stack release> -- Added if Mark_Id exists
-- Abort_Undefer; -- Added if abort is allowed
Has_Ctrl_Objs : Boolean := False;
-- A general flag which denotes whether N has at least one controlled
-- object.
Has_Tagged_Types : Boolean := False;
-- A general flag which indicates whether N has at least one library-
-- level tagged type declaration.
HSS : Node_Id := Empty;
-- The sequence of statements of N (if available)
Jump_Alts : List_Id := No_List;
-- Jump block alternatives. Depending on the value of the state counter,
-- the control flow jumps to a sequence of finalization statements. This
-- list contains the following:
--
-- when <counter value> =>
-- goto L<counter value>;
Jump_Block_Insert_Nod : Node_Id := Empty;
-- Specific point in the finalizer statements where the jump block is
-- inserted.
Last_Top_Level_Ctrl_Construct : Node_Id := Empty;
-- The last controlled construct encountered when processing the top
-- level lists of N. This can be a nested package, an instantiation or
-- an object declaration.
Prev_At_End : Entity_Id := Empty;
-- The previous at end procedure of the handled statements block of N
Priv_Decls : List_Id := No_List;
-- The private declarations of N if N is a package declaration
Spec_Id : Entity_Id := Empty;
Spec_Decls : List_Id := Top_Decls;
Stmts : List_Id := No_List;
Tagged_Type_Stmts : List_Id := No_List;
-- Contains calls to Ada.Tags.Unregister_Tag for all library-level
-- tagged types found in N.
-----------------------
-- Local subprograms --
-----------------------
procedure Build_Components;
-- Create all entites and initialize all lists used in the creation of
-- the finalizer.
procedure Create_Finalizer;
-- Create the spec and body of the finalizer and insert them in the
-- proper place in the tree depending on the context.
function New_Finalizer_Name
(Spec_Id : Node_Id; For_Spec : Boolean) return Name_Id;
-- Create a fully qualified name of a package spec or body finalizer.
-- The generated name is of the form: xx__yy__finalize_[spec|body].
procedure Process_Declarations
(Decls : List_Id;
Preprocess : Boolean := False;
Top_Level : Boolean := False);
-- Inspect a list of declarations or statements which may contain
-- objects that need finalization. When flag Preprocess is set, the
-- routine will simply count the total number of controlled objects in
-- Decls and set Counter_Val accordingly. Top_Level is only relevant
-- when Preprocess is set and if True, the processing is performed for
-- objects in nested package declarations or instances.
procedure Process_Object_Declaration
(Decl : Node_Id;
Has_No_Init : Boolean := False;
Is_Protected : Boolean := False);
-- Generate all the machinery associated with the finalization of a
-- single object. Flag Has_No_Init is used to denote certain contexts
-- where Decl does not have initialization call(s). Flag Is_Protected
-- is set when Decl denotes a simple protected object.
procedure Process_Tagged_Type_Declaration (Decl : Node_Id);
-- Generate all the code necessary to unregister the external tag of a
-- tagged type.
----------------------
-- Build_Components --
----------------------
procedure Build_Components is
Counter_Decl : Node_Id;
Counter_Typ : Entity_Id;
Counter_Typ_Decl : Node_Id;
begin
pragma Assert (Present (Decls));
-- This routine might be invoked several times when dealing with
-- constructs that have two lists (either two declarative regions
-- or declarations and statements). Avoid double initialization.
if Components_Built then
return;
end if;
Components_Built := True;
if Has_Ctrl_Objs then
-- Create entities for the counter, its type, the local exception
-- and the raised flag.
Counter_Id := Make_Temporary (Loc, 'C');
Counter_Typ := Make_Temporary (Loc, 'T');
Finalizer_Decls := New_List;
Build_Object_Declarations
(Finalizer_Data, Finalizer_Decls, Loc, For_Package);
-- Since the total number of controlled objects is always known,
-- build a subtype of Natural with precise bounds. This allows
-- the backend to optimize the case statement. Generate:
--
-- subtype Tnn is Natural range 0 .. Counter_Val;
Counter_Typ_Decl :=
Make_Subtype_Declaration (Loc,
Defining_Identifier => Counter_Typ,
Subtype_Indication =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Occurrence_Of (Standard_Natural, Loc),
Constraint =>
Make_Range_Constraint (Loc,
Range_Expression =>
Make_Range (Loc,
Low_Bound =>
Make_Integer_Literal (Loc, Uint_0),
High_Bound =>
Make_Integer_Literal (Loc, Counter_Val)))));
-- Generate the declaration of the counter itself:
--
-- Counter : Integer := 0;
Counter_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Counter_Id,
Object_Definition => New_Occurrence_Of (Counter_Typ, Loc),
Expression => Make_Integer_Literal (Loc, 0));
-- Set the type of the counter explicitly to prevent errors when
-- examining object declarations later on.
Set_Etype (Counter_Id, Counter_Typ);
if Debug_Generated_Code then
Set_Debug_Info_Needed (Counter_Id);
end if;
-- The counter and its type are inserted before the source
-- declarations of N.
Prepend_To (Decls, Counter_Decl);
Prepend_To (Decls, Counter_Typ_Decl);
-- The counter and its associated type must be manually analyzed
-- since N has already been analyzed. Use the scope of the spec
-- when inserting in a package.
if For_Package then
Push_Scope (Spec_Id);
Analyze (Counter_Typ_Decl);
Analyze (Counter_Decl);
Pop_Scope;
else
Analyze (Counter_Typ_Decl);
Analyze (Counter_Decl);
end if;
Jump_Alts := New_List;
end if;
-- If the context requires additional cleanup, the finalization
-- machinery is added after the cleanup code.
if Acts_As_Clean then
Finalizer_Stmts := Clean_Stmts;
Jump_Block_Insert_Nod := Last (Finalizer_Stmts);
else
Finalizer_Stmts := New_List;
end if;
if Has_Tagged_Types then
Tagged_Type_Stmts := New_List;
end if;
end Build_Components;
----------------------
-- Create_Finalizer --
----------------------
procedure Create_Finalizer is
Body_Id : Entity_Id;
Fin_Body : Node_Id;
Fin_Spec : Node_Id;
Jump_Block : Node_Id;
Label : Node_Id;
Label_Id : Entity_Id;
begin
-- Step 1: Creation of the finalizer name
-- Packages must use a distinct name for their finalizers since the
-- binder will have to generate calls to them by name. The name is
-- of the following form:
-- xx__yy__finalize_[spec|body]
if For_Package then
Fin_Id := Make_Defining_Identifier
(Loc, New_Finalizer_Name (Spec_Id, For_Package_Spec));
Set_Has_Qualified_Name (Fin_Id);
Set_Has_Fully_Qualified_Name (Fin_Id);
-- The default name is _finalizer
else
-- Generation of a finalization procedure exclusively for 'Old
-- interally generated constants requires different name since
-- there will need to be multiple finalization routines in the
-- same scope. See Build_Finalizer for details.
if Finalize_Old_Only then
Fin_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Name_uFinalizer_Old));
else
Fin_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Name_uFinalizer));
end if;
-- The visibility semantics of AT_END handlers force a strange
-- separation of spec and body for stack-related finalizers:
-- declare : Enclosing_Scope
-- procedure _finalizer;
-- begin
-- <controlled objects>
-- procedure _finalizer is
-- ...
-- at end
-- _finalizer;
-- end;
-- Both spec and body are within the same construct and scope, but
-- the body is part of the handled sequence of statements. This
-- placement confuses the elaboration mechanism on targets where
-- AT_END handlers are expanded into "when all others" handlers:
-- exception
-- when all others =>
-- _finalizer; -- appears to require elab checks
-- at end
-- _finalizer;
-- end;
-- Since the compiler guarantees that the body of a _finalizer is
-- always inserted in the same construct where the AT_END handler
-- resides, there is no need for elaboration checks.
Set_Kill_Elaboration_Checks (Fin_Id);
-- Inlining the finalizer produces a substantial speedup at -O2.
-- It is inlined by default at -O3. Either way, it is called
-- exactly twice (once on the normal path, and once for
-- exceptions/abort), so this won't bloat the code too much.
Set_Is_Inlined (Fin_Id);
end if;
if Debug_Generated_Code then
Set_Debug_Info_Needed (Fin_Id);
end if;
-- Step 2: Creation of the finalizer specification
-- Generate:
-- procedure Fin_Id;
Fin_Spec :=
Make_Subprogram_Declaration (Loc,
Specification =>
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Fin_Id));
if For_Package then
Set_Is_Exported (Fin_Id);
Set_Interface_Name (Fin_Id,
Make_String_Literal (Loc,
Strval => Get_Name_String (Chars (Fin_Id))));
end if;
-- Step 3: Creation of the finalizer body
-- Has_Ctrl_Objs might be set because of a generic package body having
-- controlled objects. In this case, Jump_Alts may be empty and no
-- case nor goto statements are needed.
if Has_Ctrl_Objs
and then not Is_Empty_List (Jump_Alts)
then
-- Add L0, the default destination to the jump block
Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
Set_Entity (Label_Id,
Make_Defining_Identifier (Loc, Chars (Label_Id)));
Label := Make_Label (Loc, Label_Id);
-- Generate:
-- L0 : label;
Prepend_To (Finalizer_Decls,
Make_Implicit_Label_Declaration (Loc,
Defining_Identifier => Entity (Label_Id),
Label_Construct => Label));
-- Generate:
-- when others =>
-- goto L0;
Append_To (Jump_Alts,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => New_List (Make_Others_Choice (Loc)),
Statements => New_List (
Make_Goto_Statement (Loc,
Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
-- Generate:
-- <<L0>>
Append_To (Finalizer_Stmts, Label);
-- Create the jump block which controls the finalization flow
-- depending on the value of the state counter.
Jump_Block :=
Make_Case_Statement (Loc,
Expression => Make_Identifier (Loc, Chars (Counter_Id)),
Alternatives => Jump_Alts);
if Acts_As_Clean and then Present (Jump_Block_Insert_Nod) then
Insert_After (Jump_Block_Insert_Nod, Jump_Block);
else
Prepend_To (Finalizer_Stmts, Jump_Block);
end if;
end if;
-- Add the library-level tagged type unregistration machinery before
-- the jump block circuitry. This ensures that external tags will be
-- removed even if a finalization exception occurs at some point.
if Has_Tagged_Types then
Prepend_List_To (Finalizer_Stmts, Tagged_Type_Stmts);
end if;
-- Add a call to the previous At_End handler if it exists. The call
-- must always precede the jump block.
if Present (Prev_At_End) then
Prepend_To (Finalizer_Stmts,
Make_Procedure_Call_Statement (Loc, Prev_At_End));
-- Clear the At_End handler since we have already generated the
-- proper replacement call for it.
Set_At_End_Proc (HSS, Empty);
end if;
-- Release the secondary stack
if Present (Mark_Id) then
declare
Release : Node_Id := Build_SS_Release_Call (Loc, Mark_Id);
begin
-- If the context is a build-in-place function, the secondary
-- stack must be released, unless the build-in-place function
-- itself is returning on the secondary stack. Generate:
--
-- if BIP_Alloc_Form /= Secondary_Stack then
-- SS_Release (Mark_Id);
-- end if;
--
-- Note that if the function returns on the secondary stack,
-- then the responsibility of reclaiming the space is always
-- left to the caller (recursively if needed).
if Nkind (N) = N_Subprogram_Body then
declare
Spec_Id : constant Entity_Id :=
Unique_Defining_Entity (N);
BIP_SS : constant Boolean :=
Is_Build_In_Place_Function (Spec_Id)
and then Needs_BIP_Alloc_Form (Spec_Id);
begin
if BIP_SS then
Release :=
Make_If_Statement (Loc,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd =>
New_Occurrence_Of
(Build_In_Place_Formal
(Spec_Id, BIP_Alloc_Form), Loc),
Right_Opnd =>
Make_Integer_Literal (Loc,
UI_From_Int
(BIP_Allocation_Form'Pos
(Secondary_Stack)))),
Then_Statements => New_List (Release));
end if;
end;
end if;
Append_To (Finalizer_Stmts, Release);
end;
end if;
-- Protect the statements with abort defer/undefer. This is only when
-- aborts are allowed and the cleanup statements require deferral or
-- there are controlled objects to be finalized. Note that the abort
-- defer/undefer pair does not require an extra block because each
-- finalization exception is caught in its corresponding finalization
-- block. As a result, the call to Abort_Defer always takes place.
if Abort_Allowed and then (Defer_Abort or Has_Ctrl_Objs) then
Prepend_To (Finalizer_Stmts,
Build_Runtime_Call (Loc, RE_Abort_Defer));
Append_To (Finalizer_Stmts,
Build_Runtime_Call (Loc, RE_Abort_Undefer));
end if;
-- The local exception does not need to be reraised for library-level
-- finalizers. Note that this action must be carried out after object
-- cleanup, secondary stack release, and abort undeferral. Generate:
-- if Raised and then not Abort then
-- Raise_From_Controlled_Operation (E);
-- end if;
if Has_Ctrl_Objs and Exceptions_OK and not For_Package then
Append_To (Finalizer_Stmts,
Build_Raise_Statement (Finalizer_Data));
end if;
-- Generate:
-- procedure Fin_Id is
-- Abort : constant Boolean := Triggered_By_Abort;
-- <or>
-- Abort : constant Boolean := False; -- no abort
-- E : Exception_Occurrence; -- All added if flag
-- Raised : Boolean := False; -- Has_Ctrl_Objs is set
-- L0 : label;
-- ...
-- Lnn : label;
-- begin
-- Abort_Defer; -- Added if abort is allowed
-- <call to Prev_At_End> -- Added if exists
-- <cleanup statements> -- Added if Acts_As_Clean
-- <jump block> -- Added if Has_Ctrl_Objs
-- <finalization statements> -- Added if Has_Ctrl_Objs
-- <stack release> -- Added if Mark_Id exists
-- Abort_Undefer; -- Added if abort is allowed
-- <exception propagation> -- Added if Has_Ctrl_Objs
-- end Fin_Id;
-- Create the body of the finalizer
Body_Id := Make_Defining_Identifier (Loc, Chars (Fin_Id));
if Debug_Generated_Code then
Set_Debug_Info_Needed (Body_Id);
end if;
if For_Package then
Set_Has_Qualified_Name (Body_Id);
Set_Has_Fully_Qualified_Name (Body_Id);
end if;
Fin_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Body_Id),
Declarations => Finalizer_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Finalizer_Stmts));
-- Step 4: Spec and body insertion, analysis
if For_Package then
-- If the package spec has private declarations, the finalizer
-- body must be added to the end of the list in order to have
-- visibility of all private controlled objects.
if For_Package_Spec then
if Present (Priv_Decls) then
Append_To (Priv_Decls, Fin_Spec);
Append_To (Priv_Decls, Fin_Body);
else
Append_To (Decls, Fin_Spec);
Append_To (Decls, Fin_Body);
end if;
-- For package bodies, both the finalizer spec and body are
-- inserted at the end of the package declarations.
else
Append_To (Decls, Fin_Spec);
Append_To (Decls, Fin_Body);
end if;
-- Push the name of the package
Push_Scope (Spec_Id);
Analyze (Fin_Spec);
Analyze (Fin_Body);
Pop_Scope;
-- Non-package case
else
-- Create the spec for the finalizer. The At_End handler must be
-- able to call the body which resides in a nested structure.
-- Generate:
-- declare
-- procedure Fin_Id; -- Spec
-- begin
-- <objects and possibly statements>
-- procedure Fin_Id is ... -- Body
-- <statements>
-- at end
-- Fin_Id; -- At_End handler
-- end;
pragma Assert (Present (Spec_Decls));
-- It maybe possible that we are finalizing 'Old objects which
-- exist in the spec declarations. When this is the case the
-- Finalizer_Insert_Node will come before the end of the
-- Spec_Decls. So, to mitigate this, we insert the finalizer spec
-- earlier at the Finalizer_Insert_Nod instead of appending to the
-- end of Spec_Decls to prevent its body appearing before its
-- corresponding spec.
if Present (Finalizer_Insert_Nod)
and then List_Containing (Finalizer_Insert_Nod) = Spec_Decls
then
Insert_After_And_Analyze (Finalizer_Insert_Nod, Fin_Spec);
Finalizer_Insert_Nod := Fin_Spec;
-- Otherwise, Finalizer_Insert_Nod is not in Spec_Decls
else
Append_To (Spec_Decls, Fin_Spec);
Analyze (Fin_Spec);
end if;
-- When the finalizer acts solely as a cleanup routine, the body
-- is inserted right after the spec.
if Acts_As_Clean and not Has_Ctrl_Objs then
Insert_After (Fin_Spec, Fin_Body);
-- In all other cases the body is inserted after either:
--
-- 1) The counter update statement of the last controlled object
-- 2) The last top level nested controlled package
-- 3) The last top level controlled instantiation
else
-- Manually freeze the spec. This is somewhat of a hack because
-- a subprogram is frozen when its body is seen and the freeze
-- node appears right before the body. However, in this case,
-- the spec must be frozen earlier since the At_End handler
-- must be able to call it.
--
-- declare
-- procedure Fin_Id; -- Spec
-- [Fin_Id] -- Freeze node
-- begin
-- ...
-- at end
-- Fin_Id; -- At_End handler
-- end;
Ensure_Freeze_Node (Fin_Id);
Insert_After (Fin_Spec, Freeze_Node (Fin_Id));
Set_Is_Frozen (Fin_Id);
-- In the case where the last construct to contain a controlled
-- object is either a nested package, an instantiation or a
-- freeze node, the body must be inserted directly after the
-- construct.
if Nkind (Last_Top_Level_Ctrl_Construct) in
N_Freeze_Entity | N_Package_Declaration | N_Package_Body
then
Finalizer_Insert_Nod := Last_Top_Level_Ctrl_Construct;
end if;
Insert_After (Finalizer_Insert_Nod, Fin_Body);
end if;
Analyze (Fin_Body, Suppress => All_Checks);
end if;
-- Never consider that the finalizer procedure is enabled Ghost, even
-- when the corresponding unit is Ghost, as this would lead to an
-- an external name with a ___ghost_ prefix that the binder cannot
-- generate, as it has no knowledge of the Ghost status of units.
Set_Is_Checked_Ghost_Entity (Fin_Id, False);
end Create_Finalizer;
------------------------
-- New_Finalizer_Name --
------------------------
function New_Finalizer_Name
(Spec_Id : Node_Id; For_Spec : Boolean) return Name_Id
is
procedure New_Finalizer_Name (Id : Entity_Id);
-- Place "__<name-of-Id>" in the name buffer. If the identifier
-- has a non-standard scope, process the scope first.
------------------------
-- New_Finalizer_Name --
------------------------
procedure New_Finalizer_Name (Id : Entity_Id) is
begin
if Scope (Id) = Standard_Standard then
Get_Name_String (Chars (Id));
else
New_Finalizer_Name (Scope (Id));
Add_Str_To_Name_Buffer ("__");
Get_Name_String_And_Append (Chars (Id));
end if;
end New_Finalizer_Name;
-- Start of processing for New_Finalizer_Name
begin
-- Create the fully qualified name of the enclosing scope
New_Finalizer_Name (Spec_Id);
-- Generate:
-- __finalize_[spec|body]
Add_Str_To_Name_Buffer ("__finalize_");
if For_Spec then
Add_Str_To_Name_Buffer ("spec");
else
Add_Str_To_Name_Buffer ("body");
end if;
return Name_Find;
end New_Finalizer_Name;
--------------------------
-- Process_Declarations --
--------------------------
procedure Process_Declarations
(Decls : List_Id;
Preprocess : Boolean := False;
Top_Level : Boolean := False)
is
Decl : Node_Id;
Expr : Node_Id;
Obj_Id : Entity_Id;
Obj_Typ : Entity_Id;
Pack_Id : Entity_Id;
Spec : Node_Id;
Typ : Entity_Id;
Old_Counter_Val : Nat;
-- This variable is used to determine whether a nested package or
-- instance contains at least one controlled object.
procedure Processing_Actions
(Has_No_Init : Boolean := False;
Is_Protected : Boolean := False);
-- Depending on the mode of operation of Process_Declarations, either
-- increment the controlled object counter, set the controlled object
-- flag and store the last top level construct or process the current
-- declaration. Flag Has_No_Init is used to propagate scenarios where
-- the current declaration may not have initialization proc(s). Flag
-- Is_Protected should be set when the current declaration denotes a
-- simple protected object.
------------------------
-- Processing_Actions --
------------------------
procedure Processing_Actions
(Has_No_Init : Boolean := False;
Is_Protected : Boolean := False)
is
begin
-- Library-level tagged type
if Nkind (Decl) = N_Full_Type_Declaration then
if Preprocess then
Has_Tagged_Types := True;
if Top_Level and then No (Last_Top_Level_Ctrl_Construct) then
Last_Top_Level_Ctrl_Construct := Decl;
end if;
-- Unregister tagged type, unless No_Tagged_Type_Registration
-- is active.
elsif not Restriction_Active (No_Tagged_Type_Registration) then
Process_Tagged_Type_Declaration (Decl);
end if;
-- Controlled object declaration
else
if Preprocess then
Counter_Val := Counter_Val + 1;
Has_Ctrl_Objs := True;
if Top_Level and then No (Last_Top_Level_Ctrl_Construct) then
Last_Top_Level_Ctrl_Construct := Decl;
end if;
else
Process_Object_Declaration (Decl, Has_No_Init, Is_Protected);
end if;
end if;
end Processing_Actions;
-- Start of processing for Process_Declarations
begin
if Is_Empty_List (Decls) then
return;
end if;
-- Process all declarations in reverse order
Decl := Last_Non_Pragma (Decls);
while Present (Decl) loop
-- Depending on the value of flag Finalize_Old_Only we determine
-- which objects get finalized as part of the current finalizer
-- being built.
-- When True, only temporaries capturing the value of attribute
-- 'Old are finalized and all other cases are ignored.
-- When False, temporary objects used to capture the value of 'Old
-- are ignored and all others are considered.
if Finalize_Old_Only
xor (Nkind (Decl) = N_Object_Declaration
and then Stores_Attribute_Old_Prefix
(Defining_Identifier (Decl)))
then
null;
-- Library-level tagged types
elsif Nkind (Decl) = N_Full_Type_Declaration then
Typ := Defining_Identifier (Decl);
-- Ignored Ghost types do not need any cleanup actions because
-- they will not appear in the final tree.
if Is_Ignored_Ghost_Entity (Typ) then
null;
elsif Is_Tagged_Type (Typ)
and then Is_Library_Level_Entity (Typ)
and then Convention (Typ) = Convention_Ada
and then Present (Access_Disp_Table (Typ))
and then not Is_Abstract_Type (Typ)
and then not No_Run_Time_Mode
and then not Restriction_Active (No_Tagged_Type_Registration)
and then RTE_Available (RE_Register_Tag)
then
Processing_Actions;
end if;
-- Regular object declarations
elsif Nkind (Decl) = N_Object_Declaration then
Obj_Id := Defining_Identifier (Decl);
Obj_Typ := Base_Type (Etype (Obj_Id));
Expr := Expression (Decl);
-- Bypass any form of processing for objects which have their
-- finalization disabled. This applies only to objects at the
-- library level.
if For_Package and then Finalize_Storage_Only (Obj_Typ) then
null;
-- Finalization of transient objects are treated separately in
-- order to handle sensitive cases. These include:
-- * Aggregate expansion
-- * If, case, and expression with actions expansion
-- * Transient scopes
-- If one of those contexts has marked the transient object as
-- ignored, do not generate finalization actions for it.
elsif Is_Finalized_Transient (Obj_Id)
or else Is_Ignored_Transient (Obj_Id)
then
null;
-- Ignored Ghost objects do not need any cleanup actions
-- because they will not appear in the final tree.
elsif Is_Ignored_Ghost_Entity (Obj_Id) then
null;
-- The object is of the form:
-- Obj : [constant] Typ [:= Expr];
-- Do not process tag-to-class-wide conversions because they do
-- not yield an object. Do not process the incomplete view of a
-- deferred constant. Note that an object initialized by means
-- of a build-in-place function call may appear as a deferred
-- constant after expansion activities. These kinds of objects
-- must be finalized.
elsif not Is_Imported (Obj_Id)
and then Needs_Finalization (Obj_Typ)
and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
and then not (Ekind (Obj_Id) = E_Constant
and then not Has_Completion (Obj_Id)
and then No (BIP_Initialization_Call (Obj_Id)))
then
Processing_Actions;
-- The object is of the form:
-- Obj : Access_Typ := Non_BIP_Function_Call'reference;
-- Obj : Access_Typ :=
-- BIP_Function_Call (BIPalloc => 2, ...)'reference;
elsif Is_Access_Type (Obj_Typ)
and then Needs_Finalization
(Available_View (Designated_Type (Obj_Typ)))
and then Present (Expr)
and then
(Is_Secondary_Stack_BIP_Func_Call (Expr)
or else
(Is_Non_BIP_Func_Call (Expr)
and then not Is_Related_To_Func_Return (Obj_Id)))
then
Processing_Actions (Has_No_Init => True);
-- Processing for "hook" objects generated for transient
-- objects declared inside an Expression_With_Actions.
elsif Is_Access_Type (Obj_Typ)
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
N_Object_Declaration
then
Processing_Actions (Has_No_Init => True);
-- Process intermediate results of an if expression with one
-- of the alternatives using a controlled function call.
elsif Is_Access_Type (Obj_Typ)
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
N_Defining_Identifier
and then Present (Expr)
and then Nkind (Expr) = N_Null
then
Processing_Actions (Has_No_Init => True);
-- Simple protected objects which use type System.Tasking.
-- Protected_Objects.Protection to manage their locks should
-- be treated as controlled since they require manual cleanup.
-- The only exception is illustrated in the following example:
-- package Pkg is
-- type Ctrl is new Controlled ...
-- procedure Finalize (Obj : in out Ctrl);
-- Lib_Obj : Ctrl;
-- end Pkg;
-- package body Pkg is
-- protected Prot is
-- procedure Do_Something (Obj : in out Ctrl);
-- end Prot;
-- protected body Prot is
-- procedure Do_Something (Obj : in out Ctrl) is ...
-- end Prot;
-- procedure Finalize (Obj : in out Ctrl) is
-- begin
-- Prot.Do_Something (Obj);
-- end Finalize;
-- end Pkg;
-- Since for the most part entities in package bodies depend on
-- those in package specs, Prot's lock should be cleaned up
-- first. The subsequent cleanup of the spec finalizes Lib_Obj.
-- This act however attempts to invoke Do_Something and fails
-- because the lock has disappeared.
elsif Ekind (Obj_Id) = E_Variable
and then not In_Library_Level_Package_Body (Obj_Id)
and then (Is_Simple_Protected_Type (Obj_Typ)
or else Has_Simple_Protected_Object (Obj_Typ))
then
Processing_Actions (Is_Protected => True);
end if;
-- Specific cases of object renamings
elsif Nkind (Decl) = N_Object_Renaming_Declaration then
Obj_Id := Defining_Identifier (Decl);
Obj_Typ := Base_Type (Etype (Obj_Id));
-- Bypass any form of processing for objects which have their
-- finalization disabled. This applies only to objects at the
-- library level.
if For_Package and then Finalize_Storage_Only (Obj_Typ) then
null;
-- Ignored Ghost object renamings do not need any cleanup
-- actions because they will not appear in the final tree.
elsif Is_Ignored_Ghost_Entity (Obj_Id) then
null;
-- Return object of a build-in-place function. This case is
-- recognized and marked by the expansion of an extended return
-- statement (see Expand_N_Extended_Return_Statement).
elsif Needs_Finalization (Obj_Typ)
and then Is_Return_Object (Obj_Id)
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
then
Processing_Actions (Has_No_Init => True);
-- Detect a case where a source object has been initialized by
-- a controlled function call or another object which was later
-- rewritten as a class-wide conversion of Ada.Tags.Displace.
-- Obj1 : CW_Type := Src_Obj;
-- Obj2 : CW_Type := Function_Call (...);
-- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
-- Tmp : ... := Function_Call (...)'reference;
-- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
Processing_Actions (Has_No_Init => True);
end if;
-- Inspect the freeze node of an access-to-controlled type and
-- look for a delayed finalization master. This case arises when
-- the freeze actions are inserted at a later time than the
-- expansion of the context. Since Build_Finalizer is never called
-- on a single construct twice, the master will be ultimately
-- left out and never finalized. This is also needed for freeze
-- actions of designated types themselves, since in some cases the
-- finalization master is associated with a designated type's
-- freeze node rather than that of the access type (see handling
-- for freeze actions in Build_Finalization_Master).
elsif Nkind (Decl) = N_Freeze_Entity
and then Present (Actions (Decl))
then
Typ := Entity (Decl);
-- Freeze nodes for ignored Ghost types do not need cleanup
-- actions because they will never appear in the final tree.
if Is_Ignored_Ghost_Entity (Typ) then
null;
elsif (Is_Access_Object_Type (Typ)
and then Needs_Finalization
(Available_View (Designated_Type (Typ))))
or else (Is_Type (Typ) and then Needs_Finalization (Typ))
then
Old_Counter_Val := Counter_Val;
-- Freeze nodes are considered to be identical to packages
-- and blocks in terms of nesting. The difference is that
-- a finalization master created inside the freeze node is
-- at the same nesting level as the node itself.
Process_Declarations (Actions (Decl), Preprocess);
-- The freeze node contains a finalization master
if Preprocess
and then Top_Level
and then No (Last_Top_Level_Ctrl_Construct)
and then Counter_Val > Old_Counter_Val
then
Last_Top_Level_Ctrl_Construct := Decl;
end if;
end if;
-- Nested package declarations, avoid generics
elsif Nkind (Decl) = N_Package_Declaration then
Pack_Id := Defining_Entity (Decl);
Spec := Specification (Decl);
-- Do not inspect an ignored Ghost package because all code
-- found within will not appear in the final tree.
if Is_Ignored_Ghost_Entity (Pack_Id) then
null;
elsif Ekind (Pack_Id) /= E_Generic_Package then
Old_Counter_Val := Counter_Val;
Process_Declarations
(Private_Declarations (Spec), Preprocess);
Process_Declarations
(Visible_Declarations (Spec), Preprocess);
-- Either the visible or the private declarations contain a
-- controlled object. The nested package declaration is the
-- last such construct.
if Preprocess
and then Top_Level
and then No (Last_Top_Level_Ctrl_Construct)
and then Counter_Val > Old_Counter_Val
then
Last_Top_Level_Ctrl_Construct := Decl;
end if;
end if;
-- Call the xxx__finalize_body procedure of a library level
-- package instantiation if the body contains finalization
-- statements.
if Present (Generic_Parent (Spec))
and then Is_Library_Level_Entity (Pack_Id)
and then Present (Body_Entity (Generic_Parent (Spec)))
then
if Preprocess then
declare
P : Node_Id;
begin
P := Parent (Body_Entity (Generic_Parent (Spec)));
while Present (P)
and then Nkind (P) /= N_Package_Body
loop
P := Parent (P);
end loop;
if Present (P) then
Old_Counter_Val := Counter_Val;
Process_Declarations (Declarations (P), Preprocess);
-- Note that we are processing the generic body
-- template and not the actually instantiation
-- (which is generated too late for us to process
-- it), so there is no need to update in particular
-- to update Last_Top_Level_Ctrl_Construct here.
if Counter_Val > Old_Counter_Val then
Counter_Val := Old_Counter_Val;
Set_Has_Controlled_Component (Pack_Id);
end if;
end if;
end;
elsif Has_Controlled_Component (Pack_Id) then
-- We import the xxx__finalize_body routine since the
-- generic body will be instantiated later.
declare
Id : constant Node_Id :=
Make_Defining_Identifier (Loc,
New_Finalizer_Name (Defining_Unit_Name (Spec),
For_Spec => False));
begin
Set_Has_Qualified_Name (Id);
Set_Has_Fully_Qualified_Name (Id);
Set_Is_Imported (Id);
Set_Has_Completion (Id);
Set_Interface_Name (Id,
Make_String_Literal (Loc,
Strval => Get_Name_String (Chars (Id))));
Append_New_To (Finalizer_Stmts,
Make_Subprogram_Declaration (Loc,
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Id)));
Append_To (Finalizer_Stmts,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Id, Loc)));
end;
end if;
end if;
-- Nested package bodies, avoid generics
elsif Nkind (Decl) = N_Package_Body then
-- Do not inspect an ignored Ghost package body because all
-- code found within will not appear in the final tree.
if Is_Ignored_Ghost_Entity (Defining_Entity (Decl)) then
null;
elsif Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package
then
Old_Counter_Val := Counter_Val;
Process_Declarations (Declarations (Decl), Preprocess);
-- The nested package body is the last construct to contain
-- a controlled object.
if Preprocess
and then Top_Level
and then No (Last_Top_Level_Ctrl_Construct)
and then Counter_Val > Old_Counter_Val
then
Last_Top_Level_Ctrl_Construct := Decl;
end if;
end if;
-- Handle a rare case caused by a controlled transient object
-- created as part of a record init proc. The variable is wrapped
-- in a block, but the block is not associated with a transient
-- scope.
elsif Nkind (Decl) = N_Block_Statement
and then Inside_Init_Proc
then
Old_Counter_Val := Counter_Val;
if Present (Handled_Statement_Sequence (Decl)) then
Process_Declarations
(Statements (Handled_Statement_Sequence (Decl)),
Preprocess);
end if;
Process_Declarations (Declarations (Decl), Preprocess);
-- Either the declaration or statement list of the block has a
-- controlled object.
if Preprocess
and then Top_Level
and then No (Last_Top_Level_Ctrl_Construct)
and then Counter_Val > Old_Counter_Val
then
Last_Top_Level_Ctrl_Construct := Decl;
end if;
-- Handle the case where the original context has been wrapped in
-- a block to avoid interference between exception handlers and
-- At_End handlers. Treat the block as transparent and process its
-- contents.
elsif Nkind (Decl) = N_Block_Statement
and then Is_Finalization_Wrapper (Decl)
then
if Present (Handled_Statement_Sequence (Decl)) then
Process_Declarations
(Statements (Handled_Statement_Sequence (Decl)),
Preprocess);
end if;
Process_Declarations (Declarations (Decl), Preprocess);
end if;
Prev_Non_Pragma (Decl);
end loop;
end Process_Declarations;
--------------------------------
-- Process_Object_Declaration --
--------------------------------
procedure Process_Object_Declaration
(Decl : Node_Id;
Has_No_Init : Boolean := False;
Is_Protected : Boolean := False)
is
Loc : constant Source_Ptr := Sloc (Decl);
Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
Init_Typ : Entity_Id;
-- The initialization type of the related object declaration. Note
-- that this is not necessarily the same type as Obj_Typ because of
-- possible type derivations.
Obj_Typ : Entity_Id;
-- The type of the related object declaration
function Build_BIP_Cleanup_Stmts (Func_Id : Entity_Id) return Node_Id;
-- Func_Id denotes a build-in-place function. Generate the following
-- cleanup code:
--
-- if BIPallocfrom > Secondary_Stack'Pos
-- and then BIPfinalizationmaster /= null
-- then
-- declare
-- type Ptr_Typ is access Obj_Typ;
-- for Ptr_Typ'Storage_Pool
-- use Base_Pool (BIPfinalizationmaster);
-- begin
-- Free (Ptr_Typ (Temp));
-- end;
-- end if;
--
-- Obj_Typ is the type of the current object, Temp is the original
-- allocation which Obj_Id renames.
procedure Find_Last_Init
(Last_Init : out Node_Id;
Body_Insert : out Node_Id);
-- Find the last initialization call related to object declaration
-- Decl. Last_Init denotes the last initialization call which follows
-- Decl. Body_Insert denotes a node where the finalizer body could be
-- potentially inserted after (if blocks are involved).
-----------------------------
-- Build_BIP_Cleanup_Stmts --
-----------------------------
function Build_BIP_Cleanup_Stmts
(Func_Id : Entity_Id) return Node_Id
is
Decls : constant List_Id := New_List;
Fin_Mas_Id : constant Entity_Id :=
Build_In_Place_Formal
(Func_Id, BIP_Finalization_Master);
Func_Typ : constant Entity_Id := Etype (Func_Id);
Temp_Id : constant Entity_Id :=
Entity (Prefix (Name (Parent (Obj_Id))));
Cond : Node_Id;
Free_Blk : Node_Id;
Free_Stmt : Node_Id;
Pool_Id : Entity_Id;
Ptr_Typ : Entity_Id;
begin
-- Generate:
-- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
Pool_Id := Make_Temporary (Loc, 'P');
Append_To (Decls,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Pool_Id,
Subtype_Mark =>
New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc),
Name =>
Make_Explicit_Dereference (Loc,
Prefix =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Base_Pool), Loc),
Parameter_Associations => New_List (
Make_Explicit_Dereference (Loc,
Prefix =>
New_Occurrence_Of (Fin_Mas_Id, Loc)))))));
-- Create an access type which uses the storage pool of the
-- caller's finalization master.
-- Generate:
-- type Ptr_Typ is access Func_Typ;
Ptr_Typ := Make_Temporary (Loc, 'P');
Append_To (Decls,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Ptr_Typ,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
Subtype_Indication => New_Occurrence_Of (Func_Typ, Loc))));
-- Perform minor decoration in order to set the master and the
-- storage pool attributes.
Mutate_Ekind (Ptr_Typ, E_Access_Type);
Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
if Debug_Generated_Code then
Set_Debug_Info_Needed (Pool_Id);
end if;
-- Create an explicit free statement. Note that the free uses the
-- caller's pool expressed as a renaming.
Free_Stmt :=
Make_Free_Statement (Loc,
Expression =>
Unchecked_Convert_To (Ptr_Typ,
New_Occurrence_Of (Temp_Id, Loc)));
Set_Storage_Pool (Free_Stmt, Pool_Id);
-- Create a block to house the dummy type and the instantiation as
-- well as to perform the cleanup the temporary.
-- Generate:
-- declare
-- <Decls>
-- begin
-- Free (Ptr_Typ (Temp_Id));
-- end;
Free_Blk :=
Make_Block_Statement (Loc,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Free_Stmt)));
-- Generate:
-- if BIPfinalizationmaster /= null then
Cond :=
Make_Op_Ne (Loc,
Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc),
Right_Opnd => Make_Null (Loc));
-- For constrained or tagged results escalate the condition to
-- include the allocation format. Generate:
-- if BIPallocform > Secondary_Stack'Pos
-- and then BIPfinalizationmaster /= null
-- then
if not Is_Constrained (Func_Typ)
or else Is_Tagged_Type (Func_Typ)
then
declare
Alloc : constant Entity_Id :=
Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
begin
Cond :=
Make_And_Then (Loc,
Left_Opnd =>
Make_Op_Gt (Loc,
Left_Opnd => New_Occurrence_Of (Alloc, Loc),
Right_Opnd =>
Make_Integer_Literal (Loc,
UI_From_Int
(BIP_Allocation_Form'Pos (Secondary_Stack)))),
Right_Opnd => Cond);
end;
end if;
-- Generate:
-- if <Cond> then
-- <Free_Blk>
-- end if;
return
Make_If_Statement (Loc,
Condition => Cond,
Then_Statements => New_List (Free_Blk));
end Build_BIP_Cleanup_Stmts;
--------------------
-- Find_Last_Init --
--------------------
procedure Find_Last_Init
(Last_Init : out Node_Id;
Body_Insert : out Node_Id)
is
function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id;
-- Find the last initialization call within the statements of
-- block Blk.
function Is_Init_Call (N : Node_Id) return Boolean;
-- Determine whether node N denotes one of the initialization
-- procedures of types Init_Typ or Obj_Typ.
function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id;
-- Obtain the next statement which follows list member Stmt while
-- ignoring artifacts related to access-before-elaboration checks.
-----------------------------
-- Find_Last_Init_In_Block --
-----------------------------
function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id is
HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
Stmt : Node_Id;
begin
-- Examine the individual statements of the block in reverse to
-- locate the last initialization call.
if Present (HSS) and then Present (Statements (HSS)) then
Stmt := Last (Statements (HSS));
while Present (Stmt) loop
-- Peek inside nested blocks in case aborts are allowed
if Nkind (Stmt) = N_Block_Statement then
return Find_Last_Init_In_Block (Stmt);
elsif Is_Init_Call (Stmt) then
return Stmt;
end if;
Prev (Stmt);
end loop;
end if;
return Empty;
end Find_Last_Init_In_Block;
------------------
-- Is_Init_Call --
------------------
function Is_Init_Call (N : Node_Id) return Boolean is
function Is_Init_Proc_Of
(Subp_Id : Entity_Id;
Typ : Entity_Id) return Boolean;
-- Determine whether subprogram Subp_Id is a valid init proc of
-- type Typ.
---------------------
-- Is_Init_Proc_Of --
---------------------
function Is_Init_Proc_Of
(Subp_Id : Entity_Id;
Typ : Entity_Id) return Boolean
is
Deep_Init : Entity_Id := Empty;
Prim_Init : Entity_Id := Empty;
Type_Init : Entity_Id := Empty;
begin
-- Obtain all possible initialization routines of the
-- related type and try to match the subprogram entity
-- against one of them.
-- Deep_Initialize
Deep_Init := TSS (Typ, TSS_Deep_Initialize);
-- Primitive Initialize
if Is_Controlled (Typ) then
Prim_Init := Find_Optional_Prim_Op (Typ, Name_Initialize);
if Present (Prim_Init) then
Prim_Init := Ultimate_Alias (Prim_Init);
end if;
end if;
-- Type initialization routine
if Has_Non_Null_Base_Init_Proc (Typ) then
Type_Init := Base_Init_Proc (Typ);
end if;
return
(Present (Deep_Init) and then Subp_Id = Deep_Init)
or else
(Present (Prim_Init) and then Subp_Id = Prim_Init)
or else
(Present (Type_Init) and then Subp_Id = Type_Init);
end Is_Init_Proc_Of;
-- Local variables
Call_Id : Entity_Id;
-- Start of processing for Is_Init_Call
begin
if Nkind (N) = N_Procedure_Call_Statement
and then Nkind (Name (N)) = N_Identifier
then
Call_Id := Entity (Name (N));
-- Consider both the type of the object declaration and its
-- related initialization type.
return
Is_Init_Proc_Of (Call_Id, Init_Typ)
or else
Is_Init_Proc_Of (Call_Id, Obj_Typ);
end if;
return False;
end Is_Init_Call;
-----------------------------
-- Next_Suitable_Statement --
-----------------------------
function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id is
Result : Node_Id;
begin
-- Skip call markers and Program_Error raises installed by the
-- ABE mechanism.
Result := Next (Stmt);
while Present (Result) loop
exit when Nkind (Result) not in
N_Call_Marker | N_Raise_Program_Error;
Next (Result);
end loop;
return Result;
end Next_Suitable_Statement;
-- Local variables
Call : Node_Id;
Stmt : Node_Id;
Stmt_2 : Node_Id;
Deep_Init_Found : Boolean := False;
-- A flag set when a call to [Deep_]Initialize has been found
-- Start of processing for Find_Last_Init
begin
Last_Init := Decl;
Body_Insert := Empty;
-- Object renamings and objects associated with controlled
-- function results do not require initialization.
if Has_No_Init then
return;
end if;
Stmt := Next_Suitable_Statement (Decl);
-- For an object with suppressed initialization, we check whether
-- there is in fact no initialization expression. If there is not,
-- then this is an object declaration that has been turned into a
-- different object declaration that calls the build-in-place
-- function in a 'Reference attribute, as in "F(...)'Reference".
-- We search for that later object declaration, so that the
-- Inc_Decl will be inserted after the call. Otherwise, if the
-- call raises an exception, we will finalize the (uninitialized)
-- object, which is wrong.
if No_Initialization (Decl) then
if No (Expression (Last_Init)) then
loop
Next (Last_Init);
exit when No (Last_Init);
exit when Nkind (Last_Init) = N_Object_Declaration
and then Nkind (Expression (Last_Init)) = N_Reference
and then Nkind (Prefix (Expression (Last_Init))) =
N_Function_Call
and then Is_Expanded_Build_In_Place_Call
(Prefix (Expression (Last_Init)));
end loop;
end if;
return;
-- In all other cases the initialization calls follow the related
-- object. The general structure of object initialization built by
-- routine Default_Initialize_Object is as follows:
-- [begin -- aborts allowed
-- Abort_Defer;]
-- Type_Init_Proc (Obj);
-- [begin] -- exceptions allowed
-- Deep_Initialize (Obj);
-- [exception -- exceptions allowed
-- when others =>
-- Deep_Finalize (Obj, Self => False);
-- raise;
-- end;]
-- [at end -- aborts allowed
-- Abort_Undefer;
-- end;]
-- When aborts are allowed, the initialization calls are housed
-- within a block.
elsif Nkind (Stmt) = N_Block_Statement then
Last_Init := Find_Last_Init_In_Block (Stmt);
Body_Insert := Stmt;
-- Otherwise the initialization calls follow the related object
else
pragma Assert (Present (Stmt));
Stmt_2 := Next_Suitable_Statement (Stmt);
-- Check for an optional call to Deep_Initialize which may
-- appear within a block depending on whether the object has
-- controlled components.
if Present (Stmt_2) then
if Nkind (Stmt_2) = N_Block_Statement then
Call := Find_Last_Init_In_Block (Stmt_2);
if Present (Call) then
Deep_Init_Found := True;
Last_Init := Call;
Body_Insert := Stmt_2;
end if;
elsif Is_Init_Call (Stmt_2) then
Deep_Init_Found := True;
Last_Init := Stmt_2;
Body_Insert := Last_Init;
end if;
end if;
-- If the object lacks a call to Deep_Initialize, then it must
-- have a call to its related type init proc.
if not Deep_Init_Found and then Is_Init_Call (Stmt) then
Last_Init := Stmt;
Body_Insert := Last_Init;
end if;
end if;
end Find_Last_Init;
-- Local variables
Body_Ins : Node_Id;
Count_Ins : Node_Id;
Fin_Call : Node_Id;
Fin_Stmts : List_Id := No_List;
Inc_Decl : Node_Id;
Label : Node_Id;
Label_Id : Entity_Id;
Obj_Ref : Node_Id;
-- Start of processing for Process_Object_Declaration
begin
-- Handle the object type and the reference to the object
Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
Obj_Typ := Base_Type (Etype (Obj_Id));
loop
if Is_Access_Type (Obj_Typ) then
Obj_Typ := Directly_Designated_Type (Obj_Typ);
Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
elsif Is_Concurrent_Type (Obj_Typ)
and then Present (Corresponding_Record_Type (Obj_Typ))
then
Obj_Typ := Corresponding_Record_Type (Obj_Typ);
Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
elsif Is_Private_Type (Obj_Typ)
and then Present (Full_View (Obj_Typ))
then
Obj_Typ := Full_View (Obj_Typ);
Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
elsif Obj_Typ /= Base_Type (Obj_Typ) then
Obj_Typ := Base_Type (Obj_Typ);
Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
else
exit;
end if;
end loop;
Set_Etype (Obj_Ref, Obj_Typ);
-- Handle the initialization type of the object declaration
Init_Typ := Obj_Typ;
loop
if Is_Private_Type (Init_Typ)
and then Present (Full_View (Init_Typ))
then
Init_Typ := Full_View (Init_Typ);
elsif Is_Untagged_Derivation (Init_Typ) then
Init_Typ := Root_Type (Init_Typ);
else
exit;
end if;
end loop;
-- Set a new value for the state counter and insert the statement
-- after the object declaration. Generate:
-- Counter := <value>;
Inc_Decl :=
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Counter_Id, Loc),
Expression => Make_Integer_Literal (Loc, Counter_Val));
-- Insert the counter after all initialization has been done. The
-- place of insertion depends on the context.
if Ekind (Obj_Id) in E_Constant | E_Variable then
-- The object is initialized by a build-in-place function call.
-- The counter insertion point is after the function call.
if Present (BIP_Initialization_Call (Obj_Id)) then
Count_Ins := BIP_Initialization_Call (Obj_Id);
Body_Ins := Empty;
-- The object is initialized by an aggregate. Insert the counter
-- after the last aggregate assignment.
elsif Present (Last_Aggregate_Assignment (Obj_Id)) then
Count_Ins := Last_Aggregate_Assignment (Obj_Id);
Body_Ins := Empty;
-- In all other cases the counter is inserted after the last call
-- to either [Deep_]Initialize or the type-specific init proc.
else
Find_Last_Init (Count_Ins, Body_Ins);
end if;
-- In all other cases the counter is inserted after the last call to
-- either [Deep_]Initialize or the type-specific init proc.
else
Find_Last_Init (Count_Ins, Body_Ins);
end if;
-- If the Initialize function is null or trivial, the call will have
-- been replaced with a null statement, in which case place counter
-- declaration after object declaration itself.
if No (Count_Ins) then
Count_Ins := Decl;
end if;
Insert_After (Count_Ins, Inc_Decl);
Analyze (Inc_Decl);
-- If the current declaration is the last in the list, the finalizer
-- body needs to be inserted after the set counter statement for the
-- current object declaration. This is complicated by the fact that
-- the set counter statement may appear in abort deferred block. In
-- that case, the proper insertion place is after the block.
if No (Finalizer_Insert_Nod) then
-- Insertion after an abort deferred block
if Present (Body_Ins) then
Finalizer_Insert_Nod := Body_Ins;
else
Finalizer_Insert_Nod := Inc_Decl;
end if;
end if;
-- Create the associated label with this object, generate:
-- L<counter> : label;
Label_Id :=
Make_Identifier (Loc, New_External_Name ('L', Counter_Val));
Set_Entity
(Label_Id, Make_Defining_Identifier (Loc, Chars (Label_Id)));
Label := Make_Label (Loc, Label_Id);
Prepend_To (Finalizer_Decls,
Make_Implicit_Label_Declaration (Loc,
Defining_Identifier => Entity (Label_Id),
Label_Construct => Label));
-- Create the associated jump with this object, generate:
-- when <counter> =>
-- goto L<counter>;
Prepend_To (Jump_Alts,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => New_List (
Make_Integer_Literal (Loc, Counter_Val)),
Statements => New_List (
Make_Goto_Statement (Loc,
Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
-- Insert the jump destination, generate:
-- <<L<counter>>>
Append_To (Finalizer_Stmts, Label);
-- Disable warnings on Obj_Id. This works around an issue where GCC
-- is not able to detect that Obj_Id is protected by a counter and
-- emits spurious warnings.
if not Comes_From_Source (Obj_Id) then
Set_Warnings_Off (Obj_Id);
end if;
-- Processing for simple protected objects. Such objects require
-- manual finalization of their lock managers.
if Is_Protected then
if Is_Simple_Protected_Type (Obj_Typ) then
Fin_Call := Cleanup_Protected_Object (Decl, Obj_Ref);
if Present (Fin_Call) then
Fin_Stmts := New_List (Fin_Call);
end if;
elsif Has_Simple_Protected_Object (Obj_Typ) then
if Is_Record_Type (Obj_Typ) then
Fin_Stmts := Cleanup_Record (Decl, Obj_Ref, Obj_Typ);
elsif Is_Array_Type (Obj_Typ) then
Fin_Stmts := Cleanup_Array (Decl, Obj_Ref, Obj_Typ);
end if;
end if;
-- Generate:
-- begin
-- System.Tasking.Protected_Objects.Finalize_Protection
-- (Obj._object);
-- exception
-- when others =>
-- null;
-- end;
if Present (Fin_Stmts) and then Exceptions_OK then
Fin_Stmts := New_List (
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Fin_Stmts,
Exception_Handlers => New_List (
Make_Exception_Handler (Loc,
Exception_Choices => New_List (
Make_Others_Choice (Loc)),
Statements => New_List (
Make_Null_Statement (Loc)))))));
end if;
-- Processing for regular controlled objects
else
-- Generate:
-- begin
-- [Deep_]Finalize (Obj);
-- exception
-- when Id : others =>
-- if not Raised then
-- Raised := True;
-- Save_Occurrence (E, Id);
-- end if;
-- end;
Fin_Call :=
Make_Final_Call (
Obj_Ref => Obj_Ref,
Typ => Obj_Typ);
-- Guard against a missing [Deep_]Finalize when the object type
-- was not properly frozen.
if No (Fin_Call) then
Fin_Call := Make_Null_Statement (Loc);
end if;
-- For CodePeer, the exception handlers normally generated here
-- generate complex flowgraphs which result in capacity problems.
-- Omitting these handlers for CodePeer is justified as follows:
-- If a handler is dead, then omitting it is surely ok
-- If a handler is live, then CodePeer should flag the
-- potentially-exception-raising construct that causes it
-- to be live. That is what we are interested in, not what
-- happens after the exception is raised.
if Exceptions_OK and not CodePeer_Mode then
Fin_Stmts := New_List (
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Fin_Call),
Exception_Handlers => New_List (
Build_Exception_Handler
(Finalizer_Data, For_Package)))));
-- When exception handlers are prohibited, the finalization call
-- appears unprotected. Any exception raised during finalization
-- will bypass the circuitry which ensures the cleanup of all
-- remaining objects.
else
Fin_Stmts := New_List (Fin_Call);
end if;
-- If we are dealing with a return object of a build-in-place
-- function, generate the following cleanup statements:
-- if BIPallocfrom > Secondary_Stack'Pos
-- and then BIPfinalizationmaster /= null
-- then
-- declare
-- type Ptr_Typ is access Obj_Typ;
-- for Ptr_Typ'Storage_Pool use
-- Base_Pool (BIPfinalizationmaster.all).all;
-- begin
-- Free (Ptr_Typ (Temp));
-- end;
-- end if;
-- The generated code effectively detaches the temporary from the
-- caller finalization master and deallocates the object.
if Is_Return_Object (Obj_Id) then
declare
Func_Id : constant Entity_Id := Enclosing_Function (Obj_Id);
begin
if Is_Build_In_Place_Function (Func_Id)
and then Needs_BIP_Finalization_Master (Func_Id)
then
Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id));
end if;
end;
end if;
if Ekind (Obj_Id) in E_Constant | E_Variable
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
then
-- Temporaries created for the purpose of "exporting" a
-- transient object out of an Expression_With_Actions (EWA)
-- need guards. The following illustrates the usage of such
-- temporaries.
-- Access_Typ : access [all] Obj_Typ;
-- Temp : Access_Typ := null;
-- <Counter> := ...;
-- do
-- Ctrl_Trans : [access [all]] Obj_Typ := ...;
-- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
-- <or>
-- Temp := Ctrl_Trans'Unchecked_Access;
-- in ... end;
-- The finalization machinery does not process EWA nodes as
-- this may lead to premature finalization of expressions. Note
-- that Temp is marked as being properly initialized regardless
-- of whether the initialization of Ctrl_Trans succeeded. Since
-- a failed initialization may leave Temp with a value of null,
-- add a guard to handle this case:
-- if Obj /= null then
-- <object finalization statements>
-- end if;
if Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
N_Object_Declaration
then
Fin_Stmts := New_List (
Make_If_Statement (Loc,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd => New_Occurrence_Of (Obj_Id, Loc),
Right_Opnd => Make_Null (Loc)),
Then_Statements => Fin_Stmts));
-- Return objects use a flag to aid in processing their
-- potential finalization when the enclosing function fails
-- to return properly. Generate:
-- if not Flag then
-- <object finalization statements>
-- end if;
else
Fin_Stmts := New_List (
Make_If_Statement (Loc,
Condition =>
Make_Op_Not (Loc,
Right_Opnd =>
New_Occurrence_Of
(Status_Flag_Or_Transient_Decl (Obj_Id), Loc)),
Then_Statements => Fin_Stmts));
end if;
end if;
end if;
Append_List_To (Finalizer_Stmts, Fin_Stmts);
-- Since the declarations are examined in reverse, the state counter
-- must be decremented in order to keep with the true position of
-- objects.
Counter_Val := Counter_Val - 1;
end Process_Object_Declaration;
-------------------------------------
-- Process_Tagged_Type_Declaration --
-------------------------------------
procedure Process_Tagged_Type_Declaration (Decl : Node_Id) is
Typ : constant Entity_Id := Defining_Identifier (Decl);
DT_Ptr : constant Entity_Id :=
Node (First_Elmt (Access_Disp_Table (Typ)));
begin
-- Generate:
-- Ada.Tags.Unregister_Tag (<Typ>P);
Append_To (Tagged_Type_Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Unregister_Tag), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (DT_Ptr, Loc))));
end Process_Tagged_Type_Declaration;
-- Start of processing for Build_Finalizer_Helper
begin
Fin_Id := Empty;
-- Do not perform this expansion in SPARK mode because it is not
-- necessary.
if GNATprove_Mode then
return;
end if;
-- Step 1: Extract all lists which may contain controlled objects or
-- library-level tagged types.
if For_Package_Spec then
Decls := Visible_Declarations (Specification (N));
Priv_Decls := Private_Declarations (Specification (N));
-- Retrieve the package spec id
Spec_Id := Defining_Unit_Name (Specification (N));
if Nkind (Spec_Id) = N_Defining_Program_Unit_Name then
Spec_Id := Defining_Identifier (Spec_Id);
end if;
-- Accept statement, block, entry body, package body, protected body,
-- subprogram body or task body.
else
Decls := Declarations (N);
HSS := Handled_Statement_Sequence (N);
if Present (HSS) then
if Present (Statements (HSS)) then
Stmts := Statements (HSS);
end if;
if Present (At_End_Proc (HSS)) then
Prev_At_End := At_End_Proc (HSS);
end if;
end if;
-- Retrieve the package spec id for package bodies
if For_Package_Body then
Spec_Id := Corresponding_Spec (N);
end if;
end if;
-- Do not process nested packages since those are handled by the
-- enclosing scope's finalizer. Do not process non-expanded package
-- instantiations since those will be re-analyzed and re-expanded.
if For_Package
and then
(not Is_Library_Level_Entity (Spec_Id)
-- Nested packages are library level entities, but do not need to
-- be processed separately.
or else Scope_Depth (Spec_Id) /= Uint_1
or else (Is_Generic_Instance (Spec_Id)
and then Package_Instantiation (Spec_Id) /= N))
-- Still need to process package body instantiations which may
-- contain objects requiring finalization.
and then not
(For_Package_Body
and then Is_Library_Level_Entity (Spec_Id)
and then Is_Generic_Instance (Spec_Id))
then
return;
end if;
-- Step 2: Object [pre]processing
if For_Package then
-- Preprocess the visible declarations now in order to obtain the
-- correct number of controlled object by the time the private
-- declarations are processed.
Process_Declarations (Decls, Preprocess => True, Top_Level => True);
-- From all the possible contexts, only package specifications may
-- have private declarations.
if For_Package_Spec then
Process_Declarations
(Priv_Decls, Preprocess => True, Top_Level => True);
end if;
-- The current context may lack controlled objects, but require some
-- other form of completion (task termination for instance). In such
-- cases, the finalizer must be created and carry the additional
-- statements.
if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
Build_Components;
end if;
-- The preprocessing has determined that the context has controlled
-- objects or library-level tagged types.
if Has_Ctrl_Objs or Has_Tagged_Types then
-- Private declarations are processed first in order to preserve
-- possible dependencies between public and private objects.
if For_Package_Spec then
Process_Declarations (Priv_Decls);
end if;
Process_Declarations (Decls);
end if;
-- Non-package case
else
-- Preprocess both declarations and statements
Process_Declarations (Decls, Preprocess => True, Top_Level => True);
Process_Declarations (Stmts, Preprocess => True, Top_Level => True);
-- At this point it is known that N has controlled objects. Ensure
-- that N has a declarative list since the finalizer spec will be
-- attached to it.
if Has_Ctrl_Objs and then No (Decls) then
Set_Declarations (N, New_List);
Decls := Declarations (N);
Spec_Decls := Decls;
end if;
-- The current context may lack controlled objects, but require some
-- other form of completion (task termination for instance). In such
-- cases, the finalizer must be created and carry the additional
-- statements.
if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
Build_Components;
end if;
if Has_Ctrl_Objs or Has_Tagged_Types then
Process_Declarations (Stmts);
Process_Declarations (Decls);
end if;
end if;
-- Step 3: Finalizer creation
if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
Create_Finalizer;
end if;
end Build_Finalizer_Helper;
--------------------------
-- Build_Finalizer_Call --
--------------------------
procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id) is
Is_Prot_Body : constant Boolean :=
Nkind (N) = N_Subprogram_Body
and then Is_Protected_Subprogram_Body (N);
-- Determine whether N denotes the protected version of a subprogram
-- which belongs to a protected type.
Loc : constant Source_Ptr := Sloc (N);
HSS : Node_Id;
begin
-- Do not perform this expansion in SPARK mode because we do not create
-- finalizers in the first place.
if GNATprove_Mode then
return;
end if;
-- The At_End handler should have been assimilated by the finalizer
HSS := Handled_Statement_Sequence (N);
pragma Assert (No (At_End_Proc (HSS)));
-- If the construct to be cleaned up is a protected subprogram body, the
-- finalizer call needs to be associated with the block which wraps the
-- unprotected version of the subprogram. The following illustrates this
-- scenario:
-- procedure Prot_SubpP is
-- procedure finalizer is
-- begin
-- Service_Entries (Prot_Obj);
-- Abort_Undefer;
-- end finalizer;
-- begin
-- . . .
-- begin
-- Prot_SubpN (Prot_Obj);
-- at end
-- finalizer;
-- end;
-- end Prot_SubpP;
if Is_Prot_Body then
HSS := Handled_Statement_Sequence (Last (Statements (HSS)));
-- An At_End handler and regular exception handlers cannot coexist in
-- the same statement sequence. Wrap the original statements in a block.
elsif Present (Exception_Handlers (HSS)) then
declare
End_Lab : constant Node_Id := End_Label (HSS);
Block : Node_Id;
begin
Block :=
Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS);
Set_Handled_Statement_Sequence (N,
Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
HSS := Handled_Statement_Sequence (N);
Set_End_Label (HSS, End_Lab);
end;
end if;
Set_At_End_Proc (HSS, New_Occurrence_Of (Fin_Id, Loc));
-- Attach reference to finalizer to tree, for LLVM use
Set_Parent (At_End_Proc (HSS), HSS);
Analyze (At_End_Proc (HSS));
Expand_At_End_Handler (HSS, Empty);
end Build_Finalizer_Call;
---------------------
-- Build_Finalizer --
---------------------
procedure Build_Finalizer
(N : Node_Id;
Clean_Stmts : List_Id;
Mark_Id : Entity_Id;
Top_Decls : List_Id;
Defer_Abort : Boolean;
Fin_Id : out Entity_Id)
is
Def_Ent : constant Entity_Id := Unique_Defining_Entity (N);
Loc : constant Source_Ptr := Sloc (N);
-- Declarations used for the creation of _finalization_controller
Fin_Old_Id : Entity_Id := Empty;
Fin_Controller_Id : Entity_Id := Empty;
Fin_Controller_Decls : List_Id;
Fin_Controller_Stmts : List_Id;
Fin_Controller_Body : Node_Id := Empty;
Fin_Controller_Spec : Node_Id := Empty;
Postconditions_Call : Node_Id := Empty;
-- Defining identifiers for local objects used to store exception info
Raised_Post_Exception_Id : Entity_Id := Empty;
Raised_Finalization_Exception_Id : Entity_Id := Empty;
Saved_Exception_Id : Entity_Id := Empty;
-- Start of processing for Build_Finalizer
begin
-- Create the general finalization routine
Build_Finalizer_Helper
(N => N,
Clean_Stmts => Clean_Stmts,
Mark_Id => Mark_Id,
Top_Decls => Top_Decls,
Defer_Abort => Defer_Abort,
Fin_Id => Fin_Id,
Finalize_Old_Only => False);
-- When postconditions are present, expansion gets much more complicated
-- due to both the fact that they must be called after finalization and
-- that finalization of 'Old objects must occur after the postconditions
-- get checked.
-- Additionally, exceptions between general finalization and 'Old
-- finalization must be propagated correctly and exceptions which happen
-- during _postconditions need to be saved and reraised after
-- finalization of 'Old objects.
-- Generate:
--
-- Postcond_Enabled := False;
--
-- procedure _finalization_controller is
--
-- -- Exception capturing and tracking
--
-- Saved_Exception : Exception_Occurrence;
-- Raised_Post_Exception : Boolean := False;
-- Raised_Finalization_Exception : Boolean := False;
--
-- -- Start of processing for _finalization_controller
--
-- begin
-- -- Perform general finalization
--
-- begin
-- _finalizer;
-- exception
-- when others =>
-- -- Save the exception
--
-- Raised_Finalization_Exception := True;
-- Save_Occurrence
-- (Saved_Exception, Get_Current_Excep.all);
-- end;
--
-- -- Perform postcondition checks after general finalization, but
-- -- before finalization of 'Old related objects.
--
-- if not Raised_Finalization_Exception
-- and then Return_Success_For_Postcond
-- then
-- begin
-- -- Re-enable postconditions and check them
--
-- Postcond_Enabled := True;
-- _postconditions [(Result_Obj_For_Postcond[.all])];
-- exception
-- when others =>
-- -- Save the exception
--
-- Raised_Post_Exception := True;
-- Save_Occurrence
-- (Saved_Exception, Get_Current_Excep.all);
-- end;
-- end if;
--
-- -- Finally finalize 'Old related objects
--
-- begin
-- _finalizer_old;
-- exception
-- when others =>
-- -- Reraise the previous finalization error if there is
-- -- one.
--
-- if Raised_Finalization_Exception then
-- Reraise_Occurrence (Saved_Exception);
-- end if;
--
-- -- Otherwise, reraise the current one
--
-- raise;
-- end;
--
-- -- Reraise any saved exception
--
-- if Raised_Finalization_Exception
-- or else Raised_Post_Exception
-- then
-- Reraise_Occurrence (Saved_Exception);
-- end if;
-- end _finalization_controller;
if Nkind (N) = N_Subprogram_Body
and then Present (Postconditions_Proc (Def_Ent))
then
Fin_Controller_Stmts := New_List;
Fin_Controller_Decls := New_List;
-- Build the 'Old finalizer
Build_Finalizer_Helper
(N => N,
Clean_Stmts => Empty_List,
Mark_Id => Mark_Id,
Top_Decls => Top_Decls,
Defer_Abort => Defer_Abort,
Fin_Id => Fin_Old_Id,
Finalize_Old_Only => True);
-- Create local declarations for _finalization_controller needed for
-- saving exceptions.
--
-- Generate:
--
-- Saved_Exception : Exception_Occurrence;
-- Raised_Post_Exception : Boolean := False;
-- Raised_Finalization_Exception : Boolean := False;
Saved_Exception_Id := Make_Temporary (Loc, 'S');
Raised_Post_Exception_Id := Make_Temporary (Loc, 'P');
Raised_Finalization_Exception_Id := Make_Temporary (Loc, 'F');
Append_List_To (Fin_Controller_Decls, New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Saved_Exception_Id,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)),
Make_Object_Declaration (Loc,
Defining_Identifier => Raised_Post_Exception_Id,
Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
Expression => New_Occurrence_Of (Standard_False, Loc)),
Make_Object_Declaration (Loc,
Defining_Identifier => Raised_Finalization_Exception_Id,
Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
Expression => New_Occurrence_Of (Standard_False, Loc))));
-- Call _finalizer and save any exceptions which occur
-- Generate:
--
-- begin
-- _finalizer;
-- exception
-- when others =>
-- Raised_Finalization_Exception := True;
-- Save_Occurrence
-- (Saved_Exception, Get_Current_Excep.all);
-- end;
if Present (Fin_Id) then
Append_To (Fin_Controller_Stmts,
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Fin_Id, Loc))),
Exception_Handlers => New_List (
Make_Exception_Handler (Loc,
Exception_Choices => New_List (
Make_Others_Choice (Loc)),
Statements => New_List (
Make_Assignment_Statement (Loc,
Name =>
New_Occurrence_Of
(Raised_Finalization_Exception_Id, Loc),
Expression =>
New_Occurrence_Of (Standard_True, Loc)),
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of
(RTE (RE_Save_Occurrence), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of
(Saved_Exception_Id, Loc),
Make_Explicit_Dereference (Loc,
Prefix =>
Make_Function_Call (Loc,
Name =>
Make_Explicit_Dereference (Loc,
Prefix =>
New_Occurrence_Of
(RTE (RE_Get_Current_Excep),
Loc))))))))))));
end if;
-- Create the call to postconditions based on the kind of the current
-- subprogram, and the type of the Result_Obj_For_Postcond.
-- Generate:
--
-- _postconditions (Result_Obj_For_Postcond[.all]);
--
-- or
--
-- _postconditions;
if Ekind (Def_Ent) = E_Procedure then
Postconditions_Call :=
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of
(Postconditions_Proc (Def_Ent), Loc));
else
Postconditions_Call :=
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of
(Postconditions_Proc (Def_Ent), Loc),
Parameter_Associations => New_List (
(if Is_Elementary_Type (Etype (Def_Ent)) then
New_Occurrence_Of
(Get_Result_Object_For_Postcond
(Def_Ent), Loc)
else
Make_Explicit_Dereference (Loc,
New_Occurrence_Of
(Get_Result_Object_For_Postcond
(Def_Ent), Loc)))));
end if;
-- Call _postconditions when no general finalization exceptions have
-- occurred taking care to enable the postconditions and save any
-- exception occurrences.
-- Generate:
--
-- if not Raised_Finalization_Exception
-- and then Return_Success_For_Postcond
-- then
-- begin
-- Postcond_Enabled := True;
-- _postconditions [(Result_Obj_For_Postcond[.all])];
-- exception
-- when others =>
-- Raised_Post_Exception := True;
-- Save_Occurrence
-- (Saved_Exception, Get_Current_Excep.all);
-- end;
-- end if;
Append_To (Fin_Controller_Stmts,
Make_If_Statement (Loc,
Condition =>
Make_And_Then (Loc,
Left_Opnd =>
Make_Op_Not (Loc,
Right_Opnd =>
New_Occurrence_Of
(Raised_Finalization_Exception_Id, Loc)),
Right_Opnd =>
New_Occurrence_Of
(Get_Return_Success_For_Postcond (Def_Ent), Loc)),
Then_Statements => New_List (
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Assignment_Statement (Loc,
Name =>
New_Occurrence_Of
(Get_Postcond_Enabled (Def_Ent), Loc),
Expression =>
New_Occurrence_Of
(Standard_True, Loc)),
Postconditions_Call),
Exception_Handlers => New_List (
Make_Exception_Handler (Loc,
Exception_Choices => New_List (
Make_Others_Choice (Loc)),
Statements => New_List (
Make_Assignment_Statement (Loc,
Name =>
New_Occurrence_Of
(Raised_Post_Exception_Id, Loc),
Expression =>
New_Occurrence_Of (Standard_True, Loc)),
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of
(RTE (RE_Save_Occurrence), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of
(Saved_Exception_Id, Loc),
Make_Explicit_Dereference (Loc,
Prefix =>
Make_Function_Call (Loc,
Name =>
Make_Explicit_Dereference (Loc,
Prefix =>
New_Occurrence_Of
(RTE (RE_Get_Current_Excep),
Loc))))))))))))));
-- Call _finalizer_old and reraise any exception that occurred during
-- initial finalization within the exception handler. Otherwise,
-- propagate the current exception.
-- Generate:
--
-- begin
-- _finalizer_old;
-- exception
-- when others =>
-- if Raised_Finalization_Exception then
-- Reraise_Occurrence (Saved_Exception);
-- end if;
-- raise;
-- end;
if Present (Fin_Old_Id) then
Append_To (Fin_Controller_Stmts,
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Fin_Old_Id, Loc))),
Exception_Handlers => New_List (
Make_Exception_Handler (Loc,
Exception_Choices => New_List (
Make_Others_Choice (Loc)),
Statements => New_List (
Make_If_Statement (Loc,
Condition =>
New_Occurrence_Of
(Raised_Finalization_Exception_Id, Loc),
Then_Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of
(RTE (RE_Reraise_Occurrence), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of
(Saved_Exception_Id, Loc))))),
Make_Raise_Statement (Loc)))))));
end if;
-- Once finalization is complete reraise any pending exceptions
-- Generate:
--
-- if Raised_Post_Exception
-- or else Raised_Finalization_Exception
-- then
-- Reraise_Occurrence (Saved_Exception);
-- end if;
Append_To (Fin_Controller_Stmts,
Make_If_Statement (Loc,
Condition =>
Make_Or_Else (Loc,
Left_Opnd =>
New_Occurrence_Of
(Raised_Post_Exception_Id, Loc),
Right_Opnd =>
New_Occurrence_Of
(Raised_Finalization_Exception_Id, Loc)),
Then_Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of
(Saved_Exception_Id, Loc))))));
-- Make the finalization controller subprogram body and declaration.
-- Generate:
-- procedure _finalization_controller;
--
-- procedure _finalization_controller is
-- begin
-- [Fin_Controller_Stmts];
-- end;
Fin_Controller_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Name_uFinalization_Controller));
Fin_Controller_Spec :=
Make_Subprogram_Declaration (Loc,
Specification =>
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Fin_Controller_Id));
Fin_Controller_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Procedure_Specification (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Chars (Fin_Controller_Id))),
Declarations => Fin_Controller_Decls,
Handled_Statement_Sequence =>