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-2004, 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 2,  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 COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 --  This package contains virtually all expansion mechanisms related to
  28 --    - controlled types
  29 --    - transient scopes
  30
  31 with Atree;    use Atree;
  32 with Debug;    use Debug;
  33 with Einfo;    use Einfo;
  34 with Errout;   use Errout;
  35 with Exp_Ch9;  use Exp_Ch9;
  36 with Exp_Ch11; use Exp_Ch11;
  37 with Exp_Dbug; use Exp_Dbug;
  38 with Exp_Tss;  use Exp_Tss;
  39 with Exp_Util; use Exp_Util;
  40 with Freeze;   use Freeze;
  41 with Hostparm; use Hostparm;
  42 with Nlists;   use Nlists;
  43 with Nmake;    use Nmake;
  44 with Opt;      use Opt;
  45 with Output;   use Output;
  46 with Restrict; use Restrict;
  47 with Rident;   use Rident;
  48 with Rtsfind;  use Rtsfind;
  49 with Targparm; use Targparm;
  50 with Sinfo;    use Sinfo;
  51 with Sem;      use Sem;
  52 with Sem_Ch3;  use Sem_Ch3;
  53 with Sem_Ch7;  use Sem_Ch7;
  54 with Sem_Ch8;  use Sem_Ch8;
  55 with Sem_Res;  use Sem_Res;
  56 with Sem_Type; use Sem_Type;
  57 with Sem_Util; use Sem_Util;
  58 with Snames;   use Snames;
  59 with Stand;    use Stand;
  60 with Tbuild;   use Tbuild;
  61 with Uintp;    use Uintp;
  62
  63 package body Exp_Ch7 is
  64
  65    --------------------------------
  66    -- Transient Scope Management --
  67    --------------------------------
  68
  69    --  A transient scope is created when temporary objects are created by the
  70    --  compiler. These temporary objects are allocated on the secondary stack
  71    --  and the transient scope is responsible for finalizing the object when
  72    --  appropriate and reclaiming the memory at the right time. The temporary
  73    --  objects are generally the objects allocated to store the result of a
  74    --  function returning an unconstrained or a tagged value. Expressions
  75    --  needing to be wrapped in a transient scope (functions calls returning
  76    --  unconstrained or tagged values) may appear in 3 different contexts which
  77    --  lead to 3 different kinds of transient scope expansion:
  78
  79    --   1. In a simple statement (procedure call, assignment, ...). In
  80    --      this case the instruction is wrapped into a transient block.
  81    --      (See Wrap_Transient_Statement for details)
  82
  83    --   2. In an expression of a control structure (test in a IF statement,
  84    --      expression in a CASE statement, ...).
  85    --      (See Wrap_Transient_Expression for details)
  86
  87    --   3. In a expression of an object_declaration. No wrapping is possible
  88    --      here, so the finalization actions, if any are done right after the
  89    --      declaration and the secondary stack deallocation is done in the
  90    --      proper enclosing scope (see Wrap_Transient_Declaration for details)
  91
  92    --  Note about function returning tagged types: It has been decided to
  93    --  always allocate their result in the secondary stack while it is not
  94    --  absolutely mandatory when the tagged type is constrained because the
  95    --  caller knows the size of the returned object and thus could allocate the
  96    --  result in the primary stack. But, allocating them always in the
  97    --  secondary stack simplifies many implementation hassles:
  98
  99    --    - If it is dispatching function call, the computation of the size of
 100    --      the result is possible but complex from the outside.
 101
 102    --    - If the returned type is controlled, the assignment of the returned
 103    --      value to the anonymous object involves an Adjust, and we have no
 104    --      easy way to access the anonymous object created by the back-end
 105
 106    --    - If the returned type is class-wide, this is an unconstrained type
 107    --      anyway
 108
 109    --  Furthermore, the little loss in efficiency which is the result of this
 110    --  decision is not such a big deal because function returning tagged types
 111    --  are not very much used in real life as opposed to functions returning
 112    --  access to a tagged type
 113
 114    --------------------------------------------------
 115    -- Transient Blocks and Finalization Management --
 116    --------------------------------------------------
 117
 118    function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id;
 119    --  N is a node wich may generate a transient scope. Loop over the
 120    --  parent pointers of N until it find the appropriate node to
 121    --  wrap. It it returns Empty, it means that no transient scope is
 122    --  needed in this context.
 123
 124    function Make_Clean
 125      (N                          : Node_Id;
 126       Clean                      : Entity_Id;
 127       Mark                       : Entity_Id;
 128       Flist                      : Entity_Id;
 129       Is_Task                    : Boolean;
 130       Is_Master                  : Boolean;
 131       Is_Protected_Subprogram    : Boolean;
 132       Is_Task_Allocation_Block   : Boolean;
 133       Is_Asynchronous_Call_Block : Boolean)
 134       return      Node_Id;
 135    --  Expand a the clean-up procedure for controlled and/or transient
 136    --  block, and/or task master or task body, or blocks used to
 137    --  implement task allocation or asynchronous entry calls, or
 138    --  procedures used to implement protected procedures. Clean is the
 139    --  entity for such a procedure. Mark is the entity for the secondary
 140    --  stack mark, if empty only controlled block clean-up will be
 141    --  performed. Flist is the entity for the local final list, if empty
 142    --  only transient scope clean-up will be performed. The flags
 143    --  Is_Task and Is_Master control the calls to the corresponding
 144    --  finalization actions for a task body or for an entity that is a
 145    --  task master.
 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    procedure Insert_Actions_In_Scope_Around (N : Node_Id);
 151    --  Insert the before-actions kept in the scope stack before N, and the
 152    --  after after-actions, after N which must be a member of a list.
 153
 154    function Make_Transient_Block
 155      (Loc    : Source_Ptr;
 156       Action : Node_Id)
 157       return   Node_Id;
 158    --  Create a transient block whose name is Scope, which is also a
 159    --  controlled block if Flist is not empty and whose only code is
 160    --  Action (either a single statement or single declaration).
 161
 162    type Final_Primitives is (Initialize_Case, Adjust_Case, Finalize_Case);
 163    --  This enumeration type is defined in order to ease sharing code for
 164    --  building finalization procedures for composite types.
 165
 166    Name_Of      : constant array (Final_Primitives) of Name_Id :=
 167                     (Initialize_Case => Name_Initialize,
 168                      Adjust_Case     => Name_Adjust,
 169                      Finalize_Case   => Name_Finalize);
 170
 171    Deep_Name_Of : constant array (Final_Primitives) of TSS_Name_Type :=
 172                     (Initialize_Case => TSS_Deep_Initialize,
 173                      Adjust_Case     => TSS_Deep_Adjust,
 174                      Finalize_Case   => TSS_Deep_Finalize);
 175
 176    procedure Build_Record_Deep_Procs (Typ : Entity_Id);
 177    --  Build the deep Initialize/Adjust/Finalize for a record Typ with
 178    --  Has_Component_Component set and store them using the TSS mechanism.
 179
 180    procedure Build_Array_Deep_Procs (Typ : Entity_Id);
 181    --  Build the deep Initialize/Adjust/Finalize for a record Typ with
 182    --  Has_Controlled_Component set and store them using the TSS mechanism.
 183
 184    function Make_Deep_Proc
 185      (Prim  : Final_Primitives;
 186       Typ   : Entity_Id;
 187       Stmts : List_Id)
 188       return  Node_Id;
 189    --  This function generates the tree for Deep_Initialize, Deep_Adjust
 190    --  or Deep_Finalize procedures according to the first parameter,
 191    --  these procedures operate on the type Typ. The Stmts parameter
 192    --  gives the body of the procedure.
 193
 194    function Make_Deep_Array_Body
 195      (Prim : Final_Primitives;
 196       Typ  : Entity_Id)
 197       return List_Id;
 198    --  This function generates the list of statements for implementing
 199    --  Deep_Initialize, Deep_Adjust or Deep_Finalize procedures
 200    --  according to the first parameter, these procedures operate on the
 201    --  array type Typ.
 202
 203    function Make_Deep_Record_Body
 204      (Prim : Final_Primitives;
 205       Typ  : Entity_Id)
 206       return List_Id;
 207    --  This function generates the list of statements for implementing
 208    --  Deep_Initialize, Deep_Adjust or Deep_Finalize procedures
 209    --  according to the first parameter, these procedures operate on the
 210    --  record type Typ.
 211
 212    procedure Check_Visibly_Controlled
 213      (Prim : Final_Primitives;
 214       Typ  : Entity_Id;
 215       E    : in out Entity_Id;
 216       Cref : in out Node_Id);
 217    --  The controlled operation declared for a derived type may not be
 218    --  overriding, if the controlled operations of the parent type are
 219    --  hidden, for example when the parent is a private type whose full
 220    --  view is controlled. For other primitive operations we modify the
 221    --  name of the operation to indicate that it is not overriding, but
 222    --  this is not possible for Initialize, etc. because they have to be
 223    --  retrievable by name. Before generating the proper call to one of
 224    --  these operations we check whether Typ is known to be controlled at
 225    --  the point of definition. If it is not then we must retrieve the
 226    --  hidden operation of the parent and use it instead.  This is one
 227    --  case that might be solved more cleanly once Overriding pragmas or
 228    --  declarations are in place.
 229
 230    function Convert_View
 231      (Proc : Entity_Id;
 232       Arg  : Node_Id;
 233       Ind  : Pos := 1)
 234       return Node_Id;
 235    --  Proc is one of the Initialize/Adjust/Finalize operations, and
 236    --  Arg is the argument being passed to it. Ind indicates which
 237    --  formal of procedure Proc we are trying to match. This function
 238    --  will, if necessary, generate an conversion between the partial
 239    --  and full view of Arg to match the type of the formal of Proc,
 240    --  or force a conversion to the class-wide type in the case where
 241    --  the operation is abstract.
 242
 243    -----------------------------
 244    -- Finalization Management --
 245    -----------------------------
 246
 247    --  This part describe how Initialization/Adjusment/Finalization procedures
 248    --  are generated and called. Two cases must be considered, types that are
 249    --  Controlled (Is_Controlled flag set) and composite types that contain
 250    --  controlled components (Has_Controlled_Component flag set). In the first
 251    --  case the procedures to call are the user-defined primitive operations
 252    --  Initialize/Adjust/Finalize. In the second case, GNAT generates
 253    --  Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge of
 254    --  calling the former procedures on the controlled components.
 255
 256    --  For records with Has_Controlled_Component set, a hidden "controller"
 257    --  component is inserted. This controller component contains its own
 258    --  finalization list on which all controlled components are attached
 259    --  creating an indirection on the upper-level Finalization list. This
 260    --  technique facilitates the management of objects whose number of
 261    --  controlled components changes during execution. This controller
 262    --  component is itself controlled and is attached to the upper-level
 263    --  finalization chain. Its adjust primitive is in charge of calling
 264    --  adjust on the components and adusting the finalization pointer to
 265    --  match their new location (see a-finali.adb).
 266
 267    --  It is not possible to use a similar technique for arrays that have
 268    --  Has_Controlled_Component set. In this case, deep procedures are
 269    --  generated that call initialize/adjust/finalize + attachment or
 270    --  detachment on the finalization list for all component.
 271
 272    --  Initialize calls: they are generated for declarations or dynamic
 273    --  allocations of Controlled objects with no initial value. They are
 274    --  always followed by an attachment to the current Finalization
 275    --  Chain. For the dynamic allocation case this the chain attached to
 276    --  the scope of the access type definition otherwise, this is the chain
 277    --  of the current scope.
 278
 279    --  Adjust Calls: They are generated on 2 occasions: (1) for
 280    --  declarations or dynamic allocations of Controlled objects with an
 281    --  initial value. (2) after an assignment. In the first case they are
 282    --  followed by an attachment to the final chain, in the second case
 283    --  they are not.
 284
 285    --  Finalization Calls: They are generated on (1) scope exit, (2)
 286    --  assignments, (3) unchecked deallocations. In case (3) they have to
 287    --  be detached from the final chain, in case (2) they must not and in
 288    --  case (1) this is not important since we are exiting the scope
 289    --  anyway.
 290
 291    --  Other details:
 292    --    - Type extensions will have a new record controller at each derivation
 293    --      level containing controlled components.
 294    --    - For types that are both Is_Controlled and Has_Controlled_Components,
 295    --      the record controller and the object itself are handled separately.
 296    --      It could seem simpler to attach the object at the end of its record
 297    --      controller but this would not tackle view conversions properly.
 298    --    - A classwide type can always potentially have controlled components
 299    --      but the record controller of the corresponding actual type may not
 300    --      be nown at compile time so the dispatch table contains a special
 301    --      field that allows to compute the offset of the record controller
 302    --      dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset
 303
 304    --  Here is a simple example of the expansion of a controlled block :
 305
 306    --    declare
 307    --       X : Controlled ;
 308    --       Y : Controlled := Init;
 309    --
 310    --       type R is record
 311    --          C : Controlled;
 312    --       end record;
 313    --       W : R;
 314    --       Z : R := (C => X);
 315    --    begin
 316    --       X := Y;
 317    --       W := Z;
 318    --    end;
 319    --
 320    --  is expanded into
 321    --
 322    --    declare
 323    --       _L : System.FI.Finalizable_Ptr;
 324
 325    --       procedure _Clean is
 326    --       begin
 327    --          Abort_Defer;
 328    --          System.FI.Finalize_List (_L);
 329    --          Abort_Undefer;
 330    --       end _Clean;
 331
 332    --       X : Controlled;
 333    --       begin
 334    --          Abort_Defer;
 335    --          Initialize (X);
 336    --          Attach_To_Final_List (_L, Finalizable (X), 1);
 337    --       at end: Abort_Undefer;
 338    --       Y : Controlled := Init;
 339    --       Adjust (Y);
 340    --       Attach_To_Final_List (_L, Finalizable (Y), 1);
 341    --
 342    --       type R is record
 343    --         _C : Record_Controller;
 344    --          C : Controlled;
 345    --       end record;
 346    --       W : R;
 347    --       begin
 348    --          Abort_Defer;
 349    --          Deep_Initialize (W, _L, 1);
 350    --       at end: Abort_Under;
 351    --       Z : R := (C => X);
 352    --       Deep_Adjust (Z, _L, 1);
 353
 354    --    begin
 355    --       _Assign (X, Y);
 356    --       Deep_Finalize (W, False);
 357    --       <save W's final pointers>
 358    --       W := Z;
 359    --       <restore W's final pointers>
 360    --       Deep_Adjust (W, _L, 0);
 361    --    at end
 362    --       _Clean;
 363    --    end;
 364
 365    function Global_Flist_Ref (Flist_Ref : Node_Id) return Boolean;
 366    --  Return True if Flist_Ref refers to a global final list, either
 367    --  the object GLobal_Final_List which is used to attach standalone
 368    --  objects, or any of the list controllers associated with library
 369    --  level access to controlled objects
 370
 371    procedure Clean_Simple_Protected_Objects (N : Node_Id);
 372    --  Protected objects without entries are not controlled types, and the
 373    --  locks have to be released explicitly when such an object goes out
 374    --  of scope. Traverse declarations in scope to determine whether such
 375    --  objects are present.
 376
 377    ----------------------------
 378    -- Build_Array_Deep_Procs --
 379    ----------------------------
 380
 381    procedure Build_Array_Deep_Procs (Typ : Entity_Id) is
 382    begin
 383       Set_TSS (Typ,
 384         Make_Deep_Proc (
 385           Prim  => Initialize_Case,
 386           Typ   => Typ,
 387           Stmts => Make_Deep_Array_Body (Initialize_Case, Typ)));
 388
 389       if not Is_Return_By_Reference_Type (Typ) then
 390          Set_TSS (Typ,
 391            Make_Deep_Proc (
 392              Prim  => Adjust_Case,
 393              Typ   => Typ,
 394              Stmts => Make_Deep_Array_Body (Adjust_Case, Typ)));
 395       end if;
 396
 397       Set_TSS (Typ,
 398         Make_Deep_Proc (
 399           Prim  => Finalize_Case,
 400           Typ   => Typ,
 401           Stmts => Make_Deep_Array_Body (Finalize_Case, Typ)));
 402    end Build_Array_Deep_Procs;
 403
 404    -----------------------------
 405    -- Build_Controlling_Procs --
 406    -----------------------------
 407
 408    procedure Build_Controlling_Procs (Typ : Entity_Id) is
 409    begin
 410       if Is_Array_Type (Typ) then
 411          Build_Array_Deep_Procs (Typ);
 412
 413       else pragma Assert (Is_Record_Type (Typ));
 414          Build_Record_Deep_Procs (Typ);
 415       end if;
 416    end Build_Controlling_Procs;
 417
 418    ----------------------
 419    -- Build_Final_List --
 420    ----------------------
 421
 422    procedure Build_Final_List (N : Node_Id; Typ : Entity_Id) is
 423       Loc  : constant Source_Ptr := Sloc (N);
 424       Decl : Node_Id;
 425
 426    begin
 427       Set_Associated_Final_Chain (Typ,
 428         Make_Defining_Identifier (Loc,
 429           New_External_Name (Chars (Typ), 'L')));
 430
 431       Decl :=
 432         Make_Object_Declaration (Loc,
 433           Defining_Identifier =>
 434              Associated_Final_Chain (Typ),
 435           Object_Definition   =>
 436             New_Reference_To
 437               (RTE (RE_List_Controller), Loc));
 438
 439       --  The type may have been frozen already, and this is a late freezing
 440       --  action, in which case the declaration must be elaborated at once.
 441       --  If the call is for an allocator, the chain must also be created now,
 442       --  because the freezing of the type does not build one. Otherwise, the
 443       --  declaration is one of the freezing actions for a user-defined type.
 444
 445       if Is_Frozen (Typ)
 446         or else (Nkind (N) = N_Allocator
 447                   and then Ekind (Etype (N)) = E_Anonymous_Access_Type)
 448       then
 449          Insert_Action (N, Decl);
 450       else
 451          Append_Freeze_Action (Typ, Decl);
 452       end if;
 453    end Build_Final_List;
 454
 455    ---------------------
 456    -- Build_Late_Proc --
 457    ---------------------
 458
 459    procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is
 460    begin
 461       for Final_Prim in Name_Of'Range loop
 462          if Name_Of (Final_Prim) = Nam then
 463             Set_TSS (Typ,
 464               Make_Deep_Proc (
 465                 Prim  => Final_Prim,
 466                 Typ   => Typ,
 467                 Stmts => Make_Deep_Record_Body (Final_Prim, Typ)));
 468          end if;
 469       end loop;
 470    end Build_Late_Proc;
 471
 472    -----------------------------
 473    -- Build_Record_Deep_Procs --
 474    -----------------------------
 475
 476    procedure Build_Record_Deep_Procs (Typ : Entity_Id) is
 477    begin
 478       Set_TSS (Typ,
 479         Make_Deep_Proc (
 480           Prim  => Initialize_Case,
 481           Typ   => Typ,
 482           Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
 483
 484       if not Is_Return_By_Reference_Type (Typ) then
 485          Set_TSS (Typ,
 486            Make_Deep_Proc (
 487              Prim  => Adjust_Case,
 488              Typ   => Typ,
 489              Stmts => Make_Deep_Record_Body (Adjust_Case, Typ)));
 490       end if;
 491
 492       Set_TSS (Typ,
 493         Make_Deep_Proc (
 494           Prim  => Finalize_Case,
 495           Typ   => Typ,
 496           Stmts => Make_Deep_Record_Body (Finalize_Case, Typ)));
 497    end Build_Record_Deep_Procs;
 498
 499    -------------------
 500    -- Cleanup_Array --
 501    -------------------
 502
 503    function Cleanup_Array
 504      (N    : Node_Id;
 505       Obj  : Node_Id;
 506       Typ  : Entity_Id)
 507       return List_Id
 508    is
 509       Loc        : constant Source_Ptr := Sloc (N);
 510       Index_List : constant List_Id := New_List;
 511
 512       function Free_Component return List_Id;
 513       --  Generate the code to finalize the task or protected  subcomponents
 514       --  of a single component of the array.
 515
 516       function Free_One_Dimension (Dim : Int) return List_Id;
 517       --  Generate a loop over one dimension of the array.
 518
 519       --------------------
 520       -- Free_Component --
 521       --------------------
 522
 523       function Free_Component return List_Id is
 524          Stmts : List_Id := New_List;
 525          Tsk   : Node_Id;
 526          C_Typ : constant Entity_Id := Component_Type (Typ);
 527
 528       begin
 529          --  Component type is known to contain tasks or protected objects
 530
 531          Tsk :=
 532            Make_Indexed_Component (Loc,
 533              Prefix        => Duplicate_Subexpr_No_Checks (Obj),
 534              Expressions   => Index_List);
 535
 536          Set_Etype (Tsk, C_Typ);
 537
 538          if Is_Task_Type (C_Typ) then
 539             Append_To (Stmts, Cleanup_Task (N, Tsk));
 540
 541          elsif Is_Simple_Protected_Type (C_Typ) then
 542             Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
 543
 544          elsif Is_Record_Type (C_Typ) then
 545             Stmts := Cleanup_Record (N, Tsk, C_Typ);
 546
 547          elsif Is_Array_Type (C_Typ) then
 548             Stmts := Cleanup_Array (N, Tsk, C_Typ);
 549          end if;
 550
 551          return Stmts;
 552       end Free_Component;
 553
 554       ------------------------
 555       -- Free_One_Dimension --
 556       ------------------------
 557
 558       function Free_One_Dimension (Dim : Int) return List_Id is
 559          Index      : Entity_Id;
 560
 561       begin
 562          if Dim > Number_Dimensions (Typ) then
 563             return Free_Component;
 564
 565          --  Here we generate the required loop
 566
 567          else
 568             Index :=
 569               Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
 570
 571             Append (New_Reference_To (Index, Loc), Index_List);
 572
 573             return New_List (
 574               Make_Implicit_Loop_Statement (N,
 575                 Identifier => Empty,
 576                 Iteration_Scheme =>
 577                   Make_Iteration_Scheme (Loc,
 578                     Loop_Parameter_Specification =>
 579                       Make_Loop_Parameter_Specification (Loc,
 580                         Defining_Identifier => Index,
 581                         Discrete_Subtype_Definition =>
 582                           Make_Attribute_Reference (Loc,
 583                             Prefix => Duplicate_Subexpr (Obj),
 584                             Attribute_Name  => Name_Range,
 585                             Expressions => New_List (
 586                               Make_Integer_Literal (Loc, Dim))))),
 587                 Statements =>  Free_One_Dimension (Dim + 1)));
 588          end if;
 589       end Free_One_Dimension;
 590
 591    --  Start of processing for Cleanup_Array
 592
 593    begin
 594       return Free_One_Dimension (1);
 595    end Cleanup_Array;
 596
 597    --------------------
 598    -- Cleanup_Record --
 599    --------------------
 600
 601    function Cleanup_Record
 602      (N    : Node_Id;
 603       Obj  : Node_Id;
 604       Typ  : Entity_Id)
 605       return List_Id
 606    is
 607       Loc   : constant Source_Ptr := Sloc (N);
 608       Tsk   : Node_Id;
 609       Comp  : Entity_Id;
 610       Stmts : constant List_Id    := New_List;
 611       U_Typ : constant Entity_Id  := Underlying_Type (Typ);
 612
 613    begin
 614       if Has_Discriminants (U_Typ)
 615         and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration
 616         and then
 617           Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition
 618         and then
 619           Present
 620             (Variant_Part
 621               (Component_List (Type_Definition (Parent (U_Typ)))))
 622       then
 623          --  For now, do not attempt to free a component that may appear in
 624          --  a variant, and instead issue a warning. Doing this "properly"
 625          --  would require building a case statement and would be quite a
 626          --  mess. Note that the RM only requires that free "work" for the
 627          --  case of a task access value, so already we go way beyond this
 628          --  in that we deal with the array case and non-discriminated
 629          --  record cases.
 630
 631          Error_Msg_N
 632            ("task/protected object in variant record will not be freed?", N);
 633          return New_List (Make_Null_Statement (Loc));
 634       end if;
 635
 636       Comp := First_Component (Typ);
 637
 638       while Present (Comp) loop
 639          if Has_Task (Etype (Comp))
 640            or else Has_Simple_Protected_Object (Etype (Comp))
 641          then
 642             Tsk :=
 643               Make_Selected_Component (Loc,
 644                 Prefix        => Duplicate_Subexpr_No_Checks (Obj),
 645                 Selector_Name => New_Occurrence_Of (Comp, Loc));
 646             Set_Etype (Tsk, Etype (Comp));
 647
 648             if Is_Task_Type (Etype (Comp)) then
 649                Append_To (Stmts, Cleanup_Task (N, Tsk));
 650
 651             elsif Is_Simple_Protected_Type (Etype (Comp)) then
 652                Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
 653
 654             elsif Is_Record_Type (Etype (Comp)) then
 655
 656                --  Recurse, by generating the prefix of the argument to
 657                --  the eventual cleanup call.
 658
 659                Append_List_To
 660                  (Stmts, Cleanup_Record (N, Tsk, Etype (Comp)));
 661
 662             elsif Is_Array_Type (Etype (Comp)) then
 663                Append_List_To
 664                  (Stmts, Cleanup_Array (N, Tsk, Etype (Comp)));
 665             end if;
 666          end if;
 667
 668          Next_Component (Comp);
 669       end loop;
 670
 671       return Stmts;
 672    end Cleanup_Record;
 673
 674    -------------------------------
 675    --  Cleanup_Protected_Object --
 676    -------------------------------
 677
 678    function Cleanup_Protected_Object
 679      (N    : Node_Id;
 680       Ref  : Node_Id)
 681       return Node_Id
 682    is
 683       Loc : constant Source_Ptr := Sloc (N);
 684
 685    begin
 686       return
 687         Make_Procedure_Call_Statement (Loc,
 688           Name => New_Reference_To (RTE (RE_Finalize_Protection), Loc),
 689           Parameter_Associations => New_List (
 690             Concurrent_Ref (Ref)));
 691    end Cleanup_Protected_Object;
 692
 693    ------------------------------------
 694    -- Clean_Simple_Protected_Objects --
 695    ------------------------------------
 696
 697    procedure Clean_Simple_Protected_Objects (N : Node_Id) is
 698       Stmts : constant List_Id := Statements (Handled_Statement_Sequence (N));
 699       Stmt  : Node_Id          := Last (Stmts);
 700       E     : Entity_Id;
 701
 702    begin
 703       E := First_Entity (Current_Scope);
 704       while Present (E) loop
 705          if (Ekind (E) = E_Variable
 706               or else Ekind (E) = E_Constant)
 707            and then Has_Simple_Protected_Object (Etype (E))
 708            and then not Has_Task (Etype (E))
 709          then
 710             declare
 711                Typ : constant Entity_Id := Etype (E);
 712                Ref : constant Node_Id := New_Occurrence_Of (E, Sloc (Stmt));
 713
 714             begin
 715                if Is_Simple_Protected_Type (Typ) then
 716                   Append_To (Stmts, Cleanup_Protected_Object (N, Ref));
 717
 718                elsif Has_Simple_Protected_Object (Typ) then
 719                   if Is_Record_Type (Typ) then
 720                      Append_List_To (Stmts, Cleanup_Record (N, Ref, Typ));
 721
 722                   elsif Is_Array_Type (Typ) then
 723                      Append_List_To (Stmts, Cleanup_Array (N, Ref, Typ));
 724                   end if;
 725                end if;
 726             end;
 727          end if;
 728
 729          Next_Entity (E);
 730       end loop;
 731
 732       --   Analyze inserted cleanup statements.
 733
 734       if Present (Stmt) then
 735          Stmt := Next (Stmt);
 736
 737          while Present (Stmt) loop
 738             Analyze (Stmt);
 739             Next (Stmt);
 740          end loop;
 741       end if;
 742    end Clean_Simple_Protected_Objects;
 743
 744    ------------------
 745    -- Cleanup_Task --
 746    ------------------
 747
 748    function Cleanup_Task
 749      (N    : Node_Id;
 750       Ref  : Node_Id)
 751       return Node_Id
 752    is
 753       Loc  : constant Source_Ptr := Sloc (N);
 754    begin
 755       return
 756         Make_Procedure_Call_Statement (Loc,
 757           Name => New_Reference_To (RTE (RE_Free_Task), Loc),
 758           Parameter_Associations =>
 759             New_List (Concurrent_Ref (Ref)));
 760    end Cleanup_Task;
 761
 762    ---------------------------------
 763    -- Has_Simple_Protected_Object --
 764    ---------------------------------
 765
 766    function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is
 767       Comp : Entity_Id;
 768
 769    begin
 770       if Is_Simple_Protected_Type (T) then
 771          return True;
 772
 773       elsif Is_Array_Type (T) then
 774          return Has_Simple_Protected_Object (Component_Type (T));
 775
 776       elsif Is_Record_Type (T) then
 777          Comp := First_Component (T);
 778
 779          while Present (Comp) loop
 780             if Has_Simple_Protected_Object (Etype (Comp)) then
 781                return True;
 782             end if;
 783
 784             Next_Component (Comp);
 785          end loop;
 786
 787          return False;
 788
 789       else
 790          return False;
 791       end if;
 792    end Has_Simple_Protected_Object;
 793
 794    ------------------------------
 795    -- Is_Simple_Protected_Type --
 796    ------------------------------
 797
 798    function Is_Simple_Protected_Type (T : Entity_Id) return Boolean is
 799    begin
 800       return Is_Protected_Type (T) and then not Has_Entries (T);
 801    end Is_Simple_Protected_Type;
 802
 803    ------------------------------
 804    -- Check_Visibly_Controlled --
 805    ------------------------------
 806
 807    procedure Check_Visibly_Controlled
 808      (Prim : Final_Primitives;
 809       Typ  : Entity_Id;
 810       E    : in out Entity_Id;
 811       Cref : in out Node_Id)
 812    is
 813       Parent_Type : Entity_Id;
 814       Op          : Entity_Id;
 815
 816    begin
 817       if Is_Derived_Type (Typ)
 818         and then Comes_From_Source (E)
 819         and then not Is_Overriding_Operation (E)
 820       then
 821          --  We know that the explicit operation on the type does not override
 822          --  the inherited operation of the parent, and that the derivation
 823          --  is from a private type that is not visibly controlled.
 824
 825          Parent_Type := Etype (Typ);
 826          Op := Find_Prim_Op (Parent_Type, Name_Of (Prim));
 827
 828          if Present (Op) then
 829             E := Op;
 830
 831             --  Wrap the object to be initialized into the proper
 832             --  unchecked conversion, to be compatible with the operation
 833             --  to be called.
 834
 835             if Nkind (Cref) = N_Unchecked_Type_Conversion then
 836                Cref := Unchecked_Convert_To (Parent_Type, Expression (Cref));
 837             else
 838                Cref := Unchecked_Convert_To (Parent_Type, Cref);
 839             end if;
 840          end if;
 841       end if;
 842    end Check_Visibly_Controlled;
 843
 844    ---------------------
 845    -- Controlled_Type --
 846    ---------------------
 847
 848    function Controlled_Type (T : Entity_Id) return Boolean is
 849
 850       function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean;
 851       --  If type is not frozen yet, check explicitly among its components,
 852       --  because flag is not necessarily set.
 853
 854       ------------------------------------
 855       --  Has_Some_Controlled_Component --
 856       ------------------------------------
 857
 858       function Has_Some_Controlled_Component (Rec : Entity_Id)
 859         return Boolean
 860       is
 861          Comp : Entity_Id;
 862
 863       begin
 864          if Has_Controlled_Component (Rec) then
 865             return True;
 866
 867          elsif not Is_Frozen (Rec) then
 868             if Is_Record_Type (Rec) then
 869                Comp := First_Entity (Rec);
 870
 871                while Present (Comp) loop
 872                   if not Is_Type (Comp)
 873                     and then Controlled_Type (Etype (Comp))
 874                   then
 875                      return True;
 876                   end if;
 877
 878                   Next_Entity (Comp);
 879                end loop;
 880
 881                return False;
 882
 883             elsif Is_Array_Type (Rec) then
 884                return Is_Controlled (Component_Type (Rec));
 885
 886             else
 887                return Has_Controlled_Component (Rec);
 888             end if;
 889          else
 890             return False;
 891          end if;
 892       end Has_Some_Controlled_Component;
 893
 894    --  Start of processing for Controlled_Type
 895
 896    begin
 897       --  Class-wide types must be treated as controlled because they may
 898       --  contain an extension that has controlled components
 899
 900       --  We can skip this if finalization is not available
 901
 902       return (Is_Class_Wide_Type (T)
 903                 and then not In_Finalization_Root (T)
 904                 and then not Restriction_Active (No_Finalization))
 905         or else Is_Controlled (T)
 906         or else Has_Some_Controlled_Component (T)
 907         or else (Is_Concurrent_Type (T)
 908                    and then Present (Corresponding_Record_Type (T))
 909                    and then Controlled_Type (Corresponding_Record_Type (T)));
 910    end Controlled_Type;
 911
 912    --------------------------
 913    -- Controller_Component --
 914    --------------------------
 915
 916    function Controller_Component (Typ : Entity_Id) return Entity_Id is
 917       T         : Entity_Id := Base_Type (Typ);
 918       Comp      : Entity_Id;
 919       Comp_Scop : Entity_Id;
 920       Res       : Entity_Id := Empty;
 921       Res_Scop  : Entity_Id := Empty;
 922
 923    begin
 924       if Is_Class_Wide_Type (T) then
 925          T := Root_Type (T);
 926       end if;
 927
 928       if Is_Private_Type (T) then
 929          T := Underlying_Type (T);
 930       end if;
 931
 932       --  Fetch the outermost controller
 933
 934       Comp := First_Entity (T);
 935       while Present (Comp) loop
 936          if Chars (Comp) = Name_uController then
 937             Comp_Scop := Scope (Original_Record_Component (Comp));
 938
 939             --  If this controller is at the outermost level, no need to
 940             --  look for another one
 941
 942             if Comp_Scop = T then
 943                return Comp;
 944
 945             --  Otherwise record the outermost one and continue looking
 946
 947             elsif Res = Empty or else Is_Ancestor (Res_Scop, Comp_Scop) then
 948                Res      := Comp;
 949                Res_Scop := Comp_Scop;
 950             end if;
 951          end if;
 952
 953          Next_Entity (Comp);
 954       end loop;
 955
 956       --  If we fall through the loop, there is no controller component
 957
 958       return Res;
 959    end Controller_Component;
 960
 961    ------------------
 962    -- Convert_View --
 963    ------------------
 964
 965    function Convert_View
 966      (Proc : Entity_Id;
 967       Arg  : Node_Id;
 968       Ind  : Pos := 1)
 969       return Node_Id
 970    is
 971       Fent : Entity_Id := First_Entity (Proc);
 972       Ftyp : Entity_Id;
 973       Atyp : Entity_Id;
 974
 975    begin
 976       for J in 2 .. Ind loop
 977          Next_Entity (Fent);
 978       end loop;
 979
 980       Ftyp := Etype (Fent);
 981
 982       if Nkind (Arg) = N_Type_Conversion
 983         or else Nkind (Arg) = N_Unchecked_Type_Conversion
 984       then
 985          Atyp := Entity (Subtype_Mark (Arg));
 986       else
 987          Atyp := Etype (Arg);
 988       end if;
 989
 990       if Is_Abstract (Proc) and then Is_Tagged_Type (Ftyp) then
 991          return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg);
 992
 993       elsif Ftyp /= Atyp
 994         and then Present (Atyp)
 995         and then
 996           (Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp))
 997         and then Underlying_Type (Atyp) = Underlying_Type (Ftyp)
 998       then
 999          return Unchecked_Convert_To (Ftyp, Arg);
1000
1001       --  If the argument is already a conversion, as generated by
1002       --  Make_Init_Call, set the target type to the type of the formal
1003       --  directly, to avoid spurious typing problems.
1004
1005       elsif (Nkind (Arg) = N_Unchecked_Type_Conversion
1006               or else Nkind (Arg) = N_Type_Conversion)
1007         and then not Is_Class_Wide_Type (Atyp)
1008       then
1009          Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg)));
1010          Set_Etype (Arg, Ftyp);
1011          return Arg;
1012
1013       else
1014          return Arg;
1015       end if;
1016    end Convert_View;
1017
1018    -------------------------------
1019    -- Establish_Transient_Scope --
1020    -------------------------------
1021
1022    --  This procedure is called each time a transient block has to be inserted
1023    --  that is to say for each call to a function with unconstrained ot tagged
1024    --  result. It creates a new scope on the stack scope in order to enclose
1025    --  all transient variables generated
1026
1027    procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean) is
1028       Loc       : constant Source_Ptr := Sloc (N);
1029       Wrap_Node : Node_Id;
1030
1031       Sec_Stk : constant Boolean :=
1032                   Sec_Stack and not Functions_Return_By_DSP_On_Target;
1033       --  We never need a secondary stack if functions return by DSP
1034
1035    begin
1036       --  Do not create a transient scope if we are already inside one
1037
1038       for S in reverse Scope_Stack.First .. Scope_Stack.Last loop
1039
1040          if Scope_Stack.Table (S).Is_Transient then
1041             if Sec_Stk then
1042                Set_Uses_Sec_Stack (Scope_Stack.Table (S).Entity);
1043             end if;
1044
1045             return;
1046
1047          --  If we have encountered Standard there are no enclosing
1048          --  transient scopes.
1049
1050          elsif Scope_Stack.Table (S).Entity = Standard_Standard then
1051             exit;
1052
1053          end if;
1054       end loop;
1055
1056       Wrap_Node := Find_Node_To_Be_Wrapped (N);
1057
1058       --  Case of no wrap node, false alert, no transient scope needed
1059
1060       if No (Wrap_Node) then
1061          null;
1062
1063       elsif Nkind (Wrap_Node) = N_Iteration_Scheme then
1064
1065          --  Create a declaration followed by an assignment, so that
1066          --  the assignment can have its own transient scope.
1067          --  We generate the equivalent of:
1068
1069          --  type Ptr is access all expr_type;
1070          --  Var : Ptr;
1071          --  begin
1072          --     Var := Expr'reference;
1073          --  end;
1074
1075          --  This closely resembles what is done in Remove_Side_Effect,
1076          --  but it has to be done here, before the analysis of the call
1077          --  is completed.
1078
1079          declare
1080             Ptr_Typ : constant Entity_Id :=
1081                         Make_Defining_Identifier (Loc,
1082                           Chars => New_Internal_Name ('A'));
1083             Ptr     : constant Entity_Id :=
1084                         Make_Defining_Identifier (Loc,
1085                           Chars => New_Internal_Name ('T'));
1086
1087             Expr_Type    : constant Entity_Id := Etype (N);
1088             New_Expr     : constant Node_Id := Relocate_Node (N);
1089             Decl         : Node_Id;
1090             Ptr_Typ_Decl : Node_Id;
1091             Stmt         : Node_Id;
1092
1093          begin
1094             Ptr_Typ_Decl :=
1095               Make_Full_Type_Declaration (Loc,
1096                 Defining_Identifier => Ptr_Typ,
1097                 Type_Definition =>
1098                   Make_Access_To_Object_Definition (Loc,
1099                     All_Present => True,
1100                     Subtype_Indication =>
1101                       New_Reference_To (Expr_Type, Loc)));
1102
1103             Decl :=
1104               Make_Object_Declaration (Loc,
1105                  Defining_Identifier => Ptr,
1106                  Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc));
1107
1108             Set_Etype (Ptr, Ptr_Typ);
1109             Stmt :=
1110                Make_Assignment_Statement (Loc,
1111                   Name => New_Occurrence_Of (Ptr, Loc),
1112                   Expression => Make_Reference (Loc, New_Expr));
1113
1114             Set_Analyzed (New_Expr, False);
1115
1116             Insert_List_Before_And_Analyze
1117               (Parent (Wrap_Node),
1118                  New_List (
1119                    Ptr_Typ_Decl,
1120                    Decl,
1121                    Make_Block_Statement (Loc,
1122                      Handled_Statement_Sequence =>
1123                        Make_Handled_Sequence_Of_Statements (Loc,
1124                          New_List (Stmt)))));
1125
1126             Rewrite (N,
1127               Make_Explicit_Dereference (Loc,
1128                 Prefix => New_Reference_To (Ptr, Loc)));
1129             Analyze_And_Resolve (N, Expr_Type);
1130
1131          end;
1132
1133       --  Transient scope is required
1134
1135       else
1136          New_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'));
1137          Set_Scope_Is_Transient;
1138
1139          if Sec_Stk then
1140             Set_Uses_Sec_Stack (Current_Scope);
1141             Check_Restriction (No_Secondary_Stack, N);
1142          end if;
1143
1144          Set_Etype (Current_Scope, Standard_Void_Type);
1145          Set_Node_To_Be_Wrapped (Wrap_Node);
1146
1147          if Debug_Flag_W then
1148             Write_Str ("    <Transient>");
1149             Write_Eol;
1150          end if;
1151       end if;
1152    end Establish_Transient_Scope;
1153
1154    ----------------------------
1155    -- Expand_Cleanup_Actions --
1156    ----------------------------
1157
1158    procedure Expand_Cleanup_Actions (N : Node_Id) is
1159       Loc                  :  Source_Ptr;
1160       S                    : constant Entity_Id  :=
1161                                Current_Scope;
1162       Flist                : constant Entity_Id  :=
1163                                Finalization_Chain_Entity (S);
1164       Is_Task              : constant Boolean    :=
1165                                (Nkind (Original_Node (N)) = N_Task_Body);
1166       Is_Master            : constant Boolean    :=
1167                                Nkind (N) /= N_Entry_Body
1168                                  and then Is_Task_Master (N);
1169       Is_Protected         : constant Boolean    :=
1170                                Nkind (N) = N_Subprogram_Body
1171                                  and then Is_Protected_Subprogram_Body (N);
1172       Is_Task_Allocation   : constant Boolean    :=
1173                                Nkind (N) = N_Block_Statement
1174                                  and then Is_Task_Allocation_Block (N);
1175       Is_Asynchronous_Call : constant Boolean    :=
1176                                Nkind (N) = N_Block_Statement
1177                                  and then Is_Asynchronous_Call_Block (N);
1178
1179       Clean     : Entity_Id;
1180       Mark      : Entity_Id := Empty;
1181       New_Decls : constant List_Id := New_List;
1182       Blok      : Node_Id;
1183       Wrapped   : Boolean;
1184       Chain     : Entity_Id := Empty;
1185       Decl      : Node_Id;
1186       Old_Poll  : Boolean;
1187
1188    begin
1189
1190       --  Compute a location that is not directly in the user code in
1191       --  order to avoid to generate confusing debug info. A good
1192       --  approximation is the name of the outer user-defined scope
1193
1194       declare
1195          S1 : Entity_Id := S;
1196
1197       begin
1198          while not Comes_From_Source (S1) and then S1 /= Standard_Standard loop
1199             S1 := Scope (S1);
1200          end loop;
1201
1202          Loc := Sloc (S1);
1203       end;
1204
1205       --  There are cleanup actions only if the secondary stack needs
1206       --  releasing or some finalizations are needed or in the context
1207       --  of tasking
1208
1209       if Uses_Sec_Stack  (Current_Scope)
1210         and then not Sec_Stack_Needed_For_Return (Current_Scope)
1211       then
1212          null;
1213       elsif No (Flist)
1214         and then not Is_Master
1215         and then not Is_Task
1216         and then not Is_Protected
1217         and then not Is_Task_Allocation
1218         and then not Is_Asynchronous_Call
1219       then
1220          Clean_Simple_Protected_Objects (N);
1221          return;
1222       end if;
1223
1224       --  If the current scope is the subprogram body that is the rewriting
1225       --  of a task body, and the descriptors have not been delayed (due to
1226       --  some nested instantiations) do not generate redundant cleanup
1227       --  actions: the cleanup procedure already exists for this body.
1228
1229       if Nkind (N) = N_Subprogram_Body
1230         and then Nkind (Original_Node (N)) = N_Task_Body
1231         and then not Delay_Subprogram_Descriptors (Corresponding_Spec (N))
1232       then
1233          return;
1234       end if;
1235
1236       --  Set polling off, since we don't need to poll during cleanup
1237       --  actions, and indeed for the cleanup routine, which is executed
1238       --  with aborts deferred, we don't want polling.
1239
1240       Old_Poll := Polling_Required;
1241       Polling_Required := False;
1242
1243       --  Make sure we have a declaration list, since we will add to it
1244
1245       if No (Declarations (N)) then
1246          Set_Declarations (N, New_List);
1247       end if;
1248
1249       --  The task activation call has already been built for task
1250       --  allocation blocks.
1251
1252       if not Is_Task_Allocation then
1253          Build_Task_Activation_Call (N);
1254       end if;
1255
1256       if Is_Master then
1257          Establish_Task_Master (N);
1258       end if;
1259
1260       --  If secondary stack is in use, expand:
1261       --    _Mxx : constant Mark_Id := SS_Mark;
1262
1263       --  Suppress calls to SS_Mark and SS_Release if Java_VM,
1264       --  since we never use the secondary stack on the JVM.
1265
1266       if Uses_Sec_Stack (Current_Scope)
1267         and then not Sec_Stack_Needed_For_Return (Current_Scope)
1268         and then not Java_VM
1269       then
1270          Mark := Make_Defining_Identifier (Loc, New_Internal_Name ('M'));
1271          Append_To (New_Decls,
1272            Make_Object_Declaration (Loc,
1273              Defining_Identifier => Mark,
1274              Object_Definition   => New_Reference_To (RTE (RE_Mark_Id), Loc),
1275              Expression =>
1276                Make_Function_Call (Loc,
1277                  Name => New_Reference_To (RTE (RE_SS_Mark), Loc))));
1278
1279          Set_Uses_Sec_Stack (Current_Scope, False);
1280       end if;
1281
1282       --  If finalization list is present then expand:
1283       --   Local_Final_List : System.FI.Finalizable_Ptr;
1284
1285       if Present (Flist) then
1286          Append_To (New_Decls,
1287            Make_Object_Declaration (Loc,
1288              Defining_Identifier => Flist,
1289              Object_Definition   =>
1290                New_Reference_To (RTE (RE_Finalizable_Ptr), Loc)));
1291       end if;
1292
1293       --  Clean-up procedure definition
1294
1295       Clean := Make_Defining_Identifier (Loc, Name_uClean);
1296       Set_Suppress_Elaboration_Warnings (Clean);
1297       Append_To (New_Decls,
1298         Make_Clean (N, Clean, Mark, Flist,
1299           Is_Task,
1300           Is_Master,
1301           Is_Protected,
1302           Is_Task_Allocation,
1303           Is_Asynchronous_Call));
1304
1305       --  If exception handlers are present, wrap the Sequence of
1306       --  statements in a block because it is not possible to get
1307       --  exception handlers and an AT END call in the same scope.
1308
1309       if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then
1310          Blok :=
1311            Make_Block_Statement (Loc,
1312              Handled_Statement_Sequence => Handled_Statement_Sequence (N));
1313          Set_Handled_Statement_Sequence (N,
1314            Make_Handled_Sequence_Of_Statements (Loc, New_List (Blok)));
1315          Wrapped := True;
1316
1317       --  Otherwise we do not wrap
1318
1319       else
1320          Wrapped := False;
1321          Blok    := Empty;
1322       end if;
1323
1324       --  Don't move the _chain Activation_Chain declaration in task
1325       --  allocation blocks. Task allocation blocks use this object
1326       --  in their cleanup handlers, and gigi complains if it is declared
1327       --  in the sequence of statements of the scope that declares the
1328       --  handler.
1329
1330       if Is_Task_Allocation then
1331          Chain := Activation_Chain_Entity (N);
1332          Decl := First (Declarations (N));
1333
1334          while Nkind (Decl) /= N_Object_Declaration
1335            or else Defining_Identifier (Decl) /= Chain
1336          loop
1337             Next (Decl);
1338             pragma Assert (Present (Decl));
1339          end loop;
1340
1341          Remove (Decl);
1342          Prepend_To (New_Decls, Decl);
1343       end if;
1344
1345       --  Now we move the declarations into the Sequence of statements
1346       --  in order to get them protected by the AT END call. It may seem
1347       --  weird to put declarations in the sequence of statement but in
1348       --  fact nothing forbids that at the tree level. We also set the
1349       --  First_Real_Statement field so that we remember where the real
1350       --  statements (i.e. original statements) begin. Note that if we
1351       --  wrapped the statements, the first real statement is inside the
1352       --  inner block. If the First_Real_Statement is already set (as is
1353       --  the case for subprogram bodies that are expansions of task bodies)
1354       --  then do not reset it, because its declarative part would migrate
1355       --  to the statement part.
1356
1357       if not Wrapped then
1358          if No (First_Real_Statement (Handled_Statement_Sequence (N))) then
1359             Set_First_Real_Statement (Handled_Statement_Sequence (N),
1360               First (Statements (Handled_Statement_Sequence (N))));
1361          end if;
1362
1363       else
1364          Set_First_Real_Statement (Handled_Statement_Sequence (N), Blok);
1365       end if;
1366
1367       Append_List_To (Declarations (N),
1368         Statements (Handled_Statement_Sequence (N)));
1369       Set_Statements (Handled_Statement_Sequence (N), Declarations (N));
1370
1371       --  We need to reset the Sloc of the handled statement sequence to
1372       --  properly reflect the new initial "statement" in the sequence.
1373
1374       Set_Sloc
1375         (Handled_Statement_Sequence (N), Sloc (First (Declarations (N))));
1376
1377       --  The declarations of the _Clean procedure and finalization chain
1378       --  replace the old declarations that have been moved inward
1379
1380       Set_Declarations (N, New_Decls);
1381       Analyze_Declarations (New_Decls);
1382
1383       --  The At_End call is attached to the sequence of statements.
1384
1385       declare
1386          HSS : Node_Id;
1387
1388       begin
1389          --  If the construct is a protected subprogram, then the call to
1390          --  the corresponding unprotected program appears in a block which
1391          --  is the last statement in the body, and it is this block that
1392          --  must be covered by the At_End handler.
1393
1394          if Is_Protected then
1395             HSS := Handled_Statement_Sequence
1396               (Last (Statements (Handled_Statement_Sequence (N))));
1397          else
1398             HSS := Handled_Statement_Sequence (N);
1399          end if;
1400
1401          Set_At_End_Proc (HSS, New_Occurrence_Of (Clean, Loc));
1402          Expand_At_End_Handler (HSS, Empty);
1403       end;
1404
1405       --  Restore saved polling mode
1406
1407       Polling_Required := Old_Poll;
1408    end Expand_Cleanup_Actions;
1409
1410    -------------------------------
1411    -- Expand_Ctrl_Function_Call --
1412    -------------------------------
1413
1414    procedure Expand_Ctrl_Function_Call (N : Node_Id) is
1415       Loc     : constant Source_Ptr := Sloc (N);
1416       Rtype   : constant Entity_Id  := Etype (N);
1417       Utype   : constant Entity_Id  := Underlying_Type (Rtype);
1418       Ref     : Node_Id;
1419       Action  : Node_Id;
1420       Action2 : Node_Id := Empty;
1421
1422       Attach_Level : Uint    := Uint_1;
1423       Len_Ref      : Node_Id := Empty;
1424
1425       function Last_Array_Component
1426         (Ref :  Node_Id;
1427          Typ :  Entity_Id)
1428          return Node_Id;
1429       --  Creates a reference to the last component of the array object
1430       --  designated by Ref whose type is Typ.
1431
1432       --------------------------
1433       -- Last_Array_Component --
1434       --------------------------
1435
1436       function Last_Array_Component
1437         (Ref :  Node_Id;
1438          Typ :  Entity_Id)
1439          return Node_Id
1440       is
1441          Index_List : constant List_Id := New_List;
1442
1443       begin
1444          for N in 1 .. Number_Dimensions (Typ) loop
1445             Append_To (Index_List,
1446               Make_Attribute_Reference (Loc,
1447                 Prefix         => Duplicate_Subexpr_No_Checks (Ref),
1448                 Attribute_Name => Name_Last,
1449                 Expressions    => New_List (
1450                   Make_Integer_Literal (Loc, N))));
1451          end loop;
1452
1453          return
1454            Make_Indexed_Component (Loc,
1455              Prefix      => Duplicate_Subexpr (Ref),
1456              Expressions => Index_List);
1457       end Last_Array_Component;
1458
1459    --  Start of processing for Expand_Ctrl_Function_Call
1460
1461    begin
1462       --  Optimization, if the returned value (which is on the sec-stack)
1463       --  is returned again, no need to copy/readjust/finalize, we can just
1464       --  pass the value thru (see Expand_N_Return_Statement), and thus no
1465       --  attachment is needed
1466
1467       if Nkind (Parent (N)) = N_Return_Statement then
1468          return;
1469       end if;
1470
1471       --  Resolution is now finished, make sure we don't start analysis again
1472       --  because of the duplication
1473
1474       Set_Analyzed (N);
1475       Ref := Duplicate_Subexpr_No_Checks (N);
1476
1477       --  Now we can generate the Attach Call, note that this value is
1478       --  always in the (secondary) stack and thus is attached to a singly
1479       --  linked final list:
1480
1481       --    Resx := F (X)'reference;
1482       --    Attach_To_Final_List (_Lx, Resx.all, 1);
1483
1484       --  or when there are controlled components
1485
1486       --    Attach_To_Final_List (_Lx, Resx._controller, 1);
1487
1488       --  or when it is both is_controlled and has_controlled_components
1489
1490       --    Attach_To_Final_List (_Lx, Resx._controller, 1);
1491       --    Attach_To_Final_List (_Lx, Resx, 1);
1492
1493       --  or if it is an array with is_controlled (and has_controlled)
1494
1495       --    Attach_To_Final_List (_Lx, Resx (Resx'last), 3);
1496       --    An attach level of 3 means that a whole array is to be
1497       --    attached to the finalization list (including the controlled
1498       --    components)
1499
1500       --  or if it is an array with has_controlled components but not
1501       --  is_controlled
1502
1503       --    Attach_To_Final_List (_Lx, Resx (Resx'last)._controller, 3);
1504
1505       if Has_Controlled_Component (Rtype) then
1506          declare
1507             T1 : Entity_Id := Rtype;
1508             T2 : Entity_Id := Utype;
1509
1510          begin
1511             if Is_Array_Type (T2) then
1512                Len_Ref :=
1513                  Make_Attribute_Reference (Loc,
1514                  Prefix =>
1515                    Duplicate_Subexpr_Move_Checks
1516                      (Unchecked_Convert_To (T2, Ref)),
1517                  Attribute_Name => Name_Length);
1518             end if;
1519
1520             while Is_Array_Type (T2) loop
1521                if T1 /= T2 then
1522                   Ref := Unchecked_Convert_To (T2, Ref);
1523                end if;
1524
1525                Ref := Last_Array_Component (Ref, T2);
1526                Attach_Level := Uint_3;
1527                T1 := Component_Type (T2);
1528                T2 := Underlying_Type (T1);
1529             end loop;
1530
1531             --  If the type has controlled components, go to the controller
1532             --  except in the case of arrays of controlled objects since in
1533             --  this case objects and their components are already chained
1534             --  and the head of the chain is the last array element.
1535
1536             if Is_Array_Type (Rtype) and then Is_Controlled (T2) then
1537                null;
1538
1539             elsif Has_Controlled_Component (T2) then
1540                if T1 /= T2 then
1541                   Ref := Unchecked_Convert_To (T2, Ref);
1542                end if;
1543
1544                Ref :=
1545                  Make_Selected_Component (Loc,
1546                    Prefix        => Ref,
1547                    Selector_Name => Make_Identifier (Loc, Name_uController));
1548             end if;
1549          end;
1550
1551          --  Here we know that 'Ref' has a controller so we may as well
1552          --  attach it directly
1553
1554          Action :=
1555            Make_Attach_Call (
1556              Obj_Ref      => Ref,
1557              Flist_Ref    => Find_Final_List (Current_Scope),
1558              With_Attach  => Make_Integer_Literal (Loc, Attach_Level));
1559
1560          --  If it is also Is_Controlled we need to attach the global object
1561
1562          if Is_Controlled (Rtype) then
1563             Action2 :=
1564               Make_Attach_Call (
1565                 Obj_Ref      => Duplicate_Subexpr_No_Checks (N),
1566                 Flist_Ref    => Find_Final_List (Current_Scope),
1567                 With_Attach  => Make_Integer_Literal (Loc, Attach_Level));
1568          end if;
1569
1570       else
1571          --  Here, we have a controlled type that does not seem to have
1572          --  controlled components but it could be a class wide type whose
1573          --  further derivations have controlled components. So we don't know
1574          --  if the object itself needs to be attached or if it
1575          --  has a record controller. We need to call a runtime function
1576          --  (Deep_Tag_Attach) which knows what to do thanks to the
1577          --  RC_Offset in the dispatch table.
1578
1579          Action :=
1580            Make_Procedure_Call_Statement (Loc,
1581              Name => New_Reference_To (RTE (RE_Deep_Tag_Attach), Loc),
1582              Parameter_Associations => New_List (
1583                Find_Final_List (Current_Scope),
1584
1585                Make_Attribute_Reference (Loc,
1586                    Prefix => Ref,
1587                    Attribute_Name => Name_Address),
1588
1589                Make_Integer_Literal (Loc, Attach_Level)));
1590       end if;
1591
1592       if Present (Len_Ref) then
1593          Action :=
1594            Make_Implicit_If_Statement (N,
1595              Condition => Make_Op_Gt (Loc,
1596                Left_Opnd  => Len_Ref,
1597                Right_Opnd => Make_Integer_Literal (Loc, 0)),
1598              Then_Statements => New_List (Action));
1599       end if;
1600
1601       Insert_Action (N, Action);
1602       if Present (Action2) then
1603          Insert_Action (N, Action2);
1604       end if;
1605    end Expand_Ctrl_Function_Call;
1606
1607    ---------------------------
1608    -- Expand_N_Package_Body --
1609    ---------------------------
1610
1611    --  Add call to Activate_Tasks if body is an activator (actual
1612    --  processing is in chapter 9).
1613
1614    --  Generate subprogram descriptor for elaboration routine
1615
1616    --  ENcode entity names in package body
1617
1618    procedure Expand_N_Package_Body (N : Node_Id) is
1619       Ent : constant Entity_Id := Corresponding_Spec (N);
1620
1621    begin
1622       --  This is done only for non-generic packages
1623
1624       if Ekind (Ent) = E_Package then
1625          New_Scope (Corresponding_Spec (N));
1626          Build_Task_Activation_Call (N);
1627          Pop_Scope;
1628       end if;
1629
1630       Set_Elaboration_Flag (N, Corresponding_Spec (N));
1631
1632       --  Generate a subprogram descriptor for the elaboration routine of
1633       --  a package body if the package body has no pending instantiations
1634       --  and it has generated at least one exception handler
1635
1636       if Present (Handler_Records (Body_Entity (Ent)))
1637         and then Is_Compilation_Unit (Ent)
1638         and then not Delay_Subprogram_Descriptors (Body_Entity (Ent))
1639       then
1640          Generate_Subprogram_Descriptor_For_Package
1641            (N, Body_Entity (Ent));
1642       end if;
1643
1644       Set_In_Package_Body (Ent, False);
1645
1646       --  Set to encode entity names in package body before gigi is called
1647
1648       Qualify_Entity_Names (N);
1649    end Expand_N_Package_Body;
1650
1651    ----------------------------------
1652    -- Expand_N_Package_Declaration --
1653    ----------------------------------
1654
1655    --  Add call to Activate_Tasks if there are tasks declared and the
1656    --  package has no body. Note that in Ada83,  this may result in
1657    --  premature activation of some tasks, given that we cannot tell
1658    --  whether a body will eventually appear.
1659
1660    procedure Expand_N_Package_Declaration (N : Node_Id) is
1661    begin
1662       if Nkind (Parent (N)) = N_Compilation_Unit
1663         and then not Body_Required (Parent (N))
1664         and then not Unit_Requires_Body (Defining_Entity (N))
1665         and then Present (Activation_Chain_Entity (N))
1666       then
1667          New_Scope (Defining_Entity (N));
1668          Build_Task_Activation_Call (N);
1669          Pop_Scope;
1670       end if;
1671
1672       --  Note: it is not necessary to worry about generating a subprogram
1673       --  descriptor, since the only way to get exception handlers into a
1674       --  package spec is to include instantiations, and that would cause
1675       --  generation of subprogram descriptors to be delayed in any case.
1676
1677       --  Set to encode entity names in package spec before gigi is called
1678
1679       Qualify_Entity_Names (N);
1680    end Expand_N_Package_Declaration;
1681
1682    ---------------------
1683    -- Find_Final_List --
1684    ---------------------
1685
1686    function Find_Final_List
1687      (E    : Entity_Id;
1688       Ref  : Node_Id := Empty)
1689       return Node_Id
1690    is
1691       Loc : constant Source_Ptr := Sloc (Ref);
1692       S   : Entity_Id;
1693       Id  : Entity_Id;
1694       R   : Node_Id;
1695
1696    begin
1697       --  Case of an internal component. The Final list is the record
1698       --  controller of the enclosing record
1699
1700       if Present (Ref) then
1701          R := Ref;
1702          loop
1703             case Nkind (R) is
1704                when N_Unchecked_Type_Conversion | N_Type_Conversion =>
1705                   R := Expression (R);
1706
1707                when N_Indexed_Component | N_Explicit_Dereference =>
1708                   R := Prefix (R);
1709
1710                when  N_Selected_Component =>
1711                   R := Prefix (R);
1712                   exit;
1713
1714                when  N_Identifier =>
1715                   exit;
1716
1717                when others =>
1718                   raise Program_Error;
1719             end case;
1720          end loop;
1721
1722          return
1723            Make_Selected_Component (Loc,
1724              Prefix =>
1725                Make_Selected_Component (Loc,
1726                  Prefix        => R,
1727                  Selector_Name => Make_Identifier (Loc, Name_uController)),
1728              Selector_Name => Make_Identifier (Loc, Name_F));
1729
1730       --  Case of a dynamically allocated object. The final list is the
1731       --  corresponding list controller (The next entity in the scope of
1732       --  the access type with the right type). If the type comes from a
1733       --  With_Type clause, no controller was created, and we use the
1734       --  global chain instead.
1735
1736       elsif Is_Access_Type (E) then
1737          if not From_With_Type (E) then
1738             return
1739               Make_Selected_Component (Loc,
1740                 Prefix        =>
1741                   New_Reference_To
1742                     (Associated_Final_Chain (Base_Type (E)), Loc),
1743                 Selector_Name => Make_Identifier (Loc, Name_F));
1744          else
1745             return New_Reference_To (RTE (RE_Global_Final_List), Sloc (E));
1746          end if;
1747
1748       else
1749          if Is_Dynamic_Scope (E) then
1750             S := E;
1751          else
1752             S := Enclosing_Dynamic_Scope (E);
1753          end if;
1754
1755          --  When the finalization chain entity is 'Error', it means that
1756          --  there should not be any chain at that level and that the
1757          --  enclosing one should be used
1758
1759          --  This is a nasty kludge, see ??? note in exp_ch11
1760
1761          while Finalization_Chain_Entity (S) = Error loop
1762             S := Enclosing_Dynamic_Scope (S);
1763          end loop;
1764
1765          if S = Standard_Standard then
1766             return New_Reference_To (RTE (RE_Global_Final_List), Sloc (E));
1767          else
1768             if No (Finalization_Chain_Entity (S)) then
1769
1770                Id := Make_Defining_Identifier (Sloc (S),
1771                  New_Internal_Name ('F'));
1772                Set_Finalization_Chain_Entity (S, Id);
1773
1774                --  Set momentarily some semantics attributes to allow normal
1775                --  analysis of expansions containing references to this chain.
1776                --  Will be fully decorated during the expansion of the scope
1777                --  itself
1778
1779                Set_Ekind (Id, E_Variable);
1780                Set_Etype (Id, RTE (RE_Finalizable_Ptr));
1781             end if;
1782
1783             return New_Reference_To (Finalization_Chain_Entity (S), Sloc (E));
1784          end if;
1785       end if;
1786    end Find_Final_List;
1787
1788    -----------------------------
1789    -- Find_Node_To_Be_Wrapped --
1790    -----------------------------
1791
1792    function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id is
1793       P          : Node_Id;
1794       The_Parent : Node_Id;
1795
1796    begin
1797       The_Parent := N;
1798       loop
1799          P := The_Parent;
1800          pragma Assert (P /= Empty);
1801          The_Parent := Parent (P);
1802
1803          case Nkind (The_Parent) is
1804
1805             --  Simple statement can be wrapped
1806
1807             when N_Pragma               =>
1808                return The_Parent;
1809
1810             --  Usually assignments are good candidate for wrapping
1811             --  except when they have been generated as part of a
1812             --  controlled aggregate where the wrapping should take
1813             --  place more globally.
1814
1815             when N_Assignment_Statement =>
1816                if No_Ctrl_Actions (The_Parent) then
1817                   null;
1818                else
1819                   return The_Parent;
1820                end if;
1821
1822             --  An entry call statement is a special case if it occurs in
1823             --  the context of a Timed_Entry_Call. In this case we wrap
1824             --  the entire timed entry call.
1825
1826             when N_Entry_Call_Statement     |
1827                  N_Procedure_Call_Statement =>
1828                if Nkind (Parent (The_Parent)) = N_Entry_Call_Alternative
1829                  and then
1830                    Nkind (Parent (Parent (The_Parent))) = N_Timed_Entry_Call
1831                then
1832                   return Parent (Parent (The_Parent));
1833                else
1834                   return The_Parent;
1835                end if;
1836
1837             --  Object declarations are also a boundary for the transient scope
1838             --  even if they are not really wrapped
1839             --  (see Wrap_Transient_Declaration)
1840
1841             when N_Object_Declaration          |
1842                  N_Object_Renaming_Declaration |
1843                  N_Subtype_Declaration         =>
1844                return The_Parent;
1845
1846             --  The expression itself is to be wrapped if its parent is a
1847             --  compound statement or any other statement where the expression
1848             --  is known to be scalar
1849
1850             when N_Accept_Alternative               |
1851                  N_Attribute_Definition_Clause      |
1852                  N_Case_Statement                   |
1853                  N_Code_Statement                   |
1854                  N_Delay_Alternative                |
1855                  N_Delay_Until_Statement            |
1856                  N_Delay_Relative_Statement         |
1857                  N_Discriminant_Association         |
1858                  N_Elsif_Part                       |
1859                  N_Entry_Body_Formal_Part           |
1860                  N_Exit_Statement                   |
1861                  N_If_Statement                     |
1862                  N_Iteration_Scheme                 |
1863                  N_Terminate_Alternative            =>
1864                return P;
1865
1866             when N_Attribute_Reference              =>
1867
1868                if Is_Procedure_Attribute_Name
1869                     (Attribute_Name (The_Parent))
1870                then
1871                   return The_Parent;
1872                end if;
1873
1874             --  If the expression is within the iteration scheme of a loop,
1875             --  we must create a declaration for it, followed by an assignment
1876             --  in order to have a usable statement to wrap.
1877
1878             when N_Loop_Parameter_Specification =>
1879                return Parent (The_Parent);
1880
1881             --  The following nodes contains "dummy calls" which don't
1882             --  need to be wrapped.
1883
1884             when N_Parameter_Specification     |
1885                  N_Discriminant_Specification  |
1886                  N_Component_Declaration       =>
1887                return Empty;
1888
1889             --  The return statement is not to be wrapped when the function
1890             --  itself needs wrapping at the outer-level
1891
1892             when N_Return_Statement            =>
1893                if Requires_Transient_Scope (Return_Type (The_Parent)) then
1894                   return Empty;
1895                else
1896                   return The_Parent;
1897                end if;
1898
1899             --  If we leave a scope without having been able to find a node to
1900             --  wrap, something is going wrong but this can happen in error
1901             --  situation that are not detected yet (such as a dynamic string
1902             --  in a pragma export)
1903
1904             when N_Subprogram_Body     |
1905                  N_Package_Declaration |
1906                  N_Package_Body        |
1907                  N_Block_Statement     =>
1908                return Empty;
1909
1910             --  otherwise continue the search
1911
1912             when others =>
1913                null;
1914          end case;
1915       end loop;
1916    end Find_Node_To_Be_Wrapped;
1917
1918    ----------------------
1919    -- Global_Flist_Ref --
1920    ----------------------
1921
1922    function Global_Flist_Ref  (Flist_Ref : Node_Id) return Boolean is
1923       Flist : Entity_Id;
1924
1925    begin
1926       --  Look for the Global_Final_List
1927
1928       if Is_Entity_Name (Flist_Ref) then
1929          Flist := Entity (Flist_Ref);
1930
1931       --  Look for the final list associated with an access to controlled
1932
1933       elsif  Nkind (Flist_Ref) = N_Selected_Component
1934         and then Is_Entity_Name (Prefix (Flist_Ref))
1935       then
1936          Flist :=  Entity (Prefix (Flist_Ref));
1937       else
1938          return False;
1939       end if;
1940
1941       return Present (Flist)
1942         and then Present (Scope (Flist))
1943         and then Enclosing_Dynamic_Scope (Flist) = Standard_Standard;
1944    end Global_Flist_Ref;
1945
1946    ----------------------------------
1947    -- Has_New_Controlled_Component --
1948    ----------------------------------
1949
1950    function Has_New_Controlled_Component (E : Entity_Id) return Boolean is
1951       Comp : Entity_Id;
1952
1953    begin
1954       if not Is_Tagged_Type (E) then
1955          return Has_Controlled_Component (E);
1956       elsif not Is_Derived_Type (E) then
1957          return Has_Controlled_Component (E);
1958       end if;
1959
1960       Comp := First_Component (E);
1961       while Present (Comp) loop
1962
1963          if Chars (Comp) = Name_uParent then
1964             null;
1965
1966          elsif Scope (Original_Record_Component (Comp)) = E
1967            and then Controlled_Type (Etype (Comp))
1968          then
1969             return True;
1970          end if;
1971
1972          Next_Component (Comp);
1973       end loop;
1974
1975       return False;
1976    end Has_New_Controlled_Component;
1977
1978    --------------------------
1979    -- In_Finalization_Root --
1980    --------------------------
1981
1982    --  It would seem simpler to test Scope (RTE (RE_Root_Controlled)) but
1983    --  the purpose of this function is to avoid a circular call to Rtsfind
1984    --  which would been caused by such a test.
1985
1986    function In_Finalization_Root (E : Entity_Id) return Boolean is
1987       S : constant Entity_Id := Scope (E);
1988
1989    begin
1990       return Chars (Scope (S))     = Name_System
1991         and then Chars (S)         = Name_Finalization_Root
1992         and then Scope (Scope (S)) = Standard_Standard;
1993    end  In_Finalization_Root;
1994
1995    ------------------------------------
1996    -- Insert_Actions_In_Scope_Around --
1997    ------------------------------------
1998
1999    procedure Insert_Actions_In_Scope_Around (N : Node_Id) is
2000       SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
2001
2002    begin
2003       if Present (SE.Actions_To_Be_Wrapped_Before) then
2004          Insert_List_Before (N, SE.Actions_To_Be_Wrapped_Before);
2005          SE.Actions_To_Be_Wrapped_Before := No_List;
2006       end if;
2007
2008       if Present (SE.Actions_To_Be_Wrapped_After) then
2009          Insert_List_After (N, SE.Actions_To_Be_Wrapped_After);
2010          SE.Actions_To_Be_Wrapped_After := No_List;
2011       end if;
2012    end Insert_Actions_In_Scope_Around;
2013
2014    -----------------------
2015    -- Make_Adjust_Call --
2016    -----------------------
2017
2018    function Make_Adjust_Call
2019      (Ref          : Node_Id;
2020       Typ          : Entity_Id;
2021       Flist_Ref    : Node_Id;
2022       With_Attach  : Node_Id)
2023       return         List_Id
2024    is
2025       Loc    : constant Source_Ptr := Sloc (Ref);
2026       Res    : constant List_Id    := New_List;
2027       Utyp   : Entity_Id;
2028       Proc   : Entity_Id;
2029       Cref   : Node_Id := Ref;
2030       Cref2  : Node_Id;
2031       Attach : Node_Id := With_Attach;
2032
2033    begin
2034       if Is_Class_Wide_Type (Typ) then
2035          Utyp := Underlying_Type (Base_Type (Root_Type (Typ)));
2036       else
2037          Utyp := Underlying_Type (Base_Type (Typ));
2038       end if;
2039
2040       Set_Assignment_OK (Cref);
2041
2042       --  Deal with non-tagged derivation of private views
2043
2044       if Is_Untagged_Derivation (Typ) then
2045          Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
2046          Cref := Unchecked_Convert_To (Utyp, Cref);
2047          Set_Assignment_OK (Cref);
2048          --  To prevent problems with UC see 1.156 RH ???
2049       end if;
2050
2051       --  If the underlying_type is a subtype, we are dealing with
2052       --  the completion of a private type. We need to access
2053       --  the base type and generate a conversion to it.
2054
2055       if Utyp /= Base_Type (Utyp) then
2056          pragma Assert (Is_Private_Type (Typ));
2057          Utyp := Base_Type (Utyp);
2058          Cref := Unchecked_Convert_To (Utyp, Cref);
2059       end if;
2060
2061       --  If the object is unanalyzed, set its expected type for use
2062       --  in Convert_View in case an additional conversion is needed.
2063
2064       if No (Etype (Cref))
2065         and then Nkind (Cref) /= N_Unchecked_Type_Conversion
2066       then
2067          Set_Etype (Cref, Typ);
2068       end if;
2069
2070       --  We do not need to attach to one of the Global Final Lists
2071       --  the objects whose type is Finalize_Storage_Only
2072
2073       if Finalize_Storage_Only (Typ)
2074         and then (Global_Flist_Ref (Flist_Ref)
2075           or else Entity (Constant_Value (RTE (RE_Garbage_Collected)))
2076                   = Standard_True)
2077       then
2078          Attach := Make_Integer_Literal (Loc, 0);
2079       end if;
2080
2081       --  Generate:
2082       --    Deep_Adjust (Flist_Ref, Ref, With_Attach);
2083
2084       if Has_Controlled_Component (Utyp)
2085         or else Is_Class_Wide_Type (Typ)
2086       then
2087          if Is_Tagged_Type (Utyp) then
2088             Proc := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
2089
2090          else
2091             Proc := TSS (Utyp, TSS_Deep_Adjust);
2092          end if;
2093
2094          Cref := Convert_View (Proc, Cref, 2);
2095
2096          Append_To (Res,
2097            Make_Procedure_Call_Statement (Loc,
2098              Name => New_Reference_To (Proc, Loc),
2099              Parameter_Associations =>
2100                New_List (Flist_Ref, Cref, Attach)));
2101
2102       --  Generate:
2103       --    if With_Attach then
2104       --       Attach_To_Final_List (Ref, Flist_Ref);
2105       --    end if;
2106       --    Adjust (Ref);
2107
2108       else -- Is_Controlled (Utyp)
2109
2110          Proc  := Find_Prim_Op (Utyp, Name_Of (Adjust_Case));
2111          Cref  := Convert_View (Proc, Cref);
2112          Cref2 := New_Copy_Tree (Cref);
2113
2114          Append_To (Res,
2115            Make_Procedure_Call_Statement (Loc,
2116            Name => New_Reference_To (Proc, Loc),
2117            Parameter_Associations => New_List (Cref2)));
2118
2119          Append_To (Res, Make_Attach_Call (Cref, Flist_Ref, Attach));
2120       end if;
2121
2122       return Res;
2123    end Make_Adjust_Call;
2124
2125    ----------------------
2126    -- Make_Attach_Call --
2127    ----------------------
2128
2129    --  Generate:
2130    --    System.FI.Attach_To_Final_List (Flist, Ref, Nb_Link)
2131
2132    function Make_Attach_Call
2133      (Obj_Ref      : Node_Id;
2134       Flist_Ref    : Node_Id;
2135       With_Attach  : Node_Id)
2136       return Node_Id
2137    is
2138       Loc : constant Source_Ptr := Sloc (Obj_Ref);
2139
2140    begin
2141       --  Optimization: If the number of links is statically '0', don't
2142       --  call the attach_proc.
2143
2144       if Nkind (With_Attach) = N_Integer_Literal
2145         and then Intval (With_Attach) = Uint_0
2146       then
2147          return Make_Null_Statement (Loc);
2148       end if;
2149
2150       return
2151         Make_Procedure_Call_Statement (Loc,
2152           Name => New_Reference_To (RTE (RE_Attach_To_Final_List), Loc),
2153           Parameter_Associations => New_List (
2154             Flist_Ref,
2155             OK_Convert_To (RTE (RE_Finalizable), Obj_Ref),
2156             With_Attach));
2157    end Make_Attach_Call;
2158
2159    ----------------
2160    -- Make_Clean --
2161    ----------------
2162
2163    function Make_Clean
2164      (N                          : Node_Id;
2165       Clean                      : Entity_Id;
2166       Mark                       : Entity_Id;
2167       Flist                      : Entity_Id;
2168       Is_Task                    : Boolean;
2169       Is_Master                  : Boolean;
2170       Is_Protected_Subprogram    : Boolean;
2171       Is_Task_Allocation_Block   : Boolean;
2172       Is_Asynchronous_Call_Block : Boolean)
2173       return      Node_Id
2174    is
2175       Loc  : constant Source_Ptr := Sloc (Clean);
2176       Stmt : constant List_Id    := New_List;
2177
2178       Sbody        : Node_Id;
2179       Spec         : Node_Id;
2180       Name         : Node_Id;
2181       Param        : Node_Id;
2182       Param_Type   : Entity_Id;
2183       Pid          : Entity_Id := Empty;
2184       Cancel_Param : Entity_Id;
2185
2186    begin
2187       if Is_Task then
2188          if Restricted_Profile then
2189             Append_To
2190               (Stmt, Build_Runtime_Call (Loc, RE_Complete_Restricted_Task));
2191          else
2192             Append_To (Stmt, Build_Runtime_Call (Loc, RE_Complete_Task));
2193          end if;
2194
2195       elsif Is_Master then
2196          if Restriction_Active (No_Task_Hierarchy) = False then
2197             Append_To (Stmt, Build_Runtime_Call (Loc, RE_Complete_Master));
2198          end if;
2199
2200       elsif Is_Protected_Subprogram then
2201
2202          --  Add statements to the cleanup handler of the (ordinary)
2203          --  subprogram expanded to implement a protected subprogram,
2204          --  unlocking the protected object parameter and undeferring abortion.
2205          --  If this is a protected procedure, and the object contains
2206          --  entries, this also calls the entry service routine.
2207
2208          --  NOTE: This cleanup handler references _object, a parameter
2209          --        to the procedure.
2210
2211          --  Find the _object parameter representing the protected object.
2212
2213          Spec := Parent (Corresponding_Spec (N));
2214
2215          Param := First (Parameter_Specifications (Spec));
2216          loop
2217             Param_Type := Etype (Parameter_Type (Param));
2218
2219             if Ekind (Param_Type) = E_Record_Type then
2220                Pid := Corresponding_Concurrent_Type (Param_Type);
2221             end if;
2222
2223             exit when not Present (Param) or else Present (Pid);
2224             Next (Param);
2225          end loop;
2226
2227          pragma Assert (Present (Param));
2228
2229          --  If the associated protected object declares entries,
2230          --  a protected procedure has to service entry queues.
2231          --  In this case, add
2232
2233          --  Service_Entries (_object._object'Access);
2234
2235          --  _object is the record used to implement the protected object.
2236          --  It is a parameter to the protected subprogram.
2237
2238          if Nkind (Specification (N)) = N_Procedure_Specification
2239            and then Has_Entries (Pid)
2240          then
2241             if Abort_Allowed
2242               or else Restriction_Active (No_Entry_Queue) = False
2243               or else Number_Entries (Pid) > 1
2244             then
2245                Name := New_Reference_To (RTE (RE_Service_Entries), Loc);
2246             else
2247                Name := New_Reference_To (RTE (RE_Service_Entry), Loc);
2248             end if;
2249
2250             Append_To (Stmt,
2251               Make_Procedure_Call_Statement (Loc,
2252                 Name => Name,
2253                 Parameter_Associations => New_List (
2254                   Make_Attribute_Reference (Loc,
2255                     Prefix =>
2256                       Make_Selected_Component (Loc,
2257                         Prefix => New_Reference_To (
2258                           Defining_Identifier (Param), Loc),
2259                         Selector_Name =>
2260                           Make_Identifier (Loc, Name_uObject)),
2261                     Attribute_Name => Name_Unchecked_Access))));
2262
2263          else
2264             --  Unlock (_object._object'Access);
2265
2266             --  object is the record used to implement the protected object.
2267             --  It is a parameter to the protected subprogram.
2268
2269             --  If the protected object is controlled (i.e it has entries or
2270             --  needs finalization for interrupt handling), call
2271             --  Unlock_Entries, except if the protected object follows the
2272             --  ravenscar profile, in which case call Unlock_Entry, otherwise
2273             --  call the simplified version, Unlock.
2274
2275             if Has_Entries (Pid)
2276               or else Has_Interrupt_Handler (Pid)
2277               or else (Has_Attach_Handler (Pid)
2278                          and then not Restricted_Profile)
2279             then
2280                if Abort_Allowed
2281                  or else Restriction_Active (No_Entry_Queue) = False
2282                  or else Number_Entries (Pid) > 1
2283                then
2284                   Name := New_Reference_To (RTE (RE_Unlock_Entries), Loc);
2285                else
2286                   Name := New_Reference_To (RTE (RE_Unlock_Entry), Loc);
2287                end if;
2288
2289             else
2290                Name := New_Reference_To (RTE (RE_Unlock), Loc);
2291             end if;
2292
2293             Append_To (Stmt,
2294               Make_Procedure_Call_Statement (Loc,
2295                 Name => Name,
2296                 Parameter_Associations => New_List (
2297                   Make_Attribute_Reference (Loc,
2298                     Prefix =>
2299                       Make_Selected_Component (Loc,
2300                         Prefix =>
2301                           New_Reference_To (Defining_Identifier (Param), Loc),
2302                         Selector_Name =>
2303                           Make_Identifier (Loc, Name_uObject)),
2304                     Attribute_Name => Name_Unchecked_Access))));
2305          end if;
2306
2307          if Abort_Allowed then
2308
2309             --  Abort_Undefer;
2310
2311             Append_To (Stmt,
2312               Make_Procedure_Call_Statement (Loc,
2313                 Name =>
2314                   New_Reference_To (
2315                     RTE (RE_Abort_Undefer), Loc),
2316                 Parameter_Associations => Empty_List));
2317          end if;
2318
2319       elsif Is_Task_Allocation_Block then
2320
2321          --  Add a call to Expunge_Unactivated_Tasks to the cleanup
2322          --  handler of a block created for the dynamic allocation of
2323          --  tasks:
2324
2325          --  Expunge_Unactivated_Tasks (_chain);
2326
2327          --  where _chain is the list of tasks created by the allocator
2328          --  but not yet activated. This list will be empty unless
2329          --  the block completes abnormally.
2330
2331          --  This only applies to dynamically allocated tasks;
2332          --  other unactivated tasks are completed by Complete_Task or
2333          --  Complete_Master.
2334
2335          --  NOTE: This cleanup handler references _chain, a local
2336          --        object.
2337
2338          Append_To (Stmt,
2339            Make_Procedure_Call_Statement (Loc,
2340              Name =>
2341                New_Reference_To (
2342                  RTE (RE_Expunge_Unactivated_Tasks), Loc),
2343              Parameter_Associations => New_List (
2344                New_Reference_To (Activation_Chain_Entity (N), Loc))));
2345
2346       elsif Is_Asynchronous_Call_Block then
2347
2348          --  Add a call to attempt to cancel the asynchronous entry call
2349          --  whenever the block containing the abortable part is exited.
2350
2351          --  NOTE: This cleanup handler references C, a local object
2352
2353          --  Get the argument to the Cancel procedure
2354          Cancel_Param := Entry_Cancel_Parameter (Entity (Identifier (N)));
2355
2356          --  If it is of type Communication_Block, this must be a
2357          --  protected entry call.
2358
2359          if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then
2360
2361             Append_To (Stmt,
2362
2363             --  if Enqueued (Cancel_Parameter) then
2364
2365               Make_Implicit_If_Statement (Clean,
2366                 Condition => Make_Function_Call (Loc,
2367                   Name => New_Reference_To (
2368                     RTE (RE_Enqueued), Loc),
2369                   Parameter_Associations => New_List (
2370                     New_Reference_To (Cancel_Param, Loc))),
2371                 Then_Statements => New_List (
2372
2373             --  Cancel_Protected_Entry_Call (Cancel_Param);
2374
2375                   Make_Procedure_Call_Statement (Loc,
2376                     Name => New_Reference_To (
2377                       RTE (RE_Cancel_Protected_Entry_Call), Loc),
2378                     Parameter_Associations => New_List (
2379                       New_Reference_To (Cancel_Param, Loc))))));
2380
2381          --  Asynchronous delay
2382
2383          elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then
2384             Append_To (Stmt,
2385               Make_Procedure_Call_Statement (Loc,
2386                 Name => New_Reference_To (RTE (RE_Cancel_Async_Delay), Loc),
2387                 Parameter_Associations => New_List (
2388                   Make_Attribute_Reference (Loc,
2389                     Prefix => New_Reference_To (Cancel_Param, Loc),
2390                     Attribute_Name => Name_Unchecked_Access))));
2391
2392          --  Task entry call
2393
2394          else
2395             --  Append call to Cancel_Task_Entry_Call (C);
2396
2397             Append_To (Stmt,
2398               Make_Procedure_Call_Statement (Loc,
2399                 Name => New_Reference_To (
2400                   RTE (RE_Cancel_Task_Entry_Call),
2401                   Loc),
2402                 Parameter_Associations => New_List (
2403                   New_Reference_To (Cancel_Param, Loc))));
2404
2405          end if;
2406       end if;
2407
2408       if Present (Flist) then
2409          Append_To (Stmt,
2410            Make_Procedure_Call_Statement (Loc,
2411              Name => New_Reference_To (RTE (RE_Finalize_List), Loc),
2412              Parameter_Associations => New_List (
2413                     New_Reference_To (Flist, Loc))));
2414       end if;
2415
2416       if Present (Mark) then
2417          Append_To (Stmt,
2418            Make_Procedure_Call_Statement (Loc,
2419              Name => New_Reference_To (RTE (RE_SS_Release), Loc),
2420              Parameter_Associations => New_List (
2421                     New_Reference_To (Mark, Loc))));
2422       end if;
2423
2424       Sbody :=
2425         Make_Subprogram_Body (Loc,
2426           Specification =>
2427             Make_Procedure_Specification (Loc,
2428               Defining_Unit_Name => Clean),
2429
2430           Declarations  => New_List,
2431
2432           Handled_Statement_Sequence =>
2433             Make_Handled_Sequence_Of_Statements (Loc,
2434               Statements => Stmt));
2435
2436       if Present (Flist) or else Is_Task or else Is_Master then
2437          Wrap_Cleanup_Procedure (Sbody);
2438       end if;
2439
2440       --  We do not want debug information for _Clean routines,
2441       --  since it just confuses the debugging operation unless
2442       --  we are debugging generated code.
2443
2444       if not Debug_Generated_Code then
2445          Set_Debug_Info_Off (Clean, True);
2446       end if;
2447
2448       return Sbody;
2449    end Make_Clean;
2450
2451    --------------------------
2452    -- Make_Deep_Array_Body --
2453    --------------------------
2454
2455    --  Array components are initialized and adjusted in the normal order
2456    --  and finalized in the reverse order. Exceptions are handled and
2457    --  Program_Error is re-raise in the Adjust and Finalize case
2458    --  (RM 7.6.1(12)). Generate the following code :
2459    --
2460    --  procedure Deep_<P>   --  with <P> being Initialize or Adjust or Finalize
2461    --   (L : in out Finalizable_Ptr;
2462    --    V : in out Typ)
2463    --  is
2464    --  begin
2465    --     for J1 in             Typ'First (1) .. Typ'Last (1) loop
2466    --               ^ reverse ^  --  in the finalization case
2467    --        ...
2468    --           for J2 in Typ'First (n) .. Typ'Last (n) loop
2469    --                 Make_<P>_Call (Typ, V (J1, .. , Jn), L, V);
2470    --           end loop;
2471    --        ...
2472    --     end loop;
2473    --  exception                                --  not in the
2474    --     when others => raise Program_Error;   --     Initialize case
2475    --  end Deep_<P>;
2476
2477    function Make_Deep_Array_Body
2478      (Prim : Final_Primitives;
2479       Typ  : Entity_Id)
2480       return List_Id
2481    is
2482       Loc : constant Source_Ptr := Sloc (Typ);
2483
2484       Index_List : constant List_Id := New_List;
2485       --  Stores the list of references to the indexes (one per dimension)
2486
2487       function One_Component return List_Id;
2488       --  Create one statement to initialize/adjust/finalize one array
2489       --  component, designated by a full set of indices.
2490
2491       function One_Dimension (N : Int) return List_Id;
2492       --  Create loop to deal with one dimension of the array. The single
2493       --  statement in the body of the loop initializes the inner dimensions if
2494       --  any, or else a single component.
2495
2496       -------------------
2497       -- One_Component --
2498       -------------------
2499
2500       function One_Component return List_Id is
2501          Comp_Typ : constant Entity_Id := Component_Type (Typ);
2502          Comp_Ref : constant Node_Id :=
2503                       Make_Indexed_Component (Loc,
2504                         Prefix      => Make_Identifier (Loc, Name_V),
2505                         Expressions => Index_List);
2506
2507       begin
2508          --  Set the etype of the component Reference, which is used to
2509          --  determine whether a conversion to a parent type is needed.
2510
2511          Set_Etype (Comp_Ref, Comp_Typ);
2512
2513          case Prim is
2514             when Initialize_Case =>
2515                return Make_Init_Call (Comp_Ref, Comp_Typ,
2516                         Make_Identifier (Loc, Name_L),
2517                         Make_Identifier (Loc, Name_B));
2518
2519             when Adjust_Case =>
2520                return Make_Adjust_Call (Comp_Ref, Comp_Typ,
2521                         Make_Identifier (Loc, Name_L),
2522                         Make_Identifier (Loc, Name_B));
2523
2524             when Finalize_Case =>
2525                return Make_Final_Call (Comp_Ref, Comp_Typ,
2526                         Make_Identifier (Loc, Name_B));
2527          end case;
2528       end One_Component;
2529
2530       -------------------
2531       -- One_Dimension --
2532       -------------------
2533
2534       function One_Dimension (N : Int) return List_Id is
2535          Index : Entity_Id;
2536
2537       begin
2538          if N > Number_Dimensions (Typ) then
2539             return One_Component;
2540
2541          else
2542             Index :=
2543               Make_Defining_Identifier (Loc, New_External_Name ('J', N));
2544
2545             Append_To (Index_List, New_Reference_To (Index, Loc));
2546
2547             return New_List (
2548               Make_Implicit_Loop_Statement (Typ,
2549                 Identifier => Empty,
2550                 Iteration_Scheme =>
2551                   Make_Iteration_Scheme (Loc,
2552                     Loop_Parameter_Specification =>
2553                       Make_Loop_Parameter_Specification (Loc,
2554                         Defining_Identifier => Index,
2555                         Discrete_Subtype_Definition =>
2556                           Make_Attribute_Reference (Loc,
2557                             Prefix => Make_Identifier (Loc, Name_V),
2558                             Attribute_Name  => Name_Range,
2559                             Expressions => New_List (
2560                               Make_Integer_Literal (Loc, N))),
2561                         Reverse_Present => Prim = Finalize_Case)),
2562                 Statements => One_Dimension (N + 1)));
2563          end if;
2564       end One_Dimension;
2565
2566    --  Start of processing for Make_Deep_Array_Body
2567
2568    begin
2569       return One_Dimension (1);
2570    end Make_Deep_Array_Body;
2571
2572    --------------------
2573    -- Make_Deep_Proc --
2574    --------------------
2575
2576    --  Generate:
2577    --    procedure DEEP_<prim>
2578    --      (L : IN OUT Finalizable_Ptr;    -- not for Finalize
2579    --       V : IN OUT <typ>;
2580    --       B : IN Short_Short_Integer) is
2581    --    begin
2582    --       <stmts>;
2583    --    exception                   --  Finalize and Adjust Cases only
2584    --       raise Program_Error;     --  idem
2585    --    end DEEP_<prim>;
2586
2587    function Make_Deep_Proc
2588      (Prim  : Final_Primitives;
2589       Typ   : Entity_Id;
2590       Stmts : List_Id)
2591       return Entity_Id
2592    is
2593       Loc       : constant Source_Ptr := Sloc (Typ);
2594       Formals   : List_Id;
2595       Proc_Name : Entity_Id;
2596       Handler   : List_Id := No_List;
2597       Type_B    : Entity_Id;
2598
2599    begin
2600       if Prim = Finalize_Case then
2601          Formals := New_List;
2602          Type_B := Standard_Boolean;
2603
2604       else
2605          Formals := New_List (
2606            Make_Parameter_Specification (Loc,
2607              Defining_Identifier => Make_Defining_Identifier (Loc, Name_L),
2608              In_Present          => True,
2609              Out_Present         => True,
2610              Parameter_Type      =>
2611                New_Reference_To (RTE (RE_Finalizable_Ptr), Loc)));
2612          Type_B := Standard_Short_Short_Integer;
2613       end if;
2614
2615       Append_To (Formals,
2616         Make_Parameter_Specification (Loc,
2617           Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
2618           In_Present          => True,
2619           Out_Present         => True,
2620           Parameter_Type      => New_Reference_To (Typ, Loc)));
2621
2622       Append_To (Formals,
2623         Make_Parameter_Specification (Loc,
2624           Defining_Identifier => Make_Defining_Identifier (Loc, Name_B),
2625           Parameter_Type      => New_Reference_To (Type_B, Loc)));
2626
2627       if Prim = Finalize_Case or else Prim = Adjust_Case then
2628          Handler := New_List (
2629            Make_Exception_Handler (Loc,
2630              Exception_Choices => New_List (Make_Others_Choice (Loc)),
2631              Statements        => New_List (
2632                Make_Raise_Program_Error (Loc,
2633                  Reason => PE_Finalize_Raised_Exception))));
2634       end if;
2635
2636       Proc_Name :=
2637         Make_Defining_Identifier (Loc,
2638           Chars => Make_TSS_Name (Typ, Deep_Name_Of (Prim)));
2639
2640       Discard_Node (
2641         Make_Subprogram_Body (Loc,
2642           Specification =>
2643             Make_Procedure_Specification (Loc,
2644               Defining_Unit_Name       => Proc_Name,
2645               Parameter_Specifications => Formals),
2646
2647           Declarations =>  Empty_List,
2648           Handled_Statement_Sequence =>
2649             Make_Handled_Sequence_Of_Statements (Loc,
2650               Statements         => Stmts,
2651               Exception_Handlers => Handler)));
2652
2653       return Proc_Name;
2654    end Make_Deep_Proc;
2655
2656    ---------------------------
2657    -- Make_Deep_Record_Body --
2658    ---------------------------
2659
2660    --  The Deep procedures call the appropriate Controlling proc on the
2661    --  the controller component. In the init case, it also attach the
2662    --  controller to the current finalization list.
2663
2664    function Make_Deep_Record_Body
2665      (Prim : Final_Primitives;
2666       Typ  : Entity_Id)
2667       return List_Id
2668    is
2669       Loc            : constant Source_Ptr := Sloc (Typ);
2670       Controller_Typ : Entity_Id;
2671       Obj_Ref        : constant Node_Id := Make_Identifier (Loc, Name_V);
2672       Controller_Ref : constant Node_Id :=
2673                          Make_Selected_Component (Loc,
2674                            Prefix        => Obj_Ref,
2675                            Selector_Name =>
2676                              Make_Identifier (Loc, Name_uController));
2677       Res            : constant List_Id := New_List;
2678
2679    begin
2680       if Is_Return_By_Reference_Type (Typ) then
2681          Controller_Typ := RTE (RE_Limited_Record_Controller);
2682       else
2683          Controller_Typ := RTE (RE_Record_Controller);
2684       end if;
2685
2686       case Prim is
2687          when Initialize_Case =>
2688             Append_List_To (Res,
2689               Make_Init_Call (
2690                 Ref          => Controller_Ref,
2691                 Typ          => Controller_Typ,
2692                 Flist_Ref    => Make_Identifier (Loc, Name_L),
2693                 With_Attach  => Make_Identifier (Loc, Name_B)));
2694
2695             --  When the type is also a controlled type by itself,
2696             --  Initialize it and attach it to the finalization chain
2697
2698             if Is_Controlled (Typ) then
2699                Append_To (Res,
2700                  Make_Procedure_Call_Statement (Loc,
2701                    Name => New_Reference_To (
2702                      Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
2703                    Parameter_Associations =>
2704                      New_List (New_Copy_Tree (Obj_Ref))));
2705
2706                Append_To (Res, Make_Attach_Call (
2707                  Obj_Ref      => New_Copy_Tree (Obj_Ref),
2708                  Flist_Ref    => Make_Identifier (Loc, Name_L),
2709                  With_Attach => Make_Identifier (Loc, Name_B)));
2710             end if;
2711
2712          when Adjust_Case =>
2713             Append_List_To (Res,
2714               Make_Adjust_Call (Controller_Ref, Controller_Typ,
2715                 Make_Identifier (Loc, Name_L),
2716                 Make_Identifier (Loc, Name_B)));
2717
2718             --  When the type is also a controlled type by itself,
2719             --  Adjust it it and attach it to the finalization chain
2720
2721             if Is_Controlled (Typ) then
2722                Append_To (Res,
2723                  Make_Procedure_Call_Statement (Loc,
2724                    Name => New_Reference_To (
2725                      Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
2726                    Parameter_Associations =>
2727                      New_List (New_Copy_Tree (Obj_Ref))));
2728
2729                Append_To (Res, Make_Attach_Call (
2730                  Obj_Ref      => New_Copy_Tree (Obj_Ref),
2731                  Flist_Ref    => Make_Identifier (Loc, Name_L),
2732                  With_Attach => Make_Identifier (Loc, Name_B)));
2733             end if;
2734
2735          when Finalize_Case =>
2736             if Is_Controlled (Typ) then
2737                Append_To (Res,
2738                  Make_Implicit_If_Statement (Obj_Ref,
2739                    Condition => Make_Identifier (Loc, Name_B),
2740                    Then_Statements => New_List (
2741                      Make_Procedure_Call_Statement (Loc,
2742                        Name => New_Reference_To (RTE (RE_Finalize_One), Loc),
2743                        Parameter_Associations => New_List (
2744                          OK_Convert_To (RTE (RE_Finalizable),
2745                            New_Copy_Tree (Obj_Ref))))),
2746
2747                    Else_Statements => New_List (
2748                      Make_Procedure_Call_Statement (Loc,
2749                        Name => New_Reference_To (
2750                          Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
2751                        Parameter_Associations =>
2752                         New_List (New_Copy_Tree (Obj_Ref))))));
2753             end if;
2754
2755             Append_List_To (Res,
2756               Make_Final_Call (Controller_Ref, Controller_Typ,
2757                 Make_Identifier (Loc, Name_B)));
2758       end case;
2759       return Res;
2760    end Make_Deep_Record_Body;
2761
2762    ----------------------
2763    -- Make_Final_Call --
2764    ----------------------
2765
2766    function Make_Final_Call
2767      (Ref         : Node_Id;
2768       Typ         : Entity_Id;
2769       With_Detach : Node_Id)
2770       return        List_Id
2771    is
2772       Loc   : constant Source_Ptr := Sloc (Ref);
2773       Res   : constant List_Id    := New_List;
2774       Cref  : Node_Id;
2775       Cref2 : Node_Id;
2776       Proc  : Entity_Id;
2777       Utyp  : Entity_Id;
2778
2779    begin
2780       if Is_Class_Wide_Type (Typ) then
2781          Utyp := Root_Type (Typ);
2782          Cref := Ref;
2783
2784       elsif Is_Concurrent_Type (Typ) then
2785          Utyp := Corresponding_Record_Type (Typ);
2786          Cref := Convert_Concurrent (Ref, Typ);
2787
2788       elsif Is_Private_Type (Typ)
2789         and then Present (Full_View (Typ))
2790         and then Is_Concurrent_Type (Full_View (Typ))
2791       then
2792          Utyp := Corresponding_Record_Type (Full_View (Typ));
2793          Cref := Convert_Concurrent (Ref, Full_View (Typ));
2794       else
2795          Utyp := Typ;
2796          Cref := Ref;
2797       end if;
2798
2799       Utyp := Underlying_Type (Base_Type (Utyp));
2800       Set_Assignment_OK (Cref);
2801
2802       --  Deal with non-tagged derivation of private views
2803
2804       if Is_Untagged_Derivation (Typ) then
2805          Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
2806          Cref := Unchecked_Convert_To (Utyp, Cref);
2807          Set_Assignment_OK (Cref);
2808          --  To prevent problems with UC see 1.156 RH ???
2809       end if;
2810
2811       --  If the underlying_type is a subtype, we are dealing with
2812       --  the completion of a private type. We need to access
2813       --  the base type and generate a conversion to it.
2814
2815       if Utyp /= Base_Type (Utyp) then
2816          pragma Assert (Is_Private_Type (Typ));
2817          Utyp := Base_Type (Utyp);
2818          Cref := Unchecked_Convert_To (Utyp, Cref);
2819       end if;
2820
2821       --  Generate:
2822       --    Deep_Finalize (Ref, With_Detach);
2823
2824       if Has_Controlled_Component (Utyp)
2825         or else Is_Class_Wide_Type (Typ)
2826       then
2827          if Is_Tagged_Type (Utyp) then
2828             Proc := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
2829          else
2830             Proc := TSS (Utyp, TSS_Deep_Finalize);
2831          end if;
2832
2833          Cref := Convert_View (Proc, Cref);
2834
2835          Append_To (Res,
2836            Make_Procedure_Call_Statement (Loc,
2837              Name => New_Reference_To (Proc, Loc),
2838              Parameter_Associations =>
2839                New_List (Cref, With_Detach)));
2840
2841       --  Generate:
2842       --    if With_Detach then
2843       --       Finalize_One (Ref);
2844       --    else
2845       --       Finalize (Ref);
2846       --    end if;
2847
2848       else
2849          Proc := Find_Prim_Op (Utyp, Name_Of (Finalize_Case));
2850
2851          if Chars (With_Detach) = Chars (Standard_True) then
2852             Append_To (Res,
2853               Make_Procedure_Call_Statement (Loc,
2854                 Name => New_Reference_To (RTE (RE_Finalize_One), Loc),
2855                 Parameter_Associations => New_List (
2856                   OK_Convert_To (RTE (RE_Finalizable), Cref))));
2857
2858          elsif Chars (With_Detach) = Chars (Standard_False) then
2859             Append_To (Res,
2860               Make_Procedure_Call_Statement (Loc,
2861                 Name => New_Reference_To (Proc, Loc),
2862                 Parameter_Associations =>
2863                   New_List (Convert_View (Proc, Cref))));
2864
2865          else
2866             Cref2 := New_Copy_Tree (Cref);
2867             Append_To (Res,
2868               Make_Implicit_If_Statement (Ref,
2869                 Condition => With_Detach,
2870                 Then_Statements => New_List (
2871                   Make_Procedure_Call_Statement (Loc,
2872                     Name => New_Reference_To (RTE (RE_Finalize_One), Loc),
2873                     Parameter_Associations => New_List (
2874                       OK_Convert_To (RTE (RE_Finalizable), Cref)))),
2875
2876                 Else_Statements => New_List (
2877                   Make_Procedure_Call_Statement (Loc,
2878                     Name => New_Reference_To (Proc, Loc),
2879                     Parameter_Associations =>
2880                       New_List (Convert_View (Proc, Cref2))))));
2881          end if;
2882       end if;
2883
2884       return Res;
2885    end Make_Final_Call;
2886
2887    --------------------
2888    -- Make_Init_Call --
2889    --------------------
2890
2891    function Make_Init_Call
2892      (Ref          : Node_Id;
2893       Typ          : Entity_Id;
2894       Flist_Ref    : Node_Id;
2895       With_Attach  : Node_Id)
2896       return         List_Id
2897    is
2898       Loc     : constant Source_Ptr := Sloc (Ref);
2899       Is_Conc : Boolean;
2900       Res     : constant List_Id := New_List;
2901       Proc    : Entity_Id;
2902       Utyp    : Entity_Id;
2903       Cref    : Node_Id;
2904       Cref2   : Node_Id;
2905       Attach  : Node_Id := With_Attach;
2906
2907    begin
2908       if Is_Concurrent_Type (Typ) then
2909          Is_Conc := True;
2910          Utyp    := Corresponding_Record_Type (Typ);
2911          Cref    := Convert_Concurrent (Ref, Typ);
2912
2913       elsif Is_Private_Type (Typ)
2914         and then Present (Full_View (Typ))
2915         and then Is_Concurrent_Type (Underlying_Type (Typ))
2916       then
2917          Is_Conc := True;
2918          Utyp    := Corresponding_Record_Type (Underlying_Type (Typ));
2919          Cref    := Convert_Concurrent (Ref, Underlying_Type (Typ));
2920
2921       else
2922          Is_Conc := False;
2923          Utyp    := Typ;
2924          Cref    := Ref;
2925       end if;
2926
2927       Utyp := Underlying_Type (Base_Type (Utyp));
2928
2929       Set_Assignment_OK (Cref);
2930
2931       --  Deal with non-tagged derivation of private views
2932
2933       if Is_Untagged_Derivation (Typ)
2934         and then not Is_Conc
2935       then
2936          Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
2937          Cref := Unchecked_Convert_To (Utyp, Cref);
2938          Set_Assignment_OK (Cref);
2939          --  To prevent problems with UC see 1.156 RH ???
2940       end if;
2941
2942       --  If the underlying_type is a subtype, we are dealing with
2943       --  the completion of a private type. We need to access
2944       --  the base type and generate a conversion to it.
2945
2946       if Utyp /= Base_Type (Utyp) then
2947          pragma Assert (Is_Private_Type (Typ));
2948          Utyp := Base_Type (Utyp);
2949          Cref := Unchecked_Convert_To (Utyp, Cref);
2950       end if;
2951
2952       --  We do not need to attach to one of the Global Final Lists
2953       --  the objects whose type is Finalize_Storage_Only
2954
2955       if Finalize_Storage_Only (Typ)
2956         and then (Global_Flist_Ref (Flist_Ref)
2957           or else Entity (Constant_Value (RTE (RE_Garbage_Collected)))
2958                   = Standard_True)
2959       then
2960          Attach := Make_Integer_Literal (Loc, 0);
2961       end if;
2962
2963       --  Generate:
2964       --    Deep_Initialize (Ref, Flist_Ref);
2965
2966       if Has_Controlled_Component (Utyp) then
2967          Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case));
2968
2969          Cref := Convert_View (Proc, Cref, 2);
2970
2971          Append_To (Res,
2972            Make_Procedure_Call_Statement (Loc,
2973              Name => New_Reference_To (Proc, Loc),
2974              Parameter_Associations => New_List (
2975                Node1 => Flist_Ref,
2976                Node2 => Cref,
2977                Node3 => Attach)));
2978
2979       --  Generate:
2980       --    Attach_To_Final_List (Ref, Flist_Ref);
2981       --    Initialize (Ref);
2982
2983       else -- Is_Controlled (Utyp)
2984          Proc  := Find_Prim_Op (Utyp, Name_Of (Initialize_Case));
2985          Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Cref);
2986
2987          Cref  := Convert_View (Proc, Cref);
2988          Cref2 := New_Copy_Tree (Cref);
2989
2990          Append_To (Res,
2991            Make_Procedure_Call_Statement (Loc,
2992            Name => New_Reference_To (Proc, Loc),
2993            Parameter_Associations => New_List (Cref2)));
2994
2995          Append_To (Res,
2996            Make_Attach_Call (Cref, Flist_Ref, Attach));
2997       end if;
2998
2999       return Res;
3000    end Make_Init_Call;
3001
3002    --------------------------
3003    -- Make_Transient_Block --
3004    --------------------------
3005
3006    --  If finalization is involved, this function just wraps the instruction
3007    --  into a block whose name is the transient block entity, and then
3008    --  Expand_Cleanup_Actions (called on the expansion of the handled
3009    --  sequence of statements will do the necessary expansions for
3010    --  cleanups).
3011
3012    function Make_Transient_Block
3013      (Loc    : Source_Ptr;
3014       Action : Node_Id)
3015       return   Node_Id
3016    is
3017       Flist  : constant Entity_Id := Finalization_Chain_Entity (Current_Scope);
3018       Decls  : constant List_Id   := New_List;
3019       Par    : constant Node_Id   := Parent (Action);
3020       Instrs : constant List_Id   := New_List (Action);
3021       Blk    : Node_Id;
3022
3023    begin
3024       --  Case where only secondary stack use is involved
3025
3026       if Uses_Sec_Stack (Current_Scope)
3027         and then No (Flist)
3028         and then Nkind (Action) /= N_Return_Statement
3029         and then Nkind (Par) /= N_Exception_Handler
3030       then
3031
3032          declare
3033             S  : Entity_Id;
3034             K  : Entity_Kind;
3035          begin
3036             S := Scope (Current_Scope);
3037             loop
3038                K := Ekind (S);
3039
3040                --  At the outer level, no need to release the sec stack
3041
3042                if S = Standard_Standard then
3043                   Set_Uses_Sec_Stack (Current_Scope, False);
3044                   exit;
3045
3046                --  In a function, only release the sec stack if the
3047                --  function does not return on the sec stack otherwise
3048                --  the result may be lost. The caller is responsible for
3049                --  releasing.
3050
3051                elsif K = E_Function then
3052                   Set_Uses_Sec_Stack (Current_Scope, False);
3053
3054                   if not Requires_Transient_Scope (Etype (S)) then
3055                      if not Functions_Return_By_DSP_On_Target then
3056                         Set_Uses_Sec_Stack (S, True);
3057                         Check_Restriction (No_Secondary_Stack, Action);
3058                      end if;
3059                   end if;
3060
3061                   exit;
3062
3063                --  In a loop or entry we should install a block encompassing
3064                --  all the construct. For now just release right away.
3065
3066                elsif K = E_Loop or else K = E_Entry then
3067                   exit;
3068
3069                --  In a procedure or a block, we release on exit of the
3070                --  procedure or block. ??? memory leak can be created by
3071                --  recursive calls.
3072
3073                elsif K = E_Procedure
3074                  or else K = E_Block
3075                then
3076                   if not Functions_Return_By_DSP_On_Target then
3077                      Set_Uses_Sec_Stack (S, True);
3078                      Check_Restriction (No_Secondary_Stack, Action);
3079                   end if;
3080
3081                   Set_Uses_Sec_Stack (Current_Scope, False);
3082                   exit;
3083
3084                else
3085                   S := Scope (S);
3086                end if;
3087             end loop;
3088          end;
3089       end if;
3090
3091       --  Insert actions stuck in the transient scopes as well as all
3092       --  freezing nodes needed by those actions
3093
3094       Insert_Actions_In_Scope_Around (Action);
3095
3096       declare
3097          Last_Inserted : Node_Id := Prev (Action);
3098
3099       begin
3100          if Present (Last_Inserted) then
3101             Freeze_All (First_Entity (Current_Scope), Last_Inserted);
3102          end if;
3103       end;
3104
3105       Blk :=
3106         Make_Block_Statement (Loc,
3107           Identifier => New_Reference_To (Current_Scope, Loc),
3108           Declarations => Decls,
3109           Handled_Statement_Sequence =>
3110             Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs),
3111           Has_Created_Identifier => True);
3112
3113       --  When the transient scope was established, we pushed the entry for
3114       --  the transient scope onto the scope stack, so that the scope was
3115       --  active for the installation of finalizable entities etc. Now we
3116       --  must remove this entry, since we have constructed a proper block.
3117
3118       Pop_Scope;
3119
3120       return Blk;
3121    end Make_Transient_Block;
3122
3123    ------------------------
3124    -- Node_To_Be_Wrapped --
3125    ------------------------
3126
3127    function Node_To_Be_Wrapped return Node_Id is
3128    begin
3129       return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped;
3130    end Node_To_Be_Wrapped;
3131
3132    ----------------------------
3133    -- Set_Node_To_Be_Wrapped --
3134    ----------------------------
3135
3136    procedure Set_Node_To_Be_Wrapped (N : Node_Id) is
3137    begin
3138       Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := N;
3139    end Set_Node_To_Be_Wrapped;
3140
3141    ----------------------------------
3142    -- Store_After_Actions_In_Scope --
3143    ----------------------------------
3144
3145    procedure Store_After_Actions_In_Scope (L : List_Id) is
3146       SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
3147
3148    begin
3149       if Present (SE.Actions_To_Be_Wrapped_After) then
3150          Insert_List_Before_And_Analyze (
3151           First (SE.Actions_To_Be_Wrapped_After), L);
3152
3153       else
3154          SE.Actions_To_Be_Wrapped_After := L;
3155
3156          if Is_List_Member (SE.Node_To_Be_Wrapped) then
3157             Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
3158          else
3159             Set_Parent (L, SE.Node_To_Be_Wrapped);
3160          end if;
3161
3162          Analyze_List (L);
3163       end if;
3164    end Store_After_Actions_In_Scope;
3165
3166    -----------------------------------
3167    -- Store_Before_Actions_In_Scope --
3168    -----------------------------------
3169
3170    procedure Store_Before_Actions_In_Scope (L : List_Id) is
3171       SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
3172
3173    begin
3174       if Present (SE.Actions_To_Be_Wrapped_Before) then
3175          Insert_List_After_And_Analyze (
3176            Last (SE.Actions_To_Be_Wrapped_Before), L);
3177
3178       else
3179          SE.Actions_To_Be_Wrapped_Before := L;
3180
3181          if Is_List_Member (SE.Node_To_Be_Wrapped) then
3182             Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
3183          else
3184             Set_Parent (L, SE.Node_To_Be_Wrapped);
3185          end if;
3186
3187          Analyze_List (L);
3188       end if;
3189    end Store_Before_Actions_In_Scope;
3190
3191    --------------------------------
3192    -- Wrap_Transient_Declaration --
3193    --------------------------------
3194
3195    --  If a transient scope has been established during the processing of the
3196    --  Expression of an Object_Declaration, it is not possible to wrap the
3197    --  declaration into a transient block as usual case, otherwise the object
3198    --  would be itself declared in the wrong scope. Therefore, all entities (if
3199    --  any) defined in the transient block are moved to the proper enclosing
3200    --  scope, furthermore, if they are controlled variables they are finalized
3201    --  right after the declaration. The finalization list of the transient
3202    --  scope is defined as a renaming of the enclosing one so during their
3203    --  initialization they will be attached to the proper finalization
3204    --  list. For instance, the following declaration :
3205
3206    --        X : Typ := F (G (A), G (B));
3207
3208    --  (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
3209    --  is expanded into :
3210
3211    --    _local_final_list_1 : Finalizable_Ptr;
3212    --    X : Typ := [ complex Expression-Action ];
3213    --    Finalize_One(_v1);
3214    --    Finalize_One (_v2);
3215
3216    procedure Wrap_Transient_Declaration (N : Node_Id) is
3217       S           : Entity_Id;
3218       LC          : Entity_Id := Empty;
3219       Nodes       : List_Id;
3220       Loc         : constant Source_Ptr := Sloc (N);
3221       Enclosing_S : Entity_Id;
3222       Uses_SS     : Boolean;
3223       Next_N      : constant Node_Id := Next (N);
3224
3225    begin
3226       S := Current_Scope;
3227       Enclosing_S := Scope (S);
3228
3229       --  Insert Actions kept in the Scope stack
3230
3231       Insert_Actions_In_Scope_Around (N);
3232
3233       --  If the declaration is consuming some secondary stack, mark the
3234       --  Enclosing scope appropriately.
3235
3236       Uses_SS := Uses_Sec_Stack (S);
3237       Pop_Scope;
3238
3239       --  Create a List controller and rename the final list to be its
3240       --  internal final pointer:
3241       --       Lxxx : Simple_List_Controller;
3242       --       Fxxx : Finalizable_Ptr renames Lxxx.F;
3243
3244       if Present (Finalization_Chain_Entity (S)) then
3245          LC := Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
3246
3247          Nodes := New_List (
3248            Make_Object_Declaration (Loc,
3249              Defining_Identifier => LC,
3250              Object_Definition   =>
3251                New_Reference_To (RTE (RE_Simple_List_Controller), Loc)),
3252
3253            Make_Object_Renaming_Declaration (Loc,
3254              Defining_Identifier => Finalization_Chain_Entity (S),
3255              Subtype_Mark => New_Reference_To (RTE (RE_Finalizable_Ptr), Loc),
3256              Name =>
3257                Make_Selected_Component (Loc,
3258                  Prefix        => New_Reference_To (LC, Loc),
3259                  Selector_Name => Make_Identifier (Loc, Name_F))));
3260
3261          --  Put the declaration at the beginning of the declaration part
3262          --  to make sure it will be before all other actions that have been
3263          --  inserted before N.
3264
3265          Insert_List_Before_And_Analyze (First (List_Containing (N)), Nodes);
3266
3267          --  Generate the Finalization calls by finalizing the list
3268          --  controller right away. It will be re-finalized on scope
3269          --  exit but it doesn't matter. It cannot be done when the
3270          --  call initializes a renaming object though because in this
3271          --  case, the object becomes a pointer to the temporary and thus
3272          --  increases its life span.
3273
3274          if Nkind (N) = N_Object_Renaming_Declaration
3275            and then Controlled_Type (Etype (Defining_Identifier (N)))
3276          then
3277             null;
3278
3279          else
3280             Nodes :=
3281               Make_Final_Call (
3282                    Ref         => New_Reference_To (LC, Loc),
3283                    Typ         => Etype (LC),
3284                    With_Detach => New_Reference_To (Standard_False, Loc));
3285             if Present (Next_N) then
3286                Insert_List_Before_And_Analyze (Next_N, Nodes);
3287             else
3288                Append_List_To (List_Containing (N), Nodes);
3289             end if;
3290          end if;
3291       end if;
3292
3293       --  Put the local entities back in the enclosing scope, and set the
3294       --  Is_Public flag appropriately.
3295
3296       Transfer_Entities (S, Enclosing_S);
3297
3298       --  Mark the enclosing dynamic scope so that the sec stack will be
3299       --  released upon its exit unless this is a function that returns on
3300       --  the sec stack in which case this will be done by the caller.
3301
3302       if Uses_SS then
3303          S := Enclosing_Dynamic_Scope (S);
3304
3305          if Ekind (S) = E_Function
3306            and then Requires_Transient_Scope (Etype (S))
3307          then
3308             null;
3309          else
3310             Set_Uses_Sec_Stack (S);
3311             Check_Restriction (No_Secondary_Stack, N);
3312          end if;
3313       end if;
3314    end Wrap_Transient_Declaration;
3315
3316    -------------------------------
3317    -- Wrap_Transient_Expression --
3318    -------------------------------
3319
3320    --  Insert actions before <Expression>:
3321
3322    --  (lines marked with <CTRL> are expanded only in presence of Controlled
3323    --   objects needing finalization)
3324
3325    --     _E : Etyp;
3326    --     declare
3327    --        _M : constant Mark_Id := SS_Mark;
3328    --        Local_Final_List : System.FI.Finalizable_Ptr;    <CTRL>
3329
3330    --        procedure _Clean is
3331    --        begin
3332    --           Abort_Defer;
3333    --           System.FI.Finalize_List (Local_Final_List);   <CTRL>
3334    --           SS_Release (M);
3335    --           Abort_Undefer;
3336    --        end _Clean;
3337
3338    --     begin
3339    --        _E := <Expression>;
3340    --     at end
3341    --        _Clean;
3342    --     end;
3343
3344    --    then expression is replaced by _E
3345
3346    procedure Wrap_Transient_Expression (N : Node_Id) is
3347       Loc  : constant Source_Ptr := Sloc (N);
3348       E    : constant Entity_Id :=
3349                Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
3350       Etyp : constant Entity_Id := Etype (N);
3351
3352    begin
3353       Insert_Actions (N, New_List (
3354         Make_Object_Declaration (Loc,
3355           Defining_Identifier => E,
3356           Object_Definition   => New_Reference_To (Etyp, Loc)),
3357
3358         Make_Transient_Block (Loc,
3359           Action =>
3360             Make_Assignment_Statement (Loc,
3361               Name       => New_Reference_To (E, Loc),
3362               Expression => Relocate_Node (N)))));
3363
3364       Rewrite (N, New_Reference_To (E, Loc));
3365       Analyze_And_Resolve (N, Etyp);
3366    end Wrap_Transient_Expression;
3367
3368    ------------------------------
3369    -- Wrap_Transient_Statement --
3370    ------------------------------
3371
3372    --  Transform <Instruction> into
3373
3374    --  (lines marked with <CTRL> are expanded only in presence of Controlled
3375    --   objects needing finalization)
3376
3377    --    declare
3378    --       _M : Mark_Id := SS_Mark;
3379    --       Local_Final_List : System.FI.Finalizable_Ptr ;    <CTRL>
3380
3381    --       procedure _Clean is
3382    --       begin
3383    --          Abort_Defer;
3384    --          System.FI.Finalize_List (Local_Final_List);    <CTRL>
3385    --          SS_Release (_M);
3386    --          Abort_Undefer;
3387    --       end _Clean;
3388
3389    --    begin
3390    --       <Instr uction>;
3391    --    at end
3392    --       _Clean;
3393    --    end;
3394
3395    procedure Wrap_Transient_Statement (N : Node_Id) is
3396       Loc           : constant Source_Ptr := Sloc (N);
3397       New_Statement : constant Node_Id := Relocate_Node (N);
3398
3399    begin
3400       Rewrite (N, Make_Transient_Block (Loc, New_Statement));
3401
3402       --  With the scope stack back to normal, we can call analyze on the
3403       --  resulting block. At this point, the transient scope is being
3404       --  treated like a perfectly normal scope, so there is nothing
3405       --  special about it.
3406
3407       --  Note: Wrap_Transient_Statement is called with the node already
3408       --  analyzed (i.e. Analyzed (N) is True). This is important, since
3409       --  otherwise we would get a recursive processing of the node when
3410       --  we do this Analyze call.
3411
3412       Analyze (N);
3413    end Wrap_Transient_Statement;
3414
3415 end Exp_Ch7;