gcc/ada/exp_ch7.adb

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