gcc/ada/exp_disp.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             E X P _ D I S P                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2017, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Atree;    use Atree;
  27 with Checks;   use Checks;
  28 with Debug;    use Debug;
  29 with Einfo;    use Einfo;
  30 with Elists;   use Elists;
  31 with Errout;   use Errout;
  32 with Exp_Atag; use Exp_Atag;
  33 with Exp_Ch6;  use Exp_Ch6;
  34 with Exp_CG;   use Exp_CG;
  35 with Exp_Dbug; use Exp_Dbug;
  36 with Exp_Tss;  use Exp_Tss;
  37 with Exp_Util; use Exp_Util;
  38 with Freeze;   use Freeze;
  39 with Ghost;    use Ghost;
  40 with Itypes;   use Itypes;
  41 with Layout;   use Layout;
  42 with Nlists;   use Nlists;
  43 with Nmake;    use Nmake;
  44 with Namet;    use Namet;
  45 with Opt;      use Opt;
  46 with Output;   use Output;
  47 with Restrict; use Restrict;
  48 with Rident;   use Rident;
  49 with Rtsfind;  use Rtsfind;
  50 with Sem;      use Sem;
  51 with Sem_Aux;  use Sem_Aux;
  52 with Sem_Ch6;  use Sem_Ch6;
  53 with Sem_Ch7;  use Sem_Ch7;
  54 with Sem_Ch8;  use Sem_Ch8;
  55 with Sem_Disp; use Sem_Disp;
  56 with Sem_Eval; use Sem_Eval;
  57 with Sem_Res;  use Sem_Res;
  58 with Sem_Type; use Sem_Type;
  59 with Sem_Util; use Sem_Util;
  60 with Sinfo;    use Sinfo;
  61 with Sinput;   use Sinput;
  62 with Snames;   use Snames;
  63 with Stand;    use Stand;
  64 with Stringt;  use Stringt;
  65 with SCIL_LL;  use SCIL_LL;
  66 with Tbuild;   use Tbuild;
  67
  68 package body Exp_Disp is
  69
  70    -----------------------
  71    -- Local Subprograms --
  72    -----------------------
  73
  74    function Default_Prim_Op_Position (E : Entity_Id) return Uint;
  75    --  Ada 2005 (AI-251): Returns the fixed position in the dispatch table
  76    --  of the default primitive operations.
  77
  78    function Has_DT (Typ : Entity_Id) return Boolean;
  79    pragma Inline (Has_DT);
  80    --  Returns true if we generate a dispatch table for tagged type Typ
  81
  82    function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean;
  83    --  Returns true if Prim is not a predefined dispatching primitive but it is
  84    --  an alias of a predefined dispatching primitive (i.e. through a renaming)
  85
  86    function New_Value (From : Node_Id) return Node_Id;
  87    --  From is the original Expression. New_Value is equivalent to a call to
  88    --  Duplicate_Subexpr with an explicit dereference when From is an access
  89    --  parameter.
  90
  91    function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean;
  92    --  Check if the type has a private view or if the public view appears in
  93    --  the visible part of a package spec.
  94
  95    function Prim_Op_Kind
  96      (Prim : Entity_Id;
  97       Typ  : Entity_Id) return Node_Id;
  98    --  Ada 2005 (AI-345): Determine the primitive operation kind of Prim
  99    --  according to its type Typ. Return a reference to an RE_Prim_Op_Kind
 100    --  enumeration value.
 101
 102    function Tagged_Kind (T : Entity_Id) return Node_Id;
 103    --  Ada 2005 (AI-345): Determine the tagged kind of T and return a reference
 104    --  to an RE_Tagged_Kind enumeration value.
 105
 106    ----------------------
 107    -- Apply_Tag_Checks --
 108    ----------------------
 109
 110    procedure Apply_Tag_Checks (Call_Node : Node_Id) is
 111       Loc        : constant Source_Ptr := Sloc (Call_Node);
 112       Ctrl_Arg   : constant Node_Id   := Controlling_Argument (Call_Node);
 113       Ctrl_Typ   : constant Entity_Id := Base_Type (Etype (Ctrl_Arg));
 114       Param_List : constant List_Id   := Parameter_Associations (Call_Node);
 115
 116       Subp            : Entity_Id;
 117       CW_Typ          : Entity_Id;
 118       Param           : Node_Id;
 119       Typ             : Entity_Id;
 120       Eq_Prim_Op      : Entity_Id := Empty;
 121
 122    begin
 123       if No_Run_Time_Mode then
 124          Error_Msg_CRT ("tagged types", Call_Node);
 125          return;
 126       end if;
 127
 128       --  Apply_Tag_Checks is called directly from the semantics, so we
 129       --  need a check to see whether expansion is active before proceeding.
 130       --  In addition, there is no need to expand the call when compiling
 131       --  under restriction No_Dispatching_Calls; the semantic analyzer has
 132       --  previously notified the violation of this restriction.
 133
 134       if not Expander_Active
 135         or else Restriction_Active (No_Dispatching_Calls)
 136       then
 137          return;
 138       end if;
 139
 140       --  Set subprogram. If this is an inherited operation that was
 141       --  overridden, the body that is being called is its alias.
 142
 143       Subp := Entity (Name (Call_Node));
 144
 145       if Present (Alias (Subp))
 146         and then Is_Inherited_Operation (Subp)
 147         and then No (DTC_Entity (Subp))
 148       then
 149          Subp := Alias (Subp);
 150       end if;
 151
 152       --  Definition of the class-wide type and the tagged type
 153
 154       --  If the controlling argument is itself a tag rather than a tagged
 155       --  object, then use the class-wide type associated with the subprogram's
 156       --  controlling type. This case can occur when a call to an inherited
 157       --  primitive has an actual that originated from a default parameter
 158       --  given by a tag-indeterminate call and when there is no other
 159       --  controlling argument providing the tag (AI-239 requires dispatching).
 160       --  This capability of dispatching directly by tag is also needed by the
 161       --  implementation of AI-260 (for the generic dispatching constructors).
 162
 163       if Ctrl_Typ = RTE (RE_Tag)
 164         or else (RTE_Available (RE_Interface_Tag)
 165                   and then Ctrl_Typ = RTE (RE_Interface_Tag))
 166       then
 167          CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp));
 168
 169       --  Class_Wide_Type is applied to the expressions used to initialize
 170       --  CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
 171       --  there are cases where the controlling type is resolved to a specific
 172       --  type (such as for designated types of arguments such as CW'Access).
 173
 174       elsif Is_Access_Type (Ctrl_Typ) then
 175          CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ));
 176
 177       else
 178          CW_Typ := Class_Wide_Type (Ctrl_Typ);
 179       end if;
 180
 181       Typ := Find_Specific_Type (CW_Typ);
 182
 183       if not Is_Limited_Type (Typ) then
 184          Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
 185       end if;
 186
 187       --  Dispatching call to C++ primitive
 188
 189       if Is_CPP_Class (Typ) then
 190          null;
 191
 192       --  Dispatching call to Ada primitive
 193
 194       elsif Present (Param_List) then
 195
 196          --  Generate the Tag checks when appropriate
 197
 198          Param := First_Actual (Call_Node);
 199          while Present (Param) loop
 200
 201             --  No tag check with itself
 202
 203             if Param = Ctrl_Arg then
 204                null;
 205
 206             --  No tag check for parameter whose type is neither tagged nor
 207             --  access to tagged (for access parameters)
 208
 209             elsif No (Find_Controlling_Arg (Param)) then
 210                null;
 211
 212             --  No tag check for function dispatching on result if the
 213             --  Tag given by the context is this one
 214
 215             elsif Find_Controlling_Arg (Param) = Ctrl_Arg then
 216                null;
 217
 218             --  "=" is the only dispatching operation allowed to get operands
 219             --  with incompatible tags (it just returns false). We use
 220             --  Duplicate_Subexpr_Move_Checks instead of calling Relocate_Node
 221             --  because the value will be duplicated to check the tags.
 222
 223             elsif Subp = Eq_Prim_Op then
 224                null;
 225
 226             --  No check in presence of suppress flags
 227
 228             elsif Tag_Checks_Suppressed (Etype (Param))
 229               or else (Is_Access_Type (Etype (Param))
 230                          and then Tag_Checks_Suppressed
 231                                     (Designated_Type (Etype (Param))))
 232             then
 233                null;
 234
 235             --  Optimization: no tag checks if the parameters are identical
 236
 237             elsif Is_Entity_Name (Param)
 238               and then Is_Entity_Name (Ctrl_Arg)
 239               and then Entity (Param) = Entity (Ctrl_Arg)
 240             then
 241                null;
 242
 243             --  Now we need to generate the Tag check
 244
 245             else
 246                --  Generate code for tag equality check
 247
 248                --  Perhaps should have Checks.Apply_Tag_Equality_Check???
 249
 250                Insert_Action (Ctrl_Arg,
 251                  Make_Implicit_If_Statement (Call_Node,
 252                    Condition =>
 253                      Make_Op_Ne (Loc,
 254                        Left_Opnd =>
 255                          Make_Selected_Component (Loc,
 256                            Prefix => New_Value (Ctrl_Arg),
 257                            Selector_Name =>
 258                              New_Occurrence_Of
 259                                (First_Tag_Component (Typ), Loc)),
 260
 261                        Right_Opnd =>
 262                          Make_Selected_Component (Loc,
 263                            Prefix =>
 264                              Unchecked_Convert_To (Typ, New_Value (Param)),
 265                            Selector_Name =>
 266                              New_Occurrence_Of
 267                                (First_Tag_Component (Typ), Loc))),
 268
 269                    Then_Statements =>
 270                      New_List (New_Constraint_Error (Loc))));
 271             end if;
 272
 273             Next_Actual (Param);
 274          end loop;
 275       end if;
 276    end Apply_Tag_Checks;
 277
 278    ------------------------
 279    -- Building_Static_DT --
 280    ------------------------
 281
 282    function Building_Static_DT (Typ : Entity_Id) return Boolean is
 283       Root_Typ : Entity_Id := Root_Type (Typ);
 284
 285    begin
 286       --  Handle private types
 287
 288       if Present (Full_View (Root_Typ)) then
 289          Root_Typ := Full_View (Root_Typ);
 290       end if;
 291
 292       return Static_Dispatch_Tables
 293         and then Is_Library_Level_Tagged_Type (Typ)
 294
 295          --  If the type is derived from a CPP class we cannot statically
 296          --  build the dispatch tables because we must inherit primitives
 297          --  from the CPP side.
 298
 299         and then not Is_CPP_Class (Root_Typ);
 300    end Building_Static_DT;
 301
 302    ----------------------------------
 303    -- Build_Static_Dispatch_Tables --
 304    ----------------------------------
 305
 306    procedure Build_Static_Dispatch_Tables (N : Entity_Id) is
 307       Target_List : List_Id;
 308
 309       procedure Build_Dispatch_Tables (List : List_Id);
 310       --  Build the static dispatch table of tagged types found in the list of
 311       --  declarations. The generated nodes are added at the end of Target_List
 312
 313       procedure Build_Package_Dispatch_Tables (N : Node_Id);
 314       --  Build static dispatch tables associated with package declaration N
 315
 316       ---------------------------
 317       -- Build_Dispatch_Tables --
 318       ---------------------------
 319
 320       procedure Build_Dispatch_Tables (List : List_Id) is
 321          D : Node_Id;
 322
 323       begin
 324          D := First (List);
 325          while Present (D) loop
 326
 327             --  Handle nested packages and package bodies recursively. The
 328             --  generated code is placed on the Target_List established for
 329             --  the enclosing compilation unit.
 330
 331             if Nkind (D) = N_Package_Declaration then
 332                Build_Package_Dispatch_Tables (D);
 333
 334             elsif Nkind (D) = N_Package_Body then
 335                Build_Dispatch_Tables (Declarations (D));
 336
 337             elsif Nkind (D) = N_Package_Body_Stub
 338               and then Present (Library_Unit (D))
 339             then
 340                Build_Dispatch_Tables
 341                  (Declarations (Proper_Body (Unit (Library_Unit (D)))));
 342
 343             --  Handle full type declarations and derivations of library level
 344             --  tagged types
 345
 346             elsif Nkind_In (D, N_Full_Type_Declaration,
 347                                N_Derived_Type_Definition)
 348               and then Is_Library_Level_Tagged_Type (Defining_Entity (D))
 349               and then Ekind (Defining_Entity (D)) /= E_Record_Subtype
 350               and then not Is_Private_Type (Defining_Entity (D))
 351             then
 352                --  We do not generate dispatch tables for the internal types
 353                --  created for a type extension with unknown discriminants
 354                --  The needed information is shared with the source type,
 355                --  See Expand_N_Record_Extension.
 356
 357                if Is_Underlying_Record_View (Defining_Entity (D))
 358                  or else
 359                   (not Comes_From_Source (Defining_Entity (D))
 360                      and then
 361                        Has_Unknown_Discriminants (Etype (Defining_Entity (D)))
 362                      and then
 363                        not Comes_From_Source
 364                              (First_Subtype (Defining_Entity (D))))
 365                then
 366                   null;
 367                else
 368                   Insert_List_After_And_Analyze (Last (Target_List),
 369                     Make_DT (Defining_Entity (D)));
 370                end if;
 371
 372             --  Handle private types of library level tagged types. We must
 373             --  exchange the private and full-view to ensure the correct
 374             --  expansion. If the full view is a synchronized type ignore
 375             --  the type because the table will be built for the corresponding
 376             --  record type, that has its own declaration.
 377
 378             elsif (Nkind (D) = N_Private_Type_Declaration
 379                      or else Nkind (D) = N_Private_Extension_Declaration)
 380                and then Present (Full_View (Defining_Entity (D)))
 381             then
 382                declare
 383                   E1 : constant Entity_Id := Defining_Entity (D);
 384                   E2 : constant Entity_Id := Full_View (E1);
 385
 386                begin
 387                   if Is_Library_Level_Tagged_Type (E2)
 388                     and then Ekind (E2) /= E_Record_Subtype
 389                     and then not Is_Concurrent_Type (E2)
 390                   then
 391                      Exchange_Declarations (E1);
 392                      Insert_List_After_And_Analyze (Last (Target_List),
 393                        Make_DT (E1));
 394                      Exchange_Declarations (E2);
 395                   end if;
 396                end;
 397             end if;
 398
 399             Next (D);
 400          end loop;
 401       end Build_Dispatch_Tables;
 402
 403       -----------------------------------
 404       -- Build_Package_Dispatch_Tables --
 405       -----------------------------------
 406
 407       procedure Build_Package_Dispatch_Tables (N : Node_Id) is
 408          Spec       : constant Node_Id   := Specification (N);
 409          Id         : constant Entity_Id := Defining_Entity (N);
 410          Vis_Decls  : constant List_Id   := Visible_Declarations (Spec);
 411          Priv_Decls : constant List_Id   := Private_Declarations (Spec);
 412
 413       begin
 414          Push_Scope (Id);
 415
 416          if Present (Priv_Decls) then
 417             Build_Dispatch_Tables (Vis_Decls);
 418             Build_Dispatch_Tables (Priv_Decls);
 419
 420          elsif Present (Vis_Decls) then
 421             Build_Dispatch_Tables (Vis_Decls);
 422          end if;
 423
 424          Pop_Scope;
 425       end Build_Package_Dispatch_Tables;
 426
 427    --  Start of processing for Build_Static_Dispatch_Tables
 428
 429    begin
 430       if not Expander_Active
 431         or else not Tagged_Type_Expansion
 432       then
 433          return;
 434       end if;
 435
 436       if Nkind (N) = N_Package_Declaration then
 437          declare
 438             Spec       : constant Node_Id := Specification (N);
 439             Vis_Decls  : constant List_Id := Visible_Declarations (Spec);
 440             Priv_Decls : constant List_Id := Private_Declarations (Spec);
 441
 442          begin
 443             if Present (Priv_Decls)
 444               and then Is_Non_Empty_List (Priv_Decls)
 445             then
 446                Target_List := Priv_Decls;
 447
 448             elsif not Present (Vis_Decls) then
 449                Target_List := New_List;
 450                Set_Private_Declarations (Spec, Target_List);
 451             else
 452                Target_List := Vis_Decls;
 453             end if;
 454
 455             Build_Package_Dispatch_Tables (N);
 456          end;
 457
 458       else pragma Assert (Nkind (N) = N_Package_Body);
 459          Target_List := Declarations (N);
 460          Build_Dispatch_Tables (Target_List);
 461       end if;
 462    end Build_Static_Dispatch_Tables;
 463
 464    ------------------------------
 465    -- Convert_Tag_To_Interface --
 466    ------------------------------
 467
 468    function Convert_Tag_To_Interface
 469      (Typ  : Entity_Id;
 470       Expr : Node_Id) return Node_Id
 471    is
 472       Loc       : constant Source_Ptr := Sloc (Expr);
 473       Anon_Type : Entity_Id;
 474       Result    : Node_Id;
 475
 476    begin
 477       pragma Assert (Is_Class_Wide_Type (Typ)
 478         and then Is_Interface (Typ)
 479         and then
 480           ((Nkind (Expr) = N_Selected_Component
 481              and then Is_Tag (Entity (Selector_Name (Expr))))
 482            or else
 483            (Nkind (Expr) = N_Function_Call
 484              and then RTE_Available (RE_Displace)
 485              and then Entity (Name (Expr)) = RTE (RE_Displace))));
 486
 487       Anon_Type := Create_Itype (E_Anonymous_Access_Type, Expr);
 488       Set_Directly_Designated_Type (Anon_Type, Typ);
 489       Set_Etype (Anon_Type, Anon_Type);
 490       Set_Can_Never_Be_Null (Anon_Type);
 491
 492       --  Decorate the size and alignment attributes of the anonymous access
 493       --  type, as required by the back end.
 494
 495       Layout_Type (Anon_Type);
 496
 497       if Nkind (Expr) = N_Selected_Component
 498         and then Is_Tag (Entity (Selector_Name (Expr)))
 499       then
 500          Result :=
 501            Make_Explicit_Dereference (Loc,
 502              Unchecked_Convert_To (Anon_Type,
 503                Make_Attribute_Reference (Loc,
 504                  Prefix         => Expr,
 505                  Attribute_Name => Name_Address)));
 506       else
 507          Result :=
 508            Make_Explicit_Dereference (Loc,
 509              Unchecked_Convert_To (Anon_Type, Expr));
 510       end if;
 511
 512       return Result;
 513    end Convert_Tag_To_Interface;
 514
 515    -------------------
 516    -- CPP_Num_Prims --
 517    -------------------
 518
 519    function CPP_Num_Prims (Typ : Entity_Id) return Nat is
 520       CPP_Typ  : Entity_Id;
 521       Tag_Comp : Entity_Id;
 522
 523    begin
 524       if not Is_Tagged_Type (Typ)
 525         or else not Is_CPP_Class (Root_Type (Typ))
 526       then
 527          return 0;
 528
 529       else
 530          CPP_Typ  := Enclosing_CPP_Parent (Typ);
 531          Tag_Comp := First_Tag_Component (CPP_Typ);
 532
 533          --  If number of primitives already set in the tag component, use it
 534
 535          if Present (Tag_Comp)
 536            and then DT_Entry_Count (Tag_Comp) /= No_Uint
 537          then
 538             return UI_To_Int (DT_Entry_Count (Tag_Comp));
 539
 540          --  Otherwise, count the primitives of the enclosing CPP type
 541
 542          else
 543             declare
 544                Count : Nat := 0;
 545                Elmt  : Elmt_Id;
 546
 547             begin
 548                Elmt := First_Elmt (Primitive_Operations (CPP_Typ));
 549                while Present (Elmt) loop
 550                   Count := Count + 1;
 551                   Next_Elmt (Elmt);
 552                end loop;
 553
 554                return Count;
 555             end;
 556          end if;
 557       end if;
 558    end CPP_Num_Prims;
 559
 560    ------------------------------
 561    -- Default_Prim_Op_Position --
 562    ------------------------------
 563
 564    function Default_Prim_Op_Position (E : Entity_Id) return Uint is
 565       TSS_Name : TSS_Name_Type;
 566
 567    begin
 568       Get_Name_String (Chars (E));
 569       TSS_Name :=
 570         TSS_Name_Type
 571           (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
 572
 573       if Chars (E) = Name_uSize then
 574          return Uint_1;
 575
 576       elsif TSS_Name = TSS_Stream_Read then
 577          return Uint_2;
 578
 579       elsif TSS_Name = TSS_Stream_Write then
 580          return Uint_3;
 581
 582       elsif TSS_Name = TSS_Stream_Input then
 583          return Uint_4;
 584
 585       elsif TSS_Name = TSS_Stream_Output then
 586          return Uint_5;
 587
 588       elsif Chars (E) = Name_Op_Eq then
 589          return Uint_6;
 590
 591       elsif Chars (E) = Name_uAssign then
 592          return Uint_7;
 593
 594       elsif TSS_Name = TSS_Deep_Adjust then
 595          return Uint_8;
 596
 597       elsif TSS_Name = TSS_Deep_Finalize then
 598          return Uint_9;
 599
 600       --  In VM targets unconditionally allow obtaining the position associated
 601       --  with predefined interface primitives since in these platforms any
 602       --  tagged type has these primitives.
 603
 604       elsif Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion then
 605          if Chars (E) = Name_uDisp_Asynchronous_Select then
 606             return Uint_10;
 607
 608          elsif Chars (E) = Name_uDisp_Conditional_Select then
 609             return Uint_11;
 610
 611          elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then
 612             return Uint_12;
 613
 614          elsif Chars (E) = Name_uDisp_Get_Task_Id then
 615             return Uint_13;
 616
 617          elsif Chars (E) = Name_uDisp_Requeue then
 618             return Uint_14;
 619
 620          elsif Chars (E) = Name_uDisp_Timed_Select then
 621             return Uint_15;
 622          end if;
 623       end if;
 624
 625       raise Program_Error;
 626    end Default_Prim_Op_Position;
 627
 628    ----------------------
 629    -- Elab_Flag_Needed --
 630    ----------------------
 631
 632    function Elab_Flag_Needed (Typ : Entity_Id) return Boolean is
 633    begin
 634       return Ada_Version >= Ada_2005
 635         and then not Is_Interface (Typ)
 636         and then Has_Interfaces (Typ);
 637    end Elab_Flag_Needed;
 638
 639    -----------------------------
 640    -- Expand_Dispatching_Call --
 641    -----------------------------
 642
 643    procedure Expand_Dispatching_Call (Call_Node : Node_Id) is
 644       Loc      : constant Source_Ptr := Sloc (Call_Node);
 645       Call_Typ : constant Entity_Id  := Etype (Call_Node);
 646
 647       Ctrl_Arg   : constant Node_Id   := Controlling_Argument (Call_Node);
 648       Ctrl_Typ   : constant Entity_Id := Base_Type (Etype (Ctrl_Arg));
 649       Param_List : constant List_Id   := Parameter_Associations (Call_Node);
 650
 651       Subp            : Entity_Id;
 652       CW_Typ          : Entity_Id;
 653       New_Call        : Node_Id;
 654       New_Call_Name   : Node_Id;
 655       New_Params      : List_Id := No_List;
 656       Param           : Node_Id;
 657       Res_Typ         : Entity_Id;
 658       Subp_Ptr_Typ    : Entity_Id;
 659       Subp_Typ        : Entity_Id;
 660       Typ             : Entity_Id;
 661       Eq_Prim_Op      : Entity_Id := Empty;
 662       Controlling_Tag : Node_Id;
 663
 664       procedure Build_Class_Wide_Check;
 665       --  If the denoted subprogram has a class-wide precondition, generate a
 666       --  check using that precondition before the dispatching call, because
 667       --  this is the only class-wide precondition that applies to the call.
 668
 669       function New_Value (From : Node_Id) return Node_Id;
 670       --  From is the original Expression. New_Value is equivalent to a call
 671       --  to Duplicate_Subexpr with an explicit dereference when From is an
 672       --  access parameter.
 673
 674       ----------------------------
 675       -- Build_Class_Wide_Check --
 676       ----------------------------
 677
 678       procedure Build_Class_Wide_Check is
 679          function Replace_Formals (N : Node_Id) return Traverse_Result;
 680          --  Replace occurrences of the formals of the subprogram by the
 681          --  corresponding actuals in the call, given that this check is
 682          --  performed outside of the body of the subprogram.
 683
 684          ---------------------
 685          -- Replace_Formals --
 686          ---------------------
 687
 688          function Replace_Formals (N : Node_Id) return Traverse_Result is
 689          begin
 690             if Is_Entity_Name (N)
 691               and then Present (Entity (N))
 692               and then Is_Formal (Entity (N))
 693             then
 694                declare
 695                   A : Node_Id;
 696                   F : Entity_Id;
 697
 698                begin
 699                   F := First_Formal (Subp);
 700                   A := First_Actual (Call_Node);
 701                   while Present (F) loop
 702                      if F = Entity (N) then
 703                         Rewrite (N, New_Copy_Tree (A));
 704
 705                         --  If the formal is class-wide, and thus not a
 706                         --  controlling argument, preserve its type because
 707                         --  it may appear in a nested call with a class-wide
 708                         --  parameter.
 709
 710                         if Is_Class_Wide_Type (Etype (F)) then
 711                            Set_Etype (N, Etype (F));
 712                         end if;
 713
 714                         exit;
 715                      end if;
 716
 717                      Next_Formal (F);
 718                      Next_Actual (A);
 719                   end loop;
 720                end;
 721             end if;
 722
 723             return OK;
 724          end Replace_Formals;
 725
 726          procedure Update is new Traverse_Proc (Replace_Formals);
 727
 728          --  Local variables
 729
 730          Str_Loc : constant String := Build_Location_String (Loc);
 731
 732          Cond : Node_Id;
 733          Msg  : Node_Id;
 734          Prec : Node_Id;
 735
 736       --  Start of processing for Build_Class_Wide_Check
 737
 738       begin
 739
 740          --  Locate class-wide precondition, if any
 741
 742          if Present (Contract (Subp))
 743            and then Present (Pre_Post_Conditions (Contract (Subp)))
 744          then
 745             Prec := Pre_Post_Conditions (Contract (Subp));
 746
 747             while Present (Prec) loop
 748                exit when Pragma_Name (Prec) = Name_Precondition
 749                  and then Class_Present (Prec);
 750                Prec := Next_Pragma (Prec);
 751             end loop;
 752
 753             if No (Prec) then
 754                return;
 755             end if;
 756
 757             --  The expression for the precondition is analyzed within the
 758             --  generated pragma. The message text is the last parameter of
 759             --  the generated pragma, indicating source of precondition.
 760
 761             Cond :=
 762               New_Copy_Tree
 763                 (Expression (First (Pragma_Argument_Associations (Prec))));
 764             Update (Cond);
 765
 766             --  Build message indicating the failed precondition and the
 767             --  dispatching call that caused it.
 768
 769             Msg := Expression (Last (Pragma_Argument_Associations (Prec)));
 770             Name_Len := 0;
 771             Append (Global_Name_Buffer, Strval (Msg));
 772             Append (Global_Name_Buffer, " in dispatching call at ");
 773             Append (Global_Name_Buffer, Str_Loc);
 774             Msg := Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len));
 775
 776             Insert_Action (Call_Node,
 777               Make_If_Statement (Loc,
 778                 Condition       => Make_Op_Not (Loc, Cond),
 779                 Then_Statements => New_List (
 780                   Make_Procedure_Call_Statement (Loc,
 781                     Name                   =>
 782                       New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc),
 783                     Parameter_Associations => New_List (Msg)))));
 784          end if;
 785       end Build_Class_Wide_Check;
 786
 787       ---------------
 788       -- New_Value --
 789       ---------------
 790
 791       function New_Value (From : Node_Id) return Node_Id is
 792          Res : constant Node_Id := Duplicate_Subexpr (From);
 793       begin
 794          if Is_Access_Type (Etype (From)) then
 795             return
 796               Make_Explicit_Dereference (Sloc (From),
 797                 Prefix => Res);
 798          else
 799             return Res;
 800          end if;
 801       end New_Value;
 802
 803       --  Local variables
 804
 805       New_Node          : Node_Id;
 806       SCIL_Node         : Node_Id := Empty;
 807       SCIL_Related_Node : Node_Id := Call_Node;
 808
 809    --  Start of processing for Expand_Dispatching_Call
 810
 811    begin
 812       if No_Run_Time_Mode then
 813          Error_Msg_CRT ("tagged types", Call_Node);
 814          return;
 815       end if;
 816
 817       --  Expand_Dispatching_Call is called directly from the semantics, so we
 818       --  only proceed if the expander is active.
 819
 820       if not Expander_Active
 821
 822         --  And there is no need to expand the call if we are compiling under
 823         --  restriction No_Dispatching_Calls; the semantic analyzer has
 824         --  previously notified the violation of this restriction.
 825
 826         or else Restriction_Active (No_Dispatching_Calls)
 827
 828         --  No action needed if the dispatching call has been already expanded
 829
 830         or else Is_Expanded_Dispatching_Call (Name (Call_Node))
 831       then
 832          return;
 833       end if;
 834
 835       --  Set subprogram. If this is an inherited operation that was
 836       --  overridden, the body that is being called is its alias.
 837
 838       Subp := Entity (Name (Call_Node));
 839
 840       if Present (Alias (Subp))
 841         and then Is_Inherited_Operation (Subp)
 842         and then No (DTC_Entity (Subp))
 843       then
 844          Subp := Alias (Subp);
 845       end if;
 846
 847       Build_Class_Wide_Check;
 848
 849       --  Definition of the class-wide type and the tagged type
 850
 851       --  If the controlling argument is itself a tag rather than a tagged
 852       --  object, then use the class-wide type associated with the subprogram's
 853       --  controlling type. This case can occur when a call to an inherited
 854       --  primitive has an actual that originated from a default parameter
 855       --  given by a tag-indeterminate call and when there is no other
 856       --  controlling argument providing the tag (AI-239 requires dispatching).
 857       --  This capability of dispatching directly by tag is also needed by the
 858       --  implementation of AI-260 (for the generic dispatching constructors).
 859
 860       if Ctrl_Typ = RTE (RE_Tag)
 861         or else (RTE_Available (RE_Interface_Tag)
 862                   and then Ctrl_Typ = RTE (RE_Interface_Tag))
 863       then
 864          CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp));
 865
 866       --  Class_Wide_Type is applied to the expressions used to initialize
 867       --  CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
 868       --  there are cases where the controlling type is resolved to a specific
 869       --  type (such as for designated types of arguments such as CW'Access).
 870
 871       elsif Is_Access_Type (Ctrl_Typ) then
 872          CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ));
 873
 874       else
 875          CW_Typ := Class_Wide_Type (Ctrl_Typ);
 876       end if;
 877
 878       Typ := Find_Specific_Type (CW_Typ);
 879
 880       if not Is_Limited_Type (Typ) then
 881          Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
 882       end if;
 883
 884       --  Dispatching call to C++ primitive. Create a new parameter list
 885       --  with no tag checks.
 886
 887       New_Params := New_List;
 888
 889       if Is_CPP_Class (Typ) then
 890          Param := First_Actual (Call_Node);
 891          while Present (Param) loop
 892             Append_To (New_Params, Relocate_Node (Param));
 893             Next_Actual (Param);
 894          end loop;
 895
 896       --  Dispatching call to Ada primitive
 897
 898       elsif Present (Param_List) then
 899          Apply_Tag_Checks (Call_Node);
 900
 901          Param := First_Actual (Call_Node);
 902          while Present (Param) loop
 903
 904             --  Cases in which we may have generated run-time checks. Note that
 905             --  we strip any qualification from Param before comparing with the
 906             --  already-stripped controlling argument.
 907
 908             if Unqualify (Param) = Ctrl_Arg or else Subp = Eq_Prim_Op then
 909                Append_To (New_Params,
 910                  Duplicate_Subexpr_Move_Checks (Param));
 911
 912             elsif Nkind (Parent (Param)) /= N_Parameter_Association
 913               or else not Is_Accessibility_Actual (Parent (Param))
 914             then
 915                Append_To (New_Params, Relocate_Node (Param));
 916             end if;
 917
 918             Next_Actual (Param);
 919          end loop;
 920       end if;
 921
 922       --  Generate the appropriate subprogram pointer type
 923
 924       if Etype (Subp) = Typ then
 925          Res_Typ := CW_Typ;
 926       else
 927          Res_Typ := Etype (Subp);
 928       end if;
 929
 930       Subp_Typ     := Create_Itype (E_Subprogram_Type, Call_Node);
 931       Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node);
 932       Set_Etype          (Subp_Typ, Res_Typ);
 933       Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
 934       Set_Convention     (Subp_Typ, Convention (Subp));
 935
 936       --  Notify gigi that the designated type is a dispatching primitive
 937
 938       Set_Is_Dispatch_Table_Entity (Subp_Typ);
 939
 940       --  Create a new list of parameters which is a copy of the old formal
 941       --  list including the creation of a new set of matching entities.
 942
 943       declare
 944          Old_Formal : Entity_Id := First_Formal (Subp);
 945          New_Formal : Entity_Id;
 946          Extra      : Entity_Id := Empty;
 947
 948       begin
 949          if Present (Old_Formal) then
 950             New_Formal := New_Copy (Old_Formal);
 951             Set_First_Entity (Subp_Typ, New_Formal);
 952             Param := First_Actual (Call_Node);
 953
 954             loop
 955                Set_Scope (New_Formal, Subp_Typ);
 956
 957                --  Change all the controlling argument types to be class-wide
 958                --  to avoid a recursion in dispatching.
 959
 960                if Is_Controlling_Formal (New_Formal) then
 961                   Set_Etype (New_Formal, Etype (Param));
 962                end if;
 963
 964                --  If the type of the formal is an itype, there was code here
 965                --  introduced in 1998 in revision 1.46, to create a new itype
 966                --  by copy. This seems useless, and in fact leads to semantic
 967                --  errors when the itype is the completion of a type derived
 968                --  from a private type.
 969
 970                Extra := New_Formal;
 971                Next_Formal (Old_Formal);
 972                exit when No (Old_Formal);
 973
 974                Set_Next_Entity (New_Formal, New_Copy (Old_Formal));
 975                Next_Entity (New_Formal);
 976                Next_Actual (Param);
 977             end loop;
 978
 979             Set_Next_Entity (New_Formal, Empty);
 980             Set_Last_Entity (Subp_Typ, Extra);
 981          end if;
 982
 983          --  Now that the explicit formals have been duplicated, any extra
 984          --  formals needed by the subprogram must be created.
 985
 986          if Present (Extra) then
 987             Set_Extra_Formal (Extra, Empty);
 988          end if;
 989
 990          Create_Extra_Formals (Subp_Typ);
 991       end;
 992
 993       --  Complete description of pointer type, including size information, as
 994       --  must be done with itypes to prevent order-of-elaboration anomalies
 995       --  in gigi.
 996
 997       Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
 998       Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);
 999       Set_Convention (Subp_Ptr_Typ, Convention (Subp_Typ));
1000       Layout_Type    (Subp_Ptr_Typ);
1001
1002       --  If the controlling argument is a value of type Ada.Tag or an abstract
1003       --  interface class-wide type then use it directly. Otherwise, the tag
1004       --  must be extracted from the controlling object.
1005
1006       if Ctrl_Typ = RTE (RE_Tag)
1007         or else (RTE_Available (RE_Interface_Tag)
1008                   and then Ctrl_Typ = RTE (RE_Interface_Tag))
1009       then
1010          Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
1011
1012       --  Extract the tag from an unchecked type conversion. Done to avoid
1013       --  the expansion of additional code just to obtain the value of such
1014       --  tag because the current management of interface type conversions
1015       --  generates in some cases this unchecked type conversion with the
1016       --  tag of the object (see Expand_Interface_Conversion).
1017
1018       elsif Nkind (Ctrl_Arg) = N_Unchecked_Type_Conversion
1019         and then
1020           (Etype (Expression (Ctrl_Arg)) = RTE (RE_Tag)
1021             or else
1022               (RTE_Available (RE_Interface_Tag)
1023                 and then
1024                   Etype (Expression (Ctrl_Arg)) = RTE (RE_Interface_Tag)))
1025       then
1026          Controlling_Tag := Duplicate_Subexpr (Expression (Ctrl_Arg));
1027
1028       --  Ada 2005 (AI-251): Abstract interface class-wide type
1029
1030       elsif Is_Interface (Ctrl_Typ)
1031         and then Is_Class_Wide_Type (Ctrl_Typ)
1032       then
1033          Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
1034
1035       else
1036          Controlling_Tag :=
1037            Make_Selected_Component (Loc,
1038              Prefix        => Duplicate_Subexpr_Move_Checks (Ctrl_Arg),
1039              Selector_Name => New_Occurrence_Of (DTC_Entity (Subp), Loc));
1040       end if;
1041
1042       --  Handle dispatching calls to predefined primitives
1043
1044       if Is_Predefined_Dispatching_Operation (Subp)
1045         or else Is_Predefined_Dispatching_Alias (Subp)
1046       then
1047          Build_Get_Predefined_Prim_Op_Address (Loc,
1048            Tag_Node => Controlling_Tag,
1049            Position => DT_Position (Subp),
1050            New_Node => New_Node);
1051
1052       --  Handle dispatching calls to user-defined primitives
1053
1054       else
1055          Build_Get_Prim_Op_Address (Loc,
1056            Typ      => Underlying_Type (Find_Dispatching_Type (Subp)),
1057            Tag_Node => Controlling_Tag,
1058            Position => DT_Position (Subp),
1059            New_Node => New_Node);
1060       end if;
1061
1062       New_Call_Name :=
1063         Unchecked_Convert_To (Subp_Ptr_Typ, New_Node);
1064
1065       --  Generate the SCIL node for this dispatching call. Done now because
1066       --  attribute SCIL_Controlling_Tag must be set after the new call name
1067       --  is built to reference the nodes that will see the SCIL backend
1068       --  (because Build_Get_Prim_Op_Address generates an unchecked type
1069       --  conversion which relocates the controlling tag node).
1070
1071       if Generate_SCIL then
1072          SCIL_Node := Make_SCIL_Dispatching_Call (Sloc (Call_Node));
1073          Set_SCIL_Entity      (SCIL_Node, Typ);
1074          Set_SCIL_Target_Prim (SCIL_Node, Subp);
1075
1076          --  Common case: the controlling tag is the tag of an object
1077          --  (for example, obj.tag)
1078
1079          if Nkind (Controlling_Tag) = N_Selected_Component then
1080             Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag);
1081
1082          --  Handle renaming of selected component
1083
1084          elsif Nkind (Controlling_Tag) = N_Identifier
1085            and then Nkind (Parent (Entity (Controlling_Tag))) =
1086                                              N_Object_Renaming_Declaration
1087            and then Nkind (Name (Parent (Entity (Controlling_Tag)))) =
1088                                              N_Selected_Component
1089          then
1090             Set_SCIL_Controlling_Tag (SCIL_Node,
1091               Name (Parent (Entity (Controlling_Tag))));
1092
1093          --  If the controlling tag is an identifier, the SCIL node references
1094          --  the corresponding object or parameter declaration
1095
1096          elsif Nkind (Controlling_Tag) = N_Identifier
1097            and then Nkind_In (Parent (Entity (Controlling_Tag)),
1098                               N_Object_Declaration,
1099                               N_Parameter_Specification)
1100          then
1101             Set_SCIL_Controlling_Tag (SCIL_Node,
1102               Parent (Entity (Controlling_Tag)));
1103
1104          --  If the controlling tag is a dereference, the SCIL node references
1105          --  the corresponding object or parameter declaration
1106
1107          elsif Nkind (Controlling_Tag) = N_Explicit_Dereference
1108             and then Nkind (Prefix (Controlling_Tag)) = N_Identifier
1109             and then Nkind_In (Parent (Entity (Prefix (Controlling_Tag))),
1110                                N_Object_Declaration,
1111                                N_Parameter_Specification)
1112          then
1113             Set_SCIL_Controlling_Tag (SCIL_Node,
1114               Parent (Entity (Prefix (Controlling_Tag))));
1115
1116          --  For a direct reference of the tag of the type the SCIL node
1117          --  references the internal object declaration containing the tag
1118          --  of the type.
1119
1120          elsif Nkind (Controlling_Tag) = N_Attribute_Reference
1121             and then Attribute_Name (Controlling_Tag) = Name_Tag
1122          then
1123             Set_SCIL_Controlling_Tag (SCIL_Node,
1124               Parent
1125                 (Node
1126                   (First_Elmt
1127                     (Access_Disp_Table (Entity (Prefix (Controlling_Tag)))))));
1128
1129          --  Interfaces are not supported. For now we leave the SCIL node
1130          --  decorated with the Controlling_Tag. More work needed here???
1131
1132          elsif Is_Interface (Etype (Controlling_Tag)) then
1133             Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag);
1134
1135          else
1136             pragma Assert (False);
1137             null;
1138          end if;
1139       end if;
1140
1141       if Nkind (Call_Node) = N_Function_Call then
1142          New_Call :=
1143            Make_Function_Call (Loc,
1144              Name                   => New_Call_Name,
1145              Parameter_Associations => New_Params);
1146
1147          --  If this is a dispatching "=", we must first compare the tags so
1148          --  we generate: x.tag = y.tag and then x = y
1149
1150          if Subp = Eq_Prim_Op then
1151             Param := First_Actual (Call_Node);
1152             New_Call :=
1153               Make_And_Then (Loc,
1154                 Left_Opnd =>
1155                      Make_Op_Eq (Loc,
1156                        Left_Opnd =>
1157                          Make_Selected_Component (Loc,
1158                            Prefix        => New_Value (Param),
1159                            Selector_Name =>
1160                              New_Occurrence_Of (First_Tag_Component (Typ),
1161                                                Loc)),
1162
1163                        Right_Opnd =>
1164                          Make_Selected_Component (Loc,
1165                            Prefix        =>
1166                              Unchecked_Convert_To (Typ,
1167                                New_Value (Next_Actual (Param))),
1168                            Selector_Name =>
1169                              New_Occurrence_Of
1170                                (First_Tag_Component (Typ), Loc))),
1171                 Right_Opnd => New_Call);
1172
1173             SCIL_Related_Node := Right_Opnd (New_Call);
1174          end if;
1175
1176       else
1177          New_Call :=
1178            Make_Procedure_Call_Statement (Loc,
1179              Name                   => New_Call_Name,
1180              Parameter_Associations => New_Params);
1181       end if;
1182
1183       --  Register the dispatching call in the call graph nodes table
1184
1185       Register_CG_Node (Call_Node);
1186
1187       Rewrite (Call_Node, New_Call);
1188
1189       --  Associate the SCIL node of this dispatching call
1190
1191       if Generate_SCIL then
1192          Set_SCIL_Node (SCIL_Related_Node, SCIL_Node);
1193       end if;
1194
1195       --  Suppress all checks during the analysis of the expanded code to avoid
1196       --  the generation of spurious warnings under ZFP run-time.
1197
1198       Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks);
1199    end Expand_Dispatching_Call;
1200
1201    ---------------------------------
1202    -- Expand_Interface_Conversion --
1203    ---------------------------------
1204
1205    procedure Expand_Interface_Conversion (N : Node_Id) is
1206       function Underlying_Record_Type (Typ : Entity_Id) return Entity_Id;
1207       --  Return the underlying record type of Typ
1208
1209       ----------------------------
1210       -- Underlying_Record_Type --
1211       ----------------------------
1212
1213       function Underlying_Record_Type (Typ : Entity_Id) return Entity_Id is
1214          E : Entity_Id := Typ;
1215
1216       begin
1217          --  Handle access types
1218
1219          if Is_Access_Type (E) then
1220             E := Directly_Designated_Type (E);
1221          end if;
1222
1223          --  Handle class-wide types. This conversion can appear explicitly in
1224          --  the source code. Example: I'Class (Obj)
1225
1226          if Is_Class_Wide_Type (E) then
1227             E := Root_Type (E);
1228          end if;
1229
1230          --  If the target type is a tagged synchronized type, the dispatch
1231          --  table info is in the corresponding record type.
1232
1233          if Is_Concurrent_Type (E) then
1234             E := Corresponding_Record_Type (E);
1235          end if;
1236
1237          --  Handle private types
1238
1239          E := Underlying_Type (E);
1240
1241          --  Handle subtypes
1242
1243          return Base_Type (E);
1244       end Underlying_Record_Type;
1245
1246       --  Local variables
1247
1248       Loc         : constant Source_Ptr := Sloc (N);
1249       Etyp        : constant Entity_Id  := Etype (N);
1250       Operand     : constant Node_Id    := Expression (N);
1251       Operand_Typ : Entity_Id           := Etype (Operand);
1252       Func        : Node_Id;
1253       Iface_Typ   : constant Entity_Id  := Underlying_Record_Type (Etype (N));
1254       Iface_Tag   : Entity_Id;
1255       Is_Static   : Boolean;
1256
1257    --  Start of processing for Expand_Interface_Conversion
1258
1259    begin
1260       --  Freeze the entity associated with the target interface to have
1261       --  available the attribute Access_Disp_Table.
1262
1263       Freeze_Before (N, Iface_Typ);
1264
1265       --  Ada 2005 (AI-345): Handle synchronized interface type derivations
1266
1267       if Is_Concurrent_Type (Operand_Typ) then
1268          Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ));
1269       end if;
1270
1271       --  No displacement of the pointer to the object needed when the type of
1272       --  the operand is not an interface type and the interface is one of
1273       --  its parent types (since they share the primary dispatch table).
1274
1275       declare
1276          Opnd : Entity_Id := Operand_Typ;
1277
1278       begin
1279          if Is_Access_Type (Opnd) then
1280             Opnd := Designated_Type (Opnd);
1281          end if;
1282
1283          if not Is_Interface (Opnd)
1284            and then Is_Ancestor (Iface_Typ, Opnd, Use_Full_View => True)
1285          then
1286             return;
1287          end if;
1288       end;
1289
1290       --  Evaluate if we can statically displace the pointer to the object
1291
1292       declare
1293          Opnd_Typ : constant Node_Id := Underlying_Record_Type (Operand_Typ);
1294
1295       begin
1296          Is_Static :=
1297             not Is_Interface (Opnd_Typ)
1298               and then Interface_Present_In_Ancestor
1299                          (Typ   => Opnd_Typ,
1300                           Iface => Iface_Typ)
1301               and then (Etype (Opnd_Typ) = Opnd_Typ
1302                          or else not
1303                            Is_Variable_Size_Record (Etype (Opnd_Typ)));
1304       end;
1305
1306       if not Tagged_Type_Expansion then
1307          return;
1308
1309       --  A static conversion to an interface type that is not class-wide is
1310       --  curious but legal if the interface operation is a null procedure.
1311       --  If the operation is abstract it will be rejected later.
1312
1313       elsif Is_Static
1314         and then Is_Interface (Etype (N))
1315         and then not Is_Class_Wide_Type (Etype (N))
1316         and then Comes_From_Source (N)
1317       then
1318          Rewrite (N, Unchecked_Convert_To (Etype (N), N));
1319          Analyze (N);
1320          return;
1321       end if;
1322
1323       if not Is_Static then
1324
1325          --  Give error if configurable run-time and Displace not available
1326
1327          if not RTE_Available (RE_Displace) then
1328             Error_Msg_CRT ("dynamic interface conversion", N);
1329             return;
1330          end if;
1331
1332          --  Handle conversion of access-to-class-wide interface types. Target
1333          --  can be an access to an object or an access to another class-wide
1334          --  interface (see -1- and -2- in the following example):
1335
1336          --     type Iface1_Ref is access all Iface1'Class;
1337          --     type Iface2_Ref is access all Iface1'Class;
1338
1339          --     Acc1 : Iface1_Ref := new ...
1340          --     Obj  : Obj_Ref    := Obj_Ref (Acc);    -- 1
1341          --     Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2
1342
1343          if Is_Access_Type (Operand_Typ) then
1344             Rewrite (N,
1345               Unchecked_Convert_To (Etype (N),
1346                 Make_Function_Call (Loc,
1347                   Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
1348                   Parameter_Associations => New_List (
1349
1350                     Unchecked_Convert_To (RTE (RE_Address),
1351                       Relocate_Node (Expression (N))),
1352
1353                     New_Occurrence_Of
1354                       (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
1355                        Loc)))));
1356
1357             Analyze (N);
1358             return;
1359          end if;
1360
1361          Rewrite (N,
1362            Make_Function_Call (Loc,
1363              Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
1364              Parameter_Associations => New_List (
1365                Make_Attribute_Reference (Loc,
1366                  Prefix => Relocate_Node (Expression (N)),
1367                  Attribute_Name => Name_Address),
1368
1369                New_Occurrence_Of
1370                  (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
1371                   Loc))));
1372
1373          Analyze (N);
1374
1375          --  If target is a class-wide interface, change the type of the data
1376          --  returned by IW_Convert to indicate this is a dispatching call.
1377
1378          declare
1379             New_Itype : Entity_Id;
1380
1381          begin
1382             New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
1383             Set_Etype (New_Itype, New_Itype);
1384             Set_Directly_Designated_Type (New_Itype, Etyp);
1385
1386             Rewrite (N,
1387               Make_Explicit_Dereference (Loc,
1388                 Prefix =>
1389                   Unchecked_Convert_To (New_Itype, Relocate_Node (N))));
1390             Analyze (N);
1391             Freeze_Itype (New_Itype, N);
1392
1393             return;
1394          end;
1395       end if;
1396
1397       Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ);
1398       pragma Assert (Iface_Tag /= Empty);
1399
1400       --  Keep separate access types to interfaces because one internal
1401       --  function is used to handle the null value (see following comments)
1402
1403       if not Is_Access_Type (Etype (N)) then
1404
1405          --  Statically displace the pointer to the object to reference the
1406          --  component containing the secondary dispatch table.
1407
1408          Rewrite (N,
1409            Convert_Tag_To_Interface (Class_Wide_Type (Iface_Typ),
1410              Make_Selected_Component (Loc,
1411                Prefix => Relocate_Node (Expression (N)),
1412                Selector_Name => New_Occurrence_Of (Iface_Tag, Loc))));
1413
1414       else
1415          --  Build internal function to handle the case in which the actual is
1416          --  null. If the actual is null returns null because no displacement
1417          --  is required; otherwise performs a type conversion that will be
1418          --  expanded in the code that returns the value of the displaced
1419          --  actual. That is:
1420
1421          --     function Func (O : Address) return Iface_Typ is
1422          --        type Op_Typ is access all Operand_Typ;
1423          --        Aux : Op_Typ := To_Op_Typ (O);
1424          --     begin
1425          --        if O = Null_Address then
1426          --           return null;
1427          --        else
1428          --           return Iface_Typ!(Aux.Iface_Tag'Address);
1429          --        end if;
1430          --     end Func;
1431
1432          declare
1433             Desig_Typ    : Entity_Id;
1434             Fent         : Entity_Id;
1435             New_Typ_Decl : Node_Id;
1436             Stats        : List_Id;
1437
1438          begin
1439             Desig_Typ := Etype (Expression (N));
1440
1441             if Is_Access_Type (Desig_Typ) then
1442                Desig_Typ :=
1443                  Available_View (Directly_Designated_Type (Desig_Typ));
1444             end if;
1445
1446             if Is_Concurrent_Type (Desig_Typ) then
1447                Desig_Typ := Base_Type (Corresponding_Record_Type (Desig_Typ));
1448             end if;
1449
1450             New_Typ_Decl :=
1451               Make_Full_Type_Declaration (Loc,
1452                 Defining_Identifier => Make_Temporary (Loc, 'T'),
1453                 Type_Definition =>
1454                   Make_Access_To_Object_Definition (Loc,
1455                     All_Present            => True,
1456                     Null_Exclusion_Present => False,
1457                     Constant_Present       => False,
1458                     Subtype_Indication     =>
1459                       New_Occurrence_Of (Desig_Typ, Loc)));
1460
1461             Stats := New_List (
1462               Make_Simple_Return_Statement (Loc,
1463                 Unchecked_Convert_To (Etype (N),
1464                   Make_Attribute_Reference (Loc,
1465                     Prefix         =>
1466                       Make_Selected_Component (Loc,
1467                         Prefix        =>
1468                           Unchecked_Convert_To
1469                             (Defining_Identifier (New_Typ_Decl),
1470                              Make_Identifier (Loc, Name_uO)),
1471                         Selector_Name =>
1472                           New_Occurrence_Of (Iface_Tag, Loc)),
1473                     Attribute_Name => Name_Address))));
1474
1475             --  If the type is null-excluding, no need for the null branch.
1476             --  Otherwise we need to check for it and return null.
1477
1478             if not Can_Never_Be_Null (Etype (N)) then
1479                Stats := New_List (
1480                  Make_If_Statement (Loc,
1481                   Condition       =>
1482                     Make_Op_Eq (Loc,
1483                        Left_Opnd  => Make_Identifier (Loc, Name_uO),
1484                        Right_Opnd => New_Occurrence_Of
1485                                        (RTE (RE_Null_Address), Loc)),
1486
1487                  Then_Statements => New_List (
1488                    Make_Simple_Return_Statement (Loc, Make_Null (Loc))),
1489                  Else_Statements => Stats));
1490             end if;
1491
1492             Fent := Make_Temporary (Loc, 'F');
1493             Func :=
1494               Make_Subprogram_Body (Loc,
1495                 Specification =>
1496                   Make_Function_Specification (Loc,
1497                     Defining_Unit_Name => Fent,
1498
1499                     Parameter_Specifications => New_List (
1500                       Make_Parameter_Specification (Loc,
1501                         Defining_Identifier =>
1502                           Make_Defining_Identifier (Loc, Name_uO),
1503                         Parameter_Type =>
1504                           New_Occurrence_Of (RTE (RE_Address), Loc))),
1505
1506                     Result_Definition =>
1507                       New_Occurrence_Of (Etype (N), Loc)),
1508
1509                 Declarations => New_List (New_Typ_Decl),
1510
1511                 Handled_Statement_Sequence =>
1512                   Make_Handled_Sequence_Of_Statements (Loc, Stats));
1513
1514             --  Place function body before the expression containing the
1515             --  conversion. We suppress all checks because the body of the
1516             --  internally generated function already takes care of the case
1517             --  in which the actual is null; therefore there is no need to
1518             --  double check that the pointer is not null when the program
1519             --  executes the alternative that performs the type conversion).
1520
1521             Insert_Action (N, Func, Suppress => All_Checks);
1522
1523             if Is_Access_Type (Etype (Expression (N))) then
1524
1525                --  Generate: Func (Address!(Expression))
1526
1527                Rewrite (N,
1528                  Make_Function_Call (Loc,
1529                    Name                   => New_Occurrence_Of (Fent, Loc),
1530                    Parameter_Associations => New_List (
1531                      Unchecked_Convert_To (RTE (RE_Address),
1532                        Relocate_Node (Expression (N))))));
1533
1534             else
1535                --  Generate: Func (Operand_Typ!(Expression)'Address)
1536
1537                Rewrite (N,
1538                  Make_Function_Call (Loc,
1539                    Name                   => New_Occurrence_Of (Fent, Loc),
1540                    Parameter_Associations => New_List (
1541                      Make_Attribute_Reference (Loc,
1542                        Prefix  => Unchecked_Convert_To (Operand_Typ,
1543                                     Relocate_Node (Expression (N))),
1544                        Attribute_Name => Name_Address))));
1545             end if;
1546          end;
1547       end if;
1548
1549       Analyze (N);
1550    end Expand_Interface_Conversion;
1551
1552    ------------------------------
1553    -- Expand_Interface_Actuals --
1554    ------------------------------
1555
1556    procedure Expand_Interface_Actuals (Call_Node : Node_Id) is
1557       Actual     : Node_Id;
1558       Actual_Dup : Node_Id;
1559       Actual_Typ : Entity_Id;
1560       Anon       : Entity_Id;
1561       Conversion : Node_Id;
1562       Formal     : Entity_Id;
1563       Formal_Typ : Entity_Id;
1564       Subp       : Entity_Id;
1565       Formal_DDT : Entity_Id := Empty;  -- initialize to prevent warning
1566       Actual_DDT : Entity_Id := Empty;  -- initialize to prevent warning
1567
1568    begin
1569       --  This subprogram is called directly from the semantics, so we need a
1570       --  check to see whether expansion is active before proceeding.
1571
1572       if not Expander_Active then
1573          return;
1574       end if;
1575
1576       --  Call using access to subprogram with explicit dereference
1577
1578       if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
1579          Subp := Etype (Name (Call_Node));
1580
1581       --  Call using selected component
1582
1583       elsif Nkind (Name (Call_Node)) = N_Selected_Component then
1584          Subp := Entity (Selector_Name (Name (Call_Node)));
1585
1586       --  Call using direct name
1587
1588       else
1589          Subp := Entity (Name (Call_Node));
1590       end if;
1591
1592       --  Ada 2005 (AI-251): Look for interface type formals to force "this"
1593       --  displacement
1594
1595       Formal := First_Formal (Subp);
1596       Actual := First_Actual (Call_Node);
1597       while Present (Formal) loop
1598          Formal_Typ := Etype (Formal);
1599
1600          if Ekind (Formal_Typ) = E_Record_Type_With_Private then
1601             Formal_Typ := Full_View (Formal_Typ);
1602          end if;
1603
1604          if Is_Access_Type (Formal_Typ) then
1605             Formal_DDT := Directly_Designated_Type (Formal_Typ);
1606          end if;
1607
1608          Actual_Typ := Etype (Actual);
1609
1610          if Is_Access_Type (Actual_Typ) then
1611             Actual_DDT := Directly_Designated_Type (Actual_Typ);
1612          end if;
1613
1614          if Is_Interface (Formal_Typ)
1615            and then Is_Class_Wide_Type (Formal_Typ)
1616          then
1617             --  No need to displace the pointer if the type of the actual
1618             --  coincides with the type of the formal.
1619
1620             if Actual_Typ = Formal_Typ then
1621                null;
1622
1623             --  No need to displace the pointer if the interface type is a
1624             --  parent of the type of the actual because in this case the
1625             --  interface primitives are located in the primary dispatch table.
1626
1627             elsif Is_Ancestor (Formal_Typ, Actual_Typ,
1628                                Use_Full_View => True)
1629             then
1630                null;
1631
1632             --  Implicit conversion to the class-wide formal type to force the
1633             --  displacement of the pointer.
1634
1635             else
1636                --  Normally, expansion of actuals for calls to build-in-place
1637                --  functions happens as part of Expand_Actuals, but in this
1638                --  case the call will be wrapped in a conversion and soon after
1639                --  expanded further to handle the displacement for a class-wide
1640                --  interface conversion, so if this is a BIP call then we need
1641                --  to handle it now.
1642
1643                if Ada_Version >= Ada_2005
1644                  and then Is_Build_In_Place_Function_Call (Actual)
1645                then
1646                   Make_Build_In_Place_Call_In_Anonymous_Context (Actual);
1647                end if;
1648
1649                Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual));
1650                Rewrite (Actual, Conversion);
1651                Analyze_And_Resolve (Actual, Formal_Typ);
1652             end if;
1653
1654          --  Access to class-wide interface type
1655
1656          elsif Is_Access_Type (Formal_Typ)
1657            and then Is_Interface (Formal_DDT)
1658            and then Is_Class_Wide_Type (Formal_DDT)
1659            and then Interface_Present_In_Ancestor
1660                       (Typ   => Actual_DDT,
1661                        Iface => Etype (Formal_DDT))
1662          then
1663             --  Handle attributes 'Access and 'Unchecked_Access
1664
1665             if Nkind (Actual) = N_Attribute_Reference
1666               and then
1667                (Attribute_Name (Actual) = Name_Access
1668                  or else Attribute_Name (Actual) = Name_Unchecked_Access)
1669             then
1670                --  This case must have been handled by the analysis and
1671                --  expansion of 'Access. The only exception is when types
1672                --  match and no further expansion is required.
1673
1674                pragma Assert (Base_Type (Etype (Prefix (Actual)))
1675                                = Base_Type (Formal_DDT));
1676                null;
1677
1678             --  No need to displace the pointer if the type of the actual
1679             --  coincides with the type of the formal.
1680
1681             elsif Actual_DDT = Formal_DDT then
1682                null;
1683
1684             --  No need to displace the pointer if the interface type is
1685             --  a parent of the type of the actual because in this case the
1686             --  interface primitives are located in the primary dispatch table.
1687
1688             elsif Is_Ancestor (Formal_DDT, Actual_DDT,
1689                                Use_Full_View => True)
1690             then
1691                null;
1692
1693             else
1694                Actual_Dup := Relocate_Node (Actual);
1695
1696                if From_Limited_With (Actual_Typ) then
1697
1698                   --  If the type of the actual parameter comes from a
1699                   --  limited with-clause and the non-limited view is already
1700                   --  available, we replace the anonymous access type by
1701                   --  a duplicate declaration whose designated type is the
1702                   --  non-limited view.
1703
1704                   if Has_Non_Limited_View (Actual_DDT) then
1705                      Anon := New_Copy (Actual_Typ);
1706
1707                      if Is_Itype (Anon) then
1708                         Set_Scope (Anon, Current_Scope);
1709                      end if;
1710
1711                      Set_Directly_Designated_Type
1712                        (Anon, Non_Limited_View (Actual_DDT));
1713                      Set_Etype (Actual_Dup, Anon);
1714                   end if;
1715                end if;
1716
1717                Conversion := Convert_To (Formal_Typ, Actual_Dup);
1718                Rewrite (Actual, Conversion);
1719                Analyze_And_Resolve (Actual, Formal_Typ);
1720             end if;
1721          end if;
1722
1723          Next_Actual (Actual);
1724          Next_Formal (Formal);
1725       end loop;
1726    end Expand_Interface_Actuals;
1727
1728    ----------------------------
1729    -- Expand_Interface_Thunk --
1730    ----------------------------
1731
1732    procedure Expand_Interface_Thunk
1733      (Prim       : Node_Id;
1734       Thunk_Id   : out Entity_Id;
1735       Thunk_Code : out Node_Id)
1736    is
1737       Loc     : constant Source_Ptr := Sloc (Prim);
1738       Actuals : constant List_Id    := New_List;
1739       Decl    : constant List_Id    := New_List;
1740       Formals : constant List_Id    := New_List;
1741       Target  : constant Entity_Id  := Ultimate_Alias (Prim);
1742
1743       Decl_1        : Node_Id;
1744       Decl_2        : Node_Id;
1745       Expr          : Node_Id;
1746       Formal        : Node_Id;
1747       Ftyp          : Entity_Id;
1748       Iface_Formal  : Node_Id := Empty;  -- initialize to prevent warning
1749       New_Arg       : Node_Id;
1750       Offset_To_Top : Node_Id;
1751       Target_Formal : Entity_Id;
1752
1753    begin
1754       Thunk_Id   := Empty;
1755       Thunk_Code := Empty;
1756
1757       --  No thunk needed if the primitive has been eliminated
1758
1759       if Is_Eliminated (Ultimate_Alias (Prim)) then
1760          return;
1761
1762       --  In case of primitives that are functions without formals and a
1763       --  controlling result there is no need to build the thunk.
1764
1765       elsif not Present (First_Formal (Target)) then
1766          pragma Assert (Ekind (Target) = E_Function
1767            and then Has_Controlling_Result (Target));
1768          return;
1769       end if;
1770
1771       --  Duplicate the formals of the Target primitive. In the thunk, the type
1772       --  of the controlling formal is the covered interface type (instead of
1773       --  the target tagged type). Done to avoid problems with discriminated
1774       --  tagged types because, if the controlling type has discriminants with
1775       --  default values, then the type conversions done inside the body of
1776       --  the thunk (after the displacement of the pointer to the base of the
1777       --  actual object) generate code that modify its contents.
1778
1779       --  Note: This special management is not done for predefined primitives
1780       --  because???
1781
1782       if not Is_Predefined_Dispatching_Operation (Prim) then
1783          Iface_Formal := First_Formal (Interface_Alias (Prim));
1784       end if;
1785
1786       Formal := First_Formal (Target);
1787       while Present (Formal) loop
1788          Ftyp := Etype (Formal);
1789
1790          --  Use the interface type as the type of the controlling formal (see
1791          --  comment above).
1792
1793          if not Is_Controlling_Formal (Formal)
1794            or else Is_Predefined_Dispatching_Operation (Prim)
1795          then
1796             Ftyp := Etype (Formal);
1797             Expr := New_Copy_Tree (Expression (Parent (Formal)));
1798          else
1799             Ftyp := Etype (Iface_Formal);
1800             Expr := Empty;
1801          end if;
1802
1803          Append_To (Formals,
1804            Make_Parameter_Specification (Loc,
1805              Defining_Identifier =>
1806                Make_Defining_Identifier (Sloc (Formal),
1807                  Chars => Chars (Formal)),
1808              In_Present => In_Present (Parent (Formal)),
1809              Out_Present => Out_Present (Parent (Formal)),
1810              Parameter_Type => New_Occurrence_Of (Ftyp, Loc),
1811              Expression => Expr));
1812
1813          if not Is_Predefined_Dispatching_Operation (Prim) then
1814             Next_Formal (Iface_Formal);
1815          end if;
1816
1817          Next_Formal (Formal);
1818       end loop;
1819
1820       Target_Formal := First_Formal (Target);
1821       Formal        := First (Formals);
1822       while Present (Formal) loop
1823
1824          --  If the parent is a constrained discriminated type, then the
1825          --  primitive operation will have been defined on a first subtype.
1826          --  For proper matching with controlling type, use base type.
1827
1828          if Ekind (Target_Formal) = E_In_Parameter
1829            and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
1830          then
1831             Ftyp :=
1832               Base_Type (Directly_Designated_Type (Etype (Target_Formal)));
1833          else
1834             Ftyp := Base_Type (Etype (Target_Formal));
1835          end if;
1836
1837          --  For concurrent types, the relevant information is found in the
1838          --  Corresponding_Record_Type, rather than the type entity itself.
1839
1840          if Is_Concurrent_Type (Ftyp) then
1841             Ftyp := Corresponding_Record_Type (Ftyp);
1842          end if;
1843
1844          if Ekind (Target_Formal) = E_In_Parameter
1845            and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
1846            and then Is_Controlling_Formal (Target_Formal)
1847          then
1848             --  Generate:
1849             --     type T is access all <<type of the target formal>>
1850             --     S : Storage_Offset := Storage_Offset!(Formal)
1851             --                            - Offset_To_Top (address!(Formal))
1852
1853             Decl_2 :=
1854               Make_Full_Type_Declaration (Loc,
1855                 Defining_Identifier => Make_Temporary (Loc, 'T'),
1856                 Type_Definition =>
1857                   Make_Access_To_Object_Definition (Loc,
1858                     All_Present            => True,
1859                     Null_Exclusion_Present => False,
1860                     Constant_Present       => False,
1861                     Subtype_Indication     =>
1862                       New_Occurrence_Of (Ftyp, Loc)));
1863
1864             New_Arg :=
1865               Unchecked_Convert_To (RTE (RE_Address),
1866                 New_Occurrence_Of (Defining_Identifier (Formal), Loc));
1867
1868             if not RTE_Available (RE_Offset_To_Top) then
1869                Offset_To_Top :=
1870                  Build_Offset_To_Top (Loc, New_Arg);
1871             else
1872                Offset_To_Top :=
1873                  Make_Function_Call (Loc,
1874                    Name => New_Occurrence_Of (RTE (RE_Offset_To_Top), Loc),
1875                    Parameter_Associations => New_List (New_Arg));
1876             end if;
1877
1878             Decl_1 :=
1879               Make_Object_Declaration (Loc,
1880                 Defining_Identifier => Make_Temporary (Loc, 'S'),
1881                 Constant_Present    => True,
1882                 Object_Definition   =>
1883                   New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
1884                 Expression          =>
1885                   Make_Op_Subtract (Loc,
1886                     Left_Opnd  =>
1887                       Unchecked_Convert_To
1888                         (RTE (RE_Storage_Offset),
1889                          New_Occurrence_Of
1890                            (Defining_Identifier (Formal), Loc)),
1891                      Right_Opnd =>
1892                        Offset_To_Top));
1893
1894             Append_To (Decl, Decl_2);
1895             Append_To (Decl, Decl_1);
1896
1897             --  Reference the new actual. Generate:
1898             --    T!(S)
1899
1900             Append_To (Actuals,
1901               Unchecked_Convert_To
1902                 (Defining_Identifier (Decl_2),
1903                  New_Occurrence_Of (Defining_Identifier (Decl_1), Loc)));
1904
1905          elsif Is_Controlling_Formal (Target_Formal) then
1906
1907             --  Generate:
1908             --     S1 : Storage_Offset := Storage_Offset!(Formal'Address)
1909             --                             - Offset_To_Top (Formal'Address)
1910             --     S2 : Addr_Ptr := Addr_Ptr!(S1)
1911
1912             New_Arg :=
1913               Make_Attribute_Reference (Loc,
1914                 Prefix =>
1915                   New_Occurrence_Of (Defining_Identifier (Formal), Loc),
1916                 Attribute_Name =>
1917                   Name_Address);
1918
1919             if not RTE_Available (RE_Offset_To_Top) then
1920                Offset_To_Top :=
1921                  Build_Offset_To_Top (Loc, New_Arg);
1922             else
1923                Offset_To_Top :=
1924                  Make_Function_Call (Loc,
1925                    Name => New_Occurrence_Of (RTE (RE_Offset_To_Top), Loc),
1926                    Parameter_Associations => New_List (New_Arg));
1927             end if;
1928
1929             Decl_1 :=
1930               Make_Object_Declaration (Loc,
1931                 Defining_Identifier => Make_Temporary (Loc, 'S'),
1932                 Constant_Present    => True,
1933                 Object_Definition   =>
1934                   New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
1935                 Expression          =>
1936                   Make_Op_Subtract (Loc,
1937                     Left_Opnd =>
1938                       Unchecked_Convert_To
1939                         (RTE (RE_Storage_Offset),
1940                          Make_Attribute_Reference (Loc,
1941                            Prefix =>
1942                              New_Occurrence_Of
1943                                (Defining_Identifier (Formal), Loc),
1944                            Attribute_Name => Name_Address)),
1945                     Right_Opnd =>
1946                       Offset_To_Top));
1947
1948             Decl_2 :=
1949               Make_Object_Declaration (Loc,
1950                 Defining_Identifier => Make_Temporary (Loc, 'S'),
1951                 Constant_Present    => True,
1952                 Object_Definition   =>
1953                   New_Occurrence_Of (RTE (RE_Addr_Ptr), Loc),
1954                 Expression          =>
1955                   Unchecked_Convert_To
1956                     (RTE (RE_Addr_Ptr),
1957                      New_Occurrence_Of (Defining_Identifier (Decl_1), Loc)));
1958
1959             Append_To (Decl, Decl_1);
1960             Append_To (Decl, Decl_2);
1961
1962             --  Reference the new actual, generate:
1963             --    Target_Formal (S2.all)
1964
1965             Append_To (Actuals,
1966               Unchecked_Convert_To (Ftyp,
1967                  Make_Explicit_Dereference (Loc,
1968                    New_Occurrence_Of (Defining_Identifier (Decl_2), Loc))));
1969
1970          --  Ensure proper matching of access types. Required to avoid
1971          --  reporting spurious errors.
1972
1973          elsif Is_Access_Type (Etype (Target_Formal)) then
1974             Append_To (Actuals,
1975               Unchecked_Convert_To (Base_Type (Etype (Target_Formal)),
1976                 New_Occurrence_Of (Defining_Identifier (Formal), Loc)));
1977
1978          --  No special management required for this actual
1979
1980          else
1981             Append_To (Actuals,
1982                New_Occurrence_Of (Defining_Identifier (Formal), Loc));
1983          end if;
1984
1985          Next_Formal (Target_Formal);
1986          Next (Formal);
1987       end loop;
1988
1989       Thunk_Id := Make_Temporary (Loc, 'T');
1990       Set_Ekind (Thunk_Id, Ekind (Prim));
1991       Set_Is_Thunk (Thunk_Id);
1992       Set_Convention (Thunk_Id, Convention (Prim));
1993       Set_Thunk_Entity (Thunk_Id, Target);
1994
1995       --  Procedure case
1996
1997       if Ekind (Target) = E_Procedure then
1998          Thunk_Code :=
1999            Make_Subprogram_Body (Loc,
2000               Specification =>
2001                 Make_Procedure_Specification (Loc,
2002                   Defining_Unit_Name       => Thunk_Id,
2003                   Parameter_Specifications => Formals),
2004               Declarations => Decl,
2005               Handled_Statement_Sequence =>
2006                 Make_Handled_Sequence_Of_Statements (Loc,
2007                   Statements => New_List (
2008                     Make_Procedure_Call_Statement (Loc,
2009                       Name => New_Occurrence_Of (Target, Loc),
2010                       Parameter_Associations => Actuals))));
2011
2012       --  Function case
2013
2014       else pragma Assert (Ekind (Target) = E_Function);
2015          declare
2016             Result_Def : Node_Id;
2017             Call_Node  : Node_Id;
2018
2019          begin
2020             Call_Node :=
2021               Make_Function_Call (Loc,
2022                 Name                   => New_Occurrence_Of (Target, Loc),
2023                 Parameter_Associations => Actuals);
2024
2025             if not Is_Interface (Etype (Prim)) then
2026                Result_Def := New_Copy (Result_Definition (Parent (Target)));
2027
2028             --  Thunk of function returning a class-wide interface object. No
2029             --  extra displacement needed since the displacement is generated
2030             --  in the return statement of Prim. Example:
2031
2032             --    type Iface is interface ...
2033             --    function F (O : Iface) return Iface'Class;
2034
2035             --    type T is new ... and Iface with ...
2036             --    function F (O : T) return Iface'Class;
2037
2038             elsif Is_Class_Wide_Type (Etype (Prim)) then
2039                Result_Def := New_Occurrence_Of (Etype (Prim), Loc);
2040
2041             --  Thunk of function returning an interface object. Displacement
2042             --  needed. Example:
2043
2044             --    type Iface is interface ...
2045             --    function F (O : Iface) return Iface;
2046
2047             --    type T is new ... and Iface with ...
2048             --    function F (O : T) return T;
2049
2050             else
2051                Result_Def :=
2052                  New_Occurrence_Of (Class_Wide_Type (Etype (Prim)), Loc);
2053
2054                --  Adding implicit conversion to force the displacement of
2055                --  the pointer to the object to reference the corresponding
2056                --  secondary dispatch table.
2057
2058                Call_Node :=
2059                  Make_Type_Conversion (Loc,
2060                    Subtype_Mark =>
2061                      New_Occurrence_Of (Class_Wide_Type (Etype (Prim)), Loc),
2062                    Expression   => Relocate_Node (Call_Node));
2063             end if;
2064
2065             Thunk_Code :=
2066               Make_Subprogram_Body (Loc,
2067                 Specification              =>
2068                   Make_Function_Specification (Loc,
2069                     Defining_Unit_Name       => Thunk_Id,
2070                     Parameter_Specifications => Formals,
2071                     Result_Definition        => Result_Def),
2072                 Declarations               => Decl,
2073                 Handled_Statement_Sequence =>
2074                   Make_Handled_Sequence_Of_Statements (Loc,
2075                     Statements => New_List (
2076                       Make_Simple_Return_Statement (Loc, Call_Node))));
2077          end;
2078       end if;
2079    end Expand_Interface_Thunk;
2080
2081    --------------------------
2082    -- Has_CPP_Constructors --
2083    --------------------------
2084
2085    function Has_CPP_Constructors (Typ : Entity_Id) return Boolean is
2086       E : Entity_Id;
2087
2088    begin
2089       --  Look for the constructor entities
2090
2091       E := Next_Entity (Typ);
2092       while Present (E) loop
2093          if Ekind (E) = E_Function and then Is_Constructor (E) then
2094             return True;
2095          end if;
2096
2097          Next_Entity (E);
2098       end loop;
2099
2100       return False;
2101    end Has_CPP_Constructors;
2102
2103    ------------
2104    -- Has_DT --
2105    ------------
2106
2107    function Has_DT (Typ : Entity_Id) return Boolean is
2108    begin
2109       return not Is_Interface (Typ)
2110         and then not Restriction_Active (No_Dispatching_Calls);
2111    end Has_DT;
2112
2113    ----------------------------------
2114    -- Is_Expanded_Dispatching_Call --
2115    ----------------------------------
2116
2117    function Is_Expanded_Dispatching_Call (N : Node_Id) return Boolean is
2118    begin
2119       return Nkind (N) in N_Subprogram_Call
2120         and then Nkind (Name (N)) = N_Explicit_Dereference
2121         and then Is_Dispatch_Table_Entity (Etype (Name (N)));
2122    end Is_Expanded_Dispatching_Call;
2123
2124    -----------------------------------------
2125    -- Is_Predefined_Dispatching_Operation --
2126    -----------------------------------------
2127
2128    function Is_Predefined_Dispatching_Operation
2129      (E : Entity_Id) return Boolean
2130    is
2131       TSS_Name : TSS_Name_Type;
2132
2133    begin
2134       if not Is_Dispatching_Operation (E) then
2135          return False;
2136       end if;
2137
2138       Get_Name_String (Chars (E));
2139
2140       --  Most predefined primitives have internally generated names. Equality
2141       --  must be treated differently; the predefined operation is recognized
2142       --  as a homogeneous binary operator that returns Boolean.
2143
2144       if Name_Len > TSS_Name_Type'Last then
2145          TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
2146                                      .. Name_Len));
2147          if        Chars (E) = Name_uSize
2148            or else TSS_Name  = TSS_Stream_Read
2149            or else TSS_Name  = TSS_Stream_Write
2150            or else TSS_Name  = TSS_Stream_Input
2151            or else TSS_Name  = TSS_Stream_Output
2152            or else
2153              (Chars (E) = Name_Op_Eq
2154                 and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
2155            or else Chars (E) = Name_uAssign
2156            or else TSS_Name  = TSS_Deep_Adjust
2157            or else TSS_Name  = TSS_Deep_Finalize
2158            or else Is_Predefined_Interface_Primitive (E)
2159          then
2160             return True;
2161          end if;
2162       end if;
2163
2164       return False;
2165    end Is_Predefined_Dispatching_Operation;
2166
2167    ---------------------------------------
2168    -- Is_Predefined_Internal_Operation  --
2169    ---------------------------------------
2170
2171    function Is_Predefined_Internal_Operation
2172      (E : Entity_Id) return Boolean
2173    is
2174       TSS_Name : TSS_Name_Type;
2175
2176    begin
2177       if not Is_Dispatching_Operation (E) then
2178          return False;
2179       end if;
2180
2181       Get_Name_String (Chars (E));
2182
2183       --  Most predefined primitives have internally generated names. Equality
2184       --  must be treated differently; the predefined operation is recognized
2185       --  as a homogeneous binary operator that returns Boolean.
2186
2187       if Name_Len > TSS_Name_Type'Last then
2188          TSS_Name :=
2189            TSS_Name_Type
2190              (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
2191
2192          if Nam_In (Chars (E), Name_uSize, Name_uAssign)
2193            or else
2194              (Chars (E) = Name_Op_Eq
2195                and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
2196            or else TSS_Name  = TSS_Deep_Adjust
2197            or else TSS_Name  = TSS_Deep_Finalize
2198            or else Is_Predefined_Interface_Primitive (E)
2199          then
2200             return True;
2201          end if;
2202       end if;
2203
2204       return False;
2205    end Is_Predefined_Internal_Operation;
2206
2207    -------------------------------------
2208    -- Is_Predefined_Dispatching_Alias --
2209    -------------------------------------
2210
2211    function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean
2212    is
2213    begin
2214       return not Is_Predefined_Dispatching_Operation (Prim)
2215         and then Present (Alias (Prim))
2216         and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim));
2217    end Is_Predefined_Dispatching_Alias;
2218
2219    ---------------------------------------
2220    -- Is_Predefined_Interface_Primitive --
2221    ---------------------------------------
2222
2223    function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean is
2224    begin
2225       --  In VM targets we don't restrict the functionality of this test to
2226       --  compiling in Ada 2005 mode since in VM targets any tagged type has
2227       --  these primitives.
2228
2229       return (Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion)
2230         and then Nam_In (Chars (E), Name_uDisp_Asynchronous_Select,
2231                                     Name_uDisp_Conditional_Select,
2232                                     Name_uDisp_Get_Prim_Op_Kind,
2233                                     Name_uDisp_Get_Task_Id,
2234                                     Name_uDisp_Requeue,
2235                                     Name_uDisp_Timed_Select);
2236    end Is_Predefined_Interface_Primitive;
2237
2238    ----------------------------------------
2239    -- Make_Disp_Asynchronous_Select_Body --
2240    ----------------------------------------
2241
2242    --  For interface types, generate:
2243
2244    --     procedure _Disp_Asynchronous_Select
2245    --       (T : in out <Typ>;
2246    --        S : Integer;
2247    --        P : System.Address;
2248    --        B : out System.Storage_Elements.Dummy_Communication_Block;
2249    --        F : out Boolean)
2250    --     is
2251    --     begin
2252    --        F := False;
2253    --        C := Ada.Tags.POK_Function;
2254    --     end _Disp_Asynchronous_Select;
2255
2256    --  For protected types, generate:
2257
2258    --     procedure _Disp_Asynchronous_Select
2259    --       (T : in out <Typ>;
2260    --        S : Integer;
2261    --        P : System.Address;
2262    --        B : out System.Storage_Elements.Dummy_Communication_Block;
2263    --        F : out Boolean)
2264    --     is
2265    --        I   : Integer :=
2266    --                Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2267    --        Bnn : System.Tasking.Protected_Objects.Operations.
2268    --                Communication_Block;
2269    --     begin
2270    --        System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2271    --          (T._object'Access,
2272    --           System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2273    --           P,
2274    --           System.Tasking.Asynchronous_Call,
2275    --           Bnn);
2276    --        B := System.Storage_Elements.Dummy_Communication_Block (Bnn);
2277    --     end _Disp_Asynchronous_Select;
2278
2279    --  For task types, generate:
2280
2281    --     procedure _Disp_Asynchronous_Select
2282    --       (T : in out <Typ>;
2283    --        S : Integer;
2284    --        P : System.Address;
2285    --        B : out System.Storage_Elements.Dummy_Communication_Block;
2286    --        F : out Boolean)
2287    --     is
2288    --        I   : Integer :=
2289    --                Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2290    --     begin
2291    --        System.Tasking.Rendezvous.Task_Entry_Call
2292    --          (T._task_id,
2293    --           System.Tasking.Task_Entry_Index (I),
2294    --           P,
2295    --           System.Tasking.Asynchronous_Call,
2296    --           F);
2297    --     end _Disp_Asynchronous_Select;
2298
2299    function Make_Disp_Asynchronous_Select_Body
2300      (Typ : Entity_Id) return Node_Id
2301    is
2302       Com_Block : Entity_Id;
2303       Conc_Typ  : Entity_Id           := Empty;
2304       Decls     : constant List_Id    := New_List;
2305       Loc       : constant Source_Ptr := Sloc (Typ);
2306       Obj_Ref   : Node_Id;
2307       Stmts     : constant List_Id    := New_List;
2308       Tag_Node  : Node_Id;
2309
2310    begin
2311       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2312
2313       --  Null body is generated for interface types
2314
2315       if Is_Interface (Typ) then
2316          return
2317            Make_Subprogram_Body (Loc,
2318              Specification              =>
2319                Make_Disp_Asynchronous_Select_Spec (Typ),
2320              Declarations               => New_List,
2321              Handled_Statement_Sequence =>
2322                Make_Handled_Sequence_Of_Statements (Loc,
2323                  New_List (
2324                    Make_Assignment_Statement (Loc,
2325                      Name       => Make_Identifier (Loc, Name_uF),
2326                      Expression => New_Occurrence_Of (Standard_False, Loc)))));
2327       end if;
2328
2329       if Is_Concurrent_Record_Type (Typ) then
2330          Conc_Typ := Corresponding_Concurrent_Type (Typ);
2331
2332          --  Generate:
2333          --    I : Integer :=
2334          --          Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2335
2336          --  where I will be used to capture the entry index of the primitive
2337          --  wrapper at position S.
2338
2339          if Tagged_Type_Expansion then
2340             Tag_Node :=
2341               Unchecked_Convert_To (RTE (RE_Tag),
2342                 New_Occurrence_Of
2343                   (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
2344          else
2345             Tag_Node :=
2346               Make_Attribute_Reference (Loc,
2347                 Prefix         => New_Occurrence_Of (Typ, Loc),
2348                 Attribute_Name => Name_Tag);
2349          end if;
2350
2351          Append_To (Decls,
2352            Make_Object_Declaration (Loc,
2353              Defining_Identifier =>
2354                Make_Defining_Identifier (Loc, Name_uI),
2355              Object_Definition   =>
2356                New_Occurrence_Of (Standard_Integer, Loc),
2357              Expression          =>
2358                Make_Function_Call (Loc,
2359                  Name                   =>
2360                    New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc),
2361                  Parameter_Associations =>
2362                    New_List (Tag_Node, Make_Identifier (Loc, Name_uS)))));
2363
2364          if Ekind (Conc_Typ) = E_Protected_Type then
2365
2366             --  Generate:
2367             --    Bnn : Communication_Block;
2368
2369             Com_Block := Make_Temporary (Loc, 'B');
2370             Append_To (Decls,
2371               Make_Object_Declaration (Loc,
2372                 Defining_Identifier => Com_Block,
2373                 Object_Definition   =>
2374                   New_Occurrence_Of (RTE (RE_Communication_Block), Loc)));
2375
2376             --  Build T._object'Access for calls below
2377
2378             Obj_Ref :=
2379                Make_Attribute_Reference (Loc,
2380                  Attribute_Name => Name_Unchecked_Access,
2381                  Prefix         =>
2382                    Make_Selected_Component (Loc,
2383                      Prefix        => Make_Identifier (Loc, Name_uT),
2384                      Selector_Name => Make_Identifier (Loc, Name_uObject)));
2385
2386             case Corresponding_Runtime_Package (Conc_Typ) is
2387                when System_Tasking_Protected_Objects_Entries =>
2388
2389                   --  Generate:
2390                   --    Protected_Entry_Call
2391                   --      (T._object'Access,            --  Object
2392                   --       Protected_Entry_Index! (I),  --  E
2393                   --       P,                           --  Uninterpreted_Data
2394                   --       Asynchronous_Call,           --  Mode
2395                   --       Bnn);                        --  Communication_Block
2396
2397                   --  where T is the protected object, I is the entry index, P
2398                   --  is the wrapped parameters and B is the name of the
2399                   --  communication block.
2400
2401                   Append_To (Stmts,
2402                     Make_Procedure_Call_Statement (Loc,
2403                       Name                   =>
2404                         New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc),
2405                       Parameter_Associations =>
2406                         New_List (
2407                           Obj_Ref,
2408
2409                           Make_Unchecked_Type_Conversion (Loc,  --  entry index
2410                             Subtype_Mark =>
2411                               New_Occurrence_Of
2412                                 (RTE (RE_Protected_Entry_Index), Loc),
2413                             Expression => Make_Identifier (Loc, Name_uI)),
2414
2415                           Make_Identifier (Loc, Name_uP), --  parameter block
2416                           New_Occurrence_Of               --  Asynchronous_Call
2417                             (RTE (RE_Asynchronous_Call), Loc),
2418                           New_Occurrence_Of               -- comm block
2419                             (Com_Block, Loc))));
2420
2421                when others =>
2422                   raise Program_Error;
2423             end case;
2424
2425             --  Generate:
2426             --    B := Dummy_Communication_Block (Bnn);
2427
2428             Append_To (Stmts,
2429               Make_Assignment_Statement (Loc,
2430                 Name => Make_Identifier (Loc, Name_uB),
2431                 Expression =>
2432                   Make_Unchecked_Type_Conversion (Loc,
2433                     Subtype_Mark =>
2434                       New_Occurrence_Of
2435                         (RTE (RE_Dummy_Communication_Block), Loc),
2436                     Expression   => New_Occurrence_Of (Com_Block, Loc))));
2437
2438             --  Generate:
2439             --    F := False;
2440
2441             Append_To (Stmts,
2442               Make_Assignment_Statement (Loc,
2443                 Name       => Make_Identifier (Loc, Name_uF),
2444                 Expression => New_Occurrence_Of (Standard_False, Loc)));
2445
2446          else
2447             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
2448
2449             --  Generate:
2450             --    Task_Entry_Call
2451             --      (T._task_id,             --  Acceptor
2452             --       Task_Entry_Index! (I),  --  E
2453             --       P,                      --  Uninterpreted_Data
2454             --       Asynchronous_Call,      --  Mode
2455             --       F);                     --  Rendezvous_Successful
2456
2457             --  where T is the task object, I is the entry index, P is the
2458             --  wrapped parameters and F is the status flag.
2459
2460             Append_To (Stmts,
2461               Make_Procedure_Call_Statement (Loc,
2462                 Name                   =>
2463                   New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc),
2464                 Parameter_Associations =>
2465                   New_List (
2466                     Make_Selected_Component (Loc,         -- T._task_id
2467                       Prefix        => Make_Identifier (Loc, Name_uT),
2468                       Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
2469
2470                     Make_Unchecked_Type_Conversion (Loc,  --  entry index
2471                       Subtype_Mark =>
2472                         New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
2473                       Expression   => Make_Identifier (Loc, Name_uI)),
2474
2475                     Make_Identifier (Loc, Name_uP),       --  parameter block
2476                     New_Occurrence_Of                     --  Asynchronous_Call
2477                       (RTE (RE_Asynchronous_Call), Loc),
2478                     Make_Identifier (Loc, Name_uF))));    --  status flag
2479          end if;
2480
2481       else
2482          --  Ensure that the statements list is non-empty
2483
2484          Append_To (Stmts,
2485            Make_Assignment_Statement (Loc,
2486              Name       => Make_Identifier (Loc, Name_uF),
2487              Expression => New_Occurrence_Of (Standard_False, Loc)));
2488       end if;
2489
2490       return
2491         Make_Subprogram_Body (Loc,
2492           Specification              =>
2493             Make_Disp_Asynchronous_Select_Spec (Typ),
2494           Declarations               => Decls,
2495           Handled_Statement_Sequence =>
2496             Make_Handled_Sequence_Of_Statements (Loc, Stmts));
2497    end Make_Disp_Asynchronous_Select_Body;
2498
2499    ----------------------------------------
2500    -- Make_Disp_Asynchronous_Select_Spec --
2501    ----------------------------------------
2502
2503    function Make_Disp_Asynchronous_Select_Spec
2504      (Typ : Entity_Id) return Node_Id
2505    is
2506       Loc    : constant Source_Ptr := Sloc (Typ);
2507       Def_Id : constant Node_Id    :=
2508                  Make_Defining_Identifier (Loc,
2509                    Name_uDisp_Asynchronous_Select);
2510       Params : constant List_Id    := New_List;
2511
2512    begin
2513       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2514
2515       --  T : in out Typ;                     --  Object parameter
2516       --  S : Integer;                        --  Primitive operation slot
2517       --  P : Address;                        --  Wrapped parameters
2518       --  B : out Dummy_Communication_Block;  --  Communication block dummy
2519       --  F : out Boolean;                    --  Status flag
2520
2521       Append_List_To (Params, New_List (
2522
2523         Make_Parameter_Specification (Loc,
2524           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
2525           Parameter_Type      => New_Occurrence_Of (Typ, Loc),
2526           In_Present          => True,
2527           Out_Present         => True),
2528
2529         Make_Parameter_Specification (Loc,
2530           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS),
2531           Parameter_Type      => New_Occurrence_Of (Standard_Integer, Loc)),
2532
2533         Make_Parameter_Specification (Loc,
2534           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
2535           Parameter_Type      => New_Occurrence_Of (RTE (RE_Address), Loc)),
2536
2537         Make_Parameter_Specification (Loc,
2538           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uB),
2539           Parameter_Type      =>
2540             New_Occurrence_Of (RTE (RE_Dummy_Communication_Block), Loc),
2541           Out_Present         => True),
2542
2543         Make_Parameter_Specification (Loc,
2544           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF),
2545           Parameter_Type      => New_Occurrence_Of (Standard_Boolean, Loc),
2546           Out_Present         => True)));
2547
2548       return
2549         Make_Procedure_Specification (Loc,
2550           Defining_Unit_Name       => Def_Id,
2551           Parameter_Specifications => Params);
2552    end Make_Disp_Asynchronous_Select_Spec;
2553
2554    ---------------------------------------
2555    -- Make_Disp_Conditional_Select_Body --
2556    ---------------------------------------
2557
2558    --  For interface types, generate:
2559
2560    --     procedure _Disp_Conditional_Select
2561    --       (T : in out <Typ>;
2562    --        S : Integer;
2563    --        P : System.Address;
2564    --        C : out Ada.Tags.Prim_Op_Kind;
2565    --        F : out Boolean)
2566    --     is
2567    --     begin
2568    --        F := False;
2569    --        C := Ada.Tags.POK_Function;
2570    --     end _Disp_Conditional_Select;
2571
2572    --  For protected types, generate:
2573
2574    --     procedure _Disp_Conditional_Select
2575    --       (T : in out <Typ>;
2576    --        S : Integer;
2577    --        P : System.Address;
2578    --        C : out Ada.Tags.Prim_Op_Kind;
2579    --        F : out Boolean)
2580    --     is
2581    --        I   : Integer;
2582    --        Bnn : System.Tasking.Protected_Objects.Operations.
2583    --                Communication_Block;
2584
2585    --     begin
2586    --        C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP, S));
2587
2588    --        if C = Ada.Tags.POK_Procedure
2589    --          or else C = Ada.Tags.POK_Protected_Procedure
2590    --          or else C = Ada.Tags.POK_Task_Procedure
2591    --        then
2592    --           F := True;
2593    --           return;
2594    --        end if;
2595
2596    --        I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2597    --        System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2598    --          (T.object'Access,
2599    --           System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2600    --           P,
2601    --           System.Tasking.Conditional_Call,
2602    --           Bnn);
2603    --        F := not Cancelled (Bnn);
2604    --     end _Disp_Conditional_Select;
2605
2606    --  For task types, generate:
2607
2608    --     procedure _Disp_Conditional_Select
2609    --       (T : in out <Typ>;
2610    --        S : Integer;
2611    --        P : System.Address;
2612    --        C : out Ada.Tags.Prim_Op_Kind;
2613    --        F : out Boolean)
2614    --     is
2615    --        I : Integer;
2616
2617    --     begin
2618    --        I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2619    --        System.Tasking.Rendezvous.Task_Entry_Call
2620    --          (T._task_id,
2621    --           System.Tasking.Task_Entry_Index (I),
2622    --           P,
2623    --           System.Tasking.Conditional_Call,
2624    --           F);
2625    --     end _Disp_Conditional_Select;
2626
2627    function Make_Disp_Conditional_Select_Body
2628      (Typ : Entity_Id) return Node_Id
2629    is
2630       Loc      : constant Source_Ptr := Sloc (Typ);
2631       Blk_Nam  : Entity_Id;
2632       Conc_Typ : Entity_Id           := Empty;
2633       Decls    : constant List_Id    := New_List;
2634       Obj_Ref  : Node_Id;
2635       Stmts    : constant List_Id    := New_List;
2636       Tag_Node : Node_Id;
2637
2638    begin
2639       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2640
2641       --  Null body is generated for interface types
2642
2643       if Is_Interface (Typ) then
2644          return
2645            Make_Subprogram_Body (Loc,
2646              Specification              =>
2647                Make_Disp_Conditional_Select_Spec (Typ),
2648              Declarations               => No_List,
2649              Handled_Statement_Sequence =>
2650                Make_Handled_Sequence_Of_Statements (Loc,
2651                  New_List (Make_Assignment_Statement (Loc,
2652                    Name       => Make_Identifier (Loc, Name_uF),
2653                    Expression => New_Occurrence_Of (Standard_False, Loc)))));
2654       end if;
2655
2656       if Is_Concurrent_Record_Type (Typ) then
2657          Conc_Typ := Corresponding_Concurrent_Type (Typ);
2658
2659          --  Generate:
2660          --    I : Integer;
2661
2662          --  where I will be used to capture the entry index of the primitive
2663          --  wrapper at position S.
2664
2665          Append_To (Decls,
2666            Make_Object_Declaration (Loc,
2667              Defining_Identifier => Make_Defining_Identifier (Loc, Name_uI),
2668              Object_Definition   =>
2669                New_Occurrence_Of (Standard_Integer, Loc)));
2670
2671          --  Generate:
2672          --    C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag! (<type>VP), S);
2673
2674          --    if C = POK_Procedure
2675          --      or else C = POK_Protected_Procedure
2676          --      or else C = POK_Task_Procedure;
2677          --    then
2678          --       F := True;
2679          --       return;
2680          --    end if;
2681
2682          Build_Common_Dispatching_Select_Statements (Typ, Stmts);
2683
2684          --  Generate:
2685          --    Bnn : Communication_Block;
2686
2687          --  where Bnn is the name of the communication block used in the
2688          --  call to Protected_Entry_Call.
2689
2690          Blk_Nam := Make_Temporary (Loc, 'B');
2691          Append_To (Decls,
2692            Make_Object_Declaration (Loc,
2693              Defining_Identifier => Blk_Nam,
2694              Object_Definition   =>
2695                New_Occurrence_Of (RTE (RE_Communication_Block), Loc)));
2696
2697          --  Generate:
2698          --    I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2699
2700          --  I is the entry index and S is the dispatch table slot
2701
2702          if Tagged_Type_Expansion then
2703             Tag_Node :=
2704               Unchecked_Convert_To (RTE (RE_Tag),
2705                 New_Occurrence_Of
2706                   (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
2707
2708          else
2709             Tag_Node :=
2710               Make_Attribute_Reference (Loc,
2711                 Prefix         => New_Occurrence_Of (Typ, Loc),
2712                 Attribute_Name => Name_Tag);
2713          end if;
2714
2715          Append_To (Stmts,
2716            Make_Assignment_Statement (Loc,
2717              Name       => Make_Identifier (Loc, Name_uI),
2718              Expression =>
2719                Make_Function_Call (Loc,
2720                  Name                   =>
2721                    New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc),
2722                  Parameter_Associations => New_List (
2723                    Tag_Node,
2724                    Make_Identifier (Loc, Name_uS)))));
2725
2726          if Ekind (Conc_Typ) = E_Protected_Type then
2727
2728             Obj_Ref :=                                  -- T._object'Access
2729                Make_Attribute_Reference (Loc,
2730                  Attribute_Name => Name_Unchecked_Access,
2731                  Prefix         =>
2732                    Make_Selected_Component (Loc,
2733                      Prefix        => Make_Identifier (Loc, Name_uT),
2734                      Selector_Name => Make_Identifier (Loc, Name_uObject)));
2735
2736             case Corresponding_Runtime_Package (Conc_Typ) is
2737                when System_Tasking_Protected_Objects_Entries =>
2738                   --  Generate:
2739
2740                   --    Protected_Entry_Call
2741                   --      (T._object'Access,            --  Object
2742                   --       Protected_Entry_Index! (I),  --  E
2743                   --       P,                           --  Uninterpreted_Data
2744                   --       Conditional_Call,            --  Mode
2745                   --       Bnn);                        --  Block
2746
2747                   --  where T is the protected object, I is the entry index, P
2748                   --  are the wrapped parameters and Bnn is the name of the
2749                   --  communication block.
2750
2751                   Append_To (Stmts,
2752                     Make_Procedure_Call_Statement (Loc,
2753                       Name                   =>
2754                         New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc),
2755                       Parameter_Associations => New_List (
2756                           Obj_Ref,
2757
2758                           Make_Unchecked_Type_Conversion (Loc,  --  entry index
2759                             Subtype_Mark =>
2760                               New_Occurrence_Of
2761                                  (RTE (RE_Protected_Entry_Index), Loc),
2762                             Expression => Make_Identifier (Loc, Name_uI)),
2763
2764                           Make_Identifier (Loc, Name_uP),  --  parameter block
2765
2766                           New_Occurrence_Of                --  Conditional_Call
2767                             (RTE (RE_Conditional_Call), Loc),
2768                           New_Occurrence_Of                --  Bnn
2769                             (Blk_Nam, Loc))));
2770
2771                when System_Tasking_Protected_Objects_Single_Entry =>
2772
2773                   --    If we are compiling for a restricted run-time, the call
2774                   --    uses the simpler form.
2775
2776                   Append_To (Stmts,
2777                     Make_Procedure_Call_Statement (Loc,
2778                       Name                   =>
2779                         New_Occurrence_Of
2780                           (RTE (RE_Protected_Single_Entry_Call), Loc),
2781                       Parameter_Associations => New_List (
2782                           Obj_Ref,
2783
2784                           Make_Attribute_Reference (Loc,
2785                             Prefix         => Make_Identifier (Loc, Name_uP),
2786                             Attribute_Name => Name_Address),
2787
2788                             New_Occurrence_Of
2789                              (RTE (RE_Conditional_Call), Loc))));
2790                when others =>
2791                   raise Program_Error;
2792             end case;
2793
2794             --  Generate:
2795             --    F := not Cancelled (Bnn);
2796
2797             --  where F is the success flag. The status of Cancelled is negated
2798             --  in order to match the behavior of the version for task types.
2799
2800             Append_To (Stmts,
2801               Make_Assignment_Statement (Loc,
2802                 Name       => Make_Identifier (Loc, Name_uF),
2803                 Expression =>
2804                   Make_Op_Not (Loc,
2805                     Right_Opnd =>
2806                       Make_Function_Call (Loc,
2807                         Name                   =>
2808                           New_Occurrence_Of (RTE (RE_Cancelled), Loc),
2809                         Parameter_Associations => New_List (
2810                             New_Occurrence_Of (Blk_Nam, Loc))))));
2811          else
2812             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
2813
2814             --  Generate:
2815             --    Task_Entry_Call
2816             --      (T._task_id,             --  Acceptor
2817             --       Task_Entry_Index! (I),  --  E
2818             --       P,                      --  Uninterpreted_Data
2819             --       Conditional_Call,       --  Mode
2820             --       F);                     --  Rendezvous_Successful
2821
2822             --  where T is the task object, I is the entry index, P are the
2823             --  wrapped parameters and F is the status flag.
2824
2825             Append_To (Stmts,
2826               Make_Procedure_Call_Statement (Loc,
2827                 Name                   =>
2828                   New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc),
2829                 Parameter_Associations => New_List (
2830
2831                     Make_Selected_Component (Loc,         -- T._task_id
2832                       Prefix        => Make_Identifier (Loc, Name_uT),
2833                       Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
2834
2835                     Make_Unchecked_Type_Conversion (Loc,  --  entry index
2836                       Subtype_Mark =>
2837                         New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
2838                       Expression   => Make_Identifier (Loc, Name_uI)),
2839
2840                     Make_Identifier (Loc, Name_uP),       --  parameter block
2841                     New_Occurrence_Of                      --  Conditional_Call
2842                       (RTE (RE_Conditional_Call), Loc),
2843                     Make_Identifier (Loc, Name_uF))));    --  status flag
2844          end if;
2845
2846       else
2847          --  Initialize out parameters
2848
2849          Append_To (Stmts,
2850            Make_Assignment_Statement (Loc,
2851              Name       => Make_Identifier (Loc, Name_uF),
2852              Expression => New_Occurrence_Of (Standard_False, Loc)));
2853          Append_To (Stmts,
2854            Make_Assignment_Statement (Loc,
2855              Name       => Make_Identifier (Loc, Name_uC),
2856              Expression => New_Occurrence_Of (RTE (RE_POK_Function), Loc)));
2857       end if;
2858
2859       return
2860         Make_Subprogram_Body (Loc,
2861           Specification              =>
2862             Make_Disp_Conditional_Select_Spec (Typ),
2863           Declarations               => Decls,
2864           Handled_Statement_Sequence =>
2865             Make_Handled_Sequence_Of_Statements (Loc, Stmts));
2866    end Make_Disp_Conditional_Select_Body;
2867
2868    ---------------------------------------
2869    -- Make_Disp_Conditional_Select_Spec --
2870    ---------------------------------------
2871
2872    function Make_Disp_Conditional_Select_Spec
2873      (Typ : Entity_Id) return Node_Id
2874    is
2875       Loc    : constant Source_Ptr := Sloc (Typ);
2876       Def_Id : constant Node_Id    :=
2877                  Make_Defining_Identifier (Loc,
2878                    Name_uDisp_Conditional_Select);
2879       Params : constant List_Id    := New_List;
2880
2881    begin
2882       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2883
2884       --  T : in out Typ;        --  Object parameter
2885       --  S : Integer;           --  Primitive operation slot
2886       --  P : Address;           --  Wrapped parameters
2887       --  C : out Prim_Op_Kind;  --  Call kind
2888       --  F : out Boolean;       --  Status flag
2889
2890       Append_List_To (Params, New_List (
2891
2892         Make_Parameter_Specification (Loc,
2893           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
2894           Parameter_Type      => New_Occurrence_Of (Typ, Loc),
2895           In_Present          => True,
2896           Out_Present         => True),
2897
2898         Make_Parameter_Specification (Loc,
2899           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS),
2900           Parameter_Type      => New_Occurrence_Of (Standard_Integer, Loc)),
2901
2902         Make_Parameter_Specification (Loc,
2903           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
2904           Parameter_Type      => New_Occurrence_Of (RTE (RE_Address), Loc)),
2905
2906         Make_Parameter_Specification (Loc,
2907           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC),
2908           Parameter_Type      =>
2909             New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc),
2910           Out_Present         => True),
2911
2912         Make_Parameter_Specification (Loc,
2913           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF),
2914           Parameter_Type      => New_Occurrence_Of (Standard_Boolean, Loc),
2915           Out_Present         => True)));
2916
2917       return
2918         Make_Procedure_Specification (Loc,
2919           Defining_Unit_Name       => Def_Id,
2920           Parameter_Specifications => Params);
2921    end Make_Disp_Conditional_Select_Spec;
2922
2923    -------------------------------------
2924    -- Make_Disp_Get_Prim_Op_Kind_Body --
2925    -------------------------------------
2926
2927    function Make_Disp_Get_Prim_Op_Kind_Body (Typ : Entity_Id) return Node_Id is
2928       Loc      : constant Source_Ptr := Sloc (Typ);
2929       Tag_Node : Node_Id;
2930
2931    begin
2932       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2933
2934       if Is_Interface (Typ) then
2935          return
2936            Make_Subprogram_Body (Loc,
2937              Specification              =>
2938                Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
2939              Declarations               => New_List,
2940              Handled_Statement_Sequence =>
2941                Make_Handled_Sequence_Of_Statements (Loc,
2942                  New_List (Make_Null_Statement (Loc))));
2943       end if;
2944
2945       --  Generate:
2946       --    C := get_prim_op_kind (tag! (<type>VP), S);
2947
2948       --  where C is the out parameter capturing the call kind and S is the
2949       --  dispatch table slot number.
2950
2951       if Tagged_Type_Expansion then
2952          Tag_Node :=
2953            Unchecked_Convert_To (RTE (RE_Tag),
2954              New_Occurrence_Of
2955               (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
2956
2957       else
2958          Tag_Node :=
2959            Make_Attribute_Reference (Loc,
2960              Prefix         => New_Occurrence_Of (Typ, Loc),
2961              Attribute_Name => Name_Tag);
2962       end if;
2963
2964       return
2965         Make_Subprogram_Body (Loc,
2966           Specification              =>
2967             Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
2968           Declarations               => New_List,
2969           Handled_Statement_Sequence =>
2970             Make_Handled_Sequence_Of_Statements (Loc,
2971               New_List (
2972                 Make_Assignment_Statement (Loc,
2973                   Name       => Make_Identifier (Loc, Name_uC),
2974                   Expression =>
2975                     Make_Function_Call (Loc,
2976                       Name =>
2977                         New_Occurrence_Of (RTE (RE_Get_Prim_Op_Kind), Loc),
2978                       Parameter_Associations => New_List (
2979                         Tag_Node,
2980                         Make_Identifier (Loc, Name_uS)))))));
2981    end Make_Disp_Get_Prim_Op_Kind_Body;
2982
2983    -------------------------------------
2984    -- Make_Disp_Get_Prim_Op_Kind_Spec --
2985    -------------------------------------
2986
2987    function Make_Disp_Get_Prim_Op_Kind_Spec
2988      (Typ : Entity_Id) return Node_Id
2989    is
2990       Loc    : constant Source_Ptr := Sloc (Typ);
2991       Def_Id : constant Node_Id    :=
2992                  Make_Defining_Identifier (Loc, Name_uDisp_Get_Prim_Op_Kind);
2993       Params : constant List_Id    := New_List;
2994
2995    begin
2996       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2997
2998       --  T : in out Typ;       --  Object parameter
2999       --  S : Integer;          --  Primitive operation slot
3000       --  C : out Prim_Op_Kind; --  Call kind
3001
3002       Append_List_To (Params, New_List (
3003
3004         Make_Parameter_Specification (Loc,
3005           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
3006           Parameter_Type      => New_Occurrence_Of (Typ, Loc),
3007           In_Present          => True,
3008           Out_Present         => True),
3009
3010         Make_Parameter_Specification (Loc,
3011           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS),
3012           Parameter_Type      => New_Occurrence_Of (Standard_Integer, Loc)),
3013
3014         Make_Parameter_Specification (Loc,
3015           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC),
3016           Parameter_Type      =>
3017             New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc),
3018           Out_Present         => True)));
3019
3020       return
3021         Make_Procedure_Specification (Loc,
3022            Defining_Unit_Name       => Def_Id,
3023            Parameter_Specifications => Params);
3024    end Make_Disp_Get_Prim_Op_Kind_Spec;
3025
3026    --------------------------------
3027    -- Make_Disp_Get_Task_Id_Body --
3028    --------------------------------
3029
3030    function Make_Disp_Get_Task_Id_Body
3031      (Typ : Entity_Id) return Node_Id
3032    is
3033       Loc : constant Source_Ptr := Sloc (Typ);
3034       Ret : Node_Id;
3035
3036    begin
3037       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3038
3039       if Is_Concurrent_Record_Type (Typ)
3040         and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type
3041       then
3042          --  Generate:
3043          --    return To_Address (_T._task_id);
3044
3045          Ret :=
3046            Make_Simple_Return_Statement (Loc,
3047              Expression =>
3048                Make_Unchecked_Type_Conversion (Loc,
3049                  Subtype_Mark => New_Occurrence_Of (RTE (RE_Address), Loc),
3050                  Expression   =>
3051                    Make_Selected_Component (Loc,
3052                      Prefix        => Make_Identifier (Loc, Name_uT),
3053                      Selector_Name => Make_Identifier (Loc, Name_uTask_Id))));
3054
3055       --  A null body is constructed for non-task types
3056
3057       else
3058          --  Generate:
3059          --    return Null_Address;
3060
3061          Ret :=
3062            Make_Simple_Return_Statement (Loc,
3063              Expression => New_Occurrence_Of (RTE (RE_Null_Address), Loc));
3064       end if;
3065
3066       return
3067         Make_Subprogram_Body (Loc,
3068           Specification              => Make_Disp_Get_Task_Id_Spec (Typ),
3069           Declarations               => New_List,
3070           Handled_Statement_Sequence =>
3071             Make_Handled_Sequence_Of_Statements (Loc, New_List (Ret)));
3072    end Make_Disp_Get_Task_Id_Body;
3073
3074    --------------------------------
3075    -- Make_Disp_Get_Task_Id_Spec --
3076    --------------------------------
3077
3078    function Make_Disp_Get_Task_Id_Spec
3079      (Typ : Entity_Id) return Node_Id
3080    is
3081       Loc : constant Source_Ptr := Sloc (Typ);
3082
3083    begin
3084       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3085
3086       return
3087         Make_Function_Specification (Loc,
3088           Defining_Unit_Name       =>
3089             Make_Defining_Identifier (Loc, Name_uDisp_Get_Task_Id),
3090           Parameter_Specifications => New_List (
3091             Make_Parameter_Specification (Loc,
3092               Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
3093               Parameter_Type      => New_Occurrence_Of (Typ, Loc))),
3094           Result_Definition        =>
3095             New_Occurrence_Of (RTE (RE_Address), Loc));
3096    end Make_Disp_Get_Task_Id_Spec;
3097
3098    ----------------------------
3099    -- Make_Disp_Requeue_Body --
3100    ----------------------------
3101
3102    function Make_Disp_Requeue_Body
3103      (Typ : Entity_Id) return Node_Id
3104    is
3105       Loc      : constant Source_Ptr := Sloc (Typ);
3106       Conc_Typ : Entity_Id           := Empty;
3107       Stmts    : constant List_Id    := New_List;
3108
3109    begin
3110       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3111
3112       --  Null body is generated for interface types and non-concurrent
3113       --  tagged types.
3114
3115       if Is_Interface (Typ)
3116         or else not Is_Concurrent_Record_Type (Typ)
3117       then
3118          return
3119            Make_Subprogram_Body (Loc,
3120              Specification              => Make_Disp_Requeue_Spec (Typ),
3121              Declarations               => No_List,
3122              Handled_Statement_Sequence =>
3123                Make_Handled_Sequence_Of_Statements (Loc,
3124                  New_List (Make_Null_Statement (Loc))));
3125       end if;
3126
3127       Conc_Typ := Corresponding_Concurrent_Type (Typ);
3128
3129       if Ekind (Conc_Typ) = E_Protected_Type then
3130
3131          --  Generate statements:
3132          --    if F then
3133          --       System.Tasking.Protected_Objects.Operations.
3134          --         Requeue_Protected_Entry
3135          --           (Protection_Entries_Access (P),
3136          --            O._object'Unchecked_Access,
3137          --            Protected_Entry_Index (I),
3138          --            A);
3139          --    else
3140          --       System.Tasking.Protected_Objects.Operations.
3141          --         Requeue_Task_To_Protected_Entry
3142          --           (O._object'Unchecked_Access,
3143          --            Protected_Entry_Index (I),
3144          --            A);
3145          --    end if;
3146
3147          if Restriction_Active (No_Entry_Queue) then
3148             Append_To (Stmts, Make_Null_Statement (Loc));
3149          else
3150             Append_To (Stmts,
3151               Make_If_Statement (Loc,
3152                 Condition       => Make_Identifier (Loc, Name_uF),
3153
3154                 Then_Statements =>
3155                   New_List (
3156
3157                      --  Call to Requeue_Protected_Entry
3158
3159                     Make_Procedure_Call_Statement (Loc,
3160                       Name =>
3161                         New_Occurrence_Of
3162                           (RTE (RE_Requeue_Protected_Entry), Loc),
3163                       Parameter_Associations =>
3164                         New_List (
3165
3166                           Make_Unchecked_Type_Conversion (Loc,  -- PEA (P)
3167                             Subtype_Mark =>
3168                               New_Occurrence_Of (
3169                                 RTE (RE_Protection_Entries_Access), Loc),
3170                             Expression =>
3171                               Make_Identifier (Loc, Name_uP)),
3172
3173                           Make_Attribute_Reference (Loc,      -- O._object'Acc
3174                             Attribute_Name =>
3175                               Name_Unchecked_Access,
3176                             Prefix         =>
3177                               Make_Selected_Component (Loc,
3178                                 Prefix        =>
3179                                   Make_Identifier (Loc, Name_uO),
3180                                 Selector_Name =>
3181                                   Make_Identifier (Loc, Name_uObject))),
3182
3183                           Make_Unchecked_Type_Conversion (Loc,  -- entry index
3184                             Subtype_Mark =>
3185                               New_Occurrence_Of
3186                                 (RTE (RE_Protected_Entry_Index), Loc),
3187                             Expression => Make_Identifier (Loc, Name_uI)),
3188
3189                           Make_Identifier (Loc, Name_uA)))),   -- abort status
3190
3191                 Else_Statements =>
3192                   New_List (
3193
3194                      --  Call to Requeue_Task_To_Protected_Entry
3195
3196                     Make_Procedure_Call_Statement (Loc,
3197                       Name =>
3198                         New_Occurrence_Of
3199                           (RTE (RE_Requeue_Task_To_Protected_Entry), Loc),
3200                       Parameter_Associations =>
3201                         New_List (
3202
3203                           Make_Attribute_Reference (Loc,     -- O._object'Acc
3204                             Attribute_Name => Name_Unchecked_Access,
3205                             Prefix         =>
3206                               Make_Selected_Component (Loc,
3207                                 Prefix        =>
3208                                   Make_Identifier (Loc, Name_uO),
3209                                 Selector_Name =>
3210                                   Make_Identifier (Loc, Name_uObject))),
3211
3212                           Make_Unchecked_Type_Conversion (Loc, -- entry index
3213                             Subtype_Mark =>
3214                               New_Occurrence_Of
3215                                 (RTE (RE_Protected_Entry_Index), Loc),
3216                             Expression   => Make_Identifier (Loc, Name_uI)),
3217
3218                           Make_Identifier (Loc, Name_uA)))))); -- abort status
3219          end if;
3220
3221       else
3222          pragma Assert (Is_Task_Type (Conc_Typ));
3223
3224          --  Generate:
3225          --    if F then
3226          --       System.Tasking.Rendezvous.Requeue_Protected_To_Task_Entry
3227          --         (Protection_Entries_Access (P),
3228          --          O._task_id,
3229          --          Task_Entry_Index (I),
3230          --          A);
3231          --    else
3232          --       System.Tasking.Rendezvous.Requeue_Task_Entry
3233          --         (O._task_id,
3234          --          Task_Entry_Index (I),
3235          --          A);
3236          --    end if;
3237
3238          Append_To (Stmts,
3239            Make_If_Statement (Loc,
3240              Condition       => Make_Identifier (Loc, Name_uF),
3241
3242              Then_Statements => New_List (
3243
3244                --  Call to Requeue_Protected_To_Task_Entry
3245
3246                Make_Procedure_Call_Statement (Loc,
3247                  Name =>
3248                    New_Occurrence_Of
3249                      (RTE (RE_Requeue_Protected_To_Task_Entry), Loc),
3250
3251                  Parameter_Associations => New_List (
3252
3253                    Make_Unchecked_Type_Conversion (Loc,  -- PEA (P)
3254                      Subtype_Mark =>
3255                        New_Occurrence_Of
3256                          (RTE (RE_Protection_Entries_Access), Loc),
3257                           Expression => Make_Identifier (Loc, Name_uP)),
3258
3259                    Make_Selected_Component (Loc,         -- O._task_id
3260                      Prefix        => Make_Identifier (Loc, Name_uO),
3261                      Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3262
3263                    Make_Unchecked_Type_Conversion (Loc,  -- entry index
3264                      Subtype_Mark =>
3265                        New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
3266                      Expression   => Make_Identifier (Loc, Name_uI)),
3267
3268                    Make_Identifier (Loc, Name_uA)))),    -- abort status
3269
3270              Else_Statements => New_List (
3271
3272                --  Call to Requeue_Task_Entry
3273
3274                Make_Procedure_Call_Statement (Loc,
3275                  Name                   =>
3276                    New_Occurrence_Of (RTE (RE_Requeue_Task_Entry), Loc),
3277
3278                  Parameter_Associations => New_List (
3279
3280                    Make_Selected_Component (Loc,         -- O._task_id
3281                      Prefix        => Make_Identifier (Loc, Name_uO),
3282                      Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3283
3284                    Make_Unchecked_Type_Conversion (Loc,  -- entry index
3285                      Subtype_Mark =>
3286                        New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
3287                      Expression   => Make_Identifier (Loc, Name_uI)),
3288
3289                    Make_Identifier (Loc, Name_uA))))));  -- abort status
3290       end if;
3291
3292       --  Even though no declarations are needed in both cases, we allocate
3293       --  a list for entities added by Freeze.
3294
3295       return
3296         Make_Subprogram_Body (Loc,
3297           Specification              => Make_Disp_Requeue_Spec (Typ),
3298           Declarations               => New_List,
3299           Handled_Statement_Sequence =>
3300             Make_Handled_Sequence_Of_Statements (Loc, Stmts));
3301    end Make_Disp_Requeue_Body;
3302
3303    ----------------------------
3304    -- Make_Disp_Requeue_Spec --
3305    ----------------------------
3306
3307    function Make_Disp_Requeue_Spec
3308      (Typ : Entity_Id) return Node_Id
3309    is
3310       Loc : constant Source_Ptr := Sloc (Typ);
3311
3312    begin
3313       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3314
3315       --  O : in out Typ;   -  Object parameter
3316       --  F : Boolean;      -  Protected (True) / task (False) flag
3317       --  P : Address;      -  Protection_Entries_Access value
3318       --  I : Entry_Index   -  Index of entry call
3319       --  A : Boolean       -  Abort flag
3320
3321       --  Note that the Protection_Entries_Access value is represented as a
3322       --  System.Address in order to avoid dragging in the tasking runtime
3323       --  when compiling sources without tasking constructs.
3324
3325       return
3326         Make_Procedure_Specification (Loc,
3327           Defining_Unit_Name =>
3328             Make_Defining_Identifier (Loc, Name_uDisp_Requeue),
3329
3330           Parameter_Specifications => New_List (
3331
3332               Make_Parameter_Specification (Loc,             --  O
3333                 Defining_Identifier =>
3334                   Make_Defining_Identifier (Loc, Name_uO),
3335                 Parameter_Type      =>
3336                   New_Occurrence_Of (Typ, Loc),
3337                 In_Present          => True,
3338                 Out_Present         => True),
3339
3340               Make_Parameter_Specification (Loc,             --  F
3341                 Defining_Identifier =>
3342                   Make_Defining_Identifier (Loc, Name_uF),
3343                 Parameter_Type      =>
3344                   New_Occurrence_Of (Standard_Boolean, Loc)),
3345
3346               Make_Parameter_Specification (Loc,             --  P
3347                 Defining_Identifier =>
3348                   Make_Defining_Identifier (Loc, Name_uP),
3349                 Parameter_Type      =>
3350                   New_Occurrence_Of (RTE (RE_Address), Loc)),
3351
3352               Make_Parameter_Specification (Loc,             --  I
3353                 Defining_Identifier =>
3354                   Make_Defining_Identifier (Loc, Name_uI),
3355                 Parameter_Type      =>
3356                   New_Occurrence_Of (Standard_Integer, Loc)),
3357
3358               Make_Parameter_Specification (Loc,             --  A
3359                 Defining_Identifier =>
3360                   Make_Defining_Identifier (Loc, Name_uA),
3361                 Parameter_Type      =>
3362                   New_Occurrence_Of (Standard_Boolean, Loc))));
3363    end Make_Disp_Requeue_Spec;
3364
3365    ---------------------------------
3366    -- Make_Disp_Timed_Select_Body --
3367    ---------------------------------
3368
3369    --  For interface types, generate:
3370
3371    --     procedure _Disp_Timed_Select
3372    --       (T : in out <Typ>;
3373    --        S : Integer;
3374    --        P : System.Address;
3375    --        D : Duration;
3376    --        M : Integer;
3377    --        C : out Ada.Tags.Prim_Op_Kind;
3378    --        F : out Boolean)
3379    --     is
3380    --     begin
3381    --        F := False;
3382    --        C := Ada.Tags.POK_Function;
3383    --     end _Disp_Timed_Select;
3384
3385    --  For protected types, generate:
3386
3387    --     procedure _Disp_Timed_Select
3388    --       (T : in out <Typ>;
3389    --        S : Integer;
3390    --        P : System.Address;
3391    --        D : Duration;
3392    --        M : Integer;
3393    --        C : out Ada.Tags.Prim_Op_Kind;
3394    --        F : out Boolean)
3395    --     is
3396    --        I : Integer;
3397
3398    --     begin
3399    --        C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP), S);
3400
3401    --        if C = Ada.Tags.POK_Procedure
3402    --          or else C = Ada.Tags.POK_Protected_Procedure
3403    --          or else C = Ada.Tags.POK_Task_Procedure
3404    --        then
3405    --           F := True;
3406    --           return;
3407    --        end if;
3408
3409    --        I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
3410    --        System.Tasking.Protected_Objects.Operations.
3411    --          Timed_Protected_Entry_Call
3412    --            (T._object'Access,
3413    --             System.Tasking.Protected_Objects.Protected_Entry_Index (I),
3414    --             P,
3415    --             D,
3416    --             M,
3417    --             F);
3418    --     end _Disp_Timed_Select;
3419
3420    --  For task types, generate:
3421
3422    --     procedure _Disp_Timed_Select
3423    --       (T : in out <Typ>;
3424    --        S : Integer;
3425    --        P : System.Address;
3426    --        D : Duration;
3427    --        M : Integer;
3428    --        C : out Ada.Tags.Prim_Op_Kind;
3429    --        F : out Boolean)
3430    --     is
3431    --        I : Integer;
3432
3433    --     begin
3434    --        I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
3435    --        System.Tasking.Rendezvous.Timed_Task_Entry_Call
3436    --          (T._task_id,
3437    --           System.Tasking.Task_Entry_Index (I),
3438    --           P,
3439    --           D,
3440    --           M,
3441    --           F);
3442    --     end _Disp_Time_Select;
3443
3444    function Make_Disp_Timed_Select_Body
3445      (Typ : Entity_Id) return Node_Id
3446    is
3447       Loc      : constant Source_Ptr := Sloc (Typ);
3448       Conc_Typ : Entity_Id           := Empty;
3449       Decls    : constant List_Id    := New_List;
3450       Obj_Ref  : Node_Id;
3451       Stmts    : constant List_Id    := New_List;
3452       Tag_Node : Node_Id;
3453
3454    begin
3455       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3456
3457       --  Null body is generated for interface types
3458
3459       if Is_Interface (Typ) then
3460          return
3461            Make_Subprogram_Body (Loc,
3462              Specification              => Make_Disp_Timed_Select_Spec (Typ),
3463              Declarations               => New_List,
3464              Handled_Statement_Sequence =>
3465                Make_Handled_Sequence_Of_Statements (Loc,
3466                  New_List (
3467                    Make_Assignment_Statement (Loc,
3468                      Name       => Make_Identifier (Loc, Name_uF),
3469                      Expression => New_Occurrence_Of (Standard_False, Loc)))));
3470       end if;
3471
3472       if Is_Concurrent_Record_Type (Typ) then
3473          Conc_Typ := Corresponding_Concurrent_Type (Typ);
3474
3475          --  Generate:
3476          --    I : Integer;
3477
3478          --  where I will be used to capture the entry index of the primitive
3479          --  wrapper at position S.
3480
3481          Append_To (Decls,
3482            Make_Object_Declaration (Loc,
3483              Defining_Identifier => Make_Defining_Identifier (Loc, Name_uI),
3484              Object_Definition   =>
3485                New_Occurrence_Of (Standard_Integer, Loc)));
3486
3487          --  Generate:
3488          --    C := Get_Prim_Op_Kind (tag! (<type>VP), S);
3489
3490          --    if C = POK_Procedure
3491          --      or else C = POK_Protected_Procedure
3492          --      or else C = POK_Task_Procedure;
3493          --    then
3494          --       F := True;
3495          --       return;
3496          --    end if;
3497
3498          Build_Common_Dispatching_Select_Statements (Typ, Stmts);
3499
3500          --  Generate:
3501          --    I := Get_Entry_Index (tag! (<type>VP), S);
3502
3503          --  I is the entry index and S is the dispatch table slot
3504
3505          if Tagged_Type_Expansion then
3506             Tag_Node :=
3507               Unchecked_Convert_To (RTE (RE_Tag),
3508                 New_Occurrence_Of
3509                   (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
3510
3511          else
3512             Tag_Node :=
3513               Make_Attribute_Reference (Loc,
3514                 Prefix         => New_Occurrence_Of (Typ, Loc),
3515                 Attribute_Name => Name_Tag);
3516          end if;
3517
3518          Append_To (Stmts,
3519            Make_Assignment_Statement (Loc,
3520              Name       => Make_Identifier (Loc, Name_uI),
3521              Expression =>
3522                Make_Function_Call (Loc,
3523                  Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc),
3524                  Parameter_Associations => New_List (
3525                    Tag_Node,
3526                    Make_Identifier (Loc, Name_uS)))));
3527
3528          --  Protected case
3529
3530          if Ekind (Conc_Typ) = E_Protected_Type then
3531
3532             --  Build T._object'Access
3533
3534             Obj_Ref :=
3535                Make_Attribute_Reference (Loc,
3536                   Attribute_Name => Name_Unchecked_Access,
3537                   Prefix         =>
3538                     Make_Selected_Component (Loc,
3539                       Prefix        => Make_Identifier (Loc, Name_uT),
3540                       Selector_Name => Make_Identifier (Loc, Name_uObject)));
3541
3542             --  Normal case, No_Entry_Queue restriction not active. In this
3543             --  case we generate:
3544
3545             --   Timed_Protected_Entry_Call
3546             --     (T._object'access,
3547             --      Protected_Entry_Index! (I),
3548             --      P, D, M, F);
3549
3550             --  where T is the protected object, I is the entry index, P are
3551             --  the wrapped parameters, D is the delay amount, M is the delay
3552             --  mode and F is the status flag.
3553
3554             --  Historically, there was also an implementation for single
3555             --  entry protected types (in s-tposen). However, it was removed
3556             --  by also testing for no No_Select_Statements restriction in
3557             --  Exp_Utils.Corresponding_Runtime_Package. This simplified the
3558             --  implementation of s-tposen.adb and provided consistency between
3559             --  all versions of System.Tasking.Protected_Objects.Single_Entry
3560             --  (s-tposen*.adb).
3561
3562             case Corresponding_Runtime_Package (Conc_Typ) is
3563                when System_Tasking_Protected_Objects_Entries =>
3564                   Append_To (Stmts,
3565                     Make_Procedure_Call_Statement (Loc,
3566                       Name =>
3567                         New_Occurrence_Of
3568                           (RTE (RE_Timed_Protected_Entry_Call), Loc),
3569                       Parameter_Associations => New_List (
3570                         Obj_Ref,
3571
3572                         Make_Unchecked_Type_Conversion (Loc,  --  entry index
3573                           Subtype_Mark =>
3574                             New_Occurrence_Of
3575                               (RTE (RE_Protected_Entry_Index), Loc),
3576                           Expression   => Make_Identifier (Loc, Name_uI)),
3577
3578                         Make_Identifier (Loc, Name_uP),    --  parameter block
3579                         Make_Identifier (Loc, Name_uD),    --  delay
3580                         Make_Identifier (Loc, Name_uM),    --  delay mode
3581                         Make_Identifier (Loc, Name_uF)))); --  status flag
3582
3583                when others =>
3584                   raise Program_Error;
3585             end case;
3586
3587          --  Task case
3588
3589          else
3590             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
3591
3592             --  Generate:
3593             --    Timed_Task_Entry_Call (
3594             --      T._task_id,
3595             --      Task_Entry_Index! (I),
3596             --      P,
3597             --      D,
3598             --      M,
3599             --      F);
3600
3601             --  where T is the task object, I is the entry index, P are the
3602             --  wrapped parameters, D is the delay amount, M is the delay
3603             --  mode and F is the status flag.
3604
3605             Append_To (Stmts,
3606               Make_Procedure_Call_Statement (Loc,
3607                 Name                   =>
3608                   New_Occurrence_Of (RTE (RE_Timed_Task_Entry_Call), Loc),
3609
3610                 Parameter_Associations => New_List (
3611                   Make_Selected_Component (Loc,         --  T._task_id
3612                     Prefix        => Make_Identifier (Loc, Name_uT),
3613                     Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3614
3615                   Make_Unchecked_Type_Conversion (Loc,  --  entry index
3616                     Subtype_Mark =>
3617                       New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
3618                     Expression   => Make_Identifier (Loc, Name_uI)),
3619
3620                   Make_Identifier (Loc, Name_uP),       --  parameter block
3621                   Make_Identifier (Loc, Name_uD),       --  delay
3622                   Make_Identifier (Loc, Name_uM),       --  delay mode
3623                   Make_Identifier (Loc, Name_uF))));    --  status flag
3624          end if;
3625
3626       else
3627          --  Initialize out parameters
3628
3629          Append_To (Stmts,
3630            Make_Assignment_Statement (Loc,
3631              Name       => Make_Identifier (Loc, Name_uF),
3632              Expression => New_Occurrence_Of (Standard_False, Loc)));
3633          Append_To (Stmts,
3634            Make_Assignment_Statement (Loc,
3635              Name       => Make_Identifier (Loc, Name_uC),
3636              Expression => New_Occurrence_Of (RTE (RE_POK_Function), Loc)));
3637       end if;
3638
3639       return
3640         Make_Subprogram_Body (Loc,
3641           Specification              => Make_Disp_Timed_Select_Spec (Typ),
3642           Declarations               => Decls,
3643           Handled_Statement_Sequence =>
3644             Make_Handled_Sequence_Of_Statements (Loc, Stmts));
3645    end Make_Disp_Timed_Select_Body;
3646
3647    ---------------------------------
3648    -- Make_Disp_Timed_Select_Spec --
3649    ---------------------------------
3650
3651    function Make_Disp_Timed_Select_Spec
3652      (Typ : Entity_Id) return Node_Id
3653    is
3654       Loc    : constant Source_Ptr := Sloc (Typ);
3655       Def_Id : constant Node_Id    :=
3656                  Make_Defining_Identifier (Loc,
3657                    Name_uDisp_Timed_Select);
3658       Params : constant List_Id    := New_List;
3659
3660    begin
3661       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3662
3663       --  T : in out Typ;        --  Object parameter
3664       --  S : Integer;           --  Primitive operation slot
3665       --  P : Address;           --  Wrapped parameters
3666       --  D : Duration;          --  Delay
3667       --  M : Integer;           --  Delay Mode
3668       --  C : out Prim_Op_Kind;  --  Call kind
3669       --  F : out Boolean;       --  Status flag
3670
3671       Append_List_To (Params, New_List (
3672
3673         Make_Parameter_Specification (Loc,
3674           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
3675           Parameter_Type      => New_Occurrence_Of (Typ, Loc),
3676           In_Present          => True,
3677           Out_Present         => True),
3678
3679         Make_Parameter_Specification (Loc,
3680           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS),
3681           Parameter_Type      => New_Occurrence_Of (Standard_Integer, Loc)),
3682
3683         Make_Parameter_Specification (Loc,
3684           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
3685           Parameter_Type      => New_Occurrence_Of (RTE (RE_Address), Loc)),
3686
3687         Make_Parameter_Specification (Loc,
3688           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uD),
3689           Parameter_Type      => New_Occurrence_Of (Standard_Duration, Loc)),
3690
3691         Make_Parameter_Specification (Loc,
3692           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uM),
3693           Parameter_Type      => New_Occurrence_Of (Standard_Integer, Loc)),
3694
3695         Make_Parameter_Specification (Loc,
3696           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC),
3697           Parameter_Type      =>
3698             New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc),
3699           Out_Present         => True)));
3700
3701       Append_To (Params,
3702         Make_Parameter_Specification (Loc,
3703           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF),
3704           Parameter_Type      => New_Occurrence_Of (Standard_Boolean, Loc),
3705           Out_Present         => True));
3706
3707       return
3708         Make_Procedure_Specification (Loc,
3709           Defining_Unit_Name       => Def_Id,
3710           Parameter_Specifications => Params);
3711    end Make_Disp_Timed_Select_Spec;
3712
3713    -------------
3714    -- Make_DT --
3715    -------------
3716
3717    --  The frontend supports two models for expanding dispatch tables
3718    --  associated with library-level defined tagged types: statically and
3719    --  non-statically allocated dispatch tables. In the former case the object
3720    --  containing the dispatch table is constant and it is initialized by means
3721    --  of a positional aggregate. In the latter case, the object containing
3722    --  the dispatch table is a variable which is initialized by means of
3723    --  assignments.
3724
3725    --  In case of locally defined tagged types, the object containing the
3726    --  object containing the dispatch table is always a variable (instead of a
3727    --  constant). This is currently required to give support to late overriding
3728    --  of primitives. For example:
3729
3730    --     procedure Example is
3731    --        package Pkg is
3732    --           type T1 is tagged null record;
3733    --           procedure Prim (O : T1);
3734    --        end Pkg;
3735
3736    --        type T2 is new Pkg.T1 with null record;
3737    --        procedure Prim (X : T2) is    -- late overriding
3738    --        begin
3739    --           ...
3740    --     ...
3741    --     end;
3742
3743    --  WARNING: This routine manages Ghost regions. Return statements must be
3744    --  replaced by gotos which jump to the end of the routine and restore the
3745    --  Ghost mode.
3746
3747    function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id is
3748       Loc : constant Source_Ptr := Sloc (Typ);
3749
3750       Max_Predef_Prims : constant Int :=
3751                            UI_To_Int
3752                              (Intval
3753                                (Expression
3754                                  (Parent (RTE (RE_Max_Predef_Prims)))));
3755
3756       DT_Decl : constant Elist_Id := New_Elmt_List;
3757       DT_Aggr : constant Elist_Id := New_Elmt_List;
3758       --  Entities marked with attribute Is_Dispatch_Table_Entity
3759
3760       procedure Check_Premature_Freezing
3761         (Subp        : Entity_Id;
3762          Tagged_Type : Entity_Id;
3763          Typ         : Entity_Id);
3764       --  Verify that all untagged types in the profile of a subprogram are
3765       --  frozen at the point the subprogram is frozen. This enforces the rule
3766       --  on RM 13.14 (14) as modified by AI05-019. At the point a subprogram
3767       --  is frozen, enough must be known about it to build the activation
3768       --  record for it, which requires at least that the size of all
3769       --  parameters be known. Controlling arguments are by-reference,
3770       --  and therefore the rule only applies to untagged types. Typical
3771       --  violation of the rule involves an object declaration that freezes a
3772       --  tagged type, when one of its primitive operations has a type in its
3773       --  profile whose full view has not been analyzed yet. More complex cases
3774       --  involve composite types that have one private unfrozen subcomponent.
3775
3776       procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0);
3777       --  Export the dispatch table DT of tagged type Typ. Required to generate
3778       --  forward references and statically allocate the table. For primary
3779       --  dispatch tables Index is 0; for secondary dispatch tables the value
3780       --  of index must match the Suffix_Index value assigned to the table by
3781       --  Make_Tags when generating its unique external name, and it is used to
3782       --  retrieve from the Dispatch_Table_Wrappers list associated with Typ
3783       --  the external name generated by Import_DT.
3784
3785       procedure Make_Secondary_DT
3786         (Typ              : Entity_Id;
3787          Iface            : Entity_Id;
3788          Suffix_Index     : Int;
3789          Num_Iface_Prims  : Nat;
3790          Iface_DT_Ptr     : Entity_Id;
3791          Predef_Prims_Ptr : Entity_Id;
3792          Build_Thunks     : Boolean;
3793          Result           : List_Id);
3794       --  Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch
3795       --  Table of Typ associated with Iface. Each abstract interface of Typ
3796       --  has two secondary dispatch tables: one containing pointers to thunks
3797       --  and another containing pointers to the primitives covering the
3798       --  interface primitives. The former secondary table is generated when
3799       --  Build_Thunks is True, and provides common support for dispatching
3800       --  calls through interface types; the latter secondary table is
3801       --  generated when Build_Thunks is False, and provides support for
3802       --  Generic Dispatching Constructors that dispatch calls through
3803       --  interface types. When constructing this latter table the value of
3804       --  Suffix_Index is -1 to indicate that there is no need to export such
3805       --  table when building statically allocated dispatch tables; a positive
3806       --  value of Suffix_Index must match the Suffix_Index value assigned to
3807       --  this secondary dispatch table by Make_Tags when its unique external
3808       --  name was generated.
3809
3810       ------------------------------
3811       -- Check_Premature_Freezing --
3812       ------------------------------
3813
3814       procedure Check_Premature_Freezing
3815         (Subp        : Entity_Id;
3816          Tagged_Type : Entity_Id;
3817          Typ         : Entity_Id)
3818       is
3819          Comp : Entity_Id;
3820
3821          function Is_Actual_For_Formal_Incomplete_Type
3822            (T : Entity_Id) return Boolean;
3823          --  In Ada 2012, if a nested generic has an incomplete formal type,
3824          --  the actual may be (and usually is) a private type whose completion
3825          --  appears later. It is safe to build the dispatch table in this
3826          --  case, gigi will have full views available.
3827
3828          ------------------------------------------
3829          -- Is_Actual_For_Formal_Incomplete_Type --
3830          ------------------------------------------
3831
3832          function Is_Actual_For_Formal_Incomplete_Type
3833            (T : Entity_Id) return Boolean
3834          is
3835             Gen_Par : Entity_Id;
3836             F       : Node_Id;
3837
3838          begin
3839             if not Is_Generic_Instance (Current_Scope)
3840               or else not Used_As_Generic_Actual (T)
3841             then
3842                return False;
3843             else
3844                Gen_Par := Generic_Parent (Parent (Current_Scope));
3845             end if;
3846
3847             F :=
3848               First
3849                 (Generic_Formal_Declarations
3850                    (Unit_Declaration_Node (Gen_Par)));
3851             while Present (F) loop
3852                if Ekind (Defining_Identifier (F)) = E_Incomplete_Type then
3853                   return True;
3854                end if;
3855
3856                Next (F);
3857             end loop;
3858
3859             return False;
3860          end Is_Actual_For_Formal_Incomplete_Type;
3861
3862       --  Start of processing for Check_Premature_Freezing
3863
3864       begin
3865          --  Note that if the type is a (subtype of) a generic actual, the
3866          --  actual will have been frozen by the instantiation.
3867
3868          if Present (N)
3869            and then Is_Private_Type (Typ)
3870            and then No (Full_View (Typ))
3871            and then not Is_Generic_Type (Typ)
3872            and then not Is_Tagged_Type (Typ)
3873            and then not Is_Frozen (Typ)
3874            and then not Is_Generic_Actual_Type (Typ)
3875          then
3876             Error_Msg_Sloc := Sloc (Subp);
3877             Error_Msg_NE
3878               ("declaration must appear after completion of type &", N, Typ);
3879             Error_Msg_NE
3880               ("\which is an untagged type in the profile of "
3881                & "primitive operation & declared#", N, Subp);
3882
3883          else
3884             Comp := Private_Component (Typ);
3885
3886             if not Is_Tagged_Type (Typ)
3887               and then Present (Comp)
3888               and then not Is_Frozen (Comp)
3889               and then not Is_Actual_For_Formal_Incomplete_Type (Comp)
3890             then
3891                Error_Msg_Sloc := Sloc (Subp);
3892                Error_Msg_Node_2 := Subp;
3893                Error_Msg_Name_1 := Chars (Tagged_Type);
3894                Error_Msg_NE
3895                  ("declaration must appear after completion of type &",
3896                   N, Comp);
3897                Error_Msg_NE
3898                  ("\which is a component of untagged type& in the profile "
3899                   & "of primitive & of type % that is frozen by the "
3900                   & "declaration ", N, Typ);
3901             end if;
3902          end if;
3903       end Check_Premature_Freezing;
3904
3905       ---------------
3906       -- Export_DT --
3907       ---------------
3908
3909       procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0)
3910       is
3911          Count : Nat;
3912          Elmt  : Elmt_Id;
3913
3914       begin
3915          Set_Is_Statically_Allocated (DT);
3916          Set_Is_True_Constant (DT);
3917          Set_Is_Exported (DT);
3918
3919          Count := 0;
3920          Elmt  := First_Elmt (Dispatch_Table_Wrappers (Typ));
3921          while Count /= Index loop
3922             Next_Elmt (Elmt);
3923             Count := Count + 1;
3924          end loop;
3925
3926          pragma Assert (Related_Type (Node (Elmt)) = Typ);
3927
3928          Get_External_Name (Node (Elmt));
3929          Set_Interface_Name (DT,
3930            Make_String_Literal (Loc,
3931              Strval => String_From_Name_Buffer));
3932
3933          --  Ensure proper Sprint output of this implicit importation
3934
3935          Set_Is_Internal (DT);
3936          Set_Is_Public (DT);
3937       end Export_DT;
3938
3939       -----------------------
3940       -- Make_Secondary_DT --
3941       -----------------------
3942
3943       procedure Make_Secondary_DT
3944         (Typ              : Entity_Id;
3945          Iface            : Entity_Id;
3946          Suffix_Index     : Int;
3947          Num_Iface_Prims  : Nat;
3948          Iface_DT_Ptr     : Entity_Id;
3949          Predef_Prims_Ptr : Entity_Id;
3950          Build_Thunks     : Boolean;
3951          Result           : List_Id)
3952       is
3953          Loc                : constant Source_Ptr := Sloc (Typ);
3954          Exporting_Table    : constant Boolean :=
3955                                 Building_Static_DT (Typ)
3956                                   and then Suffix_Index > 0;
3957          Iface_DT           : constant Entity_Id := Make_Temporary (Loc, 'T');
3958          Predef_Prims       : constant Entity_Id := Make_Temporary (Loc, 'R');
3959          DT_Constr_List     : List_Id;
3960          DT_Aggr_List       : List_Id;
3961          Empty_DT           : Boolean := False;
3962          Nb_Predef_Prims    : Nat := 0;
3963          Nb_Prim            : Nat;
3964          New_Node           : Node_Id;
3965          OSD                : Entity_Id;
3966          OSD_Aggr_List      : List_Id;
3967          Pos                : Nat;
3968          Prim               : Entity_Id;
3969          Prim_Elmt          : Elmt_Id;
3970          Prim_Ops_Aggr_List : List_Id;
3971
3972       begin
3973          --  Handle cases in which we do not generate statically allocated
3974          --  dispatch tables.
3975
3976          if not Building_Static_DT (Typ) then
3977             Set_Ekind (Predef_Prims, E_Variable);
3978             Set_Ekind (Iface_DT, E_Variable);
3979
3980          --  Statically allocated dispatch tables and related entities are
3981          --  constants.
3982
3983          else
3984             Set_Ekind (Predef_Prims, E_Constant);
3985             Set_Is_Statically_Allocated (Predef_Prims);
3986             Set_Is_True_Constant (Predef_Prims);
3987
3988             Set_Ekind (Iface_DT, E_Constant);
3989             Set_Is_Statically_Allocated (Iface_DT);
3990             Set_Is_True_Constant (Iface_DT);
3991          end if;
3992
3993          --  Calculate the number of slots of the dispatch table. If the number
3994          --  of primitives of Typ is 0 we reserve a dummy single entry for its
3995          --  DT because at run time the pointer to this dummy entry will be
3996          --  used as the tag.
3997
3998          if Num_Iface_Prims = 0 then
3999             Empty_DT := True;
4000             Nb_Prim  := 1;
4001          else
4002             Nb_Prim  := Num_Iface_Prims;
4003          end if;
4004
4005          --  Generate:
4006
4007          --   Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
4008          --                    (predef-prim-op-thunk-1'address,
4009          --                     predef-prim-op-thunk-2'address,
4010          --                     ...
4011          --                     predef-prim-op-thunk-n'address);
4012          --   for Predef_Prims'Alignment use Address'Alignment
4013
4014          --  Stage 1: Calculate the number of predefined primitives
4015
4016          if not Building_Static_DT (Typ) then
4017             Nb_Predef_Prims := Max_Predef_Prims;
4018          else
4019             Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4020             while Present (Prim_Elmt) loop
4021                Prim := Node (Prim_Elmt);
4022
4023                if Is_Predefined_Dispatching_Operation (Prim)
4024                  and then not Is_Abstract_Subprogram (Prim)
4025                then
4026                   Pos := UI_To_Int (DT_Position (Prim));
4027
4028                   if Pos > Nb_Predef_Prims then
4029                      Nb_Predef_Prims := Pos;
4030                   end if;
4031                end if;
4032
4033                Next_Elmt (Prim_Elmt);
4034             end loop;
4035          end if;
4036
4037          if Generate_SCIL then
4038             Nb_Predef_Prims := 0;
4039          end if;
4040
4041          --  Stage 2: Create the thunks associated with the predefined
4042          --  primitives and save their entity to fill the aggregate.
4043
4044          declare
4045             Prim_Table : array (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
4046             Decl       : Node_Id;
4047             Thunk_Id   : Entity_Id;
4048             Thunk_Code : Node_Id;
4049
4050          begin
4051             Prim_Ops_Aggr_List := New_List;
4052             Prim_Table := (others => Empty);
4053
4054             if Building_Static_DT (Typ) then
4055                Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4056                while Present (Prim_Elmt) loop
4057                   Prim := Node (Prim_Elmt);
4058
4059                   if Is_Predefined_Dispatching_Operation (Prim)
4060                     and then not Is_Abstract_Subprogram (Prim)
4061                     and then not Is_Eliminated (Prim)
4062                     and then not Generate_SCIL
4063                     and then not Present (Prim_Table
4064                                            (UI_To_Int (DT_Position (Prim))))
4065                   then
4066                      if not Build_Thunks then
4067                         Prim_Table (UI_To_Int (DT_Position (Prim))) :=
4068                           Alias (Prim);
4069
4070                      else
4071                         Expand_Interface_Thunk
4072                           (Ultimate_Alias (Prim), Thunk_Id, Thunk_Code);
4073
4074                         if Present (Thunk_Id) then
4075                            Append_To (Result, Thunk_Code);
4076                            Prim_Table (UI_To_Int (DT_Position (Prim))) :=
4077                              Thunk_Id;
4078                         end if;
4079                      end if;
4080                   end if;
4081
4082                   Next_Elmt (Prim_Elmt);
4083                end loop;
4084             end if;
4085
4086             for J in Prim_Table'Range loop
4087                if Present (Prim_Table (J)) then
4088                   New_Node :=
4089                     Unchecked_Convert_To (RTE (RE_Prim_Ptr),
4090                       Make_Attribute_Reference (Loc,
4091                         Prefix => New_Occurrence_Of (Prim_Table (J), Loc),
4092                         Attribute_Name => Name_Unrestricted_Access));
4093                else
4094                   New_Node := Make_Null (Loc);
4095                end if;
4096
4097                Append_To (Prim_Ops_Aggr_List, New_Node);
4098             end loop;
4099
4100             New_Node :=
4101               Make_Aggregate (Loc, Expressions => Prim_Ops_Aggr_List);
4102
4103             --  Remember aggregates initializing dispatch tables
4104
4105             Append_Elmt (New_Node, DT_Aggr);
4106
4107             Decl :=
4108               Make_Subtype_Declaration (Loc,
4109                 Defining_Identifier => Make_Temporary (Loc, 'S'),
4110                 Subtype_Indication  =>
4111                   New_Occurrence_Of (RTE (RE_Address_Array), Loc));
4112
4113             Append_To (Result, Decl);
4114
4115             Append_To (Result,
4116               Make_Object_Declaration (Loc,
4117                 Defining_Identifier => Predef_Prims,
4118                 Constant_Present    => Building_Static_DT (Typ),
4119                 Aliased_Present     => True,
4120                 Object_Definition   => New_Occurrence_Of
4121                                          (Defining_Identifier (Decl), Loc),
4122                 Expression => New_Node));
4123
4124             Append_To (Result,
4125               Make_Attribute_Definition_Clause (Loc,
4126                 Name       => New_Occurrence_Of (Predef_Prims, Loc),
4127                 Chars      => Name_Alignment,
4128                 Expression =>
4129                   Make_Attribute_Reference (Loc,
4130                     Prefix =>
4131                       New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
4132                     Attribute_Name => Name_Alignment)));
4133          end;
4134
4135          --  Generate
4136
4137          --   OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) :=
4138          --          (OSD_Table => (1 => <value>,
4139          --                           ...
4140          --                         N => <value>));
4141
4142          --   Iface_DT : Dispatch_Table (Nb_Prims) :=
4143          --               ([ Signature   => <sig-value> ],
4144          --                Tag_Kind      => <tag_kind-value>,
4145          --                Predef_Prims  => Predef_Prims'Address,
4146          --                Offset_To_Top => 0,
4147          --                OSD           => OSD'Address,
4148          --                Prims_Ptr     => (prim-op-1'address,
4149          --                                  prim-op-2'address,
4150          --                                  ...
4151          --                                  prim-op-n'address));
4152          --   for Iface_DT'Alignment use Address'Alignment;
4153
4154          --  Stage 3: Initialize the discriminant and the record components
4155
4156          DT_Constr_List := New_List;
4157          DT_Aggr_List   := New_List;
4158
4159          --  Nb_Prim
4160
4161          Append_To (DT_Constr_List, Make_Integer_Literal (Loc, Nb_Prim));
4162          Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, Nb_Prim));
4163
4164          --  Signature
4165
4166          if RTE_Record_Component_Available (RE_Signature) then
4167             Append_To (DT_Aggr_List,
4168               New_Occurrence_Of (RTE (RE_Secondary_DT), Loc));
4169          end if;
4170
4171          --  Tag_Kind
4172
4173          if RTE_Record_Component_Available (RE_Tag_Kind) then
4174             Append_To (DT_Aggr_List, Tagged_Kind (Typ));
4175          end if;
4176
4177          --  Predef_Prims
4178
4179          Append_To (DT_Aggr_List,
4180            Make_Attribute_Reference (Loc,
4181              Prefix         => New_Occurrence_Of (Predef_Prims, Loc),
4182              Attribute_Name => Name_Address));
4183
4184          --  Note: The correct value of Offset_To_Top will be set by the init
4185          --  subprogram
4186
4187          Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
4188
4189          --  Generate the Object Specific Data table required to dispatch calls
4190          --  through synchronized interfaces.
4191
4192          if Empty_DT
4193            or else Is_Abstract_Type (Typ)
4194            or else Is_Controlled (Typ)
4195            or else Restriction_Active (No_Dispatching_Calls)
4196            or else not Is_Limited_Type (Typ)
4197            or else not Has_Interfaces (Typ)
4198            or else not Build_Thunks
4199            or else not RTE_Record_Component_Available (RE_OSD_Table)
4200          then
4201             --  No OSD table required
4202
4203             Append_To (DT_Aggr_List,
4204               New_Occurrence_Of (RTE (RE_Null_Address), Loc));
4205
4206          else
4207             OSD_Aggr_List := New_List;
4208
4209             declare
4210                Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
4211                Prim       : Entity_Id;
4212                Prim_Alias : Entity_Id;
4213                Prim_Elmt  : Elmt_Id;
4214                E          : Entity_Id;
4215                Count      : Nat := 0;
4216                Pos        : Nat;
4217
4218             begin
4219                Prim_Table := (others => Empty);
4220                Prim_Alias := Empty;
4221
4222                Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4223                while Present (Prim_Elmt) loop
4224                   Prim := Node (Prim_Elmt);
4225
4226                   if Present (Interface_Alias (Prim))
4227                     and then Find_Dispatching_Type
4228                                (Interface_Alias (Prim)) = Iface
4229                   then
4230                      Prim_Alias := Interface_Alias (Prim);
4231                      E   := Ultimate_Alias (Prim);
4232                      Pos := UI_To_Int (DT_Position (Prim_Alias));
4233
4234                      if Present (Prim_Table (Pos)) then
4235                         pragma Assert (Prim_Table (Pos) = E);
4236                         null;
4237
4238                      else
4239                         Prim_Table (Pos) := E;
4240
4241                         Append_To (OSD_Aggr_List,
4242                           Make_Component_Association (Loc,
4243                             Choices    => New_List (
4244                               Make_Integer_Literal (Loc,
4245                                 DT_Position (Prim_Alias))),
4246                             Expression =>
4247                               Make_Integer_Literal (Loc,
4248                                 DT_Position (Alias (Prim)))));
4249
4250                         Count := Count + 1;
4251                      end if;
4252                   end if;
4253
4254                   Next_Elmt (Prim_Elmt);
4255                end loop;
4256                pragma Assert (Count = Nb_Prim);
4257             end;
4258
4259             OSD := Make_Temporary (Loc, 'I');
4260
4261             Append_To (Result,
4262               Make_Object_Declaration (Loc,
4263                 Defining_Identifier => OSD,
4264                 Object_Definition   =>
4265                   Make_Subtype_Indication (Loc,
4266                     Subtype_Mark =>
4267                       New_Occurrence_Of (RTE (RE_Object_Specific_Data), Loc),
4268                     Constraint   =>
4269                       Make_Index_Or_Discriminant_Constraint (Loc,
4270                         Constraints => New_List (
4271                           Make_Integer_Literal (Loc, Nb_Prim)))),
4272
4273                 Expression          =>
4274                   Make_Aggregate (Loc,
4275                     Component_Associations => New_List (
4276                       Make_Component_Association (Loc,
4277                         Choices    => New_List (
4278                           New_Occurrence_Of
4279                             (RTE_Record_Component (RE_OSD_Num_Prims), Loc)),
4280                         Expression =>
4281                           Make_Integer_Literal (Loc, Nb_Prim)),
4282
4283                       Make_Component_Association (Loc,
4284                         Choices    => New_List (
4285                           New_Occurrence_Of
4286                             (RTE_Record_Component (RE_OSD_Table), Loc)),
4287                         Expression => Make_Aggregate (Loc,
4288                           Component_Associations => OSD_Aggr_List))))));
4289
4290             Append_To (Result,
4291               Make_Attribute_Definition_Clause (Loc,
4292                 Name       => New_Occurrence_Of (OSD, Loc),
4293                 Chars      => Name_Alignment,
4294                 Expression =>
4295                   Make_Attribute_Reference (Loc,
4296                     Prefix         =>
4297                       New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
4298                     Attribute_Name => Name_Alignment)));
4299
4300             --  In secondary dispatch tables the Typeinfo component contains
4301             --  the address of the Object Specific Data (see a-tags.ads)
4302
4303             Append_To (DT_Aggr_List,
4304               Make_Attribute_Reference (Loc,
4305                 Prefix         => New_Occurrence_Of (OSD, Loc),
4306                 Attribute_Name => Name_Address));
4307          end if;
4308
4309          --  Initialize the table of primitive operations
4310
4311          Prim_Ops_Aggr_List := New_List;
4312
4313          if Empty_DT then
4314             Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
4315
4316          elsif Is_Abstract_Type (Typ)
4317            or else not Building_Static_DT (Typ)
4318          then
4319             for J in 1 .. Nb_Prim loop
4320                Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
4321             end loop;
4322
4323          else
4324             declare
4325                CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
4326                E            : Entity_Id;
4327                Prim_Pos     : Nat;
4328                Prim_Table   : array (Nat range 1 .. Nb_Prim) of Entity_Id;
4329                Thunk_Code   : Node_Id;
4330                Thunk_Id     : Entity_Id;
4331
4332             begin
4333                Prim_Table := (others => Empty);
4334
4335                Prim_Elmt  := First_Elmt (Primitive_Operations (Typ));
4336                while Present (Prim_Elmt) loop
4337                   Prim     := Node (Prim_Elmt);
4338                   E        := Ultimate_Alias (Prim);
4339                   Prim_Pos := UI_To_Int (DT_Position (E));
4340
4341                   --  Do not reference predefined primitives because they are
4342                   --  located in a separate dispatch table; skip abstract and
4343                   --  eliminated primitives; skip primitives located in the C++
4344                   --  part of the dispatch table because their slot is set by
4345                   --  the IC routine.
4346
4347                   if not Is_Predefined_Dispatching_Operation (Prim)
4348                     and then Present (Interface_Alias (Prim))
4349                     and then not Is_Abstract_Subprogram (Alias (Prim))
4350                     and then not Is_Eliminated (Alias (Prim))
4351                     and then (not Is_CPP_Class (Root_Type (Typ))
4352                                or else Prim_Pos > CPP_Nb_Prims)
4353                     and then Find_Dispatching_Type
4354                                (Interface_Alias (Prim)) = Iface
4355
4356                      --  Generate the code of the thunk only if the abstract
4357                      --  interface type is not an immediate ancestor of
4358                      --  Tagged_Type. Otherwise the DT associated with the
4359                      --  interface is the primary DT.
4360
4361                     and then not Is_Ancestor (Iface, Typ,
4362                                               Use_Full_View => True)
4363                   then
4364                      if not Build_Thunks then
4365                         Prim_Pos :=
4366                           UI_To_Int (DT_Position (Interface_Alias (Prim)));
4367                         Prim_Table (Prim_Pos) := Alias (Prim);
4368
4369                      else
4370                         Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
4371
4372                         if Present (Thunk_Id) then
4373                            Prim_Pos :=
4374                              UI_To_Int (DT_Position (Interface_Alias (Prim)));
4375
4376                            Prim_Table (Prim_Pos) := Thunk_Id;
4377                            Append_To (Result, Thunk_Code);
4378                         end if;
4379                      end if;
4380                   end if;
4381
4382                   Next_Elmt (Prim_Elmt);
4383                end loop;
4384
4385                for J in Prim_Table'Range loop
4386                   if Present (Prim_Table (J)) then
4387                      New_Node :=
4388                        Unchecked_Convert_To (RTE (RE_Prim_Ptr),
4389                          Make_Attribute_Reference (Loc,
4390                            Prefix => New_Occurrence_Of (Prim_Table (J), Loc),
4391                            Attribute_Name => Name_Unrestricted_Access));
4392
4393                   else
4394                      New_Node := Make_Null (Loc);
4395                   end if;
4396
4397                   Append_To (Prim_Ops_Aggr_List, New_Node);
4398                end loop;
4399             end;
4400          end if;
4401
4402          New_Node :=
4403            Make_Aggregate (Loc,
4404              Expressions => Prim_Ops_Aggr_List);
4405
4406          Append_To (DT_Aggr_List, New_Node);
4407
4408          --  Remember aggregates initializing dispatch tables
4409
4410          Append_Elmt (New_Node, DT_Aggr);
4411
4412          --  Note: Secondary dispatch tables cannot be declared constant
4413          --  because the component Offset_To_Top is currently initialized
4414          --  by the IP routine.
4415
4416          Append_To (Result,
4417            Make_Object_Declaration (Loc,
4418              Defining_Identifier => Iface_DT,
4419              Aliased_Present     => True,
4420              Constant_Present    => False,
4421
4422              Object_Definition   =>
4423                Make_Subtype_Indication (Loc,
4424                  Subtype_Mark => New_Occurrence_Of
4425                                    (RTE (RE_Dispatch_Table_Wrapper), Loc),
4426                  Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
4427                                    Constraints => DT_Constr_List)),
4428
4429              Expression          =>
4430                Make_Aggregate (Loc,
4431                  Expressions => DT_Aggr_List)));
4432
4433          Append_To (Result,
4434            Make_Attribute_Definition_Clause (Loc,
4435              Name       => New_Occurrence_Of (Iface_DT, Loc),
4436              Chars      => Name_Alignment,
4437
4438              Expression =>
4439                Make_Attribute_Reference (Loc,
4440                  Prefix         =>
4441                    New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
4442                  Attribute_Name => Name_Alignment)));
4443
4444          if Exporting_Table then
4445             Export_DT (Typ, Iface_DT, Suffix_Index);
4446
4447          --  Generate code to create the pointer to the dispatch table
4448
4449          --    Iface_DT_Ptr : Tag := Tag!(DT.Prims_Ptr'Address);
4450
4451          --  Note: This declaration is not added here if the table is exported
4452          --  because in such case Make_Tags has already added this declaration.
4453
4454          else
4455             Append_To (Result,
4456               Make_Object_Declaration (Loc,
4457                 Defining_Identifier => Iface_DT_Ptr,
4458                 Constant_Present    => True,
4459
4460                 Object_Definition   =>
4461                   New_Occurrence_Of (RTE (RE_Interface_Tag), Loc),
4462
4463                 Expression          =>
4464                   Unchecked_Convert_To (RTE (RE_Interface_Tag),
4465                     Make_Attribute_Reference (Loc,
4466                       Prefix         =>
4467                         Make_Selected_Component (Loc,
4468                           Prefix        => New_Occurrence_Of (Iface_DT, Loc),
4469                           Selector_Name =>
4470                             New_Occurrence_Of
4471                               (RTE_Record_Component (RE_Prims_Ptr), Loc)),
4472                       Attribute_Name => Name_Address))));
4473          end if;
4474
4475          Append_To (Result,
4476            Make_Object_Declaration (Loc,
4477              Defining_Identifier => Predef_Prims_Ptr,
4478              Constant_Present    => True,
4479
4480              Object_Definition   =>
4481                New_Occurrence_Of (RTE (RE_Address), Loc),
4482
4483              Expression          =>
4484                Make_Attribute_Reference (Loc,
4485                  Prefix         =>
4486                    Make_Selected_Component (Loc,
4487                      Prefix        => New_Occurrence_Of (Iface_DT, Loc),
4488                      Selector_Name =>
4489                        New_Occurrence_Of
4490                          (RTE_Record_Component (RE_Predef_Prims), Loc)),
4491                  Attribute_Name => Name_Address)));
4492
4493          --  Remember entities containing dispatch tables
4494
4495          Append_Elmt (Predef_Prims, DT_Decl);
4496          Append_Elmt (Iface_DT, DT_Decl);
4497       end Make_Secondary_DT;
4498
4499       --  Local variables
4500
4501       Elab_Code : constant List_Id := New_List;
4502       Result    : constant List_Id := New_List;
4503       Tname     : constant Name_Id := Chars (Typ);
4504
4505       --  The following name entries are used by Make_DT to generate a number
4506       --  of entities related to a tagged type. These entities may be generated
4507       --  in a scope other than that of the tagged type declaration, and if
4508       --  the entities for two tagged types with the same name happen to be
4509       --  generated in the same scope, we have to take care to use different
4510       --  names. This is achieved by means of a unique serial number appended
4511       --  to each generated entity name.
4512
4513       Name_DT           : constant Name_Id :=
4514                             New_External_Name (Tname, 'T', Suffix_Index => -1);
4515       Name_Exname       : constant Name_Id :=
4516                             New_External_Name (Tname, 'E', Suffix_Index => -1);
4517       Name_HT_Link      : constant Name_Id :=
4518                             New_External_Name (Tname, 'H', Suffix_Index => -1);
4519       Name_Predef_Prims : constant Name_Id :=
4520                             New_External_Name (Tname, 'R', Suffix_Index => -1);
4521       Name_SSD          : constant Name_Id :=
4522                             New_External_Name (Tname, 'S', Suffix_Index => -1);
4523       Name_TSD          : constant Name_Id :=
4524                             New_External_Name (Tname, 'B', Suffix_Index => -1);
4525
4526       Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
4527       --  Save the Ghost mode to restore on exit
4528
4529       AI                 : Elmt_Id;
4530       AI_Tag_Elmt        : Elmt_Id;
4531       AI_Tag_Comp        : Elmt_Id;
4532       DT                 : Entity_Id;
4533       DT_Aggr_List       : List_Id;
4534       DT_Constr_List     : List_Id;
4535       DT_Ptr             : Entity_Id;
4536       Exname             : Entity_Id;
4537       HT_Link            : Entity_Id;
4538       ITable             : Node_Id;
4539       I_Depth            : Nat := 0;
4540       Iface_Table_Node   : Node_Id;
4541       Name_ITable        : Name_Id;
4542       Nb_Predef_Prims    : Nat := 0;
4543       Nb_Prim            : Nat := 0;
4544       New_Node           : Node_Id;
4545       Num_Ifaces         : Nat := 0;
4546       Parent_Typ         : Entity_Id;
4547       Predef_Prims       : Entity_Id;
4548       Prim               : Entity_Id;
4549       Prim_Elmt          : Elmt_Id;
4550       Prim_Ops_Aggr_List : List_Id;
4551       SSD                : Entity_Id;
4552       Suffix_Index       : Int;
4553       Typ_Comps          : Elist_Id;
4554       Typ_Ifaces         : Elist_Id;
4555       TSD                : Entity_Id;
4556       TSD_Aggr_List      : List_Id;
4557       TSD_Tags_List      : List_Id;
4558
4559    --  Start of processing for Make_DT
4560
4561    begin
4562       pragma Assert (Is_Frozen (Typ));
4563
4564       --  The tagged type being processed may be subject to pragma Ghost. Set
4565       --  the mode now to ensure that any nodes generated during dispatch table
4566       --  creation are properly marked as Ghost.
4567
4568       Set_Ghost_Mode (Typ);
4569
4570       --  Handle cases in which there is no need to build the dispatch table
4571
4572       if Has_Dispatch_Table (Typ)
4573         or else No (Access_Disp_Table (Typ))
4574         or else Is_CPP_Class (Typ)
4575       then
4576          goto Leave;
4577
4578       elsif No_Run_Time_Mode then
4579          Error_Msg_CRT ("tagged types", Typ);
4580          goto Leave;
4581
4582       elsif not RTE_Available (RE_Tag) then
4583          Append_To (Result,
4584            Make_Object_Declaration (Loc,
4585              Defining_Identifier =>
4586                Node (First_Elmt (Access_Disp_Table (Typ))),
4587              Object_Definition   => New_Occurrence_Of (RTE (RE_Tag), Loc),
4588              Constant_Present    => True,
4589              Expression =>
4590                Unchecked_Convert_To (RTE (RE_Tag),
4591                  New_Occurrence_Of (RTE (RE_Null_Address), Loc))));
4592
4593          Analyze_List (Result, Suppress => All_Checks);
4594          Error_Msg_CRT ("tagged types", Typ);
4595          goto Leave;
4596       end if;
4597
4598       --  Ensure that the value of Max_Predef_Prims defined in a-tags is
4599       --  correct. Valid values are 9 under configurable runtime or 15
4600       --  with full runtime.
4601
4602       if RTE_Available (RE_Interface_Data) then
4603          if Max_Predef_Prims /= 15 then
4604             Error_Msg_N ("run-time library configuration error", Typ);
4605             goto Leave;
4606          end if;
4607       else
4608          if Max_Predef_Prims /= 9 then
4609             Error_Msg_N ("run-time library configuration error", Typ);
4610             Error_Msg_CRT ("tagged types", Typ);
4611             goto Leave;
4612          end if;
4613       end if;
4614
4615       DT           := Make_Defining_Identifier (Loc, Name_DT);
4616       Exname       := Make_Defining_Identifier (Loc, Name_Exname);
4617       HT_Link      := Make_Defining_Identifier (Loc, Name_HT_Link);
4618       Predef_Prims := Make_Defining_Identifier (Loc, Name_Predef_Prims);
4619       SSD          := Make_Defining_Identifier (Loc, Name_SSD);
4620       TSD          := Make_Defining_Identifier (Loc, Name_TSD);
4621
4622       --  Initialize Parent_Typ handling private types
4623
4624       Parent_Typ := Etype (Typ);
4625
4626       if Present (Full_View (Parent_Typ)) then
4627          Parent_Typ := Full_View (Parent_Typ);
4628       end if;
4629
4630       --  Ensure that all the primitives are frozen. This is only required when
4631       --  building static dispatch tables --- the primitives must be frozen to
4632       --  be referenced (otherwise we have problems with the backend). It is
4633       --  not a requirement with nonstatic dispatch tables because in this case
4634       --  we generate now an empty dispatch table; the extra code required to
4635       --  register the primitives in the slots will be generated later --- when
4636       --  each primitive is frozen (see Freeze_Subprogram).
4637
4638       if Building_Static_DT (Typ) then
4639          declare
4640             Saved_FLLTT : constant Boolean :=
4641                             Freezing_Library_Level_Tagged_Type;
4642
4643             Formal    : Entity_Id;
4644             Frnodes   : List_Id;
4645             Prim      : Entity_Id;
4646             Prim_Elmt : Elmt_Id;
4647
4648          begin
4649             Freezing_Library_Level_Tagged_Type := True;
4650
4651             Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4652             while Present (Prim_Elmt) loop
4653                Prim    := Node (Prim_Elmt);
4654                Frnodes := Freeze_Entity (Prim, Typ);
4655
4656                --  We disable this check for abstract subprograms, given that
4657                --  they cannot be called directly and thus the state of their
4658                --  untagged formals is of no concern. The RM is unclear in any
4659                --  case concerning the need for this check, and this topic may
4660                --  go back to the ARG.
4661
4662                if not Is_Abstract_Subprogram (Prim)  then
4663                   Formal := First_Formal (Prim);
4664                   while Present (Formal) loop
4665                      Check_Premature_Freezing (Prim, Typ, Etype (Formal));
4666                      Next_Formal (Formal);
4667                   end loop;
4668
4669                   Check_Premature_Freezing (Prim, Typ, Etype (Prim));
4670                end if;
4671
4672                if Present (Frnodes) then
4673                   Append_List_To (Result, Frnodes);
4674                end if;
4675
4676                Next_Elmt (Prim_Elmt);
4677             end loop;
4678
4679             Freezing_Library_Level_Tagged_Type := Saved_FLLTT;
4680          end;
4681       end if;
4682
4683       --  Ada 2005 (AI-251): Build the secondary dispatch tables
4684
4685       if Has_Interfaces (Typ) then
4686          Collect_Interface_Components (Typ, Typ_Comps);
4687
4688          --  Each secondary dispatch table is assigned an unique positive
4689          --  suffix index; such value also corresponds with the location of
4690          --  its entity in the Dispatch_Table_Wrappers list (see Make_Tags).
4691
4692          --  Note: This value must be kept sync with the Suffix_Index values
4693          --  generated by Make_Tags
4694
4695          Suffix_Index := 1;
4696          AI_Tag_Elmt  :=
4697            Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
4698
4699          AI_Tag_Comp := First_Elmt (Typ_Comps);
4700          while Present (AI_Tag_Comp) loop
4701             pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'P'));
4702
4703             --  Build the secondary table containing pointers to thunks
4704
4705             Make_Secondary_DT
4706              (Typ              => Typ,
4707               Iface            => Base_Type
4708                                     (Related_Type (Node (AI_Tag_Comp))),
4709               Suffix_Index     => Suffix_Index,
4710               Num_Iface_Prims  => UI_To_Int
4711                                     (DT_Entry_Count (Node (AI_Tag_Comp))),
4712               Iface_DT_Ptr     => Node (AI_Tag_Elmt),
4713               Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
4714               Build_Thunks     => True,
4715               Result           => Result);
4716
4717             --  Skip secondary dispatch table referencing thunks to predefined
4718             --  primitives.
4719
4720             Next_Elmt (AI_Tag_Elmt);
4721             pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Y'));
4722
4723             --  Secondary dispatch table referencing user-defined primitives
4724             --  covered by this interface.
4725
4726             Next_Elmt (AI_Tag_Elmt);
4727             pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'D'));
4728
4729             --  Build the secondary table containing pointers to primitives
4730             --  (used to give support to Generic Dispatching Constructors).
4731
4732             Make_Secondary_DT
4733               (Typ              => Typ,
4734                Iface            => Base_Type
4735                                      (Related_Type (Node (AI_Tag_Comp))),
4736                Suffix_Index     => -1,
4737                Num_Iface_Prims  => UI_To_Int
4738                                      (DT_Entry_Count (Node (AI_Tag_Comp))),
4739                Iface_DT_Ptr     => Node (AI_Tag_Elmt),
4740                Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
4741                Build_Thunks     => False,
4742                Result           => Result);
4743
4744             --  Skip secondary dispatch table referencing predefined primitives
4745
4746             Next_Elmt (AI_Tag_Elmt);
4747             pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Z'));
4748
4749             Suffix_Index := Suffix_Index + 1;
4750             Next_Elmt (AI_Tag_Elmt);
4751             Next_Elmt (AI_Tag_Comp);
4752          end loop;
4753       end if;
4754
4755       --  Get the _tag entity and number of primitives of its dispatch table
4756
4757       DT_Ptr  := Node (First_Elmt (Access_Disp_Table (Typ)));
4758       Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
4759
4760       if Generate_SCIL then
4761          Nb_Prim := 0;
4762       end if;
4763
4764       Set_Is_Statically_Allocated (DT,  Is_Library_Level_Tagged_Type (Typ));
4765       Set_Is_Statically_Allocated (SSD, Is_Library_Level_Tagged_Type (Typ));
4766       Set_Is_Statically_Allocated (TSD, Is_Library_Level_Tagged_Type (Typ));
4767       Set_Is_Statically_Allocated (Predef_Prims,
4768         Is_Library_Level_Tagged_Type (Typ));
4769
4770       --  In case of locally defined tagged type we declare the object
4771       --  containing the dispatch table by means of a variable. Its
4772       --  initialization is done later by means of an assignment. This is
4773       --  required to generate its External_Tag.
4774
4775       if not Building_Static_DT (Typ) then
4776
4777          --  Generate:
4778          --    DT     : No_Dispatch_Table_Wrapper;
4779          --    for DT'Alignment use Address'Alignment;
4780          --    DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address);
4781
4782          if not Has_DT (Typ) then
4783             Append_To (Result,
4784               Make_Object_Declaration (Loc,
4785                 Defining_Identifier => DT,
4786                 Aliased_Present     => True,
4787                 Constant_Present    => False,
4788                 Object_Definition   =>
4789                   New_Occurrence_Of
4790                     (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
4791
4792             Append_To (Result,
4793               Make_Attribute_Definition_Clause (Loc,
4794                 Name       => New_Occurrence_Of (DT, Loc),
4795                 Chars      => Name_Alignment,
4796                 Expression =>
4797                   Make_Attribute_Reference (Loc,
4798                     Prefix         =>
4799                       New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
4800                     Attribute_Name => Name_Alignment)));
4801
4802             Append_To (Result,
4803               Make_Object_Declaration (Loc,
4804                 Defining_Identifier => DT_Ptr,
4805                 Object_Definition   => New_Occurrence_Of (RTE (RE_Tag), Loc),
4806                 Constant_Present    => True,
4807                 Expression =>
4808                   Unchecked_Convert_To (RTE (RE_Tag),
4809                     Make_Attribute_Reference (Loc,
4810                       Prefix         =>
4811                         Make_Selected_Component (Loc,
4812                           Prefix        => New_Occurrence_Of (DT, Loc),
4813                           Selector_Name =>
4814                             New_Occurrence_Of
4815                               (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
4816                       Attribute_Name => Name_Address))));
4817
4818             Set_Is_Statically_Allocated (DT_Ptr,
4819               Is_Library_Level_Tagged_Type (Typ));
4820
4821             --  Generate the SCIL node for the previous object declaration
4822             --  because it has a tag initialization.
4823
4824             if Generate_SCIL then
4825                New_Node :=
4826                  Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
4827                Set_SCIL_Entity (New_Node, Typ);
4828                Set_SCIL_Node (Last (Result), New_Node);
4829
4830                goto Leave_SCIL;
4831
4832                --  Gnat2scil has its own implementation of dispatch tables,
4833                --  different than what is being implemented here. Generating
4834                --  further dispatch table initialization code would just
4835                --  cause gnat2scil to generate useless Scil which CodePeer
4836                --  would waste time and space analyzing, so we skip it.
4837             end if;
4838
4839          --  Generate:
4840          --    DT : Dispatch_Table_Wrapper (Nb_Prim);
4841          --    for DT'Alignment use Address'Alignment;
4842          --    DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address);
4843
4844          else
4845             --  If the tagged type has no primitives we add a dummy slot
4846             --  whose address will be the tag of this type.
4847
4848             if Nb_Prim = 0 then
4849                DT_Constr_List :=
4850                  New_List (Make_Integer_Literal (Loc, 1));
4851             else
4852                DT_Constr_List :=
4853                  New_List (Make_Integer_Literal (Loc, Nb_Prim));
4854             end if;
4855
4856             Append_To (Result,
4857               Make_Object_Declaration (Loc,
4858                 Defining_Identifier => DT,
4859                 Aliased_Present     => True,
4860                 Constant_Present    => False,
4861                 Object_Definition   =>
4862                   Make_Subtype_Indication (Loc,
4863                     Subtype_Mark =>
4864                       New_Occurrence_Of (RTE (RE_Dispatch_Table_Wrapper), Loc),
4865                     Constraint   =>
4866                       Make_Index_Or_Discriminant_Constraint (Loc,
4867                         Constraints => DT_Constr_List))));
4868
4869             Append_To (Result,
4870               Make_Attribute_Definition_Clause (Loc,
4871                 Name       => New_Occurrence_Of (DT, Loc),
4872                 Chars      => Name_Alignment,
4873                 Expression =>
4874                   Make_Attribute_Reference (Loc,
4875                     Prefix         =>
4876                       New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
4877                     Attribute_Name => Name_Alignment)));
4878
4879             Append_To (Result,
4880               Make_Object_Declaration (Loc,
4881                 Defining_Identifier => DT_Ptr,
4882                 Object_Definition   => New_Occurrence_Of (RTE (RE_Tag), Loc),
4883                 Constant_Present    => True,
4884                 Expression =>
4885                   Unchecked_Convert_To (RTE (RE_Tag),
4886                     Make_Attribute_Reference (Loc,
4887                       Prefix         =>
4888                         Make_Selected_Component (Loc,
4889                           Prefix        => New_Occurrence_Of (DT, Loc),
4890                           Selector_Name =>
4891                             New_Occurrence_Of
4892                               (RTE_Record_Component (RE_Prims_Ptr), Loc)),
4893                       Attribute_Name => Name_Address))));
4894
4895             Set_Is_Statically_Allocated (DT_Ptr,
4896               Is_Library_Level_Tagged_Type (Typ));
4897
4898             --  Generate the SCIL node for the previous object declaration
4899             --  because it has a tag initialization.
4900
4901             if Generate_SCIL then
4902                New_Node :=
4903                  Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
4904                Set_SCIL_Entity (New_Node, Typ);
4905                Set_SCIL_Node (Last (Result), New_Node);
4906
4907                goto Leave_SCIL;
4908
4909                --  Gnat2scil has its own implementation of dispatch tables,
4910                --  different than what is being implemented here. Generating
4911                --  further dispatch table initialization code would just
4912                --  cause gnat2scil to generate useless Scil which CodePeer
4913                --  would waste time and space analyzing, so we skip it.
4914             end if;
4915
4916             Append_To (Result,
4917               Make_Object_Declaration (Loc,
4918                 Defining_Identifier =>
4919                   Node (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))),
4920                 Constant_Present    => True,
4921                 Object_Definition   =>
4922                   New_Occurrence_Of (RTE (RE_Address), Loc),
4923                 Expression =>
4924                   Make_Attribute_Reference (Loc,
4925                     Prefix         =>
4926                       Make_Selected_Component (Loc,
4927                         Prefix        => New_Occurrence_Of (DT, Loc),
4928                         Selector_Name =>
4929                           New_Occurrence_Of
4930                             (RTE_Record_Component (RE_Predef_Prims), Loc)),
4931                     Attribute_Name => Name_Address)));
4932          end if;
4933       end if;
4934
4935       --  Generate: Exname : constant String := full_qualified_name (typ);
4936       --  The type itself may be an anonymous parent type, so use the first
4937       --  subtype to have a user-recognizable name.
4938
4939       Append_To (Result,
4940         Make_Object_Declaration (Loc,
4941           Defining_Identifier => Exname,
4942           Constant_Present    => True,
4943           Object_Definition   => New_Occurrence_Of (Standard_String, Loc),
4944           Expression =>
4945             Make_String_Literal (Loc,
4946               Strval => Fully_Qualified_Name_String (First_Subtype (Typ)))));
4947       Set_Is_Statically_Allocated (Exname);
4948       Set_Is_True_Constant (Exname);
4949
4950       --  Declare the object used by Ada.Tags.Register_Tag
4951
4952       if RTE_Available (RE_Register_Tag) then
4953          Append_To (Result,
4954            Make_Object_Declaration (Loc,
4955              Defining_Identifier => HT_Link,
4956              Object_Definition   => New_Occurrence_Of (RTE (RE_Tag), Loc)));
4957       end if;
4958
4959       --  Generate code to create the storage for the type specific data object
4960       --  with enough space to store the tags of the ancestors plus the tags
4961       --  of all the implemented interfaces (as described in a-tags.adb).
4962
4963       --   TSD : Type_Specific_Data (I_Depth) :=
4964       --           (Idepth             => I_Depth,
4965       --            Access_Level       => Type_Access_Level (Typ),
4966       --            Alignment          => Typ'Alignment,
4967       --            Expanded_Name      => Cstring_Ptr!(Exname'Address))
4968       --            External_Tag       => Cstring_Ptr!(Exname'Address))
4969       --            HT_Link            => HT_Link'Address,
4970       --            Transportable      => <<boolean-value>>,
4971       --            Is_Abstract        => <<boolean-value>>,
4972       --            Needs_Finalization => <<boolean-value>>,
4973       --            [ Size_Func         => Size_Prim'Access, ]
4974       --            [ Interfaces_Table  => <<access-value>>, ]
4975       --            [ SSD               => SSD_Table'Address ]
4976       --            Tags_Table         => (0 => null,
4977       --                                   1 => Parent'Tag
4978       --                                   ...);
4979       --   for TSD'Alignment use Address'Alignment
4980
4981       TSD_Aggr_List := New_List;
4982
4983       --  Idepth: Count ancestors to compute the inheritance depth. For private
4984       --  extensions, always go to the full view in order to compute the real
4985       --  inheritance depth.
4986
4987       declare
4988          Current_Typ : Entity_Id;
4989          Parent_Typ  : Entity_Id;
4990
4991       begin
4992          I_Depth     := 0;
4993          Current_Typ := Typ;
4994          loop
4995             Parent_Typ := Etype (Current_Typ);
4996
4997             if Is_Private_Type (Parent_Typ) then
4998                Parent_Typ := Full_View (Base_Type (Parent_Typ));
4999             end if;
5000
5001             exit when Parent_Typ = Current_Typ;
5002
5003             I_Depth := I_Depth + 1;
5004             Current_Typ := Parent_Typ;
5005          end loop;
5006       end;
5007
5008       Append_To (TSD_Aggr_List,
5009         Make_Integer_Literal (Loc, I_Depth));
5010
5011       --  Access_Level
5012
5013       Append_To (TSD_Aggr_List,
5014         Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
5015
5016       --  Alignment
5017
5018       --  For CPP types we cannot rely on the value of 'Alignment provided
5019       --  by the backend to initialize this TSD field.
5020
5021       if Convention (Typ) = Convention_CPP
5022         or else Is_CPP_Class (Root_Type (Typ))
5023       then
5024          Append_To (TSD_Aggr_List,
5025            Make_Integer_Literal (Loc, 0));
5026       else
5027          Append_To (TSD_Aggr_List,
5028            Make_Attribute_Reference (Loc,
5029              Prefix         => New_Occurrence_Of (Typ, Loc),
5030              Attribute_Name => Name_Alignment));
5031       end if;
5032
5033       --  Expanded_Name
5034
5035       Append_To (TSD_Aggr_List,
5036         Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
5037           Make_Attribute_Reference (Loc,
5038             Prefix         => New_Occurrence_Of (Exname, Loc),
5039             Attribute_Name => Name_Address)));
5040
5041       --  External_Tag of a local tagged type
5042
5043       --     <typ>A : constant String :=
5044       --                "Internal tag at 16#tag-addr#: <full-name-of-typ>";
5045
5046       --  The reason we generate this strange name is that we do not want to
5047       --  enter local tagged types in the global hash table used to compute
5048       --  the Internal_Tag attribute for two reasons:
5049
5050       --    1. It is hard to avoid a tasking race condition for entering the
5051       --    entry into the hash table.
5052
5053       --    2. It would cause a storage leak, unless we rig up considerable
5054       --    mechanism to remove the entry from the hash table on exit.
5055
5056       --  So what we do is to generate the above external tag name, where the
5057       --  hex address is the address of the local dispatch table (i.e. exactly
5058       --  the value we want if Internal_Tag is computed from this string).
5059
5060       --  Of course this value will only be valid if the tagged type is still
5061       --  in scope, but it clearly must be erroneous to compute the internal
5062       --  tag of a tagged type that is out of scope.
5063
5064       --  We don't do this processing if an explicit external tag has been
5065       --  specified. That's an odd case for which we have already issued a
5066       --  warning, where we will not be able to compute the internal tag.
5067
5068       if not Is_Library_Level_Entity (Typ)
5069         and then not Has_External_Tag_Rep_Clause (Typ)
5070       then
5071          declare
5072             Exname    : constant Entity_Id :=
5073                           Make_Defining_Identifier (Loc,
5074                             Chars => New_External_Name (Tname, 'A'));
5075             Full_Name : constant String_Id :=
5076                             Fully_Qualified_Name_String (First_Subtype (Typ));
5077             Str1_Id   : String_Id;
5078             Str2_Id   : String_Id;
5079
5080          begin
5081             --  Generate:
5082             --    Str1 = "Internal tag at 16#";
5083
5084             Start_String;
5085             Store_String_Chars ("Internal tag at 16#");
5086             Str1_Id := End_String;
5087
5088             --  Generate:
5089             --    Str2 = "#: <type-full-name>";
5090
5091             Start_String;
5092             Store_String_Chars ("#: ");
5093             Store_String_Chars (Full_Name);
5094             Str2_Id := End_String;
5095
5096             --  Generate:
5097             --    Exname : constant String :=
5098             --               Str1 & Address_Image (Tag) & Str2;
5099
5100             if RTE_Available (RE_Address_Image) then
5101                Append_To (Result,
5102                  Make_Object_Declaration (Loc,
5103                    Defining_Identifier => Exname,
5104                    Constant_Present    => True,
5105                    Object_Definition   => New_Occurrence_Of
5106                                             (Standard_String, Loc),
5107                    Expression =>
5108                      Make_Op_Concat (Loc,
5109                        Left_Opnd  => Make_String_Literal (Loc, Str1_Id),
5110                        Right_Opnd =>
5111                          Make_Op_Concat (Loc,
5112                            Left_Opnd  =>
5113                              Make_Function_Call (Loc,
5114                                Name =>
5115                                  New_Occurrence_Of
5116                                    (RTE (RE_Address_Image), Loc),
5117                                Parameter_Associations => New_List (
5118                                  Unchecked_Convert_To (RTE (RE_Address),
5119                                    New_Occurrence_Of (DT_Ptr, Loc)))),
5120                            Right_Opnd =>
5121                              Make_String_Literal (Loc, Str2_Id)))));
5122
5123             else
5124                Append_To (Result,
5125                  Make_Object_Declaration (Loc,
5126                    Defining_Identifier => Exname,
5127                    Constant_Present    => True,
5128                    Object_Definition   =>
5129                      New_Occurrence_Of (Standard_String, Loc),
5130                    Expression          =>
5131                      Make_Op_Concat (Loc,
5132                        Left_Opnd  => Make_String_Literal (Loc, Str1_Id),
5133                        Right_Opnd => Make_String_Literal (Loc, Str2_Id))));
5134             end if;
5135
5136             New_Node :=
5137               Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
5138                 Make_Attribute_Reference (Loc,
5139                   Prefix         => New_Occurrence_Of (Exname, Loc),
5140                   Attribute_Name => Name_Address));
5141          end;
5142
5143       --  External tag of a library-level tagged type: Check for a definition
5144       --  of External_Tag. The clause is considered only if it applies to this
5145       --  specific tagged type, as opposed to one of its ancestors.
5146       --  If the type is an unconstrained type extension, we are building the
5147       --  dispatch table of its anonymous base type, so the external tag, if
5148       --  any was specified, must be retrieved from the first subtype. Go to
5149       --  the full view in case the clause is in the private part.
5150
5151       else
5152          declare
5153             Def : constant Node_Id := Get_Attribute_Definition_Clause
5154                                         (Underlying_Type (First_Subtype (Typ)),
5155                                          Attribute_External_Tag);
5156
5157             Old_Val : String_Id;
5158             New_Val : String_Id;
5159             E       : Entity_Id;
5160
5161          begin
5162             if not Present (Def)
5163               or else Entity (Name (Def)) /= First_Subtype (Typ)
5164             then
5165                New_Node :=
5166                  Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
5167                    Make_Attribute_Reference (Loc,
5168                      Prefix         => New_Occurrence_Of (Exname, Loc),
5169                      Attribute_Name => Name_Address));
5170             else
5171                Old_Val := Strval (Expr_Value_S (Expression (Def)));
5172
5173                --  For the rep clause "for <typ>'external_tag use y" generate:
5174
5175                --     <typ>A : constant string := y;
5176                --
5177                --  <typ>A'Address is used to set the External_Tag component
5178                --  of the TSD
5179
5180                --  Create a new nul terminated string if it is not already
5181
5182                if String_Length (Old_Val) > 0
5183                  and then
5184                   Get_String_Char (Old_Val, String_Length (Old_Val)) = 0
5185                then
5186                   New_Val := Old_Val;
5187                else
5188                   Start_String (Old_Val);
5189                   Store_String_Char (Get_Char_Code (ASCII.NUL));
5190                   New_Val := End_String;
5191                end if;
5192
5193                E := Make_Defining_Identifier (Loc,
5194                       New_External_Name (Chars (Typ), 'A'));
5195
5196                Append_To (Result,
5197                  Make_Object_Declaration (Loc,
5198                    Defining_Identifier => E,
5199                    Constant_Present    => True,
5200                    Object_Definition   =>
5201                      New_Occurrence_Of (Standard_String, Loc),
5202                    Expression          =>
5203                      Make_String_Literal (Loc, New_Val)));
5204
5205                New_Node :=
5206                  Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
5207                    Make_Attribute_Reference (Loc,
5208                      Prefix         => New_Occurrence_Of (E, Loc),
5209                      Attribute_Name => Name_Address));
5210             end if;
5211          end;
5212       end if;
5213
5214       Append_To (TSD_Aggr_List, New_Node);
5215
5216       --  HT_Link
5217
5218       if RTE_Available (RE_Register_Tag) then
5219          Append_To (TSD_Aggr_List,
5220            Unchecked_Convert_To (RTE (RE_Tag_Ptr),
5221              Make_Attribute_Reference (Loc,
5222                Prefix         => New_Occurrence_Of (HT_Link, Loc),
5223                Attribute_Name => Name_Address)));
5224       else
5225          Append_To (TSD_Aggr_List,
5226            Unchecked_Convert_To (RTE (RE_Tag_Ptr),
5227              New_Occurrence_Of (RTE (RE_Null_Address), Loc)));
5228       end if;
5229
5230       --  Transportable: Set for types that can be used in remote calls
5231       --  with respect to E.4(18) legality rules.
5232
5233       declare
5234          Transportable : Entity_Id;
5235
5236       begin
5237          Transportable :=
5238            Boolean_Literals
5239              (Is_Pure (Typ)
5240                 or else Is_Shared_Passive (Typ)
5241                 or else
5242                   ((Is_Remote_Types (Typ)
5243                      or else Is_Remote_Call_Interface (Typ))
5244                    and then Original_View_In_Visible_Part (Typ))
5245                 or else not Comes_From_Source (Typ));
5246
5247          Append_To (TSD_Aggr_List,
5248             New_Occurrence_Of (Transportable, Loc));
5249       end;
5250
5251       --  Is_Abstract (Ada 2012: AI05-0173). This functionality is not
5252       --  available in the HIE runtime.
5253
5254       if RTE_Record_Component_Available (RE_Is_Abstract) then
5255          declare
5256             Is_Abstract : Entity_Id;
5257          begin
5258             Is_Abstract := Boolean_Literals (Is_Abstract_Type (Typ));
5259             Append_To (TSD_Aggr_List,
5260               New_Occurrence_Of (Is_Abstract, Loc));
5261          end;
5262       end if;
5263
5264       --  Needs_Finalization: Set if the type is controlled or has controlled
5265       --  components.
5266
5267       declare
5268          Needs_Fin : Entity_Id;
5269       begin
5270          Needs_Fin := Boolean_Literals (Needs_Finalization (Typ));
5271          Append_To (TSD_Aggr_List, New_Occurrence_Of (Needs_Fin, Loc));
5272       end;
5273
5274       --  Size_Func
5275
5276       if RTE_Record_Component_Available (RE_Size_Func) then
5277
5278          --  Initialize this field to Null_Address if we are not building
5279          --  static dispatch tables static or if the size function is not
5280          --  available. In the former case we cannot initialize this field
5281          --  until the function is frozen and registered in the dispatch
5282          --  table (see Register_Primitive).
5283
5284          if not Building_Static_DT (Typ) or else not Has_DT (Typ) then
5285             Append_To (TSD_Aggr_List,
5286               Unchecked_Convert_To (RTE (RE_Size_Ptr),
5287                 New_Occurrence_Of (RTE (RE_Null_Address), Loc)));
5288
5289          else
5290             declare
5291                Prim_Elmt : Elmt_Id;
5292                Prim      : Entity_Id;
5293                Size_Comp : Node_Id := Empty;
5294
5295             begin
5296                Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5297                while Present (Prim_Elmt) loop
5298                   Prim := Node (Prim_Elmt);
5299
5300                   if Chars (Prim) = Name_uSize then
5301                      Prim := Ultimate_Alias (Prim);
5302
5303                      if Is_Abstract_Subprogram (Prim) then
5304                         Size_Comp :=
5305                           Unchecked_Convert_To (RTE (RE_Size_Ptr),
5306                             New_Occurrence_Of (RTE (RE_Null_Address), Loc));
5307                      else
5308                         Size_Comp :=
5309                           Unchecked_Convert_To (RTE (RE_Size_Ptr),
5310                             Make_Attribute_Reference (Loc,
5311                               Prefix         => New_Occurrence_Of (Prim, Loc),
5312                               Attribute_Name => Name_Unrestricted_Access));
5313                      end if;
5314
5315                      exit;
5316                   end if;
5317
5318                   Next_Elmt (Prim_Elmt);
5319                end loop;
5320
5321                pragma Assert (Present (Size_Comp));
5322                Append_To (TSD_Aggr_List, Size_Comp);
5323             end;
5324          end if;
5325       end if;
5326
5327       --  Interfaces_Table (required for AI-405)
5328
5329       if RTE_Record_Component_Available (RE_Interfaces_Table) then
5330
5331          --  Count the number of interface types implemented by Typ
5332
5333          Collect_Interfaces (Typ, Typ_Ifaces);
5334
5335          AI := First_Elmt (Typ_Ifaces);
5336          while Present (AI) loop
5337             Num_Ifaces := Num_Ifaces + 1;
5338             Next_Elmt (AI);
5339          end loop;
5340
5341          if Num_Ifaces = 0 then
5342             Iface_Table_Node := Make_Null (Loc);
5343
5344          --  Generate the Interface_Table object
5345
5346          else
5347             declare
5348                TSD_Ifaces_List : constant List_Id := New_List;
5349                Elmt       : Elmt_Id;
5350                Sec_DT_Tag : Node_Id;
5351
5352             begin
5353                AI := First_Elmt (Typ_Ifaces);
5354                while Present (AI) loop
5355                   if Is_Ancestor (Node (AI), Typ, Use_Full_View => True) then
5356                      Sec_DT_Tag :=
5357                        New_Occurrence_Of (DT_Ptr, Loc);
5358                   else
5359                      Elmt :=
5360                        Next_Elmt
5361                         (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
5362                      pragma Assert (Has_Thunks (Node (Elmt)));
5363
5364                      while Is_Tag (Node (Elmt))
5365                         and then not
5366                           Is_Ancestor (Node (AI), Related_Type (Node (Elmt)),
5367                                        Use_Full_View => True)
5368                      loop
5369                         pragma Assert (Has_Thunks (Node (Elmt)));
5370                         Next_Elmt (Elmt);
5371                         pragma Assert (Has_Thunks (Node (Elmt)));
5372                         Next_Elmt (Elmt);
5373                         pragma Assert (not Has_Thunks (Node (Elmt)));
5374                         Next_Elmt (Elmt);
5375                         pragma Assert (not Has_Thunks (Node (Elmt)));
5376                         Next_Elmt (Elmt);
5377                      end loop;
5378
5379                      pragma Assert (Ekind (Node (Elmt)) = E_Constant
5380                        and then not
5381                          Has_Thunks (Node (Next_Elmt (Next_Elmt (Elmt)))));
5382                      Sec_DT_Tag :=
5383                        New_Occurrence_Of (Node (Next_Elmt (Next_Elmt (Elmt))),
5384                                          Loc);
5385                   end if;
5386
5387                   Append_To (TSD_Ifaces_List,
5388                      Make_Aggregate (Loc,
5389                        Expressions => New_List (
5390
5391                         --  Iface_Tag
5392
5393                         Unchecked_Convert_To (RTE (RE_Tag),
5394                           New_Occurrence_Of
5395                             (Node (First_Elmt (Access_Disp_Table (Node (AI)))),
5396                              Loc)),
5397
5398                         --  Static_Offset_To_Top
5399
5400                         New_Occurrence_Of (Standard_True, Loc),
5401
5402                         --  Offset_To_Top_Value
5403
5404                         Make_Integer_Literal (Loc, 0),
5405
5406                         --  Offset_To_Top_Func
5407
5408                         Make_Null (Loc),
5409
5410                         --  Secondary_DT
5411
5412                         Unchecked_Convert_To (RTE (RE_Tag), Sec_DT_Tag)
5413
5414                         )));
5415
5416                   Next_Elmt (AI);
5417                end loop;
5418
5419                Name_ITable := New_External_Name (Tname, 'I');
5420                ITable      := Make_Defining_Identifier (Loc, Name_ITable);
5421                Set_Is_Statically_Allocated (ITable,
5422                  Is_Library_Level_Tagged_Type (Typ));
5423
5424                --  The table of interfaces is not constant; its slots are
5425                --  filled at run time by the IP routine using attribute
5426                --  'Position to know the location of the tag components
5427                --  (and this attribute cannot be safely used before the
5428                --  object is initialized).
5429
5430                Append_To (Result,
5431                  Make_Object_Declaration (Loc,
5432                    Defining_Identifier => ITable,
5433                    Aliased_Present     => True,
5434                    Constant_Present    => False,
5435                    Object_Definition   =>
5436                      Make_Subtype_Indication (Loc,
5437                        Subtype_Mark =>
5438                          New_Occurrence_Of (RTE (RE_Interface_Data), Loc),
5439                        Constraint   =>
5440                          Make_Index_Or_Discriminant_Constraint (Loc,
5441                            Constraints => New_List (
5442                              Make_Integer_Literal (Loc, Num_Ifaces)))),
5443
5444                    Expression           => Make_Aggregate (Loc,
5445                      Expressions => New_List (
5446                        Make_Integer_Literal (Loc, Num_Ifaces),
5447                        Make_Aggregate (Loc, TSD_Ifaces_List)))));
5448
5449                Append_To (Result,
5450                  Make_Attribute_Definition_Clause (Loc,
5451                    Name       => New_Occurrence_Of (ITable, Loc),
5452                    Chars      => Name_Alignment,
5453                    Expression =>
5454                      Make_Attribute_Reference (Loc,
5455                        Prefix         =>
5456                          New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
5457                        Attribute_Name => Name_Alignment)));
5458
5459                Iface_Table_Node :=
5460                  Make_Attribute_Reference (Loc,
5461                    Prefix         => New_Occurrence_Of (ITable, Loc),
5462                    Attribute_Name => Name_Unchecked_Access);
5463             end;
5464          end if;
5465
5466          Append_To (TSD_Aggr_List, Iface_Table_Node);
5467       end if;
5468
5469       --  Generate the Select Specific Data table for synchronized types that
5470       --  implement synchronized interfaces. The size of the table is
5471       --  constrained by the number of non-predefined primitive operations.
5472
5473       if RTE_Record_Component_Available (RE_SSD) then
5474          if Ada_Version >= Ada_2005
5475            and then Has_DT (Typ)
5476            and then Is_Concurrent_Record_Type (Typ)
5477            and then Has_Interfaces (Typ)
5478            and then Nb_Prim > 0
5479            and then not Is_Abstract_Type (Typ)
5480            and then not Is_Controlled (Typ)
5481            and then not Restriction_Active (No_Dispatching_Calls)
5482            and then not Restriction_Active (No_Select_Statements)
5483          then
5484             Append_To (Result,
5485               Make_Object_Declaration (Loc,
5486                 Defining_Identifier => SSD,
5487                 Aliased_Present     => True,
5488                 Object_Definition   =>
5489                   Make_Subtype_Indication (Loc,
5490                     Subtype_Mark => New_Occurrence_Of (
5491                       RTE (RE_Select_Specific_Data), Loc),
5492                     Constraint   =>
5493                       Make_Index_Or_Discriminant_Constraint (Loc,
5494                         Constraints => New_List (
5495                           Make_Integer_Literal (Loc, Nb_Prim))))));
5496
5497             Append_To (Result,
5498               Make_Attribute_Definition_Clause (Loc,
5499                 Name       => New_Occurrence_Of (SSD, Loc),
5500                 Chars      => Name_Alignment,
5501                 Expression =>
5502                   Make_Attribute_Reference (Loc,
5503                     Prefix         =>
5504                       New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
5505                     Attribute_Name => Name_Alignment)));
5506
5507             --  This table is initialized by Make_Select_Specific_Data_Table,
5508             --  which calls Set_Entry_Index and Set_Prim_Op_Kind.
5509
5510             Append_To (TSD_Aggr_List,
5511               Make_Attribute_Reference (Loc,
5512                 Prefix         => New_Occurrence_Of (SSD, Loc),
5513                 Attribute_Name => Name_Unchecked_Access));
5514          else
5515             Append_To (TSD_Aggr_List, Make_Null (Loc));
5516          end if;
5517       end if;
5518
5519       --  Initialize the table of ancestor tags. In case of interface types
5520       --  this table is not needed.
5521
5522       TSD_Tags_List := New_List;
5523
5524       --  If we are not statically allocating the dispatch table then we must
5525       --  fill position 0 with null because we still have not generated the
5526       --  tag of Typ.
5527
5528       if not Building_Static_DT (Typ)
5529         or else Is_Interface (Typ)
5530       then
5531          Append_To (TSD_Tags_List,
5532            Unchecked_Convert_To (RTE (RE_Tag),
5533              New_Occurrence_Of (RTE (RE_Null_Address), Loc)));
5534
5535       --  Otherwise we can safely reference the tag
5536
5537       else
5538          Append_To (TSD_Tags_List,
5539            New_Occurrence_Of (DT_Ptr, Loc));
5540       end if;
5541
5542       --  Fill the rest of the table with the tags of the ancestors
5543
5544       declare
5545          Current_Typ : Entity_Id;
5546          Parent_Typ  : Entity_Id;
5547          Pos         : Nat;
5548
5549       begin
5550          Pos := 1;
5551          Current_Typ := Typ;
5552
5553          loop
5554             Parent_Typ := Etype (Current_Typ);
5555
5556             if Is_Private_Type (Parent_Typ) then
5557                Parent_Typ := Full_View (Base_Type (Parent_Typ));
5558             end if;
5559
5560             exit when Parent_Typ = Current_Typ;
5561
5562             if Is_CPP_Class (Parent_Typ) then
5563
5564                --  The tags defined in the C++ side will be inherited when
5565                --  the object is constructed (Exp_Ch3.Build_Init_Procedure)
5566
5567                Append_To (TSD_Tags_List,
5568                  Unchecked_Convert_To (RTE (RE_Tag),
5569                    New_Occurrence_Of (RTE (RE_Null_Address), Loc)));
5570             else
5571                Append_To (TSD_Tags_List,
5572                  New_Occurrence_Of
5573                    (Node (First_Elmt (Access_Disp_Table (Parent_Typ))),
5574                     Loc));
5575             end if;
5576
5577             Pos := Pos + 1;
5578             Current_Typ := Parent_Typ;
5579          end loop;
5580
5581          pragma Assert (Pos = I_Depth + 1);
5582       end;
5583
5584       Append_To (TSD_Aggr_List,
5585         Make_Aggregate (Loc,
5586           Expressions => TSD_Tags_List));
5587
5588       --  Build the TSD object
5589
5590       Append_To (Result,
5591         Make_Object_Declaration (Loc,
5592           Defining_Identifier => TSD,
5593           Aliased_Present     => True,
5594           Constant_Present    => Building_Static_DT (Typ),
5595           Object_Definition   =>
5596             Make_Subtype_Indication (Loc,
5597               Subtype_Mark => New_Occurrence_Of (
5598                 RTE (RE_Type_Specific_Data), Loc),
5599               Constraint =>
5600                 Make_Index_Or_Discriminant_Constraint (Loc,
5601                   Constraints => New_List (
5602                     Make_Integer_Literal (Loc, I_Depth)))),
5603
5604           Expression => Make_Aggregate (Loc,
5605             Expressions => TSD_Aggr_List)));
5606
5607       Set_Is_True_Constant (TSD, Building_Static_DT (Typ));
5608
5609       Append_To (Result,
5610         Make_Attribute_Definition_Clause (Loc,
5611           Name       => New_Occurrence_Of (TSD, Loc),
5612           Chars      => Name_Alignment,
5613           Expression =>
5614             Make_Attribute_Reference (Loc,
5615               Prefix         =>
5616                 New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
5617               Attribute_Name => Name_Alignment)));
5618
5619       --  Initialize or declare the dispatch table object
5620
5621       if not Has_DT (Typ) then
5622          DT_Constr_List := New_List;
5623          DT_Aggr_List   := New_List;
5624
5625          --  Typeinfo
5626
5627          New_Node :=
5628            Make_Attribute_Reference (Loc,
5629              Prefix         => New_Occurrence_Of (TSD, Loc),
5630              Attribute_Name => Name_Address);
5631
5632          Append_To (DT_Constr_List, New_Node);
5633          Append_To (DT_Aggr_List,   New_Copy (New_Node));
5634          Append_To (DT_Aggr_List,   Make_Integer_Literal (Loc, 0));
5635
5636          --  In case of locally defined tagged types we have already declared
5637          --  and uninitialized object for the dispatch table, which is now
5638          --  initialized by means of the following assignment:
5639
5640          --    DT := (TSD'Address, 0);
5641
5642          if not Building_Static_DT (Typ) then
5643             Append_To (Result,
5644               Make_Assignment_Statement (Loc,
5645                 Name       => New_Occurrence_Of (DT, Loc),
5646                 Expression => Make_Aggregate (Loc, DT_Aggr_List)));
5647
5648          --  In case of library level tagged types we declare and export now
5649          --  the constant object containing the dummy dispatch table. There
5650          --  is no need to declare the tag here because it has been previously
5651          --  declared by Make_Tags
5652
5653          --   DT : aliased constant No_Dispatch_Table :=
5654          --          (NDT_TSD       => TSD'Address;
5655          --           NDT_Prims_Ptr => 0);
5656          --   for DT'Alignment use Address'Alignment;
5657
5658          else
5659             Append_To (Result,
5660               Make_Object_Declaration (Loc,
5661                 Defining_Identifier => DT,
5662                 Aliased_Present     => True,
5663                 Constant_Present    => True,
5664                 Object_Definition   =>
5665                   New_Occurrence_Of (RTE (RE_No_Dispatch_Table_Wrapper), Loc),
5666                 Expression          => Make_Aggregate (Loc, DT_Aggr_List)));
5667
5668             Append_To (Result,
5669               Make_Attribute_Definition_Clause (Loc,
5670                 Name       => New_Occurrence_Of (DT, Loc),
5671                 Chars      => Name_Alignment,
5672                 Expression =>
5673                   Make_Attribute_Reference (Loc,
5674                     Prefix         =>
5675                       New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
5676                     Attribute_Name => Name_Alignment)));
5677
5678             Export_DT (Typ, DT);
5679          end if;
5680
5681       --  Common case: Typ has a dispatch table
5682
5683       --  Generate:
5684
5685       --   Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
5686       --                    (predef-prim-op-1'address,
5687       --                     predef-prim-op-2'address,
5688       --                     ...
5689       --                     predef-prim-op-n'address);
5690       --   for Predef_Prims'Alignment use Address'Alignment
5691
5692       --   DT : Dispatch_Table (Nb_Prims) :=
5693       --          (Signature => <sig-value>,
5694       --           Tag_Kind  => <tag_kind-value>,
5695       --           Predef_Prims => Predef_Prims'First'Address,
5696       --           Offset_To_Top => 0,
5697       --           TSD           => TSD'Address;
5698       --           Prims_Ptr     => (prim-op-1'address,
5699       --                             prim-op-2'address,
5700       --                             ...
5701       --                             prim-op-n'address));
5702       --   for DT'Alignment use Address'Alignment
5703
5704       else
5705          declare
5706             Pos : Nat;
5707
5708          begin
5709             if not Building_Static_DT (Typ) then
5710                Nb_Predef_Prims := Max_Predef_Prims;
5711
5712             else
5713                Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5714                while Present (Prim_Elmt) loop
5715                   Prim := Node (Prim_Elmt);
5716
5717                   if Is_Predefined_Dispatching_Operation (Prim)
5718                     and then not Is_Abstract_Subprogram (Prim)
5719                   then
5720                      Pos := UI_To_Int (DT_Position (Prim));
5721
5722                      if Pos > Nb_Predef_Prims then
5723                         Nb_Predef_Prims := Pos;
5724                      end if;
5725                   end if;
5726
5727                   Next_Elmt (Prim_Elmt);
5728                end loop;
5729             end if;
5730
5731             declare
5732                Prim_Table : array
5733                               (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
5734                Decl       : Node_Id;
5735                E          : Entity_Id;
5736
5737             begin
5738                Prim_Ops_Aggr_List := New_List;
5739
5740                Prim_Table := (others => Empty);
5741
5742                if Building_Static_DT (Typ) then
5743                   Prim_Elmt  := First_Elmt (Primitive_Operations (Typ));
5744                   while Present (Prim_Elmt) loop
5745                      Prim := Node (Prim_Elmt);
5746
5747                      if Is_Predefined_Dispatching_Operation (Prim)
5748                        and then not Is_Abstract_Subprogram (Prim)
5749                        and then not Is_Eliminated (Prim)
5750                        and then not Present (Prim_Table
5751                                               (UI_To_Int (DT_Position (Prim))))
5752                      then
5753                         E := Ultimate_Alias (Prim);
5754                         pragma Assert (not Is_Abstract_Subprogram (E));
5755                         Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
5756                      end if;
5757
5758                      Next_Elmt (Prim_Elmt);
5759                   end loop;
5760                end if;
5761
5762                for J in Prim_Table'Range loop
5763                   if Present (Prim_Table (J)) then
5764                      New_Node :=
5765                        Unchecked_Convert_To (RTE (RE_Prim_Ptr),
5766                          Make_Attribute_Reference (Loc,
5767                            Prefix         =>
5768                              New_Occurrence_Of (Prim_Table (J), Loc),
5769                            Attribute_Name => Name_Unrestricted_Access));
5770                   else
5771                      New_Node := Make_Null (Loc);
5772                   end if;
5773
5774                   Append_To (Prim_Ops_Aggr_List, New_Node);
5775                end loop;
5776
5777                New_Node :=
5778                  Make_Aggregate (Loc,
5779                    Expressions => Prim_Ops_Aggr_List);
5780
5781                Decl :=
5782                  Make_Subtype_Declaration (Loc,
5783                    Defining_Identifier => Make_Temporary (Loc, 'S'),
5784                    Subtype_Indication  =>
5785                      New_Occurrence_Of (RTE (RE_Address_Array), Loc));
5786
5787                Append_To (Result, Decl);
5788
5789                Append_To (Result,
5790                  Make_Object_Declaration (Loc,
5791                    Defining_Identifier => Predef_Prims,
5792                    Aliased_Present     => True,
5793                    Constant_Present    => Building_Static_DT (Typ),
5794                    Object_Definition   =>
5795                      New_Occurrence_Of (Defining_Identifier (Decl), Loc),
5796                    Expression => New_Node));
5797
5798                --  Remember aggregates initializing dispatch tables
5799
5800                Append_Elmt (New_Node, DT_Aggr);
5801
5802                Append_To (Result,
5803                  Make_Attribute_Definition_Clause (Loc,
5804                    Name       => New_Occurrence_Of (Predef_Prims, Loc),
5805                    Chars      => Name_Alignment,
5806                    Expression =>
5807                      Make_Attribute_Reference (Loc,
5808                        Prefix         =>
5809                          New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
5810                        Attribute_Name => Name_Alignment)));
5811             end;
5812          end;
5813
5814          --  Stage 1: Initialize the discriminant and the record components
5815
5816          DT_Constr_List := New_List;
5817          DT_Aggr_List   := New_List;
5818
5819          --  Num_Prims. If the tagged type has no primitives we add a dummy
5820          --  slot whose address will be the tag of this type.
5821
5822          if Nb_Prim = 0 then
5823             New_Node := Make_Integer_Literal (Loc, 1);
5824          else
5825             New_Node := Make_Integer_Literal (Loc, Nb_Prim);
5826          end if;
5827
5828          Append_To (DT_Constr_List, New_Node);
5829          Append_To (DT_Aggr_List,   New_Copy (New_Node));
5830
5831          --  Signature
5832
5833          if RTE_Record_Component_Available (RE_Signature) then
5834             Append_To (DT_Aggr_List,
5835               New_Occurrence_Of (RTE (RE_Primary_DT), Loc));
5836          end if;
5837
5838          --  Tag_Kind
5839
5840          if RTE_Record_Component_Available (RE_Tag_Kind) then
5841             Append_To (DT_Aggr_List, Tagged_Kind (Typ));
5842          end if;
5843
5844          --  Predef_Prims
5845
5846          Append_To (DT_Aggr_List,
5847            Make_Attribute_Reference (Loc,
5848              Prefix         => New_Occurrence_Of (Predef_Prims, Loc),
5849              Attribute_Name => Name_Address));
5850
5851          --  Offset_To_Top
5852
5853          Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
5854
5855          --  Typeinfo
5856
5857          Append_To (DT_Aggr_List,
5858            Make_Attribute_Reference (Loc,
5859              Prefix         => New_Occurrence_Of (TSD, Loc),
5860              Attribute_Name => Name_Address));
5861
5862          --  Stage 2: Initialize the table of user-defined primitive operations
5863
5864          Prim_Ops_Aggr_List := New_List;
5865
5866          if Nb_Prim = 0 then
5867             Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
5868
5869          elsif not Building_Static_DT (Typ) then
5870             for J in 1 .. Nb_Prim loop
5871                Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
5872             end loop;
5873
5874          else
5875             declare
5876                CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
5877                E            : Entity_Id;
5878                Prim         : Entity_Id;
5879                Prim_Elmt    : Elmt_Id;
5880                Prim_Pos     : Nat;
5881                Prim_Table   : array (Nat range 1 .. Nb_Prim) of Entity_Id;
5882
5883             begin
5884                Prim_Table := (others => Empty);
5885
5886                Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5887                while Present (Prim_Elmt) loop
5888                   Prim := Node (Prim_Elmt);
5889
5890                   --  Retrieve the ultimate alias of the primitive for proper
5891                   --  handling of renamings and eliminated primitives.
5892
5893                   E := Ultimate_Alias (Prim);
5894
5895                   --  If the alias is not a primitive operation then Prim does
5896                   --  not rename another primitive, but rather an operation
5897                   --  declared elsewhere (e.g. in another scope) and therefore
5898                   --  Prim is a new primitive.
5899
5900                   if No (Find_Dispatching_Type (E)) then
5901                      E := Prim;
5902                   end if;
5903
5904                   Prim_Pos := UI_To_Int (DT_Position (E));
5905
5906                   --  Skip predefined primitives because they are located in a
5907                   --  separate dispatch table.
5908
5909                   if not Is_Predefined_Dispatching_Operation (Prim)
5910                     and then not Is_Predefined_Dispatching_Operation (E)
5911
5912                     --  Skip entities with attribute Interface_Alias because
5913                     --  those are only required to build secondary dispatch
5914                     --  tables.
5915
5916                     and then not Present (Interface_Alias (Prim))
5917
5918                     --  Skip abstract and eliminated primitives
5919
5920                     and then not Is_Abstract_Subprogram (E)
5921                     and then not Is_Eliminated (E)
5922
5923                     --  For derivations of CPP types skip primitives located in
5924                     --  the C++ part of the dispatch table because their slots
5925                     --  are initialized by the IC routine.
5926
5927                     and then (not Is_CPP_Class (Root_Type (Typ))
5928                                or else Prim_Pos > CPP_Nb_Prims)
5929
5930                     --  Skip ignored Ghost subprograms as those will be removed
5931                     --  from the executable.
5932
5933                     and then not Is_Ignored_Ghost_Entity (E)
5934                   then
5935                      pragma Assert
5936                        (UI_To_Int (DT_Position (Prim)) <= Nb_Prim);
5937
5938                      Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
5939                   end if;
5940
5941                   Next_Elmt (Prim_Elmt);
5942                end loop;
5943
5944                for J in Prim_Table'Range loop
5945                   if Present (Prim_Table (J)) then
5946                      New_Node :=
5947                        Unchecked_Convert_To (RTE (RE_Prim_Ptr),
5948                          Make_Attribute_Reference (Loc,
5949                            Prefix         =>
5950                              New_Occurrence_Of (Prim_Table (J), Loc),
5951                            Attribute_Name => Name_Unrestricted_Access));
5952                   else
5953                      New_Node := Make_Null (Loc);
5954                   end if;
5955
5956                   Append_To (Prim_Ops_Aggr_List, New_Node);
5957                end loop;
5958             end;
5959          end if;
5960
5961          New_Node :=
5962            Make_Aggregate (Loc,
5963              Expressions => Prim_Ops_Aggr_List);
5964
5965          Append_To (DT_Aggr_List, New_Node);
5966
5967          --  Remember aggregates initializing dispatch tables
5968
5969          Append_Elmt (New_Node, DT_Aggr);
5970
5971          --  In case of locally defined tagged types we have already declared
5972          --  and uninitialized object for the dispatch table, which is now
5973          --  initialized by means of an assignment.
5974
5975          if not Building_Static_DT (Typ) then
5976             Append_To (Result,
5977               Make_Assignment_Statement (Loc,
5978                 Name       => New_Occurrence_Of (DT, Loc),
5979                 Expression => Make_Aggregate (Loc, DT_Aggr_List)));
5980
5981          --  In case of library level tagged types we declare now and export
5982          --  the constant object containing the dispatch table.
5983
5984          else
5985             Append_To (Result,
5986               Make_Object_Declaration (Loc,
5987                 Defining_Identifier => DT,
5988                 Aliased_Present     => True,
5989                 Constant_Present    => True,
5990                 Object_Definition   =>
5991                   Make_Subtype_Indication (Loc,
5992                     Subtype_Mark => New_Occurrence_Of
5993                                       (RTE (RE_Dispatch_Table_Wrapper), Loc),
5994                     Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
5995                                       Constraints => DT_Constr_List)),
5996                 Expression          => Make_Aggregate (Loc, DT_Aggr_List)));
5997
5998             Append_To (Result,
5999               Make_Attribute_Definition_Clause (Loc,
6000                 Name       => New_Occurrence_Of (DT, Loc),
6001                 Chars      => Name_Alignment,
6002                 Expression =>
6003                   Make_Attribute_Reference (Loc,
6004                     Prefix         =>
6005                       New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
6006                     Attribute_Name => Name_Alignment)));
6007
6008             Export_DT (Typ, DT);
6009          end if;
6010       end if;
6011
6012       --  Initialize the table of ancestor tags if not building static
6013       --  dispatch table
6014
6015       if not Building_Static_DT (Typ)
6016         and then not Is_Interface (Typ)
6017         and then not Is_CPP_Class (Typ)
6018       then
6019          Append_To (Result,
6020            Make_Assignment_Statement (Loc,
6021              Name       =>
6022                Make_Indexed_Component (Loc,
6023                  Prefix      =>
6024                    Make_Selected_Component (Loc,
6025                      Prefix        => New_Occurrence_Of (TSD, Loc),
6026                      Selector_Name =>
6027                        New_Occurrence_Of
6028                          (RTE_Record_Component (RE_Tags_Table), Loc)),
6029                  Expressions =>
6030                     New_List (Make_Integer_Literal (Loc, 0))),
6031
6032              Expression =>
6033                New_Occurrence_Of
6034                  (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)));
6035       end if;
6036
6037       --  Inherit the dispatch tables of the parent. There is no need to
6038       --  inherit anything from the parent when building static dispatch tables
6039       --  because the whole dispatch table (including inherited primitives) has
6040       --  been already built.
6041
6042       if Building_Static_DT (Typ) then
6043          null;
6044
6045       --  If the ancestor is a CPP_Class type we inherit the dispatch tables
6046       --  in the init proc, and we don't need to fill them in here.
6047
6048       elsif Is_CPP_Class (Parent_Typ) then
6049          null;
6050
6051       --  Otherwise we fill in the dispatch tables here
6052
6053       else
6054          if Typ /= Parent_Typ
6055            and then not Is_Interface (Typ)
6056            and then not Restriction_Active (No_Dispatching_Calls)
6057          then
6058             --  Inherit the dispatch table
6059
6060             if not Is_Interface (Typ)
6061               and then not Is_Interface (Parent_Typ)
6062               and then not Is_CPP_Class (Parent_Typ)
6063             then
6064                declare
6065                   Nb_Prims : constant Int :=
6066                                UI_To_Int (DT_Entry_Count
6067                                  (First_Tag_Component (Parent_Typ)));
6068
6069                begin
6070                   Append_To (Elab_Code,
6071                     Build_Inherit_Predefined_Prims (Loc,
6072                       Old_Tag_Node =>
6073                         New_Occurrence_Of
6074                           (Node
6075                             (Next_Elmt
6076                               (First_Elmt
6077                                 (Access_Disp_Table (Parent_Typ)))), Loc),
6078                       New_Tag_Node =>
6079                         New_Occurrence_Of
6080                           (Node
6081                             (Next_Elmt
6082                               (First_Elmt
6083                                 (Access_Disp_Table (Typ)))), Loc)));
6084
6085                   if Nb_Prims /= 0 then
6086                      Append_To (Elab_Code,
6087                        Build_Inherit_Prims (Loc,
6088                          Typ          => Typ,
6089                          Old_Tag_Node =>
6090                            New_Occurrence_Of
6091                              (Node
6092                                (First_Elmt
6093                                  (Access_Disp_Table (Parent_Typ))), Loc),
6094                          New_Tag_Node => New_Occurrence_Of (DT_Ptr, Loc),
6095                          Num_Prims    => Nb_Prims));
6096                   end if;
6097                end;
6098             end if;
6099
6100             --  Inherit the secondary dispatch tables of the ancestor
6101
6102             if not Is_CPP_Class (Parent_Typ) then
6103                declare
6104                   Sec_DT_Ancestor : Elmt_Id :=
6105                                       Next_Elmt
6106                                         (Next_Elmt
6107                                            (First_Elmt
6108                                               (Access_Disp_Table
6109                                                  (Parent_Typ))));
6110                   Sec_DT_Typ      : Elmt_Id :=
6111                                       Next_Elmt
6112                                         (Next_Elmt
6113                                            (First_Elmt
6114                                               (Access_Disp_Table (Typ))));
6115
6116                   procedure Copy_Secondary_DTs (Typ : Entity_Id);
6117                   --  Local procedure required to climb through the ancestors
6118                   --  and copy the contents of all their secondary dispatch
6119                   --  tables.
6120
6121                   ------------------------
6122                   -- Copy_Secondary_DTs --
6123                   ------------------------
6124
6125                   procedure Copy_Secondary_DTs (Typ : Entity_Id) is
6126                      E     : Entity_Id;
6127                      Iface : Elmt_Id;
6128
6129                   begin
6130                      --  Climb to the ancestor (if any) handling private types
6131
6132                      if Present (Full_View (Etype (Typ))) then
6133                         if Full_View (Etype (Typ)) /= Typ then
6134                            Copy_Secondary_DTs (Full_View (Etype (Typ)));
6135                         end if;
6136
6137                      elsif Etype (Typ) /= Typ then
6138                         Copy_Secondary_DTs (Etype (Typ));
6139                      end if;
6140
6141                      if Present (Interfaces (Typ))
6142                        and then not Is_Empty_Elmt_List (Interfaces (Typ))
6143                      then
6144                         Iface := First_Elmt (Interfaces (Typ));
6145                         E     := First_Entity (Typ);
6146                         while Present (E)
6147                           and then Present (Node (Sec_DT_Ancestor))
6148                           and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
6149                         loop
6150                            if Is_Tag (E) and then Chars (E) /= Name_uTag then
6151                               declare
6152                                  Num_Prims : constant Int :=
6153                                                UI_To_Int (DT_Entry_Count (E));
6154
6155                               begin
6156                                  if not Is_Interface (Etype (Typ)) then
6157
6158                                     --  Inherit first secondary dispatch table
6159
6160                                     Append_To (Elab_Code,
6161                                       Build_Inherit_Predefined_Prims (Loc,
6162                                         Old_Tag_Node =>
6163                                           Unchecked_Convert_To (RTE (RE_Tag),
6164                                             New_Occurrence_Of
6165                                               (Node
6166                                                 (Next_Elmt (Sec_DT_Ancestor)),
6167                                                Loc)),
6168                                         New_Tag_Node =>
6169                                           Unchecked_Convert_To (RTE (RE_Tag),
6170                                             New_Occurrence_Of
6171                                               (Node (Next_Elmt (Sec_DT_Typ)),
6172                                                Loc))));
6173
6174                                     if Num_Prims /= 0 then
6175                                        Append_To (Elab_Code,
6176                                          Build_Inherit_Prims (Loc,
6177                                            Typ          => Node (Iface),
6178                                            Old_Tag_Node =>
6179                                              Unchecked_Convert_To
6180                                                (RTE (RE_Tag),
6181                                                 New_Occurrence_Of
6182                                                   (Node (Sec_DT_Ancestor),
6183                                                    Loc)),
6184                                            New_Tag_Node =>
6185                                              Unchecked_Convert_To
6186                                               (RTE (RE_Tag),
6187                                                New_Occurrence_Of
6188                                                  (Node (Sec_DT_Typ), Loc)),
6189                                            Num_Prims    => Num_Prims));
6190                                     end if;
6191                                  end if;
6192
6193                                  Next_Elmt (Sec_DT_Ancestor);
6194                                  Next_Elmt (Sec_DT_Typ);
6195
6196                                  --  Skip the secondary dispatch table of
6197                                  --  predefined primitives
6198
6199                                  Next_Elmt (Sec_DT_Ancestor);
6200                                  Next_Elmt (Sec_DT_Typ);
6201
6202                                  if not Is_Interface (Etype (Typ)) then
6203
6204                                     --  Inherit second secondary dispatch table
6205
6206                                     Append_To (Elab_Code,
6207                                       Build_Inherit_Predefined_Prims (Loc,
6208                                         Old_Tag_Node =>
6209                                           Unchecked_Convert_To (RTE (RE_Tag),
6210                                              New_Occurrence_Of
6211                                                (Node
6212                                                  (Next_Elmt (Sec_DT_Ancestor)),
6213                                                 Loc)),
6214                                         New_Tag_Node =>
6215                                           Unchecked_Convert_To (RTE (RE_Tag),
6216                                             New_Occurrence_Of
6217                                               (Node (Next_Elmt (Sec_DT_Typ)),
6218                                                Loc))));
6219
6220                                     if Num_Prims /= 0 then
6221                                        Append_To (Elab_Code,
6222                                          Build_Inherit_Prims (Loc,
6223                                            Typ          => Node (Iface),
6224                                            Old_Tag_Node =>
6225                                              Unchecked_Convert_To
6226                                                (RTE (RE_Tag),
6227                                                 New_Occurrence_Of
6228                                                   (Node (Sec_DT_Ancestor),
6229                                                    Loc)),
6230                                            New_Tag_Node =>
6231                                              Unchecked_Convert_To
6232                                               (RTE (RE_Tag),
6233                                                New_Occurrence_Of
6234                                                  (Node (Sec_DT_Typ), Loc)),
6235                                            Num_Prims    => Num_Prims));
6236                                     end if;
6237                                  end if;
6238                               end;
6239
6240                               Next_Elmt (Sec_DT_Ancestor);
6241                               Next_Elmt (Sec_DT_Typ);
6242
6243                               --  Skip the secondary dispatch table of
6244                               --  predefined primitives
6245
6246                               Next_Elmt (Sec_DT_Ancestor);
6247                               Next_Elmt (Sec_DT_Typ);
6248
6249                               Next_Elmt (Iface);
6250                            end if;
6251
6252                            Next_Entity (E);
6253                         end loop;
6254                      end if;
6255                   end Copy_Secondary_DTs;
6256
6257                begin
6258                   if Present (Node (Sec_DT_Ancestor))
6259                     and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
6260                   then
6261                      --  Handle private types
6262
6263                      if Present (Full_View (Typ)) then
6264                         Copy_Secondary_DTs (Full_View (Typ));
6265                      else
6266                         Copy_Secondary_DTs (Typ);
6267                      end if;
6268                   end if;
6269                end;
6270             end if;
6271          end if;
6272       end if;
6273
6274       --  Generate code to check if the external tag of this type is the same
6275       --  as the external tag of some other declaration.
6276
6277       --     Check_TSD (TSD'Unrestricted_Access);
6278
6279       --  This check is a consequence of AI05-0113-1/06, so it officially
6280       --  applies to Ada 2005 (and Ada 2012). It might be argued that it is
6281       --  a desirable check to add in Ada 95 mode, but we hesitate to make
6282       --  this change, as it would be incompatible, and could conceivably
6283       --  cause a problem in existing Aa 95 code.
6284
6285       --  We check for No_Run_Time_Mode here, because we do not want to pick
6286       --  up the RE_Check_TSD entity and call it in No_Run_Time mode.
6287
6288       if not No_Run_Time_Mode
6289         and then Ada_Version >= Ada_2005
6290         and then RTE_Available (RE_Check_TSD)
6291         and then not Duplicated_Tag_Checks_Suppressed (Typ)
6292       then
6293          Append_To (Elab_Code,
6294            Make_Procedure_Call_Statement (Loc,
6295              Name                   =>
6296                New_Occurrence_Of (RTE (RE_Check_TSD), Loc),
6297              Parameter_Associations => New_List (
6298                Make_Attribute_Reference (Loc,
6299                  Prefix         => New_Occurrence_Of (TSD, Loc),
6300                  Attribute_Name => Name_Unchecked_Access))));
6301       end if;
6302
6303       --  Generate code to register the Tag in the External_Tag hash table for
6304       --  the pure Ada type only.
6305
6306       --        Register_Tag (Dt_Ptr);
6307
6308       --  Skip this action in the following cases:
6309       --    1) if Register_Tag is not available.
6310       --    2) in No_Run_Time mode.
6311       --    3) if Typ is not defined at the library level (this is required
6312       --       to avoid adding concurrency control to the hash table used
6313       --       by the run-time to register the tags).
6314
6315       if not No_Run_Time_Mode
6316         and then Is_Library_Level_Entity (Typ)
6317         and then RTE_Available (RE_Register_Tag)
6318       then
6319          Append_To (Elab_Code,
6320            Make_Procedure_Call_Statement (Loc,
6321              Name                   =>
6322                New_Occurrence_Of (RTE (RE_Register_Tag), Loc),
6323              Parameter_Associations =>
6324                New_List (New_Occurrence_Of (DT_Ptr, Loc))));
6325       end if;
6326
6327       if not Is_Empty_List (Elab_Code) then
6328          Append_List_To (Result, Elab_Code);
6329       end if;
6330
6331       --  Populate the two auxiliary tables used for dispatching asynchronous,
6332       --  conditional and timed selects for synchronized types that implement
6333       --  a limited interface. Skip this step in Ravenscar profile or when
6334       --  general dispatching is forbidden.
6335
6336       if Ada_Version >= Ada_2005
6337         and then Is_Concurrent_Record_Type (Typ)
6338         and then Has_Interfaces (Typ)
6339         and then not Restriction_Active (No_Dispatching_Calls)
6340         and then not Restriction_Active (No_Select_Statements)
6341       then
6342          Append_List_To (Result,
6343            Make_Select_Specific_Data_Table (Typ));
6344       end if;
6345
6346       --  Remember entities containing dispatch tables
6347
6348       Append_Elmt (Predef_Prims, DT_Decl);
6349       Append_Elmt (DT, DT_Decl);
6350
6351       Analyze_List (Result, Suppress => All_Checks);
6352       Set_Has_Dispatch_Table (Typ);
6353
6354       --  Mark entities containing dispatch tables. Required by the backend to
6355       --  handle them properly.
6356
6357       if Has_DT (Typ) then
6358          declare
6359             Elmt : Elmt_Id;
6360
6361          begin
6362             --  Object declarations
6363
6364             Elmt := First_Elmt (DT_Decl);
6365             while Present (Elmt) loop
6366                Set_Is_Dispatch_Table_Entity (Node (Elmt));
6367                pragma Assert (Ekind (Etype (Node (Elmt))) = E_Array_Subtype
6368                  or else Ekind (Etype (Node (Elmt))) = E_Record_Subtype);
6369                Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt)));
6370                Next_Elmt (Elmt);
6371             end loop;
6372
6373             --  Aggregates initializing dispatch tables
6374
6375             Elmt := First_Elmt (DT_Aggr);
6376             while Present (Elmt) loop
6377                Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt)));
6378                Next_Elmt (Elmt);
6379             end loop;
6380          end;
6381       end if;
6382
6383    <<Leave_SCIL>>
6384
6385       --  Register the tagged type in the call graph nodes table
6386
6387       Register_CG_Node (Typ);
6388
6389    <<Leave>>
6390       Restore_Ghost_Mode (Saved_GM);
6391
6392       return Result;
6393    end Make_DT;
6394
6395    -------------------------------------
6396    -- Make_Select_Specific_Data_Table --
6397    -------------------------------------
6398
6399    function Make_Select_Specific_Data_Table
6400      (Typ : Entity_Id) return List_Id
6401    is
6402       Assignments : constant List_Id    := New_List;
6403       Loc         : constant Source_Ptr := Sloc (Typ);
6404
6405       Conc_Typ  : Entity_Id;
6406       Decls     : List_Id := No_List;
6407       Prim      : Entity_Id;
6408       Prim_Als  : Entity_Id;
6409       Prim_Elmt : Elmt_Id;
6410       Prim_Pos  : Uint;
6411       Nb_Prim   : Nat := 0;
6412
6413       type Examined_Array is array (Int range <>) of Boolean;
6414
6415       function Find_Entry_Index (E : Entity_Id) return Uint;
6416       --  Given an entry, find its index in the visible declarations of the
6417       --  corresponding concurrent type of Typ.
6418
6419       ----------------------
6420       -- Find_Entry_Index --
6421       ----------------------
6422
6423       function Find_Entry_Index (E : Entity_Id) return Uint is
6424          Index     : Uint := Uint_1;
6425          Subp_Decl : Entity_Id;
6426
6427       begin
6428          if Present (Decls)
6429            and then not Is_Empty_List (Decls)
6430          then
6431             Subp_Decl := First (Decls);
6432             while Present (Subp_Decl) loop
6433                if Nkind (Subp_Decl) = N_Entry_Declaration then
6434                   if Defining_Identifier (Subp_Decl) = E then
6435                      return Index;
6436                   end if;
6437
6438                   Index := Index + 1;
6439                end if;
6440
6441                Next (Subp_Decl);
6442             end loop;
6443          end if;
6444
6445          return Uint_0;
6446       end Find_Entry_Index;
6447
6448       --  Local variables
6449
6450       Tag_Node : Node_Id;
6451
6452    --  Start of processing for Make_Select_Specific_Data_Table
6453
6454    begin
6455       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
6456
6457       if Present (Corresponding_Concurrent_Type (Typ)) then
6458          Conc_Typ := Corresponding_Concurrent_Type (Typ);
6459
6460          if Present (Full_View (Conc_Typ)) then
6461             Conc_Typ := Full_View (Conc_Typ);
6462          end if;
6463
6464          if Ekind (Conc_Typ) = E_Protected_Type then
6465             Decls := Visible_Declarations (Protected_Definition (
6466                        Parent (Conc_Typ)));
6467          else
6468             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
6469             Decls := Visible_Declarations (Task_Definition (
6470                        Parent (Conc_Typ)));
6471          end if;
6472       end if;
6473
6474       --  Count the non-predefined primitive operations
6475
6476       Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
6477       while Present (Prim_Elmt) loop
6478          Prim := Node (Prim_Elmt);
6479
6480          if not (Is_Predefined_Dispatching_Operation (Prim)
6481                    or else Is_Predefined_Dispatching_Alias (Prim))
6482          then
6483             Nb_Prim := Nb_Prim + 1;
6484          end if;
6485
6486          Next_Elmt (Prim_Elmt);
6487       end loop;
6488
6489       declare
6490          Examined : Examined_Array (1 .. Nb_Prim) := (others => False);
6491
6492       begin
6493          Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
6494          while Present (Prim_Elmt) loop
6495             Prim := Node (Prim_Elmt);
6496
6497             --  Look for primitive overriding an abstract interface subprogram
6498
6499             if Present (Interface_Alias (Prim))
6500               and then not
6501                 Is_Ancestor
6502                   (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
6503                    Use_Full_View => True)
6504               and then not Examined (UI_To_Int (DT_Position (Alias (Prim))))
6505             then
6506                Prim_Pos := DT_Position (Alias (Prim));
6507                pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim);
6508                Examined (UI_To_Int (Prim_Pos)) := True;
6509
6510                --  Set the primitive operation kind regardless of subprogram
6511                --  type. Generate:
6512                --    Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
6513
6514                if Tagged_Type_Expansion then
6515                   Tag_Node :=
6516                     New_Occurrence_Of
6517                      (Node (First_Elmt (Access_Disp_Table (Typ))), Loc);
6518
6519                else
6520                   Tag_Node :=
6521                     Make_Attribute_Reference (Loc,
6522                       Prefix         => New_Occurrence_Of (Typ, Loc),
6523                       Attribute_Name => Name_Tag);
6524                end if;
6525
6526                Append_To (Assignments,
6527                  Make_Procedure_Call_Statement (Loc,
6528                    Name => New_Occurrence_Of (RTE (RE_Set_Prim_Op_Kind), Loc),
6529                    Parameter_Associations => New_List (
6530                      Tag_Node,
6531                      Make_Integer_Literal (Loc, Prim_Pos),
6532                      Prim_Op_Kind (Alias (Prim), Typ))));
6533
6534                --  Retrieve the root of the alias chain
6535
6536                Prim_Als := Ultimate_Alias (Prim);
6537
6538                --  In the case of an entry wrapper, set the entry index
6539
6540                if Ekind (Prim) = E_Procedure
6541                  and then Is_Primitive_Wrapper (Prim_Als)
6542                  and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry
6543                then
6544                   --  Generate:
6545                   --    Ada.Tags.Set_Entry_Index
6546                   --      (DT_Ptr, <position>, <index>);
6547
6548                   if Tagged_Type_Expansion then
6549                      Tag_Node :=
6550                        New_Occurrence_Of
6551                          (Node (First_Elmt (Access_Disp_Table (Typ))), Loc);
6552                   else
6553                      Tag_Node :=
6554                        Make_Attribute_Reference (Loc,
6555                          Prefix         => New_Occurrence_Of (Typ, Loc),
6556                          Attribute_Name => Name_Tag);
6557                   end if;
6558
6559                   Append_To (Assignments,
6560                     Make_Procedure_Call_Statement (Loc,
6561                       Name =>
6562                         New_Occurrence_Of (RTE (RE_Set_Entry_Index), Loc),
6563                       Parameter_Associations => New_List (
6564                         Tag_Node,
6565                         Make_Integer_Literal (Loc, Prim_Pos),
6566                         Make_Integer_Literal (Loc,
6567                           Find_Entry_Index (Wrapped_Entity (Prim_Als))))));
6568                end if;
6569             end if;
6570
6571             Next_Elmt (Prim_Elmt);
6572          end loop;
6573       end;
6574
6575       return Assignments;
6576    end Make_Select_Specific_Data_Table;
6577
6578    ---------------
6579    -- Make_Tags --
6580    ---------------
6581
6582    function Make_Tags (Typ : Entity_Id) return List_Id is
6583       Loc    : constant Source_Ptr := Sloc (Typ);
6584       Result : constant List_Id    := New_List;
6585
6586       procedure Import_DT
6587         (Tag_Typ         : Entity_Id;
6588          DT              : Entity_Id;
6589          Is_Secondary_DT : Boolean);
6590       --  Import the dispatch table DT of tagged type Tag_Typ. Required to
6591       --  generate forward references and statically allocate the table. For
6592       --  primary dispatch tables that require no dispatch table generate:
6593
6594       --     DT : static aliased constant Non_Dispatch_Table_Wrapper;
6595       --     pragma Import (Ada, DT);
6596
6597       --  Otherwise generate:
6598
6599       --     DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
6600       --     pragma Import (Ada, DT);
6601
6602       ---------------
6603       -- Import_DT --
6604       ---------------
6605
6606       procedure Import_DT
6607         (Tag_Typ         : Entity_Id;
6608          DT              : Entity_Id;
6609          Is_Secondary_DT : Boolean)
6610       is
6611          DT_Constr_List : List_Id;
6612          Nb_Prim        : Nat;
6613
6614       begin
6615          Set_Is_Imported  (DT);
6616          Set_Ekind        (DT, E_Constant);
6617          Set_Related_Type (DT, Typ);
6618
6619          --  The scope must be set now to call Get_External_Name
6620
6621          Set_Scope (DT, Current_Scope);
6622
6623          Get_External_Name (DT);
6624          Set_Interface_Name (DT,
6625            Make_String_Literal (Loc, Strval => String_From_Name_Buffer));
6626
6627          --  Ensure proper Sprint output of this implicit importation
6628
6629          Set_Is_Internal (DT);
6630
6631          --  Save this entity to allow Make_DT to generate its exportation
6632
6633          Append_Elmt (DT, Dispatch_Table_Wrappers (Typ));
6634
6635          --  No dispatch table required
6636
6637          if not Is_Secondary_DT and then not Has_DT (Tag_Typ) then
6638             Append_To (Result,
6639               Make_Object_Declaration (Loc,
6640                 Defining_Identifier => DT,
6641                 Aliased_Present     => True,
6642                 Constant_Present    => True,
6643                 Object_Definition   =>
6644                   New_Occurrence_Of
6645                     (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
6646
6647          else
6648             --  Calculate the number of primitives of the dispatch table and
6649             --  the size of the Type_Specific_Data record.
6650
6651             Nb_Prim :=
6652               UI_To_Int (DT_Entry_Count (First_Tag_Component (Tag_Typ)));
6653
6654             --  If the tagged type has no primitives we add a dummy slot whose
6655             --  address will be the tag of this type.
6656
6657             if Nb_Prim = 0 then
6658                DT_Constr_List :=
6659                  New_List (Make_Integer_Literal (Loc, 1));
6660             else
6661                DT_Constr_List :=
6662                  New_List (Make_Integer_Literal (Loc, Nb_Prim));
6663             end if;
6664
6665             Append_To (Result,
6666               Make_Object_Declaration (Loc,
6667                 Defining_Identifier => DT,
6668                 Aliased_Present     => True,
6669                 Constant_Present    => True,
6670                 Object_Definition   =>
6671                   Make_Subtype_Indication (Loc,
6672                     Subtype_Mark =>
6673                       New_Occurrence_Of (RTE (RE_Dispatch_Table_Wrapper), Loc),
6674                     Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
6675                                     Constraints => DT_Constr_List))));
6676          end if;
6677       end Import_DT;
6678
6679       --  Local variables
6680
6681       Tname            : constant Name_Id := Chars (Typ);
6682       AI_Tag_Comp      : Elmt_Id;
6683       DT               : Node_Id := Empty;
6684       DT_Ptr           : Node_Id;
6685       Predef_Prims_Ptr : Node_Id;
6686       Iface_DT         : Node_Id := Empty;
6687       Iface_DT_Ptr     : Node_Id;
6688       New_Node         : Node_Id;
6689       Suffix_Index     : Int;
6690       Typ_Name         : Name_Id;
6691       Typ_Comps        : Elist_Id;
6692
6693    --  Start of processing for Make_Tags
6694
6695    begin
6696       pragma Assert (No (Access_Disp_Table (Typ)));
6697       Set_Access_Disp_Table (Typ, New_Elmt_List);
6698
6699       --  If the elaboration of this tagged type needs a boolean flag then
6700       --  define now its entity. It is initialized to True to indicate that
6701       --  elaboration is still pending; set to False by the IP routine.
6702
6703       --      TypFxx : boolean := True;
6704
6705       if Elab_Flag_Needed (Typ) then
6706          Set_Access_Disp_Table_Elab_Flag (Typ,
6707            Make_Defining_Identifier (Loc,
6708              Chars => New_External_Name (Tname, 'F')));
6709
6710          Append_To (Result,
6711            Make_Object_Declaration (Loc,
6712              Defining_Identifier => Access_Disp_Table_Elab_Flag (Typ),
6713              Object_Definition   => New_Occurrence_Of (Standard_Boolean, Loc),
6714              Expression          => New_Occurrence_Of (Standard_True, Loc)));
6715       end if;
6716
6717       --  1) Generate the primary tag entities
6718
6719       --  Primary dispatch table containing user-defined primitives
6720
6721       DT_Ptr := Make_Defining_Identifier (Loc, New_External_Name (Tname, 'P'));
6722       Set_Etype   (DT_Ptr, RTE (RE_Tag));
6723       Append_Elmt (DT_Ptr, Access_Disp_Table (Typ));
6724
6725       --  Minimum decoration
6726
6727       Set_Ekind        (DT_Ptr, E_Variable);
6728       Set_Related_Type (DT_Ptr, Typ);
6729
6730       --  Notify back end that the types are associated with a dispatch table
6731
6732       Set_Is_Dispatch_Table_Entity (RTE (RE_Prim_Ptr));
6733       Set_Is_Dispatch_Table_Entity (RTE (RE_Predef_Prims_Table_Ptr));
6734
6735       --  For CPP types there is no need to build the dispatch tables since
6736       --  they are imported from the C++ side. If the CPP type has an IP then
6737       --  we declare now the variable that will store the copy of the C++ tag.
6738       --  If the CPP type is an interface, we need the variable as well because
6739       --  it becomes the pointer to the corresponding secondary table.
6740
6741       if Is_CPP_Class (Typ) then
6742          if Has_CPP_Constructors (Typ) or else Is_Interface (Typ) then
6743             Append_To (Result,
6744               Make_Object_Declaration (Loc,
6745                 Defining_Identifier => DT_Ptr,
6746                 Object_Definition   => New_Occurrence_Of (RTE (RE_Tag), Loc),
6747                 Expression =>
6748                   Unchecked_Convert_To (RTE (RE_Tag),
6749                     New_Occurrence_Of (RTE (RE_Null_Address), Loc))));
6750
6751             Set_Is_Statically_Allocated (DT_Ptr,
6752               Is_Library_Level_Tagged_Type (Typ));
6753          end if;
6754
6755       --  Ada types
6756
6757       else
6758          --  Primary dispatch table containing predefined primitives
6759
6760          Predef_Prims_Ptr :=
6761            Make_Defining_Identifier (Loc,
6762              Chars => New_External_Name (Tname, 'Y'));
6763          Set_Etype   (Predef_Prims_Ptr, RTE (RE_Address));
6764          Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ));
6765
6766          --  Import the forward declaration of the Dispatch Table wrapper
6767          --  record (Make_DT will take care of exporting it).
6768
6769          if Building_Static_DT (Typ) then
6770             Set_Dispatch_Table_Wrappers (Typ, New_Elmt_List);
6771
6772             DT :=
6773               Make_Defining_Identifier (Loc,
6774                 Chars => New_External_Name (Tname, 'T'));
6775
6776             Import_DT (Typ, DT, Is_Secondary_DT => False);
6777
6778             if Has_DT (Typ) then
6779                Append_To (Result,
6780                  Make_Object_Declaration (Loc,
6781                    Defining_Identifier => DT_Ptr,
6782                    Constant_Present    => True,
6783                    Object_Definition   =>
6784                      New_Occurrence_Of (RTE (RE_Tag), Loc),
6785                    Expression          =>
6786                      Unchecked_Convert_To (RTE (RE_Tag),
6787                        Make_Attribute_Reference (Loc,
6788                          Prefix         =>
6789                            Make_Selected_Component (Loc,
6790                              Prefix        => New_Occurrence_Of (DT, Loc),
6791                              Selector_Name =>
6792                                New_Occurrence_Of
6793                                  (RTE_Record_Component (RE_Prims_Ptr), Loc)),
6794                          Attribute_Name => Name_Address))));
6795
6796                --  Generate the SCIL node for the previous object declaration
6797                --  because it has a tag initialization.
6798
6799                if Generate_SCIL then
6800                   New_Node :=
6801                     Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
6802                   Set_SCIL_Entity (New_Node, Typ);
6803                   Set_SCIL_Node (Last (Result), New_Node);
6804                end if;
6805
6806                Append_To (Result,
6807                  Make_Object_Declaration (Loc,
6808                    Defining_Identifier => Predef_Prims_Ptr,
6809                    Constant_Present    => True,
6810                    Object_Definition   =>
6811                      New_Occurrence_Of (RTE (RE_Address), Loc),
6812                    Expression          =>
6813                      Make_Attribute_Reference (Loc,
6814                        Prefix         =>
6815                          Make_Selected_Component (Loc,
6816                            Prefix        => New_Occurrence_Of (DT, Loc),
6817                            Selector_Name =>
6818                              New_Occurrence_Of
6819                                (RTE_Record_Component (RE_Predef_Prims), Loc)),
6820                        Attribute_Name => Name_Address)));
6821
6822             --  No dispatch table required
6823
6824             else
6825                Append_To (Result,
6826                  Make_Object_Declaration (Loc,
6827                    Defining_Identifier => DT_Ptr,
6828                    Constant_Present    => True,
6829                    Object_Definition   =>
6830                      New_Occurrence_Of (RTE (RE_Tag), Loc),
6831                    Expression          =>
6832                      Unchecked_Convert_To (RTE (RE_Tag),
6833                        Make_Attribute_Reference (Loc,
6834                          Prefix         =>
6835                            Make_Selected_Component (Loc,
6836                              Prefix => New_Occurrence_Of (DT, Loc),
6837                              Selector_Name =>
6838                                New_Occurrence_Of
6839                                  (RTE_Record_Component (RE_NDT_Prims_Ptr),
6840                                   Loc)),
6841                          Attribute_Name => Name_Address))));
6842             end if;
6843
6844             Set_Is_True_Constant (DT_Ptr);
6845             Set_Is_Statically_Allocated (DT_Ptr);
6846          end if;
6847       end if;
6848
6849       --  2) Generate the secondary tag entities
6850
6851       --  Collect the components associated with secondary dispatch tables
6852
6853       if Has_Interfaces (Typ) then
6854          Collect_Interface_Components (Typ, Typ_Comps);
6855
6856          --  For each interface type we build a unique external name associated
6857          --  with its secondary dispatch table. This name is used to declare an
6858          --  object that references this secondary dispatch table, whose value
6859          --  will be used for the elaboration of Typ objects, and also for the
6860          --  elaboration of objects of types derived from Typ that do not
6861          --  override the primitives of this interface type.
6862
6863          Suffix_Index := 1;
6864
6865          --  Note: The value of Suffix_Index must be in sync with the values of
6866          --  Suffix_Index in secondary dispatch tables generated by Make_DT.
6867
6868          if Is_CPP_Class (Typ) then
6869             AI_Tag_Comp := First_Elmt (Typ_Comps);
6870             while Present (AI_Tag_Comp) loop
6871                Get_Secondary_DT_External_Name
6872                  (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
6873                Typ_Name := Name_Find;
6874
6875                --  Declare variables to store copy of the C++ secondary tags
6876
6877                Iface_DT_Ptr :=
6878                  Make_Defining_Identifier (Loc,
6879                    Chars => New_External_Name (Typ_Name, 'P'));
6880                Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
6881                Set_Ekind (Iface_DT_Ptr, E_Variable);
6882                Set_Is_Tag (Iface_DT_Ptr);
6883
6884                Set_Has_Thunks (Iface_DT_Ptr);
6885                Set_Related_Type
6886                  (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
6887                Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
6888
6889                Append_To (Result,
6890                  Make_Object_Declaration (Loc,
6891                    Defining_Identifier => Iface_DT_Ptr,
6892                    Object_Definition   => New_Occurrence_Of
6893                                             (RTE (RE_Interface_Tag), Loc),
6894                    Expression =>
6895                      Unchecked_Convert_To (RTE (RE_Interface_Tag),
6896                        New_Occurrence_Of (RTE (RE_Null_Address), Loc))));
6897
6898                Set_Is_Statically_Allocated (Iface_DT_Ptr,
6899                  Is_Library_Level_Tagged_Type (Typ));
6900
6901                Next_Elmt (AI_Tag_Comp);
6902             end loop;
6903
6904          --  This is not a CPP_Class type
6905
6906          else
6907             AI_Tag_Comp := First_Elmt (Typ_Comps);
6908             while Present (AI_Tag_Comp) loop
6909                Get_Secondary_DT_External_Name
6910                  (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
6911                Typ_Name := Name_Find;
6912
6913                if Building_Static_DT (Typ) then
6914                   Iface_DT :=
6915                     Make_Defining_Identifier (Loc,
6916                       Chars => New_External_Name (Typ_Name, 'T'));
6917                   Import_DT
6918                     (Tag_Typ => Related_Type (Node (AI_Tag_Comp)),
6919                      DT      => Iface_DT,
6920                      Is_Secondary_DT => True);
6921                end if;
6922
6923                --  Secondary dispatch table referencing thunks to user-defined
6924                --  primitives covered by this interface.
6925
6926                Iface_DT_Ptr :=
6927                  Make_Defining_Identifier (Loc,
6928                    Chars => New_External_Name (Typ_Name, 'P'));
6929                Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
6930                Set_Ekind (Iface_DT_Ptr, E_Constant);
6931                Set_Is_Tag (Iface_DT_Ptr);
6932                Set_Has_Thunks (Iface_DT_Ptr);
6933                Set_Is_Statically_Allocated (Iface_DT_Ptr,
6934                  Is_Library_Level_Tagged_Type (Typ));
6935                Set_Is_True_Constant (Iface_DT_Ptr);
6936                Set_Related_Type
6937                  (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
6938                Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
6939
6940                if Building_Static_DT (Typ) then
6941                   Append_To (Result,
6942                     Make_Object_Declaration (Loc,
6943                       Defining_Identifier => Iface_DT_Ptr,
6944                       Constant_Present    => True,
6945                       Object_Definition   => New_Occurrence_Of
6946                                                (RTE (RE_Interface_Tag), Loc),
6947                       Expression          =>
6948                         Unchecked_Convert_To (RTE (RE_Interface_Tag),
6949                           Make_Attribute_Reference (Loc,
6950                             Prefix         =>
6951                               Make_Selected_Component (Loc,
6952                                 Prefix        =>
6953                                   New_Occurrence_Of (Iface_DT, Loc),
6954                                 Selector_Name =>
6955                                   New_Occurrence_Of
6956                                     (RTE_Record_Component (RE_Prims_Ptr),
6957                                      Loc)),
6958                             Attribute_Name => Name_Address))));
6959                end if;
6960
6961                --  Secondary dispatch table referencing thunks to predefined
6962                --  primitives.
6963
6964                Iface_DT_Ptr :=
6965                  Make_Defining_Identifier (Loc,
6966                    Chars => New_External_Name (Typ_Name, 'Y'));
6967                Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
6968                Set_Ekind (Iface_DT_Ptr, E_Constant);
6969                Set_Is_Tag (Iface_DT_Ptr);
6970                Set_Has_Thunks (Iface_DT_Ptr);
6971                Set_Is_Statically_Allocated (Iface_DT_Ptr,
6972                  Is_Library_Level_Tagged_Type (Typ));
6973                Set_Is_True_Constant (Iface_DT_Ptr);
6974                Set_Related_Type
6975                  (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
6976                Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
6977
6978                --  Secondary dispatch table referencing user-defined primitives
6979                --  covered by this interface.
6980
6981                Iface_DT_Ptr :=
6982                  Make_Defining_Identifier (Loc,
6983                    Chars => New_External_Name (Typ_Name, 'D'));
6984                Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
6985                Set_Ekind (Iface_DT_Ptr, E_Constant);
6986                Set_Is_Tag (Iface_DT_Ptr);
6987                Set_Is_Statically_Allocated (Iface_DT_Ptr,
6988                  Is_Library_Level_Tagged_Type (Typ));
6989                Set_Is_True_Constant (Iface_DT_Ptr);
6990                Set_Related_Type
6991                  (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
6992                Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
6993
6994                --  Secondary dispatch table referencing predefined primitives
6995
6996                Iface_DT_Ptr :=
6997                  Make_Defining_Identifier (Loc,
6998                    Chars => New_External_Name (Typ_Name, 'Z'));
6999                Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
7000                Set_Ekind (Iface_DT_Ptr, E_Constant);
7001                Set_Is_Tag (Iface_DT_Ptr);
7002                Set_Is_Statically_Allocated (Iface_DT_Ptr,
7003                  Is_Library_Level_Tagged_Type (Typ));
7004                Set_Is_True_Constant (Iface_DT_Ptr);
7005                Set_Related_Type
7006                  (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
7007                Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
7008
7009                Next_Elmt (AI_Tag_Comp);
7010             end loop;
7011          end if;
7012       end if;
7013
7014       --  3) At the end of Access_Disp_Table, if the type has user-defined
7015       --     primitives, we add the entity of an access type declaration that
7016       --     is used by Build_Get_Prim_Op_Address to expand dispatching calls
7017       --     through the primary dispatch table.
7018
7019       if UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))) = 0 then
7020          Analyze_List (Result);
7021
7022       --     Generate:
7023       --       type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr;
7024       --       type Typ_DT_Acc is access Typ_DT;
7025
7026       else
7027          declare
7028             Name_DT_Prims     : constant Name_Id :=
7029                                   New_External_Name (Tname, 'G');
7030             Name_DT_Prims_Acc : constant Name_Id :=
7031                                   New_External_Name (Tname, 'H');
7032             DT_Prims          : constant Entity_Id :=
7033                                   Make_Defining_Identifier (Loc,
7034                                     Name_DT_Prims);
7035             DT_Prims_Acc      : constant Entity_Id :=
7036                                   Make_Defining_Identifier (Loc,
7037                                     Name_DT_Prims_Acc);
7038          begin
7039             Append_To (Result,
7040               Make_Full_Type_Declaration (Loc,
7041                 Defining_Identifier => DT_Prims,
7042                 Type_Definition =>
7043                   Make_Constrained_Array_Definition (Loc,
7044                     Discrete_Subtype_Definitions => New_List (
7045                       Make_Range (Loc,
7046                         Low_Bound  => Make_Integer_Literal (Loc, 1),
7047                         High_Bound => Make_Integer_Literal (Loc,
7048                                        DT_Entry_Count
7049                                          (First_Tag_Component (Typ))))),
7050                     Component_Definition =>
7051                       Make_Component_Definition (Loc,
7052                         Subtype_Indication =>
7053                           New_Occurrence_Of (RTE (RE_Prim_Ptr), Loc)))));
7054
7055             Append_To (Result,
7056               Make_Full_Type_Declaration (Loc,
7057                 Defining_Identifier => DT_Prims_Acc,
7058                 Type_Definition =>
7059                    Make_Access_To_Object_Definition (Loc,
7060                      Subtype_Indication =>
7061                        New_Occurrence_Of (DT_Prims, Loc))));
7062
7063             Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ));
7064
7065             --  Analyze the resulting list and suppress the generation of the
7066             --  Init_Proc associated with the above array declaration because
7067             --  this type is never used in object declarations. It is only used
7068             --  to simplify the expansion associated with dispatching calls.
7069
7070             Analyze_List (Result);
7071             Set_Suppress_Initialization (Base_Type (DT_Prims));
7072
7073             --  Disable backend optimizations based on assumptions about the
7074             --  aliasing status of objects designated by the access to the
7075             --  dispatch table. Required to handle dispatch tables imported
7076             --  from C++.
7077
7078             Set_No_Strict_Aliasing (Base_Type (DT_Prims_Acc));
7079
7080             --  Add the freezing nodes of these declarations; required to avoid
7081             --  generating these freezing nodes in wrong scopes (for example in
7082             --  the IC routine of a derivation of Typ).
7083
7084             --  What is an "IC routine"? Is "init_proc" meant here???
7085
7086             Append_List_To (Result, Freeze_Entity (DT_Prims, Typ));
7087             Append_List_To (Result, Freeze_Entity (DT_Prims_Acc, Typ));
7088
7089             --  Mark entity of dispatch table. Required by the back end to
7090             --  handle them properly.
7091
7092             Set_Is_Dispatch_Table_Entity (DT_Prims);
7093          end;
7094       end if;
7095
7096       --  Mark entities of dispatch table. Required by the back end to handle
7097       --  them properly.
7098
7099       if Present (DT) then
7100          Set_Is_Dispatch_Table_Entity (DT);
7101          Set_Is_Dispatch_Table_Entity (Etype (DT));
7102       end if;
7103
7104       if Present (Iface_DT) then
7105          Set_Is_Dispatch_Table_Entity (Iface_DT);
7106          Set_Is_Dispatch_Table_Entity (Etype (Iface_DT));
7107       end if;
7108
7109       if Is_CPP_Class (Root_Type (Typ)) then
7110          Set_Ekind (DT_Ptr, E_Variable);
7111       else
7112          Set_Ekind (DT_Ptr, E_Constant);
7113       end if;
7114
7115       Set_Is_Tag       (DT_Ptr);
7116       Set_Related_Type (DT_Ptr, Typ);
7117
7118       return Result;
7119    end Make_Tags;
7120
7121    ---------------
7122    -- New_Value --
7123    ---------------
7124
7125    function New_Value (From : Node_Id) return Node_Id is
7126       Res : constant Node_Id := Duplicate_Subexpr (From);
7127    begin
7128       if Is_Access_Type (Etype (From)) then
7129          return Make_Explicit_Dereference (Sloc (From), Prefix => Res);
7130       else
7131          return Res;
7132       end if;
7133    end New_Value;
7134
7135    -----------------------------------
7136    -- Original_View_In_Visible_Part --
7137    -----------------------------------
7138
7139    function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is
7140       Scop : constant Entity_Id := Scope (Typ);
7141
7142    begin
7143       --  The scope must be a package
7144
7145       if not Is_Package_Or_Generic_Package (Scop) then
7146          return False;
7147       end if;
7148
7149       --  A type with a private declaration has a private view declared in
7150       --  the visible part.
7151
7152       if Has_Private_Declaration (Typ) then
7153          return True;
7154       end if;
7155
7156       return List_Containing (Parent (Typ)) =
7157         Visible_Declarations (Package_Specification (Scop));
7158    end Original_View_In_Visible_Part;
7159
7160    ------------------
7161    -- Prim_Op_Kind --
7162    ------------------
7163
7164    function Prim_Op_Kind
7165      (Prim : Entity_Id;
7166       Typ  : Entity_Id) return Node_Id
7167    is
7168       Full_Typ : Entity_Id := Typ;
7169       Loc      : constant Source_Ptr := Sloc (Prim);
7170       Prim_Op  : Entity_Id;
7171
7172    begin
7173       --  Retrieve the original primitive operation
7174
7175       Prim_Op := Ultimate_Alias (Prim);
7176
7177       if Ekind (Typ) = E_Record_Type
7178         and then Present (Corresponding_Concurrent_Type (Typ))
7179       then
7180          Full_Typ := Corresponding_Concurrent_Type (Typ);
7181       end if;
7182
7183       --  When a private tagged type is completed by a concurrent type,
7184       --  retrieve the full view.
7185
7186       if Is_Private_Type (Full_Typ) then
7187          Full_Typ := Full_View (Full_Typ);
7188       end if;
7189
7190       if Ekind (Prim_Op) = E_Function then
7191
7192          --  Protected function
7193
7194          if Ekind (Full_Typ) = E_Protected_Type then
7195             return New_Occurrence_Of (RTE (RE_POK_Protected_Function), Loc);
7196
7197          --  Task function
7198
7199          elsif Ekind (Full_Typ) = E_Task_Type then
7200             return New_Occurrence_Of (RTE (RE_POK_Task_Function), Loc);
7201
7202          --  Regular function
7203
7204          else
7205             return New_Occurrence_Of (RTE (RE_POK_Function), Loc);
7206          end if;
7207
7208       else
7209          pragma Assert (Ekind (Prim_Op) = E_Procedure);
7210
7211          if Ekind (Full_Typ) = E_Protected_Type then
7212
7213             --  Protected entry
7214
7215             if Is_Primitive_Wrapper (Prim_Op)
7216               and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
7217             then
7218                return New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc);
7219
7220             --  Protected procedure
7221
7222             else
7223                return
7224                  New_Occurrence_Of (RTE (RE_POK_Protected_Procedure), Loc);
7225             end if;
7226
7227          elsif Ekind (Full_Typ) = E_Task_Type then
7228
7229             --  Task entry
7230
7231             if Is_Primitive_Wrapper (Prim_Op)
7232               and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
7233             then
7234                return New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc);
7235
7236             --  Task "procedure". These are the internally Expander-generated
7237             --  procedures (task body for instance).
7238
7239             else
7240                return New_Occurrence_Of (RTE (RE_POK_Task_Procedure), Loc);
7241             end if;
7242
7243          --  Regular procedure
7244
7245          else
7246             return New_Occurrence_Of (RTE (RE_POK_Procedure), Loc);
7247          end if;
7248       end if;
7249    end Prim_Op_Kind;
7250
7251    ------------------------
7252    -- Register_Primitive --
7253    ------------------------
7254
7255    function Register_Primitive
7256      (Loc     : Source_Ptr;
7257       Prim    : Entity_Id) return List_Id
7258    is
7259       DT_Ptr        : Entity_Id;
7260       Iface_Prim    : Entity_Id;
7261       Iface_Typ     : Entity_Id;
7262       Iface_DT_Ptr  : Entity_Id;
7263       Iface_DT_Elmt : Elmt_Id;
7264       L             : constant List_Id := New_List;
7265       Pos           : Uint;
7266       Tag           : Entity_Id;
7267       Tag_Typ       : Entity_Id;
7268       Thunk_Id      : Entity_Id;
7269       Thunk_Code    : Node_Id;
7270
7271    begin
7272       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
7273
7274       --  Do not register in the dispatch table eliminated primitives
7275
7276       if not RTE_Available (RE_Tag)
7277         or else Is_Eliminated (Ultimate_Alias (Prim))
7278         or else Generate_SCIL
7279       then
7280          return L;
7281       end if;
7282
7283       if not Present (Interface_Alias (Prim)) then
7284          Tag_Typ := Scope (DTC_Entity (Prim));
7285          Pos := DT_Position (Prim);
7286          Tag := First_Tag_Component (Tag_Typ);
7287
7288          if Is_Predefined_Dispatching_Operation (Prim)
7289            or else Is_Predefined_Dispatching_Alias (Prim)
7290          then
7291             DT_Ptr :=
7292               Node (Next_Elmt (First_Elmt (Access_Disp_Table (Tag_Typ))));
7293
7294             Append_To (L,
7295               Build_Set_Predefined_Prim_Op_Address (Loc,
7296                 Tag_Node     => New_Occurrence_Of (DT_Ptr, Loc),
7297                 Position     => Pos,
7298                 Address_Node =>
7299                   Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7300                     Make_Attribute_Reference (Loc,
7301                       Prefix         => New_Occurrence_Of (Prim, Loc),
7302                       Attribute_Name => Name_Unrestricted_Access))));
7303
7304             --  Register copy of the pointer to the 'size primitive in the TSD
7305
7306             if Chars (Prim) = Name_uSize
7307               and then RTE_Record_Component_Available (RE_Size_Func)
7308             then
7309                DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
7310                Append_To (L,
7311                  Build_Set_Size_Function (Loc,
7312                    Tag_Node  => New_Occurrence_Of (DT_Ptr, Loc),
7313                    Size_Func => Prim));
7314             end if;
7315
7316          else
7317             pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
7318
7319             --  Skip registration of primitives located in the C++ part of the
7320             --  dispatch table. Their slot is set by the IC routine.
7321
7322             if not Is_CPP_Class (Root_Type (Tag_Typ))
7323               or else Pos > CPP_Num_Prims (Tag_Typ)
7324             then
7325                DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
7326                Append_To (L,
7327                  Build_Set_Prim_Op_Address (Loc,
7328                    Typ          => Tag_Typ,
7329                    Tag_Node     => New_Occurrence_Of (DT_Ptr, Loc),
7330                    Position     => Pos,
7331                    Address_Node =>
7332                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7333                        Make_Attribute_Reference (Loc,
7334                          Prefix         => New_Occurrence_Of (Prim, Loc),
7335                          Attribute_Name => Name_Unrestricted_Access))));
7336             end if;
7337          end if;
7338
7339       --  Ada 2005 (AI-251): Primitive associated with an interface type
7340
7341       --  Generate the code of the thunk only if the interface type is not an
7342       --  immediate ancestor of Typ; otherwise the dispatch table associated
7343       --  with the interface is the primary dispatch table and we have nothing
7344       --  else to do here.
7345
7346       else
7347          Tag_Typ   := Find_Dispatching_Type (Alias (Prim));
7348          Iface_Typ := Find_Dispatching_Type (Interface_Alias (Prim));
7349
7350          pragma Assert (Is_Interface (Iface_Typ));
7351
7352          --  No action needed for interfaces that are ancestors of Typ because
7353          --  their primitives are located in the primary dispatch table.
7354
7355          if Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True) then
7356             return L;
7357
7358          --  No action needed for primitives located in the C++ part of the
7359          --  dispatch table. Their slot is set by the IC routine.
7360
7361          elsif Is_CPP_Class (Root_Type (Tag_Typ))
7362             and then DT_Position (Alias (Prim)) <= CPP_Num_Prims (Tag_Typ)
7363             and then not Is_Predefined_Dispatching_Operation (Prim)
7364             and then not Is_Predefined_Dispatching_Alias (Prim)
7365          then
7366             return L;
7367          end if;
7368
7369          Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
7370
7371          if not Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True)
7372            and then Present (Thunk_Code)
7373          then
7374             --  Generate the code necessary to fill the appropriate entry of
7375             --  the secondary dispatch table of Prim's controlling type with
7376             --  Thunk_Id's address.
7377
7378             Iface_DT_Elmt := Find_Interface_ADT (Tag_Typ, Iface_Typ);
7379             Iface_DT_Ptr  := Node (Iface_DT_Elmt);
7380             pragma Assert (Has_Thunks (Iface_DT_Ptr));
7381
7382             Iface_Prim := Interface_Alias (Prim);
7383             Pos        := DT_Position (Iface_Prim);
7384             Tag        := First_Tag_Component (Iface_Typ);
7385
7386             Prepend_To (L, Thunk_Code);
7387
7388             if Is_Predefined_Dispatching_Operation (Prim)
7389               or else Is_Predefined_Dispatching_Alias (Prim)
7390             then
7391                Append_To (L,
7392                  Build_Set_Predefined_Prim_Op_Address (Loc,
7393                    Tag_Node =>
7394                      New_Occurrence_Of (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
7395                    Position => Pos,
7396                    Address_Node =>
7397                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7398                        Make_Attribute_Reference (Loc,
7399                          Prefix          => New_Occurrence_Of (Thunk_Id, Loc),
7400                          Attribute_Name  => Name_Unrestricted_Access))));
7401
7402                Next_Elmt (Iface_DT_Elmt);
7403                Next_Elmt (Iface_DT_Elmt);
7404                Iface_DT_Ptr := Node (Iface_DT_Elmt);
7405                pragma Assert (not Has_Thunks (Iface_DT_Ptr));
7406
7407                Append_To (L,
7408                  Build_Set_Predefined_Prim_Op_Address (Loc,
7409                    Tag_Node =>
7410                      New_Occurrence_Of (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
7411                    Position => Pos,
7412                    Address_Node =>
7413                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7414                        Make_Attribute_Reference (Loc,
7415                          Prefix          =>
7416                            New_Occurrence_Of (Alias (Prim), Loc),
7417                          Attribute_Name  => Name_Unrestricted_Access))));
7418
7419             else
7420                pragma Assert (Pos /= Uint_0
7421                  and then Pos <= DT_Entry_Count (Tag));
7422
7423                Append_To (L,
7424                  Build_Set_Prim_Op_Address (Loc,
7425                    Typ          => Iface_Typ,
7426                    Tag_Node     => New_Occurrence_Of (Iface_DT_Ptr, Loc),
7427                    Position     => Pos,
7428                    Address_Node =>
7429                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7430                        Make_Attribute_Reference (Loc,
7431                          Prefix => New_Occurrence_Of (Thunk_Id, Loc),
7432                          Attribute_Name => Name_Unrestricted_Access))));
7433
7434                Next_Elmt (Iface_DT_Elmt);
7435                Next_Elmt (Iface_DT_Elmt);
7436                Iface_DT_Ptr := Node (Iface_DT_Elmt);
7437                pragma Assert (not Has_Thunks (Iface_DT_Ptr));
7438
7439                Append_To (L,
7440                  Build_Set_Prim_Op_Address (Loc,
7441                    Typ          => Iface_Typ,
7442                    Tag_Node     => New_Occurrence_Of (Iface_DT_Ptr, Loc),
7443                    Position     => Pos,
7444                    Address_Node =>
7445                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7446                        Make_Attribute_Reference (Loc,
7447                          Prefix         =>
7448                            New_Occurrence_Of (Alias (Prim), Loc),
7449                          Attribute_Name => Name_Unrestricted_Access))));
7450
7451             end if;
7452          end if;
7453       end if;
7454
7455       return L;
7456    end Register_Primitive;
7457
7458    -------------------------
7459    -- Set_All_DT_Position --
7460    -------------------------
7461
7462    procedure Set_All_DT_Position (Typ : Entity_Id) is
7463
7464       function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean;
7465       --  Returns True if Prim is located in the dispatch table of
7466       --  predefined primitives
7467
7468       procedure Validate_Position (Prim : Entity_Id);
7469       --  Check that position assigned to Prim is completely safe (it has not
7470       --  been assigned to a previously defined primitive operation of Typ).
7471
7472       ------------------------
7473       -- In_Predef_Prims_DT --
7474       ------------------------
7475
7476       function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean is
7477       begin
7478          --  Predefined primitives
7479
7480          if Is_Predefined_Dispatching_Operation (Prim) then
7481             return True;
7482
7483          --  Renamings of predefined primitives
7484
7485          elsif Present (Alias (Prim))
7486            and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim))
7487          then
7488             if Chars (Ultimate_Alias (Prim)) /= Name_Op_Eq then
7489                return True;
7490
7491             --  An overriding operation that is a user-defined renaming of
7492             --  predefined equality inherits its slot from the overridden
7493             --  operation. Otherwise it is treated as a predefined op and
7494             --  occupies the same predefined slot as equality. A call to it is
7495             --  transformed into a call to its alias, which is the predefined
7496             --  equality op. A dispatching call thus uses the proper slot if
7497             --  operation is further inherited and called with class-wide
7498             --  arguments.
7499
7500             else
7501                return
7502                  not Comes_From_Source (Prim)
7503                    or else No (Overridden_Operation (Prim));
7504             end if;
7505
7506          --  User-defined primitives
7507
7508          else
7509             return False;
7510          end if;
7511       end In_Predef_Prims_DT;
7512
7513       -----------------------
7514       -- Validate_Position --
7515       -----------------------
7516
7517       procedure Validate_Position (Prim : Entity_Id) is
7518          Op_Elmt : Elmt_Id;
7519          Op      : Entity_Id;
7520
7521       begin
7522          --  Aliased primitives are safe
7523
7524          if Present (Alias (Prim)) then
7525             return;
7526          end if;
7527
7528          Op_Elmt := First_Elmt (Primitive_Operations (Typ));
7529          while Present (Op_Elmt) loop
7530             Op := Node (Op_Elmt);
7531
7532             --  No need to check against itself
7533
7534             if Op = Prim then
7535                null;
7536
7537             --  Primitive operations covering abstract interfaces are
7538             --  allocated later
7539
7540             elsif Present (Interface_Alias (Op)) then
7541                null;
7542
7543             --  Predefined dispatching operations are completely safe. They
7544             --  are allocated at fixed positions in a separate table.
7545
7546             elsif Is_Predefined_Dispatching_Operation (Op)
7547                or else Is_Predefined_Dispatching_Alias (Op)
7548             then
7549                null;
7550
7551             --  Aliased subprograms are safe
7552
7553             elsif Present (Alias (Op)) then
7554                null;
7555
7556             elsif DT_Position (Op) = DT_Position (Prim)
7557                and then not Is_Predefined_Dispatching_Operation (Op)
7558                and then not Is_Predefined_Dispatching_Operation (Prim)
7559                and then not Is_Predefined_Dispatching_Alias (Op)
7560                and then not Is_Predefined_Dispatching_Alias (Prim)
7561             then
7562                --  Handle aliased subprograms
7563
7564                declare
7565                   Op_1 : Entity_Id;
7566                   Op_2 : Entity_Id;
7567
7568                begin
7569                   Op_1 := Op;
7570                   loop
7571                      if Present (Overridden_Operation (Op_1)) then
7572                         Op_1 := Overridden_Operation (Op_1);
7573                      elsif Present (Alias (Op_1)) then
7574                         Op_1 := Alias (Op_1);
7575                      else
7576                         exit;
7577                      end if;
7578                   end loop;
7579
7580                   Op_2 := Prim;
7581                   loop
7582                      if Present (Overridden_Operation (Op_2)) then
7583                         Op_2 := Overridden_Operation (Op_2);
7584                      elsif Present (Alias (Op_2)) then
7585                         Op_2 := Alias (Op_2);
7586                      else
7587                         exit;
7588                      end if;
7589                   end loop;
7590
7591                   if Op_1 /= Op_2 then
7592                      raise Program_Error;
7593                   end if;
7594                end;
7595             end if;
7596
7597             Next_Elmt (Op_Elmt);
7598          end loop;
7599       end Validate_Position;
7600
7601       --  Local variables
7602
7603       Parent_Typ : constant Entity_Id := Etype (Typ);
7604       First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
7605       The_Tag    : constant Entity_Id := First_Tag_Component (Typ);
7606
7607       Adjusted  : Boolean := False;
7608       Finalized : Boolean := False;
7609
7610       Count_Prim : Nat;
7611       DT_Length  : Nat;
7612       Nb_Prim    : Nat;
7613       Prim       : Entity_Id;
7614       Prim_Elmt  : Elmt_Id;
7615
7616    --  Start of processing for Set_All_DT_Position
7617
7618    begin
7619       pragma Assert (Present (First_Tag_Component (Typ)));
7620
7621       --  Set the DT_Position for each primitive operation. Perform some sanity
7622       --  checks to avoid building inconsistent dispatch tables.
7623
7624       --  First stage: Set DTC entity of all the primitive operations. This is
7625       --  required to properly read the DT_Position attribute in latter stages.
7626
7627       Prim_Elmt  := First_Prim;
7628       Count_Prim := 0;
7629       while Present (Prim_Elmt) loop
7630          Prim := Node (Prim_Elmt);
7631
7632          --  Predefined primitives have a separate dispatch table
7633
7634          if not In_Predef_Prims_DT (Prim) then
7635             Count_Prim := Count_Prim + 1;
7636          end if;
7637
7638          Set_DTC_Entity_Value (Typ, Prim);
7639
7640          --  Clear any previous value of the DT_Position attribute. In this
7641          --  way we ensure that the final position of all the primitives is
7642          --  established by the following stages of this algorithm.
7643
7644          Set_DT_Position_Value (Prim, No_Uint);
7645
7646          Next_Elmt (Prim_Elmt);
7647       end loop;
7648
7649       declare
7650          Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean :=
7651                         (others => False);
7652
7653          E : Entity_Id;
7654
7655          procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id);
7656          --  Called if Typ is declared in a nested package or a public child
7657          --  package to handle inherited primitives that were inherited by Typ
7658          --  in the visible part, but whose declaration was deferred because
7659          --  the parent operation was private and not visible at that point.
7660
7661          procedure Set_Fixed_Prim (Pos : Nat);
7662          --  Sets to true an element of the Fixed_Prim table to indicate
7663          --  that this entry of the dispatch table of Typ is occupied.
7664
7665          ------------------------------------------
7666          -- Handle_Inherited_Private_Subprograms --
7667          ------------------------------------------
7668
7669          procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id) is
7670             Op_List     : Elist_Id;
7671             Op_Elmt     : Elmt_Id;
7672             Op_Elmt_2   : Elmt_Id;
7673             Prim_Op     : Entity_Id;
7674             Parent_Subp : Entity_Id;
7675
7676          begin
7677             Op_List := Primitive_Operations (Typ);
7678
7679             Op_Elmt := First_Elmt (Op_List);
7680             while Present (Op_Elmt) loop
7681                Prim_Op := Node (Op_Elmt);
7682
7683                --  Search primitives that are implicit operations with an
7684                --  internal name whose parent operation has a normal name.
7685
7686                if Present (Alias (Prim_Op))
7687                  and then Find_Dispatching_Type (Alias (Prim_Op)) /= Typ
7688                  and then not Comes_From_Source (Prim_Op)
7689                  and then Is_Internal_Name (Chars (Prim_Op))
7690                  and then not Is_Internal_Name (Chars (Alias (Prim_Op)))
7691                then
7692                   Parent_Subp := Alias (Prim_Op);
7693
7694                   --  Check if the type has an explicit overriding for this
7695                   --  primitive.
7696
7697                   Op_Elmt_2 := Next_Elmt (Op_Elmt);
7698                   while Present (Op_Elmt_2) loop
7699                      if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp)
7700                        and then Type_Conformant (Prim_Op, Node (Op_Elmt_2))
7701                      then
7702                         Set_DT_Position_Value (Prim_Op,
7703                           DT_Position (Parent_Subp));
7704                         Set_DT_Position_Value (Node (Op_Elmt_2),
7705                           DT_Position (Parent_Subp));
7706                         Set_Fixed_Prim (UI_To_Int (DT_Position (Prim_Op)));
7707
7708                         goto Next_Primitive;
7709                      end if;
7710
7711                      Next_Elmt (Op_Elmt_2);
7712                   end loop;
7713                end if;
7714
7715                <<Next_Primitive>>
7716                Next_Elmt (Op_Elmt);
7717             end loop;
7718          end Handle_Inherited_Private_Subprograms;
7719
7720          --------------------
7721          -- Set_Fixed_Prim --
7722          --------------------
7723
7724          procedure Set_Fixed_Prim (Pos : Nat) is
7725          begin
7726             pragma Assert (Pos <= Count_Prim);
7727             Fixed_Prim (Pos) := True;
7728          exception
7729             when Constraint_Error =>
7730                raise Program_Error;
7731          end Set_Fixed_Prim;
7732
7733       begin
7734          --  In case of nested packages and public child package it may be
7735          --  necessary a special management on inherited subprograms so that
7736          --  the dispatch table is properly filled.
7737
7738          if Ekind (Scope (Scope (Typ))) = E_Package
7739            and then Scope (Scope (Typ)) /= Standard_Standard
7740            and then ((Is_Derived_Type (Typ) and then not Is_Private_Type (Typ))
7741                        or else
7742                         (Nkind (Parent (Typ)) = N_Private_Extension_Declaration
7743                           and then Is_Generic_Type (Typ)))
7744            and then In_Open_Scopes (Scope (Etype (Typ)))
7745            and then Is_Base_Type (Typ)
7746          then
7747             Handle_Inherited_Private_Subprograms (Typ);
7748          end if;
7749
7750          --  Second stage: Register fixed entries
7751
7752          Nb_Prim   := 0;
7753          Prim_Elmt := First_Prim;
7754          while Present (Prim_Elmt) loop
7755             Prim := Node (Prim_Elmt);
7756
7757             --  Predefined primitives have a separate table and all its
7758             --  entries are at predefined fixed positions.
7759
7760             if In_Predef_Prims_DT (Prim) then
7761                if Is_Predefined_Dispatching_Operation (Prim) then
7762                   Set_DT_Position_Value (Prim,
7763                     Default_Prim_Op_Position (Prim));
7764
7765                else pragma Assert (Present (Alias (Prim)));
7766                   Set_DT_Position_Value (Prim,
7767                     Default_Prim_Op_Position (Ultimate_Alias (Prim)));
7768                end if;
7769
7770             --  Overriding primitives of ancestor abstract interfaces
7771
7772             elsif Present (Interface_Alias (Prim))
7773               and then Is_Ancestor
7774                          (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
7775                           Use_Full_View => True)
7776             then
7777                pragma Assert (DT_Position (Prim) = No_Uint
7778                  and then Present (DTC_Entity (Interface_Alias (Prim))));
7779
7780                E := Interface_Alias (Prim);
7781                Set_DT_Position_Value (Prim, DT_Position (E));
7782
7783                pragma Assert
7784                  (DT_Position (Alias (Prim)) = No_Uint
7785                     or else DT_Position (Alias (Prim)) = DT_Position (E));
7786                Set_DT_Position_Value (Alias (Prim), DT_Position (E));
7787                Set_Fixed_Prim (UI_To_Int (DT_Position (Prim)));
7788
7789             --  Overriding primitives must use the same entry as the overridden
7790             --  primitive. Note that the Alias of the operation is set when the
7791             --  operation is declared by a renaming, in which case it is not
7792             --  overriding. If it renames another primitive it will use the
7793             --  same dispatch table slot, but if it renames an operation in a
7794             --  nested package it's a new primitive and will have its own slot.
7795
7796             elsif not Present (Interface_Alias (Prim))
7797               and then Present (Alias (Prim))
7798               and then Chars (Prim) = Chars (Alias (Prim))
7799               and then Nkind (Unit_Declaration_Node (Prim)) /=
7800                          N_Subprogram_Renaming_Declaration
7801             then
7802                declare
7803                   Par_Type : constant Entity_Id :=
7804                                Find_Dispatching_Type (Alias (Prim));
7805
7806                begin
7807                   if Present (Par_Type)
7808                     and then Par_Type /= Typ
7809                     and then Is_Ancestor (Par_Type, Typ, Use_Full_View => True)
7810                     and then Present (DTC_Entity (Alias (Prim)))
7811                   then
7812                      E := Alias (Prim);
7813                      Set_DT_Position_Value (Prim, DT_Position (E));
7814
7815                      if not Is_Predefined_Dispatching_Alias (E) then
7816                         Set_Fixed_Prim (UI_To_Int (DT_Position (E)));
7817                      end if;
7818                   end if;
7819                end;
7820             end if;
7821
7822             Next_Elmt (Prim_Elmt);
7823          end loop;
7824
7825          --  Third stage: Fix the position of all the new primitives. Entries
7826          --  associated with primitives covering interfaces are handled in a
7827          --  latter round.
7828
7829          Prim_Elmt := First_Prim;
7830          while Present (Prim_Elmt) loop
7831             Prim := Node (Prim_Elmt);
7832
7833             --  Skip primitives previously set entries
7834
7835             if DT_Position (Prim) /= No_Uint then
7836                null;
7837
7838             --  Primitives covering interface primitives are handled later
7839
7840             elsif Present (Interface_Alias (Prim)) then
7841                null;
7842
7843             else
7844                --  Take the next available position in the DT
7845
7846                loop
7847                   Nb_Prim := Nb_Prim + 1;
7848                   pragma Assert (Nb_Prim <= Count_Prim);
7849                   exit when not Fixed_Prim (Nb_Prim);
7850                end loop;
7851
7852                Set_DT_Position_Value (Prim, UI_From_Int (Nb_Prim));
7853                Set_Fixed_Prim (Nb_Prim);
7854             end if;
7855
7856             Next_Elmt (Prim_Elmt);
7857          end loop;
7858       end;
7859
7860       --  Fourth stage: Complete the decoration of primitives covering
7861       --  interfaces (that is, propagate the DT_Position attribute from
7862       --  the aliased primitive)
7863
7864       Prim_Elmt := First_Prim;
7865       while Present (Prim_Elmt) loop
7866          Prim := Node (Prim_Elmt);
7867
7868          if DT_Position (Prim) = No_Uint
7869            and then Present (Interface_Alias (Prim))
7870          then
7871             pragma Assert (Present (Alias (Prim))
7872               and then Find_Dispatching_Type (Alias (Prim)) = Typ);
7873
7874             --  Check if this entry will be placed in the primary DT
7875
7876             if Is_Ancestor
7877                  (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
7878                   Use_Full_View => True)
7879             then
7880                pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
7881                Set_DT_Position_Value (Prim, DT_Position (Alias (Prim)));
7882
7883             --  Otherwise it will be placed in the secondary DT
7884
7885             else
7886                pragma Assert
7887                  (DT_Position (Interface_Alias (Prim)) /= No_Uint);
7888                Set_DT_Position_Value (Prim,
7889                  DT_Position (Interface_Alias (Prim)));
7890             end if;
7891          end if;
7892
7893          Next_Elmt (Prim_Elmt);
7894       end loop;
7895
7896       --  Generate listing showing the contents of the dispatch tables. This
7897       --  action is done before some further static checks because in case of
7898       --  critical errors caused by a wrong dispatch table we need to see the
7899       --  contents of such table.
7900
7901       if Debug_Flag_ZZ then
7902          Write_DT (Typ);
7903       end if;
7904
7905       --  Final stage: Ensure that the table is correct plus some further
7906       --  verifications concerning the primitives.
7907
7908       Prim_Elmt := First_Prim;
7909       DT_Length := 0;
7910       while Present (Prim_Elmt) loop
7911          Prim := Node (Prim_Elmt);
7912
7913          --  At this point all the primitives MUST have a position in the
7914          --  dispatch table.
7915
7916          if DT_Position (Prim) = No_Uint then
7917             raise Program_Error;
7918          end if;
7919
7920          --  Calculate real size of the dispatch table
7921
7922          if not In_Predef_Prims_DT (Prim)
7923            and then UI_To_Int (DT_Position (Prim)) > DT_Length
7924          then
7925             DT_Length := UI_To_Int (DT_Position (Prim));
7926          end if;
7927
7928          --  Ensure that the assigned position to non-predefined dispatching
7929          --  operations in the dispatch table is correct.
7930
7931          if not Is_Predefined_Dispatching_Operation (Prim)
7932            and then not Is_Predefined_Dispatching_Alias (Prim)
7933          then
7934             Validate_Position (Prim);
7935          end if;
7936
7937          if Chars (Prim) = Name_Finalize then
7938             Finalized := True;
7939          end if;
7940
7941          if Chars (Prim) = Name_Adjust then
7942             Adjusted := True;
7943          end if;
7944
7945          --  An abstract operation cannot be declared in the private part for a
7946          --  visible abstract type, because it can't be overridden outside this
7947          --  package hierarchy. For explicit declarations this is checked at
7948          --  the point of declaration, but for inherited operations it must be
7949          --  done when building the dispatch table.
7950
7951          --  Ada 2005 (AI-251): Primitives associated with interfaces are
7952          --  excluded from this check because interfaces must be visible in
7953          --  the public and private part (RM 7.3 (7.3/2))
7954
7955          --  We disable this check in Relaxed_RM_Semantics mode, to accommodate
7956          --  legacy Ada code.
7957
7958          if not Relaxed_RM_Semantics
7959            and then Is_Abstract_Type (Typ)
7960            and then Is_Abstract_Subprogram (Prim)
7961            and then Present (Alias (Prim))
7962            and then not Is_Interface
7963                           (Find_Dispatching_Type (Ultimate_Alias (Prim)))
7964            and then not Present (Interface_Alias (Prim))
7965            and then Is_Derived_Type (Typ)
7966            and then In_Private_Part (Current_Scope)
7967            and then
7968              List_Containing (Parent (Prim)) =
7969                Private_Declarations (Package_Specification (Current_Scope))
7970            and then Original_View_In_Visible_Part (Typ)
7971          then
7972             --  We exclude Input and Output stream operations because
7973             --  Limited_Controlled inherits useless Input and Output stream
7974             --  operations from Root_Controlled, which can never be overridden.
7975
7976             if not Is_TSS (Prim, TSS_Stream_Input)
7977                  and then
7978                not Is_TSS (Prim, TSS_Stream_Output)
7979             then
7980                Error_Msg_NE
7981                  ("abstract inherited private operation&" &
7982                   " must be overridden (RM 3.9.3(10))",
7983                  Parent (Typ), Prim);
7984             end if;
7985          end if;
7986
7987          Next_Elmt (Prim_Elmt);
7988       end loop;
7989
7990       --  Additional check
7991
7992       if Is_Controlled (Typ) then
7993          if not Finalized then
7994             Error_Msg_N
7995               ("controlled type has no explicit Finalize method??", Typ);
7996
7997          elsif not Adjusted then
7998             Error_Msg_N
7999               ("controlled type has no explicit Adjust method??", Typ);
8000          end if;
8001       end if;
8002
8003       --  Set the final size of the Dispatch Table
8004
8005       Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
8006
8007       --  The derived type must have at least as many components as its parent
8008       --  (for root types Etype points to itself and the test cannot fail).
8009
8010       if DT_Entry_Count (The_Tag) <
8011            DT_Entry_Count (First_Tag_Component (Parent_Typ))
8012       then
8013          raise Program_Error;
8014       end if;
8015    end Set_All_DT_Position;
8016
8017    --------------------------
8018    -- Set_CPP_Constructors --
8019    --------------------------
8020
8021    procedure Set_CPP_Constructors (Typ : Entity_Id) is
8022
8023       function Gen_Parameters_Profile (E : Entity_Id) return List_Id;
8024       --  Duplicate the parameters profile of the imported C++ constructor
8025       --  adding an access to the object as an additional parameter.
8026
8027       ----------------------------
8028       -- Gen_Parameters_Profile --
8029       ----------------------------
8030
8031       function Gen_Parameters_Profile (E : Entity_Id) return List_Id is
8032          Loc   : constant Source_Ptr := Sloc (E);
8033          Parms : List_Id;
8034          P     : Node_Id;
8035
8036       begin
8037          Parms :=
8038            New_List (
8039              Make_Parameter_Specification (Loc,
8040                Defining_Identifier =>
8041                  Make_Defining_Identifier (Loc, Name_uInit),
8042                Parameter_Type      => New_Occurrence_Of (Typ, Loc)));
8043
8044          if Present (Parameter_Specifications (Parent (E))) then
8045             P := First (Parameter_Specifications (Parent (E)));
8046             while Present (P) loop
8047                Append_To (Parms,
8048                  Make_Parameter_Specification (Loc,
8049                    Defining_Identifier =>
8050                      Make_Defining_Identifier (Loc,
8051                        Chars => Chars (Defining_Identifier (P))),
8052                    Parameter_Type      => New_Copy_Tree (Parameter_Type (P)),
8053                    Expression          => New_Copy_Tree (Expression (P))));
8054                Next (P);
8055             end loop;
8056          end if;
8057
8058          return Parms;
8059       end Gen_Parameters_Profile;
8060
8061       --  Local variables
8062
8063       Loc     : Source_Ptr;
8064       E       : Entity_Id;
8065       Found   : Boolean := False;
8066       IP      : Entity_Id;
8067       IP_Body : Node_Id;
8068       P       : Node_Id;
8069       Parms   : List_Id;
8070
8071       Covers_Default_Constructor : Entity_Id := Empty;
8072
8073    --  Start of processing for Set_CPP_Constructor
8074
8075    begin
8076       pragma Assert (Is_CPP_Class (Typ));
8077
8078       --  Look for the constructor entities
8079
8080       E := Next_Entity (Typ);
8081       while Present (E) loop
8082          if Ekind (E) = E_Function
8083            and then Is_Constructor (E)
8084          then
8085             Found := True;
8086             Loc   := Sloc (E);
8087             Parms := Gen_Parameters_Profile (E);
8088             IP    :=
8089               Make_Defining_Identifier (Loc,
8090                 Chars => Make_Init_Proc_Name (Typ));
8091
8092             --  Case 1: Constructor of untagged type
8093
8094             --  If the C++ class has no virtual methods then the matching Ada
8095             --  type is an untagged record type. In such case there is no need
8096             --  to generate a wrapper of the C++ constructor because the _tag
8097             --  component is not available.
8098
8099             if not Is_Tagged_Type (Typ) then
8100                Discard_Node
8101                  (Make_Subprogram_Declaration (Loc,
8102                     Specification =>
8103                       Make_Procedure_Specification (Loc,
8104                         Defining_Unit_Name       => IP,
8105                         Parameter_Specifications => Parms)));
8106
8107                Set_Init_Proc (Typ, IP);
8108                Set_Is_Imported    (IP);
8109                Set_Is_Constructor (IP);
8110                Set_Interface_Name (IP, Interface_Name (E));
8111                Set_Convention     (IP, Convention_CPP);
8112                Set_Is_Public      (IP);
8113                Set_Has_Completion (IP);
8114
8115             --  Case 2: Constructor of a tagged type
8116
8117             --  In this case we generate the IP as a wrapper of the the
8118             --  C++ constructor because IP must also save copy of the _tag
8119             --  generated in the C++ side. The copy of the _tag is used by
8120             --  Build_CPP_Init_Procedure to elaborate derivations of C++ types.
8121
8122             --  Generate:
8123             --     procedure IP (_init : Typ; ...) is
8124             --        procedure ConstructorP (_init : Typ; ...);
8125             --        pragma Import (ConstructorP);
8126             --     begin
8127             --        ConstructorP (_init, ...);
8128             --        if Typ._tag = null then
8129             --           Typ._tag := _init._tag;
8130             --        end if;
8131             --     end IP;
8132
8133             else
8134                declare
8135                   Body_Stmts            : constant List_Id := New_List;
8136                   Constructor_Id        : Entity_Id;
8137                   Constructor_Decl_Node : Node_Id;
8138                   Init_Tags_List        : List_Id;
8139
8140                begin
8141                   Constructor_Id := Make_Temporary (Loc, 'P');
8142
8143                   Constructor_Decl_Node :=
8144                     Make_Subprogram_Declaration (Loc,
8145                       Make_Procedure_Specification (Loc,
8146                         Defining_Unit_Name => Constructor_Id,
8147                         Parameter_Specifications => Parms));
8148
8149                   Set_Is_Imported    (Constructor_Id);
8150                   Set_Is_Constructor (Constructor_Id);
8151                   Set_Interface_Name (Constructor_Id, Interface_Name (E));
8152                   Set_Convention     (Constructor_Id, Convention_CPP);
8153                   Set_Is_Public      (Constructor_Id);
8154                   Set_Has_Completion (Constructor_Id);
8155
8156                   --  Build the init procedure as a wrapper of this constructor
8157
8158                   Parms := Gen_Parameters_Profile (E);
8159
8160                   --  Invoke the C++ constructor
8161
8162                   declare
8163                      Actuals : constant List_Id := New_List;
8164
8165                   begin
8166                      P := First (Parms);
8167                      while Present (P) loop
8168                         Append_To (Actuals,
8169                           New_Occurrence_Of (Defining_Identifier (P), Loc));
8170                         Next (P);
8171                      end loop;
8172
8173                      Append_To (Body_Stmts,
8174                        Make_Procedure_Call_Statement (Loc,
8175                          Name => New_Occurrence_Of (Constructor_Id, Loc),
8176                          Parameter_Associations => Actuals));
8177                   end;
8178
8179                   --  Initialize copies of C++ primary and secondary tags
8180
8181                   Init_Tags_List := New_List;
8182
8183                   declare
8184                      Tag_Elmt : Elmt_Id;
8185                      Tag_Comp : Node_Id;
8186
8187                   begin
8188                      Tag_Elmt := First_Elmt (Access_Disp_Table (Typ));
8189                      Tag_Comp := First_Tag_Component (Typ);
8190
8191                      while Present (Tag_Elmt)
8192                        and then Is_Tag (Node (Tag_Elmt))
8193                      loop
8194                         --  Skip the following assertion with primary tags
8195                         --  because Related_Type is not set on primary tag
8196                         --  components
8197
8198                         pragma Assert
8199                           (Tag_Comp = First_Tag_Component (Typ)
8200                              or else Related_Type (Node (Tag_Elmt))
8201                                        = Related_Type (Tag_Comp));
8202
8203                         Append_To (Init_Tags_List,
8204                           Make_Assignment_Statement (Loc,
8205                             Name =>
8206                               New_Occurrence_Of (Node (Tag_Elmt), Loc),
8207                             Expression =>
8208                               Make_Selected_Component (Loc,
8209                                 Prefix        =>
8210                                   Make_Identifier (Loc, Name_uInit),
8211                                 Selector_Name =>
8212                                   New_Occurrence_Of (Tag_Comp, Loc))));
8213
8214                         Tag_Comp := Next_Tag_Component (Tag_Comp);
8215                         Next_Elmt (Tag_Elmt);
8216                      end loop;
8217                   end;
8218
8219                   Append_To (Body_Stmts,
8220                     Make_If_Statement (Loc,
8221                       Condition =>
8222                         Make_Op_Eq (Loc,
8223                           Left_Opnd =>
8224                             New_Occurrence_Of
8225                               (Node (First_Elmt (Access_Disp_Table (Typ))),
8226                                Loc),
8227                           Right_Opnd =>
8228                             Unchecked_Convert_To (RTE (RE_Tag),
8229                               New_Occurrence_Of (RTE (RE_Null_Address), Loc))),
8230                       Then_Statements => Init_Tags_List));
8231
8232                   IP_Body :=
8233                     Make_Subprogram_Body (Loc,
8234                       Specification =>
8235                         Make_Procedure_Specification (Loc,
8236                           Defining_Unit_Name => IP,
8237                           Parameter_Specifications => Parms),
8238                       Declarations => New_List (Constructor_Decl_Node),
8239                       Handled_Statement_Sequence =>
8240                         Make_Handled_Sequence_Of_Statements (Loc,
8241                           Statements => Body_Stmts,
8242                           Exception_Handlers => No_List));
8243
8244                   Discard_Node (IP_Body);
8245                   Set_Init_Proc (Typ, IP);
8246                end;
8247             end if;
8248
8249             --  If this constructor has parameters and all its parameters have
8250             --  defaults then it covers the default constructor. The semantic
8251             --  analyzer ensures that only one constructor with defaults covers
8252             --  the default constructor.
8253
8254             if Present (Parameter_Specifications (Parent (E)))
8255               and then Needs_No_Actuals (E)
8256             then
8257                Covers_Default_Constructor := IP;
8258             end if;
8259          end if;
8260
8261          Next_Entity (E);
8262       end loop;
8263
8264       --  If there are no constructors, mark the type as abstract since we
8265       --  won't be able to declare objects of that type.
8266
8267       if not Found then
8268          Set_Is_Abstract_Type (Typ);
8269       end if;
8270
8271       --  Handle constructor that has all its parameters with defaults and
8272       --  hence it covers the default constructor. We generate a wrapper IP
8273       --  which calls the covering constructor.
8274
8275       if Present (Covers_Default_Constructor) then
8276          declare
8277             Body_Stmts : List_Id;
8278
8279          begin
8280             Loc := Sloc (Covers_Default_Constructor);
8281
8282             Body_Stmts := New_List (
8283               Make_Procedure_Call_Statement (Loc,
8284                 Name                   =>
8285                   New_Occurrence_Of (Covers_Default_Constructor, Loc),
8286                 Parameter_Associations => New_List (
8287                   Make_Identifier (Loc, Name_uInit))));
8288
8289             IP := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
8290
8291             IP_Body :=
8292               Make_Subprogram_Body (Loc,
8293                 Specification              =>
8294                   Make_Procedure_Specification (Loc,
8295                     Defining_Unit_Name       => IP,
8296                     Parameter_Specifications => New_List (
8297                       Make_Parameter_Specification (Loc,
8298                         Defining_Identifier =>
8299                           Make_Defining_Identifier (Loc, Name_uInit),
8300                         Parameter_Type      => New_Occurrence_Of (Typ, Loc)))),
8301
8302                 Declarations               => No_List,
8303
8304                 Handled_Statement_Sequence =>
8305                   Make_Handled_Sequence_Of_Statements (Loc,
8306                     Statements         => Body_Stmts,
8307                     Exception_Handlers => No_List));
8308
8309             Discard_Node (IP_Body);
8310             Set_Init_Proc (Typ, IP);
8311          end;
8312       end if;
8313
8314       --  If the CPP type has constructors then it must import also the default
8315       --  C++ constructor. It is required for default initialization of objects
8316       --  of the type. It is also required to elaborate objects of Ada types
8317       --  that are defined as derivations of this CPP type.
8318
8319       if Has_CPP_Constructors (Typ)
8320         and then No (Init_Proc (Typ))
8321       then
8322          Error_Msg_N ("??default constructor must be imported from C++", Typ);
8323       end if;
8324    end Set_CPP_Constructors;
8325
8326    ---------------------------
8327    -- Set_DT_Position_Value --
8328    ---------------------------
8329
8330    procedure Set_DT_Position_Value (Prim : Entity_Id; Value : Uint) is
8331    begin
8332       Set_DT_Position (Prim, Value);
8333
8334       --  Propagate the value to the wrapped subprogram (if one is present)
8335
8336       if Ekind_In (Prim, E_Function, E_Procedure)
8337         and then Is_Primitive_Wrapper (Prim)
8338         and then Present (Wrapped_Entity (Prim))
8339         and then Is_Dispatching_Operation (Wrapped_Entity (Prim))
8340       then
8341          Set_DT_Position (Wrapped_Entity (Prim), Value);
8342       end if;
8343    end Set_DT_Position_Value;
8344
8345    --------------------------
8346    -- Set_DTC_Entity_Value --
8347    --------------------------
8348
8349    procedure Set_DTC_Entity_Value
8350      (Tagged_Type : Entity_Id;
8351       Prim        : Entity_Id)
8352    is
8353    begin
8354       if Present (Interface_Alias (Prim))
8355         and then Is_Interface
8356                    (Find_Dispatching_Type (Interface_Alias (Prim)))
8357       then
8358          Set_DTC_Entity (Prim,
8359            Find_Interface_Tag
8360              (T     => Tagged_Type,
8361               Iface => Find_Dispatching_Type (Interface_Alias (Prim))));
8362       else
8363          Set_DTC_Entity (Prim,
8364            First_Tag_Component (Tagged_Type));
8365       end if;
8366
8367       --  Propagate the value to the wrapped subprogram (if one is present)
8368
8369       if Ekind_In (Prim, E_Function, E_Procedure)
8370         and then Is_Primitive_Wrapper (Prim)
8371         and then Present (Wrapped_Entity (Prim))
8372         and then Is_Dispatching_Operation (Wrapped_Entity (Prim))
8373       then
8374          Set_DTC_Entity (Wrapped_Entity (Prim), DTC_Entity (Prim));
8375       end if;
8376    end Set_DTC_Entity_Value;
8377
8378    -----------------
8379    -- Tagged_Kind --
8380    -----------------
8381
8382    function Tagged_Kind (T : Entity_Id) return Node_Id is
8383       Conc_Typ : Entity_Id;
8384       Loc      : constant Source_Ptr := Sloc (T);
8385
8386    begin
8387       pragma Assert
8388         (Is_Tagged_Type (T) and then RTE_Available (RE_Tagged_Kind));
8389
8390       --  Abstract kinds
8391
8392       if Is_Abstract_Type (T) then
8393          if Is_Limited_Record (T) then
8394             return New_Occurrence_Of
8395               (RTE (RE_TK_Abstract_Limited_Tagged), Loc);
8396          else
8397             return New_Occurrence_Of
8398               (RTE (RE_TK_Abstract_Tagged), Loc);
8399          end if;
8400
8401       --  Concurrent kinds
8402
8403       elsif Is_Concurrent_Record_Type (T) then
8404          Conc_Typ := Corresponding_Concurrent_Type (T);
8405
8406          if Present (Full_View (Conc_Typ)) then
8407             Conc_Typ := Full_View (Conc_Typ);
8408          end if;
8409
8410          if Ekind (Conc_Typ) = E_Protected_Type then
8411             return New_Occurrence_Of (RTE (RE_TK_Protected), Loc);
8412          else
8413             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
8414             return New_Occurrence_Of (RTE (RE_TK_Task), Loc);
8415          end if;
8416
8417       --  Regular tagged kinds
8418
8419       else
8420          if Is_Limited_Record (T) then
8421             return New_Occurrence_Of (RTE (RE_TK_Limited_Tagged), Loc);
8422          else
8423             return New_Occurrence_Of (RTE (RE_TK_Tagged), Loc);
8424          end if;
8425       end if;
8426    end Tagged_Kind;
8427
8428    --------------
8429    -- Write_DT --
8430    --------------
8431
8432    procedure Write_DT (Typ : Entity_Id) is
8433       Elmt : Elmt_Id;
8434       Prim : Node_Id;
8435
8436    begin
8437       --  Protect this procedure against wrong usage. Required because it will
8438       --  be used directly from GDB
8439
8440       if not (Typ <= Last_Node_Id)
8441         or else not Is_Tagged_Type (Typ)
8442       then
8443          Write_Str ("wrong usage: Write_DT must be used with tagged types");
8444          Write_Eol;
8445          return;
8446       end if;
8447
8448       Write_Int (Int (Typ));
8449       Write_Str (": ");
8450       Write_Name (Chars (Typ));
8451
8452       if Is_Interface (Typ) then
8453          Write_Str (" is interface");
8454       end if;
8455
8456       Write_Eol;
8457
8458       Elmt := First_Elmt (Primitive_Operations (Typ));
8459       while Present (Elmt) loop
8460          Prim := Node (Elmt);
8461          Write_Str  (" - ");
8462
8463          --  Indicate if this primitive will be allocated in the primary
8464          --  dispatch table or in a secondary dispatch table associated
8465          --  with an abstract interface type
8466
8467          if Present (DTC_Entity (Prim)) then
8468             if Etype (DTC_Entity (Prim)) = RTE (RE_Tag) then
8469                Write_Str ("[P] ");
8470             else
8471                Write_Str ("[s] ");
8472             end if;
8473          end if;
8474
8475          --  Output the node of this primitive operation and its name
8476
8477          Write_Int  (Int (Prim));
8478          Write_Str  (": ");
8479
8480          if Is_Predefined_Dispatching_Operation (Prim) then
8481             Write_Str ("(predefined) ");
8482          end if;
8483
8484          --  Prefix the name of the primitive with its corresponding tagged
8485          --  type to facilitate seeing inherited primitives.
8486
8487          if Present (Alias (Prim)) then
8488             Write_Name
8489               (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim))));
8490          else
8491             Write_Name (Chars (Typ));
8492          end if;
8493
8494          Write_Str (".");
8495          Write_Name (Chars (Prim));
8496
8497          --  Indicate if this primitive has an aliased primitive
8498
8499          if Present (Alias (Prim)) then
8500             Write_Str (" (alias = ");
8501             Write_Int (Int (Alias (Prim)));
8502
8503             --  If the DTC_Entity attribute is already set we can also output
8504             --  the name of the interface covered by this primitive (if any).
8505
8506             if Ekind_In (Alias (Prim), E_Function, E_Procedure)
8507               and then Present (DTC_Entity (Alias (Prim)))
8508               and then Is_Interface (Scope (DTC_Entity (Alias (Prim))))
8509             then
8510                Write_Str  (" from interface ");
8511                Write_Name (Chars (Scope (DTC_Entity (Alias (Prim)))));
8512             end if;
8513
8514             if Present (Interface_Alias (Prim)) then
8515                Write_Str  (", AI_Alias of ");
8516
8517                if Is_Null_Interface_Primitive (Interface_Alias (Prim)) then
8518                   Write_Str ("null primitive ");
8519                end if;
8520
8521                Write_Name
8522                  (Chars (Find_Dispatching_Type (Interface_Alias (Prim))));
8523                Write_Char (':');
8524                Write_Int  (Int (Interface_Alias (Prim)));
8525             end if;
8526
8527             Write_Str (")");
8528          end if;
8529
8530          --  Display the final position of this primitive in its associated
8531          --  (primary or secondary) dispatch table.
8532
8533          if Present (DTC_Entity (Prim))
8534            and then DT_Position (Prim) /= No_Uint
8535          then
8536             Write_Str (" at #");
8537             Write_Int (UI_To_Int (DT_Position (Prim)));
8538          end if;
8539
8540          if Is_Abstract_Subprogram (Prim) then
8541             Write_Str (" is abstract;");
8542
8543          --  Check if this is a null primitive
8544
8545          elsif Comes_From_Source (Prim)
8546            and then Ekind (Prim) = E_Procedure
8547            and then Null_Present (Parent (Prim))
8548          then
8549             Write_Str (" is null;");
8550          end if;
8551
8552          if Is_Eliminated (Ultimate_Alias (Prim)) then
8553             Write_Str (" (eliminated)");
8554          end if;
8555
8556          if Is_Imported (Prim)
8557            and then Convention (Prim) = Convention_CPP
8558          then
8559             Write_Str (" (C++)");
8560          end if;
8561
8562          Write_Eol;
8563
8564          Next_Elmt (Elmt);
8565       end loop;
8566    end Write_DT;
8567
8568 end Exp_Disp;