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 computation of 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       Skip_Self : Boolean := False) return Node_Id;
 387    --  Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
 388    --  routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create
 389    --  an adjust or finalization call. Wnen flag Skip_Self is set, the related
 390    --  action has an effect on the components only (if any).
 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          Loc    : constant Source_Ptr := Sloc (Decl);
2070          Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
2071
2072          Init_Typ : Entity_Id;
2073          --  The initialization type of the related object declaration. Note
2074          --  that this is not necessarely the same type as Obj_Typ because of
2075          --  possible type derivations.
2076
2077          Obj_Typ : Entity_Id;
2078          --  The type of the related object declaration
2079
2080          function Build_BIP_Cleanup_Stmts (Func_Id : Entity_Id) return Node_Id;
2081          --  Func_Id denotes a build-in-place function. Generate the following
2082          --  cleanup code:
2083          --
2084          --    if BIPallocfrom > Secondary_Stack'Pos
2085          --      and then BIPfinalizationmaster /= null
2086          --    then
2087          --       declare
2088          --          type Ptr_Typ is access Obj_Typ;
2089          --          for Ptr_Typ'Storage_Pool
2090          --            use Base_Pool (BIPfinalizationmaster);
2091          --       begin
2092          --          Free (Ptr_Typ (Temp));
2093          --       end;
2094          --    end if;
2095          --
2096          --  Obj_Typ is the type of the current object, Temp is the original
2097          --  allocation which Obj_Id renames.
2098
2099          procedure Find_Last_Init
2100            (Last_Init   : out Node_Id;
2101             Body_Insert : out Node_Id);
2102          --  Find the last initialization call related to object declaration
2103          --  Decl. Last_Init denotes the last initialization call which follows
2104          --  Decl. Body_Insert denotes a node where the finalizer body could be
2105          --  potentially inserted after (if blocks are involved).
2106
2107          -----------------------------
2108          -- Build_BIP_Cleanup_Stmts --
2109          -----------------------------
2110
2111          function Build_BIP_Cleanup_Stmts
2112            (Func_Id : Entity_Id) return Node_Id
2113          is
2114             Decls      : constant List_Id := New_List;
2115             Fin_Mas_Id : constant Entity_Id :=
2116                            Build_In_Place_Formal
2117                              (Func_Id, BIP_Finalization_Master);
2118             Func_Typ   : constant Entity_Id := Etype (Func_Id);
2119             Temp_Id    : constant Entity_Id :=
2120                            Entity (Prefix (Name (Parent (Obj_Id))));
2121
2122             Cond      : Node_Id;
2123             Free_Blk  : Node_Id;
2124             Free_Stmt : Node_Id;
2125             Pool_Id   : Entity_Id;
2126             Ptr_Typ   : Entity_Id;
2127
2128          begin
2129             --  Generate:
2130             --    Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2131
2132             Pool_Id := Make_Temporary (Loc, 'P');
2133
2134             Append_To (Decls,
2135               Make_Object_Renaming_Declaration (Loc,
2136                 Defining_Identifier => Pool_Id,
2137                 Subtype_Mark        =>
2138                   New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc),
2139                 Name                =>
2140                   Make_Explicit_Dereference (Loc,
2141                     Prefix =>
2142                       Make_Function_Call (Loc,
2143                         Name                   =>
2144                           New_Occurrence_Of (RTE (RE_Base_Pool), Loc),
2145                         Parameter_Associations => New_List (
2146                           Make_Explicit_Dereference (Loc,
2147                             Prefix =>
2148                               New_Occurrence_Of (Fin_Mas_Id, Loc)))))));
2149
2150             --  Create an access type which uses the storage pool of the
2151             --  caller's finalization master.
2152
2153             --  Generate:
2154             --    type Ptr_Typ is access Func_Typ;
2155
2156             Ptr_Typ := Make_Temporary (Loc, 'P');
2157
2158             Append_To (Decls,
2159               Make_Full_Type_Declaration (Loc,
2160                 Defining_Identifier => Ptr_Typ,
2161                 Type_Definition     =>
2162                   Make_Access_To_Object_Definition (Loc,
2163                     Subtype_Indication => New_Occurrence_Of (Func_Typ, Loc))));
2164
2165             --  Perform minor decoration in order to set the master and the
2166             --  storage pool attributes.
2167
2168             Set_Ekind (Ptr_Typ, E_Access_Type);
2169             Set_Finalization_Master     (Ptr_Typ, Fin_Mas_Id);
2170             Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
2171
2172             --  Create an explicit free statement. Note that the free uses the
2173             --  caller's pool expressed as a renaming.
2174
2175             Free_Stmt :=
2176               Make_Free_Statement (Loc,
2177                 Expression =>
2178                   Unchecked_Convert_To (Ptr_Typ,
2179                     New_Occurrence_Of (Temp_Id, Loc)));
2180
2181             Set_Storage_Pool (Free_Stmt, Pool_Id);
2182
2183             --  Create a block to house the dummy type and the instantiation as
2184             --  well as to perform the cleanup the temporary.
2185
2186             --  Generate:
2187             --    declare
2188             --       <Decls>
2189             --    begin
2190             --       Free (Ptr_Typ (Temp_Id));
2191             --    end;
2192
2193             Free_Blk :=
2194               Make_Block_Statement (Loc,
2195                 Declarations               => Decls,
2196                 Handled_Statement_Sequence =>
2197                   Make_Handled_Sequence_Of_Statements (Loc,
2198                     Statements => New_List (Free_Stmt)));
2199
2200             --  Generate:
2201             --    if BIPfinalizationmaster /= null then
2202
2203             Cond :=
2204               Make_Op_Ne (Loc,
2205                 Left_Opnd  => New_Occurrence_Of (Fin_Mas_Id, Loc),
2206                 Right_Opnd => Make_Null (Loc));
2207
2208             --  For constrained or tagged results escalate the condition to
2209             --  include the allocation format. Generate:
2210             --
2211             --    if BIPallocform > Secondary_Stack'Pos
2212             --      and then BIPfinalizationmaster /= null
2213             --    then
2214
2215             if not Is_Constrained (Func_Typ)
2216               or else Is_Tagged_Type (Func_Typ)
2217             then
2218                declare
2219                   Alloc : constant Entity_Id :=
2220                             Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
2221                begin
2222                   Cond :=
2223                     Make_And_Then (Loc,
2224                       Left_Opnd  =>
2225                         Make_Op_Gt (Loc,
2226                           Left_Opnd  => New_Occurrence_Of (Alloc, Loc),
2227                           Right_Opnd =>
2228                             Make_Integer_Literal (Loc,
2229                               UI_From_Int
2230                                 (BIP_Allocation_Form'Pos (Secondary_Stack)))),
2231
2232                       Right_Opnd => Cond);
2233                end;
2234             end if;
2235
2236             --  Generate:
2237             --    if <Cond> then
2238             --       <Free_Blk>
2239             --    end if;
2240
2241             return
2242               Make_If_Statement (Loc,
2243                 Condition       => Cond,
2244                 Then_Statements => New_List (Free_Blk));
2245          end Build_BIP_Cleanup_Stmts;
2246
2247          --------------------
2248          -- Find_Last_Init --
2249          --------------------
2250
2251          procedure Find_Last_Init
2252            (Last_Init   : out Node_Id;
2253             Body_Insert : out Node_Id)
2254          is
2255             function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id;
2256             --  Find the last initialization call within the statements of
2257             --  block Blk.
2258
2259             function Is_Init_Call (N : Node_Id) return Boolean;
2260             --  Determine whether node N denotes one of the initialization
2261             --  procedures of types Init_Typ or Obj_Typ.
2262
2263             function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id;
2264             --  Given a statement which is part of a list, return the next
2265             --  statement while skipping over dynamic elab checks.
2266
2267             -----------------------------
2268             -- Find_Last_Init_In_Block --
2269             -----------------------------
2270
2271             function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id is
2272                HSS  : constant Node_Id := Handled_Statement_Sequence (Blk);
2273                Stmt : Node_Id;
2274
2275             begin
2276                --  Examine the individual statements of the block in reverse to
2277                --  locate the last initialization call.
2278
2279                if Present (HSS) and then Present (Statements (HSS)) then
2280                   Stmt := Last (Statements (HSS));
2281                   while Present (Stmt) loop
2282
2283                      --  Peek inside nested blocks in case aborts are allowed
2284
2285                      if Nkind (Stmt) = N_Block_Statement then
2286                         return Find_Last_Init_In_Block (Stmt);
2287
2288                      elsif Is_Init_Call (Stmt) then
2289                         return Stmt;
2290                      end if;
2291
2292                      Prev (Stmt);
2293                   end loop;
2294                end if;
2295
2296                return Empty;
2297             end Find_Last_Init_In_Block;
2298
2299             ------------------
2300             -- Is_Init_Call --
2301             ------------------
2302
2303             function Is_Init_Call (N : Node_Id) return Boolean is
2304                function Is_Init_Proc_Of
2305                  (Subp_Id : Entity_Id;
2306                   Typ     : Entity_Id) return Boolean;
2307                --  Determine whether subprogram Subp_Id is a valid init proc of
2308                --  type Typ.
2309
2310                ---------------------
2311                -- Is_Init_Proc_Of --
2312                ---------------------
2313
2314                function Is_Init_Proc_Of
2315                  (Subp_Id : Entity_Id;
2316                   Typ     : Entity_Id) return Boolean
2317                is
2318                   Deep_Init : Entity_Id := Empty;
2319                   Prim_Init : Entity_Id := Empty;
2320                   Type_Init : Entity_Id := Empty;
2321
2322                begin
2323                   --  Obtain all possible initialization routines of the
2324                   --  related type and try to match the subprogram entity
2325                   --  against one of them.
2326
2327                   --  Deep_Initialize
2328
2329                   Deep_Init := TSS (Typ, TSS_Deep_Initialize);
2330
2331                   --  Primitive Initialize
2332
2333                   if Is_Controlled (Typ) then
2334                      Prim_Init := Find_Prim_Op (Typ, Name_Initialize);
2335
2336                      if Present (Prim_Init) then
2337                         Prim_Init := Ultimate_Alias (Prim_Init);
2338                      end if;
2339                   end if;
2340
2341                   --  Type initialization routine
2342
2343                   if Has_Non_Null_Base_Init_Proc (Typ) then
2344                      Type_Init := Base_Init_Proc (Typ);
2345                   end if;
2346
2347                   return
2348                     (Present (Deep_Init) and then Subp_Id = Deep_Init)
2349                       or else
2350                     (Present (Prim_Init) and then Subp_Id = Prim_Init)
2351                       or else
2352                     (Present (Type_Init) and then Subp_Id = Type_Init);
2353                end Is_Init_Proc_Of;
2354
2355                --  Local variables
2356
2357                Call_Id : Entity_Id;
2358
2359             --  Start of processing for Is_Init_Call
2360
2361             begin
2362                if Nkind (N) = N_Procedure_Call_Statement
2363                  and then Nkind (Name (N)) = N_Identifier
2364                then
2365                   Call_Id := Entity (Name (N));
2366
2367                   --  Consider both the type of the object declaration and its
2368                   --  related initialization type.
2369
2370                   return
2371                     Is_Init_Proc_Of (Call_Id, Init_Typ)
2372                       or else
2373                     Is_Init_Proc_Of (Call_Id, Obj_Typ);
2374                end if;
2375
2376                return False;
2377             end Is_Init_Call;
2378
2379             -----------------------------
2380             -- Next_Suitable_Statement --
2381             -----------------------------
2382
2383             function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id is
2384                Result : Node_Id := Next (Stmt);
2385
2386             begin
2387                --  Skip over access-before-elaboration checks
2388
2389                if Dynamic_Elaboration_Checks
2390                  and then Nkind (Result) = N_Raise_Program_Error
2391                then
2392                   Result := Next (Result);
2393                end if;
2394
2395                return Result;
2396             end Next_Suitable_Statement;
2397
2398             --  Local variables
2399
2400             Call   : Node_Id;
2401             Stmt   : Node_Id;
2402             Stmt_2 : Node_Id;
2403
2404          --  Start of processing for Find_Last_Init
2405
2406          begin
2407             Last_Init   := Decl;
2408             Body_Insert := Empty;
2409
2410             --  Object renamings and objects associated with controlled
2411             --  function results do not require initialization.
2412
2413             if Has_No_Init then
2414                return;
2415             end if;
2416
2417             Stmt := Next_Suitable_Statement (Decl);
2418
2419             --  A limited controlled object initialized by a function call uses
2420             --  the build-in-place machinery to obtain its value.
2421
2422             --    Obj : Lim_Controlled_Type := Func_Call;
2423
2424             --  is expanded into
2425
2426             --    Obj  : Lim_Controlled_Type;
2427             --    type Ptr_Typ is access Lim_Controlled_Type;
2428             --    Temp : constant Ptr_Typ :=
2429             --             Func_Call
2430             --               (BIPalloc  => 1,
2431             --                BIPaccess => Obj'Unrestricted_Access)'reference;
2432
2433             --  In this scenario the declaration of the temporary acts as the
2434             --  last initialization statement.
2435
2436             if Is_Limited_Type (Obj_Typ)
2437               and then Has_Init_Expression (Decl)
2438               and then No (Expression (Decl))
2439             then
2440                while Present (Stmt) loop
2441                   if Nkind (Stmt) = N_Object_Declaration
2442                     and then Present (Expression (Stmt))
2443                     and then Is_Object_Access_BIP_Func_Call
2444                                (Expr   => Expression (Stmt),
2445                                 Obj_Id => Obj_Id)
2446                   then
2447                      Last_Init := Stmt;
2448                      exit;
2449                   end if;
2450
2451                   Next (Stmt);
2452                end loop;
2453
2454             --  In all other cases the initialization calls follow the related
2455             --  object. The general structure of object initialization built by
2456             --  routine Default_Initialize_Object is as follows:
2457
2458             --   [begin                                --  aborts allowed
2459             --       Abort_Defer;]
2460             --       Type_Init_Proc (Obj);
2461             --      [begin]                            --  exceptions allowed
2462             --          Deep_Initialize (Obj);
2463             --      [exception                         --  exceptions allowed
2464             --          when others =>
2465             --             Deep_Finalize (Obj, Self => False);
2466             --             raise;
2467             --       end;]
2468             --   [at end                               --  aborts allowed
2469             --       Abort_Undefer;
2470             --    end;]
2471
2472             --  When aborts are allowed, the initialization calls are housed
2473             --  within a block.
2474
2475             elsif Nkind (Stmt) = N_Block_Statement then
2476                Last_Init   := Find_Last_Init_In_Block (Stmt);
2477                Body_Insert := Stmt;
2478
2479             --  Otherwise the initialization calls follow the related object
2480
2481             else
2482                Stmt_2 := Next_Suitable_Statement (Stmt);
2483
2484                --  Check for an optional call to Deep_Initialize which may
2485                --  appear within a block depending on whether the object has
2486                --  controlled components.
2487
2488                if Present (Stmt_2) then
2489                   if Nkind (Stmt_2) = N_Block_Statement then
2490                      Call := Find_Last_Init_In_Block (Stmt_2);
2491
2492                      if Present (Call) then
2493                         Last_Init   := Call;
2494                         Body_Insert := Stmt_2;
2495                      end if;
2496
2497                   elsif Is_Init_Call (Stmt_2) then
2498                      Last_Init   := Stmt_2;
2499                      Body_Insert := Last_Init;
2500                   end if;
2501
2502                --  If the object lacks a call to Deep_Initialize, then it must
2503                --  have a call to its related type init proc.
2504
2505                elsif Is_Init_Call (Stmt) then
2506                   Last_Init   := Stmt;
2507                   Body_Insert := Last_Init;
2508                end if;
2509             end if;
2510          end Find_Last_Init;
2511
2512          --  Local variables
2513
2514          Body_Ins  : Node_Id;
2515          Count_Ins : Node_Id;
2516          Fin_Call  : Node_Id;
2517          Fin_Stmts : List_Id;
2518          Inc_Decl  : Node_Id;
2519          Label     : Node_Id;
2520          Label_Id  : Entity_Id;
2521          Obj_Ref   : Node_Id;
2522
2523       --  Start of processing for Process_Object_Declaration
2524
2525       begin
2526          --  Handle the object type and the reference to the object
2527
2528          Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
2529          Obj_Typ := Base_Type (Etype (Obj_Id));
2530
2531          loop
2532             if Is_Access_Type (Obj_Typ) then
2533                Obj_Typ := Directly_Designated_Type (Obj_Typ);
2534                Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
2535
2536             elsif Is_Concurrent_Type (Obj_Typ)
2537               and then Present (Corresponding_Record_Type (Obj_Typ))
2538             then
2539                Obj_Typ := Corresponding_Record_Type (Obj_Typ);
2540                Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
2541
2542             elsif Is_Private_Type (Obj_Typ)
2543               and then Present (Full_View (Obj_Typ))
2544             then
2545                Obj_Typ := Full_View (Obj_Typ);
2546                Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
2547
2548             elsif Obj_Typ /= Base_Type (Obj_Typ) then
2549                Obj_Typ := Base_Type (Obj_Typ);
2550                Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
2551
2552             else
2553                exit;
2554             end if;
2555          end loop;
2556
2557          Set_Etype (Obj_Ref, Obj_Typ);
2558
2559          --  Handle the initialization type of the object declaration
2560
2561          Init_Typ := Obj_Typ;
2562          loop
2563             if Is_Private_Type (Init_Typ)
2564               and then Present (Full_View (Init_Typ))
2565             then
2566                Init_Typ := Full_View (Init_Typ);
2567
2568             elsif Is_Untagged_Derivation (Init_Typ) then
2569                Init_Typ := Root_Type (Init_Typ);
2570
2571             else
2572                exit;
2573             end if;
2574          end loop;
2575
2576          --  Set a new value for the state counter and insert the statement
2577          --  after the object declaration. Generate:
2578
2579          --    Counter := <value>;
2580
2581          Inc_Decl :=
2582            Make_Assignment_Statement (Loc,
2583              Name       => New_Occurrence_Of (Counter_Id, Loc),
2584              Expression => Make_Integer_Literal (Loc, Counter_Val));
2585
2586          --  Insert the counter after all initialization has been done. The
2587          --  place of insertion depends on the context. If an object is being
2588          --  initialized via an aggregate, then the counter must be inserted
2589          --  after the last aggregate assignment.
2590
2591          if Ekind_In (Obj_Id, E_Constant, E_Variable)
2592            and then Present (Last_Aggregate_Assignment (Obj_Id))
2593          then
2594             Count_Ins := Last_Aggregate_Assignment (Obj_Id);
2595             Body_Ins  := Empty;
2596
2597          --  In all other cases the counter is inserted after the last call to
2598          --  either [Deep_]Initialize or the type specific init proc.
2599
2600          else
2601             Find_Last_Init (Count_Ins, Body_Ins);
2602          end if;
2603
2604          Insert_After (Count_Ins, Inc_Decl);
2605          Analyze (Inc_Decl);
2606
2607          --  If the current declaration is the last in the list, the finalizer
2608          --  body needs to be inserted after the set counter statement for the
2609          --  current object declaration. This is complicated by the fact that
2610          --  the set counter statement may appear in abort deferred block. In
2611          --  that case, the proper insertion place is after the block.
2612
2613          if No (Finalizer_Insert_Nod) then
2614
2615             --  Insertion after an abort deffered block
2616
2617             if Present (Body_Ins) then
2618                Finalizer_Insert_Nod := Body_Ins;
2619             else
2620                Finalizer_Insert_Nod := Inc_Decl;
2621             end if;
2622          end if;
2623
2624          --  Create the associated label with this object, generate:
2625
2626          --    L<counter> : label;
2627
2628          Label_Id :=
2629            Make_Identifier (Loc, New_External_Name ('L', Counter_Val));
2630          Set_Entity
2631            (Label_Id, Make_Defining_Identifier (Loc, Chars (Label_Id)));
2632          Label := Make_Label (Loc, Label_Id);
2633
2634          Prepend_To (Finalizer_Decls,
2635            Make_Implicit_Label_Declaration (Loc,
2636              Defining_Identifier => Entity (Label_Id),
2637              Label_Construct     => Label));
2638
2639          --  Create the associated jump with this object, generate:
2640
2641          --    when <counter> =>
2642          --       goto L<counter>;
2643
2644          Prepend_To (Jump_Alts,
2645            Make_Case_Statement_Alternative (Loc,
2646              Discrete_Choices => New_List (
2647                Make_Integer_Literal (Loc, Counter_Val)),
2648              Statements       => New_List (
2649                Make_Goto_Statement (Loc,
2650                  Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
2651
2652          --  Insert the jump destination, generate:
2653
2654          --     <<L<counter>>>
2655
2656          Append_To (Finalizer_Stmts, Label);
2657
2658          --  Processing for simple protected objects. Such objects require
2659          --  manual finalization of their lock managers.
2660
2661          if Is_Protected then
2662             Fin_Stmts := No_List;
2663
2664             if Is_Simple_Protected_Type (Obj_Typ) then
2665                Fin_Call := Cleanup_Protected_Object (Decl, Obj_Ref);
2666
2667                if Present (Fin_Call) then
2668                   Fin_Stmts := New_List (Fin_Call);
2669                end if;
2670
2671             elsif Has_Simple_Protected_Object (Obj_Typ) then
2672                if Is_Record_Type (Obj_Typ) then
2673                   Fin_Stmts := Cleanup_Record (Decl, Obj_Ref, Obj_Typ);
2674                elsif Is_Array_Type (Obj_Typ) then
2675                   Fin_Stmts := Cleanup_Array (Decl, Obj_Ref, Obj_Typ);
2676                end if;
2677             end if;
2678
2679             --  Generate:
2680             --    begin
2681             --       System.Tasking.Protected_Objects.Finalize_Protection
2682             --         (Obj._object);
2683
2684             --    exception
2685             --       when others =>
2686             --          null;
2687             --    end;
2688
2689             if Present (Fin_Stmts) then
2690                Append_To (Finalizer_Stmts,
2691                  Make_Block_Statement (Loc,
2692                    Handled_Statement_Sequence =>
2693                      Make_Handled_Sequence_Of_Statements (Loc,
2694                        Statements         => Fin_Stmts,
2695
2696                        Exception_Handlers => New_List (
2697                          Make_Exception_Handler (Loc,
2698                            Exception_Choices => New_List (
2699                              Make_Others_Choice (Loc)),
2700
2701                            Statements     => New_List (
2702                              Make_Null_Statement (Loc)))))));
2703             end if;
2704
2705          --  Processing for regular controlled objects
2706
2707          else
2708             --  Generate:
2709             --    [Deep_]Finalize (Obj);  --  No_Exception_Propagation
2710
2711             --    begin                   --  Exception handlers allowed
2712             --       [Deep_]Finalize (Obj);
2713
2714             --    exception
2715             --       when Id : others =>
2716             --          if not Raised then
2717             --             Raised := True;
2718             --             Save_Occurrence (E, Id);
2719             --          end if;
2720             --    end;
2721
2722             Fin_Call :=
2723               Make_Final_Call (
2724                 Obj_Ref => Obj_Ref,
2725                 Typ     => Obj_Typ);
2726
2727             --  For CodePeer, the exception handlers normally generated here
2728             --  generate complex flowgraphs which result in capacity problems.
2729             --  Omitting these handlers for CodePeer is justified as follows:
2730
2731             --    If a handler is dead, then omitting it is surely ok
2732
2733             --    If a handler is live, then CodePeer should flag the
2734             --      potentially-exception-raising construct that causes it
2735             --      to be live. That is what we are interested in, not what
2736             --      happens after the exception is raised.
2737
2738             if Exceptions_OK and not CodePeer_Mode then
2739                Fin_Stmts := New_List (
2740                  Make_Block_Statement (Loc,
2741                    Handled_Statement_Sequence =>
2742                      Make_Handled_Sequence_Of_Statements (Loc,
2743                        Statements => New_List (Fin_Call),
2744
2745                     Exception_Handlers => New_List (
2746                       Build_Exception_Handler
2747                         (Finalizer_Data, For_Package)))));
2748
2749             --  When exception handlers are prohibited, the finalization call
2750             --  appears unprotected. Any exception raised during finalization
2751             --  will bypass the circuitry which ensures the cleanup of all
2752             --  remaining objects.
2753
2754             else
2755                Fin_Stmts := New_List (Fin_Call);
2756             end if;
2757
2758             --  If we are dealing with a return object of a build-in-place
2759             --  function, generate the following cleanup statements:
2760
2761             --    if BIPallocfrom > Secondary_Stack'Pos
2762             --      and then BIPfinalizationmaster /= null
2763             --    then
2764             --       declare
2765             --          type Ptr_Typ is access Obj_Typ;
2766             --          for Ptr_Typ'Storage_Pool use
2767             --                Base_Pool (BIPfinalizationmaster.all).all;
2768             --       begin
2769             --          Free (Ptr_Typ (Temp));
2770             --       end;
2771             --    end if;
2772
2773             --  The generated code effectively detaches the temporary from the
2774             --  caller finalization master and deallocates the object. This is
2775             --  disabled on .NET/JVM because pools are not supported.
2776
2777             if VM_Target = No_VM and then Is_Return_Object (Obj_Id) then
2778                declare
2779                   Func_Id : constant Entity_Id := Enclosing_Function (Obj_Id);
2780                begin
2781                   if Is_Build_In_Place_Function (Func_Id)
2782                     and then Needs_BIP_Finalization_Master (Func_Id)
2783                   then
2784                      Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id));
2785                   end if;
2786                end;
2787             end if;
2788
2789             if Ekind_In (Obj_Id, E_Constant, E_Variable)
2790               and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
2791             then
2792                --  Temporaries created for the purpose of "exporting" a
2793                --  controlled transient out of an Expression_With_Actions (EWA)
2794                --  need guards. The following illustrates the usage of such
2795                --  temporaries.
2796
2797                --    Access_Typ : access [all] Obj_Typ;
2798                --    Temp       : Access_Typ := null;
2799                --    <Counter>  := ...;
2800
2801                --    do
2802                --       Ctrl_Trans : [access [all]] Obj_Typ := ...;
2803                --       Temp := Access_Typ (Ctrl_Trans);  --  when a pointer
2804                --         <or>
2805                --       Temp := Ctrl_Trans'Unchecked_Access;
2806                --    in ... end;
2807
2808                --  The finalization machinery does not process EWA nodes as
2809                --  this may lead to premature finalization of expressions. Note
2810                --  that Temp is marked as being properly initialized regardless
2811                --  of whether the initialization of Ctrl_Trans succeeded. Since
2812                --  a failed initialization may leave Temp with a value of null,
2813                --  add a guard to handle this case:
2814
2815                --    if Obj /= null then
2816                --       <object finalization statements>
2817                --    end if;
2818
2819                if Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
2820                                                       N_Object_Declaration
2821                then
2822                   Fin_Stmts := New_List (
2823                     Make_If_Statement (Loc,
2824                       Condition       =>
2825                         Make_Op_Ne (Loc,
2826                           Left_Opnd  => New_Occurrence_Of (Obj_Id, Loc),
2827                           Right_Opnd => Make_Null (Loc)),
2828                       Then_Statements => Fin_Stmts));
2829
2830                --  Return objects use a flag to aid in processing their
2831                --  potential finalization when the enclosing function fails
2832                --  to return properly. Generate:
2833
2834                --    if not Flag then
2835                --       <object finalization statements>
2836                --    end if;
2837
2838                else
2839                   Fin_Stmts := New_List (
2840                     Make_If_Statement (Loc,
2841                       Condition     =>
2842                         Make_Op_Not (Loc,
2843                           Right_Opnd =>
2844                             New_Occurrence_Of
2845                               (Status_Flag_Or_Transient_Decl (Obj_Id), Loc)),
2846
2847                     Then_Statements => Fin_Stmts));
2848                end if;
2849             end if;
2850          end if;
2851
2852          Append_List_To (Finalizer_Stmts, Fin_Stmts);
2853
2854          --  Since the declarations are examined in reverse, the state counter
2855          --  must be decremented in order to keep with the true position of
2856          --  objects.
2857
2858          Counter_Val := Counter_Val - 1;
2859       end Process_Object_Declaration;
2860
2861       -------------------------------------
2862       -- Process_Tagged_Type_Declaration --
2863       -------------------------------------
2864
2865       procedure Process_Tagged_Type_Declaration (Decl : Node_Id) is
2866          Typ    : constant Entity_Id := Defining_Identifier (Decl);
2867          DT_Ptr : constant Entity_Id :=
2868                     Node (First_Elmt (Access_Disp_Table (Typ)));
2869       begin
2870          --  Generate:
2871          --    Ada.Tags.Unregister_Tag (<Typ>P);
2872
2873          Append_To (Tagged_Type_Stmts,
2874            Make_Procedure_Call_Statement (Loc,
2875              Name                   =>
2876                New_Occurrence_Of (RTE (RE_Unregister_Tag), Loc),
2877              Parameter_Associations => New_List (
2878                New_Occurrence_Of (DT_Ptr, Loc))));
2879       end Process_Tagged_Type_Declaration;
2880
2881    --  Start of processing for Build_Finalizer
2882
2883    begin
2884       Fin_Id := Empty;
2885
2886       --  Do not perform this expansion in SPARK mode because it is not
2887       --  necessary.
2888
2889       if GNATprove_Mode then
2890          return;
2891       end if;
2892
2893       --  Step 1: Extract all lists which may contain controlled objects or
2894       --  library-level tagged types.
2895
2896       if For_Package_Spec then
2897          Decls      := Visible_Declarations (Specification (N));
2898          Priv_Decls := Private_Declarations (Specification (N));
2899
2900          --  Retrieve the package spec id
2901
2902          Spec_Id := Defining_Unit_Name (Specification (N));
2903
2904          if Nkind (Spec_Id) = N_Defining_Program_Unit_Name then
2905             Spec_Id := Defining_Identifier (Spec_Id);
2906          end if;
2907
2908       --  Accept statement, block, entry body, package body, protected body,
2909       --  subprogram body or task body.
2910
2911       else
2912          Decls := Declarations (N);
2913          HSS   := Handled_Statement_Sequence (N);
2914
2915          if Present (HSS) then
2916             if Present (Statements (HSS)) then
2917                Stmts := Statements (HSS);
2918             end if;
2919
2920             if Present (At_End_Proc (HSS)) then
2921                Prev_At_End := At_End_Proc (HSS);
2922             end if;
2923          end if;
2924
2925          --  Retrieve the package spec id for package bodies
2926
2927          if For_Package_Body then
2928             Spec_Id := Corresponding_Spec (N);
2929          end if;
2930       end if;
2931
2932       --  Do not process nested packages since those are handled by the
2933       --  enclosing scope's finalizer. Do not process non-expanded package
2934       --  instantiations since those will be re-analyzed and re-expanded.
2935
2936       if For_Package
2937         and then
2938           (not Is_Library_Level_Entity (Spec_Id)
2939
2940              --  Nested packages are considered to be library level entities,
2941              --  but do not need to be processed separately. True library level
2942              --  packages have a scope value of 1.
2943
2944              or else Scope_Depth_Value (Spec_Id) /= Uint_1
2945              or else (Is_Generic_Instance (Spec_Id)
2946                        and then Package_Instantiation (Spec_Id) /= N))
2947       then
2948          return;
2949       end if;
2950
2951       --  Step 2: Object [pre]processing
2952
2953       if For_Package then
2954
2955          --  Preprocess the visible declarations now in order to obtain the
2956          --  correct number of controlled object by the time the private
2957          --  declarations are processed.
2958
2959          Process_Declarations (Decls, Preprocess => True, Top_Level => True);
2960
2961          --  From all the possible contexts, only package specifications may
2962          --  have private declarations.
2963
2964          if For_Package_Spec then
2965             Process_Declarations
2966               (Priv_Decls, Preprocess => True, Top_Level => True);
2967          end if;
2968
2969          --  The current context may lack controlled objects, but require some
2970          --  other form of completion (task termination for instance). In such
2971          --  cases, the finalizer must be created and carry the additional
2972          --  statements.
2973
2974          if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
2975             Build_Components;
2976          end if;
2977
2978          --  The preprocessing has determined that the context has controlled
2979          --  objects or library-level tagged types.
2980
2981          if Has_Ctrl_Objs or Has_Tagged_Types then
2982
2983             --  Private declarations are processed first in order to preserve
2984             --  possible dependencies between public and private objects.
2985
2986             if For_Package_Spec then
2987                Process_Declarations (Priv_Decls);
2988             end if;
2989
2990             Process_Declarations (Decls);
2991          end if;
2992
2993       --  Non-package case
2994
2995       else
2996          --  Preprocess both declarations and statements
2997
2998          Process_Declarations (Decls, Preprocess => True, Top_Level => True);
2999          Process_Declarations (Stmts, Preprocess => True, Top_Level => True);
3000
3001          --  At this point it is known that N has controlled objects. Ensure
3002          --  that N has a declarative list since the finalizer spec will be
3003          --  attached to it.
3004
3005          if Has_Ctrl_Objs and then No (Decls) then
3006             Set_Declarations (N, New_List);
3007             Decls      := Declarations (N);
3008             Spec_Decls := Decls;
3009          end if;
3010
3011          --  The current context may lack controlled objects, but require some
3012          --  other form of completion (task termination for instance). In such
3013          --  cases, the finalizer must be created and carry the additional
3014          --  statements.
3015
3016          if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
3017             Build_Components;
3018          end if;
3019
3020          if Has_Ctrl_Objs or Has_Tagged_Types then
3021             Process_Declarations (Stmts);
3022             Process_Declarations (Decls);
3023          end if;
3024       end if;
3025
3026       --  Step 3: Finalizer creation
3027
3028       if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
3029          Create_Finalizer;
3030       end if;
3031    end Build_Finalizer;
3032
3033    --------------------------
3034    -- Build_Finalizer_Call --
3035    --------------------------
3036
3037    procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id) is
3038       Is_Prot_Body : constant Boolean :=
3039                        Nkind (N) = N_Subprogram_Body
3040                          and then Is_Protected_Subprogram_Body (N);
3041       --  Determine whether N denotes the protected version of a subprogram
3042       --  which belongs to a protected type.
3043
3044       Loc : constant Source_Ptr := Sloc (N);
3045       HSS : Node_Id;
3046
3047    begin
3048       --  Do not perform this expansion in SPARK mode because we do not create
3049       --  finalizers in the first place.
3050
3051       if GNATprove_Mode then
3052          return;
3053       end if;
3054
3055       --  The At_End handler should have been assimilated by the finalizer
3056
3057       HSS := Handled_Statement_Sequence (N);
3058       pragma Assert (No (At_End_Proc (HSS)));
3059
3060       --  If the construct to be cleaned up is a protected subprogram body, the
3061       --  finalizer call needs to be associated with the block which wraps the
3062       --  unprotected version of the subprogram. The following illustrates this
3063       --  scenario:
3064
3065       --     procedure Prot_SubpP is
3066       --        procedure finalizer is
3067       --        begin
3068       --           Service_Entries (Prot_Obj);
3069       --           Abort_Undefer;
3070       --        end finalizer;
3071
3072       --     begin
3073       --        . . .
3074       --        begin
3075       --           Prot_SubpN (Prot_Obj);
3076       --        at end
3077       --           finalizer;
3078       --        end;
3079       --     end Prot_SubpP;
3080
3081       if Is_Prot_Body then
3082          HSS := Handled_Statement_Sequence (Last (Statements (HSS)));
3083
3084       --  An At_End handler and regular exception handlers cannot coexist in
3085       --  the same statement sequence. Wrap the original statements in a block.
3086
3087       elsif Present (Exception_Handlers (HSS)) then
3088          declare
3089             End_Lab : constant Node_Id := End_Label (HSS);
3090             Block   : Node_Id;
3091
3092          begin
3093             Block :=
3094               Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS);
3095
3096             Set_Handled_Statement_Sequence (N,
3097               Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
3098
3099             HSS := Handled_Statement_Sequence (N);
3100             Set_End_Label (HSS, End_Lab);
3101          end;
3102       end if;
3103
3104       Set_At_End_Proc (HSS, New_Occurrence_Of (Fin_Id, Loc));
3105
3106       Analyze (At_End_Proc (HSS));
3107       Expand_At_End_Handler (HSS, Empty);
3108    end Build_Finalizer_Call;
3109
3110    ---------------------
3111    -- Build_Late_Proc --
3112    ---------------------
3113
3114    procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is
3115    begin
3116       for Final_Prim in Name_Of'Range loop
3117          if Name_Of (Final_Prim) = Nam then
3118             Set_TSS (Typ,
3119               Make_Deep_Proc
3120                 (Prim  => Final_Prim,
3121                  Typ   => Typ,
3122                  Stmts => Make_Deep_Record_Body (Final_Prim, Typ)));
3123          end if;
3124       end loop;
3125    end Build_Late_Proc;
3126
3127    -------------------------------
3128    -- Build_Object_Declarations --
3129    -------------------------------
3130
3131    procedure Build_Object_Declarations
3132      (Data        : out Finalization_Exception_Data;
3133       Decls       : List_Id;
3134       Loc         : Source_Ptr;
3135       For_Package : Boolean := False)
3136    is
3137       Decl : Node_Id;
3138
3139       Dummy : Entity_Id;
3140       pragma Unreferenced (Dummy);
3141       --  This variable captures an unused dummy internal entity, see the
3142       --  comment associated with its use.
3143
3144    begin
3145       pragma Assert (Decls /= No_List);
3146
3147       --  Always set the proper location as it may be needed even when
3148       --  exception propagation is forbidden.
3149
3150       Data.Loc := Loc;
3151
3152       if Restriction_Active (No_Exception_Propagation) then
3153          Data.Abort_Id  := Empty;
3154          Data.E_Id      := Empty;
3155          Data.Raised_Id := Empty;
3156          return;
3157       end if;
3158
3159       Data.Raised_Id := Make_Temporary (Loc, 'R');
3160
3161       --  In certain scenarios, finalization can be triggered by an abort. If
3162       --  the finalization itself fails and raises an exception, the resulting
3163       --  Program_Error must be supressed and replaced by an abort signal. In
3164       --  order to detect this scenario, save the state of entry into the
3165       --  finalization code.
3166
3167       --  No need to do this for VM case, since VM version of Ada.Exceptions
3168       --  does not include routine Raise_From_Controlled_Operation which is the
3169       --  the sole user of flag Abort.
3170
3171       --  This is not needed for library-level finalizers as they are called by
3172       --  the environment task and cannot be aborted.
3173
3174       if VM_Target = No_VM and then not For_Package then
3175          if Abort_Allowed then
3176             Data.Abort_Id := Make_Temporary (Loc, 'A');
3177
3178             --  Generate:
3179             --    Abort_Id : constant Boolean := <A_Expr>;
3180
3181             Append_To (Decls,
3182               Make_Object_Declaration (Loc,
3183                 Defining_Identifier => Data.Abort_Id,
3184                 Constant_Present    => True,
3185                 Object_Definition   =>
3186                   New_Occurrence_Of (Standard_Boolean, Loc),
3187                 Expression          =>
3188                   New_Occurrence_Of (RTE (RE_Triggered_By_Abort), Loc)));
3189
3190          --  Abort is not required
3191
3192          else
3193             --  Generate a dummy entity to ensure that the internal symbols are
3194             --  in sync when a unit is compiled with and without aborts.
3195
3196             Dummy := Make_Temporary (Loc, 'A');
3197             Data.Abort_Id := Empty;
3198          end if;
3199
3200       --  .NET/JVM or library-level finalizers
3201
3202       else
3203          Data.Abort_Id := Empty;
3204       end if;
3205
3206       if Exception_Extra_Info then
3207          Data.E_Id := Make_Temporary (Loc, 'E');
3208
3209          --  Generate:
3210          --    E_Id : Exception_Occurrence;
3211
3212          Decl :=
3213            Make_Object_Declaration (Loc,
3214              Defining_Identifier => Data.E_Id,
3215              Object_Definition   =>
3216                New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc));
3217          Set_No_Initialization (Decl);
3218
3219          Append_To (Decls, Decl);
3220
3221       else
3222          Data.E_Id := Empty;
3223       end if;
3224
3225       --  Generate:
3226       --    Raised_Id : Boolean := False;
3227
3228       Append_To (Decls,
3229         Make_Object_Declaration (Loc,
3230           Defining_Identifier => Data.Raised_Id,
3231           Object_Definition   => New_Occurrence_Of (Standard_Boolean, Loc),
3232           Expression          => New_Occurrence_Of (Standard_False, Loc)));
3233    end Build_Object_Declarations;
3234
3235    ---------------------------
3236    -- Build_Raise_Statement --
3237    ---------------------------
3238
3239    function Build_Raise_Statement
3240      (Data : Finalization_Exception_Data) return Node_Id
3241    is
3242       Stmt : Node_Id;
3243       Expr : Node_Id;
3244
3245    begin
3246       --  Standard run-time and .NET/JVM targets use the specialized routine
3247       --  Raise_From_Controlled_Operation.
3248
3249       if Exception_Extra_Info
3250         and then RTE_Available (RE_Raise_From_Controlled_Operation)
3251       then
3252          Stmt :=
3253            Make_Procedure_Call_Statement (Data.Loc,
3254               Name                   =>
3255                 New_Occurrence_Of
3256                   (RTE (RE_Raise_From_Controlled_Operation), Data.Loc),
3257               Parameter_Associations =>
3258                 New_List (New_Occurrence_Of (Data.E_Id, Data.Loc)));
3259
3260       --  Restricted run-time: exception messages are not supported and hence
3261       --  Raise_From_Controlled_Operation is not supported. Raise Program_Error
3262       --  instead.
3263
3264       else
3265          Stmt :=
3266            Make_Raise_Program_Error (Data.Loc,
3267              Reason => PE_Finalize_Raised_Exception);
3268       end if;
3269
3270       --  Generate:
3271
3272       --    Raised_Id and then not Abort_Id
3273       --      <or>
3274       --    Raised_Id
3275
3276       Expr := New_Occurrence_Of (Data.Raised_Id, Data.Loc);
3277
3278       if Present (Data.Abort_Id) then
3279          Expr := Make_And_Then (Data.Loc,
3280            Left_Opnd  => Expr,
3281            Right_Opnd =>
3282              Make_Op_Not (Data.Loc,
3283                Right_Opnd => New_Occurrence_Of (Data.Abort_Id, Data.Loc)));
3284       end if;
3285
3286       --  Generate:
3287
3288       --    if Raised_Id and then not Abort_Id then
3289       --       Raise_From_Controlled_Operation (E_Id);
3290       --         <or>
3291       --       raise Program_Error;  --  restricted runtime
3292       --    end if;
3293
3294       return
3295         Make_If_Statement (Data.Loc,
3296           Condition       => Expr,
3297           Then_Statements => New_List (Stmt));
3298    end Build_Raise_Statement;
3299
3300    -----------------------------
3301    -- Build_Record_Deep_Procs --
3302    -----------------------------
3303
3304    procedure Build_Record_Deep_Procs (Typ : Entity_Id) is
3305    begin
3306       Set_TSS (Typ,
3307         Make_Deep_Proc
3308           (Prim  => Initialize_Case,
3309            Typ   => Typ,
3310            Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
3311
3312       if not Is_Limited_View (Typ) then
3313          Set_TSS (Typ,
3314            Make_Deep_Proc
3315              (Prim  => Adjust_Case,
3316               Typ   => Typ,
3317               Stmts => Make_Deep_Record_Body (Adjust_Case, Typ)));
3318       end if;
3319
3320       --  Do not generate Deep_Finalize and Finalize_Address if finalization is
3321       --  suppressed since these routine will not be used.
3322
3323       if not Restriction_Active (No_Finalization) then
3324          Set_TSS (Typ,
3325            Make_Deep_Proc
3326              (Prim  => Finalize_Case,
3327               Typ   => Typ,
3328               Stmts => Make_Deep_Record_Body (Finalize_Case, Typ)));
3329
3330          --  Create TSS primitive Finalize_Address for non-VM targets. JVM and
3331          --  .NET do not support address arithmetic and unchecked conversions.
3332
3333          if VM_Target = No_VM then
3334             Set_TSS (Typ,
3335               Make_Deep_Proc
3336                 (Prim  => Address_Case,
3337                  Typ   => Typ,
3338                  Stmts => Make_Deep_Record_Body (Address_Case, Typ)));
3339          end if;
3340       end if;
3341    end Build_Record_Deep_Procs;
3342
3343    -------------------
3344    -- Cleanup_Array --
3345    -------------------
3346
3347    function Cleanup_Array
3348      (N    : Node_Id;
3349       Obj  : Node_Id;
3350       Typ  : Entity_Id) return List_Id
3351    is
3352       Loc        : constant Source_Ptr := Sloc (N);
3353       Index_List : constant List_Id := New_List;
3354
3355       function Free_Component return List_Id;
3356       --  Generate the code to finalize the task or protected  subcomponents
3357       --  of a single component of the array.
3358
3359       function Free_One_Dimension (Dim : Int) return List_Id;
3360       --  Generate a loop over one dimension of the array
3361
3362       --------------------
3363       -- Free_Component --
3364       --------------------
3365
3366       function Free_Component return List_Id is
3367          Stmts : List_Id := New_List;
3368          Tsk   : Node_Id;
3369          C_Typ : constant Entity_Id := Component_Type (Typ);
3370
3371       begin
3372          --  Component type is known to contain tasks or protected objects
3373
3374          Tsk :=
3375            Make_Indexed_Component (Loc,
3376              Prefix        => Duplicate_Subexpr_No_Checks (Obj),
3377              Expressions   => Index_List);
3378
3379          Set_Etype (Tsk, C_Typ);
3380
3381          if Is_Task_Type (C_Typ) then
3382             Append_To (Stmts, Cleanup_Task (N, Tsk));
3383
3384          elsif Is_Simple_Protected_Type (C_Typ) then
3385             Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
3386
3387          elsif Is_Record_Type (C_Typ) then
3388             Stmts := Cleanup_Record (N, Tsk, C_Typ);
3389
3390          elsif Is_Array_Type (C_Typ) then
3391             Stmts := Cleanup_Array (N, Tsk, C_Typ);
3392          end if;
3393
3394          return Stmts;
3395       end Free_Component;
3396
3397       ------------------------
3398       -- Free_One_Dimension --
3399       ------------------------
3400
3401       function Free_One_Dimension (Dim : Int) return List_Id is
3402          Index : Entity_Id;
3403
3404       begin
3405          if Dim > Number_Dimensions (Typ) then
3406             return Free_Component;
3407
3408          --  Here we generate the required loop
3409
3410          else
3411             Index := Make_Temporary (Loc, 'J');
3412             Append (New_Occurrence_Of (Index, Loc), Index_List);
3413
3414             return New_List (
3415               Make_Implicit_Loop_Statement (N,
3416                 Identifier       => Empty,
3417                 Iteration_Scheme =>
3418                   Make_Iteration_Scheme (Loc,
3419                     Loop_Parameter_Specification =>
3420                       Make_Loop_Parameter_Specification (Loc,
3421                         Defining_Identifier         => Index,
3422                         Discrete_Subtype_Definition =>
3423                           Make_Attribute_Reference (Loc,
3424                             Prefix          => Duplicate_Subexpr (Obj),
3425                             Attribute_Name  => Name_Range,
3426                             Expressions     => New_List (
3427                               Make_Integer_Literal (Loc, Dim))))),
3428                 Statements       =>  Free_One_Dimension (Dim + 1)));
3429          end if;
3430       end Free_One_Dimension;
3431
3432    --  Start of processing for Cleanup_Array
3433
3434    begin
3435       return Free_One_Dimension (1);
3436    end Cleanup_Array;
3437
3438    --------------------
3439    -- Cleanup_Record --
3440    --------------------
3441
3442    function Cleanup_Record
3443      (N    : Node_Id;
3444       Obj  : Node_Id;
3445       Typ  : Entity_Id) return List_Id
3446    is
3447       Loc   : constant Source_Ptr := Sloc (N);
3448       Tsk   : Node_Id;
3449       Comp  : Entity_Id;
3450       Stmts : constant List_Id    := New_List;
3451       U_Typ : constant Entity_Id  := Underlying_Type (Typ);
3452
3453    begin
3454       if Has_Discriminants (U_Typ)
3455         and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration
3456         and then
3457           Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition
3458         and then
3459           Present
3460             (Variant_Part (Component_List (Type_Definition (Parent (U_Typ)))))
3461       then
3462          --  For now, do not attempt to free a component that may appear in a
3463          --  variant, and instead issue a warning. Doing this "properly" would
3464          --  require building a case statement and would be quite a mess. Note
3465          --  that the RM only requires that free "work" for the case of a task
3466          --  access value, so already we go way beyond this in that we deal
3467          --  with the array case and non-discriminated record cases.
3468
3469          Error_Msg_N
3470            ("task/protected object in variant record will not be freed??", N);
3471          return New_List (Make_Null_Statement (Loc));
3472       end if;
3473
3474       Comp := First_Component (Typ);
3475       while Present (Comp) loop
3476          if Has_Task (Etype (Comp))
3477            or else Has_Simple_Protected_Object (Etype (Comp))
3478          then
3479             Tsk :=
3480               Make_Selected_Component (Loc,
3481                 Prefix        => Duplicate_Subexpr_No_Checks (Obj),
3482                 Selector_Name => New_Occurrence_Of (Comp, Loc));
3483             Set_Etype (Tsk, Etype (Comp));
3484
3485             if Is_Task_Type (Etype (Comp)) then
3486                Append_To (Stmts, Cleanup_Task (N, Tsk));
3487
3488             elsif Is_Simple_Protected_Type (Etype (Comp)) then
3489                Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
3490
3491             elsif Is_Record_Type (Etype (Comp)) then
3492
3493                --  Recurse, by generating the prefix of the argument to
3494                --  the eventual cleanup call.
3495
3496                Append_List_To (Stmts, Cleanup_Record (N, Tsk, Etype (Comp)));
3497
3498             elsif Is_Array_Type (Etype (Comp)) then
3499                Append_List_To (Stmts, Cleanup_Array (N, Tsk, Etype (Comp)));
3500             end if;
3501          end if;
3502
3503          Next_Component (Comp);
3504       end loop;
3505
3506       return Stmts;
3507    end Cleanup_Record;
3508
3509    ------------------------------
3510    -- Cleanup_Protected_Object --
3511    ------------------------------
3512
3513    function Cleanup_Protected_Object
3514      (N   : Node_Id;
3515       Ref : Node_Id) return Node_Id
3516    is
3517       Loc : constant Source_Ptr := Sloc (N);
3518
3519    begin
3520       --  For restricted run-time libraries (Ravenscar), tasks are
3521       --  non-terminating, and protected objects can only appear at library
3522       --  level, so we do not want finalization of protected objects.
3523
3524       if Restricted_Profile then
3525          return Empty;
3526
3527       else
3528          return
3529            Make_Procedure_Call_Statement (Loc,
3530              Name                   =>
3531                New_Occurrence_Of (RTE (RE_Finalize_Protection), Loc),
3532              Parameter_Associations => New_List (Concurrent_Ref (Ref)));
3533       end if;
3534    end Cleanup_Protected_Object;
3535
3536    ------------------
3537    -- Cleanup_Task --
3538    ------------------
3539
3540    function Cleanup_Task
3541      (N   : Node_Id;
3542       Ref : Node_Id) return Node_Id
3543    is
3544       Loc  : constant Source_Ptr := Sloc (N);
3545
3546    begin
3547       --  For restricted run-time libraries (Ravenscar), tasks are
3548       --  non-terminating and they can only appear at library level, so we do
3549       --  not want finalization of task objects.
3550
3551       if Restricted_Profile then
3552          return Empty;
3553
3554       else
3555          return
3556            Make_Procedure_Call_Statement (Loc,
3557              Name                   =>
3558                New_Occurrence_Of (RTE (RE_Free_Task), Loc),
3559              Parameter_Associations => New_List (Concurrent_Ref (Ref)));
3560       end if;
3561    end Cleanup_Task;
3562
3563    ------------------------------
3564    -- Check_Visibly_Controlled --
3565    ------------------------------
3566
3567    procedure Check_Visibly_Controlled
3568      (Prim : Final_Primitives;
3569       Typ  : Entity_Id;
3570       E    : in out Entity_Id;
3571       Cref : in out Node_Id)
3572    is
3573       Parent_Type : Entity_Id;
3574       Op          : Entity_Id;
3575
3576    begin
3577       if Is_Derived_Type (Typ)
3578         and then Comes_From_Source (E)
3579         and then not Present (Overridden_Operation (E))
3580       then
3581          --  We know that the explicit operation on the type does not override
3582          --  the inherited operation of the parent, and that the derivation
3583          --  is from a private type that is not visibly controlled.
3584
3585          Parent_Type := Etype (Typ);
3586          Op := Find_Prim_Op (Parent_Type, Name_Of (Prim));
3587
3588          if Present (Op) then
3589             E := Op;
3590
3591             --  Wrap the object to be initialized into the proper
3592             --  unchecked conversion, to be compatible with the operation
3593             --  to be called.
3594
3595             if Nkind (Cref) = N_Unchecked_Type_Conversion then
3596                Cref := Unchecked_Convert_To (Parent_Type, Expression (Cref));
3597             else
3598                Cref := Unchecked_Convert_To (Parent_Type, Cref);
3599             end if;
3600          end if;
3601       end if;
3602    end Check_Visibly_Controlled;
3603
3604    -------------------------------
3605    -- CW_Or_Has_Controlled_Part --
3606    -------------------------------
3607
3608    function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is
3609    begin
3610       return Is_Class_Wide_Type (T) or else Needs_Finalization (T);
3611    end CW_Or_Has_Controlled_Part;
3612
3613    ------------------
3614    -- Convert_View --
3615    ------------------
3616
3617    function Convert_View
3618      (Proc : Entity_Id;
3619       Arg  : Node_Id;
3620       Ind  : Pos := 1) return Node_Id
3621    is
3622       Fent : Entity_Id := First_Entity (Proc);
3623       Ftyp : Entity_Id;
3624       Atyp : Entity_Id;
3625
3626    begin
3627       for J in 2 .. Ind loop
3628          Next_Entity (Fent);
3629       end loop;
3630
3631       Ftyp := Etype (Fent);
3632
3633       if Nkind_In (Arg, N_Type_Conversion, N_Unchecked_Type_Conversion) then
3634          Atyp := Entity (Subtype_Mark (Arg));
3635       else
3636          Atyp := Etype (Arg);
3637       end if;
3638
3639       if Is_Abstract_Subprogram (Proc) and then Is_Tagged_Type (Ftyp) then
3640          return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg);
3641
3642       elsif Ftyp /= Atyp
3643         and then Present (Atyp)
3644         and then (Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp))
3645         and then Base_Type (Underlying_Type (Atyp)) =
3646                  Base_Type (Underlying_Type (Ftyp))
3647       then
3648          return Unchecked_Convert_To (Ftyp, Arg);
3649
3650       --  If the argument is already a conversion, as generated by
3651       --  Make_Init_Call, set the target type to the type of the formal
3652       --  directly, to avoid spurious typing problems.
3653
3654       elsif Nkind_In (Arg, N_Unchecked_Type_Conversion, N_Type_Conversion)
3655         and then not Is_Class_Wide_Type (Atyp)
3656       then
3657          Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg)));
3658          Set_Etype (Arg, Ftyp);
3659          return Arg;
3660
3661       else
3662          return Arg;
3663       end if;
3664    end Convert_View;
3665
3666    ------------------------
3667    -- Enclosing_Function --
3668    ------------------------
3669
3670    function Enclosing_Function (E : Entity_Id) return Entity_Id is
3671       Func_Id : Entity_Id;
3672
3673    begin
3674       Func_Id := E;
3675       while Present (Func_Id) and then Func_Id /= Standard_Standard loop
3676          if Ekind (Func_Id) = E_Function then
3677             return Func_Id;
3678          end if;
3679
3680          Func_Id := Scope (Func_Id);
3681       end loop;
3682
3683       return Empty;
3684    end Enclosing_Function;
3685
3686    -------------------------------
3687    -- Establish_Transient_Scope --
3688    -------------------------------
3689
3690    --  This procedure is called each time a transient block has to be inserted
3691    --  that is to say for each call to a function with unconstrained or tagged
3692    --  result. It creates a new scope on the stack scope in order to enclose
3693    --  all transient variables generated.
3694
3695    procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean) is
3696       Loc       : constant Source_Ptr := Sloc (N);
3697       Iter_Loop : Entity_Id;
3698       Wrap_Node : Node_Id;
3699
3700    begin
3701       --  Do not create a transient scope if we are already inside one
3702
3703       for S in reverse Scope_Stack.First .. Scope_Stack.Last loop
3704          if Scope_Stack.Table (S).Is_Transient then
3705             if Sec_Stack then
3706                Set_Uses_Sec_Stack (Scope_Stack.Table (S).Entity);
3707             end if;
3708
3709             return;
3710
3711          --  If we encounter Standard there are no enclosing transient scopes
3712
3713          elsif Scope_Stack.Table (S).Entity = Standard_Standard then
3714             exit;
3715          end if;
3716       end loop;
3717
3718       Wrap_Node := Find_Node_To_Be_Wrapped (N);
3719
3720       --  The context does not contain a node that requires a transient scope,
3721       --  nothing to do.
3722
3723       if No (Wrap_Node) then
3724          null;
3725
3726       --  If the node to wrap is an iteration_scheme, the expression is one of
3727       --  the bounds, and the expansion will make an explicit declaration for
3728       --  it (see Analyze_Iteration_Scheme, sem_ch5.adb), so do not apply any
3729       --  transformations here. Same for an Ada 2012 iterator specification,
3730       --  where a block is created for the expression that build the container.
3731
3732       elsif Nkind_In (Wrap_Node, N_Iteration_Scheme,
3733                                  N_Iterator_Specification)
3734       then
3735          null;
3736
3737       --  In formal verification mode, if the node to wrap is a pragma check,
3738       --  this node and enclosed expression are not expanded, so do not apply
3739       --  any transformations here.
3740
3741       elsif GNATprove_Mode
3742         and then Nkind (Wrap_Node) = N_Pragma
3743         and then Get_Pragma_Id (Wrap_Node) = Pragma_Check
3744       then
3745          null;
3746
3747       --  Create a block entity to act as a transient scope. Note that when the
3748       --  node to be wrapped is an expression or a statement, a real physical
3749       --  block is constructed (see routines Wrap_Transient_Expression and
3750       --  Wrap_Transient_Statement) and inserted into the tree.
3751
3752       else
3753          Push_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'));
3754          Set_Scope_Is_Transient;
3755
3756          --  The transient scope must also take care of the secondary stack
3757          --  management.
3758
3759          if Sec_Stack then
3760             Set_Uses_Sec_Stack (Current_Scope);
3761             Check_Restriction (No_Secondary_Stack, N);
3762
3763             --  The expansion of iterator loops generates references to objects
3764             --  in order to extract elements from a container:
3765
3766             --    Ref : Reference_Type_Ptr := Reference (Container, Cursor);
3767             --    Obj : <object type> renames Ref.all.Element.all;
3768
3769             --  These references are controlled and returned on the secondary
3770             --  stack. A new reference is created at each iteration of the loop
3771             --  and as a result it must be finalized and the space occupied by
3772             --  it on the secondary stack reclaimed at the end of the current
3773             --  iteration.
3774
3775             --  When the context that requires a transient scope is a call to
3776             --  routine Reference, the node to be wrapped is the source object:
3777
3778             --    for Obj of Container loop
3779
3780             --  Routine Wrap_Transient_Declaration however does not generate a
3781             --  physical block as wrapping a declaration will kill it too ealy.
3782             --  To handle this peculiar case, mark the related iterator loop as
3783             --  requiring the secondary stack. This signals the finalization
3784             --  machinery to manage the secondary stack (see routine
3785             --  Process_Statements_For_Controlled_Objects).
3786
3787             Iter_Loop := Find_Enclosing_Iterator_Loop (Current_Scope);
3788
3789             if Present (Iter_Loop) then
3790                Set_Uses_Sec_Stack (Iter_Loop);
3791             end if;
3792          end if;
3793
3794          Set_Etype (Current_Scope, Standard_Void_Type);
3795          Set_Node_To_Be_Wrapped (Wrap_Node);
3796
3797          if Debug_Flag_W then
3798             Write_Str ("    <Transient>");
3799             Write_Eol;
3800          end if;
3801       end if;
3802    end Establish_Transient_Scope;
3803
3804    ----------------------------
3805    -- Expand_Cleanup_Actions --
3806    ----------------------------
3807
3808    procedure Expand_Cleanup_Actions (N : Node_Id) is
3809       Scop : constant Entity_Id := Current_Scope;
3810
3811       Is_Asynchronous_Call : constant Boolean :=
3812                                Nkind (N) = N_Block_Statement
3813                                  and then Is_Asynchronous_Call_Block (N);
3814       Is_Master            : constant Boolean :=
3815                                Nkind (N) /= N_Entry_Body
3816                                  and then Is_Task_Master (N);
3817       Is_Protected_Body    : constant Boolean :=
3818                                Nkind (N) = N_Subprogram_Body
3819                                  and then Is_Protected_Subprogram_Body (N);
3820       Is_Task_Allocation   : constant Boolean :=
3821                                Nkind (N) = N_Block_Statement
3822                                  and then Is_Task_Allocation_Block (N);
3823       Is_Task_Body         : constant Boolean :=
3824                                Nkind (Original_Node (N)) = N_Task_Body;
3825       Needs_Sec_Stack_Mark : constant Boolean :=
3826                                Uses_Sec_Stack (Scop)
3827                                  and then
3828                                    not Sec_Stack_Needed_For_Return (Scop)
3829                                  and then VM_Target = No_VM;
3830       Needs_Custom_Cleanup : constant Boolean :=
3831                                Nkind (N) = N_Block_Statement
3832                                  and then Present (Cleanup_Actions (N));
3833
3834       Actions_Required     : constant Boolean :=
3835                                Requires_Cleanup_Actions (N, True)
3836                                  or else Is_Asynchronous_Call
3837                                  or else Is_Master
3838                                  or else Is_Protected_Body
3839                                  or else Is_Task_Allocation
3840                                  or else Is_Task_Body
3841                                  or else Needs_Sec_Stack_Mark
3842                                  or else Needs_Custom_Cleanup;
3843
3844       HSS : Node_Id := Handled_Statement_Sequence (N);
3845       Loc : Source_Ptr;
3846       Cln : List_Id;
3847
3848       procedure Wrap_HSS_In_Block;
3849       --  Move HSS inside a new block along with the original exception
3850       --  handlers. Make the newly generated block the sole statement of HSS.
3851
3852       -----------------------
3853       -- Wrap_HSS_In_Block --
3854       -----------------------
3855
3856       procedure Wrap_HSS_In_Block is
3857          Block   : Node_Id;
3858          End_Lab : Node_Id;
3859
3860       begin
3861          --  Preserve end label to provide proper cross-reference information
3862
3863          End_Lab := End_Label (HSS);
3864          Block :=
3865            Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS);
3866
3867          --  Signal the finalization machinery that this particular block
3868          --  contains the original context.
3869
3870          Set_Is_Finalization_Wrapper (Block);
3871
3872          Set_Handled_Statement_Sequence (N,
3873            Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
3874          HSS := Handled_Statement_Sequence (N);
3875
3876          Set_First_Real_Statement (HSS, Block);
3877          Set_End_Label (HSS, End_Lab);
3878
3879          --  Comment needed here, see RH for 1.306 ???
3880
3881          if Nkind (N) = N_Subprogram_Body then
3882             Set_Has_Nested_Block_With_Handler (Scop);
3883          end if;
3884       end Wrap_HSS_In_Block;
3885
3886    --  Start of processing for Expand_Cleanup_Actions
3887
3888    begin
3889       --  The current construct does not need any form of servicing
3890
3891       if not Actions_Required then
3892          return;
3893
3894       --  If the current node is a rewritten task body and the descriptors have
3895       --  not been delayed (due to some nested instantiations), do not generate
3896       --  redundant cleanup actions.
3897
3898       elsif Is_Task_Body
3899         and then Nkind (N) = N_Subprogram_Body
3900         and then not Delay_Subprogram_Descriptors (Corresponding_Spec (N))
3901       then
3902          return;
3903       end if;
3904
3905       if Needs_Custom_Cleanup then
3906          Cln := Cleanup_Actions (N);
3907       else
3908          Cln := No_List;
3909       end if;
3910
3911       declare
3912          Decls     : List_Id := Declarations (N);
3913          Fin_Id    : Entity_Id;
3914          Mark      : Entity_Id := Empty;
3915          New_Decls : List_Id;
3916          Old_Poll  : Boolean;
3917
3918       begin
3919          --  If we are generating expanded code for debugging purposes, use the
3920          --  Sloc of the point of insertion for the cleanup code. The Sloc will
3921          --  be updated subsequently to reference the proper line in .dg files.
3922          --  If we are not debugging generated code, use No_Location instead,
3923          --  so that no debug information is generated for the cleanup code.
3924          --  This makes the behavior of the NEXT command in GDB monotonic, and
3925          --  makes the placement of breakpoints more accurate.
3926
3927          if Debug_Generated_Code then
3928             Loc := Sloc (Scop);
3929          else
3930             Loc := No_Location;
3931          end if;
3932
3933          --  Set polling off. The finalization and cleanup code is executed
3934          --  with aborts deferred.
3935
3936          Old_Poll := Polling_Required;
3937          Polling_Required := False;
3938
3939          --  A task activation call has already been built for a task
3940          --  allocation block.
3941
3942          if not Is_Task_Allocation then
3943             Build_Task_Activation_Call (N);
3944          end if;
3945
3946          if Is_Master then
3947             Establish_Task_Master (N);
3948          end if;
3949
3950          New_Decls := New_List;
3951
3952          --  If secondary stack is in use, generate:
3953          --
3954          --    Mnn : constant Mark_Id := SS_Mark;
3955
3956          --  Suppress calls to SS_Mark and SS_Release if VM_Target, since the
3957          --  secondary stack is never used on a VM.
3958
3959          if Needs_Sec_Stack_Mark then
3960             Mark := Make_Temporary (Loc, 'M');
3961
3962             Append_To (New_Decls,
3963               Make_Object_Declaration (Loc,
3964                 Defining_Identifier => Mark,
3965                 Object_Definition   =>
3966                   New_Occurrence_Of (RTE (RE_Mark_Id), Loc),
3967                 Expression          =>
3968                   Make_Function_Call (Loc,
3969                     Name => New_Occurrence_Of (RTE (RE_SS_Mark), Loc))));
3970
3971             Set_Uses_Sec_Stack (Scop, False);
3972          end if;
3973
3974          --  If exception handlers are present, wrap the sequence of statements
3975          --  in a block since it is not possible to have exception handlers and
3976          --  an At_End handler in the same construct.
3977
3978          if Present (Exception_Handlers (HSS)) then
3979             Wrap_HSS_In_Block;
3980
3981          --  Ensure that the First_Real_Statement field is set
3982
3983          elsif No (First_Real_Statement (HSS)) then
3984             Set_First_Real_Statement (HSS, First (Statements (HSS)));
3985          end if;
3986
3987          --  Do not move the Activation_Chain declaration in the context of
3988          --  task allocation blocks. Task allocation blocks use _chain in their
3989          --  cleanup handlers and gigi complains if it is declared in the
3990          --  sequence of statements of the scope that declares the handler.
3991
3992          if Is_Task_Allocation then
3993             declare
3994                Chain : constant Entity_Id := Activation_Chain_Entity (N);
3995                Decl  : Node_Id;
3996
3997             begin
3998                Decl := First (Decls);
3999                while Nkind (Decl) /= N_Object_Declaration
4000                  or else Defining_Identifier (Decl) /= Chain
4001                loop
4002                   Next (Decl);
4003
4004                   --  A task allocation block should always include a _chain
4005                   --  declaration.
4006
4007                   pragma Assert (Present (Decl));
4008                end loop;
4009
4010                Remove (Decl);
4011                Prepend_To (New_Decls, Decl);
4012             end;
4013          end if;
4014
4015          --  Ensure the presence of a declaration list in order to successfully
4016          --  append all original statements to it.
4017
4018          if No (Decls) then
4019             Set_Declarations (N, New_List);
4020             Decls := Declarations (N);
4021          end if;
4022
4023          --  Move the declarations into the sequence of statements in order to
4024          --  have them protected by the At_End handler. It may seem weird to
4025          --  put declarations in the sequence of statement but in fact nothing
4026          --  forbids that at the tree level.
4027
4028          Append_List_To (Decls, Statements (HSS));
4029          Set_Statements (HSS, Decls);
4030
4031          --  Reset the Sloc of the handled statement sequence to properly
4032          --  reflect the new initial "statement" in the sequence.
4033
4034          Set_Sloc (HSS, Sloc (First (Decls)));
4035
4036          --  The declarations of finalizer spec and auxiliary variables replace
4037          --  the old declarations that have been moved inward.
4038
4039          Set_Declarations (N, New_Decls);
4040          Analyze_Declarations (New_Decls);
4041
4042          --  Generate finalization calls for all controlled objects appearing
4043          --  in the statements of N. Add context specific cleanup for various
4044          --  constructs.
4045
4046          Build_Finalizer
4047            (N           => N,
4048             Clean_Stmts => Build_Cleanup_Statements (N, Cln),
4049             Mark_Id     => Mark,
4050             Top_Decls   => New_Decls,
4051             Defer_Abort => Nkind (Original_Node (N)) = N_Task_Body
4052                              or else Is_Master,
4053             Fin_Id      => Fin_Id);
4054
4055          if Present (Fin_Id) then
4056             Build_Finalizer_Call (N, Fin_Id);
4057          end if;
4058
4059          --  Restore saved polling mode
4060
4061          Polling_Required := Old_Poll;
4062       end;
4063    end Expand_Cleanup_Actions;
4064
4065    ---------------------------
4066    -- Expand_N_Package_Body --
4067    ---------------------------
4068
4069    --  Add call to Activate_Tasks if body is an activator (actual processing
4070    --  is in chapter 9).
4071
4072    --  Generate subprogram descriptor for elaboration routine
4073
4074    --  Encode entity names in package body
4075
4076    procedure Expand_N_Package_Body (N : Node_Id) is
4077       Spec_Ent : constant Entity_Id := Corresponding_Spec (N);
4078       Fin_Id   : Entity_Id;
4079
4080    begin
4081       --  This is done only for non-generic packages
4082
4083       if Ekind (Spec_Ent) = E_Package then
4084          Push_Scope (Corresponding_Spec (N));
4085
4086          --  Build dispatch tables of library level tagged types
4087
4088          if Tagged_Type_Expansion
4089            and then Is_Library_Level_Entity (Spec_Ent)
4090          then
4091             Build_Static_Dispatch_Tables (N);
4092          end if;
4093
4094          Build_Task_Activation_Call (N);
4095
4096          --  When the package is subject to pragma Initial_Condition, the
4097          --  assertion expression must be verified at the end of the body
4098          --  statements.
4099
4100          if Present (Get_Pragma (Spec_Ent, Pragma_Initial_Condition)) then
4101             Expand_Pragma_Initial_Condition (N);
4102          end if;
4103
4104          Pop_Scope;
4105       end if;
4106
4107       Set_Elaboration_Flag (N, Corresponding_Spec (N));
4108       Set_In_Package_Body (Spec_Ent, False);
4109
4110       --  Set to encode entity names in package body before gigi is called
4111
4112       Qualify_Entity_Names (N);
4113
4114       if Ekind (Spec_Ent) /= E_Generic_Package then
4115          Build_Finalizer
4116            (N           => N,
4117             Clean_Stmts => No_List,
4118             Mark_Id     => Empty,
4119             Top_Decls   => No_List,
4120             Defer_Abort => False,
4121             Fin_Id      => Fin_Id);
4122
4123          if Present (Fin_Id) then
4124             declare
4125                Body_Ent : Node_Id := Defining_Unit_Name (N);
4126
4127             begin
4128                if Nkind (Body_Ent) = N_Defining_Program_Unit_Name then
4129                   Body_Ent := Defining_Identifier (Body_Ent);
4130                end if;
4131
4132                Set_Finalizer (Body_Ent, Fin_Id);
4133             end;
4134          end if;
4135       end if;
4136    end Expand_N_Package_Body;
4137
4138    ----------------------------------
4139    -- Expand_N_Package_Declaration --
4140    ----------------------------------
4141
4142    --  Add call to Activate_Tasks if there are tasks declared and the package
4143    --  has no body. Note that in Ada 83 this may result in premature activation
4144    --  of some tasks, given that we cannot tell whether a body will eventually
4145    --  appear.
4146
4147    procedure Expand_N_Package_Declaration (N : Node_Id) is
4148       Id     : constant Entity_Id := Defining_Entity (N);
4149       Spec   : constant Node_Id   := Specification (N);
4150       Decls  : List_Id;
4151       Fin_Id : Entity_Id;
4152
4153       No_Body : Boolean := False;
4154       --  True in the case of a package declaration that is a compilation
4155       --  unit and for which no associated body will be compiled in this
4156       --  compilation.
4157
4158    begin
4159       --  Case of a package declaration other than a compilation unit
4160
4161       if Nkind (Parent (N)) /= N_Compilation_Unit then
4162          null;
4163
4164       --  Case of a compilation unit that does not require a body
4165
4166       elsif not Body_Required (Parent (N))
4167         and then not Unit_Requires_Body (Id)
4168       then
4169          No_Body := True;
4170
4171       --  Special case of generating calling stubs for a remote call interface
4172       --  package: even though the package declaration requires one, the body
4173       --  won't be processed in this compilation (so any stubs for RACWs
4174       --  declared in the package must be generated here, along with the spec).
4175
4176       elsif Parent (N) = Cunit (Main_Unit)
4177         and then Is_Remote_Call_Interface (Id)
4178         and then Distribution_Stub_Mode = Generate_Caller_Stub_Body
4179       then
4180          No_Body := True;
4181       end if;
4182
4183       --  For a nested instance, delay processing until freeze point
4184
4185       if Has_Delayed_Freeze (Id)
4186         and then Nkind (Parent (N)) /= N_Compilation_Unit
4187       then
4188          return;
4189       end if;
4190
4191       --  For a package declaration that implies no associated body, generate
4192       --  task activation call and RACW supporting bodies now (since we won't
4193       --  have a specific separate compilation unit for that).
4194
4195       if No_Body then
4196          Push_Scope (Id);
4197
4198          --  Generate RACW subprogram bodies
4199
4200          if Has_RACW (Id) then
4201             Decls := Private_Declarations (Spec);
4202
4203             if No (Decls) then
4204                Decls := Visible_Declarations (Spec);
4205             end if;
4206
4207             if No (Decls) then
4208                Decls := New_List;
4209                Set_Visible_Declarations (Spec, Decls);
4210             end if;
4211
4212             Append_RACW_Bodies (Decls, Id);
4213             Analyze_List (Decls);
4214          end if;
4215
4216          --  Generate task activation call as last step of elaboration
4217
4218          if Present (Activation_Chain_Entity (N)) then
4219             Build_Task_Activation_Call (N);
4220          end if;
4221
4222          --  When the package is subject to pragma Initial_Condition and lacks
4223          --  a body, the assertion expression must be verified at the end of
4224          --  the visible declarations. Otherwise the check is performed at the
4225          --  end of the body statements (see Expand_N_Package_Body).
4226
4227          if Present (Get_Pragma (Id, Pragma_Initial_Condition)) then
4228             Expand_Pragma_Initial_Condition (N);
4229          end if;
4230
4231          Pop_Scope;
4232       end if;
4233
4234       --  Build dispatch tables of library level tagged types
4235
4236       if Tagged_Type_Expansion
4237         and then (Is_Compilation_Unit (Id)
4238                    or else (Is_Generic_Instance (Id)
4239                              and then Is_Library_Level_Entity (Id)))
4240       then
4241          Build_Static_Dispatch_Tables (N);
4242       end if;
4243
4244       --  Note: it is not necessary to worry about generating a subprogram
4245       --  descriptor, since the only way to get exception handlers into a
4246       --  package spec is to include instantiations, and that would cause
4247       --  generation of subprogram descriptors to be delayed in any case.
4248
4249       --  Set to encode entity names in package spec before gigi is called
4250
4251       Qualify_Entity_Names (N);
4252
4253       if Ekind (Id) /= E_Generic_Package then
4254          Build_Finalizer
4255            (N           => N,
4256             Clean_Stmts => No_List,
4257             Mark_Id     => Empty,
4258             Top_Decls   => No_List,
4259             Defer_Abort => False,
4260             Fin_Id      => Fin_Id);
4261
4262          Set_Finalizer (Id, Fin_Id);
4263       end if;
4264    end Expand_N_Package_Declaration;
4265
4266    -------------------------------------
4267    -- Expand_Pragma_Initial_Condition --
4268    -------------------------------------
4269
4270    procedure Expand_Pragma_Initial_Condition (N : Node_Id) is
4271       Loc       : constant Source_Ptr := Sloc (N);
4272       Check     : Node_Id;
4273       Expr      : Node_Id;
4274       Init_Cond : Node_Id;
4275       List      : List_Id;
4276       Pack_Id   : Entity_Id;
4277
4278    begin
4279       if Nkind (N) = N_Package_Body then
4280          Pack_Id := Corresponding_Spec (N);
4281
4282          if Present (Handled_Statement_Sequence (N)) then
4283             List := Statements (Handled_Statement_Sequence (N));
4284
4285          --  The package body lacks statements, create an empty list
4286
4287          else
4288             List := New_List;
4289
4290             Set_Handled_Statement_Sequence (N,
4291               Make_Handled_Sequence_Of_Statements (Loc, Statements => List));
4292          end if;
4293
4294       elsif Nkind (N) = N_Package_Declaration then
4295          Pack_Id := Defining_Entity (N);
4296
4297          if Present (Visible_Declarations (Specification (N))) then
4298             List := Visible_Declarations (Specification (N));
4299
4300          --  The package lacks visible declarations, create an empty list
4301
4302          else
4303             List := New_List;
4304
4305             Set_Visible_Declarations (Specification (N), List);
4306          end if;
4307
4308       --  This routine should not be used on anything other than packages
4309
4310       else
4311          raise Program_Error;
4312       end if;
4313
4314       Init_Cond := Get_Pragma (Pack_Id, Pragma_Initial_Condition);
4315
4316       --  The caller should check whether the package is subject to pragma
4317       --  Initial_Condition.
4318
4319       pragma Assert (Present (Init_Cond));
4320
4321       Expr :=
4322         Get_Pragma_Arg (First (Pragma_Argument_Associations (Init_Cond)));
4323
4324       --  The assertion expression was found to be illegal, do not generate the
4325       --  runtime check as it will repeat the illegality.
4326
4327       if Error_Posted (Init_Cond) or else Error_Posted (Expr) then
4328          return;
4329       end if;
4330
4331       --  Generate:
4332       --    pragma Check (Initial_Condition, <Expr>);
4333
4334       Check :=
4335         Make_Pragma (Loc,
4336           Chars                        => Name_Check,
4337           Pragma_Argument_Associations => New_List (
4338             Make_Pragma_Argument_Association (Loc,
4339               Expression => Make_Identifier (Loc, Name_Initial_Condition)),
4340
4341             Make_Pragma_Argument_Association (Loc,
4342               Expression => New_Copy_Tree (Expr))));
4343
4344       Append_To (List, Check);
4345       Analyze (Check);
4346    end Expand_Pragma_Initial_Condition;
4347
4348    -----------------------------
4349    -- Find_Node_To_Be_Wrapped --
4350    -----------------------------
4351
4352    function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id is
4353       P          : Node_Id;
4354       The_Parent : Node_Id;
4355
4356    begin
4357       The_Parent := N;
4358       P          := Empty;
4359       loop
4360          case Nkind (The_Parent) is
4361
4362             --  Simple statement can be wrapped
4363
4364             when N_Pragma =>
4365                return The_Parent;
4366
4367             --  Usually assignments are good candidate for wrapping except
4368             --  when they have been generated as part of a controlled aggregate
4369             --  where the wrapping should take place more globally. Note that
4370             --  No_Ctrl_Actions may be set also for non-controlled assignements
4371             --  in order to disable the use of dispatching _assign, so we need
4372             --  to test explicitly for a controlled type here.
4373
4374             when N_Assignment_Statement =>
4375                if No_Ctrl_Actions (The_Parent)
4376                  and then Needs_Finalization (Etype (Name (The_Parent)))
4377                then
4378                   null;
4379                else
4380                   return The_Parent;
4381                end if;
4382
4383             --  An entry call statement is a special case if it occurs in the
4384             --  context of a Timed_Entry_Call. In this case we wrap the entire
4385             --  timed entry call.
4386
4387             when N_Entry_Call_Statement     |
4388                  N_Procedure_Call_Statement =>
4389                if Nkind (Parent (The_Parent)) = N_Entry_Call_Alternative
4390                  and then Nkind_In (Parent (Parent (The_Parent)),
4391                                     N_Timed_Entry_Call,
4392                                     N_Conditional_Entry_Call)
4393                then
4394                   return Parent (Parent (The_Parent));
4395                else
4396                   return The_Parent;
4397                end if;
4398
4399             --  Object declarations are also a boundary for the transient scope
4400             --  even if they are not really wrapped. For further details, see
4401             --  Wrap_Transient_Declaration.
4402
4403             when N_Object_Declaration          |
4404                  N_Object_Renaming_Declaration |
4405                  N_Subtype_Declaration         =>
4406                return The_Parent;
4407
4408             --  The expression itself is to be wrapped if its parent is a
4409             --  compound statement or any other statement where the expression
4410             --  is known to be scalar.
4411
4412             when N_Accept_Alternative               |
4413                  N_Attribute_Definition_Clause      |
4414                  N_Case_Statement                   |
4415                  N_Code_Statement                   |
4416                  N_Delay_Alternative                |
4417                  N_Delay_Until_Statement            |
4418                  N_Delay_Relative_Statement         |
4419                  N_Discriminant_Association         |
4420                  N_Elsif_Part                       |
4421                  N_Entry_Body_Formal_Part           |
4422                  N_Exit_Statement                   |
4423                  N_If_Statement                     |
4424                  N_Iteration_Scheme                 |
4425                  N_Terminate_Alternative            =>
4426                pragma Assert (Present (P));
4427                return P;
4428
4429             when N_Attribute_Reference =>
4430
4431                if Is_Procedure_Attribute_Name
4432                     (Attribute_Name (The_Parent))
4433                then
4434                   return The_Parent;
4435                end if;
4436
4437             --  A raise statement can be wrapped. This will arise when the
4438             --  expression in a raise_with_expression uses the secondary
4439             --  stack, for example.
4440
4441             when N_Raise_Statement =>
4442                return The_Parent;
4443
4444             --  If the expression is within the iteration scheme of a loop,
4445             --  we must create a declaration for it, followed by an assignment
4446             --  in order to have a usable statement to wrap.
4447
4448             when N_Loop_Parameter_Specification =>
4449                return Parent (The_Parent);
4450
4451             --  The following nodes contains "dummy calls" which don't need to
4452             --  be wrapped.
4453
4454             when N_Parameter_Specification     |
4455                  N_Discriminant_Specification  |
4456                  N_Component_Declaration       =>
4457                return Empty;
4458
4459             --  The return statement is not to be wrapped when the function
4460             --  itself needs wrapping at the outer-level
4461
4462             when N_Simple_Return_Statement =>
4463                declare
4464                   Applies_To : constant Entity_Id :=
4465                                  Return_Applies_To
4466                                    (Return_Statement_Entity (The_Parent));
4467                   Return_Type : constant Entity_Id := Etype (Applies_To);
4468                begin
4469                   if Requires_Transient_Scope (Return_Type) then
4470                      return Empty;
4471                   else
4472                      return The_Parent;
4473                   end if;
4474                end;
4475
4476             --  If we leave a scope without having been able to find a node to
4477             --  wrap, something is going wrong but this can happen in error
4478             --  situation that are not detected yet (such as a dynamic string
4479             --  in a pragma export)
4480
4481             when N_Subprogram_Body     |
4482                  N_Package_Declaration |
4483                  N_Package_Body        |
4484                  N_Block_Statement     =>
4485                return Empty;
4486
4487             --  Otherwise continue the search
4488
4489             when others =>
4490                null;
4491          end case;
4492
4493          P          := The_Parent;
4494          The_Parent := Parent (P);
4495       end loop;
4496    end Find_Node_To_Be_Wrapped;
4497
4498    -------------------------------------
4499    -- Get_Global_Pool_For_Access_Type --
4500    -------------------------------------
4501
4502    function Get_Global_Pool_For_Access_Type (T : Entity_Id) return Entity_Id is
4503    begin
4504       --  Access types whose size is smaller than System.Address size can exist
4505       --  only on VMS. We can't use the usual global pool which returns an
4506       --  object of type Address as truncation will make it invalid. To handle
4507       --  this case, VMS has a dedicated global pool that returns addresses
4508       --  that fit into 32 bit accesses.
4509
4510       if Opt.True_VMS_Target and then Esize (T) = 32 then
4511          return RTE (RE_Global_Pool_32_Object);
4512       else
4513          return RTE (RE_Global_Pool_Object);
4514       end if;
4515    end Get_Global_Pool_For_Access_Type;
4516
4517    ----------------------------------
4518    -- Has_New_Controlled_Component --
4519    ----------------------------------
4520
4521    function Has_New_Controlled_Component (E : Entity_Id) return Boolean is
4522       Comp : Entity_Id;
4523
4524    begin
4525       if not Is_Tagged_Type (E) then
4526          return Has_Controlled_Component (E);
4527       elsif not Is_Derived_Type (E) then
4528          return Has_Controlled_Component (E);
4529       end if;
4530
4531       Comp := First_Component (E);
4532       while Present (Comp) loop
4533          if Chars (Comp) = Name_uParent then
4534             null;
4535
4536          elsif Scope (Original_Record_Component (Comp)) = E
4537            and then Needs_Finalization (Etype (Comp))
4538          then
4539             return True;
4540          end if;
4541
4542          Next_Component (Comp);
4543       end loop;
4544
4545       return False;
4546    end Has_New_Controlled_Component;
4547
4548    ---------------------------------
4549    -- Has_Simple_Protected_Object --
4550    ---------------------------------
4551
4552    function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is
4553    begin
4554       if Has_Task (T) then
4555          return False;
4556
4557       elsif Is_Simple_Protected_Type (T) then
4558          return True;
4559
4560       elsif Is_Array_Type (T) then
4561          return Has_Simple_Protected_Object (Component_Type (T));
4562
4563       elsif Is_Record_Type (T) then
4564          declare
4565             Comp : Entity_Id;
4566
4567          begin
4568             Comp := First_Component (T);
4569             while Present (Comp) loop
4570                if Has_Simple_Protected_Object (Etype (Comp)) then
4571                   return True;
4572                end if;
4573
4574                Next_Component (Comp);
4575             end loop;
4576
4577             return False;
4578          end;
4579
4580       else
4581          return False;
4582       end if;
4583    end Has_Simple_Protected_Object;
4584
4585    ------------------------------------
4586    -- Insert_Actions_In_Scope_Around --
4587    ------------------------------------
4588
4589    procedure Insert_Actions_In_Scope_Around (N : Node_Id) is
4590       Act_After   : constant List_Id :=
4591         Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (After);
4592       Act_Before  : constant List_Id :=
4593         Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Before);
4594       --  Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
4595       --  Last), but this was incorrect as Process_Transient_Object may
4596       --  introduce new scopes and cause a reallocation of Scope_Stack.Table.
4597
4598       procedure Process_Transient_Objects
4599         (First_Object : Node_Id;
4600          Last_Object  : Node_Id;
4601          Related_Node : Node_Id);
4602       --  First_Object and Last_Object define a list which contains potential
4603       --  controlled transient objects. Finalization flags are inserted before
4604       --  First_Object and finalization calls are inserted after Last_Object.
4605       --  Related_Node is the node for which transient objects have been
4606       --  created.
4607
4608       -------------------------------
4609       -- Process_Transient_Objects --
4610       -------------------------------
4611
4612       procedure Process_Transient_Objects
4613         (First_Object : Node_Id;
4614          Last_Object  : Node_Id;
4615          Related_Node : Node_Id)
4616       is
4617          Must_Hook : Boolean := False;
4618          --  Flag denoting whether the context requires transient variable
4619          --  export to the outer finalizer.
4620
4621          function Is_Subprogram_Call (N : Node_Id) return Traverse_Result;
4622          --  Determine whether an arbitrary node denotes a subprogram call
4623
4624          procedure Detect_Subprogram_Call is
4625            new Traverse_Proc (Is_Subprogram_Call);
4626
4627          ------------------------
4628          -- Is_Subprogram_Call --
4629          ------------------------
4630
4631          function Is_Subprogram_Call (N : Node_Id) return Traverse_Result is
4632          begin
4633             --  Complex constructs are factored out by the expander and their
4634             --  occurrences are replaced with references to temporaries. Due to
4635             --  this expansion activity, inspect the original tree to detect
4636             --  subprogram calls.
4637
4638             if Nkind (N) = N_Identifier and then Original_Node (N) /= N then
4639                Detect_Subprogram_Call (Original_Node (N));
4640
4641                --  The original construct contains a subprogram call, there is
4642                --  no point in continuing the tree traversal.
4643
4644                if Must_Hook then
4645                   return Abandon;
4646                else
4647                   return OK;
4648                end if;
4649
4650             --  The original construct contains a subprogram call, there is no
4651             --  point in continuing the tree traversal.
4652
4653             elsif Nkind (N) = N_Object_Declaration
4654               and then Present (Expression (N))
4655               and then Nkind (Original_Node (Expression (N))) = N_Function_Call
4656             then
4657                Must_Hook := True;
4658                return Abandon;
4659
4660             --  A regular procedure or function call
4661
4662             elsif Nkind (N) in N_Subprogram_Call then
4663                Must_Hook := True;
4664                return Abandon;
4665
4666             --  Keep searching
4667
4668             else
4669                return OK;
4670             end if;
4671          end Is_Subprogram_Call;
4672
4673          --  Local variables
4674
4675          Built     : Boolean := False;
4676          Desig_Typ : Entity_Id;
4677          Expr      : Node_Id;
4678          Fin_Block : Node_Id;
4679          Fin_Data  : Finalization_Exception_Data;
4680          Fin_Decls : List_Id;
4681          Fin_Insrt : Node_Id;
4682          Last_Fin  : Node_Id := Empty;
4683          Loc       : Source_Ptr;
4684          Obj_Id    : Entity_Id;
4685          Obj_Ref   : Node_Id;
4686          Obj_Typ   : Entity_Id;
4687          Prev_Fin  : Node_Id := Empty;
4688          Ptr_Id    : Entity_Id;
4689          Stmt      : Node_Id;
4690          Stmts     : List_Id;
4691          Temp_Id   : Entity_Id;
4692          Temp_Ins  : Node_Id;
4693
4694       --  Start of processing for Process_Transient_Objects
4695
4696       begin
4697          --  Recognize a scenario where the transient context is an object
4698          --  declaration initialized by a build-in-place function call:
4699
4700          --    Obj : ... := BIP_Function_Call (Ctrl_Func_Call);
4701
4702          --  The rough expansion of the above is:
4703
4704          --    Temp : ... := Ctrl_Func_Call;
4705          --    Obj  : ...;
4706          --    Res  : ... := BIP_Func_Call (..., Obj, ...);
4707
4708          --  The finalization of any controlled transient must happen after
4709          --  the build-in-place function call is executed.
4710
4711          if Nkind (N) = N_Object_Declaration
4712            and then Present (BIP_Initialization_Call (Defining_Identifier (N)))
4713          then
4714             Must_Hook := True;
4715             Fin_Insrt := BIP_Initialization_Call (Defining_Identifier (N));
4716
4717          --  Search the context for at least one subprogram call. If found, the
4718          --  machinery exports all transient objects to the enclosing finalizer
4719          --  due to the possibility of abnormal call termination.
4720
4721          else
4722             Detect_Subprogram_Call (N);
4723             Fin_Insrt := Last_Object;
4724          end if;
4725
4726          --  Examine all objects in the list First_Object .. Last_Object
4727
4728          Stmt := First_Object;
4729          while Present (Stmt) loop
4730             if Nkind (Stmt) = N_Object_Declaration
4731               and then Analyzed (Stmt)
4732               and then Is_Finalizable_Transient (Stmt, N)
4733
4734               --  Do not process the node to be wrapped since it will be
4735               --  handled by the enclosing finalizer.
4736
4737               and then Stmt /= Related_Node
4738             then
4739                Loc       := Sloc (Stmt);
4740                Obj_Id    := Defining_Identifier (Stmt);
4741                Obj_Typ   := Base_Type (Etype (Obj_Id));
4742                Desig_Typ := Obj_Typ;
4743
4744                Set_Is_Processed_Transient (Obj_Id);
4745
4746                --  Handle access types
4747
4748                if Is_Access_Type (Desig_Typ) then
4749                   Desig_Typ := Available_View (Designated_Type (Desig_Typ));
4750                end if;
4751
4752                --  Create the necessary entities and declarations the first
4753                --  time around.
4754
4755                if not Built then
4756                   Built     := True;
4757                   Fin_Decls := New_List;
4758
4759                   Build_Object_Declarations (Fin_Data, Fin_Decls, Loc);
4760                end if;
4761
4762                --  Transient variables associated with subprogram calls need
4763                --  extra processing. These variables are usually created right
4764                --  before the call and finalized immediately after the call.
4765                --  If an exception occurs during the call, the clean up code
4766                --  is skipped due to the sudden change in control and the
4767                --  transient is never finalized.
4768
4769                --  To handle this case, such variables are "exported" to the
4770                --  enclosing sequence of statements where their corresponding
4771                --  "hooks" are picked up by the finalization machinery.
4772
4773                if Must_Hook then
4774
4775                   --  Step 1: Create an access type which provides a reference
4776                   --  to the transient object. Generate:
4777
4778                   --    Ann : access [all] <Desig_Typ>;
4779
4780                   Ptr_Id := Make_Temporary (Loc, 'A');
4781
4782                   Insert_Action (Stmt,
4783                     Make_Full_Type_Declaration (Loc,
4784                       Defining_Identifier => Ptr_Id,
4785                       Type_Definition     =>
4786                         Make_Access_To_Object_Definition (Loc,
4787                           All_Present        =>
4788                             Ekind (Obj_Typ) = E_General_Access_Type,
4789                           Subtype_Indication =>
4790                             New_Occurrence_Of (Desig_Typ, Loc))));
4791
4792                   --  Step 2: Create a temporary which acts as a hook to the
4793                   --  transient object. Generate:
4794
4795                   --    Temp : Ptr_Id := null;
4796
4797                   Temp_Id := Make_Temporary (Loc, 'T');
4798
4799                   Insert_Action (Stmt,
4800                     Make_Object_Declaration (Loc,
4801                       Defining_Identifier => Temp_Id,
4802                       Object_Definition   =>
4803                         New_Occurrence_Of (Ptr_Id, Loc)));
4804
4805                   --  Mark the temporary as a transient hook. This signals the
4806                   --  machinery in Build_Finalizer to recognize this special
4807                   --  case.
4808
4809                   Set_Status_Flag_Or_Transient_Decl (Temp_Id, Stmt);
4810
4811                   --  Step 3: Hook the transient object to the temporary
4812
4813                   if Is_Access_Type (Obj_Typ) then
4814                      Expr :=
4815                        Convert_To (Ptr_Id, New_Occurrence_Of (Obj_Id, Loc));
4816                   else
4817                      Expr :=
4818                        Make_Attribute_Reference (Loc,
4819                          Prefix         => New_Occurrence_Of (Obj_Id, Loc),
4820                          Attribute_Name => Name_Unrestricted_Access);
4821                   end if;
4822
4823                   --  Generate:
4824                   --    Temp := Ptr_Id (Obj_Id);
4825                   --      <or>
4826                   --    Temp := Obj_Id'Unrestricted_Access;
4827
4828                   --  When the transient object is initialized by an aggregate,
4829                   --  the hook must capture the object after the last component
4830                   --  assignment takes place. Only then is the object fully
4831                   --  initialized.
4832
4833                   if Ekind (Obj_Id) = E_Variable
4834                     and then Present (Last_Aggregate_Assignment (Obj_Id))
4835                   then
4836                      Temp_Ins := Last_Aggregate_Assignment (Obj_Id);
4837
4838                   --  Otherwise the hook seizes the related object immediately
4839
4840                   else
4841                      Temp_Ins := Stmt;
4842                   end if;
4843
4844                   Insert_After_And_Analyze (Temp_Ins,
4845                     Make_Assignment_Statement (Loc,
4846                       Name       => New_Occurrence_Of (Temp_Id, Loc),
4847                       Expression => Expr));
4848                end if;
4849
4850                Stmts := New_List;
4851
4852                --  The transient object is about to be finalized by the clean
4853                --  up code following the subprogram call. In order to avoid
4854                --  double finalization, clear the hook.
4855
4856                --  Generate:
4857                --    Temp := null;
4858
4859                if Must_Hook then
4860                   Append_To (Stmts,
4861                     Make_Assignment_Statement (Loc,
4862                       Name       => New_Occurrence_Of (Temp_Id, Loc),
4863                       Expression => Make_Null (Loc)));
4864                end if;
4865
4866                --  Generate:
4867                --    [Deep_]Finalize (Obj_Ref);
4868
4869                Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
4870
4871                if Is_Access_Type (Obj_Typ) then
4872                   Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
4873                end if;
4874
4875                Append_To (Stmts,
4876                  Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Desig_Typ));
4877
4878                --  Generate:
4879                --    [Temp := null;]
4880                --    begin
4881                --       [Deep_]Finalize (Obj_Ref);
4882
4883                --    exception
4884                --       when others =>
4885                --          if not Raised then
4886                --             Raised := True;
4887                --             Save_Occurrence
4888                --               (Enn, Get_Current_Excep.all.all);
4889                --          end if;
4890                --    end;
4891
4892                Fin_Block :=
4893                  Make_Block_Statement (Loc,
4894                    Handled_Statement_Sequence =>
4895                      Make_Handled_Sequence_Of_Statements (Loc,
4896                        Statements => Stmts,
4897                        Exception_Handlers => New_List (
4898                          Build_Exception_Handler (Fin_Data))));
4899
4900                --  The single raise statement must be inserted after all the
4901                --  finalization blocks, and we put everything into a wrapper
4902                --  block to clearly expose the construct to the back-end.
4903
4904                if Present (Prev_Fin) then
4905                   Insert_Before_And_Analyze (Prev_Fin, Fin_Block);
4906                else
4907                   Insert_After_And_Analyze (Fin_Insrt,
4908                     Make_Block_Statement (Loc,
4909                       Declarations => Fin_Decls,
4910                       Handled_Statement_Sequence =>
4911                         Make_Handled_Sequence_Of_Statements (Loc,
4912                           Statements => New_List (Fin_Block))));
4913
4914                   Last_Fin := Fin_Block;
4915                end if;
4916
4917                Prev_Fin := Fin_Block;
4918             end if;
4919
4920             --  Terminate the scan after the last object has been processed to
4921             --  avoid touching unrelated code.
4922
4923             if Stmt = Last_Object then
4924                exit;
4925             end if;
4926
4927             Next (Stmt);
4928          end loop;
4929
4930          --  Generate:
4931          --    if Raised and then not Abort then
4932          --       Raise_From_Controlled_Operation (E);
4933          --    end if;
4934
4935          if Built and then Present (Last_Fin) then
4936             Insert_After_And_Analyze (Last_Fin,
4937               Build_Raise_Statement (Fin_Data));
4938          end if;
4939       end Process_Transient_Objects;
4940
4941    --  Start of processing for Insert_Actions_In_Scope_Around
4942
4943    begin
4944       if No (Act_Before) and then No (Act_After) then
4945          return;
4946       end if;
4947
4948       declare
4949          Node_To_Wrap : constant Node_Id := Node_To_Be_Wrapped;
4950          First_Obj    : Node_Id;
4951          Last_Obj     : Node_Id;
4952          Target       : Node_Id;
4953
4954       begin
4955          --  If the node to be wrapped is the trigger of an asynchronous
4956          --  select, it is not part of a statement list. The actions must be
4957          --  inserted before the select itself, which is part of some list of
4958          --  statements. Note that the triggering alternative includes the
4959          --  triggering statement and an optional statement list. If the node
4960          --  to be wrapped is part of that list, the normal insertion applies.
4961
4962          if Nkind (Parent (Node_To_Wrap)) = N_Triggering_Alternative
4963            and then not Is_List_Member (Node_To_Wrap)
4964          then
4965             Target := Parent (Parent (Node_To_Wrap));
4966          else
4967             Target := N;
4968          end if;
4969
4970          First_Obj := Target;
4971          Last_Obj  := Target;
4972
4973          --  Add all actions associated with a transient scope into the main
4974          --  tree. There are several scenarios here:
4975
4976          --       +--- Before ----+        +----- After ---+
4977          --    1) First_Obj ....... Target ........ Last_Obj
4978
4979          --    2) First_Obj ....... Target
4980
4981          --    3)                   Target ........ Last_Obj
4982
4983          if Present (Act_Before) then
4984
4985             --  Flag declarations are inserted before the first object
4986
4987             First_Obj := First (Act_Before);
4988
4989             Insert_List_Before (Target, Act_Before);
4990          end if;
4991
4992          if Present (Act_After) then
4993
4994             --  Finalization calls are inserted after the last object
4995
4996             Last_Obj := Last (Act_After);
4997
4998             Insert_List_After (Target, Act_After);
4999          end if;
5000
5001          --  Check for transient controlled objects associated with Target and
5002          --  generate the appropriate finalization actions for them.
5003
5004          Process_Transient_Objects
5005            (First_Object => First_Obj,
5006             Last_Object  => Last_Obj,
5007             Related_Node => Target);
5008
5009          --  Reset the action lists
5010
5011          if Present (Act_Before) then
5012             Scope_Stack.Table (Scope_Stack.Last).
5013               Actions_To_Be_Wrapped (Before) := No_List;
5014          end if;
5015
5016          if Present (Act_After) then
5017             Scope_Stack.Table (Scope_Stack.Last).
5018               Actions_To_Be_Wrapped (After) := No_List;
5019          end if;
5020       end;
5021    end Insert_Actions_In_Scope_Around;
5022
5023    ------------------------------
5024    -- Is_Simple_Protected_Type --
5025    ------------------------------
5026
5027    function Is_Simple_Protected_Type (T : Entity_Id) return Boolean is
5028    begin
5029       return
5030         Is_Protected_Type (T)
5031           and then not Uses_Lock_Free (T)
5032           and then not Has_Entries (T)
5033           and then Is_RTE (Find_Protection_Type (T), RE_Protection);
5034    end Is_Simple_Protected_Type;
5035
5036    -----------------------
5037    -- Make_Adjust_Call --
5038    -----------------------
5039
5040    function Make_Adjust_Call
5041      (Obj_Ref   : Node_Id;
5042       Typ       : Entity_Id;
5043       Skip_Self : Boolean := False) return Node_Id
5044    is
5045       Loc    : constant Source_Ptr := Sloc (Obj_Ref);
5046       Adj_Id : Entity_Id := Empty;
5047       Ref    : Node_Id   := Obj_Ref;
5048       Utyp   : Entity_Id;
5049
5050    begin
5051       --  Recover the proper type which contains Deep_Adjust
5052
5053       if Is_Class_Wide_Type (Typ) then
5054          Utyp := Root_Type (Typ);
5055       else
5056          Utyp := Typ;
5057       end if;
5058
5059       Utyp := Underlying_Type (Base_Type (Utyp));
5060       Set_Assignment_OK (Ref);
5061
5062       --  Deal with non-tagged derivation of private views
5063
5064       if Is_Untagged_Derivation (Typ) then
5065          Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
5066          Ref  := Unchecked_Convert_To (Utyp, Ref);
5067          Set_Assignment_OK (Ref);
5068       end if;
5069
5070       --  When dealing with the completion of a private type, use the base
5071       --  type instead.
5072
5073       if Utyp /= Base_Type (Utyp) then
5074          pragma Assert (Is_Private_Type (Typ));
5075
5076          Utyp := Base_Type (Utyp);
5077          Ref  := Unchecked_Convert_To (Utyp, Ref);
5078       end if;
5079
5080       if Skip_Self then
5081          if Has_Controlled_Component (Utyp) then
5082             if Is_Tagged_Type (Utyp) then
5083                Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
5084             else
5085                Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
5086             end if;
5087          end if;
5088
5089       --  Class-wide types, interfaces and types with controlled components
5090
5091       elsif Is_Class_Wide_Type (Typ)
5092         or else Is_Interface (Typ)
5093         or else Has_Controlled_Component (Utyp)
5094       then
5095          if Is_Tagged_Type (Utyp) then
5096             Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
5097          else
5098             Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
5099          end if;
5100
5101       --  Derivations from [Limited_]Controlled
5102
5103       elsif Is_Controlled (Utyp) then
5104          if Has_Controlled_Component (Utyp) then
5105             Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
5106          else
5107             Adj_Id := Find_Prim_Op (Utyp, Name_Of (Adjust_Case));
5108          end if;
5109
5110       --  Tagged types
5111
5112       elsif Is_Tagged_Type (Utyp) then
5113          Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
5114
5115       else
5116          raise Program_Error;
5117       end if;
5118
5119       if Present (Adj_Id) then
5120
5121          --  If the object is unanalyzed, set its expected type for use in
5122          --  Convert_View in case an additional conversion is needed.
5123
5124          if No (Etype (Ref))
5125            and then Nkind (Ref) /= N_Unchecked_Type_Conversion
5126          then
5127             Set_Etype (Ref, Typ);
5128          end if;
5129
5130          --  The object reference may need another conversion depending on the
5131          --  type of the formal and that of the actual.
5132
5133          if not Is_Class_Wide_Type (Typ) then
5134             Ref := Convert_View (Adj_Id, Ref);
5135          end if;
5136
5137          return
5138            Make_Call (Loc,
5139              Proc_Id   => Adj_Id,
5140              Param     => New_Copy_Tree (Ref),
5141              Skip_Self => Skip_Self);
5142       else
5143          return Empty;
5144       end if;
5145    end Make_Adjust_Call;
5146
5147    ----------------------
5148    -- Make_Attach_Call --
5149    ----------------------
5150
5151    function Make_Attach_Call
5152      (Obj_Ref : Node_Id;
5153       Ptr_Typ : Entity_Id) return Node_Id
5154    is
5155       pragma Assert (VM_Target /= No_VM);
5156
5157       Loc : constant Source_Ptr := Sloc (Obj_Ref);
5158    begin
5159       return
5160         Make_Procedure_Call_Statement (Loc,
5161           Name                   =>
5162             New_Occurrence_Of (RTE (RE_Attach), Loc),
5163           Parameter_Associations => New_List (
5164             New_Occurrence_Of (Finalization_Master (Ptr_Typ), Loc),
5165             Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref)));
5166    end Make_Attach_Call;
5167
5168    ----------------------
5169    -- Make_Detach_Call --
5170    ----------------------
5171
5172    function Make_Detach_Call (Obj_Ref : Node_Id) return Node_Id is
5173       Loc : constant Source_Ptr := Sloc (Obj_Ref);
5174
5175    begin
5176       return
5177         Make_Procedure_Call_Statement (Loc,
5178           Name                   =>
5179             New_Occurrence_Of (RTE (RE_Detach), Loc),
5180           Parameter_Associations => New_List (
5181             Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref)));
5182    end Make_Detach_Call;
5183
5184    ---------------
5185    -- Make_Call --
5186    ---------------
5187
5188    function Make_Call
5189      (Loc       : Source_Ptr;
5190       Proc_Id   : Entity_Id;
5191       Param     : Node_Id;
5192       Skip_Self : Boolean := False) return Node_Id
5193    is
5194       Params : constant List_Id := New_List (Param);
5195
5196    begin
5197       --  Do not apply the controlled action to the object itself by signaling
5198       --  the related routine to avoid self.
5199
5200       if Skip_Self then
5201          Append_To (Params, New_Occurrence_Of (Standard_False, Loc));
5202       end if;
5203
5204       return
5205         Make_Procedure_Call_Statement (Loc,
5206           Name                   => New_Occurrence_Of (Proc_Id, Loc),
5207           Parameter_Associations => Params);
5208    end Make_Call;
5209
5210    --------------------------
5211    -- Make_Deep_Array_Body --
5212    --------------------------
5213
5214    function Make_Deep_Array_Body
5215      (Prim : Final_Primitives;
5216       Typ  : Entity_Id) return List_Id
5217    is
5218       function Build_Adjust_Or_Finalize_Statements
5219         (Typ : Entity_Id) return List_Id;
5220       --  Create the statements necessary to adjust or finalize an array of
5221       --  controlled elements. Generate:
5222       --
5223       --    declare
5224       --       Abort  : constant Boolean := Triggered_By_Abort;
5225       --         <or>
5226       --       Abort  : constant Boolean := False;  --  no abort
5227       --
5228       --       E      : Exception_Occurrence;
5229       --       Raised : Boolean := False;
5230       --
5231       --    begin
5232       --       for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
5233       --                 ^--  in the finalization case
5234       --          ...
5235       --          for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
5236       --             begin
5237       --                [Deep_]Adjust / Finalize (V (J1, ..., Jn));
5238       --
5239       --             exception
5240       --                when others =>
5241       --                   if not Raised then
5242       --                      Raised := True;
5243       --                      Save_Occurrence (E, Get_Current_Excep.all.all);
5244       --                   end if;
5245       --             end;
5246       --          end loop;
5247       --          ...
5248       --       end loop;
5249       --
5250       --       if Raised and then not Abort then
5251       --          Raise_From_Controlled_Operation (E);
5252       --       end if;
5253       --    end;
5254
5255       function Build_Initialize_Statements (Typ : Entity_Id) return List_Id;
5256       --  Create the statements necessary to initialize an array of controlled
5257       --  elements. Include a mechanism to carry out partial finalization if an
5258       --  exception occurs. Generate:
5259       --
5260       --    declare
5261       --       Counter : Integer := 0;
5262       --
5263       --    begin
5264       --       for J1 in V'Range (1) loop
5265       --          ...
5266       --          for JN in V'Range (N) loop
5267       --             begin
5268       --                [Deep_]Initialize (V (J1, ..., JN));
5269       --
5270       --                Counter := Counter + 1;
5271       --
5272       --             exception
5273       --                when others =>
5274       --                   declare
5275       --                      Abort  : constant Boolean := Triggered_By_Abort;
5276       --                        <or>
5277       --                      Abort  : constant Boolean := False; --  no abort
5278       --                      E      : Exception_Occurence;
5279       --                      Raised : Boolean := False;
5280
5281       --                   begin
5282       --                      Counter :=
5283       --                        V'Length (1) *
5284       --                        V'Length (2) *
5285       --                        ...
5286       --                        V'Length (N) - Counter;
5287
5288       --                      for F1 in reverse V'Range (1) loop
5289       --                         ...
5290       --                         for FN in reverse V'Range (N) loop
5291       --                            if Counter > 0 then
5292       --                               Counter := Counter - 1;
5293       --                            else
5294       --                               begin
5295       --                                  [Deep_]Finalize (V (F1, ..., FN));
5296
5297       --                               exception
5298       --                                  when others =>
5299       --                                     if not Raised then
5300       --                                        Raised := True;
5301       --                                        Save_Occurrence (E,
5302       --                                          Get_Current_Excep.all.all);
5303       --                                     end if;
5304       --                               end;
5305       --                            end if;
5306       --                         end loop;
5307       --                         ...
5308       --                      end loop;
5309       --                   end;
5310       --
5311       --                   if Raised and then not Abort then
5312       --                      Raise_From_Controlled_Operation (E);
5313       --                   end if;
5314       --
5315       --                   raise;
5316       --             end;
5317       --          end loop;
5318       --       end loop;
5319       --    end;
5320
5321       function New_References_To
5322         (L   : List_Id;
5323          Loc : Source_Ptr) return List_Id;
5324       --  Given a list of defining identifiers, return a list of references to
5325       --  the original identifiers, in the same order as they appear.
5326
5327       -----------------------------------------
5328       -- Build_Adjust_Or_Finalize_Statements --
5329       -----------------------------------------
5330
5331       function Build_Adjust_Or_Finalize_Statements
5332         (Typ : Entity_Id) return List_Id
5333       is
5334          Comp_Typ        : constant Entity_Id  := Component_Type (Typ);
5335          Index_List      : constant List_Id    := New_List;
5336          Loc             : constant Source_Ptr := Sloc (Typ);
5337          Num_Dims        : constant Int        := Number_Dimensions (Typ);
5338          Finalizer_Decls : List_Id := No_List;
5339          Finalizer_Data  : Finalization_Exception_Data;
5340          Call            : Node_Id;
5341          Comp_Ref        : Node_Id;
5342          Core_Loop       : Node_Id;
5343          Dim             : Int;
5344          J               : Entity_Id;
5345          Loop_Id         : Entity_Id;
5346          Stmts           : List_Id;
5347
5348          Exceptions_OK : constant Boolean :=
5349                            not Restriction_Active (No_Exception_Propagation);
5350
5351          procedure Build_Indexes;
5352          --  Generate the indexes used in the dimension loops
5353
5354          -------------------
5355          -- Build_Indexes --
5356          -------------------
5357
5358          procedure Build_Indexes is
5359          begin
5360             --  Generate the following identifiers:
5361             --    Jnn  -  for initialization
5362
5363             for Dim in 1 .. Num_Dims loop
5364                Append_To (Index_List,
5365                  Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));
5366             end loop;
5367          end Build_Indexes;
5368
5369       --  Start of processing for Build_Adjust_Or_Finalize_Statements
5370
5371       begin
5372          Finalizer_Decls := New_List;
5373
5374          Build_Indexes;
5375          Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
5376
5377          Comp_Ref :=
5378            Make_Indexed_Component (Loc,
5379              Prefix      => Make_Identifier (Loc, Name_V),
5380              Expressions => New_References_To (Index_List, Loc));
5381          Set_Etype (Comp_Ref, Comp_Typ);
5382
5383          --  Generate:
5384          --    [Deep_]Adjust (V (J1, ..., JN))
5385
5386          if Prim = Adjust_Case then
5387             Call := Make_Adjust_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
5388
5389          --  Generate:
5390          --    [Deep_]Finalize (V (J1, ..., JN))
5391
5392          else pragma Assert (Prim = Finalize_Case);
5393             Call := Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
5394          end if;
5395
5396          --  Generate the block which houses the adjust or finalize call:
5397
5398          --    <adjust or finalize call>;  --  No_Exception_Propagation
5399
5400          --    begin                       --  Exception handlers allowed
5401          --       <adjust or finalize call>
5402
5403          --    exception
5404          --       when others =>
5405          --          if not Raised then
5406          --             Raised := True;
5407          --             Save_Occurrence (E, Get_Current_Excep.all.all);
5408          --          end if;
5409          --    end;
5410
5411          if Exceptions_OK then
5412             Core_Loop :=
5413               Make_Block_Statement (Loc,
5414                 Handled_Statement_Sequence =>
5415                   Make_Handled_Sequence_Of_Statements (Loc,
5416                     Statements         => New_List (Call),
5417                     Exception_Handlers => New_List (
5418                       Build_Exception_Handler (Finalizer_Data))));
5419          else
5420             Core_Loop := Call;
5421          end if;
5422
5423          --  Generate the dimension loops starting from the innermost one
5424
5425          --    for Jnn in [reverse] V'Range (Dim) loop
5426          --       <core loop>
5427          --    end loop;
5428
5429          J := Last (Index_List);
5430          Dim := Num_Dims;
5431          while Present (J) and then Dim > 0 loop
5432             Loop_Id := J;
5433             Prev (J);
5434             Remove (Loop_Id);
5435
5436             Core_Loop :=
5437               Make_Loop_Statement (Loc,
5438                 Iteration_Scheme =>
5439                   Make_Iteration_Scheme (Loc,
5440                     Loop_Parameter_Specification =>
5441                       Make_Loop_Parameter_Specification (Loc,
5442                         Defining_Identifier         => Loop_Id,
5443                         Discrete_Subtype_Definition =>
5444                           Make_Attribute_Reference (Loc,
5445                             Prefix         => Make_Identifier (Loc, Name_V),
5446                             Attribute_Name => Name_Range,
5447                             Expressions    => New_List (
5448                               Make_Integer_Literal (Loc, Dim))),
5449
5450                         Reverse_Present => Prim = Finalize_Case)),
5451
5452                 Statements => New_List (Core_Loop),
5453                 End_Label  => Empty);
5454
5455             Dim := Dim - 1;
5456          end loop;
5457
5458          --  Generate the block which contains the core loop, the declarations
5459          --  of the abort flag, the exception occurrence, the raised flag and
5460          --  the conditional raise:
5461
5462          --    declare
5463          --       Abort  : constant Boolean := Triggered_By_Abort;
5464          --         <or>
5465          --       Abort  : constant Boolean := False;  --  no abort
5466
5467          --       E      : Exception_Occurrence;
5468          --       Raised : Boolean := False;
5469
5470          --    begin
5471          --       <core loop>
5472
5473          --       if Raised and then not Abort then  --  Expection handlers OK
5474          --          Raise_From_Controlled_Operation (E);
5475          --       end if;
5476          --    end;
5477
5478          Stmts := New_List (Core_Loop);
5479
5480          if Exceptions_OK then
5481             Append_To (Stmts,
5482               Build_Raise_Statement (Finalizer_Data));
5483          end if;
5484
5485          return
5486            New_List (
5487              Make_Block_Statement (Loc,
5488                Declarations               =>
5489                  Finalizer_Decls,
5490                Handled_Statement_Sequence =>
5491                  Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
5492       end Build_Adjust_Or_Finalize_Statements;
5493
5494       ---------------------------------
5495       -- Build_Initialize_Statements --
5496       ---------------------------------
5497
5498       function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is
5499          Comp_Typ        : constant Entity_Id  := Component_Type (Typ);
5500          Final_List      : constant List_Id    := New_List;
5501          Index_List      : constant List_Id    := New_List;
5502          Loc             : constant Source_Ptr := Sloc (Typ);
5503          Num_Dims        : constant Int        := Number_Dimensions (Typ);
5504          Counter_Id      : Entity_Id;
5505          Dim             : Int;
5506          F               : Node_Id;
5507          Fin_Stmt        : Node_Id;
5508          Final_Block     : Node_Id;
5509          Final_Loop      : Node_Id;
5510          Finalizer_Data  : Finalization_Exception_Data;
5511          Finalizer_Decls : List_Id := No_List;
5512          Init_Loop       : Node_Id;
5513          J               : Node_Id;
5514          Loop_Id         : Node_Id;
5515          Stmts           : List_Id;
5516
5517          Exceptions_OK : constant Boolean :=
5518                            not Restriction_Active (No_Exception_Propagation);
5519
5520          function Build_Counter_Assignment return Node_Id;
5521          --  Generate the following assignment:
5522          --    Counter := V'Length (1) *
5523          --               ...
5524          --               V'Length (N) - Counter;
5525
5526          function Build_Finalization_Call return Node_Id;
5527          --  Generate a deep finalization call for an array element
5528
5529          procedure Build_Indexes;
5530          --  Generate the initialization and finalization indexes used in the
5531          --  dimension loops.
5532
5533          function Build_Initialization_Call return Node_Id;
5534          --  Generate a deep initialization call for an array element
5535
5536          ------------------------------
5537          -- Build_Counter_Assignment --
5538          ------------------------------
5539
5540          function Build_Counter_Assignment return Node_Id is
5541             Dim  : Int;
5542             Expr : Node_Id;
5543
5544          begin
5545             --  Start from the first dimension and generate:
5546             --    V'Length (1)
5547
5548             Dim := 1;
5549             Expr :=
5550               Make_Attribute_Reference (Loc,
5551                 Prefix         => Make_Identifier (Loc, Name_V),
5552                 Attribute_Name => Name_Length,
5553                 Expressions    => New_List (Make_Integer_Literal (Loc, Dim)));
5554
5555             --  Process the rest of the dimensions, generate:
5556             --    Expr * V'Length (N)
5557
5558             Dim := Dim + 1;
5559             while Dim <= Num_Dims loop
5560                Expr :=
5561                  Make_Op_Multiply (Loc,
5562                    Left_Opnd  => Expr,
5563                    Right_Opnd =>
5564                      Make_Attribute_Reference (Loc,
5565                        Prefix         => Make_Identifier (Loc, Name_V),
5566                        Attribute_Name => Name_Length,
5567                        Expressions    => New_List (
5568                          Make_Integer_Literal (Loc, Dim))));
5569
5570                Dim := Dim + 1;
5571             end loop;
5572
5573             --  Generate:
5574             --    Counter := Expr - Counter;
5575
5576             return
5577               Make_Assignment_Statement (Loc,
5578                 Name       => New_Occurrence_Of (Counter_Id, Loc),
5579                 Expression =>
5580                   Make_Op_Subtract (Loc,
5581                     Left_Opnd  => Expr,
5582                     Right_Opnd => New_Occurrence_Of (Counter_Id, Loc)));
5583          end Build_Counter_Assignment;
5584
5585          -----------------------------
5586          -- Build_Finalization_Call --
5587          -----------------------------
5588
5589          function Build_Finalization_Call return Node_Id is
5590             Comp_Ref : constant Node_Id :=
5591                          Make_Indexed_Component (Loc,
5592                            Prefix      => Make_Identifier (Loc, Name_V),
5593                            Expressions => New_References_To (Final_List, Loc));
5594
5595          begin
5596             Set_Etype (Comp_Ref, Comp_Typ);
5597
5598             --  Generate:
5599             --    [Deep_]Finalize (V);
5600
5601             return Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
5602          end Build_Finalization_Call;
5603
5604          -------------------
5605          -- Build_Indexes --
5606          -------------------
5607
5608          procedure Build_Indexes is
5609          begin
5610             --  Generate the following identifiers:
5611             --    Jnn  -  for initialization
5612             --    Fnn  -  for finalization
5613
5614             for Dim in 1 .. Num_Dims loop
5615                Append_To (Index_List,
5616                  Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));
5617
5618                Append_To (Final_List,
5619                  Make_Defining_Identifier (Loc, New_External_Name ('F', Dim)));
5620             end loop;
5621          end Build_Indexes;
5622
5623          -------------------------------
5624          -- Build_Initialization_Call --
5625          -------------------------------
5626
5627          function Build_Initialization_Call return Node_Id is
5628             Comp_Ref : constant Node_Id :=
5629                          Make_Indexed_Component (Loc,
5630                            Prefix      => Make_Identifier (Loc, Name_V),
5631                            Expressions => New_References_To (Index_List, Loc));
5632
5633          begin
5634             Set_Etype (Comp_Ref, Comp_Typ);
5635
5636             --  Generate:
5637             --    [Deep_]Initialize (V (J1, ..., JN));
5638
5639             return Make_Init_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
5640          end Build_Initialization_Call;
5641
5642       --  Start of processing for Build_Initialize_Statements
5643
5644       begin
5645          Counter_Id := Make_Temporary (Loc, 'C');
5646          Finalizer_Decls := New_List;
5647
5648          Build_Indexes;
5649          Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
5650
5651          --  Generate the block which houses the finalization call, the index
5652          --  guard and the handler which triggers Program_Error later on.
5653
5654          --    if Counter > 0 then
5655          --       Counter := Counter - 1;
5656          --    else
5657          --       [Deep_]Finalize (V (F1, ..., FN));  --  No_Except_Propagation
5658
5659          --       begin                               --  Exceptions allowed
5660          --          [Deep_]Finalize (V (F1, ..., FN));
5661          --       exception
5662          --          when others =>
5663          --             if not Raised then
5664          --                Raised := True;
5665          --                Save_Occurrence (E, Get_Current_Excep.all.all);
5666          --             end if;
5667          --       end;
5668          --    end if;
5669
5670          if Exceptions_OK then
5671             Fin_Stmt :=
5672               Make_Block_Statement (Loc,
5673                 Handled_Statement_Sequence =>
5674                   Make_Handled_Sequence_Of_Statements (Loc,
5675                     Statements         => New_List (Build_Finalization_Call),
5676                     Exception_Handlers => New_List (
5677                       Build_Exception_Handler (Finalizer_Data))));
5678          else
5679             Fin_Stmt := Build_Finalization_Call;
5680          end if;
5681
5682          --  This is the core of the loop, the dimension iterators are added
5683          --  one by one in reverse.
5684
5685          Final_Loop :=
5686            Make_If_Statement (Loc,
5687              Condition =>
5688                Make_Op_Gt (Loc,
5689                  Left_Opnd  => New_Occurrence_Of (Counter_Id, Loc),
5690                  Right_Opnd => Make_Integer_Literal (Loc, 0)),
5691
5692              Then_Statements => New_List (
5693                Make_Assignment_Statement (Loc,
5694                  Name       => New_Occurrence_Of (Counter_Id, Loc),
5695                  Expression =>
5696                    Make_Op_Subtract (Loc,
5697                      Left_Opnd  => New_Occurrence_Of (Counter_Id, Loc),
5698                      Right_Opnd => Make_Integer_Literal (Loc, 1)))),
5699
5700              Else_Statements => New_List (Fin_Stmt));
5701
5702          --  Generate all finalization loops starting from the innermost
5703          --  dimension.
5704
5705          --    for Fnn in reverse V'Range (Dim) loop
5706          --       <final loop>
5707          --    end loop;
5708
5709          F := Last (Final_List);
5710          Dim := Num_Dims;
5711          while Present (F) and then Dim > 0 loop
5712             Loop_Id := F;
5713             Prev (F);
5714             Remove (Loop_Id);
5715
5716             Final_Loop :=
5717               Make_Loop_Statement (Loc,
5718                 Iteration_Scheme =>
5719                   Make_Iteration_Scheme (Loc,
5720                     Loop_Parameter_Specification =>
5721                       Make_Loop_Parameter_Specification (Loc,
5722                         Defining_Identifier => Loop_Id,
5723                         Discrete_Subtype_Definition =>
5724                           Make_Attribute_Reference (Loc,
5725                             Prefix         => Make_Identifier (Loc, Name_V),
5726                             Attribute_Name => Name_Range,
5727                             Expressions    => New_List (
5728                               Make_Integer_Literal (Loc, Dim))),
5729
5730                         Reverse_Present => True)),
5731
5732                 Statements => New_List (Final_Loop),
5733                 End_Label => Empty);
5734
5735             Dim := Dim - 1;
5736          end loop;
5737
5738          --  Generate the block which contains the finalization loops, the
5739          --  declarations of the abort flag, the exception occurrence, the
5740          --  raised flag and the conditional raise.
5741
5742          --    declare
5743          --       Abort  : constant Boolean := Triggered_By_Abort;
5744          --         <or>
5745          --       Abort  : constant Boolean := False;  --  no abort
5746
5747          --       E      : Exception_Occurrence;
5748          --       Raised : Boolean := False;
5749
5750          --    begin
5751          --       Counter :=
5752          --         V'Length (1) *
5753          --         ...
5754          --         V'Length (N) - Counter;
5755
5756          --       <final loop>
5757
5758          --       if Raised and then not Abort then  --  Exception handlers OK
5759          --          Raise_From_Controlled_Operation (E);
5760          --       end if;
5761
5762          --       raise;  --  Exception handlers OK
5763          --    end;
5764
5765          Stmts := New_List (Build_Counter_Assignment, Final_Loop);
5766
5767          if Exceptions_OK then
5768             Append_To (Stmts,
5769               Build_Raise_Statement (Finalizer_Data));
5770             Append_To (Stmts, Make_Raise_Statement (Loc));
5771          end if;
5772
5773          Final_Block :=
5774            Make_Block_Statement (Loc,
5775              Declarations               =>
5776                Finalizer_Decls,
5777              Handled_Statement_Sequence =>
5778                Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts));
5779
5780          --  Generate the block which contains the initialization call and
5781          --  the partial finalization code.
5782
5783          --    begin
5784          --       [Deep_]Initialize (V (J1, ..., JN));
5785
5786          --       Counter := Counter + 1;
5787
5788          --    exception
5789          --       when others =>
5790          --          <finalization code>
5791          --    end;
5792
5793          Init_Loop :=
5794            Make_Block_Statement (Loc,
5795              Handled_Statement_Sequence =>
5796                Make_Handled_Sequence_Of_Statements (Loc,
5797                  Statements         => New_List (Build_Initialization_Call),
5798                  Exception_Handlers => New_List (
5799                    Make_Exception_Handler (Loc,
5800                      Exception_Choices => New_List (Make_Others_Choice (Loc)),
5801                      Statements        => New_List (Final_Block)))));
5802
5803          Append_To (Statements (Handled_Statement_Sequence (Init_Loop)),
5804            Make_Assignment_Statement (Loc,
5805              Name       => New_Occurrence_Of (Counter_Id, Loc),
5806              Expression =>
5807                Make_Op_Add (Loc,
5808                  Left_Opnd  => New_Occurrence_Of (Counter_Id, Loc),
5809                  Right_Opnd => Make_Integer_Literal (Loc, 1))));
5810
5811          --  Generate all initialization loops starting from the innermost
5812          --  dimension.
5813
5814          --    for Jnn in V'Range (Dim) loop
5815          --       <init loop>
5816          --    end loop;
5817
5818          J := Last (Index_List);
5819          Dim := Num_Dims;
5820          while Present (J) and then Dim > 0 loop
5821             Loop_Id := J;
5822             Prev (J);
5823             Remove (Loop_Id);
5824
5825             Init_Loop :=
5826               Make_Loop_Statement (Loc,
5827                 Iteration_Scheme =>
5828                   Make_Iteration_Scheme (Loc,
5829                     Loop_Parameter_Specification =>
5830                       Make_Loop_Parameter_Specification (Loc,
5831                         Defining_Identifier => Loop_Id,
5832                         Discrete_Subtype_Definition =>
5833                           Make_Attribute_Reference (Loc,
5834                             Prefix         => Make_Identifier (Loc, Name_V),
5835                             Attribute_Name => Name_Range,
5836                             Expressions    => New_List (
5837                               Make_Integer_Literal (Loc, Dim))))),
5838
5839                 Statements => New_List (Init_Loop),
5840                 End_Label => Empty);
5841
5842             Dim := Dim - 1;
5843          end loop;
5844
5845          --  Generate the block which contains the counter variable and the
5846          --  initialization loops.
5847
5848          --    declare
5849          --       Counter : Integer := 0;
5850          --    begin
5851          --       <init loop>
5852          --    end;
5853
5854          return
5855            New_List (
5856              Make_Block_Statement (Loc,
5857                Declarations               => New_List (
5858                  Make_Object_Declaration (Loc,
5859                    Defining_Identifier => Counter_Id,
5860                    Object_Definition   =>
5861                      New_Occurrence_Of (Standard_Integer, Loc),
5862                    Expression          => Make_Integer_Literal (Loc, 0))),
5863
5864                Handled_Statement_Sequence =>
5865                  Make_Handled_Sequence_Of_Statements (Loc,
5866                    Statements => New_List (Init_Loop))));
5867       end Build_Initialize_Statements;
5868
5869       -----------------------
5870       -- New_References_To --
5871       -----------------------
5872
5873       function New_References_To
5874         (L   : List_Id;
5875          Loc : Source_Ptr) return List_Id
5876       is
5877          Refs : constant List_Id := New_List;
5878          Id   : Node_Id;
5879
5880       begin
5881          Id := First (L);
5882          while Present (Id) loop
5883             Append_To (Refs, New_Occurrence_Of (Id, Loc));
5884             Next (Id);
5885          end loop;
5886
5887          return Refs;
5888       end New_References_To;
5889
5890    --  Start of processing for Make_Deep_Array_Body
5891
5892    begin
5893       case Prim is
5894          when Address_Case =>
5895             return Make_Finalize_Address_Stmts (Typ);
5896
5897          when Adjust_Case   |
5898               Finalize_Case =>
5899             return Build_Adjust_Or_Finalize_Statements (Typ);
5900
5901          when Initialize_Case =>
5902             return Build_Initialize_Statements (Typ);
5903       end case;
5904    end Make_Deep_Array_Body;
5905
5906    --------------------
5907    -- Make_Deep_Proc --
5908    --------------------
5909
5910    function Make_Deep_Proc
5911      (Prim  : Final_Primitives;
5912       Typ   : Entity_Id;
5913       Stmts : List_Id) return Entity_Id
5914    is
5915       Loc     : constant Source_Ptr := Sloc (Typ);
5916       Formals : List_Id;
5917       Proc_Id : Entity_Id;
5918
5919    begin
5920       --  Create the object formal, generate:
5921       --    V : System.Address
5922
5923       if Prim = Address_Case then
5924          Formals := New_List (
5925            Make_Parameter_Specification (Loc,
5926              Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
5927              Parameter_Type      =>
5928                New_Occurrence_Of (RTE (RE_Address), Loc)));
5929
5930       --  Default case
5931
5932       else
5933          --  V : in out Typ
5934
5935          Formals := New_List (
5936            Make_Parameter_Specification (Loc,
5937              Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
5938              In_Present          => True,
5939              Out_Present         => True,
5940              Parameter_Type      => New_Occurrence_Of (Typ, Loc)));
5941
5942          --  F : Boolean := True
5943
5944          if Prim = Adjust_Case
5945            or else Prim = Finalize_Case
5946          then
5947             Append_To (Formals,
5948               Make_Parameter_Specification (Loc,
5949                 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
5950                 Parameter_Type      =>
5951                   New_Occurrence_Of (Standard_Boolean, Loc),
5952                 Expression          =>
5953                   New_Occurrence_Of (Standard_True, Loc)));
5954          end if;
5955       end if;
5956
5957       Proc_Id :=
5958         Make_Defining_Identifier (Loc,
5959           Chars => Make_TSS_Name (Typ, Deep_Name_Of (Prim)));
5960
5961       --  Generate:
5962       --    procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
5963       --    begin
5964       --       <stmts>
5965       --    exception                --  Finalize and Adjust cases only
5966       --       raise Program_Error;
5967       --    end Deep_Initialize / Adjust / Finalize;
5968
5969       --       or
5970
5971       --    procedure Finalize_Address (V : System.Address) is
5972       --    begin
5973       --       <stmts>
5974       --    end Finalize_Address;
5975
5976       Discard_Node (
5977         Make_Subprogram_Body (Loc,
5978           Specification =>
5979             Make_Procedure_Specification (Loc,
5980               Defining_Unit_Name       => Proc_Id,
5981               Parameter_Specifications => Formals),
5982
5983           Declarations => Empty_List,
5984
5985           Handled_Statement_Sequence =>
5986             Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)));
5987
5988       return Proc_Id;
5989    end Make_Deep_Proc;
5990
5991    ---------------------------
5992    -- Make_Deep_Record_Body --
5993    ---------------------------
5994
5995    function Make_Deep_Record_Body
5996      (Prim     : Final_Primitives;
5997       Typ      : Entity_Id;
5998       Is_Local : Boolean := False) return List_Id
5999    is
6000       function Build_Adjust_Statements (Typ : Entity_Id) return List_Id;
6001       --  Build the statements necessary to adjust a record type. The type may
6002       --  have discriminants and contain variant parts. Generate:
6003       --
6004       --    begin
6005       --       begin
6006       --          [Deep_]Adjust (V.Comp_1);
6007       --       exception
6008       --          when Id : others =>
6009       --             if not Raised then
6010       --                Raised := True;
6011       --                Save_Occurrence (E, Get_Current_Excep.all.all);
6012       --             end if;
6013       --       end;
6014       --       .  .  .
6015       --       begin
6016       --          [Deep_]Adjust (V.Comp_N);
6017       --       exception
6018       --          when Id : others =>
6019       --             if not Raised then
6020       --                Raised := True;
6021       --                Save_Occurrence (E, Get_Current_Excep.all.all);
6022       --             end if;
6023       --       end;
6024       --
6025       --       begin
6026       --          Deep_Adjust (V._parent, False);  --  If applicable
6027       --       exception
6028       --          when Id : others =>
6029       --             if not Raised then
6030       --                Raised := True;
6031       --                Save_Occurrence (E, Get_Current_Excep.all.all);
6032       --             end if;
6033       --       end;
6034       --
6035       --       if F then
6036       --          begin
6037       --             Adjust (V);  --  If applicable
6038       --          exception
6039       --             when others =>
6040       --                if not Raised then
6041       --                   Raised := True;
6042       --                   Save_Occurence (E, Get_Current_Excep.all.all);
6043       --                end if;
6044       --          end;
6045       --       end if;
6046       --
6047       --       if Raised and then not Abort then
6048       --          Raise_From_Controlled_Operation (E);
6049       --       end if;
6050       --    end;
6051
6052       function Build_Finalize_Statements (Typ : Entity_Id) return List_Id;
6053       --  Build the statements necessary to finalize a record type. The type
6054       --  may have discriminants and contain variant parts. Generate:
6055       --
6056       --    declare
6057       --       Abort  : constant Boolean := Triggered_By_Abort;
6058       --         <or>
6059       --       Abort  : constant Boolean := False;  --  no abort
6060       --       E      : Exception_Occurence;
6061       --       Raised : Boolean := False;
6062       --
6063       --    begin
6064       --       if F then
6065       --          begin
6066       --             Finalize (V);  --  If applicable
6067       --          exception
6068       --             when others =>
6069       --                if not Raised then
6070       --                   Raised := True;
6071       --                   Save_Occurence (E, Get_Current_Excep.all.all);
6072       --                end if;
6073       --          end;
6074       --       end if;
6075       --
6076       --       case Variant_1 is
6077       --          when Value_1 =>
6078       --             case State_Counter_N =>  --  If Is_Local is enabled
6079       --                when N =>                 .
6080       --                   goto LN;               .
6081       --                ...                       .
6082       --                when 1 =>                 .
6083       --                   goto L1;               .
6084       --                when others =>            .
6085       --                   goto L0;               .
6086       --             end case;                    .
6087       --
6088       --             <<LN>>                   --  If Is_Local is enabled
6089       --             begin
6090       --                [Deep_]Finalize (V.Comp_N);
6091       --             exception
6092       --                when others =>
6093       --                   if not Raised then
6094       --                      Raised := True;
6095       --                      Save_Occurence (E, Get_Current_Excep.all.all);
6096       --                   end if;
6097       --             end;
6098       --             .  .  .
6099       --             <<L1>>
6100       --             begin
6101       --                [Deep_]Finalize (V.Comp_1);
6102       --             exception
6103       --                when others =>
6104       --                   if not Raised then
6105       --                      Raised := True;
6106       --                      Save_Occurence (E, Get_Current_Excep.all.all);
6107       --                   end if;
6108       --             end;
6109       --             <<L0>>
6110       --       end case;
6111       --
6112       --       case State_Counter_1 =>  --  If Is_Local is enabled
6113       --          when M =>                 .
6114       --             goto LM;               .
6115       --       ...
6116       --
6117       --       begin
6118       --          Deep_Finalize (V._parent, False);  --  If applicable
6119       --       exception
6120       --          when Id : others =>
6121       --             if not Raised then
6122       --                Raised := True;
6123       --                Save_Occurrence (E, Get_Current_Excep.all.all);
6124       --             end if;
6125       --       end;
6126       --
6127       --       if Raised and then not Abort then
6128       --          Raise_From_Controlled_Operation (E);
6129       --       end if;
6130       --    end;
6131
6132       function Parent_Field_Type (Typ : Entity_Id) return Entity_Id;
6133       --  Given a derived tagged type Typ, traverse all components, find field
6134       --  _parent and return its type.
6135
6136       procedure Preprocess_Components
6137         (Comps     : Node_Id;
6138          Num_Comps : out Int;
6139          Has_POC   : out Boolean);
6140       --  Examine all components in component list Comps, count all controlled
6141       --  components and determine whether at least one of them is per-object
6142       --  constrained. Component _parent is always skipped.
6143
6144       -----------------------------
6145       -- Build_Adjust_Statements --
6146       -----------------------------
6147
6148       function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is
6149          Loc             : constant Source_Ptr := Sloc (Typ);
6150          Typ_Def         : constant Node_Id := Type_Definition (Parent (Typ));
6151          Bod_Stmts       : List_Id;
6152          Finalizer_Data  : Finalization_Exception_Data;
6153          Finalizer_Decls : List_Id := No_List;
6154          Rec_Def         : Node_Id;
6155          Var_Case        : Node_Id;
6156
6157          Exceptions_OK : constant Boolean :=
6158                            not Restriction_Active (No_Exception_Propagation);
6159
6160          function Process_Component_List_For_Adjust
6161            (Comps : Node_Id) return List_Id;
6162          --  Build all necessary adjust statements for a single component list
6163
6164          ---------------------------------------
6165          -- Process_Component_List_For_Adjust --
6166          ---------------------------------------
6167
6168          function Process_Component_List_For_Adjust
6169            (Comps : Node_Id) return List_Id
6170          is
6171             Stmts     : constant List_Id := New_List;
6172             Decl      : Node_Id;
6173             Decl_Id   : Entity_Id;
6174             Decl_Typ  : Entity_Id;
6175             Has_POC   : Boolean;
6176             Num_Comps : Int;
6177
6178             procedure Process_Component_For_Adjust (Decl : Node_Id);
6179             --  Process the declaration of a single controlled component
6180
6181             ----------------------------------
6182             -- Process_Component_For_Adjust --
6183             ----------------------------------
6184
6185             procedure Process_Component_For_Adjust (Decl : Node_Id) is
6186                Id       : constant Entity_Id := Defining_Identifier (Decl);
6187                Typ      : constant Entity_Id := Etype (Id);
6188                Adj_Stmt : Node_Id;
6189
6190             begin
6191                --  Generate:
6192                --    [Deep_]Adjust (V.Id);  --  No_Exception_Propagation
6193
6194                --    begin                  --  Exception handlers allowed
6195                --       [Deep_]Adjust (V.Id);
6196                --    exception
6197                --       when others =>
6198                --          if not Raised then
6199                --             Raised := True;
6200                --             Save_Occurrence (E, Get_Current_Excep.all.all);
6201                --          end if;
6202                --    end;
6203
6204                Adj_Stmt :=
6205                  Make_Adjust_Call (
6206                    Obj_Ref =>
6207                      Make_Selected_Component (Loc,
6208                        Prefix        => Make_Identifier (Loc, Name_V),
6209                        Selector_Name => Make_Identifier (Loc, Chars (Id))),
6210                    Typ     => Typ);
6211
6212                if Exceptions_OK then
6213                   Adj_Stmt :=
6214                     Make_Block_Statement (Loc,
6215                       Handled_Statement_Sequence =>
6216                         Make_Handled_Sequence_Of_Statements (Loc,
6217                           Statements         => New_List (Adj_Stmt),
6218                           Exception_Handlers => New_List (
6219                             Build_Exception_Handler (Finalizer_Data))));
6220                end if;
6221
6222                Append_To (Stmts, Adj_Stmt);
6223             end Process_Component_For_Adjust;
6224
6225          --  Start of processing for Process_Component_List_For_Adjust
6226
6227          begin
6228             --  Perform an initial check, determine the number of controlled
6229             --  components in the current list and whether at least one of them
6230             --  is per-object constrained.
6231
6232             Preprocess_Components (Comps, Num_Comps, Has_POC);
6233
6234             --  The processing in this routine is done in the following order:
6235             --    1) Regular components
6236             --    2) Per-object constrained components
6237             --    3) Variant parts
6238
6239             if Num_Comps > 0 then
6240
6241                --  Process all regular components in order of declarations
6242
6243                Decl := First_Non_Pragma (Component_Items (Comps));
6244                while Present (Decl) loop
6245                   Decl_Id  := Defining_Identifier (Decl);
6246                   Decl_Typ := Etype (Decl_Id);
6247
6248                   --  Skip _parent as well as per-object constrained components
6249
6250                   if Chars (Decl_Id) /= Name_uParent
6251                     and then Needs_Finalization (Decl_Typ)
6252                   then
6253                      if Has_Access_Constraint (Decl_Id)
6254                        and then No (Expression (Decl))
6255                      then
6256                         null;
6257                      else
6258                         Process_Component_For_Adjust (Decl);
6259                      end if;
6260                   end if;
6261
6262                   Next_Non_Pragma (Decl);
6263                end loop;
6264
6265                --  Process all per-object constrained components in order of
6266                --  declarations.
6267
6268                if Has_POC then
6269                   Decl := First_Non_Pragma (Component_Items (Comps));
6270                   while Present (Decl) loop
6271                      Decl_Id  := Defining_Identifier (Decl);
6272                      Decl_Typ := Etype (Decl_Id);
6273
6274                      --  Skip _parent
6275
6276                      if Chars (Decl_Id) /= Name_uParent
6277                        and then Needs_Finalization (Decl_Typ)
6278                        and then Has_Access_Constraint (Decl_Id)
6279                        and then No (Expression (Decl))
6280                      then
6281                         Process_Component_For_Adjust (Decl);
6282                      end if;
6283
6284                      Next_Non_Pragma (Decl);
6285                   end loop;
6286                end if;
6287             end if;
6288
6289             --  Process all variants, if any
6290
6291             Var_Case := Empty;
6292             if Present (Variant_Part (Comps)) then
6293                declare
6294                   Var_Alts : constant List_Id := New_List;
6295                   Var      : Node_Id;
6296
6297                begin
6298                   Var := First_Non_Pragma (Variants (Variant_Part (Comps)));
6299                   while Present (Var) loop
6300
6301                      --  Generate:
6302                      --     when <discrete choices> =>
6303                      --        <adjust statements>
6304
6305                      Append_To (Var_Alts,
6306                        Make_Case_Statement_Alternative (Loc,
6307                          Discrete_Choices =>
6308                            New_Copy_List (Discrete_Choices (Var)),
6309                          Statements       =>
6310                            Process_Component_List_For_Adjust (
6311                              Component_List (Var))));
6312
6313                      Next_Non_Pragma (Var);
6314                   end loop;
6315
6316                   --  Generate:
6317                   --     case V.<discriminant> is
6318                   --        when <discrete choices 1> =>
6319                   --           <adjust statements 1>
6320                   --        ...
6321                   --        when <discrete choices N> =>
6322                   --           <adjust statements N>
6323                   --     end case;
6324
6325                   Var_Case :=
6326                     Make_Case_Statement (Loc,
6327                       Expression =>
6328                         Make_Selected_Component (Loc,
6329                           Prefix        => Make_Identifier (Loc, Name_V),
6330                           Selector_Name =>
6331                             Make_Identifier (Loc,
6332                               Chars => Chars (Name (Variant_Part (Comps))))),
6333                       Alternatives => Var_Alts);
6334                end;
6335             end if;
6336
6337             --  Add the variant case statement to the list of statements
6338
6339             if Present (Var_Case) then
6340                Append_To (Stmts, Var_Case);
6341             end if;
6342
6343             --  If the component list did not have any controlled components
6344             --  nor variants, return null.
6345
6346             if Is_Empty_List (Stmts) then
6347                Append_To (Stmts, Make_Null_Statement (Loc));
6348             end if;
6349
6350             return Stmts;
6351          end Process_Component_List_For_Adjust;
6352
6353       --  Start of processing for Build_Adjust_Statements
6354
6355       begin
6356          Finalizer_Decls := New_List;
6357          Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
6358
6359          if Nkind (Typ_Def) = N_Derived_Type_Definition then
6360             Rec_Def := Record_Extension_Part (Typ_Def);
6361          else
6362             Rec_Def := Typ_Def;
6363          end if;
6364
6365          --  Create an adjust sequence for all record components
6366
6367          if Present (Component_List (Rec_Def)) then
6368             Bod_Stmts :=
6369               Process_Component_List_For_Adjust (Component_List (Rec_Def));
6370          end if;
6371
6372          --  A derived record type must adjust all inherited components. This
6373          --  action poses the following problem:
6374
6375          --    procedure Deep_Adjust (Obj : in out Parent_Typ) is
6376          --    begin
6377          --       Adjust (Obj);
6378          --       ...
6379
6380          --    procedure Deep_Adjust (Obj : in out Derived_Typ) is
6381          --    begin
6382          --       Deep_Adjust (Obj._parent);
6383          --       ...
6384          --       Adjust (Obj);
6385          --       ...
6386
6387          --  Adjusting the derived type will invoke Adjust of the parent and
6388          --  then that of the derived type. This is undesirable because both
6389          --  routines may modify shared components. Only the Adjust of the
6390          --  derived type should be invoked.
6391
6392          --  To prevent this double adjustment of shared components,
6393          --  Deep_Adjust uses a flag to control the invocation of Adjust:
6394
6395          --    procedure Deep_Adjust
6396          --      (Obj  : in out Some_Type;
6397          --       Flag : Boolean := True)
6398          --    is
6399          --    begin
6400          --       if Flag then
6401          --          Adjust (Obj);
6402          --       end if;
6403          --       ...
6404
6405          --  When Deep_Adjust is invokes for field _parent, a value of False is
6406          --  provided for the flag:
6407
6408          --    Deep_Adjust (Obj._parent, False);
6409
6410          if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
6411             declare
6412                Par_Typ  : constant Entity_Id := Parent_Field_Type (Typ);
6413                Adj_Stmt : Node_Id;
6414                Call     : Node_Id;
6415
6416             begin
6417                if Needs_Finalization (Par_Typ) then
6418                   Call :=
6419                     Make_Adjust_Call
6420                       (Obj_Ref   =>
6421                          Make_Selected_Component (Loc,
6422                            Prefix        => Make_Identifier (Loc, Name_V),
6423                            Selector_Name =>
6424                              Make_Identifier (Loc, Name_uParent)),
6425                        Typ       => Par_Typ,
6426                        Skip_Self => True);
6427
6428                   --  Generate:
6429                   --    Deep_Adjust (V._parent, False);  --  No_Except_Propagat
6430
6431                   --    begin                            --  Exceptions OK
6432                   --       Deep_Adjust (V._parent, False);
6433                   --    exception
6434                   --       when Id : others =>
6435                   --          if not Raised then
6436                   --             Raised := True;
6437                   --             Save_Occurrence (E,
6438                   --               Get_Current_Excep.all.all);
6439                   --          end if;
6440                   --    end;
6441
6442                   if Present (Call) then
6443                      Adj_Stmt := Call;
6444
6445                      if Exceptions_OK then
6446                         Adj_Stmt :=
6447                           Make_Block_Statement (Loc,
6448                             Handled_Statement_Sequence =>
6449                               Make_Handled_Sequence_Of_Statements (Loc,
6450                                 Statements         => New_List (Adj_Stmt),
6451                                 Exception_Handlers => New_List (
6452                                   Build_Exception_Handler (Finalizer_Data))));
6453                      end if;
6454
6455                      Prepend_To (Bod_Stmts, Adj_Stmt);
6456                   end if;
6457                end if;
6458             end;
6459          end if;
6460
6461          --  Adjust the object. This action must be performed last after all
6462          --  components have been adjusted.
6463
6464          if Is_Controlled (Typ) then
6465             declare
6466                Adj_Stmt : Node_Id;
6467                Proc     : Entity_Id;
6468
6469             begin
6470                Proc := Find_Prim_Op (Typ, Name_Adjust);
6471
6472                --  Generate:
6473                --    if F then
6474                --       Adjust (V);  --  No_Exception_Propagation
6475
6476                --       begin        --  Exception handlers allowed
6477                --          Adjust (V);
6478                --       exception
6479                --          when others =>
6480                --             if not Raised then
6481                --                Raised := True;
6482                --                Save_Occurrence (E,
6483                --                  Get_Current_Excep.all.all);
6484                --             end if;
6485                --       end;
6486                --    end if;
6487
6488                if Present (Proc) then
6489                   Adj_Stmt :=
6490                     Make_Procedure_Call_Statement (Loc,
6491                       Name                   => New_Occurrence_Of (Proc, Loc),
6492                       Parameter_Associations => New_List (
6493                         Make_Identifier (Loc, Name_V)));
6494
6495                   if Exceptions_OK then
6496                      Adj_Stmt :=
6497                        Make_Block_Statement (Loc,
6498                          Handled_Statement_Sequence =>
6499                            Make_Handled_Sequence_Of_Statements (Loc,
6500                              Statements         => New_List (Adj_Stmt),
6501                              Exception_Handlers => New_List (
6502                                Build_Exception_Handler
6503                                  (Finalizer_Data))));
6504                   end if;
6505
6506                   Append_To (Bod_Stmts,
6507                     Make_If_Statement (Loc,
6508                       Condition       => Make_Identifier (Loc, Name_F),
6509                       Then_Statements => New_List (Adj_Stmt)));
6510                end if;
6511             end;
6512          end if;
6513
6514          --  At this point either all adjustment statements have been generated
6515          --  or the type is not controlled.
6516
6517          if Is_Empty_List (Bod_Stmts) then
6518             Append_To (Bod_Stmts, Make_Null_Statement (Loc));
6519
6520             return Bod_Stmts;
6521
6522          --  Generate:
6523          --    declare
6524          --       Abort  : constant Boolean := Triggered_By_Abort;
6525          --         <or>
6526          --       Abort  : constant Boolean := False;  --  no abort
6527
6528          --       E      : Exception_Occurence;
6529          --       Raised : Boolean := False;
6530
6531          --    begin
6532          --       <adjust statements>
6533
6534          --       if Raised and then not Abort then
6535          --          Raise_From_Controlled_Operation (E);
6536          --       end if;
6537          --    end;
6538
6539          else
6540             if Exceptions_OK then
6541                Append_To (Bod_Stmts,
6542                  Build_Raise_Statement (Finalizer_Data));
6543             end if;
6544
6545             return
6546               New_List (
6547                 Make_Block_Statement (Loc,
6548                   Declarations               =>
6549                     Finalizer_Decls,
6550                   Handled_Statement_Sequence =>
6551                     Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
6552          end if;
6553       end Build_Adjust_Statements;
6554
6555       -------------------------------
6556       -- Build_Finalize_Statements --
6557       -------------------------------
6558
6559       function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is
6560          Loc             : constant Source_Ptr := Sloc (Typ);
6561          Typ_Def         : constant Node_Id := Type_Definition (Parent (Typ));
6562          Bod_Stmts       : List_Id;
6563          Counter         : Int := 0;
6564          Finalizer_Data  : Finalization_Exception_Data;
6565          Finalizer_Decls : List_Id := No_List;
6566          Rec_Def         : Node_Id;
6567          Var_Case        : Node_Id;
6568
6569          Exceptions_OK : constant Boolean :=
6570                            not Restriction_Active (No_Exception_Propagation);
6571
6572          function Process_Component_List_For_Finalize
6573            (Comps : Node_Id) return List_Id;
6574          --  Build all necessary finalization statements for a single component
6575          --  list. The statements may include a jump circuitry if flag Is_Local
6576          --  is enabled.
6577
6578          -----------------------------------------
6579          -- Process_Component_List_For_Finalize --
6580          -----------------------------------------
6581
6582          function Process_Component_List_For_Finalize
6583            (Comps : Node_Id) return List_Id
6584          is
6585             Alts       : List_Id;
6586             Counter_Id : Entity_Id;
6587             Decl       : Node_Id;
6588             Decl_Id    : Entity_Id;
6589             Decl_Typ   : Entity_Id;
6590             Decls      : List_Id;
6591             Has_POC    : Boolean;
6592             Jump_Block : Node_Id;
6593             Label      : Node_Id;
6594             Label_Id   : Entity_Id;
6595             Num_Comps  : Int;
6596             Stmts      : List_Id;
6597
6598             procedure Process_Component_For_Finalize
6599               (Decl  : Node_Id;
6600                Alts  : List_Id;
6601                Decls : List_Id;
6602                Stmts : List_Id);
6603             --  Process the declaration of a single controlled component. If
6604             --  flag Is_Local is enabled, create the corresponding label and
6605             --  jump circuitry. Alts is the list of case alternatives, Decls
6606             --  is the top level declaration list where labels are declared
6607             --  and Stmts is the list of finalization actions.
6608
6609             ------------------------------------
6610             -- Process_Component_For_Finalize --
6611             ------------------------------------
6612
6613             procedure Process_Component_For_Finalize
6614               (Decl  : Node_Id;
6615                Alts  : List_Id;
6616                Decls : List_Id;
6617                Stmts : List_Id)
6618             is
6619                Id       : constant Entity_Id := Defining_Identifier (Decl);
6620                Typ      : constant Entity_Id := Etype (Id);
6621                Fin_Stmt : Node_Id;
6622
6623             begin
6624                if Is_Local then
6625                   declare
6626                      Label    : Node_Id;
6627                      Label_Id : Entity_Id;
6628
6629                   begin
6630                      --  Generate:
6631                      --    LN : label;
6632
6633                      Label_Id :=
6634                        Make_Identifier (Loc,
6635                          Chars => New_External_Name ('L', Num_Comps));
6636                      Set_Entity (Label_Id,
6637                        Make_Defining_Identifier (Loc, Chars (Label_Id)));
6638                      Label := Make_Label (Loc, Label_Id);
6639
6640                      Append_To (Decls,
6641                        Make_Implicit_Label_Declaration (Loc,
6642                          Defining_Identifier => Entity (Label_Id),
6643                          Label_Construct     => Label));
6644
6645                      --  Generate:
6646                      --    when N =>
6647                      --      goto LN;
6648
6649                      Append_To (Alts,
6650                        Make_Case_Statement_Alternative (Loc,
6651                          Discrete_Choices => New_List (
6652                            Make_Integer_Literal (Loc, Num_Comps)),
6653
6654                          Statements => New_List (
6655                            Make_Goto_Statement (Loc,
6656                              Name =>
6657                                New_Occurrence_Of (Entity (Label_Id), Loc)))));
6658
6659                      --  Generate:
6660                      --    <<LN>>
6661
6662                      Append_To (Stmts, Label);
6663
6664                      --  Decrease the number of components to be processed.
6665                      --  This action yields a new Label_Id in future calls.
6666
6667                      Num_Comps := Num_Comps - 1;
6668                   end;
6669                end if;
6670
6671                --  Generate:
6672                --    [Deep_]Finalize (V.Id);  --  No_Exception_Propagation
6673
6674                --    begin                    --  Exception handlers allowed
6675                --       [Deep_]Finalize (V.Id);
6676                --    exception
6677                --       when others =>
6678                --          if not Raised then
6679                --             Raised := True;
6680                --             Save_Occurrence (E,
6681                --               Get_Current_Excep.all.all);
6682                --          end if;
6683                --    end;
6684
6685                Fin_Stmt :=
6686                  Make_Final_Call
6687                    (Obj_Ref =>
6688                       Make_Selected_Component (Loc,
6689                         Prefix        => Make_Identifier (Loc, Name_V),
6690                         Selector_Name => Make_Identifier (Loc, Chars (Id))),
6691                     Typ     => Typ);
6692
6693                if not Restriction_Active (No_Exception_Propagation) then
6694                   Fin_Stmt :=
6695                     Make_Block_Statement (Loc,
6696                       Handled_Statement_Sequence =>
6697                         Make_Handled_Sequence_Of_Statements (Loc,
6698                           Statements         => New_List (Fin_Stmt),
6699                           Exception_Handlers => New_List (
6700                             Build_Exception_Handler (Finalizer_Data))));
6701                end if;
6702
6703                Append_To (Stmts, Fin_Stmt);
6704             end Process_Component_For_Finalize;
6705
6706          --  Start of processing for Process_Component_List_For_Finalize
6707
6708          begin
6709             --  Perform an initial check, look for controlled and per-object
6710             --  constrained components.
6711
6712             Preprocess_Components (Comps, Num_Comps, Has_POC);
6713
6714             --  Create a state counter to service the current component list.
6715             --  This step is performed before the variants are inspected in
6716             --  order to generate the same state counter names as those from
6717             --  Build_Initialize_Statements.
6718
6719             if Num_Comps > 0 and then Is_Local then
6720                Counter := Counter + 1;
6721
6722                Counter_Id :=
6723                  Make_Defining_Identifier (Loc,
6724                    Chars => New_External_Name ('C', Counter));
6725             end if;
6726
6727             --  Process the component in the following order:
6728             --    1) Variants
6729             --    2) Per-object constrained components
6730             --    3) Regular components
6731
6732             --  Start with the variant parts
6733
6734             Var_Case := Empty;
6735             if Present (Variant_Part (Comps)) then
6736                declare
6737                   Var_Alts : constant List_Id := New_List;
6738                   Var      : Node_Id;
6739
6740                begin
6741                   Var := First_Non_Pragma (Variants (Variant_Part (Comps)));
6742                   while Present (Var) loop
6743
6744                      --  Generate:
6745                      --     when <discrete choices> =>
6746                      --        <finalize statements>
6747
6748                      Append_To (Var_Alts,
6749                        Make_Case_Statement_Alternative (Loc,
6750                          Discrete_Choices =>
6751                            New_Copy_List (Discrete_Choices (Var)),
6752                          Statements =>
6753                            Process_Component_List_For_Finalize (
6754                              Component_List (Var))));
6755
6756                      Next_Non_Pragma (Var);
6757                   end loop;
6758
6759                   --  Generate:
6760                   --     case V.<discriminant> is
6761                   --        when <discrete choices 1> =>
6762                   --           <finalize statements 1>
6763                   --        ...
6764                   --        when <discrete choices N> =>
6765                   --           <finalize statements N>
6766                   --     end case;
6767
6768                   Var_Case :=
6769                     Make_Case_Statement (Loc,
6770                       Expression =>
6771                         Make_Selected_Component (Loc,
6772                           Prefix        => Make_Identifier (Loc, Name_V),
6773                           Selector_Name =>
6774                             Make_Identifier (Loc,
6775                               Chars => Chars (Name (Variant_Part (Comps))))),
6776                       Alternatives => Var_Alts);
6777                end;
6778             end if;
6779
6780             --  The current component list does not have a single controlled
6781             --  component, however it may contain variants. Return the case
6782             --  statement for the variants or nothing.
6783
6784             if Num_Comps = 0 then
6785                if Present (Var_Case) then
6786                   return New_List (Var_Case);
6787                else
6788                   return New_List (Make_Null_Statement (Loc));
6789                end if;
6790             end if;
6791
6792             --  Prepare all lists
6793
6794             Alts  := New_List;
6795             Decls := New_List;
6796             Stmts := New_List;
6797
6798             --  Process all per-object constrained components in reverse order
6799
6800             if Has_POC then
6801                Decl := Last_Non_Pragma (Component_Items (Comps));
6802                while Present (Decl) loop
6803                   Decl_Id  := Defining_Identifier (Decl);
6804                   Decl_Typ := Etype (Decl_Id);
6805
6806                   --  Skip _parent
6807
6808                   if Chars (Decl_Id) /= Name_uParent
6809                     and then Needs_Finalization (Decl_Typ)
6810                     and then Has_Access_Constraint (Decl_Id)
6811                     and then No (Expression (Decl))
6812                   then
6813                      Process_Component_For_Finalize (Decl, Alts, Decls, Stmts);
6814                   end if;
6815
6816                   Prev_Non_Pragma (Decl);
6817                end loop;
6818             end if;
6819
6820             --  Process the rest of the components in reverse order
6821
6822             Decl := Last_Non_Pragma (Component_Items (Comps));
6823             while Present (Decl) loop
6824                Decl_Id  := Defining_Identifier (Decl);
6825                Decl_Typ := Etype (Decl_Id);
6826
6827                --  Skip _parent
6828
6829                if Chars (Decl_Id) /= Name_uParent
6830                  and then Needs_Finalization (Decl_Typ)
6831                then
6832                   --  Skip per-object constrained components since they were
6833                   --  handled in the above step.
6834
6835                   if Has_Access_Constraint (Decl_Id)
6836                     and then No (Expression (Decl))
6837                   then
6838                      null;
6839                   else
6840                      Process_Component_For_Finalize (Decl, Alts, Decls, Stmts);
6841                   end if;
6842                end if;
6843
6844                Prev_Non_Pragma (Decl);
6845             end loop;
6846
6847             --  Generate:
6848             --    declare
6849             --       LN : label;        --  If Is_Local is enabled
6850             --       ...                    .
6851             --       L0 : label;            .
6852
6853             --    begin                     .
6854             --       case CounterX is       .
6855             --          when N =>           .
6856             --             goto LN;         .
6857             --          ...                 .
6858             --          when 1 =>           .
6859             --             goto L1;         .
6860             --          when others =>      .
6861             --             goto L0;         .
6862             --       end case;              .
6863
6864             --       <<LN>>             --  If Is_Local is enabled
6865             --          begin
6866             --             [Deep_]Finalize (V.CompY);
6867             --          exception
6868             --             when Id : others =>
6869             --                if not Raised then
6870             --                   Raised := True;
6871             --                   Save_Occurrence (E,
6872             --                     Get_Current_Excep.all.all);
6873             --                end if;
6874             --          end;
6875             --       ...
6876             --       <<L0>>  --  If Is_Local is enabled
6877             --    end;
6878
6879             if Is_Local then
6880
6881                --  Add the declaration of default jump location L0, its
6882                --  corresponding alternative and its place in the statements.
6883
6884                Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
6885                Set_Entity (Label_Id,
6886                  Make_Defining_Identifier (Loc, Chars (Label_Id)));
6887                Label := Make_Label (Loc, Label_Id);
6888
6889                Append_To (Decls,          --  declaration
6890                  Make_Implicit_Label_Declaration (Loc,
6891                    Defining_Identifier => Entity (Label_Id),
6892                    Label_Construct     => Label));
6893
6894                Append_To (Alts,           --  alternative
6895                  Make_Case_Statement_Alternative (Loc,
6896                    Discrete_Choices => New_List (
6897                      Make_Others_Choice (Loc)),
6898
6899                    Statements => New_List (
6900                      Make_Goto_Statement (Loc,
6901                        Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
6902
6903                Append_To (Stmts, Label);  --  statement
6904
6905                --  Create the jump block
6906
6907                Prepend_To (Stmts,
6908                  Make_Case_Statement (Loc,
6909                    Expression   => Make_Identifier (Loc, Chars (Counter_Id)),
6910                    Alternatives => Alts));
6911             end if;
6912
6913             Jump_Block :=
6914               Make_Block_Statement (Loc,
6915                 Declarations               => Decls,
6916                 Handled_Statement_Sequence =>
6917                   Make_Handled_Sequence_Of_Statements (Loc, Stmts));
6918
6919             if Present (Var_Case) then
6920                return New_List (Var_Case, Jump_Block);
6921             else
6922                return New_List (Jump_Block);
6923             end if;
6924          end Process_Component_List_For_Finalize;
6925
6926       --  Start of processing for Build_Finalize_Statements
6927
6928       begin
6929          Finalizer_Decls := New_List;
6930          Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
6931
6932          if Nkind (Typ_Def) = N_Derived_Type_Definition then
6933             Rec_Def := Record_Extension_Part (Typ_Def);
6934          else
6935             Rec_Def := Typ_Def;
6936          end if;
6937
6938          --  Create a finalization sequence for all record components
6939
6940          if Present (Component_List (Rec_Def)) then
6941             Bod_Stmts :=
6942               Process_Component_List_For_Finalize (Component_List (Rec_Def));
6943          end if;
6944
6945          --  A derived record type must finalize all inherited components. This
6946          --  action poses the following problem:
6947
6948          --    procedure Deep_Finalize (Obj : in out Parent_Typ) is
6949          --    begin
6950          --       Finalize (Obj);
6951          --       ...
6952
6953          --    procedure Deep_Finalize (Obj : in out Derived_Typ) is
6954          --    begin
6955          --       Deep_Finalize (Obj._parent);
6956          --       ...
6957          --       Finalize (Obj);
6958          --       ...
6959
6960          --  Finalizing the derived type will invoke Finalize of the parent and
6961          --  then that of the derived type. This is undesirable because both
6962          --  routines may modify shared components. Only the Finalize of the
6963          --  derived type should be invoked.
6964
6965          --  To prevent this double adjustment of shared components,
6966          --  Deep_Finalize uses a flag to control the invocation of Finalize:
6967
6968          --    procedure Deep_Finalize
6969          --      (Obj  : in out Some_Type;
6970          --       Flag : Boolean := True)
6971          --    is
6972          --    begin
6973          --       if Flag then
6974          --          Finalize (Obj);
6975          --       end if;
6976          --       ...
6977
6978          --  When Deep_Finalize is invokes for field _parent, a value of False
6979          --  is provided for the flag:
6980
6981          --    Deep_Finalize (Obj._parent, False);
6982
6983          if Is_Tagged_Type (Typ)
6984            and then Is_Derived_Type (Typ)
6985          then
6986             declare
6987                Par_Typ  : constant Entity_Id := Parent_Field_Type (Typ);
6988                Call     : Node_Id;
6989                Fin_Stmt : Node_Id;
6990
6991             begin
6992                if Needs_Finalization (Par_Typ) then
6993                   Call :=
6994                     Make_Final_Call
6995                       (Obj_Ref   =>
6996                          Make_Selected_Component (Loc,
6997                            Prefix        => Make_Identifier (Loc, Name_V),
6998                            Selector_Name =>
6999                              Make_Identifier (Loc, Name_uParent)),
7000                        Typ       => Par_Typ,
7001                        Skip_Self => True);
7002
7003                   --  Generate:
7004                   --    Deep_Finalize (V._parent, False);  --  No_Except_Propag
7005
7006                   --    begin                              --  Exceptions OK
7007                   --       Deep_Finalize (V._parent, False);
7008                   --    exception
7009                   --       when Id : others =>
7010                   --          if not Raised then
7011                   --             Raised := True;
7012                   --             Save_Occurrence (E,
7013                   --               Get_Current_Excep.all.all);
7014                   --          end if;
7015                   --    end;
7016
7017                   if Present (Call) then
7018                      Fin_Stmt := Call;
7019
7020                      if Exceptions_OK then
7021                         Fin_Stmt :=
7022                           Make_Block_Statement (Loc,
7023                             Handled_Statement_Sequence =>
7024                               Make_Handled_Sequence_Of_Statements (Loc,
7025                                 Statements         => New_List (Fin_Stmt),
7026                                 Exception_Handlers => New_List (
7027                                   Build_Exception_Handler
7028                                     (Finalizer_Data))));
7029                      end if;
7030
7031                      Append_To (Bod_Stmts, Fin_Stmt);
7032                   end if;
7033                end if;
7034             end;
7035          end if;
7036
7037          --  Finalize the object. This action must be performed first before
7038          --  all components have been finalized.
7039
7040          if Is_Controlled (Typ)
7041            and then not Is_Local
7042          then
7043             declare
7044                Fin_Stmt : Node_Id;
7045                Proc     : Entity_Id;
7046
7047             begin
7048                Proc := Find_Prim_Op (Typ, Name_Finalize);
7049
7050                --  Generate:
7051                --    if F then
7052                --       Finalize (V);  --  No_Exception_Propagation
7053
7054                --       begin
7055                --          Finalize (V);
7056                --       exception
7057                --          when others =>
7058                --             if not Raised then
7059                --                Raised := True;
7060                --                Save_Occurrence (E,
7061                --                  Get_Current_Excep.all.all);
7062                --             end if;
7063                --       end;
7064                --    end if;
7065
7066                if Present (Proc) then
7067                   Fin_Stmt :=
7068                     Make_Procedure_Call_Statement (Loc,
7069                       Name                   => New_Occurrence_Of (Proc, Loc),
7070                       Parameter_Associations => New_List (
7071                         Make_Identifier (Loc, Name_V)));
7072
7073                   if Exceptions_OK then
7074                      Fin_Stmt :=
7075                        Make_Block_Statement (Loc,
7076                          Handled_Statement_Sequence =>
7077                            Make_Handled_Sequence_Of_Statements (Loc,
7078                              Statements         => New_List (Fin_Stmt),
7079                              Exception_Handlers => New_List (
7080                                Build_Exception_Handler
7081                                  (Finalizer_Data))));
7082                   end if;
7083
7084                   Prepend_To (Bod_Stmts,
7085                     Make_If_Statement (Loc,
7086                       Condition       => Make_Identifier (Loc, Name_F),
7087                       Then_Statements => New_List (Fin_Stmt)));
7088                end if;
7089             end;
7090          end if;
7091
7092          --  At this point either all finalization statements have been
7093          --  generated or the type is not controlled.
7094
7095          if No (Bod_Stmts) then
7096             return New_List (Make_Null_Statement (Loc));
7097
7098          --  Generate:
7099          --    declare
7100          --       Abort  : constant Boolean := Triggered_By_Abort;
7101          --         <or>
7102          --       Abort  : constant Boolean := False;  --  no abort
7103
7104          --       E      : Exception_Occurence;
7105          --       Raised : Boolean := False;
7106
7107          --    begin
7108          --       <finalize statements>
7109
7110          --       if Raised and then not Abort then
7111          --          Raise_From_Controlled_Operation (E);
7112          --       end if;
7113          --    end;
7114
7115          else
7116             if Exceptions_OK then
7117                Append_To (Bod_Stmts,
7118                  Build_Raise_Statement (Finalizer_Data));
7119             end if;
7120
7121             return
7122               New_List (
7123                 Make_Block_Statement (Loc,
7124                   Declarations               =>
7125                     Finalizer_Decls,
7126                   Handled_Statement_Sequence =>
7127                     Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
7128          end if;
7129       end Build_Finalize_Statements;
7130
7131       -----------------------
7132       -- Parent_Field_Type --
7133       -----------------------
7134
7135       function Parent_Field_Type (Typ : Entity_Id) return Entity_Id is
7136          Field : Entity_Id;
7137
7138       begin
7139          Field := First_Entity (Typ);
7140          while Present (Field) loop
7141             if Chars (Field) = Name_uParent then
7142                return Etype (Field);
7143             end if;
7144
7145             Next_Entity (Field);
7146          end loop;
7147
7148          --  A derived tagged type should always have a parent field
7149
7150          raise Program_Error;
7151       end Parent_Field_Type;
7152
7153       ---------------------------
7154       -- Preprocess_Components --
7155       ---------------------------
7156
7157       procedure Preprocess_Components
7158         (Comps     : Node_Id;
7159          Num_Comps : out Int;
7160          Has_POC   : out Boolean)
7161       is
7162          Decl : Node_Id;
7163          Id   : Entity_Id;
7164          Typ  : Entity_Id;
7165
7166       begin
7167          Num_Comps := 0;
7168          Has_POC   := False;
7169
7170          Decl := First_Non_Pragma (Component_Items (Comps));
7171          while Present (Decl) loop
7172             Id  := Defining_Identifier (Decl);
7173             Typ := Etype (Id);
7174
7175             --  Skip field _parent
7176
7177             if Chars (Id) /= Name_uParent
7178               and then Needs_Finalization (Typ)
7179             then
7180                Num_Comps := Num_Comps + 1;
7181
7182                if Has_Access_Constraint (Id)
7183                  and then No (Expression (Decl))
7184                then
7185                   Has_POC := True;
7186                end if;
7187             end if;
7188
7189             Next_Non_Pragma (Decl);
7190          end loop;
7191       end Preprocess_Components;
7192
7193    --  Start of processing for Make_Deep_Record_Body
7194
7195    begin
7196       case Prim is
7197          when Address_Case =>
7198             return Make_Finalize_Address_Stmts (Typ);
7199
7200          when Adjust_Case =>
7201             return Build_Adjust_Statements (Typ);
7202
7203          when Finalize_Case =>
7204             return Build_Finalize_Statements (Typ);
7205
7206          when Initialize_Case =>
7207             declare
7208                Loc : constant Source_Ptr := Sloc (Typ);
7209
7210             begin
7211                if Is_Controlled (Typ) then
7212                   return New_List (
7213                     Make_Procedure_Call_Statement (Loc,
7214                       Name                   =>
7215                         New_Occurrence_Of
7216                           (Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
7217                       Parameter_Associations => New_List (
7218                         Make_Identifier (Loc, Name_V))));
7219                else
7220                   return Empty_List;
7221                end if;
7222             end;
7223       end case;
7224    end Make_Deep_Record_Body;
7225
7226    ----------------------
7227    -- Make_Final_Call --
7228    ----------------------
7229
7230    function Make_Final_Call
7231      (Obj_Ref   : Node_Id;
7232       Typ       : Entity_Id;
7233       Skip_Self : Boolean := False) return Node_Id
7234    is
7235       Loc    : constant Source_Ptr := Sloc (Obj_Ref);
7236       Atyp   : Entity_Id;
7237       Fin_Id : Entity_Id := Empty;
7238       Ref    : Node_Id;
7239       Utyp   : Entity_Id;
7240
7241    begin
7242       --  Recover the proper type which contains [Deep_]Finalize
7243
7244       if Is_Class_Wide_Type (Typ) then
7245          Utyp := Root_Type (Typ);
7246          Atyp := Utyp;
7247          Ref  := Obj_Ref;
7248
7249       elsif Is_Concurrent_Type (Typ) then
7250          Utyp := Corresponding_Record_Type (Typ);
7251          Atyp := Empty;
7252          Ref  := Convert_Concurrent (Obj_Ref, Typ);
7253
7254       elsif Is_Private_Type (Typ)
7255         and then Present (Full_View (Typ))
7256         and then Is_Concurrent_Type (Full_View (Typ))
7257       then
7258          Utyp := Corresponding_Record_Type (Full_View (Typ));
7259          Atyp := Typ;
7260          Ref  := Convert_Concurrent (Obj_Ref, Full_View (Typ));
7261
7262       else
7263          Utyp := Typ;
7264          Atyp := Typ;
7265          Ref  := Obj_Ref;
7266       end if;
7267
7268       Utyp := Underlying_Type (Base_Type (Utyp));
7269       Set_Assignment_OK (Ref);
7270
7271       --  Deal with non-tagged derivation of private views. If the parent type
7272       --  is a protected type, Deep_Finalize is found on the corresponding
7273       --  record of the ancestor.
7274
7275       if Is_Untagged_Derivation (Typ) then
7276          if Is_Protected_Type (Typ) then
7277             Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
7278          else
7279             Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
7280
7281             if Is_Protected_Type (Utyp) then
7282                Utyp := Corresponding_Record_Type (Utyp);
7283             end if;
7284          end if;
7285
7286          Ref := Unchecked_Convert_To (Utyp, Ref);
7287          Set_Assignment_OK (Ref);
7288       end if;
7289
7290       --  Deal with derived private types which do not inherit primitives from
7291       --  their parents. In this case, [Deep_]Finalize can be found in the full
7292       --  view of the parent type.
7293
7294       if Is_Tagged_Type (Utyp)
7295         and then Is_Derived_Type (Utyp)
7296         and then Is_Empty_Elmt_List (Primitive_Operations (Utyp))
7297         and then Is_Private_Type (Etype (Utyp))
7298         and then Present (Full_View (Etype (Utyp)))
7299       then
7300          Utyp := Full_View (Etype (Utyp));
7301          Ref  := Unchecked_Convert_To (Utyp, Ref);
7302          Set_Assignment_OK (Ref);
7303       end if;
7304
7305       --  When dealing with the completion of a private type, use the base type
7306       --  instead.
7307
7308       if Utyp /= Base_Type (Utyp) then
7309          pragma Assert (Present (Atyp) and then Is_Private_Type (Atyp));
7310
7311          Utyp := Base_Type (Utyp);
7312          Ref  := Unchecked_Convert_To (Utyp, Ref);
7313          Set_Assignment_OK (Ref);
7314       end if;
7315
7316       if Skip_Self then
7317          if Has_Controlled_Component (Utyp) then
7318             if Is_Tagged_Type (Utyp) then
7319                Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
7320             else
7321                Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
7322             end if;
7323          end if;
7324
7325       --  Class-wide types, interfaces and types with controlled components
7326
7327       elsif Is_Class_Wide_Type (Typ)
7328         or else Is_Interface (Typ)
7329         or else Has_Controlled_Component (Utyp)
7330       then
7331          if Is_Tagged_Type (Utyp) then
7332             Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
7333          else
7334             Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
7335          end if;
7336
7337       --  Derivations from [Limited_]Controlled
7338
7339       elsif Is_Controlled (Utyp) then
7340          if Has_Controlled_Component (Utyp) then
7341             Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
7342          else
7343             Fin_Id := Find_Prim_Op (Utyp, Name_Of (Finalize_Case));
7344          end if;
7345
7346       --  Tagged types
7347
7348       elsif Is_Tagged_Type (Utyp) then
7349          Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
7350
7351       else
7352          raise Program_Error;
7353       end if;
7354
7355       if Present (Fin_Id) then
7356
7357          --  When finalizing a class-wide object, do not convert to the root
7358          --  type in order to produce a dispatching call.
7359
7360          if Is_Class_Wide_Type (Typ) then
7361             null;
7362
7363          --  Ensure that a finalization routine is at least decorated in order
7364          --  to inspect the object parameter.
7365
7366          elsif Analyzed (Fin_Id)
7367            or else Ekind (Fin_Id) = E_Procedure
7368          then
7369             --  In certain cases, such as the creation of Stream_Read, the
7370             --  visible entity of the type is its full view. Since Stream_Read
7371             --  will have to create an object of type Typ, the local object
7372             --  will be finalzed by the scope finalizer generated later on. The
7373             --  object parameter of Deep_Finalize will always use the private
7374             --  view of the type. To avoid such a clash between a private and a
7375             --  full view, perform an unchecked conversion of the object
7376             --  reference to the private view.
7377
7378             declare
7379                Formal_Typ : constant Entity_Id :=
7380                               Etype (First_Formal (Fin_Id));
7381             begin
7382                if Is_Private_Type (Formal_Typ)
7383                  and then Present (Full_View (Formal_Typ))
7384                  and then Full_View (Formal_Typ) = Utyp
7385                then
7386                   Ref := Unchecked_Convert_To (Formal_Typ, Ref);
7387                end if;
7388             end;
7389
7390             Ref := Convert_View (Fin_Id, Ref);
7391          end if;
7392
7393          return
7394            Make_Call (Loc,
7395              Proc_Id   => Fin_Id,
7396              Param     => New_Copy_Tree (Ref),
7397              Skip_Self => Skip_Self);
7398       else
7399          return Empty;
7400       end if;
7401    end Make_Final_Call;
7402
7403    --------------------------------
7404    -- Make_Finalize_Address_Body --
7405    --------------------------------
7406
7407    procedure Make_Finalize_Address_Body (Typ : Entity_Id) is
7408       Is_Task : constant Boolean :=
7409                   Ekind (Typ) = E_Record_Type
7410                     and then Is_Concurrent_Record_Type (Typ)
7411                     and then Ekind (Corresponding_Concurrent_Type (Typ)) =
7412                                                                  E_Task_Type;
7413       Loc     : constant Source_Ptr := Sloc (Typ);
7414       Proc_Id : Entity_Id;
7415       Stmts   : List_Id;
7416
7417    begin
7418       --  The corresponding records of task types are not controlled by design.
7419       --  For the sake of completeness, create an empty Finalize_Address to be
7420       --  used in task class-wide allocations.
7421
7422       if Is_Task then
7423          null;
7424
7425       --  Nothing to do if the type is not controlled or it already has a
7426       --  TSS entry for Finalize_Address. Skip class-wide subtypes which do not
7427       --  come from source. These are usually generated for completeness and
7428       --  do not need the Finalize_Address primitive.
7429
7430       elsif not Needs_Finalization (Typ)
7431         or else Is_Abstract_Type (Typ)
7432         or else Present (TSS (Typ, TSS_Finalize_Address))
7433         or else
7434           (Is_Class_Wide_Type (Typ)
7435             and then Ekind (Root_Type (Typ)) = E_Record_Subtype
7436             and then not Comes_From_Source (Root_Type (Typ)))
7437       then
7438          return;
7439       end if;
7440
7441       Proc_Id :=
7442         Make_Defining_Identifier (Loc,
7443           Make_TSS_Name (Typ, TSS_Finalize_Address));
7444
7445       --  Generate:
7446
7447       --    procedure <Typ>FD (V : System.Address) is
7448       --    begin
7449       --       null;                            --  for tasks
7450
7451       --       declare                          --  for all other types
7452       --          type Pnn is access all Typ;
7453       --          for Pnn'Storage_Size use 0;
7454       --       begin
7455       --          [Deep_]Finalize (Pnn (V).all);
7456       --       end;
7457       --    end TypFD;
7458
7459       if Is_Task then
7460          Stmts := New_List (Make_Null_Statement (Loc));
7461       else
7462          Stmts := Make_Finalize_Address_Stmts (Typ);
7463       end if;
7464
7465       Discard_Node (
7466         Make_Subprogram_Body (Loc,
7467           Specification =>
7468             Make_Procedure_Specification (Loc,
7469               Defining_Unit_Name => Proc_Id,
7470
7471               Parameter_Specifications => New_List (
7472                 Make_Parameter_Specification (Loc,
7473                   Defining_Identifier =>
7474                     Make_Defining_Identifier (Loc, Name_V),
7475                   Parameter_Type =>
7476                     New_Occurrence_Of (RTE (RE_Address), Loc)))),
7477
7478           Declarations => No_List,
7479
7480           Handled_Statement_Sequence =>
7481             Make_Handled_Sequence_Of_Statements (Loc,
7482               Statements => Stmts)));
7483
7484       Set_TSS (Typ, Proc_Id);
7485    end Make_Finalize_Address_Body;
7486
7487    ---------------------------------
7488    -- Make_Finalize_Address_Stmts --
7489    ---------------------------------
7490
7491    function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id is
7492       Loc      : constant Source_Ptr := Sloc (Typ);
7493       Ptr_Typ  : constant Entity_Id  := Make_Temporary (Loc, 'P');
7494       Decls    : List_Id;
7495       Desg_Typ : Entity_Id;
7496       Obj_Expr : Node_Id;
7497
7498    begin
7499       if Is_Array_Type (Typ) then
7500          if Is_Constrained (First_Subtype (Typ)) then
7501             Desg_Typ := First_Subtype (Typ);
7502          else
7503             Desg_Typ := Base_Type (Typ);
7504          end if;
7505
7506       --  Class-wide types of constrained root types
7507
7508       elsif Is_Class_Wide_Type (Typ)
7509         and then Has_Discriminants (Root_Type (Typ))
7510         and then not
7511           Is_Empty_Elmt_List (Discriminant_Constraint (Root_Type (Typ)))
7512       then
7513          declare
7514             Parent_Typ : Entity_Id;
7515
7516          begin
7517             --  Climb the parent type chain looking for a non-constrained type
7518
7519             Parent_Typ := Root_Type (Typ);
7520             while Parent_Typ /= Etype (Parent_Typ)
7521               and then Has_Discriminants (Parent_Typ)
7522               and then not
7523                 Is_Empty_Elmt_List (Discriminant_Constraint (Parent_Typ))
7524             loop
7525                Parent_Typ := Etype (Parent_Typ);
7526             end loop;
7527
7528             --  Handle views created for tagged types with unknown
7529             --  discriminants.
7530
7531             if Is_Underlying_Record_View (Parent_Typ) then
7532                Parent_Typ := Underlying_Record_View (Parent_Typ);
7533             end if;
7534
7535             Desg_Typ := Class_Wide_Type (Underlying_Type (Parent_Typ));
7536          end;
7537
7538       --  General case
7539
7540       else
7541          Desg_Typ := Typ;
7542       end if;
7543
7544       --  Generate:
7545       --    type Ptr_Typ is access all Typ;
7546       --    for Ptr_Typ'Storage_Size use 0;
7547
7548       Decls := New_List (
7549         Make_Full_Type_Declaration (Loc,
7550           Defining_Identifier => Ptr_Typ,
7551           Type_Definition     =>
7552             Make_Access_To_Object_Definition (Loc,
7553               All_Present        => True,
7554               Subtype_Indication => New_Occurrence_Of (Desg_Typ, Loc))),
7555
7556         Make_Attribute_Definition_Clause (Loc,
7557           Name       => New_Occurrence_Of (Ptr_Typ, Loc),
7558           Chars      => Name_Storage_Size,
7559           Expression => Make_Integer_Literal (Loc, 0)));
7560
7561       Obj_Expr := Make_Identifier (Loc, Name_V);
7562
7563       --  Unconstrained arrays require special processing in order to retrieve
7564       --  the elements. To achieve this, we have to skip the dope vector which
7565       --  lays in front of the elements and then use a thin pointer to perform
7566       --  the address-to-access conversion.
7567
7568       if Is_Array_Type (Typ)
7569         and then not Is_Constrained (First_Subtype (Typ))
7570       then
7571          declare
7572             Dope_Id : Entity_Id;
7573
7574          begin
7575             --  Ensure that Ptr_Typ a thin pointer, generate:
7576             --    for Ptr_Typ'Size use System.Address'Size;
7577
7578             Append_To (Decls,
7579               Make_Attribute_Definition_Clause (Loc,
7580                 Name       => New_Occurrence_Of (Ptr_Typ, Loc),
7581                 Chars      => Name_Size,
7582                 Expression =>
7583                   Make_Integer_Literal (Loc, System_Address_Size)));
7584
7585             --  Generate:
7586             --    Dnn : constant Storage_Offset :=
7587             --            Desg_Typ'Descriptor_Size / Storage_Unit;
7588
7589             Dope_Id := Make_Temporary (Loc, 'D');
7590
7591             Append_To (Decls,
7592               Make_Object_Declaration (Loc,
7593                 Defining_Identifier => Dope_Id,
7594                 Constant_Present    => True,
7595                 Object_Definition   =>
7596                   New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
7597                 Expression          =>
7598                   Make_Op_Divide (Loc,
7599                     Left_Opnd  =>
7600                       Make_Attribute_Reference (Loc,
7601                         Prefix         => New_Occurrence_Of (Desg_Typ, Loc),
7602                         Attribute_Name => Name_Descriptor_Size),
7603                     Right_Opnd =>
7604                       Make_Integer_Literal (Loc, System_Storage_Unit))));
7605
7606             --  Shift the address from the start of the dope vector to the
7607             --  start of the elements:
7608             --
7609             --    V + Dnn
7610             --
7611             --  Note that this is done through a wrapper routine since RTSfind
7612             --  cannot retrieve operations with string names of the form "+".
7613
7614             Obj_Expr :=
7615               Make_Function_Call (Loc,
7616                 Name                   =>
7617                   New_Occurrence_Of (RTE (RE_Add_Offset_To_Address), Loc),
7618                 Parameter_Associations => New_List (
7619                   Obj_Expr,
7620                   New_Occurrence_Of (Dope_Id, Loc)));
7621          end;
7622       end if;
7623
7624       --  Create the block and the finalization call
7625
7626       return New_List (
7627         Make_Block_Statement (Loc,
7628           Declarations => Decls,
7629
7630           Handled_Statement_Sequence =>
7631             Make_Handled_Sequence_Of_Statements (Loc,
7632               Statements => New_List (
7633                 Make_Final_Call (
7634                   Obj_Ref =>
7635                     Make_Explicit_Dereference (Loc,
7636                       Prefix => Unchecked_Convert_To (Ptr_Typ, Obj_Expr)),
7637                   Typ => Desg_Typ)))));
7638    end Make_Finalize_Address_Stmts;
7639
7640    -------------------------------------
7641    -- Make_Handler_For_Ctrl_Operation --
7642    -------------------------------------
7643
7644    --  Generate:
7645
7646    --    when E : others =>
7647    --      Raise_From_Controlled_Operation (E);
7648
7649    --  or:
7650
7651    --    when others =>
7652    --      raise Program_Error [finalize raised exception];
7653
7654    --  depending on whether Raise_From_Controlled_Operation is available
7655
7656    function Make_Handler_For_Ctrl_Operation
7657      (Loc : Source_Ptr) return Node_Id
7658    is
7659       E_Occ : Entity_Id;
7660       --  Choice parameter (for the first case above)
7661
7662       Raise_Node : Node_Id;
7663       --  Procedure call or raise statement
7664
7665    begin
7666       --  Standard run-time, .NET/JVM targets: add choice parameter E and pass
7667       --  it to Raise_From_Controlled_Operation so that the original exception
7668       --  name and message can be recorded in the exception message for
7669       --  Program_Error.
7670
7671       if RTE_Available (RE_Raise_From_Controlled_Operation) then
7672          E_Occ := Make_Defining_Identifier (Loc, Name_E);
7673          Raise_Node :=
7674            Make_Procedure_Call_Statement (Loc,
7675              Name                   =>
7676                New_Occurrence_Of
7677                  (RTE (RE_Raise_From_Controlled_Operation), Loc),
7678              Parameter_Associations => New_List (
7679                New_Occurrence_Of (E_Occ, Loc)));
7680
7681       --  Restricted run-time: exception messages are not supported
7682
7683       else
7684          E_Occ := Empty;
7685          Raise_Node :=
7686            Make_Raise_Program_Error (Loc,
7687              Reason => PE_Finalize_Raised_Exception);
7688       end if;
7689
7690       return
7691         Make_Implicit_Exception_Handler (Loc,
7692           Exception_Choices => New_List (Make_Others_Choice (Loc)),
7693           Choice_Parameter  => E_Occ,
7694           Statements        => New_List (Raise_Node));
7695    end Make_Handler_For_Ctrl_Operation;
7696
7697    --------------------
7698    -- Make_Init_Call --
7699    --------------------
7700
7701    function Make_Init_Call
7702      (Obj_Ref : Node_Id;
7703       Typ     : Entity_Id) return Node_Id
7704    is
7705       Loc     : constant Source_Ptr := Sloc (Obj_Ref);
7706       Is_Conc : Boolean;
7707       Proc    : Entity_Id;
7708       Ref     : Node_Id;
7709       Utyp    : Entity_Id;
7710
7711    begin
7712       --  Deal with the type and object reference. Depending on the context, an
7713       --  object reference may need several conversions.
7714
7715       if Is_Concurrent_Type (Typ) then
7716          Is_Conc := True;
7717          Utyp    := Corresponding_Record_Type (Typ);
7718          Ref     := Convert_Concurrent (Obj_Ref, Typ);
7719
7720       elsif Is_Private_Type (Typ)
7721         and then Present (Full_View (Typ))
7722         and then Is_Concurrent_Type (Underlying_Type (Typ))
7723       then
7724          Is_Conc := True;
7725          Utyp    := Corresponding_Record_Type (Underlying_Type (Typ));
7726          Ref     := Convert_Concurrent (Obj_Ref, Underlying_Type (Typ));
7727
7728       else
7729          Is_Conc := False;
7730          Utyp    := Typ;
7731          Ref     := Obj_Ref;
7732       end if;
7733
7734       Set_Assignment_OK (Ref);
7735
7736       Utyp := Underlying_Type (Base_Type (Utyp));
7737
7738       --  Deal with non-tagged derivation of private views
7739
7740       if Is_Untagged_Derivation (Typ)
7741         and then not Is_Conc
7742       then
7743          Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
7744          Ref  := Unchecked_Convert_To (Utyp, Ref);
7745
7746          --  The following is to prevent problems with UC see 1.156 RH ???
7747
7748          Set_Assignment_OK (Ref);
7749       end if;
7750
7751       --  If the underlying_type is a subtype, then we are dealing with the
7752       --  completion of a private type. We need to access the base type and
7753       --  generate a conversion to it.
7754
7755       if Utyp /= Base_Type (Utyp) then
7756          pragma Assert (Is_Private_Type (Typ));
7757          Utyp := Base_Type (Utyp);
7758          Ref  := Unchecked_Convert_To (Utyp, Ref);
7759       end if;
7760
7761       --  Select the appropriate version of initialize
7762
7763       if Has_Controlled_Component (Utyp) then
7764          Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case));
7765       else
7766          Proc := Find_Prim_Op (Utyp, Name_Of (Initialize_Case));
7767          Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Ref);
7768       end if;
7769
7770       --  The object reference may need another conversion depending on the
7771       --  type of the formal and that of the actual.
7772
7773       Ref := Convert_View (Proc, Ref);
7774
7775       --  Generate:
7776       --    [Deep_]Initialize (Ref);
7777
7778       return
7779         Make_Procedure_Call_Statement (Loc,
7780           Name =>
7781             New_Occurrence_Of (Proc, Loc),
7782           Parameter_Associations => New_List (Ref));
7783    end Make_Init_Call;
7784
7785    ------------------------------
7786    -- Make_Local_Deep_Finalize --
7787    ------------------------------
7788
7789    function Make_Local_Deep_Finalize
7790      (Typ : Entity_Id;
7791       Nam : Entity_Id) return Node_Id
7792    is
7793       Loc : constant Source_Ptr := Sloc (Typ);
7794       Formals : List_Id;
7795
7796    begin
7797       Formals := New_List (
7798
7799          --  V : in out Typ
7800
7801         Make_Parameter_Specification (Loc,
7802           Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
7803           In_Present          => True,
7804           Out_Present         => True,
7805           Parameter_Type      => New_Occurrence_Of (Typ, Loc)),
7806
7807          --  F : Boolean := True
7808
7809         Make_Parameter_Specification (Loc,
7810           Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
7811           Parameter_Type      => New_Occurrence_Of (Standard_Boolean, Loc),
7812           Expression          => New_Occurrence_Of (Standard_True, Loc)));
7813
7814       --  Add the necessary number of counters to represent the initialization
7815       --  state of an object.
7816
7817       return
7818         Make_Subprogram_Body (Loc,
7819           Specification =>
7820             Make_Procedure_Specification (Loc,
7821               Defining_Unit_Name       => Nam,
7822               Parameter_Specifications => Formals),
7823
7824           Declarations => No_List,
7825
7826           Handled_Statement_Sequence =>
7827             Make_Handled_Sequence_Of_Statements (Loc,
7828               Statements => Make_Deep_Record_Body (Finalize_Case, Typ, True)));
7829    end Make_Local_Deep_Finalize;
7830
7831    ------------------------------------
7832    -- Make_Set_Finalize_Address_Call --
7833    ------------------------------------
7834
7835    function Make_Set_Finalize_Address_Call
7836      (Loc     : Source_Ptr;
7837       Typ     : Entity_Id;
7838       Ptr_Typ : Entity_Id) return Node_Id
7839    is
7840       Desig_Typ   : constant Entity_Id :=
7841                       Available_View (Designated_Type (Ptr_Typ));
7842       Fin_Mas_Id  : constant Entity_Id := Finalization_Master (Ptr_Typ);
7843       Fin_Mas_Ref : Node_Id;
7844       Utyp        : Entity_Id;
7845
7846    begin
7847       --  If the context is a class-wide allocator, we use the class-wide type
7848       --  to obtain the proper Finalize_Address routine.
7849
7850       if Is_Class_Wide_Type (Desig_Typ) then
7851          Utyp := Desig_Typ;
7852
7853       else
7854          Utyp := Typ;
7855
7856          if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then
7857             Utyp := Full_View (Utyp);
7858          end if;
7859
7860          if Is_Concurrent_Type (Utyp) then
7861             Utyp := Corresponding_Record_Type (Utyp);
7862          end if;
7863       end if;
7864
7865       Utyp := Underlying_Type (Base_Type (Utyp));
7866
7867       --  Deal with non-tagged derivation of private views. If the parent is
7868       --  now known to be protected, the finalization routine is the one
7869       --  defined on the corresponding record of the ancestor (corresponding
7870       --  records do not automatically inherit operations, but maybe they
7871       --  should???)
7872
7873       if Is_Untagged_Derivation (Typ) then
7874          if Is_Protected_Type (Typ) then
7875             Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
7876          else
7877             Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
7878
7879             if Is_Protected_Type (Utyp) then
7880                Utyp := Corresponding_Record_Type (Utyp);
7881             end if;
7882          end if;
7883       end if;
7884
7885       --  If the underlying_type is a subtype, we are dealing with the
7886       --  completion of a private type. We need to access the base type and
7887       --  generate a conversion to it.
7888
7889       if Utyp /= Base_Type (Utyp) then
7890          pragma Assert (Is_Private_Type (Typ));
7891
7892          Utyp := Base_Type (Utyp);
7893       end if;
7894
7895       Fin_Mas_Ref := New_Occurrence_Of (Fin_Mas_Id, Loc);
7896
7897       --  If the call is from a build-in-place function, the Master parameter
7898       --  is actually a pointer. Dereference it for the call.
7899
7900       if Is_Access_Type (Etype (Fin_Mas_Id)) then
7901          Fin_Mas_Ref := Make_Explicit_Dereference (Loc, Fin_Mas_Ref);
7902       end if;
7903
7904       --  Generate:
7905       --    Set_Finalize_Address (<Ptr_Typ>FM, <Utyp>FD'Unrestricted_Access);
7906
7907       return
7908         Make_Procedure_Call_Statement (Loc,
7909           Name                   =>
7910             New_Occurrence_Of (RTE (RE_Set_Finalize_Address), Loc),
7911           Parameter_Associations => New_List (
7912             Fin_Mas_Ref,
7913             Make_Attribute_Reference (Loc,
7914               Prefix         =>
7915                 New_Occurrence_Of (TSS (Utyp, TSS_Finalize_Address), Loc),
7916               Attribute_Name => Name_Unrestricted_Access)));
7917    end Make_Set_Finalize_Address_Call;
7918
7919    --------------------------
7920    -- Make_Transient_Block --
7921    --------------------------
7922
7923    function Make_Transient_Block
7924      (Loc    : Source_Ptr;
7925       Action : Node_Id;
7926       Par    : Node_Id) return Node_Id
7927    is
7928       Decls  : constant List_Id := New_List;
7929       Instrs : constant List_Id := New_List (Action);
7930       Block  : Node_Id;
7931       Insert : Node_Id;
7932
7933    begin
7934       --  Case where only secondary stack use is involved
7935
7936       if VM_Target = No_VM
7937         and then Uses_Sec_Stack (Current_Scope)
7938         and then Nkind (Action) /= N_Simple_Return_Statement
7939         and then Nkind (Par) /= N_Exception_Handler
7940       then
7941          declare
7942             S : Entity_Id;
7943
7944          begin
7945             S := Scope (Current_Scope);
7946             loop
7947                --  At the outer level, no need to release the sec stack
7948
7949                if S = Standard_Standard then
7950                   Set_Uses_Sec_Stack (Current_Scope, False);
7951                   exit;
7952
7953                --  In a function, only release the sec stack if the function
7954                --  does not return on the sec stack otherwise the result may
7955                --  be lost. The caller is responsible for releasing.
7956
7957                elsif Ekind (S) = E_Function then
7958                   Set_Uses_Sec_Stack (Current_Scope, False);
7959
7960                   if not Requires_Transient_Scope (Etype (S)) then
7961                      Set_Uses_Sec_Stack (S, True);
7962                      Check_Restriction (No_Secondary_Stack, Action);
7963                   end if;
7964
7965                   exit;
7966
7967                --  In a loop or entry we should install a block encompassing
7968                --  all the construct. For now just release right away.
7969
7970                elsif Ekind_In (S, E_Entry, E_Loop) then
7971                   exit;
7972
7973                --  In a procedure or a block, we release on exit of the
7974                --  procedure or block. ??? memory leak can be created by
7975                --  recursive calls.
7976
7977                elsif Ekind_In (S, E_Block, E_Procedure) then
7978                   Set_Uses_Sec_Stack (S, True);
7979                   Check_Restriction (No_Secondary_Stack, Action);
7980                   Set_Uses_Sec_Stack (Current_Scope, False);
7981                   exit;
7982
7983                else
7984                   S := Scope (S);
7985                end if;
7986             end loop;
7987          end;
7988       end if;
7989
7990       --  Create the transient block. Set the parent now since the block itself
7991       --  is not part of the tree. The current scope is the E_Block entity
7992       --  that has been pushed by Establish_Transient_Scope.
7993
7994       pragma Assert (Ekind (Current_Scope) = E_Block);
7995       Block :=
7996         Make_Block_Statement (Loc,
7997           Identifier                 => New_Occurrence_Of (Current_Scope, Loc),
7998           Declarations               => Decls,
7999           Handled_Statement_Sequence =>
8000             Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs),
8001           Has_Created_Identifier     => True);
8002       Set_Parent (Block, Par);
8003
8004       --  Insert actions stuck in the transient scopes as well as all freezing
8005       --  nodes needed by those actions.
8006
8007       Insert_Actions_In_Scope_Around (Action);
8008
8009       Insert := Prev (Action);
8010       if Present (Insert) then
8011          Freeze_All (First_Entity (Current_Scope), Insert);
8012       end if;
8013
8014       --  Transfer cleanup actions to the newly created block
8015
8016       declare
8017          Cleanup_Actions : List_Id
8018            renames Scope_Stack.Table (Scope_Stack.Last).
8019                      Actions_To_Be_Wrapped (Cleanup);
8020       begin
8021          Set_Cleanup_Actions (Block, Cleanup_Actions);
8022          Cleanup_Actions := No_List;
8023       end;
8024
8025       --  When the transient scope was established, we pushed the entry for the
8026       --  transient scope onto the scope stack, so that the scope was active
8027       --  for the installation of finalizable entities etc. Now we must remove
8028       --  this entry, since we have constructed a proper block.
8029
8030       Pop_Scope;
8031
8032       return Block;
8033    end Make_Transient_Block;
8034
8035    ------------------------
8036    -- Node_To_Be_Wrapped --
8037    ------------------------
8038
8039    function Node_To_Be_Wrapped return Node_Id is
8040    begin
8041       return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped;
8042    end Node_To_Be_Wrapped;
8043
8044    ----------------------------
8045    -- Set_Node_To_Be_Wrapped --
8046    ----------------------------
8047
8048    procedure Set_Node_To_Be_Wrapped (N : Node_Id) is
8049    begin
8050       Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := N;
8051    end Set_Node_To_Be_Wrapped;
8052
8053    ----------------------------
8054    -- Store_Actions_In_Scope --
8055    ----------------------------
8056
8057    procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id) is
8058       SE      : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
8059       Actions : List_Id renames SE.Actions_To_Be_Wrapped (AK);
8060
8061    begin
8062       if No (Actions) then
8063          Actions := L;
8064
8065          if Is_List_Member (SE.Node_To_Be_Wrapped) then
8066             Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
8067          else
8068             Set_Parent (L, SE.Node_To_Be_Wrapped);
8069          end if;
8070
8071          Analyze_List (L);
8072
8073       elsif AK = Before then
8074          Insert_List_After_And_Analyze (Last (Actions), L);
8075
8076       else
8077          Insert_List_Before_And_Analyze (First (Actions), L);
8078       end if;
8079    end Store_Actions_In_Scope;
8080
8081    ----------------------------------
8082    -- Store_After_Actions_In_Scope --
8083    ----------------------------------
8084
8085    procedure Store_After_Actions_In_Scope (L : List_Id) is
8086    begin
8087       Store_Actions_In_Scope (After, L);
8088    end Store_After_Actions_In_Scope;
8089
8090    -----------------------------------
8091    -- Store_Before_Actions_In_Scope --
8092    -----------------------------------
8093
8094    procedure Store_Before_Actions_In_Scope (L : List_Id) is
8095    begin
8096       Store_Actions_In_Scope (Before, L);
8097    end Store_Before_Actions_In_Scope;
8098
8099    -----------------------------------
8100    -- Store_Cleanup_Actions_In_Scope --
8101    -----------------------------------
8102
8103    procedure Store_Cleanup_Actions_In_Scope (L : List_Id) is
8104    begin
8105       Store_Actions_In_Scope (Cleanup, L);
8106    end Store_Cleanup_Actions_In_Scope;
8107
8108    --------------------------------
8109    -- Wrap_Transient_Declaration --
8110    --------------------------------
8111
8112    --  If a transient scope has been established during the processing of the
8113    --  Expression of an Object_Declaration, it is not possible to wrap the
8114    --  declaration into a transient block as usual case, otherwise the object
8115    --  would be itself declared in the wrong scope. Therefore, all entities (if
8116    --  any) defined in the transient block are moved to the proper enclosing
8117    --  scope, furthermore, if they are controlled variables they are finalized
8118    --  right after the declaration. The finalization list of the transient
8119    --  scope is defined as a renaming of the enclosing one so during their
8120    --  initialization they will be attached to the proper finalization list.
8121    --  For instance, the following declaration :
8122
8123    --        X : Typ := F (G (A), G (B));
8124
8125    --  (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
8126    --  is expanded into :
8127
8128    --    X : Typ := [ complex Expression-Action ];
8129    --    [Deep_]Finalize (_v1);
8130    --    [Deep_]Finalize (_v2);
8131
8132    procedure Wrap_Transient_Declaration (N : Node_Id) is
8133       Encl_S  : Entity_Id;
8134       S       : Entity_Id;
8135       Uses_SS : Boolean;
8136
8137    begin
8138       S := Current_Scope;
8139       Encl_S := Scope (S);
8140
8141       --  Insert Actions kept in the Scope stack
8142
8143       Insert_Actions_In_Scope_Around (N);
8144
8145       --  If the declaration is consuming some secondary stack, mark the
8146       --  enclosing scope appropriately.
8147
8148       Uses_SS := Uses_Sec_Stack (S);
8149       Pop_Scope;
8150
8151       --  Put the local entities back in the enclosing scope, and set the
8152       --  Is_Public flag appropriately.
8153
8154       Transfer_Entities (S, Encl_S);
8155
8156       --  Mark the enclosing dynamic scope so that the sec stack will be
8157       --  released upon its exit unless this is a function that returns on
8158       --  the sec stack in which case this will be done by the caller.
8159
8160       if VM_Target = No_VM and then Uses_SS then
8161          S := Enclosing_Dynamic_Scope (S);
8162
8163          if Ekind (S) = E_Function
8164            and then Requires_Transient_Scope (Etype (S))
8165          then
8166             null;
8167          else
8168             Set_Uses_Sec_Stack (S);
8169             Check_Restriction (No_Secondary_Stack, N);
8170          end if;
8171       end if;
8172    end Wrap_Transient_Declaration;
8173
8174    -------------------------------
8175    -- Wrap_Transient_Expression --
8176    -------------------------------
8177
8178    procedure Wrap_Transient_Expression (N : Node_Id) is
8179       Loc  : constant Source_Ptr := Sloc (N);
8180       Expr : Node_Id             := Relocate_Node (N);
8181       Temp : constant Entity_Id  := Make_Temporary (Loc, 'E', N);
8182       Typ  : constant Entity_Id  := Etype (N);
8183
8184    begin
8185       --  Generate:
8186
8187       --    Temp : Typ;
8188       --    declare
8189       --       M : constant Mark_Id := SS_Mark;
8190       --       procedure Finalizer is ...  (See Build_Finalizer)
8191       --
8192       --    begin
8193       --       Temp := <Expr>;                           --  general case
8194       --       Temp := (if <Expr> then True else False); --  boolean case
8195       --
8196       --    at end
8197       --       Finalizer;
8198       --    end;
8199
8200       --  A special case is made for Boolean expressions so that the back-end
8201       --  knows to generate a conditional branch instruction, if running with
8202       --  -fpreserve-control-flow. This ensures that a control flow change
8203       --  signalling the decision outcome occurs before the cleanup actions.
8204
8205       if Opt.Suppress_Control_Flow_Optimizations
8206         and then Is_Boolean_Type (Typ)
8207       then
8208          Expr :=
8209            Make_If_Expression (Loc,
8210              Expressions => New_List (
8211                Expr,
8212                New_Occurrence_Of (Standard_True, Loc),
8213                New_Occurrence_Of (Standard_False, Loc)));
8214       end if;
8215
8216       Insert_Actions (N, New_List (
8217         Make_Object_Declaration (Loc,
8218           Defining_Identifier => Temp,
8219           Object_Definition   => New_Occurrence_Of (Typ, Loc)),
8220
8221         Make_Transient_Block (Loc,
8222           Action =>
8223             Make_Assignment_Statement (Loc,
8224               Name       => New_Occurrence_Of (Temp, Loc),
8225               Expression => Expr),
8226           Par    => Parent (N))));
8227
8228       Rewrite (N, New_Occurrence_Of (Temp, Loc));
8229       Analyze_And_Resolve (N, Typ);
8230    end Wrap_Transient_Expression;
8231
8232    ------------------------------
8233    -- Wrap_Transient_Statement --
8234    ------------------------------
8235
8236    procedure Wrap_Transient_Statement (N : Node_Id) is
8237       Loc      : constant Source_Ptr := Sloc (N);
8238       New_Stmt : constant Node_Id    := Relocate_Node (N);
8239
8240    begin
8241       --  Generate:
8242       --    declare
8243       --       M : constant Mark_Id := SS_Mark;
8244       --       procedure Finalizer is ...  (See Build_Finalizer)
8245       --
8246       --    begin
8247       --       <New_Stmt>;
8248       --
8249       --    at end
8250       --       Finalizer;
8251       --    end;
8252
8253       Rewrite (N,
8254         Make_Transient_Block (Loc,
8255           Action => New_Stmt,
8256           Par    => Parent (N)));
8257
8258       --  With the scope stack back to normal, we can call analyze on the
8259       --  resulting block. At this point, the transient scope is being
8260       --  treated like a perfectly normal scope, so there is nothing
8261       --  special about it.
8262
8263       --  Note: Wrap_Transient_Statement is called with the node already
8264       --  analyzed (i.e. Analyzed (N) is True). This is important, since
8265       --  otherwise we would get a recursive processing of the node when
8266       --  we do this Analyze call.
8267
8268       Analyze (N);
8269    end Wrap_Transient_Statement;
8270
8271 end Exp_Ch7;