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