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