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