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-2012, 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    --  ??? which entire comment?
 152
 153    -----------------------------
 154    -- Finalization Management --
 155    -----------------------------
 156
 157    --  This part describe how Initialization/Adjustment/Finalization procedures
 158    --  are generated and called. Two cases must be considered, types that are
 159    --  Controlled (Is_Controlled flag set) and composite types that contain
 160    --  controlled components (Has_Controlled_Component flag set). In the first
 161    --  case the procedures to call are the user-defined primitive operations
 162    --  Initialize/Adjust/Finalize. In the second case, GNAT generates
 163    --  Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge
 164    --  of calling the former procedures on the controlled components.
 165
 166    --  For records with Has_Controlled_Component set, a hidden "controller"
 167    --  component is inserted. This controller component contains its own
 168    --  finalization list on which all controlled components are attached
 169    --  creating an indirection on the upper-level Finalization list. This
 170    --  technique facilitates the management of objects whose number of
 171    --  controlled components changes during execution. This controller
 172    --  component is itself controlled and is attached to the upper-level
 173    --  finalization chain. Its adjust primitive is in charge of calling adjust
 174    --  on the components and adjusting the finalization pointer to match their
 175    --  new location (see a-finali.adb).
 176
 177    --  It is not possible to use a similar technique for arrays that have
 178    --  Has_Controlled_Component set. In this case, deep procedures are
 179    --  generated that call initialize/adjust/finalize + attachment or
 180    --  detachment on the finalization list for all component.
 181
 182    --  Initialize calls: they are generated for declarations or dynamic
 183    --  allocations of Controlled objects with no initial value. They are always
 184    --  followed by an attachment to the current Finalization Chain. For the
 185    --  dynamic allocation case this the chain attached to the scope of the
 186    --  access type definition otherwise, this is the chain of the current
 187    --  scope.
 188
 189    --  Adjust Calls: They are generated on 2 occasions: (1) for declarations
 190    --  or dynamic allocations of Controlled objects with an initial value.
 191    --  (2) after an assignment. In the first case they are followed by an
 192    --  attachment to the final chain, in the second case they are not.
 193
 194    --  Finalization Calls: They are generated on (1) scope exit, (2)
 195    --  assignments, (3) unchecked deallocations. In case (3) they have to
 196    --  be detached from the final chain, in case (2) they must not and in
 197    --  case (1) this is not important since we are exiting the scope anyway.
 198
 199    --  Other details:
 200
 201    --    Type extensions will have a new record controller at each derivation
 202    --    level containing controlled components. The record controller for
 203    --    the parent/ancestor is attached to the finalization list of the
 204    --    extension's record controller (i.e. the parent is like a component
 205    --    of the extension).
 206
 207    --    For types that are both Is_Controlled and Has_Controlled_Components,
 208    --    the record controller and the object itself are handled separately.
 209    --    It could seem simpler to attach the object at the end of its record
 210    --    controller but this would not tackle view conversions properly.
 211
 212    --    A classwide type can always potentially have controlled components
 213    --    but the record controller of the corresponding actual type may not
 214    --    be known at compile time so the dispatch table contains a special
 215    --    field that allows to compute the offset of the record controller
 216    --    dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
 217
 218    --  Here is a simple example of the expansion of a controlled block :
 219
 220    --    declare
 221    --       X : Controlled;
 222    --       Y : Controlled := Init;
 223    --
 224    --       type R is record
 225    --          C : Controlled;
 226    --       end record;
 227    --       W : R;
 228    --       Z : R := (C => X);
 229
 230    --    begin
 231    --       X := Y;
 232    --       W := Z;
 233    --    end;
 234    --
 235    --  is expanded into
 236    --
 237    --    declare
 238    --       _L : System.FI.Finalizable_Ptr;
 239
 240    --       procedure _Clean is
 241    --       begin
 242    --          Abort_Defer;
 243    --          System.FI.Finalize_List (_L);
 244    --          Abort_Undefer;
 245    --       end _Clean;
 246
 247    --       X : Controlled;
 248    --       begin
 249    --          Abort_Defer;
 250    --          Initialize (X);
 251    --          Attach_To_Final_List (_L, Finalizable (X), 1);
 252    --       at end: Abort_Undefer;
 253    --       Y : Controlled := Init;
 254    --       Adjust (Y);
 255    --       Attach_To_Final_List (_L, Finalizable (Y), 1);
 256    --
 257    --       type R is record
 258    --          C : Controlled;
 259    --       end record;
 260    --       W : R;
 261    --       begin
 262    --          Abort_Defer;
 263    --          Deep_Initialize (W, _L, 1);
 264    --       at end: Abort_Under;
 265    --       Z : R := (C => X);
 266    --       Deep_Adjust (Z, _L, 1);
 267
 268    --    begin
 269    --       _Assign (X, Y);
 270    --       Deep_Finalize (W, False);
 271    --       <save W's final pointers>
 272    --       W := Z;
 273    --       <restore W's final pointers>
 274    --       Deep_Adjust (W, _L, 0);
 275    --    at end
 276    --       _Clean;
 277    --    end;
 278
 279    type Final_Primitives is
 280      (Initialize_Case, Adjust_Case, Finalize_Case, Address_Case);
 281    --  This enumeration type is defined in order to ease sharing code for
 282    --  building finalization procedures for composite types.
 283
 284    Name_Of      : constant array (Final_Primitives) of Name_Id :=
 285                     (Initialize_Case => Name_Initialize,
 286                      Adjust_Case     => Name_Adjust,
 287                      Finalize_Case   => Name_Finalize,
 288                      Address_Case    => Name_Finalize_Address);
 289    Deep_Name_Of : constant array (Final_Primitives) of TSS_Name_Type :=
 290                     (Initialize_Case => TSS_Deep_Initialize,
 291                      Adjust_Case     => TSS_Deep_Adjust,
 292                      Finalize_Case   => TSS_Deep_Finalize,
 293                      Address_Case    => TSS_Finalize_Address);
 294
 295    procedure Build_Array_Deep_Procs (Typ : Entity_Id);
 296    --  Build the deep Initialize/Adjust/Finalize for a record Typ with
 297    --  Has_Controlled_Component set and store them using the TSS mechanism.
 298
 299    function Build_Cleanup_Statements (N : Node_Id) return List_Id;
 300    --  Create the clean up calls for an asynchronous call block, task master,
 301    --  protected subprogram body, task allocation block or task body. If the
 302    --  context does not contain the above constructs, the routine returns an
 303    --  empty list.
 304
 305    procedure Build_Finalizer
 306      (N           : Node_Id;
 307       Clean_Stmts : List_Id;
 308       Mark_Id     : Entity_Id;
 309       Top_Decls   : List_Id;
 310       Defer_Abort : Boolean;
 311       Fin_Id      : out Entity_Id);
 312    --  N may denote an accept statement, block, entry body, package body,
 313    --  package spec, protected body, subprogram body, and a task body. Create
 314    --  a procedure which contains finalization calls for all controlled objects
 315    --  declared in the declarative or statement region of N. The calls are
 316    --  built in reverse order relative to the original declarations. In the
 317    --  case of a tack body, the routine delays the creation of the finalizer
 318    --  until all statements have been moved to the task body procedure.
 319    --  Clean_Stmts may contain additional context-dependent code used to abort
 320    --  asynchronous calls or complete tasks (see Build_Cleanup_Statements).
 321    --  Mark_Id is the secondary stack used in the current context or Empty if
 322    --  missing. Top_Decls is the list on which the declaration of the finalizer
 323    --  is attached in the non-package case. Defer_Abort indicates that the
 324    --  statements passed in perform actions that require abort to be deferred,
 325    --  such as for task termination. Fin_Id is the finalizer declaration
 326    --  entity.
 327
 328    procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id);
 329    --  N is a construct which contains a handled sequence of statements, Fin_Id
 330    --  is the entity of a finalizer. Create an At_End handler which covers the
 331    --  statements of N and calls Fin_Id. If the handled statement sequence has
 332    --  an exception handler, the statements will be wrapped in a block to avoid
 333    --  unwanted interaction with the new At_End handler.
 334
 335    procedure Build_Record_Deep_Procs (Typ : Entity_Id);
 336    --  Build the deep Initialize/Adjust/Finalize for a record Typ with
 337    --  Has_Component_Component set and store them using the TSS mechanism.
 338
 339    procedure Check_Visibly_Controlled
 340      (Prim : Final_Primitives;
 341       Typ  : Entity_Id;
 342       E    : in out Entity_Id;
 343       Cref : in out Node_Id);
 344    --  The controlled operation declared for a derived type may not be
 345    --  overriding, if the controlled operations of the parent type are hidden,
 346    --  for example when the parent is a private type whose full view is
 347    --  controlled. For other primitive operations we modify the name of the
 348    --  operation to indicate that it is not overriding, but this is not
 349    --  possible for Initialize, etc. because they have to be retrievable by
 350    --  name. Before generating the proper call to one of these operations we
 351    --  check whether Typ is known to be controlled at the point of definition.
 352    --  If it is not then we must retrieve the hidden operation of the parent
 353    --  and use it instead.  This is one case that might be solved more cleanly
 354    --  once Overriding pragmas or declarations are in place.
 355
 356    function Convert_View
 357      (Proc : Entity_Id;
 358       Arg  : Node_Id;
 359       Ind  : Pos := 1) return Node_Id;
 360    --  Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
 361    --  argument being passed to it. Ind indicates which formal of procedure
 362    --  Proc we are trying to match. This function will, if necessary, generate
 363    --  a conversion between the partial and full view of Arg to match the type
 364    --  of the formal of Proc, or force a conversion to the class-wide type in
 365    --  the case where the operation is abstract.
 366
 367    function Enclosing_Function (E : Entity_Id) return Entity_Id;
 368    --  Given an arbitrary entity, traverse the scope chain looking for the
 369    --  first enclosing function. Return Empty if no function was found.
 370
 371    function Make_Call
 372      (Loc        : Source_Ptr;
 373       Proc_Id    : Entity_Id;
 374       Param      : Node_Id;
 375       For_Parent : Boolean := False) return Node_Id;
 376    --  Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
 377    --  routine [Deep_]Adjust / Finalize and an object parameter, create an
 378    --  adjust / finalization call. Flag For_Parent should be set when field
 379    --  _parent is being processed.
 380
 381    function Make_Deep_Proc
 382      (Prim  : Final_Primitives;
 383       Typ   : Entity_Id;
 384       Stmts : List_Id) return Node_Id;
 385    --  This function generates the tree for Deep_Initialize, Deep_Adjust or
 386    --  Deep_Finalize procedures according to the first parameter, these
 387    --  procedures operate on the type Typ. The Stmts parameter gives the body
 388    --  of the procedure.
 389
 390    function Make_Deep_Array_Body
 391      (Prim : Final_Primitives;
 392       Typ  : Entity_Id) return List_Id;
 393    --  This function generates the list of statements for implementing
 394    --  Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
 395    --  the first parameter, these procedures operate on the array type Typ.
 396
 397    function Make_Deep_Record_Body
 398      (Prim     : Final_Primitives;
 399       Typ      : Entity_Id;
 400       Is_Local : Boolean := False) return List_Id;
 401    --  This function generates the list of statements for implementing
 402    --  Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
 403    --  the first parameter, these procedures operate on the record type Typ.
 404    --  Flag Is_Local is used in conjunction with Deep_Finalize to designate
 405    --  whether the inner logic should be dictated by state counters.
 406
 407    function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id;
 408    --  Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
 409    --  Make_Deep_Record_Body. Generate the following statements:
 410    --
 411    --    declare
 412    --       type Acc_Typ is access all Typ;
 413    --       for Acc_Typ'Storage_Size use 0;
 414    --    begin
 415    --       [Deep_]Finalize (Acc_Typ (V).all);
 416    --    end;
 417
 418    ----------------------------
 419    -- Build_Array_Deep_Procs --
 420    ----------------------------
 421
 422    procedure Build_Array_Deep_Procs (Typ : Entity_Id) is
 423    begin
 424       Set_TSS (Typ,
 425         Make_Deep_Proc
 426           (Prim  => Initialize_Case,
 427            Typ   => Typ,
 428            Stmts => Make_Deep_Array_Body (Initialize_Case, Typ)));
 429
 430       if not Is_Immutably_Limited_Type (Typ) then
 431          Set_TSS (Typ,
 432            Make_Deep_Proc
 433              (Prim  => Adjust_Case,
 434               Typ   => Typ,
 435               Stmts => Make_Deep_Array_Body (Adjust_Case, Typ)));
 436       end if;
 437
 438       --  Do not generate Deep_Finalize and Finalize_Address if finalization is
 439       --  suppressed since these routine will not be used.
 440
 441       if not Restriction_Active (No_Finalization) then
 442          Set_TSS (Typ,
 443            Make_Deep_Proc
 444              (Prim  => Finalize_Case,
 445               Typ   => Typ,
 446               Stmts => Make_Deep_Array_Body (Finalize_Case, Typ)));
 447
 448          --  Create TSS primitive Finalize_Address for non-VM targets. JVM and
 449          --  .NET do not support address arithmetic and unchecked conversions.
 450
 451          if VM_Target = No_VM then
 452             Set_TSS (Typ,
 453               Make_Deep_Proc
 454                 (Prim  => Address_Case,
 455                  Typ   => Typ,
 456                  Stmts => Make_Deep_Array_Body (Address_Case, Typ)));
 457          end if;
 458       end if;
 459    end Build_Array_Deep_Procs;
 460
 461    ------------------------------
 462    -- Build_Cleanup_Statements --
 463    ------------------------------
 464
 465    function Build_Cleanup_Statements (N : Node_Id) return List_Id is
 466       Is_Asynchronous_Call : constant Boolean :=
 467                                Nkind (N) = N_Block_Statement
 468                                  and then Is_Asynchronous_Call_Block (N);
 469       Is_Master            : constant Boolean :=
 470                                Nkind (N) /= N_Entry_Body
 471                                  and then Is_Task_Master (N);
 472       Is_Protected_Body    : constant Boolean :=
 473                                Nkind (N) = N_Subprogram_Body
 474                                  and then Is_Protected_Subprogram_Body (N);
 475       Is_Task_Allocation   : constant Boolean :=
 476                                Nkind (N) = N_Block_Statement
 477                                  and then Is_Task_Allocation_Block (N);
 478       Is_Task_Body         : constant Boolean :=
 479                                Nkind (Original_Node (N)) = N_Task_Body;
 480
 481       Loc   : constant Source_Ptr := Sloc (N);
 482       Stmts : constant List_Id    := New_List;
 483
 484    begin
 485       if Is_Task_Body then
 486          if Restricted_Profile then
 487             Append_To (Stmts,
 488               Build_Runtime_Call (Loc, RE_Complete_Restricted_Task));
 489          else
 490             Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Task));
 491          end if;
 492
 493       elsif Is_Master then
 494          if Restriction_Active (No_Task_Hierarchy) = False then
 495             Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Master));
 496          end if;
 497
 498       --  Add statements to unlock the protected object parameter and to
 499       --  undefer abort. If the context is a protected procedure and the object
 500       --  has entries, call the entry service routine.
 501
 502       --  NOTE: The generated code references _object, a parameter to the
 503       --  procedure.
 504
 505       elsif Is_Protected_Body then
 506          declare
 507             Spec      : constant Node_Id := Parent (Corresponding_Spec (N));
 508             Conc_Typ  : Entity_Id;
 509             Nam       : Node_Id;
 510             Param     : Node_Id;
 511             Param_Typ : Entity_Id;
 512
 513          begin
 514             --  Find the _object parameter representing the protected object
 515
 516             Param := First (Parameter_Specifications (Spec));
 517             loop
 518                Param_Typ := Etype (Parameter_Type (Param));
 519
 520                if Ekind (Param_Typ) = E_Record_Type then
 521                   Conc_Typ := Corresponding_Concurrent_Type (Param_Typ);
 522                end if;
 523
 524                exit when No (Param) or else Present (Conc_Typ);
 525                Next (Param);
 526             end loop;
 527
 528             pragma Assert (Present (Param));
 529
 530             --  If the associated protected object has entries, a protected
 531             --  procedure has to service entry queues. In this case generate:
 532
 533             --    Service_Entries (_object._object'Access);
 534
 535             if Nkind (Specification (N)) = N_Procedure_Specification
 536               and then Has_Entries (Conc_Typ)
 537             then
 538                case Corresponding_Runtime_Package (Conc_Typ) is
 539                   when System_Tasking_Protected_Objects_Entries =>
 540                      Nam := New_Reference_To (RTE (RE_Service_Entries), Loc);
 541
 542                   when System_Tasking_Protected_Objects_Single_Entry =>
 543                      Nam := New_Reference_To (RTE (RE_Service_Entry), Loc);
 544
 545                   when others =>
 546                      raise Program_Error;
 547                end case;
 548
 549                Append_To (Stmts,
 550                  Make_Procedure_Call_Statement (Loc,
 551                    Name                   => Nam,
 552                    Parameter_Associations => New_List (
 553                      Make_Attribute_Reference (Loc,
 554                        Prefix         =>
 555                          Make_Selected_Component (Loc,
 556                            Prefix        => New_Reference_To (
 557                              Defining_Identifier (Param), Loc),
 558                            Selector_Name =>
 559                              Make_Identifier (Loc, Name_uObject)),
 560                        Attribute_Name => Name_Unchecked_Access))));
 561
 562             else
 563                --  Generate:
 564                --    Unlock (_object._object'Access);
 565
 566                case Corresponding_Runtime_Package (Conc_Typ) is
 567                   when System_Tasking_Protected_Objects_Entries =>
 568                      Nam := New_Reference_To (RTE (RE_Unlock_Entries), Loc);
 569
 570                   when System_Tasking_Protected_Objects_Single_Entry =>
 571                      Nam := New_Reference_To (RTE (RE_Unlock_Entry), Loc);
 572
 573                   when System_Tasking_Protected_Objects =>
 574                      Nam := New_Reference_To (RTE (RE_Unlock), Loc);
 575
 576                   when others =>
 577                      raise Program_Error;
 578                end case;
 579
 580                Append_To (Stmts,
 581                  Make_Procedure_Call_Statement (Loc,
 582                    Name                   => Nam,
 583                    Parameter_Associations => New_List (
 584                      Make_Attribute_Reference (Loc,
 585                        Prefix         =>
 586                          Make_Selected_Component (Loc,
 587                            Prefix        =>
 588                              New_Reference_To
 589                                (Defining_Identifier (Param), Loc),
 590                            Selector_Name =>
 591                              Make_Identifier (Loc, Name_uObject)),
 592                        Attribute_Name => Name_Unchecked_Access))));
 593             end if;
 594
 595             --  Generate:
 596             --    Abort_Undefer;
 597
 598             if Abort_Allowed then
 599                Append_To (Stmts,
 600                  Make_Procedure_Call_Statement (Loc,
 601                    Name                   =>
 602                      New_Reference_To (RTE (RE_Abort_Undefer), Loc),
 603                    Parameter_Associations => Empty_List));
 604             end if;
 605          end;
 606
 607       --  Add a call to Expunge_Unactivated_Tasks for dynamically allocated
 608       --  tasks. Other unactivated tasks are completed by Complete_Task or
 609       --  Complete_Master.
 610
 611       --  NOTE: The generated code references _chain, a local object
 612
 613       elsif Is_Task_Allocation then
 614
 615          --  Generate:
 616          --     Expunge_Unactivated_Tasks (_chain);
 617
 618          --  where _chain is the list of tasks created by the allocator but not
 619          --  yet activated. This list will be empty unless the block completes
 620          --  abnormally.
 621
 622          Append_To (Stmts,
 623            Make_Procedure_Call_Statement (Loc,
 624              Name =>
 625                New_Reference_To
 626                  (RTE (RE_Expunge_Unactivated_Tasks), Loc),
 627              Parameter_Associations => New_List (
 628                New_Reference_To (Activation_Chain_Entity (N), Loc))));
 629
 630       --  Attempt to cancel an asynchronous entry call whenever the block which
 631       --  contains the abortable part is exited.
 632
 633       --  NOTE: The generated code references Cnn, a local object
 634
 635       elsif Is_Asynchronous_Call then
 636          declare
 637             Cancel_Param : constant Entity_Id :=
 638                              Entry_Cancel_Parameter (Entity (Identifier (N)));
 639
 640          begin
 641             --  If it is of type Communication_Block, this must be a protected
 642             --  entry call. Generate:
 643
 644             --    if Enqueued (Cancel_Param) then
 645             --       Cancel_Protected_Entry_Call (Cancel_Param);
 646             --    end if;
 647
 648             if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then
 649                Append_To (Stmts,
 650                  Make_If_Statement (Loc,
 651                    Condition =>
 652                      Make_Function_Call (Loc,
 653                        Name                   =>
 654                          New_Reference_To (RTE (RE_Enqueued), Loc),
 655                        Parameter_Associations => New_List (
 656                          New_Reference_To (Cancel_Param, Loc))),
 657
 658                    Then_Statements => New_List (
 659                      Make_Procedure_Call_Statement (Loc,
 660                        Name =>
 661                          New_Reference_To
 662                            (RTE (RE_Cancel_Protected_Entry_Call), Loc),
 663                          Parameter_Associations => New_List (
 664                            New_Reference_To (Cancel_Param, Loc))))));
 665
 666             --  Asynchronous delay, generate:
 667             --    Cancel_Async_Delay (Cancel_Param);
 668
 669             elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then
 670                Append_To (Stmts,
 671                  Make_Procedure_Call_Statement (Loc,
 672                    Name                   =>
 673                      New_Reference_To (RTE (RE_Cancel_Async_Delay), Loc),
 674                    Parameter_Associations => New_List (
 675                      Make_Attribute_Reference (Loc,
 676                        Prefix         =>
 677                          New_Reference_To (Cancel_Param, Loc),
 678                        Attribute_Name => Name_Unchecked_Access))));
 679
 680             --  Task entry call, generate:
 681             --    Cancel_Task_Entry_Call (Cancel_Param);
 682
 683             else
 684                Append_To (Stmts,
 685                  Make_Procedure_Call_Statement (Loc,
 686                    Name                   =>
 687                      New_Reference_To (RTE (RE_Cancel_Task_Entry_Call), Loc),
 688                    Parameter_Associations => New_List (
 689                      New_Reference_To (Cancel_Param, Loc))));
 690             end if;
 691          end;
 692       end if;
 693
 694       return Stmts;
 695    end Build_Cleanup_Statements;
 696
 697    -----------------------------
 698    -- Build_Controlling_Procs --
 699    -----------------------------
 700
 701    procedure Build_Controlling_Procs (Typ : Entity_Id) is
 702    begin
 703       if Is_Array_Type (Typ) then
 704          Build_Array_Deep_Procs (Typ);
 705       else pragma Assert (Is_Record_Type (Typ));
 706          Build_Record_Deep_Procs (Typ);
 707       end if;
 708    end Build_Controlling_Procs;
 709
 710    -----------------------------
 711    -- Build_Exception_Handler --
 712    -----------------------------
 713
 714    function Build_Exception_Handler
 715      (Data        : Finalization_Exception_Data;
 716       For_Library : Boolean := False) return Node_Id
 717    is
 718       Actuals      : List_Id;
 719       Proc_To_Call : Entity_Id;
 720       Except       : Node_Id;
 721       Stmts        : List_Id;
 722
 723    begin
 724       pragma Assert (Present (Data.Raised_Id));
 725
 726       if Exception_Extra_Info
 727         or else (For_Library and not Restricted_Profile)
 728       then
 729          if Exception_Extra_Info then
 730
 731             --  Generate:
 732
 733             --    Get_Current_Excep.all
 734
 735             Except :=
 736               Make_Function_Call (Data.Loc,
 737                 Name =>
 738                   Make_Explicit_Dereference (Data.Loc,
 739                     Prefix =>
 740                       New_Reference_To
 741                         (RTE (RE_Get_Current_Excep), Data.Loc)));
 742
 743          else
 744             --  Generate:
 745
 746             --    null
 747
 748             Except := Make_Null (Data.Loc);
 749          end if;
 750
 751          if For_Library and then not Restricted_Profile then
 752             Proc_To_Call := RTE (RE_Save_Library_Occurrence);
 753             Actuals := New_List (Except);
 754
 755          else
 756             Proc_To_Call := RTE (RE_Save_Occurrence);
 757
 758             --  The dereference occurs only when Exception_Extra_Info is true,
 759             --  and therefore Except is not null.
 760
 761             Actuals :=
 762               New_List (
 763                 New_Reference_To (Data.E_Id, Data.Loc),
 764                 Make_Explicit_Dereference (Data.Loc, Except));
 765          end if;
 766
 767          --  Generate:
 768
 769          --    when others =>
 770          --       if not Raised_Id then
 771          --          Raised_Id := True;
 772
 773          --          Save_Occurrence (E_Id, Get_Current_Excep.all.all);
 774          --            or
 775          --          Save_Library_Occurrence (Get_Current_Excep.all);
 776          --       end if;
 777
 778          Stmts :=
 779            New_List (
 780              Make_If_Statement (Data.Loc,
 781                Condition       =>
 782                  Make_Op_Not (Data.Loc,
 783                    Right_Opnd => New_Reference_To (Data.Raised_Id, Data.Loc)),
 784
 785                Then_Statements => New_List (
 786                  Make_Assignment_Statement (Data.Loc,
 787                    Name       => New_Reference_To (Data.Raised_Id, Data.Loc),
 788                    Expression => New_Reference_To (Standard_True, Data.Loc)),
 789
 790                  Make_Procedure_Call_Statement (Data.Loc,
 791                    Name                   =>
 792                      New_Reference_To (Proc_To_Call, Data.Loc),
 793                    Parameter_Associations => Actuals))));
 794
 795       else
 796          --  Generate:
 797
 798          --    Raised_Id := True;
 799
 800          Stmts := New_List (
 801            Make_Assignment_Statement (Data.Loc,
 802              Name       => New_Reference_To (Data.Raised_Id, Data.Loc),
 803              Expression => New_Reference_To (Standard_True, Data.Loc)));
 804       end if;
 805
 806       --  Generate:
 807
 808       --    when others =>
 809
 810       return
 811         Make_Exception_Handler (Data.Loc,
 812           Exception_Choices => New_List (Make_Others_Choice (Data.Loc)),
 813           Statements        => Stmts);
 814    end Build_Exception_Handler;
 815
 816    -------------------------------
 817    -- Build_Finalization_Master --
 818    -------------------------------
 819
 820    procedure Build_Finalization_Master
 821      (Typ        : Entity_Id;
 822       Ins_Node   : Node_Id := Empty;
 823       Encl_Scope : Entity_Id := Empty)
 824    is
 825       Desig_Typ : constant Entity_Id := Directly_Designated_Type (Typ);
 826       Ptr_Typ   : Entity_Id := Root_Type (Base_Type (Typ));
 827
 828       function In_Deallocation_Instance (E : Entity_Id) return Boolean;
 829       --  Determine whether entity E is inside a wrapper package created for
 830       --  an instance of Ada.Unchecked_Deallocation.
 831
 832       ------------------------------
 833       -- In_Deallocation_Instance --
 834       ------------------------------
 835
 836       function In_Deallocation_Instance (E : Entity_Id) return Boolean is
 837          Pkg : constant Entity_Id := Scope (E);
 838          Par : Node_Id := Empty;
 839
 840       begin
 841          if Ekind (Pkg) = E_Package
 842            and then Present (Related_Instance (Pkg))
 843            and then Ekind (Related_Instance (Pkg)) = E_Procedure
 844          then
 845             Par := Generic_Parent (Parent (Related_Instance (Pkg)));
 846
 847             return
 848               Present (Par)
 849                 and then Chars (Par) = Name_Unchecked_Deallocation
 850                 and then Chars (Scope (Par)) = Name_Ada
 851                 and then Scope (Scope (Par)) = Standard_Standard;
 852          end if;
 853
 854          return False;
 855       end In_Deallocation_Instance;
 856
 857    --  Start of processing for Build_Finalization_Master
 858
 859    begin
 860       if Is_Private_Type (Ptr_Typ)
 861         and then Present (Full_View (Ptr_Typ))
 862       then
 863          Ptr_Typ := Full_View (Ptr_Typ);
 864       end if;
 865
 866       --  Certain run-time configurations and targets do not provide support
 867       --  for controlled types.
 868
 869       if Restriction_Active (No_Finalization) then
 870          return;
 871
 872       --  Do not process C, C++, CIL and Java types since it is assumend that
 873       --  the non-Ada side will handle their clean up.
 874
 875       elsif Convention (Desig_Typ) = Convention_C
 876         or else Convention (Desig_Typ) = Convention_CIL
 877         or else Convention (Desig_Typ) = Convention_CPP
 878         or else Convention (Desig_Typ) = Convention_Java
 879       then
 880          return;
 881
 882       --  Various machinery such as freezing may have already created a
 883       --  finalization master.
 884
 885       elsif Present (Finalization_Master (Ptr_Typ)) then
 886          return;
 887
 888       --  Do not process types that return on the secondary stack
 889
 890       elsif Present (Associated_Storage_Pool (Ptr_Typ))
 891         and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool)
 892       then
 893          return;
 894
 895       --  Do not process types which may never allocate an object
 896
 897       elsif No_Pool_Assigned (Ptr_Typ) then
 898          return;
 899
 900       --  Do not process access types coming from Ada.Unchecked_Deallocation
 901       --  instances. Even though the designated type may be controlled, the
 902       --  access type will never participate in allocation.
 903
 904       elsif In_Deallocation_Instance (Ptr_Typ) then
 905          return;
 906
 907       --  Ignore the general use of anonymous access types unless the context
 908       --  requires a finalization master.
 909
 910       elsif Ekind (Ptr_Typ) = E_Anonymous_Access_Type
 911         and then No (Ins_Node)
 912       then
 913          return;
 914
 915       --  Do not process non-library access types when restriction No_Nested_
 916       --  Finalization is in effect since masters are controlled objects.
 917
 918       elsif Restriction_Active (No_Nested_Finalization)
 919         and then not Is_Library_Level_Entity (Ptr_Typ)
 920       then
 921          return;
 922
 923       --  For .NET/JVM targets, allow the processing of access-to-controlled
 924       --  types where the designated type is explicitly derived from [Limited_]
 925       --  Controlled.
 926
 927       elsif VM_Target /= No_VM
 928         and then not Is_Controlled (Desig_Typ)
 929       then
 930          return;
 931
 932       --  Do not create finalization masters in Alfa mode because they result
 933       --  in unwanted expansion.
 934
 935       elsif Alfa_Mode then
 936          return;
 937       end if;
 938
 939       declare
 940          Loc        : constant Source_Ptr := Sloc (Ptr_Typ);
 941          Actions    : constant List_Id := New_List;
 942          Fin_Mas_Id : Entity_Id;
 943          Pool_Id    : Entity_Id;
 944
 945       begin
 946          --  Generate:
 947          --    Fnn : aliased Finalization_Master;
 948
 949          --  Source access types use fixed master names since the master is
 950          --  inserted in the same source unit only once. The only exception to
 951          --  this are instances using the same access type as generic actual.
 952
 953          if Comes_From_Source (Ptr_Typ)
 954            and then not Inside_A_Generic
 955          then
 956             Fin_Mas_Id :=
 957               Make_Defining_Identifier (Loc,
 958                 Chars => New_External_Name (Chars (Ptr_Typ), "FM"));
 959
 960          --  Internally generated access types use temporaries as their names
 961          --  due to possible collision with identical names coming from other
 962          --  packages.
 963
 964          else
 965             Fin_Mas_Id := Make_Temporary (Loc, 'F');
 966          end if;
 967
 968          Append_To (Actions,
 969            Make_Object_Declaration (Loc,
 970              Defining_Identifier => Fin_Mas_Id,
 971              Aliased_Present     => True,
 972              Object_Definition   =>
 973                New_Reference_To (RTE (RE_Finalization_Master), Loc)));
 974
 975          --  Storage pool selection and attribute decoration of the generated
 976          --  master. Since .NET/JVM compilers do not support pools, this step
 977          --  is skipped.
 978
 979          if VM_Target = No_VM then
 980
 981             --  If the access type has a user-defined pool, use it as the base
 982             --  storage medium for the finalization pool.
 983
 984             if Present (Associated_Storage_Pool (Ptr_Typ)) then
 985                Pool_Id := Associated_Storage_Pool (Ptr_Typ);
 986
 987             --  The default choice is the global pool
 988
 989             else
 990                Pool_Id := Get_Global_Pool_For_Access_Type (Ptr_Typ);
 991                Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
 992             end if;
 993
 994             --  Generate:
 995             --    Set_Base_Pool (Fnn, Pool_Id'Unchecked_Access);
 996
 997             Append_To (Actions,
 998               Make_Procedure_Call_Statement (Loc,
 999                 Name                   =>
1000                   New_Reference_To (RTE (RE_Set_Base_Pool), Loc),
1001                 Parameter_Associations => New_List (
1002                   New_Reference_To (Fin_Mas_Id, Loc),
1003                   Make_Attribute_Reference (Loc,
1004                     Prefix         => New_Reference_To (Pool_Id, Loc),
1005                     Attribute_Name => Name_Unrestricted_Access))));
1006          end if;
1007
1008          Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
1009
1010          --  A finalization master created for an anonymous access type must be
1011          --  inserted before a context-dependent node.
1012
1013          if Present (Ins_Node) then
1014             Push_Scope (Encl_Scope);
1015
1016             --  Treat use clauses as declarations and insert directly in front
1017             --  of them.
1018
1019             if Nkind_In (Ins_Node, N_Use_Package_Clause,
1020                                    N_Use_Type_Clause)
1021             then
1022                Insert_List_Before_And_Analyze (Ins_Node, Actions);
1023             else
1024                Insert_Actions (Ins_Node, Actions);
1025             end if;
1026
1027             Pop_Scope;
1028
1029          elsif Ekind (Desig_Typ) = E_Incomplete_Type
1030            and then Has_Completion_In_Body (Desig_Typ)
1031          then
1032             Insert_Actions (Parent (Ptr_Typ), Actions);
1033
1034          --  If the designated type is not yet frozen, then append the actions
1035          --  to that type's freeze actions. The actions need to be appended to
1036          --  whichever type is frozen later, similarly to what Freeze_Type does
1037          --  for appending the storage pool declaration for an access type.
1038          --  Otherwise, the call to Set_Storage_Pool_Ptr might reference the
1039          --  pool object before it's declared. However, it's not clear that
1040          --  this is exactly the right test to accomplish that here. ???
1041
1042          elsif Present (Freeze_Node (Desig_Typ))
1043            and then not Analyzed (Freeze_Node (Desig_Typ))
1044          then
1045             Append_Freeze_Actions (Desig_Typ, Actions);
1046
1047          elsif Present (Freeze_Node (Ptr_Typ))
1048            and then not Analyzed (Freeze_Node (Ptr_Typ))
1049          then
1050             Append_Freeze_Actions (Ptr_Typ, Actions);
1051
1052          --  If there's a pool created locally for the access type, then we
1053          --  need to ensure that the master gets created after the pool object,
1054          --  because otherwise we can have a forward reference, so we force the
1055          --  master actions to be inserted and analyzed after the pool entity.
1056          --  Note that both the access type and its designated type may have
1057          --  already been frozen and had their freezing actions analyzed at
1058          --  this point. (This seems a little unclean.???)
1059
1060          elsif VM_Target = No_VM
1061            and then Scope (Pool_Id) = Scope (Ptr_Typ)
1062          then
1063             Insert_List_After_And_Analyze (Parent (Pool_Id), Actions);
1064
1065          else
1066             Insert_Actions (Parent (Ptr_Typ), Actions);
1067          end if;
1068       end;
1069    end Build_Finalization_Master;
1070
1071    ---------------------
1072    -- Build_Finalizer --
1073    ---------------------
1074
1075    procedure Build_Finalizer
1076      (N           : Node_Id;
1077       Clean_Stmts : List_Id;
1078       Mark_Id     : Entity_Id;
1079       Top_Decls   : List_Id;
1080       Defer_Abort : Boolean;
1081       Fin_Id      : out Entity_Id)
1082    is
1083       Acts_As_Clean    : constant Boolean :=
1084                            Present (Mark_Id)
1085                              or else
1086                                (Present (Clean_Stmts)
1087                                  and then Is_Non_Empty_List (Clean_Stmts));
1088       Exceptions_OK    : constant Boolean :=
1089                            not Restriction_Active (No_Exception_Propagation);
1090       For_Package_Body : constant Boolean := Nkind (N) = N_Package_Body;
1091       For_Package_Spec : constant Boolean := Nkind (N) = N_Package_Declaration;
1092       For_Package      : constant Boolean :=
1093                            For_Package_Body or else For_Package_Spec;
1094       Loc              : constant Source_Ptr := Sloc (N);
1095
1096       --  NOTE: Local variable declarations are conservative and do not create
1097       --  structures right from the start. Entities and lists are created once
1098       --  it has been established that N has at least one controlled object.
1099
1100       Components_Built : Boolean := False;
1101       --  A flag used to avoid double initialization of entities and lists. If
1102       --  the flag is set then the following variables have been initialized:
1103       --    Counter_Id
1104       --    Finalizer_Decls
1105       --    Finalizer_Stmts
1106       --    Jump_Alts
1107
1108       Counter_Id  : Entity_Id := Empty;
1109       Counter_Val : Int       := 0;
1110       --  Name and value of the state counter
1111
1112       Decls : List_Id := No_List;
1113       --  Declarative region of N (if available). If N is a package declaration
1114       --  Decls denotes the visible declarations.
1115
1116       Finalizer_Data : Finalization_Exception_Data;
1117       --  Data for the exception
1118
1119       Finalizer_Decls : List_Id := No_List;
1120       --  Local variable declarations. This list holds the label declarations
1121       --  of all jump block alternatives as well as the declaration of the
1122       --  local exception occurence and the raised flag:
1123       --     E : Exception_Occurrence;
1124       --     Raised : Boolean := False;
1125       --     L<counter value> : label;
1126
1127       Finalizer_Insert_Nod : Node_Id := Empty;
1128       --  Insertion point for the finalizer body. Depending on the context
1129       --  (Nkind of N) and the individual grouping of controlled objects, this
1130       --  node may denote a package declaration or body, package instantiation,
1131       --  block statement or a counter update statement.
1132
1133       Finalizer_Stmts : List_Id := No_List;
1134       --  The statement list of the finalizer body. It contains the following:
1135       --
1136       --    Abort_Defer;               --  Added if abort is allowed
1137       --    <call to Prev_At_End>      --  Added if exists
1138       --    <cleanup statements>       --  Added if Acts_As_Clean
1139       --    <jump block>               --  Added if Has_Ctrl_Objs
1140       --    <finalization statements>  --  Added if Has_Ctrl_Objs
1141       --    <stack release>            --  Added if Mark_Id exists
1142       --    Abort_Undefer;             --  Added if abort is allowed
1143
1144       Has_Ctrl_Objs : Boolean := False;
1145       --  A general flag which denotes whether N has at least one controlled
1146       --  object.
1147
1148       Has_Tagged_Types : Boolean := False;
1149       --  A general flag which indicates whether N has at least one library-
1150       --  level tagged type declaration.
1151
1152       HSS : Node_Id := Empty;
1153       --  The sequence of statements of N (if available)
1154
1155       Jump_Alts : List_Id := No_List;
1156       --  Jump block alternatives. Depending on the value of the state counter,
1157       --  the control flow jumps to a sequence of finalization statements. This
1158       --  list contains the following:
1159       --
1160       --     when <counter value> =>
1161       --        goto L<counter value>;
1162
1163       Jump_Block_Insert_Nod : Node_Id := Empty;
1164       --  Specific point in the finalizer statements where the jump block is
1165       --  inserted.
1166
1167       Last_Top_Level_Ctrl_Construct : Node_Id := Empty;
1168       --  The last controlled construct encountered when processing the top
1169       --  level lists of N. This can be a nested package, an instantiation or
1170       --  an object declaration.
1171
1172       Prev_At_End : Entity_Id := Empty;
1173       --  The previous at end procedure of the handled statements block of N
1174
1175       Priv_Decls : List_Id := No_List;
1176       --  The private declarations of N if N is a package declaration
1177
1178       Spec_Id    : Entity_Id := Empty;
1179       Spec_Decls : List_Id   := Top_Decls;
1180       Stmts      : List_Id   := No_List;
1181
1182       Tagged_Type_Stmts : List_Id := No_List;
1183       --  Contains calls to Ada.Tags.Unregister_Tag for all library-level
1184       --  tagged types found in N.
1185
1186       -----------------------
1187       -- Local subprograms --
1188       -----------------------
1189
1190       procedure Build_Components;
1191       --  Create all entites and initialize all lists used in the creation of
1192       --  the finalizer.
1193
1194       procedure Create_Finalizer;
1195       --  Create the spec and body of the finalizer and insert them in the
1196       --  proper place in the tree depending on the context.
1197
1198       procedure Process_Declarations
1199         (Decls      : List_Id;
1200          Preprocess : Boolean := False;
1201          Top_Level  : Boolean := False);
1202       --  Inspect a list of declarations or statements which may contain
1203       --  objects that need finalization. When flag Preprocess is set, the
1204       --  routine will simply count the total number of controlled objects in
1205       --  Decls. Flag Top_Level denotes whether the processing is done for
1206       --  objects in nested package declarations or instances.
1207
1208       procedure Process_Object_Declaration
1209         (Decl         : Node_Id;
1210          Has_No_Init  : Boolean := False;
1211          Is_Protected : Boolean := False);
1212       --  Generate all the machinery associated with the finalization of a
1213       --  single object. Flag Has_No_Init is used to denote certain contexts
1214       --  where Decl does not have initialization call(s). Flag Is_Protected
1215       --  is set when Decl denotes a simple protected object.
1216
1217       procedure Process_Tagged_Type_Declaration (Decl : Node_Id);
1218       --  Generate all the code necessary to unregister the external tag of a
1219       --  tagged type.
1220
1221       ----------------------
1222       -- Build_Components --
1223       ----------------------
1224
1225       procedure Build_Components is
1226          Counter_Decl     : Node_Id;
1227          Counter_Typ      : Entity_Id;
1228          Counter_Typ_Decl : Node_Id;
1229
1230       begin
1231          pragma Assert (Present (Decls));
1232
1233          --  This routine might be invoked several times when dealing with
1234          --  constructs that have two lists (either two declarative regions
1235          --  or declarations and statements). Avoid double initialization.
1236
1237          if Components_Built then
1238             return;
1239          end if;
1240
1241          Components_Built := True;
1242
1243          if Has_Ctrl_Objs then
1244
1245             --  Create entities for the counter, its type, the local exception
1246             --  and the raised flag.
1247
1248             Counter_Id  := Make_Temporary (Loc, 'C');
1249             Counter_Typ := Make_Temporary (Loc, 'T');
1250
1251             Finalizer_Decls := New_List;
1252
1253             Build_Object_Declarations
1254               (Finalizer_Data, Finalizer_Decls, Loc, For_Package);
1255
1256             --  Since the total number of controlled objects is always known,
1257             --  build a subtype of Natural with precise bounds. This allows
1258             --  the backend to optimize the case statement. Generate:
1259             --
1260             --    subtype Tnn is Natural range 0 .. Counter_Val;
1261
1262             Counter_Typ_Decl :=
1263               Make_Subtype_Declaration (Loc,
1264                 Defining_Identifier => Counter_Typ,
1265                 Subtype_Indication  =>
1266                   Make_Subtype_Indication (Loc,
1267                     Subtype_Mark => New_Reference_To (Standard_Natural, Loc),
1268                     Constraint   =>
1269                       Make_Range_Constraint (Loc,
1270                         Range_Expression =>
1271                           Make_Range (Loc,
1272                             Low_Bound  =>
1273                               Make_Integer_Literal (Loc, Uint_0),
1274                             High_Bound =>
1275                               Make_Integer_Literal (Loc, Counter_Val)))));
1276
1277             --  Generate the declaration of the counter itself:
1278             --
1279             --    Counter : Integer := 0;
1280
1281             Counter_Decl :=
1282               Make_Object_Declaration (Loc,
1283                 Defining_Identifier => Counter_Id,
1284                 Object_Definition   => New_Reference_To (Counter_Typ, Loc),
1285                 Expression          => Make_Integer_Literal (Loc, 0));
1286
1287             --  Set the type of the counter explicitly to prevent errors when
1288             --  examining object declarations later on.
1289
1290             Set_Etype (Counter_Id, Counter_Typ);
1291
1292             --  The counter and its type are inserted before the source
1293             --  declarations of N.
1294
1295             Prepend_To (Decls, Counter_Decl);
1296             Prepend_To (Decls, Counter_Typ_Decl);
1297
1298             --  The counter and its associated type must be manually analized
1299             --  since N has already been analyzed. Use the scope of the spec
1300             --  when inserting in a package.
1301
1302             if For_Package then
1303                Push_Scope (Spec_Id);
1304                Analyze (Counter_Typ_Decl);
1305                Analyze (Counter_Decl);
1306                Pop_Scope;
1307
1308             else
1309                Analyze (Counter_Typ_Decl);
1310                Analyze (Counter_Decl);
1311             end if;
1312
1313             Jump_Alts := New_List;
1314          end if;
1315
1316          --  If the context requires additional clean up, the finalization
1317          --  machinery is added after the clean up code.
1318
1319          if Acts_As_Clean then
1320             Finalizer_Stmts       := Clean_Stmts;
1321             Jump_Block_Insert_Nod := Last (Finalizer_Stmts);
1322          else
1323             Finalizer_Stmts := New_List;
1324          end if;
1325
1326          if Has_Tagged_Types then
1327             Tagged_Type_Stmts := New_List;
1328          end if;
1329       end Build_Components;
1330
1331       ----------------------
1332       -- Create_Finalizer --
1333       ----------------------
1334
1335       procedure Create_Finalizer is
1336          Body_Id    : Entity_Id;
1337          Fin_Body   : Node_Id;
1338          Fin_Spec   : Node_Id;
1339          Jump_Block : Node_Id;
1340          Label      : Node_Id;
1341          Label_Id   : Entity_Id;
1342
1343          function New_Finalizer_Name return Name_Id;
1344          --  Create a fully qualified name of a package spec or body finalizer.
1345          --  The generated name is of the form: xx__yy__finalize_[spec|body].
1346
1347          ------------------------
1348          -- New_Finalizer_Name --
1349          ------------------------
1350
1351          function New_Finalizer_Name return Name_Id is
1352             procedure New_Finalizer_Name (Id : Entity_Id);
1353             --  Place "__<name-of-Id>" in the name buffer. If the identifier
1354             --  has a non-standard scope, process the scope first.
1355
1356             ------------------------
1357             -- New_Finalizer_Name --
1358             ------------------------
1359
1360             procedure New_Finalizer_Name (Id : Entity_Id) is
1361             begin
1362                if Scope (Id) = Standard_Standard then
1363                   Get_Name_String (Chars (Id));
1364
1365                else
1366                   New_Finalizer_Name (Scope (Id));
1367                   Add_Str_To_Name_Buffer ("__");
1368                   Add_Str_To_Name_Buffer (Get_Name_String (Chars (Id)));
1369                end if;
1370             end New_Finalizer_Name;
1371
1372          --  Start of processing for New_Finalizer_Name
1373
1374          begin
1375             --  Create the fully qualified name of the enclosing scope
1376
1377             New_Finalizer_Name (Spec_Id);
1378
1379             --  Generate:
1380             --    __finalize_[spec|body]
1381
1382             Add_Str_To_Name_Buffer ("__finalize_");
1383
1384             if For_Package_Spec then
1385                Add_Str_To_Name_Buffer ("spec");
1386             else
1387                Add_Str_To_Name_Buffer ("body");
1388             end if;
1389
1390             return Name_Find;
1391          end New_Finalizer_Name;
1392
1393       --  Start of processing for Create_Finalizer
1394
1395       begin
1396          --  Step 1: Creation of the finalizer name
1397
1398          --  Packages must use a distinct name for their finalizers since the
1399          --  binder will have to generate calls to them by name. The name is
1400          --  of the following form:
1401
1402          --    xx__yy__finalize_[spec|body]
1403
1404          if For_Package then
1405             Fin_Id := Make_Defining_Identifier (Loc, New_Finalizer_Name);
1406             Set_Has_Qualified_Name       (Fin_Id);
1407             Set_Has_Fully_Qualified_Name (Fin_Id);
1408
1409          --  The default name is _finalizer
1410
1411          else
1412             Fin_Id :=
1413               Make_Defining_Identifier (Loc,
1414                 Chars => New_External_Name (Name_uFinalizer));
1415
1416             --  The visibility semantics of AT_END handlers force a strange
1417             --  separation of spec and body for stack-related finalizers:
1418
1419             --     declare : Enclosing_Scope
1420             --        procedure _finalizer;
1421             --     begin
1422             --        <controlled objects>
1423             --        procedure _finalizer is
1424             --           ...
1425             --     at end
1426             --        _finalizer;
1427             --     end;
1428
1429             --  Both spec and body are within the same construct and scope, but
1430             --  the body is part of the handled sequence of statements. This
1431             --  placement confuses the elaboration mechanism on targets where
1432             --  AT_END handlers are expanded into "when all others" handlers:
1433
1434             --     exception
1435             --        when all others =>
1436             --           _finalizer;  --  appears to require elab checks
1437             --     at end
1438             --        _finalizer;
1439             --     end;
1440
1441             --  Since the compiler guarantees that the body of a _finalizer is
1442             --  always inserted in the same construct where the AT_END handler
1443             --  resides, there is no need for elaboration checks.
1444
1445             Set_Kill_Elaboration_Checks (Fin_Id);
1446          end if;
1447
1448          --  Step 2: Creation of the finalizer specification
1449
1450          --  Generate:
1451          --    procedure Fin_Id;
1452
1453          Fin_Spec :=
1454            Make_Subprogram_Declaration (Loc,
1455              Specification =>
1456                Make_Procedure_Specification (Loc,
1457                  Defining_Unit_Name => Fin_Id));
1458
1459          --  Step 3: Creation of the finalizer body
1460
1461          if Has_Ctrl_Objs then
1462
1463             --  Add L0, the default destination to the jump block
1464
1465             Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
1466             Set_Entity (Label_Id,
1467               Make_Defining_Identifier (Loc, Chars (Label_Id)));
1468             Label := Make_Label (Loc, Label_Id);
1469
1470             --  Generate:
1471             --    L0 : label;
1472
1473             Prepend_To (Finalizer_Decls,
1474               Make_Implicit_Label_Declaration (Loc,
1475                 Defining_Identifier => Entity (Label_Id),
1476                 Label_Construct     => Label));
1477
1478             --  Generate:
1479             --    when others =>
1480             --       goto L0;
1481
1482             Append_To (Jump_Alts,
1483               Make_Case_Statement_Alternative (Loc,
1484                 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1485                 Statements       => New_List (
1486                   Make_Goto_Statement (Loc,
1487                     Name => New_Reference_To (Entity (Label_Id), Loc)))));
1488
1489             --  Generate:
1490             --    <<L0>>
1491
1492             Append_To (Finalizer_Stmts, Label);
1493
1494             --  Create the jump block which controls the finalization flow
1495             --  depending on the value of the state counter.
1496
1497             Jump_Block :=
1498               Make_Case_Statement (Loc,
1499                 Expression   => Make_Identifier (Loc, Chars (Counter_Id)),
1500                 Alternatives => Jump_Alts);
1501
1502             if Acts_As_Clean
1503               and then Present (Jump_Block_Insert_Nod)
1504             then
1505                Insert_After (Jump_Block_Insert_Nod, Jump_Block);
1506             else
1507                Prepend_To (Finalizer_Stmts, Jump_Block);
1508             end if;
1509          end if;
1510
1511          --  Add the library-level tagged type unregistration machinery before
1512          --  the jump block circuitry. This ensures that external tags will be
1513          --  removed even if a finalization exception occurs at some point.
1514
1515          if Has_Tagged_Types then
1516             Prepend_List_To (Finalizer_Stmts, Tagged_Type_Stmts);
1517          end if;
1518
1519          --  Add a call to the previous At_End handler if it exists. The call
1520          --  must always precede the jump block.
1521
1522          if Present (Prev_At_End) then
1523             Prepend_To (Finalizer_Stmts,
1524               Make_Procedure_Call_Statement (Loc, Prev_At_End));
1525
1526             --  Clear the At_End handler since we have already generated the
1527             --  proper replacement call for it.
1528
1529             Set_At_End_Proc (HSS, Empty);
1530          end if;
1531
1532          --  Release the secondary stack mark
1533
1534          if Present (Mark_Id) then
1535             Append_To (Finalizer_Stmts,
1536               Make_Procedure_Call_Statement (Loc,
1537                 Name                   =>
1538                   New_Reference_To (RTE (RE_SS_Release), Loc),
1539                 Parameter_Associations => New_List (
1540                   New_Reference_To (Mark_Id, Loc))));
1541          end if;
1542
1543          --  Protect the statements with abort defer/undefer. This is only when
1544          --  aborts are allowed and the clean up statements require deferral or
1545          --  there are controlled objects to be finalized.
1546
1547          if Abort_Allowed
1548            and then
1549              (Defer_Abort or else Has_Ctrl_Objs)
1550          then
1551             Prepend_To (Finalizer_Stmts,
1552               Make_Procedure_Call_Statement (Loc,
1553                 Name => New_Reference_To (RTE (RE_Abort_Defer), Loc)));
1554
1555             Append_To (Finalizer_Stmts,
1556               Make_Procedure_Call_Statement (Loc,
1557                 Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)));
1558          end if;
1559
1560          --  The local exception does not need to be reraised for library-level
1561          --  finalizers. Note that this action must be carried out after object
1562          --  clean up, secondary stack release and abort undeferral. Generate:
1563
1564          --    if Raised and then not Abort then
1565          --       Raise_From_Controlled_Operation (E);
1566          --    end if;
1567
1568          if Has_Ctrl_Objs
1569            and then Exceptions_OK
1570            and then not For_Package
1571          then
1572             Append_To (Finalizer_Stmts,
1573               Build_Raise_Statement (Finalizer_Data));
1574          end if;
1575
1576          --  Generate:
1577          --    procedure Fin_Id is
1578          --       Abort  : constant Boolean := Triggered_By_Abort;
1579          --         <or>
1580          --       Abort  : constant Boolean := False;  --  no abort
1581
1582          --       E      : Exception_Occurrence;  --  All added if flag
1583          --       Raised : Boolean := False;      --  Has_Ctrl_Objs is set
1584          --       L0     : label;
1585          --       ...
1586          --       Lnn    : label;
1587
1588          --    begin
1589          --       Abort_Defer;               --  Added if abort is allowed
1590          --       <call to Prev_At_End>      --  Added if exists
1591          --       <cleanup statements>       --  Added if Acts_As_Clean
1592          --       <jump block>               --  Added if Has_Ctrl_Objs
1593          --       <finalization statements>  --  Added if Has_Ctrl_Objs
1594          --       <stack release>            --  Added if Mark_Id exists
1595          --       Abort_Undefer;             --  Added if abort is allowed
1596          --       <exception propagation>    --  Added if Has_Ctrl_Objs
1597          --    end Fin_Id;
1598
1599          --  Create the body of the finalizer
1600
1601          Body_Id := Make_Defining_Identifier (Loc, Chars (Fin_Id));
1602
1603          if For_Package then
1604             Set_Has_Qualified_Name       (Body_Id);
1605             Set_Has_Fully_Qualified_Name (Body_Id);
1606          end if;
1607
1608          Fin_Body :=
1609            Make_Subprogram_Body (Loc,
1610              Specification              =>
1611                Make_Procedure_Specification (Loc,
1612                  Defining_Unit_Name => Body_Id),
1613              Declarations               => Finalizer_Decls,
1614              Handled_Statement_Sequence =>
1615                Make_Handled_Sequence_Of_Statements (Loc, Finalizer_Stmts));
1616
1617          --  Step 4: Spec and body insertion, analysis
1618
1619          if For_Package then
1620
1621             --  If the package spec has private declarations, the finalizer
1622             --  body must be added to the end of the list in order to have
1623             --  visibility of all private controlled objects.
1624
1625             if For_Package_Spec then
1626                if Present (Priv_Decls) then
1627                   Append_To (Priv_Decls, Fin_Spec);
1628                   Append_To (Priv_Decls, Fin_Body);
1629                else
1630                   Append_To (Decls, Fin_Spec);
1631                   Append_To (Decls, Fin_Body);
1632                end if;
1633
1634             --  For package bodies, both the finalizer spec and body are
1635             --  inserted at the end of the package declarations.
1636
1637             else
1638                Append_To (Decls, Fin_Spec);
1639                Append_To (Decls, Fin_Body);
1640             end if;
1641
1642             --  Push the name of the package
1643
1644             Push_Scope (Spec_Id);
1645             Analyze (Fin_Spec);
1646             Analyze (Fin_Body);
1647             Pop_Scope;
1648
1649          --  Non-package case
1650
1651          else
1652             --  Create the spec for the finalizer. The At_End handler must be
1653             --  able to call the body which resides in a nested structure.
1654
1655             --  Generate:
1656             --    declare
1657             --       procedure Fin_Id;                  --  Spec
1658             --    begin
1659             --       <objects and possibly statements>
1660             --       procedure Fin_Id is ...            --  Body
1661             --       <statements>
1662             --    at end
1663             --       Fin_Id;                            --  At_End handler
1664             --    end;
1665
1666             pragma Assert (Present (Spec_Decls));
1667
1668             Append_To (Spec_Decls, Fin_Spec);
1669             Analyze (Fin_Spec);
1670
1671             --  When the finalizer acts solely as a clean up routine, the body
1672             --  is inserted right after the spec.
1673
1674             if Acts_As_Clean
1675               and then not Has_Ctrl_Objs
1676             then
1677                Insert_After (Fin_Spec, Fin_Body);
1678
1679             --  In all other cases the body is inserted after either:
1680             --
1681             --    1) The counter update statement of the last controlled object
1682             --    2) The last top level nested controlled package
1683             --    3) The last top level controlled instantiation
1684
1685             else
1686                --  Manually freeze the spec. This is somewhat of a hack because
1687                --  a subprogram is frozen when its body is seen and the freeze
1688                --  node appears right before the body. However, in this case,
1689                --  the spec must be frozen earlier since the At_End handler
1690                --  must be able to call it.
1691                --
1692                --    declare
1693                --       procedure Fin_Id;               --  Spec
1694                --       [Fin_Id]                        --  Freeze node
1695                --    begin
1696                --       ...
1697                --    at end
1698                --       Fin_Id;                         --  At_End handler
1699                --    end;
1700
1701                Ensure_Freeze_Node (Fin_Id);
1702                Insert_After (Fin_Spec, Freeze_Node (Fin_Id));
1703                Set_Is_Frozen (Fin_Id);
1704
1705                --  In the case where the last construct to contain a controlled
1706                --  object is either a nested package, an instantiation or a
1707                --  freeze node, the body must be inserted directly after the
1708                --  construct.
1709
1710                if Nkind_In (Last_Top_Level_Ctrl_Construct,
1711                               N_Freeze_Entity,
1712                               N_Package_Declaration,
1713                               N_Package_Body)
1714                then
1715                   Finalizer_Insert_Nod := Last_Top_Level_Ctrl_Construct;
1716                end if;
1717
1718                Insert_After (Finalizer_Insert_Nod, Fin_Body);
1719             end if;
1720
1721             Analyze (Fin_Body);
1722          end if;
1723       end Create_Finalizer;
1724
1725       --------------------------
1726       -- Process_Declarations --
1727       --------------------------
1728
1729       procedure Process_Declarations
1730         (Decls      : List_Id;
1731          Preprocess : Boolean := False;
1732          Top_Level  : Boolean := False)
1733       is
1734          Decl    : Node_Id;
1735          Expr    : Node_Id;
1736          Obj_Id  : Entity_Id;
1737          Obj_Typ : Entity_Id;
1738          Pack_Id : Entity_Id;
1739          Spec    : Node_Id;
1740          Typ     : Entity_Id;
1741
1742          Old_Counter_Val : Int;
1743          --  This variable is used to determine whether a nested package or
1744          --  instance contains at least one controlled object.
1745
1746          procedure Processing_Actions
1747            (Has_No_Init  : Boolean := False;
1748             Is_Protected : Boolean := False);
1749          --  Depending on the mode of operation of Process_Declarations, either
1750          --  increment the controlled object counter, set the controlled object
1751          --  flag and store the last top level construct or process the current
1752          --  declaration. Flag Has_No_Init is used to propagate scenarios where
1753          --  the current declaration may not have initialization proc(s). Flag
1754          --  Is_Protected should be set when the current declaration denotes a
1755          --  simple protected object.
1756
1757          ------------------------
1758          -- Processing_Actions --
1759          ------------------------
1760
1761          procedure Processing_Actions
1762            (Has_No_Init  : Boolean := False;
1763             Is_Protected : Boolean := False)
1764          is
1765          begin
1766             --  Library-level tagged type
1767
1768             if Nkind (Decl) = N_Full_Type_Declaration then
1769                if Preprocess then
1770                   Has_Tagged_Types := True;
1771
1772                   if Top_Level
1773                     and then No (Last_Top_Level_Ctrl_Construct)
1774                   then
1775                      Last_Top_Level_Ctrl_Construct := Decl;
1776                   end if;
1777
1778                else
1779                   Process_Tagged_Type_Declaration (Decl);
1780                end if;
1781
1782             --  Controlled object declaration
1783
1784             else
1785                if Preprocess then
1786                   Counter_Val   := Counter_Val + 1;
1787                   Has_Ctrl_Objs := True;
1788
1789                   if Top_Level
1790                     and then No (Last_Top_Level_Ctrl_Construct)
1791                   then
1792                      Last_Top_Level_Ctrl_Construct := Decl;
1793                   end if;
1794
1795                else
1796                   Process_Object_Declaration (Decl, Has_No_Init, Is_Protected);
1797                end if;
1798             end if;
1799          end Processing_Actions;
1800
1801       --  Start of processing for Process_Declarations
1802
1803       begin
1804          if No (Decls) or else Is_Empty_List (Decls) then
1805             return;
1806          end if;
1807
1808          --  Process all declarations in reverse order
1809
1810          Decl := Last_Non_Pragma (Decls);
1811          while Present (Decl) loop
1812
1813             --  Library-level tagged types
1814
1815             if Nkind (Decl) = N_Full_Type_Declaration then
1816                Typ := Defining_Identifier (Decl);
1817
1818                if Is_Tagged_Type (Typ)
1819                  and then Is_Library_Level_Entity (Typ)
1820                  and then Convention (Typ) = Convention_Ada
1821                  and then Present (Access_Disp_Table (Typ))
1822                  and then RTE_Available (RE_Register_Tag)
1823                  and then not No_Run_Time_Mode
1824                  and then not Is_Abstract_Type (Typ)
1825                then
1826                   Processing_Actions;
1827                end if;
1828
1829             --  Regular object declarations
1830
1831             elsif Nkind (Decl) = N_Object_Declaration then
1832                Obj_Id  := Defining_Identifier (Decl);
1833                Obj_Typ := Base_Type (Etype (Obj_Id));
1834                Expr    := Expression (Decl);
1835
1836                --  Bypass any form of processing for objects which have their
1837                --  finalization disabled. This applies only to objects at the
1838                --  library level.
1839
1840                if For_Package
1841                  and then Finalize_Storage_Only (Obj_Typ)
1842                then
1843                   null;
1844
1845                --  Transient variables are treated separately in order to
1846                --  minimize the size of the generated code. For details, see
1847                --  Process_Transient_Objects.
1848
1849                elsif Is_Processed_Transient (Obj_Id) then
1850                   null;
1851
1852                --  The object is of the form:
1853                --    Obj : Typ [:= Expr];
1854
1855                --  Do not process the incomplete view of a deferred constant.
1856                --  Do not consider tag-to-class-wide conversions.
1857
1858                elsif not Is_Imported (Obj_Id)
1859                  and then Needs_Finalization (Obj_Typ)
1860                  and then not (Ekind (Obj_Id) = E_Constant
1861                                 and then not Has_Completion (Obj_Id))
1862                  and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
1863                then
1864                   Processing_Actions;
1865
1866                --  The object is of the form:
1867                --    Obj : Access_Typ := Non_BIP_Function_Call'reference;
1868
1869                --    Obj : Access_Typ :=
1870                --            BIP_Function_Call (BIPalloc => 2, ...)'reference;
1871
1872                elsif Is_Access_Type (Obj_Typ)
1873                  and then Needs_Finalization
1874                             (Available_View (Designated_Type (Obj_Typ)))
1875                  and then Present (Expr)
1876                  and then
1877                    (Is_Secondary_Stack_BIP_Func_Call (Expr)
1878                      or else
1879                        (Is_Non_BIP_Func_Call (Expr)
1880                          and then not Is_Related_To_Func_Return (Obj_Id)))
1881                then
1882                   Processing_Actions (Has_No_Init => True);
1883
1884                --  Processing for "hook" objects generated for controlled
1885                --  transients declared inside an Expression_With_Actions.
1886
1887                elsif Is_Access_Type (Obj_Typ)
1888                  and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
1889                  and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
1890                                    N_Object_Declaration
1891                  and then Is_Finalizable_Transient
1892                             (Status_Flag_Or_Transient_Decl (Obj_Id), Decl)
1893                then
1894                   Processing_Actions (Has_No_Init => True);
1895
1896                --  Process intermediate results of an if expression with one
1897                --  of the alternatives using a controlled function call.
1898
1899                elsif Is_Access_Type (Obj_Typ)
1900                  and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
1901                  and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
1902                                                        N_Defining_Identifier
1903                  and then Present (Expr)
1904                  and then Nkind (Expr) = N_Null
1905                then
1906                   Processing_Actions (Has_No_Init => True);
1907
1908                --  Simple protected objects which use type System.Tasking.
1909                --  Protected_Objects.Protection to manage their locks should
1910                --  be treated as controlled since they require manual cleanup.
1911                --  The only exception is illustrated in the following example:
1912
1913                --     package Pkg is
1914                --        type Ctrl is new Controlled ...
1915                --        procedure Finalize (Obj : in out Ctrl);
1916                --        Lib_Obj : Ctrl;
1917                --     end Pkg;
1918
1919                --     package body Pkg is
1920                --        protected Prot is
1921                --           procedure Do_Something (Obj : in out Ctrl);
1922                --        end Prot;
1923
1924                --        protected body Prot is
1925                --           procedure Do_Something (Obj : in out Ctrl) is ...
1926                --        end Prot;
1927
1928                --        procedure Finalize (Obj : in out Ctrl) is
1929                --        begin
1930                --           Prot.Do_Something (Obj);
1931                --        end Finalize;
1932                --     end Pkg;
1933
1934                --  Since for the most part entities in package bodies depend on
1935                --  those in package specs, Prot's lock should be cleaned up
1936                --  first. The subsequent cleanup of the spec finalizes Lib_Obj.
1937                --  This act however attempts to invoke Do_Something and fails
1938                --  because the lock has disappeared.
1939
1940                elsif Ekind (Obj_Id) = E_Variable
1941                  and then not In_Library_Level_Package_Body (Obj_Id)
1942                  and then
1943                    (Is_Simple_Protected_Type (Obj_Typ)
1944                      or else Has_Simple_Protected_Object (Obj_Typ))
1945                then
1946                   Processing_Actions (Is_Protected => True);
1947                end if;
1948
1949             --  Specific cases of object renamings
1950
1951             elsif Nkind (Decl) = N_Object_Renaming_Declaration then
1952                Obj_Id  := Defining_Identifier (Decl);
1953                Obj_Typ := Base_Type (Etype (Obj_Id));
1954
1955                --  Bypass any form of processing for objects which have their
1956                --  finalization disabled. This applies only to objects at the
1957                --  library level.
1958
1959                if For_Package
1960                  and then Finalize_Storage_Only (Obj_Typ)
1961                then
1962                   null;
1963
1964                --  Return object of a build-in-place function. This case is
1965                --  recognized and marked by the expansion of an extended return
1966                --  statement (see Expand_N_Extended_Return_Statement).
1967
1968                elsif Needs_Finalization (Obj_Typ)
1969                  and then Is_Return_Object (Obj_Id)
1970                  and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
1971                then
1972                   Processing_Actions (Has_No_Init => True);
1973
1974                --  Detect a case where a source object has been initialized by
1975                --  a controlled function call or another object which was later
1976                --  rewritten as a class-wide conversion of Ada.Tags.Displace.
1977
1978                --     Obj1 : CW_Type := Src_Obj;
1979                --     Obj2 : CW_Type := Function_Call (...);
1980
1981                --     Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
1982                --     Tmp  : ... := Function_Call (...)'reference;
1983                --     Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
1984
1985                elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
1986                   Processing_Actions (Has_No_Init => True);
1987                end if;
1988
1989             --  Inspect the freeze node of an access-to-controlled type and
1990             --  look for a delayed finalization master. This case arises when
1991             --  the freeze actions are inserted at a later time than the
1992             --  expansion of the context. Since Build_Finalizer is never called
1993             --  on a single construct twice, the master will be ultimately
1994             --  left out and never finalized. This is also needed for freeze
1995             --  actions of designated types themselves, since in some cases the
1996             --  finalization master is associated with a designated type's
1997             --  freeze node rather than that of the access type (see handling
1998             --  for freeze actions in Build_Finalization_Master).
1999
2000             elsif Nkind (Decl) = N_Freeze_Entity
2001               and then Present (Actions (Decl))
2002             then
2003                Typ := Entity (Decl);
2004
2005                if (Is_Access_Type (Typ)
2006                     and then not Is_Access_Subprogram_Type (Typ)
2007                     and then Needs_Finalization
2008                                (Available_View (Designated_Type (Typ))))
2009                  or else (Is_Type (Typ) and then Needs_Finalization (Typ))
2010                then
2011                   Old_Counter_Val := Counter_Val;
2012
2013                   --  Freeze nodes are considered to be identical to packages
2014                   --  and blocks in terms of nesting. The difference is that
2015                   --  a finalization master created inside the freeze node is
2016                   --  at the same nesting level as the node itself.
2017
2018                   Process_Declarations (Actions (Decl), Preprocess);
2019
2020                   --  The freeze node contains a finalization master
2021
2022                   if Preprocess
2023                     and then Top_Level
2024                     and then No (Last_Top_Level_Ctrl_Construct)
2025                     and then Counter_Val > Old_Counter_Val
2026                   then
2027                      Last_Top_Level_Ctrl_Construct := Decl;
2028                   end if;
2029                end if;
2030
2031             --  Nested package declarations, avoid generics
2032
2033             elsif Nkind (Decl) = N_Package_Declaration then
2034                Spec    := Specification (Decl);
2035                Pack_Id := Defining_Unit_Name (Spec);
2036
2037                if Nkind (Pack_Id) = N_Defining_Program_Unit_Name then
2038                   Pack_Id := Defining_Identifier (Pack_Id);
2039                end if;
2040
2041                if Ekind (Pack_Id) /= E_Generic_Package then
2042                   Old_Counter_Val := Counter_Val;
2043                   Process_Declarations
2044                     (Private_Declarations (Spec), Preprocess);
2045                   Process_Declarations
2046                     (Visible_Declarations (Spec), Preprocess);
2047
2048                   --  Either the visible or the private declarations contain a
2049                   --  controlled object. The nested package declaration is the
2050                   --  last such construct.
2051
2052                   if Preprocess
2053                     and then Top_Level
2054                     and then No (Last_Top_Level_Ctrl_Construct)
2055                     and then Counter_Val > Old_Counter_Val
2056                   then
2057                      Last_Top_Level_Ctrl_Construct := Decl;
2058                   end if;
2059                end if;
2060
2061             --  Nested package bodies, avoid generics
2062
2063             elsif Nkind (Decl) = N_Package_Body then
2064                Spec := Corresponding_Spec (Decl);
2065
2066                if Ekind (Spec) /= E_Generic_Package then
2067                   Old_Counter_Val := Counter_Val;
2068                   Process_Declarations (Declarations (Decl), Preprocess);
2069
2070                   --  The nested package body is the last construct to contain
2071                   --  a controlled object.
2072
2073                   if Preprocess
2074                     and then Top_Level
2075                     and then No (Last_Top_Level_Ctrl_Construct)
2076                     and then Counter_Val > Old_Counter_Val
2077                   then
2078                      Last_Top_Level_Ctrl_Construct := Decl;
2079                   end if;
2080                end if;
2081
2082             --  Handle a rare case caused by a controlled transient variable
2083             --  created as part of a record init proc. The variable is wrapped
2084             --  in a block, but the block is not associated with a transient
2085             --  scope.
2086
2087             elsif Nkind (Decl) = N_Block_Statement
2088               and then Inside_Init_Proc
2089             then
2090                Old_Counter_Val := Counter_Val;
2091
2092                if Present (Handled_Statement_Sequence (Decl)) then
2093                   Process_Declarations
2094                     (Statements (Handled_Statement_Sequence (Decl)),
2095                      Preprocess);
2096                end if;
2097
2098                Process_Declarations (Declarations (Decl), Preprocess);
2099
2100                --  Either the declaration or statement list of the block has a
2101                --  controlled object.
2102
2103                if Preprocess
2104                  and then Top_Level
2105                  and then No (Last_Top_Level_Ctrl_Construct)
2106                  and then Counter_Val > Old_Counter_Val
2107                then
2108                   Last_Top_Level_Ctrl_Construct := Decl;
2109                end if;
2110
2111             --  Handle the case where the original context has been wrapped in
2112             --  a block to avoid interference between exception handlers and
2113             --  At_End handlers. Treat the block as transparent and process its
2114             --  contents.
2115
2116             elsif Nkind (Decl) = N_Block_Statement
2117               and then Is_Finalization_Wrapper (Decl)
2118             then
2119                if Present (Handled_Statement_Sequence (Decl)) then
2120                   Process_Declarations
2121                     (Statements (Handled_Statement_Sequence (Decl)),
2122                      Preprocess);
2123                end if;
2124
2125                Process_Declarations (Declarations (Decl), Preprocess);
2126             end if;
2127
2128             Prev_Non_Pragma (Decl);
2129          end loop;
2130       end Process_Declarations;
2131
2132       --------------------------------
2133       -- Process_Object_Declaration --
2134       --------------------------------
2135
2136       procedure Process_Object_Declaration
2137         (Decl         : Node_Id;
2138          Has_No_Init  : Boolean := False;
2139          Is_Protected : Boolean := False)
2140       is
2141          Obj_Id    : constant Entity_Id := Defining_Identifier (Decl);
2142          Loc       : constant Source_Ptr := Sloc (Decl);
2143          Body_Ins  : Node_Id;
2144          Count_Ins : Node_Id;
2145          Fin_Call  : Node_Id;
2146          Fin_Stmts : List_Id;
2147          Inc_Decl  : Node_Id;
2148          Label     : Node_Id;
2149          Label_Id  : Entity_Id;
2150          Obj_Ref   : Node_Id;
2151          Obj_Typ   : Entity_Id;
2152
2153          function Build_BIP_Cleanup_Stmts (Func_Id : Entity_Id) return Node_Id;
2154          --  Once it has been established that the current object is in fact a
2155          --  return object of build-in-place function Func_Id, generate the
2156          --  following cleanup code:
2157          --
2158          --    if BIPallocfrom > Secondary_Stack'Pos
2159          --      and then BIPfinalizationmaster /= null
2160          --    then
2161          --       declare
2162          --          type Ptr_Typ is access Obj_Typ;
2163          --          for Ptr_Typ'Storage_Pool
2164          --            use Base_Pool (BIPfinalizationmaster);
2165          --       begin
2166          --          Free (Ptr_Typ (Temp));
2167          --       end;
2168          --    end if;
2169          --
2170          --  Obj_Typ is the type of the current object, Temp is the original
2171          --  allocation which Obj_Id renames.
2172
2173          procedure Find_Last_Init
2174            (Decl        : Node_Id;
2175             Typ         : Entity_Id;
2176             Last_Init   : out Node_Id;
2177             Body_Insert : out Node_Id);
2178          --  An object declaration has at least one and at most two init calls:
2179          --  that of the type and the user-defined initialize. Given an object
2180          --  declaration, Last_Init denotes the last initialization call which
2181          --  follows the declaration. Body_Insert denotes the place where the
2182          --  finalizer body could be potentially inserted.
2183
2184          -----------------------------
2185          -- Build_BIP_Cleanup_Stmts --
2186          -----------------------------
2187
2188          function Build_BIP_Cleanup_Stmts
2189            (Func_Id : Entity_Id) return Node_Id
2190          is
2191             Decls      : constant List_Id := New_List;
2192             Fin_Mas_Id : constant Entity_Id :=
2193                            Build_In_Place_Formal
2194                              (Func_Id, BIP_Finalization_Master);
2195             Obj_Typ    : constant Entity_Id := Etype (Func_Id);
2196             Temp_Id    : constant Entity_Id :=
2197                            Entity (Prefix (Name (Parent (Obj_Id))));
2198
2199             Cond      : Node_Id;
2200             Free_Blk  : Node_Id;
2201             Free_Stmt : Node_Id;
2202             Pool_Id   : Entity_Id;
2203             Ptr_Typ   : Entity_Id;
2204
2205          begin
2206             --  Generate:
2207             --    Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2208
2209             Pool_Id := Make_Temporary (Loc, 'P');
2210
2211             Append_To (Decls,
2212               Make_Object_Renaming_Declaration (Loc,
2213                 Defining_Identifier => Pool_Id,
2214                 Subtype_Mark        =>
2215                   New_Reference_To (RTE (RE_Root_Storage_Pool), Loc),
2216                 Name                =>
2217                   Make_Explicit_Dereference (Loc,
2218                     Prefix =>
2219                       Make_Function_Call (Loc,
2220                         Name                   =>
2221                           New_Reference_To (RTE (RE_Base_Pool), Loc),
2222                         Parameter_Associations => New_List (
2223                           Make_Explicit_Dereference (Loc,
2224                             Prefix => New_Reference_To (Fin_Mas_Id, Loc)))))));
2225
2226             --  Create an access type which uses the storage pool of the
2227             --  caller's finalization master.
2228
2229             --  Generate:
2230             --    type Ptr_Typ is access Obj_Typ;
2231
2232             Ptr_Typ := Make_Temporary (Loc, 'P');
2233
2234             Append_To (Decls,
2235               Make_Full_Type_Declaration (Loc,
2236                 Defining_Identifier => Ptr_Typ,
2237                 Type_Definition     =>
2238                   Make_Access_To_Object_Definition (Loc,
2239                     Subtype_Indication => New_Reference_To (Obj_Typ, Loc))));
2240
2241             --  Perform minor decoration in order to set the master and the
2242             --  storage pool attributes.
2243
2244             Set_Ekind (Ptr_Typ, E_Access_Type);
2245             Set_Finalization_Master     (Ptr_Typ, Fin_Mas_Id);
2246             Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
2247
2248             --  Create an explicit free statement. Note that the free uses the
2249             --  caller's pool expressed as a renaming.
2250
2251             Free_Stmt :=
2252               Make_Free_Statement (Loc,
2253                 Expression =>
2254                   Unchecked_Convert_To (Ptr_Typ,
2255                     New_Reference_To (Temp_Id, Loc)));
2256
2257             Set_Storage_Pool (Free_Stmt, Pool_Id);
2258
2259             --  Create a block to house the dummy type and the instantiation as
2260             --  well as to perform the cleanup the temporary.
2261
2262             --  Generate:
2263             --    declare
2264             --       <Decls>
2265             --    begin
2266             --       Free (Ptr_Typ (Temp_Id));
2267             --    end;
2268
2269             Free_Blk :=
2270               Make_Block_Statement (Loc,
2271                 Declarations               => Decls,
2272                 Handled_Statement_Sequence =>
2273                   Make_Handled_Sequence_Of_Statements (Loc,
2274                     Statements => New_List (Free_Stmt)));
2275
2276             --  Generate:
2277             --    if BIPfinalizationmaster /= null then
2278
2279             Cond :=
2280               Make_Op_Ne (Loc,
2281                 Left_Opnd  => New_Reference_To (Fin_Mas_Id, Loc),
2282                 Right_Opnd => Make_Null (Loc));
2283
2284             --  For constrained or tagged results escalate the condition to
2285             --  include the allocation format. Generate:
2286             --
2287             --    if BIPallocform > Secondary_Stack'Pos
2288             --      and then BIPfinalizationmaster /= null
2289             --    then
2290
2291             if not Is_Constrained (Obj_Typ)
2292               or else Is_Tagged_Type (Obj_Typ)
2293             then
2294                declare
2295                   Alloc : constant Entity_Id :=
2296                             Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
2297                begin
2298                   Cond :=
2299                     Make_And_Then (Loc,
2300                       Left_Opnd  =>
2301                         Make_Op_Gt (Loc,
2302                           Left_Opnd  => New_Reference_To (Alloc, Loc),
2303                           Right_Opnd =>
2304                             Make_Integer_Literal (Loc,
2305                               UI_From_Int
2306                                 (BIP_Allocation_Form'Pos (Secondary_Stack)))),
2307
2308                       Right_Opnd => Cond);
2309                end;
2310             end if;
2311
2312             --  Generate:
2313             --    if <Cond> then
2314             --       <Free_Blk>
2315             --    end if;
2316
2317             return
2318               Make_If_Statement (Loc,
2319                 Condition       => Cond,
2320                 Then_Statements => New_List (Free_Blk));
2321          end Build_BIP_Cleanup_Stmts;
2322
2323          --------------------
2324          -- Find_Last_Init --
2325          --------------------
2326
2327          procedure Find_Last_Init
2328            (Decl        : Node_Id;
2329             Typ         : Entity_Id;
2330             Last_Init   : out Node_Id;
2331             Body_Insert : out Node_Id)
2332          is
2333             Nod_1 : Node_Id := Empty;
2334             Nod_2 : Node_Id := Empty;
2335             Utyp  : Entity_Id;
2336
2337             function Is_Init_Call
2338               (N   : Node_Id;
2339                Typ : Entity_Id) return Boolean;
2340             --  Given an arbitrary node, determine whether N is a procedure
2341             --  call and if it is, try to match the name of the call with the
2342             --  [Deep_]Initialize proc of Typ.
2343
2344             function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id;
2345             --  Given a statement which is part of a list, return the next
2346             --  real statement while skipping over dynamic elab checks.
2347
2348             ------------------
2349             -- Is_Init_Call --
2350             ------------------
2351
2352             function Is_Init_Call
2353               (N   : Node_Id;
2354                Typ : Entity_Id) return Boolean
2355             is
2356             begin
2357                --  A call to [Deep_]Initialize is always direct
2358
2359                if Nkind (N) = N_Procedure_Call_Statement
2360                  and then Nkind (Name (N)) = N_Identifier
2361                then
2362                   declare
2363                      Call_Ent  : constant Entity_Id := Entity (Name (N));
2364                      Deep_Init : constant Entity_Id :=
2365                                    TSS (Typ, TSS_Deep_Initialize);
2366                      Init      : Entity_Id := Empty;
2367
2368                   begin
2369                      --  A type may have controlled components but not be
2370                      --  controlled.
2371
2372                      if Is_Controlled (Typ) then
2373                         Init := Find_Prim_Op (Typ, Name_Initialize);
2374
2375                         if Present (Init) then
2376                            Init := Ultimate_Alias (Init);
2377                         end if;
2378                      end if;
2379
2380                      return
2381                        (Present (Deep_Init) and then Call_Ent = Deep_Init)
2382                          or else
2383                        (Present (Init)      and then Call_Ent = Init);
2384                   end;
2385                end if;
2386
2387                return False;
2388             end Is_Init_Call;
2389
2390             -----------------------------
2391             -- Next_Suitable_Statement --
2392             -----------------------------
2393
2394             function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id is
2395                Result : Node_Id := Next (Stmt);
2396
2397             begin
2398                --  Skip over access-before-elaboration checks
2399
2400                if Dynamic_Elaboration_Checks
2401                  and then Nkind (Result) = N_Raise_Program_Error
2402                then
2403                   Result := Next (Result);
2404                end if;
2405
2406                return Result;
2407             end Next_Suitable_Statement;
2408
2409          --  Start of processing for Find_Last_Init
2410
2411          begin
2412             Last_Init   := Decl;
2413             Body_Insert := Empty;
2414
2415             --  Object renamings and objects associated with controlled
2416             --  function results do not have initialization calls.
2417
2418             if Has_No_Init then
2419                return;
2420             end if;
2421
2422             if Is_Concurrent_Type (Typ) then
2423                Utyp := Corresponding_Record_Type (Typ);
2424             else
2425                Utyp := Typ;
2426             end if;
2427
2428             if Is_Private_Type (Utyp)
2429               and then Present (Full_View (Utyp))
2430             then
2431                Utyp := Full_View (Utyp);
2432             end if;
2433
2434             --  The init procedures are arranged as follows:
2435
2436             --    Object : Controlled_Type;
2437             --    Controlled_TypeIP (Object);
2438             --    [[Deep_]Initialize (Object);]
2439
2440             --  where the user-defined initialize may be optional or may appear
2441             --  inside a block when abort deferral is needed.
2442
2443             Nod_1 := Next_Suitable_Statement (Decl);
2444             if Present (Nod_1) then
2445                Nod_2 := Next_Suitable_Statement (Nod_1);
2446
2447                --  The statement following an object declaration is always a
2448                --  call to the type init proc.
2449
2450                Last_Init := Nod_1;
2451             end if;
2452
2453             --  Optional user-defined init or deep init processing
2454
2455             if Present (Nod_2) then
2456
2457                --  The statement following the type init proc may be a block
2458                --  statement in cases where abort deferral is required.
2459
2460                if Nkind (Nod_2) = N_Block_Statement then
2461                   declare
2462                      HSS  : constant Node_Id :=
2463                               Handled_Statement_Sequence (Nod_2);
2464                      Stmt : Node_Id;
2465
2466                   begin
2467                      if Present (HSS)
2468                        and then Present (Statements (HSS))
2469                      then
2470                         Stmt := First (Statements (HSS));
2471
2472                         --  Examine individual block statements and locate the
2473                         --  call to [Deep_]Initialze.
2474
2475                         while Present (Stmt) loop
2476                            if Is_Init_Call (Stmt, Utyp) then
2477                               Last_Init   := Stmt;
2478                               Body_Insert := Nod_2;
2479
2480                               exit;
2481                            end if;
2482
2483                            Next (Stmt);
2484                         end loop;
2485                      end if;
2486                   end;
2487
2488                elsif Is_Init_Call (Nod_2, Utyp) then
2489                   Last_Init := Nod_2;
2490                end if;
2491             end if;
2492          end Find_Last_Init;
2493
2494       --  Start of processing for Process_Object_Declaration
2495
2496       begin
2497          Obj_Ref := New_Reference_To (Obj_Id, Loc);
2498          Obj_Typ := Base_Type (Etype (Obj_Id));
2499
2500          --  Handle access types
2501
2502          if Is_Access_Type (Obj_Typ) then
2503             Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
2504             Obj_Typ := Directly_Designated_Type (Obj_Typ);
2505          end if;
2506
2507          Set_Etype (Obj_Ref, Obj_Typ);
2508
2509          --  Set a new value for the state counter and insert the statement
2510          --  after the object declaration. Generate:
2511          --
2512          --    Counter := <value>;
2513
2514          Inc_Decl :=
2515            Make_Assignment_Statement (Loc,
2516              Name       => New_Reference_To (Counter_Id, Loc),
2517              Expression => Make_Integer_Literal (Loc, Counter_Val));
2518
2519          --  Insert the counter after all initialization has been done. The
2520          --  place of insertion depends on the context. When dealing with a
2521          --  controlled function, the counter is inserted directly after the
2522          --  declaration because such objects lack init calls.
2523
2524          Find_Last_Init (Decl, Obj_Typ, Count_Ins, Body_Ins);
2525
2526          Insert_After (Count_Ins, Inc_Decl);
2527          Analyze (Inc_Decl);
2528
2529          --  If the current declaration is the last in the list, the finalizer
2530          --  body needs to be inserted after the set counter statement for the
2531          --  current object declaration. This is complicated by the fact that
2532          --  the set counter statement may appear in abort deferred block. In
2533          --  that case, the proper insertion place is after the block.
2534
2535          if No (Finalizer_Insert_Nod) then
2536
2537             --  Insertion after an abort deffered block
2538
2539             if Present (Body_Ins) then
2540                Finalizer_Insert_Nod := Body_Ins;
2541             else
2542                Finalizer_Insert_Nod := Inc_Decl;
2543             end if;
2544          end if;
2545
2546          --  Create the associated label with this object, generate:
2547          --
2548          --    L<counter> : label;
2549
2550          Label_Id :=
2551            Make_Identifier (Loc, New_External_Name ('L', Counter_Val));
2552          Set_Entity
2553            (Label_Id, Make_Defining_Identifier (Loc, Chars (Label_Id)));
2554          Label := Make_Label (Loc, Label_Id);
2555
2556          Prepend_To (Finalizer_Decls,
2557            Make_Implicit_Label_Declaration (Loc,
2558              Defining_Identifier => Entity (Label_Id),
2559              Label_Construct     => Label));
2560
2561          --  Create the associated jump with this object, generate:
2562          --
2563          --    when <counter> =>
2564          --       goto L<counter>;
2565
2566          Prepend_To (Jump_Alts,
2567            Make_Case_Statement_Alternative (Loc,
2568              Discrete_Choices => New_List (
2569                Make_Integer_Literal (Loc, Counter_Val)),
2570              Statements       => New_List (
2571                Make_Goto_Statement (Loc,
2572                  Name => New_Reference_To (Entity (Label_Id), Loc)))));
2573
2574          --  Insert the jump destination, generate:
2575          --
2576          --     <<L<counter>>>
2577
2578          Append_To (Finalizer_Stmts, Label);
2579
2580          --  Processing for simple protected objects. Such objects require
2581          --  manual finalization of their lock managers.
2582
2583          if Is_Protected then
2584             Fin_Stmts := No_List;
2585
2586             if Is_Simple_Protected_Type (Obj_Typ) then
2587                Fin_Call := Cleanup_Protected_Object (Decl, Obj_Ref);
2588
2589                if Present (Fin_Call) then
2590                   Fin_Stmts := New_List (Fin_Call);
2591                end if;
2592
2593             elsif Has_Simple_Protected_Object (Obj_Typ) then
2594                if Is_Record_Type (Obj_Typ) then
2595                   Fin_Stmts := Cleanup_Record (Decl, Obj_Ref, Obj_Typ);
2596                elsif Is_Array_Type (Obj_Typ) then
2597                   Fin_Stmts := Cleanup_Array (Decl, Obj_Ref, Obj_Typ);
2598                end if;
2599             end if;
2600
2601             --  Generate:
2602             --    begin
2603             --       System.Tasking.Protected_Objects.Finalize_Protection
2604             --         (Obj._object);
2605
2606             --    exception
2607             --       when others =>
2608             --          null;
2609             --    end;
2610
2611             if Present (Fin_Stmts) then
2612                Append_To (Finalizer_Stmts,
2613                  Make_Block_Statement (Loc,
2614                    Handled_Statement_Sequence =>
2615                      Make_Handled_Sequence_Of_Statements (Loc,
2616                        Statements         => Fin_Stmts,
2617
2618                        Exception_Handlers => New_List (
2619                          Make_Exception_Handler (Loc,
2620                            Exception_Choices => New_List (
2621                              Make_Others_Choice (Loc)),
2622
2623                            Statements     => New_List (
2624                              Make_Null_Statement (Loc)))))));
2625             end if;
2626
2627          --  Processing for regular controlled objects
2628
2629          else
2630             --  Generate:
2631             --    [Deep_]Finalize (Obj);  --  No_Exception_Propagation
2632
2633             --    begin                   --  Exception handlers allowed
2634             --       [Deep_]Finalize (Obj);
2635
2636             --    exception
2637             --       when Id : others =>
2638             --          if not Raised then
2639             --             Raised := True;
2640             --             Save_Occurrence (E, Id);
2641             --          end if;
2642             --    end;
2643
2644             Fin_Call :=
2645               Make_Final_Call (
2646                 Obj_Ref => Obj_Ref,
2647                 Typ     => Obj_Typ);
2648
2649             --  For CodePeer, the exception handlers normally generated here
2650             --  generate complex flowgraphs which result in capacity problems.
2651             --  Omitting these handlers for CodePeer is justified as follows:
2652
2653             --    If a handler is dead, then omitting it is surely ok
2654
2655             --    If a handler is live, then CodePeer should flag the
2656             --      potentially-exception-raising construct that causes it
2657             --      to be live. That is what we are interested in, not what
2658             --      happens after the exception is raised.
2659
2660             if Exceptions_OK and not CodePeer_Mode then
2661                Fin_Stmts := New_List (
2662                  Make_Block_Statement (Loc,
2663                    Handled_Statement_Sequence =>
2664                      Make_Handled_Sequence_Of_Statements (Loc,
2665                        Statements => New_List (Fin_Call),
2666
2667                     Exception_Handlers => New_List (
2668                       Build_Exception_Handler
2669                         (Finalizer_Data, For_Package)))));
2670
2671             --  When exception handlers are prohibited, the finalization call
2672             --  appears unprotected. Any exception raised during finalization
2673             --  will bypass the circuitry which ensures the cleanup of all
2674             --  remaining objects.
2675
2676             else
2677                Fin_Stmts := New_List (Fin_Call);
2678             end if;
2679
2680             --  If we are dealing with a return object of a build-in-place
2681             --  function, generate the following cleanup statements:
2682
2683             --    if BIPallocfrom > Secondary_Stack'Pos
2684             --      and then BIPfinalizationmaster /= null
2685             --    then
2686             --       declare
2687             --          type Ptr_Typ is access Obj_Typ;
2688             --          for Ptr_Typ'Storage_Pool use
2689             --                Base_Pool (BIPfinalizationmaster.all).all;
2690             --       begin
2691             --          Free (Ptr_Typ (Temp));
2692             --       end;
2693             --    end if;
2694             --
2695             --  The generated code effectively detaches the temporary from the
2696             --  caller finalization master and deallocates the object. This is
2697             --  disabled on .NET/JVM because pools are not supported.
2698
2699             if VM_Target = No_VM and then Is_Return_Object (Obj_Id) then
2700                declare
2701                   Func_Id : constant Entity_Id := Enclosing_Function (Obj_Id);
2702                begin
2703                   if Is_Build_In_Place_Function (Func_Id)
2704                     and then Needs_BIP_Finalization_Master (Func_Id)
2705                   then
2706                      Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id));
2707                   end if;
2708                end;
2709             end if;
2710
2711             if Ekind_In (Obj_Id, E_Constant, E_Variable)
2712               and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
2713             then
2714                --  Temporaries created for the purpose of "exporting" a
2715                --  controlled transient out of an Expression_With_Actions (EWA)
2716                --  need guards. The following illustrates the usage of such
2717                --  temporaries.
2718
2719                --    Access_Typ : access [all] Obj_Typ;
2720                --    Temp       : Access_Typ := null;
2721                --    <Counter>  := ...;
2722
2723                --    do
2724                --       Ctrl_Trans : [access [all]] Obj_Typ := ...;
2725                --       Temp := Access_Typ (Ctrl_Trans);  --  when a pointer
2726                --         <or>
2727                --       Temp := Ctrl_Trans'Unchecked_Access;
2728                --    in ... end;
2729
2730                --  The finalization machinery does not process EWA nodes as
2731                --  this may lead to premature finalization of expressions. Note
2732                --  that Temp is marked as being properly initialized regardless
2733                --  of whether the initialization of Ctrl_Trans succeeded. Since
2734                --  a failed initialization may leave Temp with a value of null,
2735                --  add a guard to handle this case:
2736
2737                --    if Obj /= null then
2738                --       <object finalization statements>
2739                --    end if;
2740
2741                if Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
2742                                                       N_Object_Declaration
2743                then
2744                   Fin_Stmts := New_List (
2745                     Make_If_Statement (Loc,
2746                       Condition       =>
2747                         Make_Op_Ne (Loc,
2748                           Left_Opnd  => New_Reference_To (Obj_Id, Loc),
2749                           Right_Opnd => Make_Null (Loc)),
2750                       Then_Statements => Fin_Stmts));
2751
2752                --  Return objects use a flag to aid in processing their
2753                --  potential finalization when the enclosing function fails
2754                --  to return properly. Generate:
2755
2756                --    if not Flag then
2757                --       <object finalization statements>
2758                --    end if;
2759
2760                else
2761                   Fin_Stmts := New_List (
2762                     Make_If_Statement (Loc,
2763                       Condition     =>
2764                         Make_Op_Not (Loc,
2765                           Right_Opnd =>
2766                             New_Reference_To
2767                               (Status_Flag_Or_Transient_Decl (Obj_Id), Loc)),
2768
2769                     Then_Statements => Fin_Stmts));
2770                end if;
2771             end if;
2772          end if;
2773
2774          Append_List_To (Finalizer_Stmts, Fin_Stmts);
2775
2776          --  Since the declarations are examined in reverse, the state counter
2777          --  must be decremented in order to keep with the true position of
2778          --  objects.
2779
2780          Counter_Val := Counter_Val - 1;
2781       end Process_Object_Declaration;
2782
2783       -------------------------------------
2784       -- Process_Tagged_Type_Declaration --
2785       -------------------------------------
2786
2787       procedure Process_Tagged_Type_Declaration (Decl : Node_Id) is
2788          Typ    : constant Entity_Id := Defining_Identifier (Decl);
2789          DT_Ptr : constant Entity_Id :=
2790                     Node (First_Elmt (Access_Disp_Table (Typ)));
2791       begin
2792          --  Generate:
2793          --    Ada.Tags.Unregister_Tag (<Typ>P);
2794
2795          Append_To (Tagged_Type_Stmts,
2796            Make_Procedure_Call_Statement (Loc,
2797              Name                   =>
2798                New_Reference_To (RTE (RE_Unregister_Tag), Loc),
2799              Parameter_Associations => New_List (
2800                New_Reference_To (DT_Ptr, Loc))));
2801       end Process_Tagged_Type_Declaration;
2802
2803    --  Start of processing for Build_Finalizer
2804
2805    begin
2806       Fin_Id := Empty;
2807
2808       --  Do not perform this expansion in Alfa mode because it is not
2809       --  necessary.
2810
2811       if Alfa_Mode then
2812          return;
2813       end if;
2814
2815       --  Step 1: Extract all lists which may contain controlled objects or
2816       --  library-level tagged types.
2817
2818       if For_Package_Spec then
2819          Decls      := Visible_Declarations (Specification (N));
2820          Priv_Decls := Private_Declarations (Specification (N));
2821
2822          --  Retrieve the package spec id
2823
2824          Spec_Id := Defining_Unit_Name (Specification (N));
2825
2826          if Nkind (Spec_Id) = N_Defining_Program_Unit_Name then
2827             Spec_Id := Defining_Identifier (Spec_Id);
2828          end if;
2829
2830       --  Accept statement, block, entry body, package body, protected body,
2831       --  subprogram body or task body.
2832
2833       else
2834          Decls := Declarations (N);
2835          HSS   := Handled_Statement_Sequence (N);
2836
2837          if Present (HSS) then
2838             if Present (Statements (HSS)) then
2839                Stmts := Statements (HSS);
2840             end if;
2841
2842             if Present (At_End_Proc (HSS)) then
2843                Prev_At_End := At_End_Proc (HSS);
2844             end if;
2845          end if;
2846
2847          --  Retrieve the package spec id for package bodies
2848
2849          if For_Package_Body then
2850             Spec_Id := Corresponding_Spec (N);
2851          end if;
2852       end if;
2853
2854       --  Do not process nested packages since those are handled by the
2855       --  enclosing scope's finalizer. Do not process non-expanded package
2856       --  instantiations since those will be re-analyzed and re-expanded.
2857
2858       if For_Package
2859         and then
2860           (not Is_Library_Level_Entity (Spec_Id)
2861
2862              --  Nested packages are considered to be library level entities,
2863              --  but do not need to be processed separately. True library level
2864              --  packages have a scope value of 1.
2865
2866              or else Scope_Depth_Value (Spec_Id) /= Uint_1
2867              or else (Is_Generic_Instance (Spec_Id)
2868                        and then Package_Instantiation (Spec_Id) /= N))
2869       then
2870          return;
2871       end if;
2872
2873       --  Step 2: Object [pre]processing
2874
2875       if For_Package then
2876
2877          --  Preprocess the visible declarations now in order to obtain the
2878          --  correct number of controlled object by the time the private
2879          --  declarations are processed.
2880
2881          Process_Declarations (Decls, Preprocess => True, Top_Level => True);
2882
2883          --  From all the possible contexts, only package specifications may
2884          --  have private declarations.
2885
2886          if For_Package_Spec then
2887             Process_Declarations
2888               (Priv_Decls, Preprocess => True, Top_Level => True);
2889          end if;
2890
2891          --  The current context may lack controlled objects, but require some
2892          --  other form of completion (task termination for instance). In such
2893          --  cases, the finalizer must be created and carry the additional
2894          --  statements.
2895
2896          if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
2897             Build_Components;
2898          end if;
2899
2900          --  The preprocessing has determined that the context has controlled
2901          --  objects or library-level tagged types.
2902
2903          if Has_Ctrl_Objs or Has_Tagged_Types then
2904
2905             --  Private declarations are processed first in order to preserve
2906             --  possible dependencies between public and private objects.
2907
2908             if For_Package_Spec then
2909                Process_Declarations (Priv_Decls);
2910             end if;
2911
2912             Process_Declarations (Decls);
2913          end if;
2914
2915       --  Non-package case
2916
2917       else
2918          --  Preprocess both declarations and statements
2919
2920          Process_Declarations (Decls, Preprocess => True, Top_Level => True);
2921          Process_Declarations (Stmts, Preprocess => True, Top_Level => True);
2922
2923          --  At this point it is known that N has controlled objects. Ensure
2924          --  that N has a declarative list since the finalizer spec will be
2925          --  attached to it.
2926
2927          if Has_Ctrl_Objs and then No (Decls) then
2928             Set_Declarations (N, New_List);
2929             Decls      := Declarations (N);
2930             Spec_Decls := Decls;
2931          end if;
2932
2933          --  The current context may lack controlled objects, but require some
2934          --  other form of completion (task termination for instance). In such
2935          --  cases, the finalizer must be created and carry the additional
2936          --  statements.
2937
2938          if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
2939             Build_Components;
2940          end if;
2941
2942          if Has_Ctrl_Objs or Has_Tagged_Types then
2943             Process_Declarations (Stmts);
2944             Process_Declarations (Decls);
2945          end if;
2946       end if;
2947
2948       --  Step 3: Finalizer creation
2949
2950       if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
2951          Create_Finalizer;
2952       end if;
2953    end Build_Finalizer;
2954
2955    --------------------------
2956    -- Build_Finalizer_Call --
2957    --------------------------
2958
2959    procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id) is
2960       Is_Prot_Body : constant Boolean :=
2961                        Nkind (N) = N_Subprogram_Body
2962                          and then Is_Protected_Subprogram_Body (N);
2963       --  Determine whether N denotes the protected version of a subprogram
2964       --  which belongs to a protected type.
2965
2966       Loc : constant Source_Ptr := Sloc (N);
2967       HSS : Node_Id;
2968
2969    begin
2970       --  Do not perform this expansion in Alfa mode because we do not create
2971       --  finalizers in the first place.
2972
2973       if Alfa_Mode then
2974          return;
2975       end if;
2976
2977       --  The At_End handler should have been assimilated by the finalizer
2978
2979       HSS := Handled_Statement_Sequence (N);
2980       pragma Assert (No (At_End_Proc (HSS)));
2981
2982       --  If the construct to be cleaned up is a protected subprogram body, the
2983       --  finalizer call needs to be associated with the block which wraps the
2984       --  unprotected version of the subprogram. The following illustrates this
2985       --  scenario:
2986
2987       --     procedure Prot_SubpP is
2988       --        procedure finalizer is
2989       --        begin
2990       --           Service_Entries (Prot_Obj);
2991       --           Abort_Undefer;
2992       --        end finalizer;
2993
2994       --     begin
2995       --        . . .
2996       --        begin
2997       --           Prot_SubpN (Prot_Obj);
2998       --        at end
2999       --           finalizer;
3000       --        end;
3001       --     end Prot_SubpP;
3002
3003       if Is_Prot_Body then
3004          HSS := Handled_Statement_Sequence (Last (Statements (HSS)));
3005
3006       --  An At_End handler and regular exception handlers cannot coexist in
3007       --  the same statement sequence. Wrap the original statements in a block.
3008
3009       elsif Present (Exception_Handlers (HSS)) then
3010          declare
3011             End_Lab : constant Node_Id := End_Label (HSS);
3012             Block   : Node_Id;
3013
3014          begin
3015             Block :=
3016               Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS);
3017
3018             Set_Handled_Statement_Sequence (N,
3019               Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
3020
3021             HSS := Handled_Statement_Sequence (N);
3022             Set_End_Label (HSS, End_Lab);
3023          end;
3024       end if;
3025
3026       Set_At_End_Proc (HSS, New_Reference_To (Fin_Id, Loc));
3027
3028       Analyze (At_End_Proc (HSS));
3029       Expand_At_End_Handler (HSS, Empty);
3030    end Build_Finalizer_Call;
3031
3032    ---------------------
3033    -- Build_Late_Proc --
3034    ---------------------
3035
3036    procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is
3037    begin
3038       for Final_Prim in Name_Of'Range loop
3039          if Name_Of (Final_Prim) = Nam then
3040             Set_TSS (Typ,
3041               Make_Deep_Proc
3042                 (Prim  => Final_Prim,
3043                  Typ   => Typ,
3044                  Stmts => Make_Deep_Record_Body (Final_Prim, Typ)));
3045          end if;
3046       end loop;
3047    end Build_Late_Proc;
3048
3049    -------------------------------
3050    -- Build_Object_Declarations --
3051    -------------------------------
3052
3053    procedure Build_Object_Declarations
3054      (Data        : out Finalization_Exception_Data;
3055       Decls       : List_Id;
3056       Loc         : Source_Ptr;
3057       For_Package : Boolean := False)
3058    is
3059       A_Expr : Node_Id;
3060       E_Decl : Node_Id;
3061
3062    begin
3063       pragma Assert (Decls /= No_List);
3064
3065       --  Always set the proper location as it may be needed even when
3066       --  exception propagation is forbidden.
3067
3068       Data.Loc := Loc;
3069
3070       if Restriction_Active (No_Exception_Propagation) then
3071          Data.Abort_Id  := Empty;
3072          Data.E_Id      := Empty;
3073          Data.Raised_Id := Empty;
3074          return;
3075       end if;
3076
3077       Data.Raised_Id := Make_Temporary (Loc, 'R');
3078
3079       --  In certain scenarios, finalization can be triggered by an abort. If
3080       --  the finalization itself fails and raises an exception, the resulting
3081       --  Program_Error must be supressed and replaced by an abort signal. In
3082       --  order to detect this scenario, save the state of entry into the
3083       --  finalization code.
3084
3085       --  No need to do this for VM case, since VM version of Ada.Exceptions
3086       --  does not include routine Raise_From_Controlled_Operation which is the
3087       --  the sole user of flag Abort.
3088
3089       --  This is not needed for library-level finalizers as they are called
3090       --  by the environment task and cannot be aborted.
3091
3092       if Abort_Allowed
3093         and then VM_Target = No_VM
3094         and then not For_Package
3095       then
3096          Data.Abort_Id  := Make_Temporary (Loc, 'A');
3097
3098          A_Expr := New_Reference_To (RTE (RE_Triggered_By_Abort), Loc);
3099
3100          --  Generate:
3101
3102          --    Abort_Id : constant Boolean := <A_Expr>;
3103
3104          Append_To (Decls,
3105            Make_Object_Declaration (Loc,
3106              Defining_Identifier => Data.Abort_Id,
3107              Constant_Present    => True,
3108              Object_Definition   => New_Reference_To (Standard_Boolean, Loc),
3109              Expression          => A_Expr));
3110
3111       else
3112          --  No abort, .NET/JVM or library-level finalizers
3113
3114          Data.Abort_Id  := Empty;
3115       end if;
3116
3117       if Exception_Extra_Info then
3118          Data.E_Id      := Make_Temporary (Loc, 'E');
3119
3120          --  Generate:
3121
3122          --    E_Id : Exception_Occurrence;
3123
3124          E_Decl :=
3125            Make_Object_Declaration (Loc,
3126              Defining_Identifier => Data.E_Id,
3127              Object_Definition   =>
3128                New_Reference_To (RTE (RE_Exception_Occurrence), Loc));
3129          Set_No_Initialization (E_Decl);
3130
3131          Append_To (Decls, E_Decl);
3132
3133       else
3134          Data.E_Id      := Empty;
3135       end if;
3136
3137       --  Generate:
3138
3139       --    Raised_Id : Boolean := False;
3140
3141       Append_To (Decls,
3142         Make_Object_Declaration (Loc,
3143           Defining_Identifier => Data.Raised_Id,
3144           Object_Definition   => New_Reference_To (Standard_Boolean, Loc),
3145           Expression          => New_Reference_To (Standard_False, Loc)));
3146    end Build_Object_Declarations;
3147
3148    ---------------------------
3149    -- Build_Raise_Statement --
3150    ---------------------------
3151
3152    function Build_Raise_Statement
3153      (Data : Finalization_Exception_Data) return Node_Id
3154    is
3155       Stmt : Node_Id;
3156       Expr : Node_Id;
3157
3158    begin
3159       --  Standard run-time and .NET/JVM targets use the specialized routine
3160       --  Raise_From_Controlled_Operation.
3161
3162       if Exception_Extra_Info
3163         and then RTE_Available (RE_Raise_From_Controlled_Operation)
3164       then
3165          Stmt :=
3166            Make_Procedure_Call_Statement (Data.Loc,
3167               Name                   =>
3168                 New_Reference_To
3169                   (RTE (RE_Raise_From_Controlled_Operation), Data.Loc),
3170               Parameter_Associations =>
3171                 New_List (New_Reference_To (Data.E_Id, Data.Loc)));
3172
3173       --  Restricted run-time: exception messages are not supported and hence
3174       --  Raise_From_Controlled_Operation is not supported. Raise Program_Error
3175       --  instead.
3176
3177       else
3178          Stmt :=
3179            Make_Raise_Program_Error (Data.Loc,
3180              Reason => PE_Finalize_Raised_Exception);
3181       end if;
3182
3183       --  Generate:
3184
3185       --    Raised_Id and then not Abort_Id
3186       --      <or>
3187       --    Raised_Id
3188
3189       Expr := New_Reference_To (Data.Raised_Id, Data.Loc);
3190
3191       if Present (Data.Abort_Id) then
3192          Expr := Make_And_Then (Data.Loc,
3193            Left_Opnd  => Expr,
3194            Right_Opnd =>
3195              Make_Op_Not (Data.Loc,
3196                Right_Opnd => New_Reference_To (Data.Abort_Id, Data.Loc)));
3197       end if;
3198
3199       --  Generate:
3200
3201       --    if Raised_Id and then not Abort_Id then
3202       --       Raise_From_Controlled_Operation (E_Id);
3203       --         <or>
3204       --       raise Program_Error;  --  restricted runtime
3205       --    end if;
3206
3207       return
3208         Make_If_Statement (Data.Loc,
3209           Condition       => Expr,
3210           Then_Statements => New_List (Stmt));
3211    end Build_Raise_Statement;
3212
3213    -----------------------------
3214    -- Build_Record_Deep_Procs --
3215    -----------------------------
3216
3217    procedure Build_Record_Deep_Procs (Typ : Entity_Id) is
3218    begin
3219       Set_TSS (Typ,
3220         Make_Deep_Proc
3221           (Prim  => Initialize_Case,
3222            Typ   => Typ,
3223            Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
3224
3225       if not Is_Immutably_Limited_Type (Typ) then
3226          Set_TSS (Typ,
3227            Make_Deep_Proc
3228              (Prim  => Adjust_Case,
3229               Typ   => Typ,
3230               Stmts => Make_Deep_Record_Body (Adjust_Case, Typ)));
3231       end if;
3232
3233       --  Do not generate Deep_Finalize and Finalize_Address if finalization is
3234       --  suppressed since these routine will not be used.
3235
3236       if not Restriction_Active (No_Finalization) then
3237          Set_TSS (Typ,
3238            Make_Deep_Proc
3239              (Prim  => Finalize_Case,
3240               Typ   => Typ,
3241               Stmts => Make_Deep_Record_Body (Finalize_Case, Typ)));
3242
3243          --  Create TSS primitive Finalize_Address for non-VM targets. JVM and
3244          --  .NET do not support address arithmetic and unchecked conversions.
3245
3246          if VM_Target = No_VM then
3247             Set_TSS (Typ,
3248               Make_Deep_Proc
3249                 (Prim  => Address_Case,
3250                  Typ   => Typ,
3251                  Stmts => Make_Deep_Record_Body (Address_Case, Typ)));
3252          end if;
3253       end if;
3254    end Build_Record_Deep_Procs;
3255
3256    -------------------
3257    -- Cleanup_Array --
3258    -------------------
3259
3260    function Cleanup_Array
3261      (N    : Node_Id;
3262       Obj  : Node_Id;
3263       Typ  : Entity_Id) return List_Id
3264    is
3265       Loc        : constant Source_Ptr := Sloc (N);
3266       Index_List : constant List_Id := New_List;
3267
3268       function Free_Component return List_Id;
3269       --  Generate the code to finalize the task or protected  subcomponents
3270       --  of a single component of the array.
3271
3272       function Free_One_Dimension (Dim : Int) return List_Id;
3273       --  Generate a loop over one dimension of the array
3274
3275       --------------------
3276       -- Free_Component --
3277       --------------------
3278
3279       function Free_Component return List_Id is
3280          Stmts : List_Id := New_List;
3281          Tsk   : Node_Id;
3282          C_Typ : constant Entity_Id := Component_Type (Typ);
3283
3284       begin
3285          --  Component type is known to contain tasks or protected objects
3286
3287          Tsk :=
3288            Make_Indexed_Component (Loc,
3289              Prefix        => Duplicate_Subexpr_No_Checks (Obj),
3290              Expressions   => Index_List);
3291
3292          Set_Etype (Tsk, C_Typ);
3293
3294          if Is_Task_Type (C_Typ) then
3295             Append_To (Stmts, Cleanup_Task (N, Tsk));
3296
3297          elsif Is_Simple_Protected_Type (C_Typ) then
3298             Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
3299
3300          elsif Is_Record_Type (C_Typ) then
3301             Stmts := Cleanup_Record (N, Tsk, C_Typ);
3302
3303          elsif Is_Array_Type (C_Typ) then
3304             Stmts := Cleanup_Array (N, Tsk, C_Typ);
3305          end if;
3306
3307          return Stmts;
3308       end Free_Component;
3309
3310       ------------------------
3311       -- Free_One_Dimension --
3312       ------------------------
3313
3314       function Free_One_Dimension (Dim : Int) return List_Id is
3315          Index : Entity_Id;
3316
3317       begin
3318          if Dim > Number_Dimensions (Typ) then
3319             return Free_Component;
3320
3321          --  Here we generate the required loop
3322
3323          else
3324             Index := Make_Temporary (Loc, 'J');
3325             Append (New_Reference_To (Index, Loc), Index_List);
3326
3327             return New_List (
3328               Make_Implicit_Loop_Statement (N,
3329                 Identifier       => Empty,
3330                 Iteration_Scheme =>
3331                   Make_Iteration_Scheme (Loc,
3332                     Loop_Parameter_Specification =>
3333                       Make_Loop_Parameter_Specification (Loc,
3334                         Defining_Identifier         => Index,
3335                         Discrete_Subtype_Definition =>
3336                           Make_Attribute_Reference (Loc,
3337                             Prefix          => Duplicate_Subexpr (Obj),
3338                             Attribute_Name  => Name_Range,
3339                             Expressions     => New_List (
3340                               Make_Integer_Literal (Loc, Dim))))),
3341                 Statements       =>  Free_One_Dimension (Dim + 1)));
3342          end if;
3343       end Free_One_Dimension;
3344
3345    --  Start of processing for Cleanup_Array
3346
3347    begin
3348       return Free_One_Dimension (1);
3349    end Cleanup_Array;
3350
3351    --------------------
3352    -- Cleanup_Record --
3353    --------------------
3354
3355    function Cleanup_Record
3356      (N    : Node_Id;
3357       Obj  : Node_Id;
3358       Typ  : Entity_Id) return List_Id
3359    is
3360       Loc   : constant Source_Ptr := Sloc (N);
3361       Tsk   : Node_Id;
3362       Comp  : Entity_Id;
3363       Stmts : constant List_Id    := New_List;
3364       U_Typ : constant Entity_Id  := Underlying_Type (Typ);
3365
3366    begin
3367       if Has_Discriminants (U_Typ)
3368         and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration
3369         and then
3370           Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition
3371         and then
3372           Present
3373             (Variant_Part (Component_List (Type_Definition (Parent (U_Typ)))))
3374       then
3375          --  For now, do not attempt to free a component that may appear in a
3376          --  variant, and instead issue a warning. Doing this "properly" would
3377          --  require building a case statement and would be quite a mess. Note
3378          --  that the RM only requires that free "work" for the case of a task
3379          --  access value, so already we go way beyond this in that we deal
3380          --  with the array case and non-discriminated record cases.
3381
3382          Error_Msg_N
3383            ("task/protected object in variant record will not be freed??", N);
3384          return New_List (Make_Null_Statement (Loc));
3385       end if;
3386
3387       Comp := First_Component (Typ);
3388       while Present (Comp) loop
3389          if Has_Task (Etype (Comp))
3390            or else Has_Simple_Protected_Object (Etype (Comp))
3391          then
3392             Tsk :=
3393               Make_Selected_Component (Loc,
3394                 Prefix        => Duplicate_Subexpr_No_Checks (Obj),
3395                 Selector_Name => New_Occurrence_Of (Comp, Loc));
3396             Set_Etype (Tsk, Etype (Comp));
3397
3398             if Is_Task_Type (Etype (Comp)) then
3399                Append_To (Stmts, Cleanup_Task (N, Tsk));
3400
3401             elsif Is_Simple_Protected_Type (Etype (Comp)) then
3402                Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
3403
3404             elsif Is_Record_Type (Etype (Comp)) then
3405
3406                --  Recurse, by generating the prefix of the argument to
3407                --  the eventual cleanup call.
3408
3409                Append_List_To (Stmts, Cleanup_Record (N, Tsk, Etype (Comp)));
3410
3411             elsif Is_Array_Type (Etype (Comp)) then
3412                Append_List_To (Stmts, Cleanup_Array (N, Tsk, Etype (Comp)));
3413             end if;
3414          end if;
3415
3416          Next_Component (Comp);
3417       end loop;
3418
3419       return Stmts;
3420    end Cleanup_Record;
3421
3422    ------------------------------
3423    -- Cleanup_Protected_Object --
3424    ------------------------------
3425
3426    function Cleanup_Protected_Object
3427      (N   : Node_Id;
3428       Ref : Node_Id) return Node_Id
3429    is
3430       Loc : constant Source_Ptr := Sloc (N);
3431
3432    begin
3433       --  For restricted run-time libraries (Ravenscar), tasks are
3434       --  non-terminating, and protected objects can only appear at library
3435       --  level, so we do not want finalization of protected objects.
3436
3437       if Restricted_Profile then
3438          return Empty;
3439
3440       else
3441          return
3442            Make_Procedure_Call_Statement (Loc,
3443              Name                   =>
3444                New_Reference_To (RTE (RE_Finalize_Protection), Loc),
3445              Parameter_Associations => New_List (Concurrent_Ref (Ref)));
3446       end if;
3447    end Cleanup_Protected_Object;
3448
3449    ------------------
3450    -- Cleanup_Task --
3451    ------------------
3452
3453    function Cleanup_Task
3454      (N   : Node_Id;
3455       Ref : Node_Id) return Node_Id
3456    is
3457       Loc  : constant Source_Ptr := Sloc (N);
3458
3459    begin
3460       --  For restricted run-time libraries (Ravenscar), tasks are
3461       --  non-terminating and they can only appear at library level, so we do
3462       --  not want finalization of task objects.
3463
3464       if Restricted_Profile then
3465          return Empty;
3466
3467       else
3468          return
3469            Make_Procedure_Call_Statement (Loc,
3470              Name                   =>
3471                New_Reference_To (RTE (RE_Free_Task), Loc),
3472              Parameter_Associations => New_List (Concurrent_Ref (Ref)));
3473       end if;
3474    end Cleanup_Task;
3475
3476    ------------------------------
3477    -- Check_Visibly_Controlled --
3478    ------------------------------
3479
3480    procedure Check_Visibly_Controlled
3481      (Prim : Final_Primitives;
3482       Typ  : Entity_Id;
3483       E    : in out Entity_Id;
3484       Cref : in out Node_Id)
3485    is
3486       Parent_Type : Entity_Id;
3487       Op          : Entity_Id;
3488
3489    begin
3490       if Is_Derived_Type (Typ)
3491         and then Comes_From_Source (E)
3492         and then not Present (Overridden_Operation (E))
3493       then
3494          --  We know that the explicit operation on the type does not override
3495          --  the inherited operation of the parent, and that the derivation
3496          --  is from a private type that is not visibly controlled.
3497
3498          Parent_Type := Etype (Typ);
3499          Op := Find_Prim_Op (Parent_Type, Name_Of (Prim));
3500
3501          if Present (Op) then
3502             E := Op;
3503
3504             --  Wrap the object to be initialized into the proper
3505             --  unchecked conversion, to be compatible with the operation
3506             --  to be called.
3507
3508             if Nkind (Cref) = N_Unchecked_Type_Conversion then
3509                Cref := Unchecked_Convert_To (Parent_Type, Expression (Cref));
3510             else
3511                Cref := Unchecked_Convert_To (Parent_Type, Cref);
3512             end if;
3513          end if;
3514       end if;
3515    end Check_Visibly_Controlled;
3516
3517    -------------------------------
3518    -- CW_Or_Has_Controlled_Part --
3519    -------------------------------
3520
3521    function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is
3522    begin
3523       return Is_Class_Wide_Type (T) or else Needs_Finalization (T);
3524    end CW_Or_Has_Controlled_Part;
3525
3526    ------------------
3527    -- Convert_View --
3528    ------------------
3529
3530    function Convert_View
3531      (Proc : Entity_Id;
3532       Arg  : Node_Id;
3533       Ind  : Pos := 1) return Node_Id
3534    is
3535       Fent : Entity_Id := First_Entity (Proc);
3536       Ftyp : Entity_Id;
3537       Atyp : Entity_Id;
3538
3539    begin
3540       for J in 2 .. Ind loop
3541          Next_Entity (Fent);
3542       end loop;
3543
3544       Ftyp := Etype (Fent);
3545
3546       if Nkind_In (Arg, N_Type_Conversion, N_Unchecked_Type_Conversion) then
3547          Atyp := Entity (Subtype_Mark (Arg));
3548       else
3549          Atyp := Etype (Arg);
3550       end if;
3551
3552       if Is_Abstract_Subprogram (Proc) and then Is_Tagged_Type (Ftyp) then
3553          return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg);
3554
3555       elsif Ftyp /= Atyp
3556         and then Present (Atyp)
3557         and then (Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp))
3558         and then Base_Type (Underlying_Type (Atyp)) =
3559                  Base_Type (Underlying_Type (Ftyp))
3560       then
3561          return Unchecked_Convert_To (Ftyp, Arg);
3562
3563       --  If the argument is already a conversion, as generated by
3564       --  Make_Init_Call, set the target type to the type of the formal
3565       --  directly, to avoid spurious typing problems.
3566
3567       elsif Nkind_In (Arg, N_Unchecked_Type_Conversion, N_Type_Conversion)
3568         and then not Is_Class_Wide_Type (Atyp)
3569       then
3570          Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg)));
3571          Set_Etype (Arg, Ftyp);
3572          return Arg;
3573
3574       else
3575          return Arg;
3576       end if;
3577    end Convert_View;
3578
3579    ------------------------
3580    -- Enclosing_Function --
3581    ------------------------
3582
3583    function Enclosing_Function (E : Entity_Id) return Entity_Id is
3584       Func_Id : Entity_Id;
3585
3586    begin
3587       Func_Id := E;
3588       while Present (Func_Id)
3589         and then Func_Id /= Standard_Standard
3590       loop
3591          if Ekind (Func_Id) = E_Function then
3592             return Func_Id;
3593          end if;
3594
3595          Func_Id := Scope (Func_Id);
3596       end loop;
3597
3598       return Empty;
3599    end Enclosing_Function;
3600
3601    -------------------------------
3602    -- Establish_Transient_Scope --
3603    -------------------------------
3604
3605    --  This procedure is called each time a transient block has to be inserted
3606    --  that is to say for each call to a function with unconstrained or tagged
3607    --  result. It creates a new scope on the stack scope in order to enclose
3608    --  all transient variables generated
3609
3610    procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean) is
3611       Loc       : constant Source_Ptr := Sloc (N);
3612       Wrap_Node : Node_Id;
3613
3614    begin
3615       --  Do not create a transient scope if we are already inside one
3616
3617       for S in reverse Scope_Stack.First .. Scope_Stack.Last loop
3618          if Scope_Stack.Table (S).Is_Transient then
3619             if Sec_Stack then
3620                Set_Uses_Sec_Stack (Scope_Stack.Table (S).Entity);
3621             end if;
3622
3623             return;
3624
3625          --  If we have encountered Standard there are no enclosing
3626          --  transient scopes.
3627
3628          elsif Scope_Stack.Table (S).Entity = Standard_Standard then
3629             exit;
3630          end if;
3631       end loop;
3632
3633       Wrap_Node := Find_Node_To_Be_Wrapped (N);
3634
3635       --  Case of no wrap node, false alert, no transient scope needed
3636
3637       if No (Wrap_Node) then
3638          null;
3639
3640       --  If the node to wrap is an iteration_scheme, the expression is
3641       --  one of the bounds, and the expansion will make an explicit
3642       --  declaration for it (see Analyze_Iteration_Scheme, sem_ch5.adb),
3643       --  so do not apply any transformations here. Same for an Ada 2012
3644       --  iterator specification, where a block is created for the expression
3645       --  that build the container.
3646
3647       elsif Nkind_In (Wrap_Node, N_Iteration_Scheme,
3648                                  N_Iterator_Specification)
3649       then
3650          null;
3651
3652       --  In formal verification mode, if the node to wrap is a pragma check,
3653       --  this node and enclosed expression are not expanded, so do not apply
3654       --  any transformations here.
3655
3656       elsif Alfa_Mode
3657         and then Nkind (Wrap_Node) = N_Pragma
3658         and then Get_Pragma_Id (Wrap_Node) = Pragma_Check
3659       then
3660          null;
3661
3662       else
3663          Push_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'));
3664          Set_Scope_Is_Transient;
3665
3666          if Sec_Stack then
3667             Set_Uses_Sec_Stack (Current_Scope);
3668             Check_Restriction (No_Secondary_Stack, N);
3669          end if;
3670
3671          Set_Etype (Current_Scope, Standard_Void_Type);
3672          Set_Node_To_Be_Wrapped (Wrap_Node);
3673
3674          if Debug_Flag_W then
3675             Write_Str ("    <Transient>");
3676             Write_Eol;
3677          end if;
3678       end if;
3679    end Establish_Transient_Scope;
3680
3681    ----------------------------
3682    -- Expand_Cleanup_Actions --
3683    ----------------------------
3684
3685    procedure Expand_Cleanup_Actions (N : Node_Id) is
3686       Scop : constant Entity_Id := Current_Scope;
3687
3688       Is_Asynchronous_Call : constant Boolean :=
3689                                Nkind (N) = N_Block_Statement
3690                                  and then Is_Asynchronous_Call_Block (N);
3691       Is_Master            : constant Boolean :=
3692                                Nkind (N) /= N_Entry_Body
3693                                  and then Is_Task_Master (N);
3694       Is_Protected_Body    : constant Boolean :=
3695                                Nkind (N) = N_Subprogram_Body
3696                                  and then Is_Protected_Subprogram_Body (N);
3697       Is_Task_Allocation   : constant Boolean :=
3698                                Nkind (N) = N_Block_Statement
3699                                  and then Is_Task_Allocation_Block (N);
3700       Is_Task_Body         : constant Boolean :=
3701                                Nkind (Original_Node (N)) = N_Task_Body;
3702       Needs_Sec_Stack_Mark : constant Boolean :=
3703                                Uses_Sec_Stack (Scop)
3704                                  and then
3705                                    not Sec_Stack_Needed_For_Return (Scop)
3706                                  and then VM_Target = No_VM;
3707
3708       Actions_Required     : constant Boolean :=
3709                                Requires_Cleanup_Actions (N, True)
3710                                  or else Is_Asynchronous_Call
3711                                  or else Is_Master
3712                                  or else Is_Protected_Body
3713                                  or else Is_Task_Allocation
3714                                  or else Is_Task_Body
3715                                  or else Needs_Sec_Stack_Mark;
3716
3717       HSS : Node_Id := Handled_Statement_Sequence (N);
3718       Loc : Source_Ptr;
3719
3720       procedure Wrap_HSS_In_Block;
3721       --  Move HSS inside a new block along with the original exception
3722       --  handlers. Make the newly generated block the sole statement of HSS.
3723
3724       -----------------------
3725       -- Wrap_HSS_In_Block --
3726       -----------------------
3727
3728       procedure Wrap_HSS_In_Block is
3729          Block   : Node_Id;
3730          End_Lab : Node_Id;
3731
3732       begin
3733          --  Preserve end label to provide proper cross-reference information
3734
3735          End_Lab := End_Label (HSS);
3736          Block :=
3737            Make_Block_Statement (Loc,
3738              Handled_Statement_Sequence => HSS);
3739
3740          --  Signal the finalization machinery that this particular block
3741          --  contains the original context.
3742
3743          Set_Is_Finalization_Wrapper (Block);
3744
3745          Set_Handled_Statement_Sequence (N,
3746            Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
3747          HSS := Handled_Statement_Sequence (N);
3748
3749          Set_First_Real_Statement (HSS, Block);
3750          Set_End_Label (HSS, End_Lab);
3751
3752          --  Comment needed here, see RH for 1.306 ???
3753
3754          if Nkind (N) = N_Subprogram_Body then
3755             Set_Has_Nested_Block_With_Handler (Scop);
3756          end if;
3757       end Wrap_HSS_In_Block;
3758
3759    --  Start of processing for Expand_Cleanup_Actions
3760
3761    begin
3762       --  The current construct does not need any form of servicing
3763
3764       if not Actions_Required then
3765          return;
3766
3767       --  If the current node is a rewritten task body and the descriptors have
3768       --  not been delayed (due to some nested instantiations), do not generate
3769       --  redundant cleanup actions.
3770
3771       elsif Is_Task_Body
3772         and then Nkind (N) = N_Subprogram_Body
3773         and then not Delay_Subprogram_Descriptors (Corresponding_Spec (N))
3774       then
3775          return;
3776       end if;
3777
3778       declare
3779          Decls     : List_Id := Declarations (N);
3780          Fin_Id    : Entity_Id;
3781          Mark      : Entity_Id := Empty;
3782          New_Decls : List_Id;
3783          Old_Poll  : Boolean;
3784
3785       begin
3786          --  If we are generating expanded code for debugging purposes, use the
3787          --  Sloc of the point of insertion for the cleanup code. The Sloc will
3788          --  be updated subsequently to reference the proper line in .dg files.
3789          --  If we are not debugging generated code, use No_Location instead,
3790          --  so that no debug information is generated for the cleanup code.
3791          --  This makes the behavior of the NEXT command in GDB monotonic, and
3792          --  makes the placement of breakpoints more accurate.
3793
3794          if Debug_Generated_Code then
3795             Loc := Sloc (Scop);
3796          else
3797             Loc := No_Location;
3798          end if;
3799
3800          --  Set polling off. The finalization and cleanup code is executed
3801          --  with aborts deferred.
3802
3803          Old_Poll := Polling_Required;
3804          Polling_Required := False;
3805
3806          --  A task activation call has already been built for a task
3807          --  allocation block.
3808
3809          if not Is_Task_Allocation then
3810             Build_Task_Activation_Call (N);
3811          end if;
3812
3813          if Is_Master then
3814             Establish_Task_Master (N);
3815          end if;
3816
3817          New_Decls := New_List;
3818
3819          --  If secondary stack is in use, generate:
3820          --
3821          --    Mnn : constant Mark_Id := SS_Mark;
3822
3823          --  Suppress calls to SS_Mark and SS_Release if VM_Target, since the
3824          --  secondary stack is never used on a VM.
3825
3826          if Needs_Sec_Stack_Mark then
3827             Mark := Make_Temporary (Loc, 'M');
3828
3829             Append_To (New_Decls,
3830               Make_Object_Declaration (Loc,
3831                 Defining_Identifier => Mark,
3832                 Object_Definition   =>
3833                   New_Reference_To (RTE (RE_Mark_Id), Loc),
3834                 Expression          =>
3835                   Make_Function_Call (Loc,
3836                     Name => New_Reference_To (RTE (RE_SS_Mark), Loc))));
3837
3838             Set_Uses_Sec_Stack (Scop, False);
3839          end if;
3840
3841          --  If exception handlers are present, wrap the sequence of statements
3842          --  in a block since it is not possible to have exception handlers and
3843          --  an At_End handler in the same construct.
3844
3845          if Present (Exception_Handlers (HSS)) then
3846             Wrap_HSS_In_Block;
3847
3848          --  Ensure that the First_Real_Statement field is set
3849
3850          elsif No (First_Real_Statement (HSS)) then
3851             Set_First_Real_Statement (HSS, First (Statements (HSS)));
3852          end if;
3853
3854          --  Do not move the Activation_Chain declaration in the context of
3855          --  task allocation blocks. Task allocation blocks use _chain in their
3856          --  cleanup handlers and gigi complains if it is declared in the
3857          --  sequence of statements of the scope that declares the handler.
3858
3859          if Is_Task_Allocation then
3860             declare
3861                Chain : constant Entity_Id := Activation_Chain_Entity (N);
3862                Decl  : Node_Id;
3863
3864             begin
3865                Decl := First (Decls);
3866                while Nkind (Decl) /= N_Object_Declaration
3867                  or else Defining_Identifier (Decl) /= Chain
3868                loop
3869                   Next (Decl);
3870
3871                   --  A task allocation block should always include a _chain
3872                   --  declaration.
3873
3874                   pragma Assert (Present (Decl));
3875                end loop;
3876
3877                Remove (Decl);
3878                Prepend_To (New_Decls, Decl);
3879             end;
3880          end if;
3881
3882          --  Ensure the presence of a declaration list in order to successfully
3883          --  append all original statements to it.
3884
3885          if No (Decls) then
3886             Set_Declarations (N, New_List);
3887             Decls := Declarations (N);
3888          end if;
3889
3890          --  Move the declarations into the sequence of statements in order to
3891          --  have them protected by the At_End handler. It may seem weird to
3892          --  put declarations in the sequence of statement but in fact nothing
3893          --  forbids that at the tree level.
3894
3895          Append_List_To (Decls, Statements (HSS));
3896          Set_Statements (HSS, Decls);
3897
3898          --  Reset the Sloc of the handled statement sequence to properly
3899          --  reflect the new initial "statement" in the sequence.
3900
3901          Set_Sloc (HSS, Sloc (First (Decls)));
3902
3903          --  The declarations of finalizer spec and auxiliary variables replace
3904          --  the old declarations that have been moved inward.
3905
3906          Set_Declarations (N, New_Decls);
3907          Analyze_Declarations (New_Decls);
3908
3909          --  Generate finalization calls for all controlled objects appearing
3910          --  in the statements of N. Add context specific cleanup for various
3911          --  constructs.
3912
3913          Build_Finalizer
3914            (N           => N,
3915             Clean_Stmts => Build_Cleanup_Statements (N),
3916             Mark_Id     => Mark,
3917             Top_Decls   => New_Decls,
3918             Defer_Abort => Nkind (Original_Node (N)) = N_Task_Body
3919                              or else Is_Master,
3920             Fin_Id      => Fin_Id);
3921
3922          if Present (Fin_Id) then
3923             Build_Finalizer_Call (N, Fin_Id);
3924          end if;
3925
3926          --  Restore saved polling mode
3927
3928          Polling_Required := Old_Poll;
3929       end;
3930    end Expand_Cleanup_Actions;
3931
3932    ---------------------------
3933    -- Expand_N_Package_Body --
3934    ---------------------------
3935
3936    --  Add call to Activate_Tasks if body is an activator (actual processing
3937    --  is in chapter 9).
3938
3939    --  Generate subprogram descriptor for elaboration routine
3940
3941    --  Encode entity names in package body
3942
3943    procedure Expand_N_Package_Body (N : Node_Id) is
3944       Spec_Ent : constant Entity_Id := Corresponding_Spec (N);
3945       Fin_Id   : Entity_Id;
3946
3947    begin
3948       --  This is done only for non-generic packages
3949
3950       if Ekind (Spec_Ent) = E_Package then
3951          Push_Scope (Corresponding_Spec (N));
3952
3953          --  Build dispatch tables of library level tagged types
3954
3955          if Tagged_Type_Expansion
3956            and then Is_Library_Level_Entity (Spec_Ent)
3957          then
3958             Build_Static_Dispatch_Tables (N);
3959          end if;
3960
3961          Build_Task_Activation_Call (N);
3962          Pop_Scope;
3963       end if;
3964
3965       Set_Elaboration_Flag (N, Corresponding_Spec (N));
3966       Set_In_Package_Body (Spec_Ent, False);
3967
3968       --  Set to encode entity names in package body before gigi is called
3969
3970       Qualify_Entity_Names (N);
3971
3972       if Ekind (Spec_Ent) /= E_Generic_Package then
3973          Build_Finalizer
3974            (N           => N,
3975             Clean_Stmts => No_List,
3976             Mark_Id     => Empty,
3977             Top_Decls   => No_List,
3978             Defer_Abort => False,
3979             Fin_Id      => Fin_Id);
3980
3981          if Present (Fin_Id) then
3982             declare
3983                Body_Ent : Node_Id := Defining_Unit_Name (N);
3984
3985             begin
3986                if Nkind (Body_Ent) = N_Defining_Program_Unit_Name then
3987                   Body_Ent := Defining_Identifier (Body_Ent);
3988                end if;
3989
3990                Set_Finalizer (Body_Ent, Fin_Id);
3991             end;
3992          end if;
3993       end if;
3994    end Expand_N_Package_Body;
3995
3996    ----------------------------------
3997    -- Expand_N_Package_Declaration --
3998    ----------------------------------
3999
4000    --  Add call to Activate_Tasks if there are tasks declared and the package
4001    --  has no body. Note that in Ada 83 this may result in premature activation
4002    --  of some tasks, given that we cannot tell whether a body will eventually
4003    --  appear.
4004
4005    procedure Expand_N_Package_Declaration (N : Node_Id) is
4006       Id     : constant Entity_Id := Defining_Entity (N);
4007       Spec   : constant Node_Id   := Specification (N);
4008       Decls  : List_Id;
4009       Fin_Id : Entity_Id;
4010
4011       No_Body : Boolean := False;
4012       --  True in the case of a package declaration that is a compilation
4013       --  unit and for which no associated body will be compiled in this
4014       --  compilation.
4015
4016    begin
4017       --  Case of a package declaration other than a compilation unit
4018
4019       if Nkind (Parent (N)) /= N_Compilation_Unit then
4020          null;
4021
4022       --  Case of a compilation unit that does not require a body
4023
4024       elsif not Body_Required (Parent (N))
4025         and then not Unit_Requires_Body (Id)
4026       then
4027          No_Body := True;
4028
4029       --  Special case of generating calling stubs for a remote call interface
4030       --  package: even though the package declaration requires one, the body
4031       --  won't be processed in this compilation (so any stubs for RACWs
4032       --  declared in the package must be generated here, along with the spec).
4033
4034       elsif Parent (N) = Cunit (Main_Unit)
4035         and then Is_Remote_Call_Interface (Id)
4036         and then Distribution_Stub_Mode = Generate_Caller_Stub_Body
4037       then
4038          No_Body := True;
4039       end if;
4040
4041       --  For a nested instance, delay processing until freeze point
4042
4043       if Has_Delayed_Freeze (Id)
4044         and then Nkind (Parent (N)) /= N_Compilation_Unit
4045       then
4046          return;
4047       end if;
4048
4049       --  For a package declaration that implies no associated body, generate
4050       --  task activation call and RACW supporting bodies now (since we won't
4051       --  have a specific separate compilation unit for that).
4052
4053       if No_Body then
4054          Push_Scope (Id);
4055
4056          if Has_RACW (Id) then
4057
4058             --  Generate RACW subprogram bodies
4059
4060             Decls := Private_Declarations (Spec);
4061
4062             if No (Decls) then
4063                Decls := Visible_Declarations (Spec);
4064             end if;
4065
4066             if No (Decls) then
4067                Decls := New_List;
4068                Set_Visible_Declarations (Spec, Decls);
4069             end if;
4070
4071             Append_RACW_Bodies (Decls, Id);
4072             Analyze_List (Decls);
4073          end if;
4074
4075          if Present (Activation_Chain_Entity (N)) then
4076
4077             --  Generate task activation call as last step of elaboration
4078
4079             Build_Task_Activation_Call (N);
4080          end if;
4081
4082          Pop_Scope;
4083       end if;
4084
4085       --  Build dispatch tables of library level tagged types
4086
4087       if Tagged_Type_Expansion
4088         and then (Is_Compilation_Unit (Id)
4089                    or else (Is_Generic_Instance (Id)
4090                              and then Is_Library_Level_Entity (Id)))
4091       then
4092          Build_Static_Dispatch_Tables (N);
4093       end if;
4094
4095       --  Note: it is not necessary to worry about generating a subprogram
4096       --  descriptor, since the only way to get exception handlers into a
4097       --  package spec is to include instantiations, and that would cause
4098       --  generation of subprogram descriptors to be delayed in any case.
4099
4100       --  Set to encode entity names in package spec before gigi is called
4101
4102       Qualify_Entity_Names (N);
4103
4104       if Ekind (Id) /= E_Generic_Package then
4105          Build_Finalizer
4106            (N           => N,
4107             Clean_Stmts => No_List,
4108             Mark_Id     => Empty,
4109             Top_Decls   => No_List,
4110             Defer_Abort => False,
4111             Fin_Id      => Fin_Id);
4112
4113          Set_Finalizer (Id, Fin_Id);
4114       end if;
4115    end Expand_N_Package_Declaration;
4116
4117    -----------------------------
4118    -- Find_Node_To_Be_Wrapped --
4119    -----------------------------
4120
4121    function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id is
4122       P          : Node_Id;
4123       The_Parent : Node_Id;
4124
4125    begin
4126       The_Parent := N;
4127       loop
4128          P := The_Parent;
4129          pragma Assert (P /= Empty);
4130          The_Parent := Parent (P);
4131
4132          case Nkind (The_Parent) is
4133
4134             --  Simple statement can be wrapped
4135
4136             when N_Pragma =>
4137                return The_Parent;
4138
4139             --  Usually assignments are good candidate for wrapping except
4140             --  when they have been generated as part of a controlled aggregate
4141             --  where the wrapping should take place more globally.
4142
4143             when N_Assignment_Statement =>
4144                if No_Ctrl_Actions (The_Parent) then
4145                   null;
4146                else
4147                   return The_Parent;
4148                end if;
4149
4150             --  An entry call statement is a special case if it occurs in the
4151             --  context of a Timed_Entry_Call. In this case we wrap the entire
4152             --  timed entry call.
4153
4154             when N_Entry_Call_Statement     |
4155                  N_Procedure_Call_Statement =>
4156                if Nkind (Parent (The_Parent)) = N_Entry_Call_Alternative
4157                  and then Nkind_In (Parent (Parent (The_Parent)),
4158                                     N_Timed_Entry_Call,
4159                                     N_Conditional_Entry_Call)
4160                then
4161                   return Parent (Parent (The_Parent));
4162                else
4163                   return The_Parent;
4164                end if;
4165
4166             --  Object declarations are also a boundary for the transient scope
4167             --  even if they are not really wrapped. For further details, see
4168             --  Wrap_Transient_Declaration.
4169
4170             when N_Object_Declaration          |
4171                  N_Object_Renaming_Declaration |
4172                  N_Subtype_Declaration         =>
4173                return The_Parent;
4174
4175             --  The expression itself is to be wrapped if its parent is a
4176             --  compound statement or any other statement where the expression
4177             --  is known to be scalar
4178
4179             when N_Accept_Alternative               |
4180                  N_Attribute_Definition_Clause      |
4181                  N_Case_Statement                   |
4182                  N_Code_Statement                   |
4183                  N_Delay_Alternative                |
4184                  N_Delay_Until_Statement            |
4185                  N_Delay_Relative_Statement         |
4186                  N_Discriminant_Association         |
4187                  N_Elsif_Part                       |
4188                  N_Entry_Body_Formal_Part           |
4189                  N_Exit_Statement                   |
4190                  N_If_Statement                     |
4191                  N_Iteration_Scheme                 |
4192                  N_Terminate_Alternative            =>
4193                return P;
4194
4195             when N_Attribute_Reference =>
4196
4197                if Is_Procedure_Attribute_Name
4198                     (Attribute_Name (The_Parent))
4199                then
4200                   return The_Parent;
4201                end if;
4202
4203             --  A raise statement can be wrapped. This will arise when the
4204             --  expression in a raise_with_expression uses the secondary
4205             --  stack, for example.
4206
4207             when N_Raise_Statement =>
4208                return The_Parent;
4209
4210             --  If the expression is within the iteration scheme of a loop,
4211             --  we must create a declaration for it, followed by an assignment
4212             --  in order to have a usable statement to wrap.
4213
4214             when N_Loop_Parameter_Specification =>
4215                return Parent (The_Parent);
4216
4217             --  The following nodes contains "dummy calls" which don't need to
4218             --  be wrapped.
4219
4220             when N_Parameter_Specification     |
4221                  N_Discriminant_Specification  |
4222                  N_Component_Declaration       =>
4223                return Empty;
4224
4225             --  The return statement is not to be wrapped when the function
4226             --  itself needs wrapping at the outer-level
4227
4228             when N_Simple_Return_Statement =>
4229                declare
4230                   Applies_To : constant Entity_Id :=
4231                                  Return_Applies_To
4232                                    (Return_Statement_Entity (The_Parent));
4233                   Return_Type : constant Entity_Id := Etype (Applies_To);
4234                begin
4235                   if Requires_Transient_Scope (Return_Type) then
4236                      return Empty;
4237                   else
4238                      return The_Parent;
4239                   end if;
4240                end;
4241
4242             --  If we leave a scope without having been able to find a node to
4243             --  wrap, something is going wrong but this can happen in error
4244             --  situation that are not detected yet (such as a dynamic string
4245             --  in a pragma export)
4246
4247             when N_Subprogram_Body     |
4248                  N_Package_Declaration |
4249                  N_Package_Body        |
4250                  N_Block_Statement     =>
4251                return Empty;
4252
4253             --  Otherwise continue the search
4254
4255             when others =>
4256                null;
4257          end case;
4258       end loop;
4259    end Find_Node_To_Be_Wrapped;
4260
4261    -------------------------------------
4262    -- Get_Global_Pool_For_Access_Type --
4263    -------------------------------------
4264
4265    function Get_Global_Pool_For_Access_Type (T : Entity_Id) return Entity_Id is
4266    begin
4267       --  Access types whose size is smaller than System.Address size can exist
4268       --  only on VMS. We can't use the usual global pool which returns an
4269       --  object of type Address as truncation will make it invalid. To handle
4270       --  this case, VMS has a dedicated global pool that returns addresses
4271       --  that fit into 32 bit accesses.
4272
4273       if Opt.True_VMS_Target and then Esize (T) = 32 then
4274          return RTE (RE_Global_Pool_32_Object);
4275       else
4276          return RTE (RE_Global_Pool_Object);
4277       end if;
4278    end Get_Global_Pool_For_Access_Type;
4279
4280    ----------------------------------
4281    -- Has_New_Controlled_Component --
4282    ----------------------------------
4283
4284    function Has_New_Controlled_Component (E : Entity_Id) return Boolean is
4285       Comp : Entity_Id;
4286
4287    begin
4288       if not Is_Tagged_Type (E) then
4289          return Has_Controlled_Component (E);
4290       elsif not Is_Derived_Type (E) then
4291          return Has_Controlled_Component (E);
4292       end if;
4293
4294       Comp := First_Component (E);
4295       while Present (Comp) loop
4296          if Chars (Comp) = Name_uParent then
4297             null;
4298
4299          elsif Scope (Original_Record_Component (Comp)) = E
4300            and then Needs_Finalization (Etype (Comp))
4301          then
4302             return True;
4303          end if;
4304
4305          Next_Component (Comp);
4306       end loop;
4307
4308       return False;
4309    end Has_New_Controlled_Component;
4310
4311    ---------------------------------
4312    -- Has_Simple_Protected_Object --
4313    ---------------------------------
4314
4315    function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is
4316    begin
4317       if Has_Task (T) then
4318          return False;
4319
4320       elsif Is_Simple_Protected_Type (T) then
4321          return True;
4322
4323       elsif Is_Array_Type (T) then
4324          return Has_Simple_Protected_Object (Component_Type (T));
4325
4326       elsif Is_Record_Type (T) then
4327          declare
4328             Comp : Entity_Id;
4329
4330          begin
4331             Comp := First_Component (T);
4332             while Present (Comp) loop
4333                if Has_Simple_Protected_Object (Etype (Comp)) then
4334                   return True;
4335                end if;
4336
4337                Next_Component (Comp);
4338             end loop;
4339
4340             return False;
4341          end;
4342
4343       else
4344          return False;
4345       end if;
4346    end Has_Simple_Protected_Object;
4347
4348    ------------------------------------
4349    -- Insert_Actions_In_Scope_Around --
4350    ------------------------------------
4351
4352    procedure Insert_Actions_In_Scope_Around (N : Node_Id) is
4353       After  : constant List_Id :=
4354         Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped_After;
4355       Before : constant List_Id :=
4356         Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped_Before;
4357       --  Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
4358       --  Last), but this was incorrect as Process_Transient_Object may
4359       --  introduce new scopes and cause a reallocation of Scope_Stack.Table.
4360
4361       procedure Process_Transient_Objects
4362         (First_Object : Node_Id;
4363          Last_Object  : Node_Id;
4364          Related_Node : Node_Id);
4365       --  First_Object and Last_Object define a list which contains potential
4366       --  controlled transient objects. Finalization flags are inserted before
4367       --  First_Object and finalization calls are inserted after Last_Object.
4368       --  Related_Node is the node for which transient objects have been
4369       --  created.
4370
4371       -------------------------------
4372       -- Process_Transient_Objects --
4373       -------------------------------
4374
4375       procedure Process_Transient_Objects
4376         (First_Object : Node_Id;
4377          Last_Object  : Node_Id;
4378          Related_Node : Node_Id)
4379       is
4380          function Requires_Hooking return Boolean;
4381          --  Determine whether the context requires transient variable export
4382          --  to the outer finalizer. This scenario arises when the context may
4383          --  raise an exception.
4384
4385          ----------------------
4386          -- Requires_Hooking --
4387          ----------------------
4388
4389          function Requires_Hooking return Boolean is
4390          begin
4391             --  The context is either a procedure or function call or an object
4392             --  declaration initialized by a function call. Note that in the
4393             --  latter case, a function call that returns on the secondary
4394             --  stack is usually rewritten into something else. Its proper
4395             --  detection requires examination of the original initialization
4396             --  expression.
4397
4398             return Nkind (N) in N_Subprogram_Call
4399               or else (Nkind (N) = N_Object_Declaration
4400                          and then Nkind (Original_Node (Expression (N))) =
4401                                     N_Function_Call);
4402          end Requires_Hooking;
4403
4404          --  Local variables
4405
4406          Must_Hook : constant Boolean := Requires_Hooking;
4407          Built     : Boolean := False;
4408          Desig_Typ : Entity_Id;
4409          Fin_Block : Node_Id;
4410          Fin_Data  : Finalization_Exception_Data;
4411          Fin_Decls : List_Id;
4412          Last_Fin  : Node_Id := Empty;
4413          Loc       : Source_Ptr;
4414          Obj_Id    : Entity_Id;
4415          Obj_Ref   : Node_Id;
4416          Obj_Typ   : Entity_Id;
4417          Prev_Fin  : Node_Id := Empty;
4418          Stmt      : Node_Id;
4419          Stmts     : List_Id;
4420          Temp_Id   : Entity_Id;
4421
4422       --  Start of processing for Process_Transient_Objects
4423
4424       begin
4425          --  Examine all objects in the list First_Object .. Last_Object
4426
4427          Stmt := First_Object;
4428          while Present (Stmt) loop
4429             if Nkind (Stmt) = N_Object_Declaration
4430               and then Analyzed (Stmt)
4431               and then Is_Finalizable_Transient (Stmt, N)
4432
4433               --  Do not process the node to be wrapped since it will be
4434               --  handled by the enclosing finalizer.
4435
4436               and then Stmt /= Related_Node
4437             then
4438                Loc       := Sloc (Stmt);
4439                Obj_Id    := Defining_Identifier (Stmt);
4440                Obj_Typ   := Base_Type (Etype (Obj_Id));
4441                Desig_Typ := Obj_Typ;
4442
4443                Set_Is_Processed_Transient (Obj_Id);
4444
4445                --  Handle access types
4446
4447                if Is_Access_Type (Desig_Typ) then
4448                   Desig_Typ := Available_View (Designated_Type (Desig_Typ));
4449                end if;
4450
4451                --  Create the necessary entities and declarations the first
4452                --  time around.
4453
4454                if not Built then
4455                   Fin_Decls := New_List;
4456
4457                   Build_Object_Declarations (Fin_Data, Fin_Decls, Loc);
4458
4459                   Built := True;
4460                end if;
4461
4462                --  Transient variables associated with subprogram calls need
4463                --  extra processing. These variables are usually created right
4464                --  before the call and finalized immediately after the call.
4465                --  If an exception occurs during the call, the clean up code
4466                --  is skipped due to the sudden change in control and the
4467                --  transient is never finalized.
4468
4469                --  To handle this case, such variables are "exported" to the
4470                --  enclosing sequence of statements where their corresponding
4471                --  "hooks" are picked up by the finalization machinery.
4472
4473                if Must_Hook then
4474                   declare
4475                      Expr   : Node_Id;
4476                      Ptr_Id : Entity_Id;
4477
4478                   begin
4479                      --  Step 1: Create an access type which provides a
4480                      --  reference to the transient object. Generate:
4481
4482                      --    Ann : access [all] <Desig_Typ>;
4483
4484                      Ptr_Id := Make_Temporary (Loc, 'A');
4485
4486                      Insert_Action (Stmt,
4487                        Make_Full_Type_Declaration (Loc,
4488                          Defining_Identifier => Ptr_Id,
4489                          Type_Definition     =>
4490                            Make_Access_To_Object_Definition (Loc,
4491                              All_Present        =>
4492                                Ekind (Obj_Typ) = E_General_Access_Type,
4493                              Subtype_Indication =>
4494                                New_Reference_To (Desig_Typ, Loc))));
4495
4496                      --  Step 2: Create a temporary which acts as a hook to
4497                      --  the transient object. Generate:
4498
4499                      --    Temp : Ptr_Id := null;
4500
4501                      Temp_Id := Make_Temporary (Loc, 'T');
4502
4503                      Insert_Action (Stmt,
4504                        Make_Object_Declaration (Loc,
4505                          Defining_Identifier => Temp_Id,
4506                          Object_Definition   =>
4507                            New_Reference_To (Ptr_Id, Loc)));
4508
4509                      --  Mark the temporary as a transient hook. This signals
4510                      --  the machinery in Build_Finalizer to recognize this
4511                      --  special case.
4512
4513                      Set_Status_Flag_Or_Transient_Decl (Temp_Id, Stmt);
4514
4515                      --  Step 3: Hook the transient object to the temporary
4516
4517                      if Is_Access_Type (Obj_Typ) then
4518                         Expr :=
4519                           Convert_To (Ptr_Id, New_Reference_To (Obj_Id, Loc));
4520                      else
4521                         Expr :=
4522                           Make_Attribute_Reference (Loc,
4523                             Prefix         => New_Reference_To (Obj_Id, Loc),
4524                             Attribute_Name => Name_Unrestricted_Access);
4525                      end if;
4526
4527                      --  Generate:
4528                      --    Temp := Ptr_Id (Obj_Id);
4529                      --      <or>
4530                      --    Temp := Obj_Id'Unrestricted_Access;
4531
4532                      Insert_After_And_Analyze (Stmt,
4533                        Make_Assignment_Statement (Loc,
4534                          Name       => New_Reference_To (Temp_Id, Loc),
4535                          Expression => Expr));
4536                   end;
4537                end if;
4538
4539                Stmts := New_List;
4540
4541                --  The transient object is about to be finalized by the clean
4542                --  up code following the subprogram call. In order to avoid
4543                --  double finalization, clear the hook.
4544
4545                --  Generate:
4546                --    Temp := null;
4547
4548                if Must_Hook then
4549                   Append_To (Stmts,
4550                     Make_Assignment_Statement (Loc,
4551                       Name       => New_Reference_To (Temp_Id, Loc),
4552                       Expression => Make_Null (Loc)));
4553                end if;
4554
4555                --  Generate:
4556                --    [Deep_]Finalize (Obj_Ref);
4557
4558                Obj_Ref := New_Reference_To (Obj_Id, Loc);
4559
4560                if Is_Access_Type (Obj_Typ) then
4561                   Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
4562                end if;
4563
4564                Append_To (Stmts,
4565                  Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Desig_Typ));
4566
4567                --  Generate:
4568                --    [Temp := null;]
4569                --    begin
4570                --       [Deep_]Finalize (Obj_Ref);
4571
4572                --    exception
4573                --       when others =>
4574                --          if not Raised then
4575                --             Raised := True;
4576                --             Save_Occurrence
4577                --               (Enn, Get_Current_Excep.all.all);
4578                --          end if;
4579                --    end;
4580
4581                Fin_Block :=
4582                  Make_Block_Statement (Loc,
4583                    Handled_Statement_Sequence =>
4584                      Make_Handled_Sequence_Of_Statements (Loc,
4585                        Statements => Stmts,
4586                        Exception_Handlers => New_List (
4587                          Build_Exception_Handler (Fin_Data))));
4588
4589                --  The single raise statement must be inserted after all the
4590                --  finalization blocks, and we put everything into a wrapper
4591                --  block to clearly expose the construct to the back-end.
4592
4593                if Present (Prev_Fin) then
4594                   Insert_Before_And_Analyze (Prev_Fin, Fin_Block);
4595                else
4596                   Insert_After_And_Analyze (Last_Object,
4597                     Make_Block_Statement (Loc,
4598                       Declarations => Fin_Decls,
4599                       Handled_Statement_Sequence =>
4600                         Make_Handled_Sequence_Of_Statements (Loc,
4601                           Statements => New_List (Fin_Block))));
4602
4603                   Last_Fin := Fin_Block;
4604                end if;
4605
4606                Prev_Fin := Fin_Block;
4607             end if;
4608
4609             --  Terminate the scan after the last object has been processed to
4610             --  avoid touching unrelated code.
4611
4612             if Stmt = Last_Object then
4613                exit;
4614             end if;
4615
4616             Next (Stmt);
4617          end loop;
4618
4619          --  Generate:
4620          --    if Raised and then not Abort then
4621          --       Raise_From_Controlled_Operation (E);
4622          --    end if;
4623
4624          if Built
4625            and then Present (Last_Fin)
4626          then
4627             Insert_After_And_Analyze (Last_Fin,
4628               Build_Raise_Statement (Fin_Data));
4629          end if;
4630       end Process_Transient_Objects;
4631
4632    --  Start of processing for Insert_Actions_In_Scope_Around
4633
4634    begin
4635       if No (Before) and then No (After) then
4636          return;
4637       end if;
4638
4639       declare
4640          Node_To_Wrap : constant Node_Id := Node_To_Be_Wrapped;
4641          First_Obj    : Node_Id;
4642          Last_Obj     : Node_Id;
4643          Target       : Node_Id;
4644
4645       begin
4646          --  If the node to be wrapped is the trigger of an asynchronous
4647          --  select, it is not part of a statement list. The actions must be
4648          --  inserted before the select itself, which is part of some list of
4649          --  statements. Note that the triggering alternative includes the
4650          --  triggering statement and an optional statement list. If the node
4651          --  to be wrapped is part of that list, the normal insertion applies.
4652
4653          if Nkind (Parent (Node_To_Wrap)) = N_Triggering_Alternative
4654            and then not Is_List_Member (Node_To_Wrap)
4655          then
4656             Target := Parent (Parent (Node_To_Wrap));
4657          else
4658             Target := N;
4659          end if;
4660
4661          First_Obj := Target;
4662          Last_Obj  := Target;
4663
4664          --  Add all actions associated with a transient scope into the main
4665          --  tree. There are several scenarios here:
4666
4667          --       +--- Before ----+        +----- After ---+
4668          --    1) First_Obj ....... Target ........ Last_Obj
4669
4670          --    2) First_Obj ....... Target
4671
4672          --    3)                   Target ........ Last_Obj
4673
4674          if Present (Before) then
4675
4676             --  Flag declarations are inserted before the first object
4677
4678             First_Obj := First (Before);
4679
4680             Insert_List_Before (Target, Before);
4681          end if;
4682
4683          if Present (After) then
4684
4685             --  Finalization calls are inserted after the last object
4686
4687             Last_Obj := Last (After);
4688
4689             Insert_List_After (Target, After);
4690          end if;
4691
4692          --  Check for transient controlled objects associated with Target and
4693          --  generate the appropriate finalization actions for them.
4694
4695          Process_Transient_Objects
4696            (First_Object => First_Obj,
4697             Last_Object  => Last_Obj,
4698             Related_Node => Target);
4699
4700          --  Reset the action lists
4701
4702          if Present (Before) then
4703             Scope_Stack.Table (Scope_Stack.Last).
4704               Actions_To_Be_Wrapped_Before := No_List;
4705          end if;
4706
4707          if Present (After) then
4708             Scope_Stack.Table (Scope_Stack.Last).
4709               Actions_To_Be_Wrapped_After := No_List;
4710          end if;
4711       end;
4712    end Insert_Actions_In_Scope_Around;
4713
4714    ------------------------------
4715    -- Is_Simple_Protected_Type --
4716    ------------------------------
4717
4718    function Is_Simple_Protected_Type (T : Entity_Id) return Boolean is
4719    begin
4720       return
4721         Is_Protected_Type (T)
4722           and then not Uses_Lock_Free (T)
4723           and then not Has_Entries (T)
4724           and then Is_RTE (Find_Protection_Type (T), RE_Protection);
4725    end Is_Simple_Protected_Type;
4726
4727    -----------------------
4728    -- Make_Adjust_Call --
4729    -----------------------
4730
4731    function Make_Adjust_Call
4732      (Obj_Ref    : Node_Id;
4733       Typ        : Entity_Id;
4734       For_Parent : Boolean := False) return Node_Id
4735    is
4736       Loc    : constant Source_Ptr := Sloc (Obj_Ref);
4737       Adj_Id : Entity_Id := Empty;
4738       Ref    : Node_Id   := Obj_Ref;
4739       Utyp   : Entity_Id;
4740
4741    begin
4742       --  Recover the proper type which contains Deep_Adjust
4743
4744       if Is_Class_Wide_Type (Typ) then
4745          Utyp := Root_Type (Typ);
4746       else
4747          Utyp := Typ;
4748       end if;
4749
4750       Utyp := Underlying_Type (Base_Type (Utyp));
4751       Set_Assignment_OK (Ref);
4752
4753       --  Deal with non-tagged derivation of private views
4754
4755       if Is_Untagged_Derivation (Typ) then
4756          Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
4757          Ref  := Unchecked_Convert_To (Utyp, Ref);
4758          Set_Assignment_OK (Ref);
4759       end if;
4760
4761       --  When dealing with the completion of a private type, use the base
4762       --  type instead.
4763
4764       if Utyp /= Base_Type (Utyp) then
4765          pragma Assert (Is_Private_Type (Typ));
4766
4767          Utyp := Base_Type (Utyp);
4768          Ref  := Unchecked_Convert_To (Utyp, Ref);
4769       end if;
4770
4771       --  Select the appropriate version of adjust
4772
4773       if For_Parent then
4774          if Has_Controlled_Component (Utyp) then
4775             Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
4776          end if;
4777
4778       --  Class-wide types, interfaces and types with controlled components
4779
4780       elsif Is_Class_Wide_Type (Typ)
4781         or else Is_Interface (Typ)
4782         or else Has_Controlled_Component (Utyp)
4783       then
4784          if Is_Tagged_Type (Utyp) then
4785             Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
4786          else
4787             Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
4788          end if;
4789
4790       --  Derivations from [Limited_]Controlled
4791
4792       elsif Is_Controlled (Utyp) then
4793          if Has_Controlled_Component (Utyp) then
4794             Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
4795          else
4796             Adj_Id := Find_Prim_Op (Utyp, Name_Of (Adjust_Case));
4797          end if;
4798
4799       --  Tagged types
4800
4801       elsif Is_Tagged_Type (Utyp) then
4802          Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
4803
4804       else
4805          raise Program_Error;
4806       end if;
4807
4808       if Present (Adj_Id) then
4809
4810          --  If the object is unanalyzed, set its expected type for use in
4811          --  Convert_View in case an additional conversion is needed.
4812
4813          if No (Etype (Ref))
4814            and then Nkind (Ref) /= N_Unchecked_Type_Conversion
4815          then
4816             Set_Etype (Ref, Typ);
4817          end if;
4818
4819          --  The object reference may need another conversion depending on the
4820          --  type of the formal and that of the actual.
4821
4822          if not Is_Class_Wide_Type (Typ) then
4823             Ref := Convert_View (Adj_Id, Ref);
4824          end if;
4825
4826          return Make_Call (Loc, Adj_Id, New_Copy_Tree (Ref), For_Parent);
4827       else
4828          return Empty;
4829       end if;
4830    end Make_Adjust_Call;
4831
4832    ----------------------
4833    -- Make_Attach_Call --
4834    ----------------------
4835
4836    function Make_Attach_Call
4837      (Obj_Ref : Node_Id;
4838       Ptr_Typ : Entity_Id) return Node_Id
4839    is
4840       pragma Assert (VM_Target /= No_VM);
4841
4842       Loc : constant Source_Ptr := Sloc (Obj_Ref);
4843    begin
4844       return
4845         Make_Procedure_Call_Statement (Loc,
4846           Name                   =>
4847             New_Reference_To (RTE (RE_Attach), Loc),
4848           Parameter_Associations => New_List (
4849             New_Reference_To (Finalization_Master (Ptr_Typ), Loc),
4850             Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref)));
4851    end Make_Attach_Call;
4852
4853    ----------------------
4854    -- Make_Detach_Call --
4855    ----------------------
4856
4857    function Make_Detach_Call (Obj_Ref : Node_Id) return Node_Id is
4858       Loc : constant Source_Ptr := Sloc (Obj_Ref);
4859
4860    begin
4861       return
4862         Make_Procedure_Call_Statement (Loc,
4863           Name                   =>
4864             New_Reference_To (RTE (RE_Detach), Loc),
4865           Parameter_Associations => New_List (
4866             Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref)));
4867    end Make_Detach_Call;
4868
4869    ---------------
4870    -- Make_Call --
4871    ---------------
4872
4873    function Make_Call
4874      (Loc        : Source_Ptr;
4875       Proc_Id    : Entity_Id;
4876       Param      : Node_Id;
4877       For_Parent : Boolean := False) return Node_Id
4878    is
4879       Params : constant List_Id := New_List (Param);
4880
4881    begin
4882       --  When creating a call to Deep_Finalize for a _parent field of a
4883       --  derived type, disable the invocation of the nested Finalize by giving
4884       --  the corresponding flag a False value.
4885
4886       if For_Parent then
4887          Append_To (Params, New_Reference_To (Standard_False, Loc));
4888       end if;
4889
4890       return
4891         Make_Procedure_Call_Statement (Loc,
4892           Name                   => New_Reference_To (Proc_Id, Loc),
4893           Parameter_Associations => Params);
4894    end Make_Call;
4895
4896    --------------------------
4897    -- Make_Deep_Array_Body --
4898    --------------------------
4899
4900    function Make_Deep_Array_Body
4901      (Prim : Final_Primitives;
4902       Typ  : Entity_Id) return List_Id
4903    is
4904       function Build_Adjust_Or_Finalize_Statements
4905         (Typ : Entity_Id) return List_Id;
4906       --  Create the statements necessary to adjust or finalize an array of
4907       --  controlled elements. Generate:
4908       --
4909       --    declare
4910       --       Abort  : constant Boolean := Triggered_By_Abort;
4911       --         <or>
4912       --       Abort  : constant Boolean := False;  --  no abort
4913       --
4914       --       E      : Exception_Occurrence;
4915       --       Raised : Boolean := False;
4916       --
4917       --    begin
4918       --       for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
4919       --                 ^--  in the finalization case
4920       --          ...
4921       --          for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
4922       --             begin
4923       --                [Deep_]Adjust / Finalize (V (J1, ..., Jn));
4924       --
4925       --             exception
4926       --                when others =>
4927       --                   if not Raised then
4928       --                      Raised := True;
4929       --                      Save_Occurrence (E, Get_Current_Excep.all.all);
4930       --                   end if;
4931       --             end;
4932       --          end loop;
4933       --          ...
4934       --       end loop;
4935       --
4936       --       if Raised and then not Abort then
4937       --          Raise_From_Controlled_Operation (E);
4938       --       end if;
4939       --    end;
4940
4941       function Build_Initialize_Statements (Typ : Entity_Id) return List_Id;
4942       --  Create the statements necessary to initialize an array of controlled
4943       --  elements. Include a mechanism to carry out partial finalization if an
4944       --  exception occurs. Generate:
4945       --
4946       --    declare
4947       --       Counter : Integer := 0;
4948       --
4949       --    begin
4950       --       for J1 in V'Range (1) loop
4951       --          ...
4952       --          for JN in V'Range (N) loop
4953       --             begin
4954       --                [Deep_]Initialize (V (J1, ..., JN));
4955       --
4956       --                Counter := Counter + 1;
4957       --
4958       --             exception
4959       --                when others =>
4960       --                   declare
4961       --                      Abort  : constant Boolean := Triggered_By_Abort;
4962       --                        <or>
4963       --                      Abort  : constant Boolean := False; --  no abort
4964       --                      E      : Exception_Occurence;
4965       --                      Raised : Boolean := False;
4966
4967       --                   begin
4968       --                      Counter :=
4969       --                        V'Length (1) *
4970       --                        V'Length (2) *
4971       --                        ...
4972       --                        V'Length (N) - Counter;
4973
4974       --                      for F1 in reverse V'Range (1) loop
4975       --                         ...
4976       --                         for FN in reverse V'Range (N) loop
4977       --                            if Counter > 0 then
4978       --                               Counter := Counter - 1;
4979       --                            else
4980       --                               begin
4981       --                                  [Deep_]Finalize (V (F1, ..., FN));
4982
4983       --                               exception
4984       --                                  when others =>
4985       --                                     if not Raised then
4986       --                                        Raised := True;
4987       --                                        Save_Occurrence (E,
4988       --                                          Get_Current_Excep.all.all);
4989       --                                     end if;
4990       --                               end;
4991       --                            end if;
4992       --                         end loop;
4993       --                         ...
4994       --                      end loop;
4995       --                   end;
4996       --
4997       --                   if Raised and then not Abort then
4998       --                      Raise_From_Controlled_Operation (E);
4999       --                   end if;
5000       --
5001       --                   raise;
5002       --             end;
5003       --          end loop;
5004       --       end loop;
5005       --    end;
5006
5007       function New_References_To
5008         (L   : List_Id;
5009          Loc : Source_Ptr) return List_Id;
5010       --  Given a list of defining identifiers, return a list of references to
5011       --  the original identifiers, in the same order as they appear.
5012
5013       -----------------------------------------
5014       -- Build_Adjust_Or_Finalize_Statements --
5015       -----------------------------------------
5016
5017       function Build_Adjust_Or_Finalize_Statements
5018         (Typ : Entity_Id) return List_Id
5019       is
5020          Comp_Typ        : constant Entity_Id  := Component_Type (Typ);
5021          Index_List      : constant List_Id    := New_List;
5022          Loc             : constant Source_Ptr := Sloc (Typ);
5023          Num_Dims        : constant Int        := Number_Dimensions (Typ);
5024          Finalizer_Decls : List_Id := No_List;
5025          Finalizer_Data  : Finalization_Exception_Data;
5026          Call            : Node_Id;
5027          Comp_Ref        : Node_Id;
5028          Core_Loop       : Node_Id;
5029          Dim             : Int;
5030          J               : Entity_Id;
5031          Loop_Id         : Entity_Id;
5032          Stmts           : List_Id;
5033
5034          Exceptions_OK : constant Boolean :=
5035                            not Restriction_Active (No_Exception_Propagation);
5036
5037          procedure Build_Indices;
5038          --  Generate the indices used in the dimension loops
5039
5040          -------------------
5041          -- Build_Indices --
5042          -------------------
5043
5044          procedure Build_Indices is
5045          begin
5046             --  Generate the following identifiers:
5047             --    Jnn  -  for initialization
5048
5049             for Dim in 1 .. Num_Dims loop
5050                Append_To (Index_List,
5051                  Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));
5052             end loop;
5053          end Build_Indices;
5054
5055       --  Start of processing for Build_Adjust_Or_Finalize_Statements
5056
5057       begin
5058          Finalizer_Decls := New_List;
5059
5060          Build_Indices;
5061          Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
5062
5063          Comp_Ref :=
5064            Make_Indexed_Component (Loc,
5065              Prefix      => Make_Identifier (Loc, Name_V),
5066              Expressions => New_References_To (Index_List, Loc));
5067          Set_Etype (Comp_Ref, Comp_Typ);
5068
5069          --  Generate:
5070          --    [Deep_]Adjust (V (J1, ..., JN))
5071
5072          if Prim = Adjust_Case then
5073             Call := Make_Adjust_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
5074
5075          --  Generate:
5076          --    [Deep_]Finalize (V (J1, ..., JN))
5077
5078          else pragma Assert (Prim = Finalize_Case);
5079             Call := Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
5080          end if;
5081
5082          --  Generate the block which houses the adjust or finalize call:
5083
5084          --    <adjust or finalize call>;  --  No_Exception_Propagation
5085
5086          --    begin                       --  Exception handlers allowed
5087          --       <adjust or finalize call>
5088
5089          --    exception
5090          --       when others =>
5091          --          if not Raised then
5092          --             Raised := True;
5093          --             Save_Occurrence (E, Get_Current_Excep.all.all);
5094          --          end if;
5095          --    end;
5096
5097          if Exceptions_OK then
5098             Core_Loop :=
5099               Make_Block_Statement (Loc,
5100                 Handled_Statement_Sequence =>
5101                   Make_Handled_Sequence_Of_Statements (Loc,
5102                     Statements         => New_List (Call),
5103                     Exception_Handlers => New_List (
5104                       Build_Exception_Handler (Finalizer_Data))));
5105          else
5106             Core_Loop := Call;
5107          end if;
5108
5109          --  Generate the dimension loops starting from the innermost one
5110
5111          --    for Jnn in [reverse] V'Range (Dim) loop
5112          --       <core loop>
5113          --    end loop;
5114
5115          J := Last (Index_List);
5116          Dim := Num_Dims;
5117          while Present (J) and then Dim > 0 loop
5118             Loop_Id := J;
5119             Prev (J);
5120             Remove (Loop_Id);
5121
5122             Core_Loop :=
5123               Make_Loop_Statement (Loc,
5124                 Iteration_Scheme =>
5125                   Make_Iteration_Scheme (Loc,
5126                     Loop_Parameter_Specification =>
5127                       Make_Loop_Parameter_Specification (Loc,
5128                         Defining_Identifier         => Loop_Id,
5129                         Discrete_Subtype_Definition =>
5130                           Make_Attribute_Reference (Loc,
5131                             Prefix         => Make_Identifier (Loc, Name_V),
5132                             Attribute_Name => Name_Range,
5133                             Expressions    => New_List (
5134                               Make_Integer_Literal (Loc, Dim))),
5135
5136                         Reverse_Present => Prim = Finalize_Case)),
5137
5138                 Statements => New_List (Core_Loop),
5139                 End_Label  => Empty);
5140
5141             Dim := Dim - 1;
5142          end loop;
5143
5144          --  Generate the block which contains the core loop, the declarations
5145          --  of the abort flag, the exception occurrence, the raised flag and
5146          --  the conditional raise:
5147
5148          --    declare
5149          --       Abort  : constant Boolean := Triggered_By_Abort;
5150          --         <or>
5151          --       Abort  : constant Boolean := False;  --  no abort
5152
5153          --       E      : Exception_Occurrence;
5154          --       Raised : Boolean := False;
5155
5156          --    begin
5157          --       <core loop>
5158
5159          --       if Raised and then not Abort then  --  Expection handlers OK
5160          --          Raise_From_Controlled_Operation (E);
5161          --       end if;
5162          --    end;
5163
5164          Stmts := New_List (Core_Loop);
5165
5166          if Exceptions_OK then
5167             Append_To (Stmts,
5168               Build_Raise_Statement (Finalizer_Data));
5169          end if;
5170
5171          return
5172            New_List (
5173              Make_Block_Statement (Loc,
5174                Declarations               =>
5175                  Finalizer_Decls,
5176                Handled_Statement_Sequence =>
5177                  Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
5178       end Build_Adjust_Or_Finalize_Statements;
5179
5180       ---------------------------------
5181       -- Build_Initialize_Statements --
5182       ---------------------------------
5183
5184       function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is
5185          Comp_Typ        : constant Entity_Id  := Component_Type (Typ);
5186          Final_List      : constant List_Id    := New_List;
5187          Index_List      : constant List_Id    := New_List;
5188          Loc             : constant Source_Ptr := Sloc (Typ);
5189          Num_Dims        : constant Int        := Number_Dimensions (Typ);
5190          Counter_Id      : Entity_Id;
5191          Dim             : Int;
5192          F               : Node_Id;
5193          Fin_Stmt        : Node_Id;
5194          Final_Block     : Node_Id;
5195          Final_Loop      : Node_Id;
5196          Finalizer_Data  : Finalization_Exception_Data;
5197          Finalizer_Decls : List_Id := No_List;
5198          Init_Loop       : Node_Id;
5199          J               : Node_Id;
5200          Loop_Id         : Node_Id;
5201          Stmts           : List_Id;
5202
5203          Exceptions_OK : constant Boolean :=
5204                            not Restriction_Active (No_Exception_Propagation);
5205
5206          function Build_Counter_Assignment return Node_Id;
5207          --  Generate the following assignment:
5208          --    Counter := V'Length (1) *
5209          --               ...
5210          --               V'Length (N) - Counter;
5211
5212          function Build_Finalization_Call return Node_Id;
5213          --  Generate a deep finalization call for an array element
5214
5215          procedure Build_Indices;
5216          --  Generate the initialization and finalization indices used in the
5217          --  dimension loops.
5218
5219          function Build_Initialization_Call return Node_Id;
5220          --  Generate a deep initialization call for an array element
5221
5222          ------------------------------
5223          -- Build_Counter_Assignment --
5224          ------------------------------
5225
5226          function Build_Counter_Assignment return Node_Id is
5227             Dim  : Int;
5228             Expr : Node_Id;
5229
5230          begin
5231             --  Start from the first dimension and generate:
5232             --    V'Length (1)
5233
5234             Dim := 1;
5235             Expr :=
5236               Make_Attribute_Reference (Loc,
5237                 Prefix         => Make_Identifier (Loc, Name_V),
5238                 Attribute_Name => Name_Length,
5239                 Expressions    => New_List (Make_Integer_Literal (Loc, Dim)));
5240
5241             --  Process the rest of the dimensions, generate:
5242             --    Expr * V'Length (N)
5243
5244             Dim := Dim + 1;
5245             while Dim <= Num_Dims loop
5246                Expr :=
5247                  Make_Op_Multiply (Loc,
5248                    Left_Opnd  => Expr,
5249                    Right_Opnd =>
5250                      Make_Attribute_Reference (Loc,
5251                        Prefix         => Make_Identifier (Loc, Name_V),
5252                        Attribute_Name => Name_Length,
5253                        Expressions    => New_List (
5254                          Make_Integer_Literal (Loc, Dim))));
5255
5256                Dim := Dim + 1;
5257             end loop;
5258
5259             --  Generate:
5260             --    Counter := Expr - Counter;
5261
5262             return
5263               Make_Assignment_Statement (Loc,
5264                 Name       => New_Reference_To (Counter_Id, Loc),
5265                 Expression =>
5266                   Make_Op_Subtract (Loc,
5267                     Left_Opnd  => Expr,
5268                     Right_Opnd => New_Reference_To (Counter_Id, Loc)));
5269          end Build_Counter_Assignment;
5270
5271          -----------------------------
5272          -- Build_Finalization_Call --
5273          -----------------------------
5274
5275          function Build_Finalization_Call return Node_Id is
5276             Comp_Ref : constant Node_Id :=
5277                          Make_Indexed_Component (Loc,
5278                            Prefix      => Make_Identifier (Loc, Name_V),
5279                            Expressions => New_References_To (Final_List, Loc));
5280
5281          begin
5282             Set_Etype (Comp_Ref, Comp_Typ);
5283
5284             --  Generate:
5285             --    [Deep_]Finalize (V);
5286
5287             return Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
5288          end Build_Finalization_Call;
5289
5290          -------------------
5291          -- Build_Indices --
5292          -------------------
5293
5294          procedure Build_Indices is
5295          begin
5296             --  Generate the following identifiers:
5297             --    Jnn  -  for initialization
5298             --    Fnn  -  for finalization
5299
5300             for Dim in 1 .. Num_Dims loop
5301                Append_To (Index_List,
5302                  Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));
5303
5304                Append_To (Final_List,
5305                  Make_Defining_Identifier (Loc, New_External_Name ('F', Dim)));
5306             end loop;
5307          end Build_Indices;
5308
5309          -------------------------------
5310          -- Build_Initialization_Call --
5311          -------------------------------
5312
5313          function Build_Initialization_Call return Node_Id is
5314             Comp_Ref : constant Node_Id :=
5315                          Make_Indexed_Component (Loc,
5316                            Prefix      => Make_Identifier (Loc, Name_V),
5317                            Expressions => New_References_To (Index_List, Loc));
5318
5319          begin
5320             Set_Etype (Comp_Ref, Comp_Typ);
5321
5322             --  Generate:
5323             --    [Deep_]Initialize (V (J1, ..., JN));
5324
5325             return Make_Init_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
5326          end Build_Initialization_Call;
5327
5328       --  Start of processing for Build_Initialize_Statements
5329
5330       begin
5331          Counter_Id := Make_Temporary (Loc, 'C');
5332          Finalizer_Decls := New_List;
5333
5334          Build_Indices;
5335          Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
5336
5337          --  Generate the block which houses the finalization call, the index
5338          --  guard and the handler which triggers Program_Error later on.
5339
5340          --    if Counter > 0 then
5341          --       Counter := Counter - 1;
5342          --    else
5343          --       [Deep_]Finalize (V (F1, ..., FN));  --  No_Except_Propagation
5344
5345          --       begin                               --  Exceptions allowed
5346          --          [Deep_]Finalize (V (F1, ..., FN));
5347          --       exception
5348          --          when others =>
5349          --             if not Raised then
5350          --                Raised := True;
5351          --                Save_Occurrence (E, Get_Current_Excep.all.all);
5352          --             end if;
5353          --       end;
5354          --    end if;
5355
5356          if Exceptions_OK then
5357             Fin_Stmt :=
5358               Make_Block_Statement (Loc,
5359                 Handled_Statement_Sequence =>
5360                   Make_Handled_Sequence_Of_Statements (Loc,
5361                     Statements         => New_List (Build_Finalization_Call),
5362                     Exception_Handlers => New_List (
5363                       Build_Exception_Handler (Finalizer_Data))));
5364          else
5365             Fin_Stmt := Build_Finalization_Call;
5366          end if;
5367
5368          --  This is the core of the loop, the dimension iterators are added
5369          --  one by one in reverse.
5370
5371          Final_Loop :=
5372            Make_If_Statement (Loc,
5373              Condition =>
5374                Make_Op_Gt (Loc,
5375                  Left_Opnd  => New_Reference_To (Counter_Id, Loc),
5376                  Right_Opnd => Make_Integer_Literal (Loc, 0)),
5377
5378              Then_Statements => New_List (
5379                Make_Assignment_Statement (Loc,
5380                  Name       => New_Reference_To (Counter_Id, Loc),
5381                  Expression =>
5382                    Make_Op_Subtract (Loc,
5383                      Left_Opnd  => New_Reference_To (Counter_Id, Loc),
5384                      Right_Opnd => Make_Integer_Literal (Loc, 1)))),
5385
5386              Else_Statements => New_List (Fin_Stmt));
5387
5388          --  Generate all finalization loops starting from the innermost
5389          --  dimension.
5390
5391          --    for Fnn in reverse V'Range (Dim) loop
5392          --       <final loop>
5393          --    end loop;
5394
5395          F := Last (Final_List);
5396          Dim := Num_Dims;
5397          while Present (F) and then Dim > 0 loop
5398             Loop_Id := F;
5399             Prev (F);
5400             Remove (Loop_Id);
5401
5402             Final_Loop :=
5403               Make_Loop_Statement (Loc,
5404                 Iteration_Scheme =>
5405                   Make_Iteration_Scheme (Loc,
5406                     Loop_Parameter_Specification =>
5407                       Make_Loop_Parameter_Specification (Loc,
5408                         Defining_Identifier => Loop_Id,
5409                         Discrete_Subtype_Definition =>
5410                           Make_Attribute_Reference (Loc,
5411                             Prefix         => Make_Identifier (Loc, Name_V),
5412                             Attribute_Name => Name_Range,
5413                             Expressions    => New_List (
5414                               Make_Integer_Literal (Loc, Dim))),
5415
5416                         Reverse_Present => True)),
5417
5418                 Statements => New_List (Final_Loop),
5419                 End_Label => Empty);
5420
5421             Dim := Dim - 1;
5422          end loop;
5423
5424          --  Generate the block which contains the finalization loops, the
5425          --  declarations of the abort flag, the exception occurrence, the
5426          --  raised flag and the conditional raise.
5427
5428          --    declare
5429          --       Abort  : constant Boolean := Triggered_By_Abort;
5430          --         <or>
5431          --       Abort  : constant Boolean := False;  --  no abort
5432
5433          --       E      : Exception_Occurrence;
5434          --       Raised : Boolean := False;
5435
5436          --    begin
5437          --       Counter :=
5438          --         V'Length (1) *
5439          --         ...
5440          --         V'Length (N) - Counter;
5441
5442          --       <final loop>
5443
5444          --       if Raised and then not Abort then  --  Exception handlers OK
5445          --          Raise_From_Controlled_Operation (E);
5446          --       end if;
5447
5448          --       raise;  --  Exception handlers OK
5449          --    end;
5450
5451          Stmts := New_List (Build_Counter_Assignment, Final_Loop);
5452
5453          if Exceptions_OK then
5454             Append_To (Stmts,
5455               Build_Raise_Statement (Finalizer_Data));
5456             Append_To (Stmts, Make_Raise_Statement (Loc));
5457          end if;
5458
5459          Final_Block :=
5460            Make_Block_Statement (Loc,
5461              Declarations               =>
5462                Finalizer_Decls,
5463              Handled_Statement_Sequence =>
5464                Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts));
5465
5466          --  Generate the block which contains the initialization call and
5467          --  the partial finalization code.
5468
5469          --    begin
5470          --       [Deep_]Initialize (V (J1, ..., JN));
5471
5472          --       Counter := Counter + 1;
5473
5474          --    exception
5475          --       when others =>
5476          --          <finalization code>
5477          --    end;
5478
5479          Init_Loop :=
5480            Make_Block_Statement (Loc,
5481              Handled_Statement_Sequence =>
5482                Make_Handled_Sequence_Of_Statements (Loc,
5483                  Statements         => New_List (Build_Initialization_Call),
5484                  Exception_Handlers => New_List (
5485                    Make_Exception_Handler (Loc,
5486                      Exception_Choices => New_List (Make_Others_Choice (Loc)),
5487                      Statements        => New_List (Final_Block)))));
5488
5489          Append_To (Statements (Handled_Statement_Sequence (Init_Loop)),
5490            Make_Assignment_Statement (Loc,
5491              Name       => New_Reference_To (Counter_Id, Loc),
5492              Expression =>
5493                Make_Op_Add (Loc,
5494                  Left_Opnd  => New_Reference_To (Counter_Id, Loc),
5495                  Right_Opnd => Make_Integer_Literal (Loc, 1))));
5496
5497          --  Generate all initialization loops starting from the innermost
5498          --  dimension.
5499
5500          --    for Jnn in V'Range (Dim) loop
5501          --       <init loop>
5502          --    end loop;
5503
5504          J := Last (Index_List);
5505          Dim := Num_Dims;
5506          while Present (J) and then Dim > 0 loop
5507             Loop_Id := J;
5508             Prev (J);
5509             Remove (Loop_Id);
5510
5511             Init_Loop :=
5512               Make_Loop_Statement (Loc,
5513                 Iteration_Scheme =>
5514                   Make_Iteration_Scheme (Loc,
5515                     Loop_Parameter_Specification =>
5516                       Make_Loop_Parameter_Specification (Loc,
5517                         Defining_Identifier => Loop_Id,
5518                         Discrete_Subtype_Definition =>
5519                           Make_Attribute_Reference (Loc,
5520                             Prefix         => Make_Identifier (Loc, Name_V),
5521                             Attribute_Name => Name_Range,
5522                             Expressions    => New_List (
5523                               Make_Integer_Literal (Loc, Dim))))),
5524
5525                 Statements => New_List (Init_Loop),
5526                 End_Label => Empty);
5527
5528             Dim := Dim - 1;
5529          end loop;
5530
5531          --  Generate the block which contains the counter variable and the
5532          --  initialization loops.
5533
5534          --    declare
5535          --       Counter : Integer := 0;
5536          --    begin
5537          --       <init loop>
5538          --    end;
5539
5540          return
5541            New_List (
5542              Make_Block_Statement (Loc,
5543                Declarations               => New_List (
5544                  Make_Object_Declaration (Loc,
5545                    Defining_Identifier => Counter_Id,
5546                    Object_Definition   =>
5547                      New_Reference_To (Standard_Integer, Loc),
5548                    Expression          => Make_Integer_Literal (Loc, 0))),
5549
5550                Handled_Statement_Sequence =>
5551                  Make_Handled_Sequence_Of_Statements (Loc,
5552                    Statements => New_List (Init_Loop))));
5553       end Build_Initialize_Statements;
5554
5555       -----------------------
5556       -- New_References_To --
5557       -----------------------
5558
5559       function New_References_To
5560         (L   : List_Id;
5561          Loc : Source_Ptr) return List_Id
5562       is
5563          Refs : constant List_Id := New_List;
5564          Id   : Node_Id;
5565
5566       begin
5567          Id := First (L);
5568          while Present (Id) loop
5569             Append_To (Refs, New_Reference_To (Id, Loc));
5570             Next (Id);
5571          end loop;
5572
5573          return Refs;
5574       end New_References_To;
5575
5576    --  Start of processing for Make_Deep_Array_Body
5577
5578    begin
5579       case Prim is
5580          when Address_Case =>
5581             return Make_Finalize_Address_Stmts (Typ);
5582
5583          when Adjust_Case   |
5584               Finalize_Case =>
5585             return Build_Adjust_Or_Finalize_Statements (Typ);
5586
5587          when Initialize_Case =>
5588             return Build_Initialize_Statements (Typ);
5589       end case;
5590    end Make_Deep_Array_Body;
5591
5592    --------------------
5593    -- Make_Deep_Proc --
5594    --------------------
5595
5596    function Make_Deep_Proc
5597      (Prim  : Final_Primitives;
5598       Typ   : Entity_Id;
5599       Stmts : List_Id) return Entity_Id
5600    is
5601       Loc     : constant Source_Ptr := Sloc (Typ);
5602       Formals : List_Id;
5603       Proc_Id : Entity_Id;
5604
5605    begin
5606       --  Create the object formal, generate:
5607       --    V : System.Address
5608
5609       if Prim = Address_Case then
5610          Formals := New_List (
5611            Make_Parameter_Specification (Loc,
5612              Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
5613              Parameter_Type      => New_Reference_To (RTE (RE_Address), Loc)));
5614
5615       --  Default case
5616
5617       else
5618          --  V : in out Typ
5619
5620          Formals := New_List (
5621            Make_Parameter_Specification (Loc,
5622              Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
5623              In_Present          => True,
5624              Out_Present         => True,
5625              Parameter_Type      => New_Reference_To (Typ, Loc)));
5626
5627          --  F : Boolean := True
5628
5629          if Prim = Adjust_Case
5630            or else Prim = Finalize_Case
5631          then
5632             Append_To (Formals,
5633               Make_Parameter_Specification (Loc,
5634                 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
5635                 Parameter_Type      =>
5636                   New_Reference_To (Standard_Boolean, Loc),
5637                 Expression          =>
5638                   New_Reference_To (Standard_True, Loc)));
5639          end if;
5640       end if;
5641
5642       Proc_Id :=
5643         Make_Defining_Identifier (Loc,
5644           Chars => Make_TSS_Name (Typ, Deep_Name_Of (Prim)));
5645
5646       --  Generate:
5647       --    procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
5648       --    begin
5649       --       <stmts>
5650       --    exception                --  Finalize and Adjust cases only
5651       --       raise Program_Error;
5652       --    end Deep_Initialize / Adjust / Finalize;
5653
5654       --       or
5655
5656       --    procedure Finalize_Address (V : System.Address) is
5657       --    begin
5658       --       <stmts>
5659       --    end Finalize_Address;
5660
5661       Discard_Node (
5662         Make_Subprogram_Body (Loc,
5663           Specification =>
5664             Make_Procedure_Specification (Loc,
5665               Defining_Unit_Name       => Proc_Id,
5666               Parameter_Specifications => Formals),
5667
5668           Declarations => Empty_List,
5669
5670           Handled_Statement_Sequence =>
5671             Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)));
5672
5673       return Proc_Id;
5674    end Make_Deep_Proc;
5675
5676    ---------------------------
5677    -- Make_Deep_Record_Body --
5678    ---------------------------
5679
5680    function Make_Deep_Record_Body
5681      (Prim     : Final_Primitives;
5682       Typ      : Entity_Id;
5683       Is_Local : Boolean := False) return List_Id
5684    is
5685       function Build_Adjust_Statements (Typ : Entity_Id) return List_Id;
5686       --  Build the statements necessary to adjust a record type. The type may
5687       --  have discriminants and contain variant parts. Generate:
5688       --
5689       --    begin
5690       --       begin
5691       --          [Deep_]Adjust (V.Comp_1);
5692       --       exception
5693       --          when Id : others =>
5694       --             if not Raised then
5695       --                Raised := True;
5696       --                Save_Occurrence (E, Get_Current_Excep.all.all);
5697       --             end if;
5698       --       end;
5699       --       .  .  .
5700       --       begin
5701       --          [Deep_]Adjust (V.Comp_N);
5702       --       exception
5703       --          when Id : others =>
5704       --             if not Raised then
5705       --                Raised := True;
5706       --                Save_Occurrence (E, Get_Current_Excep.all.all);
5707       --             end if;
5708       --       end;
5709       --
5710       --       begin
5711       --          Deep_Adjust (V._parent, False);  --  If applicable
5712       --       exception
5713       --          when Id : others =>
5714       --             if not Raised then
5715       --                Raised := True;
5716       --                Save_Occurrence (E, Get_Current_Excep.all.all);
5717       --             end if;
5718       --       end;
5719       --
5720       --       if F then
5721       --          begin
5722       --             Adjust (V);  --  If applicable
5723       --          exception
5724       --             when others =>
5725       --                if not Raised then
5726       --                   Raised := True;
5727       --                   Save_Occurence (E, Get_Current_Excep.all.all);
5728       --                end if;
5729       --          end;
5730       --       end if;
5731       --
5732       --       if Raised and then not Abort then
5733       --          Raise_From_Controlled_Operation (E);
5734       --       end if;
5735       --    end;
5736
5737       function Build_Finalize_Statements (Typ : Entity_Id) return List_Id;
5738       --  Build the statements necessary to finalize a record type. The type
5739       --  may have discriminants and contain variant parts. Generate:
5740       --
5741       --    declare
5742       --       Abort  : constant Boolean := Triggered_By_Abort;
5743       --         <or>
5744       --       Abort  : constant Boolean := False;  --  no abort
5745       --       E      : Exception_Occurence;
5746       --       Raised : Boolean := False;
5747       --
5748       --    begin
5749       --       if F then
5750       --          begin
5751       --             Finalize (V);  --  If applicable
5752       --          exception
5753       --             when others =>
5754       --                if not Raised then
5755       --                   Raised := True;
5756       --                   Save_Occurence (E, Get_Current_Excep.all.all);
5757       --                end if;
5758       --          end;
5759       --       end if;
5760       --
5761       --       case Variant_1 is
5762       --          when Value_1 =>
5763       --             case State_Counter_N =>  --  If Is_Local is enabled
5764       --                when N =>                 .
5765       --                   goto LN;               .
5766       --                ...                       .
5767       --                when 1 =>                 .
5768       --                   goto L1;               .
5769       --                when others =>            .
5770       --                   goto L0;               .
5771       --             end case;                    .
5772       --
5773       --             <<LN>>                   --  If Is_Local is enabled
5774       --             begin
5775       --                [Deep_]Finalize (V.Comp_N);
5776       --             exception
5777       --                when others =>
5778       --                   if not Raised then
5779       --                      Raised := True;
5780       --                      Save_Occurence (E, Get_Current_Excep.all.all);
5781       --                   end if;
5782       --             end;
5783       --             .  .  .
5784       --             <<L1>>
5785       --             begin
5786       --                [Deep_]Finalize (V.Comp_1);
5787       --             exception
5788       --                when others =>
5789       --                   if not Raised then
5790       --                      Raised := True;
5791       --                      Save_Occurence (E, Get_Current_Excep.all.all);
5792       --                   end if;
5793       --             end;
5794       --             <<L0>>
5795       --       end case;
5796       --
5797       --       case State_Counter_1 =>  --  If Is_Local is enabled
5798       --          when M =>                 .
5799       --             goto LM;               .
5800       --       ...
5801       --
5802       --       begin
5803       --          Deep_Finalize (V._parent, False);  --  If applicable
5804       --       exception
5805       --          when Id : others =>
5806       --             if not Raised then
5807       --                Raised := True;
5808       --                Save_Occurrence (E, Get_Current_Excep.all.all);
5809       --             end if;
5810       --       end;
5811       --
5812       --       if Raised and then not Abort then
5813       --          Raise_From_Controlled_Operation (E);
5814       --       end if;
5815       --    end;
5816
5817       function Parent_Field_Type (Typ : Entity_Id) return Entity_Id;
5818       --  Given a derived tagged type Typ, traverse all components, find field
5819       --  _parent and return its type.
5820
5821       procedure Preprocess_Components
5822         (Comps     : Node_Id;
5823          Num_Comps : out Int;
5824          Has_POC   : out Boolean);
5825       --  Examine all components in component list Comps, count all controlled
5826       --  components and determine whether at least one of them is per-object
5827       --  constrained. Component _parent is always skipped.
5828
5829       -----------------------------
5830       -- Build_Adjust_Statements --
5831       -----------------------------
5832
5833       function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is
5834          Loc             : constant Source_Ptr := Sloc (Typ);
5835          Typ_Def         : constant Node_Id := Type_Definition (Parent (Typ));
5836          Bod_Stmts       : List_Id;
5837          Finalizer_Data  : Finalization_Exception_Data;
5838          Finalizer_Decls : List_Id := No_List;
5839          Rec_Def         : Node_Id;
5840          Var_Case        : Node_Id;
5841
5842          Exceptions_OK : constant Boolean :=
5843                            not Restriction_Active (No_Exception_Propagation);
5844
5845          function Process_Component_List_For_Adjust
5846            (Comps : Node_Id) return List_Id;
5847          --  Build all necessary adjust statements for a single component list
5848
5849          ---------------------------------------
5850          -- Process_Component_List_For_Adjust --
5851          ---------------------------------------
5852
5853          function Process_Component_List_For_Adjust
5854            (Comps : Node_Id) return List_Id
5855          is
5856             Stmts     : constant List_Id := New_List;
5857             Decl      : Node_Id;
5858             Decl_Id   : Entity_Id;
5859             Decl_Typ  : Entity_Id;
5860             Has_POC   : Boolean;
5861             Num_Comps : Int;
5862
5863             procedure Process_Component_For_Adjust (Decl : Node_Id);
5864             --  Process the declaration of a single controlled component
5865
5866             ----------------------------------
5867             -- Process_Component_For_Adjust --
5868             ----------------------------------
5869
5870             procedure Process_Component_For_Adjust (Decl : Node_Id) is
5871                Id       : constant Entity_Id := Defining_Identifier (Decl);
5872                Typ      : constant Entity_Id := Etype (Id);
5873                Adj_Stmt : Node_Id;
5874
5875             begin
5876                --  Generate:
5877                --    [Deep_]Adjust (V.Id);  --  No_Exception_Propagation
5878
5879                --    begin                  --  Exception handlers allowed
5880                --       [Deep_]Adjust (V.Id);
5881                --    exception
5882                --       when others =>
5883                --          if not Raised then
5884                --             Raised := True;
5885                --             Save_Occurrence (E, Get_Current_Excep.all.all);
5886                --          end if;
5887                --    end;
5888
5889                Adj_Stmt :=
5890                  Make_Adjust_Call (
5891                    Obj_Ref =>
5892                      Make_Selected_Component (Loc,
5893                        Prefix        => Make_Identifier (Loc, Name_V),
5894                        Selector_Name => Make_Identifier (Loc, Chars (Id))),
5895                    Typ     => Typ);
5896
5897                if Exceptions_OK then
5898                   Adj_Stmt :=
5899                     Make_Block_Statement (Loc,
5900                       Handled_Statement_Sequence =>
5901                         Make_Handled_Sequence_Of_Statements (Loc,
5902                           Statements         => New_List (Adj_Stmt),
5903                           Exception_Handlers => New_List (
5904                             Build_Exception_Handler (Finalizer_Data))));
5905                end if;
5906
5907                Append_To (Stmts, Adj_Stmt);
5908             end Process_Component_For_Adjust;
5909
5910          --  Start of processing for Process_Component_List_For_Adjust
5911
5912          begin
5913             --  Perform an initial check, determine the number of controlled
5914             --  components in the current list and whether at least one of them
5915             --  is per-object constrained.
5916
5917             Preprocess_Components (Comps, Num_Comps, Has_POC);
5918
5919             --  The processing in this routine is done in the following order:
5920             --    1) Regular components
5921             --    2) Per-object constrained components
5922             --    3) Variant parts
5923
5924             if Num_Comps > 0 then
5925
5926                --  Process all regular components in order of declarations
5927
5928                Decl := First_Non_Pragma (Component_Items (Comps));
5929                while Present (Decl) loop
5930                   Decl_Id  := Defining_Identifier (Decl);
5931                   Decl_Typ := Etype (Decl_Id);
5932
5933                   --  Skip _parent as well as per-object constrained components
5934
5935                   if Chars (Decl_Id) /= Name_uParent
5936                     and then Needs_Finalization (Decl_Typ)
5937                   then
5938                      if Has_Access_Constraint (Decl_Id)
5939                        and then No (Expression (Decl))
5940                      then
5941                         null;
5942                      else
5943                         Process_Component_For_Adjust (Decl);
5944                      end if;
5945                   end if;
5946
5947                   Next_Non_Pragma (Decl);
5948                end loop;
5949
5950                --  Process all per-object constrained components in order of
5951                --  declarations.
5952
5953                if Has_POC then
5954                   Decl := First_Non_Pragma (Component_Items (Comps));
5955                   while Present (Decl) loop
5956                      Decl_Id  := Defining_Identifier (Decl);
5957                      Decl_Typ := Etype (Decl_Id);
5958
5959                      --  Skip _parent
5960
5961                      if Chars (Decl_Id) /= Name_uParent
5962                        and then Needs_Finalization (Decl_Typ)
5963                        and then Has_Access_Constraint (Decl_Id)
5964                        and then No (Expression (Decl))
5965                      then
5966                         Process_Component_For_Adjust (Decl);
5967                      end if;
5968
5969                      Next_Non_Pragma (Decl);
5970                   end loop;
5971                end if;
5972             end if;
5973
5974             --  Process all variants, if any
5975
5976             Var_Case := Empty;
5977             if Present (Variant_Part (Comps)) then
5978                declare
5979                   Var_Alts : constant List_Id := New_List;
5980                   Var      : Node_Id;
5981
5982                begin
5983                   Var := First_Non_Pragma (Variants (Variant_Part (Comps)));
5984                   while Present (Var) loop
5985
5986                      --  Generate:
5987                      --     when <discrete choices> =>
5988                      --        <adjust statements>
5989
5990                      Append_To (Var_Alts,
5991                        Make_Case_Statement_Alternative (Loc,
5992                          Discrete_Choices =>
5993                            New_Copy_List (Discrete_Choices (Var)),
5994                          Statements       =>
5995                            Process_Component_List_For_Adjust (
5996                              Component_List (Var))));
5997
5998                      Next_Non_Pragma (Var);
5999                   end loop;
6000
6001                   --  Generate:
6002                   --     case V.<discriminant> is
6003                   --        when <discrete choices 1> =>
6004                   --           <adjust statements 1>
6005                   --        ...
6006                   --        when <discrete choices N> =>
6007                   --           <adjust statements N>
6008                   --     end case;
6009
6010                   Var_Case :=
6011                     Make_Case_Statement (Loc,
6012                       Expression =>
6013                         Make_Selected_Component (Loc,
6014                           Prefix        => Make_Identifier (Loc, Name_V),
6015                           Selector_Name =>
6016                             Make_Identifier (Loc,
6017                               Chars => Chars (Name (Variant_Part (Comps))))),
6018                       Alternatives => Var_Alts);
6019                end;
6020             end if;
6021
6022             --  Add the variant case statement to the list of statements
6023
6024             if Present (Var_Case) then
6025                Append_To (Stmts, Var_Case);
6026             end if;
6027
6028             --  If the component list did not have any controlled components
6029             --  nor variants, return null.
6030
6031             if Is_Empty_List (Stmts) then
6032                Append_To (Stmts, Make_Null_Statement (Loc));
6033             end if;
6034
6035             return Stmts;
6036          end Process_Component_List_For_Adjust;
6037
6038       --  Start of processing for Build_Adjust_Statements
6039
6040       begin
6041          Finalizer_Decls := New_List;
6042          Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
6043
6044          if Nkind (Typ_Def) = N_Derived_Type_Definition then
6045             Rec_Def := Record_Extension_Part (Typ_Def);
6046          else
6047             Rec_Def := Typ_Def;
6048          end if;
6049
6050          --  Create an adjust sequence for all record components
6051
6052          if Present (Component_List (Rec_Def)) then
6053             Bod_Stmts :=
6054               Process_Component_List_For_Adjust (Component_List (Rec_Def));
6055          end if;
6056
6057          --  A derived record type must adjust all inherited components. This
6058          --  action poses the following problem:
6059
6060          --    procedure Deep_Adjust (Obj : in out Parent_Typ) is
6061          --    begin
6062          --       Adjust (Obj);
6063          --       ...
6064
6065          --    procedure Deep_Adjust (Obj : in out Derived_Typ) is
6066          --    begin
6067          --       Deep_Adjust (Obj._parent);
6068          --       ...
6069          --       Adjust (Obj);
6070          --       ...
6071
6072          --  Adjusting the derived type will invoke Adjust of the parent and
6073          --  then that of the derived type. This is undesirable because both
6074          --  routines may modify shared components. Only the Adjust of the
6075          --  derived type should be invoked.
6076
6077          --  To prevent this double adjustment of shared components,
6078          --  Deep_Adjust uses a flag to control the invocation of Adjust:
6079
6080          --    procedure Deep_Adjust
6081          --      (Obj  : in out Some_Type;
6082          --       Flag : Boolean := True)
6083          --    is
6084          --    begin
6085          --       if Flag then
6086          --          Adjust (Obj);
6087          --       end if;
6088          --       ...
6089
6090          --  When Deep_Adjust is invokes for field _parent, a value of False is
6091          --  provided for the flag:
6092
6093          --    Deep_Adjust (Obj._parent, False);
6094
6095          if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
6096             declare
6097                Par_Typ  : constant Entity_Id := Parent_Field_Type (Typ);
6098                Adj_Stmt : Node_Id;
6099                Call     : Node_Id;
6100
6101             begin
6102                if Needs_Finalization (Par_Typ) then
6103                   Call :=
6104                     Make_Adjust_Call
6105                       (Obj_Ref    =>
6106                          Make_Selected_Component (Loc,
6107                            Prefix        => Make_Identifier (Loc, Name_V),
6108                            Selector_Name =>
6109                              Make_Identifier (Loc, Name_uParent)),
6110                        Typ        => Par_Typ,
6111                        For_Parent => True);
6112
6113                   --  Generate:
6114                   --    Deep_Adjust (V._parent, False);  --  No_Except_Propagat
6115
6116                   --    begin                            --  Exceptions OK
6117                   --       Deep_Adjust (V._parent, False);
6118                   --    exception
6119                   --       when Id : others =>
6120                   --          if not Raised then
6121                   --             Raised := True;
6122                   --             Save_Occurrence (E,
6123                   --               Get_Current_Excep.all.all);
6124                   --          end if;
6125                   --    end;
6126
6127                   if Present (Call) then
6128                      Adj_Stmt := Call;
6129
6130                      if Exceptions_OK then
6131                         Adj_Stmt :=
6132                           Make_Block_Statement (Loc,
6133                             Handled_Statement_Sequence =>
6134                               Make_Handled_Sequence_Of_Statements (Loc,
6135                                 Statements         => New_List (Adj_Stmt),
6136                                 Exception_Handlers => New_List (
6137                                   Build_Exception_Handler (Finalizer_Data))));
6138                      end if;
6139
6140                      Prepend_To (Bod_Stmts, Adj_Stmt);
6141                   end if;
6142                end if;
6143             end;
6144          end if;
6145
6146          --  Adjust the object. This action must be performed last after all
6147          --  components have been adjusted.
6148
6149          if Is_Controlled (Typ) then
6150             declare
6151                Adj_Stmt : Node_Id;
6152                Proc     : Entity_Id;
6153
6154             begin
6155                Proc := Find_Prim_Op (Typ, Name_Adjust);
6156
6157                --  Generate:
6158                --    if F then
6159                --       Adjust (V);  --  No_Exception_Propagation
6160
6161                --       begin        --  Exception handlers allowed
6162                --          Adjust (V);
6163                --       exception
6164                --          when others =>
6165                --             if not Raised then
6166                --                Raised := True;
6167                --                Save_Occurrence (E,
6168                --                  Get_Current_Excep.all.all);
6169                --             end if;
6170                --       end;
6171                --    end if;
6172
6173                if Present (Proc) then
6174                   Adj_Stmt :=
6175                     Make_Procedure_Call_Statement (Loc,
6176                       Name                   => New_Reference_To (Proc, Loc),
6177                       Parameter_Associations => New_List (
6178                         Make_Identifier (Loc, Name_V)));
6179
6180                   if Exceptions_OK then
6181                      Adj_Stmt :=
6182                        Make_Block_Statement (Loc,
6183                          Handled_Statement_Sequence =>
6184                            Make_Handled_Sequence_Of_Statements (Loc,
6185                              Statements         => New_List (Adj_Stmt),
6186                              Exception_Handlers => New_List (
6187                                Build_Exception_Handler
6188                                  (Finalizer_Data))));
6189                   end if;
6190
6191                   Append_To (Bod_Stmts,
6192                     Make_If_Statement (Loc,
6193                       Condition       => Make_Identifier (Loc, Name_F),
6194                       Then_Statements => New_List (Adj_Stmt)));
6195                end if;
6196             end;
6197          end if;
6198
6199          --  At this point either all adjustment statements have been generated
6200          --  or the type is not controlled.
6201
6202          if Is_Empty_List (Bod_Stmts) then
6203             Append_To (Bod_Stmts, Make_Null_Statement (Loc));
6204
6205             return Bod_Stmts;
6206
6207          --  Generate:
6208          --    declare
6209          --       Abort  : constant Boolean := Triggered_By_Abort;
6210          --         <or>
6211          --       Abort  : constant Boolean := False;  --  no abort
6212
6213          --       E      : Exception_Occurence;
6214          --       Raised : Boolean := False;
6215
6216          --    begin
6217          --       <adjust statements>
6218
6219          --       if Raised and then not Abort then
6220          --          Raise_From_Controlled_Operation (E);
6221          --       end if;
6222          --    end;
6223
6224          else
6225             if Exceptions_OK then
6226                Append_To (Bod_Stmts,
6227                  Build_Raise_Statement (Finalizer_Data));
6228             end if;
6229
6230             return
6231               New_List (
6232                 Make_Block_Statement (Loc,
6233                   Declarations               =>
6234                     Finalizer_Decls,
6235                   Handled_Statement_Sequence =>
6236                     Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
6237          end if;
6238       end Build_Adjust_Statements;
6239
6240       -------------------------------
6241       -- Build_Finalize_Statements --
6242       -------------------------------
6243
6244       function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is
6245          Loc             : constant Source_Ptr := Sloc (Typ);
6246          Typ_Def         : constant Node_Id := Type_Definition (Parent (Typ));
6247          Bod_Stmts       : List_Id;
6248          Counter         : Int := 0;
6249          Finalizer_Data  : Finalization_Exception_Data;
6250          Finalizer_Decls : List_Id := No_List;
6251          Rec_Def         : Node_Id;
6252          Var_Case        : Node_Id;
6253
6254          Exceptions_OK : constant Boolean :=
6255                            not Restriction_Active (No_Exception_Propagation);
6256
6257          function Process_Component_List_For_Finalize
6258            (Comps : Node_Id) return List_Id;
6259          --  Build all necessary finalization statements for a single component
6260          --  list. The statements may include a jump circuitry if flag Is_Local
6261          --  is enabled.
6262
6263          -----------------------------------------
6264          -- Process_Component_List_For_Finalize --
6265          -----------------------------------------
6266
6267          function Process_Component_List_For_Finalize
6268            (Comps : Node_Id) return List_Id
6269          is
6270             Alts       : List_Id;
6271             Counter_Id : Entity_Id;
6272             Decl       : Node_Id;
6273             Decl_Id    : Entity_Id;
6274             Decl_Typ   : Entity_Id;
6275             Decls      : List_Id;
6276             Has_POC    : Boolean;
6277             Jump_Block : Node_Id;
6278             Label      : Node_Id;
6279             Label_Id   : Entity_Id;
6280             Num_Comps  : Int;
6281             Stmts      : List_Id;
6282
6283             procedure Process_Component_For_Finalize
6284               (Decl  : Node_Id;
6285                Alts  : List_Id;
6286                Decls : List_Id;
6287                Stmts : List_Id);
6288             --  Process the declaration of a single controlled component. If
6289             --  flag Is_Local is enabled, create the corresponding label and
6290             --  jump circuitry. Alts is the list of case alternatives, Decls
6291             --  is the top level declaration list where labels are declared
6292             --  and Stmts is the list of finalization actions.
6293
6294             ------------------------------------
6295             -- Process_Component_For_Finalize --
6296             ------------------------------------
6297
6298             procedure Process_Component_For_Finalize
6299               (Decl  : Node_Id;
6300                Alts  : List_Id;
6301                Decls : List_Id;
6302                Stmts : List_Id)
6303             is
6304                Id       : constant Entity_Id := Defining_Identifier (Decl);
6305                Typ      : constant Entity_Id := Etype (Id);
6306                Fin_Stmt : Node_Id;
6307
6308             begin
6309                if Is_Local then
6310                   declare
6311                      Label    : Node_Id;
6312                      Label_Id : Entity_Id;
6313
6314                   begin
6315                      --  Generate:
6316                      --    LN : label;
6317
6318                      Label_Id :=
6319                        Make_Identifier (Loc,
6320                          Chars => New_External_Name ('L', Num_Comps));
6321                      Set_Entity (Label_Id,
6322                        Make_Defining_Identifier (Loc, Chars (Label_Id)));
6323                      Label := Make_Label (Loc, Label_Id);
6324
6325                      Append_To (Decls,
6326                        Make_Implicit_Label_Declaration (Loc,
6327                          Defining_Identifier => Entity (Label_Id),
6328                          Label_Construct     => Label));
6329
6330                      --  Generate:
6331                      --    when N =>
6332                      --      goto LN;
6333
6334                      Append_To (Alts,
6335                        Make_Case_Statement_Alternative (Loc,
6336                          Discrete_Choices => New_List (
6337                            Make_Integer_Literal (Loc, Num_Comps)),
6338
6339                          Statements => New_List (
6340                            Make_Goto_Statement (Loc,
6341                              Name =>
6342                                New_Reference_To (Entity (Label_Id), Loc)))));
6343
6344                      --  Generate:
6345                      --    <<LN>>
6346
6347                      Append_To (Stmts, Label);
6348
6349                      --  Decrease the number of components to be processed.
6350                      --  This action yields a new Label_Id in future calls.
6351
6352                      Num_Comps := Num_Comps - 1;
6353                   end;
6354                end if;
6355
6356                --  Generate:
6357                --    [Deep_]Finalize (V.Id);  --  No_Exception_Propagation
6358
6359                --    begin                    --  Exception handlers allowed
6360                --       [Deep_]Finalize (V.Id);
6361                --    exception
6362                --       when others =>
6363                --          if not Raised then
6364                --             Raised := True;
6365                --             Save_Occurrence (E,
6366                --               Get_Current_Excep.all.all);
6367                --          end if;
6368                --    end;
6369
6370                Fin_Stmt :=
6371                  Make_Final_Call
6372                    (Obj_Ref =>
6373                       Make_Selected_Component (Loc,
6374                         Prefix        => Make_Identifier (Loc, Name_V),
6375                         Selector_Name => Make_Identifier (Loc, Chars (Id))),
6376                     Typ     => Typ);
6377
6378                if not Restriction_Active (No_Exception_Propagation) then
6379                   Fin_Stmt :=
6380                     Make_Block_Statement (Loc,
6381                       Handled_Statement_Sequence =>
6382                         Make_Handled_Sequence_Of_Statements (Loc,
6383                           Statements         => New_List (Fin_Stmt),
6384                           Exception_Handlers => New_List (
6385                             Build_Exception_Handler (Finalizer_Data))));
6386                end if;
6387
6388                Append_To (Stmts, Fin_Stmt);
6389             end Process_Component_For_Finalize;
6390
6391          --  Start of processing for Process_Component_List_For_Finalize
6392
6393          begin
6394             --  Perform an initial check, look for controlled and per-object
6395             --  constrained components.
6396
6397             Preprocess_Components (Comps, Num_Comps, Has_POC);
6398
6399             --  Create a state counter to service the current component list.
6400             --  This step is performed before the variants are inspected in
6401             --  order to generate the same state counter names as those from
6402             --  Build_Initialize_Statements.
6403
6404             if Num_Comps > 0
6405               and then Is_Local
6406             then
6407                Counter := Counter + 1;
6408
6409                Counter_Id :=
6410                  Make_Defining_Identifier (Loc,
6411                    Chars => New_External_Name ('C', Counter));
6412             end if;
6413
6414             --  Process the component in the following order:
6415             --    1) Variants
6416             --    2) Per-object constrained components
6417             --    3) Regular components
6418
6419             --  Start with the variant parts
6420
6421             Var_Case := Empty;
6422             if Present (Variant_Part (Comps)) then
6423                declare
6424                   Var_Alts : constant List_Id := New_List;
6425                   Var      : Node_Id;
6426
6427                begin
6428                   Var := First_Non_Pragma (Variants (Variant_Part (Comps)));
6429                   while Present (Var) loop
6430
6431                      --  Generate:
6432                      --     when <discrete choices> =>
6433                      --        <finalize statements>
6434
6435                      Append_To (Var_Alts,
6436                        Make_Case_Statement_Alternative (Loc,
6437                          Discrete_Choices =>
6438                            New_Copy_List (Discrete_Choices (Var)),
6439                          Statements =>
6440                            Process_Component_List_For_Finalize (
6441                              Component_List (Var))));
6442
6443                      Next_Non_Pragma (Var);
6444                   end loop;
6445
6446                   --  Generate:
6447                   --     case V.<discriminant> is
6448                   --        when <discrete choices 1> =>
6449                   --           <finalize statements 1>
6450                   --        ...
6451                   --        when <discrete choices N> =>
6452                   --           <finalize statements N>
6453                   --     end case;
6454
6455                   Var_Case :=
6456                     Make_Case_Statement (Loc,
6457                       Expression =>
6458                         Make_Selected_Component (Loc,
6459                           Prefix        => Make_Identifier (Loc, Name_V),
6460                           Selector_Name =>
6461                             Make_Identifier (Loc,
6462                               Chars => Chars (Name (Variant_Part (Comps))))),
6463                       Alternatives => Var_Alts);
6464                end;
6465             end if;
6466
6467             --  The current component list does not have a single controlled
6468             --  component, however it may contain variants. Return the case
6469             --  statement for the variants or nothing.
6470
6471             if Num_Comps = 0 then
6472                if Present (Var_Case) then
6473                   return New_List (Var_Case);
6474                else
6475                   return New_List (Make_Null_Statement (Loc));
6476                end if;
6477             end if;
6478
6479             --  Prepare all lists
6480
6481             Alts  := New_List;
6482             Decls := New_List;
6483             Stmts := New_List;
6484
6485             --  Process all per-object constrained components in reverse order
6486
6487             if Has_POC then
6488                Decl := Last_Non_Pragma (Component_Items (Comps));
6489                while Present (Decl) loop
6490                   Decl_Id  := Defining_Identifier (Decl);
6491                   Decl_Typ := Etype (Decl_Id);
6492
6493                   --  Skip _parent
6494
6495                   if Chars (Decl_Id) /= Name_uParent
6496                     and then Needs_Finalization (Decl_Typ)
6497                     and then Has_Access_Constraint (Decl_Id)
6498                     and then No (Expression (Decl))
6499                   then
6500                      Process_Component_For_Finalize (Decl, Alts, Decls, Stmts);
6501                   end if;
6502
6503                   Prev_Non_Pragma (Decl);
6504                end loop;
6505             end if;
6506
6507             --  Process the rest of the components in reverse order
6508
6509             Decl := Last_Non_Pragma (Component_Items (Comps));
6510             while Present (Decl) loop
6511                Decl_Id  := Defining_Identifier (Decl);
6512                Decl_Typ := Etype (Decl_Id);
6513
6514                --  Skip _parent
6515
6516                if Chars (Decl_Id) /= Name_uParent
6517                  and then Needs_Finalization (Decl_Typ)
6518                then
6519                   --  Skip per-object constrained components since they were
6520                   --  handled in the above step.
6521
6522                   if Has_Access_Constraint (Decl_Id)
6523                     and then No (Expression (Decl))
6524                   then
6525                      null;
6526                   else
6527                      Process_Component_For_Finalize (Decl, Alts, Decls, Stmts);
6528                   end if;
6529                end if;
6530
6531                Prev_Non_Pragma (Decl);
6532             end loop;
6533
6534             --  Generate:
6535             --    declare
6536             --       LN : label;        --  If Is_Local is enabled
6537             --       ...                    .
6538             --       L0 : label;            .
6539
6540             --    begin                     .
6541             --       case CounterX is       .
6542             --          when N =>           .
6543             --             goto LN;         .
6544             --          ...                 .
6545             --          when 1 =>           .
6546             --             goto L1;         .
6547             --          when others =>      .
6548             --             goto L0;         .
6549             --       end case;              .
6550
6551             --       <<LN>>             --  If Is_Local is enabled
6552             --          begin
6553             --             [Deep_]Finalize (V.CompY);
6554             --          exception
6555             --             when Id : others =>
6556             --                if not Raised then
6557             --                   Raised := True;
6558             --                   Save_Occurrence (E,
6559             --                     Get_Current_Excep.all.all);
6560             --                end if;
6561             --          end;
6562             --       ...
6563             --       <<L0>>  --  If Is_Local is enabled
6564             --    end;
6565
6566             if Is_Local then
6567
6568                --  Add the declaration of default jump location L0, its
6569                --  corresponding alternative and its place in the statements.
6570
6571                Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
6572                Set_Entity (Label_Id,
6573                  Make_Defining_Identifier (Loc, Chars (Label_Id)));
6574                Label := Make_Label (Loc, Label_Id);
6575
6576                Append_To (Decls,          --  declaration
6577                  Make_Implicit_Label_Declaration (Loc,
6578                    Defining_Identifier => Entity (Label_Id),
6579                    Label_Construct     => Label));
6580
6581                Append_To (Alts,           --  alternative
6582                  Make_Case_Statement_Alternative (Loc,
6583                    Discrete_Choices => New_List (
6584                      Make_Others_Choice (Loc)),
6585
6586                    Statements => New_List (
6587                      Make_Goto_Statement (Loc,
6588                        Name => New_Reference_To (Entity (Label_Id), Loc)))));
6589
6590                Append_To (Stmts, Label);  --  statement
6591
6592                --  Create the jump block
6593
6594                Prepend_To (Stmts,
6595                  Make_Case_Statement (Loc,
6596                    Expression   => Make_Identifier (Loc, Chars (Counter_Id)),
6597                    Alternatives => Alts));
6598             end if;
6599
6600             Jump_Block :=
6601               Make_Block_Statement (Loc,
6602                 Declarations               => Decls,
6603                 Handled_Statement_Sequence =>
6604                   Make_Handled_Sequence_Of_Statements (Loc, Stmts));
6605
6606             if Present (Var_Case) then
6607                return New_List (Var_Case, Jump_Block);
6608             else
6609                return New_List (Jump_Block);
6610             end if;
6611          end Process_Component_List_For_Finalize;
6612
6613       --  Start of processing for Build_Finalize_Statements
6614
6615       begin
6616          Finalizer_Decls := New_List;
6617          Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
6618
6619          if Nkind (Typ_Def) = N_Derived_Type_Definition then
6620             Rec_Def := Record_Extension_Part (Typ_Def);
6621          else
6622             Rec_Def := Typ_Def;
6623          end if;
6624
6625          --  Create a finalization sequence for all record components
6626
6627          if Present (Component_List (Rec_Def)) then
6628             Bod_Stmts :=
6629               Process_Component_List_For_Finalize (Component_List (Rec_Def));
6630          end if;
6631
6632          --  A derived record type must finalize all inherited components. This
6633          --  action poses the following problem:
6634
6635          --    procedure Deep_Finalize (Obj : in out Parent_Typ) is
6636          --    begin
6637          --       Finalize (Obj);
6638          --       ...
6639
6640          --    procedure Deep_Finalize (Obj : in out Derived_Typ) is
6641          --    begin
6642          --       Deep_Finalize (Obj._parent);
6643          --       ...
6644          --       Finalize (Obj);
6645          --       ...
6646
6647          --  Finalizing the derived type will invoke Finalize of the parent and
6648          --  then that of the derived type. This is undesirable because both
6649          --  routines may modify shared components. Only the Finalize of the
6650          --  derived type should be invoked.
6651
6652          --  To prevent this double adjustment of shared components,
6653          --  Deep_Finalize uses a flag to control the invocation of Finalize:
6654
6655          --    procedure Deep_Finalize
6656          --      (Obj  : in out Some_Type;
6657          --       Flag : Boolean := True)
6658          --    is
6659          --    begin
6660          --       if Flag then
6661          --          Finalize (Obj);
6662          --       end if;
6663          --       ...
6664
6665          --  When Deep_Finalize is invokes for field _parent, a value of False
6666          --  is provided for the flag:
6667
6668          --    Deep_Finalize (Obj._parent, False);
6669
6670          if Is_Tagged_Type (Typ)
6671            and then Is_Derived_Type (Typ)
6672          then
6673             declare
6674                Par_Typ  : constant Entity_Id := Parent_Field_Type (Typ);
6675                Call     : Node_Id;
6676                Fin_Stmt : Node_Id;
6677
6678             begin
6679                if Needs_Finalization (Par_Typ) then
6680                   Call :=
6681                     Make_Final_Call
6682                       (Obj_Ref    =>
6683                          Make_Selected_Component (Loc,
6684                            Prefix        => Make_Identifier (Loc, Name_V),
6685                            Selector_Name =>
6686                              Make_Identifier (Loc, Name_uParent)),
6687                        Typ        => Par_Typ,
6688                        For_Parent => True);
6689
6690                   --  Generate:
6691                   --    Deep_Finalize (V._parent, False);  --  No_Except_Propag
6692
6693                   --    begin                              --  Exceptions OK
6694                   --       Deep_Finalize (V._parent, False);
6695                   --    exception
6696                   --       when Id : others =>
6697                   --          if not Raised then
6698                   --             Raised := True;
6699                   --             Save_Occurrence (E,
6700                   --               Get_Current_Excep.all.all);
6701                   --          end if;
6702                   --    end;
6703
6704                   if Present (Call) then
6705                      Fin_Stmt := Call;
6706
6707                      if Exceptions_OK then
6708                         Fin_Stmt :=
6709                           Make_Block_Statement (Loc,
6710                             Handled_Statement_Sequence =>
6711                               Make_Handled_Sequence_Of_Statements (Loc,
6712                                 Statements         => New_List (Fin_Stmt),
6713                                 Exception_Handlers => New_List (
6714                                   Build_Exception_Handler
6715                                     (Finalizer_Data))));
6716                      end if;
6717
6718                      Append_To (Bod_Stmts, Fin_Stmt);
6719                   end if;
6720                end if;
6721             end;
6722          end if;
6723
6724          --  Finalize the object. This action must be performed first before
6725          --  all components have been finalized.
6726
6727          if Is_Controlled (Typ)
6728            and then not Is_Local
6729          then
6730             declare
6731                Fin_Stmt : Node_Id;
6732                Proc     : Entity_Id;
6733
6734             begin
6735                Proc := Find_Prim_Op (Typ, Name_Finalize);
6736
6737                --  Generate:
6738                --    if F then
6739                --       Finalize (V);  --  No_Exception_Propagation
6740
6741                --       begin
6742                --          Finalize (V);
6743                --       exception
6744                --          when others =>
6745                --             if not Raised then
6746                --                Raised := True;
6747                --                Save_Occurrence (E,
6748                --                  Get_Current_Excep.all.all);
6749                --             end if;
6750                --       end;
6751                --    end if;
6752
6753                if Present (Proc) then
6754                   Fin_Stmt :=
6755                     Make_Procedure_Call_Statement (Loc,
6756                       Name                   => New_Reference_To (Proc, Loc),
6757                       Parameter_Associations => New_List (
6758                         Make_Identifier (Loc, Name_V)));
6759
6760                   if Exceptions_OK then
6761                      Fin_Stmt :=
6762                        Make_Block_Statement (Loc,
6763                          Handled_Statement_Sequence =>
6764                            Make_Handled_Sequence_Of_Statements (Loc,
6765                              Statements         => New_List (Fin_Stmt),
6766                              Exception_Handlers => New_List (
6767                                Build_Exception_Handler
6768                                  (Finalizer_Data))));
6769                   end if;
6770
6771                   Prepend_To (Bod_Stmts,
6772                     Make_If_Statement (Loc,
6773                       Condition       => Make_Identifier (Loc, Name_F),
6774                       Then_Statements => New_List (Fin_Stmt)));
6775                end if;
6776             end;
6777          end if;
6778
6779          --  At this point either all finalization statements have been
6780          --  generated or the type is not controlled.
6781
6782          if No (Bod_Stmts) then
6783             return New_List (Make_Null_Statement (Loc));
6784
6785          --  Generate:
6786          --    declare
6787          --       Abort  : constant Boolean := Triggered_By_Abort;
6788          --         <or>
6789          --       Abort  : constant Boolean := False;  --  no abort
6790
6791          --       E      : Exception_Occurence;
6792          --       Raised : Boolean := False;
6793
6794          --    begin
6795          --       <finalize statements>
6796
6797          --       if Raised and then not Abort then
6798          --          Raise_From_Controlled_Operation (E);
6799          --       end if;
6800          --    end;
6801
6802          else
6803             if Exceptions_OK then
6804                Append_To (Bod_Stmts,
6805                  Build_Raise_Statement (Finalizer_Data));
6806             end if;
6807
6808             return
6809               New_List (
6810                 Make_Block_Statement (Loc,
6811                   Declarations               =>
6812                     Finalizer_Decls,
6813                   Handled_Statement_Sequence =>
6814                     Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
6815          end if;
6816       end Build_Finalize_Statements;
6817
6818       -----------------------
6819       -- Parent_Field_Type --
6820       -----------------------
6821
6822       function Parent_Field_Type (Typ : Entity_Id) return Entity_Id is
6823          Field : Entity_Id;
6824
6825       begin
6826          Field := First_Entity (Typ);
6827          while Present (Field) loop
6828             if Chars (Field) = Name_uParent then
6829                return Etype (Field);
6830             end if;
6831
6832             Next_Entity (Field);
6833          end loop;
6834
6835          --  A derived tagged type should always have a parent field
6836
6837          raise Program_Error;
6838       end Parent_Field_Type;
6839
6840       ---------------------------
6841       -- Preprocess_Components --
6842       ---------------------------
6843
6844       procedure Preprocess_Components
6845         (Comps     : Node_Id;
6846          Num_Comps : out Int;
6847          Has_POC   : out Boolean)
6848       is
6849          Decl : Node_Id;
6850          Id   : Entity_Id;
6851          Typ  : Entity_Id;
6852
6853       begin
6854          Num_Comps := 0;
6855          Has_POC   := False;
6856
6857          Decl := First_Non_Pragma (Component_Items (Comps));
6858          while Present (Decl) loop
6859             Id  := Defining_Identifier (Decl);
6860             Typ := Etype (Id);
6861
6862             --  Skip field _parent
6863
6864             if Chars (Id) /= Name_uParent
6865               and then Needs_Finalization (Typ)
6866             then
6867                Num_Comps := Num_Comps + 1;
6868
6869                if Has_Access_Constraint (Id)
6870                  and then No (Expression (Decl))
6871                then
6872                   Has_POC := True;
6873                end if;
6874             end if;
6875
6876             Next_Non_Pragma (Decl);
6877          end loop;
6878       end Preprocess_Components;
6879
6880    --  Start of processing for Make_Deep_Record_Body
6881
6882    begin
6883       case Prim is
6884          when Address_Case =>
6885             return Make_Finalize_Address_Stmts (Typ);
6886
6887          when Adjust_Case =>
6888             return Build_Adjust_Statements (Typ);
6889
6890          when Finalize_Case =>
6891             return Build_Finalize_Statements (Typ);
6892
6893          when Initialize_Case =>
6894             declare
6895                Loc : constant Source_Ptr := Sloc (Typ);
6896
6897             begin
6898                if Is_Controlled (Typ) then
6899                   return New_List (
6900                     Make_Procedure_Call_Statement (Loc,
6901                       Name                   =>
6902                         New_Reference_To
6903                           (Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
6904                       Parameter_Associations => New_List (
6905                         Make_Identifier (Loc, Name_V))));
6906                else
6907                   return Empty_List;
6908                end if;
6909             end;
6910       end case;
6911    end Make_Deep_Record_Body;
6912
6913    ----------------------
6914    -- Make_Final_Call --
6915    ----------------------
6916
6917    function Make_Final_Call
6918      (Obj_Ref    : Node_Id;
6919       Typ        : Entity_Id;
6920       For_Parent : Boolean := False) return Node_Id
6921    is
6922       Loc    : constant Source_Ptr := Sloc (Obj_Ref);
6923       Atyp   : Entity_Id;
6924       Fin_Id : Entity_Id := Empty;
6925       Ref    : Node_Id;
6926       Utyp   : Entity_Id;
6927
6928    begin
6929       --  Recover the proper type which contains [Deep_]Finalize
6930
6931       if Is_Class_Wide_Type (Typ) then
6932          Utyp := Root_Type (Typ);
6933          Atyp := Utyp;
6934          Ref  := Obj_Ref;
6935
6936       elsif Is_Concurrent_Type (Typ) then
6937          Utyp := Corresponding_Record_Type (Typ);
6938          Atyp := Empty;
6939          Ref  := Convert_Concurrent (Obj_Ref, Typ);
6940
6941       elsif Is_Private_Type (Typ)
6942         and then Present (Full_View (Typ))
6943         and then Is_Concurrent_Type (Full_View (Typ))
6944       then
6945          Utyp := Corresponding_Record_Type (Full_View (Typ));
6946          Atyp := Typ;
6947          Ref  := Convert_Concurrent (Obj_Ref, Full_View (Typ));
6948
6949       else
6950          Utyp := Typ;
6951          Atyp := Typ;
6952          Ref  := Obj_Ref;
6953       end if;
6954
6955       Utyp := Underlying_Type (Base_Type (Utyp));
6956       Set_Assignment_OK (Ref);
6957
6958       --  Deal with non-tagged derivation of private views. If the parent type
6959       --  is a protected type, Deep_Finalize is found on the corresponding
6960       --  record of the ancestor.
6961
6962       if Is_Untagged_Derivation (Typ) then
6963          if Is_Protected_Type (Typ) then
6964             Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
6965          else
6966             Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
6967
6968             if Is_Protected_Type (Utyp) then
6969                Utyp := Corresponding_Record_Type (Utyp);
6970             end if;
6971          end if;
6972
6973          Ref := Unchecked_Convert_To (Utyp, Ref);
6974          Set_Assignment_OK (Ref);
6975       end if;
6976
6977       --  Deal with derived private types which do not inherit primitives from
6978       --  their parents. In this case, [Deep_]Finalize can be found in the full
6979       --  view of the parent type.
6980
6981       if Is_Tagged_Type (Utyp)
6982         and then Is_Derived_Type (Utyp)
6983         and then Is_Empty_Elmt_List (Primitive_Operations (Utyp))
6984         and then Is_Private_Type (Etype (Utyp))
6985         and then Present (Full_View (Etype (Utyp)))
6986       then
6987          Utyp := Full_View (Etype (Utyp));
6988          Ref  := Unchecked_Convert_To (Utyp, Ref);
6989          Set_Assignment_OK (Ref);
6990       end if;
6991
6992       --  When dealing with the completion of a private type, use the base type
6993       --  instead.
6994
6995       if Utyp /= Base_Type (Utyp) then
6996          pragma Assert (Present (Atyp) and then Is_Private_Type (Atyp));
6997
6998          Utyp := Base_Type (Utyp);
6999          Ref  := Unchecked_Convert_To (Utyp, Ref);
7000          Set_Assignment_OK (Ref);
7001       end if;
7002
7003       --  Select the appropriate version of Finalize
7004
7005       if For_Parent then
7006          if Has_Controlled_Component (Utyp) then
7007             Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
7008          end if;
7009
7010       --  Class-wide types, interfaces and types with controlled components
7011
7012       elsif Is_Class_Wide_Type (Typ)
7013         or else Is_Interface (Typ)
7014         or else Has_Controlled_Component (Utyp)
7015       then
7016          if Is_Tagged_Type (Utyp) then
7017             Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
7018          else
7019             Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
7020          end if;
7021
7022       --  Derivations from [Limited_]Controlled
7023
7024       elsif Is_Controlled (Utyp) then
7025          if Has_Controlled_Component (Utyp) then
7026             Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
7027          else
7028             Fin_Id := Find_Prim_Op (Utyp, Name_Of (Finalize_Case));
7029          end if;
7030
7031       --  Tagged types
7032
7033       elsif Is_Tagged_Type (Utyp) then
7034          Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
7035
7036       else
7037          raise Program_Error;
7038       end if;
7039
7040       if Present (Fin_Id) then
7041
7042          --  When finalizing a class-wide object, do not convert to the root
7043          --  type in order to produce a dispatching call.
7044
7045          if Is_Class_Wide_Type (Typ) then
7046             null;
7047
7048          --  Ensure that a finalization routine is at least decorated in order
7049          --  to inspect the object parameter.
7050
7051          elsif Analyzed (Fin_Id)
7052            or else Ekind (Fin_Id) = E_Procedure
7053          then
7054             --  In certain cases, such as the creation of Stream_Read, the
7055             --  visible entity of the type is its full view. Since Stream_Read
7056             --  will have to create an object of type Typ, the local object
7057             --  will be finalzed by the scope finalizer generated later on. The
7058             --  object parameter of Deep_Finalize will always use the private
7059             --  view of the type. To avoid such a clash between a private and a
7060             --  full view, perform an unchecked conversion of the object
7061             --  reference to the private view.
7062
7063             declare
7064                Formal_Typ : constant Entity_Id :=
7065                               Etype (First_Formal (Fin_Id));
7066             begin
7067                if Is_Private_Type (Formal_Typ)
7068                  and then Present (Full_View (Formal_Typ))
7069                  and then Full_View (Formal_Typ) = Utyp
7070                then
7071                   Ref := Unchecked_Convert_To (Formal_Typ, Ref);
7072                end if;
7073             end;
7074
7075             Ref := Convert_View (Fin_Id, Ref);
7076          end if;
7077
7078          return Make_Call (Loc, Fin_Id, New_Copy_Tree (Ref), For_Parent);
7079       else
7080          return Empty;
7081       end if;
7082    end Make_Final_Call;
7083
7084    --------------------------------
7085    -- Make_Finalize_Address_Body --
7086    --------------------------------
7087
7088    procedure Make_Finalize_Address_Body (Typ : Entity_Id) is
7089       Is_Task : constant Boolean :=
7090                   Ekind (Typ) = E_Record_Type
7091                     and then Is_Concurrent_Record_Type (Typ)
7092                     and then Ekind (Corresponding_Concurrent_Type (Typ)) =
7093                                E_Task_Type;
7094       Loc     : constant Source_Ptr := Sloc (Typ);
7095       Proc_Id : Entity_Id;
7096       Stmts   : List_Id;
7097
7098    begin
7099       --  The corresponding records of task types are not controlled by design.
7100       --  For the sake of completeness, create an empty Finalize_Address to be
7101       --  used in task class-wide allocations.
7102
7103       if Is_Task then
7104          null;
7105
7106       --  Nothing to do if the type is not controlled or it already has a
7107       --  TSS entry for Finalize_Address. Skip class-wide subtypes which do not
7108       --  come from source. These are usually generated for completeness and
7109       --  do not need the Finalize_Address primitive.
7110
7111       elsif not Needs_Finalization (Typ)
7112         or else Is_Abstract_Type (Typ)
7113         or else Present (TSS (Typ, TSS_Finalize_Address))
7114         or else
7115           (Is_Class_Wide_Type (Typ)
7116             and then Ekind (Root_Type (Typ)) = E_Record_Subtype
7117             and then not Comes_From_Source (Root_Type (Typ)))
7118       then
7119          return;
7120       end if;
7121
7122       Proc_Id :=
7123         Make_Defining_Identifier (Loc,
7124           Make_TSS_Name (Typ, TSS_Finalize_Address));
7125
7126       --  Generate:
7127
7128       --    procedure <Typ>FD (V : System.Address) is
7129       --    begin
7130       --       null;                            --  for tasks
7131
7132       --       declare                          --  for all other types
7133       --          type Pnn is access all Typ;
7134       --          for Pnn'Storage_Size use 0;
7135       --       begin
7136       --          [Deep_]Finalize (Pnn (V).all);
7137       --       end;
7138       --    end TypFD;
7139
7140       if Is_Task then
7141          Stmts := New_List (Make_Null_Statement (Loc));
7142       else
7143          Stmts := Make_Finalize_Address_Stmts (Typ);
7144       end if;
7145
7146       Discard_Node (
7147         Make_Subprogram_Body (Loc,
7148           Specification =>
7149             Make_Procedure_Specification (Loc,
7150               Defining_Unit_Name => Proc_Id,
7151
7152               Parameter_Specifications => New_List (
7153                 Make_Parameter_Specification (Loc,
7154                   Defining_Identifier =>
7155                     Make_Defining_Identifier (Loc, Name_V),
7156                   Parameter_Type =>
7157                     New_Reference_To (RTE (RE_Address), Loc)))),
7158
7159           Declarations => No_List,
7160
7161           Handled_Statement_Sequence =>
7162             Make_Handled_Sequence_Of_Statements (Loc,
7163               Statements => Stmts)));
7164
7165       Set_TSS (Typ, Proc_Id);
7166    end Make_Finalize_Address_Body;
7167
7168    ---------------------------------
7169    -- Make_Finalize_Address_Stmts --
7170    ---------------------------------
7171
7172    function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id is
7173       Loc      : constant Source_Ptr := Sloc (Typ);
7174       Ptr_Typ  : constant Entity_Id  := Make_Temporary (Loc, 'P');
7175       Decls    : List_Id;
7176       Desg_Typ : Entity_Id;
7177       Obj_Expr : Node_Id;
7178
7179    begin
7180       if Is_Array_Type (Typ) then
7181          if Is_Constrained (First_Subtype (Typ)) then
7182             Desg_Typ := First_Subtype (Typ);
7183          else
7184             Desg_Typ := Base_Type (Typ);
7185          end if;
7186
7187       --  Class-wide types of constrained root types
7188
7189       elsif Is_Class_Wide_Type (Typ)
7190         and then Has_Discriminants (Root_Type (Typ))
7191         and then not
7192           Is_Empty_Elmt_List (Discriminant_Constraint (Root_Type (Typ)))
7193       then
7194          declare
7195             Parent_Typ : Entity_Id;
7196
7197          begin
7198             --  Climb the parent type chain looking for a non-constrained type
7199
7200             Parent_Typ := Root_Type (Typ);
7201             while Parent_Typ /= Etype (Parent_Typ)
7202               and then Has_Discriminants (Parent_Typ)
7203               and then not
7204                 Is_Empty_Elmt_List (Discriminant_Constraint (Parent_Typ))
7205             loop
7206                Parent_Typ := Etype (Parent_Typ);
7207             end loop;
7208
7209             --  Handle views created for tagged types with unknown
7210             --  discriminants.
7211
7212             if Is_Underlying_Record_View (Parent_Typ) then
7213                Parent_Typ := Underlying_Record_View (Parent_Typ);
7214             end if;
7215
7216             Desg_Typ := Class_Wide_Type (Underlying_Type (Parent_Typ));
7217          end;
7218
7219       --  General case
7220
7221       else
7222          Desg_Typ := Typ;
7223       end if;
7224
7225       --  Generate:
7226       --    type Ptr_Typ is access all Typ;
7227       --    for Ptr_Typ'Storage_Size use 0;
7228
7229       Decls := New_List (
7230         Make_Full_Type_Declaration (Loc,
7231           Defining_Identifier => Ptr_Typ,
7232           Type_Definition     =>
7233             Make_Access_To_Object_Definition (Loc,
7234               All_Present        => True,
7235               Subtype_Indication => New_Reference_To (Desg_Typ, Loc))),
7236
7237         Make_Attribute_Definition_Clause (Loc,
7238           Name       => New_Reference_To (Ptr_Typ, Loc),
7239           Chars      => Name_Storage_Size,
7240           Expression => Make_Integer_Literal (Loc, 0)));
7241
7242       Obj_Expr := Make_Identifier (Loc, Name_V);
7243
7244       --  Unconstrained arrays require special processing in order to retrieve
7245       --  the elements. To achieve this, we have to skip the dope vector which
7246       --  lays in front of the elements and then use a thin pointer to perform
7247       --  the address-to-access conversion.
7248
7249       if Is_Array_Type (Typ)
7250         and then not Is_Constrained (First_Subtype (Typ))
7251       then
7252          declare
7253             Dope_Id : Entity_Id;
7254
7255          begin
7256             --  Ensure that Ptr_Typ a thin pointer, generate:
7257             --    for Ptr_Typ'Size use System.Address'Size;
7258
7259             Append_To (Decls,
7260               Make_Attribute_Definition_Clause (Loc,
7261                 Name       => New_Reference_To (Ptr_Typ, Loc),
7262                 Chars      => Name_Size,
7263                 Expression =>
7264                   Make_Integer_Literal (Loc, System_Address_Size)));
7265
7266             --  Generate:
7267             --    Dnn : constant Storage_Offset :=
7268             --            Desg_Typ'Descriptor_Size / Storage_Unit;
7269
7270             Dope_Id := Make_Temporary (Loc, 'D');
7271
7272             Append_To (Decls,
7273               Make_Object_Declaration (Loc,
7274                 Defining_Identifier => Dope_Id,
7275                 Constant_Present    => True,
7276                 Object_Definition   =>
7277                   New_Reference_To (RTE (RE_Storage_Offset), Loc),
7278                 Expression          =>
7279                   Make_Op_Divide (Loc,
7280                     Left_Opnd  =>
7281                       Make_Attribute_Reference (Loc,
7282                         Prefix         => New_Reference_To (Desg_Typ, Loc),
7283                         Attribute_Name => Name_Descriptor_Size),
7284                     Right_Opnd =>
7285                       Make_Integer_Literal (Loc, System_Storage_Unit))));
7286
7287             --  Shift the address from the start of the dope vector to the
7288             --  start of the elements:
7289             --
7290             --    V + Dnn
7291             --
7292             --  Note that this is done through a wrapper routine since RTSfind
7293             --  cannot retrieve operations with string names of the form "+".
7294
7295             Obj_Expr :=
7296               Make_Function_Call (Loc,
7297                 Name                   =>
7298                   New_Reference_To (RTE (RE_Add_Offset_To_Address), Loc),
7299                 Parameter_Associations => New_List (
7300                   Obj_Expr,
7301                   New_Reference_To (Dope_Id, Loc)));
7302          end;
7303       end if;
7304
7305       --  Create the block and the finalization call
7306
7307       return New_List (
7308         Make_Block_Statement (Loc,
7309           Declarations => Decls,
7310
7311           Handled_Statement_Sequence =>
7312             Make_Handled_Sequence_Of_Statements (Loc,
7313               Statements => New_List (
7314                 Make_Final_Call (
7315                   Obj_Ref =>
7316                     Make_Explicit_Dereference (Loc,
7317                       Prefix => Unchecked_Convert_To (Ptr_Typ, Obj_Expr)),
7318                   Typ => Desg_Typ)))));
7319    end Make_Finalize_Address_Stmts;
7320
7321    -------------------------------------
7322    -- Make_Handler_For_Ctrl_Operation --
7323    -------------------------------------
7324
7325    --  Generate:
7326
7327    --    when E : others =>
7328    --      Raise_From_Controlled_Operation (E);
7329
7330    --  or:
7331
7332    --    when others =>
7333    --      raise Program_Error [finalize raised exception];
7334
7335    --  depending on whether Raise_From_Controlled_Operation is available
7336
7337    function Make_Handler_For_Ctrl_Operation
7338      (Loc : Source_Ptr) return Node_Id
7339    is
7340       E_Occ : Entity_Id;
7341       --  Choice parameter (for the first case above)
7342
7343       Raise_Node : Node_Id;
7344       --  Procedure call or raise statement
7345
7346    begin
7347       --  Standard run-time, .NET/JVM targets: add choice parameter E and pass
7348       --  it to Raise_From_Controlled_Operation so that the original exception
7349       --  name and message can be recorded in the exception message for
7350       --  Program_Error.
7351
7352       if RTE_Available (RE_Raise_From_Controlled_Operation) then
7353          E_Occ := Make_Defining_Identifier (Loc, Name_E);
7354          Raise_Node :=
7355            Make_Procedure_Call_Statement (Loc,
7356              Name                   =>
7357                New_Reference_To
7358                  (RTE (RE_Raise_From_Controlled_Operation), Loc),
7359              Parameter_Associations => New_List (
7360                New_Reference_To (E_Occ, Loc)));
7361
7362       --  Restricted run-time: exception messages are not supported
7363
7364       else
7365          E_Occ := Empty;
7366          Raise_Node :=
7367            Make_Raise_Program_Error (Loc,
7368              Reason => PE_Finalize_Raised_Exception);
7369       end if;
7370
7371       return
7372         Make_Implicit_Exception_Handler (Loc,
7373           Exception_Choices => New_List (Make_Others_Choice (Loc)),
7374           Choice_Parameter  => E_Occ,
7375           Statements        => New_List (Raise_Node));
7376    end Make_Handler_For_Ctrl_Operation;
7377
7378    --------------------
7379    -- Make_Init_Call --
7380    --------------------
7381
7382    function Make_Init_Call
7383      (Obj_Ref : Node_Id;
7384       Typ     : Entity_Id) return Node_Id
7385    is
7386       Loc     : constant Source_Ptr := Sloc (Obj_Ref);
7387       Is_Conc : Boolean;
7388       Proc    : Entity_Id;
7389       Ref     : Node_Id;
7390       Utyp    : Entity_Id;
7391
7392    begin
7393       --  Deal with the type and object reference. Depending on the context, an
7394       --  object reference may need several conversions.
7395
7396       if Is_Concurrent_Type (Typ) then
7397          Is_Conc := True;
7398          Utyp    := Corresponding_Record_Type (Typ);
7399          Ref     := Convert_Concurrent (Obj_Ref, Typ);
7400
7401       elsif Is_Private_Type (Typ)
7402         and then Present (Full_View (Typ))
7403         and then Is_Concurrent_Type (Underlying_Type (Typ))
7404       then
7405          Is_Conc := True;
7406          Utyp    := Corresponding_Record_Type (Underlying_Type (Typ));
7407          Ref     := Convert_Concurrent (Obj_Ref, Underlying_Type (Typ));
7408
7409       else
7410          Is_Conc := False;
7411          Utyp    := Typ;
7412          Ref     := Obj_Ref;
7413       end if;
7414
7415       Set_Assignment_OK (Ref);
7416
7417       Utyp := Underlying_Type (Base_Type (Utyp));
7418
7419       --  Deal with non-tagged derivation of private views
7420
7421       if Is_Untagged_Derivation (Typ)
7422         and then not Is_Conc
7423       then
7424          Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
7425          Ref  := Unchecked_Convert_To (Utyp, Ref);
7426
7427          --  The following is to prevent problems with UC see 1.156 RH ???
7428
7429          Set_Assignment_OK (Ref);
7430       end if;
7431
7432       --  If the underlying_type is a subtype, then we are dealing with the
7433       --  completion of a private type. We need to access the base type and
7434       --  generate a conversion to it.
7435
7436       if Utyp /= Base_Type (Utyp) then
7437          pragma Assert (Is_Private_Type (Typ));
7438          Utyp := Base_Type (Utyp);
7439          Ref  := Unchecked_Convert_To (Utyp, Ref);
7440       end if;
7441
7442       --  Select the appropriate version of initialize
7443
7444       if Has_Controlled_Component (Utyp) then
7445          Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case));
7446       else
7447          Proc := Find_Prim_Op (Utyp, Name_Of (Initialize_Case));
7448          Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Ref);
7449       end if;
7450
7451       --  The object reference may need another conversion depending on the
7452       --  type of the formal and that of the actual.
7453
7454       Ref := Convert_View (Proc, Ref);
7455
7456       --  Generate:
7457       --    [Deep_]Initialize (Ref);
7458
7459       return
7460         Make_Procedure_Call_Statement (Loc,
7461           Name =>
7462             New_Reference_To (Proc, Loc),
7463           Parameter_Associations => New_List (Ref));
7464    end Make_Init_Call;
7465
7466    ------------------------------
7467    -- Make_Local_Deep_Finalize --
7468    ------------------------------
7469
7470    function Make_Local_Deep_Finalize
7471      (Typ : Entity_Id;
7472       Nam : Entity_Id) return Node_Id
7473    is
7474       Loc : constant Source_Ptr := Sloc (Typ);
7475       Formals : List_Id;
7476
7477    begin
7478       Formals := New_List (
7479
7480          --  V : in out Typ
7481
7482         Make_Parameter_Specification (Loc,
7483           Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
7484           In_Present          => True,
7485           Out_Present         => True,
7486           Parameter_Type      => New_Reference_To (Typ, Loc)),
7487
7488          --  F : Boolean := True
7489
7490         Make_Parameter_Specification (Loc,
7491           Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
7492           Parameter_Type      => New_Reference_To (Standard_Boolean, Loc),
7493           Expression          => New_Reference_To (Standard_True, Loc)));
7494
7495       --  Add the necessary number of counters to represent the initialization
7496       --  state of an object.
7497
7498       return
7499         Make_Subprogram_Body (Loc,
7500           Specification =>
7501             Make_Procedure_Specification (Loc,
7502               Defining_Unit_Name       => Nam,
7503               Parameter_Specifications => Formals),
7504
7505           Declarations => No_List,
7506
7507           Handled_Statement_Sequence =>
7508             Make_Handled_Sequence_Of_Statements (Loc,
7509               Statements => Make_Deep_Record_Body (Finalize_Case, Typ, True)));
7510    end Make_Local_Deep_Finalize;
7511
7512    ------------------------------------
7513    -- Make_Set_Finalize_Address_Call --
7514    ------------------------------------
7515
7516    function Make_Set_Finalize_Address_Call
7517      (Loc     : Source_Ptr;
7518       Typ     : Entity_Id;
7519       Ptr_Typ : Entity_Id) return Node_Id
7520    is
7521       Desig_Typ   : constant Entity_Id :=
7522                       Available_View (Designated_Type (Ptr_Typ));
7523       Fin_Mas_Id  : constant Entity_Id := Finalization_Master (Ptr_Typ);
7524       Fin_Mas_Ref : Node_Id;
7525       Utyp        : Entity_Id;
7526
7527    begin
7528       --  If the context is a class-wide allocator, we use the class-wide type
7529       --  to obtain the proper Finalize_Address routine.
7530
7531       if Is_Class_Wide_Type (Desig_Typ) then
7532          Utyp := Desig_Typ;
7533
7534       else
7535          Utyp := Typ;
7536
7537          if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then
7538             Utyp := Full_View (Utyp);
7539          end if;
7540
7541          if Is_Concurrent_Type (Utyp) then
7542             Utyp := Corresponding_Record_Type (Utyp);
7543          end if;
7544       end if;
7545
7546       Utyp := Underlying_Type (Base_Type (Utyp));
7547
7548       --  Deal with non-tagged derivation of private views. If the parent is
7549       --  now known to be protected, the finalization routine is the one
7550       --  defined on the corresponding record of the ancestor (corresponding
7551       --  records do not automatically inherit operations, but maybe they
7552       --  should???)
7553
7554       if Is_Untagged_Derivation (Typ) then
7555          if Is_Protected_Type (Typ) then
7556             Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
7557          else
7558             Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
7559
7560             if Is_Protected_Type (Utyp) then
7561                Utyp := Corresponding_Record_Type (Utyp);
7562             end if;
7563          end if;
7564       end if;
7565
7566       --  If the underlying_type is a subtype, we are dealing with the
7567       --  completion of a private type. We need to access the base type and
7568       --  generate a conversion to it.
7569
7570       if Utyp /= Base_Type (Utyp) then
7571          pragma Assert (Is_Private_Type (Typ));
7572
7573          Utyp := Base_Type (Utyp);
7574       end if;
7575
7576       Fin_Mas_Ref := New_Occurrence_Of (Fin_Mas_Id, Loc);
7577
7578       --  If the call is from a build-in-place function, the Master parameter
7579       --  is actually a pointer. Dereference it for the call.
7580
7581       if Is_Access_Type (Etype (Fin_Mas_Id)) then
7582          Fin_Mas_Ref := Make_Explicit_Dereference (Loc, Fin_Mas_Ref);
7583       end if;
7584
7585       --  Generate:
7586       --    Set_Finalize_Address (<Ptr_Typ>FM, <Utyp>FD'Unrestricted_Access);
7587
7588       return
7589         Make_Procedure_Call_Statement (Loc,
7590           Name                   =>
7591             New_Reference_To (RTE (RE_Set_Finalize_Address), Loc),
7592           Parameter_Associations => New_List (
7593             Fin_Mas_Ref,
7594             Make_Attribute_Reference (Loc,
7595               Prefix         =>
7596                 New_Reference_To (TSS (Utyp, TSS_Finalize_Address), Loc),
7597               Attribute_Name => Name_Unrestricted_Access)));
7598    end Make_Set_Finalize_Address_Call;
7599
7600    --------------------------
7601    -- Make_Transient_Block --
7602    --------------------------
7603
7604    function Make_Transient_Block
7605      (Loc    : Source_Ptr;
7606       Action : Node_Id;
7607       Par    : Node_Id) return Node_Id
7608    is
7609       Decls  : constant List_Id := New_List;
7610       Instrs : constant List_Id := New_List (Action);
7611       Block  : Node_Id;
7612       Insert : Node_Id;
7613
7614    begin
7615       --  Case where only secondary stack use is involved
7616
7617       if VM_Target = No_VM
7618         and then Uses_Sec_Stack (Current_Scope)
7619         and then Nkind (Action) /= N_Simple_Return_Statement
7620         and then Nkind (Par) /= N_Exception_Handler
7621       then
7622          declare
7623             S : Entity_Id;
7624
7625          begin
7626             S := Scope (Current_Scope);
7627             loop
7628                --  At the outer level, no need to release the sec stack
7629
7630                if S = Standard_Standard then
7631                   Set_Uses_Sec_Stack (Current_Scope, False);
7632                   exit;
7633
7634                --  In a function, only release the sec stack if the function
7635                --  does not return on the sec stack otherwise the result may
7636                --  be lost. The caller is responsible for releasing.
7637
7638                elsif Ekind (S) = E_Function then
7639                   Set_Uses_Sec_Stack (Current_Scope, False);
7640
7641                   if not Requires_Transient_Scope (Etype (S)) then
7642                      Set_Uses_Sec_Stack (S, True);
7643                      Check_Restriction (No_Secondary_Stack, Action);
7644                   end if;
7645
7646                   exit;
7647
7648                --  In a loop or entry we should install a block encompassing
7649                --  all the construct. For now just release right away.
7650
7651                elsif Ekind_In (S, E_Entry, E_Loop) then
7652                   exit;
7653
7654                --  In a procedure or a block, we release on exit of the
7655                --  procedure or block. ??? memory leak can be created by
7656                --  recursive calls.
7657
7658                elsif Ekind_In (S, E_Block, E_Procedure) then
7659                   Set_Uses_Sec_Stack (S, True);
7660                   Check_Restriction (No_Secondary_Stack, Action);
7661                   Set_Uses_Sec_Stack (Current_Scope, False);
7662                   exit;
7663
7664                else
7665                   S := Scope (S);
7666                end if;
7667             end loop;
7668          end;
7669       end if;
7670
7671       --  Create the transient block. Set the parent now since the block itself
7672       --  is not part of the tree.
7673
7674       Block :=
7675         Make_Block_Statement (Loc,
7676           Identifier                 => New_Reference_To (Current_Scope, Loc),
7677           Declarations               => Decls,
7678           Handled_Statement_Sequence =>
7679             Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs),
7680           Has_Created_Identifier     => True);
7681       Set_Parent (Block, Par);
7682
7683       --  Insert actions stuck in the transient scopes as well as all freezing
7684       --  nodes needed by those actions.
7685
7686       Insert_Actions_In_Scope_Around (Action);
7687
7688       Insert := Prev (Action);
7689       if Present (Insert) then
7690          Freeze_All (First_Entity (Current_Scope), Insert);
7691       end if;
7692
7693       --  When the transient scope was established, we pushed the entry for the
7694       --  transient scope onto the scope stack, so that the scope was active
7695       --  for the installation of finalizable entities etc. Now we must remove
7696       --  this entry, since we have constructed a proper block.
7697
7698       Pop_Scope;
7699
7700       return Block;
7701    end Make_Transient_Block;
7702
7703    ------------------------
7704    -- Node_To_Be_Wrapped --
7705    ------------------------
7706
7707    function Node_To_Be_Wrapped return Node_Id is
7708    begin
7709       return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped;
7710    end Node_To_Be_Wrapped;
7711
7712    ----------------------------
7713    -- Set_Node_To_Be_Wrapped --
7714    ----------------------------
7715
7716    procedure Set_Node_To_Be_Wrapped (N : Node_Id) is
7717    begin
7718       Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := N;
7719    end Set_Node_To_Be_Wrapped;
7720
7721    ----------------------------------
7722    -- Store_After_Actions_In_Scope --
7723    ----------------------------------
7724
7725    procedure Store_After_Actions_In_Scope (L : List_Id) is
7726       SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
7727
7728    begin
7729       if Present (SE.Actions_To_Be_Wrapped_After) then
7730          Insert_List_Before_And_Analyze (
7731           First (SE.Actions_To_Be_Wrapped_After), L);
7732
7733       else
7734          SE.Actions_To_Be_Wrapped_After := L;
7735
7736          if Is_List_Member (SE.Node_To_Be_Wrapped) then
7737             Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
7738          else
7739             Set_Parent (L, SE.Node_To_Be_Wrapped);
7740          end if;
7741
7742          Analyze_List (L);
7743       end if;
7744    end Store_After_Actions_In_Scope;
7745
7746    -----------------------------------
7747    -- Store_Before_Actions_In_Scope --
7748    -----------------------------------
7749
7750    procedure Store_Before_Actions_In_Scope (L : List_Id) is
7751       SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
7752
7753    begin
7754       if Present (SE.Actions_To_Be_Wrapped_Before) then
7755          Insert_List_After_And_Analyze (
7756            Last (SE.Actions_To_Be_Wrapped_Before), L);
7757
7758       else
7759          SE.Actions_To_Be_Wrapped_Before := L;
7760
7761          if Is_List_Member (SE.Node_To_Be_Wrapped) then
7762             Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
7763          else
7764             Set_Parent (L, SE.Node_To_Be_Wrapped);
7765          end if;
7766
7767          Analyze_List (L);
7768       end if;
7769    end Store_Before_Actions_In_Scope;
7770
7771    --------------------------------
7772    -- Wrap_Transient_Declaration --
7773    --------------------------------
7774
7775    --  If a transient scope has been established during the processing of the
7776    --  Expression of an Object_Declaration, it is not possible to wrap the
7777    --  declaration into a transient block as usual case, otherwise the object
7778    --  would be itself declared in the wrong scope. Therefore, all entities (if
7779    --  any) defined in the transient block are moved to the proper enclosing
7780    --  scope, furthermore, if they are controlled variables they are finalized
7781    --  right after the declaration. The finalization list of the transient
7782    --  scope is defined as a renaming of the enclosing one so during their
7783    --  initialization they will be attached to the proper finalization list.
7784    --  For instance, the following declaration :
7785
7786    --        X : Typ := F (G (A), G (B));
7787
7788    --  (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
7789    --  is expanded into :
7790
7791    --    X : Typ := [ complex Expression-Action ];
7792    --    [Deep_]Finalize (_v1);
7793    --    [Deep_]Finalize (_v2);
7794
7795    procedure Wrap_Transient_Declaration (N : Node_Id) is
7796       Encl_S  : Entity_Id;
7797       S       : Entity_Id;
7798       Uses_SS : Boolean;
7799
7800    begin
7801       S := Current_Scope;
7802       Encl_S := Scope (S);
7803
7804       --  Insert Actions kept in the Scope stack
7805
7806       Insert_Actions_In_Scope_Around (N);
7807
7808       --  If the declaration is consuming some secondary stack, mark the
7809       --  enclosing scope appropriately.
7810
7811       Uses_SS := Uses_Sec_Stack (S);
7812       Pop_Scope;
7813
7814       --  Put the local entities back in the enclosing scope, and set the
7815       --  Is_Public flag appropriately.
7816
7817       Transfer_Entities (S, Encl_S);
7818
7819       --  Mark the enclosing dynamic scope so that the sec stack will be
7820       --  released upon its exit unless this is a function that returns on
7821       --  the sec stack in which case this will be done by the caller.
7822
7823       if VM_Target = No_VM and then Uses_SS then
7824          S := Enclosing_Dynamic_Scope (S);
7825
7826          if Ekind (S) = E_Function
7827            and then Requires_Transient_Scope (Etype (S))
7828          then
7829             null;
7830          else
7831             Set_Uses_Sec_Stack (S);
7832             Check_Restriction (No_Secondary_Stack, N);
7833          end if;
7834       end if;
7835    end Wrap_Transient_Declaration;
7836
7837    -------------------------------
7838    -- Wrap_Transient_Expression --
7839    -------------------------------
7840
7841    procedure Wrap_Transient_Expression (N : Node_Id) is
7842       Expr : constant Node_Id    := Relocate_Node (N);
7843       Loc  : constant Source_Ptr := Sloc (N);
7844       Temp : constant Entity_Id  := Make_Temporary (Loc, 'E', N);
7845       Typ  : constant Entity_Id  := Etype (N);
7846
7847    begin
7848       --  Generate:
7849
7850       --    Temp : Typ;
7851       --    declare
7852       --       M : constant Mark_Id := SS_Mark;
7853       --       procedure Finalizer is ...  (See Build_Finalizer)
7854
7855       --    begin
7856       --       Temp := <Expr>;
7857       --
7858       --    at end
7859       --       Finalizer;
7860       --    end;
7861
7862       Insert_Actions (N, New_List (
7863         Make_Object_Declaration (Loc,
7864           Defining_Identifier => Temp,
7865           Object_Definition   => New_Reference_To (Typ, Loc)),
7866
7867         Make_Transient_Block (Loc,
7868           Action =>
7869             Make_Assignment_Statement (Loc,
7870               Name       => New_Reference_To (Temp, Loc),
7871               Expression => Expr),
7872           Par    => Parent (N))));
7873
7874       Rewrite (N, New_Reference_To (Temp, Loc));
7875       Analyze_And_Resolve (N, Typ);
7876    end Wrap_Transient_Expression;
7877
7878    ------------------------------
7879    -- Wrap_Transient_Statement --
7880    ------------------------------
7881
7882    procedure Wrap_Transient_Statement (N : Node_Id) is
7883       Loc      : constant Source_Ptr := Sloc (N);
7884       New_Stmt : constant Node_Id    := Relocate_Node (N);
7885
7886    begin
7887       --  Generate:
7888       --    declare
7889       --       M : constant Mark_Id := SS_Mark;
7890       --       procedure Finalizer is ...  (See Build_Finalizer)
7891       --
7892       --    begin
7893       --       <New_Stmt>;
7894       --
7895       --    at end
7896       --       Finalizer;
7897       --    end;
7898
7899       Rewrite (N,
7900         Make_Transient_Block (Loc,
7901           Action => New_Stmt,
7902           Par    => Parent (N)));
7903
7904       --  With the scope stack back to normal, we can call analyze on the
7905       --  resulting block. At this point, the transient scope is being
7906       --  treated like a perfectly normal scope, so there is nothing
7907       --  special about it.
7908
7909       --  Note: Wrap_Transient_Statement is called with the node already
7910       --  analyzed (i.e. Analyzed (N) is True). This is important, since
7911       --  otherwise we would get a recursive processing of the node when
7912       --  we do this Analyze call.
7913
7914       Analyze (N);
7915    end Wrap_Transient_Statement;
7916
7917 end Exp_Ch7;