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