gcc/ada/exp_ch7.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              E X P _ C H 7                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 --  This package contains virtually all expansion mechanisms related to
  27 --    - controlled types
  28 --    - transient scopes
  29
  30 with Atree;    use Atree;
  31 with Debug;    use Debug;
  32 with Einfo;    use Einfo;
  33 with Elists;   use Elists;
  34 with Errout;   use Errout;
  35 with Exp_Ch6;  use Exp_Ch6;
  36 with Exp_Ch9;  use Exp_Ch9;
  37 with Exp_Ch11; use Exp_Ch11;
  38 with Exp_Dbug; use Exp_Dbug;
  39 with Exp_Dist; use Exp_Dist;
  40 with Exp_Disp; use Exp_Disp;
  41 with Exp_Tss;  use Exp_Tss;
  42 with Exp_Util; use Exp_Util;
  43 with Freeze;   use Freeze;
  44 with Lib;      use Lib;
  45 with Nlists;   use Nlists;
  46 with Nmake;    use Nmake;
  47 with Opt;      use Opt;
  48 with Output;   use Output;
  49 with Restrict; use Restrict;
  50 with Rident;   use Rident;
  51 with Rtsfind;  use Rtsfind;
  52 with Sinfo;    use Sinfo;
  53 with Sem;      use Sem;
  54 with Sem_Aux;  use Sem_Aux;
  55 with Sem_Ch3;  use Sem_Ch3;
  56 with Sem_Ch7;  use Sem_Ch7;
  57 with Sem_Ch8;  use Sem_Ch8;
  58 with Sem_Res;  use Sem_Res;
  59 with Sem_Util; use Sem_Util;
  60 with Snames;   use Snames;
  61 with Stand;    use Stand;
  62 with Targparm; use Targparm;
  63 with Tbuild;   use Tbuild;
  64 with Ttypes;   use Ttypes;
  65 with Uintp;    use Uintp;
  66
  67 package body Exp_Ch7 is
  68
  69    --------------------------------
  70    -- Transient Scope Management --
  71    --------------------------------
  72
  73    --  A transient scope is created when temporary objects are created by the
  74    --  compiler. These temporary objects are allocated on the secondary stack
  75    --  and the transient scope is responsible for finalizing the object when
  76    --  appropriate and reclaiming the memory at the right time. The temporary
  77    --  objects are generally the objects allocated to store the result of a
  78    --  function returning an unconstrained or a tagged value. Expressions
  79    --  needing to be wrapped in a transient scope (functions calls returning
  80    --  unconstrained or tagged values) may appear in 3 different contexts which
  81    --  lead to 3 different kinds of transient scope expansion:
  82
  83    --   1. In a simple statement (procedure call, assignment, ...). In this
  84    --      case the instruction is wrapped into a transient block. See
  85    --      Wrap_Transient_Statement for details.
  86
  87    --   2. In an expression of a control structure (test in a IF statement,
  88    --      expression in a CASE statement, ...). See Wrap_Transient_Expression
  89    --      for details.
  90
  91    --   3. In a expression of an object_declaration. No wrapping is possible
  92    --      here, so the finalization actions, if any, are done right after the
  93    --      declaration and the secondary stack deallocation is done in the
  94    --      proper enclosing scope. See Wrap_Transient_Declaration for details.
  95
  96    --  Note about functions returning tagged types: it has been decided to
  97    --  always allocate their result in the secondary stack, even though is not
  98    --  absolutely mandatory when the tagged type is constrained because the
  99    --  caller knows the size of the returned object and thus could allocate the
 100    --  result in the primary stack. An exception to this is when the function
 101    --  builds its result in place, as is done for functions with inherently
 102    --  limited result types for Ada 2005. In that case, certain callers may
 103    --  pass the address of a constrained object as the target object for the
 104    --  function result.
 105
 106    --  By allocating tagged results in the secondary stack a number of
 107    --  implementation difficulties are avoided:
 108
 109    --    - If it is a dispatching function call, the computation of the size of
 110    --      the result is possible but complex from the outside.
 111
 112    --    - If the returned type is controlled, the assignment of the returned
 113    --      value to the anonymous object involves an Adjust, and we have no
 114    --      easy way to access the anonymous object created by the back end.
 115
 116    --    - If the returned type is class-wide, this is an unconstrained type
 117    --      anyway.
 118
 119    --  Furthermore, the small loss in efficiency which is the result of this
 120    --  decision is not such a big deal because functions returning tagged types
 121    --  are not as common in practice compared to functions returning access to
 122    --  a tagged type.
 123
 124    --------------------------------------------------
 125    -- Transient Blocks and Finalization Management --
 126    --------------------------------------------------
 127
 128    function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id;
 129    --  N is a node which may generate a transient scope. Loop over the parent
 130    --  pointers of N until it find the appropriate node to wrap. If it returns
 131    --  Empty, it means that no transient scope is needed in this context.
 132
 133    procedure Insert_Actions_In_Scope_Around (N : Node_Id);
 134    --  Insert the before-actions kept in the scope stack before N, and the
 135    --  after-actions after N, which must be a member of a list.
 136
 137    function Make_Transient_Block
 138      (Loc    : Source_Ptr;
 139       Action : Node_Id;
 140       Par    : Node_Id) return Node_Id;
 141    --  Action is a single statement or object declaration. Par is the proper
 142    --  parent of the generated block. Create a transient block whose name is
 143    --  the current scope and the only handled statement is Action. If Action
 144    --  involves controlled objects or secondary stack usage, the corresponding
 145    --  cleanup actions are performed at the end of the block.
 146
 147    procedure Set_Node_To_Be_Wrapped (N : Node_Id);
 148    --  Set the field Node_To_Be_Wrapped of the current scope
 149
 150    --  ??? The entire comment needs to be rewritten
 151
 152    -----------------------------
 153    -- Finalization Management --
 154    -----------------------------
 155
 156    --  This part describe how Initialization/Adjustment/Finalization procedures
 157    --  are generated and called. Two cases must be considered, types that are
 158    --  Controlled (Is_Controlled flag set) and composite types that contain
 159    --  controlled components (Has_Controlled_Component flag set). In the first
 160    --  case the procedures to call are the user-defined primitive operations
 161    --  Initialize/Adjust/Finalize. In the second case, GNAT generates
 162    --  Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge
 163    --  of calling the former procedures on the controlled components.
 164
 165    --  For records with Has_Controlled_Component set, a hidden "controller"
 166    --  component is inserted. This controller component contains its own
 167    --  finalization list on which all controlled components are attached
 168    --  creating an indirection on the upper-level Finalization list. This
 169    --  technique facilitates the management of objects whose number of
 170    --  controlled components changes during execution. This controller
 171    --  component is itself controlled and is attached to the upper-level
 172    --  finalization chain. Its adjust primitive is in charge of calling adjust
 173    --  on the components and adjusting the finalization pointer to match their
 174    --  new location (see a-finali.adb).
 175
 176    --  It is not possible to use a similar technique for arrays that have
 177    --  Has_Controlled_Component set. In this case, deep procedures are
 178    --  generated that call initialize/adjust/finalize + attachment or
 179    --  detachment on the finalization list for all component.
 180
 181    --  Initialize calls: they are generated for declarations or dynamic
 182    --  allocations of Controlled objects with no initial value. They are always
 183    --  followed by an attachment to the current Finalization Chain. For the
 184    --  dynamic allocation case this the chain attached to the scope of the
 185    --  access type definition otherwise, this is the chain of the current
 186    --  scope.
 187
 188    --  Adjust Calls: They are generated on 2 occasions: (1) for declarations
 189    --  or dynamic allocations of Controlled objects with an initial value.
 190    --  (2) after an assignment. In the first case they are followed by an
 191    --  attachment to the final chain, in the second case they are not.
 192
 193    --  Finalization Calls: They are generated on (1) scope exit, (2)
 194    --  assignments, (3) unchecked deallocations. In case (3) they have to
 195    --  be detached from the final chain, in case (2) they must not and in
 196    --  case (1) this is not important since we are exiting the scope anyway.
 197
 198    --  Other details:
 199
 200    --    Type extensions will have a new record controller at each derivation
 201    --    level containing controlled components. The record controller for
 202    --    the parent/ancestor is attached to the finalization list of the
 203    --    extension's record controller (i.e. the parent is like a component
 204    --    of the extension).
 205
 206    --    For types that are both Is_Controlled and Has_Controlled_Components,
 207    --    the record controller and the object itself are handled separately.
 208    --    It could seem simpler to attach the object at the end of its record
 209    --    controller but this would not tackle view conversions properly.
 210
 211    --    A classwide type can always potentially have controlled components
 212    --    but the record controller of the corresponding actual type may not
 213    --    be known at compile time so the dispatch table contains a special
 214    --    field that allows to compute the offset of the record controller
 215    --    dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
 216
 217    --  Here is a simple example of the expansion of a controlled block :
 218
 219    --    declare
 220    --       X : Controlled;
 221    --       Y : Controlled := Init;
 222    --
 223    --       type R is record
 224    --          C : Controlled;
 225    --       end record;
 226    --       W : R;
 227    --       Z : R := (C => X);
 228
 229    --    begin
 230    --       X := Y;
 231    --       W := Z;
 232    --    end;
 233    --
 234    --  is expanded into
 235    --
 236    --    declare
 237    --       _L : System.FI.Finalizable_Ptr;
 238
 239    --       procedure _Clean is
 240    --       begin
 241    --          Abort_Defer;
 242    --          System.FI.Finalize_List (_L);
 243    --          Abort_Undefer;
 244    --       end _Clean;
 245
 246    --       X : Controlled;
 247    --       begin
 248    --          Abort_Defer;
 249    --          Initialize (X);
 250    --          Attach_To_Final_List (_L, Finalizable (X), 1);
 251    --       at end: Abort_Undefer;
 252    --       Y : Controlled := Init;
 253    --       Adjust (Y);
 254    --       Attach_To_Final_List (_L, Finalizable (Y), 1);
 255    --
 256    --       type R is record
 257    --          C : Controlled;
 258    --       end record;
 259    --       W : R;
 260    --       begin
 261    --          Abort_Defer;
 262    --          Deep_Initialize (W, _L, 1);
 263    --       at end: Abort_Under;
 264    --       Z : R := (C => X);
 265    --       Deep_Adjust (Z, _L, 1);
 266
 267    --    begin
 268    --       _Assign (X, Y);
 269    --       Deep_Finalize (W, False);
 270    --       <save W's final pointers>
 271    --       W := Z;
 272    --       <restore W's final pointers>
 273    --       Deep_Adjust (W, _L, 0);
 274    --    at end
 275    --       _Clean;
 276    --    end;
 277
 278    type Final_Primitives is
 279      (Initialize_Case, Adjust_Case, Finalize_Case, Address_Case);
 280    --  This enumeration type is defined in order to ease sharing code for
 281    --  building finalization procedures for composite types.
 282
 283    Name_Of      : constant array (Final_Primitives) of Name_Id :=
 284                     (Initialize_Case => Name_Initialize,
 285                      Adjust_Case     => Name_Adjust,
 286                      Finalize_Case   => Name_Finalize,
 287                      Address_Case    => Name_Finalize_Address);
 288    Deep_Name_Of : constant array (Final_Primitives) of TSS_Name_Type :=
 289                     (Initialize_Case => TSS_Deep_Initialize,
 290                      Adjust_Case     => TSS_Deep_Adjust,
 291                      Finalize_Case   => TSS_Deep_Finalize,
 292                      Address_Case    => TSS_Finalize_Address);
 293
 294    procedure Build_Array_Deep_Procs (Typ : Entity_Id);
 295    --  Build the deep Initialize/Adjust/Finalize for a record Typ with
 296    --  Has_Controlled_Component set and store them using the TSS mechanism.
 297
 298    function Build_Cleanup_Statements (N : Node_Id) return List_Id;
 299    --  Create the clean up calls for an asynchronous call block, task master,
 300    --  protected subprogram body, task allocation block or task body. If the
 301    --  context does not contain the above constructs, the routine returns an
 302    --  empty list.
 303
 304    procedure Build_Finalizer
 305      (N           : Node_Id;
 306       Clean_Stmts : List_Id;
 307       Mark_Id     : Entity_Id;
 308       Top_Decls   : List_Id;
 309       Defer_Abort : Boolean;
 310       Fin_Id      : out Entity_Id);
 311    --  N may denote an accept statement, block, entry body, package body,
 312    --  package spec, protected body, subprogram body, and a task body. Create
 313    --  a procedure which contains finalization calls for all controlled objects
 314    --  declared in the declarative or statement region of N. The calls are
 315    --  built in reverse order relative to the original declarations. In the
 316    --  case of a tack body, the routine delays the creation of the finalizer
 317    --  until all statements have been moved to the task body procedure.
 318    --  Clean_Stmts may contain additional context-dependent code used to abort
 319    --  asynchronous calls or complete tasks (see Build_Cleanup_Statements).
 320    --  Mark_Id is the secondary stack used in the current context or Empty if
 321    --  missing. Top_Decls is the list on which the declaration of the finalizer
 322    --  is attached in the non-package case. Defer_Abort indicates that the
 323    --  statements passed in perform actions that require abort to be deferred,
 324    --  such as for task termination. Fin_Id is the finalizer declaration
 325    --  entity.
 326
 327    procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id);
 328    --  N is a construct which contains a handled sequence of statements, Fin_Id
 329    --  is the entity of a finalizer. Create an At_End handler which covers the
 330    --  statements of N and calls Fin_Id. If the handled statement sequence has
 331    --  an exception handler, the statements will be wrapped in a block to avoid
 332    --  unwanted interaction with the new At_End handler.
 333
 334    procedure Build_Record_Deep_Procs (Typ : Entity_Id);
 335    --  Build the deep Initialize/Adjust/Finalize for a record Typ with
 336    --  Has_Component_Component set and store them using the TSS mechanism.
 337
 338    procedure Check_Visibly_Controlled
 339      (Prim : Final_Primitives;
 340       Typ  : Entity_Id;
 341       E    : in out Entity_Id;
 342       Cref : in out Node_Id);
 343    --  The controlled operation declared for a derived type may not be
 344    --  overriding, if the controlled operations of the parent type are hidden,
 345    --  for example when the parent is a private type whose full view is
 346    --  controlled. For other primitive operations we modify the name of the
 347    --  operation to indicate that it is not overriding, but this is not
 348    --  possible for Initialize, etc. because they have to be retrievable by
 349    --  name. Before generating the proper call to one of these operations we
 350    --  check whether Typ is known to be controlled at the point of definition.
 351    --  If it is not then we must retrieve the hidden operation of the parent
 352    --  and use it instead.  This is one case that might be solved more cleanly
 353    --  once Overriding pragmas or declarations are in place.
 354
 355    function Convert_View
 356      (Proc : Entity_Id;
 357       Arg  : Node_Id;
 358       Ind  : Pos := 1) return Node_Id;
 359    --  Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
 360    --  argument being passed to it. Ind indicates which formal of procedure
 361    --  Proc we are trying to match. This function will, if necessary, generate
 362    --  a conversion between the partial and full view of Arg to match the type
 363    --  of the formal of Proc, or force a conversion to the class-wide type in
 364    --  the case where the operation is abstract.
 365
 366    function Enclosing_Function (E : Entity_Id) return Entity_Id;
 367    --  Given an arbitrary entity, traverse the scope chain looking for the
 368    --  first enclosing function. Return Empty if no function was found.
 369
 370    function Make_Call
 371      (Loc        : Source_Ptr;
 372       Proc_Id    : Entity_Id;
 373       Param      : Node_Id;
 374       For_Parent : Boolean := False) return Node_Id;
 375    --  Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
 376    --  routine [Deep_]Adjust / Finalize and an object parameter, create an
 377    --  adjust / finalization call. Flag For_Parent should be set when field
 378    --  _parent is being processed.
 379
 380    function Make_Deep_Proc
 381      (Prim  : Final_Primitives;
 382       Typ   : Entity_Id;
 383       Stmts : List_Id) return Node_Id;
 384    --  This function generates the tree for Deep_Initialize, Deep_Adjust or
 385    --  Deep_Finalize procedures according to the first parameter, these
 386    --  procedures operate on the type Typ. The Stmts parameter gives the body
 387    --  of the procedure.
 388
 389    function Make_Deep_Array_Body
 390      (Prim : Final_Primitives;
 391       Typ  : Entity_Id) return List_Id;
 392    --  This function generates the list of statements for implementing
 393    --  Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
 394    --  the first parameter, these procedures operate on the array type Typ.
 395
 396    function Make_Deep_Record_Body
 397      (Prim     : Final_Primitives;
 398       Typ      : Entity_Id;
 399       Is_Local : Boolean := False) return List_Id;
 400    --  This function generates the list of statements for implementing
 401    --  Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
 402    --  the first parameter, these procedures operate on the record type Typ.
 403    --  Flag Is_Local is used in conjunction with Deep_Finalize to designate
 404    --  whether the inner logic should be dictated by state counters.
 405
 406    function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id;
 407    --  Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
 408    --  Make_Deep_Record_Body. Generate the following statements:
 409    --
 410    --    declare
 411    --       type Acc_Typ is access all Typ;
 412    --       for Acc_Typ'Storage_Size use 0;
 413    --    begin
 414    --       [Deep_]Finalize (Acc_Typ (V).all);
 415    --    end;
 416
 417    ----------------------------
 418    -- Build_Array_Deep_Procs --
 419    ----------------------------
 420
 421    procedure Build_Array_Deep_Procs (Typ : Entity_Id) is
 422    begin
 423       Set_TSS (Typ,
 424         Make_Deep_Proc
 425           (Prim  => Initialize_Case,
 426            Typ   => Typ,
 427            Stmts => Make_Deep_Array_Body (Initialize_Case, Typ)));
 428
 429       if not Is_Immutably_Limited_Type (Typ) then
 430          Set_TSS (Typ,
 431            Make_Deep_Proc
 432              (Prim  => Adjust_Case,
 433               Typ   => Typ,
 434               Stmts => Make_Deep_Array_Body (Adjust_Case, Typ)));
 435       end if;
 436
 437       --  Do not generate Deep_Finalize and Finalize_Address if finalization is
 438       --  suppressed since these routine will not be used.
 439
 440       if not Restriction_Active (No_Finalization) then
 441          Set_TSS (Typ,
 442            Make_Deep_Proc
 443              (Prim  => Finalize_Case,
 444               Typ   => Typ,
 445               Stmts => Make_Deep_Array_Body (Finalize_Case, Typ)));
 446
 447          --  Create TSS primitive Finalize_Address for non-VM targets. JVM and
 448          --  .NET do not support address arithmetic and unchecked conversions.
 449
 450          if VM_Target = No_VM then
 451             Set_TSS (Typ,
 452               Make_Deep_Proc
 453                 (Prim  => Address_Case,
 454                  Typ   => Typ,
 455                  Stmts => Make_Deep_Array_Body (Address_Case, Typ)));
 456          end if;
 457       end if;
 458    end Build_Array_Deep_Procs;
 459
 460    ------------------------------
 461    -- Build_Cleanup_Statements --
 462    ------------------------------
 463
 464    function Build_Cleanup_Statements (N : Node_Id) return List_Id is
 465       Is_Asynchronous_Call : constant Boolean :=
 466                                Nkind (N) = N_Block_Statement
 467                                  and then Is_Asynchronous_Call_Block (N);
 468       Is_Master            : constant Boolean :=
 469                                Nkind (N) /= N_Entry_Body
 470                                  and then Is_Task_Master (N);
 471       Is_Protected_Body    : constant Boolean :=
 472                                Nkind (N) = N_Subprogram_Body
 473                                  and then Is_Protected_Subprogram_Body (N);
 474       Is_Task_Allocation   : constant Boolean :=
 475                                Nkind (N) = N_Block_Statement
 476                                  and then Is_Task_Allocation_Block (N);
 477       Is_Task_Body         : constant Boolean :=
 478                                Nkind (Original_Node (N)) = N_Task_Body;
 479
 480       Loc   : constant Source_Ptr := Sloc (N);
 481       Stmts : constant List_Id    := New_List;
 482
 483    begin
 484       if Is_Task_Body then
 485          if Restricted_Profile then
 486             Append_To (Stmts,
 487               Build_Runtime_Call (Loc, RE_Complete_Restricted_Task));
 488          else
 489             Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Task));
 490          end if;
 491
 492       elsif Is_Master then
 493          if Restriction_Active (No_Task_Hierarchy) = False then
 494             Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Master));
 495          end if;
 496
 497       --  Add statements to unlock the protected object parameter and to
 498       --  undefer abort. If the context is a protected procedure and the object
 499       --  has entries, call the entry service routine.
 500
 501       --  NOTE: The generated code references _object, a parameter to the
 502       --  procedure.
 503
 504       elsif Is_Protected_Body then
 505          declare
 506             Spec      : constant Node_Id := Parent (Corresponding_Spec (N));
 507             Conc_Typ  : Entity_Id;
 508             Nam       : Node_Id;
 509             Param     : Node_Id;
 510             Param_Typ : Entity_Id;
 511
 512          begin
 513             --  Find the _object parameter representing the protected object
 514
 515             Param := First (Parameter_Specifications (Spec));
 516             loop
 517                Param_Typ := Etype (Parameter_Type (Param));
 518
 519                if Ekind (Param_Typ) = E_Record_Type then
 520                   Conc_Typ := Corresponding_Concurrent_Type (Param_Typ);
 521                end if;
 522
 523                exit when No (Param) or else Present (Conc_Typ);
 524                Next (Param);
 525             end loop;
 526
 527             pragma Assert (Present (Param));
 528
 529             --  If the associated protected object has entries, a protected
 530             --  procedure has to service entry queues. In this case generate:
 531
 532             --    Service_Entries (_object._object'Access);
 533
 534             if Nkind (Specification (N)) = N_Procedure_Specification
 535               and then Has_Entries (Conc_Typ)
 536             then
 537                case Corresponding_Runtime_Package (Conc_Typ) is
 538                   when System_Tasking_Protected_Objects_Entries =>
 539                      Nam := New_Reference_To (RTE (RE_Service_Entries), Loc);
 540
 541                   when System_Tasking_Protected_Objects_Single_Entry =>
 542                      Nam := New_Reference_To (RTE (RE_Service_Entry), Loc);
 543
 544                   when others =>
 545                      raise Program_Error;
 546                end case;
 547
 548                Append_To (Stmts,
 549                  Make_Procedure_Call_Statement (Loc,
 550                    Name                   => Nam,
 551                    Parameter_Associations => New_List (
 552                      Make_Attribute_Reference (Loc,
 553                        Prefix         =>
 554                          Make_Selected_Component (Loc,
 555                            Prefix        => New_Reference_To (
 556                              Defining_Identifier (Param), Loc),
 557                            Selector_Name =>
 558                              Make_Identifier (Loc, Name_uObject)),
 559                        Attribute_Name => Name_Unchecked_Access))));
 560
 561             else
 562                --  Generate:
 563                --    Unlock (_object._object'Access);
 564
 565                case Corresponding_Runtime_Package (Conc_Typ) is
 566                   when System_Tasking_Protected_Objects_Entries =>
 567                      Nam := New_Reference_To (RTE (RE_Unlock_Entries), Loc);
 568
 569                   when System_Tasking_Protected_Objects_Single_Entry =>
 570                      Nam := New_Reference_To (RTE (RE_Unlock_Entry), Loc);
 571
 572                   when System_Tasking_Protected_Objects =>
 573                      Nam := New_Reference_To (RTE (RE_Unlock), Loc);
 574
 575                   when others =>
 576                      raise Program_Error;
 577                end case;
 578
 579                Append_To (Stmts,
 580                  Make_Procedure_Call_Statement (Loc,
 581                    Name                   => Nam,
 582                    Parameter_Associations => New_List (
 583                      Make_Attribute_Reference (Loc,
 584                        Prefix         =>
 585                          Make_Selected_Component (Loc,
 586                            Prefix        =>
 587                              New_Reference_To
 588                                (Defining_Identifier (Param), Loc),
 589                            Selector_Name =>
 590                              Make_Identifier (Loc, Name_uObject)),
 591                        Attribute_Name => Name_Unchecked_Access))));
 592             end if;
 593
 594             --  Generate:
 595             --    Abort_Undefer;
 596
 597             if Abort_Allowed then
 598                Append_To (Stmts,
 599                  Make_Procedure_Call_Statement (Loc,
 600                    Name                   =>
 601                      New_Reference_To (RTE (RE_Abort_Undefer), Loc),
 602                    Parameter_Associations => Empty_List));
 603             end if;
 604          end;
 605
 606       --  Add a call to Expunge_Unactivated_Tasks for dynamically allocated
 607       --  tasks. Other unactivated tasks are completed by Complete_Task or
 608       --  Complete_Master.
 609
 610       --  NOTE: The generated code references _chain, a local object
 611
 612       elsif Is_Task_Allocation then
 613
 614          --  Generate:
 615          --     Expunge_Unactivated_Tasks (_chain);
 616
 617          --  where _chain is the list of tasks created by the allocator but not
 618          --  yet activated. This list will be empty unless the block completes
 619          --  abnormally.
 620
 621          Append_To (Stmts,
 622            Make_Procedure_Call_Statement (Loc,
 623              Name =>
 624                New_Reference_To
 625                  (RTE (RE_Expunge_Unactivated_Tasks), Loc),
 626              Parameter_Associations => New_List (
 627                New_Reference_To (Activation_Chain_Entity (N), Loc))));
 628
 629       --  Attempt to cancel an asynchronous entry call whenever the block which
 630       --  contains the abortable part is exited.
 631
 632       --  NOTE: The generated code references Cnn, a local object
 633
 634       elsif Is_Asynchronous_Call then
 635          declare
 636             Cancel_Param : constant Entity_Id :=
 637                              Entry_Cancel_Parameter (Entity (Identifier (N)));
 638
 639          begin
 640             --  If it is of type Communication_Block, this must be a protected
 641             --  entry call. Generate:
 642
 643             --    if Enqueued (Cancel_Param) then
 644             --       Cancel_Protected_Entry_Call (Cancel_Param);
 645             --    end if;
 646
 647             if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then
 648                Append_To (Stmts,
 649                  Make_If_Statement (Loc,
 650                    Condition =>
 651                      Make_Function_Call (Loc,
 652                        Name                   =>
 653                          New_Reference_To (RTE (RE_Enqueued), Loc),
 654                        Parameter_Associations => New_List (
 655                          New_Reference_To (Cancel_Param, Loc))),
 656
 657                    Then_Statements => New_List (
 658                      Make_Procedure_Call_Statement (Loc,
 659                        Name =>
 660                          New_Reference_To
 661                            (RTE (RE_Cancel_Protected_Entry_Call), Loc),
 662                          Parameter_Associations => New_List (
 663                            New_Reference_To (Cancel_Param, Loc))))));
 664
 665             --  Asynchronous delay, generate:
 666             --    Cancel_Async_Delay (Cancel_Param);
 667
 668             elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then
 669                Append_To (Stmts,
 670                  Make_Procedure_Call_Statement (Loc,
 671                    Name                   =>
 672                      New_Reference_To (RTE (RE_Cancel_Async_Delay), Loc),
 673                    Parameter_Associations => New_List (
 674                      Make_Attribute_Reference (Loc,
 675                        Prefix         =>
 676                          New_Reference_To (Cancel_Param, Loc),
 677                        Attribute_Name => Name_Unchecked_Access))));
 678
 679             --  Task entry call, generate:
 680             --    Cancel_Task_Entry_Call (Cancel_Param);
 681
 682             else
 683                Append_To (Stmts,
 684                  Make_Procedure_Call_Statement (Loc,
 685                    Name                   =>
 686                      New_Reference_To (RTE (RE_Cancel_Task_Entry_Call), Loc),
 687                    Parameter_Associations => New_List (
 688                      New_Reference_To (Cancel_Param, Loc))));
 689             end if;
 690          end;
 691       end if;
 692
 693       return Stmts;
 694    end Build_Cleanup_Statements;
 695
 696    -----------------------------
 697    -- Build_Controlling_Procs --
 698    -----------------------------
 699
 700    procedure Build_Controlling_Procs (Typ : Entity_Id) is
 701    begin
 702       if Is_Array_Type (Typ) then
 703          Build_Array_Deep_Procs (Typ);
 704       else pragma Assert (Is_Record_Type (Typ));
 705          Build_Record_Deep_Procs (Typ);
 706       end if;
 707    end Build_Controlling_Procs;
 708
 709    -----------------------------
 710    -- Build_Exception_Handler --
 711    -----------------------------
 712
 713    function Build_Exception_Handler
 714      (Data        : Finalization_Exception_Data;
 715       For_Library : Boolean := False) return Node_Id
 716    is
 717       Actuals      : List_Id;
 718       Proc_To_Call : Entity_Id;
 719
 720    begin
 721       pragma Assert (Present (Data.E_Id));
 722       pragma Assert (Present (Data.Raised_Id));
 723
 724       --  Generate:
 725       --    Get_Current_Excep.all.all
 726
 727       Actuals := New_List (
 728         Make_Explicit_Dereference (Data.Loc,
 729           Prefix =>
 730             Make_Function_Call (Data.Loc,
 731               Name =>
 732                 Make_Explicit_Dereference (Data.Loc,
 733                   Prefix =>
 734                     New_Reference_To (RTE (RE_Get_Current_Excep),
 735                                       Data.Loc)))));
 736
 737       if For_Library and then not Restricted_Profile then
 738          Proc_To_Call := RTE (RE_Save_Library_Occurrence);
 739
 740       else
 741          Proc_To_Call := RTE (RE_Save_Occurrence);
 742          Prepend_To (Actuals, New_Reference_To (Data.E_Id, Data.Loc));
 743       end if;
 744
 745       --  Generate:
 746       --    when others =>
 747       --       if not Raised_Id then
 748       --          Raised_Id := True;
 749
 750       --          Save_Occurrence (E_Id, Get_Current_Excep.all.all);
 751       --            or
 752       --          Save_Library_Occurrence (Get_Current_Excep.all.all);
 753       --       end if;
 754
 755       return
 756         Make_Exception_Handler (Data.Loc,
 757           Exception_Choices =>
 758             New_List (Make_Others_Choice (Data.Loc)),
 759           Statements => New_List (
 760             Make_If_Statement (Data.Loc,
 761               Condition       =>
 762                 Make_Op_Not (Data.Loc,
 763                   Right_Opnd => New_Reference_To (Data.Raised_Id, Data.Loc)),
 764
 765               Then_Statements => New_List (
 766                 Make_Assignment_Statement (Data.Loc,
 767                   Name       => New_Reference_To (Data.Raised_Id, Data.Loc),
 768                   Expression => New_Reference_To (Standard_True, Data.Loc)),
 769
 770                 Make_Procedure_Call_Statement (Data.Loc,
 771                   Name                   =>
 772                     New_Reference_To (Proc_To_Call, Data.Loc),
 773                   Parameter_Associations => Actuals)))));
 774    end Build_Exception_Handler;
 775
 776    -------------------------------
 777    -- Build_Finalization_Master --
 778    -------------------------------
 779
 780    procedure Build_Finalization_Master
 781      (Typ        : Entity_Id;
 782       Ins_Node   : Node_Id := Empty;
 783       Encl_Scope : Entity_Id := Empty)
 784    is
 785       Desig_Typ : constant Entity_Id := Directly_Designated_Type (Typ);
 786       Ptr_Typ   : Entity_Id := Root_Type (Base_Type (Typ));
 787
 788       function In_Deallocation_Instance (E : Entity_Id) return Boolean;
 789       --  Determine whether entity E is inside a wrapper package created for
 790       --  an instance of Ada.Unchecked_Deallocation.
 791
 792       ------------------------------
 793       -- In_Deallocation_Instance --
 794       ------------------------------
 795
 796       function In_Deallocation_Instance (E : Entity_Id) return Boolean is
 797          Pkg : constant Entity_Id := Scope (E);
 798          Par : Node_Id := Empty;
 799
 800       begin
 801          if Ekind (Pkg) = E_Package
 802            and then Present (Related_Instance (Pkg))
 803            and then Ekind (Related_Instance (Pkg)) = E_Procedure
 804          then
 805             Par := Generic_Parent (Parent (Related_Instance (Pkg)));
 806
 807             return
 808               Present (Par)
 809                 and then Chars (Par) = Name_Unchecked_Deallocation
 810                 and then Chars (Scope (Par)) = Name_Ada
 811                 and then Scope (Scope (Par)) = Standard_Standard;
 812          end if;
 813
 814          return False;
 815       end In_Deallocation_Instance;
 816
 817    --  Start of processing for Build_Finalization_Master
 818
 819    begin
 820       if Is_Private_Type (Ptr_Typ)
 821         and then Present (Full_View (Ptr_Typ))
 822       then
 823          Ptr_Typ := Full_View (Ptr_Typ);
 824       end if;
 825
 826       --  Certain run-time configurations and targets do not provide support
 827       --  for controlled types.
 828
 829       if Restriction_Active (No_Finalization) then
 830          return;
 831
 832       --  Do not process C, C++, CIL and Java types since it is assumend that
 833       --  the non-Ada side will handle their clean up.
 834
 835       elsif Convention (Desig_Typ) = Convention_C
 836         or else Convention (Desig_Typ) = Convention_CIL
 837         or else Convention (Desig_Typ) = Convention_CPP
 838         or else Convention (Desig_Typ) = Convention_Java
 839       then
 840          return;
 841
 842       --  Various machinery such as freezing may have already created a
 843       --  finalization master.
 844
 845       elsif Present (Finalization_Master (Ptr_Typ)) then
 846          return;
 847
 848       --  Do not process types that return on the secondary stack
 849
 850       elsif Present (Associated_Storage_Pool (Ptr_Typ))
 851         and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool)
 852       then
 853          return;
 854
 855       --  Do not process types which may never allocate an object
 856
 857       elsif No_Pool_Assigned (Ptr_Typ) then
 858          return;
 859
 860       --  Do not process access types coming from Ada.Unchecked_Deallocation
 861       --  instances. Even though the designated type may be controlled, the
 862       --  access type will never participate in allocation.
 863
 864       elsif In_Deallocation_Instance (Ptr_Typ) then
 865          return;
 866
 867       --  Ignore the general use of anonymous access types unless the context
 868       --  requires a finalization master.
 869
 870       elsif Ekind (Ptr_Typ) = E_Anonymous_Access_Type
 871         and then No (Ins_Node)
 872       then
 873          return;
 874
 875       --  Do not process non-library access types when restriction No_Nested_
 876       --  Finalization is in effect since masters are controlled objects.
 877
 878       elsif Restriction_Active (No_Nested_Finalization)
 879         and then not Is_Library_Level_Entity (Ptr_Typ)
 880       then
 881          return;
 882
 883       --  For .NET/JVM targets, allow the processing of access-to-controlled
 884       --  types where the designated type is explicitly derived from [Limited_]
 885       --  Controlled.
 886
 887       elsif VM_Target /= No_VM
 888         and then not Is_Controlled (Desig_Typ)
 889       then
 890          return;
 891
 892       --  Do not create finalization masters in Alfa mode because they result
 893       --  in unwanted expansion.
 894
 895       elsif Alfa_Mode then
 896          return;
 897       end if;
 898
 899       declare
 900          Loc        : constant Source_Ptr := Sloc (Ptr_Typ);
 901          Actions    : constant List_Id := New_List;
 902          Fin_Mas_Id : Entity_Id;
 903          Pool_Id    : Entity_Id;
 904
 905       begin
 906          --  Generate:
 907          --    Fnn : aliased Finalization_Master;
 908
 909          --  Source access types use fixed master names since the master is
 910          --  inserted in the same source unit only once. The only exception to
 911          --  this are instances using the same access type as generic actual.
 912
 913          if Comes_From_Source (Ptr_Typ)
 914            and then not Inside_A_Generic
 915          then
 916             Fin_Mas_Id :=
 917               Make_Defining_Identifier (Loc,
 918                 Chars => New_External_Name (Chars (Ptr_Typ), "FM"));
 919
 920          --  Internally generated access types use temporaries as their names
 921          --  due to possible collision with identical names coming from other
 922          --  packages.
 923
 924          else
 925             Fin_Mas_Id := Make_Temporary (Loc, 'F');
 926          end if;
 927
 928          Append_To (Actions,
 929            Make_Object_Declaration (Loc,
 930              Defining_Identifier => Fin_Mas_Id,
 931              Aliased_Present     => True,
 932              Object_Definition   =>
 933                New_Reference_To (RTE (RE_Finalization_Master), Loc)));
 934
 935          --  Storage pool selection and attribute decoration of the generated
 936          --  master. Since .NET/JVM compilers do not support pools, this step
 937          --  is skipped.
 938
 939          if VM_Target = No_VM then
 940
 941             --  If the access type has a user-defined pool, use it as the base
 942             --  storage medium for the finalization pool.
 943
 944             if Present (Associated_Storage_Pool (Ptr_Typ)) then
 945                Pool_Id := Associated_Storage_Pool (Ptr_Typ);
 946
 947             --  The default choice is the global pool
 948
 949             else
 950                Pool_Id := Get_Global_Pool_For_Access_Type (Ptr_Typ);
 951                Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
 952             end if;
 953
 954             --  Generate:
 955             --    Set_Base_Pool (Fnn, Pool_Id'Unchecked_Access);
 956
 957             Append_To (Actions,
 958               Make_Procedure_Call_Statement (Loc,
 959                 Name                   =>
 960                   New_Reference_To (RTE (RE_Set_Base_Pool), Loc),
 961                 Parameter_Associations => New_List (
 962                   New_Reference_To (Fin_Mas_Id, Loc),
 963                   Make_Attribute_Reference (Loc,
 964                     Prefix         => New_Reference_To (Pool_Id, Loc),
 965                     Attribute_Name => Name_Unrestricted_Access))));
 966          end if;
 967
 968          Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
 969
 970          --  A finalization master created for an anonymous access type must be
 971          --  inserted before a context-dependent node.
 972
 973          if Present (Ins_Node) then
 974             Push_Scope (Encl_Scope);
 975
 976             --  Treat use clauses as declarations and insert directly in front
 977             --  of them.
 978
 979             if Nkind_In (Ins_Node, N_Use_Package_Clause,
 980                                    N_Use_Type_Clause)
 981             then
 982                Insert_List_Before_And_Analyze (Ins_Node, Actions);
 983             else
 984                Insert_Actions (Ins_Node, Actions);
 985             end if;
 986
 987             Pop_Scope;
 988
 989          elsif Ekind (Desig_Typ) = E_Incomplete_Type
 990            and then Has_Completion_In_Body (Desig_Typ)
 991          then
 992             Insert_Actions (Parent (Ptr_Typ), Actions);
 993
 994          --  If the designated type is not yet frozen, then append the actions
 995          --  to that type's freeze actions. The actions need to be appended to
 996          --  whichever type is frozen later, similarly to what Freeze_Type does
 997          --  for appending the storage pool declaration for an access type.
 998          --  Otherwise, the call to Set_Storage_Pool_Ptr might reference the
 999          --  pool object before it's declared. However, it's not clear that
1000          --  this is exactly the right test to accomplish that here. ???
1001
1002          elsif Present (Freeze_Node (Desig_Typ))
1003            and then not Analyzed (Freeze_Node (Desig_Typ))
1004          then
1005             Append_Freeze_Actions (Desig_Typ, Actions);
1006
1007          elsif Present (Freeze_Node (Ptr_Typ))
1008            and then not Analyzed (Freeze_Node (Ptr_Typ))
1009          then
1010             Append_Freeze_Actions (Ptr_Typ, Actions);
1011
1012          --  If there's a pool created locally for the access type, then we
1013          --  need to ensure that the master gets created after the pool object,
1014          --  because otherwise we can have a forward reference, so we force the
1015          --  master actions to be inserted and analyzed after the pool entity.
1016          --  Note that both the access type and its designated type may have
1017          --  already been frozen and had their freezing actions analyzed at
1018          --  this point. (This seems a little unclean.???)
1019
1020          elsif VM_Target = No_VM
1021            and then Scope (Pool_Id) = Scope (Ptr_Typ)
1022          then
1023             Insert_List_After_And_Analyze (Parent (Pool_Id), Actions);
1024
1025          else
1026             Insert_Actions (Parent (Ptr_Typ), Actions);
1027          end if;
1028       end;
1029    end Build_Finalization_Master;
1030
1031    ---------------------
1032    -- Build_Finalizer --
1033    ---------------------
1034
1035    procedure Build_Finalizer
1036      (N           : Node_Id;
1037       Clean_Stmts : List_Id;
1038       Mark_Id     : Entity_Id;
1039       Top_Decls   : List_Id;
1040       Defer_Abort : Boolean;
1041       Fin_Id      : out Entity_Id)
1042    is
1043       Acts_As_Clean    : constant Boolean :=
1044                            Present (Mark_Id)
1045                              or else
1046                                (Present (Clean_Stmts)
1047                                  and then Is_Non_Empty_List (Clean_Stmts));
1048       Exceptions_OK    : constant Boolean :=
1049                            not Restriction_Active (No_Exception_Propagation);
1050       For_Package_Body : constant Boolean := Nkind (N) = N_Package_Body;
1051       For_Package_Spec : constant Boolean := Nkind (N) = N_Package_Declaration;
1052       For_Package      : constant Boolean :=
1053                            For_Package_Body or else For_Package_Spec;
1054       Loc              : constant Source_Ptr := Sloc (N);
1055
1056       --  NOTE: Local variable declarations are conservative and do not create
1057       --  structures right from the start. Entities and lists are created once
1058       --  it has been established that N has at least one controlled object.
1059
1060       Components_Built : Boolean := False;
1061       --  A flag used to avoid double initialization of entities and lists. If
1062       --  the flag is set then the following variables have been initialized:
1063       --    Counter_Id
1064       --    Finalizer_Decls
1065       --    Finalizer_Stmts
1066       --    Jump_Alts
1067
1068       Counter_Id  : Entity_Id := Empty;
1069       Counter_Val : Int       := 0;
1070       --  Name and value of the state counter
1071
1072       Decls : List_Id := No_List;
1073       --  Declarative region of N (if available). If N is a package declaration
1074       --  Decls denotes the visible declarations.
1075
1076       Finalizer_Data : Finalization_Exception_Data;
1077       --  Data for the exception
1078
1079       Finalizer_Decls : List_Id := No_List;
1080       --  Local variable declarations. This list holds the label declarations
1081       --  of all jump block alternatives as well as the declaration of the
1082       --  local exception occurence and the raised flag:
1083       --     E : Exception_Occurrence;
1084       --     Raised : Boolean := False;
1085       --     L<counter value> : label;
1086
1087       Finalizer_Insert_Nod : Node_Id := Empty;
1088       --  Insertion point for the finalizer body. Depending on the context
1089       --  (Nkind of N) and the individual grouping of controlled objects, this
1090       --  node may denote a package declaration or body, package instantiation,
1091       --  block statement or a counter update statement.
1092
1093       Finalizer_Stmts : List_Id := No_List;
1094       --  The statement list of the finalizer body. It contains the following:
1095       --
1096       --    Abort_Defer;               --  Added if abort is allowed
1097       --    <call to Prev_At_End>      --  Added if exists
1098       --    <cleanup statements>       --  Added if Acts_As_Clean
1099       --    <jump block>               --  Added if Has_Ctrl_Objs
1100       --    <finalization statements>  --  Added if Has_Ctrl_Objs
1101       --    <stack release>            --  Added if Mark_Id exists
1102       --    Abort_Undefer;             --  Added if abort is allowed
1103
1104       Has_Ctrl_Objs : Boolean := False;
1105       --  A general flag which denotes whether N has at least one controlled
1106       --  object.
1107
1108       Has_Tagged_Types : Boolean := False;
1109       --  A general flag which indicates whether N has at least one library-
1110       --  level tagged type declaration.
1111
1112       HSS : Node_Id := Empty;
1113       --  The sequence of statements of N (if available)
1114
1115       Jump_Alts : List_Id := No_List;
1116       --  Jump block alternatives. Depending on the value of the state counter,
1117       --  the control flow jumps to a sequence of finalization statements. This
1118       --  list contains the following:
1119       --
1120       --     when <counter value> =>
1121       --        goto L<counter value>;
1122
1123       Jump_Block_Insert_Nod : Node_Id := Empty;
1124       --  Specific point in the finalizer statements where the jump block is
1125       --  inserted.
1126
1127       Last_Top_Level_Ctrl_Construct : Node_Id := Empty;
1128       --  The last controlled construct encountered when processing the top
1129       --  level lists of N. This can be a nested package, an instantiation or
1130       --  an object declaration.
1131
1132       Prev_At_End : Entity_Id := Empty;
1133       --  The previous at end procedure of the handled statements block of N
1134
1135       Priv_Decls : List_Id := No_List;
1136       --  The private declarations of N if N is a package declaration
1137
1138       Spec_Id    : Entity_Id := Empty;
1139       Spec_Decls : List_Id   := Top_Decls;
1140       Stmts      : List_Id   := No_List;
1141
1142       Tagged_Type_Stmts : List_Id := No_List;
1143       --  Contains calls to Ada.Tags.Unregister_Tag for all library-level
1144       --  tagged types found in N.
1145
1146       -----------------------
1147       -- Local subprograms --
1148       -----------------------
1149
1150       procedure Build_Components;
1151       --  Create all entites and initialize all lists used in the creation of
1152       --  the finalizer.
1153
1154       procedure Create_Finalizer;
1155       --  Create the spec and body of the finalizer and insert them in the
1156       --  proper place in the tree depending on the context.
1157
1158       procedure Process_Declarations
1159         (Decls      : List_Id;
1160          Preprocess : Boolean := False;
1161          Top_Level  : Boolean := False);
1162       --  Inspect a list of declarations or statements which may contain
1163       --  objects that need finalization. When flag Preprocess is set, the
1164       --  routine will simply count the total number of controlled objects in
1165       --  Decls. Flag Top_Level denotes whether the processing is done for
1166       --  objects in nested package declarations or instances.
1167
1168       procedure Process_Object_Declaration
1169         (Decl         : Node_Id;
1170          Has_No_Init  : Boolean := False;
1171          Is_Protected : Boolean := False);
1172       --  Generate all the machinery associated with the finalization of a
1173       --  single object. Flag Has_No_Init is used to denote certain contexts
1174       --  where Decl does not have initialization call(s). Flag Is_Protected
1175       --  is set when Decl denotes a simple protected object.
1176
1177       procedure Process_Tagged_Type_Declaration (Decl : Node_Id);
1178       --  Generate all the code necessary to unregister the external tag of a
1179       --  tagged type.
1180
1181       ----------------------
1182       -- Build_Components --
1183       ----------------------
1184
1185       procedure Build_Components is
1186          Counter_Decl     : Node_Id;
1187          Counter_Typ      : Entity_Id;
1188          Counter_Typ_Decl : Node_Id;
1189
1190       begin
1191          pragma Assert (Present (Decls));
1192
1193          --  This routine might be invoked several times when dealing with
1194          --  constructs that have two lists (either two declarative regions
1195          --  or declarations and statements). Avoid double initialization.
1196
1197          if Components_Built then
1198             return;
1199          end if;
1200
1201          Components_Built := True;
1202
1203          if Has_Ctrl_Objs then
1204
1205             --  Create entities for the counter, its type, the local exception
1206             --  and the raised flag.
1207
1208             Counter_Id  := Make_Temporary (Loc, 'C');
1209             Counter_Typ := Make_Temporary (Loc, 'T');
1210
1211             Finalizer_Decls := New_List;
1212
1213             if Exceptions_OK then
1214                Build_Object_Declarations
1215                  (Finalizer_Data, Finalizer_Decls, Loc, For_Package);
1216             end if;
1217
1218             --  Since the total number of controlled objects is always known,
1219             --  build a subtype of Natural with precise bounds. This allows
1220             --  the backend to optimize the case statement. Generate:
1221             --
1222             --    subtype Tnn is Natural range 0 .. Counter_Val;
1223
1224             Counter_Typ_Decl :=
1225               Make_Subtype_Declaration (Loc,
1226                 Defining_Identifier => Counter_Typ,
1227                 Subtype_Indication  =>
1228                   Make_Subtype_Indication (Loc,
1229                     Subtype_Mark => New_Reference_To (Standard_Natural, Loc),
1230                     Constraint   =>
1231                       Make_Range_Constraint (Loc,
1232                         Range_Expression =>
1233                           Make_Range (Loc,
1234                             Low_Bound  =>
1235                               Make_Integer_Literal (Loc, Uint_0),
1236                             High_Bound =>
1237                               Make_Integer_Literal (Loc, Counter_Val)))));
1238
1239             --  Generate the declaration of the counter itself:
1240             --
1241             --    Counter : Integer := 0;
1242
1243             Counter_Decl :=
1244               Make_Object_Declaration (Loc,
1245                 Defining_Identifier => Counter_Id,
1246                 Object_Definition   => New_Reference_To (Counter_Typ, Loc),
1247                 Expression          => Make_Integer_Literal (Loc, 0));
1248
1249             --  Set the type of the counter explicitly to prevent errors when
1250             --  examining object declarations later on.
1251
1252             Set_Etype (Counter_Id, Counter_Typ);
1253
1254             --  The counter and its type are inserted before the source
1255             --  declarations of N.
1256
1257             Prepend_To (Decls, Counter_Decl);
1258             Prepend_To (Decls, Counter_Typ_Decl);
1259
1260             --  The counter and its associated type must be manually analized
1261             --  since N has already been analyzed. Use the scope of the spec
1262             --  when inserting in a package.
1263
1264             if For_Package then
1265                Push_Scope (Spec_Id);
1266                Analyze (Counter_Typ_Decl);
1267                Analyze (Counter_Decl);
1268                Pop_Scope;
1269
1270             else
1271                Analyze (Counter_Typ_Decl);
1272                Analyze (Counter_Decl);
1273             end if;
1274
1275             Jump_Alts := New_List;
1276          end if;
1277
1278          --  If the context requires additional clean up, the finalization
1279          --  machinery is added after the clean up code.
1280
1281          if Acts_As_Clean then
1282             Finalizer_Stmts       := Clean_Stmts;
1283             Jump_Block_Insert_Nod := Last (Finalizer_Stmts);
1284          else
1285             Finalizer_Stmts := New_List;
1286          end if;
1287
1288          if Has_Tagged_Types then
1289             Tagged_Type_Stmts := New_List;
1290          end if;
1291       end Build_Components;
1292
1293       ----------------------
1294       -- Create_Finalizer --
1295       ----------------------
1296
1297       procedure Create_Finalizer is
1298          Body_Id    : Entity_Id;
1299          Fin_Body   : Node_Id;
1300          Fin_Spec   : Node_Id;
1301          Jump_Block : Node_Id;
1302          Label      : Node_Id;
1303          Label_Id   : Entity_Id;
1304
1305          function New_Finalizer_Name return Name_Id;
1306          --  Create a fully qualified name of a package spec or body finalizer.
1307          --  The generated name is of the form: xx__yy__finalize_[spec|body].
1308
1309          ------------------------
1310          -- New_Finalizer_Name --
1311          ------------------------
1312
1313          function New_Finalizer_Name return Name_Id is
1314             procedure New_Finalizer_Name (Id : Entity_Id);
1315             --  Place "__<name-of-Id>" in the name buffer. If the identifier
1316             --  has a non-standard scope, process the scope first.
1317
1318             ------------------------
1319             -- New_Finalizer_Name --
1320             ------------------------
1321
1322             procedure New_Finalizer_Name (Id : Entity_Id) is
1323             begin
1324                if Scope (Id) = Standard_Standard then
1325                   Get_Name_String (Chars (Id));
1326
1327                else
1328                   New_Finalizer_Name (Scope (Id));
1329                   Add_Str_To_Name_Buffer ("__");
1330                   Add_Str_To_Name_Buffer (Get_Name_String (Chars (Id)));
1331                end if;
1332             end New_Finalizer_Name;
1333
1334          --  Start of processing for New_Finalizer_Name
1335
1336          begin
1337             --  Create the fully qualified name of the enclosing scope
1338
1339             New_Finalizer_Name (Spec_Id);
1340
1341             --  Generate:
1342             --    __finalize_[spec|body]
1343
1344             Add_Str_To_Name_Buffer ("__finalize_");
1345
1346             if For_Package_Spec then
1347                Add_Str_To_Name_Buffer ("spec");
1348             else
1349                Add_Str_To_Name_Buffer ("body");
1350             end if;
1351
1352             return Name_Find;
1353          end New_Finalizer_Name;
1354
1355       --  Start of processing for Create_Finalizer
1356
1357       begin
1358          --  Step 1: Creation of the finalizer name
1359
1360          --  Packages must use a distinct name for their finalizers since the
1361          --  binder will have to generate calls to them by name. The name is
1362          --  of the following form:
1363
1364          --    xx__yy__finalize_[spec|body]
1365
1366          if For_Package then
1367             Fin_Id := Make_Defining_Identifier (Loc, New_Finalizer_Name);
1368             Set_Has_Qualified_Name       (Fin_Id);
1369             Set_Has_Fully_Qualified_Name (Fin_Id);
1370
1371          --  The default name is _finalizer
1372
1373          else
1374             Fin_Id :=
1375               Make_Defining_Identifier (Loc,
1376                 Chars => New_External_Name (Name_uFinalizer));
1377          end if;
1378
1379          --  Step 2: Creation of the finalizer specification
1380
1381          --  Generate:
1382          --    procedure Fin_Id;
1383
1384          Fin_Spec :=
1385            Make_Subprogram_Declaration (Loc,
1386              Specification =>
1387                Make_Procedure_Specification (Loc,
1388                  Defining_Unit_Name => Fin_Id));
1389
1390          --  Step 3: Creation of the finalizer body
1391
1392          if Has_Ctrl_Objs then
1393
1394             --  Add L0, the default destination to the jump block
1395
1396             Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
1397             Set_Entity (Label_Id,
1398               Make_Defining_Identifier (Loc, Chars (Label_Id)));
1399             Label := Make_Label (Loc, Label_Id);
1400
1401             --  Generate:
1402             --    L0 : label;
1403
1404             Prepend_To (Finalizer_Decls,
1405               Make_Implicit_Label_Declaration (Loc,
1406                 Defining_Identifier => Entity (Label_Id),
1407                 Label_Construct     => Label));
1408
1409             --  Generate:
1410             --    when others =>
1411             --       goto L0;
1412
1413             Append_To (Jump_Alts,
1414               Make_Case_Statement_Alternative (Loc,
1415                 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1416                 Statements       => New_List (
1417                   Make_Goto_Statement (Loc,
1418                     Name => New_Reference_To (Entity (Label_Id), Loc)))));
1419
1420             --  Generate:
1421             --    <<L0>>
1422
1423             Append_To (Finalizer_Stmts, Label);
1424
1425             --  The local exception does not need to be reraised for library-
1426             --  level finalizers. Generate:
1427             --
1428             --    if Raised and then not Abort then
1429             --       Raise_From_Controlled_Operation (E);
1430             --    end if;
1431
1432             if not For_Package
1433               and then Exceptions_OK
1434             then
1435                Append_To (Finalizer_Stmts,
1436                  Build_Raise_Statement (Finalizer_Data));
1437             end if;
1438
1439             --  Create the jump block which controls the finalization flow
1440             --  depending on the value of the state counter.
1441
1442             Jump_Block :=
1443               Make_Case_Statement (Loc,
1444                 Expression   => Make_Identifier (Loc, Chars (Counter_Id)),
1445                 Alternatives => Jump_Alts);
1446
1447             if Acts_As_Clean
1448               and then Present (Jump_Block_Insert_Nod)
1449             then
1450                Insert_After (Jump_Block_Insert_Nod, Jump_Block);
1451             else
1452                Prepend_To (Finalizer_Stmts, Jump_Block);
1453             end if;
1454          end if;
1455
1456          --  Add the library-level tagged type unregistration machinery before
1457          --  the jump block circuitry. This ensures that external tags will be
1458          --  removed even if a finalization exception occurs at some point.
1459
1460          if Has_Tagged_Types then
1461             Prepend_List_To (Finalizer_Stmts, Tagged_Type_Stmts);
1462          end if;
1463
1464          --  Add a call to the previous At_End handler if it exists. The call
1465          --  must always precede the jump block.
1466
1467          if Present (Prev_At_End) then
1468             Prepend_To (Finalizer_Stmts,
1469               Make_Procedure_Call_Statement (Loc, Prev_At_End));
1470
1471             --  Clear the At_End handler since we have already generated the
1472             --  proper replacement call for it.
1473
1474             Set_At_End_Proc (HSS, Empty);
1475          end if;
1476
1477          --  Release the secondary stack mark
1478
1479          if Present (Mark_Id) then
1480             Append_To (Finalizer_Stmts,
1481               Make_Procedure_Call_Statement (Loc,
1482                 Name                   =>
1483                   New_Reference_To (RTE (RE_SS_Release), Loc),
1484                 Parameter_Associations => New_List (
1485                   New_Reference_To (Mark_Id, Loc))));
1486          end if;
1487
1488          --  Protect the statements with abort defer/undefer. This is only when
1489          --  aborts are allowed and the clean up statements require deferral or
1490          --  there are controlled objects to be finalized.
1491
1492          if Abort_Allowed
1493            and then
1494              (Defer_Abort or else Has_Ctrl_Objs)
1495          then
1496             Prepend_To (Finalizer_Stmts,
1497               Make_Procedure_Call_Statement (Loc,
1498                 Name => New_Reference_To (RTE (RE_Abort_Defer), Loc)));
1499
1500             Append_To (Finalizer_Stmts,
1501               Make_Procedure_Call_Statement (Loc,
1502                 Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)));
1503          end if;
1504
1505          --  Generate:
1506          --    procedure Fin_Id is
1507          --       Abort  : constant Boolean := Triggered_By_Abort;
1508          --         <or>
1509          --       Abort  : constant Boolean := False;  --  no abort
1510
1511          --       E      : Exception_Occurrence;  --  All added if flag
1512          --       Raised : Boolean := False;      --  Has_Ctrl_Objs is set
1513          --       L0     : label;
1514          --       ...
1515          --       Lnn    : label;
1516
1517          --    begin
1518          --       Abort_Defer;               --  Added if abort is allowed
1519          --       <call to Prev_At_End>      --  Added if exists
1520          --       <cleanup statements>       --  Added if Acts_As_Clean
1521          --       <jump block>               --  Added if Has_Ctrl_Objs
1522          --       <finalization statements>  --  Added if Has_Ctrl_Objs
1523          --       <stack release>            --  Added if Mark_Id exists
1524          --       Abort_Undefer;             --  Added if abort is allowed
1525          --    end Fin_Id;
1526
1527          --  Create the body of the finalizer
1528
1529          Body_Id := Make_Defining_Identifier (Loc, Chars (Fin_Id));
1530
1531          if For_Package then
1532             Set_Has_Qualified_Name       (Body_Id);
1533             Set_Has_Fully_Qualified_Name (Body_Id);
1534          end if;
1535
1536          Fin_Body :=
1537            Make_Subprogram_Body (Loc,
1538              Specification              =>
1539                Make_Procedure_Specification (Loc,
1540                  Defining_Unit_Name => Body_Id),
1541              Declarations               => Finalizer_Decls,
1542              Handled_Statement_Sequence =>
1543                Make_Handled_Sequence_Of_Statements (Loc, Finalizer_Stmts));
1544
1545          --  Step 4: Spec and body insertion, analysis
1546
1547          if For_Package then
1548
1549             --  If the package spec has private declarations, the finalizer
1550             --  body must be added to the end of the list in order to have
1551             --  visibility of all private controlled objects.
1552
1553             if For_Package_Spec then
1554                if Present (Priv_Decls) then
1555                   Append_To (Priv_Decls, Fin_Spec);
1556                   Append_To (Priv_Decls, Fin_Body);
1557                else
1558                   Append_To (Decls, Fin_Spec);
1559                   Append_To (Decls, Fin_Body);
1560                end if;
1561
1562             --  For package bodies, both the finalizer spec and body are
1563             --  inserted at the end of the package declarations.
1564
1565             else
1566                Append_To (Decls, Fin_Spec);
1567                Append_To (Decls, Fin_Body);
1568             end if;
1569
1570             --  Push the name of the package
1571
1572             Push_Scope (Spec_Id);
1573             Analyze (Fin_Spec);
1574             Analyze (Fin_Body);
1575             Pop_Scope;
1576
1577          --  Non-package case
1578
1579          else
1580             --  Create the spec for the finalizer. The At_End handler must be
1581             --  able to call the body which resides in a nested structure.
1582
1583             --  Generate:
1584             --    declare
1585             --       procedure Fin_Id;                  --  Spec
1586             --    begin
1587             --       <objects and possibly statements>
1588             --       procedure Fin_Id is ...            --  Body
1589             --       <statements>
1590             --    at end
1591             --       Fin_Id;                            --  At_End handler
1592             --    end;
1593
1594             pragma Assert (Present (Spec_Decls));
1595
1596             Append_To (Spec_Decls, Fin_Spec);
1597             Analyze (Fin_Spec);
1598
1599             --  When the finalizer acts solely as a clean up routine, the body
1600             --  is inserted right after the spec.
1601
1602             if Acts_As_Clean
1603               and then not Has_Ctrl_Objs
1604             then
1605                Insert_After (Fin_Spec, Fin_Body);
1606
1607             --  In all other cases the body is inserted after either:
1608             --
1609             --    1) The counter update statement of the last controlled object
1610             --    2) The last top level nested controlled package
1611             --    3) The last top level controlled instantiation
1612
1613             else
1614                --  Manually freeze the spec. This is somewhat of a hack because
1615                --  a subprogram is frozen when its body is seen and the freeze
1616                --  node appears right before the body. However, in this case,
1617                --  the spec must be frozen earlier since the At_End handler
1618                --  must be able to call it.
1619                --
1620                --    declare
1621                --       procedure Fin_Id;               --  Spec
1622                --       [Fin_Id]                        --  Freeze node
1623                --    begin
1624                --       ...
1625                --    at end
1626                --       Fin_Id;                         --  At_End handler
1627                --    end;
1628
1629                Ensure_Freeze_Node (Fin_Id);
1630                Insert_After (Fin_Spec, Freeze_Node (Fin_Id));
1631                Set_Is_Frozen (Fin_Id);
1632
1633                --  In the case where the last construct to contain a controlled
1634                --  object is either a nested package, an instantiation or a
1635                --  freeze node, the body must be inserted directly after the
1636                --  construct.
1637
1638                if Nkind_In (Last_Top_Level_Ctrl_Construct,
1639                               N_Freeze_Entity,
1640                               N_Package_Declaration,
1641                               N_Package_Body)
1642                then
1643                   Finalizer_Insert_Nod := Last_Top_Level_Ctrl_Construct;
1644                end if;
1645
1646                Insert_After (Finalizer_Insert_Nod, Fin_Body);
1647             end if;
1648
1649             Analyze (Fin_Body);
1650          end if;
1651       end Create_Finalizer;
1652
1653       --------------------------
1654       -- Process_Declarations --
1655       --------------------------
1656
1657       procedure Process_Declarations
1658         (Decls      : List_Id;
1659          Preprocess : Boolean := False;
1660          Top_Level  : Boolean := False)
1661       is
1662          Decl    : Node_Id;
1663          Expr    : Node_Id;
1664          Obj_Id  : Entity_Id;
1665          Obj_Typ : Entity_Id;
1666          Pack_Id : Entity_Id;
1667          Spec    : Node_Id;
1668          Typ     : Entity_Id;
1669
1670          Old_Counter_Val : Int;
1671          --  This variable is used to determine whether a nested package or
1672          --  instance contains at least one controlled object.
1673
1674          procedure Processing_Actions
1675            (Has_No_Init  : Boolean := False;
1676             Is_Protected : Boolean := False);
1677          --  Depending on the mode of operation of Process_Declarations, either
1678          --  increment the controlled object counter, set the controlled object
1679          --  flag and store the last top level construct or process the current
1680          --  declaration. Flag Has_No_Init is used to propagate scenarios where
1681          --  the current declaration may not have initialization proc(s). Flag
1682          --  Is_Protected should be set when the current declaration denotes a
1683          --  simple protected object.
1684
1685          ------------------------
1686          -- Processing_Actions --
1687          ------------------------
1688
1689          procedure Processing_Actions
1690            (Has_No_Init  : Boolean := False;
1691             Is_Protected : Boolean := False)
1692          is
1693          begin
1694             --  Library-level tagged type
1695
1696             if Nkind (Decl) = N_Full_Type_Declaration then
1697                if Preprocess then
1698                   Has_Tagged_Types := True;
1699
1700                   if Top_Level
1701                     and then No (Last_Top_Level_Ctrl_Construct)
1702                   then
1703                      Last_Top_Level_Ctrl_Construct := Decl;
1704                   end if;
1705
1706                else
1707                   Process_Tagged_Type_Declaration (Decl);
1708                end if;
1709
1710             --  Controlled object declaration
1711
1712             else
1713                if Preprocess then
1714                   Counter_Val   := Counter_Val + 1;
1715                   Has_Ctrl_Objs := True;
1716
1717                   if Top_Level
1718                     and then No (Last_Top_Level_Ctrl_Construct)
1719                   then
1720                      Last_Top_Level_Ctrl_Construct := Decl;
1721                   end if;
1722
1723                else
1724                   Process_Object_Declaration (Decl, Has_No_Init, Is_Protected);
1725                end if;
1726             end if;
1727          end Processing_Actions;
1728
1729       --  Start of processing for Process_Declarations
1730
1731       begin
1732          if No (Decls) or else Is_Empty_List (Decls) then
1733             return;
1734          end if;
1735
1736          --  Process all declarations in reverse order
1737
1738          Decl := Last_Non_Pragma (Decls);
1739          while Present (Decl) loop
1740
1741             --  Library-level tagged types
1742
1743             if Nkind (Decl) = N_Full_Type_Declaration then
1744                Typ := Defining_Identifier (Decl);
1745
1746                if Is_Tagged_Type (Typ)
1747                  and then Is_Library_Level_Entity (Typ)
1748                  and then Convention (Typ) = Convention_Ada
1749                  and then Present (Access_Disp_Table (Typ))
1750                  and then RTE_Available (RE_Register_Tag)
1751                  and then not No_Run_Time_Mode
1752                  and then not Is_Abstract_Type (Typ)
1753                then
1754                   Processing_Actions;
1755                end if;
1756
1757             --  Regular object declarations
1758
1759             elsif Nkind (Decl) = N_Object_Declaration then
1760                Obj_Id  := Defining_Identifier (Decl);
1761                Obj_Typ := Base_Type (Etype (Obj_Id));
1762                Expr    := Expression (Decl);
1763
1764                --  Bypass any form of processing for objects which have their
1765                --  finalization disabled. This applies only to objects at the
1766                --  library level.
1767
1768                if For_Package
1769                  and then Finalize_Storage_Only (Obj_Typ)
1770                then
1771                   null;
1772
1773                --  Transient variables are treated separately in order to
1774                --  minimize the size of the generated code. For details, see
1775                --  Process_Transient_Objects.
1776
1777                elsif Is_Processed_Transient (Obj_Id) then
1778                   null;
1779
1780                --  The object is of the form:
1781                --    Obj : Typ [:= Expr];
1782
1783                --  Do not process the incomplete view of a deferred constant.
1784                --  Do not consider tag-to-class-wide conversions.
1785
1786                elsif not Is_Imported (Obj_Id)
1787                  and then Needs_Finalization (Obj_Typ)
1788                  and then not (Ekind (Obj_Id) = E_Constant
1789                                 and then not Has_Completion (Obj_Id))
1790                  and then not Is_Tag_To_CW_Conversion (Obj_Id)
1791                then
1792                   Processing_Actions;
1793
1794                --  The object is of the form:
1795                --    Obj : Access_Typ := Non_BIP_Function_Call'reference;
1796
1797                --    Obj : Access_Typ :=
1798                --            BIP_Function_Call
1799                --              (..., BIPaccess => null, ...)'reference;
1800
1801                elsif Is_Access_Type (Obj_Typ)
1802                  and then Needs_Finalization
1803                             (Available_View (Designated_Type (Obj_Typ)))
1804                  and then Present (Expr)
1805                  and then
1806                    (Is_Null_Access_BIP_Func_Call (Expr)
1807                      or else
1808                        (Is_Non_BIP_Func_Call (Expr)
1809                          and then not Is_Related_To_Func_Return (Obj_Id)))
1810                then
1811                   Processing_Actions (Has_No_Init => True);
1812
1813                --  Processing for "hook" objects generated for controlled
1814                --  transients declared inside an Expression_With_Actions.
1815
1816                elsif Is_Access_Type (Obj_Typ)
1817                  and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
1818                  and then Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) =
1819                                    N_Object_Declaration
1820                  and then Is_Finalizable_Transient
1821                             (Return_Flag_Or_Transient_Decl (Obj_Id), Decl)
1822                then
1823                   Processing_Actions (Has_No_Init => True);
1824
1825                --  Simple protected objects which use type System.Tasking.
1826                --  Protected_Objects.Protection to manage their locks should
1827                --  be treated as controlled since they require manual cleanup.
1828                --  The only exception is illustrated in the following example:
1829
1830                --     package Pkg is
1831                --        type Ctrl is new Controlled ...
1832                --        procedure Finalize (Obj : in out Ctrl);
1833                --        Lib_Obj : Ctrl;
1834                --     end Pkg;
1835
1836                --     package body Pkg is
1837                --        protected Prot is
1838                --           procedure Do_Something (Obj : in out Ctrl);
1839                --        end Prot;
1840
1841                --        protected body Prot is
1842                --           procedure Do_Something (Obj : in out Ctrl) is ...
1843                --        end Prot;
1844
1845                --        procedure Finalize (Obj : in out Ctrl) is
1846                --        begin
1847                --           Prot.Do_Something (Obj);
1848                --        end Finalize;
1849                --     end Pkg;
1850
1851                --  Since for the most part entities in package bodies depend on
1852                --  those in package specs, Prot's lock should be cleaned up
1853                --  first. The subsequent cleanup of the spec finalizes Lib_Obj.
1854                --  This act however attempts to invoke Do_Something and fails
1855                --  because the lock has disappeared.
1856
1857                elsif Ekind (Obj_Id) = E_Variable
1858                  and then not In_Library_Level_Package_Body (Obj_Id)
1859                  and then
1860                    (Is_Simple_Protected_Type (Obj_Typ)
1861                      or else Has_Simple_Protected_Object (Obj_Typ))
1862                then
1863                   Processing_Actions (Is_Protected => True);
1864                end if;
1865
1866             --  Specific cases of object renamings
1867
1868             elsif Nkind (Decl) = N_Object_Renaming_Declaration
1869               and then Nkind (Name (Decl)) = N_Explicit_Dereference
1870               and then Nkind (Prefix (Name (Decl))) = N_Identifier
1871             then
1872                Obj_Id  := Defining_Identifier (Decl);
1873                Obj_Typ := Base_Type (Etype (Obj_Id));
1874
1875                --  Bypass any form of processing for objects which have their
1876                --  finalization disabled. This applies only to objects at the
1877                --  library level.
1878
1879                if For_Package
1880                  and then Finalize_Storage_Only (Obj_Typ)
1881                then
1882                   null;
1883
1884                --  Return object of a build-in-place function. This case is
1885                --  recognized and marked by the expansion of an extended return
1886                --  statement (see Expand_N_Extended_Return_Statement).
1887
1888                elsif Needs_Finalization (Obj_Typ)
1889                  and then Is_Return_Object (Obj_Id)
1890                  and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
1891                then
1892                   Processing_Actions (Has_No_Init => True);
1893                end if;
1894
1895             --  Inspect the freeze node of an access-to-controlled type and
1896             --  look for a delayed finalization master. This case arises when
1897             --  the freeze actions are inserted at a later time than the
1898             --  expansion of the context. Since Build_Finalizer is never called
1899             --  on a single construct twice, the master will be ultimately
1900             --  left out and never finalized. This is also needed for freeze
1901             --  actions of designated types themselves, since in some cases the
1902             --  finalization master is associated with a designated type's
1903             --  freeze node rather than that of the access type (see handling
1904             --  for freeze actions in Build_Finalization_Master).
1905
1906             elsif Nkind (Decl) = N_Freeze_Entity
1907               and then Present (Actions (Decl))
1908             then
1909                Typ := Entity (Decl);
1910
1911                if (Is_Access_Type (Typ)
1912                     and then not Is_Access_Subprogram_Type (Typ)
1913                     and then Needs_Finalization
1914                                (Available_View (Designated_Type (Typ))))
1915                  or else (Is_Type (Typ) and then Needs_Finalization (Typ))
1916                then
1917                   Old_Counter_Val := Counter_Val;
1918
1919                   --  Freeze nodes are considered to be identical to packages
1920                   --  and blocks in terms of nesting. The difference is that
1921                   --  a finalization master created inside the freeze node is
1922                   --  at the same nesting level as the node itself.
1923
1924                   Process_Declarations (Actions (Decl), Preprocess);
1925
1926                   --  The freeze node contains a finalization master
1927
1928                   if Preprocess
1929                     and then Top_Level
1930                     and then No (Last_Top_Level_Ctrl_Construct)
1931                     and then Counter_Val > Old_Counter_Val
1932                   then
1933                      Last_Top_Level_Ctrl_Construct := Decl;
1934                   end if;
1935                end if;
1936
1937             --  Nested package declarations, avoid generics
1938
1939             elsif Nkind (Decl) = N_Package_Declaration then
1940                Spec    := Specification (Decl);
1941                Pack_Id := Defining_Unit_Name (Spec);
1942
1943                if Nkind (Pack_Id) = N_Defining_Program_Unit_Name then
1944                   Pack_Id := Defining_Identifier (Pack_Id);
1945                end if;
1946
1947                if Ekind (Pack_Id) /= E_Generic_Package then
1948                   Old_Counter_Val := Counter_Val;
1949                   Process_Declarations
1950                     (Private_Declarations (Spec), Preprocess);
1951                   Process_Declarations
1952                     (Visible_Declarations (Spec), Preprocess);
1953
1954                   --  Either the visible or the private declarations contain a
1955                   --  controlled object. The nested package declaration is the
1956                   --  last such construct.
1957
1958                   if Preprocess
1959                     and then Top_Level
1960                     and then No (Last_Top_Level_Ctrl_Construct)
1961                     and then Counter_Val > Old_Counter_Val
1962                   then
1963                      Last_Top_Level_Ctrl_Construct := Decl;
1964                   end if;
1965                end if;
1966
1967             --  Nested package bodies, avoid generics
1968
1969             elsif Nkind (Decl) = N_Package_Body then
1970                Spec := Corresponding_Spec (Decl);
1971
1972                if Ekind (Spec) /= E_Generic_Package then
1973                   Old_Counter_Val := Counter_Val;
1974                   Process_Declarations (Declarations (Decl), Preprocess);
1975
1976                   --  The nested package body is the last construct to contain
1977                   --  a controlled object.
1978
1979                   if Preprocess
1980                     and then Top_Level
1981                     and then No (Last_Top_Level_Ctrl_Construct)
1982                     and then Counter_Val > Old_Counter_Val
1983                   then
1984                      Last_Top_Level_Ctrl_Construct := Decl;
1985                   end if;
1986                end if;
1987
1988             --  Handle a rare case caused by a controlled transient variable
1989             --  created as part of a record init proc. The variable is wrapped
1990             --  in a block, but the block is not associated with a transient
1991             --  scope.
1992
1993             elsif Nkind (Decl) = N_Block_Statement
1994               and then Inside_Init_Proc
1995             then
1996                Old_Counter_Val := Counter_Val;
1997
1998                if Present (Handled_Statement_Sequence (Decl)) then
1999                   Process_Declarations
2000                     (Statements (Handled_Statement_Sequence (Decl)),
2001                      Preprocess);
2002                end if;
2003
2004                Process_Declarations (Declarations (Decl), Preprocess);
2005
2006                --  Either the declaration or statement list of the block has a
2007                --  controlled object.
2008
2009                if Preprocess
2010                  and then Top_Level
2011                  and then No (Last_Top_Level_Ctrl_Construct)
2012                  and then Counter_Val > Old_Counter_Val
2013                then
2014                   Last_Top_Level_Ctrl_Construct := Decl;
2015                end if;
2016             end if;
2017
2018             Prev_Non_Pragma (Decl);
2019          end loop;
2020       end Process_Declarations;
2021
2022       --------------------------------
2023       -- Process_Object_Declaration --
2024       --------------------------------
2025
2026       procedure Process_Object_Declaration
2027         (Decl         : Node_Id;
2028          Has_No_Init  : Boolean := False;
2029          Is_Protected : Boolean := False)
2030       is
2031          Obj_Id    : constant Entity_Id := Defining_Identifier (Decl);
2032          Loc       : constant Source_Ptr := Sloc (Decl);
2033          Body_Ins  : Node_Id;
2034          Count_Ins : Node_Id;
2035          Fin_Call  : Node_Id;
2036          Fin_Stmts : List_Id;
2037          Inc_Decl  : Node_Id;
2038          Label     : Node_Id;
2039          Label_Id  : Entity_Id;
2040          Obj_Ref   : Node_Id;
2041          Obj_Typ   : Entity_Id;
2042
2043          function Build_BIP_Cleanup_Stmts (Func_Id : Entity_Id) return Node_Id;
2044          --  Once it has been established that the current object is in fact a
2045          --  return object of build-in-place function Func_Id, generate the
2046          --  following cleanup code:
2047          --
2048          --    if BIPallocfrom > Secondary_Stack'Pos
2049          --      and then BIPfinalizationmaster /= null
2050          --    then
2051          --       declare
2052          --          type Ptr_Typ is access Obj_Typ;
2053          --          for Ptr_Typ'Storage_Pool
2054          --            use Base_Pool (BIPfinalizationmaster);
2055          --       begin
2056          --          Free (Ptr_Typ (Temp));
2057          --       end;
2058          --    end if;
2059          --
2060          --  Obj_Typ is the type of the current object, Temp is the original
2061          --  allocation which Obj_Id renames.
2062
2063          procedure Find_Last_Init
2064            (Decl        : Node_Id;
2065             Typ         : Entity_Id;
2066             Last_Init   : out Node_Id;
2067             Body_Insert : out Node_Id);
2068          --  An object declaration has at least one and at most two init calls:
2069          --  that of the type and the user-defined initialize. Given an object
2070          --  declaration, Last_Init denotes the last initialization call which
2071          --  follows the declaration. Body_Insert denotes the place where the
2072          --  finalizer body could be potentially inserted.
2073
2074          -----------------------------
2075          -- Build_BIP_Cleanup_Stmts --
2076          -----------------------------
2077
2078          function Build_BIP_Cleanup_Stmts
2079            (Func_Id : Entity_Id) return Node_Id
2080          is
2081             Decls      : constant List_Id := New_List;
2082             Fin_Mas_Id : constant Entity_Id :=
2083                            Build_In_Place_Formal
2084                              (Func_Id, BIP_Finalization_Master);
2085             Obj_Typ    : constant Entity_Id := Etype (Func_Id);
2086             Temp_Id    : constant Entity_Id :=
2087                            Entity (Prefix (Name (Parent (Obj_Id))));
2088
2089             Cond      : Node_Id;
2090             Free_Blk  : Node_Id;
2091             Free_Stmt : Node_Id;
2092             Pool_Id   : Entity_Id;
2093             Ptr_Typ   : Entity_Id;
2094
2095          begin
2096             --  Generate:
2097             --    Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2098
2099             Pool_Id := Make_Temporary (Loc, 'P');
2100
2101             Append_To (Decls,
2102               Make_Object_Renaming_Declaration (Loc,
2103                 Defining_Identifier => Pool_Id,
2104                 Subtype_Mark        =>
2105                   New_Reference_To (RTE (RE_Root_Storage_Pool), Loc),
2106                 Name                =>
2107                   Make_Explicit_Dereference (Loc,
2108                     Prefix =>
2109                       Make_Function_Call (Loc,
2110                         Name                   =>
2111                           New_Reference_To (RTE (RE_Base_Pool), Loc),
2112                         Parameter_Associations => New_List (
2113                           Make_Explicit_Dereference (Loc,
2114                             Prefix => New_Reference_To (Fin_Mas_Id, Loc)))))));
2115
2116             --  Create an access type which uses the storage pool of the
2117             --  caller's finalization master.
2118
2119             --  Generate:
2120             --    type Ptr_Typ is access Obj_Typ;
2121
2122             Ptr_Typ := Make_Temporary (Loc, 'P');
2123
2124             Append_To (Decls,
2125               Make_Full_Type_Declaration (Loc,
2126                 Defining_Identifier => Ptr_Typ,
2127                 Type_Definition     =>
2128                   Make_Access_To_Object_Definition (Loc,
2129                     Subtype_Indication => New_Reference_To (Obj_Typ, Loc))));
2130
2131             --  Perform minor decoration in order to set the master and the
2132             --  storage pool attributes.
2133
2134             Set_Ekind (Ptr_Typ, E_Access_Type);
2135             Set_Finalization_Master     (Ptr_Typ, Fin_Mas_Id);
2136             Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
2137
2138             --  Create an explicit free statement. Note that the free uses the
2139             --  caller's pool expressed as a renaming.
2140
2141             Free_Stmt :=
2142               Make_Free_Statement (Loc,
2143                 Expression =>
2144                   Unchecked_Convert_To (Ptr_Typ,
2145                     New_Reference_To (Temp_Id, Loc)));
2146
2147             Set_Storage_Pool (Free_Stmt, Pool_Id);
2148
2149             --  Create a block to house the dummy type and the instantiation as
2150             --  well as to perform the cleanup the temporary.
2151
2152             --  Generate:
2153             --    declare
2154             --       <Decls>
2155             --    begin
2156             --       Free (Ptr_Typ (Temp_Id));
2157             --    end;
2158
2159             Free_Blk :=
2160               Make_Block_Statement (Loc,
2161                 Declarations               => Decls,
2162                 Handled_Statement_Sequence =>
2163                   Make_Handled_Sequence_Of_Statements (Loc,
2164                     Statements => New_List (Free_Stmt)));
2165
2166             --  Generate:
2167             --    if BIPfinalizationmaster /= null then
2168
2169             Cond :=
2170               Make_Op_Ne (Loc,
2171                 Left_Opnd  => New_Reference_To (Fin_Mas_Id, Loc),
2172                 Right_Opnd => Make_Null (Loc));
2173
2174             --  For constrained or tagged results escalate the condition to
2175             --  include the allocation format. Generate:
2176             --
2177             --    if BIPallocform > Secondary_Stack'Pos
2178             --      and then BIPfinalizationmaster /= null
2179             --    then
2180
2181             if not Is_Constrained (Obj_Typ)
2182               or else Is_Tagged_Type (Obj_Typ)
2183             then
2184                declare
2185                   Alloc : constant Entity_Id :=
2186                             Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
2187                begin
2188                   Cond :=
2189                     Make_And_Then (Loc,
2190                       Left_Opnd  =>
2191                         Make_Op_Gt (Loc,
2192                           Left_Opnd  => New_Reference_To (Alloc, Loc),
2193                           Right_Opnd =>
2194                             Make_Integer_Literal (Loc,
2195                               UI_From_Int
2196                                 (BIP_Allocation_Form'Pos (Secondary_Stack)))),
2197
2198                       Right_Opnd => Cond);
2199                end;
2200             end if;
2201
2202             --  Generate:
2203             --    if <Cond> then
2204             --       <Free_Blk>
2205             --    end if;
2206
2207             return
2208               Make_If_Statement (Loc,
2209                 Condition       => Cond,
2210                 Then_Statements => New_List (Free_Blk));
2211          end Build_BIP_Cleanup_Stmts;
2212
2213          --------------------
2214          -- Find_Last_Init --
2215          --------------------
2216
2217          procedure Find_Last_Init
2218            (Decl        : Node_Id;
2219             Typ         : Entity_Id;
2220             Last_Init   : out Node_Id;
2221             Body_Insert : out Node_Id)
2222          is
2223             Nod_1 : Node_Id := Empty;
2224             Nod_2 : Node_Id := Empty;
2225             Utyp  : Entity_Id;
2226
2227             function Is_Init_Call
2228               (N   : Node_Id;
2229                Typ : Entity_Id) return Boolean;
2230             --  Given an arbitrary node, determine whether N is a procedure
2231             --  call and if it is, try to match the name of the call with the
2232             --  [Deep_]Initialize proc of Typ.
2233
2234             function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id;
2235             --  Given a statement which is part of a list, return the next
2236             --  real statement while skipping over dynamic elab checks.
2237
2238             ------------------
2239             -- Is_Init_Call --
2240             ------------------
2241
2242             function Is_Init_Call
2243               (N   : Node_Id;
2244                Typ : Entity_Id) return Boolean
2245             is
2246             begin
2247                --  A call to [Deep_]Initialize is always direct
2248
2249                if Nkind (N) = N_Procedure_Call_Statement
2250                  and then Nkind (Name (N)) = N_Identifier
2251                then
2252                   declare
2253                      Call_Ent  : constant Entity_Id := Entity (Name (N));
2254                      Deep_Init : constant Entity_Id :=
2255                                    TSS (Typ, TSS_Deep_Initialize);
2256                      Init      : Entity_Id := Empty;
2257
2258                   begin
2259                      --  A type may have controlled components but not be
2260                      --  controlled.
2261
2262                      if Is_Controlled (Typ) then
2263                         Init := Find_Prim_Op (Typ, Name_Initialize);
2264
2265                         if Present (Init) then
2266                            Init := Ultimate_Alias (Init);
2267                         end if;
2268                      end if;
2269
2270                      return
2271                        (Present (Deep_Init) and then Call_Ent = Deep_Init)
2272                          or else
2273                        (Present (Init)      and then Call_Ent = Init);
2274                   end;
2275                end if;
2276
2277                return False;
2278             end Is_Init_Call;
2279
2280             -----------------------------
2281             -- Next_Suitable_Statement --
2282             -----------------------------
2283
2284             function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id is
2285                Result : Node_Id := Next (Stmt);
2286
2287             begin
2288                --  Skip over access-before-elaboration checks
2289
2290                if Dynamic_Elaboration_Checks
2291                  and then Nkind (Result) = N_Raise_Program_Error
2292                then
2293                   Result := Next (Result);
2294                end if;
2295
2296                return Result;
2297             end Next_Suitable_Statement;
2298
2299          --  Start of processing for Find_Last_Init
2300
2301          begin
2302             Last_Init   := Decl;
2303             Body_Insert := Empty;
2304
2305             --  Object renamings and objects associated with controlled
2306             --  function results do not have initialization calls.
2307
2308             if Has_No_Init then
2309                return;
2310             end if;
2311
2312             if Is_Concurrent_Type (Typ) then
2313                Utyp := Corresponding_Record_Type (Typ);
2314             else
2315                Utyp := Typ;
2316             end if;
2317
2318             if Is_Private_Type (Utyp)
2319               and then Present (Full_View (Utyp))
2320             then
2321                Utyp := Full_View (Utyp);
2322             end if;
2323
2324             --  The init procedures are arranged as follows:
2325
2326             --    Object : Controlled_Type;
2327             --    Controlled_TypeIP (Object);
2328             --    [[Deep_]Initialize (Object);]
2329
2330             --  where the user-defined initialize may be optional or may appear
2331             --  inside a block when abort deferral is needed.
2332
2333             Nod_1 := Next_Suitable_Statement (Decl);
2334             if Present (Nod_1) then
2335                Nod_2 := Next_Suitable_Statement (Nod_1);
2336
2337                --  The statement following an object declaration is always a
2338                --  call to the type init proc.
2339
2340                Last_Init := Nod_1;
2341             end if;
2342
2343             --  Optional user-defined init or deep init processing
2344
2345             if Present (Nod_2) then
2346
2347                --  The statement following the type init proc may be a block
2348                --  statement in cases where abort deferral is required.
2349
2350                if Nkind (Nod_2) = N_Block_Statement then
2351                   declare
2352                      HSS  : constant Node_Id :=
2353                               Handled_Statement_Sequence (Nod_2);
2354                      Stmt : Node_Id;
2355
2356                   begin
2357                      if Present (HSS)
2358                        and then Present (Statements (HSS))
2359                      then
2360                         Stmt := First (Statements (HSS));
2361
2362                         --  Examine individual block statements and locate the
2363                         --  call to [Deep_]Initialze.
2364
2365                         while Present (Stmt) loop
2366                            if Is_Init_Call (Stmt, Utyp) then
2367                               Last_Init   := Stmt;
2368                               Body_Insert := Nod_2;
2369
2370                               exit;
2371                            end if;
2372
2373                            Next (Stmt);
2374                         end loop;
2375                      end if;
2376                   end;
2377
2378                elsif Is_Init_Call (Nod_2, Utyp) then
2379                   Last_Init := Nod_2;
2380                end if;
2381             end if;
2382          end Find_Last_Init;
2383
2384       --  Start of processing for Process_Object_Declaration
2385
2386       begin
2387          Obj_Ref := New_Reference_To (Obj_Id, Loc);
2388          Obj_Typ := Base_Type (Etype (Obj_Id));
2389
2390          --  Handle access types
2391
2392          if Is_Access_Type (Obj_Typ) then
2393             Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
2394             Obj_Typ := Directly_Designated_Type (Obj_Typ);
2395          end if;
2396
2397          Set_Etype (Obj_Ref, Obj_Typ);
2398
2399          --  Set a new value for the state counter and insert the statement
2400          --  after the object declaration. Generate:
2401          --
2402          --    Counter := <value>;
2403
2404          Inc_Decl :=
2405            Make_Assignment_Statement (Loc,
2406              Name       => New_Reference_To (Counter_Id, Loc),
2407              Expression => Make_Integer_Literal (Loc, Counter_Val));
2408
2409          --  Insert the counter after all initialization has been done. The
2410          --  place of insertion depends on the context. When dealing with a
2411          --  controlled function, the counter is inserted directly after the
2412          --  declaration because such objects lack init calls.
2413
2414          Find_Last_Init (Decl, Obj_Typ, Count_Ins, Body_Ins);
2415
2416          Insert_After (Count_Ins, Inc_Decl);
2417          Analyze (Inc_Decl);
2418
2419          --  If the current declaration is the last in the list, the finalizer
2420          --  body needs to be inserted after the set counter statement for the
2421          --  current object declaration. This is complicated by the fact that
2422          --  the set counter statement may appear in abort deferred block. In
2423          --  that case, the proper insertion place is after the block.
2424
2425          if No (Finalizer_Insert_Nod) then
2426
2427             --  Insertion after an abort deffered block
2428
2429             if Present (Body_Ins) then
2430                Finalizer_Insert_Nod := Body_Ins;
2431             else
2432                Finalizer_Insert_Nod := Inc_Decl;
2433             end if;
2434          end if;
2435
2436          --  Create the associated label with this object, generate:
2437          --
2438          --    L<counter> : label;
2439
2440          Label_Id :=
2441            Make_Identifier (Loc, New_External_Name ('L', Counter_Val));
2442          Set_Entity
2443            (Label_Id, Make_Defining_Identifier (Loc, Chars (Label_Id)));
2444          Label := Make_Label (Loc, Label_Id);
2445
2446          Prepend_To (Finalizer_Decls,
2447            Make_Implicit_Label_Declaration (Loc,
2448              Defining_Identifier => Entity (Label_Id),
2449              Label_Construct     => Label));
2450
2451          --  Create the associated jump with this object, generate:
2452          --
2453          --    when <counter> =>
2454          --       goto L<counter>;
2455
2456          Prepend_To (Jump_Alts,
2457            Make_Case_Statement_Alternative (Loc,
2458              Discrete_Choices => New_List (
2459                Make_Integer_Literal (Loc, Counter_Val)),
2460              Statements       => New_List (
2461                Make_Goto_Statement (Loc,
2462                  Name => New_Reference_To (Entity (Label_Id), Loc)))));
2463
2464          --  Insert the jump destination, generate:
2465          --
2466          --     <<L<counter>>>
2467
2468          Append_To (Finalizer_Stmts, Label);
2469
2470          --  Processing for simple protected objects. Such objects require
2471          --  manual finalization of their lock managers.
2472
2473          if Is_Protected then
2474             Fin_Stmts := No_List;
2475
2476             if Is_Simple_Protected_Type (Obj_Typ) then
2477                Fin_Call := Cleanup_Protected_Object (Decl, Obj_Ref);
2478
2479                if Present (Fin_Call) then
2480                   Fin_Stmts := New_List (Fin_Call);
2481                end if;
2482
2483             elsif Has_Simple_Protected_Object (Obj_Typ) then
2484                if Is_Record_Type (Obj_Typ) then
2485                   Fin_Stmts := Cleanup_Record (Decl, Obj_Ref, Obj_Typ);
2486                elsif Is_Array_Type (Obj_Typ) then
2487                   Fin_Stmts := Cleanup_Array (Decl, Obj_Ref, Obj_Typ);
2488                end if;
2489             end if;
2490
2491             --  Generate:
2492             --    begin
2493             --       System.Tasking.Protected_Objects.Finalize_Protection
2494             --         (Obj._object);
2495
2496             --    exception
2497             --       when others =>
2498             --          null;
2499             --    end;
2500
2501             if Present (Fin_Stmts) then
2502                Append_To (Finalizer_Stmts,
2503                  Make_Block_Statement (Loc,
2504                    Handled_Statement_Sequence =>
2505                      Make_Handled_Sequence_Of_Statements (Loc,
2506                        Statements         => Fin_Stmts,
2507
2508                        Exception_Handlers => New_List (
2509                          Make_Exception_Handler (Loc,
2510                            Exception_Choices => New_List (
2511                              Make_Others_Choice (Loc)),
2512
2513                            Statements     => New_List (
2514                              Make_Null_Statement (Loc)))))));
2515             end if;
2516
2517          --  Processing for regular controlled objects
2518
2519          else
2520             --  Generate:
2521             --    [Deep_]Finalize (Obj);  --  No_Exception_Propagation
2522
2523             --    begin                   --  Exception handlers allowed
2524             --       [Deep_]Finalize (Obj);
2525
2526             --    exception
2527             --       when Id : others =>
2528             --          if not Raised then
2529             --             Raised := True;
2530             --             Save_Occurrence (E, Id);
2531             --          end if;
2532             --    end;
2533
2534             Fin_Call :=
2535               Make_Final_Call (
2536                 Obj_Ref => Obj_Ref,
2537                 Typ     => Obj_Typ);
2538
2539             if Exceptions_OK then
2540                Fin_Stmts := New_List (
2541                  Make_Block_Statement (Loc,
2542                    Handled_Statement_Sequence =>
2543                      Make_Handled_Sequence_Of_Statements (Loc,
2544                        Statements => New_List (Fin_Call),
2545
2546                     Exception_Handlers => New_List (
2547                       Build_Exception_Handler
2548                         (Finalizer_Data, For_Package)))));
2549
2550             --  When exception handlers are prohibited, the finalization call
2551             --  appears unprotected. Any exception raised during finalization
2552             --  will bypass the circuitry which ensures the cleanup of all
2553             --  remaining objects.
2554
2555             else
2556                Fin_Stmts := New_List (Fin_Call);
2557             end if;
2558
2559             --  If we are dealing with a return object of a build-in-place
2560             --  function, generate the following cleanup statements:
2561
2562             --    if BIPallocfrom > Secondary_Stack'Pos
2563             --      and then BIPfinalizationmaster /= null
2564             --    then
2565             --       declare
2566             --          type Ptr_Typ is access Obj_Typ;
2567             --          for Ptr_Typ'Storage_Pool use
2568             --                Base_Pool (BIPfinalizationmaster.all).all;
2569             --       begin
2570             --          Free (Ptr_Typ (Temp));
2571             --       end;
2572             --    end if;
2573             --
2574             --  The generated code effectively detaches the temporary from the
2575             --  caller finalization master and deallocates the object. This is
2576             --  disabled on .NET/JVM because pools are not supported.
2577
2578             if VM_Target = No_VM and then Is_Return_Object (Obj_Id) then
2579                declare
2580                   Func_Id : constant Entity_Id := Enclosing_Function (Obj_Id);
2581                begin
2582                   if Is_Build_In_Place_Function (Func_Id)
2583                     and then Needs_BIP_Finalization_Master (Func_Id)
2584                   then
2585                      Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id));
2586                   end if;
2587                end;
2588             end if;
2589
2590             if Ekind_In (Obj_Id, E_Constant, E_Variable)
2591               and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
2592             then
2593                --  Return objects use a flag to aid their potential
2594                --  finalization when the enclosing function fails to return
2595                --  properly. Generate:
2596
2597                --    if not Flag then
2598                --       <object finalization statements>
2599                --    end if;
2600
2601                if Is_Return_Object (Obj_Id) then
2602                   Fin_Stmts := New_List (
2603                     Make_If_Statement (Loc,
2604                       Condition     =>
2605                         Make_Op_Not (Loc,
2606                           Right_Opnd =>
2607                             New_Reference_To
2608                               (Return_Flag_Or_Transient_Decl (Obj_Id), Loc)),
2609
2610                     Then_Statements => Fin_Stmts));
2611
2612                --  Temporaries created for the purpose of "exporting" a
2613                --  controlled transient out of an Expression_With_Actions (EWA)
2614                --  need guards. The following illustrates the usage of such
2615                --  temporaries.
2616
2617                --    Access_Typ : access [all] Obj_Typ;
2618                --    Temp       : Access_Typ := null;
2619                --    <Counter>  := ...;
2620
2621                --    do
2622                --       Ctrl_Trans : [access [all]] Obj_Typ := ...;
2623                --       Temp := Access_Typ (Ctrl_Trans);  --  when a pointer
2624                --         <or>
2625                --       Temp := Ctrl_Trans'Unchecked_Access;
2626                --    in ... end;
2627
2628                --  The finalization machinery does not process EWA nodes as
2629                --  this may lead to premature finalization of expressions. Note
2630                --  that Temp is marked as being properly initialized regardless
2631                --  of whether the initialization of Ctrl_Trans succeeded. Since
2632                --  a failed initialization may leave Temp with a value of null,
2633                --  add a guard to handle this case:
2634
2635                --    if Obj /= null then
2636                --       <object finalization statements>
2637                --    end if;
2638
2639                else
2640                   pragma Assert
2641                     (Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) =
2642                        N_Object_Declaration);
2643
2644                   Fin_Stmts := New_List (
2645                     Make_If_Statement (Loc,
2646                       Condition       =>
2647                         Make_Op_Ne (Loc,
2648                           Left_Opnd  => New_Reference_To (Obj_Id, Loc),
2649                           Right_Opnd => Make_Null (Loc)),
2650
2651                       Then_Statements => Fin_Stmts));
2652                end if;
2653             end if;
2654          end if;
2655
2656          Append_List_To (Finalizer_Stmts, Fin_Stmts);
2657
2658          --  Since the declarations are examined in reverse, the state counter
2659          --  must be decremented in order to keep with the true position of
2660          --  objects.
2661
2662          Counter_Val := Counter_Val - 1;
2663       end Process_Object_Declaration;
2664
2665       -------------------------------------
2666       -- Process_Tagged_Type_Declaration --
2667       -------------------------------------
2668
2669       procedure Process_Tagged_Type_Declaration (Decl : Node_Id) is
2670          Typ    : constant Entity_Id := Defining_Identifier (Decl);
2671          DT_Ptr : constant Entity_Id :=
2672                     Node (First_Elmt (Access_Disp_Table (Typ)));
2673       begin
2674          --  Generate:
2675          --    Ada.Tags.Unregister_Tag (<Typ>P);
2676
2677          Append_To (Tagged_Type_Stmts,
2678            Make_Procedure_Call_Statement (Loc,
2679              Name                   =>
2680                New_Reference_To (RTE (RE_Unregister_Tag), Loc),
2681              Parameter_Associations => New_List (
2682                New_Reference_To (DT_Ptr, Loc))));
2683       end Process_Tagged_Type_Declaration;
2684
2685    --  Start of processing for Build_Finalizer
2686
2687    begin
2688       Fin_Id := Empty;
2689
2690       --  Do not perform this expansion in Alfa mode because it is not
2691       --  necessary.
2692
2693       if Alfa_Mode then
2694          return;
2695       end if;
2696
2697       --  Step 1: Extract all lists which may contain controlled objects or
2698       --  library-level tagged types.
2699
2700       if For_Package_Spec then
2701          Decls      := Visible_Declarations (Specification (N));
2702          Priv_Decls := Private_Declarations (Specification (N));
2703
2704          --  Retrieve the package spec id
2705
2706          Spec_Id := Defining_Unit_Name (Specification (N));
2707
2708          if Nkind (Spec_Id) = N_Defining_Program_Unit_Name then
2709             Spec_Id := Defining_Identifier (Spec_Id);
2710          end if;
2711
2712       --  Accept statement, block, entry body, package body, protected body,
2713       --  subprogram body or task body.
2714
2715       else
2716          Decls := Declarations (N);
2717          HSS   := Handled_Statement_Sequence (N);
2718
2719          if Present (HSS) then
2720             if Present (Statements (HSS)) then
2721                Stmts := Statements (HSS);
2722             end if;
2723
2724             if Present (At_End_Proc (HSS)) then
2725                Prev_At_End := At_End_Proc (HSS);
2726             end if;
2727          end if;
2728
2729          --  Retrieve the package spec id for package bodies
2730
2731          if For_Package_Body then
2732             Spec_Id := Corresponding_Spec (N);
2733          end if;
2734       end if;
2735
2736       --  Do not process nested packages since those are handled by the
2737       --  enclosing scope's finalizer. Do not process non-expanded package
2738       --  instantiations since those will be re-analyzed and re-expanded.
2739
2740       if For_Package
2741         and then
2742           (not Is_Library_Level_Entity (Spec_Id)
2743
2744              --  Nested packages are considered to be library level entities,
2745              --  but do not need to be processed separately. True library level
2746              --  packages have a scope value of 1.
2747
2748              or else Scope_Depth_Value (Spec_Id) /= Uint_1
2749              or else (Is_Generic_Instance (Spec_Id)
2750                        and then Package_Instantiation (Spec_Id) /= N))
2751       then
2752          return;
2753       end if;
2754
2755       --  Step 2: Object [pre]processing
2756
2757       if For_Package then
2758
2759          --  Preprocess the visible declarations now in order to obtain the
2760          --  correct number of controlled object by the time the private
2761          --  declarations are processed.
2762
2763          Process_Declarations (Decls, Preprocess => True, Top_Level => True);
2764
2765          --  From all the possible contexts, only package specifications may
2766          --  have private declarations.
2767
2768          if For_Package_Spec then
2769             Process_Declarations
2770               (Priv_Decls, Preprocess => True, Top_Level => True);
2771          end if;
2772
2773          --  The current context may lack controlled objects, but require some
2774          --  other form of completion (task termination for instance). In such
2775          --  cases, the finalizer must be created and carry the additional
2776          --  statements.
2777
2778          if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
2779             Build_Components;
2780          end if;
2781
2782          --  The preprocessing has determined that the context has controlled
2783          --  objects or library-level tagged types.
2784
2785          if Has_Ctrl_Objs or Has_Tagged_Types then
2786
2787             --  Private declarations are processed first in order to preserve
2788             --  possible dependencies between public and private objects.
2789
2790             if For_Package_Spec then
2791                Process_Declarations (Priv_Decls);
2792             end if;
2793
2794             Process_Declarations (Decls);
2795          end if;
2796
2797       --  Non-package case
2798
2799       else
2800          --  Preprocess both declarations and statements
2801
2802          Process_Declarations (Decls, Preprocess => True, Top_Level => True);
2803          Process_Declarations (Stmts, Preprocess => True, Top_Level => True);
2804
2805          --  At this point it is known that N has controlled objects. Ensure
2806          --  that N has a declarative list since the finalizer spec will be
2807          --  attached to it.
2808
2809          if Has_Ctrl_Objs and then No (Decls) then
2810             Set_Declarations (N, New_List);
2811             Decls      := Declarations (N);
2812             Spec_Decls := Decls;
2813          end if;
2814
2815          --  The current context may lack controlled objects, but require some
2816          --  other form of completion (task termination for instance). In such
2817          --  cases, the finalizer must be created and carry the additional
2818          --  statements.
2819
2820          if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
2821             Build_Components;
2822          end if;
2823
2824          if Has_Ctrl_Objs or Has_Tagged_Types then
2825             Process_Declarations (Stmts);
2826             Process_Declarations (Decls);
2827          end if;
2828       end if;
2829
2830       --  Step 3: Finalizer creation
2831
2832       if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
2833          Create_Finalizer;
2834       end if;
2835    end Build_Finalizer;
2836
2837    --------------------------
2838    -- Build_Finalizer_Call --
2839    --------------------------
2840
2841    procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id) is
2842       Loc : constant Source_Ptr := Sloc (N);
2843       HSS : Node_Id := Handled_Statement_Sequence (N);
2844
2845       Is_Prot_Body : constant Boolean :=
2846                        Nkind (N) = N_Subprogram_Body
2847                          and then Is_Protected_Subprogram_Body (N);
2848       --  Determine whether N denotes the protected version of a subprogram
2849       --  which belongs to a protected type.
2850
2851    begin
2852       --  Do not perform this expansion in Alfa mode because we do not create
2853       --  finalizers in the first place.
2854
2855       if Alfa_Mode then
2856          return;
2857       end if;
2858
2859       --  The At_End handler should have been assimilated by the finalizer
2860
2861       pragma Assert (No (At_End_Proc (HSS)));
2862
2863       --  If the construct to be cleaned up is a protected subprogram body, the
2864       --  finalizer call needs to be associated with the block which wraps the
2865       --  unprotected version of the subprogram. The following illustrates this
2866       --  scenario:
2867
2868       --     procedure Prot_SubpP is
2869       --        procedure finalizer is
2870       --        begin
2871       --           Service_Entries (Prot_Obj);
2872       --           Abort_Undefer;
2873       --        end finalizer;
2874
2875       --     begin
2876       --        . . .
2877       --        begin
2878       --           Prot_SubpN (Prot_Obj);
2879       --        at end
2880       --           finalizer;
2881       --        end;
2882       --     end Prot_SubpP;
2883
2884       if Is_Prot_Body then
2885          HSS := Handled_Statement_Sequence (Last (Statements (HSS)));
2886
2887       --  An At_End handler and regular exception handlers cannot coexist in
2888       --  the same statement sequence. Wrap the original statements in a block.
2889
2890       elsif Present (Exception_Handlers (HSS)) then
2891          declare
2892             End_Lab : constant Node_Id := End_Label (HSS);
2893             Block   : Node_Id;
2894
2895          begin
2896             Block :=
2897               Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS);
2898
2899             Set_Handled_Statement_Sequence (N,
2900               Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
2901
2902             HSS := Handled_Statement_Sequence (N);
2903             Set_End_Label (HSS, End_Lab);
2904          end;
2905       end if;
2906
2907       Set_At_End_Proc (HSS, New_Reference_To (Fin_Id, Loc));
2908
2909       Analyze (At_End_Proc (HSS));
2910       Expand_At_End_Handler (HSS, Empty);
2911    end Build_Finalizer_Call;
2912
2913    ---------------------
2914    -- Build_Late_Proc --
2915    ---------------------
2916
2917    procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is
2918    begin
2919       for Final_Prim in Name_Of'Range loop
2920          if Name_Of (Final_Prim) = Nam then
2921             Set_TSS (Typ,
2922               Make_Deep_Proc
2923                 (Prim  => Final_Prim,
2924                  Typ   => Typ,
2925                  Stmts => Make_Deep_Record_Body (Final_Prim, Typ)));
2926          end if;
2927       end loop;
2928    end Build_Late_Proc;
2929
2930    -------------------------------
2931    -- Build_Object_Declarations --
2932    -------------------------------
2933
2934    procedure Build_Object_Declarations
2935      (Data        : out Finalization_Exception_Data;
2936       Decls       : List_Id;
2937       Loc         : Source_Ptr;
2938       For_Package : Boolean := False)
2939    is
2940       A_Expr : Node_Id;
2941       E_Decl : Node_Id;
2942
2943    begin
2944       pragma Assert (Decls /= No_List);
2945
2946       if Restriction_Active (No_Exception_Propagation) then
2947          Data.Abort_Id := Empty;
2948          Data.E_Id := Empty;
2949          Data.Raised_Id := Empty;
2950          return;
2951       end if;
2952
2953       Data.Abort_Id  := Make_Temporary (Loc, 'A');
2954       Data.E_Id      := Make_Temporary (Loc, 'E');
2955       Data.Raised_Id := Make_Temporary (Loc, 'R');
2956       Data.Loc       := Loc;
2957
2958       --  In certain scenarios, finalization can be triggered by an abort. If
2959       --  the finalization itself fails and raises an exception, the resulting
2960       --  Program_Error must be supressed and replaced by an abort signal. In
2961       --  order to detect this scenario, save the state of entry into the
2962       --  finalization code.
2963
2964       --  No need to do this for VM case, since VM version of Ada.Exceptions
2965       --  does not include routine Raise_From_Controlled_Operation which is the
2966       --  the sole user of flag Abort.
2967
2968       --  This is not needed for library-level finalizers as they are called
2969       --  by the environment task and cannot be aborted.
2970
2971       if Abort_Allowed
2972         and then VM_Target = No_VM
2973         and then not For_Package
2974       then
2975          A_Expr := New_Reference_To (RTE (RE_Triggered_By_Abort), Loc);
2976
2977       --  No abort, .NET/JVM or library-level finalizers
2978
2979       else
2980          A_Expr := New_Reference_To (Standard_False, Loc);
2981       end if;
2982
2983       --  Generate:
2984       --    Abort_Id : constant Boolean := <A_Expr>;
2985
2986       Append_To (Decls,
2987         Make_Object_Declaration (Loc,
2988           Defining_Identifier => Data.Abort_Id,
2989           Constant_Present    => True,
2990           Object_Definition   => New_Reference_To (Standard_Boolean, Loc),
2991           Expression          => A_Expr));
2992
2993       --  Generate:
2994       --    E_Id : Exception_Occurrence;
2995
2996       E_Decl :=
2997         Make_Object_Declaration (Loc,
2998           Defining_Identifier => Data.E_Id,
2999           Object_Definition   =>
3000             New_Reference_To (RTE (RE_Exception_Occurrence), Loc));
3001       Set_No_Initialization (E_Decl);
3002
3003       Append_To (Decls, E_Decl);
3004
3005       --  Generate:
3006       --    Raised_Id : Boolean := False;
3007
3008       Append_To (Decls,
3009         Make_Object_Declaration (Loc,
3010           Defining_Identifier => Data.Raised_Id,
3011           Object_Definition   => New_Reference_To (Standard_Boolean, Loc),
3012           Expression          => New_Reference_To (Standard_False, Loc)));
3013    end Build_Object_Declarations;
3014
3015    ---------------------------
3016    -- Build_Raise_Statement --
3017    ---------------------------
3018
3019    function Build_Raise_Statement
3020      (Data : Finalization_Exception_Data) return Node_Id
3021    is
3022       Stmt : Node_Id;
3023
3024    begin
3025       --  Standard run-time and .NET/JVM targets use the specialized routine
3026       --  Raise_From_Controlled_Operation.
3027
3028       if RTE_Available (RE_Raise_From_Controlled_Operation) then
3029          Stmt :=
3030            Make_Procedure_Call_Statement (Data.Loc,
3031               Name                   =>
3032                 New_Reference_To
3033                   (RTE (RE_Raise_From_Controlled_Operation), Data.Loc),
3034               Parameter_Associations =>
3035                 New_List (New_Reference_To (Data.E_Id, Data.Loc)));
3036
3037       --  Restricted run-time: exception messages are not supported and hence
3038       --  Raise_From_Controlled_Operation is not supported. Raise Program_Error
3039       --  instead.
3040
3041       else
3042          Stmt :=
3043            Make_Raise_Program_Error (Data.Loc,
3044              Reason => PE_Finalize_Raised_Exception);
3045       end if;
3046
3047       --  Generate:
3048       --    if Raised_Id and then not Abort_Id then
3049       --       Raise_From_Controlled_Operation (E_Id);
3050       --         <or>
3051       --       raise Program_Error;  --  restricted runtime
3052       --    end if;
3053
3054       return
3055         Make_If_Statement (Data.Loc,
3056           Condition       =>
3057             Make_And_Then (Data.Loc,
3058               Left_Opnd  => New_Reference_To (Data.Raised_Id, Data.Loc),
3059               Right_Opnd =>
3060                 Make_Op_Not (Data.Loc,
3061                   Right_Opnd => New_Reference_To (Data.Abort_Id, Data.Loc))),
3062
3063           Then_Statements => New_List (Stmt));
3064    end Build_Raise_Statement;
3065
3066    -----------------------------
3067    -- Build_Record_Deep_Procs --
3068    -----------------------------
3069
3070    procedure Build_Record_Deep_Procs (Typ : Entity_Id) is
3071    begin
3072       Set_TSS (Typ,
3073         Make_Deep_Proc
3074           (Prim  => Initialize_Case,
3075            Typ   => Typ,
3076            Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
3077
3078       if not Is_Immutably_Limited_Type (Typ) then
3079          Set_TSS (Typ,
3080            Make_Deep_Proc
3081              (Prim  => Adjust_Case,
3082               Typ   => Typ,
3083               Stmts => Make_Deep_Record_Body (Adjust_Case, Typ)));
3084       end if;
3085
3086       --  Do not generate Deep_Finalize and Finalize_Address if finalization is
3087       --  suppressed since these routine will not be used.
3088
3089       if not Restriction_Active (No_Finalization) then
3090          Set_TSS (Typ,
3091            Make_Deep_Proc
3092              (Prim  => Finalize_Case,
3093               Typ   => Typ,
3094               Stmts => Make_Deep_Record_Body (Finalize_Case, Typ)));
3095
3096          --  Create TSS primitive Finalize_Address for non-VM targets. JVM and
3097          --  .NET do not support address arithmetic and unchecked conversions.
3098
3099          if VM_Target = No_VM then
3100             Set_TSS (Typ,
3101               Make_Deep_Proc
3102                 (Prim  => Address_Case,
3103                  Typ   => Typ,
3104                  Stmts => Make_Deep_Record_Body (Address_Case, Typ)));
3105          end if;
3106       end if;
3107    end Build_Record_Deep_Procs;
3108
3109    -------------------
3110    -- Cleanup_Array --
3111    -------------------
3112
3113    function Cleanup_Array
3114      (N    : Node_Id;
3115       Obj  : Node_Id;
3116       Typ  : Entity_Id) return List_Id
3117    is
3118       Loc        : constant Source_Ptr := Sloc (N);
3119       Index_List : constant List_Id := New_List;
3120
3121       function Free_Component return List_Id;
3122       --  Generate the code to finalize the task or protected  subcomponents
3123       --  of a single component of the array.
3124
3125       function Free_One_Dimension (Dim : Int) return List_Id;
3126       --  Generate a loop over one dimension of the array
3127
3128       --------------------
3129       -- Free_Component --
3130       --------------------
3131
3132       function Free_Component return List_Id is
3133          Stmts : List_Id := New_List;
3134          Tsk   : Node_Id;
3135          C_Typ : constant Entity_Id := Component_Type (Typ);
3136
3137       begin
3138          --  Component type is known to contain tasks or protected objects
3139
3140          Tsk :=
3141            Make_Indexed_Component (Loc,
3142              Prefix        => Duplicate_Subexpr_No_Checks (Obj),
3143              Expressions   => Index_List);
3144
3145          Set_Etype (Tsk, C_Typ);
3146
3147          if Is_Task_Type (C_Typ) then
3148             Append_To (Stmts, Cleanup_Task (N, Tsk));
3149
3150          elsif Is_Simple_Protected_Type (C_Typ) then
3151             Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
3152
3153          elsif Is_Record_Type (C_Typ) then
3154             Stmts := Cleanup_Record (N, Tsk, C_Typ);
3155
3156          elsif Is_Array_Type (C_Typ) then
3157             Stmts := Cleanup_Array (N, Tsk, C_Typ);
3158          end if;
3159
3160          return Stmts;
3161       end Free_Component;
3162
3163       ------------------------
3164       -- Free_One_Dimension --
3165       ------------------------
3166
3167       function Free_One_Dimension (Dim : Int) return List_Id is
3168          Index : Entity_Id;
3169
3170       begin
3171          if Dim > Number_Dimensions (Typ) then
3172             return Free_Component;
3173
3174          --  Here we generate the required loop
3175
3176          else
3177             Index := Make_Temporary (Loc, 'J');
3178             Append (New_Reference_To (Index, Loc), Index_List);
3179
3180             return New_List (
3181               Make_Implicit_Loop_Statement (N,
3182                 Identifier       => Empty,
3183                 Iteration_Scheme =>
3184                   Make_Iteration_Scheme (Loc,
3185                     Loop_Parameter_Specification =>
3186                       Make_Loop_Parameter_Specification (Loc,
3187                         Defining_Identifier         => Index,
3188                         Discrete_Subtype_Definition =>
3189                           Make_Attribute_Reference (Loc,
3190                             Prefix          => Duplicate_Subexpr (Obj),
3191                             Attribute_Name  => Name_Range,
3192                             Expressions     => New_List (
3193                               Make_Integer_Literal (Loc, Dim))))),
3194                 Statements       =>  Free_One_Dimension (Dim + 1)));
3195          end if;
3196       end Free_One_Dimension;
3197
3198    --  Start of processing for Cleanup_Array
3199
3200    begin
3201       return Free_One_Dimension (1);
3202    end Cleanup_Array;
3203
3204    --------------------
3205    -- Cleanup_Record --
3206    --------------------
3207
3208    function Cleanup_Record
3209      (N    : Node_Id;
3210       Obj  : Node_Id;
3211       Typ  : Entity_Id) return List_Id
3212    is
3213       Loc   : constant Source_Ptr := Sloc (N);
3214       Tsk   : Node_Id;
3215       Comp  : Entity_Id;
3216       Stmts : constant List_Id    := New_List;
3217       U_Typ : constant Entity_Id  := Underlying_Type (Typ);
3218
3219    begin
3220       if Has_Discriminants (U_Typ)
3221         and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration
3222         and then
3223           Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition
3224         and then
3225           Present
3226             (Variant_Part (Component_List (Type_Definition (Parent (U_Typ)))))
3227       then
3228          --  For now, do not attempt to free a component that may appear in a
3229          --  variant, and instead issue a warning. Doing this "properly" would
3230          --  require building a case statement and would be quite a mess. Note
3231          --  that the RM only requires that free "work" for the case of a task
3232          --  access value, so already we go way beyond this in that we deal
3233          --  with the array case and non-discriminated record cases.
3234
3235          Error_Msg_N
3236            ("task/protected object in variant record will not be freed?", N);
3237          return New_List (Make_Null_Statement (Loc));
3238       end if;
3239
3240       Comp := First_Component (Typ);
3241       while Present (Comp) loop
3242          if Has_Task (Etype (Comp))
3243            or else Has_Simple_Protected_Object (Etype (Comp))
3244          then
3245             Tsk :=
3246               Make_Selected_Component (Loc,
3247                 Prefix        => Duplicate_Subexpr_No_Checks (Obj),
3248                 Selector_Name => New_Occurrence_Of (Comp, Loc));
3249             Set_Etype (Tsk, Etype (Comp));
3250
3251             if Is_Task_Type (Etype (Comp)) then
3252                Append_To (Stmts, Cleanup_Task (N, Tsk));
3253
3254             elsif Is_Simple_Protected_Type (Etype (Comp)) then
3255                Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
3256
3257             elsif Is_Record_Type (Etype (Comp)) then
3258
3259                --  Recurse, by generating the prefix of the argument to
3260                --  the eventual cleanup call.
3261
3262                Append_List_To (Stmts, Cleanup_Record (N, Tsk, Etype (Comp)));
3263
3264             elsif Is_Array_Type (Etype (Comp)) then
3265                Append_List_To (Stmts, Cleanup_Array (N, Tsk, Etype (Comp)));
3266             end if;
3267          end if;
3268
3269          Next_Component (Comp);
3270       end loop;
3271
3272       return Stmts;
3273    end Cleanup_Record;
3274
3275    ------------------------------
3276    -- Cleanup_Protected_Object --
3277    ------------------------------
3278
3279    function Cleanup_Protected_Object
3280      (N   : Node_Id;
3281       Ref : Node_Id) return Node_Id
3282    is
3283       Loc : constant Source_Ptr := Sloc (N);
3284
3285    begin
3286       --  For restricted run-time libraries (Ravenscar), tasks are
3287       --  non-terminating, and protected objects can only appear at library
3288       --  level, so we do not want finalization of protected objects.
3289
3290       if Restricted_Profile then
3291          return Empty;
3292
3293       else
3294          return
3295            Make_Procedure_Call_Statement (Loc,
3296              Name                   =>
3297                New_Reference_To (RTE (RE_Finalize_Protection), Loc),
3298              Parameter_Associations => New_List (Concurrent_Ref (Ref)));
3299       end if;
3300    end Cleanup_Protected_Object;
3301
3302    ------------------
3303    -- Cleanup_Task --
3304    ------------------
3305
3306    function Cleanup_Task
3307      (N   : Node_Id;
3308       Ref : Node_Id) return Node_Id
3309    is
3310       Loc  : constant Source_Ptr := Sloc (N);
3311
3312    begin
3313       --  For restricted run-time libraries (Ravenscar), tasks are
3314       --  non-terminating and they can only appear at library level, so we do
3315       --  not want finalization of task objects.
3316
3317       if Restricted_Profile then
3318          return Empty;
3319
3320       else
3321          return
3322            Make_Procedure_Call_Statement (Loc,
3323              Name                   =>
3324                New_Reference_To (RTE (RE_Free_Task), Loc),
3325              Parameter_Associations => New_List (Concurrent_Ref (Ref)));
3326       end if;
3327    end Cleanup_Task;
3328
3329    ------------------------------
3330    -- Check_Visibly_Controlled --
3331    ------------------------------
3332
3333    procedure Check_Visibly_Controlled
3334      (Prim : Final_Primitives;
3335       Typ  : Entity_Id;
3336       E    : in out Entity_Id;
3337       Cref : in out Node_Id)
3338    is
3339       Parent_Type : Entity_Id;
3340       Op          : Entity_Id;
3341
3342    begin
3343       if Is_Derived_Type (Typ)
3344         and then Comes_From_Source (E)
3345         and then not Present (Overridden_Operation (E))
3346       then
3347          --  We know that the explicit operation on the type does not override
3348          --  the inherited operation of the parent, and that the derivation
3349          --  is from a private type that is not visibly controlled.
3350
3351          Parent_Type := Etype (Typ);
3352          Op := Find_Prim_Op (Parent_Type, Name_Of (Prim));
3353
3354          if Present (Op) then
3355             E := Op;
3356
3357             --  Wrap the object to be initialized into the proper
3358             --  unchecked conversion, to be compatible with the operation
3359             --  to be called.
3360
3361             if Nkind (Cref) = N_Unchecked_Type_Conversion then
3362                Cref := Unchecked_Convert_To (Parent_Type, Expression (Cref));
3363             else
3364                Cref := Unchecked_Convert_To (Parent_Type, Cref);
3365             end if;
3366          end if;
3367       end if;
3368    end Check_Visibly_Controlled;
3369
3370    -------------------------------
3371    -- CW_Or_Has_Controlled_Part --
3372    -------------------------------
3373
3374    function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is
3375    begin
3376       return Is_Class_Wide_Type (T) or else Needs_Finalization (T);
3377    end CW_Or_Has_Controlled_Part;
3378
3379    ------------------
3380    -- Convert_View --
3381    ------------------
3382
3383    function Convert_View
3384      (Proc : Entity_Id;
3385       Arg  : Node_Id;
3386       Ind  : Pos := 1) return Node_Id
3387    is
3388       Fent : Entity_Id := First_Entity (Proc);
3389       Ftyp : Entity_Id;
3390       Atyp : Entity_Id;
3391
3392    begin
3393       for J in 2 .. Ind loop
3394          Next_Entity (Fent);
3395       end loop;
3396
3397       Ftyp := Etype (Fent);
3398
3399       if Nkind_In (Arg, N_Type_Conversion, N_Unchecked_Type_Conversion) then
3400          Atyp := Entity (Subtype_Mark (Arg));
3401       else
3402          Atyp := Etype (Arg);
3403       end if;
3404
3405       if Is_Abstract_Subprogram (Proc) and then Is_Tagged_Type (Ftyp) then
3406          return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg);
3407
3408       elsif Ftyp /= Atyp
3409         and then Present (Atyp)
3410         and then (Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp))
3411         and then Base_Type (Underlying_Type (Atyp)) =
3412                  Base_Type (Underlying_Type (Ftyp))
3413       then
3414          return Unchecked_Convert_To (Ftyp, Arg);
3415
3416       --  If the argument is already a conversion, as generated by
3417       --  Make_Init_Call, set the target type to the type of the formal
3418       --  directly, to avoid spurious typing problems.
3419
3420       elsif Nkind_In (Arg, N_Unchecked_Type_Conversion, N_Type_Conversion)
3421         and then not Is_Class_Wide_Type (Atyp)
3422       then
3423          Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg)));
3424          Set_Etype (Arg, Ftyp);
3425          return Arg;
3426
3427       else
3428          return Arg;
3429       end if;
3430    end Convert_View;
3431
3432    ------------------------
3433    -- Enclosing_Function --
3434    ------------------------
3435
3436    function Enclosing_Function (E : Entity_Id) return Entity_Id is
3437       Func_Id : Entity_Id;
3438
3439    begin
3440       Func_Id := E;
3441       while Present (Func_Id)
3442         and then Func_Id /= Standard_Standard
3443       loop
3444          if Ekind (Func_Id) = E_Function then
3445             return Func_Id;
3446          end if;
3447
3448          Func_Id := Scope (Func_Id);
3449       end loop;
3450
3451       return Empty;
3452    end Enclosing_Function;
3453
3454    -------------------------------
3455    -- Establish_Transient_Scope --
3456    -------------------------------
3457
3458    --  This procedure is called each time a transient block has to be inserted
3459    --  that is to say for each call to a function with unconstrained or tagged
3460    --  result. It creates a new scope on the stack scope in order to enclose
3461    --  all transient variables generated
3462
3463    procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean) is
3464       Loc       : constant Source_Ptr := Sloc (N);
3465       Wrap_Node : Node_Id;
3466
3467    begin
3468       --  Do not create a transient scope if we are already inside one
3469
3470       for S in reverse Scope_Stack.First .. Scope_Stack.Last loop
3471          if Scope_Stack.Table (S).Is_Transient then
3472             if Sec_Stack then
3473                Set_Uses_Sec_Stack (Scope_Stack.Table (S).Entity);
3474             end if;
3475
3476             return;
3477
3478          --  If we have encountered Standard there are no enclosing
3479          --  transient scopes.
3480
3481          elsif Scope_Stack.Table (S).Entity = Standard_Standard then
3482             exit;
3483          end if;
3484       end loop;
3485
3486       Wrap_Node := Find_Node_To_Be_Wrapped (N);
3487
3488       --  Case of no wrap node, false alert, no transient scope needed
3489
3490       if No (Wrap_Node) then
3491          null;
3492
3493       --  If the node to wrap is an iteration_scheme, the expression is
3494       --  one of the bounds, and the expansion will make an explicit
3495       --  declaration for it (see Analyze_Iteration_Scheme, sem_ch5.adb),
3496       --  so do not apply any transformations here.
3497
3498       elsif Nkind (Wrap_Node) = N_Iteration_Scheme then
3499          null;
3500
3501       --  In formal verification mode, if the node to wrap is a pragma check,
3502       --  this node and enclosed expression are not expanded, so do not apply
3503       --  any transformations here.
3504
3505       elsif Alfa_Mode
3506         and then Nkind (Wrap_Node) = N_Pragma
3507         and then Get_Pragma_Id (Wrap_Node) = Pragma_Check
3508       then
3509          null;
3510
3511       else
3512          Push_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'));
3513          Set_Scope_Is_Transient;
3514
3515          if Sec_Stack then
3516             Set_Uses_Sec_Stack (Current_Scope);
3517             Check_Restriction (No_Secondary_Stack, N);
3518          end if;
3519
3520          Set_Etype (Current_Scope, Standard_Void_Type);
3521          Set_Node_To_Be_Wrapped (Wrap_Node);
3522
3523          if Debug_Flag_W then
3524             Write_Str ("    <Transient>");
3525             Write_Eol;
3526          end if;
3527       end if;
3528    end Establish_Transient_Scope;
3529
3530    ----------------------------
3531    -- Expand_Cleanup_Actions --
3532    ----------------------------
3533
3534    procedure Expand_Cleanup_Actions (N : Node_Id) is
3535       Scop : constant Entity_Id := Current_Scope;
3536
3537       Is_Asynchronous_Call : constant Boolean :=
3538                                Nkind (N) = N_Block_Statement
3539                                  and then Is_Asynchronous_Call_Block (N);
3540       Is_Master            : constant Boolean :=
3541                                Nkind (N) /= N_Entry_Body
3542                                  and then Is_Task_Master (N);
3543       Is_Protected_Body    : constant Boolean :=
3544                                Nkind (N) = N_Subprogram_Body
3545                                  and then Is_Protected_Subprogram_Body (N);
3546       Is_Task_Allocation   : constant Boolean :=
3547                                Nkind (N) = N_Block_Statement
3548                                  and then Is_Task_Allocation_Block (N);
3549       Is_Task_Body         : constant Boolean :=
3550                                Nkind (Original_Node (N)) = N_Task_Body;
3551       Needs_Sec_Stack_Mark : constant Boolean :=
3552                                Uses_Sec_Stack (Scop)
3553                                  and then
3554                                    not Sec_Stack_Needed_For_Return (Scop)
3555                                  and then VM_Target = No_VM;
3556
3557       Actions_Required     : constant Boolean :=
3558                                Requires_Cleanup_Actions (N)
3559                                  or else Is_Asynchronous_Call
3560                                  or else Is_Master
3561                                  or else Is_Protected_Body
3562                                  or else Is_Task_Allocation
3563                                  or else Is_Task_Body
3564                                  or else Needs_Sec_Stack_Mark;
3565
3566       HSS : Node_Id := Handled_Statement_Sequence (N);
3567       Loc : Source_Ptr;
3568
3569       procedure Wrap_HSS_In_Block;
3570       --  Move HSS inside a new block along with the original exception
3571       --  handlers. Make the newly generated block the sole statement of HSS.
3572
3573       -----------------------
3574       -- Wrap_HSS_In_Block --
3575       -----------------------
3576
3577       procedure Wrap_HSS_In_Block is
3578          Block   : Node_Id;
3579          End_Lab : Node_Id;
3580
3581       begin
3582          --  Preserve end label to provide proper cross-reference information
3583
3584          End_Lab := End_Label (HSS);
3585          Block :=
3586            Make_Block_Statement (Loc,
3587              Handled_Statement_Sequence => HSS);
3588
3589          Set_Handled_Statement_Sequence (N,
3590            Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
3591          HSS := Handled_Statement_Sequence (N);
3592
3593          Set_First_Real_Statement (HSS, Block);
3594          Set_End_Label (HSS, End_Lab);
3595
3596          --  Comment needed here, see RH for 1.306 ???
3597
3598          if Nkind (N) = N_Subprogram_Body then
3599             Set_Has_Nested_Block_With_Handler (Scop);
3600          end if;
3601       end Wrap_HSS_In_Block;
3602
3603    --  Start of processing for Expand_Cleanup_Actions
3604
3605    begin
3606       --  The current construct does not need any form of servicing
3607
3608       if not Actions_Required then
3609          return;
3610
3611       --  If the current node is a rewritten task body and the descriptors have
3612       --  not been delayed (due to some nested instantiations), do not generate
3613       --  redundant cleanup actions.
3614
3615       elsif Is_Task_Body
3616         and then Nkind (N) = N_Subprogram_Body
3617         and then not Delay_Subprogram_Descriptors (Corresponding_Spec (N))
3618       then
3619          return;
3620       end if;
3621
3622       declare
3623          Decls     : List_Id := Declarations (N);
3624          Fin_Id    : Entity_Id;
3625          Mark      : Entity_Id := Empty;
3626          New_Decls : List_Id;
3627          Old_Poll  : Boolean;
3628
3629       begin
3630          --  If we are generating expanded code for debugging purposes, use the
3631          --  Sloc of the point of insertion for the cleanup code. The Sloc will
3632          --  be updated subsequently to reference the proper line in .dg files.
3633          --  If we are not debugging generated code, use No_Location instead,
3634          --  so that no debug information is generated for the cleanup code.
3635          --  This makes the behavior of the NEXT command in GDB monotonic, and
3636          --  makes the placement of breakpoints more accurate.
3637
3638          if Debug_Generated_Code then
3639             Loc := Sloc (Scop);
3640          else
3641             Loc := No_Location;
3642          end if;
3643
3644          --  Set polling off. The finalization and cleanup code is executed
3645          --  with aborts deferred.
3646
3647          Old_Poll := Polling_Required;
3648          Polling_Required := False;
3649
3650          --  A task activation call has already been built for a task
3651          --  allocation block.
3652
3653          if not Is_Task_Allocation then
3654             Build_Task_Activation_Call (N);
3655          end if;
3656
3657          if Is_Master then
3658             Establish_Task_Master (N);
3659          end if;
3660
3661          New_Decls := New_List;
3662
3663          --  If secondary stack is in use, generate:
3664          --
3665          --    Mnn : constant Mark_Id := SS_Mark;
3666
3667          --  Suppress calls to SS_Mark and SS_Release if VM_Target, since the
3668          --  secondary stack is never used on a VM.
3669
3670          if Needs_Sec_Stack_Mark then
3671             Mark := Make_Temporary (Loc, 'M');
3672
3673             Append_To (New_Decls,
3674               Make_Object_Declaration (Loc,
3675                 Defining_Identifier => Mark,
3676                 Object_Definition   =>
3677                   New_Reference_To (RTE (RE_Mark_Id), Loc),
3678                 Expression          =>
3679                   Make_Function_Call (Loc,
3680                     Name => New_Reference_To (RTE (RE_SS_Mark), Loc))));
3681
3682             Set_Uses_Sec_Stack (Scop, False);
3683          end if;
3684
3685          --  If exception handlers are present, wrap the sequence of statements
3686          --  in a block since it is not possible to have exception handlers and
3687          --  an At_End handler in the same construct.
3688
3689          if Present (Exception_Handlers (HSS)) then
3690             Wrap_HSS_In_Block;
3691
3692          --  Ensure that the First_Real_Statement field is set
3693
3694          elsif No (First_Real_Statement (HSS)) then
3695             Set_First_Real_Statement (HSS, First (Statements (HSS)));
3696          end if;
3697
3698          --  Do not move the Activation_Chain declaration in the context of
3699          --  task allocation blocks. Task allocation blocks use _chain in their
3700          --  cleanup handlers and gigi complains if it is declared in the
3701          --  sequence of statements of the scope that declares the handler.
3702
3703          if Is_Task_Allocation then
3704             declare
3705                Chain : constant Entity_Id := Activation_Chain_Entity (N);
3706                Decl  : Node_Id;
3707
3708             begin
3709                Decl := First (Decls);
3710                while Nkind (Decl) /= N_Object_Declaration
3711                  or else Defining_Identifier (Decl) /= Chain
3712                loop
3713                   Next (Decl);
3714
3715                   --  A task allocation block should always include a _chain
3716                   --  declaration.
3717
3718                   pragma Assert (Present (Decl));
3719                end loop;
3720
3721                Remove (Decl);
3722                Prepend_To (New_Decls, Decl);
3723             end;
3724          end if;
3725
3726          --  Ensure the presence of a declaration list in order to successfully
3727          --  append all original statements to it.
3728
3729        &nb