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