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             Build_Object_Declarations
1214               (Finalizer_Data, Finalizer_Decls, Loc, For_Package);
1215
1216             --  Since the total number of controlled objects is always known,
1217             --  build a subtype of Natural with precise bounds. This allows
1218             --  the backend to optimize the case statement. Generate:
1219             --
1220             --    subtype Tnn is Natural range 0 .. Counter_Val;
1221
1222             Counter_Typ_Decl :=
1223               Make_Subtype_Declaration (Loc,
1224                 Defining_Identifier => Counter_Typ,
1225                 Subtype_Indication  =>
1226                   Make_Subtype_Indication (Loc,
1227                     Subtype_Mark => New_Reference_To (Standard_Natural, Loc),
1228                     Constraint   =>
1229                       Make_Range_Constraint (Loc,
1230                         Range_Expression =>
1231                           Make_Range (Loc,
1232                             Low_Bound  =>
1233                               Make_Integer_Literal (Loc, Uint_0),
1234                             High_Bound =>
1235                               Make_Integer_Literal (Loc, Counter_Val)))));
1236
1237             --  Generate the declaration of the counter itself:
1238             --
1239             --    Counter : Integer := 0;
1240
1241             Counter_Decl :=
1242               Make_Object_Declaration (Loc,
1243                 Defining_Identifier => Counter_Id,
1244                 Object_Definition   => New_Reference_To (Counter_Typ, Loc),
1245                 Expression          => Make_Integer_Literal (Loc, 0));
1246
1247             --  Set the type of the counter explicitly to prevent errors when
1248             --  examining object declarations later on.
1249
1250             Set_Etype (Counter_Id, Counter_Typ);
1251
1252             --  The counter and its type are inserted before the source
1253             --  declarations of N.
1254
1255             Prepend_To (Decls, Counter_Decl);
1256             Prepend_To (Decls, Counter_Typ_Decl);
1257
1258             --  The counter and its associated type must be manually analized
1259             --  since N has already been analyzed. Use the scope of the spec
1260             --  when inserting in a package.
1261
1262             if For_Package then
1263                Push_Scope (Spec_Id);
1264                Analyze (Counter_Typ_Decl);
1265                Analyze (Counter_Decl);
1266                Pop_Scope;
1267
1268             else
1269                Analyze (Counter_Typ_Decl);
1270                Analyze (Counter_Decl);
1271             end if;
1272
1273             Jump_Alts := New_List;
1274          end if;
1275
1276          --  If the context requires additional clean up, the finalization
1277          --  machinery is added after the clean up code.
1278
1279          if Acts_As_Clean then
1280             Finalizer_Stmts       := Clean_Stmts;
1281             Jump_Block_Insert_Nod := Last (Finalizer_Stmts);
1282          else
1283             Finalizer_Stmts := New_List;
1284          end if;
1285
1286          if Has_Tagged_Types then
1287             Tagged_Type_Stmts := New_List;
1288          end if;
1289       end Build_Components;
1290
1291       ----------------------
1292       -- Create_Finalizer --
1293       ----------------------
1294
1295       procedure Create_Finalizer is
1296          Body_Id    : Entity_Id;
1297          Fin_Body   : Node_Id;
1298          Fin_Spec   : Node_Id;
1299          Jump_Block : Node_Id;
1300          Label      : Node_Id;
1301          Label_Id   : Entity_Id;
1302
1303          function New_Finalizer_Name return Name_Id;
1304          --  Create a fully qualified name of a package spec or body finalizer.
1305          --  The generated name is of the form: xx__yy__finalize_[spec|body].
1306
1307          ------------------------
1308          -- New_Finalizer_Name --
1309          ------------------------
1310
1311          function New_Finalizer_Name return Name_Id is
1312             procedure New_Finalizer_Name (Id : Entity_Id);
1313             --  Place "__<name-of-Id>" in the name buffer. If the identifier
1314             --  has a non-standard scope, process the scope first.
1315
1316             ------------------------
1317             -- New_Finalizer_Name --
1318             ------------------------
1319
1320             procedure New_Finalizer_Name (Id : Entity_Id) is
1321             begin
1322                if Scope (Id) = Standard_Standard then
1323                   Get_Name_String (Chars (Id));
1324
1325                else
1326                   New_Finalizer_Name (Scope (Id));
1327                   Add_Str_To_Name_Buffer ("__");
1328                   Add_Str_To_Name_Buffer (Get_Name_String (Chars (Id)));
1329                end if;
1330             end New_Finalizer_Name;
1331
1332          --  Start of processing for New_Finalizer_Name
1333
1334          begin
1335             --  Create the fully qualified name of the enclosing scope
1336
1337             New_Finalizer_Name (Spec_Id);
1338
1339             --  Generate:
1340             --    __finalize_[spec|body]
1341
1342             Add_Str_To_Name_Buffer ("__finalize_");
1343
1344             if For_Package_Spec then
1345                Add_Str_To_Name_Buffer ("spec");
1346             else
1347                Add_Str_To_Name_Buffer ("body");
1348             end if;
1349
1350             return Name_Find;
1351          end New_Finalizer_Name;
1352
1353       --  Start of processing for Create_Finalizer
1354
1355       begin
1356          --  Step 1: Creation of the finalizer name
1357
1358          --  Packages must use a distinct name for their finalizers since the
1359          --  binder will have to generate calls to them by name. The name is
1360          --  of the following form:
1361
1362          --    xx__yy__finalize_[spec|body]
1363
1364          if For_Package then
1365             Fin_Id := Make_Defining_Identifier (Loc, New_Finalizer_Name);
1366             Set_Has_Qualified_Name       (Fin_Id);
1367             Set_Has_Fully_Qualified_Name (Fin_Id);
1368
1369          --  The default name is _finalizer
1370
1371          else
1372             Fin_Id :=
1373               Make_Defining_Identifier (Loc,
1374                 Chars => New_External_Name (Name_uFinalizer));
1375          end if;
1376
1377          --  Step 2: Creation of the finalizer specification
1378
1379          --  Generate:
1380          --    procedure Fin_Id;
1381
1382          Fin_Spec :=
1383            Make_Subprogram_Declaration (Loc,
1384              Specification =>
1385                Make_Procedure_Specification (Loc,
1386                  Defining_Unit_Name => Fin_Id));
1387
1388          --  Step 3: Creation of the finalizer body
1389
1390          if Has_Ctrl_Objs then
1391
1392             --  Add L0, the default destination to the jump block
1393
1394             Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
1395             Set_Entity (Label_Id,
1396               Make_Defining_Identifier (Loc, Chars (Label_Id)));
1397             Label := Make_Label (Loc, Label_Id);
1398
1399             --  Generate:
1400             --    L0 : label;
1401
1402             Prepend_To (Finalizer_Decls,
1403               Make_Implicit_Label_Declaration (Loc,
1404                 Defining_Identifier => Entity (Label_Id),
1405                 Label_Construct     => Label));
1406
1407             --  Generate:
1408             --    when others =>
1409             --       goto L0;
1410
1411             Append_To (Jump_Alts,
1412               Make_Case_Statement_Alternative (Loc,
1413                 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1414                 Statements       => New_List (
1415                   Make_Goto_Statement (Loc,
1416                     Name => New_Reference_To (Entity (Label_Id), Loc)))));
1417
1418             --  Generate:
1419             --    <<L0>>
1420
1421             Append_To (Finalizer_Stmts, Label);
1422
1423             --  The local exception does not need to be reraised for library-
1424             --  level finalizers. Generate:
1425             --
1426             --    if Raised and then not Abort then
1427             --       Raise_From_Controlled_Operation (E);
1428             --    end if;
1429
1430             if not For_Package
1431               and then Exceptions_OK
1432             then
1433                Append_To (Finalizer_Stmts,
1434                  Build_Raise_Statement (Finalizer_Data));
1435             end if;
1436
1437             --  Create the jump block which controls the finalization flow
1438             --  depending on the value of the state counter.
1439
1440             Jump_Block :=
1441               Make_Case_Statement (Loc,
1442                 Expression   => Make_Identifier (Loc, Chars (Counter_Id)),
1443                 Alternatives => Jump_Alts);
1444
1445             if Acts_As_Clean
1446               and then Present (Jump_Block_Insert_Nod)
1447             then
1448                Insert_After (Jump_Block_Insert_Nod, Jump_Block);
1449             else
1450                Prepend_To (Finalizer_Stmts, Jump_Block);
1451             end if;
1452          end if;
1453
1454          --  Add the library-level tagged type unregistration machinery before
1455          --  the jump block circuitry. This ensures that external tags will be
1456          --  removed even if a finalization exception occurs at some point.
1457
1458          if Has_Tagged_Types then
1459             Prepend_List_To (Finalizer_Stmts, Tagged_Type_Stmts);
1460          end if;
1461
1462          --  Add a call to the previous At_End handler if it exists. The call
1463          --  must always precede the jump block.
1464
1465          if Present (Prev_At_End) then
1466             Prepend_To (Finalizer_Stmts,
1467               Make_Procedure_Call_Statement (Loc, Prev_At_End));
1468
1469             --  Clear the At_End handler since we have already generated the
1470             --  proper replacement call for it.
1471
1472             Set_At_End_Proc (HSS, Empty);
1473          end if;
1474
1475          --  Release the secondary stack mark
1476
1477          if Present (Mark_Id) then
1478             Append_To (Finalizer_Stmts,
1479               Make_Procedure_Call_Statement (Loc,
1480                 Name                   =>
1481                   New_Reference_To (RTE (RE_SS_Release), Loc),
1482                 Parameter_Associations => New_List (
1483                   New_Reference_To (Mark_Id, Loc))));
1484          end if;
1485
1486          --  Protect the statements with abort defer/undefer. This is only when
1487          --  aborts are allowed and the clean up statements require deferral or
1488          --  there are controlled objects to be finalized.
1489
1490          if Abort_Allowed
1491            and then
1492              (Defer_Abort or else Has_Ctrl_Objs)
1493          then
1494             Prepend_To (Finalizer_Stmts,
1495               Make_Procedure_Call_Statement (Loc,
1496                 Name => New_Reference_To (RTE (RE_Abort_Defer), Loc)));
1497
1498             Append_To (Finalizer_Stmts,
1499               Make_Procedure_Call_Statement (Loc,
1500                 Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)));
1501          end if;
1502
1503          --  Generate:
1504          --    procedure Fin_Id is
1505          --       Abort  : constant Boolean := Triggered_By_Abort;
1506          --         <or>
1507          --       Abort  : constant Boolean := False;  --  no abort
1508
1509          --       E      : Exception_Occurrence;  --  All added if flag
1510          --       Raised : Boolean := False;      --  Has_Ctrl_Objs is set
1511          --       L0     : label;
1512          --       ...
1513          --       Lnn    : label;
1514
1515          --    begin
1516          --       Abort_Defer;               --  Added if abort is allowed
1517          --       <call to Prev_At_End>      --  Added if exists
1518          --       <cleanup statements>       --  Added if Acts_As_Clean
1519          --       <jump block>               --  Added if Has_Ctrl_Objs
1520          --       <finalization statements>  --  Added if Has_Ctrl_Objs
1521          --       <stack release>            --  Added if Mark_Id exists
1522          --       Abort_Undefer;             --  Added if abort is allowed
1523          --    end Fin_Id;
1524
1525          --  Create the body of the finalizer
1526
1527          Body_Id := Make_Defining_Identifier (Loc, Chars (Fin_Id));
1528
1529          if For_Package then
1530             Set_Has_Qualified_Name       (Body_Id);
1531             Set_Has_Fully_Qualified_Name (Body_Id);
1532          end if;
1533
1534          Fin_Body :=
1535            Make_Subprogram_Body (Loc,
1536              Specification              =>
1537                Make_Procedure_Specification (Loc,
1538                  Defining_Unit_Name => Body_Id),
1539              Declarations               => Finalizer_Decls,
1540              Handled_Statement_Sequence =>
1541                Make_Handled_Sequence_Of_Statements (Loc, Finalizer_Stmts));
1542
1543          --  Step 4: Spec and body insertion, analysis
1544
1545          if For_Package then
1546
1547             --  If the package spec has private declarations, the finalizer
1548             --  body must be added to the end of the list in order to have
1549             --  visibility of all private controlled objects.
1550
1551             if For_Package_Spec then
1552                if Present (Priv_Decls) then
1553                   Append_To (Priv_Decls, Fin_Spec);
1554                   Append_To (Priv_Decls, Fin_Body);
1555                else
1556                   Append_To (Decls, Fin_Spec);
1557                   Append_To (Decls, Fin_Body);
1558                end if;
1559
1560             --  For package bodies, both the finalizer spec and body are
1561             --  inserted at the end of the package declarations.
1562
1563             else
1564                Append_To (Decls, Fin_Spec);
1565                Append_To (Decls, Fin_Body);
1566             end if;
1567
1568             --  Push the name of the package
1569
1570             Push_Scope (Spec_Id);
1571             Analyze (Fin_Spec);
1572             Analyze (Fin_Body);
1573             Pop_Scope;
1574
1575          --  Non-package case
1576
1577          else
1578             --  Create the spec for the finalizer. The At_End handler must be
1579             --  able to call the body which resides in a nested structure.
1580
1581             --  Generate:
1582             --    declare
1583             --       procedure Fin_Id;                  --  Spec
1584             --    begin
1585             --       <objects and possibly statements>
1586             --       procedure Fin_Id is ...            --  Body
1587             --       <statements>
1588             --    at end
1589             --       Fin_Id;                            --  At_End handler
1590             --    end;
1591
1592             pragma Assert (Present (Spec_Decls));
1593
1594             Append_To (Spec_Decls, Fin_Spec);
1595             Analyze (Fin_Spec);
1596
1597             --  When the finalizer acts solely as a clean up routine, the body
1598             --  is inserted right after the spec.
1599
1600             if Acts_As_Clean
1601               and then not Has_Ctrl_Objs
1602             then
1603                Insert_After (Fin_Spec, Fin_Body);
1604
1605             --  In all other cases the body is inserted after either:
1606             --
1607             --    1) The counter update statement of the last controlled object
1608             --    2) The last top level nested controlled package
1609             --    3) The last top level controlled instantiation
1610
1611             else
1612                --  Manually freeze the spec. This is somewhat of a hack because
1613                --  a subprogram is frozen when its body is seen and the freeze
1614                --  node appears right before the body. However, in this case,
1615                --  the spec must be frozen earlier since the At_End handler
1616                --  must be able to call it.
1617                --
1618                --    declare
1619                --       procedure Fin_Id;               --  Spec
1620                --       [Fin_Id]                        --  Freeze node
1621                --    begin
1622                --       ...
1623                --    at end
1624                --       Fin_Id;                         --  At_End handler
1625                --    end;
1626
1627                Ensure_Freeze_Node (Fin_Id);
1628                Insert_After (Fin_Spec, Freeze_Node (Fin_Id));
1629                Set_Is_Frozen (Fin_Id);
1630
1631                --  In the case where the last construct to contain a controlled
1632                --  object is either a nested package, an instantiation or a
1633                --  freeze node, the body must be inserted directly after the
1634                --  construct.
1635
1636                if Nkind_In (Last_Top_Level_Ctrl_Construct,
1637                               N_Freeze_Entity,
1638                               N_Package_Declaration,
1639                               N_Package_Body)
1640                then
1641                   Finalizer_Insert_Nod := Last_Top_Level_Ctrl_Construct;
1642                end if;
1643
1644                Insert_After (Finalizer_Insert_Nod, Fin_Body);
1645             end if;
1646
1647             Analyze (Fin_Body);
1648          end if;
1649       end Create_Finalizer;
1650
1651       --------------------------
1652       -- Process_Declarations --
1653       --------------------------
1654
1655       procedure Process_Declarations
1656         (Decls      : List_Id;
1657          Preprocess : Boolean := False;
1658          Top_Level  : Boolean := False)
1659       is
1660          Decl    : Node_Id;
1661          Expr    : Node_Id;
1662          Obj_Id  : Entity_Id;
1663          Obj_Typ : Entity_Id;
1664          Pack_Id : Entity_Id;
1665          Spec    : Node_Id;
1666          Typ     : Entity_Id;
1667
1668          Old_Counter_Val : Int;
1669          --  This variable is used to determine whether a nested package or
1670          --  instance contains at least one controlled object.
1671
1672          procedure Processing_Actions
1673            (Has_No_Init  : Boolean := False;
1674             Is_Protected : Boolean := False);
1675          --  Depending on the mode of operation of Process_Declarations, either
1676          --  increment the controlled object counter, set the controlled object
1677          --  flag and store the last top level construct or process the current
1678          --  declaration. Flag Has_No_Init is used to propagate scenarios where
1679          --  the current declaration may not have initialization proc(s). Flag
1680          --  Is_Protected should be set when the current declaration denotes a
1681          --  simple protected object.
1682
1683          ------------------------
1684          -- Processing_Actions --
1685          ------------------------
1686
1687          procedure Processing_Actions
1688            (Has_No_Init  : Boolean := False;
1689             Is_Protected : Boolean := False)
1690          is
1691          begin
1692             --  Library-level tagged type
1693
1694             if Nkind (Decl) = N_Full_Type_Declaration then
1695                if Preprocess then
1696                   Has_Tagged_Types := True;
1697
1698                   if Top_Level
1699                     and then No (Last_Top_Level_Ctrl_Construct)
1700                   then
1701                      Last_Top_Level_Ctrl_Construct := Decl;
1702                   end if;
1703
1704                else
1705                   Process_Tagged_Type_Declaration (Decl);
1706                end if;
1707
1708             --  Controlled object declaration
1709
1710             else
1711                if Preprocess then
1712                   Counter_Val   := Counter_Val + 1;
1713                   Has_Ctrl_Objs := True;
1714
1715                   if Top_Level
1716                     and then No (Last_Top_Level_Ctrl_Construct)
1717                   then
1718                      Last_Top_Level_Ctrl_Construct := Decl;
1719                   end if;
1720
1721                else
1722                   Process_Object_Declaration (Decl, Has_No_Init, Is_Protected);
1723                end if;
1724             end if;
1725          end Processing_Actions;
1726
1727       --  Start of processing for Process_Declarations
1728
1729       begin
1730          if No (Decls) or else Is_Empty_List (Decls) then
1731             return;
1732          end if;
1733
1734          --  Process all declarations in reverse order
1735
1736          Decl := Last_Non_Pragma (Decls);
1737          while Present (Decl) loop
1738
1739             --  Library-level tagged types
1740
1741             if Nkind (Decl) = N_Full_Type_Declaration then
1742                Typ := Defining_Identifier (Decl);
1743
1744                if Is_Tagged_Type (Typ)
1745                  and then Is_Library_Level_Entity (Typ)
1746                  and then Convention (Typ) = Convention_Ada
1747                  and then Present (Access_Disp_Table (Typ))
1748                  and then RTE_Available (RE_Register_Tag)
1749                  and then not No_Run_Time_Mode
1750                  and then not Is_Abstract_Type (Typ)
1751                then
1752                   Processing_Actions;
1753                end if;
1754
1755             --  Regular object declarations
1756
1757             elsif Nkind (Decl) = N_Object_Declaration then
1758                Obj_Id  := Defining_Identifier (Decl);
1759                Obj_Typ := Base_Type (Etype (Obj_Id));
1760                Expr    := Expression (Decl);
1761
1762                --  Bypass any form of processing for objects which have their
1763                --  finalization disabled. This applies only to objects at the
1764                --  library level.
1765
1766                if For_Package
1767                  and then Finalize_Storage_Only (Obj_Typ)
1768                then
1769                   null;
1770
1771                --  Transient variables are treated separately in order to
1772                --  minimize the size of the generated code. For details, see
1773                --  Process_Transient_Objects.
1774
1775                elsif Is_Processed_Transient (Obj_Id) then
1776                   null;
1777
1778                --  The object is of the form:
1779                --    Obj : Typ [:= Expr];
1780
1781                --  Do not process the incomplete view of a deferred constant.
1782                --  Do not consider tag-to-class-wide conversions.
1783
1784                elsif not Is_Imported (Obj_Id)
1785                  and then Needs_Finalization (Obj_Typ)
1786                  and then not (Ekind (Obj_Id) = E_Constant
1787                                 and then not Has_Completion (Obj_Id))
1788                  and then not Is_Tag_To_CW_Conversion (Obj_Id)
1789                then
1790                   Processing_Actions;
1791
1792                --  The object is of the form:
1793                --    Obj : Access_Typ := Non_BIP_Function_Call'reference;
1794
1795                --    Obj : Access_Typ :=
1796                --            BIP_Function_Call
1797                --              (..., BIPaccess => null, ...)'reference;
1798
1799                elsif Is_Access_Type (Obj_Typ)
1800                  and then Needs_Finalization
1801                             (Available_View (Designated_Type (Obj_Typ)))
1802                  and then Present (Expr)
1803                  and then
1804                    (Is_Null_Access_BIP_Func_Call (Expr)
1805                      or else
1806                        (Is_Non_BIP_Func_Call (Expr)
1807                          and then not Is_Related_To_Func_Return (Obj_Id)))
1808                then
1809                   Processing_Actions (Has_No_Init => True);
1810
1811                --  Processing for "hook" objects generated for controlled
1812                --  transients declared inside an Expression_With_Actions.
1813
1814                elsif Is_Access_Type (Obj_Typ)
1815                  and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
1816                  and then Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) =
1817                                    N_Object_Declaration
1818                  and then Is_Finalizable_Transient
1819                             (Return_Flag_Or_Transient_Decl (Obj_Id), Decl)
1820                then
1821                   Processing_Actions (Has_No_Init => True);
1822
1823                --  Simple protected objects which use type System.Tasking.
1824                --  Protected_Objects.Protection to manage their locks should
1825                --  be treated as controlled since they require manual cleanup.
1826                --  The only exception is illustrated in the following example:
1827
1828                --     package Pkg is
1829                --        type Ctrl is new Controlled ...
1830                --        procedure Finalize (Obj : in out Ctrl);
1831                --        Lib_Obj : Ctrl;
1832                --     end Pkg;
1833
1834                --     package body Pkg is
1835                --        protected Prot is
1836                --           procedure Do_Something (Obj : in out Ctrl);
1837                --        end Prot;
1838
1839                --        protected body Prot is
1840                --           procedure Do_Something (Obj : in out Ctrl) is ...
1841                --        end Prot;
1842
1843                --        procedure Finalize (Obj : in out Ctrl) is
1844                --        begin
1845                --           Prot.Do_Something (Obj);
1846                --        end Finalize;
1847                --     end Pkg;
1848
1849                --  Since for the most part entities in package bodies depend on
1850                --  those in package specs, Prot's lock should be cleaned up
1851                --  first. The subsequent cleanup of the spec finalizes Lib_Obj.
1852                --  This act however attempts to invoke Do_Something and fails
1853                --  because the lock has disappeared.
1854
1855                elsif Ekind (Obj_Id) = E_Variable
1856                  and then not In_Library_Level_Package_Body (Obj_Id)
1857                  and then
1858                    (Is_Simple_Protected_Type (Obj_Typ)
1859                      or else Has_Simple_Protected_Object (Obj_Typ))
1860                then
1861                   Processing_Actions (Is_Protected => True);
1862                end if;
1863
1864             --  Specific cases of object renamings
1865
1866             elsif Nkind (Decl) = N_Object_Renaming_Declaration
1867               and then Nkind (Name (Decl)) = N_Explicit_Dereference
1868               and then Nkind (Prefix (Name (Decl))) = N_Identifier
1869             then
1870                Obj_Id  := Defining_Identifier (Decl);
1871                Obj_Typ := Base_Type (Etype (Obj_Id));
1872
1873                --  Bypass any form of processing for objects which have their
1874                --  finalization disabled. This applies only to objects at the
1875                --  library level.
1876
1877                if For_Package
1878                  and then Finalize_Storage_Only (Obj_Typ)
1879                then
1880                   null;
1881
1882                --  Return object of a build-in-place function. This case is
1883                --  recognized and marked by the expansion of an extended return
1884                --  statement (see Expand_N_Extended_Return_Statement).
1885
1886                elsif Needs_Finalization (Obj_Typ)
1887                  and then Is_Return_Object (Obj_Id)
1888                  and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
1889                then
1890                   Processing_Actions (Has_No_Init => True);
1891                end if;
1892
1893             --  Inspect the freeze node of an access-to-controlled type and
1894             --  look for a delayed finalization master. This case arises when
1895             --  the freeze actions are inserted at a later time than the
1896             --  expansion of the context. Since Build_Finalizer is never called
1897             --  on a single construct twice, the master will be ultimately
1898             --  left out and never finalized. This is also needed for freeze
1899             --  actions of designated types themselves, since in some cases the
1900             --  finalization master is associated with a designated type's
1901             --  freeze node rather than that of the access type (see handling
1902             --  for freeze actions in Build_Finalization_Master).
1903
1904             elsif Nkind (Decl) = N_Freeze_Entity
1905               and then Present (Actions (Decl))
1906             then
1907                Typ := Entity (Decl);
1908
1909                if (Is_Access_Type (Typ)
1910                     and then not Is_Access_Subprogram_Type (Typ)
1911                     and then Needs_Finalization
1912                                (Available_View (Designated_Type (Typ))))
1913                  or else (Is_Type (Typ) and then Needs_Finalization (Typ))
1914                then
1915                   Old_Counter_Val := Counter_Val;
1916
1917                   --  Freeze nodes are considered to be identical to packages
1918                   --  and blocks in terms of nesting. The difference is that
1919                   --  a finalization master created inside the freeze node is
1920                   --  at the same nesting level as the node itself.
1921
1922                   Process_Declarations (Actions (Decl), Preprocess);
1923
1924                   --  The freeze node contains a finalization master
1925
1926                   if Preprocess
1927                     and then Top_Level
1928                     and then No (Last_Top_Level_Ctrl_Construct)
1929                     and then Counter_Val > Old_Counter_Val
1930                   then
1931                      Last_Top_Level_Ctrl_Construct := Decl;
1932                   end if;
1933                end if;
1934
1935             --  Nested package declarations, avoid generics
1936
1937             elsif Nkind (Decl) = N_Package_Declaration then
1938                Spec    := Specification (Decl);
1939                Pack_Id := Defining_Unit_Name (Spec);
1940
1941                if Nkind (Pack_Id) = N_Defining_Program_Unit_Name then
1942                   Pack_Id := Defining_Identifier (Pack_Id);
1943                end if;
1944
1945                if Ekind (Pack_Id) /= E_Generic_Package then
1946                   Old_Counter_Val := Counter_Val;
1947                   Process_Declarations
1948                     (Private_Declarations (Spec), Preprocess);
1949                   Process_Declarations
1950                     (Visible_Declarations (Spec), Preprocess);
1951
1952                   --  Either the visible or the private declarations contain a
1953                   --  controlled object. The nested package declaration is the
1954                   --  last such construct.
1955
1956                   if Preprocess
1957                     and then Top_Level
1958                     and then No (Last_Top_Level_Ctrl_Construct)
1959                     and then Counter_Val > Old_Counter_Val
1960                   then
1961                      Last_Top_Level_Ctrl_Construct := Decl;
1962                   end if;
1963                end if;
1964
1965             --  Nested package bodies, avoid generics
1966
1967             elsif Nkind (Decl) = N_Package_Body then
1968                Spec := Corresponding_Spec (Decl);
1969
1970                if Ekind (Spec) /= E_Generic_Package then
1971                   Old_Counter_Val := Counter_Val;
1972                   Process_Declarations (Declarations (Decl), Preprocess);
1973
1974                   --  The nested package body is the last construct to contain
1975                   --  a controlled object.
1976
1977                   if Preprocess
1978                     and then Top_Level
1979                     and then No (Last_Top_Level_Ctrl_Construct)
1980                     and then Counter_Val > Old_Counter_Val
1981                   then
1982                      Last_Top_Level_Ctrl_Construct := Decl;
1983                   end if;
1984                end if;
1985
1986             --  Handle a rare case caused by a controlled transient variable
1987             --  created as part of a record init proc. The variable is wrapped
1988             --  in a block, but the block is not associated with a transient
1989             --  scope.
1990
1991             elsif Nkind (Decl) = N_Block_Statement
1992               and then Inside_Init_Proc
1993             then
1994                Old_Counter_Val := Counter_Val;
1995
1996                if Present (Handled_Statement_Sequence (Decl)) then
1997                   Process_Declarations
1998                     (Statements (Handled_Statement_Sequence (Decl)),
1999                      Preprocess);
2000                end if;
2001
2002                Process_Declarations (Declarations (Decl), Preprocess);
2003
2004                --  Either the declaration or statement list of the block has a
2005                --  controlled object.
2006
2007                if Preprocess
2008                  and then Top_Level
2009                  and then No (Last_Top_Level_Ctrl_Construct)
2010                  and then Counter_Val > Old_Counter_Val
2011                then
2012                   Last_Top_Level_Ctrl_Construct := Decl;
2013                end if;
2014             end if;
2015
2016             Prev_Non_Pragma (Decl);
2017          end loop;
2018       end Process_Declarations;
2019
2020       --------------------------------
2021       -- Process_Object_Declaration --
2022       --------------------------------
2023
2024       procedure Process_Object_Declaration
2025         (Decl         : Node_Id;
2026          Has_No_Init  : Boolean := False;
2027          Is_Protected : Boolean := False)
2028       is
2029          Obj_Id    : constant Entity_Id := Defining_Identifier (Decl);
2030          Loc       : constant Source_Ptr := Sloc (Decl);
2031          Body_Ins  : Node_Id;
2032          Count_Ins : Node_Id;
2033          Fin_Call  : Node_Id;
2034          Fin_Stmts : List_Id;
2035          Inc_Decl  : Node_Id;
2036          Label     : Node_Id;
2037          Label_Id  : Entity_Id;
2038          Obj_Ref   : Node_Id;
2039          Obj_Typ   : Entity_Id;
2040
2041          function Build_BIP_Cleanup_Stmts (Func_Id : Entity_Id) return Node_Id;
2042          --  Once it has been established that the current object is in fact a
2043          --  return object of build-in-place function Func_Id, generate the
2044          --  following cleanup code:
2045          --
2046          --    if BIPallocfrom > Secondary_Stack'Pos
2047          --      and then BIPfinalizationmaster /= null
2048          --    then
2049          --       declare
2050          --          type Ptr_Typ is access Obj_Typ;
2051          --          for Ptr_Typ'Storage_Pool
2052          --            use Base_Pool (BIPfinalizationmaster);
2053          --       begin
2054          --          Free (Ptr_Typ (Temp));
2055          --       end;
2056          --    end if;
2057          --
2058          --  Obj_Typ is the type of the current object, Temp is the original
2059          --  allocation which Obj_Id renames.
2060
2061          procedure Find_Last_Init
2062            (Decl        : Node_Id;
2063             Typ         : Entity_Id;
2064             Last_Init   : out Node_Id;
2065             Body_Insert : out Node_Id);
2066          --  An object declaration has at least one and at most two init calls:
2067          --  that of the type and the user-defined initialize. Given an object
2068          --  declaration, Last_Init denotes the last initialization call which
2069          --  follows the declaration. Body_Insert denotes the place where the
2070          --  finalizer body could be potentially inserted.
2071
2072          -----------------------------
2073          -- Build_BIP_Cleanup_Stmts --
2074          -----------------------------
2075
2076          function Build_BIP_Cleanup_Stmts
2077            (Func_Id : Entity_Id) return Node_Id
2078          is
2079             Decls      : constant List_Id := New_List;
2080             Fin_Mas_Id : constant Entity_Id :=
2081                            Build_In_Place_Formal
2082                              (Func_Id, BIP_Finalization_Master);
2083             Obj_Typ    : constant Entity_Id := Etype (Func_Id);
2084             Temp_Id    : constant Entity_Id :=
2085                            Entity (Prefix (Name (Parent (Obj_Id))));
2086
2087             Cond      : Node_Id;
2088             Free_Blk  : Node_Id;
2089             Free_Stmt : Node_Id;
2090             Pool_Id   : Entity_Id;
2091             Ptr_Typ   : Entity_Id;
2092
2093          begin
2094             --  Generate:
2095             --    Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2096
2097             Pool_Id := Make_Temporary (Loc, 'P');
2098
2099             Append_To (Decls,
2100               Make_Object_Renaming_Declaration (Loc,
2101                 Defining_Identifier => Pool_Id,
2102                 Subtype_Mark        =>
2103                   New_Reference_To (RTE (RE_Root_Storage_Pool), Loc),
2104                 Name                =>
2105                   Make_Explicit_Dereference (Loc,
2106                     Prefix =>
2107                       Make_Function_Call (Loc,
2108                         Name                   =>
2109                           New_Reference_To (RTE (RE_Base_Pool), Loc),
2110                         Parameter_Associations => New_List (
2111                           Make_Explicit_Dereference (Loc,
2112                             Prefix => New_Reference_To (Fin_Mas_Id, Loc)))))));
2113
2114             --  Create an access type which uses the storage pool of the
2115             --  caller's finalization master.
2116
2117             --  Generate:
2118             --    type Ptr_Typ is access Obj_Typ;
2119
2120             Ptr_Typ := Make_Temporary (Loc, 'P');
2121
2122             Append_To (Decls,
2123               Make_Full_Type_Declaration (Loc,
2124                 Defining_Identifier => Ptr_Typ,
2125                 Type_Definition     =>
2126                   Make_Access_To_Object_Definition (Loc,
2127                     Subtype_Indication => New_Reference_To (Obj_Typ, Loc))));
2128
2129             --  Perform minor decoration in order to set the master and the
2130             --  storage pool attributes.
2131
2132             Set_Ekind (Ptr_Typ, E_Access_Type);
2133             Set_Finalization_Master     (Ptr_Typ, Fin_Mas_Id);
2134             Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
2135
2136             --  Create an explicit free statement. Note that the free uses the
2137             --  caller's pool expressed as a renaming.
2138
2139             Free_Stmt :=
2140               Make_Free_Statement (Loc,
2141                 Expression =>
2142                   Unchecked_Convert_To (Ptr_Typ,
2143                     New_Reference_To (Temp_Id, Loc)));
2144
2145             Set_Storage_Pool (Free_Stmt, Pool_Id);
2146
2147             --  Create a block to house the dummy type and the instantiation as
2148             --  well as to perform the cleanup the temporary.
2149
2150             --  Generate:
2151             --    declare
2152             --       <Decls>
2153             --    begin
2154             --       Free (Ptr_Typ (Temp_Id));
2155             --    end;
2156
2157             Free_Blk :=
2158               Make_Block_Statement (Loc,
2159                 Declarations               => Decls,
2160                 Handled_Statement_Sequence =>
2161                   Make_Handled_Sequence_Of_Statements (Loc,
2162                     Statements => New_List (Free_Stmt)));
2163
2164             --  Generate:
2165             --    if BIPfinalizationmaster /= null then
2166
2167             Cond :=
2168               Make_Op_Ne (Loc,
2169                 Left_Opnd  => New_Reference_To (Fin_Mas_Id, Loc),
2170                 Right_Opnd => Make_Null (Loc));
2171
2172             --  For constrained or tagged results escalate the condition to
2173             --  include the allocation format. Generate:
2174             --
2175             --    if BIPallocform > Secondary_Stack'Pos
2176             --      and then BIPfinalizationmaster /= null
2177             --    then
2178
2179             if not Is_Constrained (Obj_Typ)
2180               or else Is_Tagged_Type (Obj_Typ)
2181             then
2182                declare
2183                   Alloc : constant Entity_Id :=
2184                             Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
2185                begin
2186                   Cond :=
2187                     Make_And_Then (Loc,
2188                       Left_Opnd  =>
2189                         Make_Op_Gt (Loc,
2190                           Left_Opnd  => New_Reference_To (Alloc, Loc),
2191                           Right_Opnd =>
2192                             Make_Integer_Literal (Loc,
2193                               UI_From_Int
2194                                 (BIP_Allocation_Form'Pos (Secondary_Stack)))),
2195
2196                       Right_Opnd => Cond);
2197                end;
2198             end if;
2199
2200             --  Generate:
2201             --    if <Cond> then
2202             --       <Free_Blk>
2203             --    end if;
2204
2205             return
2206               Make_If_Statement (Loc,
2207                 Condition       => Cond,
2208                 Then_Statements => New_List (Free_Blk));
2209          end Build_BIP_Cleanup_Stmts;
2210
2211          --------------------
2212          -- Find_Last_Init --
2213          --------------------
2214
2215          procedure Find_Last_Init
2216            (Decl        : Node_Id;
2217             Typ         : Entity_Id;
2218             Last_Init   : out Node_Id;
2219             Body_Insert : out Node_Id)
2220          is
2221             Nod_1 : Node_Id := Empty;
2222             Nod_2 : Node_Id := Empty;
2223             Utyp  : Entity_Id;
2224
2225             function Is_Init_Call
2226               (N   : Node_Id;
2227                Typ : Entity_Id) return Boolean;
2228             --  Given an arbitrary node, determine whether N is a procedure
2229             --  call and if it is, try to match the name of the call with the
2230             --  [Deep_]Initialize proc of Typ.
2231
2232             function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id;
2233             --  Given a statement which is part of a list, return the next
2234             --  real statement while skipping over dynamic elab checks.
2235
2236             ------------------
2237             -- Is_Init_Call --
2238             ------------------
2239
2240             function Is_Init_Call
2241               (N   : Node_Id;
2242                Typ : Entity_Id) return Boolean
2243             is
2244             begin
2245                --  A call to [Deep_]Initialize is always direct
2246
2247                if Nkind (N) = N_Procedure_Call_Statement
2248                  and then Nkind (Name (N)) = N_Identifier
2249                then
2250                   declare
2251                      Call_Ent  : constant Entity_Id := Entity (Name (N));
2252                      Deep_Init : constant Entity_Id :=
2253                                    TSS (Typ, TSS_Deep_Initialize);
2254                      Init      : Entity_Id := Empty;
2255
2256                   begin
2257                      --  A type may have controlled components but not be
2258                      --  controlled.
2259
2260                      if Is_Controlled (Typ) then
2261                         Init := Find_Prim_Op (Typ, Name_Initialize);
2262
2263                         if Present (Init) then
2264                            Init := Ultimate_Alias (Init);
2265                         end if;
2266                      end if;
2267
2268                      return
2269                        (Present (Deep_Init) and then Call_Ent = Deep_Init)
2270                          or else
2271                        (Present (Init)      and then Call_Ent = Init);
2272                   end;
2273                end if;
2274
2275                return False;
2276             end Is_Init_Call;
2277
2278             -----------------------------
2279             -- Next_Suitable_Statement --
2280             -----------------------------
2281
2282             function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id is
2283                Result : Node_Id := Next (Stmt);
2284
2285             begin
2286                --  Skip over access-before-elaboration checks
2287
2288                if Dynamic_Elaboration_Checks
2289                  and then Nkind (Result) = N_Raise_Program_Error
2290                then
2291                   Result := Next (Result);
2292                end if;
2293
2294                return Result;
2295             end Next_Suitable_Statement;
2296
2297          --  Start of processing for Find_Last_Init
2298
2299          begin
2300             Last_Init   := Decl;
2301             Body_Insert := Empty;
2302
2303             --  Object renamings and objects associated with controlled
2304             --  function results do not have initialization calls.
2305
2306             if Has_No_Init then
2307                return;
2308             end if;
2309
2310             if Is_Concurrent_Type (Typ) then
2311                Utyp := Corresponding_Record_Type (Typ);
2312             else
2313                Utyp := Typ;
2314             end if;
2315
2316             if Is_Private_Type (Utyp)
2317               and then Present (Full_View (Utyp))
2318             then
2319                Utyp := Full_View (Utyp);
2320             end if;
2321
2322             --  The init procedures are arranged as follows:
2323
2324             --    Object : Controlled_Type;
2325             --    Controlled_TypeIP (Object);
2326             --    [[Deep_]Initialize (Object);]
2327
2328             --  where the user-defined initialize may be optional or may appear
2329             --  inside a block when abort deferral is needed.
2330
2331             Nod_1 := Next_Suitable_Statement (Decl);
2332             if Present (Nod_1) then
2333                Nod_2 := Next_Suitable_Statement (Nod_1);
2334
2335                --  The statement following an object declaration is always a
2336                --  call to the type init proc.
2337
2338                Last_Init := Nod_1;
2339             end if;
2340
2341             --  Optional user-defined init or deep init processing
2342
2343             if Present (Nod_2) then
2344
2345                --  The statement following the type init proc may be a block
2346                --  statement in cases where abort deferral is required.
2347
2348                if Nkind (Nod_2) = N_Block_Statement then
2349                   declare
2350                      HSS  : constant Node_Id :=
2351                               Handled_Statement_Sequence (Nod_2);
2352                      Stmt : Node_Id;
2353
2354                   begin
2355                      if Present (HSS)
2356                        and then Present (Statements (HSS))
2357                      then
2358                         Stmt := First (Statements (HSS));
2359
2360                         --  Examine individual block statements and locate the
2361                         --  call to [Deep_]Initialze.
2362
2363                         while Present (Stmt) loop
2364                            if Is_Init_Call (Stmt, Utyp) then
2365                               Last_Init   := Stmt;
2366                               Body_Insert := Nod_2;
2367
2368                               exit;
2369                            end if;
2370
2371                            Next (Stmt);
2372                         end loop;
2373                      end if;
2374                   end;
2375
2376                elsif Is_Init_Call (Nod_2, Utyp) then
2377                   Last_Init := Nod_2;
2378                end if;
2379             end if;
2380          end Find_Last_Init;
2381
2382       --  Start of processing for Process_Object_Declaration
2383
2384       begin
2385          Obj_Ref := New_Reference_To (Obj_Id, Loc);
2386          Obj_Typ := Base_Type (Etype (Obj_Id));
2387
2388          --  Handle access types
2389
2390          if Is_Access_Type (Obj_Typ) then
2391             Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
2392             Obj_Typ := Directly_Designated_Type (Obj_Typ);
2393          end if;
2394
2395          Set_Etype (Obj_Ref, Obj_Typ);
2396
2397          --  Set a new value for the state counter and insert the statement
2398          --  after the object declaration. Generate:
2399          --
2400          --    Counter := <value>;
2401
2402          Inc_Decl :=
2403            Make_Assignment_Statement (Loc,
2404              Name       => New_Reference_To (Counter_Id, Loc),
2405              Expression => Make_Integer_Literal (Loc, Counter_Val));
2406
2407          --  Insert the counter after all initialization has been done. The
2408          --  place of insertion depends on the context. When dealing with a
2409          --  controlled function, the counter is inserted directly after the
2410          --  declaration because such objects lack init calls.
2411
2412          Find_Last_Init (Decl, Obj_Typ, Count_Ins, Body_Ins);
2413
2414          Insert_After (Count_Ins, Inc_Decl);
2415          Analyze (Inc_Decl);
2416
2417          --  If the current declaration is the last in the list, the finalizer
2418          --  body needs to be inserted after the set counter statement for the
2419          --  current object declaration. This is complicated by the fact that
2420          --  the set counter statement may appear in abort deferred block. In
2421          --  that case, the proper insertion place is after the block.
2422
2423          if No (Finalizer_Insert_Nod) then
2424
2425             --  Insertion after an abort deffered block
2426
2427             if Present (Body_Ins) then
2428                Finalizer_Insert_Nod := Body_Ins;
2429             else
2430                Finalizer_Insert_Nod := Inc_Decl;
2431             end if;
2432          end if;
2433
2434          --  Create the associated label with this object, generate:
2435          --
2436          --    L<counter> : label;
2437
2438          Label_Id :=
2439            Make_Identifier (Loc, New_External_Name ('L', Counter_Val));
2440          Set_Entity
2441            (Label_Id, Make_Defining_Identifier (Loc, Chars (Label_Id)));
2442          Label := Make_Label (Loc, Label_Id);
2443
2444          Prepend_To (Finalizer_Decls,
2445            Make_Implicit_Label_Declaration (Loc,
2446              Defining_Identifier => Entity (Label_Id),
2447              Label_Construct     => Label));
2448
2449          --  Create the associated jump with this object, generate:
2450          --
2451          --    when <counter> =>
2452          --       goto L<counter>;
2453
2454          Prepend_To (Jump_Alts,
2455            Make_Case_Statement_Alternative (Loc,
2456              Discrete_Choices => New_List (
2457                Make_Integer_Literal (Loc, Counter_Val)),
2458              Statements       => New_List (
2459                Make_Goto_Statement (Loc,
2460                  Name => New_Reference_To (Entity (Label_Id), Loc)))));
2461
2462          --  Insert the jump destination, generate:
2463          --
2464          --     <<L<counter>>>
2465
2466          Append_To (Finalizer_Stmts, Label);
2467
2468          --  Processing for simple protected objects. Such objects require
2469          --  manual finalization of their lock managers.
2470
2471          if Is_Protected then
2472             Fin_Stmts := No_List;
2473
2474             if Is_Simple_Protected_Type (Obj_Typ) then
2475                Fin_Call := Cleanup_Protected_Object (Decl, Obj_Ref);
2476
2477                if Present (Fin_Call) then
2478                   Fin_Stmts := New_List (Fin_Call);
2479                end if;
2480
2481             elsif Has_Simple_Protected_Object (Obj_Typ) then
2482                if Is_Record_Type (Obj_Typ) then
2483                   Fin_Stmts := Cleanup_Record (Decl, Obj_Ref, Obj_Typ);
2484                elsif Is_Array_Type (Obj_Typ) then
2485                   Fin_Stmts := Cleanup_Array (Decl, Obj_Ref, Obj_Typ);
2486                end if;
2487             end if;
2488
2489             --  Generate:
2490             --    begin
2491             --       System.Tasking.Protected_Objects.Finalize_Protection
2492             --         (Obj._object);
2493
2494             --    exception
2495             --       when others =>
2496             --          null;
2497             --    end;
2498
2499             if Present (Fin_Stmts) then
2500                Append_To (Finalizer_Stmts,
2501                  Make_Block_Statement (Loc,
2502                    Handled_Statement_Sequence =>
2503                      Make_Handled_Sequence_Of_Statements (Loc,
2504                        Statements         => Fin_Stmts,
2505
2506                        Exception_Handlers => New_List (
2507                          Make_Exception_Handler (Loc,
2508                            Exception_Choices => New_List (
2509                              Make_Others_Choice (Loc)),
2510
2511                            Statements     => New_List (
2512                              Make_Null_Statement (Loc)))))));
2513             end if;
2514
2515          --  Processing for regular controlled objects
2516
2517          else
2518             --  Generate:
2519             --    [Deep_]Finalize (Obj);  --  No_Exception_Propagation
2520
2521             --    begin                   --  Exception handlers allowed
2522             --       [Deep_]Finalize (Obj);
2523
2524             --    exception
2525             --       when Id : others =>
2526             --          if not Raised then
2527             --             Raised := True;
2528             --             Save_Occurrence (E, Id);
2529             --          end if;
2530             --    end;
2531
2532             Fin_Call :=
2533               Make_Final_Call (
2534                 Obj_Ref => Obj_Ref,
2535                 Typ     => Obj_Typ);
2536
2537             if Exceptions_OK then
2538                Fin_Stmts := New_List (
2539                  Make_Block_Statement (Loc,
2540                    Handled_Statement_Sequence =>
2541                      Make_Handled_Sequence_Of_Statements (Loc,
2542                        Statements => New_List (Fin_Call),
2543
2544                     Exception_Handlers => New_List (
2545                       Build_Exception_Handler
2546                         (Finalizer_Data, For_Package)))));
2547
2548             --  When exception handlers are prohibited, the finalization call
2549             --  appears unprotected. Any exception raised during finalization
2550             --  will bypass the circuitry which ensures the cleanup of all
2551             --  remaining objects.
2552
2553             else
2554                Fin_Stmts := New_List (Fin_Call);
2555             end if;
2556
2557             --  If we are dealing with a return object of a build-in-place
2558             --  function, generate the following cleanup statements:
2559
2560             --    if BIPallocfrom > Secondary_Stack'Pos
2561             --      and then BIPfinalizationmaster /= null
2562             --    then
2563             --       declare
2564             --          type Ptr_Typ is access Obj_Typ;
2565             --          for Ptr_Typ'Storage_Pool use
2566             --                Base_Pool (BIPfinalizationmaster.all).all;
2567             --       begin
2568             --          Free (Ptr_Typ (Temp));
2569             --       end;
2570             --    end if;
2571             --
2572             --  The generated code effectively detaches the temporary from the
2573             --  caller finalization master and deallocates the object. This is
2574             --  disabled on .NET/JVM because pools are not supported.
2575
2576             if VM_Target = No_VM and then Is_Return_Object (Obj_Id) then
2577                declare
2578                   Func_Id : constant Entity_Id := Enclosing_Function (Obj_Id);
2579                begin
2580                   if Is_Build_In_Place_Function (Func_Id)
2581                     and then Needs_BIP_Finalization_Master (Func_Id)
2582                   then
2583                      Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id));
2584                   end if;
2585                end;
2586             end if;
2587
2588             if Ekind_In (Obj_Id, E_Constant, E_Variable)
2589               and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
2590             then
2591                --  Return objects use a flag to aid their potential
2592                --  finalization when the enclosing function fails to return
2593                --  properly. Generate:
2594
2595                --    if not Flag then
2596                --       <object finalization statements>
2597                --    end if;
2598
2599                if Is_Return_Object (Obj_Id) then
2600                   Fin_Stmts := New_List (
2601                     Make_If_Statement (Loc,
2602                       Condition     =>
2603                         Make_Op_Not (Loc,
2604                           Right_Opnd =>
2605                             New_Reference_To
2606                               (Return_Flag_Or_Transient_Decl (Obj_Id), Loc)),
2607
2608                     Then_Statements => Fin_Stmts));
2609
2610                --  Temporaries created for the purpose of "exporting" a
2611                --  controlled transient out of an Expression_With_Actions (EWA)
2612                --  need guards. The following illustrates the usage of such
2613                --  temporaries.
2614
2615                --    Access_Typ : access [all] Obj_Typ;
2616                --    Temp       : Access_Typ := null;
2617                --    <Counter>  := ...;
2618
2619                --    do
2620                --       Ctrl_Trans : [access [all]] Obj_Typ := ...;
2621                --       Temp := Access_Typ (Ctrl_Trans);  --  when a pointer
2622                --         <or>
2623                --       Temp := Ctrl_Trans'Unchecked_Access;
2624                --    in ... end;
2625
2626                --  The finalization machinery does not process EWA nodes as
2627                --  this may lead to premature finalization of expressions. Note
2628                --  that Temp is marked as being properly initialized regardless
2629                --  of whether the initialization of Ctrl_Trans succeeded. Since
2630                --  a failed initialization may leave Temp with a value of null,
2631                --  add a guard to handle this case:
2632
2633                --    if Obj /= null then
2634                --       <object finalization statements>
2635                --    end if;
2636
2637                else
2638                   pragma Assert
2639                     (Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) =
2640                        N_Object_Declaration);
2641
2642                   Fin_Stmts := New_List (
2643                     Make_If_Statement (Loc,
2644                       Condition       =>
2645                         Make_Op_Ne (Loc,
2646                           Left_Opnd  => New_Reference_To (Obj_Id, Loc),
2647                           Right_Opnd => Make_Null (Loc)),
2648
2649                       Then_Statements => Fin_Stmts));
2650                end if;
2651             end if;
2652          end if;
2653
2654          Append_List_To (Finalizer_Stmts, Fin_Stmts);
2655
2656          --  Since the declarations are examined in reverse, the state counter
2657          --  must be decremented in order to keep with the true position of
2658          --  objects.
2659
2660          Counter_Val := Counter_Val - 1;
2661       end Process_Object_Declaration;
2662
2663       -------------------------------------
2664       -- Process_Tagged_Type_Declaration --
2665       -------------------------------------
2666
2667       procedure Process_Tagged_Type_Declaration (Decl : Node_Id) is
2668          Typ    : constant Entity_Id := Defining_Identifier (Decl);
2669          DT_Ptr : constant Entity_Id :=
2670                     Node (First_Elmt (Access_Disp_Table (Typ)));
2671       begin
2672          --  Generate:
2673          --    Ada.Tags.Unregister_Tag (<Typ>P);
2674
2675          Append_To (Tagged_Type_Stmts,
2676            Make_Procedure_Call_Statement (Loc,
2677              Name                   =>
2678                New_Reference_To (RTE (RE_Unregister_Tag), Loc),
2679              Parameter_Associations => New_List (
2680                New_Reference_To (DT_Ptr, Loc))));
2681       end Process_Tagged_Type_Declaration;
2682
2683    --  Start of processing for Build_Finalizer
2684
2685    begin
2686       Fin_Id := Empty;
2687
2688       --  Do not perform this expansion in Alfa mode because it is not
2689       --  necessary.
2690
2691       if Alfa_Mode then
2692          return;
2693       end if;
2694
2695       --  Step 1: Extract all lists which may contain controlled objects or
2696       --  library-level tagged types.
2697
2698       if For_Package_Spec then
2699          Decls      := Visible_Declarations (Specification (N));
2700          Priv_Decls := Private_Declarations (Specification (N));
2701
2702          --  Retrieve the package spec id
2703
2704          Spec_Id := Defining_Unit_Name (Specification (N));
2705
2706          if Nkind (Spec_Id) = N_Defining_Program_Unit_Name then
2707             Spec_Id := Defining_Identifier (Spec_Id);
2708          end if;
2709
2710       --  Accept statement, block, entry body, package body, protected body,
2711       --  subprogram body or task body.
2712
2713       else
2714          Decls := Declarations (N);
2715          HSS   := Handled_Statement_Sequence (N);
2716
2717          if Present (HSS) then
2718             if Present (Statements (HSS)) then
2719                Stmts := Statements (HSS);
2720             end if;
2721
2722             if Present (At_End_Proc (HSS)) then
2723                Prev_At_End := At_End_Proc (HSS);
2724             end if;
2725          end if;
2726
2727          --  Retrieve the package spec id for package bodies
2728
2729          if For_Package_Body then
2730             Spec_Id := Corresponding_Spec (N);
2731          end if;
2732       end if;
2733
2734       --  Do not process nested packages since those are handled by the
2735       --  enclosing scope's finalizer. Do not process non-expanded package
2736       --  instantiations since those will be re-analyzed and re-expanded.
2737
2738       if For_Package
2739         and then
2740           (not Is_Library_Level_Entity (Spec_Id)
2741
2742              --  Nested packages are considered to be library level entities,
2743              --  but do not need to be processed separately. True library level
2744              --  packages have a scope value of 1.
2745
2746              or else Scope_Depth_Value (Spec_Id) /= Uint_1
2747              or else (Is_Generic_Instance (Spec_Id)
2748                        and then Package_Instantiation (Spec_Id) /= N))
2749       then
2750          return;
2751       end if;
2752
2753       --  Step 2: Object [pre]processing
2754
2755       if For_Package then
2756
2757          --  Preprocess the visible declarations now in order to obtain the
2758          --  correct number of controlled object by the time the private
2759          --  declarations are processed.
2760
2761          Process_Declarations (Decls, Preprocess => True, Top_Level => True);
2762
2763          --  From all the possible contexts, only package specifications may
2764          --  have private declarations.
2765
2766          if For_Package_Spec then
2767             Process_Declarations
2768               (Priv_Decls, Preprocess => True, Top_Level => True);
2769          end if;
2770
2771          --  The current context may lack controlled objects, but require some
2772          --  other form of completion (task termination for instance). In such
2773          --  cases, the finalizer must be created and carry the additional
2774          --  statements.
2775
2776          if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
2777             Build_Components;
2778          end if;
2779
2780          --  The preprocessing has determined that the context has controlled
2781          --  objects or library-level tagged types.
2782
2783          if Has_Ctrl_Objs or Has_Tagged_Types then
2784
2785             --  Private declarations are processed first in order to preserve
2786             --  possible dependencies between public and private objects.
2787
2788             if For_Package_Spec then
2789                Process_Declarations (Priv_Decls);
2790             end if;
2791
2792             Process_Declarations (Decls);
2793          end if;
2794
2795       --  Non-package case
2796
2797       else
2798          --  Preprocess both declarations and statements
2799
2800          Process_Declarations (Decls, Preprocess => True, Top_Level => True);
2801          Process_Declarations (Stmts, Preprocess => True, Top_Level => True);
2802
2803          --  At this point it is known that N has controlled objects. Ensure
2804          --  that N has a declarative list since the finalizer spec will be
2805          --  attached to it.
2806
2807          if Has_Ctrl_Objs and then No (Decls) then
2808             Set_Declarations (N, New_List);
2809             Decls      := Declarations (N);
2810             Spec_Decls := Decls;
2811          end if;
2812
2813          --  The current context may lack controlled objects, but require some
2814          --  other form of completion (task termination for instance). In such
2815          --  cases, the finalizer must be created and carry the additional
2816          --  statements.
2817
2818          if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
2819             Build_Components;
2820          end if;
2821
2822          if Has_Ctrl_Objs or Has_Tagged_Types then
2823             Process_Declarations (Stmts);
2824             Process_Declarations (Decls);
2825          end if;
2826       end if;
2827
2828       --  Step 3: Finalizer creation
2829
2830       if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
2831          Create_Finalizer;
2832       end if;
2833    end Build_Finalizer;
2834
2835    --------------------------
2836    -- Build_Finalizer_Call --
2837    --------------------------
2838
2839    procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id) is
2840       Loc : constant Source_Ptr := Sloc (N);
2841       HSS : Node_Id := Handled_Statement_Sequence (N);
2842
2843       Is_Prot_Body : constant Boolean :=
2844                        Nkind (N) = N_Subprogram_Body
2845                          and then Is_Protected_Subprogram_Body (N);
2846       --  Determine whether N denotes the protected version of a subprogram
2847       --  which belongs to a protected type.
2848
2849    begin
2850       --  Do not perform this expansion in Alfa mode because we do not create
2851       --  finalizers in the first place.
2852
2853       if Alfa_Mode then
2854          return;
2855       end if;
2856
2857       --  The At_End handler should have been assimilated by the finalizer
2858
2859       pragma Assert (No (At_End_Proc (HSS)));
2860
2861       --  If the construct to be cleaned up is a protected subprogram body, the
2862       --  finalizer call needs to be associated with the block which wraps the
2863       --  unprotected version of the subprogram. The following illustrates this
2864       --  scenario:
2865
2866       --     procedure Prot_SubpP is
2867       --        procedure finalizer is
2868       --        begin
2869       --           Service_Entries (Prot_Obj);
2870       --           Abort_Undefer;
2871       --        end finalizer;
2872
2873       --     begin
2874       --        . . .
2875       --        begin
2876       --           Prot_SubpN (Prot_Obj);
2877       --        at end
2878       --           finalizer;
2879       --        end;
2880       --     end Prot_SubpP;
2881
2882       if Is_Prot_Body then
2883          HSS := Handled_Statement_Sequence (Last (Statements (HSS)));
2884
2885       --  An At_End handler and regular exception handlers cannot coexist in
2886       --  the same statement sequence. Wrap the original statements in a block.
2887
2888       elsif Present (Exception_Handlers (HSS)) then
2889          declare
2890             End_Lab : constant Node_Id := End_Label (HSS);
2891             Block   : Node_Id;
2892
2893          begin
2894             Block :=
2895               Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS);
2896
2897             Set_Handled_Statement_Sequence (N,
2898               Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
2899
2900             HSS := Handled_Statement_Sequence (N);
2901             Set_End_Label (HSS, End_Lab);
2902          end;
2903       end if;
2904
2905       Set_At_End_Proc (HSS, New_Reference_To (Fin_Id, Loc));
2906
2907       Analyze (At_End_Proc (HSS));
2908       Expand_At_End_Handler (HSS, Empty);
2909    end Build_Finalizer_Call;
2910
2911    ---------------------
2912    -- Build_Late_Proc --
2913    ---------------------
2914
2915    procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is
2916    begin
2917       for Final_Prim in Name_Of'Range loop
2918          if Name_Of (Final_Prim) = Nam then
2919             Set_TSS (Typ,
2920               Make_Deep_Proc
2921                 (Prim  => Final_Prim,
2922                  Typ   => Typ,
2923                  Stmts => Make_Deep_Record_Body (Final_Prim, Typ)));
2924          end if;
2925       end loop;
2926    end Build_Late_Proc;
2927
2928    -------------------------------
2929    -- Build_Object_Declarations --
2930    -------------------------------
2931
2932    procedure Build_Object_Declarations
2933      (Data        : out Finalization_Exception_Data;
2934       Decls       : List_Id;
2935       Loc         : Source_Ptr;
2936       For_Package : Boolean := False)
2937    is
2938       A_Expr : Node_Id;
2939       E_Decl : Node_Id;
2940
2941    begin
2942       pragma Assert (Decls /= No_List);
2943
2944       --  Always set the proper location as it may be needed even when
2945       --  exception propagation is forbidden.
2946
2947       Data.Loc := Loc;
2948
2949       if Restriction_Active (No_Exception_Propagation) then
2950          Data.Abort_Id  := Empty;
2951          Data.E_Id      := Empty;
2952          Data.Raised_Id := Empty;
2953          return;
2954       end if;
2955
2956       Data.Abort_Id  := Make_Temporary (Loc, 'A');
2957       Data.E_Id      := Make_Temporary (Loc, 'E');
2958       Data.Raised_Id := Make_Temporary (Loc, 'R');
2959
2960       --  In certain scenarios, finalization can be triggered by an abort. If
2961       --  the finalization itself fails and raises an exception, the resulting
2962       --  Program_Error must be supressed and replaced by an abort signal. In
2963       --  order to detect this scenario, save the state of entry into the
2964       --  finalization code.
2965
2966       --  No need to do this for VM case, since VM version of Ada.Exceptions
2967       --  does not include routine Raise_From_Controlled_Operation which is the
2968       --  the sole user of flag Abort.
2969
2970       --  This is not needed for library-level finalizers as they are called
2971       --  by the environment task and cannot be aborted.
2972
2973       if Abort_Allowed
2974         and then VM_Target = No_VM
2975         and then not For_Package
2976       then
2977          A_Expr := New_Reference_To (RTE (RE_Triggered_By_Abort), Loc);
2978
2979       --  No abort, .NET/JVM or library-level finalizers
2980
2981       else
2982          A_Expr := New_Reference_To (Standard_False, Loc);
2983       end if;
2984
2985       --  Generate:
2986       --    Abort_Id : constant Boolean := <A_Expr>;
2987
2988       Append_To (Decls,
2989         Make_Object_Declaration (Loc,
2990           Defining_Identifier => Data.Abort_Id,
2991           Constant_Present    => True,
2992           Object_Definition   => New_Reference_To (Standard_Boolean, Loc),
2993           Expression          => A_Expr));
2994
2995       --  Generate:
2996       --    E_Id : Exception_Occurrence;
2997
2998       E_Decl :=
2999         Make_Object_Declaration (Loc,
3000           Defining_Identifier => Data.E_Id,
3001           Object_Definition   =>
3002             New_Reference_To (RTE (RE_Exception_Occurrence), Loc));
3003       Set_No_Initialization (E_Decl);
3004
3005       Append_To (Decls, E_Decl);
3006
3007       --  Generate:
3008       --    Raised_Id : Boolean := False;
3009
3010       Append_To (Decls,
3011         Make_Object_Declaration (Loc,
3012           Defining_Identifier => Data.Raised_Id,
3013           Object_Definition   => New_Reference_To (Standard_Boolean, Loc),
3014           Expression          => New_Reference_To (Standard_False, Loc)));
3015    end Build_Object_Declarations;
3016
3017    ---------------------------
3018    -- Build_Raise_Statement --
3019    ---------------------------
3020
3021    function Build_Raise_Statement
3022      (Data : Finalization_Exception_Data) return Node_Id
3023    is
3024       Stmt : Node_Id;
3025
3026    begin
3027       --  Standard run-time and .NET/JVM targets use the specialized routine
3028       --  Raise_From_Controlled_Operation.
3029
3030       if RTE_Available (RE_Raise_From_Controlled_Operation) then
3031          Stmt :=
3032            Make_Procedure_Call_Statement (Data.Loc,
3033               Name                   =>
3034                 New_Reference_To
3035                   (RTE (RE_Raise_From_Controlled_Operation), Data.Loc),
3036               Parameter_Associations =>
3037                 New_List (New_Reference_To (Data.E_Id, Data.Loc)));
3038
3039       --  Restricted run-time: exception messages are not supported and hence
3040       --  Raise_From_Controlled_Operation is not supported. Raise Program_Error
3041       --  instead.
3042
3043       else
3044          Stmt :=
3045            Make_Raise_Program_Error (Data.Loc,
3046              Reason => PE_Finalize_Raised_Exception);
3047       end if;
3048
3049       --  Generate:
3050       --    if Raised_Id and then not Abort_Id then
3051       --       Raise_From_Controlled_Operation (E_Id);
3052       --         <or>
3053       --       raise Program_Error;  --  restricted runtime
3054       --    end if;
3055
3056       return
3057         Make_If_Statement (Data.Loc,
3058           Condition       =>
3059             Make_And_Then (Data.Loc,
3060               Left_Opnd  => New_Reference_To (Data.Raised_Id, Data.Loc),
3061               Right_Opnd =>
3062                 Make_Op_Not (Data.Loc,
3063                   Right_Opnd => New_Reference_To (Data.Abort_Id, Data.Loc))),
3064
3065           Then_Statements => New_List (Stmt));
3066    end Build_Raise_Statement;
3067
3068    -----------------------------
3069    -- Build_Record_Deep_Procs --
3070    -----------------------------
3071
3072    procedure Build_Record_Deep_Procs (Typ : Entity_Id) is
3073    begin
3074       Set_TSS (Typ,
3075         Make_Deep_Proc
3076           (Prim  => Initialize_Case,
3077            Typ   => Typ,
3078            Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
3079
3080       if not Is_Immutably_Limited_Type (Typ) then
3081          Set_TSS (Typ,
3082            Make_Deep_Proc
3083              (Prim  => Adjust_Case,
3084               Typ   => Typ,
3085               Stmts => Make_Deep_Record_Body (Adjust_Case, Typ)));
3086       end if;
3087
3088       --  Do not generate Deep_Finalize and Finalize_Address if finalization is
3089       --  suppressed since these routine will not be used.
3090
3091       if not Restriction_Active (No_Finalization) then
3092          Set_TSS (Typ,
3093            Make_Deep_Proc
3094              (Prim  => Finalize_Case,
3095               Typ   => Typ,
3096               Stmts => Make_Deep_Record_Body (Finalize_Case, Typ)));
3097
3098          --  Create TSS primitive Finalize_Address for non-VM targets. JVM and
3099          --  .NET do not support address arithmetic and unchecked conversions.
3100
3101          if VM_Target = No_VM then
3102             Set_TSS (Typ,
3103               Make_Deep_Proc
3104                 (Prim  => Address_Case,
3105                  Typ   => Typ,
3106                  Stmts => Make_Deep_Record_Body (Address_Case, Typ)));
3107          end if;
3108       end if;
3109    end Build_Record_Deep_Procs;
3110
3111    -------------------
3112    -- Cleanup_Array --
3113    -------------------
3114
3115    function Cleanup_Array
3116      (N    : Node_Id;
3117       Obj  : Node_Id;
3118       Typ  : Entity_Id) return List_Id
3119    is
3120       Loc        : constant Source_Ptr := Sloc (N);
3121       Index_List : constant List_Id := New_List;
3122
3123       function Free_Component return List_Id;
3124       --  Generate the code to finalize the task or protected  subcomponents
3125       --  of a single component of the array.
3126
3127       function Free_One_Dimension (Dim : Int) return List_Id;
3128       --  Generate a loop over one dimension of the array
3129
3130       --------------------
3131       -- Free_Component --
3132       --------------------
3133
3134       function Free_Component return List_Id is
3135          Stmts : List_Id := New_List;
3136          Tsk   : Node_Id;
3137          C_Typ : constant Entity_Id := Component_Type (Typ);
3138
3139       begin
3140          --  Component type is known to contain tasks or protected objects
3141
3142          Tsk :=
3143            Make_Indexed_Component (Loc,
3144              Prefix        => Duplicate_Subexpr_No_Checks (Obj),
3145              Expressions   => Index_List);
3146
3147          Set_Etype (Tsk, C_Typ);
3148
3149          if Is_Task_Type (C_Typ) then
3150             Append_To (Stmts, Cleanup_Task (N, Tsk));
3151
3152          elsif Is_Simple_Protected_Type (C_Typ) then
3153             Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
3154
3155          elsif Is_Record_Type (C_Typ) then
3156             Stmts := Cleanup_Record (N, Tsk, C_Typ);
3157
3158          elsif Is_Array_Type (C_Typ) then
3159             Stmts := Cleanup_Array (N, Tsk, C_Typ);
3160          end if;
3161
3162          return Stmts;
3163       end Free_Component;
3164
3165       ------------------------
3166       -- Free_One_Dimension --
3167       ------------------------
3168
3169       function Free_One_Dimension (Dim : Int) return List_Id is
3170          Index : Entity_Id;
3171
3172       begin
3173          if Dim > Number_Dimensions (Typ) then
3174             return Free_Component;
3175
3176          --  Here we generate the required loop
3177
3178          else
3179             Index := Make_Temporary (Loc, 'J');
3180             Append (New_Reference_To (Index, Loc), Index_List);
3181
3182             return New_List (
3183               Make_Implicit_Loop_Statement (N,
3184                 Identifier       => Empty,
3185                 Iteration_Scheme =>
3186                   Make_Iteration_Scheme (Loc,
3187                     Loop_Parameter_Specification =>
3188                       Make_Loop_Parameter_Specification (Loc,
3189                         Defining_Identifier         => Index,
3190                         Discrete_Subtype_Definition =>
3191                           Make_Attribute_Reference (Loc,
3192                             Prefix          => Duplicate_Subexpr (Obj),
3193                             Attribute_Name  => Name_Range,
3194                             Expressions     => New_List (