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