gcc/ada/exp_ch7.adb

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