gcc/ada/exp_ch7.adb

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