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