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