gcc/ada/exp_ch7.adb

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