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