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